Skip to content
Snippets Groups Projects
Commit 6f90daf7 authored by Liam Healy's avatar Liam Healy
Browse files

Explicit precision specification modes

The GSL precision mode used mainly in special functions is now
explicitly given in the CL argument list; remove special treatment of
:mode in C argument list of defmfun call, which meddled with the CL
arglist.  Changed sf-mode options to :double, :single, :approx.
parent 2557a24b
No related branches found
No related tags found
No related merge requests found
;; Macro for defining GSL functions. ;; Macro for defining GSL functions.
;; Liam Healy 2008-04-16 20:49:50EDT defmfun.lisp ;; Liam Healy 2008-04-16 20:49:50EDT defmfun.lisp
;; Time-stamp: <2008-08-09 19:49:10EDT defmfun.lisp> ;; Time-stamp: <2008-08-10 18:00:49EDT defmfun.lisp>
;; $Id$ ;; $Id$
(in-package :gsl) (in-package :gsl)
...@@ -127,7 +127,7 @@ ...@@ -127,7 +127,7 @@
(expand-defmfun-wrap (expand-defmfun-wrap
'airy-Ai '(x) 'airy-Ai '(x)
"gsl_sf_airy_Ai_e" "gsl_sf_airy_Ai_e"
'((x :double) :mode (ret sf-result)) '((x :double) (mode sf-mode) (ret sf-result))
'(:documentation "The Airy function Ai(x).")) '(:documentation "The Airy function Ai(x)."))
;;; Generic function and methods of a vector ;;; Generic function and methods of a vector
...@@ -460,13 +460,12 @@ ...@@ -460,13 +460,12 @@
;; walk only a top-level function call ;; walk only a top-level function call
(rest val) (rest val)
(list val))))) (list val)))))
(remove :mode c-arguments)))) c-arguments)))
(defun expand-defmfun-plain (name arglist gsl-name c-arguments key-args) (defun expand-defmfun-plain (name arglist gsl-name c-arguments key-args)
"The main function for expansion of defmfun." "The main function for expansion of defmfun."
(with-defmfun-key-args key-args (with-defmfun-key-args key-args
(let* ((cargs (substitute '(mode sf-mode) :mode c-arguments)) (let* ((carg-symbs (c-arguments c-arguments))
(carg-symbs (c-arguments cargs))
(clargs (or arglist carg-symbs)) (clargs (or arglist carg-symbs))
(arglist-symbs (arglist-plain-and-categories arglist nil)) (arglist-symbs (arglist-plain-and-categories arglist nil))
(cret-type (if (member c-return *special-c-return*) (cret-type (if (member c-return *special-c-return*)
...@@ -474,7 +473,7 @@ ...@@ -474,7 +473,7 @@
(if (listp c-return) (st-type c-return) c-return))) (if (listp c-return) (st-type c-return) c-return)))
(cret-name (cret-name
(if (listp c-return) (st-symbol c-return) (make-symbol "CRETURN"))) (if (listp c-return) (st-symbol c-return) (make-symbol "CRETURN")))
(complex-args (complex-scalars clargs cargs)) (complex-args (complex-scalars clargs c-arguments))
(allocated ; Foreign objects to be allocated (allocated ; Foreign objects to be allocated
(remove-if (remove-if
(lambda (s) (lambda (s)
...@@ -483,7 +482,7 @@ ...@@ -483,7 +482,7 @@
(allocated-decl (allocated-decl
(append (append
(mapcar (mapcar
(lambda (s) (find s cargs :key #'st-symbol)) (lambda (s) (find s c-arguments :key #'st-symbol))
allocated))) allocated)))
(clret (or ; better as a symbol macro (clret (or ; better as a symbol macro
(substitute cret-name :c-return return) (substitute cret-name :c-return return)
...@@ -491,60 +490,56 @@ ...@@ -491,60 +490,56 @@
outputs outputs
(unless (eq c-return :void) (unless (eq c-return :void)
(list cret-name)))) (list cret-name))))
(clargs-types (cl-argument-types clargs cargs))) (clargs-types (cl-argument-types clargs c-arguments)))
`(,defn `(,defn
,@(when (and name (not (defgeneric-method-p name))) ,@(when (and name (not (defgeneric-method-p name)))
(list name)) (list name))
,(let ((noaux ,(if global
(if (member :mode c-arguments) (append clargs (cons '&aux global))
`(,@clargs &optional (mode :double-prec)) clargs)
`(,@clargs)))) ,(declaration-form
(if global clargs-types (set-difference arglist-symbs carg-symbs))
(append noaux (cons '&aux global)) ,@(when documentation (list documentation))
noaux)) (,@(if (or allocated-decl complex-args)
,(declaration-form `(cffi:with-foreign-objects
clargs-types (set-difference arglist-symbs carg-symbs)) ,(mapcar #'wfo-declare
,@(when documentation (list documentation)) (append allocated-decl
(,@(if (or allocated-decl complex-args) (mapcar #'rest complex-args))))
`(cffi:with-foreign-objects '(let ()))
,(mapcar #'wfo-declare #-native ,@(mapcar (lambda (v) `(copy-cl-to-c ,v)) inputs)
(append allocated-decl (let ((,cret-name
(mapcar #'rest complex-args)))) (cffi:foreign-funcall
'(let ())) ,gsl-name
#-native ,@(mapcar (lambda (v) `(copy-cl-to-c ,v)) inputs) ,@(mapcan
(let ((,cret-name (lambda (arg)
(cffi:foreign-funcall (let ((cfind ; variable is complex
,gsl-name (first (member (st-symbol arg) complex-args :key 'first))))
,@(mapcan (if cfind ; so substitute call to complex-to-gsl
(lambda (arg) `(,(third cfind)
(let ((cfind ; variable is complex (complex-to-gsl ,(first cfind) ,(second cfind)))
(first (member (st-symbol arg) complex-args :key 'first)))) ;; otherwise use without conversion
(if cfind ; so substitute call to complex-to-gsl (list (if (member (st-symbol arg) allocated)
`(,(third cfind) :pointer
(complex-to-gsl ,(first cfind) ,(second cfind))) (st-type arg))
;; otherwise use without conversion (st-symbol arg)))))
(list (if (member (st-symbol arg) allocated) c-arguments)
:pointer ,cret-type)))
(st-type arg)) ,@(case c-return
(st-symbol arg))))) (:void `((declare (ignore ,cret-name))))
cargs) (:error-code ; fill in arguments
,cret-type))) `((check-gsl-status ,cret-name
,@(case c-return ',(or (defgeneric-method-p name) name)))))
(:void `((declare (ignore ,cret-name)))) #-native
(:error-code ; fill in arguments ,@(when outputs `(,(mapcar (lambda (x) `(setf (cl-invalid ,x) t))) outputs))
`((check-gsl-status ,cret-name ,@(when (or null-pointer-info (eq c-return :pointer))
',(or (defgeneric-method-p name) name))))) `((check-null-pointer ,cret-name
#-native ,@(or null-pointer-info
,@(when outputs `(,(mapcar (lambda (x) `(setf (cl-invalid ,x) t))) outputs)) '(:ENOMEM "No memory allocated")))))
,@(when (or null-pointer-info (eq c-return :pointer)) ,@after
`((check-null-pointer ,cret-name (values
,@(or null-pointer-info ,@(defmfun-return
'(:ENOMEM "No memory allocated"))))) c-return cret-name clret allocated return return-supplied-p
,@after enumeration outputs))))))))
(values
,@(defmfun-return
c-return cret-name clret allocated return return-supplied-p
enumeration outputs))))))))
(defun defmfun-return (defun defmfun-return
(c-return cret-name clret allocated return return-supplied-p enumeration outputs) (c-return cret-name clret allocated return return-supplied-p enumeration outputs)
......
*~
;; Airy functions ;; Airy functions
;; Liam Healy, Fri Mar 17 2006 - 18:41 ;; Liam Healy, Fri Mar 17 2006 - 18:41
;; Time-stamp: <2008-07-10 21:20:39EDT airy.lisp> ;; Time-stamp: <2008-08-10 17:50:02EDT airy.lisp>
;; $Id$ ;; $Id$
(in-package :gsl) (in-package :gsl)
...@@ -9,48 +9,48 @@ ...@@ -9,48 +9,48 @@
;;;; Airy functions ;;;; Airy functions
;;;;**************************************************************************** ;;;;****************************************************************************
(defmfun airy-Ai (x) (defmfun airy-Ai (x &optional (mode :double))
"gsl_sf_airy_Ai_e" ((x :double) :mode (ret sf-result)) "gsl_sf_airy_Ai_e" ((x :double) (mode sf-mode) (ret sf-result))
:documentation ; FDL :documentation ; FDL
"The Airy function Ai(x).") "The Airy function Ai(x).")
(defmfun airy-Bi (x) (defmfun airy-Bi (x &optional (mode :double))
"gsl_sf_airy_Bi_e" ((x :double) :mode (ret sf-result)) "gsl_sf_airy_Bi_e" ((x :double) (mode sf-mode) (ret sf-result))
:documentation ; FDL :documentation ; FDL
"The Airy function Bi(x).") "The Airy function Bi(x).")
(defmfun airy-Ai-scaled (x) (defmfun airy-Ai-scaled (x &optional (mode :double))
"gsl_sf_airy_Ai_scaled_e" ((x :double) :mode (ret sf-result)) "gsl_sf_airy_Ai_scaled_e" ((x :double) (mode sf-mode) (ret sf-result))
:documentation ; FDL :documentation ; FDL
"The scaled Airy function S_A(x) Ai(x). "The scaled Airy function S_A(x) Ai(x).
For x>0 the scaling factor S_A(x) is \exp(+(2/3) x^(3/2)), For x>0 the scaling factor S_A(x) is \exp(+(2/3) x^(3/2)),
and is 1 for x<0.") and is 1 for x<0.")
(defmfun airy-Bi-scaled (x) (defmfun airy-Bi-scaled (x &optional (mode :double))
"gsl_sf_airy_Bi_scaled_e" ((x :double) :mode (ret sf-result)) "gsl_sf_airy_Bi_scaled_e" ((x :double) (mode sf-mode) (ret sf-result))
:documentation ; FDL :documentation ; FDL
"The scaled Airy function S_B(x) Bi(x). "The scaled Airy function S_B(x) Bi(x).
For x>0 the scaling factor S_B(x) is exp(-(2/3) x^(3/2)), For x>0 the scaling factor S_B(x) is exp(-(2/3) x^(3/2)),
and is 1 for x<0.") and is 1 for x<0.")
(defmfun airy-Ai-deriv (x) (defmfun airy-Ai-deriv (x &optional (mode :double))
"gsl_sf_airy_Ai_deriv_e" ((x :double) :mode (ret sf-result)) "gsl_sf_airy_Ai_deriv_e" ((x :double) (mode sf-mode) (ret sf-result))
:documentation ; FDL :documentation ; FDL
"The Airy function derivative Ai'(x).") "The Airy function derivative Ai'(x).")
(defmfun airy-Bi-deriv (x) (defmfun airy-Bi-deriv (x &optional (mode :double))
"gsl_sf_airy_Bi_deriv_e" ((x :double) :mode (ret sf-result)) "gsl_sf_airy_Bi_deriv_e" ((x :double) (mode sf-mode) (ret sf-result))
:documentation "The Airy function derivative Bi'(x).") :documentation "The Airy function derivative Bi'(x).")
(defmfun airy-Ai-deriv-scaled (x) (defmfun airy-Ai-deriv-scaled (x &optional (mode :double))
"gsl_sf_airy_Ai_deriv_scaled_e" ((x :double) :mode (ret sf-result)) "gsl_sf_airy_Ai_deriv_scaled_e" ((x :double) (mode sf-mode) (ret sf-result))
:documentation ; FDL :documentation ; FDL
"The scaled Airy function derivative S_A(x) Ai'(x). "The scaled Airy function derivative S_A(x) Ai'(x).
For x>0 the scaling factor S_A(x) is exp(+(2/3) x^(3/2)), For x>0 the scaling factor S_A(x) is exp(+(2/3) x^(3/2)),
and is 1 for x<0.") and is 1 for x<0.")
(defmfun airy-Bi-deriv-scaled (x) (defmfun airy-Bi-deriv-scaled (x &optional (mode :double))
"gsl_sf_airy_Bi_deriv_scaled_e" ((x :double) :mode (ret sf-result)) "gsl_sf_airy_Bi_deriv_scaled_e" ((x :double) (mode sf-mode) (ret sf-result))
:documentation ; FDL :documentation ; FDL
"The scaled Airy function derivative S_B(x) Bi'(x). "The scaled Airy function derivative S_B(x) Bi'(x).
For x>0 the scaling factor S_B(x) is For x>0 the scaling factor S_B(x) is
......
;; Bessel functions ;; Bessel functions
;; Liam Healy, Fri Mar 17 2006 - 18:42 ;; Liam Healy, Fri Mar 17 2006 - 18:42
;; Time-stamp: <2008-07-08 21:43:01EDT bessel.lisp> ;; Time-stamp: <2008-08-10 17:55:45EDT bessel.lisp>
;; $Id$ ;; $Id$
(in-package :gsl) (in-package :gsl)
...@@ -365,9 +365,9 @@ ...@@ -365,9 +365,9 @@
"The regular cylindrical Bessel function of fractional order "The regular cylindrical Bessel function of fractional order
\nu, J_\nu(x).") \nu, J_\nu(x).")
(defmfun spherical-Jnu-array (nu v) (defmfun spherical-Jnu-array (nu v &optional (mode :double))
"gsl_sf_bessel_sequence_Jnu_e" "gsl_sf_bessel_sequence_Jnu_e"
((nu :double) :mode ((dim0 v) :int) ((c-pointer v) :pointer)) ((nu :double) (mode sf-mode) ((dim0 v) :int) ((c-pointer v) :pointer))
:outputs (v) :outputs (v)
:documentation ; FDL :documentation ; FDL
"The regular cylindrical Bessel function of "The regular cylindrical Bessel function of
......
;; Elliptic integrals ;; Elliptic integrals
;; Liam Healy, Mon Mar 20 2006 - 21:50 ;; Liam Healy, Mon Mar 20 2006 - 21:50
;; Time-stamp: <2008-03-13 17:27:04EDT elliptic-integrals.lisp> ;; Time-stamp: <2008-08-10 17:55:35EDT elliptic-integrals.lisp>
;; $Id$ ;; $Id$
(in-package :gsl) (in-package :gsl)
...@@ -9,15 +9,15 @@ ...@@ -9,15 +9,15 @@
;;;; Legendre form of complete elliptic integrals ;;;; Legendre form of complete elliptic integrals
;;;;**************************************************************************** ;;;;****************************************************************************
(defmfun elliptic-integral-K-complete (k) (defmfun elliptic-integral-K-complete (k &optional (mode :double))
"gsl_sf_ellint_Kcomp_e" ((k :double) :mode (ret sf-result)) "gsl_sf_ellint_Kcomp_e" ((k :double) (mode sf-mode) (ret sf-result))
:documentation ; FDL :documentation ; FDL
"The complete elliptic integral of the first kind, K(k). Note that "The complete elliptic integral of the first kind, K(k). Note that
Abramowitz & Stegun define this function in terms of the parameter m Abramowitz & Stegun define this function in terms of the parameter m
= k^2.") = k^2.")
(defmfun elliptic-integral-E-complete (k) (defmfun elliptic-integral-E-complete (k &optional (mode :double))
"gsl_sf_ellint_Ecomp_e" ((k :double) :mode (ret sf-result)) "gsl_sf_ellint_Ecomp_e" ((k :double) (mode sf-mode) (ret sf-result))
:documentation ; FDL :documentation ; FDL
"The complete elliptic integral of the second kind, E(k). "The complete elliptic integral of the second kind, E(k).
Note that Abramowitz & Stegun define this function in terms of the Note that Abramowitz & Stegun define this function in terms of the
...@@ -27,32 +27,32 @@ ...@@ -27,32 +27,32 @@
;;;; Legendre form of incomplete elliptic integrals ;;;; Legendre form of incomplete elliptic integrals
;;;;**************************************************************************** ;;;;****************************************************************************
(defmfun elliptic-integral-F (phi k) (defmfun elliptic-integral-F (phi k &optional (mode :double))
"gsl_sf_ellint_F_e" ((phi :double) (k :double) :mode (ret sf-result)) "gsl_sf_ellint_F_e" ((phi :double) (k :double) (mode sf-mode) (ret sf-result))
:documentation ; FDL :documentation ; FDL
"The incomplete elliptic integral of the first kind, F(phi,k). Note "The incomplete elliptic integral of the first kind, F(phi,k). Note
that Abramowitz & Stegun define this function in terms of the that Abramowitz & Stegun define this function in terms of the
parameter m = k^2.") parameter m = k^2.")
(defmfun elliptic-integral-E (phi k) (defmfun elliptic-integral-E (phi k &optional (mode :double))
"gsl_sf_ellint_E_e" ((phi :double) (k :double) :mode (ret sf-result)) "gsl_sf_ellint_E_e" ((phi :double) (k :double) (mode sf-mode) (ret sf-result))
:documentation ; FDL :documentation ; FDL
"The incomplete elliptic integral of the second kind, E(phi,k). Note "The incomplete elliptic integral of the second kind, E(phi,k). Note
that Abramowitz & Stegun define this function in terms of the that Abramowitz & Stegun define this function in terms of the
parameter m = k^2.") parameter m = k^2.")
(defmfun elliptic-integral-P (phi k n) (defmfun elliptic-integral-P (phi k n &optional (mode :double))
"gsl_sf_ellint_P_e" "gsl_sf_ellint_P_e"
((phi :double) (k :double) (n :double) :mode (ret sf-result)) ((phi :double) (k :double) (n :double) (mode sf-mode) (ret sf-result))
:documentation ; FDL :documentation ; FDL
"The incomplete elliptic integral of the third kind, P(phi,k,n). "The incomplete elliptic integral of the third kind, P(phi,k,n).
Note that Abramowitz & Stegun define this function in terms of the Note that Abramowitz & Stegun define this function in terms of the
parameters m = k^2 and sin^2(alpha) = k^2, with the change of sign parameters m = k^2 and sin^2(alpha) = k^2, with the change of sign
n to -n.") n to -n.")
(defmfun elliptic-integral-D (phi k n) (defmfun elliptic-integral-D (phi k n &optional (mode :double))
"gsl_sf_ellint_D_e" "gsl_sf_ellint_D_e"
((phi :double) (k :double) (n :double) :mode (ret sf-result)) ((phi :double) (k :double) (n :double) (mode sf-mode) (ret sf-result))
:documentation ; FDL :documentation ; FDL
"The incomplete elliptic integral D(phi,k,n) which is "The incomplete elliptic integral D(phi,k,n) which is
defined through the Carlson form RD(x,y,z) defined through the Carlson form RD(x,y,z)
...@@ -63,26 +63,26 @@ ...@@ -63,26 +63,26 @@
;;;; Carlson forms ;;;; Carlson forms
;;;;**************************************************************************** ;;;;****************************************************************************
(defmfun elliptic-integral-RC (x y) (defmfun elliptic-integral-RC (x y &optional (mode :double))
"gsl_sf_ellint_RC_e" ((x :double) (y :double) :mode (ret sf-result)) "gsl_sf_ellint_RC_e" ((x :double) (y :double) (mode sf-mode) (ret sf-result))
:documentation ; FDL :documentation ; FDL
"The incomplete elliptic integral RC(x,y).") "The incomplete elliptic integral RC(x,y).")
(defmfun elliptic-integral-RD (x y z) (defmfun elliptic-integral-RD (x y z &optional (mode :double))
"gsl_sf_ellint_RD_e" "gsl_sf_ellint_RD_e"
((x :double) (y :double) (z :double) :mode (ret sf-result)) ((x :double) (y :double) (z :double) (mode sf-mode) (ret sf-result))
:documentation ; FDL :documentation ; FDL
"The incomplete elliptic integral RD(x,y,z).") "The incomplete elliptic integral RD(x,y,z).")
(defmfun elliptic-integral-RF (x y z) (defmfun elliptic-integral-RF (x y z &optional (mode :double))
"gsl_sf_ellint_RF_e" "gsl_sf_ellint_RF_e"
((x :double) (y :double) (z :double) :mode (ret sf-result)) ((x :double) (y :double) (z :double) (mode sf-mode) (ret sf-result))
:documentation ; FDL :documentation ; FDL
"The incomplete elliptic integral RF(x,y,z).") "The incomplete elliptic integral RF(x,y,z).")
(defmfun elliptic-integral-RJ (x y z p) (defmfun elliptic-integral-RJ (x y z p &optional (mode :double))
"gsl_sf_ellint_RJ_e" "gsl_sf_ellint_RJ_e"
((x :double) (y :double) (z :double) (p :double) :mode (ret sf-result)) ((x :double) (y :double) (z :double) (p :double) (mode sf-mode) (ret sf-result))
:documentation ; FDL :documentation ; FDL
"The incomplete elliptic integral RJ(x,y,z,p).") "The incomplete elliptic integral RJ(x,y,z,p).")
......
;; Structures returned by special functions. ;; Structures returned by special functions.
;; Liam Healy, Mon Jan 1 2007 - 11:35 ;; Liam Healy, Mon Jan 1 2007 - 11:35
;; Time-stamp: <2008-02-16 22:45:31EST return-structures.lisp> ;; Time-stamp: <2008-08-10 17:47:07EDT return-structures.lisp>
;; $Id$ ;; $Id$
(in-package :gsl) (in-package :gsl)
...@@ -26,9 +26,9 @@ ...@@ -26,9 +26,9 @@
(cffi:defcenum sf-mode (cffi:defcenum sf-mode
"Numerical precision modes with which to calculate special functions." "Numerical precision modes with which to calculate special functions."
;; file:///usr/share/doc/gsl-ref-html/gsl-ref_7.html#SEC62 ;; file:///usr/share/doc/gsl-ref-html/gsl-ref_7.html#SEC62
:double-prec :double
:single-prec :single
:approx-prec) :approx)
(defun val (sf-result &optional (type 'sf-result)) (defun val (sf-result &optional (type 'sf-result))
(cffi:foreign-slot-value sf-result type 'val)) (cffi:foreign-slot-value sf-result type 'val))
......
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