;;;; unif.test --- tests guile's uniform arrays     -*- scheme -*-
;;;;
;;;; Copyright 2004 Free Software Foundation, Inc.
;;;;
;;;; This program is free software; you can redistribute it and/or modify
;;;; it under the terms of the GNU General Public License as published by
;;;; the Free Software Foundation; either version 2, or (at your option)
;;;; any later version.
;;;; 
;;;; This program 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 General Public License for more details.
;;;; 
;;;; You should have received a copy of the GNU General Public License
;;;; along with this software; see the file COPYING.  If not, write to
;;;; the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
;;;; Boston, MA 02110-1301 USA
;;;;
;;;; As a special exception, the Free Software Foundation gives permission
;;;; for additional uses of the text contained in its release of GUILE.
;;;;
;;;; The exception is that, if you link the GUILE library with other files
;;;; to produce an executable, this does not by itself cause the
;;;; resulting executable to be covered by the GNU General Public License.
;;;; Your use of that executable is in no way restricted on account of
;;;; linking the GUILE library code into it.
;;;;
;;;; This exception does not however invalidate any other reasons why
;;;; the executable file might be covered by the GNU General Public License.
;;;;
;;;; This exception applies only to the code released by the
;;;; Free Software Foundation under the name GUILE.  If you copy
;;;; code from other Free Software Foundation releases into a copy of
;;;; GUILE, as the General Public License permits, the exception does
;;;; not apply to the code that you add in this way.  To avoid misleading
;;;; anyone as to the status of such modified files, you must delete
;;;; this exception notice from them.
;;;;
;;;; If you write modifications of your own for GUILE, it is your choice
;;;; whether to permit this exception to apply to your modifications.
;;;; If you do not wish that, delete this exception notice.  

