r11214: 2006-10-10 Kevin Rosenberg (kevin@rosenberg.net)

[uffi.git] / src / functions.lisp

diff --git a/src/functions.lisp b/src/functions.lisp
index 9469945367265763b5814df2023dfebd351b8e05..fb74d6aaf1d7a5c8c08eb54583fe3ee355d0c557 100644 (file)
--- a/src/functions.lisp
+++ b/src/functions.lisp
@@ -7,25 +7,22 @@
 ;;;; Programmer:    Kevin M. Rosenberg
 ;;;; Date Started:  Feb 2002
 ;;;;
 ;;;; Programmer:    Kevin M. Rosenberg
 ;;;; Date Started:  Feb 2002
 ;;;;

-;;;; $Id: functions.lisp,v 1.8 2003/06/06 21:59:18 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.

 ;;;; *************************************************************************
 
 (in-package #:uffi)
 
 (defun process-function-args (args)
   (if (null args)
 ;;;; *************************************************************************
 
 (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
       #+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))
       (let (processed)
        (dolist (arg args)
          (push (process-one-function-arg arg) processed))


@@ -48,8 +45,9 @@
   (let ((name (car arg))
        (type (convert-from-uffi-type (cadr arg) :routine)))
     #+(or cmu sbcl scl)
   (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))
     (if (and (listp type) (listp (car type)))
        (append (list name) type)
       (list name type))


@@ -63,10 +61,116 @@
       (list type)
     type))
 
       (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
 ;; 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))
   
   (let* ((result-type (convert-from-uffi-type returning :return))
         (function-args (process-function-args args))


@@ -94,8 +198,8 @@
        ,@(if module (list :module module) (values))
        :result-type ,result-type
       :language :ansi-c
        ,@(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
     `(eval-when (:compile-toplevel :load-toplevel :execute)
        (ccl:define-entry-point (,lisp-name ,foreign-name)
          ,function-args


@@ -117,10 +221,5 @@
     ))
 
 
     ))
 
 

-(defun make-lisp-name (name)
-  (let ((converted (substitute #\- #\_ name)))
-     (intern 
-      #+case-sensitive converted
-      #-case-sensitive (string-upcase converted))))