external/cffi.darcs/_darcs/pristine/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)
  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 docstring)
 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            ,@(ensure-list docstring)
 187            ,(translate-objects
 188              syms arg-names arg-types return-type caller))))))
 189
 190 (defun %defcfun-varargs (lisp-name foreign-name return-type args options doc)
 191   (with-unique-names (varargs)
 192     (let ((arg-names (mapcar #'car args)))
 193       `(defmacro ,lisp-name (,@arg-names &rest ,varargs)
 194          ,@(ensure-list doc)
 195          `(foreign-funcall-varargs
 196            ,'(,foreign-name ,@options)
 197            ,,`(list ,@(loop for (name type) in args
 198                             collect `',type collect name))
 199            ,@,varargs
 200            ,',return-type)))))
 201
 202 ;;; The following four functions take care of parsing DEFCFUN's first
 203 ;;; argument whose syntax can be one of:
 204 ;;;
 205 ;;;     1.  string
 206 ;;;     2.  symbol
 207 ;;;     3.  \( string [symbol] options* )
 208 ;;;     4.  \( symbol [string] options* )
 209 ;;;
 210 ;;; The string argument denotes the foreign function's name. The
 211 ;;; symbol argument is used to name the Lisp function. If one isn't
 212 ;;; present, its name is derived from the other. See the user
 213 ;;; documentation for an explanation of the derivation rules.
 214
 215 (defun lisp-name (spec &optional varp)
 216   (etypecase spec
 217     (list (if (keywordp (second spec))
 218               (lisp-name (first spec) varp)
 219               (if (symbolp (first spec))
 220                   (first spec)
 221                   (lisp-name (second spec) varp))))
 222     (string (intern
 223              (format nil (if varp "*~A*" "~A")
 224                      (canonicalize-symbol-name-case
 225                       (substitute #\- #\_ spec)))))
 226     (symbol spec)))
 227
 228 (defun foreign-name (spec &optional varp)
 229   (etypecase spec
 230     (list (if (stringp (second spec))
 231               (second spec)
 232               (foreign-name (first spec) varp)))
 233     (string spec)
 234     (symbol (let ((name (substitute #\_ #\-
 235                                     (string-downcase (symbol-name spec)))))
 236               (if varp
 237                   (string-trim '(#\*) name)
 238                   name)))))
 239
 240 (defun foreign-options (spec varp)
 241   (let ((opts (if (listp spec)
 242                   (if (keywordp (second spec))
 243                       (cdr spec)
 244                       (cddr spec))
 245                   nil)))
 246     (if varp
 247         (funcall 'parse-defcvar-options opts)
 248         (parse-function-options opts))))
 249
 250 (defun parse-name-and-options (spec &optional varp)
 251   (values (lisp-name spec varp)
 252           (foreign-name spec varp)
 253           (foreign-options spec varp)))
 254
 255 ;;; If we find a &REST token at the end of ARGS, it means this is a
 256 ;;; varargs foreign function therefore we define a lisp macro using
 257 ;;; %DEFCFUN-VARARGS. Otherwise, a lisp function is defined with
 258 ;;; %DEFCFUN.
 259 (defmacro defcfun (name-and-options return-type &body args)
 260   "Defines a Lisp function that calls a foreign function."
 261   (let ((docstring (when (stringp (car args)) (pop args))))
 262     (multiple-value-bind (lisp-name foreign-name options)
 263         (parse-name-and-options name-and-options)
 264       (if (eq (car (last args)) '&rest)
 265           (%defcfun-varargs lisp-name foreign-name return-type
 266                             (butlast args) options docstring)
 267           (%defcfun lisp-name foreign-name return-type args options
 268                     docstring)))))
 269
 270 ;;;# Defining Callbacks
 271
 272 (defun inverse-translate-objects (args types declarations rettype call)
 273   `(let (,@(loop for arg in args and type in types
 274                  collect (list arg (expand-from-foreign
 275                                     arg (parse-type type)))))
 276      ,@declarations
 277      ,(expand-to-foreign call (parse-type rettype))))
 278
 279 (defun parse-defcallback-options (options)
 280   (destructuring-bind (&key (calling-convention :cdecl)
 281                             (cconv calling-convention))
 282       options
 283     (list :calling-convention cconv)))
 284
 285 (defmacro defcallback (name-and-options return-type args &body body)
 286   (multiple-value-bind (body declarations)
 287       (parse-body body :documentation t)
 288     (let ((arg-names (mapcar #'car args))
 289           (arg-types (mapcar #'cadr args))
 290           (name (car (ensure-list name-and-options)))
 291           (options (cdr (ensure-list name-and-options))))
 292       `(progn
 293          (%defcallback ,name ,(canonicalize-foreign-type return-type)
 294              ,arg-names ,(mapcar #'canonicalize-foreign-type arg-types)
 295            ,(inverse-translate-objects
 296              arg-names arg-types declarations return-type
 297              `(block ,name ,@body))
 298            ,@(parse-defcallback-options options))
 299          ',name))))
 300
 301 (declaim (inline get-callback))
 302 (defun get-callback (symbol)
 303   (%callback symbol))
 304
 305 (defmacro callback (name)
 306   `(%callback ',name))