Coverage report: /home/luis/src/cffi/src/functions.lisp
Kind | Covered | All | % |
expression | 207 | 225 | 92.0 |
branch | 12 | 16 | 75.0 |
Key
Not instrumented
Executed
Not executed
Both branches taken
One branch taken
Neither branch taken
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)
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
187
syms arg-names arg-types return-type caller))))))
189
(defun %defcfun-varargs (lisp-name foreign-name return-type args options)
190
(with-unique-names (varargs)
191
(let ((arg-names (mapcar #'car args)))
192
`(defmacro ,lisp-name (,@arg-names &rest ,varargs)
193
`(foreign-funcall-varargs
194
,'(,foreign-name ,@options)
195
,,`(list ,@(loop for (name type) in args
196
collect `',type collect name))
200
;;; The following four functions take care of parsing DEFCFUN's first
201
;;; argument whose syntax can be one of:
205
;;; 3. \( string [symbol] options* )
206
;;; 4. \( symbol [string] options* )
208
;;; The string argument denotes the foreign function's name. The
209
;;; symbol argument is used to name the Lisp function. If one isn't
210
;;; present, its name is derived from the other. See the user
211
;;; documentation for an explanation of the derivation rules.
213
(defun lisp-name (spec &optional varp)
215
(list (if (keywordp (second spec))
216
(lisp-name (first spec) varp)
217
(if (symbolp (first spec))
219
(lisp-name (second spec) varp))))
221
(format nil (if varp "*~A*" "~A")
222
(canonicalize-symbol-name-case
223
(substitute #\- #\_ spec)))))
226
(defun foreign-name (spec &optional varp)
228
(list (if (stringp (second spec))
230
(foreign-name (first spec) varp)))
232
(symbol (let ((name (substitute #\_ #\-
233
(string-downcase (symbol-name spec)))))
235
(string-trim '(#\*) name)
238
(defun foreign-options (spec varp)
239
(let ((opts (if (listp spec)
240
(if (keywordp (second spec))
245
(funcall 'parse-defcvar-options opts)
246
(parse-function-options opts))))
248
(defun parse-name-and-options (spec &optional varp)
249
(values (lisp-name spec varp)
250
(foreign-name spec varp)
251
(foreign-options spec varp)))
253
;;; If we find a &REST token at the end of ARGS, it means this is a
254
;;; varargs foreign function therefore we define a lisp macro using
255
;;; %DEFCFUN-VARARGS. Otherwise, a lisp function is defined with
257
(defmacro defcfun (name-and-options return-type &body args)
258
"Defines a Lisp function that calls a foreign function."
259
(discard-docstring args)
260
(multiple-value-bind (lisp-name foreign-name options)
261
(parse-name-and-options name-and-options)
262
(if (eq (car (last args)) '&rest)
263
(%defcfun-varargs lisp-name foreign-name return-type
264
(butlast args) options)
265
(%defcfun lisp-name foreign-name return-type args options))))
267
;;;# Defining Callbacks
269
(defun inverse-translate-objects (args types declarations rettype call)
270
`(let (,@(loop for arg in args and type in types
271
collect (list arg (expand-from-foreign
272
arg (parse-type type)))))
274
,(expand-to-foreign call (parse-type rettype))))
276
(defun parse-defcallback-options (options)
277
(destructuring-bind (&key (calling-convention :cdecl)
278
(cconv calling-convention))
280
(list :calling-convention cconv)))
282
(defmacro defcallback (name-and-options return-type args &body body)
283
(multiple-value-bind (body docstring declarations)
285
(declare (ignore docstring))
286
(let ((arg-names (mapcar #'car args))
287
(arg-types (mapcar #'cadr args))
288
(name (car (ensure-list name-and-options)))
289
(options (cdr (ensure-list name-and-options))))
291
(%defcallback ,name ,(canonicalize-foreign-type return-type)
292
,arg-names ,(mapcar #'canonicalize-foreign-type arg-types)
293
,(inverse-translate-objects
294
arg-names arg-types declarations return-type
295
`(block ,name ,@body))
296
,@(parse-defcallback-options options))
299
(declaim (inline get-callback))
300
(defun get-callback (symbol)
303
(defmacro callback (name)