diff --git a/gsll.asd b/gsll.asd index 313936839eb322e8bbf72b30af44416d2e36ffee..c892fdb8c56b348b869a0382428aed8de62ea81d 100644 --- a/gsll.asd +++ b/gsll.asd @@ -1,6 +1,6 @@ ;; Definition of GSLL system ;; Liam Healy -;; Time-stamp: <2011-08-26 10:32:29EDT gsll.asd> +;; Time-stamp: <2011-10-29 19:21:04EDT gsll.asd> ;; ;; Copyright 2006, 2007, 2008, 2009, 2010, 2011 Liam M. Healy ;; Distributed under the terms of the GNU General Public License @@ -18,8 +18,8 @@ ;; You should have received a copy of the GNU General Public License ;; along with this program. If not, see <http://www.gnu.org/licenses/>. -(when (asdf:find-system :fsbv nil) - (pushnew :fsbv *features*)) +(eval-when (:compile-toplevel :load-toplevel :execute) + (asdf:oos 'asdf:load-op :cffi-fsbv)) ; loads cff-grovel too, needed here (asdf:defsystem #:gsll :name "GSLL" @@ -32,7 +32,7 @@ #:cffi-grovel #:trivial-garbage #:alexandria - #+fsbv #:fsbv + #:metabang-bind #:osicat) :components ((:module init diff --git a/init/body-expand.lisp b/init/body-expand.lisp index 05af36a62d0bf3c7913499fc187bf25c8b9091fc..d570dd6d1c23d61b06a55827cf9332b25e6bf60b 100644 --- a/init/body-expand.lisp +++ b/init/body-expand.lisp @@ -1,8 +1,8 @@ ;; Expand the body of a defmfun ;; Liam Healy 2009-04-13 22:07:13EDT body-expand.lisp -;; Time-stamp: <2011-10-23 22:06:16EDT body-expand.lisp> +;; Time-stamp: <2011-10-29 18:52:05EDT body-expand.lisp> ;; -;; Copyright 2009, 2010 Liam M. Healy +;; Copyright 2009, 2010, 2011 Liam M. Healy ;; Distributed under the terms of the GNU General Public License ;; ;; This program is free software: you can redistribute it and/or modify @@ -30,58 +30,6 @@ :int (if (listp c-return) (grid:st-type c-return) c-return)))) -#+fsbv -(defun variables-passed-by-value (c-arguments-st) - "Create a list of (symbol newsymbol-st) for each structure - variable in the C argument list." - (loop for sd in c-arguments-st - collect - (when (fsbv:defined-type-p (grid:st-type sd)) - (list (grid:st-symbol sd) - (grid:make-st - (make-symbol (string (grid:st-symbol sd))) - (grid:st-type sd)))))) - -;;; This function should never be called even when FSBV is absent, -;;; because the potential callers should all have #-fsbv -;;; conditionalization. It is here just so that body-expand can -;;; compile when FSBV is absent. -#-fsbv -(defmacro no-fsbv-error (function-name &rest args) - (declare (ignore args)) - `(error - "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) (grid:make-st (gensym "ARG") (grid: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 cl-convert-form (decl) "Generate a form that calls the appropriate converter from C/GSL to CL." (list `(cffi:mem-ref ,(grid:st-symbol decl) ',(grid:st-actual-type decl)))) @@ -97,19 +45,15 @@ (with-defmfun-key-args key-args (let* ((creturn-st (creturn-st c-return)) (allocated-return ; Allocated and then returned from CL function - (mapcar - (lambda (s) - (or (find s c-arguments :key #'grid:st-symbol) - ;; Catch programming errors, usually typos - (error "Could not find ~a among the arguments" s))) - (remove-if + (mapcar (lambda (s) - (member s (arglist-plain-and-categories arglist nil))) - (variables-used-in-c-arguments c-arguments)))) - (pbv ; passed by value - #+fsbv - (variables-passed-by-value (cons creturn-st c-arguments)) - #-fsbv nil) + (or (find s c-arguments :key #'grid:st-symbol) + ;; Catch programming errors, usually typos + (error "Could not find ~a among the arguments" s))) + (remove-if + (lambda (s) + (member s (arglist-plain-and-categories arglist nil))) + (variables-used-in-c-arguments c-arguments)))) (clret (or ; better as a symbol macro (substitute (grid:st-symbol creturn-st) :c-return @@ -135,39 +79,39 @@ callback-dynamic cbinfo (first callback-dynamic-variables)) before (when callback-object (callback-set-dynamic callback-object arglist))) - ,@(callback-set-slots - cbinfo callback-dynamic-variables callback-dynamic) - (let ((,(grid:st-symbol creturn-st) - ,(ffexpand (some 'identity pbv) - gsl-name - (append - (mappend - (lambda (arg) - (list (cond - ((member (grid:st-symbol arg) - allocated-return) - :pointer) - (t (grid:st-type arg))) - (grid:st-symbol arg))) - (mapcar 'grid:st-pointer-generic-pointer - c-arguments)) - (list (grid:st-type creturn-st)))))) - ,@(case c-return - (:void `((declare (ignore ,(grid:st-symbol creturn-st))))) - (:error-code ; fill in arguments - `((check-gsl-status ,(grid:st-symbol creturn-st) - ',(or (defgeneric-method-p name) name))))) - ,@(when (eq (grid:st-type creturn-st) :pointer) - `((check-null-pointer - ,(grid:st-symbol creturn-st) - ,@'('memory-allocation-failure "No memory allocated.")))) - ,@after - ,(values-unless-singleton - (defmfun-return - c-return (grid:st-symbol creturn-st) clret - allocated-return - return return-supplied-p - enumeration outputs)))))))) + ,@(callback-set-slots + cbinfo callback-dynamic-variables callback-dynamic) + (let ((,(grid:st-symbol creturn-st) + (cffi:foreign-funcall + ,gsl-name + ,@(append + (mappend + (lambda (arg) + (list (cond + ((member (grid:st-symbol arg) + allocated-return) + :pointer) + (t (grid:st-type arg))) + (grid:st-symbol arg))) + (mapcar 'grid:st-pointer-generic-pointer + c-arguments)) + (list (grid:st-type creturn-st)))))) + ,@(case c-return + (:void `((declare (ignore ,(grid:st-symbol creturn-st))))) + (:error-code ; fill in arguments + `((check-gsl-status ,(grid:st-symbol creturn-st) + ',(or (defgeneric-method-p name) name))))) + ,@(when (eq (grid:st-type creturn-st) :pointer) + `((check-null-pointer + ,(grid:st-symbol creturn-st) + ,@'('memory-allocation-failure "No memory allocated.")))) + ,@after + ,(values-unless-singleton + (defmfun-return + c-return (grid:st-symbol creturn-st) clret + allocated-return + return return-supplied-p + enumeration outputs)))))))) (defun defmfun-return (c-return cret-name clret allocated return return-supplied-p enumeration outputs) diff --git a/init/types.lisp b/init/types.lisp index 0558fc75bf2a650f7f7abb013f8327520fb0a9a8..2b2602f1c10baf1b374ed96007e4fd0557dbebd1 100644 --- a/init/types.lisp +++ b/init/types.lisp @@ -1,6 +1,6 @@ ;; Number types used by GSL functions, and specification conversion ;; Liam Healy 2008-12-31 21:06:34EST types.lisp -;; Time-stamp: <2011-10-23 20:54:45EDT types.lisp> +;; Time-stamp: <2011-10-29 16:51:58EDT types.lisp> ;; ;; Copyright 2008, 2009, 2010, 2011 Liam M. Healy ;; Distributed under the terms of the GNU General Public License @@ -25,8 +25,8 @@ ;;;;**************************************************************************** (case (cffi:foreign-type-size :long) - (8 (push :int64 *features*) - (4 (push :int32 *features*)))) + (8 (push :int64 *features*)) + (4 (push :int32 *features*))) ;;;;**************************************************************************** ;;;; Type specification conversion @@ -79,7 +79,7 @@ "long-long")) (concatenate 'string (subseq ut 0 (- (length ut) 9)) "llong") ut)))) - grid:*cstd-integer-types*)) + cffi:*built-in-integer-types*)) ;; The floating types are associated by order, so it is important that ;; order of *fp-type-mapping* and *gsl-splice-fp-types* match, ;; though the latter may be longer. diff --git a/special-functions/gamma.lisp b/special-functions/gamma.lisp index 13d49eed76eeec3fcd1e36a90c6b36535cf79182..15c81084ad8724529b87e61b08c539623f98d4b6 100644 --- a/special-functions/gamma.lisp +++ b/special-functions/gamma.lisp @@ -1,8 +1,8 @@ ;; Gamma functions ;; Liam Healy, Thu Apr 27 2006 - 22:06 -;; Time-stamp: <2011-10-23 22:04:31EDT gamma.lisp> +;; Time-stamp: <2011-10-29 18:19:04EDT gamma.lisp> ;; -;; Copyright 2006, 2007, 2008, 2009, 2010 Liam M. Healy +;; Copyright 2006, 2007, 2008, 2009, 2010, 2011 Liam M. Healy ;; Distributed under the terms of the GNU General Public License ;; ;; This program is free software: you can redistribute it and/or modify @@ -41,7 +41,7 @@ Gamma(x) is not considered an overflow is given by +gamma-xmax+.") (defmfun log-gamma (x) - "gsl_sf_lngamma_e" ((x :double) (ret sf-result)) + "gsl_sf_lngamma_e" ((x :double) (ret (:pointer (:struct sf-result)))) :documentation ; FDL "The logarithm of the Gamma function, log(Gamma(x)), subject to x not a being negative @@ -51,9 +51,9 @@ (defmfun log-gamma-sign (x) "gsl_sf_lngamma_sgn_e" - ((x :double) (ret sf-result) (sign (:pointer :double))) + ((x :double) (ret (:pointer (:struct sf-result))) (sign (:pointer :double))) :return ((multiple-value-bind (val err) - (fsbv:object ret 'sf-result) + (cffi:convert-from-foreign ret '(:struct sf-result)) (values val (cffi:mem-ref sign :double) err ))) :documentation ; FDL "Compute the sign of the gamma function and the logarithm of @@ -147,15 +147,18 @@ (defmfun log-pochammer-sign (a x) "gsl_sf_lnpoch_sgn_e" - ((a :double) (x :double) (ret sf-result) (sign (:pointer :double))) + ((a :double) + (x :double) + (ret (:pointer (:struct sf-result))) + (sign (:pointer :double))) :documentation ; FDL "The logarithm of the Pochhammer symbol and its sign. The computed parameters are result = log(|(a)_x|) and sgn = sgn((a)_x) where (a)_x := Gamma(a + x)/Gamma(a), subject to a, a+x not being negative integers." - :return ((multiple-value-bind (val err) - (fsbv:object ret 'sf-result) - (values val (cffi:mem-ref sign :double) err )))) + :return ((multiple-value-bind (val err) + (cffi:convert-from-foreign ret '(:struct sf-result)) + (values val (cffi:mem-ref sign :double) err )))) (defmfun relative-pochammer (a x) "gsl_sf_pochrel_e" ((a :double) (x :double) (ret sf-result)) diff --git a/special-functions/return-structures.lisp b/special-functions/return-structures.lisp index 7670e01af7933c77baace77600c593254735230a..c4e81e5bba87862727dda1d7aa796d8e5a60be73 100644 --- a/special-functions/return-structures.lisp +++ b/special-functions/return-structures.lisp @@ -1,6 +1,6 @@ ;; Structures returned by special functions. ;; Liam Healy, Mon Jan 1 2007 - 11:35 -;; Time-stamp: <2011-10-23 21:15:46EDT return-structures.lisp> +;; Time-stamp: <2011-10-29 18:24:42EDT return-structures.lisp> ;; ;; Copyright 2007, 2008, 2009, 2010, 2011 Liam M. Healy ;; Distributed under the terms of the GNU General Public License @@ -26,30 +26,35 @@ ;;; Define methods for cffi:translate-from-foreign for translate-from-foreign ;;; that return the slots as successive values. -;;; (defmethod cffi:translate-from-foreign (value (type ))); sf-result -;;; (defmethod cffi:translate-from-foreign (value (type ))); sf-result-e10 -;;; This should become the cffi:translate-from-foreign method for sf-result-e10 -;;;(defun values-e10 (val err e10) -;;; (values val e10 err)) -;;; Note: need to enhance CFFI to either make a default class name for each type, or allow the specification of a class when groveling. + +(cffi:define-translation-method (pointer sf-result :from) + (let ((plist (call-next-method))) + (values (getf plist 'val) (getf plist 'err)))) + +(cffi:define-translation-method (pointer sf-result-e10 :from) + (let ((plist (call-next-method))) + (values (getf plist 'val) (getf plist 'e10) (getf plist 'err)))) (defun complex-with-error (real-sfr imaginary-sfr) "Return two complex numbers, the value and the error." - (multiple-value-bind (re-val re-err) - (fsbv:object real-sfr 'sf-result) - (multiple-value-bind (im-val im-err) - (fsbv:object imaginary-sfr 'sf-result) - (values - (complex re-val im-val) - (complex re-err im-err))))) + (metabang-bind:bind + (((:values treal-val treal-err) + (cffi:convert-from-foreign real-sfr '(:struct sf-result))) + ((:values timag-val timag-err) + (cffi:convert-from-foreign imaginary-sfr '(:struct sf-result)))) + (values + (complex treal-val timag-val) + (complex treal-err timag-err)))) (defun values-with-errors (&rest values-sfr) "Return numbers as values and errors." (loop for vs in values-sfr - for (val err) = (multiple-value-list (fsbv:object vs 'sf-result)) - collect val into values - collect err into errors - finally (return (values-list (append values errors))))) + for tvs + = (multiple-value-list + (cffi:convert-from-foreign vs '(:struct sf-result))) + collect (first tvs) into values + collect (second tvs) into errors + finally (return (values-list (append values errors))))) ;;;;**************************************************************************** ;;;; Array construction