cffi-clisp.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-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 <jamesjb@jamesjb.com>
6 ;;; Copyright (C) 2005-2006, Joerg Hoehle <hoehle@users.sourceforge.net>
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 0))
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)) into types
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) '#:ffi)))
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)))))