[Top][All Lists]
[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
[Guile-commits] GNU Guile branch, master, updated. release_1-9-9-35-g92d
|
From: |
Andy Wingo |
|
Subject: |
[Guile-commits] GNU Guile branch, master, updated. release_1-9-9-35-g92d3387 |
|
Date: |
Wed, 31 Mar 2010 20:31:40 +0000 |
This is an automated email from the git hooks/post-receive script. It was
generated because a ref change was pushed to the repository containing
the project "GNU Guile".
http://git.savannah.gnu.org/cgit/guile.git/commit/?id=92d33877d9f8523eaebab75373a30f161e6cc1e8
The branch, master has been updated
via 92d33877d9f8523eaebab75373a30f161e6cc1e8 (commit)
via 8ecd1943ef7bbef67b83b0502da1527e3b7a7133 (commit)
via e275b8a220f39b5a1ff9644ac21796a12e4d0c9a (commit)
from 28828f40eb8ea7e10e35aa1e83ebf37449350c08 (commit)
Those revisions listed above that are new to this repository have
not appeared on any other notification email; so we list those
revisions in full, below.
- Log -----------------------------------------------------------------
commit 92d33877d9f8523eaebab75373a30f161e6cc1e8
Author: Andy Wingo <address@hidden>
Date: Wed Mar 31 22:31:11 2010 +0200
fix array bugs in ecmascript
* module/language/ecmascript/array.scm (pput, *array-prototype*): Fix
bugs in ecmascript array runtime.
commit 8ecd1943ef7bbef67b83b0502da1527e3b7a7133
Author: Andy Wingo <address@hidden>
Date: Wed Mar 31 22:29:29 2010 +0200
fix bug in ash opcode
* libguile/vm-i-scheme.c (ash): Fix embarrassing bug in (ash 1 32).
* test-suite/tests/bit-operations.test ("bitshifts on word boundaries"):
Add tests.
commit e275b8a220f39b5a1ff9644ac21796a12e4d0c9a
Author: Andy Wingo <address@hidden>
Date: Wed Mar 31 21:16:54 2010 +0200
rename unif.test to arrays.test
* test-suite/tests/arrays.test: Move all unif.test here. Unif.test was
mostly testing arrays anyway. Incorporate the existing arrays.test.
* test-suite/tests/unif.test: Deleted.
* test-suite/Makefile.am: Update.
-----------------------------------------------------------------------
Summary of changes:
libguile/vm-i-scheme.c | 19 +-
module/language/ecmascript/array.scm | 8 +-
test-suite/Makefile.am | 1 -
test-suite/tests/arrays.test | 565 +++++++++++++++++++++++++++++++++-
test-suite/tests/bit-operations.test | 6 +-
test-suite/tests/unif.test | 572 ----------------------------------
6 files changed, 584 insertions(+), 587 deletions(-)
delete mode 100644 test-suite/tests/unif.test
diff --git a/libguile/vm-i-scheme.c b/libguile/vm-i-scheme.c
index ecc77bd..df31810 100644
--- a/libguile/vm-i-scheme.c
+++ b/libguile/vm-i-scheme.c
@@ -287,10 +287,23 @@ VM_DEFINE_FUNCTION (157, ash, "ash", 2)
if (SCM_I_INUMP (x) && SCM_I_INUMP (y))
{
if (SCM_I_INUM (y) < 0)
+ /* Right shift, will be a fixnum. */
RETURN (SCM_I_MAKINUM (SCM_I_INUM (x) >> -SCM_I_INUM (y)));
- else if ((SCM_I_INUM (x) << SCM_I_INUM (y)) >> SCM_I_INUM (y)
- == SCM_I_INUM (x))
- RETURN (SCM_I_MAKINUM (SCM_I_INUM (x) << SCM_I_INUM (y)));
+ else
+ /* Left shift. See comments in scm_ash. */
+ {
+ long nn, bits_to_shift;
+
+ nn = SCM_I_INUM (x);
+ bits_to_shift = SCM_I_INUM (y);
+
+ if (bits_to_shift < SCM_I_FIXNUM_BIT-1
+ && ((unsigned long)
+ (SCM_SRS (nn, (SCM_I_FIXNUM_BIT-1 - bits_to_shift)) + 1)
+ <= 1))
+ RETURN (SCM_I_MAKINUM (nn << bits_to_shift));
+ /* fall through */
+ }
/* fall through */
}
SYNC_REGISTER ();
diff --git a/module/language/ecmascript/array.scm
b/module/language/ecmascript/array.scm
index e9fc3c6..9970345 100644
--- a/module/language/ecmascript/array.scm
+++ b/module/language/ecmascript/array.scm
@@ -1,6 +1,6 @@
;;; ECMAScript for Guile
-;; Copyright (C) 2009 Free Software Foundation, Inc.
+;; Copyright (C) 2009, 2010 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
@@ -63,12 +63,12 @@
(cond ((and (integer? p) (exact? p) (>= 0 p))
(let ((vect (js-array-vector o)))
(if (< p (vector-length vect))
- (vector-set! vect p)
+ (vector-set! vect p v)
;; Fixme: round up to powers of 2?
(let ((new (make-vector (1+ p) 0)))
(vector-move-left! vect 0 (vector-length vect) new 0)
(set! (js-array-vector o) new)
- (vector-set! new p)))))
+ (vector-set! new p v)))))
((or (and (symbol? p) (eq? p 'length))
(and (string? p) (string=? p "length")))
(let ((vect (js-array-vector o)))
@@ -93,7 +93,7 @@
((is-a? (car objs) <js-array-object>)
(let ((v (js-array-vector (car objs))))
(vector-move-left! v 0 (vector-length v)
- rv i (+ i (vector-length v)))
+ rv i)
(lp (cdr objs) (+ i (vector-length v)))))
(else
(error "generic array concats not yet implemented"))))))
diff --git a/test-suite/Makefile.am b/test-suite/Makefile.am
index afd206f..bc166c4 100644
--- a/test-suite/Makefile.am
+++ b/test-suite/Makefile.am
@@ -116,7 +116,6 @@ SCM_TESTS = tests/00-initial-env.test \
tests/threads.test \
tests/time.test \
tests/tree-il.test \
- tests/unif.test \
tests/version.test \
tests/vlist.test \
tests/weaks.test
diff --git a/test-suite/tests/arrays.test b/test-suite/tests/arrays.test
index 30dc750..4eba805 100644
--- a/test-suite/tests/arrays.test
+++ b/test-suite/tests/arrays.test
@@ -1,6 +1,6 @@
-;;;; arrays.test --- tests guile's arrays -*- scheme -*-
+;;;; unif.test --- tests guile's uniform arrays -*- scheme -*-
;;;;
-;;;; Copyright 2010 Free Software Foundation, Inc.
+;;;; Copyright 2004, 2006, 2009, 2010 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
@@ -16,8 +16,561 @@
;;;; 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))
+(define-module (test-suite test-arrays)
+ #:use-module ((system base compile) #:select (compile))
+ #:use-module (test-suite lib)
+ #:use-module (srfi srfi-4)
+ #:use-module (srfi srfi-4 gnu))
-(pass-if "equal? on array and non-array"
- (not (equal? #2f64((0 1) (2 3)) 100)))
+;;;
+;;; array?
+;;;
+
+(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.*"))
+
+
+(with-test-prefix "sanity"
+ ;; At the current time of writing, bignums have a tc7 that is one bit
+ ;; away from strings. It used to be that the vector implementation
+ ;; registered for strings had the TYP7S mask, not the TYP7 mask,
+ ;; making the system think that bignums were vectors. Doh!
+ (pass-if (not (uniform-vector? 12345678901234567890123456789))))
+
+(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)))))))
+
+;;;
+;;; syntax
+;;;
+
+(with-test-prefix "syntax"
+
+ (pass-if "rank and lower bounds"
+ ;; uniform u32 array of rank 2 with index ranges 2..3 and 7..8.
+ (let ((a 'address@hidden@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 'address@hidden(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))))
+
+;;;
+;;; equal? with vector and one-dimensional array
+;;;
+
+(with-test-prefix "equal?"
+ (pass-if "array and non-array"
+ (not (equal? #2f64((0 1) (2 3)) 100)))
+
+ (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))))
diff --git a/test-suite/tests/bit-operations.test
b/test-suite/tests/bit-operations.test
index 0e9df7d..e7da571 100644
--- a/test-suite/tests/bit-operations.test
+++ b/test-suite/tests/bit-operations.test
@@ -1,5 +1,5 @@
;;;; bit-operations.test --- bitwise operations on numbers -*- scheme -*-
-;;;; Copyright (C) 2000, 2001, 2003, 2006, 2009 Free Software Foundation, Inc.
+;;;; Copyright (C) 2000, 2001, 2003, 2006, 2009, 2010 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
@@ -362,3 +362,7 @@
(+ fixnum-bit fixnum-bit 1) (- (ash 1 (+ fixnum-bit 1)) 1))
(list (- fixnum-min 1) (+ fixnum-bit 1)
(+ fixnum-bit fixnum-bit 2) (- (ash 1 (+ fixnum-bit 1)) 1))))))
+
+(with-test-prefix "bitshifts on word boundaries"
+ (pass-if (= (ash 1 32) 4294967296))
+ (pass-if (= (ash 1 64) 18446744073709551616)))
diff --git a/test-suite/tests/unif.test b/test-suite/tests/unif.test
deleted file mode 100644
index a850dba..0000000
--- a/test-suite/tests/unif.test
+++ /dev/null
@@ -1,572 +0,0 @@
-;;;; unif.test --- tests guile's uniform arrays -*- scheme -*-
-;;;;
-;;;; Copyright 2004, 2006, 2009, 2010 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-unif)
- #:use-module ((system base compile) #:select (compile))
- #:use-module (test-suite lib)
- #:use-module (srfi srfi-4)
- #:use-module (srfi srfi-4 gnu))
-
-;;;
-;;; array?
-;;;
-
-(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.*"))
-
-
-(with-test-prefix "sanity"
- ;; At the current time of writing, bignums have a tc7 that is one bit
- ;; away from strings. It used to be that the vector implementation
- ;; registered for strings had the TYP7S mask, not the TYP7 mask,
- ;; making the system think that bignums were vectors. Doh!
- (pass-if (not (uniform-vector? 12345678901234567890123456789))))
-
-(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)))))))
-
-;;;
-;;; syntax
-;;;
-
-(with-test-prefix "syntax"
-
- (pass-if "rank and lower bounds"
- ;; uniform u32 array of rank 2 with index ranges 2..3 and 7..8.
- (let ((a 'address@hidden@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 'address@hidden(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))))
-
-;;;
-;;; equal? with vector and one-dimensional array
-;;;
-
-(pass-if "vector equal? 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)))
hooks/post-receive
--
GNU Guile
| [Prev in Thread] |
Current Thread |
[Next in Thread] |
- [Guile-commits] GNU Guile branch, master, updated. release_1-9-9-35-g92d3387,
Andy Wingo <=