r11710: fix build-twice-in-a-row

[uffi.git] / src / functions.lisp

diff --git a/src/functions.lisp b/src/functions.lisp
index 1610b2246849e5e386227965f82c9a0f88fc0279..aab3b63d934dddb50ba29c1f798327a6dc9d54ff 100644 (file)
--- a/src/functions.lisp
+++ b/src/functions.lisp
@@ -9,23 +9,20 @@
 ;;;;
 ;;;; $Id$
 ;;;;
-;;;; This file, part of UFFI, is Copyright (c) 2002 by Kevin M. Rosenberg
+;;;; This file, part of UFFI, is Copyright (c) 2005 by Kevin M. Rosenberg
 ;;;;
-;;;; UFFI users are granted the rights to distribute and use this software
-;;;; as governed by the terms of the Lisp Lesser GNU Public License
-;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL.
 ;;;; *************************************************************************
 
 (in-package #:uffi)
 
 (defun process-function-args (args)
   (if (null args)
-      #+(or lispworks cmu sbcl scl cormanlisp (and mcl (not openmcl))) nil
+      #+(or lispworks cmu sbcl scl cormanlisp digitool) nil
       #+allegro '(:void)
       #+openmcl (values nil nil)
 
       ;; args not null
-      #+(or lispworks allegro cmu sbcl scl (and mcl (not openmcl)) cormanlisp)
+      #+(or lispworks allegro cmu sbcl scl digitool cormanlisp)
       (let (processed)
        (dolist (arg args)
          (push (process-one-function-arg arg) processed))
@@ -50,7 +47,7 @@
     #+(or cmu sbcl scl)
     ;(list name type :in)
     `(,name ,type ,@(if (= (length arg) 3) (list (third arg)) (values)))
-    #+(or allegro lispworks (and mcl (not openmcl)))
+    #+(or allegro lispworks digitool)
     (if (and (listp type) (listp (car type)))
        (append (list name) type)
       (list name type))
@@ -107,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)))
@@ -140,6 +137,7 @@
 (defmacro def-function (names args &key module returning)
   (multiple-value-bind (lisp-args out processed)
       (preprocess-args args)
+    (declare (ignorable lisp-args processed))
     (if (= (length out) 0)
        `(%def-function ,names ,args 
          ,@(if module (list :module module) (values))
@@ -148,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))))))
@@ -172,13 +185,12 @@
 ;; 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)
-  #+(or cmu sbcl scl allegro mcl cormanlisp) (declare (ignore module))
+  #+(or cmu sbcl scl allegro openmcl digitool cormanlisp) (declare (ignore module))
   
   (let* ((result-type (convert-from-uffi-type returning :return))
         (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)
@@ -200,8 +212,8 @@
        ,@(if module (list :module module) (values))
        :result-type ,result-type
       :language :ansi-c
-       #-macosx :calling-convention #-macosx :cdecl)
-    #+(and mcl (not openmcl))
+       #+:win32 :calling-convention #+:win32 :cdecl)
+    #+digitool
     `(eval-when (:compile-toplevel :load-toplevel :execute)
        (ccl:define-entry-point (,lisp-name ,foreign-name)
          ,function-args