Commit de18c122 authored by Liam Healy's avatar Liam Healy

Make marrays make from pointer with copy

Make marrays from pointer with #'copy instead of make-marray;
:from-pointer argument removed from #'make-marray.  Define a macro
foreign-pointer-method that for most implementations just returns the
form.  For CLISP however, it checks that the pointer is of type
+foreign-pointer-type+, because in CLISP the foreign pointer class is
T.  Export marray subclass names.
parent e4a26746
;; A "marray" is an array in both GSL and CL
;; Liam Healy 2008-04-06 21:23:41EDT
;; Time-stamp: <2009-03-20 11:33:31EDT marray.lisp>
;; Time-stamp: <2009-03-20 17:20:00EDT marray.lisp>
;; $Id$
(in-package :gsl)
......@@ -109,7 +109,8 @@
:allocation :class)))
;; Push mapping onto *class-element-type*
(pushnew ',(cons class-name element-type-cl)
*class-element-type* :test #'equal))))
*class-element-type* :test #'equal)
(export ',class-name))))
*array-element-types*)))
;;;;****************************************************************************
......@@ -118,43 +119,24 @@
(export 'make-marray)
(defun make-marray
(class-or-element-type &rest keys &key dimensions initial-contents from-pointer cl-array
(class-or-element-type &rest keys &key dimensions initial-contents 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 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
;; choice but to copy over the data even on native implementations;
;; because GSL is doing the mallocing, the data are not
;; CL-accessible.
(if from-pointer
(make-marray class-or-element-type
:initial-contents
(contents-from-pointer
from-pointer
(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
(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)))
If the :cl-array is supplied, it should be a CL array generated
with #'make-ffa."
(apply #'make-instance
(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)
"Get the appropriate element type for the numeric code n"
......@@ -199,13 +181,26 @@
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)))
(foreign-pointer-method
pointer
;; 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)))
(defmethod copy-to-destination
((pointer #.+foreign-pointer-class+) (class-name symbol))
(foreign-pointer-method
pointer
(make-marray
class-name
:initial-contents
(contents-from-pointer
pointer
(if (subtypep class-name 'matrix) 'gsl-matrix-c 'gsl-vector-c)
(lookup-type class-name *class-element-type*)))))
;; Some functions in solve-minimize-fit return a pointer to a GSL
;; vector of double-floats. This function turns that into a
;; foreign-friendly array. There is no choice but to copy over the
;; data even on native implementations; because GSL is doing the
;; mallocing, the data are not CL-accessible.
;; Matrices
;; Liam Healy 2008-04-15 21:57:52EDT matrix.lisp
;; Time-stamp: <2009-03-20 10:48:31EDT matrix.lisp>
;; Time-stamp: <2009-03-20 17:20:57EDT matrix.lisp>
;; $Id$
(in-package :gsl)
......@@ -37,13 +37,13 @@
(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)))
(foreign-pointer-method
pointer
(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))))))
;;;;****************************************************************************
;;;; Mathematical
......
;; Vectors
;; Liam Healy 2008-04-13 09:39:02EDT vector.lisp
;; Time-stamp: <2009-03-20 10:37:55EDT vector.lisp>
;; Time-stamp: <2009-03-20 17:20:40EDT vector.lisp>
;; $Id$
(in-package :gsl)
......@@ -32,11 +32,11 @@
(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)))
(foreign-pointer-method
pointer
(loop for i below (dim0 object)
do (setf (maref pointer i nil (element-type object))
(maref object i)))))
;;;;****************************************************************************
;;;; Function definitions
......
;; Definition of GSL objects and ways to use them.
;; Liam Healy, Sun Dec 3 2006 - 10:21
;; Time-stamp: <2009-03-20 10:22:49EDT mobject.lisp>
;; Time-stamp: <2009-03-20 17:22:22EDT mobject.lisp>
;;; GSL objects are represented in GSLL as and instance of a 'mobject.
;;; The macro demobject takes care of defining the appropriate
......@@ -244,6 +244,19 @@
(defconstant +foreign-pointer-type+ (type-of (cffi:null-pointer))
"The type of foreign pointers."))
;;; Note: clisp has a foreign pointer class = T, so it would be best
;;; to narrow down methods that dispatch on this class.
(defmacro foreign-pointer-method (pointer form)
"Execute this form only if the pointer is of +foreign-pointer-type+;
otherwise call the next method."
#-clisp (declare (ignore pointer))
#+clisp
`(if (typep ,pointer +foreign-pointer-type+)
,form
(call-next-method))
#-clisp
form)
;;; Some functions in solve-minimize-fit return a pointer to a GSL
;;; vector with double-floats. This function will return a contents
;;; form suitable for make-marray. There is no choice but to copy
......@@ -251,7 +264,7 @@
;;; the mallocing, the data are not CL-accessible.
(defmethod mpointer ((object #.+foreign-pointer-class+))
(check-type object #.+foreign-pointer-type+)
#+clisp (check-type object #.+foreign-pointer-type+)
object)
(export 'order)
......
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