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            ,@(ensure-list docstring)
 239            ,(if call-by-value
 240                 `(foreign-funcall
 241                   ,(cons foreign-name options)
 242                   ,@(append (mapcan #'list arg-types arg-names)
 243                             (list return-type)))
 244                 (translate-objects
 245                  syms arg-names arg-types return-type caller)))))))
 246
 247 (defun %defcfun-varargs (lisp-name foreign-name return-type args options doc)
 248   (with-unique-names (varargs)
 249     (let ((arg-names (mapcar #'car args)))
 250       `(defmacro ,lisp-name (,@arg-names &rest ,varargs)
 251          ,@(ensure-list doc)
 252          `(foreign-funcall-varargs
 253            ,'(,foreign-name ,@options)
 254            ,,`(list ,@(loop for (name type) in args
 255                             collect `',type collect name))
 256            ,@,varargs
 257            ,',return-type)))))
 258
 259 (defgeneric translate-underscore-separated-name (name)
 260   (:method ((name string))
 261     (values (intern (canonicalize-symbol-name-case (substitute #\- #\_ name)))))
 262   (:method ((name symbol))
 263     (substitute #\_ #\- (string-downcase (symbol-name name)))))
 264
 265 (defun collapse-prefix (l special-words)
 266   (unless (null l)
 267     (multiple-value-bind (newpre skip) (check-prefix l special-words)
 268       (cons newpre (collapse-prefix (nthcdr skip l) special-words)))))
 269
 270 (defun check-prefix (l special-words)
 271   (let ((pl (loop for i from (1- (length l)) downto 0
 272                   collect (apply #'concatenate 'simple-string (butlast l i)))))
 273     (loop for w in special-words
 274           for p = (position-if #'(lambda (s) (string= s w)) pl)
 275           when p do (return-from check-prefix (values (nth p pl) (1+ p))))
 276     (values (first l) 1)))
 277
 278 (defgeneric translate-camelcase-name (name &key upper-initial-p special-words)
 279   (:method ((name string) &key upper-initial-p special-words)
 280     (declare (ignore upper-initial-p))
 281     (values (intern (reduce #'(lambda (s1 s2)
 282                                 (concatenate 'simple-string s1 "-" s2))
 283                             (mapcar #'string-upcase
 284                                     (collapse-prefix
 285                                      (split-if #'(lambda (ch)
 286                                                    (or (upper-case-p ch)
 287                                                        (digit-char-p ch)))
 288                                                name)
 289                                      special-words))))))
 290   (:method ((name symbol) &key upper-initial-p special-words)
 291     (apply #'concatenate
 292            'string
 293            (loop for str in (split-if #'(lambda (ch) (eq ch #\-))
 294                                           (string name)
 295                                       :elide)
 296                  for first-word-p = t then nil
 297                  for e = (member str special-words
 298                                  :test #'equal :key #'string-upcase)
 299                  collect (cond
 300                            ((and first-word-p (not upper-initial-p))
 301                             (string-downcase str))
 302                            (e (first e))
 303                            (t (string-capitalize str)))))))
 304
 305 (defgeneric translate-name-from-foreign (foreign-name package &optional varp)
 306   (:method (foreign-name package &optional varp)
 307     (declare (ignore package))
 308     (let ((sym (translate-underscore-separated-name foreign-name)))
 309       (if varp
 310           (values (intern (format nil "*~A*"
 311                                   (canonicalize-symbol-name-case
 312                                    (symbol-name sym)))))
 313           sym))))
 314
 315 (defgeneric translate-name-to-foreign (lisp-name package &optional varp)
 316   (:method (lisp-name package &optional varp)
 317     (declare (ignore package))
 318     (let ((name (translate-underscore-separated-name lisp-name)))
 319       (if varp
 320           (string-trim '(#\*) name)
 321           name))))
 322
 323 (defun lisp-name (spec varp)
 324   (check-type spec string)
 325   (translate-name-from-foreign spec *package* varp))
 326
 327 (defun foreign-name (spec varp)
 328   (check-type spec (and symbol (not null)))
 329   (translate-name-to-foreign spec *package* varp))
 330
 331 (defun foreign-options (opts varp)
 332   (if varp
 333       (funcall 'parse-defcvar-options opts)
 334       (parse-function-options opts)))
 335
 336 (defun lisp-name-p (name)
 337   (and name (symbolp name) (not (keywordp name))))
 338
 339 (defun %parse-name-and-options (spec varp)
 340   (cond
 341     ((stringp spec)
 342      (values (lisp-name spec varp) spec nil))
 343     ((symbolp spec)
 344      (assert (not (null spec)))
 345      (values spec (foreign-name spec varp) nil))
 346     ((and (consp spec) (stringp (first spec)))
 347      (destructuring-bind (foreign-name &rest options)
 348          spec
 349        (cond
 350          ((or (null options)
 351               (keywordp (first options)))
 352           (values (lisp-name foreign-name varp) foreign-name options))
 353          (t
 354           (assert (lisp-name-p (first options)))
 355           (values (first options) foreign-name (rest options))))))
 356     ((and (consp spec) (lisp-name-p (first spec)))
 357      (destructuring-bind (lisp-name &rest options)
 358          spec
 359        (cond
 360          ((or (null options)
 361               (keywordp (first options)))
 362           (values lisp-name (foreign-name spec varp) options))
 363          (t
 364           (assert (stringp (first options)))
 365           (values lisp-name (first options) (rest options))))))
 366     (t
 367      (error "Not a valid foreign function specifier: ~A" spec))))
 368
 369 ;;; DEFCFUN's first argument has can have the following syntax:
 370 ;;;
 371 ;;;     1.  string
 372 ;;;     2.  symbol
 373 ;;;     3.  \( string [symbol] options* )
 374 ;;;     4.  \( symbol [string] options* )
 375 ;;;
 376 ;;; The string argument denotes the foreign function's name. The
 377 ;;; symbol argument is used to name the Lisp function. If one isn't
 378 ;;; present, its name is derived from the other. See the user
 379 ;;; documentation for an explanation of the derivation rules.
 380 (defun parse-name-and-options (spec &optional varp)
 381   (multiple-value-bind (lisp-name foreign-name options)
 382       (%parse-name-and-options spec varp)
 383     (values lisp-name foreign-name (foreign-options options varp))))
 384
 385 ;;; If we find a &REST token at the end of ARGS, it means this is a
 386 ;;; varargs foreign function therefore we define a lisp macro using
 387 ;;; %DEFCFUN-VARARGS. Otherwise, a lisp function is defined with
 388 ;;; %DEFCFUN.
 389 (defmacro defcfun (name-and-options return-type &body args)
 390   "Defines a Lisp function that calls a foreign function."
 391   (let ((docstring (when (stringp (car args)) (pop args))))
 392     (multiple-value-bind (lisp-name foreign-name options)
 393         (parse-name-and-options name-and-options)
 394       (if (eq (lastcar args) '&rest)
 395           (%defcfun-varargs lisp-name foreign-name return-type
 396                             (butlast args) options docstring)
 397           (%defcfun lisp-name foreign-name return-type args options
 398                     docstring)))))
 399
 400 ;;;# Defining Callbacks
 401
 402 (defun inverse-translate-objects (args types declarations rettype call)
 403   `(let (,@(loop for arg in args and type in types
 404                  collect (list arg (expand-from-foreign
 405                                     arg (parse-type type)))))
 406      ,@declarations
 407      ,(expand-to-foreign call (parse-type rettype))))
 408
 409 (defun parse-defcallback-options (options)
 410   (destructuring-bind (&key (cconv :cdecl cconv-p)
 411                             (calling-convention cconv calling-convention-p)
 412                             (convention calling-convention))
 413       options
 414     (when cconv-p
 415       (warn-obsolete-argument :cconv :convention))
 416     (when calling-convention-p
 417       (warn-obsolete-argument :calling-convention :convention))
 418     (list :convention convention)))
 419
 420 (defmacro defcallback (name-and-options return-type args &body body)
 421   (multiple-value-bind (body declarations)
 422       (parse-body body :documentation t)
 423     (let ((arg-names (mapcar #'car args))
 424           (arg-types (mapcar #'cadr args))
 425           (name (car (ensure-list name-and-options)))
 426           (options (cdr (ensure-list name-and-options))))
 427       `(progn
 428          (%defcallback ,name ,(canonicalize-foreign-type return-type)
 429              ,arg-names ,(mapcar #'canonicalize-foreign-type arg-types)
 430            ,(inverse-translate-objects
 431              arg-names arg-types declarations return-type
 432              `(block ,name ,@body))
 433            ,@(parse-defcallback-options options))
 434          ',name))))
 435
 436 (declaim (inline get-callback))
 437 (defun get-callback (symbol)
 438   (%callback symbol))
 439
 440 (defmacro callback (name)
 441   `(%callback ',name))