guile-devel
[Top][All Lists]
Advanced

[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]

[PATCH] Add SRFI-25 implementation


From: Andreas Rottmann
Subject: [PATCH] Add SRFI-25 implementation
Date: Mon, 27 Jul 2015 23:59:41 +0200

Adds an implementation of SRFI 25 on top of Guile's native arrays. The
implementation does not introduce a disjoint type; Guile arrays and
SRFI-25 arrays can be used interchangably, though with different, partly
conflicting APIs.

* NEWS: Add preliminary, incomplete section on 2.0.12, noting the
  addition of SRFI-25.
* doc/ref/srfi-modules.texi (SRFI-25): New node.
* module/srfi/srfi-25.scm: New file.
* test-suite/tests/srfi-25.test: New file.
* module/Makefile.am:
* test-suite/Makefile.am: Add new files.
---
 NEWS                          |  15 +-
 doc/ref/srfi-modules.texi     | 240 +++++++++++++++++++++-
 module/Makefile.am            |   1 +
 module/srfi/srfi-25.scm       | 159 +++++++++++++++
 test-suite/Makefile.am        |   3 +-
 test-suite/tests/srfi-25.test | 461 ++++++++++++++++++++++++++++++++++++++++++
 6 files changed, 876 insertions(+), 3 deletions(-)
 create mode 100644 module/srfi/srfi-25.scm
 create mode 100644 test-suite/tests/srfi-25.test

diff --git a/NEWS b/NEWS
index 0292dcd..19c4e39 100644
--- a/NEWS
+++ b/NEWS
@@ -1,10 +1,23 @@
 Guile NEWS --- history of user-visible changes.
-Copyright (C) 1996-2014 Free Software Foundation, Inc.
+Copyright (C) 1996-2015 Free Software Foundation, Inc.
 See the end for copying conditions.
 
 Please send Guile bug reports to address@hidden
 
+Changes in 2.0.12 (since 2.0.11):
 
+* New interfaces
+
+** SRFI-25 (Multi-dimensional Array Primitives)
+
+Guile now includes SRFI-25, a core set of procedures for creating and
+manipulating multidimensional arrays. This functionality is already
+available in Guile, albeit with a different API, with its native array
+data type, but the inclusion of the SRFI is nevertheless useful for code
+intended to be portable across multiple implementations. See "SRFI-25" i
+the manual for details.
+
+
 Changes in 2.0.11 (since 2.0.10):
 
 This release fixes an embarrassing regression introduced in the C
diff --git a/doc/ref/srfi-modules.texi b/doc/ref/srfi-modules.texi
index d8ed8e1..53312e9 100644
--- a/doc/ref/srfi-modules.texi
+++ b/doc/ref/srfi-modules.texi
@@ -1,6 +1,6 @@
 @c -*-texinfo-*-
 @c This is part of the GNU Guile Reference Manual.
address@hidden Copyright (C) 1996, 1997, 2000-2004, 2006, 2007-2014
address@hidden Copyright (C) 1996, 1997, 2000-2004, 2006, 2007-2015
 @c   Free Software Foundation, Inc.
 @c See the file guile.texi for copying conditions.
 
@@ -36,6 +36,7 @@ get the relevant SRFI documents from the SRFI home page
 * SRFI-18::                     Multithreading support
 * SRFI-19::                     Time/Date library.
 * SRFI-23::                     Error reporting
+* SRFI-25::                     Multi-dimensional Array Primitives
 * SRFI-26::                     Specializing parameters
 * SRFI-27::                     Sources of Random Bits
 * SRFI-28::                     Basic format strings.
@@ -3018,6 +3019,243 @@ locale.
 
 The SRFI-23 @code{error} procedure is always available.
 
