diff --git a/test-suite/tests/srfi-1.test b/test-suite/tests/srfi-1.test new file mode 100644 index 000000000..236905e28 --- /dev/null +++ b/test-suite/tests/srfi-1.test @@ -0,0 +1,607 @@ +;;;; srfi-1.test --- Test suite for Guile's SRFI-1 functions. -*- scheme -*- +;;;; +;;;; Copyright 2003 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., 59 Temple Place, Suite 330, +;;;; Boston, MA 02111-1307 USA + +(use-modules (srfi srfi-1) + (test-suite lib)) + +(define (ref-delete x lst . proc) + "Reference implemenation of srfi-1 `delete'." + (set! proc (if (null? proc) equal? (car proc))) + (do ((ret '()) + (lst lst (cdr lst))) + ((null? lst) + (reverse! ret)) + (if (not (proc x (car lst))) + (set! ret (cons (car lst) ret))))) + +(define (ref-delete-duplicates lst . proc) + "Reference implemenation of srfi-1 `delete-duplicates'." + (set! proc (if (null? proc) equal? (car proc))) + (if (null? lst) + '() + (do ((keep '())) + ((null? lst) + (reverse! keep)) + (let ((elem (car lst))) + (set! keep (cons elem keep)) + (set! lst (ref-delete elem lst proc)))))) + + +;; +;; concatenate and concatenate! +;; + +(let () + (define (common-tests concatenate-proc unmodified?) + (define (try lstlst want) + (let ((lstlst-copy (copy-tree lstlst)) + (got (concatenate-proc lstlst))) + (if unmodified? + (if (not (equal? lstlst lstlst-copy)) + (error "input lists modified"))) + (equal? got want))) + + (pass-if-exception "too few args" exception:wrong-num-args + (concatenate-proc)) + + (pass-if-exception "too many args" exception:wrong-num-args + (concatenate-proc '() '())) + + (pass-if "no lists" + (try '() '())) + + (pass-if (try '((1)) '(1))) + (pass-if (try '((1 2)) '(1 2))) + (pass-if (try '(() (1)) '(1))) + (pass-if (try '(() () (1)) '(1))) + + (pass-if (try '((1) (2)) '(1 2))) + (pass-if (try '(() (1 2)) '(1 2))) + + (pass-if (try '((1) 2) '(1 . 2))) + (pass-if (try '((1) (2) 3) '(1 2 . 3))) + (pass-if (try '((1) (2) (3 . 4)) '(1 2 3 . 4))) + ) + + (with-test-prefix "concatenate" + (common-tests concatenate #t)) + + (with-test-prefix "concatenate!" + (common-tests concatenate! #f))) + +;; +;; count +;; + +(with-test-prefix "count" + (pass-if-exception "no args" exception:wrong-num-args + (count)) + + (pass-if-exception "one arg" exception:wrong-num-args + (count noop)) + + (with-test-prefix "one list" + (define (or1 x) + x) + + (pass-if "empty list" (= 0 (count or1 '()))) + + (pass-if-exception "pred arg count 0" exception:wrong-type-arg + (count (lambda () x) '(1 2 3))) + (pass-if-exception "pred arg count 2" exception:wrong-type-arg + (count (lambda (x y) x) '(1 2 3))) + + (pass-if-exception "improper 1" exception:wrong-type-arg + (count or1 1)) + (pass-if-exception "improper 2" exception:wrong-type-arg + (count or1 '(1 . 2))) + (pass-if-exception "improper 3" exception:wrong-type-arg + (count or1 '(1 2 . 3))) + + (pass-if (= 0 (count or1 '(#f)))) + (pass-if (= 1 (count or1 '(#t)))) + + (pass-if (= 0 (count or1 '(#f #f)))) + (pass-if (= 1 (count or1 '(#f #t)))) + (pass-if (= 1 (count or1 '(#t #f)))) + (pass-if (= 2 (count or1 '(#t #t)))) + + (pass-if (= 0 (count or1 '(#f #f #f)))) + (pass-if (= 1 (count or1 '(#f #f #t)))) + (pass-if (= 1 (count or1 '(#t #f #f)))) + (pass-if (= 2 (count or1 '(#t #f #t)))) + (pass-if (= 3 (count or1 '(#t #t #t))))) + + (with-test-prefix "two lists" + (define (or2 x y) + (or x y)) + + (pass-if "arg order" + (= 1 (count (lambda (x y) + (and (= 1 x) + (= 2 y))) + '(1) '(2)))) + + (pass-if "empty lists" (= 0 (count or2 '() '()))) + + (pass-if-exception "pred arg count 0" exception:wrong-type-arg + (count (lambda () #t) '(1 2 3) '(1 2 3))) + (pass-if-exception "pred arg count 1" exception:wrong-type-arg + (count (lambda (x) x) '(1 2 3) '(1 2 3))) + (pass-if-exception "pred arg count 3" exception:wrong-type-arg + (count (lambda (x y z) x) '(1 2 3) '(1 2 3))) + + (pass-if-exception "improper first 1" exception:wrong-type-arg + (count or2 1 '(1 2 3))) + (pass-if-exception "improper first 2" exception:wrong-type-arg + (count or2 '(1 . 2) '(1 2 3))) + (pass-if-exception "improper first 3" exception:wrong-type-arg + (count or2 '(1 2 . 3) '(1 2 3))) + + (pass-if-exception "improper second 1" exception:wrong-type-arg + (count or2 '(1 2 3) 1)) + (pass-if-exception "improper second 2" exception:wrong-type-arg + (count or2 '(1 2 3) '(1 . 2))) + (pass-if-exception "improper second 3" exception:wrong-type-arg + (count or2 '(1 2 3) '(1 2 . 3))) + + (pass-if (= 0 (count or2 '(#f) '(#f)))) + (pass-if (= 1 (count or2 '(#t) '(#f)))) + (pass-if (= 1 (count or2 '(#f) '(#t)))) + + (pass-if (= 0 (count or2 '(#f #f) '(#f #f)))) + (pass-if (= 1 (count or2 '(#t #f) '(#t #f)))) + (pass-if (= 2 (count or2 '(#t #t) '(#f #f)))) + (pass-if (= 2 (count or2 '(#t #f) '(#f #t)))) + + (with-test-prefix "stop shortest" + (pass-if (= 2 (count or2 '(#t #f #t) '(#f #t)))) + (pass-if (= 2 (count or2 '(#t #f #t #t) '(#f #t)))) + (pass-if (= 2 (count or2 '(#t #f) '(#f #t #t)))) + (pass-if (= 2 (count or2 '(#t #f) '(#f #t #t #t)))))) + + (with-test-prefix "three lists" + (define (or3 x y z) + (or x y z)) + + (pass-if "arg order" + (= 1 (count (lambda (x y z) + (and (= 1 x) + (= 2 y) + (= 3 z))) + '(1) '(2) '(3)))) + + (pass-if "empty lists" (= 0 (count or3 '() '() '()))) + + ;; currently bad pred argument gives wrong-num-args when 3 or more + ;; lists, as opposed to wrong-type-arg for 1 or 2 lists + (pass-if-exception "pred arg count 0" exception:wrong-num-args + (count (lambda () #t) '(1 2 3) '(1 2 3) '(1 2 3))) + (pass-if-exception "pred arg count 2" exception:wrong-num-args + (count (lambda (x y) x) '(1 2 3) '(1 2 3)'(1 2 3) )) + (pass-if-exception "pred arg count 4" exception:wrong-num-args + (count (lambda (w x y z) x) '(1 2 3) '(1 2 3) '(1 2 3))) + + (pass-if-exception "improper first 1" exception:wrong-type-arg + (count or3 1 '(1 2 3) '(1 2 3))) + (pass-if-exception "improper first 2" exception:wrong-type-arg + (count or3 '(1 . 2) '(1 2 3) '(1 2 3))) + (pass-if-exception "improper first 3" exception:wrong-type-arg + (count or3 '(1 2 . 3) '(1 2 3) '(1 2 3))) + + (pass-if-exception "improper second 1" exception:wrong-type-arg + (count or3 '(1 2 3) 1 '(1 2 3))) + (pass-if-exception "improper second 2" exception:wrong-type-arg + (count or3 '(1 2 3) '(1 . 2) '(1 2 3))) + (pass-if-exception "improper second 3" exception:wrong-type-arg + (count or3 '(1 2 3) '(1 2 . 3) '(1 2 3))) + + (pass-if-exception "improper third 1" exception:wrong-type-arg + (count or3 '(1 2 3) '(1 2 3) 1)) + (pass-if-exception "improper third 2" exception:wrong-type-arg + (count or3 '(1 2 3) '(1 2 3) '(1 . 2))) + (pass-if-exception "improper third 3" exception:wrong-type-arg + (count or3 '(1 2 3) '(1 2 3) '(1 2 . 3))) + + (pass-if (= 0 (count or3 '(#f) '(#f) '(#f)))) + (pass-if (= 1 (count or3 '(#t) '(#f) '(#f)))) + (pass-if (= 1 (count or3 '(#f) '(#t) '(#f)))) + (pass-if (= 1 (count or3 '(#f) '(#f) '(#t)))) + + (pass-if (= 0 (count or3 '(#f #f) '(#f #f) '(#f #f)))) + + (pass-if (= 1 (count or3 '(#t #f) '(#f #f) '(#f #f)))) + (pass-if (= 1 (count or3 '(#f #t) '(#f #f) '(#f #f)))) + (pass-if (= 1 (count or3 '(#f #f) '(#t #f) '(#f #f)))) + (pass-if (= 1 (count or3 '(#f #f) '(#f #t) '(#f #f)))) + (pass-if (= 1 (count or3 '(#f #f) '(#f #f) '(#t #f)))) + (pass-if (= 1 (count or3 '(#f #f) '(#f #f) '(#f #t)))) + + (pass-if (= 2 (count or3 '(#t #t) '(#f #f) '(#f #f)))) + (pass-if (= 2 (count or3 '(#f #f) '(#t #t) '(#f #f)))) + (pass-if (= 2 (count or3 '(#f #f) '(#f #f) '(#t #t)))) + (pass-if (= 2 (count or3 '(#f #f) '(#t #f) '(#f #t)))) + + (with-test-prefix "stop shortest" + (pass-if (= 0 (count or3 '() '(#t #t #t) '(#t #t)))) + (pass-if (= 0 (count or3 '(#t #t #t) '() '(#t #t)))) + (pass-if (= 0 (count or3 '(#t #t #t) '(#t #t) '()))) + + (pass-if (= 1 (count or3 '(#t) '(#t #t #t) '(#t #t)))) + (pass-if (= 1 (count or3 '(#t #t #t) '(#t) '(#t #t)))) + (pass-if (= 1 (count or3 '(#t #t #t) '(#t #t) '(#t))))))) + +;; +;; delete and delete! +;; + +(let () + ;; Call (PROC lst) for all lists of length up to 6, with all combinations + ;; of elements to be retained or deleted. Elements to retain are numbers, + ;; 0 upwards. Elements to be deleted are #f. + (define (test-lists proc) + (do ((n 0 (1+ n))) + ((>= n 6)) + (do ((limit (ash 1 n)) + (i 0 (1+ i))) + ((>= i limit)) + (let ((lst '())) + (do ((bit 0 (1+ bit))) + ((>= bit n)) + (set! lst (cons (if (logbit? bit i) bit #f) lst))) + (proc lst))))) + + (define (common-tests delete-proc) + (pass-if-exception "too few args" exception:wrong-num-args + (delete-proc 0)) + + (pass-if-exception "too many args" exception:wrong-num-args + (delete-proc 0 '() equal? 99)) + + (pass-if "empty" + (eq? '() (delete-proc 0 '()))) + + (pass-if "equal? (the default)" + (equal? '((1) (3)) + (delete-proc '(2) '((1) (2) (3))))) + + (pass-if "eq?" + (equal? '((1) (2) (3)) + (delete-proc '(2) '((1) (2) (3)) eq?))) + + (pass-if "called arg order" + (equal? '(1 2 3) + (delete-proc 3 '(1 2 3 4 5) <)))) + + (with-test-prefix "delete" + (common-tests delete) + + (test-lists + (lambda (lst) + (let ((lst-copy (list-copy lst))) + (with-test-prefix lst-copy + (pass-if "result" + (equal? (delete #f lst) + (ref-delete #f lst))) + (pass-if "non-destructive" + (equal? lst-copy lst))))))) + + (with-test-prefix "delete!" + (common-tests delete!) + + (test-lists + (lambda (lst) + (pass-if lst + (equal? (delete! #f lst) + (ref-delete #f lst))))))) + +;; +;; delete-duplicates and delete-duplicates! +;; + +(let () + ;; Call (PROC lst) for all lists of length 1 <= n <= 4, with all + ;; combinations of numbers 1 to n in the elements + (define (test-lists proc) + (do ((n 1 (1+ n))) + ((> n 4)) + (do ((limit (integer-expt n n)) + (i 0 (1+ i))) + ((>= i limit)) + (let ((lst '())) + (do ((j 0 (1+ j)) + (rem i (quotient rem n))) + ((>= j n)) + (set! lst (cons (remainder rem n) lst))) + (proc lst))))) + + (define (common-tests delete-duplicates-proc) + (pass-if-exception "too few args" exception:wrong-num-args + (delete-duplicates-proc)) + + (pass-if-exception "too many args" exception:wrong-num-args + (delete-duplicates-proc '() equal? 99)) + + (pass-if "empty" + (eq? '() (delete-duplicates-proc '()))) + + (pass-if "equal? (the default)" + (equal? '((2)) + (delete-duplicates-proc '((2) (2) (2))))) + + (pass-if "eq?" + (equal? '((2) (2) (2)) + (delete-duplicates-proc '((2) (2) (2)) eq?))) + + (pass-if "called arg order" + (let ((ok #t)) + (delete-duplicates-proc '(1 2 3 4 5) + (lambda (x y) + (if (> x y) + (set! ok #f)) + #f)) + ok))) + + (with-test-prefix "delete-duplicates" + (common-tests delete-duplicates) + + (test-lists + (lambda (lst) + (let ((lst-copy (list-copy lst))) + (with-test-prefix lst-copy + (pass-if "result" + (equal? (delete-duplicates lst) + (ref-delete-duplicates lst))) + (pass-if "non-destructive" + (equal? lst-copy lst))))))) + + (with-test-prefix "delete-duplicates!" + (common-tests delete-duplicates!) + + (test-lists + (lambda (lst) + (pass-if lst + (equal? (delete-duplicates! lst) + (ref-delete-duplicates lst))))))) + +;; +;; drop +;; + +(with-test-prefix "drop" + + (pass-if "'() 0" + (null? (drop '() 0))) + + (pass-if "'(a) 0" + (let ((lst '(a))) + (eq? lst + (drop lst 0)))) + + (pass-if "'(a b) 0" + (let ((lst '(a b))) + (eq? lst + (drop lst 0)))) + + (pass-if "'(a) 1" + (let ((lst '(a))) + (eq? (cdr lst) + (drop lst 1)))) + + (pass-if "'(a b) 1" + (let ((lst '(a b))) + (eq? (cdr lst) + (drop lst 1)))) + + (pass-if "'(a b) 2" + (let ((lst '(a b))) + (eq? (cddr lst) + (drop lst 2)))) + + (pass-if "'(a b c) 1" + (let ((lst '(a b c))) + (eq? (cddr lst) + (drop lst 2)))) + + (pass-if "circular '(a) 0" + (let ((lst (circular-list 'a))) + (eq? lst + (drop lst 0)))) + + (pass-if "circular '(a) 1" + (let ((lst (circular-list 'a))) + (eq? lst + (drop lst 1)))) + + (pass-if "circular '(a) 2" + (let ((lst (circular-list 'a))) + (eq? lst + (drop lst 1)))) + + (pass-if "circular '(a b) 1" + (let ((lst (circular-list 'a))) + (eq? (cdr lst) + (drop lst 0)))) + + (pass-if "circular '(a b) 2" + (let ((lst (circular-list 'a))) + (eq? lst + (drop lst 1)))) + + (pass-if "circular '(a b) 5" + (let ((lst (circular-list 'a))) + (eq? (cdr lst) + (drop lst 5)))) + + (pass-if "'(a . b) 1" + (eq? 'b + (drop '(a . b) 1))) + + (pass-if "'(a b . c) 1" + (equal? 'c + (drop '(a b . c) 2)))) + +;; +;; length+ +;; + +(with-test-prefix "length+" + (pass-if-exception "too few args" exception:wrong-num-args + (length+)) + (pass-if-exception "too many args" exception:wrong-num-args + (length+ 123 456)) + (pass-if (= 0 (length+ '()))) + (pass-if (= 1 (length+ '(x)))) + (pass-if (= 2 (length+ '(x y)))) + (pass-if (= 3 (length+ '(x y z)))) + (pass-if (not (length+ (circular-list 1)))) + (pass-if (not (length+ (circular-list 1 2)))) + (pass-if (not (length+ (circular-list 1 2 3))))) + +;; +;; list-copy +;; + +(with-test-prefix "list-copy" + (pass-if (equal? '() (list-copy '()))) + (pass-if (equal? '(1 2) (list-copy '(1 2)))) + (pass-if (equal? '(1 2 3) (list-copy '(1 2 3)))) + (pass-if (equal? '(1 2 3 4) (list-copy '(1 2 3 4)))) + (pass-if (equal? '(1 2 3 4 5) (list-copy '(1 2 3 4 5)))) + + ;; improper lists can be copied + (pass-if (equal? 1 (list-copy 1))) + (pass-if (equal? '(1 . 2) (list-copy '(1 . 2)))) + (pass-if (equal? '(1 2 . 3) (list-copy '(1 2 . 3)))) + (pass-if (equal? '(1 2 3 . 4) (list-copy '(1 2 3 . 4)))) + (pass-if (equal? '(1 2 3 4 . 5) (list-copy '(1 2 3 4 . 5))))) + +;; +;; take +;; + +(with-test-prefix "take" + + (pass-if "'() 0" + (null? (take '() 0))) + + (pass-if "'(a) 0" + (null? (take '(a) 0))) + + (pass-if "'(a b) 0" + (null? (take '() 0))) + + (pass-if "'(a b c) 0" + (null? (take '() 0))) + + (pass-if "'(a) 1" + (let* ((lst '(a)) + (got (take lst 1))) + (and (equal? '(a) got) + (not (eq? lst got))))) + + (pass-if "'(a b) 1" + (equal? '(a) + (take '(a b) 1))) + + (pass-if "'(a b c) 1" + (equal? '(a) + (take '(a b c) 1))) + + (pass-if "'(a b) 2" + (let* ((lst '(a b)) + (got (take lst 2))) + (and (equal? '(a b) got) + (not (eq? lst got))))) + + (pass-if "'(a b c) 2" + (equal? '(a b) + (take '(a b c) 2))) + + (pass-if "circular '(a) 0" + (equal? '() + (take (circular-list 'a) 0))) + + (pass-if "circular '(a) 1" + (equal? '(a) + (take (circular-list 'a) 1))) + + (pass-if "circular '(a) 2" + (equal? '(a a) + (take (circular-list 'a) 2))) + + (pass-if "circular '(a b) 5" + (equal? '(a b a b a) + (take (circular-list 'a 'b) 5))) + + (pass-if "'(a . b) 1" + (equal? '(a) + (take '(a . b) 1))) + + (pass-if "'(a b . c) 1" + (equal? '(a) + (take '(a b . c) 1))) + + (pass-if "'(a b . c) 2" + (equal? '(a b) + (take '(a b . c) 2)))) + +;; +;; partition +;; + +(define (test-partition pred list kept-good dropped-good) + (call-with-values (lambda () + (partition pred list)) + (lambda (kept dropped) + (and (equal? kept kept-good) + (equal? dropped dropped-good))))) + +(with-test-prefix "partition" + + (pass-if "with dropped tail" + (test-partition even? '(1 2 3 4 5 6 7) + '(2 4 6) '(1 3 5 7))) + + (pass-if "with kept tail" + (test-partition even? '(1 2 3 4 5 6) + '(2 4 6) '(1 3 5))) + + (pass-if "with everything dropped" + (test-partition even? '(1 3 5 7) + '() '(1 3 5 7))) + + (pass-if "with everything kept" + (test-partition even? '(2 4 6) + '(2 4 6) '())) + + (pass-if "with empty list" + (test-partition even? '() + '() '())) + + (pass-if "with reasonably long list" + ;; the old implementation from SRFI-1 reference implementation + ;; would signal a stack-overflow for a list of only 500 elements! + (call-with-values (lambda () + (partition even? + (make-list 10000 1))) + (lambda (even odd) + (and (= (length odd) 10000) + (= (length even) 0)))))) + diff --git a/test-suite/tests/srfi-17.test b/test-suite/tests/srfi-17.test new file mode 100644 index 000000000..6f0cd81f3 --- /dev/null +++ b/test-suite/tests/srfi-17.test @@ -0,0 +1,35 @@ +;;;; srfi-17.test --- test suite for Guile's SRFI-17 functions. -*- scheme -*- +;;;; +;;;; Copyright (C) 2001, 2003 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., 59 Temple Place, Suite 330, +;;;; Boston, MA 02111-1307 USA + +(define-module (test-suite test-srfi-17) + :use-module (test-suite lib) + :use-module (srfi srfi-17)) + + +(with-test-prefix "set!" + + (with-test-prefix "target is not procedure with setter" + + (pass-if-exception "(set! (symbol->string 'x) 1)" + exception:wrong-type-arg + (set! (symbol->string 'x) 1)) + + (pass-if-exception "(set! '#f 1)" + exception:bad-variable + (eval '(set! '#f 1) (interaction-environment))))) diff --git a/test-suite/tests/unif.test b/test-suite/tests/unif.test new file mode 100644 index 000000000..95bbe3e31 --- /dev/null +++ b/test-suite/tests/unif.test @@ -0,0 +1,67 @@ +;;;; 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)) + + +;;; +;;; 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))))))