Commit 0c0834e1 authored by Liam Healy's avatar Liam Healy

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
;; Get/set array or elements: cl-array, maref
;; 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: $
(in-package :gsl)
(export 'maref)
;;; Normally we won't need to set or get directly from the GSL
;;; vector/matrix pointer. However, it is necessary to have access to
......@@ -31,16 +32,24 @@
(list (c-array:cl-cffi tp))))))
c-array:*array-element-types*)))
(defmethod maref
((pointer #.+foreign-pointer-class+) index &optional index2
(type 'double-float))
(if index2
(maref-function-picker
(defgeneric maref (object index &optional index2 type)
(:documentation
"An element of the data. The object may be a foreign-array object, a pointer to
a GSL vector or matrix, or an ordinary CL array of one or two dimensions.")
(: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
(:pointer pointer sizet index sizet index2))
(maref-function-picker
(maref-function-picker
type vector
(:pointer pointer sizet index))))
(:pointer pointer sizet index)))))
;;; Index the GSL function names to maref
#.(cons 'progn
......@@ -60,16 +69,25 @@
'matrix tp)))
c-array:*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)))
(defgeneric (setf maref) (value object index &optional index2 type)
(:documentation
"Set an element of the data. The object may be a foreign-array object,
a pointer to a GSL vector or matrix, or an ordinary CL array
of one or two dimensions.")
(:method (value (object marray) index &optional index2 type)
(declare (ignore type))
(if index2
(setf (grid:gref object index index2) 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)
#.(cons 'progn
......
;; Permutations
;; 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$
(in-package :gsl)
......@@ -314,7 +314,7 @@
(save-test permutation
(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
(cl-array perm-1))
(let ((perm-1 (make-permutation 4 t))) ;permutation-reverse
......
;; Get/set array or elements: cl-array, maref
;; 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)
(export '(cl-array maref))
(export '(cl-array))
;;; These functions handle the details of converting between the C
;;; representation of arrays and Common Lisp arrays. The function
......@@ -40,44 +40,16 @@
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)
(:documentation
"An element of the data. The object may be a foreign-array
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))))
(defmethod grid:gref ((object foreign-array) &rest indices)
#-native (copy-c-to-cl object)
(apply 'aref (cl-array object) indices))
;;; 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
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))))
(defmethod (setf grid:gref) (value (object foreign-array) &rest indices)
(apply '(setf aref) value (cl-array object) indices)
#-native (setf (c-invalid object) t))
;; Foreign (C or C-compatible) arrays
;; 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)
......@@ -19,7 +19,7 @@
(defgeneric (setf c-invalid) (value object) ; do nothing
(:method (value (object t)) value))
(defclass foreign-array ()
(defclass foreign-array (grid:grid)
((cl-array :initarg :cl-array :documentation "The Lisp array.")
#-native
(c-pointer :accessor c-pointer :documentation "A pointer to the C array.")
......@@ -60,7 +60,7 @@
total-size (array-total-size cl-array))
#-native
(let ((cptr (cffi:foreign-alloc
(c-array:cl-cffi (element-type object))
(cl-cffi (element-type object))
:count (total-size object))))
(setf (c-pointer object) cptr)
(tg:finalize object (lambda () (cffi:foreign-free cptr))))
......@@ -71,7 +71,7 @@
(setf original-array oa
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
"Print the contents of the foreign-array.")
......@@ -96,7 +96,7 @@
(defun element-size (object)
"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
......@@ -120,7 +120,7 @@
(total-size object))
(setf (c-invalid object) nil)))
;;; Called right before maref
;;; Called right before gref
#-native
(defun copy-c-to-cl (object)
"Copy the C array to the CL array."
......@@ -138,7 +138,7 @@
"Copy length elements from array (starting at index-offset) of type
lisp-type to the memory area that starts at pointer, coercing the
elements if necessary."
(let ((cffi-type (c-array:component-type lisp-type)))
(let ((cffi-type (component-type lisp-type)))
(loop :repeat length
for array-index :from index-offset
for pointer-index :from 0 :by (if (subtypep lisp-type 'complex) 2 1)
......@@ -156,7 +156,7 @@
"Copy length elements from array (starting at index-offset) of type
lisp-type from the memory area that starts at pointer, coercing the
elements if necessary."
(let ((cffi-type (c-array:component-type lisp-type)))
(let ((cffi-type (component-type lisp-type)))
(loop :repeat length
for pointer-index :from 0 :by (if (subtypep lisp-type 'complex) 2 1)
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
;; 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)
(pushnew :fsbv *features*))
......@@ -14,7 +14,7 @@
:version "0"
:author "Liam M. Healy"
: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
((:module grid ; temporary
:components
......@@ -27,6 +27,7 @@
:depends-on ("pkgdcl" "complex-types" "symbol-type"))
(:file "foreign-friendly" :depends-on ("pkgdcl"))
(:file "foreign-array" :depends-on ("pkgdcl" "foreign-friendly"))
(:file "methods" :depends-on ("pkgdcl"))
(:file "element-reference" :depends-on ("pkgdcl"))
(:file "copy" :depends-on ("pkgdcl"))))
(:module init
......
;; Load GSL
;; 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$
(defpackage gsll
......@@ -9,10 +9,10 @@
(:import-from
:c-array
#:cl-array #:dimensions #:total-size #:element-type #:dim0 #:dim1
#:c-pointer #:maref #:copy #:clone)
#:c-pointer #:copy #:clone)
(:export
#:cl-array #:dimensions #:total-size #:element-type #:dim0 #:dim1
#:maref #:copy #:clone))
#:copy #:clone))
(cffi:define-foreign-library libgslcblas
(:darwin
......
......@@ -8,7 +8,7 @@
(LET ((PERM-1
(MAKE-PERMUTATION
4 T)))
(MAREF PERM-1
(grid:gref PERM-1
2))))
(LISP-UNIT::ASSERT-NUMERICAL-EQUAL (LIST #(0 1 2 3))
(MULTIPLE-VALUE-LIST
......
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