cffi-mkcl.lisp - clic - Clic is an command line interactive client for gopher written in Common LISP
(HTM) git clone git://bitreich.org/clic/ git://enlrupgkhuxnvlhsf6lc3fziv5h2hhfrinws65d7roiv6bfj7d652fid.onion/clic/
(DIR) Log
(DIR) Files
(DIR) Refs
(DIR) Tags
(DIR) README
(DIR) LICENSE
---
cffi-mkcl.lisp (12048B)
---
1 ;;;; -*- Mode: lisp; indent-tabs-mode: nil -*-
2 ;;;
3 ;;; cffi-mkcl.lisp --- MKCL backend for CFFI.
4 ;;;
5 ;;; Copyright (C) 2010-2012, Jean-Claude Beaudoin
6 ;;; Copyright (C) 2005-2006, James Bielman <jamesjb@jamesjb.com>
7 ;;;
8 ;;; Permission is hereby granted, free of charge, to any person
9 ;;; obtaining a copy of this software and associated documentation
10 ;;; files (the "Software"), to deal in the Software without
11 ;;; restriction, including without limitation the rights to use, copy,
12 ;;; modify, merge, publish, distribute, sublicense, and/or sell copies
13 ;;; of the Software, and to permit persons to whom the Software is
14 ;;; furnished to do so, subject to the following conditions:
15 ;;;
16 ;;; The above copyright notice and this permission notice shall be
17 ;;; included in all copies or substantial portions of the Software.
18 ;;;
19 ;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
20 ;;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
21 ;;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
22 ;;; NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT
23 ;;; HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY,
24 ;;; WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
25 ;;; OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER
26 ;;; DEALINGS IN THE SOFTWARE.
27 ;;;
28
29 ;;;# Administrivia
30
31 (defpackage #:cffi-sys
32 (:use #:common-lisp #:alexandria)
33 (:export
34 #:canonicalize-symbol-name-case
35 #:foreign-pointer
36 #:pointerp
37 #:pointer-eq
38 #:null-pointer
39 #:null-pointer-p
40 #:inc-pointer
41 #:make-pointer
42 #:pointer-address
43 #:%foreign-alloc
44 #:foreign-free
45 #:with-foreign-pointer
46 #:%foreign-funcall
47 #:%foreign-funcall-pointer
48 #:%foreign-type-alignment
49 #:%foreign-type-size
50 #:%load-foreign-library
51 #:%close-foreign-library
52 #:native-namestring
53 #:%mem-ref
54 #:%mem-set
55 #:make-shareable-byte-vector
56 #:with-pointer-to-vector-data
57 #:%foreign-symbol-pointer
58 #:%defcallback
59 #:%callback))
60
61 (in-package #:cffi-sys)
62
63 ;;;# Mis-features
64
65 (pushnew 'flat-namespace *features*)
66
67 ;;;# Symbol Case
68
69 (defun canonicalize-symbol-name-case (name)
70 (declare (string name))
71 (string-upcase name))
72
73 ;;;# Allocation
74
75 (defun %foreign-alloc (size)
76 "Allocate SIZE bytes of foreign-addressable memory."
77 (si:allocate-foreign-data :void size))
78
79 (defun foreign-free (ptr)
80 "Free a pointer PTR allocated by FOREIGN-ALLOC."
81 (si:free-foreign-data ptr)
82 nil)
83
84 (defmacro with-foreign-pointer ((var size &optional size-var) &body body)
85 "Bind VAR to SIZE bytes of foreign memory during BODY. The
86 pointer in VAR is invalid beyond the dynamic extent of BODY, and
87 may be stack-allocated if supported by the implementation. If
88 SIZE-VAR is supplied, it will be bound to SIZE during BODY."
89 (unless size-var
90 (setf size-var (gensym "SIZE")))
91 `(let* ((,size-var ,size)
92 (,var (%foreign-alloc ,size-var)))
93 (unwind-protect
94 (progn ,@body)
95 (foreign-free ,var))))
96
97 ;;;# Misc. Pointer Operations
98
99 (deftype foreign-pointer ()
100 'si:foreign)
101
102 (defun null-pointer ()
103 "Construct and return a null pointer."
104 (si:make-foreign-null-pointer))
105
106 (defun null-pointer-p (ptr)
107 "Return true if PTR is a null pointer."
108 (si:null-pointer-p ptr))
109
110 (defun inc-pointer (ptr offset)
111 "Return a pointer OFFSET bytes past PTR."
112 (ffi:make-pointer (+ (ffi:pointer-address ptr) offset) :void))
113
114 (defun pointerp (ptr)
115 "Return true if PTR is a foreign pointer."
116 ;;(typep ptr 'si:foreign)
117 (si:foreignp ptr))
118
119 (defun pointer-eq (ptr1 ptr2)
120 "Return true if PTR1 and PTR2 point to the same address."
121 (= (ffi:pointer-address ptr1) (ffi:pointer-address ptr2)))
122
123 (defun make-pointer (address)
124 "Return a pointer pointing to ADDRESS."
125 (ffi:make-pointer address :void))
126
127 (defun pointer-address (ptr)
128 "Return the address pointed to by PTR."
129 (ffi:pointer-address ptr))
130
131 ;;;# Shareable Vectors
132 ;;;
133 ;;; This interface is very experimental. WITH-POINTER-TO-VECTOR-DATA
134 ;;; should be defined to perform a copy-in/copy-out if the Lisp
135 ;;; implementation can't do this.
136
137 (defun make-shareable-byte-vector (size)
138 "Create a Lisp vector of SIZE bytes that can passed to
139 WITH-POINTER-TO-VECTOR-DATA."
140 (make-array size :element-type '(unsigned-byte 8)))
141
142 ;;; MKCL, built with the Boehm GC never moves allocated data, so this
143 ;;; isn't nearly as hard to do.
144 (defun %vector-address (vector)
145 "Return the address of VECTOR's data."
146 (check-type vector (vector (unsigned-byte 8)))
147 #-mingw64
148 (ffi:c-inline (vector) (object)
149 :unsigned-long
150 "(uintptr_t) #0->vector.self.b8"
151 :side-effects nil
152 :one-liner t)
153 #+mingw64
154 (ffi:c-inline (vector) (object)
155 :unsigned-long-long
156 "(uintptr_t) #0->vector.self.b8"
157 :side-effects nil
158 :one-liner t))
159
160 (defmacro with-pointer-to-vector-data ((ptr-var vector) &body body)
161 "Bind PTR-VAR to a foreign pointer to the data in VECTOR."
162 `(let ((,ptr-var (make-pointer (%vector-address ,vector))))
163 ,@body))
164
165 ;;;# Dereferencing
166
167 (defun %mem-ref (ptr type &optional (offset 0))
168 "Dereference an object of TYPE at OFFSET bytes from PTR."
169 (let* ((type (cffi-type->mkcl-type type))
170 (type-size (ffi:size-of-foreign-type type)))
171 (si:foreign-ref-elt
172 (si:foreign-recast ptr (+ offset type-size) :void) offset type)))
173
174 (defun %mem-set (value ptr type &optional (offset 0))
175 "Set an object of TYPE at OFFSET bytes from PTR."
176 (let* ((type (cffi-type->mkcl-type type))
177 (type-size (ffi:size-of-foreign-type type)))
178 (si:foreign-set-elt
179 (si:foreign-recast ptr (+ offset type-size) :void)
180 offset type value)))
181
182 ;;;# Type Operations
183
184 (defconstant +translation-table+
185 '((:char :byte "char")
186 (:unsigned-char :unsigned-byte "unsigned char")
187 (:short :short "short")
188 (:unsigned-short :unsigned-short "unsigned short")
189 (:int :int "int")
190 (:unsigned-int :unsigned-int "unsigned int")
191 (:long :long "long")
192 (:unsigned-long :unsigned-long "unsigned long")
193 (:long-long :long-long "long long")
194 (:unsigned-long-long :unsigned-long-long "unsigned long long")
195 (:float :float "float")
196 (:double :double "double")
197 (:pointer :pointer-void "void*")
198 (:void :void "void")))
199
200 (defun cffi-type->mkcl-type (type-keyword)
201 "Convert a CFFI type keyword to an MKCL type keyword."
202 (or (second (find type-keyword +translation-table+ :key #'first))
203 (error "~S is not a valid CFFI type" type-keyword)))
204
205 (defun mkcl-type->c-type (type-keyword)
206 "Convert a CFFI type keyword to an valid C type keyword."
207 (or (third (find type-keyword +translation-table+ :key #'second))
208 (error "~S is not a valid CFFI type" type-keyword)))
209
210 (defun %foreign-type-size (type-keyword)
211 "Return the size in bytes of a foreign type."
212 (nth-value 0 (ffi:size-of-foreign-type
213 (cffi-type->mkcl-type type-keyword))))
214
215 (defun %foreign-type-alignment (type-keyword)
216 "Return the alignment in bytes of a foreign type."
217 (nth-value 1 (ffi:size-of-foreign-type
218 (cffi-type->mkcl-type type-keyword))))
219
220 ;;;# Calling Foreign Functions
221
222 #|
223 (defconstant +mkcl-inline-codes+ "#0,#1,#2,#3,#4,#5,#6,#7,#8,#9,#a,#b,#c,#d,#e,#f,#g,#h,#i,#j,#k,#l,#m,#n,#o,#p,#q,#r,#s,#t,#u,#v,#w,#x,#y,#z")
224 |#
225
226 (defun produce-function-pointer-call (pointer types values return-type)
227 #|
228 (if (stringp pointer)
229 (produce-function-pointer-call
230 `(%foreign-symbol-pointer ,pointer nil) types values return-type)
231 `(ffi:c-inline
232 ,(list* pointer values)
233 ,(list* :pointer-void types) ,return-type
234 ,(with-output-to-string (s)
235 (let ((types (mapcar #'mkcl-type->c-type types)))
236 ;; On AMD64, the following code only works with the extra
237 ;; argument ",...". If this is not present, functions
238 ;; like sprintf do not work
239 (format s "((~A (*)(~@[~{~A,~}...~]))(#0))(~A)"
240 (mkcl-type->c-type return-type) types
241 (subseq +mkcl-inline-codes+ 3
242 (max 3 (+ 2 (* (length values) 3)))))))
243 :one-liner t :side-effects t))
244 |#
245 ;; The version here below is definitely not as efficient as the one above
246 ;; but it has the great vertue of working in all cases, (contrary to the
247 ;; silent and unsafe limitations of the one above). JCB
248 ;; I should re-optimize this one day, when I get time... JCB
249 (progn
250 (when (stringp pointer)
251 (setf pointer `(%foreign-symbol-pointer ,pointer nil)))
252 `(si:call-cfun ,pointer ,return-type (list ,@types) (list ,@values))))
253
254
255 (defun foreign-funcall-parse-args (args)
256 "Return three values, lists of arg types, values, and result type."
257 (let ((return-type :void))
258 (loop for (type arg) on args by #'cddr
259 if arg collect (cffi-type->mkcl-type type) into types
260 and collect arg into values
261 else do (setf return-type (cffi-type->mkcl-type type))
262 finally (return (values types values return-type)))))
263
264 (defmacro %foreign-funcall (name args &key library convention)
265 "Call a foreign function."
266 (declare (ignore library convention))
267 (multiple-value-bind (types values return-type)
268 (foreign-funcall-parse-args args)
269 (produce-function-pointer-call name types values return-type)))
270
271 (defmacro %foreign-funcall-pointer (ptr args &key convention)
272 "Funcall a pointer to a foreign function."
273 (declare (ignore convention))
274 (multiple-value-bind (types values return-type)
275 (foreign-funcall-parse-args args)
276 (produce-function-pointer-call ptr types values return-type)))
277
278 ;;;# Foreign Libraries
279
280 (defun %load-foreign-library (name path)
281 "Load a foreign library."
282 (declare (ignore name))
283 (handler-case (si:load-foreign-module path)
284 (file-error ()
285 (error "file error while trying to load `~A'" path))))
286
287 (defun %close-foreign-library (handle)
288 ;;(declare (ignore handle))
289 ;;(error "%CLOSE-FOREIGN-LIBRARY unimplemented.")
290 (si:unload-foreign-module handle))
291
292 (defun native-namestring (pathname)
293 (namestring pathname))
294
295 ;;;# Callbacks
296
297 ;;; Create a package to contain the symbols for callback functions.
298 ;;; We want to redefine callbacks with the same symbol so the internal
299 ;;; data structures are reused.
300 (defpackage #:cffi-callbacks
301 (:use))
302
303 (defvar *callbacks* (make-hash-table))
304
305 ;;; Intern a symbol in the CFFI-CALLBACKS package used to name the
306 ;;; internal callback for NAME.
307 (eval-when (:compile-toplevel :load-toplevel :execute)
308 (defun intern-callback (name)
309 (intern (format nil "~A::~A"
310 (if-let (package (symbol-package name))
311 (package-name package)
312 "#")
313 (symbol-name name))
314 '#:cffi-callbacks)))
315
316 (defmacro %defcallback (name rettype arg-names arg-types body
317 &key convention)
318 (declare (ignore convention))
319 (let ((cb-name (intern-callback name)))
320 `(progn
321 (ffi:defcallback (,cb-name :cdecl)
322 ,(cffi-type->mkcl-type rettype)
323 ,(mapcar #'list arg-names
324 (mapcar #'cffi-type->mkcl-type arg-types))
325 ;;(block ,cb-name ,@body)
326 (block ,cb-name ,body))
327 (setf (gethash ',name *callbacks*) ',cb-name))))
328
329 (defun %callback (name)
330 (multiple-value-bind (symbol winp)
331 (gethash name *callbacks*)
332 (unless winp
333 (error "Undefined callback: ~S" name))
334 (ffi:callback symbol)))
335
336 ;;;# Foreign Globals
337
338 (defun %foreign-symbol-pointer (name library)
339 "Returns a pointer to a foreign symbol NAME."
340 (declare (ignore library))
341 (values (ignore-errors (si:find-foreign-symbol name :default :pointer-void 0))))
342