From e5d0cfa7ae42310923f8ea71c0f86172e258d0e0 Mon Sep 17 00:00:00 2001
From: Liam Healy <liam@thinkpad.local>
Date: Sun, 27 Jun 2010 22:05:10 -0400
Subject: [PATCH] Reorder block allocation, replace marray class

Set the contents of the block structure before using it in
alloc-from-block.  Replace the 'marray class with 'foreign-array.
Quote foreign struct slots.  Eliminate copy methods.  Now simple
operations like 'vector-reverse work.
---
 data/both.lisp          | 15 ++++++-----
 data/foreign-array.lisp | 58 ++++++++++++++++++++---------------------
 data/matrix.lisp        | 12 +--------
 data/vector.lisp        | 10 +------
 gsll.asd                | 22 ++++++++--------
 init/defmfun-array.lisp |  4 +--
 init/init.lisp          |  5 ++--
 7 files changed, 55 insertions(+), 71 deletions(-)

diff --git a/data/both.lisp b/data/both.lisp
index 49133350..72b50ee7 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: <2010-06-27 18:03:26EDT both.lisp>
+;; Time-stamp: <2010-06-27 21:31:00EDT both.lisp>
 ;;
 ;; Copyright 2008, 2009 Liam M. Healy
 ;; Distributed under the terms of the GNU General Public License
@@ -28,7 +28,7 @@
   ("gsl_" :category :type "_alloc_from_block")
   ((blockptr :pointer)
    (0 sizet)				; offset
-   ((size object) sizet)			; number of elements
+   ((total-size object) sizet)		; number of elements
    (1 sizet))				; stride
   :definition :generic
   :c-return :pointer
@@ -68,6 +68,8 @@
   :c-return :void
   :documentation "Set all elements to 0.")
 
+#|
+;;; These will be handled by grid functions/CFFI; do we need to use GSL's routines? 
 (defmfun grid:copy-to-destination
     ((source both) (destination both))
   ("gsl_" :category :type "_memcpy")
@@ -86,6 +88,7 @@
   :inputs (source)
   :outputs (destination)
   :return (destination))
+|#
 
 (defmfun swap ((a both) (b both))
   ("gsl_" :category :type "_swap")
@@ -175,7 +178,7 @@
   :documentation			; FDL
   "Add the scalar complex x to all the elements of array a.")
 
