diff --git a/data/marray.lisp b/data/marray.lisp index 225e68c474c9a3ece43f4b4d383209011ce67b48..1c21f817bddd89ff54afe7fb5fef2b8768be4df4 100644 --- a/data/marray.lisp +++ b/data/marray.lisp @@ -1,6 +1,6 @@ ;; A "marray" is an array in both GSL and CL ;; Liam Healy 2008-04-06 21:23:41EDT -;; Time-stamp: <2009-03-16 09:36:00EDT marray.lisp> +;; Time-stamp: <2009-03-20 11:33:31EDT marray.lisp> ;; $Id$ (in-package :gsl) @@ -118,13 +118,14 @@ (export 'make-marray) (defun make-marray - (element-type &rest keys &key dimensions initial-contents from-pointer cl-array + (class-or-element-type &rest keys &key dimensions initial-contents from-pointer cl-array &allow-other-keys) "Make a GSLL array with the given element type, :dimensions, and :initial-contents, :initial-element or :cl-array. If the :cl-array is supplied, it should be a CL array generated with #'make-ffa. If a pointer to a GSL object is given in :from-pointer, create - an object with duplicate contents; if a matrix, :dimensions must be set to 2." + an object with duplicate contents; if a matrix, :dimensions must be a list + of length 2 (contents are unimportant)." ;; Some functions in solve-minimize-fit return a pointer to a GSL ;; vector of double-floats. With the :from-pointer argument, this ;; function turn that into a foreign-friendly array. There is no @@ -132,21 +133,27 @@ ;; because GSL is doing the mallocing, the data are not ;; CL-accessible. (if from-pointer - (make-marray element-type + (make-marray class-or-element-type :initial-contents (contents-from-pointer from-pointer - (if (eql dimensions 2) 'gsl-matrix-c 'gsl-vector-c) - element-type)) + (if (and (listp dimensions) + (eql (length dimensions) 2)) + 'gsl-matrix-c 'gsl-vector-c) + (if (subtypep class-or-element-type 'marray) + (lookup-type class-or-element-type *class-element-type*) + class-or-element-type))) (apply #'make-instance - (data-class-name - (if - (or - (and dimensions (listp dimensions) (eql (length dimensions) 2)) - (and initial-contents (listp (first initial-contents))) - (and cl-array (eql (length (array-dimensions cl-array)) 2))) - 'matrix 'vector) - element-type) + (if (subtypep class-or-element-type 'marray) + class-or-element-type + (data-class-name + (if + (or + (and dimensions (listp dimensions) (eql (length dimensions) 2)) + (and initial-contents (listp (first initial-contents))) + (and cl-array (eql (length (array-dimensions cl-array)) 2))) + 'matrix 'vector) + class-or-element-type)) keys))) (defun hashm-numeric-code (n) @@ -183,7 +190,22 @@ (total-size object))) ;;;;**************************************************************************** -;;;; C structures +;;;; Copy to and from bare mpointers ;;;;**************************************************************************** -;;; For #-native, do the whole thing using _alloc, _free functions. +(defgeneric contents-from-pointer (pointer struct-type &optional element-type) + (:documentation + "Create a contents list from the GSL object of type struct-type + referenced by pointer.")) + +(defmethod copy-making-destination ((pointer #.+foreign-pointer-class+)) + (if (typep pointer +foreign-pointer-type+) + ;; Default assumption when destination isn't given in #'copy is + ;; that this should make a vector-double-float. + (copy-to-destination pointer 'vector-double-float) + (call-next-method))) + +(defmethod copy-to-destination ((pointer #.+foreign-pointer-class+) (class-name symbol)) + (if (typep pointer +foreign-pointer-type+) + (make-marray class-name :from-pointer pointer) + (call-next-method))) diff --git a/data/matrix.lisp b/data/matrix.lisp index 84a2474f1e7a67f70ec60fcc75c71d840a13c08b..427f62b2d3458a0c7b1bdf265b09f5d216f5861c 100644 --- a/data/matrix.lisp +++ b/data/matrix.lisp @@ -1,6 +1,6 @@ ;; Matrices ;; Liam Healy 2008-04-15 21:57:52EDT matrix.lisp -;; Time-stamp: <2009-03-18 14:45:31EDT matrix.lisp> +;; Time-stamp: <2009-03-20 10:48:31EDT matrix.lisp> ;; $Id$ (in-package :gsl) @@ -35,6 +35,16 @@ collect (loop for j below dim1 collect (maref pointer i j element-type))))) +(defmethod copy-to-destination + ((object matrix) (pointer #.+foreign-pointer-class+)) + (if (typep pointer +foreign-pointer-type+) + (loop for i below (dim0 object) + do (loop for j below (dim1 object) + do + (setf (maref pointer i j (element-type object)) + (maref object i j)))) + (call-next-method))) + ;;;;**************************************************************************** ;;;; Mathematical ;;;;**************************************************************************** diff --git a/data/vector.lisp b/data/vector.lisp index 49e28dcd572a233d825ef4bb88bece6e6619a96b..19aa1190ab03aa54f6ddd24500ed7ac1afecbcd2 100644 --- a/data/vector.lisp +++ b/data/vector.lisp @@ -1,6 +1,6 @@ ;; Vectors ;; Liam Healy 2008-04-13 09:39:02EDT vector.lisp -;; Time-stamp: <2008-12-28 18:01:59EST vector.lisp> +;; Time-stamp: <2009-03-20 10:37:55EDT vector.lisp> ;; $Id$ (in-package :gsl) @@ -30,6 +30,14 @@ (loop for i below (cffi:foreign-slot-value pointer struct-type 'size) collect (maref pointer i nil element-type))) +(defmethod copy-to-destination + ((object mvector) (pointer #.+foreign-pointer-class+)) + (if (typep pointer +foreign-pointer-type+) + (loop for i below (dim0 object) + do (setf (maref pointer i nil (element-type object)) + (maref object i))) + (call-next-method))) + ;;;;**************************************************************************** ;;;; Function definitions ;;;;**************************************************************************** diff --git a/documentation/index.html b/documentation/index.html index 4ec0427d958140f82260dd43794069479272bd0d..70caeaf558839edbf1b190f0afc8bac41d519c89 100644 --- a/documentation/index.html +++ b/documentation/index.html @@ -303,7 +303,12 @@ area of memory.</p> with <code>setf maref</code>. A complete CL array may be extracted with the function <code>#'cl-array</code>. </p> - +<p>Copying marrays is performed with the function <code>copy</code>. + This works between marrays, pointers, and CL arrays. It is useful + for functions intended to be passed to GSL functions (for + e.g. solving, minimizing or fitting) that need to set a GSL vector + or matrix, because one can simply copy into the passed-in pointer. +</p> <h3>Passing functions</h3> <p> Functions that are passed to GSL functions (known as <i>callbacks</i> @@ -391,7 +396,7 @@ and arrays used internally or for function return. <!-- Created: Feb 25 2005 --> <!-- hhmts start --> <small> -Time-stamp: <2009-03-10 21:00:47EDT index.html> +Time-stamp: <2009-03-20 11:54:53EDT index.html> </small> <!-- hhmts end --> </div> diff --git a/init/mobject.lisp b/init/mobject.lisp index acd2b0d69fcf1e637c9b68b96b57397fbed298a0..ad39c0a363f0a85f7016c47062dd99cc3b30d66e 100644 --- a/init/mobject.lisp +++ b/init/mobject.lisp @@ -1,6 +1,6 @@ ;; Definition of GSL objects and ways to use them. ;; Liam Healy, Sun Dec 3 2006 - 10:21 -;; Time-stamp: <2009-02-24 15:36:40EST mobject.lisp> +;; Time-stamp: <2009-03-20 10:22:49EDT mobject.lisp> ;;; GSL objects are represented in GSLL as and instance of a 'mobject. ;;; The macro demobject takes care of defining the appropriate @@ -250,11 +250,6 @@ ;;; over the data even on native implementations; because GSL is doing ;;; the mallocing, the data are not CL-accessible. -(defgeneric contents-from-pointer (pointer struct-type &optional element-type) - (:documentation - "Create a contents list from the GSL object of type struct-type - referenced by pointer.")) - (defmethod mpointer ((object #.+foreign-pointer-class+)) (check-type object #.+foreign-pointer-type+) object) diff --git a/solve-minimize-fit/minimization-multi.lisp b/solve-minimize-fit/minimization-multi.lisp index ebd822ac9493991df33413306c01cd7ff3bfef2c..a7038f3b768d42a8b29fee49b71f36fff3039744 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-02-26 13:55:22EST minimization-multi.lisp> +;; Time-stamp: <2009-03-19 11:19:31EDT minimization-multi.lisp> ;; $Id$ (in-package :gsl) @@ -148,7 +148,7 @@ (((mpointer minimizer) :pointer)) :definition :method :c-return (crtn :pointer) - :return ((make-marray 'double-float :from-pointer crtn)) + :return ((copy crtn)) :documentation ; FDL "The current best estimate of the location of the minimum.") @@ -157,7 +157,7 @@ (((mpointer minimizer) :pointer)) :definition :method :c-return (crtn :pointer) - :return ((make-marray 'double-float :from-pointer crtn)) + :return ((copy crtn)) :documentation ; FDL "The current best estimate of the location of the minimum.") @@ -188,7 +188,7 @@ "gsl_multimin_fdfminimizer_gradient" (((mpointer minimizer) :pointer)) :c-return (crtn :pointer) - :return ((make-marray 'double-float :from-pointer crtn)) + :return ((copy 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 6fddfa5ad6b5b8f8b021f1b5c74731bd81127296..4802598c9964633e1b40d04200505c844d498e4c 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: <2009-02-16 10:16:06EST nonlinear-least-squares.lisp> +;; Time-stamp: <2009-03-19 11:13:41EDT nonlinear-least-squares.lisp> ;; $Id$ (in-package :gsl) @@ -157,7 +157,7 @@ (((mpointer solver) :pointer)) :definition :method :c-return (crtn :pointer) - :return ((make-marray 'double-float :from-pointer crtn)) + :return ((copy crtn)) :documentation ; FDL "The current best-fit parameters.") @@ -166,15 +166,13 @@ (((mpointer solver) :pointer)) :definition :method :c-return (crtn :pointer) - :return ((make-marray 'double-float :from-pointer crtn)) + :return ((copy crtn)) :documentation ; FDL "The current best-fit parameters.") ;;; Why doesn't GSL have functions to extract these values? (defmethod function-value ((solver nonlinear-fdffit)) - (make-marray - 'double-float - :from-pointer + (copy (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 4466a1c2391e6ff8bbbb902ab593fc67d05c3ff6..629bf69eb589666a3b72724319c9974c1067eb9e 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-02-16 09:56:43EST roots-multi.lisp> +;;; Time-stamp: <2009-03-20 11:33:58EDT roots-multi.lisp> ;;; $Id$ (in-package :gsl) @@ -143,7 +143,7 @@ (((mpointer solver) :pointer)) :definition :method :c-return (crtn :pointer) - :return ((make-marray 'double-float :from-pointer crtn)) + :return ((copy crtn)) :documentation ; FDL "The current estimate of the root for the solver.") @@ -152,7 +152,7 @@ (((mpointer solver) :pointer)) :definition :method :c-return (crtn :pointer) - :return ((make-marray 'double-float :from-pointer crtn)) + :return ((copy crtn)) :documentation "The current estimate of the root for the solver.") @@ -161,7 +161,7 @@ (((mpointer solver) :pointer)) :definition :method :c-return (crtn :pointer) - :return ((make-marray 'double-float :from-pointer crtn)) + :return ((copy crtn)) :documentation ; FDL "The function value f(x) at the current estimate x of the root for the solver.") @@ -170,7 +170,7 @@ (((mpointer solver) :pointer)) :definition :method :c-return (crtn :pointer) - :return ((make-marray 'double-float :from-pointer crtn)) + :return ((copy crtn)) :documentation ; FDL "The function value f(x) at the current estimate x of the root for the solver.") @@ -179,7 +179,7 @@ (((mpointer solver) :pointer)) :definition :method :c-return (crtn :pointer) - :return ((make-marray 'double-float :from-pointer crtn)) + :return ((copy crtn)) :documentation ; FDL "The last step dx taken by the solver.") @@ -188,7 +188,7 @@ (((mpointer solver) :pointer)) :definition :method :c-return (crtn :pointer) - :return ((make-marray 'double-float :from-pointer crtn)) + :return ((copy crtn)) :documentation ; FDL "The last step dx taken by the solver.")