Commit 6f90daf7 authored by Liam Healy's avatar Liam Healy

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
;; Macro for defining GSL functions.
;; 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$
(in-package :gsl)
......@@ -127,7 +127,7 @@
(expand-defmfun-wrap
'airy-Ai '(x)
"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)."))
;;; Generic function and methods of a vector
......@@ -460,13 +460,12 @@
;; walk only a top-level function call
(rest val)
(list val)))))
(remove :mode c-arguments))))
c-arguments)))
(defun expand-defmfun-plain (name arglist gsl-name c-arguments key-args)
"The main function for expansion of defmfun."
(with-defmfun-key-args key-args
(let* ((cargs (substitute '(mode sf-mode) :mode c-arguments))
(carg-symbs (c-arguments cargs))
(let* ((carg-symbs (c-arguments c-arguments))
(clargs (or arglist carg-symbs))
(arglist-symbs (arglist-plain-and-categories arglist nil))
(cret-type (if (member c-return *special-c-return*)
......@@ -474,7 +473,7 @@
(if (listp c-return) (st-type c-return) c-return)))
(cret-name
(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
(remove-if
(lambda (s)
......@@ -483,7 +482,7 @@
(allocated-decl
(append
(mapcar
(lambda (s) (find s cargs :key #'st-symbol))
(lambda (s) (find s c-arguments :key #'st-symbol))
allocated)))
(clret (or ; better as a symbol macro
(substitute cret-name :c-return return)
......@@ -491,60 +490,56 @@
outputs
(unless (eq c-return :void)
(list cret-name))))
(clargs-types (cl-argument-types clargs cargs)))
(clargs-types (cl-argument-types clargs c-arguments)))
`(,defn
,@(when (and name (not (defgeneric-method-p name)))
(list name))
,(let ((noaux
(if (member :mode c-arguments)
`(,@clargs &optional (mode :double-prec))
`(,@clargs))))
(if global
(append noaux (cons '&aux global))
noaux))
,(declaration-form
clargs-types (set-difference arglist-symbs carg-symbs))
,@(when documentation (list documentation))
(,@(if (or allocated-decl complex-args)
`(cffi:with-foreign-objects
,(mapcar #'wfo-declare
(append allocated-decl
(mapcar #'rest complex-args))))
'(let ()))
#-native ,@(mapcar (lambda (v) `(copy-cl-to-c ,v)) inputs)
(let ((,cret-name
(cffi:foreign-funcall
,gsl-name
,@(mapcan
(lambda (arg)
(let ((cfind ; variable is complex
(first (member (st-symbol arg) complex-args :key 'first))))
(if cfind ; so substitute call to complex-to-gsl
`(,(third cfind)
(complex-to-gsl ,(first cfind) ,(second cfind)))
;; otherwise use without conversion
(list (if (member (st-symbol arg) allocated)
:pointer
(st-type arg))
(st-symbol arg)))))
cargs)
,cret-type)))
,@(case c-return
(:void `((declare (ignore ,cret-name))))
(:error-code ; fill in arguments
`((check-gsl-status ,cret-name
',(or (defgeneric-method-p name) name)))))
#-native
,@(when outputs `(,(mapcar (lambda (x) `(setf (cl-invalid ,x) t))) outputs))
,@(when (or null-pointer-info (eq c-return :pointer))
`((check-null-pointer ,cret-name
,@(or null-pointer-info
'(:ENOMEM "No memory allocated")))))
,@after
(values
,@(defmfun-return
c-return cret-name clret allocated return return-supplied-p
enumeration outputs))))))))
,@(when (and name (not (defgeneric-method-p name)))
(list name))
,(if global
(append clargs (cons '&aux global))
clargs)
,(declaration-form
clargs-types (set-difference arglist-symbs carg-symbs))
,@(when documentation (list documentation))
(,@(if (or allocated-decl complex-args)
`(cffi:with-foreign-objects
,(mapcar #'wfo-declare
(append allocated-decl
(mapcar #'rest complex-args))))
'(let ()))
#-native ,@(mapcar (lambda (v) `(copy-cl-to-c ,v)) inputs)
(let ((,cret-name
(cffi:foreign-funcall
,gsl-name
,@(mapcan
(lambda (arg)
(let ((cfind ; variable is complex
(first (member (st-symbol arg) complex-args :key 'first))))
(if cfind ; so substitute call to complex-to-gsl
`(,(third cfind)
(complex-to-gsl ,(first cfind) ,(second cfind)))
;; otherwise use without conversion
(list (if (member (st-symbol arg) allocated)
:pointer
(st-type arg))
(st-symbol arg)))))
c-arguments)
,cret-type)))
,@(case c-return
(:void `((declare (ignore ,cret-name))))
(:error-code ; fill in arguments
`((check-gsl-status ,cret-name
',(or (defgeneric-method-p name) name)))))
#-native
,@(when outputs `(,(mapcar (lambda (x) `(setf (cl-invalid ,x) t))) outputs))
,@(when (or null-pointer-info (eq c-return :pointer))
`((check-null-pointer ,cret-name
,@(or null-pointer-info
'(:ENOMEM "No memory allocated")))))
,@after
(values
,@(defmfun-return
c-return cret-name clret allocated return return-supplied-p
enumeration outputs))))))))
(defun defmfun-return
(c-return cret-name clret allocated return return-supplied-p enumeration outputs)
......
;; Airy functions
;; 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$
(in-package :gsl)
......@@ -9,48 +9,48 @@
;;;; Airy functions
;;;;****************************************************************************
(defmfun airy-Ai (x)
"gsl_sf_airy_Ai_e" ((x :double) :mode (ret sf-result))
(defmfun airy-Ai (x &optional (mode :double))
"gsl_sf_airy_Ai_e" ((x :double) (mode sf-mode) (ret sf-result))
:documentation ; FDL
"The Airy function Ai(x).")
(defmfun airy-Bi (x)
"gsl_sf_airy_Bi_e" ((x :double) :mode (ret sf-result))
(defmfun airy-Bi (x &optional (mode :double))
"gsl_sf_airy_Bi_e" ((x :double) (mode sf-mode) (ret sf-result))
:documentation ; FDL
"The Airy function Bi(x).")
(defmfun airy-Ai-scaled (x)
"gsl_sf_airy_Ai_scaled_e" ((x :double) :mode (ret sf-result))
(defmfun airy-Ai-scaled (x &optional (mode :double))
"gsl_sf_airy_Ai_scaled_e" ((x :double) (mode sf-mode) (ret sf-result))
:documentation ; FDL
"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)),
and is 1 for x<0.")
(defmfun airy-Bi-scaled (x)
"gsl_sf_airy_Bi_scaled_e" ((x :double) :mode (ret sf-result))
(defmfun airy-Bi-scaled (x &optional (mode :double))
"gsl_sf_airy_Bi_scaled_e" ((x :double) (mode sf-mode) (ret sf-result))
:documentation ; FDL
"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)),
and is 1 for x<0.")
(defmfun airy-Ai-deriv (x)
"gsl_sf_airy_Ai_deriv_e" ((x :double) :mode (ret sf-result))
(defmfun airy-Ai-deriv (x &optional (mode :double))
"gsl_sf_airy_Ai_deriv_e" ((x :double) (mode sf-mode) (ret sf-result))
:documentation ; FDL
"The Airy function derivative Ai'(x).")
(defmfun airy-Bi-deriv (x)
"gsl_sf_airy_Bi_deriv_e" ((x :double) :mode (ret sf-result))
(defmfun airy-Bi-deriv (x &optional (mode :double))
"gsl_sf_airy_Bi_deriv_e" ((x :double) (mode sf-mode) (ret sf-result))
:documentation "The Airy function derivative Bi'(x).")
(defmfun airy-Ai-deriv-scaled (x)
"gsl_sf_airy_Ai_deriv_scaled_e" ((x :double) :mode (ret sf-result))
(defmfun airy-Ai-deriv-scaled (x &optional (mode :double))
"gsl_sf_airy_Ai_deriv_scaled_e" ((x :double) (mode sf-mode) (ret sf-result))
:documentation ; FDL
"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)),
and is 1 for x<0.")
(defmfun airy-Bi-deriv-scaled (x)
"gsl_sf_airy_Bi_deriv_scaled_e" ((x :double) :mode (ret sf-result))
(defmfun airy-Bi-deriv-scaled (x &optional (mode :double))
"gsl_sf_airy_Bi_deriv_scaled_e" ((x :double) (mode sf-mode) (ret sf-result))
:documentation ; FDL
"The scaled Airy function derivative S_B(x) Bi'(x).
For x>0 the scaling factor S_B(x) is
......
;; Bessel functions
;; 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$
(in-package :gsl)
......@@ -365,9 +365,9 @@
"The regular cylindrical Bessel function of fractional order
\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"
((nu :double) :mode ((dim0 v) :int) ((c-pointer v) :pointer))
((nu :double) (mode sf-mode) ((dim0 v) :int) ((c-pointer v) :pointer))
:outputs (v)
:documentation ; FDL
"The regular cylindrical Bessel function of
......
;; Elliptic integrals
;; 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$
(in-package :gsl)
......@@ -9,15 +9,15 @@
;;;; Legendre form of complete elliptic integrals
;;;;****************************************************************************
(defmfun elliptic-integral-K-complete (k)
"gsl_sf_ellint_Kcomp_e" ((k :double) :mode (ret sf-result))
(defmfun elliptic-integral-K-complete (k &optional (mode :double))
"gsl_sf_ellint_Kcomp_e" ((k :double) (mode sf-mode) (ret sf-result))
:documentation ; FDL
"The complete elliptic integral of the first kind, K(k). Note that
Abramowitz & Stegun define this function in terms of the parameter m
= k^2.")
(defmfun elliptic-integral-E-complete (k)
"gsl_sf_ellint_Ecomp_e" ((k :double) :mode (ret sf-result))
(defmfun elliptic-integral-E-complete (k &optional (mode :double))
"gsl_sf_ellint_Ecomp_e" ((k :double) (mode sf-mode) (ret sf-result))
:documentation ; FDL
"The complete elliptic integral of the second kind, E(k).
Note that Abramowitz & Stegun define this function in terms of the
......@@ -27,32 +27,32 @@
;;;; Legendre form of incomplete elliptic integrals
;;;;****************************************************************************
(defmfun elliptic-integral-F (phi k)
"gsl_sf_ellint_F_e" ((phi :double) (k :double) :mode (ret sf-result))
(defmfun elliptic-integral-F (phi k &optional (mode :double))
"gsl_sf_ellint_F_e" ((phi :double) (k :double) (mode sf-mode) (ret sf-result))
:documentation ; FDL
"The incomplete elliptic integral of the first kind, F(phi,k). Note
that Abramowitz & Stegun define this function in terms of the
parameter m = k^2.")
(defmfun elliptic-integral-E (phi k)
"gsl_sf_ellint_E_e" ((phi :double) (k :double) :mode (ret sf-result))
(defmfun elliptic-integral-E (phi k &optional (mode :double))
"gsl_sf_ellint_E_e" ((phi :double) (k :double) (mode sf-mode) (ret sf-result))
:documentation ; FDL
"The incomplete elliptic integral of the second kind, E(phi,k). Note
that Abramowitz & Stegun define this function in terms of the
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"
((phi :double) (k :double) (n :double) :mode (ret sf-result))
((phi :double) (k :double) (n :double) (mode sf-mode) (ret sf-result))
:documentation ; FDL
"The incomplete elliptic integral of the third kind, P(phi,k,n).
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
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"
((phi :double) (k :double) (n :double) :mode (ret sf-result))
((phi :double) (k :double) (n :double) (mode sf-mode) (ret sf-result))
:documentation ; FDL
"The incomplete elliptic integral D(phi,k,n) which is
defined through the Carlson form RD(x,y,z)
......@@ -63,26 +63,26 @@
;;;; Carlson forms
;;;;****************************************************************************
(defmfun elliptic-integral-RC (x y)
"gsl_sf_ellint_RC_e" ((x :double) (y :double) :mode (ret sf-result))
(defmfun elliptic-integral-RC (x y &optional (mode :double))
"gsl_sf_ellint_RC_e" ((x :double) (y :double) (mode sf-mode) (ret sf-result))
:documentation ; FDL
"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"
((x :double) (y :double) (z :double) :mode (ret sf-result))
((x :double) (y :double) (z :double) (mode sf-mode) (ret sf-result))
:documentation ; FDL
"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"
((x :double) (y :double) (z :double) :mode (ret sf-result))
((x :double) (y :double) (z :double) (mode sf-mode) (ret sf-result))
:documentation ; FDL
"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"
((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
"The incomplete elliptic integral RJ(x,y,z,p).")
......
;; Structures returned by special functions.
;; 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$
(in-package :gsl)
......@@ -26,9 +26,9 @@
(cffi:defcenum sf-mode
"Numerical precision modes with which to calculate special functions."
;; file:///usr/share/doc/gsl-ref-html/gsl-ref_7.html#SEC62
:double-prec
:single-prec
:approx-prec)
:double
:single
:approx)
(defun val (sf-result &optional (type 'sf-result))
(cffi:foreign-slot-value sf-result type 'val))
......
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment