X-Git-Url: https://git.distorted.org.uk/~mdw/clg/blobdiff_plain/49ef0cdc631ac61e8a114fec45cca75786580915..00485707ad4f321c6a3e73533ff397d549a0efbf:/gffi/interface.lisp diff --git a/gffi/interface.lisp b/gffi/interface.lisp index 35a1a2f..bcb0cae 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.6 2007-09-07 07:28:42 espen Exp $ (in-package "GFFI") @@ -99,13 +99,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,12 +117,14 @@ (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) @@ -129,7 +135,8 @@ (%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 +173,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 +196,26 @@ (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))))))) + (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 +249,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) @@ -413,6 +435,18 @@ ;;;; 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 +457,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 +487,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