From: Kevin M. Rosenberg Date: Fri, 27 Aug 2004 12:34:27 +0000 (+0000) Subject: r9929: patch for supporting :out from ben@medianstrip.net X-Git-Tag: v1.6.1~90 X-Git-Url: http://git.kpe.io/?p=uffi.git;a=commitdiff_plain;h=db363beace9ab3ba90fe398d6b373c6d6a834490 r9929: patch for supporting :out from ben@medianstrip.net --- diff --git a/debian/changelog b/debian/changelog index d32a3d2..530fbd8 100644 --- a/debian/changelog +++ b/debian/changelog @@ -1,3 +1,9 @@ +cl-uffi (1.4.25-1) unstable; urgency=low + + * New upstream + + -- Kevin M. Rosenberg Fri, 27 Aug 2004 06:33:16 -0600 + cl-uffi (1.4.24-1) unstable; urgency=low * Fix for OpenMCL from James Bielman diff --git a/doc/ref_aggregate.xml b/doc/ref_aggregate.xml index 09bbd74..c189264 100644 --- a/doc/ref_aggregate.xml +++ b/doc/ref_aggregate.xml @@ -377,7 +377,7 @@ structure. It's type is :pointer-self. Syntax - deref-array array type positon => value + deref-array array type position => value diff --git a/src/functions.lisp b/src/functions.lisp index 1b6b325..35f9f98 100644 --- a/src/functions.lisp +++ b/src/functions.lisp @@ -48,7 +48,8 @@ (let ((name (car arg)) (type (convert-from-uffi-type (cadr arg) :routine))) #+(or cmu sbcl scl) - (list name type :in) + ;(list name type :in) + `(,name ,type ,@(if (= (length arg) 3) (list (third arg)) (values))) #+(or allegro lispworks (and mcl (not openmcl))) (if (and (listp type) (listp (car type))) (append (list name) type) @@ -63,9 +64,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) + #+(or cmu sbcl scl allegro mcl cormanlisp) (declare (ignore module)) + + (multiple-value-bind (lisp-args out processed) + (preprocess-args args) + (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) +(defmacro %def-function (names args &key module returning) #+(or cmu sbcl scl allegro mcl cormanlisp) (declare (ignore module)) (let* ((result-type (convert-from-uffi-type returning :return)) diff --git a/tests/make.sh b/tests/make.sh index ba59d82..05d3632 100644 --- a/tests/make.sh +++ b/tests/make.sh @@ -2,17 +2,22 @@ case "`uname`" in Linux) os_linux=1 ;; + FreeBSD) os_freebsd=1 ;; Darwin) os_darwin=1 ;; SunOS) os_sunos=1 ;; AIX) os_aix=1 ;; *) echo "Unable to identify uname " `uname` - exit 1 ;; + exit 1 ;; esac - + if [ "$os_linux" ]; then gcc -fPIC -DPIC -c $SOURCE -o $OBJECT gcc -shared $OBJECT -o $SHARED_LIB +elif [ "$os_freebsd" ]; then + gcc -fPIC -DPIC -c $SOURCE -o $OBJECT + gcc -shared $OBJECT -o $SHARED_LIB + elif [ "$os_darwin" ]; then cc -dynamic -c $SOURCE -o $OBJECT ld -bundle /usr/lib/bundle1.o -flat_namespace -undefined suppress -o $BASE.dylib $OBJECT