Commit ac62a39f authored by liam's avatar liam
Browse files

Rename double-to-cl as dcref, etc. Make the symbol lookup use a

hashtable for speed.  Fix bug in return value in success-failure and
success-continue cases.


git-svn-id: svn+ssh://pop/opt/space/mathematics/gsl/trunk@3277 a3d8a0fb-c1db-0310-ace7-a616afeb9e30
parent 2035b727
;; Matrices ;; Matrices
;; Liam Healy, Sun Mar 26 2006 - 11:51 ;; Liam Healy, Sun Mar 26 2006 - 11:51
;; Time-stamp: <2008-01-21 11:47:04EST matrix.lisp> ;; Time-stamp: <2008-01-28 22:19:38EST matrix.lisp>
;; $Id: $ ;; $Id: $
(in-package :gsl) (in-package :gsl)
...@@ -526,7 +526,7 @@ ...@@ -526,7 +526,7 @@
When there are several equal maximum elements then the lowest index is When there are several equal maximum elements then the lowest index is
returned." returned."
:c-return :void :c-return :void
:return ((list (size-to-cl imax) (size-to-cl jmax)))) :return ((list (scref imax) (scref jmax))))
(defun-gsl-mdsf gsl-min-index ((m gsl-matrix)) (defun-gsl-mdsf gsl-min-index ((m gsl-matrix))
"gsl_matrix_min_index" "gsl_matrix_min_index"
...@@ -536,7 +536,7 @@ ...@@ -536,7 +536,7 @@
When there are several equal minimum elements then the When there are several equal minimum elements then the
lowest index is returned." lowest index is returned."
:c-return :void :c-return :void
:return ((list (size-to-cl imin) (size-to-cl jmin)))) :return ((list (scref imin) (scref jmin))))
(defun-gsl-mdsf gsl-minmax-index ((m gsl-matrix)) (defun-gsl-mdsf gsl-minmax-index ((m gsl-matrix))
"gsl_matrix_minmax_index" "gsl_matrix_minmax_index"
...@@ -547,8 +547,8 @@ ...@@ -547,8 +547,8 @@
When there are several equal minimum elements then the lowest index is When there are several equal minimum elements then the lowest index is
returned." returned."
:c-return :void :c-return :void
:return ((list (size-to-cl imin) (size-to-cl jmin)) :return ((list (scref imin) (scref jmin))
(list (size-to-cl imax) (size-to-cl jmax)))) (list (scref imax) (scref jmax))))
;;;;**************************************************************************** ;;;;****************************************************************************
;;;; Properties ;;;; Properties
......
;; Foreign callback functions. ;; Foreign callback functions.
;; Liam Healy ;; Liam Healy
;; Time-stamp: <2008-01-20 22:34:41EST functions.lisp> ;; Time-stamp: <2008-01-28 22:21:09EST functions.lisp>
;; $Id: $ ;; $Id: $
(in-package :gsl) (in-package :gsl)
...@@ -182,7 +182,7 @@ ...@@ -182,7 +182,7 @@
reading or setting." reading or setting."
`(symbol-macrolet `(symbol-macrolet
,(loop for i from 0 for a in element-names ,(loop for i from 0 for a in element-names
collect `(,a (double-to-cl ,c-vector ,i))) collect `(,a (dcref ,c-vector ,i)))
,@body)) ,@body))
(defmacro with-c-doubles (defmacro with-c-doubles
...@@ -193,5 +193,5 @@ ...@@ -193,5 +193,5 @@
,(loop for (c-vector . element-names) in cvector-names ,(loop for (c-vector . element-names) in cvector-names
append append
(loop for i from 0 for a in element-names (loop for i from 0 for a in element-names
collect `(,a (double-to-cl ,c-vector ,i)))) collect `(,a (dcref ,c-vector ,i))))
,@body)) ,@body))
;; Definition of GSLL system ;; Definition of GSLL system
;; Liam Healy ;; Liam Healy
;; Time-stamp: <2008-01-21 17:58:44EST gsll.asd> ;; Time-stamp: <2008-01-28 22:24:15EST gsll.asd>
;; $Id: $ ;; $Id: $
(asdf:defsystem "gsll" (asdf:defsystem "gsll"
...@@ -171,6 +171,6 @@ ...@@ -171,6 +171,6 @@
(:file "hankel" :depends-on (init data)) (:file "hankel" :depends-on (init data))
(:file "roots-one" :depends-on (init general)) (:file "roots-one" :depends-on (init general))
(:file "minimization-one" :depends-on (init general)) (:file "minimization-one" :depends-on (init general))
(:file "roots-multi" :depends-on (init general data)) (:file "roots-multi" :depends-on (init general data roots-one))
(:file "minimization-multi" :depends-on (init general data)) (:file "minimization-multi" :depends-on (init general data))
(:file "linear-least-squares" :depends-on (init general data)))) (:file "linear-least-squares" :depends-on (init general data))))
;; Macros to interface GSL functions. ;; Macros to interface GSL functions.
;; Liam Healy ;; Liam Healy
;; Time-stamp: <2008-01-26 21:33:48EST interface.lisp> ;; Time-stamp: <2008-01-28 22:36:32EST interface.lisp>
;; $Id: $ ;; $Id: $
(in-package :gsl) (in-package :gsl)
...@@ -11,24 +11,17 @@ ...@@ -11,24 +11,17 @@
;;;; Lookup table to find CL functions from C function names ;;;; Lookup table to find CL functions from C function names
;;;;**************************************************************************** ;;;;****************************************************************************
(defparameter *sf-name-mapping* nil (defparameter *gsl-symbol-equivalence*
"An alist mapping the CL and GSL names of the special functions. (make-hash-table :test 'equal :size 1500))
This will only be populated when macros are expanded.")
(defun map-name (cl-name gsl-name) (defun map-name (cl-name gsl-name)
(setf *sf-name-mapping* (acons cl-name gsl-name *sf-name-mapping*))) ;; Trust here that the library does not have two symbols that differ
;; only by the case of one or more letters.
(setf (gethash (string-downcase gsl-name) *gsl-symbol-equivalence*) cl-name))
(defun gsl-lookup (string) (defun gsl-lookup (string)
"Find the CL function name given the GSL C special function function name. "Find the GSLL (Lisp) equivalent of the GSL symbol."
If cl-ppcre (http://www.weitz.de/cl-ppcre/) is installed, the string (gethash (string-downcase string) *gsl-symbol-equivalence*))
can be a regular expression; otherwise, it must match the C name exactly
except for case."
(remove string *sf-name-mapping*
:key #'rest
:test-not
(if (find-package :ppcre)
(symbol-function (intern "ALL-MATCHES" :ppcre))
#'string-equal)))
;;;;**************************************************************************** ;;;;****************************************************************************
;;;; Symbol-type declaration ;;;; Symbol-type declaration
...@@ -235,13 +228,13 @@ ...@@ -235,13 +228,13 @@
(:success-failure (:success-failure
(if (equal clret invalidate) (if (equal clret invalidate)
;; success-failure more important than passed-in ;; success-failure more important than passed-in
`((success-failure ,@clret)) `((success-failure ,cret-name))
(remove cret-name ; don't return c-return itself (remove cret-name ; don't return c-return itself
`(,@clret (success-failure ,cret-name))))) `(,@clret (success-failure ,cret-name)))))
(:success-continue (:success-continue
(if (equal clret invalidate) (if (equal clret invalidate)
;; success-failure more important than passed-in ;; success-failure more important than passed-in
`((success-continue ,@clret)) `((success-continue ,cret-name))
(remove cret-name ; don't return c-return itself (remove cret-name ; don't return c-return itself
`(,@clret (success-continue ,cret-name))))) `(,@clret (success-continue ,cret-name)))))
(:true-false (:true-false
......
;******************************************************** ;; Conversion of numbers C->CL
; file: number-conversion.lisp ;; Liam Healy, Sun May 28 2006 - 22:04
; description: Conversion of numbers C->CL ;; Time-stamp: <2008-01-28 22:09:08EST number-conversion.lisp>
; date: Sun May 28 2006 - 22:04 ;; $Id: $
; author: Liam M. Healy
; modified: Sat Sep 15 2007 - 22:34
;********************************************************
;;; $Id: $
(in-package :gsl) (in-package :gsl)
...@@ -13,24 +9,30 @@ ...@@ -13,24 +9,30 @@
;;;; Built-in numerical types ;;;; Built-in numerical types
;;;;**************************************************************************** ;;;;****************************************************************************
(defmacro float-to-cl (float &optional (index 0)) (export '(fcref dcref scref icref))
(defmacro fcref (float &optional (index 0))
"Reference C float(s)."
`(cffi:mem-aref ,float :float ,index)) `(cffi:mem-aref ,float :float ,index))
(defmacro double-to-cl (double &optional (index 0)) (defmacro dcref (double &optional (index 0))
"Reference C double(s)."
`(cffi:mem-aref ,double :double ,index)) `(cffi:mem-aref ,double :double ,index))
(defmacro size-to-cl (size &optional (index 0)) (defmacro scref (size &optional (index 0))
"Reference C size(s)."
`(cffi:mem-aref ,size :size ,index)) `(cffi:mem-aref ,size :size ,index))
(defmacro int-to-cl (integer &optional (index 0)) (defmacro icref (integer &optional (index 0))
"Reference C integer(s)."
`(cffi:mem-aref ,integer :int ,index)) `(cffi:mem-aref ,integer :int ,index))
(defun cl-convert-function (type) (defun cl-convert-function (type)
(case type (case type
(:float 'float-to-cl) (:float 'fcref)
(:double 'double-to-cl) (:double 'dcref)
(:size 'size-to-cl) (:size 'scref)
(:int 'int-to-cl) (:int 'icref)
(gsl-complex 'complex-to-cl))) (gsl-complex 'complex-to-cl)))
;;;;**************************************************************************** ;;;;****************************************************************************
...@@ -49,8 +51,8 @@ ...@@ -49,8 +51,8 @@
gsl-complex gsl-complex
(* index (cffi:foreign-type-size 'gsl-complex))) (* index (cffi:foreign-type-size 'gsl-complex)))
'gsl-complex 'dat))) 'gsl-complex 'dat)))
(complex (double-to-cl carr 0) (complex (dcref carr 0)
(double-to-cl carr 1)))) (dcref carr 1))))
;;;;**************************************************************************** ;;;;****************************************************************************
;;;; Conversion form ;;;; Conversion form
......
;; Linear least squares, or linear regression ;; Linear least squares, or linear regression
;; Liam Healy <2008-01-21 12:41:46EST linear-least-squares.lisp> ;; Liam Healy <2008-01-21 12:41:46EST linear-least-squares.lisp>
;; Time-stamp: <2008-01-26 19:48:03EST linear-least-squares.lisp> ;; Time-stamp: <2008-01-28 22:22:22EST linear-least-squares.lisp>
;; $Id: $ ;; $Id: $
(in-package :gsl) (in-package :gsl)
...@@ -218,7 +218,7 @@ ...@@ -218,7 +218,7 @@
(rank :size) (rank :size)
((pointer parameters) :pointer) (covariance :pointer) (chisq :double) ((pointer parameters) :pointer) (covariance :pointer) (chisq :double)
(workspace :pointer)) (workspace :pointer))
:return ((double-to-cl chisq) (size-to-cl rank)) :return ((dcref chisq) (scref rank))
:documentation ; FDL :documentation ; FDL
"Compute the best-fit parameters c of the weighted "Compute the best-fit parameters c of the weighted
model y = X c for the observations y and weights model y = X c for the observations y and weights
......
;; Multivariate minimization. ;; Multivariate minimization.
;; Liam Healy <Tue Jan 8 2008 - 21:28> ;; Liam Healy <Tue Jan 8 2008 - 21:28>
;; Time-stamp: <2008-01-27 22:55:36EST minimization-multi.lisp> ;; Time-stamp: <2008-01-28 22:42:05EST minimization-multi.lisp>
;; $Id: $ ;; $Id: $
(in-package :gsl) (in-package :gsl)
...@@ -335,10 +335,9 @@ ...@@ -335,10 +335,9 @@
(defun parabaloid-and-derivative (defun parabaloid-and-derivative
(arguments-gv-pointer fnval derivative-gv-pointer) (arguments-gv-pointer fnval derivative-gv-pointer)
(with-c-double (fnval fv) (setf (dcref fnval) (parabaloid arguments-gv-pointer))
(setf fv (parabaloid arguments-gv-pointer)) (parabaloid-derivative
(parabaloid-derivative arguments-gv-pointer derivative-gv-pointer))
arguments-gv-pointer derivative-gv-pointer)))
(def-minimization-functions (def-minimization-functions
parabaloid 2 parabaloid-derivative parabaloid-and-derivative) parabaloid 2 parabaloid-derivative parabaloid-and-derivative)
......
;; Example ODE ;; Example ODE
;; Liam Healy Sat Sep 29 2007 - 17:49 ;; Liam Healy Sat Sep 29 2007 - 17:49
;; Time-stamp: <2008-01-20 17:40:48EST ode-example.lisp> ;; Time-stamp: <2008-01-28 22:21:07EST ode-example.lisp>
;; $Id: $ ;; $Id: $
;;; van der Pol as given in Section 25.5 of the GSL manual. To ;;; van der Pol as given in Section 25.5 of the GSL manual. To
...@@ -35,11 +35,11 @@ ...@@ -35,11 +35,11 @@
(declare (special mu)) (declare (special mu))
(with-ode-integration (time step-size (dependent dep0 dep1) 2) (with-ode-integration (time step-size (dependent dep0 dep1) 2)
(setf dep0 1.0d0 dep1 0.0d0) (setf dep0 1.0d0 dep1 0.0d0)
(loop (when (or (>= (double-to-cl time) max-time) (> iter *max-iter*)) (return)) (loop (when (or (>= (dcref time) max-time) (> iter *max-iter*)) (return))
(apply-evolution (apply-evolution
evolve control stepper vanderpol evolve control stepper vanderpol
time max-time step-size dependent) time max-time step-size dependent)
(incf iter) (incf iter)
(format t "~&~12,6f~10t~12,6f~24t~12,6f" (format t "~&~12,6f~10t~12,6f~24t~12,6f"
(double-to-cl time) dep0 dep1))))) (dcref time) dep0 dep1)))))
;; ODE system setup ;; ODE system setup
;; Liam Healy, Sun Apr 15 2007 - 14:19 ;; Liam Healy, Sun Apr 15 2007 - 14:19
;; Time-stamp: <2008-01-20 18:06:12EST ode-system.lisp> ;; Time-stamp: <2008-01-28 22:21:08EST ode-system.lisp>
;; $Id: $ ;; $Id: $
(in-package :gsl) (in-package :gsl)
...@@ -36,7 +36,7 @@ ...@@ -36,7 +36,7 @@
&body body) &body body)
"Environment for integration of ordinary differential equations. "Environment for integration of ordinary differential equations.
The variables time and step-size will become C doubles in the body; The variables time and step-size will become C doubles in the body;
to convert back, use double-to-cl. The dependent variable may to convert back, use #'dcref The dependent variable may
be specified as a list being the same as the first argument to be specified as a list being the same as the first argument to
with-c-double." with-c-double."
(let ((ctime (make-symbol "CTIME")) (let ((ctime (make-symbol "CTIME"))
...@@ -49,8 +49,8 @@ ...@@ -49,8 +49,8 @@
((,(if (listp dependent) (first dependent) dependent) ((,(if (listp dependent) (first dependent) dependent)
:double ,dimensions) (,ctime :double) (,cstep :double)) :double ,dimensions) (,ctime :double) (,cstep :double))
(setf (setf
(double-to-cl ,cstep) ,step-size (dcref ,cstep) ,step-size
(double-to-cl ,ctime) ,time) (dcref ,ctime) ,time)
,(if (listp dependent) ,(if (listp dependent)
`(with-c-double ,dependent `(with-c-double ,dependent
(symbol-macrolet ((,time ,ctime) (,step-size ,cstep)) (symbol-macrolet ((,time ,ctime) (,step-size ,cstep))
......
;; Simulated Annealing ;; Simulated Annealing
;; Liam Healy Sun Feb 11 2007 - 17:23 ;; Liam Healy Sun Feb 11 2007 - 17:23
;; Time-stamp: <2008-01-20 22:37:12EST simulated-annealing.lisp> ;; Time-stamp: <2008-01-28 22:19:40EST simulated-annealing.lisp>
;; $Id: $ ;; $Id: $
(in-package :gsl) (in-package :gsl)
...@@ -175,7 +175,7 @@ ...@@ -175,7 +175,7 @@
(let ((*sa-function-calls* 0)) (let ((*sa-function-calls* 0))
(rng-environment-setup) (rng-environment-setup)
(cffi:with-foreign-object (initial :double) (cffi:with-foreign-object (initial :double)
(setf (double-to-cl initial) 15.5d0) (setf (dcref initial) 15.5d0)
(with-simulated-annealing-parameters (with-simulated-annealing-parameters
(params 200 10 10.0d0 1.0d0 0.002d0 1.005d0 2.0d-6) (params 200 10 10.0d0 1.0d0 0.002d0 1.005d0 2.0d-6)
(simulated-annealing (simulated-annealing
......
...@@ -42,7 +42,7 @@ ...@@ -42,7 +42,7 @@
(exp-F :double) (exp-G :double)) (exp-F :double) (exp-G :double))
:return :return
((val F) (val Fp) (val G) (val Gp) ((val F) (val Fp) (val G) (val Gp)
(double-to-cl exp-F) (double-to-cl exp-G) (dcref exp-F) (dcref exp-G)
(err F) (err Fp) (err G) (err Gp)) (err F) (err Fp) (err G) (err Gp))
:documentation :documentation
"The Coulomb wave functions @math{F_L(\eta,x)}, "The Coulomb wave functions @math{F_L(\eta,x)},
...@@ -65,7 +65,7 @@ ...@@ -65,7 +65,7 @@
@math{L = Lmin \dots Lmin + kmax}, storing the results in @var{fc-array}. @math{L = Lmin \dots Lmin + kmax}, storing the results in @var{fc-array}.
In the case of overflow the exponent is stored in the second value returned." In the case of overflow the exponent is stored in the second value returned."
:invalidate (fc-array) :invalidate (fc-array)
:return (fc-array (double-to-cl F-exponent))) :return (fc-array (dcref F-exponent)))
(defun-gsl coulomb-wave-FG-array (L-min eta x fc-array gc-array) (defun-gsl coulomb-wave-FG-array (L-min eta x fc-array gc-array)
"gsl_sf_coulomb_wave_FG_array" "gsl_sf_coulomb_wave_FG_array"
...@@ -77,7 +77,7 @@ ...@@ -77,7 +77,7 @@
@math{G_L(\eta,x)} for @math{L = Lmin \dots Lmin + kmax} storing the @math{G_L(\eta,x)} for @math{L = Lmin \dots Lmin + kmax} storing the
results in @var{fc_array} and @var{gc_array}. In the case of overflow the results in @var{fc_array} and @var{gc_array}. In the case of overflow the
exponents are stored in @var{F_exponent} and @var{G_exponent}." exponents are stored in @var{F_exponent} and @var{G_exponent}."
:return (fc-array gc-array (double-to-cl F-exponent) (double-to-cl G-exponent))) :return (fc-array gc-array (dcref F-exponent) (dcref G-exponent)))
(defun-gsl coulomb-wave-FGp-array (L-min eta x fc-array fcp-array gc-array gcp-array) (defun-gsl coulomb-wave-FGp-array (L-min eta x fc-array fcp-array gc-array gcp-array)
"gsl_sf_coulomb_wave_FGp_array" "gsl_sf_coulomb_wave_FGp_array"
...@@ -94,7 +94,7 @@ ...@@ -94,7 +94,7 @@
and @var{G_exponent}." and @var{G_exponent}."
:return :return
(fc-array fcp-array gc-array gcp-array (fc-array fcp-array gc-array gcp-array
(double-to-cl F-exponent) (double-to-cl G-exponent))) (dcref F-exponent) (dcref G-exponent)))
(defun-gsl coulomb-wave-sphF-array (L-min eta x fc-array) (defun-gsl coulomb-wave-sphF-array (L-min eta x fc-array)
"gsl_sf_coulomb_wave_sphF_array" "gsl_sf_coulomb_wave_sphF_array"
...@@ -107,7 +107,7 @@ ...@@ -107,7 +107,7 @@
stored in @var{F_exponent}. This function reduces to spherical Bessel stored in @var{F_exponent}. This function reduces to spherical Bessel
functions in the limit @math{\eta \to 0}." functions in the limit @math{\eta \to 0}."
:invalidate (fc-array) :invalidate (fc-array)
:return (fc-array (double-to-cl F-exponent))) :return (fc-array (dcref F-exponent)))
;;;;**************************************************************************** ;;;;****************************************************************************
;;;; Coulomb Wave Function Normalization Constant ;;;; Coulomb Wave Function Normalization Constant
......
...@@ -41,7 +41,7 @@ ...@@ -41,7 +41,7 @@
function is computed using the real Lanczos method. The value of the function is computed using the real Lanczos method. The value of the
gamma function can be reconstructed using the relation @math{\Gamma(x) = gamma function can be reconstructed using the relation @math{\Gamma(x) =
sgn * \exp(resultlg)}." sgn * \exp(resultlg)}."
:return ((val ret) (double-to-cl sign) (err ret))) :return ((val ret) (dcref sign) (err ret)))
(defun-gsl gamma* (x) (defun-gsl gamma* (x)
"gsl_sf_gammastar_e" ((x :double) (ret sf-result)) "gsl_sf_gammastar_e" ((x :double) (ret sf-result))
...@@ -128,7 +128,7 @@ ...@@ -128,7 +128,7 @@
\log(|(a)_x|)} and @math{sgn = \sgn((a)_x)} where @math{(a)_x := \log(|(a)_x|)} and @math{sgn = \sgn((a)_x)} where @math{(a)_x :=
\Gamma(a + x)/\Gamma(a)}, subject to @math{a}, @math{a+x} not being \Gamma(a + x)/\Gamma(a)}, subject to @math{a}, @math{a+x} not being
negative integers." negative integers."
:return ((val ret) (double-to-cl sign) (err ret))) :return ((val ret) (dcref sign) (err ret)))
(defun-gsl relative-pochammer (a x) (defun-gsl relative-pochammer (a x)
"gsl_sf_pochrel_e" ((a :double) (x :double) (ret sf-result)) "gsl_sf_pochrel_e" ((a :double) (x :double) (ret sf-result))
......
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