1 ;;;; -*- Mode: lisp; indent-tabs-mode: nil -*-
3 ;;; functions.lisp --- High-level interface to foreign functions.
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.
31 ;;;# Calling Foreign Functions
33 ;;; FOREIGN-FUNCALL is the main primitive for calling foreign
34 ;;; functions. It converts each argument based on the installed
35 ;;; translators for its type, then passes the resulting list to
36 ;;; CFFI-SYS:%FOREIGN-FUNCALL.
38 ;;; For implementation-specific reasons, DEFCFUN doesn't use
39 ;;; FOREIGN-FUNCALL directly and might use something else (passed to
40 ;;; TRANSLATE-OBJECTS as the CALL-FORM argument) instead of
41 ;;; CFFI-SYS:%FOREIGN-FUNCALL to call the foreign-function.
43 (defun translate-objects (syms args types rettype call-form
)
44 "Helper function for FOREIGN-FUNCALL and DEFCFUN."
46 (expand-from-foreign call-form
(parse-type rettype
))
47 (expand-to-foreign-dyn
49 (list (translate-objects (cdr syms
) (cdr args
)
50 (cdr types
) rettype call-form
))
51 (parse-type (car types
)))))
53 (defun parse-args-and-types (args)
54 "Returns 4 values. Types, canonicalized types, args and return type."
55 (let ((return-type :void
))
56 (loop for
(type arg
) on args by
#'cddr
57 if arg collect type into types
58 and collect
(canonicalize-foreign-type type
) into ctypes
59 and collect arg into fargs
60 else do
(setf return-type type
)
61 finally
(return (values types ctypes fargs return-type
)))))
63 ;;; While the options passed directly to DEFCFUN/FOREIGN-FUNCALL have
64 ;;; precedence, we also grab its library's options, if possible.
65 (defun parse-function-options (options &key pointer
)
66 (destructuring-bind (&key
(library :default libraryp
) calling-convention
67 (cconv calling-convention
))
69 (list* :calling-convention
72 (let ((lib-options (foreign-library-options
73 (get-foreign-library library
))))
74 (getf lib-options
:cconv
75 (getf lib-options
:calling-convention
))))
77 ;; Don't pass the library option if we're dealing with
78 ;; FOREIGN-FUNCALL-POINTER.
80 (list :library library
)))))
82 (defun foreign-funcall-form (thing options args pointerp
)
83 (multiple-value-bind (types ctypes fargs rettype
)
84 (parse-args-and-types args
)
85 (let ((syms (make-gensym-list (length fargs
))))
87 syms fargs types rettype
88 `(,(if pointerp
'%foreign-funcall-pointer
'%foreign-funcall
)
90 (,@(mapcan #'list ctypes syms
)
91 ,(canonicalize-foreign-type rettype
))
92 ,@(parse-function-options options
:pointer pointerp
))))))
94 (defmacro foreign-funcall
(name-and-options &rest args
)
95 "Wrapper around %FOREIGN-FUNCALL that translates its arguments."
96 (let ((name (car (ensure-list name-and-options
)))
97 (options (cdr (ensure-list name-and-options
))))
98 (foreign-funcall-form name options args nil
)))
100 (defmacro foreign-funcall-pointer
(pointer options
&rest args
)
101 (foreign-funcall-form pointer options args t
))
103 (defun promote-varargs-type (builtin-type)
104 "Default argument promotions."
107 ((:char
:short
) :int
)
108 ((:unsigned-char
:unsigned-short
) :unsigned-int
)
111 (defun foreign-funcall-varargs-form (thing options fixed-args varargs pointerp
)
112 (multiple-value-bind (fixed-types fixed-ctypes fixed-fargs
)
113 (parse-args-and-types fixed-args
)
114 (multiple-value-bind (varargs-types varargs-ctypes varargs-fargs rettype
)
115 (parse-args-and-types varargs
)
116 (let ((fixed-syms (make-gensym-list (length fixed-fargs
)))
117 (varargs-syms (make-gensym-list (length varargs-fargs
))))
119 (append fixed-syms varargs-syms
)
120 (append fixed-fargs varargs-fargs
)
121 (append fixed-types varargs-types
)
123 `(,(if pointerp
'%foreign-funcall-pointer
'%foreign-funcall
)
128 (mapcar #'promote-varargs-type varargs-ctypes
))
130 (loop for sym in varargs-syms
131 and type in varargs-ctypes
133 collect
`(float ,sym
1.0d0
)
135 (list (canonicalize-foreign-type rettype
)))
138 ;;; For now, the only difference between this macro and
139 ;;; FOREIGN-FUNCALL is that it does argument promotion for that
140 ;;; variadic argument. This could be useful to call an hypothetical
141 ;;; %foreign-funcall-varargs on some hypothetical lisp on an
142 ;;; hypothetical platform that has different calling conventions for
143 ;;; varargs functions. :-)
144 (defmacro foreign-funcall-varargs
(name-and-options fixed-args
146 "Wrapper around %FOREIGN-FUNCALL that translates its arguments
147 and does type promotion for the variadic arguments."
148 (let ((name (car (ensure-list name-and-options
)))
149 (options (cdr (ensure-list name-and-options
))))
150 (foreign-funcall-varargs-form name options fixed-args varargs nil
)))
152 (defmacro foreign-funcall-pointer-varargs
(pointer options fixed-args
154 "Wrapper around %FOREIGN-FUNCALL-POINTER that translates its
155 arguments and does type promotion for the variadic arguments."
156 (foreign-funcall-varargs-form pointer options fixed-args varargs t
))
158 ;;;# Defining Foreign Functions
160 ;;; The DEFCFUN macro provides a declarative interface for defining
161 ;;; Lisp functions that call foreign functions.
163 ;; If cffi-sys doesn't provide a defcfun-helper-forms,
164 ;; we define one that uses %foreign-funcall.
165 (eval-when (:compile-toplevel
:load-toplevel
:execute
)
166 (unless (fboundp 'defcfun-helper-forms
)
167 (defun defcfun-helper-forms (name lisp-name rettype args types options
)
168 (declare (ignore lisp-name
))
171 `(%foreign-funcall
,name
,(append (mapcan #'list types args
)
175 (defun %defcfun
(lisp-name foreign-name return-type args options docstring
)
176 (let ((arg-names (mapcar #'car args
))
177 (arg-types (mapcar #'cadr args
))
178 (syms (make-gensym-list (length args
))))
179 (multiple-value-bind (prelude caller
)
180 (defcfun-helper-forms
181 foreign-name lisp-name
(canonicalize-foreign-type return-type
)
182 syms
(mapcar #'canonicalize-foreign-type arg-types
) options
)
185 (defun ,lisp-name
,arg-names
186 ,@(ensure-list docstring
)
188 syms arg-names arg-types return-type caller
))))))
190 (defun %defcfun-varargs
(lisp-name foreign-name return-type args options doc
)
191 (with-unique-names (varargs)
192 (let ((arg-names (mapcar #'car args
)))
193 `(defmacro ,lisp-name
(,@arg-names
&rest
,varargs
)
195 `(foreign-funcall-varargs
196 ,'(,foreign-name
,@options
)
197 ,,`(list ,@(loop for
(name type
) in args
198 collect
`',type collect name
))
202 ;;; The following four functions take care of parsing DEFCFUN's first
203 ;;; argument whose syntax can be one of:
207 ;;; 3. \( string [symbol] options* )
208 ;;; 4. \( symbol [string] options* )
210 ;;; The string argument denotes the foreign function's name. The
211 ;;; symbol argument is used to name the Lisp function. If one isn't
212 ;;; present, its name is derived from the other. See the user
213 ;;; documentation for an explanation of the derivation rules.
215 (defun lisp-name (spec &optional varp
)
217 (list (if (keywordp (second spec
))
218 (lisp-name (first spec
) varp
)
219 (if (symbolp (first spec
))
221 (lisp-name (second spec
) varp
))))
223 (format nil
(if varp
"*~A*" "~A")
224 (canonicalize-symbol-name-case
225 (substitute #\-
#\_ spec
)))))
228 (defun foreign-name (spec &optional varp
)
230 (list (if (stringp (second spec
))
232 (foreign-name (first spec
) varp
)))
234 (symbol (let ((name (substitute #\_
#\-
235 (string-downcase (symbol-name spec
)))))
237 (string-trim '(#\
*) name
)
240 (defun foreign-options (spec varp
)
241 (let ((opts (if (listp spec
)
242 (if (keywordp (second spec
))
247 (funcall 'parse-defcvar-options opts
)
248 (parse-function-options opts
))))
250 (defun parse-name-and-options (spec &optional varp
)
251 (values (lisp-name spec varp
)
252 (foreign-name spec varp
)
253 (foreign-options spec varp
)))
255 ;;; If we find a &REST token at the end of ARGS, it means this is a
256 ;;; varargs foreign function therefore we define a lisp macro using
257 ;;; %DEFCFUN-VARARGS. Otherwise, a lisp function is defined with
259 (defmacro defcfun
(name-and-options return-type
&body args
)
260 "Defines a Lisp function that calls a foreign function."
261 (let ((docstring (when (stringp (car args
)) (pop args
))))
262 (multiple-value-bind (lisp-name foreign-name options
)
263 (parse-name-and-options name-and-options
)
264 (if (eq (car (last args
)) '&rest
)
265 (%defcfun-varargs lisp-name foreign-name return-type
266 (butlast args
) options docstring
)
267 (%defcfun lisp-name foreign-name return-type args options
270 ;;;# Defining Callbacks
272 (defun inverse-translate-objects (args types declarations rettype call
)
273 `(let (,@(loop for arg in args and type in types
274 collect
(list arg
(expand-from-foreign
275 arg
(parse-type type
)))))
277 ,(expand-to-foreign call
(parse-type rettype
))))
279 (defun parse-defcallback-options (options)
280 (destructuring-bind (&key
(calling-convention :cdecl
)
281 (cconv calling-convention
))
283 (list :calling-convention cconv
)))
285 (defmacro defcallback
(name-and-options return-type args
&body body
)
286 (multiple-value-bind (body docstring declarations
)
288 (declare (ignore docstring
))
289 (let ((arg-names (mapcar #'car args
))
290 (arg-types (mapcar #'cadr args
))
291 (name (car (ensure-list name-and-options
)))
292 (options (cdr (ensure-list name-and-options
))))
294 (%defcallback
,name
,(canonicalize-foreign-type return-type
)
295 ,arg-names
,(mapcar #'canonicalize-foreign-type arg-types
)
296 ,(inverse-translate-objects
297 arg-names arg-types declarations return-type
298 `(block ,name
,@body
))
299 ,@(parse-defcallback-options options
))
302 (declaim (inline get-callback
))
303 (defun get-callback (symbol)
306 (defmacro callback
(name)