Skip to content
Snippets Groups Projects
Commit 0c0834e1 authored by Liam Healy's avatar Liam Healy
Browse files

Define foreign-array as subclass of grid:grid

Define foreign-array as subclass of grid:grid with access to elements
through grid:gref.
parent 3680b307
No related branches found
No related tags found
No related merge requests found
;; Get/set array or elements: cl-array, maref ;; Get/set array or elements: cl-array, maref
;; Liam Healy 2008-08-27 22:43:10EDT maref.lisp ;; Liam Healy 2008-08-27 22:43:10EDT maref.lisp
;; Time-stamp: <2009-12-21 09:42:47EST maref.lisp> ;; Time-stamp: <2009-12-21 14:10:40EST maref.lisp>
;; $Id: $ ;; $Id: $
(in-package :gsl) (in-package :gsl)
(export 'maref)
;;; Normally we won't need to set or get directly from the GSL ;;; Normally we won't need to set or get directly from the GSL
;;; vector/matrix pointer. However, it is necessary to have access to ;;; vector/matrix pointer. However, it is necessary to have access to
...@@ -31,16 +32,24 @@ ...@@ -31,16 +32,24 @@
(list (c-array:cl-cffi tp)))))) (list (c-array:cl-cffi tp))))))
c-array:*array-element-types*))) c-array:*array-element-types*)))
(defmethod maref (defgeneric maref (object index &optional index2 type)
((pointer #.+foreign-pointer-class+) index &optional index2 (:documentation
(type 'double-float)) "An element of the data. The object may be a foreign-array object, a pointer to
(if index2 a GSL vector or matrix, or an ordinary CL array of one or two dimensions.")
(maref-function-picker (:method ((object marray) index &optional index2 type)
(declare (ignore type))
(if index2
(grid:gref object index index2)
(grid:gref object index)))
(:method ((pointer #.+foreign-pointer-class+) index &optional index2
(type 'double-float))
(if index2
(maref-function-picker
type matrix type matrix
(:pointer pointer sizet index sizet index2)) (:pointer pointer sizet index sizet index2))
(maref-function-picker (maref-function-picker
type vector type vector
(:pointer pointer sizet index)))) (:pointer pointer sizet index)))))
;;; Index the GSL function names to maref ;;; Index the GSL function names to maref
#.(cons 'progn #.(cons 'progn
...@@ -60,16 +69,25 @@ ...@@ -60,16 +69,25 @@
'matrix tp))) 'matrix tp)))
c-array:*array-element-types*))) c-array:*array-element-types*)))
(defmethod (setf maref) (defgeneric (setf maref) (value object index &optional index2 type)
(value (pointer #.+foreign-pointer-class+) index &optional index2 (:documentation
(type 'double-float)) "Set an element of the data. The object may be a foreign-array object,
(if index2 a pointer to a GSL vector or matrix, or an ordinary CL array
(maref-function-picker of one or two dimensions.")
type matrix (:method (value (object marray) index &optional index2 type)
(:pointer pointer sizet index sizet index2) value) (declare (ignore type))
(maref-function-picker (if index2
type vector (setf (grid:gref object index index2) value)
(:pointer pointer sizet index) value))) (setf (grid:gref object index) value)))
(:method (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) ;;; Index the GSL function names to (setf maref)
#.(cons 'progn #.(cons 'progn
......
;; Permutations ;; Permutations
;; Liam Healy, Sun Mar 26 2006 - 11:51 ;; Liam Healy, Sun Mar 26 2006 - 11:51
;; Time-stamp: <2009-12-21 10:21:32EST permutation.lisp> ;; Time-stamp: <2009-12-21 14:13:53EST permutation.lisp>
;; $Id$ ;; $Id$
(in-package :gsl) (in-package :gsl)
...@@ -314,7 +314,7 @@ ...@@ -314,7 +314,7 @@
(save-test permutation (save-test permutation
(let ((perm-1 (make-permutation 4 t))) ;maref (let ((perm-1 (make-permutation 4 t))) ;maref
(maref perm-1 2)) (grid:gref perm-1 2))
(let ((perm-1 (make-permutation 4 t))) ;cl-array (let ((perm-1 (make-permutation 4 t))) ;cl-array
(cl-array perm-1)) (cl-array perm-1))
(let ((perm-1 (make-permutation 4 t))) ;permutation-reverse (let ((perm-1 (make-permutation 4 t))) ;permutation-reverse
......
;; Get/set array or elements: cl-array, maref ;; Get/set array or elements: cl-array, maref
;; Liam Healy 2009-12-21 09:40:27EST element-reference.lisp ;; Liam Healy 2009-12-21 09:40:27EST element-reference.lisp
;; Time-stamp: <2009-12-21 09:47:31EST element-reference.lisp> ;; Time-stamp: <2009-12-21 13:46:59EST element-reference.lisp>
(in-package :c-array) (in-package :c-array)
(export '(cl-array maref)) (export '(cl-array))
;;; These functions handle the details of converting between the C ;;; These functions handle the details of converting between the C
;;; representation of arrays and Common Lisp arrays. The function ;;; representation of arrays and Common Lisp arrays. The function
...@@ -40,44 +40,16 @@ ...@@ -40,44 +40,16 @@
object)) object))
;;;;**************************************************************************** ;;;;****************************************************************************
;;;; Get or set elements of the array: maref, (setf maref) ;;;; Get or set elements of the array: gref, (setf gref)
;;;;**************************************************************************** ;;;;****************************************************************************
(defgeneric maref (object index &optional index2 type) (defmethod grid:gref ((object foreign-array) &rest indices)
(:documentation #-native (copy-c-to-cl object)
"An element of the data. The object may be a foreign-array (apply 'aref (cl-array object) indices))
object or an ordinary CL array of one or two dimensions.")
(:method ((object foreign-array) index &optional index2 type)
(declare (ignore type))
#-native (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 ;;; Alternative to complete copy is to mark which elements have
;;; changed and just copy them. Is it worth it? ;;; changed and just copy them. Is it worth it?
(defgeneric (setf maref) (value object index &optional index2 type) (defmethod (setf grid:gref) (value (object foreign-array) &rest indices)
(:documentation (apply '(setf aref) value (cl-array object) indices)
"Set an element of the data. The object may be a #-native (setf (c-invalid object) t))
foreign-array object or an ordinary CL array of one or two
dimensions.")
(:method (value (object foreign-array) 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 object) 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))))
;; Foreign (C or C-compatible) arrays ;; Foreign (C or C-compatible) arrays
;; Liam Healy 2008-12-28 10:44:22EST foreign-array.lisp ;; Liam Healy 2008-12-28 10:44:22EST foreign-array.lisp
;; Time-stamp: <2009-12-21 09:04:05EST foreign-array.lisp> ;; Time-stamp: <2009-12-21 14:02:16EST foreign-array.lisp>
(in-package :c-array) (in-package :c-array)
...@@ -19,7 +19,7 @@ ...@@ -19,7 +19,7 @@
(defgeneric (setf c-invalid) (value object) ; do nothing (defgeneric (setf c-invalid) (value object) ; do nothing
(:method (value (object t)) value)) (:method (value (object t)) value))
(defclass foreign-array () (defclass foreign-array (grid:grid)
((cl-array :initarg :cl-array :documentation "The Lisp array.") ((cl-array :initarg :cl-array :documentation "The Lisp array.")
#-native #-native
(c-pointer :accessor c-pointer :documentation "A pointer to the C array.") (c-pointer :accessor c-pointer :documentation "A pointer to the C array.")
...@@ -60,7 +60,7 @@ ...@@ -60,7 +60,7 @@
total-size (array-total-size cl-array)) total-size (array-total-size cl-array))
#-native #-native
(let ((cptr (cffi:foreign-alloc (let ((cptr (cffi:foreign-alloc
(c-array:cl-cffi (element-type object)) (cl-cffi (element-type object))
:count (total-size object)))) :count (total-size object))))
(setf (c-pointer object) cptr) (setf (c-pointer object) cptr)
(tg:finalize object (lambda () (cffi:foreign-free cptr)))) (tg:finalize object (lambda () (cffi:foreign-free cptr))))
...@@ -71,7 +71,7 @@ ...@@ -71,7 +71,7 @@
(setf original-array oa (setf original-array oa
offset offset
(* index-offset (* index-offset
(cffi:foreign-type-size (c-array:cl-cffi (element-type object)))))))) (cffi:foreign-type-size (cl-cffi (element-type object))))))))
(defparameter *print-contents* t (defparameter *print-contents* t
"Print the contents of the foreign-array.") "Print the contents of the foreign-array.")
...@@ -96,7 +96,7 @@ ...@@ -96,7 +96,7 @@
(defun element-size (object) (defun element-size (object)
"The size of each element as stored in C." "The size of each element as stored in C."
(cffi:foreign-type-size (c-array:cl-cffi (element-type object)))) (cffi:foreign-type-size (cl-cffi (element-type object))))
;;;;**************************************************************************** ;;;;****************************************************************************
;;;; Syncronize C and CL ;;;; Syncronize C and CL
...@@ -120,7 +120,7 @@ ...@@ -120,7 +120,7 @@
(total-size object)) (total-size object))
(setf (c-invalid object) nil))) (setf (c-invalid object) nil)))
;;; Called right before maref ;;; Called right before gref
#-native #-native
(defun copy-c-to-cl (object) (defun copy-c-to-cl (object)
"Copy the C array to the CL array." "Copy the C array to the CL array."
...@@ -138,7 +138,7 @@ ...@@ -138,7 +138,7 @@
"Copy length elements from array (starting at index-offset) of type "Copy length elements from array (starting at index-offset) of type
lisp-type to the memory area that starts at pointer, coercing the lisp-type to the memory area that starts at pointer, coercing the
elements if necessary." elements if necessary."
(let ((cffi-type (c-array:component-type lisp-type))) (let ((cffi-type (component-type lisp-type)))
(loop :repeat length (loop :repeat length
for array-index :from index-offset for array-index :from index-offset
for pointer-index :from 0 :by (if (subtypep lisp-type 'complex) 2 1) for pointer-index :from 0 :by (if (subtypep lisp-type 'complex) 2 1)
...@@ -156,7 +156,7 @@ ...@@ -156,7 +156,7 @@
"Copy length elements from array (starting at index-offset) of type "Copy length elements from array (starting at index-offset) of type
lisp-type from the memory area that starts at pointer, coercing the lisp-type from the memory area that starts at pointer, coercing the
elements if necessary." elements if necessary."
(let ((cffi-type (c-array:component-type lisp-type))) (let ((cffi-type (component-type lisp-type)))
(loop :repeat length (loop :repeat length
for pointer-index :from 0 :by (if (subtypep lisp-type 'complex) 2 1) for pointer-index :from 0 :by (if (subtypep lisp-type 'complex) 2 1)
for array-index :from index-offset for array-index :from index-offset
......
;; Methods for grid functions
;; Liam Healy 2009-12-21 11:19:00EST methods.lisp
;; Time-stamp: <2009-12-21 13:48:59EST methods.lisp>
(in-package :c-array)
(defmethod grid:grid-rank ((object foreign-array))
(length (dimensions object)))
(defmethod grid:grid-dimensions ((object foreign-array))
(dimensions object))
(defmethod grid:make-grid-data
((type (eql 'foreign-array)) dimensions rest-spec
&key (initial-element nil initial-element-p))
;; Nothing to do here, because the data is inserted in
;; initialize-instance :after for foreign-array.
nil)
;; Definition of GSLL system ;; Definition of GSLL system
;; Liam Healy ;; Liam Healy
;; Time-stamp: <2009-12-21 10:22:26EST gsll.asd> ;; Time-stamp: <2009-12-21 14:16:54EST gsll.asd>
(when (asdf:find-system :fsbv nil) (when (asdf:find-system :fsbv nil)
(pushnew :fsbv *features*)) (pushnew :fsbv *features*))
...@@ -14,7 +14,7 @@ ...@@ -14,7 +14,7 @@
:version "0" :version "0"
:author "Liam M. Healy" :author "Liam M. Healy"
:licence "LLGPL v3, FDL" :licence "LLGPL v3, FDL"
:depends-on (cffi cffi-grovel trivial-garbage cl-utilities #+fsbv fsbv) :depends-on (grid cffi cffi-grovel trivial-garbage cl-utilities #+fsbv fsbv)
:components :components
((:module grid ; temporary ((:module grid ; temporary
:components :components
...@@ -27,6 +27,7 @@ ...@@ -27,6 +27,7 @@
:depends-on ("pkgdcl" "complex-types" "symbol-type")) :depends-on ("pkgdcl" "complex-types" "symbol-type"))
(:file "foreign-friendly" :depends-on ("pkgdcl")) (:file "foreign-friendly" :depends-on ("pkgdcl"))
(:file "foreign-array" :depends-on ("pkgdcl" "foreign-friendly")) (:file "foreign-array" :depends-on ("pkgdcl" "foreign-friendly"))
(:file "methods" :depends-on ("pkgdcl"))
(:file "element-reference" :depends-on ("pkgdcl")) (:file "element-reference" :depends-on ("pkgdcl"))
(:file "copy" :depends-on ("pkgdcl")))) (:file "copy" :depends-on ("pkgdcl"))))
(:module init (:module init
......
;; Load GSL ;; Load GSL
;; Liam Healy Sat Mar 4 2006 - 18:53 ;; Liam Healy Sat Mar 4 2006 - 18:53
;; Time-stamp: <2009-12-21 10:45:40EST init.lisp> ;; Time-stamp: <2009-12-21 13:58:51EST init.lisp>
;; $Id$ ;; $Id$
(defpackage gsll (defpackage gsll
...@@ -9,10 +9,10 @@ ...@@ -9,10 +9,10 @@
(:import-from (:import-from
:c-array :c-array
#:cl-array #:dimensions #:total-size #:element-type #:dim0 #:dim1 #:cl-array #:dimensions #:total-size #:element-type #:dim0 #:dim1
#:c-pointer #:maref #:copy #:clone) #:c-pointer #:copy #:clone)
(:export (:export
#:cl-array #:dimensions #:total-size #:element-type #:dim0 #:dim1 #:cl-array #:dimensions #:total-size #:element-type #:dim0 #:dim1
#:maref #:copy #:clone)) #:copy #:clone))
(cffi:define-foreign-library libgslcblas (cffi:define-foreign-library libgslcblas
(:darwin (:darwin
......
...@@ -8,7 +8,7 @@ ...@@ -8,7 +8,7 @@
(LET ((PERM-1 (LET ((PERM-1
(MAKE-PERMUTATION (MAKE-PERMUTATION
4 T))) 4 T)))
(MAREF PERM-1 (grid:gref PERM-1
2)))) 2))))
(LISP-UNIT::ASSERT-NUMERICAL-EQUAL (LIST #(0 1 2 3)) (LISP-UNIT::ASSERT-NUMERICAL-EQUAL (LIST #(0 1 2 3))
(MULTIPLE-VALUE-LIST (MULTIPLE-VALUE-LIST
......
0% Loading or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment