X-Git-Url: https://git.distorted.org.uk/~mdw/clg/blobdiff_plain/b673a77b9342c272dc57fc0b54396cd1b162a9b5..f28952dfbbc69735b835a429131f2384eee7e9d0:/gffi/interface.lisp

diff --git a/gffi/interface.lisp b/gffi/interface.lisp
index 6778ea6..72e3c13 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.5 2007-04-06 16:06:24 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)))
@@ -99,13 +103,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 +121,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)
@@ -174,7 +192,7 @@
 
 ;; 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))
@@ -189,12 +207,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))))))))))
 
 
 
@@ -285,7 +318,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 
@@ -362,8 +398,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 
@@ -385,6 +424,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)
@@ -410,10 +455,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)
@@ -463,17 +522,14 @@
 	  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