From 6f90daf7e7d1193bebefea24d45b463c4a5194fc Mon Sep 17 00:00:00 2001
From: Liam Healy <liam@thinkpad.local>
Date: Sun, 10 Aug 2008 18:15:24 -0400
Subject: [PATCH] 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.
---
 init/defmfun.lisp                         | 115 +++++++++++-----------
 linear-algebra/.gitignore                 |   1 +
 special-functions/airy.lisp               |  34 +++----
 special-functions/bessel.lisp             |   6 +-
 special-functions/elliptic-integrals.lisp |  42 ++++----
 special-functions/return-structures.lisp  |   8 +-
 6 files changed, 101 insertions(+), 105 deletions(-)
 create mode 100644 linear-algebra/.gitignore

diff --git a/init/defmfun.lisp b/init/defmfun.lisp
index 36042c9a..22eea28e 100644
--- a/init/defmfun.lisp
+++ b/init/defmfun.lisp
@@ -1,6 +1,6 @@
 ;; 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)
diff --git a/linear-algebra/.gitignore b/linear-algebra/.gitignore
new file mode 100644
index 00000000..b25c15b8
--- /dev/null
+++ b/linear-algebra/.gitignore
@@ -0,0 +1 @@
+*~
diff --git a/special-functions/airy.lisp b/special-functions/airy.lisp
index 25fb67f2..9c757f67 100644
--- a/special-functions/airy.lisp
+++ b/special-functions/airy.lisp
@@ -1,6 +1,6 @@
 ;; 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
diff --git a/special-functions/bessel.lisp b/special-functions/bessel.lisp
index bfcaaeb9..7e2f2c6d 100644
--- a/special-functions/bessel.lisp
+++ b/special-functions/bessel.lisp
@@ -1,6 +1,6 @@
 ;; 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
diff --git a/special-functions/elliptic-integrals.lisp b/special-functions/elliptic-integrals.lisp
index bdd53300..07571a95 100644
--- a/special-functions/elliptic-integrals.lisp
+++ b/special-functions/elliptic-integrals.lisp
@@ -1,6 +1,6 @@
 ;; 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).")
 
diff --git a/special-functions/return-structures.lisp b/special-functions/return-structures.lisp
index 4f3fdb48..0edcc2ad 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: <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))
-- 
GitLab