address@hidden SRFI-25
address@hidden SRFI-25 - Multi-dimensional Array Primitives
address@hidden SRFI-25
address@hidden array, multi-dimensional
address@hidden multi-dimensional array
+
+Note that Guile's implementation of SRFI-25 does not introduce a
+disjoint type; Guile arrays (@pxref{Arrays}) and SRFI-25 arrays can be
+used interchangably, though with different, partly conflicting APIs. The
+SRFI-25 API can be used with,
+
address@hidden
+(use-modules (srfi srfi-25))
address@hidden example
+
+Note that this will override @code{make-array}, @code{array-ref} and
address@hidden @ref{Using Guile Modules} describes how to control
+the import of identifiers, e.g., by importing the SRFI-25 variants with
+different names.
+
+This subsection is based on
address@hidden://srfi.schemers.org/srfi-45/srfi-45.html, the specification
+of SRFI-45} written by Jussi Piitulainen.
+
address@hidden Copyright (C) Jussi Piitulainen (2001). All Rights Reserved.
+
address@hidden Permission is hereby granted, free of charge, to any person 
obtaining a
address@hidden copy of this software and associated documentation files (the
address@hidden "Software"), to deal in the Software without restriction, 
including
address@hidden without limitation the rights to use, copy, modify, merge, 
publish,
address@hidden distribute, sublicense, and/or sell copies of the Software, and 
to
address@hidden permit persons to whom the Software is furnished to do so, 
subject to
address@hidden the following conditions:
+
address@hidden The above copyright notice and this permission notice shall be 
included
address@hidden in all copies or substantial portions of the Software.
+
address@hidden THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, 
EXPRESS
address@hidden OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
address@hidden MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
address@hidden NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT 
HOLDERS BE
address@hidden LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN 
ACTION
address@hidden OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN 
CONNECTION
address@hidden WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
+
+A core set of procedures for creating and manipulating heterogeneous
+multidimensional arrays is proposed. The design is consistent with the
+rest of Scheme and independent of other container data types. It
+provides easy sharing of parts of an array as other arrays without
+copying, encouraging a declarative style of programming.
+
+The specification is based on an original contribution by Alan Bawden in
+1993.
+
+The proposed arrays encourage a natural declarative programming
+style. They allow sharing of most any rectangular part of an array
+through an affine index mapping, without copying. But imperative style
+is equally natural.
+
+The design is consistent with the two indexed data structures of Scheme:
+vectors and strings. The design makes arrays a self-contained
+type. These statements are illustrated in the following paragraphs.
+
+First, in the one-dimensional case, the arguments of the following
+relevant calls match exactly.
+
address@hidden
+(vector-set! v k o)
+(string-set! s k c)
+(array-set! a k o)
address@hidden example
+
+
+Likewise, @code{make-array} matches @code{make-vector} and
address@hidden An analogue to @code{vector}, @code{string} and
address@hidden is provided, alleviating the lack of an external
+representation. Index bounds are specified as for @code{substring},
+lower bound included and upper bound excluded.
+
+Array shapes are specified as arrays. These can be made with a special
+procedure @code{shape} that does not have a shape argument. An array
+does not retain a dependence to the shape array. For example, mutation
+of a shape array is allowed.
+
+Index mappings return multiple values as multiple values.
+
+Array dimensions can begin at any index. In particular, the choice
+between @code{0} and @code{1} is left to the user. (Shapes and index
+objects are zero based, though.)
+
+The ability to pack an index sequence in a vector is useful for
+implementing higher level operations. (The ability to pack it in a
+one-dimensional array lets one use, say, a row of a matrix as an index.)
+
address@hidden Specification
+
+Arrays are heterogeneous data structures whose elements are indexed by
+integer sequences of fixed length. The length of a valid index sequence
+is the rank or the number of dimensions of an array. The shape of an
+array consists of bounds for each index.
+
+The lower bound @var{b} and the upper bound @var{e} of a dimension are
+exact integers with @code{(<= @var{b} @var{e})}. A valid index along the
+dimension is an exact integer @var{k} that satisfies both
address@hidden(<= @var{b} @var{k})} and @code{(< @var{k} @var{e})}. The length
+of the array along the dimension is the difference
address@hidden(- @var{e} @var{b})}. The size of an array is the product of the
+lengths of its dimensions.
+
+A shape is specified as an even number of exact integers. These are
+alternately the lower and upper bounds for the dimensions of an array.
+
+The following ten procedures are provided by the module @code{(srfi
+srfi-25)}:
+
address@hidden array? obj
+Returns @code{#t} if @var{obj} is an array, otherwise returns
address@hidden Note that this procedure returns @code{#t} for both SRFI-25
+and Guile's native arrays.
address@hidden defun
+
address@hidden make-array shape
address@hidden make-array shape obj
+Returns a newly allocated array whose shape is given by @var{shape}. If
address@hidden is provided, then each element is initialized to it. Otherwise
+the initial contents of each element is unspecified. The array does not
+retain a dependence to @var{shape}.
address@hidden defun
+
address@hidden shape bound ...
+Returns a shape. The sequence @var{bound ...} must consist of an even
+number of exact integers that are pairwise not decreasing. Each pair
+gives the lower and upper bound of a dimension. If the shape is used to
+specify the dimensions of an array and @var{bound ...} is the sequence
address@hidden e0 ... bk ek ...} of @var{n} pairs of bounds, then a valid index
+to the array is any sequence @var{j0 ... jk ...} of @var{n} exact
+integers where each @var{jk} satisfies @code{(<address@hidden@var{jk})} and
address@hidden(< @var{jk} @var{ek})}.
+
+The shape of a @var{d}-dimensional array is a @address@hidden × @var{2}}
+array where the element at @var{k 0} contains the lower bound for an
+index along dimension @var{k} and the element at @var{k 1} contains the
+corresponding upper bound, where @var{k} satisfies @code{(<= 0 @var{k})}
+and @code{(< @var{k} @var{d})}.
address@hidden defun
+
address@hidden array shape obj ...
+Returns a new array whose shape is given by @var{shape} and the initial
+contents of the elements are @var{obj ...} in row major order. The array
+does not retain a dependence to @var{shape}.
address@hidden defun
+
address@hidden array-rank array
+Returns the number of dimensions of @var{array}.
address@hidden
+(array-rank (make-array (shape 1 2 3 4)))
address@hidden example
+Returns @samp{2}.
address@hidden defun
+
address@hidden array-start array k
+Returns the lower bound for the index along dimension @var{k}.
address@hidden defun
+
address@hidden array-end array k
+Returns the upper bound for the index along dimension @var{k}.
address@hidden defun
+
address@hidden array-ref array k ...
address@hidden array-ref array index
+Returns the contents of the element of @var{array} at index @var{k
+...}. The sequence @var{k ...} must be a valid index to @var{array}. In
+the second form, @var{index} must be either a vector or a 0-based
+1-dimensional array containing @var{k ...}.
+
address@hidden
+(array-ref (array (shape 0 2 0 3)
+              'uno 'dos 'tres
+              'cuatro 'cinco 'seis)
+   1 0)
address@hidden example
+
+Returns @samp{cuatro}.
+
address@hidden
+(let ((a (array (shape 4 7 1 2) 3 1 4)))
+   (list (array-ref a 4 1)
+         (array-ref a (vector 5 1))
+         (array-ref a (array (shape 0 2)
+                         6 1))))
address@hidden example
+
+Returns @samp{(3 1 4)}.
address@hidden defun
+
address@hidden array-set! array k ... obj
address@hidden array-set! array index obj
+Stores @var{obj} in the element of @var{array} at index @var{k
+...}. Returns an unspecified value. The sequence @var{k ...} must be a
+valid index to @var{array}. In the second form, @var{index} must be
+either a vector or a 0-based 1-dimensional array containing @var{k ...}.
+
address@hidden
+(let ((a (make-array
+            (shape 4 5 4 5 4 5))))
+   (array-set! a 4 4 4 'huuhkaja)
+   (array-ref a 4 4 4))
address@hidden example
+Returns @samp{huuhkaja}.
address@hidden defun
+
address@hidden share-array array shape proc
+Returns a new array of shape @var{shape} that shares elements of
address@hidden through @var{proc}. The procedure @var{proc} must implement
+an affine function that returns indices of @var{array} when given
+indices of the array returned by @code{share-array}. The array does not
+retain a dependence to @var{shape}.
address@hidden
+(define i_4
+   (let* ((i (make-array
+                (shape 0 4 0 4)
+                0))
+          (d (share-array i
+                (shape 0 4)
+                (lambda (k)
+                   (values k k)))))
+      (do ((k 0 (+ k 1)))
+          ((= k 4))
+         (array-set! d k 1))
+      i))
address@hidden example
+
+Note: the affinity requirement for @var{proc} means that each value must
+be a sum of multiples of the arguments passed to @var{proc}, plus a
+constant.
address@hidden defun
+
 @node SRFI-26
 @subsection SRFI-26 - specializing parameters
 @cindex SRFI-26
diff --git a/module/Makefile.am b/module/Makefile.am
index 7e96de7..915e23a 100644
--- a/module/Makefile.am
+++ b/module/Makefile.am
@@ -276,6 +276,7 @@ SRFI_SOURCES = \
   srfi/srfi-17.scm \
   srfi/srfi-18.scm \
   srfi/srfi-19.scm \
+  srfi/srfi-25.scm \
   srfi/srfi-26.scm \
   srfi/srfi-27.scm \
   srfi/srfi-28.scm \
diff --git a/module/srfi/srfi-25.scm b/module/srfi/srfi-25.scm
new file mode 100644
index 0000000..3a5d2e9
--- /dev/null
+++ b/module/srfi/srfi-25.scm
@@ -0,0 +1,159 @@
+;;; -*- mode: scheme; coding: utf-8; -*-
+
+;; Copyright (C) 2012, 2015 Free Software Foundation, Inc.
+;;
+;; This library is free software; you can redistribute it and/or
+;; modify it under the terms of the GNU Lesser General Public
+;; License as published by the Free Software Foundation; either
+;; version 3 of the License, or (at your option) any later version.
+;;
+;; This library 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
+;; Lesser General Public License for more details.
+;;
+;; You should have received a copy of the GNU Lesser General Public
+;; License along with this library. If not, see
+;; <http://www.gnu.org/licenses/>.
+
+;;; Commentary:
+
+;;; Code:
+
+(define-module (srfi srfi-25)
+  #:re-export (array?
+               array-rank)
+
+  #:replace ((srfi:make-array . make-array)
+             (srfi:array-set! . array-set!)
+             (srfi:array-ref . array-ref))
+  #:export (shape
+            array
+            array-start
+            array-end
+            share-array)
+  #:use-module (srfi srfi-9))
+
+(define* (srfi:make-array shape #:optional (fill *unspecified*))
+  (apply make-array fill (shape->bounds shape)))
+
+(define (shape . bounds)
+  (let ((shape (make-array *unspecified* (/ (length bounds) 2) 2)))
+    (let loop ((b bounds)
+               (k 0))
+      (cond ((null? b)
+             shape)
+            ((null? (cdr b))
+             (error "bounds must be of even number" bounds))
+            (else
+             (let ((lower (car b))
+                   (upper (cadr b)))
+               (unless (<= lower upper)
+                 (error "lower bound must not be larger than upper bound"
+                        lower upper))
+               (array-set! shape lower k 0)
+               (array-set! shape upper k 1)
+               (loop (cddr b) (+ k 1))))))))
+
+(define (shape->bounds shape)
+  (let loop ((bounds '())
+             (k (cadar (array-shape shape))))
+    (if (< k 0)
+        bounds
+        (loop (cons (list (array-ref shape k 0)
+                          (- (array-ref shape k 1) 1))
+                    bounds)
+              (- k 1)))))
+
+(define (shape->sizes shape)
+  (let ((rank (+ 1 (cadar (array-shape shape)))))
+    (do ((result (make-vector rank))
+         (k (- rank 1) (- k 1))
+         (size 1 (* size (- (array-ref shape k 1)
+                            (array-ref shape k 0)))))
+        ((< k 0) result)
+      (vector-set! result k size))))
+
+;;++ check length of `elements'
+;;++ don't use array-start, but make `shape->sizes' provide starts
+(define (array shape . elements)
+  (let ((result (srfi:make-array shape))
+        (elements (list->vector elements))
+        (sizes (shape->sizes shape)))
+    (define (element-offset indices)
+      (let loop ((offset 0)
+                 (k 0)
+                 (indices indices))
+        (if (null? indices)
+            offset
+            (loop (+ offset
+                     (* (- (car indices) (array-start result k))
+                        (vector-ref sizes k)))
+                  (+ k 1)
+                  (cdr indices)))))
+    (array-index-map! result
+                      (lambda indices
+                        (vector-ref elements (element-offset indices))))
+    result))
+
+(define (array-bounds array k)
+  (list-ref (array-shape array) k))
+
+(define (array-start array k)
+  (car (array-bounds array k)))
+
+(define (array-end array k)
+  (+ 1 (cadr (array-bounds array k))))
+
+
+(define (array->index-list array)
+  (unless (and (= 1 (array-rank array))
+               (= 0 (array-start array 0)))
+    (error "array used as index must be zero-based and of rank 1" array))
+  (array->list array))
+
+(define srfi:array-ref
+  (case-lambda
+    ((array) ;zero-dimensional case
+     (array-ref array))
+    ((array i)
+     (cond ((array? i)
+            (apply array-ref array (array->index-list i)))
+           ((vector? i)
+            (apply array-ref array (vector->list i)))
+           (else
+            (array-ref array i))))
+    ((array i0 . indices)
+     (apply array-ref array i0 indices))))
+
+(define srfi:array-set!
+  (case-lambda
+    ((array obj) ; zero-dimensional case
+     (array-set! array obj))
+    ((array i obj)
+     (cond ((array? i)
+            (apply array-set! array obj (array->index-list i)))
+           ((vector? i)
+            (apply array-set! array obj (vector->list i)))
+           (else
+            (array-set! array obj i))))
+    ((array i0 . indices+obj)
+     (call-with-values
+         (lambda () (split-indices+obj (cons i0 indices+obj)))
+       (lambda (indices obj)
+         (apply array-set! array obj indices))))))
+
+(define (split-indices+obj indices+obj)
+  (let loop ((l indices+obj)
+             (indices '()))
+    (if (null? (cdr l))
+        (values (reverse indices) (car l))
+        (loop (cdr l) (cons (car l) indices)))))
+
+(define (share-array array shape proc)
+  (apply make-shared-array
+         array
+         (lambda indices
+           (call-with-values (lambda () (apply proc indices))
+             list))
+         (shape->bounds shape)))
diff --git a/test-suite/Makefile.am b/test-suite/Makefile.am
index 3b10353..121e2ef 100644
--- a/test-suite/Makefile.am
+++ b/test-suite/Makefile.am
@@ -1,7 +1,7 @@
 ## Process this file with automake to produce Makefile.in.
 ##
 ## Copyright 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009,
-##   2010, 2011, 2012, 2013, 2014 Software Foundation, Inc.
+##   2010, 2011, 2012, 2013, 2014, 2015 Software Foundation, Inc.
 ##
 ## This file is part of GUILE.
 ##
@@ -133,6 +133,7 @@ SCM_TESTS = tests/00-initial-env.test               \
            tests/srfi-17.test                  \
            tests/srfi-18.test                  \
            tests/srfi-19.test                  \
+           tests/srfi-25.test                  \
            tests/srfi-26.test                  \
            tests/srfi-27.test                  \
            tests/srfi-31.test                  \
diff --git a/test-suite/tests/srfi-25.test b/test-suite/tests/srfi-25.test
new file mode 100644
index 0000000..083e58c
--- /dev/null
+++ b/test-suite/tests/srfi-25.test
@@ -0,0 +1,461 @@
+;;; -*- mode: scheme; coding: utf-8; -*-
+
+;; Copyright (C) 2012, 2015 Free Software Foundation, Inc.
+;; Copyright (C) 2001 Jussi Piitulainen. All Rights Reserved.
+;;
+;; Permission is hereby granted, free of charge, to any person
+;; obtaining a copy of this software and associated documentation
+;; files (the "Software"), to deal in the Software without
+;; restriction, including without limitation the rights to use, copy,
+;; modify, merge, publish, distribute, sublicense, and/or sell copies
+;; of the Software, and to permit persons to whom the Software is
+;; furnished to do so, subject to the following conditions:
+;;
+;; The above copyright notice and this permission notice shall be
+;; included in all copies or substantial portions of the Software.
+;;
+;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
+;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
+;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
+;; NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS
+;; BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN
+;; ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN
+;; CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
+;; SOFTWARE.
+
+;;; Commentary:
+
+;; Test suite linked to by the SRFI 25 specification, adapted to use
+;; Guile's testing infrastructure.
+
+;;; Code:
+
+(define-module (test-srfi-25)
+  #:use-module (test-suite lib)
+  #:use-module (srfi srfi-25))
+
+;;; Simple tests
+
+(pass-if "(shape ...)"
+  (and (shape)
+       (shape -1 -1)
+       (shape -1 0)
+       (shape -1 1)
+       (shape 1 2 3 4 5 6 7 8 1 2 3 4 5 6 7 8 1 2 3 4 5 6 7 8)
+       #t))
+
+
+(pass-if "(make-array (shape ...) [o])"
+  (and (make-array (shape))
+       (make-array (shape) *)
+       (make-array (shape -1 -1))
+       (make-array (shape -1 -1) *)
+       (make-array (shape -1 1))
+       (make-array (shape 1 2 3 4 5 6 7 8 1 2 3 4 5 6 7 8 1 2 3 4) *)
+       #t))
+
+
+(pass-if "(array (shape ...) ...)"
+  (and (array (shape) *)
+       (array (shape -1 -1))
+       (array (shape -1 1) * *)
+       (array (shape 1 2 3 4 5 6 7 8 1 2 3 4 5 6 7 8) *)
+       #t))
+
+
+(pass-if "(array-rank (shape ...))"
+  (and (= (array-rank (shape)) 2)
+       (= (array-rank (shape -1 -1)) 2)
+       (= (array-rank (shape -1 1)) 2)
+       (= (array-rank (shape 1 2 3 4 5 6 7 8)) 2)))
+
+
+(pass-if "(array-rank (make-array ...))"
+  (and (= (array-rank (make-array (shape))) 0)
+       (= (array-rank (make-array (shape -1 -1))) 1)
+       (= (array-rank (make-array (shape -1 1))) 1)
+       (= (array-rank (make-array (shape 1 2 3 4 5 6 7 8))) 4)))
+
+
+(pass-if "(array-rank (array ...))"
+  (and (= (array-rank (array (shape) *)) 0)
+       (= (array-rank (array (shape -1 -1))) 1)
+       (= (array-rank (array (shape -1 1) * *)) 1)
+       (= (array-rank (array (shape 1 2 3 4 5 6 7 8) *)) 4)))
+
+
+(pass-if "(array-start (shape ...))"
+  (and (= (array-start (shape -1 -1) 0) 0)
+       (= (array-start (shape -1 -1) 1) 0)
+       (= (array-start (shape -1 1) 0) 0)
+       (= (array-start (shape -1 1) 1) 0)
+       (= (array-start (shape 1 2 3 4 5 6 7 8) 0) 0)
+       (= (array-start (shape 1 2 3 4 5 6 7 8) 1) 0)))
+
+
+(pass-if "(array-end (shape ...))"
+  (and (= (array-end (shape -1 -1) 0) 1)
+       (= (array-end (shape -1 -1) 1) 2)
+       (= (array-end (shape -1 1) 0) 1)
+       (= (array-end (shape -1 1) 1) 2)
+       (= (array-end (shape 1 2 3 4 5 6 7 8) 0) 4)
+       (= (array-end (shape 1 2 3 4 5 6 7 8) 1) 2)))
+
+
+(pass-if "(array-start (make-array ...))"
+  (and #;(= (array-start (make-array (shape -1 -1)) 0) -1)
+       (= (array-start (make-array (shape -1 1)) 0) -1)
+       (= (array-start (make-array (shape 1 2 3 4 5 6 7 8)) 0) 1)
+       (= (array-start (make-array (shape 1 2 3 4 5 6 7 8)) 1) 3)
+       (= (array-start (make-array (shape 1 2 3 4 5 6 7 8)) 2) 5)
+       (= (array-start (make-array (shape 1 2 3 4 5 6 7 8)) 3) 7)))
+
+
+(pass-if "(array-end (make-array ...))"
+  (and #;(= (array-end (make-array (shape -1 -1)) 0) -1)
+       (= (array-end (make-array (shape -1 1)) 0) 1)
+       (= (array-end (make-array (shape 1 2 3 4 5 6 7 8)) 0) 2)
+       (= (array-end (make-array (shape 1 2 3 4 5 6 7 8)) 1) 4)
+       (= (array-end (make-array (shape 1 2 3 4 5 6 7 8)) 2) 6)
+       (= (array-end (make-array (shape 1 2 3 4 5 6 7 8)) 3) 8)))
+
+
+(pass-if "(array-start (array ...))"
+  (and #;(= (array-start (array (shape -1 -1)) 0) -1)
+       (= (array-start (array (shape -1 1) * *) 0) -1)
+       (= (array-start (array (shape 1 2 3 4 5 6 7 8) *) 0) 1)
+       (= (array-start (array (shape 1 2 3 4 5 6 7 8) *) 1) 3)
+       (= (array-start (array (shape 1 2 3 4 5 6 7 8) *) 2) 5)
+       (= (array-start (array (shape 1 2 3 4 5 6 7 8) *) 3) 7)))
+
+
+(pass-if "(array-end (array ...))"
+  (and #;(= (array-end (array (shape -1 -1)) 0) -1)
+       (= (array-end (array (shape -1 1) * *) 0) 1)
+       (= (array-end (array (shape 1 2 3 4 5 6 7 8) *) 0) 2)
+       (= (array-end (array (shape 1 2 3 4 5 6 7 8) *) 1) 4)
+       (= (array-end (array (shape 1 2 3 4 5 6 7 8) *) 2) 6)
+       (= (array-end (array (shape 1 2 3 4 5 6 7 8) *) 3) 8)))
+
+
+(pass-if "array-ref of make-array with arguments"
+  (and (eq? (array-ref (make-array (shape) 'a)) 'a)
+       (eq? (array-ref (make-array (shape -1 1) 'b) -1) 'b)
+       (eq? (array-ref (make-array (shape -1 1) 'c) 0) 'c)
+       (eq? (array-ref (make-array (shape 1 2 3 4 5 6 7 8) 'd) 1 3 5 7) 'd)))
+
+
+(pass-if "array-ref of make-array with vector"
+  (and (eq? (array-ref (make-array (shape) 'a) '#()) 'a)
+       (eq? (array-ref (make-array (shape -1 1) 'b) '#(-1)) 'b)
+       (eq? (array-ref (make-array (shape -1 1) 'c) '#(0)) 'c)
+       (eq? (array-ref (make-array (shape 1 2 3 4 5 6 7 8) 'd)
+                       '#(1 3 5 7))
+            'd)))
+
+
+(pass-if "(array-ref of make-array with array"
+  (and (eq? (array-ref (make-array (shape) 'a)
+                       (array (shape 0 0)))
+            'a)
+       (eq? (array-ref (make-array (shape -1 1) 'b)
+                       (array (shape 0 1) -1))
+            'b)
+       (eq? (array-ref (make-array (shape -1 1) 'c)
+                       (array (shape 0 1) 0))
+            'c)
+       (eq? (array-ref (make-array (shape 1 2 3 4 5 6 7 8) 'd)
+                       (array (shape 0 4) 1 3 5 7))
+            'd)))
+
+
+(pass-if "array-set! with arguments"
+  (and (let ((arr (make-array (shape) 'o)))
+         (array-set! arr 'a)
+         (eq? (array-ref arr) 'a))
+       (let ((arr (make-array (shape -1 1) 'o)))
+         (array-set! arr -1 'b)
+         (array-set! arr 0 'c)
+         (and (eq? (array-ref arr -1) 'b)
+              (eq? (array-ref arr 0) 'c)))
+       (let ((arr (make-array (shape 1 2 3 4 5 6 7 8) 'o)))
+         (array-set! arr 1 3 5 7 'd)
+         (eq? (array-ref arr 1 3 5 7) 'd))))
+
+
+(pass-if "array-set! with vector"
+  (and (let ((arr (make-array (shape) 'o)))
+         (array-set! arr '#() 'a)
+         (eq? (array-ref arr) 'a))
+       (let ((arr (make-array (shape -1 1) 'o)))
+         (array-set! arr '#(-1) 'b)
+         (array-set! arr '#(0) 'c)
+         (and (eq? (array-ref arr -1) 'b)
+              (eq? (array-ref arr 0) 'c)))
+       (let ((arr (make-array (shape 1 2 3 4 5 6 7 8) 'o)))
+         (array-set! arr '#(1 3 5 7) 'd)
+         (eq? (array-ref arr 1 3 5 7) 'd))))
+
+
+(pass-if "array-set! with arguments"
+  (and (let ((arr (make-array (shape) 'o)))
+         (array-set! arr 'a)
+         (eq? (array-ref arr) 'a))
+       (let ((arr (make-array (shape -1 1) 'o)))
+         (array-set! arr (array (shape 0 1) -1) 'b)
+         (array-set! arr (array (shape 0 1) 0) 'c)
+         (and (eq? (array-ref arr -1) 'b)
+              (eq? (array-ref arr 0) 'c)))
+       (let ((arr (make-array (shape 1 2 3 4 5 6 7 8) 'o)))
+         (array-set! arr (array (shape 0 4) 1 3 5 7) 'd)
+         (eq? (array-ref arr 1 3 5 7) 'd))))
+
+
+;;; Share and change:
+;;;
+;;;  org     brk     swp            box
+;;;
+;;;   0 1     1 2     5 6
+;;; 6 a b   2 a b   3 d c   0 2 4 6 8: e
+;;; 7 c d   3 e f   4 f e
+;;; 8 e f
+
+(pass-if "shared change"
+  (let* ((org (array (shape 6 9 0 2) 'a 'b 'c 'd 'e 'f))
+         (brk (share-array
+               org
+               (shape 2 4 1 3)
+               (lambda (r k)
+                 (values
+                   (+ 6 (* 2 (- r 2)))
+                   (- k 1)))))
+         (swp (share-array
+               org
+               (shape 3 5 5 7)
+               (lambda (r k)
+                 (values
+                   (+ 7 (- r 3))
+                   (- 1 (- k 5))))))
+         (box (share-array
+               swp
+               (shape 0 1 2 3 4 5 6 7 8 9)
+               (lambda _ (values 4 6))))
+         (org-contents (lambda ()
+                         (list (array-ref org 6 0) (array-ref org 6 1)
+                               (array-ref org 7 0) (array-ref org 7 1)
+                               (array-ref org 8 0) (array-ref org 8 1))))
+         (brk-contents (lambda ()
+                         (list (array-ref brk 2 1) (array-ref brk 2 2)
+                               (array-ref brk 3 1) (array-ref brk 3 2))))
+         (swp-contents (lambda ()
+                         (list (array-ref swp 3 5) (array-ref swp 3 6)
+                               (array-ref swp 4 5) (array-ref swp 4 6))))
+         (box-contents (lambda ()
+                         (list (array-ref box 0 2 4 6 8)))))
+    (and (equal? (org-contents) '(a b c d e f))
+         (equal? (brk-contents) '(a b e f))
+         (equal? (swp-contents) '(d c f e))
+         (equal? (box-contents) '(e))
+         (begin (array-set! org 6 0 'x) #t)
+         (equal? (org-contents) '(x b c d e f))
+         (equal? (brk-contents) '(x b e f))
+         (equal? (swp-contents) '(d c f e))
+         (equal? (box-contents) '(e))
+         (begin (array-set! brk 3 1 'y) #t)
+         (equal? (org-contents) '(x b c d y f))
+         (equal? (brk-contents) '(x b y f))
+         (equal? (swp-contents) '(d c f y))
+         (equal? (box-contents) '(y))
+         (begin (array-set! swp 4 5 'z) #t)
+         (equal? (org-contents) '(x b c d y z))
+         (equal? (brk-contents) '(x b y z))
+         (equal? (swp-contents) '(d c z y))
+         (equal? (box-contents) '(y))
+         (begin (array-set! box 0 2 4 6 8 'e) #t)
+         (equal? (org-contents) '(x b c d e z))
+         (equal? (brk-contents) '(x b e z))
+         (equal? (swp-contents) '(d c z e))
+         (equal? (box-contents) '(e)))))
+
+
+;;; Check that arrays copy the shape specification
+
+(pass-if "array-set! of shape"
+  (let ((shp (shape 10 12)))
+    (let ((arr (make-array shp))
+          (ars (array shp * *))
+          (art (share-array (make-array shp) shp (lambda (k) k))))
+      (array-set! shp 0 0 '?)
+      (array-set! shp 0 1 '!)
+      (and (= (array-rank shp) 2)
+           (= (array-start shp 0) 0)
+           (= (array-end shp 0) 1)
+           (= (array-start shp 1) 0)
+           (= (array-end shp 1) 2)
+           (eq? (array-ref shp 0 0) '?)
+           (eq? (array-ref shp 0 1) '!)
+           (= (array-rank arr) 1)
+           (= (array-start arr 0) 10)
+           (= (array-end arr 0) 12)
+           (= (array-rank ars) 1)
+           (= (array-start ars 0) 10)
+           (= (array-end ars 0) 12)
+           (= (array-rank art) 1)
+           (= (array-start art 0) 10)
+           (= (array-end art 0) 12)))))
+
+
+;;; Check that index arrays work even when they share
+;;;
+;;; arr       ixn
+;;;   5  6      0 1
+;;; 4 nw ne   0 4 6
+;;; 5 sw se   1 5 4
+
+(with-test-prefix "array access with sharing index array"
+  (let ((arr (array (shape 4 6 5 7) 'nw 'ne 'sw 'se))
+        (ixn (array (shape 0 2 0 2) 4 6 5 4)))
+    (let ((col0 (share-array
+                 ixn
+                 (shape 0 2)
+                 (lambda (k)
+                   (values k 0))))
+          (row0 (share-array
+                 ixn
+                 (shape 0 2)
+                 (lambda (k)
+                   (values 0 k))))
+          (wor1 (share-array
+                 ixn
+                 (shape 0 2)
+                 (lambda (k)
+                   (values 1 (- 1 k)))))
+          (cod (share-array
+                ixn
+                (shape 0 2)
+                (lambda (k)
+                  (case k
+                    ((0) (values 1 0))
+                    ((1) (values 0 1))))))
+          (box (share-array
+                ixn
+                (shape 0 2)
+                (lambda (k)
+                  (values 1 0)))))
+      (pass-if "basic reference"
+        (and (eq? (array-ref arr col0) 'nw)
+             (eq? (array-ref arr row0) 'ne)
+             (eq? (array-ref arr wor1) 'nw)
+             (eq? (array-ref arr cod) 'se)
+             (eq? (array-ref arr box) 'sw)))
+      (pass-if "after modification"
+        (and
+          (begin
+            (array-set! arr col0 'ul)
+            (array-set! arr row0 'ur)
+            (array-set! arr cod 'lr)
+            (array-set! arr box 'll)
+            #t)
+          (eq? (array-ref arr 4 5) 'ul)
+          (eq? (array-ref arr 4 6) 'ur)
+          (eq? (array-ref arr 5 5) 'll)
+          (eq? (array-ref arr 5 6) 'lr)
+          (begin
+            (array-set! arr wor1 'xx)
+            (eq? (array-ref arr 4 5) 'xx)))))))
+
+
+;;; Check that shape arrays work even when they share
+;;;
+;;; arr             shp       shq       shr       shs
+;;;    1  2  3  4      0  1      0  1      0  1      0  1 
+;;; 1 10 12 16 20   0 10 12   0 12 20   0 10 10   0 12 12
+;;; 2 10 11 12 13   1 10 11   1 11 13   1 11 12   1 12 12
+;;;                                     2 12 16
+;;;                                     3 13 20
+
+(pass-if "sharing shape array"
+  (let ((arr (array (shape 1 3 1 5) 10 12 16 20 10 11 12 13)))
+    (let ((shp (share-array
+                arr
+                (shape 0 2 0 2)
+                (lambda (r k)
+                  (values (+ r 1) (+ k 1)))))
+          (shq (share-array
+                arr
+                (shape 0 2 0 2)
+                (lambda (r k)
+                  (values (+ r 1) (* 2 (+ 1 k))))))
+          (shr (share-array
+                arr
+                (shape 0 4 0 2)
+                (lambda (r k)
+                  (values (- 2 k) (+ r 1)))))
+          (shs (share-array
+                arr
+                (shape 0 2 0 2)
+                (lambda (r k)
+                  (values 2 3)))))
+      (and (let ((arr-p (make-array shp)))
+             (and (= (array-rank arr-p) 2)
+                  (= (array-start arr-p 0) 10)
+                  (= (array-end arr-p 0) 12)
+                  (= (array-start arr-p 1) 10)
+                  (= (array-end arr-p 1) 11)))
+           (let ((arr-q (array shq * * * *  * * * *  * * * *  * * * *)))
+             (and (= (array-rank arr-q) 2)
+                  (= (array-start arr-q 0) 12)
+                  (= (array-end arr-q 0) 20)
+                  (= (array-start arr-q 1) 11)
+                  (= (array-end arr-q 1) 13)))
+           (let ((arr-r (share-array
+                         (array (shape) *)
+                         shr
+                         (lambda _ (values)))))
+             (and (= (array-rank arr-r) 4)
+                  (= (array-start arr-r 0) 10)
+                  (= (array-end arr-r 0) 10)
+                  (= (array-start arr-r 1) 11)
+                  (= (array-end arr-r 1) 12)
+                  (= (array-start arr-r 2) 12)
+                  (= (array-end arr-r 2) 16)
+                  (= (array-start arr-r 3) 13)
+                  (= (array-end arr-r 3) 20)))
+           (let ((arr-s (make-array shs)))
+             (and (= (array-rank arr-s) 2)
+                  (= (array-start arr-s 0) 12)
+                  (= (array-end arr-s 0) 12)
+                  (= (array-start arr-s 1) 12)
+                  (= (array-end arr-s 1) 12)))))))
+
+
+(let ((super (array (shape 4 7 4 7)
+                    1 * *
+                    * 2 *
+                    * * 3))
+      (subshape (share-array
+                 (array (shape 0 2 0 3)
+                        * 4 *
+                        * 7 *)
+                 (shape 0 1 0 2)
+                 (lambda (r k)
+                   (values k 1)))))
+  (let ((sub (share-array super subshape (lambda (k) (values k k)))))
+                                        ;(array-equal? subshape (shape 4 7))
+    (pass-if "sharing subshape"
+      (and (= (array-rank subshape) 2)
+           (= (array-start subshape 0) 0)
+           (= (array-end subshape 0) 1)
+           (= (array-start subshape 1) 0)
+           (= (array-end subshape 1) 2)
+           (= (array-ref subshape 0 0) 4)
+           (= (array-ref subshape 0 1) 7)))
+                                        ;(array-equal? sub (array (shape 4 7) 
1 2 3))
+    (pass-if "sharing with sharing subshape"
+      (and (= (array-rank sub) 1)
+           (= (array-start sub 0) 4)
+           (= (array-end sub 0) 7)
+           (= (array-ref sub 4) 1)
+           (= (array-ref sub 5) 2)
+           (= (array-ref sub 6) 3)))))
+
-- 
2.1.4




reply via email to

[Prev in Thread] Current Thread [Next in Thread]