mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-05-02 21:10:27 +02:00
Code Activity
guile/test-suite/tests/unif.test
Marius Vollmer 7d81830dd2 The FSF has a new address.
2005-05-23 20:15:36 +00:00

387 lines
14 KiB
Scheme
Raw Blame History

;;;; 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)))))))
View git blame Copy permalink