Skip to content
Snippets Groups Projects
Commit 121e475d authored by Liam M. Healy's avatar Liam M. Healy
Browse files

Fix sf-result* definitions, eliminate ffexpand, fsbv:object

Fix sf-result and sf-result-e10 translation methods, and use in
complex-with-error and values-with-errors.  Some usage in gamma.lisp
updated, but there will be a need to replace sf-result with (:struct
sf-result) in all declarations for many special functions.

I removed ffexpand and everything it depended on because there is no
reason to make a side defcfun for call-by-value functions, and if FSBV
is missing CFFI already emits an error.  All usage of fsbv:object and
any thing from the FSBV package is now gone.
parent 639a5f35
No related branches found
No related tags found
No related merge requests found
;; 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
......
;; 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)
......
;; 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.
......
;; 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))
......
;; 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
......
0% Loading or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment