1 ;;;; -*- Mode: lisp; indent-tabs-mode: nil -*-
3 ;;; cffi-openmcl.lisp --- CFFI-SYS implementation for OpenMCL.
5 ;;; Copyright (C) 2005-2006, James Bielman <jamesjb@jamesjb.com>
7 ;;; Permission is hereby granted, free of charge, to any person
8 ;;; obtaining a copy of this software and associated documentation
9 ;;; files (the "Software"), to deal in the Software without
10 ;;; restriction, including without limitation the rights to use, copy,
11 ;;; modify, merge, publish, distribute, sublicense, and/or sell copies
12 ;;; of the Software, and to permit persons to whom the Software is
13 ;;; furnished to do so, subject to the following conditions:
15 ;;; The above copyright notice and this permission notice shall be
16 ;;; included in all copies or substantial portions of the Software.
18 ;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
19 ;;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
20 ;;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
21 ;;; NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT
22 ;;; HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY,
23 ;;; WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
24 ;;; OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER
25 ;;; DEALINGS IN THE SOFTWARE.
30 (defpackage #:cffi-sys
31 (:use
#:common-lisp
#:ccl
#:cffi-utils
)
33 #:canonicalize-symbol-name-case
35 #:pointerp
; ccl:pointerp
39 #:with-foreign-pointer
48 #:%foreign-funcall-pointer
49 #:%foreign-type-alignment
51 #:%load-foreign-library
52 #:%close-foreign-library
54 #:make-shareable-byte-vector
55 #:with-pointer-to-vector-data
56 #:%foreign-symbol-pointer
60 (in-package #:cffi-sys
)
64 (eval-when (:compile-toplevel
:load-toplevel
:execute
)
65 (mapc (lambda (feature) (pushnew feature
*features
*))
67 #+darwin-target cffi-features
:darwin
68 #+unix cffi-features
:unix
69 #+ppc32-target cffi-features
:ppc32
70 #+x8664-target cffi-features
:x86-64
72 cffi-features
:flat-namespace
77 (defun canonicalize-symbol-name-case (name)
78 (declare (string name
))
83 ;;; Functions and macros for allocating foreign memory on the stack
84 ;;; and on the heap. The main CFFI package defines macros that wrap
85 ;;; FOREIGN-ALLOC and FOREIGN-FREE in UNWIND-PROTECT for the common
86 ;;; usage when the memory has dynamic extent.
88 (defun %foreign-alloc
(size)
89 "Allocate SIZE bytes on the heap and return a pointer."
92 (defun foreign-free (ptr)
93 "Free a PTR allocated by FOREIGN-ALLOC."
94 ;; TODO: Should we make this a dead macptr?
97 (defmacro with-foreign-pointer
((var size
&optional size-var
) &body body
)
98 "Bind VAR to SIZE bytes of foreign memory during BODY. The
99 pointer in VAR is invalid beyond the dynamic extent of BODY, and
100 may be stack-allocated if supported by the implementation. If
101 SIZE-VAR is supplied, it will be bound to SIZE during BODY."
103 (setf size-var
(gensym "SIZE")))
104 `(let ((,size-var
,size
))
105 (%stack-block
((,var
,size-var
))
108 ;;;# Misc. Pointer Operations
110 (deftype foreign-pointer
()
113 (defun null-pointer ()
114 "Construct and return a null pointer."
117 (defun null-pointer-p (ptr)
118 "Return true if PTR is a null pointer."
119 (ccl:%null-ptr-p ptr
))
121 (defun inc-pointer (ptr offset
)
122 "Return a pointer OFFSET bytes past PTR."
123 (ccl:%inc-ptr ptr offset
))
125 (defun pointer-eq (ptr1 ptr2
)
126 "Return true if PTR1 and PTR2 point to the same address."
127 (ccl:%ptr-eql ptr1 ptr2
))
129 (defun make-pointer (address)
130 "Return a pointer pointing to ADDRESS."
131 (ccl:%int-to-ptr address
))
133 (defun pointer-address (ptr)
134 "Return the address pointed to by PTR."
135 (ccl:%ptr-to-int ptr
))
137 ;;;# Shareable Vectors
139 ;;; This interface is very experimental. WITH-POINTER-TO-VECTOR-DATA
140 ;;; should be defined to perform a copy-in/copy-out if the Lisp
141 ;;; implementation can't do this.
143 (defun make-shareable-byte-vector (size)
144 "Create a Lisp vector of SIZE bytes that can passed to
145 WITH-POINTER-TO-VECTOR-DATA."
146 (make-array size
:element-type
'(unsigned-byte 8)))
148 (defmacro with-pointer-to-vector-data
((ptr-var vector
) &body body
)
149 "Bind PTR-VAR to a foreign pointer to the data in VECTOR."
150 `(ccl:with-pointer-to-ivector
(,ptr-var
,vector
)
155 ;;; Define the %MEM-REF and %MEM-SET functions, as well as compiler
156 ;;; macros that optimize the case where the type keyword is constant
158 (defmacro define-mem-accessors
(&body pairs
)
160 (defun %mem-ref
(ptr type
&optional
(offset 0))
162 ,@(loop for
(keyword fn
) in pairs
163 collect
`(,keyword
(,fn ptr offset
)))))
164 (defun %mem-set
(value ptr type
&optional
(offset 0))
166 ,@(loop for
(keyword fn
) in pairs
167 collect
`(,keyword
(setf (,fn ptr offset
) value
)))))
168 (define-compiler-macro %mem-ref
169 (&whole form ptr type
&optional
(offset 0))
172 ,@(loop for
(keyword fn
) in pairs
173 collect
`(,keyword
`(,',fn
,ptr
,offset
))))
175 (define-compiler-macro %mem-set
176 (&whole form value ptr type
&optional
(offset 0))
180 ,@(loop for
(keyword fn
) in pairs
181 collect
`(,keyword
`(setf (,',fn
,ptr
,offset
)
185 (define-mem-accessors
186 (:char %get-signed-byte
)
187 (:unsigned-char %get-unsigned-byte
)
188 (:short %get-signed-word
)
189 (:unsigned-short %get-unsigned-word
)
190 (:int %get-signed-long
)
191 (:unsigned-int %get-unsigned-long
)
192 #+32-bit-target
(:long %get-signed-long
)
193 #+64-bit-target
(:long ccl
::%%get-signed-longlong
)
194 #+32-bit-target
(:unsigned-long %get-unsigned-long
)
195 #+64-bit-target
(:unsigned-long ccl
::%%get-unsigned-longlong
)
196 (:long-long ccl
::%get-signed-long-long
)
197 (:unsigned-long-long ccl
::%get-unsigned-long-long
)
198 (:float %get-single-float
)
199 (:double %get-double-float
)
202 ;;;# Calling Foreign Functions
204 (defun convert-foreign-type (type-keyword)
205 "Convert a CFFI type keyword to an OpenMCL type."
208 (:unsigned-char
:unsigned-byte
)
209 (:short
:signed-short
)
210 (:unsigned-short
:unsigned-short
)
212 (:unsigned-int
:unsigned-int
)
214 (:unsigned-long
:unsigned-long
)
215 (:long-long
:signed-doubleword
)
216 (:unsigned-long-long
:unsigned-doubleword
)
217 (:float
:single-float
)
218 (:double
:double-float
)
222 (defun %foreign-type-size
(type-keyword)
223 "Return the size in bytes of a foreign type."
224 (/ (ccl::foreign-type-bits
225 (ccl::parse-foreign-type
226 (convert-foreign-type type-keyword
))) 8))
228 ;; There be dragons here. See the following thread for details:
229 ;; http://clozure.com/pipermail/openmcl-devel/2005-June/002777.html
230 (defun %foreign-type-alignment
(type-keyword)
231 "Return the alignment in bytes of a foreign type."
232 (/ (ccl::foreign-type-alignment
233 (ccl::parse-foreign-type
234 (convert-foreign-type type-keyword
))) 8))
236 (defun convert-foreign-funcall-types (args)
237 "Convert foreign types for a call to FOREIGN-FUNCALL."
238 (loop for
(type arg
) on args by
#'cddr
239 collect
(convert-foreign-type type
)
242 (defun convert-external-name (name)
243 "Add an underscore to NAME if necessary for the ABI."
244 #+darwinppc-target
(concatenate 'string
"_" name
)
245 #-darwinppc-target name
)
247 (defmacro %foreign-funcall
(function-name args
&key library calling-convention
)
248 "Perform a foreign function call, document it more later."
249 (declare (ignore library calling-convention
))
251 ,(convert-external-name function-name
)
252 ,@(convert-foreign-funcall-types args
)))
254 (defmacro %foreign-funcall-pointer
(ptr args
&key calling-convention
)
255 (declare (ignore calling-convention
))
256 `(ff-call ,ptr
,@(convert-foreign-funcall-types args
)))
260 ;;; The *CALLBACKS* hash table maps CFFI callback names to OpenMCL "macptr"
261 ;;; entry points. It is safe to store the pointers directly because
262 ;;; OpenMCL will update the address of these pointers when a saved image
263 ;;; is loaded (see CCL::RESTORE-PASCAL-FUNCTIONS).
264 (defvar *callbacks
* (make-hash-table))
266 ;;; Create a package to contain the symbols for callback functions. We
267 ;;; want to redefine callbacks with the same symbol so the internal data
268 ;;; structures are reused.
269 (defpackage #:cffi-callbacks
272 ;;; Intern a symbol in the CFFI-CALLBACKS package used to name the internal
273 ;;; callback for NAME.
274 (defun intern-callback (name)
275 (intern (format nil
"~A::~A" (package-name (symbol-package name
))
279 (defmacro %defcallback
(name rettype arg-names arg-types body
280 &key calling-convention
)
281 (declare (ignore calling-convention
))
282 (let ((cb-name (intern-callback name
)))
284 (defcallback ,cb-name
285 (,@(mapcan (lambda (sym type
)
286 (list (convert-foreign-type type
) sym
))
288 ,(convert-foreign-type rettype
))
290 (setf (gethash ',name
*callbacks
*) (symbol-value ',cb-name
)))))
292 (defun %callback
(name)
293 (or (gethash name
*callbacks
*)
294 (error "Undefined callback: ~S" name
)))
296 ;;;# Loading Foreign Libraries
298 (defun %load-foreign-library
(name path
)
299 "Load the foreign library NAME."
300 (declare (ignore name
))
301 (open-shared-library path
))
303 (defun %close-foreign-library
(name)
304 "Close the foreign library NAME."
305 (close-shared-library name
)) ; :completely t ?
307 (defun native-namestring (pathname)
308 (ccl::native-translated-namestring pathname
))
312 (defun %foreign-symbol-pointer
(name library
)
313 "Returns a pointer to a foreign symbol NAME."
314 (declare (ignore library
))
315 (foreign-symbol-address (convert-external-name name
)))