Commit ed0605dc authored by Liam Healy's avatar Liam Healy
Browse files

Eliminate copy-to-destination for arrays, mvectors, matrices

Since the copy generic function has been established in grid,
eliminate copy-to-destination for arrays, mvectors, matrices.
parent 1d5f6494
;; Copy grid:foreign-arrays to/from CL arrays
;; Liam Healy 2009-02-11 19:28:44EST copy-cl.lisp
;; Time-stamp: <2010-06-30 19:57:28EDT copy-cl.lisp>
;;
;; Copyright 2009 Liam M. Healy
;; Distributed under the terms of the GNU General Public License
;;
;; This program is free software: you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
;; the Free Software Foundation, either version 3 of the License, or
;; (at your option) any later version.
;;
;; This program is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;; GNU General Public License for more details.
;;
;; You should have received a copy of the GNU General Public License
;; along with this program. If not, see <http://www.gnu.org/licenses/>.
;;; The function #'copy can be used to copy the contents to or from a
;;; CL array. If the destination isn't literally supplied, it can be
;;; a symbol 'array indicating that the grid:foreign-array is to be copied to a CL
;;; array, or an element type like 'double-float, indicating the
;;; contents of the CL array is to be copied to a new grid:foreign-array with the
;;; given element type.
;;; Contrast this with the function #'cl-array or the initarg
;;; :cl-array to #'grid:make-foreign-array. The function returns the cl-array
;;; without copying, and so might be faster but also makes the
;;; original grid:foreign-array object vulnerable if an element is changed, which
;;; officially has unpredictable results. Likewise, the initarg will
;;; use the given CL array directly in the created grid:foreign-array without
;;; copying.
(in-package :gsl)
;;; These make destination but are methods of copy-to-destination so
;;; that the class argument may be supplied.
(defmethod grid:copy-to-destination ((source mvector) (destination array))
(unless (equal (dimensions source) (array-dimensions destination))
(error 'grid:array-mismatch))
(loop for i below (dim0 source)
do (setf (aref destination i) (grid:gref source i)))
destination)
(defmethod grid:copy-to-destination ((source matrix) (destination array))
(unless (equal (dimensions source) (array-dimensions destination))
(error 'grid:array-mismatch))
(loop for i below (dim0 source) do
(loop for j below (dim1 source) do
(setf (aref destination i j) (grid:gref source i j))))
destination)
(defmethod grid:copy-to-destination ((source array) (destination mvector))
(unless (equal (array-dimensions source) (dimensions destination))
(error 'grid:array-mismatch))
(loop for i below (length source)
do (setf (grid:gref destination i) (aref source i)))
destination)
(defmethod grid:copy-to-destination ((source array) (destination matrix))
(unless (equal (array-dimensions source) (dimensions destination))
(error 'grid:array-mismatch))
(loop for i below (array-dimension source 0) do
(loop for j below (array-dimension source 1) do
(setf (grid:gref destination i j) (aref source i j))))
destination)
(defmethod grid:copy-to-destination ((source grid:foreign-array) (destclass (eql 'array)))
(let ((destination
(grid:make-ffa (element-type source) :dimensions (dimensions source))))
(grid:copy-to-destination source destination)))
;;; Copy to a named grid:foreign-array element-type, where the type is a symbol
(defmethod grid:copy-to-destination ((source array) (destclass symbol))
(let ((destination
(grid:make-foreign-array destclass :dimensions (array-dimensions source))))
(grid:copy-to-destination source destination)))
;;; Copy to a named grid:foreign-array element-type, where the type is a list
(defmethod grid:copy-to-destination ((source array) (destclass list))
(let ((destination
(grid:make-foreign-array destclass :dimensions (array-dimensions source))))
(grid:copy-to-destination source destination)))
;;; Examples and tests
(generate-all-array-tests vector-copy-to-cl-and-back t
(cl-array (copy (copy (array-default 3) 'array) 'default-element-type)))
(generate-all-array-tests matrix-copy-to-cl-and-back t
(cl-array (copy (copy (array-default '(3 3)) 'array) 'default-element-type)))
;; Definition of GSLL system
;; Liam Healy
;; Time-stamp: <2010-05-22 18:08:01EDT gsll-tests.asd>
;; Time-stamp: <2010-07-06 22:26:35EDT gsll-tests.asd>
;;
;; Copyright 2007, 2008, 2009 Liam M. Healy
;; Distributed under the terms of the GNU General Public License
......@@ -113,7 +113,6 @@
(:file "mathematical")
(:file "mathieu")
(:file "matrix-copy")
(:file "matrix-copy-to-cl-and-back")
(:file "matrix-div")
(:file "matrix-max-index")
(:file "matrix-max")
......@@ -194,7 +193,6 @@
(:file "transport")
(:file "trigonometry")
(:file "vector-copy")
(:file "vector-copy-to-cl-and-back")
(:file "vector-div")
(:file "vector-max-index")
(:file "vector-max")
......
;; Definition of GSLL system
;; Liam Healy
;; Time-stamp: <2010-06-29 21:42:42EDT gsll.asd>
;; Time-stamp: <2010-07-06 22:26:15EDT gsll.asd>
;;
;; Copyright 2006, 2007, 2008, 2009 Liam M. Healy
;; Distributed under the terms of the GNU General Public License
......@@ -78,7 +78,6 @@
(:file "vector" :depends-on ("foreign-array" "array-structs"))
(:file "matrix" :depends-on ("foreign-array" "vector" "array-structs"))
(: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"))))
......
;; Generate matrices used in tests of linear algebra functions
;; Liam Healy 2009-09-19 18:28:31EDT matrix-generation.lisp
;; Time-stamp: <2010-06-29 22:15:24EDT matrix-generation.lisp>
;; Time-stamp: <2010-07-06 22:29:07EDT matrix-generation.lisp>
;;
;; Copyright 2009, 2010 Liam M. Healy
;; Distributed under the terms of the GNU General Public License
......@@ -38,7 +38,8 @@
based on a function of the element indices i, j."
(grid:map-grid
:source function
:destination-gtype `((foreign-array ,(if dim1 2 1)) ,element-type)
:destination-specification
`((foreign-array ,dim0 ,dim1) ,element-type)
:source-dims (if dim1 (list dim0 dim1) (list dim0))))
(defun constant-matrix
......
;; Regression test MATRIX-COPY-TO-CL-AND-BACK for GSLL, automatically generated
;;
;; Copyright 2009 Liam M. Healy
;; Distributed under the terms of the GNU General Public License
;;
;; This program is free software: you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
;; the Free Software Foundation, either version 3 of the License, or
;; (at your option) any later version.
;;
;; This program is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;; GNU General Public License for more details.
;;
;; You should have received a copy of the GNU General Public License
;; along with this program. If not, see <http://www.gnu.org/licenses/>.
(in-package :gsl)
(LISP-UNIT:DEFINE-TEST MATRIX-COPY-TO-CL-AND-BACK
(LISP-UNIT::ASSERT-NUMERICAL-EQUAL
(LIST
#2A((-34.5 8.24 3.29)
(-8.93 34.12 -6.15)
(49.27 -13.49 32.5)))
(MULTIPLE-VALUE-LIST
(CL-ARRAY
(COPY
(COPY
(GRID:MAKE-FOREIGN-ARRAY 'SINGLE-FLOAT :INITIAL-CONTENTS
'((-34.5 8.24 3.29)
(-8.93 34.12 -6.15)
(49.27 -13.49 32.5)))
'ARRAY)
'SINGLE-FLOAT))))
(LISP-UNIT::ASSERT-NUMERICAL-EQUAL
(LIST
#2A((-34.5d0 8.24d0 3.29d0)
(-8.93d0 34.12d0 -6.15d0)
(49.27d0 -13.49d0 32.5d0)))
(MULTIPLE-VALUE-LIST
(CL-ARRAY
(COPY
(COPY
(GRID:MAKE-FOREIGN-ARRAY 'DOUBLE-FLOAT :INITIAL-CONTENTS
'((-34.5d0 8.24d0 3.29d0)
(-8.93d0 34.12d0 -6.15d0)
(49.27d0 -13.49d0 32.5d0)))
'ARRAY)
'DOUBLE-FLOAT))))
(LISP-UNIT::ASSERT-NUMERICAL-EQUAL
(LIST
#2A((#C(-34.5 8.24) #C(3.29 -8.93) #C(34.12 -6.15))
(#C(-8.93 34.12) #C(-6.15 49.27) #C(-13.49 32.5))
(#C(49.27 -13.49) #C(32.5 42.73)
#C(-17.24 43.31))))
(MULTIPLE-VALUE-LIST
(CL-ARRAY
(COPY
(COPY
(GRID:MAKE-FOREIGN-ARRAY '(COMPLEX SINGLE-FLOAT)
:INITIAL-CONTENTS
'((-34.5 8.24 3.29 -8.93 34.12 -6.15)
(-8.93 34.12 -6.15 49.27 -13.49
32.5)
(49.27 -13.49 32.5 42.73 -17.24
43.31)))
'ARRAY)
'(COMPLEX SINGLE-FLOAT)))))
(LISP-UNIT::ASSERT-NUMERICAL-EQUAL
(LIST
#2A((#C(-34.5d0 8.24d0) #C(3.29d0 -8.93d0)
#C(34.12d0 -6.15d0))
(#C(-8.93d0 34.12d0) #C(-6.15d0 49.27d0)
#C(-13.49d0 32.5d0))
(#C(49.27d0 -13.49d0) #C(32.5d0 42.73d0)
#C(-17.24d0 43.31d0))))
(MULTIPLE-VALUE-LIST
(CL-ARRAY
(COPY
(COPY
(GRID:MAKE-FOREIGN-ARRAY '(COMPLEX DOUBLE-FLOAT)
:INITIAL-CONTENTS
'((-34.5d0 8.24d0 3.29d0 -8.93d0
34.12d0 -6.15d0)
(-8.93d0 34.12d0 -6.15d0 49.27d0
-13.49d0 32.5d0)
(49.27d0 -13.49d0 32.5d0 42.73d0
-17.24d0 43.31d0)))
'ARRAY)
'(COMPLEX DOUBLE-FLOAT)))))
(LISP-UNIT::ASSERT-NUMERICAL-EQUAL
(LIST #2A((-64 -68 71) (-91 52 -10) (73 -5 123)))
(MULTIPLE-VALUE-LIST
(CL-ARRAY
(COPY
(COPY
(GRID:MAKE-FOREIGN-ARRAY '(SIGNED-BYTE 8) :INITIAL-CONTENTS
'((-64 -68 71) (-91 52 -10)
(73 -5 123)))
'ARRAY)
'(SIGNED-BYTE 8)))))
(LISP-UNIT::ASSERT-NUMERICAL-EQUAL
(LIST #2A((67 44 189) (116 163 140) (161 215 98)))
(MULTIPLE-VALUE-LIST
(CL-ARRAY
(COPY
(COPY
(GRID:MAKE-FOREIGN-ARRAY '(UNSIGNED-BYTE 8) :INITIAL-CONTENTS
'((67 44 189) (116 163 140)
(161 215 98)))
'ARRAY)
'(UNSIGNED-BYTE 8)))))
(LISP-UNIT::ASSERT-NUMERICAL-EQUAL
(LIST #2A((-64 -68 71) (-91 52 -10) (73 -5 123)))
(MULTIPLE-VALUE-LIST
(CL-ARRAY
(COPY
(COPY
(GRID:MAKE-FOREIGN-ARRAY '(SIGNED-BYTE 16) :INITIAL-CONTENTS
'((-64 -68 71) (-91 52 -10)
(73 -5 123)))
'ARRAY)
'(SIGNED-BYTE 16)))))
(LISP-UNIT::ASSERT-NUMERICAL-EQUAL
(LIST #2A((67 44 189) (116 163 140) (161 215 98)))
(MULTIPLE-VALUE-LIST
(CL-ARRAY
(COPY
(COPY
(GRID:MAKE-FOREIGN-ARRAY '(UNSIGNED-BYTE 16) :INITIAL-CONTENTS
'((67 44 189) (116 163 140)
(161 215 98)))
'ARRAY)
'(UNSIGNED-BYTE 16)))))
(LISP-UNIT::ASSERT-NUMERICAL-EQUAL
(LIST #2A((-64 -68 71) (-91 52 -10) (73 -5 123)))
(MULTIPLE-VALUE-LIST
(CL-ARRAY
(COPY
(COPY
(GRID:MAKE-FOREIGN-ARRAY '(SIGNED-BYTE 32) :INITIAL-CONTENTS
'((-64 -68 71) (-91 52 -10)
(73 -5 123)))
'ARRAY)
'(SIGNED-BYTE 32)))))
(LISP-UNIT::ASSERT-NUMERICAL-EQUAL
(LIST #2A((67 44 189) (116 163 140) (161 215 98)))
(MULTIPLE-VALUE-LIST
(CL-ARRAY
(COPY
(COPY
(GRID:MAKE-FOREIGN-ARRAY '(UNSIGNED-BYTE 32) :INITIAL-CONTENTS
'((67 44 189) (116 163 140)
(161 215 98)))
'ARRAY)
'(UNSIGNED-BYTE 32)))))
#+int64
(LISP-UNIT::ASSERT-NUMERICAL-EQUAL
(LIST #2A((-64 -68 71) (-91 52 -10) (73 -5 123)))
(MULTIPLE-VALUE-LIST
(CL-ARRAY
(COPY
(COPY
(GRID:MAKE-FOREIGN-ARRAY '(SIGNED-BYTE 64) :INITIAL-CONTENTS
'((-64 -68 71) (-91 52 -10)
(73 -5 123)))
'ARRAY)
'(SIGNED-BYTE 64)))))
#+int64
(LISP-UNIT::ASSERT-NUMERICAL-EQUAL
(LIST #2A((67 44 189) (116 163 140) (161 215 98)))
(MULTIPLE-VALUE-LIST
(CL-ARRAY
(COPY
(COPY
(GRID:MAKE-FOREIGN-ARRAY '(UNSIGNED-BYTE 64) :INITIAL-CONTENTS
'((67 44 189) (116 163 140)
(161 215 98)))
'ARRAY)
'(UNSIGNED-BYTE 64))))))
;; Regression test VECTOR-COPY-TO-CL-AND-BACK for GSLL, automatically generated
;;
;; Copyright 2009 Liam M. Healy
;; Distributed under the terms of the GNU General Public License
;;
;; This program is free software: you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
;; the Free Software Foundation, either version 3 of the License, or
;; (at your option) any later version.
;;
;; This program is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;; GNU General Public License for more details.
;;
;; You should have received a copy of the GNU General Public License
;; along with this program. If not, see <http://www.gnu.org/licenses/>.
(in-package :gsl)
(LISP-UNIT:DEFINE-TEST VECTOR-COPY-TO-CL-AND-BACK
(LISP-UNIT::ASSERT-NUMERICAL-EQUAL
(LIST #(-34.5 8.24 3.29))
(MULTIPLE-VALUE-LIST
(CL-ARRAY
(COPY
(COPY
(GRID:MAKE-FOREIGN-ARRAY 'SINGLE-FLOAT :INITIAL-CONTENTS
'(-34.5 8.24 3.29))
'ARRAY)
'SINGLE-FLOAT))))
(LISP-UNIT::ASSERT-NUMERICAL-EQUAL
(LIST #(-34.5d0 8.24d0 3.29d0))
(MULTIPLE-VALUE-LIST
(CL-ARRAY
(COPY
(COPY
(GRID:MAKE-FOREIGN-ARRAY 'DOUBLE-FLOAT :INITIAL-CONTENTS
'(-34.5d0 8.24d0 3.29d0))
'ARRAY)
'DOUBLE-FLOAT))))
(LISP-UNIT::ASSERT-NUMERICAL-EQUAL
(LIST #(#C(-34.5 8.24) #C(3.29 -8.93) #C(34.12 -6.15)))
(MULTIPLE-VALUE-LIST
(CL-ARRAY
(COPY
(COPY
(GRID:MAKE-FOREIGN-ARRAY '(COMPLEX SINGLE-FLOAT)
:INITIAL-CONTENTS
'(-34.5 8.24 3.29 -8.93 34.12 -6.15))
'ARRAY)
'(COMPLEX SINGLE-FLOAT)))))
(LISP-UNIT::ASSERT-NUMERICAL-EQUAL
(LIST
#(#C(-34.5d0 8.24d0) #C(3.29d0 -8.93d0)
#C(34.12d0 -6.15d0)))
(MULTIPLE-VALUE-LIST
(CL-ARRAY
(COPY
(COPY
(GRID:MAKE-FOREIGN-ARRAY '(COMPLEX DOUBLE-FLOAT)
:INITIAL-CONTENTS
'(-34.5d0 8.24d0 3.29d0 -8.93d0
34.12d0 -6.15d0))
'ARRAY)
'(COMPLEX DOUBLE-FLOAT)))))
(LISP-UNIT::ASSERT-NUMERICAL-EQUAL (LIST #(-64 -68 71))
(MULTIPLE-VALUE-LIST
(CL-ARRAY
(COPY
(COPY
(GRID:MAKE-FOREIGN-ARRAY
'(SIGNED-BYTE 8)
:INITIAL-CONTENTS
'(-64 -68 71))
'ARRAY)
'(SIGNED-BYTE
8)))))
(LISP-UNIT::ASSERT-NUMERICAL-EQUAL (LIST #(67 44 189))
(MULTIPLE-VALUE-LIST
(CL-ARRAY
(COPY
(COPY
(GRID:MAKE-FOREIGN-ARRAY
'(UNSIGNED-BYTE
8)
:INITIAL-CONTENTS
'(67 44 189))
'ARRAY)
'(UNSIGNED-BYTE
8)))))
(LISP-UNIT::ASSERT-NUMERICAL-EQUAL (LIST #(-64 -68 71))
(MULTIPLE-VALUE-LIST
(CL-ARRAY
(COPY
(COPY
(GRID:MAKE-FOREIGN-ARRAY
'(SIGNED-BYTE
16)
:INITIAL-CONTENTS
'(-64 -68 71))
'ARRAY)
'(SIGNED-BYTE
16)))))
(LISP-UNIT::ASSERT-NUMERICAL-EQUAL (LIST #(67 44 189))
(MULTIPLE-VALUE-LIST
(CL-ARRAY
(COPY
(COPY
(GRID:MAKE-FOREIGN-ARRAY
'(UNSIGNED-BYTE
16)
:INITIAL-CONTENTS
'(67 44 189))
'ARRAY)
'(UNSIGNED-BYTE
16)))))
(LISP-UNIT::ASSERT-NUMERICAL-EQUAL (LIST #(-64 -68 71))
(MULTIPLE-VALUE-LIST
(CL-ARRAY
(COPY
(COPY
(GRID:MAKE-FOREIGN-ARRAY
'(SIGNED-BYTE
32)
:INITIAL-CONTENTS
'(-64 -68 71))
'ARRAY)
'(SIGNED-BYTE
32)))))
(LISP-UNIT::ASSERT-NUMERICAL-EQUAL (LIST #(67 44 189))
(MULTIPLE-VALUE-LIST
(CL-ARRAY
(COPY
(COPY
(GRID:MAKE-FOREIGN-ARRAY
'(UNSIGNED-BYTE
32)
:INITIAL-CONTENTS
'(67 44 189))
'ARRAY)
'(UNSIGNED-BYTE
32)))))
#+int64
(LISP-UNIT::ASSERT-NUMERICAL-EQUAL (LIST #(-64 -68 71))
(MULTIPLE-VALUE-LIST
(CL-ARRAY
(COPY
(COPY
(GRID:MAKE-FOREIGN-ARRAY
'(SIGNED-BYTE
64)
:INITIAL-CONTENTS
'(-64 -68 71))
'ARRAY)
'(SIGNED-BYTE
64)))))
#+int64
(LISP-UNIT::ASSERT-NUMERICAL-EQUAL (LIST #(67 44 189))
(MULTIPLE-VALUE-LIST
(CL-ARRAY
(COPY
(COPY
(GRID:MAKE-FOREIGN-ARRAY
'(UNSIGNED-BYTE
64)
:INITIAL-CONTENTS
'(67 44 189))
'ARRAY)
'(UNSIGNED-BYTE
64))))))
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