r2784: *** empty log message ***

[uffi.git] / src-mcl / functions.cl

diff --git a/src-mcl/functions.cl b/src-mcl/functions.cl
index 2db1fd9f95dcdef58bb87230f9157de4037033ab..693f15d96560825036d42a59d2344d30bc3e7633 100644 (file)
--- a/src-mcl/functions.cl
+++ b/src-mcl/functions.cl
@@ -7,7 +7,7 @@
 ;;;; Programmers:   Kevin M. Rosenberg and John DeSoi
 ;;;; Date Started:  Feb 2002
 ;;;;
-;;;; $Id: functions.cl,v 1.1 2002/09/16 17:57:43 kevin Exp $
+;;;; $Id: functions.cl,v 1.2 2002/09/20 04:51:14 kevin Exp $
 ;;;;
 ;;;; This file, part of UFFI, is Copyright (c) 2002 by Kevin M. Rosenberg
 ;;;; and John DeSoi
@@ -20,37 +20,37 @@
 (declaim (optimize (debug 3) (speed 3) (safety 1) (compilation-speed 0)))
 (in-package :uffi)
 
+
+(defun make-lisp-name (name)
+  (let ((converted (substitute #\- #\_ name)))
+     (intern 
+      #+case-sensitive converted
+      #-case-sensitive (string-upcase converted))))
+
+#-openmcl
 (defun process-function-args (args)
   (if (null args)
-      #+lispworks nil
-      #+allegro '(:void)
-      #+cmu nil
-      #+mcl nil
-      (let (processed)
-       (dolist (arg args)
-         (push (process-one-function-arg arg) processed))
-       (nreverse processed))))
+    nil
+    (let (processed)
+      (dolist (arg args)
+        (push (process-one-function-arg arg) processed))
+      (nreverse processed))))
 
+#-openmcl
 (defun process-one-function-arg (arg)
   (let ((name (car arg))
        (type (convert-from-uffi-type (cadr arg) :routine)))
     (if (and (listp type) (listp (car type)))
-       (append (list name) type)
+      (append (list name) type)
       (list name type))
     ))
 
-(defun allegro-convert-return-type (type)
-  (if (and (listp type) (not (listp (car type))))
-      (list type)
-    type))
 
 ;; name is either a string representing foreign name, or a list
 ;; of foreign-name as a string and lisp name as a symbol
-
-
+#-openmcl
 (defmacro def-function (names args &key module returning)
   (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)))
@@ -61,10 +61,33 @@
          ,result-type))))
 
 
-(defun make-lisp-name (name)
-  (let ((converted (substitute #\- #\_ name)))
-     (intern 
-      #+case-sensitive converted
-      #-case-sensitive (string-upcase converted))))
 
+#+openmcl
+(defun process-function-args (args)
+  (if (null args)
+    (values nil nil)
+    (let ((processed nil)
+          (params nil)
+          name type)
+      (dolist (arg args)
+        (setf name (car arg))
+        (setf type (convert-from-uffi-type (cadr arg) :routine))
+        ;(when (and (listp type) (eq (car type) :address))
+        ;(setf type :address))
+        (push name params)
+        (push type processed)
+        (push name processed))
+      (values (nreverse params) (nreverse processed)))))
+       
 
+#+openmcl
+(defmacro def-function (names args &key module returning)
+  (declare (ignore module))
+  (let* ((result-type (convert-from-uffi-type returning :return))
+        (foreign-name (if (atom names) names (car names)))
+        (lisp-name (if (atom names) (make-lisp-name names) (cadr names))))
+    #+darwinppc-target 
+    (setf foreign-name (concatenate 'string "_" foreign-name))
+    (multiple-value-bind (params args) (process-function-args args)
+      `(defun ,lisp-name ,params
+         (ccl::external-call ,foreign-name ,@args ,result-type)))))