diff --git a/init/body-expand.lisp b/init/body-expand.lisp index ad4cbe9571df796bccd4b2e5a707e1163df02aa7..f9daf3e4072211ad3aff98fd698edce760cfea6a 100644 --- a/init/body-expand.lisp +++ b/init/body-expand.lisp @@ -1,6 +1,6 @@ ;; Expand the body of a defmfun ;; Liam Healy 2009-04-13 22:07:13EDT body-expand.lisp -;; Time-stamp: <2009-05-03 10:03:03EDT body-expand.lisp> +;; Time-stamp: <2009-05-03 16:31:28EDT body-expand.lisp> ;; $Id: $ (in-package :gsl) @@ -53,6 +53,35 @@ "System FSBV is not present, so function ~a cannot be used." ,function-name)) +#+fsbv +(defun make-defcfun-for-fsbv (gsl-name ff-args) + "Make a fsbv:defcfun form so that function will be prepped." + (multiple-value-bind (args return-type) + (fsbv:defcfun-args-from-ff-args ff-args) + (let ((gsl-name-symbol (make-symbol gsl-name)) + (symbargs + (mapcar (lambda (st) (make-st (gensym "ARG") (st-type st))) + args))) + (values + `(fsbv:defcfun (,gsl-name-symbol gsl-name) ,return-type + "Function definition generated for FSBV prepping; will actually + be called by fsbv:foreign-funcall" + ,@symbargs) + gsl-name-symbol)))) + +(defun ffexpand (pass-by-value-p gsl-name args) + "Expand the foreign funcall." + (if pass-by-value-p + #+fsbv + (multiple-value-bind (form symbol) + (make-defcfun-for-fsbv gsl-name args) + (declare (special fsbv-functions)) + (push form fsbv-functions) + `(fsbv:foreign-funcall ,symbol ,@args)) + #-fsbv + `(no-fsbv-error no-fsbv-error ,@args) + `(cffi:foreign-funcall ,gsl-name ,@args))) + (defun body-expand (name arglist gsl-name c-arguments key-args) "Expand the body (computational part) of the defmfun." (with-defmfun-key-args key-args @@ -96,19 +125,17 @@ ,@(callback-set-slots cbinfo callback-dynamic-variables callback-dynamic) (let ((,(st-symbol creturn-st) - (,(if (some 'identity pbv) - #+fsbv 'fsbv:foreign-funcall - #-fsbv 'no-fsbv-error - 'cffi:foreign-funcall) - ,gsl-name - ,@(mappend - (lambda (arg) - (list (cond - ((member (st-symbol arg) allocated-return) :pointer) - (t (st-type arg))) - (st-symbol arg))) - (mapcar 'st-pointer-generic-pointer c-arguments)) - ,(st-type creturn-st)))) + ,(ffexpand (some 'identity pbv) + gsl-name + (append + (mappend + (lambda (arg) + (list (cond + ((member (st-symbol arg) allocated-return) :pointer) + (t (st-type arg))) + (st-symbol arg))) + (mapcar 'st-pointer-generic-pointer c-arguments)) + (list(st-type creturn-st)))))) ,@(case c-return (:void `((declare (ignore ,(st-symbol creturn-st))))) (:error-code ; fill in arguments diff --git a/init/defmfun.lisp b/init/defmfun.lisp index e47961ec3d52b51e07b3b98c0797fcdb94e6bb5e..b044d6e87f036355483d3d03390461b82db4c115 100644 --- a/init/defmfun.lisp +++ b/init/defmfun.lisp @@ -1,6 +1,6 @@ ;; Macro for defining GSL functions. ;; Liam Healy 2008-04-16 20:49:50EDT defmfun.lisp -;; Time-stamp: <2009-04-04 22:00:20EDT defmfun.lisp> +;; Time-stamp: <2009-05-03 15:38:45EDT defmfun.lisp> ;; $Id$ (in-package :gsl) @@ -84,7 +84,7 @@ index export documentation inputs outputs before after enumeration qualifier gsl-version switch cbinfo callback-dynamic callback-object) - (special indexed-functions callback-dynamic-variables)) + (special indexed-functions callback-dynamic-variables #+fsbv fsbv-functions)) ,@body)) (defun optional-args-to-switch-gsl-functions (arglist gsl-name) @@ -97,9 +97,9 @@ (listp (first gsl-name))))) (defun expand-defmfun-wrap (name arglist gsl-name c-arguments key-args) - (let (indexed-functions callback-dynamic-variables) + (let (indexed-functions callback-dynamic-variables #+fsbv fsbv-functions) ;; workaround for compiler errors that don't see 'indexed-function is used - (declare (ignorable indexed-functions callback-dynamic-variables)) + (declare (ignorable indexed-functions callback-dynamic-variables #+fsbv fsbv-functions)) (with-defmfun-key-args key-args (setf indexed-functions (list) callback-dynamic-variables @@ -119,7 +119,8 @@ (make-symbol-cardinals (list name 'dynfn) num-callbacks :gsl) (make-symbol-cardinals - (list name 'cbfn) num-callbacks :gsl)))))) + (list name 'cbfn) num-callbacks :gsl))))) + #+fsbv fsbv-functions #+fsbv (list)) (wrap-index-export (cond ((eq definition :generic) @@ -156,6 +157,8 @@ cbinfo (second callback-dynamic-variables) (first callback-dynamic-variables)) + #+fsbv + ,@fsbv-functions ,@index-export)))) ;;;;**************************************************************************** diff --git a/linear-algebra/blas2.lisp b/linear-algebra/blas2.lisp index 67124af35c71b67183f6a7de4c642a719c3ef426..2f655a324100916d781b7bb6e6533ab4d039c17f 100644 --- a/linear-algebra/blas2.lisp +++ b/linear-algebra/blas2.lisp @@ -1,6 +1,6 @@ ;; BLAS level 2, Matrix-vector operations ;; Liam Healy, Wed Apr 26 2006 - 21:08 -;; Time-stamp: <2009-05-03 11:31:55EDT blas2.lisp> +;; Time-stamp: <2009-05-03 12:38:28EDT blas2.lisp> ;; $Id$ (in-package :gsl) @@ -201,12 +201,13 @@ :documentation ; FDL "The rank-1 update A = alpha x y^T + A of the matrix A.") +#+fsbv (defmfun conjugate-rank-1-update (alpha (x vector) (y vector) (A matrix)) ("gsl_blas_" :type "gerc") ((alpha :element-c-type) ((mpointer A) :pointer) ((mpointer x) :pointer) ((mpointer y) :pointer)) :definition :generic - :element-types #+fsbv :float-complex #-fsbv :float + :element-types :complex :inputs (x y A) :outputs (A) :documentation ; FDL