[uim-commit] r1209 - in branches/r5rs/sigscheme: . test
kzk at freedesktop.org
kzk at freedesktop.org
Wed Aug 17 10:43:00 PDT 2005
Author: kzk
Date: 2005-08-17 10:42:57 -0700 (Wed, 17 Aug 2005)
New Revision: 1209
Added:
branches/r5rs/sigscheme/test/bigloo-apply.scm
branches/r5rs/sigscheme/test/bigloo-bchar.scm
branches/r5rs/sigscheme/test/bigloo-bool.scm
branches/r5rs/sigscheme/test/bigloo-case.scm
branches/r5rs/sigscheme/test/bigloo-letrec.scm
branches/r5rs/sigscheme/test/bigloo-list.scm
branches/r5rs/sigscheme/test/bigloo-quote.scm
branches/r5rs/sigscheme/test/bigloo-vector.scm
branches/r5rs/sigscheme/test/gauche-euc-jp.scm
branches/r5rs/sigscheme/test/gauche-primsyn.scm
branches/r5rs/sigscheme/test/unittest-bigloo.scm
branches/r5rs/sigscheme/test/unittest-gauche.scm
Modified:
branches/r5rs/sigscheme/eval.c
branches/r5rs/sigscheme/read.c
branches/r5rs/sigscheme/runtest.sh
branches/r5rs/sigscheme/test/test-r4rs.scm
branches/r5rs/sigscheme/test/unittest.scm
Log:
* added test cases ported from Bigloo and Gauche
* sigscheme/test/bigloo-apply.scm
* sigscheme/test/bigloo-bool.scm
* sigscheme/test/bigloo-vector.scm
* sigscheme/test/bigloo-case.scm
* sigscheme/test/bigloo-list.scm
* sigscheme/test/bigloo-letrec.scm
* sigscheme/test/bigloo-bchar.scm
* sigscheme/test/bigloo-quote.scm
* sigscheme/test/gauche-euc-jp.scm
* sigscheme/test/gauche-primsyn.scm
* sigscheme/test/unittest-bigloo.scm
* sigscheme/test/unittest-gauche.scm
- new file
* sigscheme/test/test-r4rs.scm
- supress output
* sigscheme/test/unittest.scm
- supress unnecessary newline
* sigscheme/read.c
- (read_sexpression): more informational error message
* sigscheme/eval.c
- (ScmOp_apply): report error in mutiarg-apply
* sigscheme/runtest.sh
- change to run test/bigloo-*.scm and test/gauche-*.scm
Modified: branches/r5rs/sigscheme/eval.c
===================================================================
--- branches/r5rs/sigscheme/eval.c 2005-08-17 16:17:51 UTC (rev 1208)
+++ branches/r5rs/sigscheme/eval.c 2005-08-17 17:42:57 UTC (rev 1209)
@@ -456,6 +456,8 @@
/* sanity check */
if CHECK_2_ARGS(args)
SigScm_Error("apply : Wrong number of arguments\n");
+ if (!SCM_NULLP(SCM_CDR(SCM_CDR(args))))
+ SigScm_Error("apply : Doesn't support multiarg apply\n");
/* 1st elem of list is proc */
proc = SCM_CAR(args);
Modified: branches/r5rs/sigscheme/read.c
===================================================================
--- branches/r5rs/sigscheme/read.c 2005-08-17 16:17:51 UTC (rev 1208)
+++ branches/r5rs/sigscheme/read.c 2005-08-17 17:42:57 UTC (rev 1209)
@@ -206,7 +206,7 @@
case EOF:
SigScm_Error("end in #\n");
default:
- SigScm_Error("Unsupported #\n");
+ SigScm_Error("Unsupported # : %c\n", c1);
}
}
break;
Modified: branches/r5rs/sigscheme/runtest.sh
===================================================================
--- branches/r5rs/sigscheme/runtest.sh 2005-08-17 16:17:51 UTC (rev 1208)
+++ branches/r5rs/sigscheme/runtest.sh 2005-08-17 17:42:57 UTC (rev 1209)
@@ -1,7 +1,24 @@
#!/bin/sh
+
+echo "[ Run Test ported from Bigloo]"
+for test in test/bigloo-*.scm
+do
+ echo "Running test $test..."
+ ./sscm $test
+done
+
+echo "[ Run Test ported from Gauche ]"
+for test in test/gauche-*.scm
+do
+ echo "Running test $test..."
+ ./sscm $test
+done
+
+echo "[ Run SigScheme Test ]"
for test in test/test-*.scm
do
echo "Running test $test..."
./sscm $test
done
+
Added: branches/r5rs/sigscheme/test/bigloo-apply.scm
===================================================================
--- branches/r5rs/sigscheme/test/bigloo-apply.scm 2005-08-17 16:17:51 UTC (rev 1208)
+++ branches/r5rs/sigscheme/test/bigloo-apply.scm 2005-08-17 17:42:57 UTC (rev 1209)
@@ -0,0 +1,158 @@
+;*---------------------------------------------------------------------*/
+;* serrano/prgm/project/bigloo/recette/apply.scm */
+;* */
+;* Author : Manuel Serrano */
+;* Creation : Tue Nov 3 10:58:26 1992 */
+;* Last change : Tue Aug 24 15:06:18 2004 (serrano) */
+;* */
+;* On test differentes sortes d'apply */
+;*---------------------------------------------------------------------*/
+
+(load "./test/unittest-bigloo.scm")
+
+
+;*---------------------------------------------------------------------*/
+;* gtest1 ... */
+;*---------------------------------------------------------------------*/
+(define gtest1
+ (lambda (x y)
+ (+ x y)))
+
+;*---------------------------------------------------------------------*/
+;* gtest2 ... */
+;*---------------------------------------------------------------------*/
+(define (gtest2 . x)
+ (+ (car x) (cadr x)))
+
+;*---------------------------------------------------------------------*/
+;* gtest3 ... */
+;*---------------------------------------------------------------------*/
+(define (gtest3 x . y)
+ (+ x (car y)))
+
+;*---------------------------------------------------------------------*/
+;* gtest4 ... */
+;*---------------------------------------------------------------------*/
+(define (gtest4)
+ 'foo)
+
+;*---------------------------------------------------------------------*/
+;* gtest4b ... */
+;*---------------------------------------------------------------------*/
+(define (gtest4b . x)
+ 'foo)
+
+;*---------------------------------------------------------------------*/
+;* gtest5 ... */
+;*---------------------------------------------------------------------*/
+(define (gtest5)
+ (lambda ()
+ 'foo))
+
+;*---------------------------------------------------------------------*/
+;* gtest6 ... */
+;*---------------------------------------------------------------------*/
+(define (gtest6)
+ (lambda x
+ 'foo))
+
+;*---------------------------------------------------------------------*/
+;* ltest1 ... */
+;*---------------------------------------------------------------------*/
+(define (ltest1 a b)
+ (let ((foo (lambda (x y) (+ x y))))
+ (apply foo (list (+ 1 a) (+ 1 b)))))
+
+;*---------------------------------------------------------------------*/
+;* ltest2 ... */
+;*---------------------------------------------------------------------*/
+(define (ltest2 a b)
+ (let ((foo (lambda (x y) (+ x (+ y (+ a b))))))
+ foo))
+
+;*---------------------------------------------------------------------*/
+;* ltest3 ... */
+;*---------------------------------------------------------------------*/
+(define (ltest3 a)
+ (let ((foo (lambda (z . x)
+ (let loop ((x x))
+ (if (null? x)
+ a
+ (+ (car x) (loop (cdr x))))))))
+ foo))
+
+;*---------------------------------------------------------------------*/
+;* extern-apply ... */
+;*---------------------------------------------------------------------*/
+(define (extern-apply x)
+ (apply foo1 x))
+
+;*---------------------------------------------------------------------*/
+;* apply-dummy ... */
+;* ------------------------------------------------------------- */
+;* Bigloo1.9 was unable to compile this extern apply form. */
+;*---------------------------------------------------------------------*/
+(define (apply-dummy x y)
+ (apply c-dummy (cons x y)))
+
+;*---------------------------------------------------------------------*/
+;* test-apply ... */
+;*---------------------------------------------------------------------*/
+(define (test-apply)
+ (test "extern apply" (extern-apply '(1)) 1)
+ (test "gapply" (apply gtest1 '(1 3)) 4)
+ (test "gapply" ((begin gtest1) 1 3) 4)
+ (test "gapply" (apply gtest2 '(1 3)) 4)
+ (test "gapply" ((begin gtest2) 1 3) 4)
+ (test "gapply" (apply gtest3 '(1 3)) 4)
+ (test "gapply" ((begin gtest3) 1 3) 4)
+ (test "gapply" (apply (begin gtest1) '(1 3)) 4)
+ (test "gapply" (apply (begin gtest2) '(1 3)) 4)
+ (test "gapply" (apply (begin gtest3) '(1 3)) 4)
+ (test "gapply" (apply gtest4 '()) 'foo)
+ (test "gapply" (apply gtest4b '()) 'foo)
+ (test "gapply" (apply (gtest5) '()) 'foo)
+ (test "gapply" (apply (gtest6) '()) 'foo)
+ (test "lapply" (ltest1 1 2) 5)
+ (test "lapply" ((ltest2 2 3) 1 2) 8)
+ (test "lapply" (apply (ltest2 2 3) (list 1 2)) 8)
+ (test "lapply" ((ltest3 1) 0 2 3 4) 10)
+ (test "lapply" (apply (ltest3 1) (list 0 2 3 4)) 10)
+ (test "lapply" (apply (lambda (x y) (list x y)) '(1 2)) '(1 2))
+ (test "napply" (apply cons 1 '(2)) '(1 . 2))
+ (test "napply" (apply cons 1 2 '()) '(1 . 2))
+ (test "aapply" (apply apply cons (list 1 2 '())) '(1 . 2))
+ (test "mapply" (apply (lambda (z) z) 1 '()) 1)
+ (test "mapply" (apply (lambda (z) z) '(1)) 1)
+ (test "mapply" (apply (lambda (a z) z) '(1 2)) 2)
+ (test "mapply" (apply (lambda (a z) z) 1 '(2)) 2)
+ (test "mapply" (apply (lambda (a z) z) 1 2 '()) 2)
+ (test "mapply" (apply (lambda (a b c z) z) '(1 2 3 4)) 4)
+ (test "mapply" (apply (lambda (a b c z) z) 1 '(2 3 4)) 4)
+ (test "mapply" (apply (lambda (a b c z) z) 1 2 '(3 4)) 4)
+ (test "mapply" (apply (lambda (a b c z) z) 1 2 3 '(4)) 4)
+ (test "mapply" (apply (lambda (a b c z) z) 1 2 3 4 '()) 4)
+ (test "mapply" (apply (lambda (a b c d z) z) 1 2 3 4 '(5))5)
+ (test "mapply" (apply (lambda (a b c d z) z) 1 2 3 4 5 '()) 5)
+ (test "mapply" (apply (lambda (a b c d e z) z) 1 2 3 4 '(5 6)) 6)
+ (test "mapply" (apply (lambda (a b c d e f z) z) 1 2 3 4 '(5 6 7)) 7)
+ (test "mapply" (apply (lambda (a b . z) (car z)) 1 2 3 4 5 '(6 7)) 3)
+ (test "mapply" (apply (lambda (a . z) (car z)) 1 2 3 4 '(5 6 7)) 2)
+ (test "mapply" (apply (lambda (a b c d . z) (car z)) 1 2 3 4 '(5 6 7)) 5)
+ (test "mapply" (apply (lambda (a b c d e . z) (car z)) 1 '(2 3 4 5 6 7)) 6)
+ (test "mapply" (apply (lambda (a b c d e f . z) (car z)) 1 2 3 4 '(5 6 7)) 7)
+ (test "mapply" (apply (lambda (a1 a2 a3 a4 a5 a6 a7 a8 a9 a10 a11 a12 a13 a14 a15 a16 a17 a18 a19 a20 a21 a22 a23 a24 a25 a26 a27 a28 a29 a30 a31 a32) (list a1 a2 a3 a4 a5 a6 a7 a8 a9 a10 a11 a12 a13 a14 a15 a16 a17 a18 a19 a20 a21 a22 a23 a24 a25 a26 a27 a28 a29 a30 a31 a32))
+ (list 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32))
+ '(1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32))
+ (test "mapply" (apply (lambda (a1 a2 a3 a4 a5 a6 a7 a8 a9 a10 a11 a12 a13 a14 a15 a16 a17 a18 a19 a20 a21 a22 a23 a24 a25 a26 a27 a28 a29 a30 a31 a32)
+ (list a1 a2 a3 a4 a5 a6 a7 a8 a9 a10 a11 a12 a13 a14 a15 a16 a17 a18 a19 a20 a21 a22 a23 a24 a25 a26 a27 a28 a29 a30 a31 a32))
+ (apply (lambda (a1 a2 a3 a4 a5 a6 a7 a8 a9 a10 a11 a12 a13 a14 a15 a16 a17 a18 a19 a20 a21 a22 a23 a24 a25 a26 a27 a28 a29 a30 a31 a32) (list a1 a2 a3 a4 a5 a6 a7 a8 a9 a10 a11 a12 a13 a14 a15 a16 a17 a18 a19 a20 a21 a22 a23 a24 a25 a26 a27 a28 a29 a30 a31 a32))
+ (list 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32)))
+ '(1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32))
+ (test "mapply" (apply (lambda (a1 a2 a3 a4 a5 a6 a7 a8 a9 a10 a11 a12 a13 a14 a15 a16 a17 a18 a19 a20 a21 a22 a23 a24 a25 a26 a27 a28 a29 a30 a31 . a32) (list a1 a2 a3 a4 a5 a6 a7 a8 a9 a10 a11 a12 a13 a14 a15 a16 a17 a18 a19 a20 a21 a22 a23 a24 a25 a26 a27 a28 a29 a30 a31 a32))
+ (list 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32))
+ '(1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 (32))))
+
+(test-apply)
+
+(total-report)
Added: branches/r5rs/sigscheme/test/bigloo-bchar.scm
===================================================================
--- branches/r5rs/sigscheme/test/bigloo-bchar.scm 2005-08-17 16:17:51 UTC (rev 1208)
+++ branches/r5rs/sigscheme/test/bigloo-bchar.scm 2005-08-17 17:42:57 UTC (rev 1209)
@@ -0,0 +1,54 @@
+;*---------------------------------------------------------------------*/
+;* serrano/prgm/project/bigloo/recette/bchar.scm */
+;* */
+;* Author : Manuel Serrano */
+;* Creation : Tue Dec 1 09:29:00 1992 */
+;* Last change : Tue May 7 14:38:22 2002 (serrano) */
+;* */
+;* On test les caracteres */
+;*---------------------------------------------------------------------*/
+
+(load "./test/unittest-bigloo.scm")
+
+;*---------------------------------------------------------------------*/
+;* test-char ... */
+;*---------------------------------------------------------------------*/
+(define (test-char)
+ (test "char?" (char? #\a) #t)
+ (test "char?" (char? 1) #f)
+ (test "char=?" (let ((x #\a)) (char=? x #\a)) #t)
+ (test "char=?" (let ((x #\b)) (char=? x #\a)) #f)
+; (test "char<?" (let ((x #\b)) (char<? x #\a)) #f)
+; (test "char<?" (let ((x #\b)) (char<? #\a x)) #t)
+; (test "char>?" (let ((x #\b)) (char>? x #\a)) #t)
+; (test "char>?" (let ((x #\b)) (char>? #\a x)) #f)
+; (let ((s "été"))
+; (test "char>?" (char>? (string-ref s 0) #a127) #t))
+; (test "char-ci=?" (let ((x #\A)) (char-ci=? x #\a)) #t)
+; (test "char-ci=?" (let ((x #\B)) (char-ci=? x #\a)) #f)
+; (test "char-ci<?" (let ((x #\B)) (char-ci<? x #\a)) #f)
+; (test "char-ci<?" (let ((x #\B)) (char-ci<? #\a x)) #t)
+; (test "char-ci>?" (let ((x #\B)) (char-ci>? x #\a)) #t)
+; (test "char-ci>?" (let ((x #\B)) (char-ci>? #\a x)) #f)
+ (test "char-alphabetic?" (char-alphabetic? #\a) #t)
+ (test "char-alphabetic?" (char-alphabetic? #\0) #f)
+ (test "char-numeric?" (char-numeric? #\a) #f)
+ (test "char-numeric?" (char-numeric? #\0) #t)
+ (test "char-whitespace?" (char-whitespace? #\a) #f)
+ (test "char-whitespace?" (char-whitespace? #\space) #t)
+ (test "char-upper-case?" (char-upper-case? #\A) #t)
+ (test "char-upper-case?" (char-upper-case? #\a) #f)
+ (test "char-lower-case?" (char-lower-case? #\A) #f)
+ (test "char-lower-case?" (char-lower-case? #\a) #t)
+ (test "char->integer" (char->integer #\0) 48)
+; (test "char->integer" (char->integer #a200) 200)
+ (test "integer->char" (integer->char 48) #\0)
+ (test "char-upcase" (char-upcase #\a) #\A)
+ (test "char-upcase" (char-upcase #\A) #\A)
+ (test "char-downcase" (char-downcase #\a) #\a)
+ (test "char-downcase" (char-downcase #\A) #\a)
+ (test "unsigned char" (char->integer (integer->char 128)) 128))
+
+(test-char)
+
+(total-report)
Added: branches/r5rs/sigscheme/test/bigloo-bool.scm
===================================================================
--- branches/r5rs/sigscheme/test/bigloo-bool.scm 2005-08-17 16:17:51 UTC (rev 1208)
+++ branches/r5rs/sigscheme/test/bigloo-bool.scm 2005-08-17 17:42:57 UTC (rev 1209)
@@ -0,0 +1,77 @@
+;*---------------------------------------------------------------------*/
+;* serrano/prgm/project/bigloo/recette/bool.scm */
+;* */
+;* Author : Manuel Serrano */
+;* Creation : Tue Nov 3 09:16:12 1992 */
+;* Last change : Wed Apr 1 14:05:49 1998 (serrano) */
+;* */
+;* On test les operations booleenes. */
+;*---------------------------------------------------------------------*/
+
+(load "./test/unittest-bigloo.scm")
+
+;*---------------------------------------------------------------------*/
+;* predicat ... */
+;*---------------------------------------------------------------------*/
+(define (predicat x)
+ (> x 5))
+
+;*---------------------------------------------------------------------*/
+;* faux-predicat ... */
+;*---------------------------------------------------------------------*/
+(define (faux-predicat x)
+ (> x 5))
+
+;*---------------------------------------------------------------------*/
+;* encore-faux ... */
+;*---------------------------------------------------------------------*/
+(define (encore-faux x)
+ (> x 5))
+
+;*---------------------------------------------------------------------*/
+;* local-pred-1 ... */
+;*---------------------------------------------------------------------*/
+(define (local-pred-1 x)
+ (let ((pred (lambda (x) (< x 3))))
+ (if (pred x) #t #f)))
+
+;*---------------------------------------------------------------------*/
+;* local-pred-2 ... */
+;*---------------------------------------------------------------------*/
+(define (local-pred-2 x)
+ (let* ((foo (lambda (x) (< x 3)))
+ (bar (lambda (x) (if (foo x) 3 4)))
+ (gee (lambda (x) (if (foo x) 3 4))))
+ bar
+ gee
+ (if (foo x) #t #f)))
+
+;*---------------------------------------------------------------------*/
+;* local-pred-3 ... */
+;*---------------------------------------------------------------------*/
+(define (local-pred-3 x)
+ (let ((pred (lambda (x) (< x 3))))
+ (pred x)))
+
+;*---------------------------------------------------------------------*/
+;* test-bool ... */
+;*---------------------------------------------------------------------*/
+(define (test-bool)
+ (test "or" (or #f #f) #f)
+ (test "not" (not #f) #t)
+ (test "and" (and #t #t) #t)
+ (test "and" (and #t #f) #f)
+ (test "if" (let ((x 1)) (if x x)) 1)
+ (test "ifnot" (let ((x 1)) (if (not x) #t #f)) #f)
+ (test "ifor" (let ((x 1) (y #f)) (if (or x y) x y)) 1)
+ (test "ifand" (let ((x 1) (y #f)) (if (and x y) #t #f)) #f)
+ (test "pred" (if (predicat 6) #t #f) #t)
+ (test "faux" (if (faux-predicat 6) (faux-predicat 7) (faux-predicat 3)) #t)
+ (test "encore-faux" (if (encore-faux 6) #t #f) #t)
+ (test "local-pred-1" (local-pred-1 1) #t)
+ (test "local-pred-2" (local-pred-2 1) #t)
+ (test "local-pred-3" (if (local-pred-3 1) #t #f) #t))
+
+(test-bool)
+
+(total-report)
Added: branches/r5rs/sigscheme/test/bigloo-case.scm
===================================================================
--- branches/r5rs/sigscheme/test/bigloo-case.scm 2005-08-17 16:17:51 UTC (rev 1208)
+++ branches/r5rs/sigscheme/test/bigloo-case.scm 2005-08-17 17:42:57 UTC (rev 1209)
@@ -0,0 +1,138 @@
+;*---------------------------------------------------------------------*/
+;* serrano/prgm/project/bigloo/recette/case.scm */
+;* */
+;* Author : Manuel Serrano */
+;* Creation : Wed Mar 18 15:16:39 1992 */
+;* Last change : Mon May 19 06:11:19 2003 (serrano) */
+;* */
+;* On test le case. */
+;*---------------------------------------------------------------------*/
+
+(load "./test/unittest-bigloo.scm")
+
+;*---------------------------------------------------------------------*/
+;* test 1. */
+;*---------------------------------------------------------------------*/
+(define (test1 x)
+ (case x
+ ((tutu) 'tutu)
+ ((toto) 'toto)
+ (else
+ 'dummy
+ 'else)))
+
+;*---------------------------------------------------------------------*/
+;* test 2. */
+;*---------------------------------------------------------------------*/
+(define (test2 x)
+ (case (begin 1 2 x)
+ ((tete tutu tyty) 1)
+ ((toto) 2)
+ ((tata) 3)))
+
+;*---------------------------------------------------------------------*/
+;* test 3. */
+;*---------------------------------------------------------------------*/
+(define (test3 x)
+ (case (begin 2 3 x)
+ ((1 2 3 4) 1)
+ ((5 6 7 8) 5)
+ (else 0)))
+
+;*---------------------------------------------------------------------*/
+;* test 4. */
+;*---------------------------------------------------------------------*/
+(define (test4 x)
+ (case x
+ ((tutu 1) "tutu ou 1")
+ ((2 3) "2 ou 3")
+ (else "else")))
+
+;*---------------------------------------------------------------------*/
+;* test 5. */
+;* ------------------------------------------------------------- */
+;* Ce test est important car il permet de tester la compilation */
+;* des cases qui comportent des symboles qui ont meme nombre de */
+;* hash */
+;*---------------------------------------------------------------------*/
+(define (test5 x)
+ (case x
+ ((SHOW show)
+ 'show)
+ ((compute!)
+ 'compute!)
+ (else
+ 'else)))
+
+;*---------------------------------------------------------------------*/
+;* test 6. */
+;*---------------------------------------------------------------------*/
+(define (test6 x)
+ (case x
+ ((#\o)
+ #\o)
+ ((#\d)
+ #\d)
+ ((#\x)
+ #\x)))
+
+;*---------------------------------------------------------------------*/
+;* test 7. ... */
+;*---------------------------------------------------------------------*/
+(define (test7 x)
+ ;; set! et fibo on meme nombre de hash
+ (case x
+ ((set!)
+ 'set!)
+ (else
+ 'else)))
+
+;*---------------------------------------------------------------------*/
+;* test.8 */
+;* ------------------------------------------------------------- */
+;* This test used to make the compiler crashes. */
+;*---------------------------------------------------------------------*/
+;(define-macro push!
+; (lambda (stack o)
+; `(begin
+; (set! ,stack (cons ,o ,stack))
+; ,o)))
+;
+;(define (test.8 data)
+; (let ((elem-stack '()))
+; (push! elem-stack
+; (read/rp (regular-grammar ()
+; (else 2))
+; (open-input-string data)))
+; elem-stack))
+
+;*---------------------------------------------------------------------*/
+;* test-case ... */
+;*---------------------------------------------------------------------*/
+(define (test-case)
+ (test "case symbol" (test1 'tutu) 'tutu)
+ (test "case symbol" (test1 'toto) 'toto)
+ (test "case symbol" (test1 'tata) 'else)
+ (test "case symbol" (test1 5) 'else)
+ (test "case symbol" (test2 'tutu) 1)
+ (test "case symbol" (test2 'toto) 2)
+ (test "case symbol" (test2 'tata) 3)
+; (test "case symbol" (test2 5) #unspecified)
+ (test "case integer" (test3 (+ 1 2)) 1)
+ (test "case integer" (test3 'toto) 0)
+ (test "case mixte" (test4 'tutu) "tutu ou 1")
+ (test "case mixte" (test4 1) "tutu ou 1")
+ (test "case mixte "(test4 3) "2 ou 3")
+ (test "case mixte" (test4 'titi) "else")
+ (test "case hash" (test5 'show) 'show)
+ (test "case hash" (test5 'SHOW) 'show)
+ (test "case hash" (test5 'compute!) 'compute!)
+ (test "case hash" (test5 'toto) 'else)
+; (test "case char" (test6 #\a) #unspecified)
+ (test "case char" (test6 #\x) #\x)
+ (test "case char" (test6 (string-ref "o" 0)) #\o)
+ (test "case hash" (test7 'fibo) 'else))
+
+(test-case)
+
+(total-report)
Added: branches/r5rs/sigscheme/test/bigloo-letrec.scm
===================================================================
--- branches/r5rs/sigscheme/test/bigloo-letrec.scm 2005-08-17 16:17:51 UTC (rev 1208)
+++ branches/r5rs/sigscheme/test/bigloo-letrec.scm 2005-08-17 17:42:57 UTC (rev 1209)
@@ -0,0 +1,44 @@
+;*---------------------------------------------------------------------*/
+;* serrano/prgm/project/bigloo/recette/letrec.scm */
+;* */
+;* Author : Manuel Serrano */
+;* Creation : Tue Nov 17 19:18:37 1992 */
+;* Last change : Fri Jul 6 09:38:02 2001 (serrano) */
+;* */
+;* On test `letrec' */
+;*---------------------------------------------------------------------*/
+
+(load "./test/unittest-bigloo.scm")
+
+;*---------------------------------------------------------------------*/
+;* test1 ... */
+;*---------------------------------------------------------------------*/
+(define (test1 y)
+ (letrec ((x (number->string y))
+ (foo (lambda (string)
+ (string->symbol (string-append string x)))))
+ foo))
+
+;*---------------------------------------------------------------------*/
+;* plante1 */
+;* ------------------------------------------------------------- */
+;* un test qui plantait a la compilation */
+;*---------------------------------------------------------------------*/
+(define (foo a)
+ (letrec ((foo (lambda (x) (bar 0) (set! foo 8) 'done))
+ (bar (lambda (x) (if (= x 0)
+ 'done
+ (foo x)))))
+ (foo a)))
+
+;*---------------------------------------------------------------------*/
+;* test-letrec ... */
+;*---------------------------------------------------------------------*/
+(define (test-letrec)
+ (test "letrec" ((test1 1) "TOTO") 'TOTO1)
+ (test "letrec" (foo 10) 'done)
+ (test "delay" (procedure? (letrec ((foo (delay foo))) (force foo))) #t))
+
+(test-letrec)
+
+(total-report)
Added: branches/r5rs/sigscheme/test/bigloo-list.scm
===================================================================
--- branches/r5rs/sigscheme/test/bigloo-list.scm 2005-08-17 16:17:51 UTC (rev 1208)
+++ branches/r5rs/sigscheme/test/bigloo-list.scm 2005-08-17 17:42:57 UTC (rev 1209)
@@ -0,0 +1,117 @@
+;*---------------------------------------------------------------------*/
+;* serrano/prgm/project/bigloo/recette/list.scm */
+;* */
+;* Author : Manuel Serrano */
+;* Creation : Tue Nov 3 09:21:42 1992 */
+;* Last change : Fri Nov 14 17:29:58 2003 (serrano) */
+;* */
+;* On teste les operations primitives sur les listes */
+;*---------------------------------------------------------------------*/
+
+(load "./test/unittest-bigloo.scm")
+
+;*---------------------------------------------------------------------*/
+;* test-list ... */
+;*---------------------------------------------------------------------*/
+(define (test-list)
+ (test "car" (car (list 1 2 3)) 1)
+ (test "cdr" (cdr (list 1 2 3)) '(2 3))
+ (test "set-car!" (let ((x (cons 1 2))) (set-car! x 0) x) (cons 0 2))
+ (test "set-cdr!" (let ((x (cons 1 2))) (set-cdr! x 0) x) (cons 1 0))
+ (test "cons" (cons 1 (cons 2 '())) '(1 2))
+; (test "epair.1" (epair? (econs 1 2 3)) #t)
+; (test "epair.2" (epair? (cons 2 3)) #f)
+; (test "epair.3" (pair? (econs 1 2 3)) #t)
+; (test "epair.4" (cer (econs 1 2 3)) 3)
+; (test "epair.5" (let ((p (econs 1 2 3)))
+; (set-cer! p 4)
+; (cer p))
+; 4)
+; (test "epair.6" (car (econs 1 2 3)) 1)
+; (test "epair.7" (cdr (econs 1 2 3)) 2)
+ (test "map.1" (map (lambda (x) (+ 1 x)) '(1 2 3)) '(2 3 4))
+ (test "map.2" (map cons '(1 2 3) '(4 5 6)) '((1 . 4) (2 . 5) (3 . 6)))
+ (test "map.3" (map list '(1 2 3) '(4 5 6)) '((1 4) (2 5) (3 6)))
+ (test "map.4" (map (lambda (a b) (list a b)) '(1 2 3) '(4 5 6))
+ '((1 4) (2 5) (3 6)))
+ (test "map.5" (map (lambda (a b c) (list a b c)) '(1 2 3) '(4 5 6) '(7 8 9))
+ '((1 4 7) (2 5 8) (3 6 9)))
+ (test "map.6" (map (lambda (x) x) '()) '())
+ (test "map.7" (map car '()) '())
+ (test "map.8" (map car '((1))) '(1))
+ (test "for-each.1" (begin (for-each (lambda (x) x) '()) #t) #t)
+ (test "for-each.2" (let ((v 0))
+ (for-each (lambda (x) (set! v (+ x v)))
+ '(1 2 3))
+ v)
+ 6)
+ (test "for-each.3" (let ((v 0))
+ (for-each (lambda (x y) (set! v (+ y x v)))
+ '(1 2 3) '(4 5 6))
+ v)
+ 21)
+ (test "for-each.4" (let ((v 0))
+ (for-each (lambda (x y z) (set! v (+ y x v z)))
+ '(1 2 3) '(4 5 6) '(7 8 9))
+ v)
+ 45)
+; (test "filter" (filter number? '(1 2 #\a "foo" foo 3)) '(1 2 3))
+; (test "filter!" (let ((l (list 1 2 #\a "foo" 'foo 3)))
+; (set! l (filter! number? l))
+; l) '(1 2 3))
+; (test "any?" (any? number? '(1 2 3 4 5 6)) #t)
+; (test "any?" (any? number? '(toto 1 2 3 4 5 6)) #t)
+; (test "any?" (any? number? '(toto 1 2 3 4 5 6 tutu)) #t)
+; (test "any?" (any? number? '(toto tutu)) #f)
+; (test "any?" (any? > '(1 2 3 4) '(5 6 7 8)) #f)
+; (test "any?" (any? > '(1 2 3 4) '(5 0 7 8)) #t)
+; (test "every?" (every? number? '(1 2 3 4 5 6)) #t)
+; (test "every?" (every? number? '(toto 1 2 3 4 5 6)) #f)
+; (test "every?" (every? number? '(toto 1 2 3 4 5 6 tutu)) #f)
+; (test "every?" (every? number? '(toto tutu)) #f)
+; (test "every?" (every? > '(1 2 3 4) '(5 6 7 8)) #f)
+; (test "every?" (every? > '(5 6 7 8) '(1 2 3 4)) #t)
+ (test "reverse" (reverse '(1 2 3 4)) '(4 3 2 1))
+; (test "reverse!" (reverse! '(1 2 3 4)) '(4 3 2 1))
+ (test "list-tail" (list-tail '(1 2 3 4) 2) '(3 4))
+ (test "list-ref" (list-ref '(1 2 (3 4) 5) 2) '(3 4))
+ (test "assoc" (assoc 1 '((2 3) (4 5))) #f)
+ (test "equal.1" (equal? '(1 2 (3 4 (5) (6 7)) (5 6) "titi"
+ #(1 2 (6 #(6 7)) titi) tutu)
+ '(1 2 (3 4 (5) (6 7)) (5 6) "titi"
+ #(1 2 (6 #(6 7)) titi) tutu))
+ #t)
+ (test "equal.2" (equal? '(1 2 (3 4 (5) (6 7)) (5 6) "titi"
+ #(1 2 (6 #(6 7)) titi) tutu)
+ '(1 2 (3 4 (5) (6 7)) (5 6) "titi"
+ #(1 2 (6 #(6 7)) toto) tutu))
+ #f)
+ (test "member.1" (member '(1 2 3) '((0 1 2) (1 2 3) (4 5 6)))
+ '((1 2 3) (4 5 6)))
+ (test "length" (length '(1 2 3)) 3)
+ (test "append.1" (append '(1 2 (3 4)) '((5 6) 7)) '(1 2 (3 4) (5 6) 7))
+ (test "append.2" (append '(a b) '(c . d)) '(a b c . d))
+ (test "append.3" (append '() 'a) 'a)
+ (test "list" (list 1 2 3) '(1 2 3))
+ (test "list?.1" (list? '(1 2 . 4)) #f)
+ (test "list?.2" (list? '(1 2 3 4)) #t)
+; (test "remq" (let ((x '(1 2 3 4))) (remq 2 x)) '(1 3 4))
+; (test "remq!" (let ((x '(1 2 3 4))) (remq! 2 x) x) '(1 3 4))
+; (test "delete" (let ((x '(1 2 (3 4) 5))) (delete '(3 4) x)) '(1 2 5))
+; (test "delete!" (let ((x '(1 2 (3 4) 5))) (delete! '(3 4) x) x) '(1 2 5))
+ (test "memq.1" (memq 3 '(1 2 3 4 5)) '(3 4 5))
+ (test "memq.2" (memq #\a '(1 2 3 4 5)) #f)
+ (test "member.2" (member '(2 3) '((1 2) (2 3) (3 4) (4 5)))
+ '((2 3) (3 4) (4 5)))
+; (test "cons*.1" (cons* 1 0) '(1 . 0))
+; (test "cons*.2" (cons* (cons* (quote x) 0 (quote ())) (quote ())) '((x 0)))
+; (test "make-list.1" (make-list 2) '(#unspecified #unspecified))
+; (test "make-list.2" (make-list 10 4) '(4 4 4 4 4 4 4 4 4 4))
+; (test "list-tabulate" (list-tabulate 4 values) '(0 1 2 3))
+; (test "iota.1" (iota 5) '(0 1 2 3 4))
+; (test "iota.2" (iota 5 0 -1.) '(0. -1. -2. -3. -4.))
+ )
+
+(test-list)
+
+(total-report)
Added: branches/r5rs/sigscheme/test/bigloo-quote.scm
===================================================================
--- branches/r5rs/sigscheme/test/bigloo-quote.scm 2005-08-17 16:17:51 UTC (rev 1208)
+++ branches/r5rs/sigscheme/test/bigloo-quote.scm 2005-08-17 17:42:57 UTC (rev 1209)
@@ -0,0 +1,42 @@
+;*---------------------------------------------------------------------*/
+;* serrano/prgm/project/bigloo/recette/kwote.scm */
+;* */
+;* Author : Manuel Serrano */
+;* Creation : Tue Nov 3 10:22:02 1992 */
+;* Last change : Fri Jul 6 09:37:50 2001 (serrano) */
+;* */
+;* On test l'expansion des kwote */
+;*---------------------------------------------------------------------*/
+
+(load "./test/unittest-bigloo.scm")
+
+;*---------------------------------------------------------------------*/
+;* test-quote ... */
+;*---------------------------------------------------------------------*/
+(define (test-quote)
+ (test "quote" `(list ,(+ 1 2) 4) '(list 3 4))
+ (test "quote" (let ((name 'a)) `(list ,name ',name)) '(list a (quote a)))
+ (test "quote" `(a ,(+ 1 2) ,@(map (lambda (x) (+ 10 x))
+ '(4 -5 6))
+ b)
+ '(a 3 14 5 16 b))
+ (test "quote" `((foo ,(- 10 3)) ,@(cdr '(c)) . ,(car '((cons))))
+ '((foo 7) cons))
+ (test "quote" `(a `(b ,(+ 1 2) ,(foo ,(+ 1 3) d) e) f)
+ '(a `(b ,(+ 1 2) ,(foo 4 d) e) f))
+ (test "quote" (let ((name1 'x)
+ (name2 'y))
+ `(a `(b ,,name1 ,',name2 d) e))
+ '(a `(b ,x ,'y d) e))
+ (test "quote" (quasiquote (list (unquote (+ 1 2)) 4))
+ '(list 3 4))
+ (test "quote" '(quasiquote (list (unquote (+ 1 2)) 4))
+ '`(list ,(+ 1 2) 4))
+ (test "quote" `#(1 2 ,(+ 1 2) ,(+ 2 2))
+ '#(1 2 3 4))
+ (test "quote" `#(1 2 ,(+ 1 2) ,@(map (lambda (x) (+ 1 x)) '(3 4)) 6)
+ '#(1 2 3 4 5 6)))
+
+(test-quote)
+
+(total-report)
Added: branches/r5rs/sigscheme/test/bigloo-vector.scm
===================================================================
--- branches/r5rs/sigscheme/test/bigloo-vector.scm 2005-08-17 16:17:51 UTC (rev 1208)
+++ branches/r5rs/sigscheme/test/bigloo-vector.scm 2005-08-17 17:42:57 UTC (rev 1209)
@@ -0,0 +1,65 @@
+;*---------------------------------------------------------------------*/
+;* serrano/prgm/project/bigloo/recette/vector.scm */
+;* */
+;* Author : Manuel Serrano */
+;* Creation : Tue Nov 3 09:39:09 1992 */
+;* Last change : Mon Jun 7 11:46:40 2004 (serrano) */
+;* */
+;* On test les operations primitives sur les vecteurs */
+;*---------------------------------------------------------------------*/
+
+(load "./test/unittest-bigloo.scm")
+
+;*---------------------------------------------------------------------*/
+;* Tvector optimization check */
+;*---------------------------------------------------------------------*/
+(define *number-images* (vector #\0 #\1 #\2))
+(define *foo* (vector "toto" "toto"))
+
+(define (prin-integer n)
+ (let ((x (vector-ref *number-images* 2)))
+ x))
+
+(define (foo n)
+ (vector-ref (if (equal? 5 n) *number-images* *foo*) 0)
+ (prin-integer n))
+
+;*---------------------------------------------------------------------*/
+;* test-vector ... */
+;*---------------------------------------------------------------------*/
+(define (test-vector)
+ (test "vector?" (vector? '#()) #t)
+ (test "vector?" (vector? '#(1)) #t)
+ (test "ref" (vector-ref '#(1 2 3 4) 2) 3)
+ (test "set" (let ((v (make-vector 1 '())))
+ (vector-set! v 0 'toto)
+ (vector-ref v 0))
+ 'toto)
+ (test "length" (vector-length '#(1 2 3 4 5)) 5)
+ (test "length" (vector-length (make-vector 5 'toto)) 5)
+ (test "equal vector" (let ((v (make-vector 3 '())))
+ (vector-set! v 0 '(1 2 3))
+ (vector-set! v 1 '#(1 2 3))
+ (vector-set! v 2 'hello)
+ v)
+ '#((1 2 3) #(1 2 3) hello))
+ (test "vector-fill" (let ((v (make-vector 3 1)))
+ (vector-fill! v 2)
+ (+ (vector-ref v 0)
+ (vector-ref v 1)
+ (vector-ref v 2)))
+ 6)
+ (test "tvector.1" (let ((t '#(1 2 3)))
+ (vector-ref t 2))
+ 3)
+; (test "tvector2"
+; (string? (with-output-to-string
+; (lambda ()
+; (print (make-array-of-int 1 1)))))
+; #t)
+ (test "vector-ref" (foo 10) #\2)
+ (test "vector-ref" (vector-ref (let ((v (vector 0 1 2))) v) 2) 2))
+
+(test-vector)
+
+(total-report)
Added: branches/r5rs/sigscheme/test/gauche-euc-jp.scm
===================================================================
--- branches/r5rs/sigscheme/test/gauche-euc-jp.scm 2005-08-17 16:17:51 UTC (rev 1208)
+++ branches/r5rs/sigscheme/test/gauche-euc-jp.scm 2005-08-17 17:42:57 UTC (rev 1209)
@@ -0,0 +1,162 @@
+;; this test only works when the core system is compiled with euc-jp.
+
+;; $Id: euc-jp.scm,v 1.6 2001/05/03 19:05:39 shirok Exp $
+
+(load "./test/unittest-gauche.scm")
+
+;;-------------------------------------------------------------------
+
+(test "string" "¤¤¤íh¤Ë¤Û¤Øt"
+ (lambda () (string #\¤¤ #\¤í #\h #\¤Ë #\¤Û #\¤Ø #\t)))
+(test "list->string" "¤¤¤íh¤Ë¤Û¤Øt"
+ (lambda () (list->string '(#\¤¤ #\¤í #\h #\¤Ë #\¤Û #\¤Ø #\t))))
+(test "make-string" "¤Ø¤Ø¤Ø¤Ø¤Ø" (lambda () (make-string 5 #\¤Ø)))
+(test "make-string" "" (lambda () (make-string 0 #\¤Ø)))
+
+(test "string->list" '(#\¤¤ #\¤í #\h #\¤Ë #\¤Û #\¤Ø #\t)
+ (lambda () (string->list "¤¤¤íh¤Ë¤Û¤Øt")))
+(test "string->list" '(#\¤í #\h #\¤Ë #\¤Û #\¤Ø #\t)
+ (lambda () (string->list "¤¤¤íh¤Ë¤Û¤Øt" 1)))
+(test "string->list" '(#\¤í #\h #\¤Ë)
+ (lambda () (string->list "¤¤¤íh¤Ë¤Û¤Øt" 1 4)))
+
+(test "string-copy" '("¤¡¤ã¦Í¤£" #f)
+ (lambda () (let* ((x "¤¡¤ã¦Í¤£") (y (string-copy x)))
+ (list y (eq? x y)))))
+(test "string-copy" "¤ã¦Í¤£" (lambda () (string-copy "¤¡¤ã¦Í¤£" 1)))
+(test "string-copy" "¤ã¦Í" (lambda () (string-copy "¤¡¤ã¦Í¤£" 1 3)))
+
+(test "string-ref" #\¤í (lambda () (string-ref "¤¤¤í¤Ï" 1)))
+(define x (string-copy "¤¤¤í¤Ï¤Ë¤Û"))
+(test "string-set!" "¤¤¤íZ¤Ë¤Û" (lambda () (string-set! x 2 #\Z) x))
+
+(test "string-fill!" "¤Î¤Î¤Î¤Î¤Î¤Î"
+ (lambda () (string-fill! (string-copy "000000") #\¤Î)))
+(test "string-fill!" "000¤Î¤Î¤Î"
+ (lambda () (string-fill! (string-copy "000000") #\¤Î 3)))
+(test "string-fill!" "000¤Î¤Î0"
+ (lambda () (string-fill! (string-copy "000000") #\¤Î 3 5)))
+
+;(test "string-join" "¤Õ¤¥ ¤Ð¤¡ ¤Ð¤º"
+; (lambda () (string-join '("¤Õ¤¥" "¤Ð¤¡" "¤Ð¤º"))))
+;(test "string-join" "¤Õ¤¥¡ª¤Ð¤¡¡ª¤Ð¤º"
+; (lambda () (string-join '("¤Õ¤¥" "¤Ð¤¡" "¤Ð¤º") "¡ª")))
+;(test "string-join" "¤Õ¤¥¢ª¢«¤Ð¤¡¢ª¢«¤Ð¤º"
+; (lambda () (string-join '("¤Õ¤¥" "¤Ð¤¡" "¤Ð¤º") "¢ª¢«" 'infix)))
+;(test "string-join" ""
+; (lambda () (string-join '() "¢ª¢«")))
+;(test "string-join" "¤Õ¤¥¡ª¤Ð¤¡¡ª¤Ð¤º¡ª"
+; (lambda () (string-join '("¤Õ¤¥" "¤Ð¤¡" "¤Ð¤º") "¡ª" 'suffix)))
+;(test "string-join" "¡ª¤Õ¤¥¡ª¤Ð¤¡¡ª¤Ð¤º"
+; (lambda () (string-join '("¤Õ¤¥" "¤Ð¤¡" "¤Ð¤º") "¡ª" 'prefix)))
+;(test "string-join" "¤Õ¤¥¡ª¤Ð¤¡¡ª¤Ð¤º"
+; (lambda () (string-join '("¤Õ¤¥" "¤Ð¤¡" "¤Ð¤º") "¡ª" 'strict-infix)))
+
+;(test "string-substitute!" "¤¦¤¨¤ªdefghi"
+; (lambda ()
+; (let ((s (string-copy "abcdefghi")))
+; (string-substitute! s 0 "¤¦¤¨¤ª")
+; s)))
+;(test "string-substitute!" "abc¤¦¤¨¤ªghi"
+; (lambda ()
+; (let ((s (string-copy "abcdefghi")))
+; (string-substitute! s 3 "¤¦¤¨¤ª")
+; s)))
+
+;;-------------------------------------------------------------------
+;(test-section "string-pointer")
+;(define sp #f)
+;(test "make-string-pointer" #t
+; (lambda ()
+; (set! sp (make-string-pointer "¤¤¤í¤Ï¤Ëho¤Ø¤È"))
+; (string-pointer? sp)))
+;(test "string-pointer-next!" #\¤¤
+; (lambda () (string-pointer-next! sp)))
+;(test "string-pointer-next!" #\¤í
+; (lambda () (string-pointer-next! sp)))
+;(test "string-pointer-prev!" #\¤í
+; (lambda () (string-pointer-prev! sp)))
+;(test "string-pointer-prev!" #\¤¤
+; (lambda () (string-pointer-prev! sp)))
+;(test "string-pointer-prev!" #t
+; (lambda () (eof-object? (string-pointer-prev! sp))))
+;(test "string-pointer-index" 0
+; (lambda () (string-pointer-index sp)))
+;(test "string-pointer-index" 8
+; (lambda () (do ((x (string-pointer-next! sp) (string-pointer-next! sp)))
+; ((eof-object? x) (string-pointer-index sp)))))
+;(test "string-pointer-substring" '("¤¤¤í¤Ï¤Ëho¤Ø¤È" "")
+; (lambda () (list (string-pointer-substring sp)
+; (string-pointer-substring sp :after #t))))
+;(test "string-pointer-substring" '("¤¤¤í¤Ï¤Ëh" "o¤Ø¤È")
+; (lambda ()
+; (string-pointer-set! sp 5)
+; (list (string-pointer-substring sp)
+; (string-pointer-substring sp :after #t))))
+;(test "string-pointer-substring" '("" "¤¤¤í¤Ï¤Ëho¤Ø¤È")
+; (lambda ()
+; (string-pointer-set! sp 0)
+; (list (string-pointer-substring sp)
+; (string-pointer-substring sp :after #t))))
+
+;;-------------------------------------------------------------------
+;(use srfi-13)
+
+;(test "string-every" #t (lambda () (string-every #\¤¢ "")))
+;(test "string-every" #t (lambda () (string-every #\¤¢ "¤¢¤¢¤¢¤¢")))
+;(test "string-every" #f (lambda () (string-every #\¤¢ "¤¢¤¢¤¢a")))
+;(test "string-every" #t (lambda () (string-every #[¤¢-¤ó] "¤¢¤¢¤¤¤¢")))
+;(test "string-every" #f (lambda () (string-every #[¤¢-¤ó] "¤¢¤¢a¤¢")))
+;(test "string-every" #t (lambda () (string-every #[¤¢-¤ó] "")))
+;(test "string-every" #t (lambda () (string-every (lambda (x) (char-ci=? x #\¤¢)) "¤¢¤¢¤¢¤¢")))
+;(test "string-every" #f (lambda () (string-every (lambda (x) (char-ci=? x #\¤¢)) "¤¢¤¤¤¢¤¤")))
+
+;(test "string-any" #t (lambda () (string-any #\¤¢ "¤¢¤¢¤¢¤¢")))
+;(test "string-any" #f (lambda () (string-any #\¤¢ "¤¤¤¦¤¨¤ª")))
+;(test "string-any" #f (lambda () (string-any #\¤¢ "")))
+;(test "string-any" #t (lambda () (string-any #[¤¢-¤ó] "¤¹¤¡¼¤à")))
+;(test "string-any" #f (lambda () (string-any #[¤¢-¤ó] "¥¹¥¡¼¥à")))
+;(test "string-any" #f (lambda () (string-any #[¤¢-¤ó] "")))
+;(test "string-any" #t (lambda () (string-any (lambda (x) (char-ci=? x #\¤¢)) "¤é¤é¤é¤¢")))
+;(test "string-any" #f (lambda () (string-any (lambda (x) (char-ci=? x #\¤¢)) "¥é¥é¥é¥¢")))
+;(test "string-tabulate" "¥¢¥£¥¤¥¥¥¦"
+; (lambda ()
+; (string-tabulate (lambda (code)
+; (integer->char (+ code
+; (char->integer #\¥¢))))
+; 5)))
+;(test "reverse-list->string" "¤ó¤ò¤ï"
+; (lambda () (reverse-list->string '(#\¤ï #\¤ò #\¤ó))))
+;(test "string-copy!" "ab¤¦¤¨¤ªfg"
+; (lambda () (let ((x (string-copy "abcdefg")))
+; (string-copy! x 2 "¤¢¤¤¤¦¤¨¤ª¤«" 2 5)
+; x)))
+;(test "string-take" "¤¢¤¤¤¦¤¨" (lambda () (string-take "¤¢¤¤¤¦¤¨¤ª¤«" 4)))
+;(test "string-drop" "¤ª¤«" (lambda () (string-drop "¤¢¤¤¤¦¤¨¤ª¤«" 4)))
+;(test "string-take-right" "¤¦¤¨¤ª¤«" (lambda () (string-take-right "¤¢¤¤¤¦¤¨¤ª¤«" 4)))
+;(test "string-drop-right" "¤¢¤¤" (lambda () (string-drop-right "¤¢¤¤¤¦¤¨¤ª¤«" 4)))
+;(test "string-pad" "¢£¢£¥Ñ¥Ã¥É" (lambda () (string-pad "¥Ñ¥Ã¥É" 5 #\¢£)))
+;(test "string-pad" "¥Ñ¥Ç¥£¥ó¥°" (lambda () (string-pad "¥Ñ¥Ç¥£¥ó¥°" 5 #\¢£)))
+;(test "string-pad" "¥Ç¥£¥ó¥°¥¹" (lambda () (string-pad "¥Ñ¥Ç¥£¥ó¥°¥¹" 5 #\¢£)))
+;(test "string-pad-right" "¥Ñ¥Ã¥É¢£¢£" (lambda () (string-pad-right "¥Ñ¥Ã¥É" 5 #\¢£)))
+;(test "string-pad" "¥Ñ¥Ç¥£¥ó¥°" (lambda () (string-pad-right "¥Ñ¥Ç¥£¥ó¥°¥¹" 5 #\¢£)))
+
+;;-------------------------------------------------------------------
+;(use srfi-14)
+
+;(test "char-set" #t
+; (lambda () (char-set= (char-set #\¤¢ #\¤¤ #\¤¦ #\¤¨ #\¤ª)
+; (string->char-set "¤ª¤¦¤¨¤¤¤¢"))))
+;(test "char-set" #t
+; (lambda () (char-set= (list->char-set '(#\¤¢ #\¤¤ #\¤¦ #\¤ó))
+; (string->char-set "¤ó¤ó¤¤¤¤¤¤¤¢¤¢¤¦"))))
+;(test "char-set" #t
+; (lambda () (char-set<= (list->char-set '(#\¤Û #\¤²))
+; char-set:full)))
+;(test "char-set" #t
+; (lambda ()
+; (char-set= (->char-set "¤¡¤£¤¥¤§¤©¤¢¤¤¤¦¤¨")
+; (integer-range->char-set (char->integer #\¤¡)
+; (char->integer #\¤ª)))))
+
+(total-report)
Added: branches/r5rs/sigscheme/test/gauche-primsyn.scm
===================================================================
--- branches/r5rs/sigscheme/test/gauche-primsyn.scm 2005-08-17 16:17:51 UTC (rev 1208)
+++ branches/r5rs/sigscheme/test/gauche-primsyn.scm 2005-08-17 17:42:57 UTC (rev 1209)
@@ -0,0 +1,144 @@
+;;;
+;;; primitive syntax test
+;;;
+
+(load "./test/unittest-gauche.scm")
+
+;;----------------------------------------------------------------
+;(test-section "contitionals")
+
+(test "if" 5 (lambda () (if #f 2 5)))
+(test "if" 2 (lambda () (if (not #f) 2 5)))
+
+(test "and" #t (lambda () (and)))
+(test "and" 5 (lambda () (and 5)))
+(test "and" #f (lambda () (and 5 #f 2)))
+(test "and" #f (lambda () (and 5 #f unbound-var)))
+(test "and" 'a (lambda () (and 3 4 'a)))
+
+(test "or" #f (lambda () (or)))
+(test "or" 3 (lambda () (or 3 9)))
+(test "or" 3 (lambda () (or #f 3 unbound-var)))
+
+;(test "when" 4 (lambda () (when 3 5 4)))
+;(test "when" (test-undef) (lambda () (when #f 5 4)))
+;(test "unless" (test-undef) (lambda () (unless 3 5 4)))
+;(test "unless" 4 (lambda () (unless #f 5 4)))
+
+;(test "cond" (test-undef) (lambda () (cond (#f 2))))
+(test "cond" 5 (lambda () (cond (#f 2) (else 5))))
+(test "cond" 2 (lambda () (cond (1 2) (else 5))))
+(test "cond" 8 (lambda () (cond (#f 2) (1 8) (else 5))))
+(test "cond" 3 (lambda () (cond (1 => (lambda (x) (+ x 2))) (else 8))))
+
+(test "case" #t (lambda () (case (+ 2 3) ((1 3 5 7 9) #t) ((0 2 4 6 8) #f))))
+
+;;----------------------------------------------------------------
+;(test-section "closure and saved env")
+
+(test "lambda" 5 (lambda () ((lambda (x) (car x)) '(5 6 7))))
+(test "lambda" 12
+ (lambda ()
+ ((lambda (x y)
+ ((lambda (z) (* (car z) (cdr z))) (cons x y))) 3 4)))
+
+(define (addN n) (lambda (a) (+ a n)))
+(test "lambda" 5 (lambda () ((addN 2) 3)))
+(define add3 (addN 3))
+(test "lambda" 9 (lambda () (add3 6)))
+
+(define count (let ((c 0)) (lambda () (set! c (+ c 1)) c)))
+(test "lambda" 1 (lambda () (count)))
+(test "lambda" 2 (lambda () (count)))
+
+;;----------------------------------------------------------------
+;(test-section "application")
+
+;(test "apply" '(1 2 3) (lambda () (apply list 1 '(2 3))))
+;(test "apply" '(1 2 3) (lambda () (apply apply (list list 1 2 '(3)))))
+
+(test "map" '() (lambda () (map car '())))
+(test "map" '(1 2 3) (lambda () (map car '((1) (2) (3)))))
+(test "map" '(() () ()) (lambda () (map cdr '((1) (2) (3)))))
+(test "map" '((1 . 4) (2 . 5) (3 . 6)) (lambda () (map cons '(1 2 3) '(4 5 6))))
+
+;;----------------------------------------------------------------
+;(test-section "loop")
+
+(define (fact-non-tail-rec n)
+ (if (<= n 1) n (* n (fact-non-tail-rec (- n 1)))))
+(test "loop non-tail-rec" 120 (lambda () (fact-non-tail-rec 5)))
+
+(define (fact-tail-rec n r)
+ (if (<= n 1) r (fact-tail-rec (- n 1) (* n r))))
+(test "loop tail-rec" 120 (lambda () (fact-tail-rec 5 1)))
+
+(define (fact-named-let n)
+ (let loop ((n n) (r 1)) (if (<= n 1) r (loop (- n 1) (* n r)))))
+(test "loop named-let" 120 (lambda () (fact-named-let 5)))
+
+(define (fact-int-define n)
+ (define (rec n r) (if (<= n 1) r (rec (- n 1) (* n r))))
+ (rec n 1))
+(test "loop int-define" 120 (lambda () (fact-int-define 5)))
+
+(define (fact-do n)
+ (do ((n n (- n 1)) (r 1 (* n r))) ((<= n 1) r)))
+(test "loop do" 120 (lambda () (fact-do 5)))
+
+;;----------------------------------------------------------------
+;(test-section "quasiquote")
+
+(test "qq" '(1 2 3) (lambda () `(1 2 3)))
+(test "qq" '() (lambda () `()))
+(test "qq," '((1 . 2)) (lambda () `(,(cons 1 2))))
+(test "qq," '((1 . 2) 3) (lambda () `(,(cons 1 2) 3)))
+(test "qq@" '(1 2 3 4) (lambda () `(1 ,@(list 2 3) 4)))
+(test "qq@" '(1 2 3 4) (lambda () `(1 2 ,@(list 3 4))))
+(test "qq." '(1 2 3 4) (lambda () `(1 2 . ,(list 3 4))))
+(test "qq#," '#((1 . 2) 3) (lambda () `#(,(cons 1 2) 3)))
+(test "qq#@" '#(1 2 3 4) (lambda () `#(1 ,@(list 2 3) 4)))
+(test "qq#@" '#(1 2 3 4) (lambda () `#(1 2 ,@(list 3 4))))
+(test "qq#" '#() (lambda () `#()))
+(test "qq#@" '#() (lambda () `#(,@(list))))
+
+(test "qq@@" '(1 2 1 2) (lambda () `(,@(list 1 2) ,@(list 1 2))))
+(test "qq@@" '(1 2 a 1 2) (lambda () `(,@(list 1 2) a ,@(list 1 2))))
+(test "qq@@" '(a 1 2 1 2) (lambda () `(a ,@(list 1 2) ,@(list 1 2))))
+(test "qq@@" '(1 2 1 2 a) (lambda () `(,@(list 1 2) ,@(list 1 2) a)))
+(test "qq@@" '(1 2 1 2 a b) (lambda () `(,@(list 1 2) ,@(list 1 2) a b)))
+(test "qq at ." '(1 2 1 2 . a)
+ (lambda () `(,@(list 1 2) ,@(list 1 2) . a)))
+(test "qq at ." '(1 2 1 2 1 . 2)
+ (lambda () `(,@(list 1 2) ,@(list 1 2) . ,(cons 1 2))))
+(test "qq at ." '(1 2 1 2 a 1 . 2)
+ (lambda () `(,@(list 1 2) ,@(list 1 2) a . ,(cons 1 2))))
+
+(test "qq#@@" '#(1 2 1 2) (lambda () `#(,@(list 1 2) ,@(list 1 2))))
+(test "qq#@@" '#(1 2 a 1 2) (lambda () `#(,@(list 1 2) a ,@(list 1 2))))
+(test "qq#@@" '#(a 1 2 1 2) (lambda () `#(a ,@(list 1 2) ,@(list 1 2))))
+(test "qq#@@" '#(1 2 1 2 a) (lambda () `#(,@(list 1 2) ,@(list 1 2) a)))
+(test "qq#@@" '#(1 2 1 2 a b) (lambda () `#(,@(list 1 2) ,@(list 1 2) a b)))
+
+(test "qqq" '(1 `(1 ,2 ,3) 1) (lambda () `(1 `(1 ,2 ,,(+ 1 2)) 1)))
+(test "qqq" '(1 `(1 , at 2 ,@(1 2))) (lambda () `(1 `(1 , at 2 ,@,(list 1 2)))))
+(test "qqq#" '#(1 `(1 ,2 ,3) 1) (lambda () `#(1 `(1 ,2 ,,(+ 1 2)) 1)))
+(test "qqq#" '#(1 `(1 , at 2 ,@(1 2))) (lambda () `#(1 `(1 , at 2 ,@,(list 1 2)))))
+
+;;----------------------------------------------------------------
+;(test-section "multiple values")
+;(test "receive" '(1 2 3)
+; (lambda () (receive (a b c) (values 1 2 3) (list a b c))))
+;(test "receive" '(1 2 3)
+; (lambda () (receive (a . r) (values 1 2 3) (cons a r))))
+;(test "receive" '(1 2 3)
+; (lambda () (receive x (values 1 2 3) x)))
+;(test "receive" 1
+; (lambda () (receive (a) 1 a)))
+;(test "call-with-values" '(1 2 3)
+; (lambda () (call-with-values (lambda () (values 1 2 3)) list)))
+;(test "call-with-values" '()
+; (lambda () (call-with-values (lambda () (values)) list)))
+
+(total-report)
+
Modified: branches/r5rs/sigscheme/test/test-r4rs.scm
===================================================================
--- branches/r5rs/sigscheme/test/test-r4rs.scm 2005-08-17 16:17:51 UTC (rev 1208)
+++ branches/r5rs/sigscheme/test/test-r4rs.scm 2005-08-17 17:42:57 UTC (rev 1209)
@@ -43,22 +43,22 @@
(define cur-section '())(define errs '())
(define SECTION (lambda args
- (display "SECTION") (write args) (newline)
+; (display "SECTION") (write args) (newline)
(set! cur-section args) #t))
(define record-error (lambda (e) (set! errs (cons (list cur-section e) errs))))
(define test
(lambda (expect fun . args)
- (write (cons fun args))
- (display " ==> ")
+; (write (cons fun args))
+; (display " ==> ")
((lambda (res)
- (write res)
- (newline)
+; (write res)
+; (newline)
(cond ((not (equal? expect res))
(record-error (list res expect (cons fun args)))
- (display " BUT EXPECTED ")
- (write expect)
- (newline)
+; (display " BUT EXPECTED ")
+; (write expect)
+; (newline)
#f)
(else #t)))
(if (procedure? fun) (apply fun args) (car args)))))
@@ -86,15 +86,16 @@
(define i 1)
(for-each (lambda (x) (display (make-string i #\ ))
(set! i (+ 3 i))
- (write x)
- (newline))
+; (write x)
+; (newline)
+ )
disjoint-type-functions)
(define type-matrix
(map (lambda (x)
(let ((t (map (lambda (f) (f x)) disjoint-type-functions)))
- (write t)
- (write x)
- (newline)
+; (write t)
+; (write x)
+; (newline)
t))
type-examples))
(set! i 0)
@@ -923,9 +924,6 @@
(test #\a string-ref "abc" 0)
(test #\c string-ref "abc" 2)
(test 0 string-length "")
-
-(print "foooooooooooo")
-
(test "" substring "ab" 0 0)
(test "" substring "ab" 1 1)
(test "" substring "ab" 2 2)
Added: branches/r5rs/sigscheme/test/unittest-bigloo.scm
===================================================================
--- branches/r5rs/sigscheme/test/unittest-bigloo.scm 2005-08-17 16:17:51 UTC (rev 1208)
+++ branches/r5rs/sigscheme/test/unittest-bigloo.scm 2005-08-17 17:42:57 UTC (rev 1209)
@@ -0,0 +1,12 @@
+(load "./test/unittest.scm")
+
+;*---------------------------------------------------------------------*/
+;* For Bigloo Test */
+;*---------------------------------------------------------------------*/
+(define test assert-equal?)
+(define (foo1 x)
+ x)
+(define (foo2 . x)
+ x)
+(define (foo3 x . y)
+ (cons x y))
Added: branches/r5rs/sigscheme/test/unittest-gauche.scm
===================================================================
--- branches/r5rs/sigscheme/test/unittest-gauche.scm 2005-08-17 16:17:51 UTC (rev 1208)
+++ branches/r5rs/sigscheme/test/unittest-gauche.scm 2005-08-17 17:42:57 UTC (rev 1209)
@@ -0,0 +1,5 @@
+(load "./test/unittest.scm")
+
+(define test
+ (lambda (msg ret func)
+ (assert-equal? msg ret (func))))
Modified: branches/r5rs/sigscheme/test/unittest.scm
===================================================================
--- branches/r5rs/sigscheme/test/unittest.scm 2005-08-17 16:17:51 UTC (rev 1208)
+++ branches/r5rs/sigscheme/test/unittest.scm 2005-08-17 17:42:57 UTC (rev 1209)
@@ -10,27 +10,24 @@
(if (= total-err-num 0)
(print "OK")
(begin
- (print "[ ERROR NUM ]\n")
- (print total-err-num)
- (print "\n"))))))
+ (print "[ ERROR NUM ]")
+ (print total-err-num))))))
(define report-error
(lambda (errmsg)
(begin
(print "error : ")
- (print errmsg)
- (print "\n"))))
+ (print errmsg))))
(define assert
(lambda (msg exp)
- (begin
- (set! total-test-num (+ total-test-num 1))
- (if exp
- #t
- (begin
- (set! total-err-num (+ total-err-num 1))
- (report-error msg)
- #f)))))
+ (set! total-test-num (+ total-test-num 1))
+ (if exp
+ #t
+ (begin
+ (set! total-err-num (+ total-err-num 1))
+ (report-error msg)
+ #f))))
(define assert-eq?
(lambda (msg a b)
@@ -39,8 +36,7 @@
(print "assert-eq? : we expect ")
(print a)
(print " but got ")
- (print b)
- (print "\n")))))
+ (print b)))))
(define assert-equal?
(lambda (msg a b)
@@ -49,5 +45,4 @@
(print "assert-equal? : we expect ")
(print a)
(print " but got ")
- (print b)
- (print "\n")))))
+ (print b)))))
More information about the uim-commit
mailing list