mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-04-30 11:50:28 +02:00
Code Activity
guile/test-suite/tests/arrays.test
Daniel Llorens 3b6a2f281a Move uniform-array->bytevector from (rnrs bytevectors) to core 
This is to have arrays use bytevectors and not the other way
around. Besides, it's not an RnRS function.
2020-04-09 16:59:39 +02:00

1154 lines
36 KiB
Scheme
Raw Permalink Blame History

This file contains invisible Unicode characters

This file contains invisible Unicode characters that are indistinguishable to humans but may be processed differently by a computer. If you think that this is intentional, you can safely ignore this warning. Use the Escape button to reveal them.

;;;; 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 (rnrs bytevectors)
#: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)))))
(with-test-prefix "Arrays over bytevectors"
(pass-if "array?"
(array? #vu8(1 2 3)))
(pass-if "array-length"
(equal? (iota 16)
(map array-length
(map make-bytevector (iota 16)))))
(pass-if "array-ref"
(let ((bv #vu8(255 127)))
(and (= 255 (array-ref bv 0))
(= 127 (array-ref bv 1)))))
(pass-if-exception "array-ref [index out-of-range]"
exception:out-of-range
(let ((bv #vu8(1 2)))
(array-ref bv 2)))
(pass-if "array-set!"
(let ((bv (make-bytevector 2)))
(array-set! bv 255 0)
(array-set! bv 77 1)
(equal? '(255 77)
(bytevector->u8-list bv))))
(pass-if-exception "array-set! [index out-of-range]"
exception:out-of-range
(let ((bv (make-bytevector 2)))
(array-set! bv 0 2)))
(pass-if-exception "array-set! [value out-of-range]"
exception:out-of-range
(let ((bv (make-bytevector 2)))
(array-set! bv 256 0)))
(pass-if "array-type"
(eq? 'vu8 (array-type #vu8())))
(pass-if "array-contents"
(let ((bv (u8-list->bytevector (iota 10))))
(eq? bv (array-contents bv))))
(pass-if "array-ref"
(let ((bv (u8-list->bytevector (iota 10))))
(equal? (iota 10)
(map (lambda (i) (array-ref bv i))
(iota 10)))))
(pass-if "array-set!"
(let ((bv (make-bytevector 10)))
(for-each (lambda (i)
(array-set! bv i i))
(iota 10))
(equal? (iota 10)
(bytevector->u8-list bv))))
(pass-if "make-typed-array"
(let ((bv (make-typed-array 'vu8 77 33)))
(equal? bv (u8-list->bytevector (make-list 33 77)))))
(pass-if-exception "make-typed-array [out-of-range]"
exception:out-of-range
(make-typed-array 'vu8 256 77)))
(with-test-prefix "uniform-array->bytevector"
(pass-if "bytevector"
(let ((bv #vu8(0 1 128 255)))
(equal? bv (uniform-array->bytevector bv))))
(pass-if "empty bitvector"
(let ((bv (uniform-array->bytevector (make-bitvector 0))))
(equal? bv #vu8())))
(pass-if "bitvector < 8"
(let ((bv (uniform-array->bytevector (make-bitvector 4 #t))))
(= (bytevector-length bv) 4)))
(pass-if "bitvector == 8"
(let ((bv (uniform-array->bytevector (make-bitvector 8 #t))))
(= (bytevector-length bv) 4)))
(pass-if "bitvector > 8"
(let ((bv (uniform-array->bytevector (make-bitvector 9 #t))))
(= (bytevector-length bv) 4)))
(pass-if "bitvector == 32"
(let ((bv (uniform-array->bytevector (make-bitvector 32 #t))))
(= (bytevector-length bv) 4)))
(pass-if "bitvector > 32"
(let ((bv (uniform-array->bytevector (make-bitvector 33 #t))))
(= (bytevector-length bv) 8))))
View git blame Copy permalink