X-Git-Url: https://git.distorted.org.uk/~mdw/clg/blobdiff_plain/49ef0cdc631ac61e8a114fec45cca75786580915..f1cd62bb56113ab79947e38ee321f3485f5fcca5:/gffi/interface.lisp diff --git a/gffi/interface.lisp b/gffi/interface.lisp index 35a1a2f..6b918d2 100644 --- a/gffi/interface.lisp +++ b/gffi/interface.lisp @@ -20,7 +20,7 @@ ;; TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE ;; SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. -;; $Id: interface.lisp,v 1.2 2006-04-26 19:19:14 espen Exp $ +;; $Id: interface.lisp,v 1.10 2008-12-10 02:40:18 espen Exp $ (in-package "GFFI") @@ -72,15 +72,19 @@ #'string-capitalize (cons prefix (split-string (symbol-name type-name) :delimiter #\-)))))) -(defun default-type-name (alien-name) - (let ((parts - (mapcar - #'string-upcase - (split-string-if alien-name #'upper-case-p)))) - (intern - (concatenate-strings (rest parts) #\-) - (find-prefix-package (first parts))))) +(defun split-alien-name (alien-name) + (let ((parts (split-string-if alien-name #'upper-case-p))) + (do ((prefix (first parts) (concatenate 'string prefix (first rest))) + (rest (rest parts) (cdr rest))) + ((null rest) + (error "Couldn't split alien name '~A' to find a registered prefix" + alien-name)) + (when (find-prefix-package prefix) + (return (values (string-upcase (concatenate-strings rest #\-)) + (find-prefix-package prefix))))))) +(defun default-type-name (alien-name) + (multiple-value-call #'intern (split-alien-name alien-name))) (defun in-arg-p (style) (find style '(:in :in/out :in/return :in-out :return))) @@ -92,6 +96,29 @@ (find style '(:in/return :return))) (defmacro defbinding (name lambda-list return-type &rest args) + "This defines a foreign function call. NAME should either be a symbol or a +list (LISP-SYM STRING). The lisp function will be given the name of the lisp +symbol and the foreign function name is either the string given or automatically +generated using DEFAULT-ALIEN-FNAME. + +If LAMBDA-LIST is nil, the lambda list for the generated lisp function is +automatically computed from the input arguments as described below. If it is +non-nil, it gives the lambda list for the function. To manually specify an empty +lambda list, pass (NIL) which gets recognised as a special value. + +RETURN-TYPE should be a valid type. + +A normal element of ARGS is a list matching + + (EXPR TYPE &OPTIONAL (STYLE :IN) (OUT-TYPE TYPE)) + +however a shorthand form for an input parameter with name the same as its type +is that you can just give the atom TYPE as an argument. The lambda-list for the +function is the list of all input arguments, although if an EXPR is repeated, it +will only appear once. To add a constant argument, define one with STYLE :IN and +EXPR the value it should take. + +To give the binding a docstring, pass a string as the first element of ARGS." (multiple-value-bind (lisp-name c-name) (if (atom name) (values name (default-alien-fname name)) @@ -99,13 +126,17 @@ (let* ((lambda-list-supplied-p lambda-list) (lambda-list (unless (equal lambda-list '(nil)) lambda-list)) - (aux-vars ()) + (arg-types ()) + (aux-bindings ()) (doc-string (when (stringp (first args)) (pop args))) (parsed-args (mapcar #'(lambda (arg) (destructuring-bind - (expr type &optional (style :in) (out-type type)) arg + (expr type &optional (style :in) (out-type type)) + (if (atom arg) + (list arg arg) + arg) (cond ((find style '(:in-out :return)) (warn "Deprecated argument style: ~S" style)) @@ -113,23 +144,33 @@ (error "Bogus argument style: ~S" style))) (when (and (not lambda-list-supplied-p) - (namep expr) (in-arg-p style)) - (push expr lambda-list)) + (namep expr) (in-arg-p style) + (not (find expr lambda-list))) + (push expr lambda-list) + (push type arg-types)) (let ((aux (unless (or (not (in-arg-p style)) (namep expr)) (gensym)))) (when aux - (push `(,aux ,expr) aux-vars)) + (push (list aux expr) aux-bindings)) (list (cond ((and (namep expr) (not (in-arg-p style))) expr) - ((namep expr) (make-symbol (string expr))) - ((gensym))) + ((namep expr) + #-clisp(make-symbol (string expr)) + ;; The above used to work in CLISP, but I'm + ;; not sure exactly at which version it + ;; broke. The following could potentially + ;; cause variable capturing + #+clisp(intern (format nil "~A-~A" (string expr) (gensym)))) + (#-clisp(gensym) + #+clisp(intern (string (gensym))))) (or aux expr) type style out-type)))) args))) (%defbinding c-name lisp-name (if lambda-list-supplied-p lambda-list (nreverse lambda-list)) - aux-vars return-type doc-string parsed-args)))) + (not lambda-list-supplied-p) (nreverse arg-types) + aux-bindings return-type doc-string parsed-args)))) #+(or cmu sbcl) @@ -166,14 +207,15 @@ (:language :stdc)))) `(funcall (load-time-value - (ffi::foreign-library-function ,cname (ffi::foreign-library :default) + (ffi::foreign-library-function + ,cname (ffi::foreign-library :default) #?(clisp>= 2 40)nil nil (ffi:parse-c-type ',c-function))) ,@fparams))) ;; TODO: check if in and out types (if different) translates to same ;; alien type -(defun %defbinding (cname lisp-name lambda-list aux-vars return-type doc args) +(defun %defbinding (cname lisp-name lambda-list declare-p arg-types aux-bindings return-type doc args) (let ((out (loop for (var expr type style out-type) in args when (or (out-arg-p style) (return-arg-p style)) @@ -188,12 +230,27 @@ (alien-arg-wrapper type var expr style (create-wrapper (rest args) body))) body))) - `(defun ,lisp-name ,lambda-list + `(progn + ,(when declare-p + `(declaim + (ftype + (function + ,(mapcar #'argument-type arg-types) + (values + ,@(when return-type (list (return-type return-type))) + ,@(loop + for (var expr type style out-type) in args + when (out-arg-p style) + collect (return-type out-type) + when (return-arg-p style) + collect (return-type type)))) + ,lisp-name))) + (defun ,lisp-name ,lambda-list ,doc - (let ,aux-vars + (let ,aux-bindings ,(if return-type (create-wrapper args `(values ,fcall ,@out)) - (create-wrapper args `(progn ,fcall (values ,@out))))))))) + (create-wrapper args `(progn ,fcall (values ,@out)))))))))) @@ -227,7 +284,7 @@ (system-area-pointer address)))))) #+clisp (ffi::foreign-library-function name - (ffi::foreign-library :default) + (ffi::foreign-library :default) #?(clisp>= 2 40)nil nil (ffi:parse-c-type c-function))) (return-value-translator (from-alien-function return-type))) (multiple-value-bind (arg-translators cleanup-funcs) @@ -284,7 +341,10 @@ (let ((define-callback #+cmu'alien:def-callback #+(and sbcl alien-callbacks)'sb-alien::define-alien-callback - #+(and sbcl (not alien-callbacks))'sb-alien:define-alien-function)) + #+(and sbcl (not alien-callbacks))'sb-alien:define-alien-function) + (args (mapcar #'(lambda (arg) + (if (atom arg) (list arg arg) arg)) + args))) `(progn #+cmu(defparameter ,name nil) (,define-callback ,name @@ -361,8 +421,11 @@ ;;; translated according to RETTYPE. Obtain a pointer that can be ;;; passed to C code for this callback by calling %CALLBACK. (defmacro define-callback (name return-type args &body body) - (let ((arg-names (mapcar #'first args)) - (arg-types (mapcar #'second args))) + (let* ((args (mapcar #'(lambda (arg) + (if (atom arg) (list arg arg) arg)) + args)) + (arg-names (mapcar #'first args)) + (arg-types (mapcar #'second args))) `(progn (defvar ,name ',name) (register-callback ',name @@ -384,6 +447,12 @@ ;;;; Type expansion +;; A hack to make the TYPE-EXPAND code for SBCL work. +#?+(pkg-config:sbcl>= 1 0 35 15) +(sb-ext:without-package-locks + (setf (symbol-function 'sb-kernel::type-expand) + (lambda (form) (typexpand form)))) + (defun type-expand-1 (form) #+(or cmu sbcl) (let ((def (cond ((symbolp form) @@ -409,10 +478,24 @@ (error "~A can not be expanded to ~A" form type)))))) (expand form))) +(defun type-equal-p (type1 type2) + (and (subtypep type1 type2) (subtypep type2 type1))) ;;;; Type methods +(defun find-type-method (name type-spec &optional (error-p t)) + (let ((type-methods (get name 'type-methods)) + (specifier (if (atom type-spec) + type-spec + (first type-spec)))) + (or + (gethash specifier type-methods) + (when error-p + (error + "No explicit type method for ~A when call width type specifier ~A found" + name type-spec))))) + (defun find-next-type-method (name type-spec &optional (error-p t)) (let ((type-methods (get name 'type-methods))) (labels ((search-method-in-cpl-order (classes) @@ -423,7 +506,7 @@ (lookup-method (type-spec) (if (and (symbolp type-spec) (find-class type-spec nil)) (let ((class (find-class type-spec))) - #+clisp + #?(or (sbcl>= 0 9 15) (featurep :clisp)) (unless (class-finalized-p class) (finalize-inheritance class)) (search-method-in-cpl-order @@ -453,24 +536,23 @@ ;; This is to handle unexpandable types whichs doesn't name a ;; class. It may cause infinite loops with illegal ;; call-next-method calls - (unless (and (symbolp type-spec) (find-class type-spec nil)) + (unless (or + (null type-spec) + (and (symbolp type-spec) (find-class type-spec nil))) (search-nodes (get name 'built-in-type-hierarchy))) (when error-p (error "No next type method ~A for type specifier ~A" name type-spec)))))) (defun find-applicable-type-method (name type-spec &optional (error-p t)) - (let ((type-methods (get name 'type-methods)) - (specifier (if (atom type-spec) - type-spec - (first type-spec)))) - (or - (gethash specifier type-methods) - (find-next-type-method name type-spec nil) - (when error-p - (error - "No applicable type method for ~A when call width type specifier ~A" - name type-spec))))) + (or + (find-type-method name type-spec nil) + (find-next-type-method name type-spec nil) + (when error-p + (error + "No applicable type method for ~A when call width type specifier ~A" + name type-spec)))) + (defun insert-type-in-hierarchy (specifier function nodes) (cond