r11615: 2007-04-12 Kevin Rosenberg (kevin@rosenberg.net)

[uffi.git] / src / functions.lisp

diff --git a/src/functions.lisp b/src/functions.lisp
index fb74d6aaf1d7a5c8c08eb54583fe3ee355d0c557..aab3b63d934dddb50ba29c1f798327a6dc9d54ff 100644 (file)
--- a/src/functions.lisp
+++ b/src/functions.lisp
@@ -104,7 +104,7 @@
            (push (list (first arg)
                        (list :reference-return (second arg))) processed)
            (push (subseq arg 0 2) processed))
-       finally (return processed)))
+       finally (return (nreverse processed))))
 
 (defun preprocess-names (names)
   (let ((fname (gensym)))
@@ -146,21 +146,36 @@
        #+(or cmu scl sbcl)
        `(%def-function ,names ,args 
          ,@(if returning (list :returning returning) (values)))
-       #+lispworks
-       `(%def-function ,names ,(convert-lispworks-args args) 
+       #+(and lispworks lispworks5)
+       (multiple-value-bind (name-pair fname lisp-name)
+           (preprocess-names names)
+         `(progn
+              (%def-function ,name-pair ,(convert-lispworks-args args)
+                             ,@(if module (list :module module) (values))
+                             ,@(if returning (list :returning returning) (values)))
+              (defun ,lisp-name ,lisp-args
+                (,fname ,@(mapcar 
+                           #'(lambda (arg)
+                               (cond ((member (first arg) lisp-args)
+                                      (first arg))
+                                     ((member (first arg) out :key #'first)
+                                      t)))
+                         args)))))
+       #+(and lispworks (not lispworks5))
+       `(%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
+         `(progn
            (%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)
+                       ,@(mapcar #'(lambda (arg)
                                      (list 'deref-pointer
                                            (first arg)
                                            (second arg))) out))))))
@@ -176,7 +191,6 @@
         (function-args (process-function-args args))
         (foreign-name (if (atom names) names (car names)))
         (lisp-name (if (atom names) (make-lisp-name names) (cadr names))))
-
     ;; todo: calling-convention :stdcall for cormanlisp
     #+allegro
     `(ff:def-foreign-call (,lisp-name ,foreign-name)