[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
[Prev in Thread] |
Current Thread |
[Next in Thread] |
- [PATCH] Add SRFI-25 implementation,
Andreas Rottmann <=