r9929: patch for supporting :out from ben@medianstrip.net

diff --git a/debian/changelog b/debian/changelog
index d32a3d22c4cdaf159237814159c2da924e1561ba..530fbd8752a525770eaf68970bf165b48e88dbb9 100644 (file)
--- a/debian/changelog
+++ b/debian/changelog
@@ -1,3 +1,9 @@
+cl-uffi (1.4.25-1) unstable; urgency=low
+
+  * New upstream
+
+ -- Kevin M. Rosenberg <kmr@debian.org>  Fri, 27 Aug 2004 06:33:16 -0600
+
 cl-uffi (1.4.24-1) unstable; urgency=low
 
   * Fix for OpenMCL from James Bielman

diff --git a/doc/ref_aggregate.xml b/doc/ref_aggregate.xml
index 09bbd741b1d451a93a42ebe769576a66a481d74e..c1892648ad5ef60af4fb3d818ce902af752f3fec 100644 (file)
--- a/doc/ref_aggregate.xml
+++ b/doc/ref_aggregate.xml
@@ -377,7 +377,7 @@ structure. It's type is <constant>:pointer-self</constant>.
       <refsynopsisdiv>
        <title>Syntax</title>
        <synopsis>
-         <function>deref-array</function> <replaceable>array type positon</replaceable> => <returnvalue>value</returnvalue>
+         <function>deref-array</function> <replaceable>array type position</replaceable> => <returnvalue>value</returnvalue>
        </synopsis>
       </refsynopsisdiv>
       <refsect1>

