Commit 3467a214 authored by liam's avatar liam

Use letm instead of with-data, remove static objects in tests, add GSL

objects for histogram.


git-svn-id: svn+ssh://pop/opt/space/mathematics/gsl/trunk@3283 a3d8a0fb-c1db-0310-ace7-a616afeb9e30
parent ddee5998
;; Using GSL storage. ;; Using GSL storage.
;; Liam Healy, Sun Mar 26 2006 - 16:32 ;; Liam Healy, Sun Mar 26 2006 - 16:32
;; Time-stamp: <2008-02-03 13:17:10EST data.lisp> ;; Time-stamp: <2008-02-03 23:34:26EST data.lisp>
;; $Id: $ ;; $Id: $
(in-package :gsl) (in-package :gsl)
...@@ -103,19 +103,42 @@ ...@@ -103,19 +103,42 @@
;;(LONG-DOUBLE . "_long_double") ;;(LONG-DOUBLE . "_long_double")
(COMPLEX . "_complex"))) (COMPLEX . "_complex")))
(defmacro data-go (type size-spec-is-list) (defmacro data-go (type matrixp)
"Define the letm function for data types." "Define the letm function for data types."
(let ((size-spec (if size-spec-is-list 'listp 'numberp)) (if matrixp ; Matrix (two indices)
(init-spec (if size-spec-is-list 'array-dimensions 'length))) `(defgo ,type (size-or-initial &optional size-or-zero zero)
`(defgo ,type (size-or-initial &optional zero) (if (and (numberp size-or-initial) (numberp size-or-zero))
(let ((argsymb (gensym "ARG"))) ;; Array dimensions are given as literal numbers for matrix
(list (list
`(make-data ',',type ,zero `(make-data ',',type ,zero ,size-or-initial ,size-or-zero)
(if (,',size-spec ,argsymb) ,argsymb (,',init-spec ,argsymb))) 'free)
'free ;; Determine at runtime whether first arg is initial or dimension
(lambda (symb) (let ((argsymb (gensym "ARG")))
`(unless (,',size-spec ,argsymb) (setf (data ,symb) ,argsymb))) (list
(lambda () (list argsymb size-or-initial))))))) `(apply #'make-data ',',type nil
(if (and (numberp ,argsymb) (numberp ,size-or-zero))
(list ,argsymb ,size-or-zero)
(array-dimensions ,argsymb)))
'free
(lambda (symb)
`(unless (and (numberp ,argsymb) (numberp ,size-or-zero))
(setf (data ,symb) ,argsymb)))
(lambda () (list argsymb size-or-initial))))))
;; Vector or other one-index object
`(defgo ,type (size-or-initial &optional zero)
(if (numberp size-or-initial)
;; Size is given as literal number
(list
`(make-data ',',type ,zero ,size-or-initial)
'free)
;; Determine at runtime whether first arg is initial or size
(let ((argsymb (gensym "ARG")))
(list
`(make-data ',',type ,zero
(if (numberp ,argsymb) ,argsymb (length ,argsymb)))
'free
(lambda (symb) `(unless (numberp ,argsymb) (setf (data ,symb) ,argsymb)))
(lambda () (list argsymb size-or-initial))))))))
(defmacro defdata (defmacro defdata
(c-string cl-symbol cl-base-type (c-string cl-symbol cl-base-type
......
;; Permutations ;; Permutations
;; Liam Healy, Sun Mar 26 2006 - 11:51 ;; Liam Healy, Sun Mar 26 2006 - 11:51
;; Time-stamp: <2008-01-21 11:12:01EST permutation.lisp> ;; Time-stamp: <2008-02-03 23:33:15EST permutation.lisp>
;; $Id: $ ;; $Id: $
(in-package :gsl) (in-package :gsl)
...@@ -69,8 +69,8 @@ ...@@ -69,8 +69,8 @@
(defun-gsl permutation-size (p) (defun-gsl permutation-size (p)
"gsl_permutation_size" "gsl_permutation_size"
(((pointer p) gsl-permutation-c)) (((pointer p) gsl-permutation-c))
:c-return :size ; FDL :c-return :size
:documentation :documentation ; FDL
"The size of the permutation p.") "The size of the permutation p.")
(defun-gsl permutation-data (p) (defun-gsl permutation-data (p)
...@@ -241,81 +241,68 @@ ...@@ -241,81 +241,68 @@
;;;; Examples and unit test ;;;; Examples and unit test
;;;;**************************************************************************** ;;;;****************************************************************************
(defparameter *perm-1* (make-data 'permutation t 4)) (defun generate-all-permutations (n)
(defparameter *perm-2* (make-data 'permutation t 4)) "Generate all the permutations of n objects."
(letm ((perm (permutation n t)))
(loop collect (data perm 'list)
while (permutation-next perm))))
(lisp-unit:define-test permutation (lisp-unit:define-test permutation
(lisp-unit:assert-eql ;gsl-aref (lisp-unit:assert-eql ;gsl-aref
2 2
(progn (letm ((perm-1 (permutation 4 t)))
(set-identity *perm-1*) (set-identity perm-1)
(gsl-aref *perm-1* 2))) (gsl-aref perm-1 2)))
(lisp-unit:assert-equalp ;data (lisp-unit:assert-equalp ;data
#(0 1 2 3) #(0 1 2 3)
(progn (letm ((perm-1 (permutation 4 t)))
(set-identity *perm-1*) (set-identity perm-1)
(data *perm-1*))) (data perm-1)))
(lisp-unit:assert-equalp ;permutation-reverse (lisp-unit:assert-equalp ;permutation-reverse
#(3 2 1 0) #(3 2 1 0)
(progn (letm ((perm-1 (permutation 4 t)))
(set-identity *perm-1*) (set-identity perm-1)
(data (permutation-reverse *perm-1*)))) (data (permutation-reverse perm-1))))
(lisp-unit:assert-equalp ;permutation-next, permutation-inverse (lisp-unit:assert-equalp ;permutation-next, permutation-inverse
#(0 3 1 2) #(0 3 1 2)
(progn (letm ((perm-1 (permutation 4 t)) (perm-2 (permutation 4 t)))
(set-identity *perm-1*) (set-identity perm-1)
(permutation-next *perm-1*) (permutation-next perm-1)
(permutation-next *perm-1*) (permutation-next perm-1)
(permutation-next *perm-1*) (permutation-next perm-1)
(permutation-inverse *perm-2* *perm-1*) (permutation-inverse perm-2 perm-1)
(data *perm-2*))) (data perm-2)))
(lisp-unit:assert-equalp ;swap-elements (lisp-unit:assert-equalp ;swap-elements
#(0 3 2 1) #(0 3 2 1)
(progn (letm ((perm-1 (permutation 4 t)))
(set-identity *perm-1*) (set-identity perm-1)
(swap-elements *perm-1* 1 3) (swap-elements perm-1 1 3)
(data *perm-1*))) (data perm-1)))
(lisp-unit:assert-equalp ;permute-vector (lisp-unit:assert-equalp ;permute-vector
#(33 44 11 22) #(33 44 11 22)
(progn (letm ((perm-1 (permutation 4 t))
(set-identity *perm-1*) (intvec (vector-fixnum #(11 22 33 44))))
(swap-elements *perm-1* 1 3) (set-identity perm-1)
(swap-elements *perm-1* 0 2) (swap-elements perm-1 1 3)
(setf (data *intvec-1*) #(11 22 33 44)) (swap-elements perm-1 0 2)
(permute-vector *perm-1* *intvec-1*) (permute-vector perm-1 intvec)
(data *intvec-1*))) (data intvec)))
(lisp-unit:assert-eql ;inversions (lisp-unit:assert-eql ;inversions
3 3
(progn (letm ((perm-1 (permutation 4 t)))
(set-identity *perm-1*) (set-identity perm-1)
(swap-elements *perm-1* 1 3) (swap-elements perm-1 1 3)
(inversions *perm-1*))) (inversions perm-1)))
(lisp-unit:assert-eql ;linear-cycles (lisp-unit:assert-eql ;linear-cycles
3 3
(progn (letm ((perm-1 (permutation 4 t)))
(set-identity *perm-1*) (set-identity perm-1)
(swap-elements *perm-1* 1 3) (swap-elements perm-1 1 3)
(linear-cycles *perm-1*))) (linear-cycles perm-1)))
(lisp-unit:assert-eql ;canonical-cycles (lisp-unit:assert-eql ;canonical-cycles
2 2
(progn (letm ((perm-1 (permutation 4 t)))
(set-identity *perm-1*) (set-identity perm-1)
(swap-elements *perm-1* 1 3) (swap-elements perm-1 1 3)
(swap-elements *perm-1* 0 2) (swap-elements perm-1 0 2)
(canonical-cycles *perm-1*)))) (canonical-cycles perm-1))))
;;;;****************************************************************************
;;;; Examples
;;;;****************************************************************************
#|
(with-data (perm permutation 4 t)
(loop collect (data perm 'list)
while (permutation-next perm)))
((0 1 2 3) (0 1 3 2) (0 2 1 3) (0 2 3 1) (0 3 1 2) (0 3 2 1) (1 0 2 3)
(1 0 3 2) (1 2 0 3) (1 2 3 0) (1 3 0 2) (1 3 2 0) (2 0 1 3) (2 0 3 1)
(2 1 0 3) (2 1 3 0) (2 3 0 1) (2 3 1 0) (3 0 1 2) (3 0 2 1) (3 1 0 2)
(3 1 2 0) (3 2 0 1) (3 2 1 0))
|#
;; Eigenvectors and eigenvalues ;; Eigenvectors and eigenvalues
;; Liam Healy, Sun May 21 2006 - 19:52 ;; Liam Healy, Sun May 21 2006 - 19:52
;; Time-stamp: <2008-02-03 13:22:47EST eigensystems.lisp> ;; Time-stamp: <2008-02-03 14:14:10EST eigensystems.lisp>
;; $Id: $ ;; $Id: $
(in-package :gsl) (in-package :gsl)
...@@ -182,21 +182,16 @@ ...@@ -182,21 +182,16 @@
;;;; Example ;;;; Example
;;;;**************************************************************************** ;;;;****************************************************************************
(defun eigenvalue-eigenvectors-example () (defun eigenvalue-eigenvectors-example ()
(with-data (mat matrix-double (3 3)) (letm ((evecs (matrix-double 3 3))
(setf (data mat) (evals (vector-double 3))
#2A((20.0d0 -10.0d0 0.0d0) (ws (eigen-symmv 3))
(-10.0d0 30.0d0 0.0d0) (mat (matrix-double
(0.0d0 0.0d0 40.0d0))) #2A((20.0d0 -10.0d0 0.0d0)
(with-data (evecs matrix-double (3 3)) (-10.0d0 30.0d0 0.0d0)
(with-data (evals vector-double 3) (0.0d0 0.0d0 40.0d0)))))
(letm ((ws (eigen-symmv 3))) (eigenvalues-eigenvectors-symmetric mat evals evecs ws)
(eigenvalues-eigenvectors-symmetric mat evals evecs ws) (values (data evals) (data evecs))))
(values (data evals) (data evecs)))))))
#| #|
#(13.819660112501051d0 36.180339887498945d0 40.0d0) #(13.819660112501051d0 36.180339887498945d0 40.0d0)
......
;; Definition of GSLL system ;; Definition of GSLL system
;; Liam Healy ;; Liam Healy
;; Time-stamp: <2008-01-28 22:24:15EST gsll.asd> ;; Time-stamp: <2008-02-03 22:30:09EST gsll.asd>
;; $Id: $ ;; $Id: $
(asdf:defsystem "gsll" (asdf:defsystem "gsll"
...@@ -163,7 +163,8 @@ ...@@ -163,7 +163,8 @@
((:file "interpolation") ((:file "interpolation")
(:file "types") (:file "types")
(:file "lookup") (:file "lookup")
(:file "evaluation"))) (:file "evaluation")
(:file "spline-example")))
(:file "numerical-differentiation" :depends-on (init general)) (:file "numerical-differentiation" :depends-on (init general))
(:file "chebyshev" :depends-on (init general)) (:file "chebyshev" :depends-on (init general))
(:file "series-acceleration" :depends-on (init)) (:file "series-acceleration" :depends-on (init))
......
;******************************************************** ;; The histogram structure
; file: structure.lisp ;; Liam Healy, Mon Jan 1 2007 - 11:32
; description: The histogram structure. ;; Time-stamp: <2008-02-03 21:53:32EST histogram.lisp>
; date: Mon Jan 1 2007 - 11:32 ;; $Id: $
; author: Liam M. Healy
; modified: Tue Jan 2 2007 - 23:03
;********************************************************
;;; $Id: $
(in-package :gsl) (in-package :gsl)
;;; Define, make, copy histograms in one or two dimensions. ;;; Define, make, copy histograms in one or two dimensions.
;;; Should this have a with-histogram macro, or be integrated into (defgo histogram (size &rest from-or-ranges)
;;; the data superclass (and so use with-data)? (list `(make-histogram ,size
,(when from-or-ranges
`(when (typep (first ,from-or-ranges) 'histogram)
(first ,from-or-ranges))))
'free
(when from-or-ranges
(lambda (sym)
`(unless (typep (first ,from-or-ranges) 'histogram)
(set-ranges ,sym ,@from-or-ranges))))))
(defclass histogram () (defclass histogram ()
((pointer ((pointer
...@@ -26,7 +30,7 @@ ...@@ -26,7 +30,7 @@
"gsl_histogram_alloc" "gsl_histogram_alloc"
(((number-of-bins object) :size)) (((number-of-bins object) :size))
:export nil :export nil
:index alloc :index (letm histogram)
:c-return (cr :pointer) :c-return (cr :pointer)
:return ((assign-pointer object cr))) :return ((assign-pointer object cr)))
...@@ -35,7 +39,7 @@ ...@@ -35,7 +39,7 @@
(((first (number-of-bins object)) :size) (((first (number-of-bins object)) :size)
((second (number-of-bins object)) :size)) ((second (number-of-bins object)) :size))
:export nil :export nil
:index alloc :index (letm histogram)
:c-return (cr :pointer) :c-return (cr :pointer)
:return ((assign-pointer object cr))) :return ((assign-pointer object cr)))
...@@ -56,13 +60,17 @@ ...@@ -56,13 +60,17 @@
"gsl_histogram_free" "gsl_histogram_free"
(((pointer object) :pointer)) (((pointer object) :pointer))
:c-return (cr :pointer) :c-return (cr :pointer)
:return ((assign-pointer object cr))) :return ((assign-pointer object cr))
:export nil
:index (letm histogram))
(defun-gsl free-histo-2 (object) (defun-gsl free-histo-2 (object)
"gsl_histogram2d_free" "gsl_histogram2d_free"
(((pointer object) :pointer)) (((pointer object) :pointer))
:c-return (cr :pointer) :c-return (cr :pointer)
:return ((assign-pointer object cr))) :return ((assign-pointer object cr))
:export nil
:index (letm histogram))
(defmethod free ((object histogram)) (defmethod free ((object histogram))
(histo-1d2d object free-histo)) (histo-1d2d object free-histo))
...@@ -74,11 +82,11 @@ ...@@ -74,11 +82,11 @@
(((pointer histogram) :pointer) (((pointer histogram) :pointer)
((gsl-array ranges) :pointer) ((dim0 ranges) :size)) ((gsl-array ranges) :pointer) ((dim0 ranges) :size))
:export nil :export nil
:index set-ranges :index (letm histogram)
:documentation :documentation ; FDL
"Set the ranges of the existing histogram using "Set the ranges of the existing histogram using
the gsl-vector of ranges. The values of the histogram the gsl-vector of ranges. The values of the histogram
bins are reset to zero. The @code{ranges} array should contain the bins are reset to zero. The ranges array should contain the
desired bin limits. The ranges can be arbitrary, subject to the desired bin limits. The ranges can be arbitrary, subject to the
restriction that they are monotonically increasing.") restriction that they are monotonically increasing.")
...@@ -88,7 +96,7 @@ ...@@ -88,7 +96,7 @@
((gsl-array x-ranges) :pointer) ((dim0 x-ranges) :size) ((gsl-array x-ranges) :pointer) ((dim0 x-ranges) :size)
((gsl-array y-ranges) :pointer) ((dim0 y-ranges) :size)) ((gsl-array y-ranges) :pointer) ((dim0 y-ranges) :size))
:export nil :export nil
:index set-ranges) :index (letm histogram))
(export 'set-ranges) (export 'set-ranges)
(defun set-ranges (histogram &rest ranges) (defun set-ranges (histogram &rest ranges)
...@@ -109,16 +117,16 @@ ...@@ -109,16 +117,16 @@
(((pointer histogram) :pointer) (minimum :double) (maximum :double)) (((pointer histogram) :pointer) (minimum :double) (maximum :double))
:export nil :export nil
:index set-ranges-uniform :index set-ranges-uniform
:documentation :documentation ; FDL
"Set the ranges of the existing histogram @var{h} to cover "Set the ranges of the existing histogram h to cover
the range @var{xmin} to @var{xmax} uniformly. The values of the the range xmin to xmax uniformly. The values of the
histogram bins are reset to zero. The bin ranges are shown in the table histogram bins are reset to zero. The bin ranges are shown in the table
below, below,
bin[0] corresponds to xmin <= x < xmin + d bin[0] corresponds to xmin <= x < xmin + d
bin[1] corresponds to xmin + d <= x < xmin + 2 d bin[1] corresponds to xmin + d <= x < xmin + 2 d
...... ......
bin[n-1] corresponds to xmin + (n-1)d <= x < xmax bin[n-1] corresponds to xmin + (n-1)d <= x < xmax
where @math{d} is the bin spacing, @math{d = (xmax-xmin)/n}.") where d is the bin spacing, d = (xmax-xmin)/n.")
;;; GSL documentation does not state what the return value for the ;;; GSL documentation does not state what the return value for the
;;; C function means; assumed to be error code. ;;; C function means; assumed to be error code.
...@@ -133,15 +141,16 @@ ...@@ -133,15 +141,16 @@
(export 'set-ranges-uniform) (export 'set-ranges-uniform)
(defun set-ranges-uniform (histogram &rest limits) (defun set-ranges-uniform (histogram &rest limits)
"Set the ranges of the existing histogram @var{h} to cover ;; FDL
the range @var{xmin} to @var{xmax} uniformly. The values of the "Set the ranges of the existing histogram h to cover
the range xmin to xmax uniformly. The values of the
histogram bins are reset to zero. The bin ranges are shown in the table histogram bins are reset to zero. The bin ranges are shown in the table
below, below,
bin[0] corresponds to xmin <= x < xmin + d bin[0] corresponds to xmin <= x < xmin + d
bin[1] corresponds to xmin + d <= x < xmin + 2 d bin[1] corresponds to xmin + d <= x < xmin + 2 d
...... ......
bin[n-1] corresponds to xmin + (n-1)d <= x < xmax bin[n-1] corresponds to xmin + (n-1)d <= x < xmax
where @math{d} is the bin spacing, @math{d = (xmax-xmin)/n}." where d is the bin spacing, d = (xmax-xmin)/n."
(histo-1d2d histogram set-ranges-uniform (histo-1d2d histogram set-ranges-uniform
((first limits) (second limits)) ((first limits) (second limits))
((first limits) (second limits) ((first limits) (second limits)
...@@ -152,7 +161,7 @@ ...@@ -152,7 +161,7 @@
(((pointer destination) :pointer) ((pointer source) :pointer)) (((pointer destination) :pointer) ((pointer source) :pointer))
:export nil :export nil
:index copy :index copy
:documentation :documentation ; FDL
"Copy the histogram source into the pre-existing "Copy the histogram source into the pre-existing
histogram destination, making the latter into histogram destination, making the latter into
an exact copy of the former. an exact copy of the former.
...@@ -172,7 +181,7 @@ ...@@ -172,7 +181,7 @@
(((pointer source) :pointer)) (((pointer source) :pointer))
:export nil :export nil
:index clone :index clone
:documentation :documentation ; FDL
"Create a new histogram which is an "Create a new histogram which is an
exact copy of the histogram source, and return the pointer.") exact copy of the histogram source, and return the pointer.")
...@@ -181,12 +190,15 @@ ...@@ -181,12 +190,15 @@
(((pointer source) :pointer)) (((pointer source) :pointer))
:export nil :export nil
:index clone :index clone
:documentation :documentation ; FDL
"Create a new histogram which is an "Create a new histogram which is an
exact copy of the histogram source, and return the pointer.") exact copy of the histogram source, and return the pointer.")
(export 'clone) (export 'clone)
(defun clone (source) (defun clone (source)
;; FDL
"Create a new histogram which is an
exact copy of the histogram source, and return the pointer."
(histo-1d2d source clone)) (histo-1d2d source clone))
(defun make-histogram (size &optional from) (defun make-histogram (size &optional from)
...@@ -198,5 +210,3 @@ ...@@ -198,5 +210,3 @@
(unless (pointer ret) (unless (pointer ret)
(alloc ret)) (alloc ret))
ret)) ret))
...@@ -121,51 +121,61 @@ ...@@ -121,51 +121,61 @@
((first values) (second values)))) ((first values) (second values))))
;;; Examples and unit test ;;; Examples and unit test
(defparameter *sample-histogram*
(let ((histo (make-histogram 10)))
(set-ranges-uniform histo 0.0d0 10.0d0)
histo))
(defun setup-sample-histogram ()
(reset *sample-histogram*)
(increment *sample-histogram* 2.7d0)
(increment *sample-histogram* 6.9d0 2.0d0))
(lisp-unit:define-test histogram (lisp-unit:define-test histogram
(lisp-unit:assert-error (lisp-unit:assert-error
'gsl-warning 'gsl-warning
(progn (letm ((histo (histogram 10)))
(setup-sample-histogram) (set-ranges-uniform histo 0.0d0 10.0d0)
(increment *sample-histogram* -2.0d0))) (increment histo -2.0d0)))
(lisp-unit:assert-first-fp-equal (lisp-unit:assert-first-fp-equal
"0.000000000000d+01" "0.000000000000d+01"
(progn (letm ((histo (histogram 10)))
(setup-sample-histogram) (set-ranges-uniform histo 0.0d0 10.0d0)
(gsl-aref *sample-histogram* 1))) (increment histo 2.7d0)
(increment histo 6.9d0 2.0d0)
(gsl-aref histo 1)))
(lisp-unit:assert-first-fp-equal (lisp-unit:assert-first-fp-equal
"0.100000000000d+01" "0.100000000000d+01"
(progn (letm ((histo (histogram 10)))
(setup-sample-histogram) (set-ranges-uniform histo 0.0d0 10.0d0)
(gsl-aref *sample-histogram* 2))) (increment histo 2.7d0)
(increment histo 6.9d0 2.0d0)
(gsl-aref histo 2)))
(lisp-unit:assert-first-fp-equal (lisp-unit:assert-first-fp-equal
"0.200000000000d+01" "0.200000000000d+01"
(progn (letm ((histo (histogram 10)))
(setup-sample-histogram) (set-ranges-uniform histo 0.0d0 10.0d0)
(gsl-aref *sample-histogram* 6))) (increment histo 2.7d0)
(increment histo 6.9d0 2.0d0)
(gsl-aref histo 6)))
(lisp-unit:assert-error (lisp-unit:assert-error
'gsl-error 'gsl-error
(gsl-aref *sample-histogram* 16)) (letm ((histo (histogram 10)))
(lisp-unit:assert-first-fp-equal (set-ranges-uniform histo 0.0d0 10.0d0)
"0.000000000000d+01" (increment histo 2.7d0)
(gsl-min-range *sample-histogram*)) (increment histo 6.9d0 2.0d0)
(gsl-aref histo 16)))
(lisp-unit:assert-first-fp-equal (lisp-unit:assert-first-fp-equal
"0.100000000000d+02" '("0.000000000000d+01" "0.100000000000d+02")
(gsl-max-range *sample-histogram*)) (lisp-unit:fp-values
(letm ((histo (histogram 10)))
(set-ranges-uniform histo 0.0d0 10.0d0)
(increment histo 2.7d0)
(increment histo 6.9d0 2.0d0)
(values (gsl-min-range histo) (gsl-max-range histo)))))
(lisp-unit:assert-eql (lisp-unit:assert-eql
10 10
(bins *sample-histogram*)) (letm ((histo (histogram 10)))
(set-ranges-uniform histo 0.0d0 10.0d0)
(increment histo 2.7d0)
(increment histo 6.9d0 2.0d0)
(bins histo)))
(lisp-unit:assert-eql (lisp-unit:assert-eql
5 5
(histogram-find *sample-histogram* 5.5d0))) (letm ((histo (histogram 10)))
(set-ranges-uniform histo 0.0d0 10.0d0)
(increment histo 2.7d0)
(increment histo 6.9d0 2.0d0)
(histogram-find histo 5.5d0))))
;; Utility definitions ;; Utility definitions
;; Liam Healy, Sun Dec 3 2006 - 10:21 ;; Liam Healy, Sun Dec 3 2006 - 10:21
;; Time-stamp: <2008-02-03 13:31:47EST utility.lisp> ;; Time-stamp: <2008-02-03 23:00:32EST utility.lisp>
;; $Id: $ ;; $Id: $
(in-package :gsl) (in-package :gsl)
...@@ -32,39 +32,42 @@ ...@@ -32,39 +32,42 @@
(let* (setters ; save setting forms (let* (setters ; save setting forms
freers ; save freeing forms freers ; save freeing forms
assigns ; save global assignements assigns ; save global assignements
(*not-for-users* t) (*not-for-users* t))
(bnd ; rewrite the bindings with allocators ;; Rewrite the bindings with allocators and push them on assigns
(mapcar (dolist (b bindings)
(lambda (b) (if (atom b)
(let ((defsymb (first b)) (defas (second b))) (push b assigns)
(if (and (listp b) (listp defas) (let ((defsymb (first b)) (defas (second b)))
(member (first defas) *letm-expanded-object*)) (if (and (listp b) (listp defas)
;; It is a GSL object (member (first defas) *letm-expanded-object*))
(destructuring-bind (allocator freer &optional setter assign) ;; It is a GSL object
(apply (first defas) (rest defas)) (destructuring-bind (allocator freer &optional setter assign)
;; If there's a setting function, save the form (apply (first defas) (rest defas))
(when setter (push (funcall setter defsymb) setters)) ;; If there's a setting function, save the form
;; Save the freeing form (when setter (push (funcall setter defsymb) setters))
(push `(,freer ,defsymb) freers) ;; Save the freeing form
;; Save the global assignments (push `(,freer ,defsymb) freers)
(when assign (push (funcall assign) assigns)) ;; Save the global assignments
;; Return the allocation form to be used in let (when assign (push (funcall assign) assigns))
`(,defsymb ,allocator)) ;; Return the allocation form to be used in let
;; Not a GSL object, just define it with let (push `(,defsymb ,allocator) assigns))
b))) ;; Not a GSL object, just define it with let
bindings))) (push b assigns)))))
(if freers (if freers
;; There were GSL objects ;; There were GSL objects
`(let* (,@assigns ,@bnd) `(let* (,@(reverse assigns))
;; put the body in an unwind-protect ;; put the body in an unwind-protect
(unwind-protect (unwind-protect
(progn (progn
,@setters ; setting the objects ,@(reverse setters) ; setting the objects
,@body) ,@body)
,@freers)) ; freeing the objects