Commit 60551931 authored by Liam Healy's avatar Liam Healy

Complete #'maref and #'cl-array generic functions

Put maref and cl-array into a new file maref.lisp, each one has three
methods (gsl-data, CL array, GSL pointer).  The pointer method for
maref selects over all possible element types.  This compiles but is
not tested.
parent 9bf385d1
;; Functions for both vectors and matrices.
;; Liam Healy 2008-04-26 20:48:44EDT both.lisp
;; Time-stamp: <2008-08-17 16:18:46EDT both.lisp>
;; Time-stamp: <2008-08-28 21:41:15EDT both.lisp>
;; $Id$
(in-package :gsl)
......
;; Data using ffa
;; Liam Healy 2008-04-06 21:23:41EDT data-ffa.lisp
;; Time-stamp: <2008-08-23 23:09:12EDT data.lisp>
;; Time-stamp: <2008-08-28 21:31:49EDT data.lisp>
;; $Id$
(in-package :gsl)
......@@ -10,7 +10,7 @@
;;;;****************************************************************************
(defclass gsl-data ()
((cl-array :initarg :cl-array :accessor cl-array :documentation "The Lisp array.")
((cl-array :initarg :cl-array :documentation "The Lisp array.")
(mpointer :initarg :mpointer :accessor mpointer
:documentation "A pointer to the GSL representation of the data.")
(block-pointer :initform nil :accessor block-pointer
......@@ -41,7 +41,7 @@
"A superclass for all data storage structures, such as vector, matrix,
etc."))
(export '(cl-array dimensions total-size element-type))
(export '(dimensions total-size element-type))
(defmethod print-object ((object gsl-data) stream)
(print-unreadable-object (object stream :type t)
......@@ -129,12 +129,6 @@
(make-data-from-array type array-or-dimensions)
(make-data-from-dimensions type array-or-dimensions))))
;;; ... or from the pointer which was malloced by GSL
#(or)
(defun make-data-from-pointer (pointer &optional (class 'vector-double-float) size)
"Given a C pointer to a GSL data type, make the CL object."
)
;;;;****************************************************************************
;;;; Expand letm bindings
;;;;****************************************************************************
......@@ -286,50 +280,6 @@
(cffi:mem-aref pointer cffi-type pointer-index)
(cffi:mem-aref pointer cffi-type (1+ pointer-index)))))))
(defgeneric maref (object index &optional index2)
(:documentation "An element of the data.")
(:method ((object gsl-data) index &optional index2)
(copy-c-to-cl object)
(if index2
(aref (cl-array object) index index2)
(aref (cl-array object) index))))
;;; Alternative to complete copy is to mark which elements have
;;; changed and just copy them. Is it worth it?
(defgeneric (setf maref) (value object index &optional index2)
(:documentation "Set an element of the data.")
(:method (value (object gsl-data) index &optional index2)
(if index2
(setf (aref (cl-array object) index index2) value)
(setf (aref (cl-array object) index) value))
#-native
(setf c-invalid t)))
;;; It is necessary to have access to elements from the GSL
;;; vector/matrix pointers for things like callback functions in
;;; solve-minimize-fit and in #'cl-array method for pointers.
(defmfun maref ((pointer #.+foreign-pointer-class+) index &optional index2)
;; If passed a pointer, assume that it is a GSL vector or matrix,
;; depending on the number of indices. This is useful in the
;; callback functions for solve-minimize-fit.
("gsl_vector_get" "gsl_matrix_get")
(((pointer :pointer) (index sizet))
((pointer :pointer) (index sizet) (index2 sizet)))
:definition :method
:c-return :double)
(defmfun (setf maref)
(value (pointer #.+foreign-pointer-class+) index &optional index2)
;; If passed a pointer, assume that it is a GSL vector or matrix,
;; depending on the number of indices. This is useful in the
;; callback functions for solve-minimize-fit.
("gsl_vector_set" "gsl_matrix_set")
(((pointer :pointer) (index sizet) (value :double))
((pointer :pointer) (index sizet) (index2 sizet) (value :double)))
:definition :method
:c-return :double)
;;;;****************************************************************************
;;;; C structures
;;;;****************************************************************************
......
;; Get/set array or elements: cl-array, maref
;; Liam Healy 2008-08-27 22:43:10EDT maref.lisp
;; Time-stamp: <2008-08-28 21:51:18EDT maref.lisp>
;; $Id: $
(in-package :gsl)
(export '(cl-array maref))
;;; These functions handle the details of converting between the GSL
;;; representation of arrays and Common Lisp arrays. The function
;;; #'maref can be treated like #'aref for reading and setting
;;; elements, except that it is limited to two indices (vectors or
;;; matrices only) and requires a final argument with the element
;;; type when taking a GSL pointer as the first argument (only needed
;;; in the case of solve-minimize-fit for callbacks and some return
;;; values).
;;; Both these functions take one of the following class arguments for
;;; the array:
;;; - a gsl-data
;;; - a Common Lisp array
;;; - a pointer to a GSL vector or matrix structure
;;;;****************************************************************************
;;;; Get the entire array: cl-array
;;;;****************************************************************************
(defgeneric cl-array (object &optional array-rank element-type)
(:documentation
"The array as a CL native array. The object may be a gsl-data object,
a pointer to a GSL vector or matrix, or an ordinary CL array of one
or two dimensions. Optional arguments array-rank and element-type
are used only for pointers.")
(:method ((object gsl-data) &optional array-rank element-type)
(declare (ignore array-rank element-type))
(copy-c-to-cl object)
(slot-value object 'cl-array))
(:method ((object array) &optional array-rank element-type)
;; For compatibility, work on CL arrays as well.
(declare (ignore array-rank element-type))
array))
;;; Some functions in solve-minimize-fit return a pointer to a GSL
;;; vector with double-floats. #'cl-array will 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.
(defmethod cl-array ((pointer #.+foreign-pointer-class+)
&optional (array-rank 1) (element-type 'double-float))
(if (= array-rank 2)
;; Matrix
(let* ((dim1 (cffi:foreign-slot-value pointer 'gsl-matrix-c 'size1))
(dim2 (cffi:foreign-slot-value pointer 'gsl-matrix-c 'size2))
(array (make-array* (list dim1 dim2) element-type)))
;; Copy over from the C side
(loop for i below size1
do (loop for j below size2 do
(setf (aref array i j) (maref pointer i j))))
array)
;; Vector
(let* ((size (cffi:foreign-slot-value pointer 'gsl-vector-c 'size))
(array (make-array* size element-type)))
;; Copy over from the C side
(loop for i below size
do (setf (aref array i) (maref pointer i)))
array)))
;;;;****************************************************************************
;;;; Get or set elements of the array: maref, (setf maref)
;;;;****************************************************************************
(defgeneric maref (object index &optional index2 type)
(:documentation
"An element of the data. The object may be a gsl-data object, a pointer to
a GSL vector or matrix, or an ordinary CL array of one or two dimensions.")
(:method ((object gsl-data) index &optional index2 type)
(declare (ignore type))
(copy-c-to-cl object)
(if index2
(aref (cl-array object) index index2)
(aref (cl-array object) index)))
(:method ((object array) index &optional index2 type)
;; For compatibility, work on CL arrays as well.
(declare (ignore type))
(if index2
(aref object index index2)
(aref object index))))
;;; Alternative to complete copy is to mark which elements have
;;; changed and just copy them. Is it worth it?
(defgeneric (setf maref) (value object index &optional index2 type)
(:documentation
"Set an element of the data. The object may be a gsl-data object,
a pointer to a GSL vector or matrix, or an ordinary CL array
of one or two dimensions.")
(:method (value (object gsl-data) index &optional index2 type)
(declare (ignore type))
(if index2
(setf (aref (slot-value object 'cl-array) index index2) value)
(setf (aref (slot-value object 'cl-array) index) value))
#-native
(setf c-invalid t))
(:method (value (object array) index &optional index2 type)
;; For compatibility, work on CL arrays as well.
(declare (ignore type))
(if index2
(setf (aref object index index2) value)
(setf (aref object index) value))))
;;; Normally we won't need to set or get directly from the GSL
;;; vector/matrix pointer. However, it is necessary to have access to
;;; elements from the GSL vector/matrix pointers for things like
;;; callback functions in solve-minimize-fit and in #'cl-array method
;;; for pointers.
(eval-when (:compile-toplevel :load-toplevel)
(defun maref-function-picker (type-symbol category ffrestargs &optional value-symbol)
"Generate sexp to select on the various gsl_{vector,matrix}*_{get,set} functions."
(cons 'cond
(mapcar (lambda (tp)
`((equal ,type-symbol ',tp)
(cffi:foreign-funcall
,(actual-gsl-function-name
`("gsl_" :category :type ,(if value-symbol "_set" "_get"))
category tp)
,@ffrestargs
,@(if value-symbol
(list (cl-ffa tp) value-symbol)
(list (cl-ffa tp))))))
*array-element-types*))))
(defmethod maref
((pointer #.+foreign-pointer-class+) index &optional index2
(type 'double-float))
(if index2
#.(maref-function-picker
'type 'matrix
'(:pointer pointer sizet index sizet index2))
#.(maref-function-picker
'type 'vector
'(:pointer pointer sizet index))))
;;; Index the GSL function names to maref
#.(cons 'progn
(append
(mapcar (lambda (tp)
`(map-name
'maref
,(actual-gsl-function-name
`("gsl_" :category :type ,"_get")
'vector tp)))
*array-element-types*)
(mapcar (lambda (tp)
`(map-name
'maref
,(actual-gsl-function-name
`("gsl_" :category :type ,"_get")
'matrix tp)))
*array-element-types*)))
(defmethod (setf maref)
(value (pointer #.+foreign-pointer-class+) index &optional index2
(type 'double-float))
(if index2
#.(maref-function-picker
'type 'matrix
'(:pointer pointer sizet index sizet index2) 'value)
#.(maref-function-picker
'type 'vector
'(:pointer pointer sizet index) 'value)))
;;; Index the GSL function names to (setf maref)
#.(cons 'progn
(append
(mapcar (lambda (tp)
`(map-name
'(setf maref)
,(actual-gsl-function-name
`("gsl_" :category :type ,"_set")
'vector tp)))
*array-element-types*)
(mapcar (lambda (tp)
`(map-name
'(setf maref)
,(actual-gsl-function-name
`("gsl_" :category :type ,"_set")
'matrix tp)))
*array-element-types*)))
;; Vectors
;; Liam Healy 2008-04-13 09:39:02EDT vector-ffa.lisp
;; Time-stamp: <2008-08-23 22:54:06EDT vector.lisp>
;; Time-stamp: <2008-08-28 21:41:15EDT vector.lisp>
;; $Id$
(in-package :gsl)
......@@ -26,25 +26,6 @@
(defun make-vector-from-pointer ())
;;;;****************************************************************************
;;;; Make from GSL vector
;;;;****************************************************************************
;;; Some functions in solve-minimize-fit return a pointer to a GSL
;;; vector with double-floats. The functions here turn that into a
;;; foreign-friendly array. There is no choice but to copy over the
;;; data; because GSL is doing the mallocing, the data are not
;;; CL-accessible.
(defmethod cl-array ((pointer #.+foreign-pointer-class+))
"Given a C pointer to a GSL vector, make the CL object."
(let* ((size (cffi:foreign-slot-value pointer 'gsl-vector-c 'size))
(array (make-array* size 'double-float)))
;; Copy over from the C side
(loop for i below size
do (setf (aref array i) (maref pointer i)))
array))
;;;;****************************************************************************
;;;; Function definitions
;;;;****************************************************************************
......
;; Definition of GSLL system
;; Liam Healy
;; Time-stamp: <2008-08-23 19:39:32EDT gsll.asd>
;; Time-stamp: <2008-08-29 00:57:28EDT gsll.asd>
;; $Id$
(asdf:defsystem "gsll"
......@@ -37,11 +37,11 @@
(:file "data")
(:file "vector" :depends-on (data))
(:file "matrix" :depends-on (data vector))
(:file "maref" :depends-on (data vector matrix))
(:file "both" :depends-on (data vector matrix))
(:file "permutation" :depends-on (data))
(:file "combination"
:depends-on (data matrix both permutation)) ; preload defgeneric
))
(:file "combination" ; preload defgeneric
:depends-on (data matrix both permutation))))
(:file "polynomial" :depends-on (init data))
(:module special-functions
:depends-on (init)
......
;; Updating and accessing histogram elements.
;; Liam Healy, Mon Jan 1 2007 - 14:43
;; Time-stamp: <2008-08-23 19:08:14EDT updating-accessing.lisp>
;; Time-stamp: <2008-08-28 21:54:43EDT updating-accessing.lisp>
;; $Id$
(in-package :gsl)
......@@ -24,7 +24,7 @@
histograms for a small range of a larger dataset, ignoring the values
outside the range of interest.")
(defmfun maref ((histogram histogram) i &optional i2)
(defmfun maref ((histogram histogram) i &optional i2 element-type)
"gsl_histogram_get"
(((mpointer histogram) :pointer) ((first i) sizet))
:definition :method
......
;; Mapping of element type names
;; Liam Healy 2008-04-13 11:22:46EDT element-types.lisp
;; Time-stamp: <2008-08-10 22:17:19EDT element-types.lisp>
;; Time-stamp: <2008-08-27 20:57:18EDT element-types.lisp>
;; $Id$
;;; The different element type forms:
......@@ -79,6 +79,7 @@
;;; Used by #'cl-gsl
(defparameter *cstd-cl-type-mapping*
(append
*fp-type-mapping*
(mapcar
(lambda (type)
(cons
......@@ -88,8 +89,7 @@
'unsigned-byte
'signed-byte)
(* 8 (cffi:foreign-type-size type)))))
*cstd-integer-types*)
*fp-type-mapping*)
*cstd-integer-types*))
;; Be careful when reverse associating, as there may be several C
;; types that map to a single CL type.
"An alist of the C standard types as keywords, and the CL type
......@@ -289,11 +289,11 @@
(defparameter *float-complex-types*
(remove-if (lambda (tp) (subtypep tp 'integer)) *array-element-types*)
"All the array element types supported except for complex types.")
"All the float or complex array element types supported.")
(defparameter *float-types*
(remove-if-not (lambda (tp) (subtypep tp 'float)) *array-element-types*)
"All the array element types supported except for complex types.")
"All the float array element types.")
(defparameter *complex-types*
(remove-if-not (lambda (tp) (subtypep tp 'complex)) *array-element-types*)
......
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