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 ad8aca4382a2ff8b7091b9606b63a83bc931789f..fb74d6aaf1d7a5c8c08eb54583fe3ee355d0c557 100644 (file)
--- a/src/functions.lisp
+++ b/src/functions.lisp
@@ -2,59 +2,57 @@
 ;;;; *************************************************************************
 ;;;; FILE IDENTIFICATION
 ;;;;
 ;;;; *************************************************************************
 ;;;; FILE IDENTIFICATION
 ;;;;

-;;;; Name:          function.cl
+;;;; Name:          function.lisp

 ;;;; Purpose:       UFFI source to C function definitions
 ;;;; Programmer:    Kevin M. Rosenberg
 ;;;; Date Started:  Feb 2002
 ;;;;
 ;;;; Purpose:       UFFI source to C function definitions
 ;;;; Programmer:    Kevin M. Rosenberg
 ;;;; Date Started:  Feb 2002
 ;;;;

-;;;; $Id: functions.lisp,v 1.4 2002/10/14 03:07:41 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)
 
 (defun process-function-args (args)
   (if (null args)

-      #+(or lispworks cmu sbcl cormanlisp (and mcl (not openmcl))) nil
+      #+(or lispworks cmu sbcl scl cormanlisp digitool) nil

       #+allegro '(:void)
       #+allegro '(:void)

-      #+mcl (values nil nil)
+      #+openmcl (values nil nil)

 
       ;; args not null
 
       ;; args not null

-      #+(or lispworks allegro cmu sbcl (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))
        (nreverse processed))
       #+openmcl
       (let ((processed nil)
       (let (processed)
        (dolist (arg args)
          (push (process-one-function-arg arg) processed))
        (nreverse processed))
       #+openmcl
       (let ((processed nil)

-           (params nil)
-           name type)
+           (params nil))

        (dolist (arg args)
        (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))
+         (let ((name (car arg))
+               (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)))
     ))
 
 (defun process-one-function-arg (arg)
   (let ((name (car arg))
        (type (convert-from-uffi-type (cadr arg) :routine)))
        (values (nreverse params) (nreverse processed)))
     ))
 
 (defun process-one-function-arg (arg)
   (let ((name (car arg))
        (type (convert-from-uffi-type (cadr arg) :routine)))

-    #+(or cmu sbcl)
-    (list name type :in)
-    #+(or allegro lispworks (and mcl (not openmcl)))
+    #+(or cmu sbcl scl)
+    ;(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))

+    #+openmcl
+    (declare (ignore 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 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))


@@ -80,7 +184,7 @@
        :returning ,(allegro-convert-return-type result-type)
        :call-direct t
        :strings-convert nil)
        :returning ,(allegro-convert-return-type result-type)
        :call-direct t
        :strings-convert nil)

-    #+cmu
+    #+(or cmu scl)

     `(alien:def-alien-routine (,foreign-name ,lisp-name)
         ,result-type
        ,@function-args)
     `(alien:def-alien-routine (,foreign-name ,lisp-name)
         ,result-type
        ,@function-args)


@@ -93,12 +197,15 @@
         ,function-args
        ,@(if module (list :module module) (values))
        :result-type ,result-type
         ,function-args
        ,@(if module (list :module module) (values))
        :result-type ,result-type

-       :calling-convention :cdecl)
-    #+(and mcl (not openmcl))
+      :language :ansi-c
+       #+:win32 :calling-convention #+:win32 :cdecl)
+    #+digitool

     `(eval-when (:compile-toplevel :load-toplevel :execute)
        (ccl:define-entry-point (,lisp-name ,foreign-name)
          ,function-args
          ,result-type))
     `(eval-when (:compile-toplevel :load-toplevel :execute)
        (ccl:define-entry-point (,lisp-name ,foreign-name)
          ,function-args
          ,result-type))

+    #+openmcl
+    (declare (ignore function-args))

     #+(and openmcl darwinppc-target)
     (setf foreign-name (concatenate 'string "_" foreign-name))
     #+openmcl
     #+(and openmcl darwinppc-target)
     (setf foreign-name (concatenate 'string "_" foreign-name))
     #+openmcl


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

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