mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-04-29 19:30:36 +02:00
Code Activity
guile/test-suite/tests/arrays.test
Daniel Llorens c2cf685b65 Remove the 'simple vector' concept 
* Deprecate scm_is_simple_vector.
* libguile/vectors.c (scm_vector_elements,
  scm_vector_writable_elements): These functions take an array; reword
  to make this clear.
* libguile/print.h: Remove reference to 'simple vector'.
* doc/ref/api-data.texi: Remove documentation for scm_is_simple_vector.
  Remove references to 'simple vector'.
  Fix documentation for scm_vector_elements,
  scm_vector_writable_elements.
* test-suite/tests/arrays.test:
* test-suite/tests/vectors.test: Remove references to 'simple vector'.
2021-08-16 15:39:21 +02:00

1093 lines
34 KiB
Scheme
Raw Permalink Blame History

;;;; 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 "plain 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 typed 3-array with last nonempty dim."
"#3f64:0:0:1()"
(format #f "~a" (make-typed-array 'f64 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)))))
;;;
;;; reading arrays
;;;
(with-test-prefix/c&e "reading arrays"
(pass-if "empty 3-array with first nonempty dim I"
(array-equal? (make-array 1 1 0 0)
(call-with-input-string "#3(())" read)))
(pass-if "empty 3-array with first nonempty dim II"
(array-equal? (make-array 1 1 0 0)
#3(())))
(pass-if "empty 3-array with middle nonempty dim I"
(array-equal? (make-array 1 0 1 0)
(call-with-input-string "#3:0:1:0()" read)))
(pass-if "empty 3-array with middle nonempty dim II"
(array-equal? (make-array 1 0 1 0)
#3:0:1:0()))
(pass-if "empty typed 3-array with middle nonempty dim I"
(array-equal? (make-typed-array 'f64 1 0 1 0)
(call-with-input-string "#3f64:0:1:0()" read)))
(pass-if "empty typed 3-array with middle nonempty dim II"
(array-equal? (make-typed-array 'f64 1 0 1 0)
#3f64:0:1:0()))
(pass-if "array with specified size I"
(array-equal? #f64(1 2 3)
(call-with-input-string "#f64:3(1 2 3)" read)))
(pass-if "array with specified size II"
(array-equal? #f64(1 2 3)
#f64:3(1 2 3))))
View git blame Copy permalink