Coverage report: /home/ellis/.stash/quicklisp/dists/quicklisp/software/cffi-20250622-git/src/functions.lisp

KindCoveredAll%
expression0615 0.0
branch044 0.0
Key
Not instrumented
Conditionalized out
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 &optional indirect)
44
   "Helper function for FOREIGN-FUNCALL and DEFCFUN.  If 'indirect is T, all arguments are represented by foreign pointers, even those that can be represented by CL objects."
45
   (if (null args)
46
       (expand-from-foreign call-form (parse-type rettype))
47
       (funcall
48
        (if indirect
49
            #'expand-to-foreign-dyn-indirect
50
            #'expand-to-foreign-dyn)
51
        (car args) (car syms)
52
        (list (translate-objects (cdr syms) (cdr args)
53
                                 (cdr types) rettype call-form indirect))
54
        (parse-type (car types)))))
55
 
56
 (defun parse-args-and-types (args)
57
   "Returns 4 values: types, canonicalized types, args and return type."
58
   (let* ((len (length args))
59
          (return-type (if (oddp len) (lastcar args) :void)))
60
     (loop repeat (floor len 2)
61
           for (type arg) on args by #'cddr
62
           collect type into types
63
           collect (canonicalize-foreign-type type) into ctypes
64
           collect arg into fargs
65
           finally (return (values types ctypes fargs return-type)))))
66
 
67
 ;;; While the options passed directly to DEFCFUN/FOREIGN-FUNCALL have
68
 ;;; precedence, we also grab its library's options, if possible.
69
 (defun parse-function-options (options &key pointer)
70
   (destructuring-bind (&key (library :default libraryp)
71
                             (cconv nil cconv-p)
72
                             (calling-convention cconv calling-convention-p)
73
                             (convention calling-convention))
74
       options
75
     (when cconv-p
76
       (warn-obsolete-argument :cconv :convention))
77
     (when calling-convention-p
78
       (warn-obsolete-argument :calling-convention :convention))
79
     (list* :convention
80
            (or convention
81
                (when libraryp
82
                  (let ((lib-options (foreign-library-options
83
                                      (get-foreign-library library))))
84
                    (getf lib-options :convention)))
85
                :cdecl)
86
            ;; Don't pass the library option if we're dealing with
87
            ;; FOREIGN-FUNCALL-POINTER.
88
            (unless pointer
89
              (list :library library)))))
90
 
