diff options
Diffstat (limited to 'test-suite/tests/arrays.test')
-rw-r--r-- | test-suite/tests/arrays.test | 1055 |
1 files changed, 1055 insertions, 0 deletions
diff --git a/test-suite/tests/arrays.test b/test-suite/tests/arrays.test new file mode 100644 index 000000000..e913e30a2 --- /dev/null +++ b/test-suite/tests/arrays.test @@ -0,0 +1,1055 @@ +;;;; arrays.test --- tests guile's uniform arrays -*- scheme -*- +;;;; +;;;; Copyright 2004, 2006, 2009, 2010, 2011, 2012, 2013, 2014, 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, write to the Free Software +;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA + +(define-module (test-suite test-arrays) + #:use-module ((system base compile) #:select (compile)) + #:use-module (test-suite lib) + #:use-module (srfi srfi-4) + #:use-module (srfi srfi-4 gnu)) + +(define (array-row a i) + (make-shared-array a (lambda (j) (list i j)) + (cadr (array-dimensions a)))) + +(define (array-col a j) + (make-shared-array a (lambda (i) (list i j)) + (car (array-dimensions a)))) + +(define exception:wrong-num-indices + (cons 'misc-error "^wrong number of indices.*")) + +(define exception:length-non-negative + (cons 'read-error ".*array length must be non-negative.*")) + +(define exception:wrong-type-arg + (cons #t "Wrong type")) + +(define exception:mapping-out-of-range + (cons 'misc-error "^mapping out of range")) ;; per scm_make_shared_array + +;;; +;;; array? +;;; + +(with-test-prefix "array?" + + (let ((bool (make-typed-array 'b #t '(5 6))) + (char (make-typed-array 'a #\a '(5 6))) + (byte (make-typed-array 'u8 0 '(5 6))) + (short (make-typed-array 's16 0 '(5 6))) + (ulong (make-typed-array 'u32 0 '(5 6))) + (long (make-typed-array 's32 0 '(5 6))) + (longlong (make-typed-array 's64 0 '(5 6))) + (float (make-typed-array 'f32 0 '(5 6))) + (double (make-typed-array 'f64 0 '(5 6))) + (complex (make-typed-array 'c64 0 '(5 6))) + (scm (make-typed-array #t 0 '(5 6)))) + + (with-test-prefix "is bool" + (pass-if (eq? #t (typed-array? bool 'b))) + (pass-if (eq? #f (typed-array? char 'b))) + (pass-if (eq? #f (typed-array? byte 'b))) + (pass-if (eq? #f (typed-array? short 'b))) + (pass-if (eq? #f (typed-array? ulong 'b))) + (pass-if (eq? #f (typed-array? long 'b))) + (pass-if (eq? #f (typed-array? longlong 'b))) + (pass-if (eq? #f (typed-array? float 'b))) + (pass-if (eq? #f (typed-array? double 'b))) + (pass-if (eq? #f (typed-array? complex 'b))) + (pass-if (eq? #f (typed-array? scm 'b)))) + + (with-test-prefix "is char" + (pass-if (eq? #f (typed-array? bool 'a))) + (pass-if (eq? #t (typed-array? char 'a))) + (pass-if (eq? #f (typed-array? byte 'a))) + (pass-if (eq? #f (typed-array? short 'a))) + (pass-if (eq? #f (typed-array? ulong 'a))) + (pass-if (eq? #f (typed-array? long 'a))) + (pass-if (eq? #f (typed-array? longlong 'a))) + (pass-if (eq? #f (typed-array? float 'a))) + (pass-if (eq? #f (typed-array? double 'a))) + (pass-if (eq? #f (typed-array? complex 'a))) + (pass-if (eq? #f (typed-array? scm 'a)))) + + (with-test-prefix "is byte" + (pass-if (eq? #f (typed-array? bool 'u8))) + (pass-if (eq? #f (typed-array? char 'u8))) + (pass-if (eq? #t (typed-array? byte 'u8))) + (pass-if (eq? #f (typed-array? short 'u8))) + (pass-if (eq? #f (typed-array? ulong 'u8))) + (pass-if (eq? #f (typed-array? long 'u8))) + (pass-if (eq? #f (typed-array? longlong 'u8))) + (pass-if (eq? #f (typed-array? float 'u8))) + (pass-if (eq? #f (typed-array? double 'u8))) + (pass-if (eq? #f (typed-array? complex 'u8))) + (pass-if (eq? #f (typed-array? scm 'u8)))) + + (with-test-prefix "is short" + (pass-if (eq? #f (typed-array? bool 's16))) + (pass-if (eq? #f (typed-array? char 's16))) + (pass-if (eq? #f (typed-array? byte 's16))) + (pass-if (eq? #t (typed-array? short 's16))) + (pass-if (eq? #f (typed-array? ulong 's16))) + (pass-if (eq? #f (typed-array? long 's16))) + (pass-if (eq? #f (typed-array? longlong 's16))) + (pass-if (eq? #f (typed-array? float 's16))) + (pass-if (eq? #f (typed-array? double 's16))) + (pass-if (eq? #f (typed-array? complex 's16))) + (pass-if (eq? #f (typed-array? scm 's16)))) + + (with-test-prefix "is ulong" + (pass-if (eq? #f (typed-array? bool 'u32))) + (pass-if (eq? #f (typed-array? char 'u32))) + (pass-if (eq? #f (typed-array? byte 'u32))) + (pass-if (eq? #f (typed-array? short 'u32))) + (pass-if (eq? #t (typed-array? ulong 'u32))) + (pass-if (eq? #f (typed-array? long 'u32))) + (pass-if (eq? #f (typed-array? longlong 'u32))) + (pass-if (eq? #f (typed-array? float 'u32))) + (pass-if (eq? #f (typed-array? double 'u32))) + (pass-if (eq? #f (typed-array? complex 'u32))) + (pass-if (eq? #f (typed-array? scm 'u32)))) + + (with-test-prefix "is long" + (pass-if (eq? #f (typed-array? bool 's32))) + (pass-if (eq? #f (typed-array? char 's32))) + (pass-if (eq? #f (typed-array? byte 's32))) + (pass-if (eq? #f (typed-array? short 's32))) + (pass-if (eq? #f (typed-array? ulong 's32))) + (pass-if (eq? #t (typed-array? long 's32))) + (pass-if (eq? #f (typed-array? longlong 's32))) + (pass-if (eq? #f (typed-array? float 's32))) + (pass-if (eq? #f (typed-array? double 's32))) + (pass-if (eq? #f (typed-array? complex 's32))) + (pass-if (eq? #f (typed-array? scm 's32)))) + + (with-test-prefix "is long long" + (pass-if (eq? #f (typed-array? bool 's64))) + (pass-if (eq? #f (typed-array? char 's64))) + (pass-if (eq? #f (typed-array? byte 's64))) + (pass-if (eq? #f (typed-array? short 's64))) + (pass-if (eq? #f (typed-array? ulong 's64))) + (pass-if (eq? #f (typed-array? long 's64))) + (pass-if (eq? #t (typed-array? longlong 's64))) + (pass-if (eq? #f (typed-array? float 's64))) + (pass-if (eq? #f (typed-array? double 's64))) + (pass-if (eq? #f (typed-array? complex 's64))) + (pass-if (eq? #f (typed-array? scm 's64)))) + + (with-test-prefix "is float" + (pass-if (eq? #f (typed-array? bool 'f32))) + (pass-if (eq? #f (typed-array? char 'f32))) + (pass-if (eq? #f (typed-array? byte 'f32))) + (pass-if (eq? #f (typed-array? short 'f32))) + (pass-if (eq? #f (typed-array? ulong 'f32))) + (pass-if (eq? #f (typed-array? long 'f32))) + (pass-if (eq? #f (typed-array? longlong 'f32))) + (pass-if (eq? #t (typed-array? float 'f32))) + (pass-if (eq? #f (typed-array? double 'f32))) + (pass-if (eq? #f (typed-array? complex 'f32))) + (pass-if (eq? #f (typed-array? scm 'f32)))) + + (with-test-prefix "is double" + (pass-if (eq? #f (typed-array? bool 'f64))) + (pass-if (eq? #f (typed-array? char 'f64))) + (pass-if (eq? #f (typed-array? byte 'f64))) + (pass-if (eq? #f (typed-array? short 'f64))) + (pass-if (eq? #f (typed-array? ulong 'f64))) + (pass-if (eq? #f (typed-array? long 'f64))) + (pass-if (eq? #f (typed-array? longlong 'f64))) + (pass-if (eq? #f (typed-array? float 'f64))) + (pass-if (eq? #t (typed-array? double 'f64))) + (pass-if (eq? #f (typed-array? complex 'f64))) + (pass-if (eq? #f (typed-array? scm 'f64)))) + + (with-test-prefix "is complex" + (pass-if (eq? #f (typed-array? bool 'c64))) + (pass-if (eq? #f (typed-array? char 'c64))) + (pass-if (eq? #f (typed-array? byte 'c64))) + (pass-if (eq? #f (typed-array? short 'c64))) + (pass-if (eq? #f (typed-array? ulong 'c64))) + (pass-if (eq? #f (typed-array? long 'c64))) + (pass-if (eq? #f (typed-array? longlong 'c64))) + (pass-if (eq? #f (typed-array? float 'c64))) + (pass-if (eq? #f (typed-array? double 'c64))) + (pass-if (eq? #t (typed-array? complex 'c64))) + (pass-if (eq? #f (typed-array? scm 'c64)))) + + (with-test-prefix "is scm" + (pass-if (eq? #f (typed-array? bool #t))) + (pass-if (eq? #f (typed-array? char #t))) + (pass-if (eq? #f (typed-array? byte #t))) + (pass-if (eq? #f (typed-array? short #t))) + (pass-if (eq? #f (typed-array? ulong #t))) + (pass-if (eq? #f (typed-array? long #t))) + (pass-if (eq? #f (typed-array? longlong #t))) + (pass-if (eq? #f (typed-array? float #t))) + (pass-if (eq? #f (typed-array? double #t))) + (pass-if (eq? #f (typed-array? complex #t))) + (pass-if (eq? #t (typed-array? scm #t)))) + + (with-test-prefix "typed-array? returns #f" + (pass-if (eq? #f (typed-array? '(1 2 3) 'c64))) + (pass-if (eq? #f (typed-array? '(1 2 3) #t))) + (pass-if (eq? #f (typed-array? 99 'c64))) + (pass-if (eq? #f (typed-array? 99 #t)))))) + +;;; +;;; array-equal? +;;; + +(with-test-prefix/c&e "array-equal?" + + (pass-if "#s16(...)" + (array-equal? #s16(1 2 3) #s16(1 2 3))) + + (pass-if "#0f64(...)" + (array-equal? #0f64(99) (make-typed-array 'f64 99))) + + (pass-if "#0(...)" + (array-equal? #0(99) (make-array 99)))) + +;;; +;;; make-shared-array +;;; + +(with-test-prefix/c&e "make-shared-array" + + ;; this failed in guile 1.8.0 + (pass-if "vector unchanged" + (let* ((a (make-array #f '(0 7))) + (s (make-shared-array a list '(0 7)))) + (array-equal? a s))) + + (pass-if-exception "vector, high too big" exception:mapping-out-of-range + (let* ((a (make-array #f '(0 7)))) + (make-shared-array a list '(0 8)))) + + (pass-if-exception "vector, low too big" exception:out-of-range + (let* ((a (make-array #f '(0 7)))) + (make-shared-array a list '(-1 7)))) + + (pass-if "truncate columns" + (array-equal? (make-shared-array #2((a b c) (d e f) (g h i)) list 3 2) + #2((a b) (d e) (g h)))) + + (pass-if "pick one column" + (array-equal? (make-shared-array #2((a b c) (d e f) (g h i)) + (lambda (i) (list i 2)) + '(0 2)) + #(c f i))) + + (pass-if "diagonal" + (array-equal? (make-shared-array #2((a b c) (d e f) (g h i)) + (lambda (i) (list i i)) + '(0 2)) + #(a e i))) + + ;; this failed in guile 1.8.0 + (pass-if "2 dims from 1 dim" + (array-equal? (make-shared-array #1(a b c d e f g h i j k l) + (lambda (i j) (list (+ (* i 3) j))) + 4 3) + #2((a b c) (d e f) (g h i) (j k l)))) + + (pass-if "reverse columns" + (array-equal? (make-shared-array #2((a b c) (d e f) (g h i)) + (lambda (i j) (list i (- 2 j))) + 3 3) + #2((c b a) (f e d) (i h g)))) + + (pass-if "fixed offset, 0 based becomes 1 based" + (let* ((x #2((a b c) (d e f) (g h i))) + (y (make-shared-array x + (lambda (i j) (list (1- i) (1- j))) + '(1 3) '(1 3)))) + (and (eq? (array-ref x 0 0) 'a) + (eq? (array-ref y 1 1) 'a)))) + + ;; this failed in guile 1.8.0 + (pass-if "stride every third element" + (array-equal? (make-shared-array #1(a b c d e f g h i j k l) + (lambda (i) (list (* i 3))) + 4) + #1(a d g j))) + + (pass-if "shared of shared" + (let* ((a #2((1 2 3) (4 5 6) (7 8 9))) + (s1 (make-shared-array a (lambda (i) (list i 1)) 3)) + (s2 (make-shared-array s1 list '(1 2)))) + (and (eqv? 5 (array-ref s2 1)) + (eqv? 8 (array-ref s2 2)))))) + + +;;; +;;; array-slice +;;; + +(with-test-prefix/c&e "array-slice" + + (pass-if "vector I" + (let ((v (vector 1 2 3))) + (array-fill! (array-slice v 1) 'a) + (array-equal? v #(1 a 3)))) + + (pass-if "vector II" + (let ((v (vector 1 2 3))) + (array-copy! #(a b c) (array-slice v)) + (array-equal? v #(a b c)))) + + (pass-if "array I" + (let ((a (list->array 2 '((1 2 3) (4 5 6))))) + (array-fill! (array-slice a 1 1) 'a) + (array-equal? a #2((1 2 3) (4 a 6))))) + + (pass-if "array II" + (let ((a (list->array 2 '((1 2 3) (4 5 6))))) + (array-copy! #(a b c) (array-slice a 1)) + (array-equal? a #2((1 2 3) (a b c))))) + + (pass-if "array III" + (let ((a (list->array 2 '((1 2 3) (4 5 6))))) + (array-copy! #2((a b c) (x y z)) (array-slice a)) + (array-equal? a #2((a b c) (x y z))))) + + (pass-if "rank 0 array" + (let ((a (make-array 77))) + (array-fill! (array-slice a) 'a) + (array-equal? a #0(a))))) + + +;;; +;;; array-cell-ref +;;; + +(with-test-prefix/c&e "array-cell-ref" + + (pass-if "vector I" + (let ((v (vector 1 2 3))) + (equal? 2 (array-cell-ref v 1)))) + + (pass-if "vector II" + (let ((v (vector 1 2 3))) + (array-copy! #(a b c) (array-cell-ref v)) + (array-equal? v #(a b c)))) + + (pass-if "array I" + (let ((a (list->array 2 '((1 2 3) (4 5 6))))) + (equal? 5 (array-cell-ref a 1 1)))) + + (pass-if "array II" + (let ((a (list->array 2 '((1 2 3) (4 5 6))))) + (array-copy! #(a b c) (array-cell-ref a 1)) + (array-equal? a #2((1 2 3) (a b c))))) + + (pass-if "array III" + (let ((a (list->array 2 '((1 2 3) (4 5 6))))) + (array-copy! #2((a b c) (x y z)) (array-cell-ref a)) + (array-equal? a #2((a b c) (x y z))))) + + (pass-if "rank 0 array" + (let ((a (make-array 77))) + (equal? (array-cell-ref a) 77)))) + + +;;; +;;; array-cell-set! +;;; + +(with-test-prefix/c&e "array-cell-set!" + + (pass-if "vector I" + (let ((v (vector 1 2 3))) + (and (eq? v (array-cell-set! v 'x 1)) + (array-equal? v #(1 x 3))))) + + (pass-if "vector II" + (let ((v (vector 1 2 3))) + (and (eq? v (array-cell-set! (array-cell-ref v) #(a b c))) + (array-equal? v #(a b c))))) + + (pass-if "array I" + (let ((a (list->array 2 '((1 2 3) (4 5 6))))) + (and (eq? a (array-cell-set! a 'x 1 1)) + (array-equal? a #2((1 2 3) (4 x 6)))))) + + (pass-if "array II" + (let ((a (list->array 2 '((1 2 3) (4 5 6))))) + (and (eq? a (array-cell-set! a #(a b c) 1)) + (array-equal? a #2((1 2 3) (a b c)))))) + + (pass-if "array III" + (let ((a (list->array 2 '((1 2 3) (4 5 6))))) + (and (eq? a (array-cell-set! a #2((a b c) (x y z)))) + (array-equal? a #2((a b c) (x y z)))))) + + (pass-if "rank 0 array" + (let ((a (make-array 77))) + (and (eq? a (array-cell-set! a 99)) + (array-equal? a #0(99)))))) + + +;;; +;;; array-contents +;;; + +(define (every-two x) (make-shared-array x (lambda (i) (list (* i 2))) 2)) + +(with-test-prefix/c&e "array-contents" + + (pass-if "0-rank array" + (let ((a (make-vector 1 77))) + (and + (eq? a (array-contents (make-shared-array a (const '(0))))) + (eq? a (array-contents (make-shared-array a (const '(0))) #t))))) + + (pass-if "simple vector" + (let* ((a (make-array 0 4))) + (eq? a (array-contents a)))) + + (pass-if "offset vector" + (let* ((a (make-array 0 '(1 4)))) + (array-copy! #(1 2 3 4) (array-contents a)) + (array-equal? #1@1(1 2 3 4) a))) + + (pass-if "offset vector, strict" + (let* ((a (make-array 0 '(1 4)))) + (array-copy! #(1 2 3 4) (array-contents a #t)) + (array-equal? #1@1(1 2 3 4) a))) + + (pass-if "stepped vector" + (let* ((a (make-array 0 4))) + (array-copy! #(99 66) (array-contents (every-two a))) + (array-equal? #(99 0 66 0) a))) + + ;; this failed in 2.0.9. + (pass-if "stepped vector, strict" + (let* ((a (make-array 0 4))) + (not (array-contents (every-two a) #t)))) + + (pass-if "plain rank 2 array" + (let* ((a (make-array 0 2 2))) + (array-copy! #(1 2 3 4) (array-contents a #t)) + (array-equal? #2((1 2) (3 4)) a))) + + (pass-if "offset rank 2 array" + (let* ((a (make-array 0 '(1 2) '(1 2)))) + (array-copy! #(1 2 3 4) (array-contents a #t)) + (array-equal? #2@1@1((1 2) (3 4)) a))) + + (pass-if "transposed rank 2 array" + (let* ((a (make-array 0 4 4))) + (not (array-contents (transpose-array a 1 0) #t)))) + + ;; This is a consequence of (array-contents? a #t) => #t. + (pass-if "empty array" + (let ((a (make-typed-array 'f64 2 0 0))) + (f64vector? (array-contents a)))) + + (pass-if "broadcast vector I" + (let* ((a (make-array 0 4)) + (b (make-shared-array a (lambda (i j k) (list k)) 1 1 4))) + (array-copy! #(1 2 3 4) (array-contents b #t)) + (array-equal? #(1 2 3 4) a))) + + (pass-if "broadcast vector II" + (let* ((a (make-array 0 4)) + (b (make-shared-array a (lambda (i j k) (list k)) 2 1 4))) + (not (array-contents b)))) + + ;; FIXME maybe this should be allowed. + ;; (pass-if "broadcast vector -> empty" + ;; (let* ((a (make-array 0 4)) + ;; (b (make-shared-array a (lambda (i j k) (list k)) 0 1 4))) + ;; (if #f #f))) + + (pass-if "broadcast 2-rank I" + (let* ((a #2((1 2 3) (4 5 6))) + (b (make-shared-array a (lambda (i j) (list 0 j)) 2 3))) + (not (array-contents b)))) + + (pass-if "broadcast 2-rank II" + (let* ((a #2((1 2 3) (4 5 6))) + (b (make-shared-array a (lambda (i j) (list i 0)) 2 3))) + (not (array-contents b)))) + + (pass-if "literal array" + (not (not (array-contents #2((1 2 3) (4 5 6))))))) + + +;;; +;;; shared-array-root +;;; + +(define amap1 (lambda (i) (list (* 2 i)))) +(define amap2 (lambda (i j) (list (+ 1 (* 2 i)) (+ 1 (* 2 j))))) + +(with-test-prefix/c&e "shared-array-root" + + (pass-if "plain vector" + (let* ((a (make-vector 4 0)) + (b (make-shared-array a amap1 2))) + (eq? (shared-array-root a) (shared-array-root b) (array-contents a)))) + + (pass-if "plain array rank 2" + (let* ((a (make-array 0 4 4)) + (b (make-shared-array a amap2 2 2))) + (eq? (shared-array-root a) (shared-array-root b) (array-contents a)))) + + (pass-if "uniform array rank 2" + (let* ((a (make-typed-array 'c64 0 4 4)) + (b (make-shared-array a amap2 2 2))) + (eq? (shared-array-root a) (shared-array-root b) (array-contents a)))) + + (pass-if "bit array rank 2" + (let* ((a (make-typed-array 'b #f 4 4)) + (b (make-shared-array a amap2 2 2))) + (eq? (shared-array-root a) (shared-array-root b) (array-contents a))))) + +;;; +;;; shared-array-offset +;;; + +(with-test-prefix/c&e "shared-array-offset" + + (pass-if "plain vector" + (zero? (shared-array-offset (make-vector 4 0)))) + + (pass-if "plain array rank 2" + (zero? (shared-array-offset (make-array 0 4 4)))) + + (pass-if "row of rank-2 array, I" + (= 0 (shared-array-offset (array-row (make-array 0 5 3) 0)))) + + (pass-if "row of rank-2 array, II" + (= 4 (shared-array-offset (array-row (make-array 0 6 4) 1)))) + + (pass-if "col of rank-2 array, I" + (= 0 (shared-array-offset (array-col (make-array 0 5 3) 0)))) + + (pass-if "col of rank-2 array, II" + (= 1 (shared-array-offset (array-col (make-array 0 6 4) 1))))) + + +;;; +;;; shared-array-increments +;;; + +(with-test-prefix "shared-array-increments" + + (pass-if "plain vector" + (equal? '(1) (shared-array-increments (make-vector 4 0)))) + + (pass-if "plain array rank 2" + (equal? '(4 1) (shared-array-increments (make-array 0 3 4)))) + + (pass-if "plain array rank 3" + (equal? '(20 5 1) (shared-array-increments (make-array 0 3 4 5)))) + + (pass-if "row of rank-2 array" + (equal? '(1) (shared-array-increments (array-row (make-array 0 5 3) 0)))) + + (pass-if "col of rank-2 array" + (equal? '(3) (shared-array-increments (array-col (make-array 0 5 3) 0))))) + + +;;; +;;; transpose-array +;;; + +; see strings.test. +(with-test-prefix/c&e "transpose-array" + + (pass-if-exception "non array argument" exception:wrong-type-arg + (transpose-array 99)) + + (pass-if "rank 0" + (let* ((a #0(99)) + (b (transpose-array a))) + (and (array-equal? a b) + (eq? (shared-array-root a) (shared-array-root b))))) + + (pass-if "rank 1" + (let* ((a #(1 2 3)) + (b (transpose-array a 0))) + (and (array-equal? a b) + (eq? (shared-array-root a) (shared-array-root b))))) + + (pass-if "rank 2" + (let* ((a #2((1 2 3) (4 5 6))) + (b (transpose-array a 1 0)) + (c (transpose-array a 0 1))) + (and (array-equal? b #2((1 4) (2 5) (3 6))) + (array-equal? c a) + (eq? (shared-array-root a) + (shared-array-root b) + (shared-array-root c))))) + + ; rank > 2 is needed to check against the inverted axis index logic. + (pass-if "rank 3" + (let* ((a #3(((0 1 2 3) (4 5 6 7) (8 9 10 11)) + ((12 13 14 15) (16 17 18 19) (20 21 22 23)))) + (b (transpose-array a 1 2 0))) + (and (array-equal? b #3(((0 4 8) (12 16 20)) ((1 5 9) (13 17 21)) + ((2 6 10) (14 18 22)) ((3 7 11) (15 19 23)))) + (eq? (shared-array-root a) + (shared-array-root b)))))) + +;;; +;;; array->list +;;; + +(with-test-prefix/c&e "array->list" + (pass-if-equal "uniform vector" '(1 2 3) (array->list #s16(1 2 3))) + (pass-if-equal "vector" '(1 2 3) (array->list #(1 2 3))) + (pass-if-equal "rank 2 array" '((1 2) (3 4) (5 6)) (array->list #2((1 2) (3 4) (5 6)))) + (pass-if-equal "empty vector" '() (array->list #())) + + (pass-if-equal "http://bugs.gnu.org/12465 - ok" + '(3 4) + (let* ((a #2((1 2) (3 4))) + (b (make-shared-array a (lambda (j) (list 1 j)) 2))) + (array->list b))) + (pass-if-equal "http://bugs.gnu.org/12465 - bad" + '(2 4) + (let* ((a #2((1 2) (3 4))) + (b (make-shared-array a (lambda (i) (list i 1)) 2))) + (array->list b)))) + +;;; +;;; array-fill! +;;; + +(with-test-prefix "array-fill!" + + (with-test-prefix "bool" + (let ((a (make-bitvector 1 #t))) + (pass-if "#f" (array-fill! a #f) #t) + (pass-if "#t" (array-fill! a #t) #t))) + + (with-test-prefix "char" + (let ((a (make-string 1 #\a))) + (pass-if "x" (array-fill! a #\x) #t))) + + (with-test-prefix "byte" + (let ((a (make-s8vector 1 0))) + (pass-if "0" (array-fill! a 0) #t) + (pass-if "127" (array-fill! a 127) #t) + (pass-if "-128" (array-fill! a -128) #t) + (pass-if-exception "128" exception:out-of-range + (array-fill! a 128)) + (pass-if-exception "-129" exception:out-of-range + (array-fill! a -129)) + (pass-if-exception "symbol" exception:wrong-type-arg + (array-fill! a 'symbol)))) + + (with-test-prefix "short" + (let ((a (make-s16vector 1 0))) + (pass-if "0" (array-fill! a 0) #t) + (pass-if "123" (array-fill! a 123) #t) + (pass-if "-123" (array-fill! a -123) #t))) + + (with-test-prefix "ulong" + (let ((a (make-u32vector 1 1))) + (pass-if "0" (array-fill! a 0) #t) + (pass-if "123" (array-fill! a 123) #t) + (pass-if-exception "-123" exception:out-of-range + (array-fill! a -123) #t))) + + (with-test-prefix "long" + (let ((a (make-s32vector 1 -1))) + (pass-if "0" (array-fill! a 0) #t) + (pass-if "123" (array-fill! a 123) #t) + (pass-if "-123" (array-fill! a -123) #t))) + + (with-test-prefix "float" + (let ((a (make-f32vector 1 1.0))) + (pass-if "0.0" (array-fill! a 0) #t) + (pass-if "123.0" (array-fill! a 123.0) #t) + (pass-if "-123.0" (array-fill! a -123.0) #t) + (pass-if "0" (array-fill! a 0) #t) + (pass-if "123" (array-fill! a 123) #t) + (pass-if "-123" (array-fill! a -123) #t) + (pass-if "5/8" (array-fill! a 5/8) #t))) + + (with-test-prefix "double" + (let ((a (make-f64vector 1 1/3))) + (pass-if "0.0" (array-fill! a 0) #t) + (pass-if "123.0" (array-fill! a 123.0) #t) + (pass-if "-123.0" (array-fill! a -123.0) #t) + (pass-if "0" (array-fill! a 0) #t) + (pass-if "123" (array-fill! a 123) #t) + (pass-if "-123" (array-fill! a -123) #t) + (pass-if "5/8" (array-fill! a 5/8) #t))) + + (with-test-prefix "noncompact" + (let* ((a (make-array 0 3 3)) + (b (make-shared-array a (lambda (i) (list i i)) 3))) + (array-fill! b 9) + (pass-if + (and (equal? b #(9 9 9)) + (equal? a #2((9 0 0) (0 9 0) (0 0 9)))))))) + +;;; +;;; array-in-bounds? +;;; + +(with-test-prefix "array-in-bounds?" + + (pass-if (let ((a (make-array #f '(425 425)))) + (eq? #f (array-in-bounds? a 0))))) + +;;; +;;; array-prototype +;;; + +(with-test-prefix "array-type" + + (with-test-prefix "on make-foo-vector" + + (pass-if "bool" + (eq? 'b (array-type (make-bitvector 1)))) + + (pass-if "char" + (eq? 'a (array-type (make-string 1)))) + + (pass-if "byte" + (eq? 'u8 (array-type (make-u8vector 1)))) + + (pass-if "short" + (eq? 's16 (array-type (make-s16vector 1)))) + + (pass-if "ulong" + (eq? 'u32 (array-type (make-u32vector 1)))) + + (pass-if "long" + (eq? 's32 (array-type (make-s32vector 1)))) + + (pass-if "long long" + (eq? 's64 (array-type (make-s64vector 1)))) + + (pass-if "float" + (eq? 'f32 (array-type (make-f32vector 1)))) + + (pass-if "double" + (eq? 'f64 (array-type (make-f64vector 1)))) + + (pass-if "complex" + (eq? 'c64 (array-type (make-c64vector 1)))) + + (pass-if "scm" + (eq? #t (array-type (make-vector 1))))) + + (with-test-prefix "on make-typed-array" + + (let ((types '(b a u8 s8 u16 s16 u32 s32 u64 u64 f32 f64 c32 c64))) + (for-each (lambda (type) + (pass-if (symbol->string type) + (eq? type + (array-type (make-typed-array type + *unspecified* + '(5 6)))))) + types)))) + +;;; +;;; array-set! +;;; + +(with-test-prefix "array-set!" + + (with-test-prefix "bitvector" + + ;; in Guile 1.8.0 a bug in bitvector_set() caused a segv in array-set! + ;; on a bitvector like the following + (let ((a (make-bitvector 1))) + (pass-if "one elem set #t" + (begin + (array-set! a #t 0) + (eq? #t (array-ref a 0)))) + (pass-if "one elem set #f" + (begin + (array-set! a #f 0) + (eq? #f (array-ref a 0)))))) + + (with-test-prefix "byte" + + (let ((a (make-s8vector 1))) + + (pass-if "-128" + (begin (array-set! a -128 0) #t)) + (pass-if "0" + (begin (array-set! a 0 0) #t)) + (pass-if "127" + (begin (array-set! a 127 0) #t)) + (pass-if-exception "-129" exception:out-of-range + (begin (array-set! a -129 0) #t)) + (pass-if-exception "128" exception:out-of-range + (begin (array-set! a 128 0) #t)))) + + (with-test-prefix "short" + + (let ((a (make-s16vector 1))) + ;; true if n can be array-set! into a + (define (fits? n) + (false-if-exception (begin (array-set! a n 0) #t))) + + (with-test-prefix "store/fetch" + ;; Check array-ref gives back what was put with array-set!. + ;; In Guile 1.6.4 and earlier, array-set! only demanded an inum and + ;; would silently truncate to a short. + + (do ((n 1 (1+ (* 2 n)))) ;; n=2^k-1 + ((not (fits? n))) + (array-set! a n 0) + (pass-if n + (= n (array-ref a 0)))) + + (do ((n -1 (* 2 n))) ;; -n=2^k + ((not (fits? n))) + (array-set! a n 0) + (pass-if n + (= n (array-ref a 0)))))))) + +;;; +;;; array-set! +;;; + +(with-test-prefix "array-set!" + + (with-test-prefix "one dim" + (let ((a (make-array #f '(3 5)))) + (pass-if "start" + (array-set! a 'y 3) + #t) + (pass-if "end" + (array-set! a 'y 5) + #t) + (pass-if-exception "start-1" exception:out-of-range + (array-set! a 'y 2)) + (pass-if-exception "end+1" exception:out-of-range + (array-set! a 'y 6)) + (pass-if-exception "two indexes" exception:wrong-num-indices + (array-set! a 'y 6 7)))) + + (with-test-prefix "two dim" + (let ((a (make-array #f '(3 5) '(7 9)))) + (pass-if "start" + (array-set! a 'y 3 7) + #t) + (pass-if "end" + (array-set! a 'y 5 9) + #t) + (pass-if-exception "start i-1" exception:out-of-range + (array-set! a 'y 2 7)) + (pass-if-exception "end i+1" exception:out-of-range + (array-set! a 'y 6 9)) + (pass-if-exception "one index" exception:wrong-num-indices + (array-set! a 'y 4)) + (pass-if-exception "three indexes" exception:wrong-num-indices + (array-set! a 'y 4 8 0))))) + +;;; +;;; uniform-vector +;;; + +(with-test-prefix "typed arrays" + + (with-test-prefix "array-ref byte" + + (let ((a (make-s8vector 1))) + + (pass-if "0" + (begin + (array-set! a 0 0) + (= 0 (array-ref a 0)))) + (pass-if "127" + (begin + (array-set! a 127 0) + (= 127 (array-ref a 0)))) + (pass-if "-128" + (begin + (array-set! a -128 0) + (= -128 (array-ref a 0)))))) + + (with-test-prefix "shared with rank 1 equality" + + (let ((a #f64(1 2 3 4))) + + (pass-if "change offset" + (let ((b (make-shared-array a (lambda (i) (list (+ i 1))) 3))) + (and (eq? (array-type b) (array-type a)) + (= 3 (array-length b)) + (array-equal? b #f64(2 3 4))))) + + (pass-if "change stride" + (let ((c (make-shared-array a (lambda (i) (list (* i 2))) 2))) + (and (eq? (array-type c) (array-type a)) + (= 2 (array-length c)) + (array-equal? c #f64(1 3)))))))) + +;;; +;;; syntax +;;; + +(with-test-prefix/c&e "syntax" + + (pass-if "rank and lower bounds" + ;; uniform u32 array of rank 2 with index ranges 2..3 and 7..8. + (let ((a '#2u32@2@7((1 2) (3 4)))) + (and (array? a) + (typed-array? a 'u32) + (= (array-rank a) 2) + (let loop ((bounds '((2 7) (2 8) (3 7) (3 8))) + (result #t)) + (if (null? bounds) + result + (and result + (loop (cdr bounds) + (apply array-in-bounds? a (car bounds))))))))) + + (pass-if "negative lower bound" + (let ((a '#1@-3(a b))) + (and (array? a) + (= (array-rank a) 1) + (array-in-bounds? a -3) (array-in-bounds? a -2) + (eq? 'a (array-ref a -3)) + (eq? 'b (array-ref a -2))))) + + (pass-if-exception "negative length" exception:length-non-negative + (with-input-from-string "'#1:-3(#t #t)" read)) + + (pass-if "bitvector is self-evaluating" + (equal? (compile (bitvector)) (bitvector))) + + ; this failed in 2.0.9. + (pass-if "typed arrays that are not uniform arrays" + (let ((a #2b((#t #f) (#f #t))) + (b (make-typed-array 'b #f 2 2))) + (array-set! b #t 0 0) + (array-set! b #t 1 1) + (array-equal? a b)))) + +;;; +;;; equal? with vector and one-dimensional array +;;; + +(with-test-prefix/c&e "equal?" + (pass-if "array and non-array" + (not (equal? #2f64((0 1) (2 3)) 100))) + + (pass-if "empty vectors of different types" + (not (equal? #s32() #f64()))) + + (pass-if "empty arrays of different types" + (not (equal? #2s32() #2f64()))) + + (pass-if "empty arrays of the same type" + (equal? #s32() #s32())) + + (pass-if "identical uniform vectors of the same type" + (equal? #s32(1) #s32(1))) + + (pass-if "nonidentical uniform vectors of the same type" + (not (equal? #s32(1) #s32(-1)))) + + (pass-if "identical uniform vectors of different types" + (not (equal? #s32(1) #s64(1)))) + + (pass-if "nonidentical uniform vectors of different types" + (not (equal? #s32(1) #s64(-1)))) + + (pass-if "vector and one-dimensional array" + (equal? (make-shared-array #2((a b c) (d e f) (g h i)) + (lambda (i) (list i i)) + '(0 2)) + #(a e i)))) + +;;; +;;; slices as generalized vectors +;;; + +(with-test-prefix/c&e "generalized vector slices" + (pass-if (equal? (array-row #2u32((0 1) (2 3)) 1) + #u32(2 3))) + (pass-if (equal? (array-ref (array-row #2u32((0 1) (2 3)) 1) 0) + 2))) + +;;; +;;; printing arrays +;;; + +(with-test-prefix/c&e "printing arrays" + (pass-if-equal "writing 1D arrays that aren't vectors" + "#1(b c)" + (format #f "~a" (make-shared-array #(a b c) + (lambda (i) (list (+ i 1))) + 2))) + + (pass-if-equal "0-array" + "#0(9)" + (format #f "~a" (make-array 9))) + + (pass-if-equal "2-array" + "#2f64((0.0 1.0) (2.0 3.0))" + (format #f "~a" #2f64((0 1) (2 3)))) + + (pass-if-equal "empty 3-array" + "#3()" + (format #f "~a" (make-array 1 0 0 0))) + + (pass-if-equal "empty 3-array with last nonempty dim." + "#3:0:0:1()" + (format #f "~a" (make-array 1 0 0 1))) + + (pass-if-equal "empty 3-array with middle nonempty dim." + "#3:0:1:0()" + (format #f "~a" (make-array 1 0 1 0))) + + (pass-if-equal "empty 3-array with first nonempty dim." + "#3(())" + (format #f "~a" (make-array 1 1 0 0))) + + (pass-if-equal "3-array with non-zero lower bounds" + "#3@1@0@1(((1 1 1) (1 1 1)) ((1 1 1) (1 1 1)))" + (format #f "~a" (make-array 1 '(1 2) '(0 1) '(1 3)))) + + (pass-if-equal "3-array with non-zero-lower bounds and last nonempty dim." + "#3@0:0@0:0@1:3()" + (format #f "~a" (make-array 1 0 0 '(1 3)))) + + (pass-if-equal "3-array with non-zero-lower bounds and middle nonempty dim." + "#3@0:0@1:3@0:0()" + (format #f "~a" (make-array 1 0 '(1 3) 0))) + + (pass-if-equal "3-array with non-zero-lower bounds and first nonempty dim." + "#3@1@0@0(() () ())" + (format #f "~a" (make-array 1 '(1 3) 0 0))) + + (pass-if-equal "3-array with singleton dim case I" + "#3@1@1@-1(((1 1 1)))" + (format #f "~a" (make-array 1 '(1 1) '(1 1) '(-1 1)))) + + (pass-if-equal "3-array with singleton dim case II" + "#3@-1@1@1(((1) (1) (1)))" + (format #f "~a" (make-array 1 '(-1 -1) '(1 3) '(1 1)))) + + (pass-if-equal "3-array with singleton dim case III" + "#3@1@-1@1(((1)) ((1)) ((1)))" + (format #f "~a" (make-array 1 '(1 3) '(-1 -1) '(1 1))))) + |