chiark / gitweb /
Bug fix (function name included in declarations)
[clg] / gffi / interface.lisp
index 88ce957..6b249a3 100644 (file)
@@ -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.3 2006-08-16 11:02:45 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)
@@ -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