[bpt/guile.git] / test-suite / tests / unif.test

;;;; unif.test --- tests guile's uniform arrays     -*- scheme -*-
;;;;
;;;; Copyright 2004, 2006 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 2.1 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-unif)
  #:use-module (test-suite lib))

;;;
;;; array?
;;;

(define exception:wrong-num-indices
  (cons 'misc-error "^wrong number of indices.*"))

(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))))))

;;;
;;; array-equal?
;;;

(with-test-prefix "array-equal?"

  (pass-if "#s16(...)"
    (array-equal? #s16(1 2 3) #s16(1 2 3))))

;;;
;;; 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))))

;;;
;;; 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:out-of-range
	(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)))))

;;;
;;; make-shared-array
;;;

(define exception:mapping-out-of-range
  (cons 'misc-error "^mapping out of range"))  ;; per scm_make_shared_array

(with-test-prefix "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))))))

;;;
;;; uniform-vector-ref
;;;

(with-test-prefix "uniform-vector-ref"

  (with-test-prefix "byte"

    (let ((a (make-s8vector 1)))

      (pass-if "0"
	(begin
	  (array-set! a 0 0)
	  (= 0 (uniform-vector-ref a 0))))
      (pass-if "127"
	(begin
	  (array-set! a 127 0)
	  (= 127 (uniform-vector-ref a 0))))
      (pass-if "-128"
	(begin
	  (array-set! a -128 0)
	  (= -128 (uniform-vector-ref a 0)))))))
Commit	Line	Data
f410f8e7 KR	1	;;;; unif.test --- tests guile's uniform arrays -- scheme --
f410f8e7 KR	2	;;;;
6e7d5622	3	;;;; Copyright 2004, 2006 Free Software Foundation, Inc.
f410f8e7 KR	4	;;;;
	5	;;;; This library is free software; you can redistribute it and/or
	6	;;;; modify it under the terms of the GNU Lesser General Public
	7	;;;; License as published by the Free Software Foundation; either
	8	;;;; version 2.1 of the License, or (at your option) any later version.
	9	;;;;
	10	;;;; This library is distributed in the hope that it will be useful,
	11	;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
	12	;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
	13	;;;; Lesser General Public License for more details.
	14	;;;;
	15	;;;; You should have received a copy of the GNU Lesser General Public
	16	;;;; License along with this library; if not, write to the Free Software
92205699	17	;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
f410f8e7 KR	18
	19	(define-module (test-suite test-unif)
	20	#:use-module (test-suite lib))
	21
d2866d6e KR	22	;;;
	23	;;; array?
	24	;;;
	25
34ea1617 MV	26	(define exception:wrong-num-indices
	27	(cons 'misc-error "^wrong number of indices.*"))
	28
d2866d6e KR	29	(with-test-prefix "array?"
d2866d6e KR	30
3963764d MV	31	(let ((bool (make-typed-array 'b #t '(5 6)))
	32	(char (make-typed-array 'a #\a '(5 6)))
	33	(byte (make-typed-array 'u8 0 '(5 6)))
	34	(short (make-typed-array 's16 0 '(5 6)))
	35	(ulong (make-typed-array 'u32 0 '(5 6)))
	36	(long (make-typed-array 's32 0 '(5 6)))
	37	(longlong (make-typed-array 's64 0 '(5 6)))
	38	(float (make-typed-array 'f32 0 '(5 6)))
	39	(double (make-typed-array 'f64 0 '(5 6)))
	40	(complex (make-typed-array 'c64 0 '(5 6)))
	41	(scm (make-typed-array #t 0 '(5 6))))
d2866d6e KR	42
d2866d6e KR	43	(with-test-prefix "is bool"
3963764d MV	44	(pass-if (eq? #t (typed-array? bool 'b)))
	45	(pass-if (eq? #f (typed-array? char 'b)))
	46	(pass-if (eq? #f (typed-array? byte 'b)))
	47	(pass-if (eq? #f (typed-array? short 'b)))
	48	(pass-if (eq? #f (typed-array? ulong 'b)))
	49	(pass-if (eq? #f (typed-array? long 'b)))
	50	(pass-if (eq? #f (typed-array? longlong 'b)))
	51	(pass-if (eq? #f (typed-array? float 'b)))
	52	(pass-if (eq? #f (typed-array? double 'b)))
	53	(pass-if (eq? #f (typed-array? complex 'b)))
	54	(pass-if (eq? #f (typed-array? scm 'b))))
d2866d6e KR	55
d2866d6e KR	56	(with-test-prefix "is char"
3963764d MV	57	(pass-if (eq? #f (typed-array? bool 'a)))
	58	(pass-if (eq? #t (typed-array? char 'a)))
	59	(pass-if (eq? #f (typed-array? byte 'a)))
	60	(pass-if (eq? #f (typed-array? short 'a)))
	61	(pass-if (eq? #f (typed-array? ulong 'a)))
	62	(pass-if (eq? #f (typed-array? long 'a)))
	63	(pass-if (eq? #f (typed-array? longlong 'a)))
	64	(pass-if (eq? #f (typed-array? float 'a)))
	65	(pass-if (eq? #f (typed-array? double 'a)))
	66	(pass-if (eq? #f (typed-array? complex 'a)))
	67	(pass-if (eq? #f (typed-array? scm 'a))))
d2866d6e KR	68
d2866d6e KR	69	(with-test-prefix "is byte"
a4837772 MV	70	(pass-if (eq? #f (typed-array? bool 'u8)))
	71	(pass-if (eq? #f (typed-array? char 'u8)))
	72	(pass-if (eq? #t (typed-array? byte 'u8)))
	73	(pass-if (eq? #f (typed-array? short 'u8)))
	74	(pass-if (eq? #f (typed-array? ulong 'u8)))
	75	(pass-if (eq? #f (typed-array? long 'u8)))
	76	(pass-if (eq? #f (typed-array? longlong 'u8)))
3963764d MV	77	(pass-if (eq? #f (typed-array? float 'u8)))
	78	(pass-if (eq? #f (typed-array? double 'u8)))
	79	(pass-if (eq? #f (typed-array? complex 'u8)))
	80	(pass-if (eq? #f (typed-array? scm 'u8))))
d2866d6e KR	81
d2866d6e KR	82	(with-test-prefix "is short"
a4837772 MV	83	(pass-if (eq? #f (typed-array? bool 's16)))
	84	(pass-if (eq? #f (typed-array? char 's16)))
	85	(pass-if (eq? #f (typed-array? byte 's16)))
	86	(pass-if (eq? #t (typed-array? short 's16)))
	87	(pass-if (eq? #f (typed-array? ulong 's16)))
	88	(pass-if (eq? #f (typed-array? long 's16)))
	89	(pass-if (eq? #f (typed-array? longlong 's16)))
3963764d MV	90	(pass-if (eq? #f (typed-array? float 's16)))
	91	(pass-if (eq? #f (typed-array? double 's16)))
	92	(pass-if (eq? #f (typed-array? complex 's16)))
	93	(pass-if (eq? #f (typed-array? scm 's16))))
d2866d6e KR	94
d2866d6e KR	95	(with-test-prefix "is ulong"
a4837772 MV	96	(pass-if (eq? #f (typed-array? bool 'u32)))
	97	(pass-if (eq? #f (typed-array? char 'u32)))
	98	(pass-if (eq? #f (typed-array? byte 'u32)))
	99	(pass-if (eq? #f (typed-array? short 'u32)))
	100	(pass-if (eq? #t (typed-array? ulong 'u32)))
	101	(pass-if (eq? #f (typed-array? long 'u32)))
	102	(pass-if (eq? #f (typed-array? longlong 'u32)))
3963764d MV	103	(pass-if (eq? #f (typed-array? float 'u32)))
	104	(pass-if (eq? #f (typed-array? double 'u32)))
	105	(pass-if (eq? #f (typed-array? complex 'u32)))
	106	(pass-if (eq? #f (typed-array? scm 'u32))))
d2866d6e KR	107
d2866d6e KR	108	(with-test-prefix "is long"
a4837772 MV	109	(pass-if (eq? #f (typed-array? bool 's32)))
	110	(pass-if (eq? #f (typed-array? char 's32)))
	111	(pass-if (eq? #f (typed-array? byte 's32)))
	112	(pass-if (eq? #f (typed-array? short 's32)))
	113	(pass-if (eq? #f (typed-array? ulong 's32)))
	114	(pass-if (eq? #t (typed-array? long 's32)))
	115	(pass-if (eq? #f (typed-array? longlong 's32)))
3963764d MV	116	(pass-if (eq? #f (typed-array? float 's32)))
	117	(pass-if (eq? #f (typed-array? double 's32)))
	118	(pass-if (eq? #f (typed-array? complex 's32)))
	119	(pass-if (eq? #f (typed-array? scm 's32))))
d2866d6e KR	120
d2866d6e KR	121	(with-test-prefix "is long long"
a4837772 MV	122	(pass-if (eq? #f (typed-array? bool 's64)))
	123	(pass-if (eq? #f (typed-array? char 's64)))
	124	(pass-if (eq? #f (typed-array? byte 's64)))
	125	(pass-if (eq? #f (typed-array? short 's64)))
	126	(pass-if (eq? #f (typed-array? ulong 's64)))
	127	(pass-if (eq? #f (typed-array? long 's64)))
	128	(pass-if (eq? #t (typed-array? longlong 's64)))
3963764d MV	129	(pass-if (eq? #f (typed-array? float 's64)))
	130	(pass-if (eq? #f (typed-array? double 's64)))
	131	(pass-if (eq? #f (typed-array? complex 's64)))
	132	(pass-if (eq? #f (typed-array? scm 's64))))
d2866d6e KR	133
d2866d6e KR	134	(with-test-prefix "is float"
a4837772 MV	135	(pass-if (eq? #f (typed-array? bool 'f32)))
	136	(pass-if (eq? #f (typed-array? char 'f32)))
	137	(pass-if (eq? #f (typed-array? byte 'f32)))
	138	(pass-if (eq? #f (typed-array? short 'f32)))
	139	(pass-if (eq? #f (typed-array? ulong 'f32)))
	140	(pass-if (eq? #f (typed-array? long 'f32)))
	141	(pass-if (eq? #f (typed-array? longlong 'f32)))
3963764d MV	142	(pass-if (eq? #t (typed-array? float 'f32)))
	143	(pass-if (eq? #f (typed-array? double 'f32)))
	144	(pass-if (eq? #f (typed-array? complex 'f32)))
	145	(pass-if (eq? #f (typed-array? scm 'f32))))
d2866d6e KR	146
d2866d6e KR	147	(with-test-prefix "is double"
a4837772 MV	148	(pass-if (eq? #f (typed-array? bool 'f64)))
	149	(pass-if (eq? #f (typed-array? char 'f64)))
	150	(pass-if (eq? #f (typed-array? byte 'f64)))
	151	(pass-if (eq? #f (typed-array? short 'f64)))
	152	(pass-if (eq? #f (typed-array? ulong 'f64)))
	153	(pass-if (eq? #f (typed-array? long 'f64)))
	154	(pass-if (eq? #f (typed-array? longlong 'f64)))
3963764d MV	155	(pass-if (eq? #f (typed-array? float 'f64)))
	156	(pass-if (eq? #t (typed-array? double 'f64)))
	157	(pass-if (eq? #f (typed-array? complex 'f64)))
	158	(pass-if (eq? #f (typed-array? scm 'f64))))
d2866d6e KR	159
d2866d6e KR	160	(with-test-prefix "is complex"
a4837772 MV	161	(pass-if (eq? #f (typed-array? bool 'c64)))
	162	(pass-if (eq? #f (typed-array? char 'c64)))
	163	(pass-if (eq? #f (typed-array? byte 'c64)))
	164	(pass-if (eq? #f (typed-array? short 'c64)))
	165	(pass-if (eq? #f (typed-array? ulong 'c64)))
	166	(pass-if (eq? #f (typed-array? long 'c64)))
	167	(pass-if (eq? #f (typed-array? longlong 'c64)))
3963764d MV	168	(pass-if (eq? #f (typed-array? float 'c64)))
	169	(pass-if (eq? #f (typed-array? double 'c64)))
	170	(pass-if (eq? #t (typed-array? complex 'c64)))
	171	(pass-if (eq? #f (typed-array? scm 'c64))))
d2866d6e KR	172
d2866d6e KR	173	(with-test-prefix "is scm"
a4837772 MV	174	(pass-if (eq? #f (typed-array? bool #t)))
	175	(pass-if (eq? #f (typed-array? char #t)))
	176	(pass-if (eq? #f (typed-array? byte #t)))
	177	(pass-if (eq? #f (typed-array? short #t)))
	178	(pass-if (eq? #f (typed-array? ulong #t)))
	179	(pass-if (eq? #f (typed-array? long #t)))
	180	(pass-if (eq? #f (typed-array? longlong #t)))
3963764d MV	181	(pass-if (eq? #f (typed-array? float #t)))
	182	(pass-if (eq? #f (typed-array? double #t)))
	183	(pass-if (eq? #f (typed-array? complex #t)))
	184	(pass-if (eq? #t (typed-array? scm #t))))))
d2866d6e	185
400f0fb7 MV	186	;;;
	187	;;; array-equal?
	188	;;;
	189
	190	(with-test-prefix "array-equal?"
	191
bd6713d5 MV	192	(pass-if "#s16(...)"
bd6713d5 MV	193	(array-equal? #s16(1 2 3) #s16(1 2 3))))
400f0fb7	194
d2866d6e KR	195	;;;
	196	;;; array-fill!
	197	;;;
	198
	199	(with-test-prefix "array-fill!"
	200
	201	(with-test-prefix "bool"
3963764d	202	(let ((a (make-bitvector 1 #t)))
d2866d6e KR	203	(pass-if "#f" (array-fill! a #f) #t)
	204	(pass-if "#t" (array-fill! a #t) #t)))
	205
	206	(with-test-prefix "char"
3963764d	207	(let ((a (make-string 1 #\a)))
d2866d6e KR	208	(pass-if "x" (array-fill! a #\x) #t)))
	209
	210	(with-test-prefix "byte"
3963764d	211	(let ((a (make-s8vector 1 0)))
d2866d6e KR	212	(pass-if "0" (array-fill! a 0) #t)
d2866d6e KR	213	(pass-if "127" (array-fill! a 127) #t)
2291a3a7 KR	214	(pass-if "-128" (array-fill! a -128) #t)
	215	(pass-if-exception "128" exception:out-of-range
	216	(array-fill! a 128))
	217	(pass-if-exception "-129" exception:out-of-range
	218	(array-fill! a -129))
	219	(pass-if-exception "symbol" exception:wrong-type-arg
	220	(array-fill! a 'symbol))))
d2866d6e KR	221
d2866d6e KR	222	(with-test-prefix "short"
3963764d	223	(let ((a (make-s16vector 1 0)))
d2866d6e KR	224	(pass-if "0" (array-fill! a 0) #t)
	225	(pass-if "123" (array-fill! a 123) #t)
	226	(pass-if "-123" (array-fill! a -123) #t)))
	227
	228	(with-test-prefix "ulong"
3963764d	229	(let ((a (make-u32vector 1 1)))
d2866d6e KR	230	(pass-if "0" (array-fill! a 0) #t)
	231	(pass-if "123" (array-fill! a 123) #t)
	232	(pass-if-exception "-123" exception:out-of-range
	233	(array-fill! a -123) #t)))
	234
	235	(with-test-prefix "long"
3963764d	236	(let ((a (make-s32vector 1 -1)))
d2866d6e KR	237	(pass-if "0" (array-fill! a 0) #t)
	238	(pass-if "123" (array-fill! a 123) #t)
	239	(pass-if "-123" (array-fill! a -123) #t)))
	240
	241	(with-test-prefix "float"
3963764d	242	(let ((a (make-f32vector 1 1.0)))
d2866d6e KR	243	(pass-if "0.0" (array-fill! a 0) #t)
	244	(pass-if "123.0" (array-fill! a 123.0) #t)
	245	(pass-if "-123.0" (array-fill! a -123.0) #t)
	246	(pass-if "0" (array-fill! a 0) #t)
	247	(pass-if "123" (array-fill! a 123) #t)
	248	(pass-if "-123" (array-fill! a -123) #t)
	249	(pass-if "5/8" (array-fill! a 5/8) #t)))
	250
	251	(with-test-prefix "double"
3963764d	252	(let ((a (make-f64vector 1 1/3)))
d2866d6e KR	253	(pass-if "0.0" (array-fill! a 0) #t)
	254	(pass-if "123.0" (array-fill! a 123.0) #t)
	255	(pass-if "-123.0" (array-fill! a -123.0) #t)
	256	(pass-if "0" (array-fill! a 0) #t)
	257	(pass-if "123" (array-fill! a 123) #t)
	258	(pass-if "-123" (array-fill! a -123) #t)
	259	(pass-if "5/8" (array-fill! a 5/8) #t))))
	260
fcae94c5 KR	261	;;;
	262	;;; array-in-bounds?
	263	;;;
	264
	265	(with-test-prefix "array-in-bounds?"
	266
	267	(pass-if (let ((a (make-array #f '(425 425))))
	268	(eq? #f (array-in-bounds? a 0)))))
	269
d2866d6e KR	270	;;;
	271	;;; array-prototype
	272	;;;
	273
3963764d	274	(with-test-prefix "array-type"
d2866d6e	275
3963764d	276	(with-test-prefix "on make-foo-vector"
d2866d6e KR	277
d2866d6e KR	278	(pass-if "bool"
3963764d	279	(eq? 'b (array-type (make-bitvector 1))))
d2866d6e KR	280
d2866d6e KR	281	(pass-if "char"
3963764d	282	(eq? 'a (array-type (make-string 1))))
d2866d6e KR	283
d2866d6e KR	284	(pass-if "byte"
3963764d	285	(eq? 'u8 (array-type (make-u8vector 1))))
d2866d6e KR	286
d2866d6e KR	287	(pass-if "short"
3963764d	288	(eq? 's16 (array-type (make-s16vector 1))))
d2866d6e KR	289
d2866d6e KR	290	(pass-if "ulong"
3963764d	291	(eq? 'u32 (array-type (make-u32vector 1))))
d2866d6e KR	292
d2866d6e KR	293	(pass-if "long"
3963764d	294	(eq? 's32 (array-type (make-s32vector 1))))
d2866d6e	295
3963764d MV	296	(pass-if "long long"
3963764d MV	297	(eq? 's64 (array-type (make-s64vector 1))))
d2866d6e KR	298
d2866d6e KR	299	(pass-if "float"
3963764d	300	(eq? 'f32 (array-type (make-f32vector 1))))
d2866d6e KR	301
d2866d6e KR	302	(pass-if "double"
3963764d	303	(eq? 'f64 (array-type (make-f64vector 1))))
d2866d6e KR	304
d2866d6e KR	305	(pass-if "complex"
3963764d	306	(eq? 'c64 (array-type (make-c64vector 1))))
d2866d6e KR	307
d2866d6e KR	308	(pass-if "scm"
3963764d	309	(eq? #t (array-type (make-vector 1)))))
d2866d6e	310
3963764d	311	(with-test-prefix "on make-typed-array"
d2866d6e	312
3963764d MV	313	(let ((types '(b a u8 s8 u16 s16 u32 s32 u64 u64 f32 f64 c32 c64)))
	314	(for-each (lambda (type)
	315	(pass-if (symbol->string type)
	316	(eq? type
28c1c15c MV	317	(array-type (make-typed-array type
	318	unspecified
	319	'(5 6))))))
3963764d	320	types))))
f410f8e7	321
a1f3180a KR	322	;;;
	323	;;; array-set!
	324	;;;
	325
	326	(with-test-prefix "array-set!"
	327
6e7d5622 KR	328	(with-test-prefix "bitvector"
	329
	330	;; in Guile 1.8.0 a bug in bitvector_set() caused a segv in array-set!
	331	;; on a bitvector like the following
	332	(let ((a (make-bitvector 1)))
	333	(pass-if "one elem set #t"
	334	(begin
	335	(array-set! a #t 0)
	336	(eq? #t (array-ref a 0))))
	337	(pass-if "one elem set #f"
	338	(begin
	339	(array-set! a #f 0)
	340	(eq? #f (array-ref a 0))))))
	341
7f9ca7c3 KR	342	(with-test-prefix "byte"
7f9ca7c3 KR	343
3963764d	344	(let ((a (make-s8vector 1)))
7f9ca7c3 KR	345
	346	(pass-if "-128"
	347	(begin (array-set! a -128 0) #t))
	348	(pass-if "0"
	349	(begin (array-set! a 0 0) #t))
	350	(pass-if "127"
	351	(begin (array-set! a 127 0) #t))
	352	(pass-if-exception "-129" exception:out-of-range
	353	(begin (array-set! a -129 0) #t))
	354	(pass-if-exception "128" exception:out-of-range
af4701b0	355	(begin (array-set! a 128 0) #t))))
7f9ca7c3	356
a1f3180a KR	357	(with-test-prefix "short"
a1f3180a KR	358
3963764d	359	(let ((a (make-s16vector 1)))
a1f3180a KR	360	;; true if n can be array-set! into a
	361	(define (fits? n)
	362	(false-if-exception (begin (array-set! a n 0) #t)))
	363
	364	(with-test-prefix "store/fetch"
	365	;; Check array-ref gives back what was put with array-set!.
	366	;; In Guile 1.6.4 and earlier, array-set! only demanded an inum and
	367	;; would silently truncate to a short.
	368
	369	(do ((n 1 (1+ (* 2 n)))) ;; n=2^k-1
	370	((not (fits? n)))
	371	(array-set! a n 0)
	372	(pass-if n
	373	(= n (array-ref a 0))))
	374
	375	(do ((n -1 (* 2 n))) ;; -n=2^k
	376	((not (fits? n)))
	377	(array-set! a n 0)
	378	(pass-if n
	379	(= n (array-ref a 0))))))))
	380
f410f8e7	381	;;;
bd6713d5	382	;;; array-set!
f410f8e7 KR	383	;;;
f410f8e7 KR	384
bd6713d5	385	(with-test-prefix "array-set!"
f410f8e7 KR	386
f410f8e7 KR	387	(with-test-prefix "one dim"
3963764d	388	(let ((a (make-array #f '(3 5))))
f410f8e7	389	(pass-if "start"
bd6713d5	390	(array-set! a 'y 3)
f410f8e7 KR	391	#t)
f410f8e7 KR	392	(pass-if "end"
bd6713d5	393	(array-set! a 'y 5)
f410f8e7 KR	394	#t)
f410f8e7 KR	395	(pass-if-exception "start-1" exception:out-of-range
bd6713d5	396	(array-set! a 'y 2))
f410f8e7	397	(pass-if-exception "end+1" exception:out-of-range
bd6713d5	398	(array-set! a 'y 6))
f410f8e7	399	(pass-if-exception "two indexes" exception:out-of-range
bd6713d5	400	(array-set! a 'y 6 7))))
f410f8e7 KR	401
f410f8e7 KR	402	(with-test-prefix "two dim"
3963764d	403	(let ((a (make-array #f '(3 5) '(7 9))))
f410f8e7	404	(pass-if "start"
bd6713d5	405	(array-set! a 'y 3 7)
f410f8e7 KR	406	#t)
f410f8e7 KR	407	(pass-if "end"
bd6713d5	408	(array-set! a 'y 5 9)
f410f8e7 KR	409	#t)
f410f8e7 KR	410	(pass-if-exception "start i-1" exception:out-of-range
bd6713d5	411	(array-set! a 'y 2 7))
f410f8e7	412	(pass-if-exception "end i+1" exception:out-of-range
bd6713d5	413	(array-set! a 'y 6 9))
34ea1617	414	(pass-if-exception "one index" exception:wrong-num-indices
bd6713d5	415	(array-set! a 'y 4))
34ea1617	416	(pass-if-exception "three indexes" exception:wrong-num-indices
bd6713d5	417	(array-set! a 'y 4 8 0)))))
3fdb8558	418
60176421 KR	419	;;;
	420	;;; make-shared-array
	421	;;;
	422
6e7d5622 KR	423	(define exception:mapping-out-of-range
	424	(cons 'misc-error "^mapping out of range")) ;; per scm_make_shared_array
	425
60176421 KR	426	(with-test-prefix "make-shared-array"
60176421 KR	427
6e7d5622 KR	428	;; this failed in guile 1.8.0
	429	(pass-if "vector unchanged"
	430	(let* ((a (make-array #f '(0 7)))
	431	(s (make-shared-array a list '(0 7))))
	432	(array-equal? a s)))
	433
	434	(pass-if-exception "vector, high too big" exception:mapping-out-of-range
	435	(let* ((a (make-array #f '(0 7))))
	436	(make-shared-array a list '(0 8))))
	437
	438	(pass-if-exception "vector, low too big" exception:out-of-range
	439	(let* ((a (make-array #f '(0 7))))
	440	(make-shared-array a list '(-1 7))))
	441
	442	(pass-if "truncate columns"
	443	(array-equal? (make-shared-array #2((a b c) (d e f) (g h i)) list 3 2)
	444	#2((a b) (d e) (g h))))
	445
	446	(pass-if "pick one column"
	447	(array-equal? (make-shared-array #2((a b c) (d e f) (g h i))
	448	(lambda (i) (list i 2))
	449	'(0 2))
	450	#(c f i)))
	451
	452	(pass-if "diagonal"
	453	(array-equal? (make-shared-array #2((a b c) (d e f) (g h i))
	454	(lambda (i) (list i i))
	455	'(0 2))
	456	#(a e i)))
	457
	458	;; this failed in guile 1.8.0
	459	(pass-if "2 dims from 1 dim"
	460	(array-equal? (make-shared-array #1(a b c d e f g h i j k l)
	461	(lambda (i j) (list (+ (* i 3) j)))
	462	4 3)
	463	#2((a b c) (d e f) (g h i) (j k l))))
	464
	465	(pass-if "reverse columns"
	466	(array-equal? (make-shared-array #2((a b c) (d e f) (g h i))
	467	(lambda (i j) (list i (- 2 j)))
	468	3 3)
	469	#2((c b a) (f e d) (i h g))))
	470
	471	(pass-if "fixed offset, 0 based becomes 1 based"
	472	(let* ((x #2((a b c) (d e f) (g h i)))
	473	(y (make-shared-array x
	474	(lambda (i j) (list (1- i) (1- j)))
	475	'(1 3) '(1 3))))
	476	(and (eq? (array-ref x 0 0) 'a)
	477	(eq? (array-ref y 1 1) 'a))))
	478
	479	;; this failed in guile 1.8.0
	480	(pass-if "stride every third element"
	481	(array-equal? (make-shared-array #1(a b c d e f g h i j k l)
	482	(lambda (i) (list (* i 3)))
	483	4)
	484	#1(a d g j)))
	485
60176421 KR	486	(pass-if "shared of shared"
	487	(let* ((a #2((1 2 3) (4 5 6) (7 8 9)))
	488	(s1 (make-shared-array a (lambda (i) (list i 1)) 3))
	489	(s2 (make-shared-array s1 list '(1 2))))
	490	(and (eqv? 5 (array-ref s2 1))
	491	(eqv? 8 (array-ref s2 2))))))
	492
3fdb8558 KR	493	;;;
	494	;;; uniform-vector-ref
	495	;;;
	496
	497	(with-test-prefix "uniform-vector-ref"
	498
	499	(with-test-prefix "byte"
	500
3963764d	501	(let ((a (make-s8vector 1)))
3fdb8558 KR	502
	503	(pass-if "0"
	504	(begin
	505	(array-set! a 0 0)
	506	(= 0 (uniform-vector-ref a 0))))
	507	(pass-if "127"
	508	(begin
	509	(array-set! a 127 0)
	510	(= 127 (uniform-vector-ref a 0))))
	511	(pass-if "-128"
	512	(begin
	513	(array-set! a -128 0)
3fdb8558	514	(= -128 (uniform-vector-ref a 0)))))))