diff --git a/src/functions.lisp b/src/functions.lisp
index 1b6b32501f4d8bc044d6877b5233eaa8fc019bc9..35f9f9837c5b8d5037253c53f16c744b105fe6c3 100644 (file)
--- a/src/functions.lisp
+++ b/src/functions.lisp
@@ -48,7 +48,8 @@
   (let ((name (car arg))
        (type (convert-from-uffi-type (cadr arg) :routine)))
     #+(or cmu sbcl scl)
-    (list name type :in)
+    ;(list name type :in)
+    `(,name ,type ,@(if (= (length arg) 3) (list (third arg)) (values)))
     #+(or allegro lispworks (and mcl (not openmcl)))
     (if (and (listp type) (listp (car type)))
        (append (list name) type)
@@ -63,9 +64,116 @@
       (list type)
     type))
 
+(defun funcallable-lambda-list (args)
+  (let ((ll nil))
+    (dolist (arg args)
+      (push (car arg) ll))
+    (nreverse ll)))
+
+#|
+(defmacro def-funcallable (name args &key returning)
+  (let ((result-type (convert-from-uffi-type returning :return))
+       (function-args (process-function-args args)))
+    #+lispworks
+    `(fli:define-foreign-funcallable ,name ,function-args
+      :result-type ,result-type
+      :language :ansi-c
+      :calling-convention :cdecl)
+    #+(or cmu scl sbcl)
+    ;; requires the type of the function pointer be declared correctly!
+    (let* ((ptrsym (gensym))
+          (ll (funcallable-lambda-list args)))
+      `(defun ,name ,(cons ptrsym ll)
+       (alien::alien-funcall ,ptrsym ,@ll)))
+    #+openmcl
+    (multiple-value-bind (params args) (process-function-args args)
+      (let ((ptrsym (gensym)))
+       `(defun ,name ,(cons ptrsym params)
+         (ccl::ff-call ,ptrsym ,@args ,result-type))))
+    #+allegro
+    ;; this is most definitely wrong
+    (let* ((ptrsym (gensym))
+          (ll (funcallable-lambda-list args)))
+      `(defun ,name ,(cons ptrsym ll)
+       (system::ff-funcall ,ptrsym ,@ll)))
+    ))
+|#    
+
+(defun convert-lispworks-args (args)
+  (loop for arg in args
+       with processed = nil
+       do
+       (if (and (= (length arg) 3) (eq (third arg) :out))
+           (push (list (first arg)
+                       (list :reference-return (second arg))) processed)
+           (push (subseq arg 0 2) processed))
+       finally (return processed)))
+
+(defun preprocess-names (names)
+  (let ((fname (gensym)))
+    (if (atom names)
+       (values (list names fname) fname (uffi::make-lisp-name names))
+       (values (list (first names) fname) fname (second names)))))
+
+(defun preprocess-args (args)
+  (loop for arg in args
+       with lisp-args = nil and out = nil and processed = nil
+       do
+       (if (= (length arg) 3)
+           (ecase (third arg)
+             (:in 
+              (progn
+                (push (first arg) lisp-args)
+                (push (list (first arg) (second arg)) processed)))
+             (:out
+              (progn
+                (push (list (first arg) (second arg)) out)
+                (push (list (first arg) (list '* (second arg))) processed))))
+           (progn
+             (push (first arg) lisp-args)
+             (push arg processed)))
+       finally (return (values (nreverse lisp-args) 
+                               (nreverse out) 
+                               (nreverse processed)))))
+
+
+(defmacro def-function (names args &key module returning)
+  #+(or cmu sbcl scl allegro mcl cormanlisp) (declare (ignore module))
+
+  (multiple-value-bind (lisp-args out processed)
+      (preprocess-args args)
+    (if (= (length out) 0)
+       `(%def-function ,names ,args 
+         ,@(if module (list :module module) (values))
+         ,@(if returning (list :returning returning) (values)))
+
+       #+(or cmu scl sbcl)
+       `(%def-function ,names ,args 
+         ,@(if returning (list :returning returning) (values)))
+       #+lispworks
+       `(%def-function ,names ,(convert-lispworks-args args) 
+         ,@(if module (list :module module) (values))
+         ,@(if returning (list :returning returning) (values)))
+       #-(or cmu scl sbcl lispworks)
+       (multiple-value-bind (name-pair fname lisp-name)
+           (preprocess-names names)
+         `(prog1
+           (%def-function ,name-pair ,processed 
+            :module ,module :returning ,returning)
+           ;(declaim (inline ,fname))
+           (defun ,lisp-name ,lisp-args
+             (with-foreign-objects ,out
+               (values (,fname ,@(mapcar #'first args))
+                       ,@(mapcar #'(lambda (arg)
+                                     (list 'deref-pointer
+                                           (first arg)
+                                           (second arg))) out))))))
+       )))
+       
+
 ;; name is either a string representing foreign name, or a list
 ;; of foreign-name as a string and lisp name as a symbol
-(defmacro def-function (names args &key module returning)
+(defmacro %def-function (names args &key module returning)
   #+(or cmu sbcl scl allegro mcl cormanlisp) (declare (ignore module))
   
   (let* ((result-type (convert-from-uffi-type returning :return))

diff --git a/tests/make.sh b/tests/make.sh
index ba59d82321738481c46ba55e7e885b1bcc218bc1..05d363245f5d16227c188e5dd183b87de466b268 100644 (file)
--- a/tests/make.sh
+++ b/tests/make.sh
@@ -2,17 +2,22 @@
 
 case "`uname`" in
     Linux) os_linux=1 ;;
+    FreeBSD) os_freebsd=1 ;;
     Darwin) os_darwin=1 ;;
     SunOS) os_sunos=1 ;;
     AIX) os_aix=1 ;;
     *) echo "Unable to identify uname " `uname`
-       exit 1 ;;       
+       exit 1 ;;
 esac
-    
+
 if [ "$os_linux" ]; then
     gcc -fPIC -DPIC -c $SOURCE -o $OBJECT
     gcc -shared $OBJECT -o $SHARED_LIB
 
+elif [ "$os_freebsd" ]; then
+    gcc -fPIC -DPIC -c $SOURCE -o $OBJECT
+    gcc -shared $OBJECT -o $SHARED_LIB
+
 elif [ "$os_darwin" ]; then
     cc -dynamic -c $SOURCE -o $OBJECT
     ld -bundle /usr/lib/bundle1.o -flat_namespace -undefined suppress -o $BASE.dylib $OBJECT