91
 (defun structure-by-value-p (ctype)
92
   "A structure or union is to be called or returned by value."
93
   (let ((actual-type (ensure-parsed-base-type ctype)))
94
     (or (and (typep actual-type 'foreign-struct-type)
95
              (not (bare-struct-type-p actual-type)))
96
         #+cffi::no-long-long (typep actual-type 'emulated-llong-type))))
97
 
98
 (defun fn-call-by-value-p (argument-types return-type)
99
   "One or more structures in the arguments or return from the function are called by value."
100
   (or (some 'structure-by-value-p argument-types)
101
       (structure-by-value-p return-type)))
102
 
103
 (defvar *foreign-structures-by-value*
104
   (lambda (&rest args)
105
     (declare (ignore args))
106
     (restart-case
107
         (error "Unable to call structures by value without cffi-libffi loaded.")
108
       (load-cffi-libffi () :report "Load cffi-libffi."
109
         (asdf:operate 'asdf:load-op 'cffi-libffi))))
110
   "A function that produces a form suitable for calling structures by value.")
111
 
112
 (defun foreign-funcall-form (thing options args pointerp)
113
   (multiple-value-bind (types ctypes fargs rettype)
114
       (parse-args-and-types args)
115
     (let ((syms (make-gensym-list (length fargs)))
116
           (fsbvp (fn-call-by-value-p ctypes rettype)))
117
       (if fsbvp
118
           ;; Structures by value call through *foreign-structures-by-value*
119
           (funcall *foreign-structures-by-value*
120
                    thing
121
                    fargs
122
                    syms
123
                    types
124
                    rettype
125
                    ctypes
126
                    pointerp)
127
           (translate-objects
128
            syms fargs types rettype
129
            `(,(if pointerp '%foreign-funcall-pointer '%foreign-funcall)
130
              ;; No structures by value, direct call
131
              ,thing
132
              (,@(mapcan #'list ctypes syms)
133
               ,(canonicalize-foreign-type rettype))
134
              ,@(parse-function-options options :pointer pointerp)))))))
135
 
136
 (defmacro foreign-funcall (name-and-options &rest args)
137
   "Wrapper around %FOREIGN-FUNCALL that translates its arguments."
138
   (let ((name (car (ensure-list name-and-options)))
139
         (options (cdr (ensure-list name-and-options))))
140
     (foreign-funcall-form name options args nil)))
141
 
142
 (defmacro foreign-funcall-pointer (pointer options &rest args)
143
   (foreign-funcall-form pointer options args t))
144
 
145
 (defun promote-varargs-type (builtin-type)
146
   "Default argument promotions."
147
   (case builtin-type
148
     (:float :double)
149
     ((:char :short) :int)
150
     ((:unsigned-char :unsigned-short) :unsigned-int)
151
     (t builtin-type)))
152
 
153
 ;; If cffi-sys doesn't provide a %foreign-funcall-varargs macros we
154
 ;; define one that use %foreign-funcall.
155
 (eval-when (:compile-toplevel :load-toplevel :execute)
156
   (unless (fboundp '%foreign-funcall-varargs)
157
     (defmacro %foreign-funcall-varargs (name fixed-args varargs
158
                                         &rest args &key convention library)
159
       (declare (ignore convention library))
160
       `(%foreign-funcall ,name ,(append fixed-args varargs) ,@args)))
161
   (unless (fboundp '%foreign-funcall-pointer-varargs)
162
     (defmacro %foreign-funcall-pointer-varargs (pointer fixed-args varargs
163
                                                 &rest args &key convention)
164
       (declare (ignore convention))
165
       `(%foreign-funcall-pointer ,pointer ,(append fixed-args varargs) ,@args))))
166
 
167
 (defun foreign-funcall-varargs-form (thing options fixed-args varargs pointerp)
168
   (multiple-value-bind (fixed-types fixed-ctypes fixed-fargs)
169
       (parse-args-and-types fixed-args)
170
     (multiple-value-bind (varargs-types varargs-ctypes varargs-fargs rettype)
171
         (parse-args-and-types varargs)
172
       (let ((fixed-syms (make-gensym-list (length fixed-fargs)))
173
             (varargs-syms (make-gensym-list (length varargs-fargs))))
174
         (translate-objects
175
          (append fixed-syms varargs-syms)
176
          (append fixed-fargs varargs-fargs)
177
          (append fixed-types varargs-types)
178
          rettype
179
          `(,(if pointerp '%foreign-funcall-pointer-varargs '%foreign-funcall-varargs)
180
             ,thing
181
             ,(mapcan #'list fixed-ctypes fixed-syms)
182
             ,(append
183
               (mapcan #'list
184
                       (mapcar #'promote-varargs-type varargs-ctypes)
185
                       (loop for sym in varargs-syms
186
                             and type in varargs-ctypes
187
                             if (eq type :float)
188
                               collect `(float ,sym 1.0d0)
189
                             else collect sym))
190
               (list (canonicalize-foreign-type rettype)))
191
             ,@options))))))
192
 
193
 (defmacro foreign-funcall-varargs (name-and-options fixed-args
194
                                    &rest varargs)
195
   "Wrapper around %FOREIGN-FUNCALL that translates its arguments
196
 and does type promotion for the variadic arguments."
197
   (let ((name (car (ensure-list name-and-options)))
198
         (options (cdr (ensure-list name-and-options))))
199
     (foreign-funcall-varargs-form name options fixed-args varargs nil)))
200
 
201
 (defmacro foreign-funcall-pointer-varargs (pointer options fixed-args
202
                                            &rest varargs)
203
   "Wrapper around %FOREIGN-FUNCALL-POINTER that translates its
204
 arguments and does type promotion for the variadic arguments."
205
   (foreign-funcall-varargs-form pointer options fixed-args varargs t))
206
 
207
 ;;;# Defining Foreign Functions
208
 ;;;
209
 ;;; The DEFCFUN macro provides a declarative interface for defining
210
 ;;; Lisp functions that call foreign functions.
211
 
212
 ;; If cffi-sys doesn't provide a defcfun-helper-forms,
213
 ;; we define one that uses %foreign-funcall.
214
 (eval-when (:compile-toplevel :load-toplevel :execute)
215
   (unless (fboundp 'defcfun-helper-forms)
216
     (defun defcfun-helper-forms (name lisp-name rettype args types options)
217
       (declare (ignore lisp-name))
218
       (values
219
        '()
220
        `(%foreign-funcall ,name ,(append (mapcan #'list types args)
221
                                          (list rettype))
222
                           ,@options)))))
223
 
224
 (defun %defcfun (lisp-name foreign-name return-type args options docstring)
225
   (let* ((arg-names (mapcar #'first args))
226
          (arg-types (mapcar #'second args))
227
          (syms (make-gensym-list (length args)))
228
          (call-by-value (fn-call-by-value-p arg-types return-type)))
229
     (multiple-value-bind (prelude caller)
230
         (if call-by-value
231
             (values nil nil)
232
             (defcfun-helper-forms
233
              foreign-name lisp-name (canonicalize-foreign-type return-type)
234
              syms (mapcar #'canonicalize-foreign-type arg-types) options))
235
       `(progn
236
          ,prelude
237
          (defun ,lisp-name ,arg-names
238
            #+cmucl (declare (notinline alien::%heap-alien))
239
            ,@(ensure-list docstring)
240
            ,(if call-by-value
241
                 `(foreign-funcall
242
                   ,(cons foreign-name options)
243
                   ,@(append (mapcan #'list arg-types arg-names)
244
                             (list return-type)))
245
                 (translate-objects
246
                  syms arg-names arg-types return-type caller)))))))
247
 
248
 (defun %defcfun-varargs (lisp-name foreign-name return-type args options doc)
249
   (with-unique-names (varargs)
250
     (let ((arg-names (mapcar #'car args)))
251
       `(defmacro ,lisp-name (,@arg-names &rest ,varargs)
252
          ,@(ensure-list doc)
253
          `(foreign-funcall-varargs
254
            ,'(,foreign-name ,@options)
255
            ,,`(list ,@(loop for (name type) in args
256
                             collect `',type collect name))
257
            ,@,varargs
258
            ,',return-type)))))
259
 
260
 (defgeneric translate-underscore-separated-name (name)
261
   (:method ((name string))
262
     (values (intern (canonicalize-symbol-name-case (substitute #\- #\_ name)))))
263
   (:method ((name symbol))
264
     (substitute #\_ #\- (string-downcase (symbol-name name)))))
265
 
266
 (defun collapse-prefix (l special-words)
267
   (unless (null l)
268
     (multiple-value-bind (newpre skip) (check-prefix l special-words)
269
       (cons newpre (collapse-prefix (nthcdr skip l) special-words)))))
270
 
271
 (defun check-prefix (l special-words)
272
   (let ((pl (loop for i from (1- (length l)) downto 0
273
                   collect (apply #'concatenate 'simple-string (butlast l i)))))
274
     (loop for w in special-words
275
           for p = (position-if #'(lambda (s) (string= s w)) pl)
276
           when p do (return-from check-prefix (values (nth p pl) (1+ p))))
277
     (values (first l) 1)))
278
 
279
 (defgeneric translate-camelcase-name (name &key upper-initial-p special-words)
280
   (:method ((name string) &key upper-initial-p special-words)
281
     (declare (ignore upper-initial-p))
282
     (values (intern (reduce #'(lambda (s1 s2)
283
                                 (concatenate 'simple-string s1 "-" s2))
284
                             (mapcar #'string-upcase
285
                                     (collapse-prefix
286
                                      (split-if #'(lambda (ch)
287
                                                    (or (upper-case-p ch)
288
                                                        (digit-char-p ch)))
289
                                                name)
290
                                      special-words))))))
291
   (:method ((name symbol) &key upper-initial-p special-words)
292
     (apply #'concatenate
293
            'string
294
            (loop for str in (split-if #'(lambda (ch) (eq ch #\-))
295
                                           (string name)
296
                                       :elide)
297
                  for first-word-p = t then nil
298
                  for e = (member str special-words
299
                                  :test #'equal :key #'string-upcase)
300
                  collect (cond
301
                            ((and first-word-p (not upper-initial-p))
302
                             (string-downcase str))
303
                            (e (first e))
304
                            (t (string-capitalize str)))))))
305
 
306
 (defgeneric translate-name-from-foreign (foreign-name package &optional varp)
307
   (:method (foreign-name package &optional varp)
308
     (declare (ignore package))
309
     (let ((sym (translate-underscore-separated-name foreign-name)))
310
       (if varp
311
           (values (intern (format nil "*~A*"
312
                                   (canonicalize-symbol-name-case
313
                                    (symbol-name sym)))))
314
           sym))))
315
 
316
 (defgeneric translate-name-to-foreign (lisp-name package &optional varp)
317
   (:method (lisp-name package &optional varp)
318
     (declare (ignore package))
319
     (let ((name (translate-underscore-separated-name lisp-name)))
320
       (if varp
321
           (string-trim '(#\*) name)
322
           name))))
323
 
324
 (defun lisp-name (spec varp)
325
   (check-type spec string)
326
   (translate-name-from-foreign spec *package* varp))
327
 
328
 (defun foreign-name (spec varp)
329
   (check-type spec (and symbol (not null)))
330
   (translate-name-to-foreign spec *package* varp))
331
 
332
 (defun foreign-options (opts varp)
333
   (if varp
334
       (funcall 'parse-defcvar-options opts)
335
       (parse-function-options opts)))
336
 
337
 (defun lisp-name-p (name)
338
   (and name (symbolp name) (not (keywordp name))))
339
 
340
 (defun %parse-name-and-options (spec varp)
341
   (cond
342
     ((stringp spec)
343
      (values (lisp-name spec varp) spec nil))
344
     ((symbolp spec)
345
      (assert (not (null spec)))
346
      (values spec (foreign-name spec varp) nil))
347
     ((and (consp spec) (stringp (first spec)))
348
      (destructuring-bind (foreign-name &rest options)
349
          spec
350
        (cond
351
          ((or (null options)
352
               (keywordp (first options)))
353
           (values (lisp-name foreign-name varp) foreign-name options))
354
          (t
355
           (assert (lisp-name-p (first options)))
356
           (values (first options) foreign-name (rest options))))))
357
     ((and (consp spec) (lisp-name-p (first spec)))
358
      (destructuring-bind (lisp-name &rest options)
359
          spec
360
        (cond
361
          ((or (null options)
362
               (keywordp (first options)))
363
           (values lisp-name (foreign-name spec varp) options))
364
          (t
365
           (assert (stringp (first options)))
366
           (values lisp-name (first options) (rest options))))))
367
     (t
368
      (error "Not a valid foreign function specifier: ~A" spec))))
369
 
370
 ;;; DEFCFUN's first argument has can have the following syntax:
371
 ;;;
372
 ;;;     1.  string
373
 ;;;     2.  symbol
374
 ;;;     3.  \( string [symbol] options* )
375
 ;;;     4.  \( symbol [string] options* )
376
 ;;;
377
 ;;; The string argument denotes the foreign function's name. The
378
 ;;; symbol argument is used to name the Lisp function. If one isn't
379
 ;;; present, its name is derived from the other. See the user
380
 ;;; documentation for an explanation of the derivation rules.
381
 (defun parse-name-and-options (spec &optional varp)
382
   (multiple-value-bind (lisp-name foreign-name options)
383
       (%parse-name-and-options spec varp)
384
     (values lisp-name foreign-name (foreign-options options varp))))
385
 
386
 ;;; If we find a &REST token at the end of ARGS, it means this is a
387
 ;;; varargs foreign function therefore we define a lisp macro using
388
 ;;; %DEFCFUN-VARARGS. Otherwise, a lisp function is defined with
389
 ;;; %DEFCFUN.
390
 (defmacro defcfun (name-and-options return-type &body args)
391
   "Defines a Lisp function that calls a foreign function."
392
   (let ((docstring (when (stringp (car args)) (pop args))))
393
     (multiple-value-bind (lisp-name foreign-name options)
394
         (parse-name-and-options name-and-options)
395
       (if (eq (lastcar args) '&rest)
396
           (%defcfun-varargs lisp-name foreign-name return-type
397
                             (butlast args) options docstring)
398
           (%defcfun lisp-name foreign-name return-type args options
399
                     docstring)))))
400
 
401
 ;;;# Defining Callbacks
402
 
403
 (defun inverse-translate-objects (args types declarations rettype call)
404
   `(let (,@(loop for arg in args and type in types
405
                  collect (list arg (expand-from-foreign
406
                                     arg (parse-type type)))))
407
      ,@declarations
408
      ,(expand-to-foreign call (parse-type rettype))))
409
 
410
 (defun parse-defcallback-options (options)
411
   (destructuring-bind (&key (cconv :cdecl cconv-p)
412
                             (calling-convention cconv calling-convention-p)
413
                             (convention calling-convention))
414
       options
415
     (when cconv-p
416
       (warn-obsolete-argument :cconv :convention))
417
     (when calling-convention-p
418
       (warn-obsolete-argument :calling-convention :convention))
419
     (list :convention convention)))
420
 
421
 (defmacro defcallback (name-and-options return-type args &body body)
422
   (multiple-value-bind (body declarations)
423
       (parse-body body :documentation t)
424
     (let ((arg-names (mapcar #'car args))
425
           (arg-types (mapcar #'cadr args))
426
           (name (car (ensure-list name-and-options)))
427
           (options (cdr (ensure-list name-and-options))))
428
       `(progn
429
          (%defcallback ,name ,(canonicalize-foreign-type return-type)
430
              ,arg-names ,(mapcar #'canonicalize-foreign-type arg-types)
431
            ,(inverse-translate-objects
432
              arg-names arg-types declarations return-type
433
              `(block ,name ,@body))
434
            ,@(parse-defcallback-options options))
435
          ',name))))
436
 
437
 (declaim (inline get-callback))
438
 (defun get-callback (symbol)
439
   (%callback symbol))
440
 
441
 (defmacro callback (name)
442
   `(%callback ',name))