Commit ac62a39f authored by liam's avatar liam

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
;; 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: $
(in-package :gsl)
......@@ -526,7 +526,7 @@
When there are several equal maximum elements then the lowest index is
returned."
: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))
"gsl_matrix_min_index"
......@@ -536,7 +536,7 @@
When there are several equal minimum elements then the
lowest index is returned."
: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))
"gsl_matrix_minmax_index"
......@@ -547,8 +547,8 @@
When there are several equal minimum elements then the lowest index is
returned."
:c-return :void
:return ((list (size-to-cl imin) (size-to-cl jmin))
(list (size-to-cl imax) (size-to-cl jmax))))
:return ((list (scref imin) (scref jmin))
(list (scref imax) (scref jmax))))
;;;;****************************************************************************
;;;; Properties
......
;; Foreign callback functions.
;; Liam Healy
;; Time-stamp: <2008-01-20 22:34:41EST functions.lisp>
;; Time-stamp: <2008-01-28 22:21:09EST functions.lisp>
;; $Id: $
(in-package :gsl)
......@@ -182,7 +182,7 @@
reading or setting."
`(symbol-macrolet
,(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))
(defmacro with-c-doubles
......@@ -193,5 +193,5 @@
,(loop for (c-vector . element-names) in cvector-names
append
(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))
;; Definition of GSLL system
;; Liam Healy
;; Time-stamp: <2008-01-21 17:58:44EST gsll.asd>
;; Time-stamp: <2008-01-28 22:24:15EST gsll.asd>
;; $Id: $
(asdf:defsystem "gsll"
......@@ -171,6 +171,6 @@
(:file "hankel" :depends-on (init data))
(:file "roots-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 "linear-least-squares" :depends-on (init general data))))
;; Macros to interface GSL functions.
;; Liam Healy
;; Time-stamp: <2008-01-26 21:33:48EST interface.lisp>
;; Time-stamp: <2008-01-28 22:36:32EST interface.lisp>
;; $Id: $
(in-package :gsl)
......@@ -11,24 +11,17 @@
;;;; Lookup table to find CL functions from C function names
;;;;****************************************************************************
(defparameter *sf-name-mapping* nil
"An alist mapping the CL and GSL names of the special functions.
This will only be populated when macros are expanded.")
(defparameter *gsl-symbol-equivalence*
(make-hash-table :test 'equal :size 1500))
(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)
"Find the CL function name given the GSL C special function function name.
If cl-ppcre (http://www.weitz.de/cl-ppcre/) is installed, the string
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)))
"Find the GSLL (Lisp) equivalent of the GSL symbol."
(gethash (string-downcase string) *gsl-symbol-equivalence*))
;;;;****************************************************************************
;;;; Symbol-type declaration
......@@ -235,13 +228,13 @@
(:success-failure
(if (equal clret invalidate)
;; success-failure more important than passed-in
`((success-failure ,@clret))
`((success-failure ,cret-name))
(remove cret-name ; don't return c-return itself
`(,@clret (success-failure ,cret-name)))))
(:success-continue
(if (equal clret invalidate)
;; success-failure more important than passed-in
`((success-continue ,@clret))
`((success-continue ,cret-name))
(remove cret-name ; don't return c-return itself
`(,@clret (success-continue ,cret-name)))))
(:true-false
......
;********************************************************
; file: number-conversion.lisp
; description: Conversion of numbers C->CL
; date: Sun May 28 2006 - 22:04
; author: Liam M. Healy
; modified: Sat Sep 15 2007 - 22:34
;********************************************************
;;; $Id: $
;; Conversion of numbers C->CL
;; Liam Healy, Sun May 28 2006 - 22:04
;; Time-stamp: <2008-01-28 22:09:08EST number-conversion.lisp>
;; $Id: $
(in-package :gsl)
......@@ -13,24 +9,30 @@
;;;; 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))
(defmacro double-to-cl (double &optional (index 0))
(defmacro dcref (double &optional (index 0))
"Reference C double(s)."
`(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))
(defmacro int-to-cl (integer &optional (index 0))
(defmacro icref (integer &optional (index 0))
"Reference C integer(s)."
`(cffi:mem-aref ,integer :int ,index))
(defun cl-convert-function (type)
(case type
(:float 'float-to-cl)
(:double 'double-to-cl)
(:size 'size-to-cl)
(:int 'int-to-cl)
(:float 'fcref)
(:double 'dcref)
(:size 'scref)
(:int 'icref)
(gsl-complex 'complex-to-cl)))
;;;;****************************************************************************
......@@ -49,8 +51,8 @@
gsl-complex
(* index (cffi:foreign-type-size 'gsl-complex)))
'gsl-complex 'dat)))
(complex (double-to-cl carr 0)
(double-to-cl carr 1))))
(complex (dcref carr 0)
(dcref carr 1))))
;;;;****************************************************************************
;;;; Conversion form
......
;; Linear least squares, or linear regression
;; 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: $
(in-package :gsl)
......@@ -218,7 +218,7 @@
(rank :size)
((pointer parameters) :pointer) (covariance :pointer) (chisq :double)
(workspace :pointer))
:return ((double-to-cl chisq) (size-to-cl rank))
:return ((dcref chisq) (scref rank))
:documentation ; FDL
"Compute the best-fit parameters c of the weighted
model y = X c for the observations y and weights
......
;; Multivariate minimization.
;; 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: $
(in-package :gsl)
......@@ -335,10 +335,9 @@
(defun parabaloid-and-derivative
(arguments-gv-pointer fnval derivative-gv-pointer)
(with-c-double (fnval fv)
(setf fv (parabaloid arguments-gv-pointer))
(parabaloid-derivative
arguments-gv-pointer derivative-gv-pointer)))
(setf (dcref fnval) (parabaloid arguments-gv-pointer))
(parabaloid-derivative
arguments-gv-pointer derivative-gv-pointer))
(def-minimization-functions
parabaloid 2 parabaloid-derivative parabaloid-and-derivative)
......
;; Example ODE
;; 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: $
;;; van der Pol as given in Section 25.5 of the GSL manual. To
......@@ -35,11 +35,11 @@
(declare (special mu))
(with-ode-integration (time step-size (dependent dep0 dep1) 2)
(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
evolve control stepper vanderpol
time max-time step-size dependent)
(incf iter)
(format t "~&~12,6f~10t~12,6f~24t~12,6f"
(double-to-cl time) dep0 dep1)))))
(dcref time) dep0 dep1)))))
;; ODE system setup
;; 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: $
(in-package :gsl)
......@@ -36,7 +36,7 @@
&body body)
"Environment for integration of ordinary differential equations.
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
with-c-double."
(let ((ctime (make-symbol "CTIME"))
......@@ -49,8 +49,8 @@
((,(if (listp dependent) (first dependent) dependent)
:double ,dimensions) (,ctime :double) (,cstep :double))
(setf
(double-to-cl ,cstep) ,step-size
(double-to-cl ,ctime) ,time)
(dcref ,cstep) ,step-size
(dcref ,ctime) ,time)
,(if (listp dependent)
`(with-c-double ,dependent
(symbol-macrolet ((,time ,ctime) (,step-size ,cstep))
......
;; Simulated Annealing
;; 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: $
(in-package :gsl)
......@@ -175,7 +175,7 @@
(let ((*sa-function-calls* 0))
(rng-environment-setup)
(cffi:with-foreign-object (initial :double)
(setf (double-to-cl initial) 15.5d0)
(setf (dcref initial) 15.5d0)
(with-simulated-annealing-parameters
(params 200 10 10.0d0 1.0d0 0.002d0 1.005d0 2.0d-6)
(simulated-annealing
......
......@@ -42,7 +42,7 @@
(exp-F :double) (exp-G :double))
:return
((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))
:documentation
"The Coulomb wave functions @math{F_L(\eta,x)},
......@@ -65,7 +65,7 @@
@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."
: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)
"gsl_sf_coulomb_wave_FG_array"
......@@ -77,7 +77,7 @@
@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
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)
"gsl_sf_coulomb_wave_FGp_array"
......@@ -94,7 +94,7 @@
and @var{G_exponent}."
:return
(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)
"gsl_sf_coulomb_wave_sphF_array"
......@@ -107,7 +107,7 @@
stored in @var{F_exponent}. This function reduces to spherical Bessel
functions in the limit @math{\eta \to 0}."
:invalidate (fc-array)
:return (fc-array (double-to-cl F-exponent)))
:return (fc-array (dcref F-exponent)))
;;;;****************************************************************************
;;;; Coulomb Wave Function Normalization Constant
......
......@@ -41,7 +41,7 @@
function is computed using the real Lanczos method. The value of the
gamma function can be reconstructed using the relation @math{\Gamma(x) =
sgn * \exp(resultlg)}."
:return ((val ret) (double-to-cl sign) (err ret)))
:return ((val ret) (dcref sign) (err ret)))
(defun-gsl gamma* (x)
"gsl_sf_gammastar_e" ((x :double) (ret sf-result))
......@@ -128,7 +128,7 @@
\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
negative integers."
:return ((val ret) (double-to-cl sign) (err ret)))
:return ((val ret) (dcref sign) (err ret)))
(defun-gsl relative-pochammer (a x)
"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