1 ;;;; -*- Mode: lisp; indent-tabs-mode: nil -*-
3 ;;; uffi-compat.lisp --- UFFI compatibility layer for CFFI.
5 ;;; Copyright (C) 2005-2006, James Bielman <jamesjb@jamesjb.com>
6 ;;; Copyright (C) 2005-2007, Luis Oliveira <loliveira@common-lisp.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.
29 ;;; Code borrowed from UFFI is Copyright (c) Kevin M. Rosenberg.
31 (defpackage #:cffi-uffi-compat
32 (:nicknames
#:uffi
) ;; is this a good idea?
52 #:allocate-foreign-object
55 #:with-foreign-objects
56 #:size-of-foreign-type
59 #:ensure-char-character
61 #:ensure-char-storable
65 #:+null-cstring-pointer
+
66 #:char-array-to-pointer
69 #:convert-from-foreign-usb8
73 #:convert-from-cstring
78 #:convert-from-foreign-string
79 #:convert-to-foreign-string
80 #:allocate-foreign-string
82 #:with-foreign-strings
83 #:foreign-string-length
; not implemented
89 #:find-foreign-library
90 #:load-foreign-library
91 #:default-foreign-library-type
92 #:foreign-library-types
99 (in-package #:cffi-uffi-compat
)
102 (eval-when (:compile-toplevel
:load-toplevel
:execute
)
103 (when (equal (machine-type) "POWER MACINTOSH")
104 (pushnew :ppc
*features
*)))
106 (defun convert-uffi-type (uffi-type)
107 "Convert a UFFI primitive type to a CFFI type."
108 ;; Many CFFI types are the same as UFFI. This list handles the
112 (:pointer-void
:pointer
)
113 (:pointer-self
:pointer
)
114 (:char
'(uffi-char :char
))
115 (:unsigned-char
'(uffi-char :unsigned-char
))
117 (:unsigned-byte
:unsigned-char
)
119 (if (listp uffi-type
)
120 (case (car uffi-type
)
121 ;; this is imho gross but it is what uffi does
122 (quote (convert-uffi-type (second uffi-type
)))
124 (:array
`(uffi-array ,(convert-uffi-type (second uffi-type
))
126 (:union
(second uffi-type
))
127 (:struct
(convert-uffi-type (second uffi-type
)))
128 (:struct-pointer
:pointer
))
131 (cffi:define-foreign-type uffi-array-type
()
132 ;; ELEMENT-TYPE should be /unparsed/, suitable for passing to mem-aref.
133 ((element-type :initform
(error "An element-type is required.")
134 :accessor element-type
:initarg
:element-type
)
135 (nelems :initform
(error "nelems is required.")
136 :accessor nelems
:initarg
:nelems
))
137 (:actual-type
:pointer
)
138 (:documentation
"UFFI's :array type."))
140 (cffi:define-parse-method uffi-array
(element-type count
)
141 (make-instance 'uffi-array-type
:element-type element-type
142 :nelems
(or count
1)))
144 (defmethod cffi:foreign-type-size
((type uffi-array-type
))
145 (* (cffi:foreign-type-size
(element-type type
)) (nelems type
)))
147 (defmethod cffi::aggregatep
((type uffi-array-type
))
150 ;; UFFI's :(unsigned-)char
151 (cffi:define-foreign-type uffi-char
()
154 (cffi:define-parse-method uffi-char
(base-type)
155 (make-instance 'uffi-char
:actual-type base-type
))
157 (defmethod cffi:translate-to-foreign
((value character
) (type uffi-char
))
160 (defmethod cffi:translate-from-foreign
(obj (type uffi-char
))
163 (defmacro def-type
(name type
)
164 "Define a Common Lisp type NAME for UFFI type TYPE."
165 (declare (ignore type
))
166 `(deftype ,name
() t
))
168 (defmacro def-foreign-type
(name type
)
169 "Define a new foreign type."
170 `(cffi:defctype
,name
,(convert-uffi-type type
)))
172 (defmacro def-constant
(name value
&key export
)
173 "Define a constant and conditionally export it."
174 `(eval-when (:compile-toplevel
:load-toplevel
:execute
)
175 (defconstant ,name
,value
)
176 ,@(when export
`((export ',name
)))
179 (defmacro null-char-p
(val)
180 "Return true if character is null."
181 `(zerop (char-code ,val
)))
183 (defmacro def-enum
(enum-name args
&key
(separator-string "#"))
184 "Creates a constants for a C type enum list, symbols are
185 created in the created in the current package. The symbol is the
186 concatenation of the enum-name name, separator-string, and
191 (declare (fixnum counter
))
193 (let ((name (if (listp arg
) (car arg
) arg
))
194 (value (if (listp arg
)
196 (setq counter
(cadr arg
))
201 (setq name
(intern (concatenate 'string
202 (symbol-name enum-name
)
204 (symbol-name name
))))
205 (push `(def-constant ,name
,value
) constants
)))
206 (setf cmds
(append '(progn) `((cffi:defctype
,enum-name
:int
))
207 (nreverse constants
)))
210 (defmacro def-struct
(name &body fields
)
211 "Define a C structure."
212 `(cffi:defcstruct
,name
213 ,@(loop for
(name uffi-type
) in fields
214 for cffi-type
= (convert-uffi-type uffi-type
)
215 collect
(list name cffi-type
))))
217 ;; TODO: figure out why the compiler macro is kicking in before
218 ;; the setf expander.
219 (defun %foreign-slot-value
(obj type field
)
220 (cffi:foreign-slot-value obj type field
))
222 (defun (setf %foreign-slot-value
) (value obj type field
)
223 (setf (cffi:foreign-slot-value obj type field
) value
))
225 (defmacro get-slot-value
(obj type field
)
226 "Access a slot value from a structure."
227 `(%foreign-slot-value
,obj
,type
,field
))
229 ;; UFFI uses a different function when accessing a slot whose
230 ;; type is a pointer. We don't need that in CFFI so we use
231 ;; foreign-slot-value too.
232 (defmacro get-slot-pointer
(obj type field
)
233 "Access a pointer slot value from a structure."
234 `(cffi:foreign-slot-value
,obj
,type
,field
))
236 (defmacro def-array-pointer
(name type
)
237 "Define a foreign array type."
238 `(cffi:defctype
,name
(uffi-array ,(convert-uffi-type type
) 1)))
240 (defmacro deref-array
(array type position
)
241 "Dereference an array."
242 `(cffi:mem-aref
,array
243 ,(if (constantp type
)
244 `',(element-type (cffi::parse-type
245 (convert-uffi-type (eval type
))))
246 `(element-type (cffi::parse-type
247 (convert-uffi-type ,type
))))
250 ;; UFFI's documentation on DEF-UNION is a bit scarce, I'm not sure
251 ;; if DEFCUNION and DEF-UNION are strictly compatible.
252 (defmacro def-union
(name &body fields
)
253 "Define a foreign union type."
254 `(cffi:defcunion
,name
255 ,@(loop for
(name uffi-type
) in fields
256 for cffi-type
= (convert-uffi-type uffi-type
)
257 collect
(list name cffi-type
))))
259 (defmacro allocate-foreign-object
(type &optional
(size 1))
260 "Allocate one or more instance of a foreign type."
261 `(cffi:foreign-alloc
,(if (constantp type
)
262 `',(convert-uffi-type (eval type
))
263 `(convert-uffi-type ,type
))
266 (defmacro free-foreign-object
(ptr)
267 "Free a foreign object allocated by ALLOCATE-FOREIGN-OBJECT."
268 `(cffi:foreign-free
,ptr
))
270 (defmacro with-foreign-object
((var type
) &body body
)
271 "Wrap the allocation of a foreign object around BODY."
272 `(cffi:with-foreign-object
(,var
(convert-uffi-type ,type
))
275 ;; Taken from UFFI's src/objects.lisp
276 (defmacro with-foreign-objects
(bindings &rest body
)
278 `(with-foreign-object ,(car bindings
)
279 (with-foreign-objects ,(cdr bindings
)
283 (defmacro size-of-foreign-type
(type)
284 "Return the size in bytes of a foreign type."
285 `(cffi:foreign-type-size
(convert-uffi-type ,type
)))
287 (defmacro pointer-address
(ptr)
288 "Return the address of a pointer."
289 `(cffi:pointer-address
,ptr
))
291 (defmacro deref-pointer
(ptr type
)
292 "Dereference a pointer."
293 `(cffi:mem-ref
,ptr
(convert-uffi-type ,type
)))
295 (defsetf deref-pointer
(ptr type
) (value)
296 `(setf (cffi:mem-ref
,ptr
(convert-uffi-type ,type
)) ,value
))
298 (defmacro ensure-char-character
(obj &environment env
)
299 "Convert OBJ to a character if it is an integer."
300 (if (constantp obj env
)
301 (if (characterp obj
) obj
(code-char obj
))
302 (let ((obj-var (gensym)))
303 `(let ((,obj-var
,obj
))
304 (if (characterp ,obj-var
)
306 (code-char ,obj-var
))))))
308 (defmacro ensure-char-integer
(obj &environment env
)
309 "Convert OBJ to an integer if it is a character."
310 (if (constantp obj env
)
311 (let ((the-obj (eval obj
)))
312 (if (characterp the-obj
) (char-code the-obj
) the-obj
))
313 (let ((obj-var (gensym)))
314 `(let ((,obj-var
,obj
))
315 (if (characterp ,obj-var
)
319 (defmacro ensure-char-storable
(obj)
320 "Ensure OBJ is storable as a character."
321 `(ensure-char-integer ,obj
))
323 (defmacro make-null-pointer
(type)
324 "Create a NULL pointer."
325 (declare (ignore type
))
326 `(cffi:null-pointer
))
328 (defmacro make-pointer
(address type
)
329 "Create a pointer to ADDRESS."
330 (declare (ignore type
))
331 `(cffi:make-pointer
,address
))
333 (defmacro null-pointer-p
(ptr)
334 "Return true if PTR is a null pointer."
335 `(cffi:null-pointer-p
,ptr
))
337 (defparameter +null-cstring-pointer
+ (cffi:null-pointer
)
338 "A constant NULL string pointer.")
340 (defmacro char-array-to-pointer
(obj)
343 (defmacro with-cast-pointer
((var ptr type
) &body body
)
344 "Cast a pointer, does nothing in CFFI."
345 (declare (ignore type
))
349 (defmacro def-foreign-var
(name type module
)
350 "Define a symbol macro to access a foreign variable."
351 (declare (ignore module
))
352 (flet ((lisp-name (name)
353 (intern (cffi-sys:canonicalize-symbol-name-case
354 (substitute #\-
#\_ name
)))))
355 `(cffi:defcvar
,(if (listp name
)
357 (list name
(lisp-name name
)))
358 ,(convert-uffi-type type
))))
360 (defmacro def-pointer-var
(name value
&optional doc
)
361 #-openmcl
`(defvar ,name
,value
,@(if doc
(list doc
)))
362 #+openmcl
`(ccl::defloadvar
,name
,value
,doc
))
364 (defmacro convert-from-cstring
(s)
365 "Convert a cstring to a Lisp string."
366 (let ((ret (gensym)))
367 `(let ((,ret
(cffi:foreign-string-to-lisp
,s
)))
372 (defmacro convert-to-cstring
(obj)
373 "Convert a Lisp string to a cstring."
374 (let ((str (gensym)))
378 (cffi:foreign-string-alloc
,str
)))))
380 (defmacro free-cstring
(ptr)
382 `(cffi:foreign-string-free
,ptr
))
384 (defmacro with-cstring
((foreign-string lisp-string
) &body body
)
385 "Binds a newly creating string."
386 (let ((str (gensym)))
387 `(let ((,str
,lisp-string
))
389 (let ((,foreign-string
(cffi:null-pointer
)))
391 (cffi:with-foreign-string
(,foreign-string
,str
)
394 ;; Taken from UFFI's src/strings.lisp
395 (defmacro with-cstrings
(bindings &rest body
)
397 `(with-cstring ,(car bindings
)
398 (with-cstrings ,(cdr bindings
)
402 (defmacro def-function
(name args
&key module
(returning :void
))
403 "Define a foreign function."
404 (declare (ignore module
))
405 `(cffi:defcfun
,name
,(convert-uffi-type returning
)
406 ,@(loop for
(name type
) in args
407 collect
`(,name
,(convert-uffi-type type
)))))
409 ;;; Taken from UFFI's src/libraries.lisp
411 (defvar *loaded-libraries
* nil
412 "List of foreign libraries loaded. Used to prevent reloading a library")
414 (defun default-foreign-library-type ()
415 "Returns string naming default library type for platform"
416 #+(or win32 cygwin mswindows
) "dll"
417 #+(or macos macosx darwin ccl-5.0
) "dylib"
418 #-
(or win32 cygwin mswindows macos macosx darwin ccl-5.0
) "so")
420 (defun foreign-library-types ()
421 "Returns list of string naming possible library types for platform,
422 sorted by preference"
423 #+(or win32 cygwin mswindows
) '("dll" "lib" "so")
424 #+(or macos macosx darwin ccl-5.0
) '("dylib" "bundle")
425 #-
(or win32 cygwin mswindows macos macosx darwin ccl-5.0
) '("so" "a" "o"))
427 (defun find-foreign-library (names directories
&key types drive-letters
)
428 "Looks for a foreign library. directories can be a single
429 string or a list of strings of candidate directories. Use default
430 library type if type is not specified."
432 (setq types
(foreign-library-types)))
433 (unless (listp types
)
434 (setq types
(list types
)))
435 (unless (listp names
)
436 (setq names
(list names
)))
437 (unless (listp directories
)
438 (setq directories
(list directories
)))
439 #+(or win32 mswindows
)
440 (unless (listp drive-letters
)
441 (setq drive-letters
(list drive-letters
)))
442 #-
(or win32 mswindows
)
443 (setq drive-letters
'(nil))
444 (dolist (drive-letter drive-letters
)
446 (dolist (dir directories
)
448 (let ((path (make-pathname
450 #+lispworks
(when drive-letter drive-letter
)
452 #-lispworks
(when drive-letter drive-letter
)
458 (pathname-directory dir
))
463 (parse-namestring dir
)))))))
464 (when (probe-file path
)
465 (return-from find-foreign-library path
)))))))
468 (defun convert-supporting-libraries-to-string (libs)
471 (push (format nil
"-l~A" lib
) lib-load-list
))
472 (nreverse lib-load-list
)))
474 (defun load-foreign-library (filename &key module supporting-libraries
476 #+(or allegro mcl sbcl clisp
) (declare (ignore module supporting-libraries
))
477 #+(or cmu scl sbcl
) (declare (ignore module
))
479 (when (and filename
(or (null (pathname-directory filename
))
480 (probe-file filename
)))
481 (if (pathnamep filename
) ;; ensure filename is a string to check if
482 (setq filename
(namestring filename
))) ; already loaded
484 (if (and (not force-load
)
485 (find filename
*loaded-libraries
* :test
#'string-equal
))
486 t
;; return T, but don't reload library
488 ;; FIXME: Hmm, what are these two for?
490 (let ((type (pathname-type (parse-namestring filename
))))
491 (if (string-equal type
"so")
492 (sys::load-object-file filename
)
493 (alien:load-foreign filename
495 (convert-supporting-libraries-to-string
496 supporting-libraries
))))
498 (let ((type (pathname-type (parse-namestring filename
))))
499 (if (string-equal type
"so")
500 (sys::load-dynamic-object filename
)
501 (alien:load-foreign filename
503 (convert-supporting-libraries-to-string
504 supporting-libraries
))))
507 (cffi:load-foreign-library filename
)
508 (push filename
*loaded-libraries
*)
511 ;; Taken from UFFI's src/os.lisp
513 "Return the value of the environment variable."
514 #+allegro
(sys::getenv
(string var
))
515 #+clisp
(sys::getenv
(string var
))
516 #+(or cmu scl
) (cdr (assoc (string var
) ext
:*environment-list
* :test
#'equalp
518 #+gcl
(si:getenv
(string var
))
519 #+lispworks
(lw:environment-variable
(string var
))
520 #+lucid
(lcl:environment-variable
(string var
))
521 #+mcl
(ccl::getenv var
)
522 #+sbcl
(sb-ext:posix-getenv var
)
523 #-
(or allegro clisp cmu scl gcl lispworks lucid mcl sbcl
)
524 (error 'not-implemented
:proc
(list 'getenv var
)))
526 ;; Taken from UFFI's src/os.lisp
527 ;; modified from function ASDF -- Copyright Dan Barlow and Contributors
528 (defun run-shell-command (control-string &rest args
&key output
)
529 "Interpolate ARGS into CONTROL-STRING as if by FORMAT, and
530 synchronously execute the result using a Bourne-compatible shell, with
531 output to *trace-output*. Returns the shell's exit code."
533 (setq output
*trace-output
*))
535 (let ((command (apply #'format nil control-string args
)))
537 (sb-impl::process-exit-code
541 :input nil
:output output
))
544 (ext:process-exit-code
548 :input nil
:output output
))
551 (excl:run-shell-command command
:input nil
:output output
)
554 (system:call-system-showing-output
556 :shell-type
"/bin/sh"
557 :output-stream output
)
559 #+clisp
;XXX not exactly *trace-output*, I know
560 (ext:run-shell-command command
:output
:terminal
:wait t
)
564 (ccl:external-process-status
565 (ccl:run-program
"/bin/sh" (list "-c" command
)
566 :input nil
:output output
569 #-
(or openmcl clisp lispworks allegro scl cmu sbcl
)
570 (error "RUN-SHELL-PROGRAM not implemented for this Lisp")
573 ;;; Some undocumented UFFI operators...
575 (defmacro convert-from-foreign-string
(obj &key length
(locale :default
)
576 (null-terminated-p t
))
577 ;; in effect, (eq NULL-TERMINATED-P (null LENGTH)). Hopefully,
578 ;; that's compatible with the intended semantics, which are
579 ;; undocumented. If that's not the case, we can implement
580 ;; NULL-TERMINATED-P in CFFI:FOREIGN-STRING-TO-LISP.
581 (declare (ignore locale null-terminated-p
))
582 (let ((ret (gensym)))
583 `(let ((,ret
(cffi:foreign-string-to-lisp
,obj
:count
,length
)))
588 ;; What's the difference between this and convert-to-cstring?
589 (defmacro convert-to-foreign-string
(obj)
590 (let ((str (gensym)))
594 (cffi:foreign-string-alloc
,str
)))))
596 (defmacro allocate-foreign-string
(size &key unsigned
)
597 (declare (ignore unsigned
))
598 `(cffi:foreign-alloc
:char
:count
,size
))
601 (defmacro with-foreign-string
((foreign-string lisp-string
) &body body
)
602 (let ((str (gensym)))
603 `(let ((,str
,lisp-string
))
605 (let ((,foreign-string
(cffi:null-pointer
)))
607 (cffi:with-foreign-string
(,foreign-string
,str
)
610 (defmacro with-foreign-strings
(bindings &body body
)
611 `(with-foreign-string ,(car bindings
)
613 `((with-foreign-strings ,(cdr bindings
) ,@body
))
616 ;; This function returns a form? Where is this used in user-code?
617 (defun foreign-string-length (foreign-string)
618 (declare (ignore foreign-string
))
619 (error "FOREIGN-STRING-LENGTH not implemented."))
621 ;; This should be optimized.
622 (defun convert-from-foreign-usb8 (s len
)
623 (let ((a (make-array len
:element-type
'(unsigned-byte 8))))
625 (setf (aref a i
) (cffi:mem-ref s
:unsigned-char i
)))))