Permalink
Fetching contributors…
Cannot retrieve contributors at this time
442 lines (402 sloc) 18.6 KB
;;;; -*- Mode: lisp; indent-tabs-mode: nil -*-
;;;
;;; functions.lisp --- High-level interface to foreign functions.
;;;
;;; Copyright (C) 2005-2006, James Bielman <jamesjb@jamesjb.com>
;;; Copyright (C) 2005-2007, Luis Oliveira <loliveira@common-lisp.net>
;;;
;;; Permission is hereby granted, free of charge, to any person
;;; obtaining a copy of this software and associated documentation
;;; files (the "Software"), to deal in the Software without
;;; restriction, including without limitation the rights to use, copy,
;;; modify, merge, publish, distribute, sublicense, and/or sell copies
;;; of the Software, and to permit persons to whom the Software is
;;; furnished to do so, subject to the following conditions:
;;;
;;; The above copyright notice and this permission notice shall be
;;; included in all copies or substantial portions of the Software.
;;;
;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
;;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
;;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
;;; NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT
;;; HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY,
;;; WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
;;; OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER
;;; DEALINGS IN THE SOFTWARE.
;;;
(in-package #:cffi)
;;;# Calling Foreign Functions
;;;
;;; FOREIGN-FUNCALL is the main primitive for calling foreign
;;; functions. It converts each argument based on the installed
;;; translators for its type, then passes the resulting list to
;;; CFFI-SYS:%FOREIGN-FUNCALL.
;;;
;;; For implementation-specific reasons, DEFCFUN doesn't use
;;; FOREIGN-FUNCALL directly and might use something else (passed to
;;; TRANSLATE-OBJECTS as the CALL-FORM argument) instead of
;;; CFFI-SYS:%FOREIGN-FUNCALL to call the foreign-function.
(defun translate-objects (syms args types rettype call-form &optional indirect)
"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."
(if (null args)
(expand-from-foreign call-form (parse-type rettype))
(funcall
(if indirect
#'expand-to-foreign-dyn-indirect
#'expand-to-foreign-dyn)
(car args) (car syms)
(list (translate-objects (cdr syms) (cdr args)
(cdr types) rettype call-form indirect))
(parse-type (car types)))))
(defun parse-args-and-types (args)
"Returns 4 values: types, canonicalized types, args and return type."
(let* ((len (length args))
(return-type (if (oddp len) (lastcar args) :void)))
(loop repeat (floor len 2)
for (type arg) on args by #'cddr
collect type into types
collect (canonicalize-foreign-type type) into ctypes
collect arg into fargs
finally (return (values types ctypes fargs return-type)))))
;;; While the options passed directly to DEFCFUN/FOREIGN-FUNCALL have
;;; precedence, we also grab its library's options, if possible.
(defun parse-function-options (options &key pointer)
(destructuring-bind (&key (library :default libraryp)
(cconv nil cconv-p)
(calling-convention cconv calling-convention-p)
(convention calling-convention))
options
(when cconv-p
(warn-obsolete-argument :cconv :convention))
(when calling-convention-p
(warn-obsolete-argument :calling-convention :convention))
(list* :convention
(or convention
(when libraryp
(let ((lib-options (foreign-library-options
(get-foreign-library library))))
(getf lib-options :convention)))
:cdecl)
;; Don't pass the library option if we're dealing with
;; FOREIGN-FUNCALL-POINTER.
(unless pointer
(list :library library)))))
(defun structure-by-value-p (ctype)
"A structure or union is to be called or returned by value."
(let ((actual-type (ensure-parsed-base-type ctype)))
(or (and (typep actual-type 'foreign-struct-type)
(not (bare-struct-type-p actual-type)))
#+cffi::no-long-long (typep actual-type 'emulated-llong-type))))
(defun fn-call-by-value-p (argument-types return-type)
"One or more structures in the arguments or return from the function are called by value."
(or (some 'structure-by-value-p argument-types)
(structure-by-value-p return-type)))
(defvar *foreign-structures-by-value*
(lambda (&rest args)
(declare (ignore args))
(restart-case
(error "Unable to call structures by value without cffi-libffi loaded.")
(load-cffi-libffi () :report "Load cffi-libffi."
(asdf:operate 'asdf:load-op 'cffi-libffi))))
"A function that produces a form suitable for calling structures by value.")
(defun foreign-funcall-form (thing options args pointerp)
(multiple-value-bind (types ctypes fargs rettype)
(parse-args-and-types args)
(let ((syms (make-gensym-list (length fargs)))
(fsbvp (fn-call-by-value-p ctypes rettype)))
(if fsbvp
;; Structures by value call through *foreign-structures-by-value*
(funcall *foreign-structures-by-value*
thing
fargs
syms
types
rettype
ctypes
pointerp)
(translate-objects
syms fargs types rettype
`(,(if pointerp '%foreign-funcall-pointer '%foreign-funcall)
;; No structures by value, direct call
,thing
(,@(mapcan #'list ctypes syms)
,(canonicalize-foreign-type rettype))
,@(parse-function-options options :pointer pointerp)))))))
(defmacro foreign-funcall (name-and-options &rest args)
"Wrapper around %FOREIGN-FUNCALL that translates its arguments."
(let ((name (car (ensure-list name-and-options)))
(options (cdr (ensure-list name-and-options))))
(foreign-funcall-form name options args nil)))
(defmacro foreign-funcall-pointer (pointer options &rest args)
(foreign-funcall-form pointer options args t))
(defun promote-varargs-type (builtin-type)
"Default argument promotions."
(case builtin-type
(:float :double)
((:char :short) :int)
((:unsigned-char :unsigned-short) :unsigned-int)
(t builtin-type)))
;; If cffi-sys doesn't provide a %foreign-funcall-varargs macros we
;; define one that use %foreign-funcall.
(eval-when (:compile-toplevel :load-toplevel :execute)
(unless (fboundp '%foreign-funcall-varargs)
(defmacro %foreign-funcall-varargs (name fixed-args varargs
&rest args &key convention library)
(declare (ignore convention library))
`(%foreign-funcall ,name ,(append fixed-args varargs) ,@args)))
(unless (fboundp '%foreign-funcall-pointer-varargs)
(defmacro %foreign-funcall-pointer-varargs (pointer fixed-args varargs
&rest args &key convention)
(declare (ignore convention))
`(%foreign-funcall-pointer ,pointer ,(append fixed-args varargs) ,@args))))
(defun foreign-funcall-varargs-form (thing options fixed-args varargs pointerp)
(multiple-value-bind (fixed-types fixed-ctypes fixed-fargs)
(parse-args-and-types fixed-args)
(multiple-value-bind (varargs-types varargs-ctypes varargs-fargs rettype)
(parse-args-and-types varargs)
(let ((fixed-syms (make-gensym-list (length fixed-fargs)))
(varargs-syms (make-gensym-list (length varargs-fargs))))
(translate-objects
(append fixed-syms varargs-syms)
(append fixed-fargs varargs-fargs)
(append fixed-types varargs-types)
rettype
`(,(if pointerp '%foreign-funcall-pointer-varargs '%foreign-funcall-varargs)
,thing
,(mapcan #'list fixed-ctypes fixed-syms)
,(append
(mapcan #'list
(mapcar #'promote-varargs-type varargs-ctypes)
(loop for sym in varargs-syms
and type in varargs-ctypes
if (eq type :float)
collect `(float ,sym 1.0d0)
else collect sym))
(list (canonicalize-foreign-type rettype)))
,@options))))))
(defmacro foreign-funcall-varargs (name-and-options fixed-args
&rest varargs)
"Wrapper around %FOREIGN-FUNCALL that translates its arguments
and does type promotion for the variadic arguments."
(let ((name (car (ensure-list name-and-options)))
(options (cdr (ensure-list name-and-options))))
(foreign-funcall-varargs-form name options fixed-args varargs nil)))
(defmacro foreign-funcall-pointer-varargs (pointer options fixed-args
&rest varargs)
"Wrapper around %FOREIGN-FUNCALL-POINTER that translates its
arguments and does type promotion for the variadic arguments."
(foreign-funcall-varargs-form pointer options fixed-args varargs t))
;;;# Defining Foreign Functions
;;;
;;; The DEFCFUN macro provides a declarative interface for defining
;;; Lisp functions that call foreign functions.
;; If cffi-sys doesn't provide a defcfun-helper-forms,
;; we define one that uses %foreign-funcall.
(eval-when (:compile-toplevel :load-toplevel :execute)
(unless (fboundp 'defcfun-helper-forms)
(defun defcfun-helper-forms (name lisp-name rettype args types options)
(declare (ignore lisp-name))
(values
'()
`(%foreign-funcall ,name ,(append (mapcan #'list types args)
(list rettype))
,@options)))))
(defun %defcfun (lisp-name foreign-name return-type args options docstring)
(let* ((arg-names (mapcar #'first args))
(arg-types (mapcar #'second args))
(syms (make-gensym-list (length args)))
(call-by-value (fn-call-by-value-p arg-types return-type)))
(multiple-value-bind (prelude caller)
(if call-by-value
(values nil nil)
(defcfun-helper-forms
foreign-name lisp-name (canonicalize-foreign-type return-type)
syms (mapcar #'canonicalize-foreign-type arg-types) options))
`(progn
,prelude
(defun ,lisp-name ,arg-names
,@(ensure-list docstring)
,(if call-by-value
`(foreign-funcall
,(cons foreign-name options)
,@(append (mapcan #'list arg-types arg-names)
(list return-type)))
(translate-objects
syms arg-names arg-types return-type caller)))))))
(defun %defcfun-varargs (lisp-name foreign-name return-type args options doc)
(with-unique-names (varargs)
(let ((arg-names (mapcar #'car args)))
`(defmacro ,lisp-name (,@arg-names &rest ,varargs)
,@(ensure-list doc)
`(foreign-funcall-varargs
,'(,foreign-name ,@options)
,,`(list ,@(loop for (name type) in args
collect `',type collect name))
,@,varargs
,',return-type)))))
(defgeneric translate-underscore-separated-name (name)
(:method ((name string))
(values (intern (canonicalize-symbol-name-case (substitute #\- #\_ name)))))
(:method ((name symbol))
(substitute #\_ #\- (string-downcase (symbol-name name)))))
(defun collapse-prefix (l special-words)
(unless (null l)
(multiple-value-bind (newpre skip) (check-prefix l special-words)
(cons newpre (collapse-prefix (nthcdr skip l) special-words)))))
(defun check-prefix (l special-words)
(let ((pl (loop for i from (1- (length l)) downto 0
collect (apply #'concatenate 'simple-string (butlast l i)))))
(loop for w in special-words
for p = (position-if #'(lambda (s) (string= s w)) pl)
when p do (return-from check-prefix (values (nth p pl) (1+ p))))
(values (first l) 1)))
(defgeneric translate-camelcase-name (name &key upper-initial-p special-words)
(:method ((name string) &key upper-initial-p special-words)
(declare (ignore upper-initial-p))
(values (intern (reduce #'(lambda (s1 s2)
(concatenate 'simple-string s1 "-" s2))
(mapcar #'string-upcase
(collapse-prefix
(split-if #'(lambda (ch)
(or (upper-case-p ch)
(digit-char-p ch)))
name)
special-words))))))
(:method ((name symbol) &key upper-initial-p special-words)
(apply #'concatenate
'string
(loop for str in (split-if #'(lambda (ch) (eq ch #\-))
(string name)
:elide)
for first-word-p = t then nil
for e = (member str special-words
:test #'equal :key #'string-upcase)
collect (cond
((and first-word-p (not upper-initial-p))
(string-downcase str))
(e (first e))
(t (string-capitalize str)))))))
(defgeneric translate-name-from-foreign (foreign-name package &optional varp)
(:method (foreign-name package &optional varp)
(declare (ignore package))
(let ((sym (translate-underscore-separated-name foreign-name)))
(if varp
(values (intern (format nil "*~A*"
(canonicalize-symbol-name-case
(symbol-name sym)))))
sym))))
(defgeneric translate-name-to-foreign (lisp-name package &optional varp)
(:method (lisp-name package &optional varp)
(declare (ignore package))
(let ((name (translate-underscore-separated-name lisp-name)))
(if varp
(string-trim '(#\*) name)
name))))
(defun lisp-name (spec varp)
(check-type spec string)
(translate-name-from-foreign spec *package* varp))
(defun foreign-name (spec varp)
(check-type spec (and symbol (not null)))
(translate-name-to-foreign spec *package* varp))
(defun foreign-options (opts varp)
(if varp
(funcall 'parse-defcvar-options opts)
(parse-function-options opts)))
(defun lisp-name-p (name)
(and name (symbolp name) (not (keywordp name))))
(defun %parse-name-and-options (spec varp)
(cond
((stringp spec)
(values (lisp-name spec varp) spec nil))
((symbolp spec)
(assert (not (null spec)))
(values spec (foreign-name spec varp) nil))
((and (consp spec) (stringp (first spec)))
(destructuring-bind (foreign-name &rest options)
spec
(cond
((or (null options)
(keywordp (first options)))
(values (lisp-name foreign-name varp) foreign-name options))
(t
(assert (lisp-name-p (first options)))
(values (first options) foreign-name (rest options))))))
((and (consp spec) (lisp-name-p (first spec)))
(destructuring-bind (lisp-name &rest options)
spec
(cond
((or (null options)
(keywordp (first options)))
(values lisp-name (foreign-name spec varp) options))
(t
(assert (stringp (first options)))
(values lisp-name (first options) (rest options))))))
(t
(error "Not a valid foreign function specifier: ~A" spec))))
;;; DEFCFUN's first argument has can have the following syntax:
;;;
;;; 1. string
;;; 2. symbol
;;; 3. \( string [symbol] options* )
;;; 4. \( symbol [string] options* )
;;;
;;; The string argument denotes the foreign function's name. The
;;; symbol argument is used to name the Lisp function. If one isn't
;;; present, its name is derived from the other. See the user
;;; documentation for an explanation of the derivation rules.
(defun parse-name-and-options (spec &optional varp)
(multiple-value-bind (lisp-name foreign-name options)
(%parse-name-and-options spec varp)
(values lisp-name foreign-name (foreign-options options varp))))
;;; If we find a &REST token at the end of ARGS, it means this is a
;;; varargs foreign function therefore we define a lisp macro using
;;; %DEFCFUN-VARARGS. Otherwise, a lisp function is defined with
;;; %DEFCFUN.
(defmacro defcfun (name-and-options return-type &body args)
"Defines a Lisp function that calls a foreign function."
(let ((docstring (when (stringp (car args)) (pop args))))
(multiple-value-bind (lisp-name foreign-name options)
(parse-name-and-options name-and-options)
(if (eq (lastcar args) '&rest)
(%defcfun-varargs lisp-name foreign-name return-type
(butlast args) options docstring)
(%defcfun lisp-name foreign-name return-type args options
docstring)))))
;;;# Defining Callbacks
(defun inverse-translate-objects (args types declarations rettype call)
`(let (,@(loop for arg in args and type in types
collect (list arg (expand-from-foreign
arg (parse-type type)))))
,@declarations
,(expand-to-foreign call (parse-type rettype))))
(defun parse-defcallback-options (options)
(destructuring-bind (&key (cconv :cdecl cconv-p)
(calling-convention cconv calling-convention-p)
(convention calling-convention))
options
(when cconv-p
(warn-obsolete-argument :cconv :convention))
(when calling-convention-p
(warn-obsolete-argument :calling-convention :convention))
(list :convention convention)))
(defmacro defcallback (name-and-options return-type args &body body)
(multiple-value-bind (body declarations)
(parse-body body :documentation t)
(let ((arg-names (mapcar #'car args))
(arg-types (mapcar #'cadr args))
(name (car (ensure-list name-and-options)))
(options (cdr (ensure-list name-and-options))))
`(progn
(%defcallback ,name ,(canonicalize-foreign-type return-type)
,arg-names ,(mapcar #'canonicalize-foreign-type arg-types)
,(inverse-translate-objects
arg-names arg-types declarations return-type
`(block ,name ,@body))
,@(parse-defcallback-options options))
',name))))
(declaim (inline get-callback))
(defun get-callback (symbol)
(%callback symbol))
(defmacro callback (name)
`(%callback ',name))