Commit 7b6dea21 authored by Liam Healy's avatar Liam Healy
Browse files

Use slot 'grid:data instead of superfluous slot 'cl-array

The grid definitions supply the slot 'grid:data which can be used for
CL array storage for marrays.  In order for a combination of zero
dimension (k) to be made, there is an ignore-errors around the
make-affi in initialize-instance :after for foreign-array.
parent 0c0834e1
;; Get/set array or elements: cl-array, maref
;; Liam Healy 2009-12-21 09:40:27EST element-reference.lisp
;; Time-stamp: <2009-12-21 13:46:59EST element-reference.lisp>
;; Time-stamp: <2009-12-21 15:55:44EST element-reference.lisp>
(in-package :c-array)
......@@ -33,7 +33,7 @@
(:method ((object foreign-array) &optional array-rank element-type)
(declare (ignore array-rank element-type))
#-native (copy-c-to-cl object)
(slot-value object 'cl-array))
(slot-value object 'grid:data))
(:method ((object array) &optional array-rank element-type)
;; For compatibility, work on CL arrays as well.
(declare (ignore array-rank element-type))
......@@ -45,11 +45,11 @@
(defmethod grid:gref ((object foreign-array) &rest indices)
#-native (copy-c-to-cl object)
(apply 'aref (cl-array object) indices))
(apply 'aref (grid:grid-data object) indices))
;;; Alternative to complete copy is to mark which elements have
;;; changed and just copy them. Is it worth it?
(defmethod (setf grid:gref) (value (object foreign-array) &rest indices)
(apply '(setf aref) value (cl-array object) indices)
(apply '(setf aref) value (grid:grid-data 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 14:02:16EST foreign-array.lisp>
;; Time-stamp: <2009-12-21 19:04:46EST foreign-array.lisp>
(in-package :c-array)
......@@ -8,8 +8,8 @@
;;;; Object and methods
;;;;****************************************************************************
(export
'(foreign-array cl-array dimensions total-size element-type element-size))
(export '(foreign-array dimensions total-size element-type element-size
*print-contents*))
#-native
(defgeneric (setf cl-invalid) (value object) ; do nothing
......@@ -20,8 +20,7 @@
(:method (value (object t)) value))
(defclass foreign-array (grid:grid)
((cl-array :initarg :cl-array :documentation "The Lisp array.")
#-native
(#-native
(c-pointer :accessor c-pointer :documentation "A pointer to the C array.")
(dimensions :reader dimensions)
(total-size :reader total-size)
......@@ -53,11 +52,17 @@
((object foreign-array) &rest initargs
&key dimensions initial-contents initial-element)
(declare (ignore dimensions #+native initial-contents #+native initial-element))
(with-slots (cl-array dimensions original-array offset total-size) object
(unless (and (slot-boundp object 'cl-array) cl-array)
(setf cl-array (apply #'make-ffa (element-type object) initargs)))
(setf dimensions (array-dimensions cl-array)
total-size (array-total-size cl-array))
(with-slots (grid:rank grid:affi grid:specification grid:data
dimensions original-array offset total-size)
object
(unless (and (slot-boundp object 'grid:data) grid:data)
(setf grid:data (apply #'make-ffa (element-type object) initargs)))
(setf dimensions (array-dimensions grid:data)
total-size (array-total-size grid:data)
grid:rank (length dimensions)
grid:specification
(list (cons (class-of object) dimensions) (element-type object))
grid:affi (ignore-errors (affi:make-affi dimensions)))
#-native
(let ((cptr (cffi:foreign-alloc
(cl-cffi (element-type object))
......@@ -67,7 +72,7 @@
#-native
(setf (cl-invalid object) (not (or initial-contents initial-element)))
(multiple-value-bind (oa index-offset)
(find-original-array (cl-array object))
(find-original-array grid:data)
(setf original-array oa
offset
(* index-offset
......@@ -81,7 +86,7 @@
(if *print-contents*
(progn
#-native (copy-c-to-cl object)
(princ (cl-array object) stream))
(princ (grid:grid-data object) stream))
(format stream "dimensions ~a" (dimensions object)))))
(export '(dim0 dim1))
......@@ -113,7 +118,7 @@
"Copy the CL array to the C array."
(when (and (typep object 'mobject) (c-invalid object))
(copy-array-to-pointer
(slot-value object 'cl-array)
(slot-value object 'grid:data)
(c-pointer object)
(element-type object)
0
......@@ -126,7 +131,7 @@
"Copy the C array to the CL array."
(when (and (typep object 'mobject) (cl-invalid object))
(copy-array-from-pointer
(slot-value object 'cl-array)
(slot-value object 'grid:data)
(c-pointer object)
(element-type object)
0
......
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