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 ;; 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))