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
Loading
Loading
Loading
Loading
+4 −4
Original line number Diff line number Diff line
;; 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
+43 −99
Original line number Diff line number Diff line
;; 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))))
@@ -106,10 +54,6 @@
	       (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)
	   (clret (or			; better as a symbol macro
		   (substitute
		    (grid:st-symbol creturn-st) :c-return
@@ -138,9 +82,9 @@
	 ,@(callback-set-slots
	    cbinfo callback-dynamic-variables callback-dynamic)
	 (let ((,(grid:st-symbol creturn-st)
		  ,(ffexpand (some 'identity pbv)
			     gsl-name
			     (append
		 (cffi:foreign-funcall
		  ,gsl-name
		  ,@(append
		     (mappend
		      (lambda (arg)
			(list (cond
+4 −4
Original line number Diff line number Diff line
;; 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.
+12 −9
Original line number Diff line number Diff line
;; 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,14 +147,17 @@

(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)
		(cffi:convert-from-foreign ret '(:struct sf-result))
	      (values val (cffi:mem-ref sign :double) err ))))

(defmfun relative-pochammer (a x)
+23 −18
Original line number Diff line number Diff line
;; 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,29 +26,34 @@

;;; 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)
  (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 re-val im-val)
       (complex re-err im-err)))))
     (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
	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)))))

;;;;****************************************************************************