Commit efa2315f authored by Liam Healy's avatar Liam Healy

Extend #'copy to copy to or from mpointers

Both copy-to-array and copy-making-destination have been extended so
that an mpointer can occur as the first or second argument.  If the
first argument, the second argument should be a symbol representing a
subclass of marray.  If the second argument is not present
(copy-making-destination), 'vector-double-float is assumed.  If the
mpointer is the second argument, the marray contents are copied into
its contents.  These methods are useful for callbacks and GSL
functions that send raw mpointers.  For example, a callback that uses
foreign arrays directly can simply copy from and to them.  This has
been applied in the solve-minimize-fit functions that return a raw
mpointer, replacing the explicit call to make-marray.  The first
argument to #'marray can now be either the class name or element-type.
parent c5e449db
;; 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)))
;; 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
;;;;****************************************************************************
......
;; 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
;;;;****************************************************************************
......
......@@ -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>
......
;; 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)
......
;; 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.")
......
;; 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))
......
;;; 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.")
......
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