X-Git-Url: http://git.kpe.io/?a=blobdiff_plain;f=src%2Ffunctions.lisp;h=01d62eab7c83546737aca36832ee6b30d278a3cf;hb=HEAD;hp=1610b2246849e5e386227965f82c9a0f88fc0279;hpb=5a7117c2a750662b4ecd36c62c7c073d76f64b4e;p=uffi.git diff --git a/src/functions.lisp b/src/functions.lisp index 1610b22..01d62ea 100644 --- a/src/functions.lisp +++ b/src/functions.lisp @@ -7,56 +7,51 @@ ;;;; Programmer: Kevin M. Rosenberg ;;;; Date Started: Feb 2002 ;;;; -;;;; $Id$ +;;;; This file, part of UFFI, is Copyright (c) 2002-2010 by Kevin M. Rosenberg ;;;; -;;;; This file, part of UFFI, is Copyright (c) 2002 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) - #+(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)) - (nreverse processed)) + (dolist (arg args) + (push (process-one-function-arg arg) processed)) + (nreverse processed)) #+openmcl (let ((processed nil) - (params nil)) - (dolist (arg args) - (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))) + (params nil)) + (dolist (arg args) + (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))) + (type (convert-from-uffi-type (cadr arg) :routine))) #+(or cmu sbcl scl) ;(list name type :in) `(,name ,type ,@(if (= (length arg) 3) (list (third arg)) (values))) - #+(or allegro lispworks (and mcl (not openmcl))) + #+(or allegro lispworks digitool) (if (and (listp type) (listp (car type))) - (append (list name) type) + (append (list name) type) (list name type)) #+openmcl (declare (ignore name type)) - )) + )) (defun allegro-convert-return-type (type) @@ -73,7 +68,7 @@ #| (defmacro def-funcallable (name args &key returning) (let ((result-type (convert-from-uffi-type returning :return)) - (function-args (process-function-args args))) + (function-args (process-function-args args))) #+lispworks `(fli:define-foreign-funcallable ,name ,function-args :result-type ,result-type @@ -82,126 +77,141 @@ #+(or cmu scl sbcl) ;; requires the type of the function pointer be declared correctly! (let* ((ptrsym (gensym)) - (ll (funcallable-lambda-list args))) + (ll (funcallable-lambda-list args))) `(defun ,name ,(cons ptrsym ll) - (alien::alien-funcall ,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)))) + `(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))) + (ll (funcallable-lambda-list args))) `(defun ,name ,(cons ptrsym ll) - (system::ff-funcall ,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))) + 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 (nreverse 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))))) + (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))))) + 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)))))) - ))) - + `(%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))) + #+(or lispworks5 lispworks6) + (multiple-value-bind (name-pair fname lisp-name) + (preprocess-names names) + `(progn + (%def-function ,name-pair ,(convert-lispworks-args args) + ,@(if module (list :module module) (values)) + ,@(if returning (list :returning returning) (values))) + (defun ,lisp-name ,lisp-args + (,fname ,@(mapcar + #'(lambda (arg) + (cond ((member (first arg) lisp-args) + (first arg)) + ((member (first arg) out :key #'first) + t))) + args))))) + #+(and lispworks (not lispworks5) (not lispworks 6)) + `(%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) + `(progn + (%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)) - - (let* ((result-type (convert-from-uffi-type returning :return)) - (function-args (process-function-args args)) - (foreign-name (if (atom names) names (car names))) - (lisp-name (if (atom names) (make-lisp-name names) (cadr names)))) + #+(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)) + (foreign-name (if (atom names) names (car names))) + (lisp-name (if (atom names) (make-lisp-name names) (cadr names)))) ;; todo: calling-convention :stdcall for cormanlisp #+allegro `(ff:def-foreign-call (,lisp-name ,foreign-name) - ,function-args + ,function-args :returning ,(allegro-convert-return-type result-type) :call-direct t :strings-convert nil) #+(or cmu scl) `(alien:def-alien-routine (,foreign-name ,lisp-name) - ,result-type + ,result-type ,@function-args) #+sbcl `(sb-alien:define-alien-routine (,foreign-name ,lisp-name) - ,result-type + ,result-type ,@function-args) #+lispworks `(fli:define-foreign-function (,lisp-name ,foreign-name :source) - ,function-args + ,function-args ,@(if module (list :module module) (values)) :result-type ,result-type :language :ansi-c - #-macosx :calling-convention #-macosx :cdecl) - #+(and mcl (not openmcl)) + #+:mswindows :calling-convention #+:mswindows :cdecl) + #+digitool `(eval-when (:compile-toplevel :load-toplevel :execute) (ccl:define-entry-point (,lisp-name ,foreign-name) ,function-args