-(defmethod elt+ ((x float) (a marray))
+(defmethod elt+ ((x float) (a foreign-array))
   (elt+ a x))
   
 (defmfun elt- ((a both) (b both))
@@ -190,7 +193,7 @@
   "Subtract the elements of b from the elements of a.
    The two must have the same dimensions.")
 
-(defmethod elt- ((a marray) (x float))
+(defmethod elt- ((a foreign-array) (x float))
   (elt+ a (- x)))
 
 (defmfun elt* ((a vector) (b vector))
@@ -235,7 +238,7 @@
   :outputs (a)
   :return (a))
 
-(defmethod elt/ ((a marray) (x number))
+(defmethod elt/ ((a foreign-array) (x number))
   (elt* a (/ x)))
 
 (defmfun elt* ((a both) (x float))
@@ -262,7 +265,7 @@
   :documentation			; FDL
   "Multiply the elements of a by the scalar complex factor x.")
 
-(defmethod elt* ((x float) (a marray))
+(defmethod elt* ((x float) (a foreign-array))
   (elt* a x))
 
 ;;;;****************************************************************************
diff --git a/data/foreign-array.lisp b/data/foreign-array.lisp
index 55b4eb4b..e6e494f7 100644
--- a/data/foreign-array.lisp
+++ b/data/foreign-array.lisp
@@ -1,6 +1,6 @@
 ;; A grid:foreign-array with added metadata for GSL.
 ;; Liam Healy 2008-04-06 21:23:41EDT
-;; Time-stamp: <2010-06-27 18:27:37EDT foreign-array.lisp>
+;; Time-stamp: <2010-06-27 21:49:36EDT foreign-array.lisp>
 ;;
 ;; Copyright 2008, 2009 Liam M. Healy
 ;; Distributed under the terms of the GNU General Public License
@@ -32,7 +32,7 @@
 ;;; GSL free functions because they would free the C array data.
 
 (defmacro metadata-slot (object name)
-  `(getf (foreign-metadata ,object) ,name))
+  `(getf (slot-value ,object 'grid:foreign-metadata) ,name))
 
 (defun make-gsl-metadata (object)
   "Make the necessary GSL metadata (mpointer and block-pointer)
@@ -43,26 +43,26 @@
   (unless (metadata-slot object 'mpointer)
     (when (zerop (total-size object))
       (error "Object ~a has zero total dimension." object))
-    (let* ((blockptr (cffi:foreign-alloc 'gsl-block-c)) ; check this result
-	   ;; it is not clear what foreign-alloc does if the alloc fails.
-	   (array-struct (alloc-from-block object blockptr)))
+    (let ((blockptr (cffi:foreign-alloc 'gsl-block-c)))
       (setf (cffi:foreign-slot-value blockptr 'gsl-block-c 'size)
 	    (grid:total-size object)
 	    (cffi:foreign-slot-value blockptr 'gsl-block-c 'data)
 	    (foreign-pointer object)
-	    (metadata-slot object 'block-pointer) blockptr
-	    (metadata-slot object 'mpointer) array-struct
-	    ;; alloc-from-block automatically copies over the data pointer
-	    ;; from the block to the vector/matrix; we must do that manually here
-	    (cffi:foreign-slot-value
-	     array-struct
-	     (if (typep object 'matrix) 'gsl-matrix-c 'gsl-vector-c) 'data)
-	    (foreign-pointer object))
-      (tg:finalize object
-		   (lambda ()
-		     (cffi:foreign-free blockptr)
-		     (cffi:foreign-free array-struct))))
-    (metadata-slot object 'mpointer)))
+	    (metadata-slot object 'block-pointer) blockptr)
+      (let ((array-struct (alloc-from-block object blockptr)))
+	(setf
+	 (metadata-slot object 'mpointer) array-struct
+	 ;; alloc-from-block automatically copies over the data pointer
+	 ;; from the block to the vector/matrix; we must do that manually here
+	 (cffi:foreign-slot-value
+	  array-struct
+	  (if (typep object 'matrix) 'gsl-matrix-c 'gsl-vector-c) 'data)
+	 (foreign-pointer object))
+	(tg:finalize object
+		     (lambda ()
+		       (cffi:foreign-free blockptr)
+		       (cffi:foreign-free array-struct))))
+      (metadata-slot object 'mpointer))))
 
 (defmethod mpointer ((object grid:foreign-array))
   (or 
@@ -76,17 +76,15 @@
 ;;;;;;; There are >1400 calls to make-marray, write an emulation?
 ;;; This should probably be moved/renamed grid:make-foreign-array.
 (export 'make-marray)
-(defun make-marray
-    (element-type &rest keys &key dimensions initial-contents
-     &allow-other-keys)
+(defun make-marray (element-type &rest keys &key dimensions &allow-other-keys)
   "Make a GSLL array with the given element type,
    :dimensions, and :initial-contents, :initial-element or :data."
   (when (subtypep element-type 'grid:foreign-array)
-    (error "Can't take a class name here anymore, sorry.")
-    (apply
-     'grid:make-grid
-     `((grid:foreign-array ,@dimensions) element-type)
-     keys)))
+    (error "Can't take a class name here anymore, sorry."))
+  (apply
+   'grid:make-grid
+   `((grid:foreign-array ,@dimensions) element-type)
+   keys))
 
 (defun make-marray-or-default
     (default dimensions
@@ -122,12 +120,12 @@
     (grid:make-grid
      (case category
        (:vector
-	`((foreign-array ,(cffi:foreign-slot-value mpointer cstruct size))
+	`((foreign-array ,(cffi:foreign-slot-value mpointer cstruct 'size))
 	  ,element-type))
        (:matrix
 	`((foreign-array
-	   ,(cffi:foreign-slot-value mpointer cstruct size0)
-	   ,(cffi:foreign-slot-value mpointer cstruct size1)))
-	,element-type))
+	   ,(cffi:foreign-slot-value mpointer cstruct 'size0)
+	   ,(cffi:foreign-slot-value mpointer cstruct 'size1))
+	  ,element-type)))
      :foreign-pointer foreign-pointer
      :foreign-metadata mpointer)))
diff --git a/data/matrix.lisp b/data/matrix.lisp
index fee58c4c..e1d59ea2 100644
--- a/data/matrix.lisp
+++ b/data/matrix.lisp
@@ -1,6 +1,6 @@
 ;; Matrices
 ;; Liam Healy 2008-04-15 21:57:52EDT matrix.lisp
-;; Time-stamp: <2010-06-27 18:03:26EDT matrix.lisp>
+;; Time-stamp: <2010-06-27 21:27:22EDT matrix.lisp>
 ;;
 ;; Copyright 2008, 2009 Liam M. Healy
 ;; Distributed under the terms of the GNU General Public License
@@ -36,16 +36,6 @@
        collect (loop for j below dim1
 		  collect (maref pointer i j element-type)))))
 
-(defmethod grid:copy-to-destination
-    ((object matrix) (pointer #.+foreign-pointer-class+))
-  (foreign-pointer-method
-   pointer
-   (loop for i below (dim0 object)
-      do (loop for j below (dim1 object)
-	    do
-	    (setf (maref pointer i j (element-type object))
-		  (maref object i j))))))
-
 ;;;;****************************************************************************
 ;;;; Mathematical
 ;;;;****************************************************************************
diff --git a/data/vector.lisp b/data/vector.lisp
index d37fe787..18b7ebb2 100644
--- a/data/vector.lisp
+++ b/data/vector.lisp
@@ -1,6 +1,6 @@
 ;; Vectors
 ;; Liam Healy 2008-04-13 09:39:02EDT vector.lisp
-;; Time-stamp: <2010-06-27 18:03:25EDT vector.lisp>
+;; Time-stamp: <2010-06-27 21:09:42EDT vector.lisp>
 ;;
 ;; Copyright 2008, 2009 Liam M. Healy
 ;; Distributed under the terms of the GNU General Public License
@@ -32,14 +32,6 @@
   (loop for i below (cffi:foreign-slot-value pointer struct-type 'size)
      collect (maref pointer i nil element-type)))
 
-(defmethod grid:copy-to-destination
-    ((object mvector) (pointer #.+foreign-pointer-class+))
-  (foreign-pointer-method
-   pointer
-   (loop for i below (dim0 object)
-      do (setf (maref pointer i nil (element-type object))
-	       (maref object i)))))
-
 ;;;;****************************************************************************
 ;;;; Function definitions
 ;;;;****************************************************************************
diff --git a/gsll.asd b/gsll.asd
index 13f47de5..9d72962f 100644
--- a/gsll.asd
+++ b/gsll.asd
@@ -1,6 +1,6 @@
 ;; Definition of GSLL system 
 ;; Liam Healy
-;; Time-stamp: <2010-06-27 17:57:19EDT gsll.asd>
+;; Time-stamp: <2010-06-27 21:22:11EDT gsll.asd>
 ;;
 ;; Copyright 2006, 2007, 2008, 2009 Liam M. Healy
 ;; Distributed under the terms of the GNU General Public License
@@ -70,20 +70,20 @@
 	    ((:file "mathematical")
 	     #+fsbv
 	     (:file "complex")))
-   #+(or)
    (:module data
 	    :depends-on (init)
 	    :components
 	    ((cffi-grovel:grovel-file "array-structs")
-	     (:file "marray" :depends-on ("array-structs"))
-	     (:file "vector" :depends-on ("marray" "array-structs"))
-	     (:file "matrix" :depends-on ("marray" "vector" "array-structs"))
-	     (:file "maref" :depends-on ("marray" "vector" "matrix"))
-	     (:file "both" :depends-on ("marray" "vector" "matrix"))
-	     (:file "copy-cl")
-	     (:file "array-tests" :depends-on ("both"))
-	     (:file "permutation" :depends-on ("marray" "array-structs"))
-	     (:file "combination" :depends-on ("marray" "array-structs"))))
+	     (:file "foreign-array" :depends-on ("array-structs"))
+	     (:file "vector" :depends-on ("foreign-array" "array-structs"))
+	     (:file "matrix" :depends-on ("foreign-array" "vector" "array-structs"))
+	     ;(:file "maref" :depends-on ("foreign-array" "vector" "matrix"))
+	     (:file "both" :depends-on ("foreign-array" "vector" "matrix"))
+	     ;(:file "copy-cl")
+	     ;(:file "array-tests" :depends-on ("both"))
+	     ;(:file "permutation" :depends-on ("foreign-array" "array-structs"))
+	     ;(:file "combination" :depends-on ("foreign-array" "array-structs"))
+	     ))
    #+(or)
    (:file "polynomial" :depends-on (init data))
    #+(or)
diff --git a/init/defmfun-array.lisp b/init/defmfun-array.lisp
index ecd29c75..273feb8d 100644
--- a/init/defmfun-array.lisp
+++ b/init/defmfun-array.lisp
@@ -1,6 +1,6 @@
 ;; Helpers for defining GSL functions on arrays
 ;; Liam Healy 2009-01-07 22:01:16EST defmfun-array.lisp
-;; Time-stamp: <2010-06-27 18:03:21EDT defmfun-array.lisp>
+;; Time-stamp: <2010-06-27 21:11:54EDT defmfun-array.lisp>
 ;;
 ;; Copyright 2009 Liam M. Healy
 ;; Distributed under the terms of the GNU General Public License
@@ -164,7 +164,7 @@
 		 (:component-float-type
 		  (grid:number-class (grid:component-float-type element-type)))
 		 (otherwise
-		  (data-class-name
+		  (grid:data-class-name
 		   (if (and (eq (second arg) 'both) replace-both)
 		       replace-both
 		       (second arg))
diff --git a/init/init.lisp b/init/init.lisp
index 33fb7301..77291c1d 100644
--- a/init/init.lisp
+++ b/init/init.lisp
@@ -1,6 +1,6 @@
 ;; Load GSL
 ;; Liam Healy Sat Mar  4 2006 - 18:53
-;; Time-stamp: <2010-06-27 18:20:14EDT init.lisp>
+;; Time-stamp: <2010-06-27 21:28:45EDT init.lisp>
 ;;
 ;; Copyright 2006, 2007, 2008, 2009 Liam M. Healy
 ;; Distributed under the terms of the GNU General Public License
@@ -23,7 +23,8 @@
   (:use :common-lisp :cffi)
   (:import-from
    :grid
-   #:cl-array #:dimensions #:total-size #:element-type #:dim0 #:dim1
+   #:cl-array #:dimensions #:total-size #:element-type
+   #:foreign-array #:matrix #:dim0 #:dim1
     ; #:copy #:clone
    )
   (:shadowing-import-from :grid #:foreign-pointer)
-- 
GitLab