1 ;;;; -*- Mode: lisp; indent-tabs-mode: nil -*-
3 ;;; cffi-clisp.lisp --- CFFI-SYS implementation for CLISP.
5 ;;; Copyright (C) 2005-2006, James Bielman <jamesjb@jamesjb.com>
6 ;;; Copyright (C) 2005-2006, Joerg Hoehle <hoehle@users.sourceforge.net>
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:
16 ;;; The above copyright notice and this permission notice shall be
17 ;;; included in all copies or substantial portions of the Software.
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.
31 (defpackage #:cffi-sys
32 (:use
#:common-lisp
#:cffi-utils
#:alexandria
)
34 #:canonicalize-symbol-name-case
45 #:with-foreign-pointer
47 #:%foreign-funcall-pointer
48 #:%foreign-type-alignment
50 #:%load-foreign-library
51 #:%close-foreign-library
55 #:make-shareable-byte-vector
56 #:with-pointer-to-vector-data
57 #:%foreign-symbol-pointer
61 (in-package #:cffi-sys
)
65 (defun canonicalize-symbol-name-case (name)
66 (declare (string name
))
69 ;;;# Built-In Foreign Types
71 (defun convert-foreign-type (type)
72 "Convert a CFFI built-in type keyword to a CLisp FFI type."
75 (:unsigned-char
'ffi
:uchar
)
77 (:unsigned-short
'ffi
:ushort
)
79 (:unsigned-int
'ffi
:uint
)
81 (:unsigned-long
'ffi
:ulong
)
82 (:long-long
'ffi
:sint64
)
83 (:unsigned-long-long
'ffi
:uint64
)
84 (:float
'ffi
:single-float
)
85 (:double
'ffi
:double-float
)
86 ;; Clisp's FFI:C-POINTER converts NULL to NIL. For now
87 ;; we have a workaround in the pointer operations...
88 (:pointer
'ffi
:c-pointer
)
91 (defun %foreign-type-size
(type)
92 "Return the size in bytes of objects having foreign type TYPE."
93 (nth-value 0 (ffi:sizeof
(convert-foreign-type type
))))
95 ;; Remind me to buy a beer for whoever made getting the alignment
96 ;; of foreign types part of the public interface in CLisp. :-)
97 (defun %foreign-type-alignment
(type)
98 "Return the structure alignment in bytes of foreign TYPE."
99 #+(and cffi-features
:darwin cffi-features
:ppc32
)
101 ((:double
:long-long
:unsigned-long-long
)
102 (return-from %foreign-type-alignment
8)))
103 ;; Override not necessary for the remaining types...
104 (nth-value 1 (ffi:sizeof
(convert-foreign-type type
))))
106 ;;;# Basic Pointer Operations
108 (deftype foreign-pointer
()
109 '(or null ffi
:foreign-address
))
111 (defun pointerp (ptr)
112 "Return true if PTR is a foreign pointer."
113 (or (null ptr
) (typep ptr
'ffi
:foreign-address
)))
115 (defun pointer-eq (ptr1 ptr2
)
116 "Return true if PTR1 and PTR2 point to the same address."
117 (eql (ffi:foreign-address-unsigned ptr1
)
118 (ffi:foreign-address-unsigned ptr2
)))
120 (defun null-pointer ()
121 "Return a null foreign pointer."
122 (ffi:unsigned-foreign-address
0))
124 (defun null-pointer-p (ptr)
125 "Return true if PTR is a null foreign pointer."
126 (or (null ptr
) (zerop (ffi:foreign-address-unsigned ptr
))))
128 (defun inc-pointer (ptr offset
)
129 "Return a pointer pointing OFFSET bytes past PTR."
130 (ffi:unsigned-foreign-address
131 (+ offset
(if (null ptr
) 0 (ffi:foreign-address-unsigned ptr
)))))
133 (defun make-pointer (address)
134 "Return a pointer pointing to ADDRESS."
135 (ffi:unsigned-foreign-address address
))
137 (defun pointer-address (ptr)
138 "Return the address pointed to by PTR."
139 (ffi:foreign-address-unsigned ptr
))
141 ;;;# Foreign Memory Allocation
143 (defun %foreign-alloc
(size)
144 "Allocate SIZE bytes of foreign-addressable memory and return a
145 pointer to the allocated block. An implementation-specific error
146 is signalled if the memory cannot be allocated."
147 (ffi:foreign-address
(ffi:allocate-shallow
'ffi
:uint8
:count size
)))
149 (defun foreign-free (ptr)
150 "Free a pointer PTR allocated by FOREIGN-ALLOC. The results
151 are undefined if PTR is used after being freed."
152 (ffi:foreign-free ptr
))
154 (defmacro with-foreign-pointer
((var size
&optional size-var
) &body body
)
155 "Bind VAR to a pointer to SIZE bytes of foreign-addressable
156 memory during BODY. Both PTR and the memory block pointed to
157 have dynamic extent and may be stack allocated if supported by
158 the implementation. If SIZE-VAR is supplied, it will be bound to
161 (setf size-var
(gensym "SIZE")))
162 (let ((obj-var (gensym)))
163 `(let ((,size-var
,size
))
164 (ffi:with-foreign-object
165 (,obj-var
`(ffi:c-array ffi
:uint8
,,size-var
))
166 (let ((,var
(ffi:foreign-address
,obj-var
)))
171 (defun %mem-ref
(ptr type
&optional
(offset 0))
172 "Dereference a pointer OFFSET bytes from PTR to an object of
173 built-in foreign TYPE. Returns the object as a foreign pointer
175 (ffi:memory-as ptr
(convert-foreign-type type
) offset
))
177 (define-compiler-macro %mem-ref
(&whole form ptr type
&optional
(offset 0))
178 "Compiler macro to open-code when TYPE is constant."
180 `(ffi:memory-as
,ptr
',(convert-foreign-type (eval type
)) ,offset
)
183 (defun %mem-set
(value ptr type
&optional
(offset 0))
184 "Set a pointer OFFSET bytes from PTR to an object of built-in
185 foreign TYPE to VALUE."
186 (setf (ffi:memory-as ptr
(convert-foreign-type type
) offset
) value
))
188 (define-compiler-macro %mem-set
189 (&whole form value ptr type
&optional
(offset 0))
191 ;; (setf (ffi:memory-as) value) is exported, but not so nice
192 ;; w.r.t. the left to right evaluation rule
193 `(ffi::write-memory-as
194 ,value
,ptr
',(convert-foreign-type (eval type
)) ,offset
)
197 ;;;# Shareable Vectors
199 ;;; This interface is very experimental. WITH-POINTER-TO-VECTOR-DATA
200 ;;; should be defined to perform a copy-in/copy-out if the Lisp
201 ;;; implementation can't do this.
203 (declaim (inline make-shareable-byte-vector
))
204 (defun make-shareable-byte-vector (size)
205 "Create a Lisp vector of SIZE bytes can passed to
206 WITH-POINTER-TO-VECTOR-DATA."
207 (make-array size
:element-type
'(unsigned-byte 8)))
209 (deftype shareable-byte-vector
()
210 `(vector (unsigned-byte 8)))
212 (defmacro with-pointer-to-vector-data
((ptr-var vector
) &body body
)
213 "Bind PTR-VAR to a foreign pointer to the data in VECTOR."
214 (with-unique-names (vector-var size-var
)
215 `(let ((,vector-var
,vector
))
216 (check-type ,vector-var shareable-byte-vector
)
217 (with-foreign-pointer (,ptr-var
(length ,vector-var
) ,size-var
)
219 (loop for i below
,size-var do
220 (%mem-set
(aref ,vector-var i
) ,ptr-var
:unsigned-char i
))
221 (unwind-protect (progn ,@body
)
223 (loop for i below
,size-var do
224 (setf (aref ,vector-var i
)
225 (%mem-ref
,ptr-var
:unsigned-char i
))))))))
227 ;;;# Foreign Function Calling
229 (defun parse-foreign-funcall-args (args)
230 "Return three values, a list of CLISP FFI types, a list of
231 values to pass to the function, and the CLISP FFI return type."
232 (let ((return-type nil
))
233 (loop for
(type arg
) on args by
#'cddr
234 if arg collect
(list (gensym) (convert-foreign-type type
)) into types
235 and collect arg into fargs
236 else do
(setf return-type
(convert-foreign-type type
))
237 finally
(return (values types fargs return-type
)))))
239 (defun convert-cconv (calling-convention)
240 (ecase calling-convention
241 (:stdcall
:stdc-stdcall
)
244 (defun c-function-type (arg-types rettype calling-convention
)
245 "Generate the apropriate CLISP foreign type specification. Also
246 takes care of converting the calling convention names."
247 `(ffi:c-function
(:arguments
,@arg-types
)
248 (:return-type
,rettype
)
249 (:language
,(convert-cconv calling-convention
))))
251 ;;; Quick hack around the fact that the CFFI package is not yet
252 ;;; defined when this file is loaded. I suppose we could arrange for
253 ;;; the CFFI package to be defined a bit earlier, though.
254 (defun library-handle-form (name)
255 (flet ((find-cffi-symbol (symbol)
256 (find-symbol (symbol-name symbol
) '#:cffi
)))
257 `(,(find-cffi-symbol '#:foreign-library-handle
)
258 (,(find-cffi-symbol '#:get-foreign-library
) ',name
))))
260 (eval-when (:compile-toplevel
:load-toplevel
:execute
)
261 ;; version 2.40 (CVS 2006-09-03, to be more precise) added a
262 ;; PROPERTIES argument to FFI::FOREIGN-LIBRARY-FUNCTION.
263 (defun post-2.40-ffi-interface-p
()
264 (let ((f-l-f (find-symbol (string '#:foreign-library-function
) '#:ffi
)))
265 (if (and f-l-f
(= (length (ext:arglist f-l-f
)) 5))
268 ;; FFI::FOREIGN-LIBRARY-FUNCTION and FFI::FOREIGN-LIBRARY-VARIABLE
269 ;; were deprecated in 2.41 and removed in 2.45.
270 (defun post-2.45-ffi-interface-p
()
271 (if (find-symbol (string '#:foreign-library-function
) '#:ffi
)
275 #+#.
(cffi-sys::post-2.45-ffi-interface-p
)
276 (defun %foreign-funcall-aux
(name type library
)
277 `(ffi::find-foreign-function
,name
,type nil
,library nil nil
))
279 #-
#.
(cffi-sys::post-2.45-ffi-interface-p
)
280 (defun %foreign-funcall-aux
(name type library
)
281 `(ffi::foreign-library-function
283 #+#.
(cffi-sys::post-2.40-ffi-interface-p
)
287 (defmacro %foreign-funcall
(name args
&key library calling-convention
)
288 "Invoke a foreign function called NAME, taking pairs of
289 foreign-type/value pairs from ARGS. If a single element is left
290 over at the end of ARGS, it specifies the foreign return type of
292 (multiple-value-bind (types fargs rettype
)
293 (parse-foreign-funcall-args args
)
297 ,(%foreign-funcall-aux
300 ',(c-function-type types rettype calling-convention
))
301 (if (eq library
:default
)
303 (library-handle-form library
)))
308 (defmacro %foreign-funcall-pointer
(ptr args
&key calling-convention
)
309 "Similar to %foreign-funcall but takes a pointer instead of a string."
310 (multiple-value-bind (types fargs rettype
)
311 (parse-foreign-funcall-args args
)
312 `(funcall (ffi:foreign-function
313 ,ptr
(load-time-value
314 (ffi:parse-c-type
',(c-function-type
315 types rettype calling-convention
))))
320 ;;; *CALLBACKS* contains the callbacks defined by the CFFI DEFCALLBACK
321 ;;; macro. The symbol naming the callback is the key, and the value
322 ;;; is a list containing a Lisp function, the parsed CLISP FFI type of
323 ;;; the callback, and a saved pointer that should not persist across
325 (defvar *callbacks
* (make-hash-table))
327 ;;; Return a CLISP FFI function type for a CFFI callback function
328 ;;; given a return type and list of argument names and types.
329 (eval-when (:compile-toplevel
:load-toplevel
:execute
)
330 (defun callback-type (rettype arg-names arg-types calling-convention
)
333 (:arguments
,@(mapcar (lambda (sym type
)
334 (list sym
(convert-foreign-type type
)))
335 arg-names arg-types
))
336 (:return-type
,(convert-foreign-type rettype
))
337 (:language
,(convert-cconv calling-convention
))))))
339 ;;; Register and create a callback function.
340 (defun register-callback (name function parsed-type
)
341 (setf (gethash name
*callbacks
*)
342 (list function parsed-type
343 (ffi:with-foreign-object
(ptr 'ffi
:c-pointer
)
344 ;; Create callback by converting Lisp function to foreign
345 (setf (ffi:memory-as ptr parsed-type
) function
)
346 (ffi:foreign-value ptr
)))))
348 ;;; Restore all saved callback pointers when restarting the Lisp
349 ;;; image. This is pushed onto CUSTOM:*INIT-HOOKS*.
350 ;;; Needs clisp > 2.35, bugfix 2005-09-29
351 (defun restore-callback-pointers ()
354 (register-callback name
(first list
) (second list
)))
357 ;;; Add RESTORE-CALLBACK-POINTERS to the lists of functions to run
358 ;;; when an image is restarted.
359 (eval-when (:load-toplevel
:execute
)
360 (pushnew 'restore-callback-pointers custom
:*init-hooks
*))
362 ;;; Define a callback function NAME to run BODY with arguments
363 ;;; ARG-NAMES translated according to ARG-TYPES and the return type
364 ;;; translated according to RETTYPE. Obtain a pointer that can be
365 ;;; passed to C code for this callback by calling %CALLBACK.
366 (defmacro %defcallback
(name rettype arg-names arg-types body
367 &key calling-convention
)
368 `(register-callback ',name
(lambda ,arg-names
,body
)
369 ,(callback-type rettype arg-names arg-types
370 calling-convention
)))
372 ;;; Look up the name of a callback and return a pointer that can be
373 ;;; passed to a C function. Signals an error if no callback is
374 ;;; defined called NAME.
375 (defun %callback
(name)
376 (multiple-value-bind (list winp
) (gethash name
*callbacks
*)
378 (error "Undefined callback: ~S" name
))
381 ;;;# Loading and Closing Foreign Libraries
383 (defun %load-foreign-library
(name path
)
384 "Load a foreign library from PATH."
385 (declare (ignore name
))
386 #+#.
(cffi-sys::post-2.45-ffi-interface-p
)
387 (ffi:open-foreign-library path
)
388 #-
#.
(cffi-sys::post-2.45-ffi-interface-p
)
389 (ffi::foreign-library path
))
391 (defun %close-foreign-library
(handle)
392 "Close a foreign library."
393 (ffi:close-foreign-library handle
))
395 (defun native-namestring (pathname)
396 (namestring pathname
))
400 (defun %foreign-symbol-pointer
(name library
)
401 "Returns a pointer to a foreign symbol NAME."
402 (prog1 (ignore-errors
404 #+#.
(cffi-sys::post-2.45-ffi-interface-p
)
405 (ffi::find-foreign-variable name nil library nil nil
)
406 #-
#.
(cffi-sys::post-2.45-ffi-interface-p
)
407 (ffi::foreign-library-variable name library nil nil
)))))