;;;; unif.test --- tests guile's uniform arrays     -*- scheme -*-
;;;;
;;;; Copyright 2004 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., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA

(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 (eq? #t (array? bool  	  #t)))
      (pass-if (eq? #f (array? char  	  #t)))
      (pass-if (eq? #f (array? byte  	  #t)))
      (pass-if (eq? #f (array? short 	  #t)))
      (pass-if (eq? #f (array? ulong 	  #t)))
      (pass-if (eq? #f (array? long  	  #t)))
      (if have-llvect?
	  (pass-if (eq? #f (array? longlong #t))))
      (pass-if (eq? #f (array? float    #t)))
      (pass-if (eq? #f (array? double   #t)))
      (pass-if (eq? #f (array? complex  #t)))
      (pass-if (eq? #f (array? scm      #t))))

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

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

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

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

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

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

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

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

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

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

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

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

  (with-test-prefix "bool"
    (let ((a (make-uniform-vector 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-uniform-vector 1 #\a)))
      (pass-if "x" (array-fill! a #\x) #t)))

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

  (with-test-prefix "short"
    (let ((a (make-uniform-vector 1 's)))
      (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-uniform-vector 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-uniform-vector 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-uniform-vector 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-uniform-vector 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-prototype
;;;

(with-test-prefix "array-prototype"

  (with-test-prefix "on make-uniform-vector"

    (pass-if "bool"
      (eq? #t (array-prototype (make-uniform-vector 1 #t))))

    (pass-if "char"
      (char=? #\a (array-prototype (make-uniform-vector 1 #\a))))

    (pass-if "byte"
      (char=? #\nul (array-prototype (make-uniform-vector 1 #\nul))))

    (pass-if "short"
      (eq? 's (array-prototype (make-uniform-vector 1 's))))

    (pass-if "ulong"
      (let ((p (array-prototype (make-uniform-vector 1 1))))
	(and (= 1 p)
	     (exact? p))))

    (pass-if "long"
      (= -1 (array-prototype (make-uniform-vector 1 -1))))

    (if have-llvect?
	(pass-if "long long"
	  (eq? 'l (array-prototype (make-uniform-vector 1 'l)))))

    (pass-if "float"
      (let ((p (array-prototype (make-uniform-vector 1 1.0))))
	(and (= 1.0 p)
	     (not (exact? p)))))

    (pass-if "double"
      (let ((p (array-prototype (make-uniform-vector 1 1/3))))
	(and (= 1/3 p)
	     (exact? p))))

    (pass-if "complex"
      (= 0+i (array-prototype (make-uniform-vector 1 0+i))))

    (pass-if "scm"
      (eq? '() (array-prototype (make-uniform-vector 1 '())))))

  (with-test-prefix "on make-uniform-array"

    (pass-if "bool"
      (eq? #t (array-prototype (make-uniform-array #t '(5 6)))))

    (pass-if "char"
      (char=? #\a (array-prototype (make-uniform-array #\a '(5 6)))))

    (pass-if "byte"
      (char=? #\nul (array-prototype (make-uniform-array #\nul '(5 6)))))

    (pass-if "short"
      (eq? 's (array-prototype (make-uniform-array 's '(5 6)))))

    (pass-if "ulong"
      (let ((p (array-prototype (make-uniform-array 1 '(5 6)))))
	(and (= 1 p)
	     (exact? p))))

    (pass-if "long"
      (let ((p (array-prototype (make-uniform-array -1 '(5 6)))))
	(and (= -1 p)
	     (exact? p))))

    (if have-llvect?
	(pass-if "long long"
	  (eq? 'l (array-prototype (make-uniform-array 'l '(5 6))))))

    (pass-if "float"
      (let ((p (array-prototype (make-uniform-array 1.0 '(5 6)))))
	(and (= 1.0 p)
	     (not (exact? p)))))

    (pass-if "double"
      (let ((p (array-prototype (make-uniform-array 1/3 '(5 6)))))
	(and (= 1/3 p)
	     (exact? p))))

    (pass-if "complex"
      (= 0+i (array-prototype (make-uniform-array 0+i '(5 6)))))

    (pass-if "scm"
      (eq? '() (array-prototype (make-uniform-array '() '(5 6)))))))

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