X-Git-Url: http://git.kpe.io/?a=blobdiff_plain;f=src%2Ffunctions.lisp;h=fb74d6aaf1d7a5c8c08eb54583fe3ee355d0c557;hb=895cdddc64ad069c4d8173a21d0d5ce47b79e919;hp=600603d2ff33ad135361feb33856e74252f29afb;hpb=3dc00d0c4f7d59f610746a053f72fbe9d1a80fab;p=uffi.git

diff --git a/src/functions.lisp b/src/functions.lisp
index 600603d..fb74d6a 100644
--- a/src/functions.lisp
+++ b/src/functions.lisp
@@ -2,31 +2,27 @@
 ;;;; *************************************************************************
 ;;;; FILE IDENTIFICATION
 ;;;;
-;;;; Name:          function.cl
+;;;; Name:          function.lisp
 ;;;; Purpose:       UFFI source to C function definitions
 ;;;; Programmer:    Kevin M. Rosenberg
 ;;;; Date Started:  Feb 2002
 ;;;;
-;;;; $Id: functions.lisp,v 1.7 2003/02/06 06:54:22 kevin Exp $
+;;;; $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.
 ;;;; *************************************************************************
 
-(declaim (optimize (debug 3) (speed 3) (safety 1) (compilation-speed 0)))
-(in-package :uffi)
+(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))
@@ -49,8 +45,9 @@
   (let ((name (car arg))
 	(type (convert-from-uffi-type (cadr arg) :routine)))
     #+(or cmu sbcl scl)
-    (list name type :in)
-    #+(or allegro lispworks (and mcl (not openmcl)))
+    ;(list name type :in)
+    `(,name ,type ,@(if (= (length arg) 3) (list (third arg)) (values)))
+    #+(or allegro lispworks digitool)
     (if (and (listp type) (listp (car type)))
 	(append (list name) type)
       (list name type))
@@ -64,10 +61,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)
+  (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))
+	  ,@(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)
-  #+(or cmu sbcl scl allegro mcl cormanlisp) (declare (ignore module))
+(defmacro %def-function (names args &key module returning)
+  #+(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))
@@ -95,8 +198,8 @@
        ,@(if module (list :module module) (values))
        :result-type ,result-type
       :language :ansi-c
-       :calling-convention :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
@@ -118,10 +221,5 @@
     ))
 
 
-(defun make-lisp-name (name)
-  (let ((converted (substitute #\- #\_ name)))
-     (intern 
-      #+case-sensitive converted
-      #-case-sensitive (string-upcase converted))))