X-Git-Url: https://www.chiark.greenend.org.uk/ucgi/~mdw/git/clg/blobdiff_plain/49ef0cdc631ac61e8a114fec45cca75786580915..cab97f15ae5940cd20884ed8c5ca99a9afc0f226:/gffi/interface.lisp diff --git a/gffi/interface.lisp b/gffi/interface.lisp index 35a1a2f..6b249a3 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.9 2008-10-08 16:34:07 espen Exp $ (in-package "GFFI") @@ -99,13 +99,17 @@ (defmacro defbinding (name lambda-list return-type &rest args) (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 +117,33 @@ (defmacro defbinding (name lambda-list return-type &rest args) (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 +180,15 @@ (defun foreign-funcall (cname args return-type) (: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 +203,27 @@ (defun %defbinding (cname lisp-name lambda-list aux-vars return-type doc args) (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 +257,7 @@ (defun mkbinding (name return-type &rest arg-types) (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 +314,10 @@ (defmacro define-callback (name return-type args &body body) (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 +394,11 @@ (defun restore-callback-pointers () ;;; 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 @@ -413,6 +449,18 @@ (defun type-expand-to (type form) ;;;; 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 +471,7 @@ (defun find-next-type-method (name type-spec &optional (error-p t)) (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 +501,23 @@ (defun find-next-type-method (name type-spec &optional (error-p t)) ;; 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