From 60551931be21c486f5c89f717346869db1915bf5 Mon Sep 17 00:00:00 2001 From: Liam Healy <liam@thinkpad.local> Date: Fri, 29 Aug 2008 01:00:34 -0400 Subject: [PATCH] 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. --- data/both.lisp | 2 +- data/data.lisp | 56 +-------- data/maref.lisp | 195 ++++++++++++++++++++++++++++++ data/vector.lisp | 21 +--- gsll.asd | 8 +- histogram/updating-accessing.lisp | 4 +- init/element-types.lisp | 10 +- 7 files changed, 211 insertions(+), 85 deletions(-) create mode 100644 data/maref.lisp diff --git a/data/both.lisp b/data/both.lisp index 86c7955c..3d3da0d5 100644 --- a/data/both.lisp +++ b/data/both.lisp @@ -1,6 +1,6 @@ ;; 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) diff --git a/data/data.lisp b/data/data.lisp index 48f9cd76..284c7295 100644 --- a/data/data.lisp +++ b/data/data.lisp @@ -1,6 +1,6 @@ ;; 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 ;;;;**************************************************************************** diff --git a/data/maref.lisp b/data/maref.lisp new file mode 100644 index 00000000..9d818a14 --- /dev/null +++ b/data/maref.lisp @@ -0,0 +1,195 @@ +;; 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*))) + + + + diff --git a/data/vector.lisp b/data/vector.lisp index 2462be1e..25ec6704 100644 --- a/data/vector.lisp +++ b/data/vector.lisp @@ -1,6 +1,6 @@ ;; 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 ;;;;**************************************************************************** diff --git a/gsll.asd b/gsll.asd index 59ee6d80..b4294180 100644 --- a/gsll.asd +++ b/gsll.asd @@ -1,6 +1,6 @@ ;; 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) diff --git a/histogram/updating-accessing.lisp b/histogram/updating-accessing.lisp index bc70af48..89164933 100644 --- a/histogram/updating-accessing.lisp +++ b/histogram/updating-accessing.lisp @@ -1,6 +1,6 @@ ;; 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 diff --git a/init/element-types.lisp b/init/element-types.lisp index 0e0ab903..3c67322c 100644 --- a/init/element-types.lisp +++ b/init/element-types.lisp @@ -1,6 +1,6 @@ ;; 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*) -- GitLab