cffi-clisp.lisp - clic - Clic is an command line interactive client for gopher … | |
git clone git://bitreich.org/clic/ git://enlrupgkhuxnvlhsf6lc3fziv5h2hhfrinws65… | |
Log | |
Files | |
Refs | |
Tags | |
README | |
LICENSE | |
--- | |
cffi-clisp.lisp (15949B) | |
--- | |
1 ;;;; -*- Mode: lisp; indent-tabs-mode: nil -*- | |
2 ;;; | |
3 ;;; cffi-clisp.lisp --- CFFI-SYS implementation for CLISP. | |
4 ;;; | |
5 ;;; Copyright (C) 2005-2006, James Bielman <[email protected]> | |
6 ;;; Copyright (C) 2005-2006, Joerg Hoehle <[email protected]> | |
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 (eval-when (:compile-toplevel :load-toplevel :execute) | |
64 (unless (find-package :ffi) | |
65 (error "CFFI requires CLISP compiled with dynamic FFI support."))) | |
66 | |
67 ;;;# Symbol Case | |
68 | |
69 (defun canonicalize-symbol-name-case (name) | |
70 (declare (string name)) | |
71 (string-upcase name)) | |
72 | |
73 ;;;# Built-In Foreign Types | |
74 | |
75 (defun convert-foreign-type (type) | |
76 "Convert a CFFI built-in type keyword to a CLisp FFI type." | |
77 (ecase type | |
78 (:char 'ffi:char) | |
79 (:unsigned-char 'ffi:uchar) | |
80 (:short 'ffi:short) | |
81 (:unsigned-short 'ffi:ushort) | |
82 (:int 'ffi:int) | |
83 (:unsigned-int 'ffi:uint) | |
84 (:long 'ffi:long) | |
85 (:unsigned-long 'ffi:ulong) | |
86 (:long-long 'ffi:sint64) | |
87 (:unsigned-long-long 'ffi:uint64) | |
88 (:float 'ffi:single-float) | |
89 (:double 'ffi:double-float) | |
90 ;; Clisp's FFI:C-POINTER converts NULL to NIL. For now | |
91 ;; we have a workaround in the pointer operations... | |
92 (:pointer 'ffi:c-pointer) | |
93 (:void nil))) | |
94 | |
95 (defun %foreign-type-size (type) | |
96 "Return the size in bytes of objects having foreign type TYPE." | |
97 (nth-value 0 (ffi:sizeof (convert-foreign-type type)))) | |
98 | |
99 ;; Remind me to buy a beer for whoever made getting the alignment | |
100 ;; of foreign types part of the public interface in CLisp. :-) | |
101 (defun %foreign-type-alignment (type) | |
102 "Return the structure alignment in bytes of foreign TYPE." | |
103 #+(and darwin ppc) | |
104 (case type | |
105 ((:double :long-long :unsigned-long-long) | |
106 (return-from %foreign-type-alignment 8))) | |
107 ;; Override not necessary for the remaining types... | |
108 (nth-value 1 (ffi:sizeof (convert-foreign-type type)))) | |
109 | |
110 ;;;# Basic Pointer Operations | |
111 | |
112 (deftype foreign-pointer () | |
113 'ffi:foreign-address) | |
114 | |
115 (defun pointerp (ptr) | |
116 "Return true if PTR is a foreign pointer." | |
117 (typep ptr 'ffi:foreign-address)) | |
118 | |
119 (defun pointer-eq (ptr1 ptr2) | |
120 "Return true if PTR1 and PTR2 point to the same address." | |
121 (eql (ffi:foreign-address-unsigned ptr1) | |
122 (ffi:foreign-address-unsigned ptr2))) | |
123 | |
124 (defun null-pointer () | |
125 "Return a null foreign pointer." | |
126 (ffi:unsigned-foreign-address 0)) | |
127 | |
128 (defun null-pointer-p (ptr) | |
129 "Return true if PTR is a null foreign pointer." | |
130 (zerop (ffi:foreign-address-unsigned ptr))) | |
131 | |
132 (defun inc-pointer (ptr offset) | |
133 "Return a pointer pointing OFFSET bytes past PTR." | |
134 (ffi:unsigned-foreign-address | |
135 (+ offset (ffi:foreign-address-unsigned ptr)))) | |
136 | |
137 (defun make-pointer (address) | |
138 "Return a pointer pointing to ADDRESS." | |
139 (ffi:unsigned-foreign-address address)) | |
140 | |
141 (defun pointer-address (ptr) | |
142 "Return the address pointed to by PTR." | |
143 (ffi:foreign-address-unsigned ptr)) | |
144 | |
145 ;;;# Foreign Memory Allocation | |
146 | |
147 (defun %foreign-alloc (size) | |
148 "Allocate SIZE bytes of foreign-addressable memory and return a | |
149 pointer to the allocated block. An implementation-specific error | |
150 is signalled if the memory cannot be allocated." | |
151 (ffi:foreign-address | |
152 (ffi:allocate-shallow 'ffi:uint8 :count (if (zerop size) 1 size)))) | |
153 | |
154 (defun foreign-free (ptr) | |
155 "Free a pointer PTR allocated by FOREIGN-ALLOC. The results | |
156 are undefined if PTR is used after being freed." | |
157 (ffi:foreign-free ptr)) | |
158 | |
159 (defmacro with-foreign-pointer ((var size &optional size-var) &body body) | |
160 "Bind VAR to a pointer to SIZE bytes of foreign-addressable | |
161 memory during BODY. Both PTR and the memory block pointed to | |
162 have dynamic extent and may be stack allocated if supported by | |
163 the implementation. If SIZE-VAR is supplied, it will be bound to | |
164 SIZE during BODY." | |
165 (unless size-var | |
166 (setf size-var (gensym "SIZE"))) | |
167 (let ((obj-var (gensym))) | |
168 `(let ((,size-var ,size)) | |
169 (ffi:with-foreign-object | |
170 (,obj-var `(ffi:c-array ffi:uint8 ,,size-var)) | |
171 (let ((,var (ffi:foreign-address ,obj-var))) | |
172 ,@body))))) | |
173 | |
174 ;;;# Memory Access | |
175 | |
176 ;;; %MEM-REF and its compiler macro work around CLISP's FFI:C-POINTER | |
177 ;;; type and convert NILs back to null pointers. | |
178 (defun %mem-ref (ptr type &optional (offset 0)) | |
179 "Dereference a pointer OFFSET bytes from PTR to an object of | |
180 built-in foreign TYPE. Returns the object as a foreign pointer | |
181 or Lisp number." | |
182 (let ((value (ffi:memory-as ptr (convert-foreign-type type) offset))) | |
183 (if (eq type :pointer) | |
184 (or value (null-pointer)) | |
185 value))) | |
186 | |
187 (define-compiler-macro %mem-ref (&whole form ptr type &optional (offset … | |
188 "Compiler macro to open-code when TYPE is constant." | |
189 (if (constantp type) | |
190 (let* ((ftype (convert-foreign-type (eval type))) | |
191 (form `(ffi:memory-as ,ptr ',ftype ,offset))) | |
192 (if (eq type :pointer) | |
193 `(or ,form (null-pointer)) | |
194 form)) | |
195 form)) | |
196 | |
197 (defun %mem-set (value ptr type &optional (offset 0)) | |
198 "Set a pointer OFFSET bytes from PTR to an object of built-in | |
199 foreign TYPE to VALUE." | |
200 (setf (ffi:memory-as ptr (convert-foreign-type type) offset) value)) | |
201 | |
202 (define-compiler-macro %mem-set | |
203 (&whole form value ptr type &optional (offset 0)) | |
204 (if (constantp type) | |
205 ;; (setf (ffi:memory-as) value) is exported, but not so nice | |
206 ;; w.r.t. the left to right evaluation rule | |
207 `(ffi::write-memory-as | |
208 ,value ,ptr ',(convert-foreign-type (eval type)) ,offset) | |
209 form)) | |
210 | |
211 ;;;# Shareable Vectors | |
212 ;;; | |
213 ;;; This interface is very experimental. WITH-POINTER-TO-VECTOR-DATA | |
214 ;;; should be defined to perform a copy-in/copy-out if the Lisp | |
215 ;;; implementation can't do this. | |
216 | |
217 (declaim (inline make-shareable-byte-vector)) | |
218 (defun make-shareable-byte-vector (size) | |
219 "Create a Lisp vector of SIZE bytes can passed to | |
220 WITH-POINTER-TO-VECTOR-DATA." | |
221 (make-array size :element-type '(unsigned-byte 8))) | |
222 | |
223 (deftype shareable-byte-vector () | |
224 `(vector (unsigned-byte 8))) | |
225 | |
226 (defmacro with-pointer-to-vector-data ((ptr-var vector) &body body) | |
227 "Bind PTR-VAR to a foreign pointer to the data in VECTOR." | |
228 (with-unique-names (vector-var size-var) | |
229 `(let ((,vector-var ,vector)) | |
230 (check-type ,vector-var shareable-byte-vector) | |
231 (with-foreign-pointer (,ptr-var (length ,vector-var) ,size-var) | |
232 ;; copy-in | |
233 (loop for i below ,size-var do | |
234 (%mem-set (aref ,vector-var i) ,ptr-var :unsigned-char i)) | |
235 (unwind-protect (progn ,@body) | |
236 ;; copy-out | |
237 (loop for i below ,size-var do | |
238 (setf (aref ,vector-var i) | |
239 (%mem-ref ,ptr-var :unsigned-char i)))))))) | |
240 | |
241 ;;;# Foreign Function Calling | |
242 | |
243 (defun parse-foreign-funcall-args (args) | |
244 "Return three values, a list of CLISP FFI types, a list of | |
245 values to pass to the function, and the CLISP FFI return type." | |
246 (let ((return-type nil)) | |
247 (loop for (type arg) on args by #'cddr | |
248 if arg collect (list (gensym) (convert-foreign-type type)) int… | |
249 and collect arg into fargs | |
250 else do (setf return-type (convert-foreign-type type)) | |
251 finally (return (values types fargs return-type))))) | |
252 | |
253 (defun convert-calling-convention (convention) | |
254 (ecase convention | |
255 (:stdcall :stdc-stdcall) | |
256 (:cdecl :stdc))) | |
257 | |
258 (defun c-function-type (arg-types rettype convention) | |
259 "Generate the apropriate CLISP foreign type specification. Also | |
260 takes care of converting the calling convention names." | |
261 `(ffi:c-function (:arguments ,@arg-types) | |
262 (:return-type ,rettype) | |
263 (:language ,(convert-calling-convention convention)))) | |
264 | |
265 ;;; Quick hack around the fact that the CFFI package is not yet | |
266 ;;; defined when this file is loaded. I suppose we could arrange for | |
267 ;;; the CFFI package to be defined a bit earlier, though. | |
268 (defun library-handle-form (name) | |
269 (flet ((find-cffi-symbol (symbol) | |
270 (find-symbol (symbol-name symbol) '#:cffi))) | |
271 `(,(find-cffi-symbol '#:foreign-library-handle) | |
272 (,(find-cffi-symbol '#:get-foreign-library) ',name)))) | |
273 | |
274 (eval-when (:compile-toplevel :load-toplevel :execute) | |
275 ;; version 2.40 (CVS 2006-09-03, to be more precise) added a | |
276 ;; PROPERTIES argument to FFI::FOREIGN-LIBRARY-FUNCTION. | |
277 (defun post-2.40-ffi-interface-p () | |
278 (let ((f-l-f (find-symbol (string '#:foreign-library-function) '#:ff… | |
279 (if (and f-l-f (= (length (ext:arglist f-l-f)) 5)) | |
280 '(:and) | |
281 '(:or)))) | |
282 ;; FFI::FOREIGN-LIBRARY-FUNCTION and FFI::FOREIGN-LIBRARY-VARIABLE | |
283 ;; were deprecated in 2.41 and removed in 2.45. | |
284 (defun post-2.45-ffi-interface-p () | |
285 (if (find-symbol (string '#:foreign-library-function) '#:ffi) | |
286 '(:or) | |
287 '(:and)))) | |
288 | |
289 #+#.(cffi-sys::post-2.45-ffi-interface-p) | |
290 (defun %foreign-funcall-aux (name type library) | |
291 `(ffi::find-foreign-function ,name ,type nil ,library nil nil)) | |
292 | |
293 #-#.(cffi-sys::post-2.45-ffi-interface-p) | |
294 (defun %foreign-funcall-aux (name type library) | |
295 `(ffi::foreign-library-function | |
296 ,name ,library nil | |
297 #+#.(cffi-sys::post-2.40-ffi-interface-p) | |
298 nil | |
299 ,type)) | |
300 | |
301 (defmacro %foreign-funcall (name args &key library convention) | |
302 "Invoke a foreign function called NAME, taking pairs of | |
303 foreign-type/value pairs from ARGS. If a single element is left | |
304 over at the end of ARGS, it specifies the foreign return type of | |
305 the function call." | |
306 (multiple-value-bind (types fargs rettype) | |
307 (parse-foreign-funcall-args args) | |
308 (let* ((fn (%foreign-funcall-aux | |
309 name | |
310 `(ffi:parse-c-type | |
311 ',(c-function-type types rettype convention)) | |
312 (if (eq library :default) | |
313 :default | |
314 (library-handle-form library)))) | |
315 (form `(funcall | |
316 (load-time-value | |
317 (handler-case ,fn | |
318 (error (err) | |
319 (warn "~A" err)))) | |
320 ,@fargs))) | |
321 (if (eq rettype 'ffi:c-pointer) | |
322 `(or ,form (null-pointer)) | |
323 form)))) | |
324 | |
325 (defmacro %foreign-funcall-pointer (ptr args &key convention) | |
326 "Similar to %foreign-funcall but takes a pointer instead of a string." | |
327 (multiple-value-bind (types fargs rettype) | |
328 (parse-foreign-funcall-args args) | |
329 `(funcall (ffi:foreign-function | |
330 ,ptr (load-time-value | |
331 (ffi:parse-c-type ',(c-function-type | |
332 types rettype convention)))) | |
333 ,@fargs))) | |
334 | |
335 ;;;# Callbacks | |
336 | |
337 ;;; *CALLBACKS* contains the callbacks defined by the CFFI DEFCALLBACK | |
338 ;;; macro. The symbol naming the callback is the key, and the value | |
339 ;;; is a list containing a Lisp function, the parsed CLISP FFI type of | |
340 ;;; the callback, and a saved pointer that should not persist across | |
341 ;;; saved images. | |
342 (defvar *callbacks* (make-hash-table)) | |
343 | |
344 ;;; Return a CLISP FFI function type for a CFFI callback function | |
345 ;;; given a return type and list of argument names and types. | |
346 (eval-when (:compile-toplevel :load-toplevel :execute) | |
347 (defun callback-type (rettype arg-names arg-types convention) | |
348 (ffi:parse-c-type | |
349 `(ffi:c-function | |
350 (:arguments ,@(mapcar (lambda (sym type) | |
351 (list sym (convert-foreign-type type))) | |
352 arg-names arg-types)) | |
353 (:return-type ,(convert-foreign-type rettype)) | |
354 (:language ,(convert-calling-convention convention)))))) | |
355 | |
356 ;;; Register and create a callback function. | |
357 (defun register-callback (name function parsed-type) | |
358 (setf (gethash name *callbacks*) | |
359 (list function parsed-type | |
360 (ffi:with-foreign-object (ptr 'ffi:c-pointer) | |
361 ;; Create callback by converting Lisp function to foreign | |
362 (setf (ffi:memory-as ptr parsed-type) function) | |
363 (ffi:foreign-value ptr))))) | |
364 | |
365 ;;; Restore all saved callback pointers when restarting the Lisp | |
366 ;;; image. This is pushed onto CUSTOM:*INIT-HOOKS*. | |
367 ;;; Needs clisp > 2.35, bugfix 2005-09-29 | |
368 (defun restore-callback-pointers () | |
369 (maphash | |
370 (lambda (name list) | |
371 (register-callback name (first list) (second list))) | |
372 *callbacks*)) | |
373 | |
374 ;;; Add RESTORE-CALLBACK-POINTERS to the lists of functions to run | |
375 ;;; when an image is restarted. | |
376 (eval-when (:load-toplevel :execute) | |
377 (pushnew 'restore-callback-pointers custom:*init-hooks*)) | |
378 | |
379 ;;; Define a callback function NAME to run BODY with arguments | |
380 ;;; ARG-NAMES translated according to ARG-TYPES and the return type | |
381 ;;; translated according to RETTYPE. Obtain a pointer that can be | |
382 ;;; passed to C code for this callback by calling %CALLBACK. | |
383 (defmacro %defcallback (name rettype arg-names arg-types body | |
384 &key convention) | |
385 `(register-callback | |
386 ',name | |
387 (lambda ,arg-names | |
388 ;; Work around CLISP's FFI:C-POINTER type and convert NIL values | |
389 ;; back into a null pointers. | |
390 (let (,@(loop for name in arg-names | |
391 and type in arg-types | |
392 when (eq type :pointer) | |
393 collect `(,name (or ,name (null-pointer))))) | |
394 ,body)) | |
395 ,(callback-type rettype arg-names arg-types convention))) | |
396 | |
397 ;;; Look up the name of a callback and return a pointer that can be | |
398 ;;; passed to a C function. Signals an error if no callback is | |
399 ;;; defined called NAME. | |
400 (defun %callback (name) | |
401 (multiple-value-bind (list winp) (gethash name *callbacks*) | |
402 (unless winp | |
403 (error "Undefined callback: ~S" name)) | |
404 (third list))) | |
405 | |
406 ;;;# Loading and Closing Foreign Libraries | |
407 | |
408 (defun %load-foreign-library (name path) | |
409 "Load a foreign library from PATH." | |
410 (declare (ignore name)) | |
411 #+#.(cffi-sys::post-2.45-ffi-interface-p) | |
412 (ffi:open-foreign-library path) | |
413 #-#.(cffi-sys::post-2.45-ffi-interface-p) | |
414 (ffi::foreign-library path)) | |
415 | |
416 (defun %close-foreign-library (handle) | |
417 "Close a foreign library." | |
418 (ffi:close-foreign-library handle)) | |
419 | |
420 (defun native-namestring (pathname) | |
421 (namestring pathname)) | |
422 | |
423 ;;;# Foreign Globals | |
424 | |
425 (defun %foreign-symbol-pointer (name library) | |
426 "Returns a pointer to a foreign symbol NAME." | |
427 (prog1 (ignore-errors | |
428 (ffi:foreign-address | |
429 #+#.(cffi-sys::post-2.45-ffi-interface-p) | |
430 (ffi::find-foreign-variable name nil library nil nil) | |
431 #-#.(cffi-sys::post-2.45-ffi-interface-p) | |
432 (ffi::foreign-library-variable name library nil nil))))) |