3rdparties/software/cffi_0.21.0/src/functions.lisp (19030 bytes)
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))