Coverage report: /home/luis/src/cffi/src/functions.lisp

KindCoveredAll%
expression207225 92.0
branch1216 75.0
Key
Not instrumented
Executed
Not executed
 
Both branches taken
One branch taken
Neither branch taken
1
 ;;;; -*- Mode: lisp; indent-tabs-mode: nil -*-
2
 ;;;
3
 ;;; functions.lisp --- High-level interface to foreign functions.
4
 ;;;
5
 ;;; Copyright (C) 2005-2006, James Bielman  <jamesjb@jamesjb.com>
6
 ;;; Copyright (C) 2005-2007, Luis Oliveira  <loliveira@common-lisp.net>
7
 ;;;
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:
15
 ;;;
16
 ;;; The above copyright notice and this permission notice shall be
17
 ;;; included in all copies or substantial portions of the Software.
18
 ;;;
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.
27
 ;;;
28
 
29
 (in-package #:cffi)
30
 
31
 ;;;# Calling Foreign Functions
32
 ;;;
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.
37
 ;;;
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.
42
 
43
 (defun translate-objects (syms args types rettype call-form)
44
   "Helper function for FOREIGN-FUNCALL and DEFCFUN."
45
   (if (null args)
46
       (expand-from-foreign call-form (parse-type rettype))
47
       (expand-to-foreign-dyn
48
        (car args) (car syms)
49
        (list (translate-objects (cdr syms) (cdr args)
50
                                 (cdr types) rettype call-form))
51
        (parse-type (car types)))))
52
 
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)))))
62
 
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))
68
       options
69
     (list* :calling-convention
70
            (or cconv
71
                (when libraryp
72
                  (let ((lib-options (foreign-library-options
73
                                      (get-foreign-library library))))
74
                    (getf lib-options :cconv
75
                          (getf lib-options :calling-convention))))
76
                :cdecl)
77
            ;; Don't pass the library option if we're dealing with
78
            ;; FOREIGN-FUNCALL-POINTER.
79
            (unless pointer
80
              (list :library library)))))
81
 
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))))
86
       (translate-objects
87
        syms fargs types rettype
88
        `(,(if pointerp '%foreign-funcall-pointer '%foreign-funcall)
89
          ,thing
90
          (,@(mapcan #'list ctypes syms)
91
             ,(canonicalize-foreign-type rettype))
92
          ,@(parse-function-options options :pointer pointerp))))))
93
 
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)))
99
 
100
 (defmacro foreign-funcall-pointer (pointer options &rest args)
101
   (foreign-funcall-form pointer options args t))
102
 
103
 (defun promote-varargs-type (builtin-type)
104
   "Default argument promotions."
105
   (case builtin-type
106
     (:float :double)
107
     ((:char :short) :int)
108
     ((:unsigned-char :unsigned-short) :unsigned-int)
109
     (t builtin-type)))
110
 
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))))
118
         (translate-objects
119
          (append fixed-syms varargs-syms)
120
          (append fixed-fargs varargs-fargs)
121
          (append fixed-types varargs-types)
122
          rettype
123
          `(,(if pointerp '%foreign-funcall-pointer '%foreign-funcall)
124
             ,thing
125
             ,(append
126
               (mapcan #'list
127
                       (nconc fixed-ctypes
128
                              (mapcar #'promote-varargs-type varargs-ctypes))
129
                       (append fixed-syms
130
                               (loop for sym in varargs-syms
131
                                     and type in varargs-ctypes
132
                                     if (eq type :float)
133
                                     collect `(float ,sym 1.0d0)
134
                                     else collect sym)))
135
               (list (canonicalize-foreign-type rettype)))
136
             ,@options))))))
137
 
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
145
                                    &rest varargs)
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)))
151
 
152
 (defmacro foreign-funcall-pointer-varargs (pointer options fixed-args
153
                                            &rest varargs)
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))
157
 
158
 ;;;# Defining Foreign Functions
159
 ;;;
160
 ;;; The DEFCFUN macro provides a declarative interface for defining
161
 ;;; Lisp functions that call foreign functions.
162
 
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))
169
       (values
170
        '()
171
        `(%foreign-funcall ,name ,(append (mapcan #'list types args)
172
                                          (list rettype))
173
                           ,@options)))))
174
 
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)
183
       `(progn
184
          ,prelude
185
          (defun ,lisp-name ,arg-names
186
            ,(translate-objects
187
              syms arg-names arg-types return-type caller))))))
188
 
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))
197
            ,@,varargs
198
            ,',return-type)))))
199
 
200
 ;;; The following four functions take care of parsing DEFCFUN's first
201
 ;;; argument whose syntax can be one of:
202
 ;;;
203
 ;;;     1.  string
204
 ;;;     2.  symbol
205
 ;;;     3.  \( string [symbol] options* )
206
 ;;;     4.  \( symbol [string] options* )
207
 ;;;
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.
212
 
213
 (defun lisp-name (spec &optional varp)
214
   (etypecase spec
215
     (list (if (keywordp (second spec))
216
               (lisp-name (first spec) varp)
217
               (if (symbolp (first spec))
218
                   (first spec)
219
                   (lisp-name (second spec) varp))))
220
     (string (intern
221
              (format nil (if varp "*~A*" "~A")
222
                      (canonicalize-symbol-name-case
223
                       (substitute #\- #\_ spec)))))
224
     (symbol spec)))
225
 
226
 (defun foreign-name (spec &optional varp)
227
   (etypecase spec
228
     (list (if (stringp (second spec))
229
               (second spec)
230
               (foreign-name (first spec) varp)))
231
     (string spec)
232
     (symbol (let ((name (substitute #\_ #\-
233
                                     (string-downcase (symbol-name spec)))))
234
               (if varp
235
                   (string-trim '(#\*) name)
236
                   name)))))
237
 
238
 (defun foreign-options (spec varp)
239
   (let ((opts (if (listp spec)
240
                   (if (keywordp (second spec))
241
                       (cdr spec)
242
                       (cddr spec))
243
                   nil)))
244
     (if varp
245
         (funcall 'parse-defcvar-options opts)
246
         (parse-function-options opts))))
247
 
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)))
252
 
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
256
 ;;; %DEFCFUN.
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))))
266
 
267
 ;;;# Defining Callbacks
268
 
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)))))
273
      ,@declarations
274
      ,(expand-to-foreign call (parse-type rettype))))
275
 
276
 (defun parse-defcallback-options (options)
277
   (destructuring-bind (&key (calling-convention :cdecl)
278
                             (cconv calling-convention))
279
       options
280
     (list :calling-convention cconv)))
281
 
282
 (defmacro defcallback (name-and-options return-type args &body body)
283
   (multiple-value-bind (body docstring declarations)
284
       (parse-body body)
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))))
290
       `(progn
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))
297
          ',name))))
298
 
299
 (declaim (inline get-callback))
300
 (defun get-callback (symbol)
301
   (%callback symbol))
302
 
303
 (defmacro callback (name)
304
   `(%callback ',name))
305