(define-module (test-suite test-unif)
  #:use-module (test-suite lib))

;; true if long long uniform arrays are available
(define have-llvect?  (false-if-exception (make-uniform-vector 1 'l)))


;;;
;;; array?
;;;

(with-test-prefix "array?"

  (let ((bool     (make-uniform-array #t    '(5 6)))
	(char     (make-uniform-array #\a   '(5 6)))
	(byte     (make-uniform-array #\nul '(5 6)))
	(short    (make-uniform-array 's    '(5 6)))
	(ulong    (make-uniform-array 1     '(5 6)))
	(long     (make-uniform-array -1    '(5 6)))
	(longlong (and have-llvect?
		       (make-uniform-array 'l '(5 6))))
	(float    (make-uniform-array 1.0   '(5 6)))
	(double   (make-uniform-array 1/3   '(5 6)))
	(complex  (make-uniform-array 0+i   '(5 6)))
	(scm      (make-uniform-array '()   '(5 6))))

    (with-test-prefix "is bool"
      (pass-if "bool"  (eq? #t (array? bool  	  #t)))
      (pass-if "char"  (eq? #f (array? char  	  #t)))
      (pass-if "byte"  (eq? #f (array? byte  	  #t)))
      (pass-if "short" (eq? #f (array? short 	  #t)))
      (pass-if "ulong" (eq? #f (array? ulong 	  #t)))
      (pass-if "long"  (eq? #f (array? long  	  #t)))
      (if have-llvect?
	  (pass-if "longlong" (eq? #f (array? longlong #t))))
      (pass-if "float"   (eq? #f (array? float    #t)))
      (pass-if "double"  (eq? #f (array? double   #t)))
      (pass-if "complex" (eq? #f (array? complex  #t)))
      (pass-if "scm"     (eq? #f (array? scm      #t))))

    (with-test-prefix "is char"
      (pass-if "bool"  (eq? #f (array? bool  	  #\a)))
      (pass-if "char"  (eq? #t (array? char  	  #\a)))
      (pass-if "byte"  (eq? #f (array? byte  	  #\a)))
      (pass-if "short" (eq? #f (array? short 	  #\a)))
      (pass-if "ulong" (eq? #f (array? ulong 	  #\a)))
      (pass-if "long"  (eq? #f (array? long  	  #\a)))
      (if have-llvect?
	  (pass-if "longlong" (eq? #f (array? longlong #\a))))
      (pass-if "float"   (eq? #f (array? float    #\a)))
      (pass-if "double"  (eq? #f (array? double   #\a)))
      (pass-if "complex" (eq? #f (array? complex  #\a)))
      (pass-if "scm"     (eq? #f (array? scm      #\a))))

    (with-test-prefix "is byte"
      (pass-if "bool"  (eq? #f (array? bool  	  #\nul)))
      (pass-if "char"  (eq? #f (array? char  	  #\nul)))
      (pass-if "byte"  (eq? #t (array? byte  	  #\nul)))
      (pass-if "short" (eq? #f (array? short 	  #\nul)))
      (pass-if "ulong" (eq? #f (array? ulong 	  #\nul)))
      (pass-if "long"  (eq? #f (array? long  	  #\nul)))
      (if have-llvect?
	  (pass-if "longlong" (eq? #f (array? longlong #\nul))))
      (pass-if "float"   (eq? #f (array? float    #\nul)))
      (pass-if "double"  (eq? #f (array? double   #\nul)))
      (pass-if "complex" (eq? #f (array? complex  #\nul)))
      (pass-if "scm"     (eq? #f (array? scm      #\nul))))

    (with-test-prefix "is short"
      (pass-if "bool"  (eq? #f (array? bool  	  's)))
      (pass-if "char"  (eq? #f (array? char  	  's)))
      (pass-if "byte"  (eq? #f (array? byte  	  's)))
      (pass-if "short" (eq? #t (array? short 	  's)))
      (pass-if "ulong" (eq? #f (array? ulong 	  's)))
      (pass-if "long"  (eq? #f (array? long  	  's)))
      (if have-llvect?
	  (pass-if "longlong" (eq? #f (array? longlong 's))))
      (pass-if "float"   (eq? #f (array? float    's)))
      (pass-if "double"  (eq? #f (array? double   's)))
      (pass-if "complex" (eq? #f (array? complex  's)))
      (pass-if "scm"     (eq? #f (array? scm      's))))

    (with-test-prefix "is ulong"
      (pass-if "bool"  (eq? #f (array? bool  	  1)))
      (pass-if "char"  (eq? #f (array? char  	  1)))
      (pass-if "byte"  (eq? #f (array? byte  	  1)))
      (pass-if "short" (eq? #f (array? short 	  1)))
      (pass-if "ulong" (eq? #t (array? ulong 	  1)))
      (pass-if "long"  (eq? #f (array? long  	  1)))
      (if have-llvect?
	  (pass-if "longlong" (eq? #f (array? longlong 1))))
      (pass-if "float"   (eq? #f (array? float    1)))
      (pass-if "double"  (eq? #f (array? double   1)))
      (pass-if "complex" (eq? #f (array? complex  1)))
      (pass-if "scm"     (eq? #f (array? scm      1))))

    (with-test-prefix "is long"
      (pass-if "bool"  (eq? #f (array? bool  	  -1)))
      (pass-if "char"  (eq? #f (array? char  	  -1)))
      (pass-if "byte"  (eq? #f (array? byte  	  -1)))
      (pass-if "short" (eq? #f (array? short 	  -1)))
      (pass-if "ulong" (eq? #f (array? ulong 	  -1)))
      (pass-if "long"  (eq? #t (array? long  	  -1)))
      (if have-llvect?
	  (pass-if "longlong" (eq? #f (array? longlong -1))))
      (pass-if "float"   (eq? #f (array? float    -1)))
      (pass-if "double"  (eq? #f (array? double   -1)))
      (pass-if "complex" (eq? #f (array? complex  -1)))
      (pass-if "scm"     (eq? #f (array? scm      -1))))

    (with-test-prefix "is long long"
      (pass-if "bool"  (eq? #f (array? bool  	  'l)))
      (pass-if "char"  (eq? #f (array? char  	  'l)))
      (pass-if "byte"  (eq? #f (array? byte  	  'l)))
      (pass-if "short" (eq? #f (array? short 	  'l)))
      (pass-if "ulong" (eq? #f (array? ulong 	  'l)))
      (pass-if "long"  (eq? #f (array? long  	  'l)))
      (if have-llvect?
	  (pass-if "longlong" (eq? #t (array? longlong 'l))))
      (pass-if "float"   (eq? #f (array? float    'l)))
      (pass-if "double"  (eq? #f (array? double   'l)))
      (pass-if "complex" (eq? #f (array? complex  'l)))
      (pass-if "scm"     (eq? #f (array? scm      'l))))

    (with-test-prefix "is float"
      (pass-if "bool"  (eq? #f (array? bool  	  1.0)))
      (pass-if "char"  (eq? #f (array? char  	  1.0)))
      (pass-if "byte"  (eq? #f (array? byte  	  1.0)))
      (pass-if "short" (eq? #f (array? short 	  1.0)))
      (pass-if "ulong" (eq? #f (array? ulong 	  1.0)))
      (pass-if "long"  (eq? #f (array? long  	  1.0)))
      (if have-llvect?
	  (pass-if "longlong" (eq? #f (array? longlong 1.0))))
      (pass-if "float"   (eq? #t (array? float    1.0)))
      (pass-if "double"  (eq? #f (array? double   1.0)))
      (pass-if "complex" (eq? #f (array? complex  1.0)))
      (pass-if "scm"     (eq? #f (array? scm      1.0))))

    (with-test-prefix "is double"
      (pass-if "bool"  (eq? #f (array? bool  	  1/3)))
      (pass-if "char"  (eq? #f (array? char  	  1/3)))
      (pass-if "byte"  (eq? #f (array? byte  	  1/3)))
      (pass-if "short" (eq? #f (array? short 	  1/3)))
      (pass-if "ulong" (eq? #f (array? ulong 	  1/3)))
      (pass-if "long"  (eq? #f (array? long  	  1/3)))
      (if have-llvect?
	  (pass-if "longlong" (eq? #f (array? longlong 1/3))))
      (pass-if "float"   (eq? #f (array? float    1/3)))
      (pass-if "double"  (eq? #t (array? double   1/3)))
      (pass-if "complex" (eq? #f (array? complex  1/3)))
      (pass-if "scm"     (eq? #f (array? scm      1/3))))

    (with-test-prefix "is complex"
      (pass-if "bool"  (eq? #f (array? bool  	  0+i)))
      (pass-if "char"  (eq? #f (array? char  	  0+i)))
      (pass-if "byte"  (eq? #f (array? byte  	  0+i)))
      (pass-if "short" (eq? #f (array? short 	  0+i)))
      (pass-if "ulong" (eq? #f (array? ulong 	  0+i)))
      (pass-if "long"  (eq? #f (array? long  	  0+i)))
      (if have-llvect?
	  (pass-if "longlong" (eq? #f (array? longlong 0+i))))
      (pass-if "float"   (eq? #f (array? float    0+i)))
      (pass-if "double"  (eq? #f (array? double   0+i)))
      (pass-if "complex" (eq? #t (array? complex  0+i)))
      (pass-if "scm"     (eq? #f (array? scm      0+i))))

    (with-test-prefix "is scm"
      (pass-if "bool"  (eq? #f (array? bool  	  '())))
      (pass-if "char"  (eq? #f (array? char  	  '())))
      (pass-if "byte"  (eq? #f (array? byte  	  '())))
      (pass-if "short" (eq? #f (array? short 	  '())))
      (pass-if "ulong" (eq? #f (array? ulong 	  '())))
      (pass-if "long"  (eq? #f (array? long  	  '())))
      (if have-llvect?
	  (pass-if "longlong" (eq? #f (array? longlong '()))))
      (pass-if "float"   (eq? #f (array? float    '())))
      (pass-if "double"  (eq? #f (array? double   '())))
      (pass-if "complex" (eq? #f (array? complex  '())))
      (pass-if "scm"     (eq? #t (array? scm      '()))))))

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

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

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

;;;
;;; array-fill!
;;;

(with-test-prefix "array-fill!"

  (with-test-prefix "byte"
    (let ((a (make-uniform-vector 1 #\nul)))
      (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)))))

;;;
;;; array-set!
;;;

(with-test-prefix "array-set!"

  (with-test-prefix "byte"

    (let ((a (make-uniform-array #\nul 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))

      (pass-if "#\\nul"
	(begin (array-set! a #\nul 0) #t))
      (pass-if "#\\del"
	(begin (array-set! a #\del 0) #t))
      (pass-if "char 255"
	(begin (array-set! a (integer->char 255) 0) #t))))

  (with-test-prefix "short"

    (let ((a (make-uniform-array 's 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))))))))

;;;
;;; uniform-array-set1!
;;;

(with-test-prefix "uniform-array-set1!"

  (with-test-prefix "one dim"
    (let ((a (make-uniform-array '() '(3 5))))
      (pass-if "start"
	(uniform-array-set1! a 'y '(3))
	#t)
      (pass-if "end"
	(uniform-array-set1! a 'y '(5))
	#t)
      (pass-if-exception "start-1" exception:out-of-range
	(uniform-array-set1! a 'y '(2)))
      (pass-if-exception "end+1" exception:out-of-range
	(uniform-array-set1! a 'y '(6)))
      (pass-if-exception "two indexes" exception:out-of-range
	(uniform-array-set1! a 'y '(6 7)))
      (pass-if-exception "two improper indexes" exception:out-of-range
	(uniform-array-set1! a 'y '(6 . 7)))
      (pass-if-exception "three improper indexes" exception:out-of-range
	(uniform-array-set1! a 'y '(6 7 . 8)))))

  (with-test-prefix "two dim"
    (let ((a (make-uniform-array '() '(3 5) '(7 9))))
      (pass-if "start"
	(uniform-array-set1! a 'y '(3 7))
	#t)
      (pass-if "end"
	(uniform-array-set1! a 'y '(5 9))
	#t)
      (pass-if-exception "start i-1" exception:out-of-range
	(uniform-array-set1! a 'y '(2 7)))
      (pass-if-exception "end i+1" exception:out-of-range
	(uniform-array-set1! a 'y '(6 9)))
      (pass-if-exception "one index" exception:wrong-num-args
	(uniform-array-set1! a 'y '(4)))
      (pass-if-exception "three indexes" exception:wrong-num-args
	(uniform-array-set1! a 'y '(4 8 0)))
      (pass-if-exception "two improper indexes" exception:wrong-num-args
	(uniform-array-set1! a 'y '(4 . 8)))
      (pass-if-exception "three improper indexes" exception:wrong-num-args
	(uniform-array-set1! a 'y '(4 8 . 0))))))

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

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

  (with-test-prefix "byte"

    (let ((a (make-uniform-array #\nul 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))))

      (pass-if "#\\nul"
	(begin
	  (array-set! a #\nul 0)
	  (= 0 (uniform-vector-ref a 0))))
      (pass-if "#\\del"
	(begin
	  (array-set! a #\del 0)
	  (= 127 (uniform-vector-ref a 0))))
      (pass-if "char 255"
	(begin
	  (array-set! a (integer->char 255) 0)
	  (= -1 (uniform-vector-ref a 0))))
      (pass-if "char 128"
	(begin
	  (array-set! a (integer->char 128) 0)
	  (= -128 (uniform-vector-ref a 0)))))))