src/functions.lisp

   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 (defun foreign-funcall-varargs-form (thing options fixed-args varargs pointerp)
 154   (multiple-value-bind (fixed-types fixed-ctypes fixed-fargs)
 155       (parse-args-and-types fixed-args)
 156     (multiple-value-bind (varargs-types varargs-ctypes varargs-fargs rettype)
 157         (parse-args-and-types varargs)
 158       (let ((fixed-syms (make-gensym-list (length fixed-fargs)))
 159             (varargs-syms (make-gensym-list (length varargs-fargs))))
 160         (translate-objects
 161          (append fixed-syms varargs-syms)
 162          (append fixed-fargs varargs-fargs)
 163          (append fixed-types varargs-types)
 164          rettype
 165          `(,(if pointerp '%foreign-funcall-pointer '%foreign-funcall)
 166             ,thing
 167             ,(append
 168               (mapcan #'list
 169                       (nconc fixed-ctypes
 170                              (mapcar #'promote-varargs-type varargs-ctypes))
 171                       (append fixed-syms
 172                               (loop for sym in varargs-syms
 173                                     and type in varargs-ctypes
 174                                     if (eq type :float)
 175                                     collect `(float ,sym 1.0d0)
 176                                     else collect sym)))
 177               (list (canonicalize-foreign-type rettype)))
 178             ,@options))))))
 179
 180 ;;; For now, the only difference between this macro and
 181 ;;; FOREIGN-FUNCALL is that it does argument promotion for that
 182 ;;; variadic argument. This could be useful to call an hypothetical
 183 ;;; %foreign-funcall-varargs on some hypothetical lisp on an
 184 ;;; hypothetical platform that has different calling conventions for
 185 ;;; varargs functions. :-)
 186 (defmacro foreign-funcall-varargs (name-and-options fixed-args
 187                                    &rest varargs)
 188   "Wrapper around %FOREIGN-FUNCALL that translates its arguments
 189 and does type promotion for the variadic arguments."
 190   (let ((name (car (ensure-list name-and-options)))
 191         (options (cdr (ensure-list name-and-options))))
 192     (foreign-funcall-varargs-form name options fixed-args varargs nil)))
 193
 194 (defmacro foreign-funcall-pointer-varargs (pointer options fixed-args
 195                                            &rest varargs)
 196   "Wrapper around %FOREIGN-FUNCALL-POINTER that translates its
 197 arguments and does type promotion for the variadic arguments."
 198   (foreign-funcall-varargs-form pointer options fixed-args varargs t))
 199
 200 ;;;# Defining Foreign Functions
 201 ;;;
 202 ;;; The DEFCFUN macro provides a declarative interface for defining
 203 ;;; Lisp functions that call foreign functions.
 204
 205 ;; If cffi-sys doesn't provide a defcfun-helper-forms,
 206 ;; we define one that uses %foreign-funcall.
 207 (eval-when (:compile-toplevel :load-toplevel :execute)
 208   (unless (fboundp 'defcfun-helper-forms)
 209     (defun defcfun-helper-forms (name lisp-name rettype args types options)
 210       (declare (ignore lisp-name))
 211       (values
 212        '()
 213        `(%foreign-funcall ,name ,(append (mapcan #'list types args)
 214                                          (list rettype))
 215                           ,@options)))))
 216
 217 (defun %defcfun (lisp-name foreign-name return-type args options docstring)
 218   (let* ((arg-names (mapcar #'first args))
 219          (arg-types (mapcar #'second args))
 220          (syms (make-gensym-list (length args)))
 221          (call-by-value (fn-call-by-value-p arg-types return-type)))
 222     (multiple-value-bind (prelude caller)
 223         (if call-by-value
 224             (values nil nil)
 225             (defcfun-helper-forms
 226              foreign-name lisp-name (canonicalize-foreign-type return-type)
 227              syms (mapcar #'canonicalize-foreign-type arg-types) options))
 228       `(progn
 229          ,prelude
 230          (defun ,lisp-name ,arg-names
 231            ,@(ensure-list docstring)
 232            ,(if call-by-value
 233                 `(foreign-funcall
 234                   ,(cons foreign-name options)
 235                   ,@(append (mapcan #'list arg-types arg-names)
 236                             (list return-type)))
 237                 (translate-objects
 238                  syms arg-names arg-types return-type caller)))))))
 239
 240 (defun %defcfun-varargs (lisp-name foreign-name return-type args options doc)
 241   (with-unique-names (varargs)
 242     (let ((arg-names (mapcar #'car args)))
 243       `(defmacro ,lisp-name (,@arg-names &rest ,varargs)
 244          ,@(ensure-list doc)
 245          `(foreign-funcall-varargs
 246            ,'(,foreign-name ,@options)
 247            ,,`(list ,@(loop for (name type) in args
 248                             collect `',type collect name))
 249            ,@,varargs
 250            ,',return-type)))))
 251
 252 (defgeneric translate-underscore-separated-name (name)
 253   (:method ((name string))
 254     (values (intern (canonicalize-symbol-name-case (substitute #\- #\_ name)))))
 255   (:method ((name symbol))
 256     (substitute #\_ #\- (string-downcase (symbol-name name)))))
 257
 258 (defun collapse-prefix (l special-words)
 259   (unless (null l)
 260     (multiple-value-bind (newpre skip) (check-prefix l special-words)
 261       (cons newpre (collapse-prefix (nthcdr skip l) special-words)))))
 262
 263 (defun check-prefix (l special-words)
 264   (let ((pl (loop for i from (1- (length l)) downto 0
 265                   collect (apply #'concatenate 'simple-string (butlast l i)))))
 266     (loop for w in special-words
 267           for p = (position-if #'(lambda (s) (string= s w)) pl)
 268           when p do (return-from check-prefix (values (nth p pl) (1+ p))))
 269     (values (first l) 1)))
 270
 271 (defgeneric translate-camelcase-name (name &key upper-initial-p special-words)
 272   (:method ((name string) &key upper-initial-p special-words)
 273     (declare (ignore upper-initial-p))
 274     (values (intern (reduce #'(lambda (s1 s2)
 275                                 (concatenate 'simple-string s1 "-" s2))
 276                             (mapcar #'string-upcase
 277                                     (collapse-prefix
 278                                      (split-if #'(lambda (ch)
 279                                                    (or (upper-case-p ch)
 280                                                        (digit-char-p ch)))
 281                                                name)
 282                                      special-words))))))
 283   (:method ((name symbol) &key upper-initial-p special-words)
 284     (apply #'concatenate
 285            'string
 286            (loop for str in (split-if #'(lambda (ch) (eq ch #\-))
 287                                           (string name)
 288                                       :elide)
 289                  for first-word-p = t then nil
 290                  for e = (member str special-words
 291                                  :test #'equal :key #'string-upcase)
 292                  collect (cond
 293                            ((and first-word-p (not upper-initial-p))
 294                             (string-downcase str))
 295                            (e (first e))
 296                            (t (string-capitalize str)))))))
 297
 298 (defgeneric translate-name-from-foreign (foreign-name package &optional varp)
 299   (:method (foreign-name package &optional varp)
 300     (declare (ignore package))
 301     (let ((sym (translate-underscore-separated-name foreign-name)))
 302       (if varp
 303           (values (intern (format nil "*~A*"
 304                                   (canonicalize-symbol-name-case
 305                                    (symbol-name sym)))))
 306           sym))))
 307
 308 (defgeneric translate-name-to-foreign (lisp-name package &optional varp)
 309   (:method (lisp-name package &optional varp)
 310     (declare (ignore package))
 311     (let ((name (translate-underscore-separated-name lisp-name)))
 312       (if varp
 313           (string-trim '(#\*) name)
 314           name))))
 315
 316 (defun lisp-name (spec varp)
 317   (check-type spec string)
 318   (translate-name-from-foreign spec *package* varp))
 319
 320 (defun foreign-name (spec varp)
 321   (check-type spec (and symbol (not null)))
 322   (translate-name-to-foreign spec *package* varp))
 323
 324 (defun foreign-options (opts varp)
 325   (if varp
 326       (funcall 'parse-defcvar-options opts)
 327       (parse-function-options opts)))
 328
 329 (defun lisp-name-p (name)
 330   (and name (symbolp name) (not (keywordp name))))
 331
 332 (defun %parse-name-and-options (spec varp)
 333   (cond
 334     ((stringp spec)
 335      (values (lisp-name spec varp) spec nil))
 336     ((symbolp spec)
 337      (assert (not (null spec)))
 338      (values spec (foreign-name spec varp) nil))
 339     ((and (consp spec) (stringp (first spec)))
 340      (destructuring-bind (foreign-name &rest options)
 341          spec
 342        (cond
 343          ((or (null options)
 344               (keywordp (first options)))
 345           (values (lisp-name foreign-name varp) foreign-name options))
 346          (t
 347           (assert (lisp-name-p (first options)))
 348           (values (first options) foreign-name (rest options))))))
 349     ((and (consp spec) (lisp-name-p (first spec)))
 350      (destructuring-bind (lisp-name &rest options)
 351          spec
 352        (cond
 353          ((or (null options)
 354               (keywordp (first options)))
 355           (values lisp-name (foreign-name spec varp) options))
 356          (t
 357           (assert (stringp (first options)))
 358           (values lisp-name (first options) (rest options))))))
 359     (t
 360      (error "Not a valid foreign function specifier: ~A" spec))))
 361
 362 ;;; DEFCFUN's first argument has can have the following syntax:
 363 ;;;
 364 ;;;     1.  string
 365 ;;;     2.  symbol
 366 ;;;     3.  \( string [symbol] options* )
 367 ;;;     4.  \( symbol [string] options* )
 368 ;;;
 369 ;;; The string argument denotes the foreign function's name. The
 370 ;;; symbol argument is used to name the Lisp function. If one isn't
 371 ;;; present, its name is derived from the other. See the user
 372 ;;; documentation for an explanation of the derivation rules.
 373 (defun parse-name-and-options (spec &optional varp)
 374   (multiple-value-bind (lisp-name foreign-name options)
 375       (%parse-name-and-options spec varp)
 376     (values lisp-name foreign-name (foreign-options options varp))))
 377
 378 ;;; If we find a &REST token at the end of ARGS, it means this is a
 379 ;;; varargs foreign function therefore we define a lisp macro using
 380 ;;; %DEFCFUN-VARARGS. Otherwise, a lisp function is defined with
 381 ;;; %DEFCFUN.
 382 (defmacro defcfun (name-and-options return-type &body args)
 383   "Defines a Lisp function that calls a foreign function."
 384   (let ((docstring (when (stringp (car args)) (pop args))))
 385     (multiple-value-bind (lisp-name foreign-name options)
 386         (parse-name-and-options name-and-options)
 387       (if (eq (lastcar args) '&rest)
 388           (%defcfun-varargs lisp-name foreign-name return-type
 389                             (butlast args) options docstring)
 390           (%defcfun lisp-name foreign-name return-type args options
 391                     docstring)))))
 392
 393 ;;;# Defining Callbacks
 394
 395 (defun inverse-translate-objects (args types declarations rettype call)
 396   `(let (,@(loop for arg in args and type in types
 397                  collect (list arg (expand-from-foreign
 398                                     arg (parse-type type)))))
 399      ,@declarations
 400      ,(expand-to-foreign call (parse-type rettype))))
 401
 402 (defun parse-defcallback-options (options)
 403   (destructuring-bind (&key (cconv :cdecl cconv-p)
 404                             (calling-convention cconv calling-convention-p)
 405                             (convention calling-convention))
 406       options
 407     (when cconv-p
 408       (warn-obsolete-argument :cconv :convention))
 409     (when calling-convention-p
 410       (warn-obsolete-argument :calling-convention :convention))
 411     (list :convention convention)))
 412
 413 (defmacro defcallback (name-and-options return-type args &body body)
 414   (multiple-value-bind (body declarations)
 415       (parse-body body :documentation t)
 416     (let ((arg-names (mapcar #'car args))
 417           (arg-types (mapcar #'cadr args))
 418           (name (car (ensure-list name-and-options)))
 419           (options (cdr (ensure-list name-and-options))))
 420       `(progn
 421          (%defcallback ,name ,(canonicalize-foreign-type return-type)
 422              ,arg-names ,(mapcar #'canonicalize-foreign-type arg-types)
 423            ,(inverse-translate-objects
 424              arg-names arg-types declarations return-type
 425              `(block ,name ,@body))
 426            ,@(parse-defcallback-options options))
 427          ',name))))
 428
 429 (declaim (inline get-callback))
 430 (defun get-callback (symbol)
 431   (%callback symbol))
 432
 433 (defmacro callback (name)
 434   `(%callback ',name))