1 ;;;; -*- Mode: lisp; indent-tabs-mode: nil -*-
3 ;;; cffi-ecl.lisp --- ECL backend for CFFI.
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
#:cffi-utils
)
33 #:canonicalize-symbol-name-case
39 #:with-foreign-pointer
48 #:%foreign-funcall-pointer
49 #:%foreign-type-alignment
51 #:%load-foreign-library
53 #:make-shareable-byte-vector
54 #:with-pointer-to-vector-data
57 #:%foreign-symbol-pointer
))
59 (in-package #:cffi-sys
)
63 (eval-when (:compile-toplevel
:load-toplevel
:execute
)
64 (mapc (lambda (feature) (pushnew feature
*features
*))
65 '(;; Backend mis-features.
66 cffi-features
:no-long-long
67 cffi-features
:flat-namespace
69 #+:darwin cffi-features
:darwin
70 #+:darwin cffi-features
:unix
71 #+:unix cffi-features
:unix
72 #+:win32 cffi-features
:windows
73 ;; XXX: figure out a way to get a X86 feature
74 ;;#+:athlon cffi-features:x86
75 #+:powerpc7450 cffi-features
:ppc32
80 (defun canonicalize-symbol-name-case (name)
81 (declare (string name
))
86 (defun %foreign-alloc
(size)
87 "Allocate SIZE bytes of foreign-addressable memory."
88 (si:allocate-foreign-data
:void size
))
90 (defun foreign-free (ptr)
91 "Free a pointer PTR allocated by FOREIGN-ALLOC."
92 (si:free-foreign-data ptr
))
94 (defmacro with-foreign-pointer
((var size
&optional size-var
) &body body
)
95 "Bind VAR to SIZE bytes of foreign memory during BODY. The
96 pointer in VAR is invalid beyond the dynamic extent of BODY, and
97 may be stack-allocated if supported by the implementation. If
98 SIZE-VAR is supplied, it will be bound to SIZE during BODY."
100 (setf size-var
(gensym "SIZE")))
101 `(let* ((,size-var
,size
)
102 (,var
(%foreign-alloc
,size-var
)))
105 (foreign-free ,var
))))
107 ;;;# Misc. Pointer Operations
109 (deftype foreign-pointer
()
112 (defun null-pointer ()
113 "Construct and return a null pointer."
114 (si:allocate-foreign-data
:void
0))
116 (defun null-pointer-p (ptr)
117 "Return true if PTR is a null pointer."
118 (si:null-pointer-p ptr
))
120 (defun inc-pointer (ptr offset
)
121 "Return a pointer OFFSET bytes past PTR."
122 (ffi:make-pointer
(+ (ffi:pointer-address ptr
) offset
) :void
))
124 (defun pointerp (ptr)
125 "Return true if PTR is a foreign pointer."
126 (typep ptr
'si
:foreign-data
))
128 (defun pointer-eq (ptr1 ptr2
)
129 "Return true if PTR1 and PTR2 point to the same address."
130 (= (ffi:pointer-address ptr1
) (ffi:pointer-address ptr2
)))
132 (defun make-pointer (address)
133 "Return a pointer pointing to ADDRESS."
134 (ffi:make-pointer address
:void
))
136 (defun pointer-address (ptr)
137 "Return the address pointed to by PTR."
138 (ffi:pointer-address ptr
))
142 (defun %mem-ref
(ptr type
&optional
(offset 0))
143 "Dereference an object of TYPE at OFFSET bytes from PTR."
144 (let* ((type (cffi-type->ecl-type type
))
145 (type-size (ffi:size-of-foreign-type type
)))
146 (si:foreign-data-ref-elt
147 (si:foreign-data-recast ptr
(+ offset type-size
) :void
) offset type
)))
149 (defun %mem-set
(value ptr type
&optional
(offset 0))
150 "Set an object of TYPE at OFFSET bytes from PTR."
151 (let* ((type (cffi-type->ecl-type type
))
152 (type-size (ffi:size-of-foreign-type type
)))
153 (si:foreign-data-set-elt
154 (si:foreign-data-recast ptr
(+ offset type-size
) :void
)
159 (defconstant +translation-table
+
160 '((:char
:byte
"char")
161 (:unsigned-char
:unsigned-byte
"unsigned char")
162 (:short
:short
"short")
163 (:unsigned-short
:unsigned-short
"unsigned short")
165 (:unsigned-int
:unsigned-int
"unsigned int")
167 (:unsigned-long
:unsigned-long
"unsigned long")
168 (:float
:float
"float")
169 (:double
:double
"double")
170 (:pointer
:pointer-void
"void*")
171 (:void
:void
"void")))
173 (defun cffi-type->ecl-type
(type-keyword)
174 "Convert a CFFI type keyword to an ECL type keyword."
175 (or (second (find type-keyword
+translation-table
+ :key
#'first
))
176 (error "~S is not a valid CFFI type" type-keyword
)))
178 (defun ecl-type->c-type
(type-keyword)
179 "Convert a CFFI type keyword to an valid C type keyword."
180 (or (third (find type-keyword
+translation-table
+ :key
#'second
))
181 (error "~S is not a valid CFFI type" type-keyword
)))
183 (defun %foreign-type-size
(type-keyword)
184 "Return the size in bytes of a foreign type."
185 (nth-value 0 (ffi:size-of-foreign-type
186 (cffi-type->ecl-type type-keyword
))))
188 (defun %foreign-type-alignment
(type-keyword)
189 "Return the alignment in bytes of a foreign type."
190 (nth-value 1 (ffi:size-of-foreign-type
191 (cffi-type->ecl-type type-keyword
))))
193 ;;;# Calling Foreign Functions
195 (defconstant +ecl-inline-codes
+ "#0,#1,#2,#3,#4,#5,#6,#7,#8,#9,#a,#b,#c,#d,#e,#f,#g,#h,#i,#j,#k,#l,#m,#n,#o,#p,#q,#r,#s,#t,#u,#v,#w,#x,#y,#z")
197 (defun produce-function-pointer-call (pointer types values return-type
)
199 (if (stringp pointer
)
200 (produce-function-pointer-call
201 `(%foreign-symbol-pointer
,pointer nil
) types values return-type
)
203 ,(list* pointer values
)
204 ,(list* :pointer-void types
) ,return-type
205 ,(with-output-to-string (s)
206 (let ((types (mapcar #'ecl-type-
>c-type types
)))
207 ;; On AMD64, the following code only works with the extra
208 ;; argument ",...". If this is not present, functions
209 ;; like sprintf do not work
210 (format s
"((~A (*)(~@[~{~A,~}...~]))(#0))(~A)"
211 (ecl-type->c-type return-type
) types
212 (subseq +ecl-inline-codes
+ 3
213 (max 3 (+ 2 (* (length values
) 3)))))))
214 :one-liner t
:side-effects t
))
217 (when (stringp pointer
)
218 (setf pointer
`(%foreign-symbol-pointer
,pointer nil
)))
219 `(si:call-cfun
,pointer
,return-type
(list ,@types
) (list ,@values
))))
222 (defun foreign-funcall-parse-args (args)
223 "Return three values, lists of arg types, values, and result type."
224 (let ((return-type :void
))
225 (loop for
(type arg
) on args by
#'cddr
226 if arg collect
(cffi-type->ecl-type type
) into types
227 and collect arg into values
228 else do
(setf return-type
(cffi-type->ecl-type type
))
229 finally
(return (values types values return-type
)))))
231 (defmacro %foreign-funcall
(name args
&key library calling-convention
)
232 "Call a foreign function."
233 (declare (ignore library calling-convention
))
234 (multiple-value-bind (types values return-type
)
235 (foreign-funcall-parse-args args
)
236 (produce-function-pointer-call name types values return-type
)))
238 (defmacro %foreign-funcall-pointer
(ptr args
&key calling-convention
)
239 "Funcall a pointer to a foreign function."
240 (declare (ignore calling-convention
))
241 (multiple-value-bind (types values return-type
)
242 (foreign-funcall-parse-args args
)
243 (produce-function-pointer-call ptr types values return-type
)))
245 ;;;# Foreign Libraries
247 (defun %load-foreign-library
(name path
)
248 "Load a foreign library."
249 (declare (ignore name
))
250 #-dffi
(error "LOAD-FOREIGN-LIBRARY requires ECL's DFFI support. Use ~
251 FFI:LOAD-FOREIGN-LIBRARY with a constant argument instead.")
252 #+dffi
(si:load-foreign-module path
))
254 (defun %close-foreign-library
(handle)
255 (error "%CLOSE-FOREIGN-LIBRARY unimplemented."))
257 (defun native-namestring (pathname)
258 (namestring pathname
))
262 ;;; Create a package to contain the symbols for callback functions.
263 ;;; We want to redefine callbacks with the same symbol so the internal
264 ;;; data structures are reused.
265 (defpackage #:cffi-callbacks
268 (defvar *callbacks
* (make-hash-table))
270 ;;; Intern a symbol in the CFFI-CALLBACKS package used to name the
271 ;;; internal callback for NAME.
272 (eval-when (:compile-toplevel
:load-toplevel
:execute
)
273 (defun intern-callback (name)
274 (intern (format nil
"~A::~A" (package-name (symbol-package name
))
278 (defmacro %defcallback
(name rettype arg-names arg-types body
279 &key calling-convention
)
280 (declare (ignore calling-convention
))
281 (let ((cb-name (intern-callback name
)))
283 (ffi:defcallback
(,cb-name
:cdecl
)
284 ,(cffi-type->ecl-type rettype
)
285 ,(mapcar #'list arg-names
286 (mapcar #'cffi-type-
>ecl-type arg-types
))
288 (setf (gethash ',name
*callbacks
*) ',cb-name
))))
290 (defun %callback
(name)
291 (multiple-value-bind (symbol winp
)
292 (gethash name
*callbacks
*)
294 (error "Undefined callback: ~S" name
))
295 (ffi:callback symbol
)))
299 (defun %foreign-symbol-pointer
(name library
)
300 "Returns a pointer to a foreign symbol NAME."
301 (declare (ignore library
))
302 (si:find-foreign-symbol name
:default
:pointer-void
0))