From mboxrd@z Thu Jan 1 00:00:00 1970 Path: news.gmane.org!not-for-mail From: Andreas Rottmann Newsgroups: gmane.lisp.guile.devel Subject: [PATCH] Add SRFI-25 implementation Date: Mon, 27 Jul 2015 23:59:41 +0200 Message-ID: <1438034381-18809-1-git-send-email-a.rottmann@gmx.at> NNTP-Posting-Host: plane.gmane.org Mime-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: quoted-printable X-Trace: ger.gmane.org 1438034439 31851 80.91.229.3 (27 Jul 2015 22:00:39 GMT) X-Complaints-To: usenet@ger.gmane.org NNTP-Posting-Date: Mon, 27 Jul 2015 22:00:39 +0000 (UTC) To: guile-devel Original-X-From: guile-devel-bounces+guile-devel=m.gmane.org@gnu.org Tue Jul 28 00:00:21 2015 Return-path: Envelope-to: guile-devel@m.gmane.org Original-Received: from lists.gnu.org ([208.118.235.17]) by plane.gmane.org with esmtp (Exim 4.69) (envelope-from ) id 1ZJqRX-0008Dv-37 for guile-devel@m.gmane.org; Tue, 28 Jul 2015 00:00:19 +0200 Original-Received: from localhost ([::1]:55916 helo=lists.gnu.org) by lists.gnu.org with esmtp (Exim 4.71) (envelope-from ) id 1ZJqRW-0002LC-FG for guile-devel@m.gmane.org; Mon, 27 Jul 2015 18:00:18 -0400 Original-Received: from eggs.gnu.org ([2001:4830:134:3::10]:40300) by lists.gnu.org with esmtp (Exim 4.71) (envelope-from ) id 1ZJqRP-0002A8-H2 for guile-devel@gnu.org; Mon, 27 Jul 2015 18:00:15 -0400 Original-Received: from Debian-exim by eggs.gnu.org with spam-scanned (Exim 4.71) (envelope-from ) id 1ZJqRK-0003HT-5q for guile-devel@gnu.org; Mon, 27 Jul 2015 18:00:11 -0400 Original-Received: from mout.gmx.net ([212.227.17.22]:57898) by eggs.gnu.org with esmtp (Exim 4.71) (envelope-from ) id 1ZJqRJ-0003Ad-O0 for guile-devel@gnu.org; Mon, 27 Jul 2015 18:00:06 -0400 Original-Received: from delenn.home.rotty.xx.vu ([91.119.248.54]) by mail.gmx.com (mrgmx103) with ESMTPSA (Nemesis) id 0MgbvP-1ZVlBt3UKV-00Nwx7 for ; Tue, 28 Jul 2015 00:00:03 +0200 Original-Received: by delenn.home.rotty.xx.vu (Postfix, from userid 1000) id 878CC3202EE; Tue, 28 Jul 2015 00:00:00 +0200 (CEST) X-Mailer: git-send-email 2.1.4 X-Provags-ID: V03:K0:5LlynrLY7PALxBELQ+dqe33u+NabxHSdRm7QPNGjxCBUAi8n1Mw Pbo6u0paPJzgUkeaXEWDVKSVAHTpmS4PLuWTOF8ZT5eHqZtQ6qIzNzFYG6G0JBC2PSNXkFx 9c+zyLaT3dQlnD51QiqDi23Noe4z2g1K1MMQfEjDHfR92qkk8+7+M0bKXM2vZysQWuua7VO b+SlwKRhwgUaRbSNv2sig== X-UI-Out-Filterresults: notjunk:1;V01:K0:OmUy+IJxYQ4=:97cC+XjKgrOfhm1hZEE4JJ QrvjI3o38/8fObrvT0HXa+D+Szer+qZVS7FLWJi+ueEiAgcG5ft9Yvdw94zep5AxdOirZr4AH oXYoN6yvuaRhGeod1SIM5v1ZFGU5+w6GPz+JVVuz0joBkN2q+x81MTZOOCldMc2QnhzBZ5mp3 KZ/uTY29osgtK1mkGPzxP7MU7tqmnwOgyam5m87jP/w2xDyzxt/ouPEZOY3mustcNGcRVodj/ 0eIavFZ19IYsqQVg5rdZj0YTa10FXeMXReXjqmd1aiPPZxKGtTpeJmvOUSs+yjxHTqhwt0HFC 3N4lF7tlhJvSAFBq0ZAms/deCXePU8+CgkUtn6zEeR5Xu2N6WK2OtQ9pKW/maQbm9oPYihI+k EjRraiKhtg55UvWD5UKTZxP7bJqvzYe/cvdtAqD6sBbx0wccf2oH+ntBmGmLnv7+orQ339bWk vDr8mMzF7gaXyqBG5mK2B6FJsrH5P0sY/wQLYtr8o/WINycxEIdAfmHsS+nrrPbX9bBm8snVM J7xsYwXV8+o35IbIT1V2Hh07KETQZ3CGIYTXZUC9sy8cW1vZx+OeENql9xZuUUVbGCizV4r07 b9EgmYy0Umuc8CnQGOUTtPpwZU9ryQPZ+Q+Ly6dvveoiMx++8so+xJXbmgN53sRnJ7nS4Wc+B 7/m3W6izCnJ6V2Y2gqxdqBQCTxPmTqux7J7MfTeY4p3g2/I/dsuLkzxoZ9w6724XryC0= X-detected-operating-system: by eggs.gnu.org: GNU/Linux 3.x [generic] X-Received-From: 212.227.17.22 X-BeenThere: guile-devel@gnu.org X-Mailman-Version: 2.1.14 Precedence: list List-Id: "Developers list for Guile, the GNU extensibility library" List-Unsubscribe: , List-Archive: List-Post: List-Help: List-Subscribe: , Errors-To: guile-devel-bounces+guile-devel=m.gmane.org@gnu.org Original-Sender: guile-devel-bounces+guile-devel=m.gmane.org@gnu.org Xref: news.gmane.org gmane.lisp.guile.devel:17778 Archived-At: 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. =20 Please send Guile bug reports to bug-guile@gnu.org. =20 +Changes in 2.0.12 (since 2.0.11): =20 +* 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. + +=0C Changes in 2.0.11 (since 2.0.10): =20 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. -@c Copyright (C) 1996, 1997, 2000-2004, 2006, 2007-2014 +@c Copyright (C) 1996, 1997, 2000-2004, 2006, 2007-2015 @c Free Software Foundation, Inc. @c See the file guile.texi for copying conditions. =20 @@ -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. =20 The SRFI-23 @code{error} procedure is always available. =20 +@node SRFI-25 +@subsection SRFI-25 - Multi-dimensional Array Primitives +@cindex SRFI-25 +@cindex array, multi-dimensional +@cindex 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, + +@example +(use-modules (srfi srfi-25)) +@end example + +Note that this will override @code{make-array}, @code{array-ref} and +@code{array-set!}. @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 +@uref{http://srfi.schemers.org/srfi-45/srfi-45.html, the specification +of SRFI-45} written by Jussi Piitulainen. + +@c Copyright (C) Jussi Piitulainen (2001). All Rights Reserved. + +@c Permission is hereby granted, free of charge, to any person obtaining= a +@c copy of this software and associated documentation files (the +@c "Software"), to deal in the Software without restriction, including +@c without limitation the rights to use, copy, modify, merge, publish, +@c distribute, sublicense, and/or sell copies of the Software, and to +@c permit persons to whom the Software is furnished to do so, subject to +@c the following conditions: + +@c The above copyright notice and this permission notice shall be includ= ed +@c in all copies or substantial portions of the Software. + +@c THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRE= SS +@c OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF +@c MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND +@c NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS B= E +@c LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTIO= N +@c OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION +@c 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. + +@example +(vector-set! v k o) +(string-set! s k c) +(array-set! a k o) +@end example + + +Likewise, @code{make-array} matches @code{make-vector} and +@code{make-string}. An analogue to @code{vector}, @code{string} and +@code{list} 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.) + +@subsubheading 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{(<=3D @var{b} @var{e})}. A valid index along t= he +dimension is an exact integer @var{k} that satisfies both +@code{(<=3D @var{b} @var{k})} and @code{(< @var{k} @var{e})}. The length +of the array along the dimension is the difference +@code{(- @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)}: + +@defun array? obj +Returns @code{#t} if @var{obj} is an array, otherwise returns +@code{#f}. Note that this procedure returns @code{#t} for both SRFI-25 +and Guile's native arrays. +@end defun + +@defun make-array shape +@defunx make-array shape obj +Returns a newly allocated array whose shape is given by @var{shape}. If +@var{obj} 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}. +@end defun + +@defun 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 +@var{b0 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{(<=3D=C2=A0@var{bk}=C2=A0@v= ar{jk})} and +@code{(< @var{jk} @var{ek})}. + +The shape of a @var{d}-dimensional array is a @math{@var{d} =C3=97 @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{(<=3D 0 @var{k}= )} +and @code{(< @var{k} @var{d})}. +@end defun + +@defun 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}. +@end defun + +@defun array-rank array +Returns the number of dimensions of @var{array}. +@example +(array-rank (make-array (shape 1 2 3 4))) +@end example +Returns @samp{2}. +@end defun + +@defun array-start array k +Returns the lower bound for the index along dimension @var{k}. +@end defun + +@defun array-end array k +Returns the upper bound for the index along dimension @var{k}. +@end defun + +@defun array-ref array k ... +@defunx 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 ...}. + +@example +(array-ref (array (shape 0 2 0 3) + 'uno 'dos 'tres + 'cuatro 'cinco 'seis) + 1 0) +@end example + +Returns @samp{cuatro}. + +@example +(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)))) +@end example + +Returns @samp{(3 1 4)}. +@end defun + +@defun array-set! array k ... obj +@defunx 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 ...}. + +@example +(let ((a (make-array + (shape 4 5 4 5 4 5)))) + (array-set! a 4 4 4 'huuhkaja) + (array-ref a 4 4 4)) +@end example +Returns @samp{huuhkaja}. +@end defun + +@defun share-array array shape proc +Returns a new array of shape @var{shape} that shares elements of +@var{array} 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}. +@example +(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))) + ((=3D k 4)) + (array-set! d k 1)) + i)) +@end 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. +@end 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 =3D \ 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 +;; . + +;;; 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 (<=3D 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 (=3D 1 (array-rank array)) + (=3D 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 =3D 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.tes= t 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 (=3D (array-rank (shape)) 2) + (=3D (array-rank (shape -1 -1)) 2) + (=3D (array-rank (shape -1 1)) 2) + (=3D (array-rank (shape 1 2 3 4 5 6 7 8)) 2))) + + +(pass-if "(array-rank (make-array ...))" + (and (=3D (array-rank (make-array (shape))) 0) + (=3D (array-rank (make-array (shape -1 -1))) 1) + (=3D (array-rank (make-array (shape -1 1))) 1) + (=3D (array-rank (make-array (shape 1 2 3 4 5 6 7 8))) 4))) + + +(pass-if "(array-rank (array ...))" + (and (=3D (array-rank (array (shape) *)) 0) + (=3D (array-rank (array (shape -1 -1))) 1) + (=3D (array-rank (array (shape -1 1) * *)) 1) + (=3D (array-rank (array (shape 1 2 3 4 5 6 7 8) *)) 4))) + + +(pass-if "(array-start (shape ...))" + (and (=3D (array-start (shape -1 -1) 0) 0) + (=3D (array-start (shape -1 -1) 1) 0) + (=3D (array-start (shape -1 1) 0) 0) + (=3D (array-start (shape -1 1) 1) 0) + (=3D (array-start (shape 1 2 3 4 5 6 7 8) 0) 0) + (=3D (array-start (shape 1 2 3 4 5 6 7 8) 1) 0))) + + +(pass-if "(array-end (shape ...))" + (and (=3D (array-end (shape -1 -1) 0) 1) + (=3D (array-end (shape -1 -1) 1) 2) + (=3D (array-end (shape -1 1) 0) 1) + (=3D (array-end (shape -1 1) 1) 2) + (=3D (array-end (shape 1 2 3 4 5 6 7 8) 0) 4) + (=3D (array-end (shape 1 2 3 4 5 6 7 8) 1) 2))) + + +(pass-if "(array-start (make-array ...))" + (and #;(=3D (array-start (make-array (shape -1 -1)) 0) -1) + (=3D (array-start (make-array (shape -1 1)) 0) -1) + (=3D (array-start (make-array (shape 1 2 3 4 5 6 7 8)) 0) 1) + (=3D (array-start (make-array (shape 1 2 3 4 5 6 7 8)) 1) 3) + (=3D (array-start (make-array (shape 1 2 3 4 5 6 7 8)) 2) 5) + (=3D (array-start (make-array (shape 1 2 3 4 5 6 7 8)) 3) 7))) + + +(pass-if "(array-end (make-array ...))" + (and #;(=3D (array-end (make-array (shape -1 -1)) 0) -1) + (=3D (array-end (make-array (shape -1 1)) 0) 1) + (=3D (array-end (make-array (shape 1 2 3 4 5 6 7 8)) 0) 2) + (=3D (array-end (make-array (shape 1 2 3 4 5 6 7 8)) 1) 4) + (=3D (array-end (make-array (shape 1 2 3 4 5 6 7 8)) 2) 6) + (=3D (array-end (make-array (shape 1 2 3 4 5 6 7 8)) 3) 8))) + + +(pass-if "(array-start (array ...))" + (and #;(=3D (array-start (array (shape -1 -1)) 0) -1) + (=3D (array-start (array (shape -1 1) * *) 0) -1) + (=3D (array-start (array (shape 1 2 3 4 5 6 7 8) *) 0) 1) + (=3D (array-start (array (shape 1 2 3 4 5 6 7 8) *) 1) 3) + (=3D (array-start (array (shape 1 2 3 4 5 6 7 8) *) 2) 5) + (=3D (array-start (array (shape 1 2 3 4 5 6 7 8) *) 3) 7))) + + +(pass-if "(array-end (array ...))" + (and #;(=3D (array-end (array (shape -1 -1)) 0) -1) + (=3D (array-end (array (shape -1 1) * *) 0) 1) + (=3D (array-end (array (shape 1 2 3 4 5 6 7 8) *) 0) 2) + (=3D (array-end (array (shape 1 2 3 4 5 6 7 8) *) 1) 4) + (=3D (array-end (array (shape 1 2 3 4 5 6 7 8) *) 2) 6) + (=3D (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 (=3D (array-rank shp) 2) + (=3D (array-start shp 0) 0) + (=3D (array-end shp 0) 1) + (=3D (array-start shp 1) 0) + (=3D (array-end shp 1) 2) + (eq? (array-ref shp 0 0) '?) + (eq? (array-ref shp 0 1) '!) + (=3D (array-rank arr) 1) + (=3D (array-start arr 0) 10) + (=3D (array-end arr 0) 12) + (=3D (array-rank ars) 1) + (=3D (array-start ars 0) 10) + (=3D (array-end ars 0) 12) + (=3D (array-rank art) 1) + (=3D (array-start art 0) 10) + (=3D (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=20 +;;; 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 (=3D (array-rank arr-p) 2) + (=3D (array-start arr-p 0) 10) + (=3D (array-end arr-p 0) 12) + (=3D (array-start arr-p 1) 10) + (=3D (array-end arr-p 1) 11))) + (let ((arr-q (array shq * * * * * * * * * * * * * * * *))) + (and (=3D (array-rank arr-q) 2) + (=3D (array-start arr-q 0) 12) + (=3D (array-end arr-q 0) 20) + (=3D (array-start arr-q 1) 11) + (=3D (array-end arr-q 1) 13))) + (let ((arr-r (share-array + (array (shape) *) + shr + (lambda _ (values))))) + (and (=3D (array-rank arr-r) 4) + (=3D (array-start arr-r 0) 10) + (=3D (array-end arr-r 0) 10) + (=3D (array-start arr-r 1) 11) + (=3D (array-end arr-r 1) 12) + (=3D (array-start arr-r 2) 12) + (=3D (array-end arr-r 2) 16) + (=3D (array-start arr-r 3) 13) + (=3D (array-end arr-r 3) 20))) + (let ((arr-s (make-array shs))) + (and (=3D (array-rank arr-s) 2) + (=3D (array-start arr-s 0) 12) + (=3D (array-end arr-s 0) 12) + (=3D (array-start arr-s 1) 12) + (=3D (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 (=3D (array-rank subshape) 2) + (=3D (array-start subshape 0) 0) + (=3D (array-end subshape 0) 1) + (=3D (array-start subshape 1) 0) + (=3D (array-end subshape 1) 2) + (=3D (array-ref subshape 0 0) 4) + (=3D (array-ref subshape 0 1) 7))) + ;(array-equal? sub (array (shape= 4 7) 1 2 3)) + (pass-if "sharing with sharing subshape" + (and (=3D (array-rank sub) 1) + (=3D (array-start sub 0) 4) + (=3D (array-end sub 0) 7) + (=3D (array-ref sub 4) 1) + (=3D (array-ref sub 5) 2) + (=3D (array-ref sub 6) 3))))) + --=20 2.1.4