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 ;;; (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
)
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
)
63 ;;; FIXME: long-long could be supported anyway on 64-bit machines. --luis
67 (eval-when (:compile-toplevel
:load-toplevel
:execute
)
68 (mapc (lambda (feature) (pushnew feature
*features
*))
70 #+:macos cffi-features
:darwin
71 #+:unix cffi-features
:unix
72 #+:win32 cffi-features
:windows
74 (cond ((string-equal (machine-type) "X86_64")
75 (pushnew 'cffi-features
:x86-64
*features
*))
76 ((member :pc386
*features
*)
77 (pushnew 'cffi-features
:x86
*features
*))
78 ;; FIXME: probably catches PPC64 as well
79 ((string-equal (machine-type) "POWER MACINTOSH")
80 (pushnew 'cffi-features
:ppc32
*features
*))))
84 (defun canonicalize-symbol-name-case (name)
85 (declare (string name
))
88 ;;;# Built-In Foreign Types
90 (defun convert-foreign-type (type)
91 "Convert a CFFI built-in type keyword to a CLisp FFI type."
94 (:unsigned-char
'ffi
:uchar
)
96 (:unsigned-short
'ffi
:ushort
)
98 (:unsigned-int
'ffi
:uint
)
100 (:unsigned-long
'ffi
:ulong
)
101 (:long-long
'ffi
:sint64
)
102 (:unsigned-long-long
'ffi
:uint64
)
103 (:float
'ffi
:single-float
)
104 (:double
'ffi
:double-float
)
105 ;; Clisp's FFI:C-POINTER converts NULL to NIL. For now
106 ;; we have a workaround in the pointer operations...
107 (:pointer
'ffi
:c-pointer
)
110 (defun %foreign-type-size
(type)
111 "Return the size in bytes of objects having foreign type TYPE."
112 (nth-value 0 (ffi:sizeof
(convert-foreign-type type
))))
114 ;; Remind me to buy a beer for whoever made getting the alignment
115 ;; of foreign types part of the public interface in CLisp. :-)
116 (defun %foreign-type-alignment
(type)
117 "Return the structure alignment in bytes of foreign TYPE."
118 #+(and cffi-features
:darwin cffi-features
:ppc32
)
120 ((:double
:long-long
:unsigned-long-long
)
121 (return-from %foreign-type-alignment
8)))
122 ;; Override not necessary for the remaining types...
123 (nth-value 1 (ffi:sizeof
(convert-foreign-type type
))))
125 ;;;# Basic Pointer Operations
127 (deftype foreign-pointer
()
128 '(or null ffi
:foreign-address
))
130 (defun pointerp (ptr)
131 "Return true if PTR is a foreign pointer."
132 (or (null ptr
) (typep ptr
'ffi
:foreign-address
)))
134 (defun pointer-eq (ptr1 ptr2
)
135 "Return true if PTR1 and PTR2 point to the same address."
136 (eql (ffi:foreign-address-unsigned ptr1
)
137 (ffi:foreign-address-unsigned ptr2
)))
139 (defun null-pointer ()
140 "Return a null foreign pointer."
141 (ffi:unsigned-foreign-address
0))
143 (defun null-pointer-p (ptr)
144 "Return true if PTR is a null foreign pointer."
145 (or (null ptr
) (zerop (ffi:foreign-address-unsigned ptr
))))
147 (defun inc-pointer (ptr offset
)
148 "Return a pointer pointing OFFSET bytes past PTR."
149 (ffi:unsigned-foreign-address
150 (+ offset
(if (null ptr
) 0 (ffi:foreign-address-unsigned ptr
)))))
152 (defun make-pointer (address)
153 "Return a pointer pointing to ADDRESS."
154 (ffi:unsigned-foreign-address address
))
156 (defun pointer-address (ptr)
157 "Return the address pointed to by PTR."
158 (ffi:foreign-address-unsigned ptr
))
160 ;;;# Foreign Memory Allocation
162 (defun %foreign-alloc
(size)
163 "Allocate SIZE bytes of foreign-addressable memory and return a
164 pointer to the allocated block. An implementation-specific error
165 is signalled if the memory cannot be allocated."
166 (ffi:foreign-address
(ffi:allocate-shallow
'ffi
:uint8
:count size
)))
168 (defun foreign-free (ptr)
169 "Free a pointer PTR allocated by FOREIGN-ALLOC. The results
170 are undefined if PTR is used after being freed."
171 (ffi:foreign-free ptr
))
173 (defmacro with-foreign-pointer
((var size
&optional size-var
) &body body
)
174 "Bind VAR to a pointer to SIZE bytes of foreign-addressable
175 memory during BODY. Both PTR and the memory block pointed to
176 have dynamic extent and may be stack allocated if supported by
177 the implementation. If SIZE-VAR is supplied, it will be bound to
180 (setf size-var
(gensym "SIZE")))
181 (let ((obj-var (gensym)))
182 `(let ((,size-var
,size
))
183 (ffi:with-foreign-object
184 (,obj-var
`(ffi:c-array ffi
:uint8
,,size-var
))
185 (let ((,var
(ffi:foreign-address
,obj-var
)))
190 (defun %mem-ref
(ptr type
&optional
(offset 0))
191 "Dereference a pointer OFFSET bytes from PTR to an object of
192 built-in foreign TYPE. Returns the object as a foreign pointer
194 (ffi:memory-as ptr
(convert-foreign-type type
) offset
))
196 (define-compiler-macro %mem-ref
(&whole form ptr type
&optional
(offset 0))
197 "Compiler macro to open-code when TYPE is constant."
199 `(ffi:memory-as
,ptr
',(convert-foreign-type (eval type
)) ,offset
)
202 (defun %mem-set
(value ptr type
&optional
(offset 0))
203 "Set a pointer OFFSET bytes from PTR to an object of built-in
204 foreign TYPE to VALUE."
205 (setf (ffi:memory-as ptr
(convert-foreign-type type
) offset
) value
))
207 (define-compiler-macro %mem-set
208 (&whole form value ptr type
&optional
(offset 0))
210 ;; (setf (ffi:memory-as) value) is exported, but not so nice
211 ;; w.r.t. the left to right evaluation rule
212 `(ffi::write-memory-as
213 ,value
,ptr
',(convert-foreign-type (eval type
)) ,offset
)
216 ;;;# Shareable Vectors
218 ;;; This interface is very experimental. WITH-POINTER-TO-VECTOR-DATA
219 ;;; should be defined to perform a copy-in/copy-out if the Lisp
220 ;;; implementation can't do this.
222 (declaim (inline make-shareable-byte-vector
))
223 (defun make-shareable-byte-vector (size)
224 "Create a Lisp vector of SIZE bytes can passed to
225 WITH-POINTER-TO-VECTOR-DATA."
226 (make-array size
:element-type
'(unsigned-byte 8)))
228 (deftype shareable-byte-vector
()
229 `(vector (unsigned-byte 8)))
231 (defmacro with-pointer-to-vector-data
((ptr-var vector
) &body body
)
232 "Bind PTR-VAR to a foreign pointer to the data in VECTOR."
233 (with-unique-names (vector-var size-var
)
234 `(let ((,vector-var
,vector
))
235 (check-type ,vector-var shareable-byte-vector
)
236 (with-foreign-pointer (,ptr-var
(length ,vector-var
) ,size-var
)
238 (loop for i below
,size-var do
239 (%mem-set
(aref ,vector-var i
) ,ptr-var
:unsigned-char i
))
240 (unwind-protect (progn ,@body
)
242 (loop for i below
,size-var do
243 (setf (aref ,vector-var i
)
244 (%mem-ref
,ptr-var
:unsigned-char i
))))))))
246 ;;;# Foreign Function Calling
248 (defun parse-foreign-funcall-args (args)
249 "Return three values, a list of CLISP FFI types, a list of
250 values to pass to the function, and the CLISP FFI return type."
251 (let ((return-type nil
))
252 (loop for
(type arg
) on args by
#'cddr
253 if arg collect
(list (gensym) (convert-foreign-type type
)) into types
254 and collect arg into fargs
255 else do
(setf return-type
(convert-foreign-type type
))
256 finally
(return (values types fargs return-type
)))))
258 (defun convert-cconv (calling-convention)
259 (ecase calling-convention
260 (:stdcall
:stdc-stdcall
)
263 (defun c-function-type (arg-types rettype calling-convention
)
264 "Generate the apropriate CLISP foreign type specification. Also
265 takes care of converting the calling convention names."
266 `(ffi:c-function
(:arguments
,@arg-types
)
267 (:return-type
,rettype
)
268 (:language
,(convert-cconv calling-convention
))))
270 ;;; Quick hack around the fact that the CFFI package is not yet
271 ;;; defined when this file is loaded. I suppose we could arrange for
272 ;;; the CFFI package to be defined a bit earlier, though.
273 (defun library-handle-form (name)
274 (flet ((find-cffi-symbol (symbol)
275 (find-symbol (symbol-name symbol
) '#:cffi
)))
276 `(,(find-cffi-symbol '#:foreign-library-handle
)
277 (,(find-cffi-symbol '#:get-foreign-library
) ',name
))))
279 (defmacro %foreign-funcall
(name args
&key library calling-convention
)
280 "Invoke a foreign function called NAME, taking pairs of
281 foreign-type/value pairs from ARGS. If a single element is left
282 over at the end of ARGS, it specifies the foreign return type of
284 (multiple-value-bind (types fargs rettype
)
285 (parse-foreign-funcall-args args
)
289 (ffi::foreign-library-function
291 ,(if (eq library
:default
)
293 (library-handle-form library
))
295 ;; As of version 2.40 (CVS 2006-09-03, to be more precise),
296 ;; FFI::FOREIGN-LIBRARY-FUNCTION takes an additional
297 ;; 'PROPERTIES' argument.
298 #+#.
(cl:if
(cl:= (cl:length
(ext:arglist
299 'ffi
::foreign-library-function
)) 5)
302 (ffi:parse-c-type
',(c-function-type
303 types rettype calling-convention
)))
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 (ffi::foreign-library path
))
388 (defun %close-foreign-library
(handle)
389 "Close a foreign library."
390 (ffi:close-foreign-library handle
))
392 (defun native-namestring (pathname)
393 (namestring pathname
))
397 (defun %foreign-symbol-pointer
(name library
)
398 "Returns a pointer to a foreign symbol NAME."
399 (prog1 (ignore-errors
401 (ffi::foreign-library-variable
402 name library nil nil
)))))