diff --git a/data/marray.lisp b/data/foreign-array.lisp similarity index 74% rename from data/marray.lisp rename to data/foreign-array.lisp index 666574a7e5668889b35a9bbb4bb1129fc9760024..a5fc37395552d5f656360adc5014cf07ee5ca6b7 100644 --- a/data/marray.lisp +++ b/data/foreign-array.lisp @@ -1,6 +1,6 @@ -;; A "marray" is an array in both GSL and CL +;; A grid:foreign-array with added metadata for GSL. ;; Liam Healy 2008-04-06 21:23:41EDT -;; Time-stamp: <2010-06-26 23:04:25EDT marray.lisp> +;; Time-stamp: <2010-06-27 08:48:58EDT foreign-array.lisp> ;; ;; Copyright 2008, 2009 Liam M. Healy ;; Distributed under the terms of the GNU General Public License @@ -21,11 +21,9 @@ (in-package :gsl) ;;;;**************************************************************************** -;;;; The class marray and its construction +;;;; Make the mpointer, block-pointer, total-size metadata ;;;;**************************************************************************** -;;; Slots were mpointer, block-pointer, total-size - ;;; We don't allocate or free the C array data, because that is ;;; handled by grid:foreign-array. We can use the GSL functions ;;; *_alloc_from_block because they will allocate only the structure, @@ -37,13 +35,16 @@ `(getf (foreign-metadata ,object) ,name)) (defun make-gsl-metadata (object) - ;; Need to check that all allocations succeeded. - ;; Don't do anything if mpointer has been assigned, - ;; or this is a permutation or combination (they have their own methods). + "Make the necessary GSL metadata (mpointer and block-pointer) + for the given foreign array, and return the mpointer. + This should only be called by #'mpointer the first time + it is called on a particular foreign-array." + ;; Don't do anything if mpointer has already been assigned. (unless (metadata-slot object 'mpointer) (when (zerop (total-size object)) (error "Object ~a has zero total dimension." object)) - (let* ((blockptr (cffi:foreign-alloc 'gsl-block-c)) + (let* ((blockptr (cffi:foreign-alloc 'gsl-block-c)) ; check this result + ;; it is not clear what foreign-alloc does if the alloc fails. (array-struct (alloc-from-block object blockptr))) (setf (cffi:foreign-slot-value blockptr 'gsl-block-c 'size) (grid:total-size object) @@ -60,11 +61,13 @@ (tg:finalize object (lambda () (cffi:foreign-free blockptr) - (cffi:foreign-free array-struct)))))) + (cffi:foreign-free array-struct)))) + (metadata-slot object 'mpointer))) (defmethod mpointer ((object grid:foreign-array)) - (metadata-slot object 'mpointer) - (make-gsl-metadata object)) + (or + (metadata-slot object 'mpointer) + (make-gsl-metadata object))) ;;;;**************************************************************************** ;;;; Make data from either the dimensions provided or from the initial values @@ -86,7 +89,7 @@ keys))) ;;;;**************************************************************************** -;;;; Copy to and from bare mpointers +;;;; Make from GSL mpointers ;;;;**************************************************************************** ;; Some functions in solve-minimize-fit return a pointer to a GSL @@ -95,6 +98,28 @@ ;; data even on native implementations; because GSL is doing the ;; mallocing, the data are not CL-accessible. +(defun make-foreign-array-from-mpointer + (mpointer &optional (element-type 'double-float) (category :vector)) + "Make the foreign array when a GSL pointer to a + gsl-vector-c or gsl-matrix-c is given." + (let* ((cstruct + (case category + (:vector 'gsl-vector-c) + (:matrix 'gsl-matrix-c) + (t (error "Unrecognized category ~a" category)))) + (c-pointer (cffi:foreign-slot-value mpointer cstruct 'data))) + (grid:make-grid + (case category + (:vector + `((foreign-array ,(cffi:foreign-slot-value mpointer cstruct size)) + ,element-type)) + (:matrix + `((foreign-array + ,(cffi:foreign-slot-value mpointer cstruct size0) + ,(cffi:foreign-slot-value mpointer cstruct size1))) + ,element-type)) + :foreign-pointer c-pointer + :foreign-metadata mpointer))) ;;;;**************************************************************************** ;;;; Convenient defaulting of defmfun arguments diff --git a/solve-minimize-fit/minimization-multi.lisp b/solve-minimize-fit/minimization-multi.lisp index 1d339eb7c07d58f60bfa29f64dee4031878c8d3e..208e0722721705e9ccc37e379f568b0bb2cb4a30 100644 --- a/solve-minimize-fit/minimization-multi.lisp +++ b/solve-minimize-fit/minimization-multi.lisp @@ -1,6 +1,6 @@ ;; Multivariate minimization. ;; Liam Healy <Tue Jan 8 2008 - 21:28> -;; Time-stamp: <2009-12-27 10:05:32EST minimization-multi.lisp> +;; Time-stamp: <2010-06-27 08:39:24EDT minimization-multi.lisp> ;; ;; Copyright 2008, 2009 Liam M. Healy ;; Distributed under the terms of the GNU General Public License @@ -138,7 +138,7 @@ :definition :method :callback-object minimizer :c-return (crtn :pointer) - :return ((copy crtn)) + :return ((make-foreign-array-from-mpointer crtn)) :documentation ; FDL "The current best estimate of the location of the minimum.") @@ -148,7 +148,7 @@ :definition :method :callback-object minimizer :c-return (crtn :pointer) - :return ((copy crtn)) + :return ((make-foreign-array-from-mpointer crtn)) :documentation ; FDL "The current best estimate of the location of the minimum.") @@ -180,7 +180,7 @@ "gsl_multimin_fdfminimizer_gradient" (((mpointer minimizer) :pointer)) :c-return (crtn :pointer) - :return ((copy crtn)) + :return ((make-foreign-array-from-mpointer crtn)) :documentation ; FDL "The current best estimate of the gradient for the minimizer.") diff --git a/solve-minimize-fit/nonlinear-least-squares.lisp b/solve-minimize-fit/nonlinear-least-squares.lisp index 7922f40573d44ebc8582d8e415c5e891ad897c0e..ac3565c94ceff889dcae645fbcbe5f8fc173dd0e 100644 --- a/solve-minimize-fit/nonlinear-least-squares.lisp +++ b/solve-minimize-fit/nonlinear-least-squares.lisp @@ -1,6 +1,6 @@ ;; Nonlinear least squares fitting. ;; Liam Healy, 2008-02-09 12:59:16EST nonlinear-least-squares.lisp -;; Time-stamp: <2010-04-25 22:13:58EDT nonlinear-least-squares.lisp> +;; Time-stamp: <2010-06-27 08:42:19EDT nonlinear-least-squares.lisp> ;; ;; Copyright 2008, 2009 Liam M. Healy ;; Distributed under the terms of the GNU General Public License @@ -119,7 +119,7 @@ (((mpointer solver) :pointer)) :definition :method :c-return (crtn :pointer) - :return ((copy crtn)) + :return ((make-foreign-array-from-mpointer crtn)) :documentation ; FDL "The current best-fit parameters.") @@ -128,13 +128,13 @@ (((mpointer solver) :pointer)) :definition :method :c-return (crtn :pointer) - :return ((copy crtn)) + :return ((make-foreign-array-from-mpointer crtn)) :documentation ; FDL "The current best-fit parameters.") ;;; Why doesn't GSL have functions to extract these values? (defmethod function-value ((solver nonlinear-fdffit)) - (copy + (make-foreign-array-from-mpointer (cffi:foreign-slot-value (mpointer solver) 'gsl-fdffit-solver 'f))) (defmethod last-step ((solver nonlinear-fdffit)) diff --git a/solve-minimize-fit/roots-multi.lisp b/solve-minimize-fit/roots-multi.lisp index 7821ba999d1c7b3de5bddcec9a1944882f3238ef..d9a19baa465bc5d78289f2d5eda3dbf0a2d4f4f9 100644 --- a/solve-minimize-fit/roots-multi.lisp +++ b/solve-minimize-fit/roots-multi.lisp @@ -1,6 +1,6 @@ ;;; Multivariate roots. ;;; Liam Healy 2008-01-12 12:49:08 -;;; Time-stamp: <2009-12-27 10:05:32EST roots-multi.lisp> +;;; Time-stamp: <2010-06-27 08:44:26EDT roots-multi.lisp> ;; ;; Copyright 2008, 2009 Liam M. Healy ;; Distributed under the terms of the GNU General Public License @@ -147,7 +147,7 @@ :definition :method :callback-object solver :c-return (crtn :pointer) - :return ((copy crtn)) + :return ((make-foreign-array-from-mpointer crtn)) :documentation ; FDL "The current estimate of the root for the solver.") @@ -157,7 +157,7 @@ :definition :method :callback-object solver :c-return (crtn :pointer) - :return ((copy crtn)) + :return ((make-foreign-array-from-mpointer crtn)) :documentation "The current estimate of the root for the solver.") @@ -166,7 +166,7 @@ (((mpointer solver) :pointer)) :definition :method :c-return (crtn :pointer) - :return ((copy crtn)) + :return ((make-foreign-array-from-mpointer crtn)) :documentation ; FDL "The function value f(x) at the current estimate x of the root for the solver.") @@ -175,7 +175,7 @@ (((mpointer solver) :pointer)) :definition :method :c-return (crtn :pointer) - :return ((copy crtn)) + :return ((make-foreign-array-from-mpointer crtn)) :documentation ; FDL "The function value f(x) at the current estimate x of the root for the solver.") @@ -184,7 +184,7 @@ (((mpointer solver) :pointer)) :definition :method :c-return (crtn :pointer) - :return ((copy crtn)) + :return ((make-foreign-array-from-mpointer crtn)) :documentation ; FDL "The last step dx taken by the solver.") @@ -193,7 +193,7 @@ (((mpointer solver) :pointer)) :definition :method :c-return (crtn :pointer) - :return ((copy crtn)) + :return ((make-foreign-array-from-mpointer crtn)) :documentation ; FDL "The last step dx taken by the solver.")