[uim-commit] r2890 - in branches/r5rs/sigscheme: . test
yamaken at freedesktop.org
yamaken at freedesktop.org
Tue Jan 10 11:50:29 PST 2006
Author: yamaken
Date: 2006-01-10 11:50:23 -0800 (Tue, 10 Jan 2006)
New Revision: 2890
Modified:
branches/r5rs/sigscheme/syntax.c
branches/r5rs/sigscheme/test/test-exp.scm
Log:
* sigscheme/syntax.c
- (scm_s_do): Fix incorrect syntax application for scm_s_begin()
which uses eval_state invalidly, with FOR_EACH_PAIR()
* sigscheme/test/test-exp.scm
- Add various tests for 'do'. Some tests cause error
$ ./sscm test/test-exp.scm
error: no error has occurred in test do invalid form: non-list bindings form #2
error: no error has occurred in test do invalid form: duplicate variable name #1
error: no error has occurred in test do invalid form: duplicate variable name #2
error: no error has occurred in test do invalid form: improper binding #3
error: no error has occurred in test do invalid form: improper commands #1
error: do valid form: no exps #1
expected: <#<undef>>
actual: <#t>
FAILED: 1 tests, 272 assertions, 266 successes, 6 failures, 0 errors
And "do invalid form: non-list test form" causes SEGV
Modified: branches/r5rs/sigscheme/syntax.c
===================================================================
--- branches/r5rs/sigscheme/syntax.c 2006-01-10 17:15:40 UTC (rev 2889)
+++ branches/r5rs/sigscheme/syntax.c 2006-01-10 19:50:23 UTC (rev 2890)
@@ -894,7 +894,8 @@
/* now execution phase! */
while (FALSEP(EVAL(test, env))) {
/* execute commands */
- EVAL(scm_s_begin(commands, eval_state), env);
+ FOR_EACH_PAIR(tmp, commands)
+ EVAL(CAR(tmp), env);
/*
* Notice
Modified: branches/r5rs/sigscheme/test/test-exp.scm
===================================================================
--- branches/r5rs/sigscheme/test/test-exp.scm 2006-01-10 17:15:40 UTC (rev 2889)
+++ branches/r5rs/sigscheme/test/test-exp.scm 2006-01-10 19:50:23 UTC (rev 2890)
@@ -32,6 +32,8 @@
(load "./test/unittest.scm")
+(use srfi-23)
+
(define tn test-name)
(define tee #t)
@@ -693,37 +695,233 @@
;;
;; do
;;
-(assert-error "do invalid form #1"
- (lambda ()
- (do)))
-(assert-error "do invalid form #2"
- (lambda ()
- (do a)))
-(assert-error "do invalid form #3"
- (lambda ()
- (do (a 1))))
-(assert-error "do invalid form #4"
- (lambda ()
- (do ((a 1))
- )))
-(assert-error "do invalid form #5"
- (lambda ()
- (do ((a))
- 'eval)))
-(assert-error "do invalid form #6"
- (lambda ()
- (do ((a 1))
- 'unknow-value)))
-(assert-error "do invalid form #7"
- (lambda ()
- (do ((a 1 2 'excessive))
- 'eval)))
-(assert-error "do invalid form #8"
- (lambda ()
- (do ((a 1))
- ()
- 'eval)))
+(if (or (symbol-bound? 'v)
+ (symbol-bound? 'w)
+ (symbol-bound? 'i)
+ (symbol-bound? 'evaled))
+ (error "global variables for 'do' tests are tainted"))
+(tn "do invalid form")
+(assert-error (tn) (lambda ()
+ (do)))
+(assert-error (tn) (lambda ()
+ (do v)))
+(assert-error (tn) (lambda ()
+ (do (v 1))))
+(assert-error (tn) (lambda ()
+ (do ((v 1))
+ )))
+(assert-error (tn) (lambda ()
+ (do ((v))
+ 'eval)))
+(assert-error (tn) (lambda ()
+ (do ((v 1))
+ 'unknow-value)))
+(assert-error (tn) (lambda ()
+ (do ((v 1 2 'excessive))
+ 'eval)))
+(tn "do invalid form: no test")
+(assert-error (tn) (lambda ()
+ (do ((v 1))
+ ()
+ 'eval)))
+(tn "do invalid form: non-list test form")
+(assert-error (tn) (lambda ()
+ (do ((v 1))
+ 'test
+ 'eval)))
+(assert-error (tn) (lambda ()
+ (do ((v 1))
+ 1
+ 'eval)))
+(tn "do invalid form: non-list bindings form")
+(assert-error (tn) (lambda ()
+ (do 'bindings
+ (#t #t)
+ 'eval)))
+(assert-error (tn) (lambda ()
+ (do 1
+ (#t #t)
+ 'eval)))
+(tn "do invalid form: non-symbol variable name")
+(assert-error (tn) (lambda ()
+ (do ((1 1))
+ (#t #t)
+ #t)))
+(assert-error (tn) (lambda ()
+ (do ((#t 1))
+ (#t #t)
+ #t)))
+(assert-error (tn) (lambda ()
+ (do (("a" 1))
+ (#t #t)
+ #t)))
+(tn "do invalid form: duplicate variable name")
+(assert-error (tn) (lambda ()
+ (do ((v 1)
+ (v 2))
+ (#t #t)
+ #t)))
+(assert-error (tn) (lambda ()
+ (do ((v 1)
+ (w 0)
+ (v 2))
+ (#t #t)
+ #t)))
+(tn "do invalid form: improper binding")
+(assert-error (tn) (lambda ()
+ (do ((v . 1))
+ (#t #t)
+ #t)))
+(assert-error (tn) (lambda ()
+ (do ((v 1 . v))
+ (#t #t)
+ #t)))
+(assert-error (tn) (lambda ()
+ (do ((v 1) . 1)
+ (#t #t)
+ #t)))
+(tn "do invalid form: improper exps")
+(assert-error (tn) (lambda ()
+ (do ((v 1))
+ (#t . #t)
+ #t)))
+(assert-error (tn) (lambda ()
+ (do ((v 1))
+ (#t #t . #t)
+ #t)))
+(tn "do invalid form: improper commands")
+(assert-error (tn) (lambda ()
+ (do ((v 1))
+ (#t #t)
+ #t . #t)))
+
+(tn "do valid form: no bindings")
+(assert-true (tn) (lambda ()
+ (do ()
+ (#t #t)
+ 'foo)))
+(assert-true (tn) (lambda ()
+ (do ()
+ (#t)
+ 'foo)))
+(assert-true (tn) (lambda ()
+ (do ()
+ (#t #t)
+ )))
+(assert-true (tn) (lambda ()
+ (do ()
+ (#t)
+ )))
+(tn "do valid form: no commands")
+(assert-true (tn) (lambda ()
+ (do ((v 1))
+ (#t #t)
+ )))
+(assert-true (tn) (lambda ()
+ (do ((v 1))
+ (#t)
+ )))
+(tn "do valid form: no exps")
+(if (provided? "sigscheme")
+ (assert-equal? (tn)
+ (undef)
+ (do ((v 1))
+ (#t)
+ 'foo)))
+
+(tn "do inter-iteration variable isolation")
+(assert-equal? (tn)
+ '(2 1 0)
+ (do ((v '() (cons i v))
+ (i 0 (+ i 1)))
+ ((= i 3) v)
+ ))
+(assert-equal? (tn)
+ '(2 1 0)
+ (do ((i 0 (+ i 1))
+ (v '() (cons i v)))
+ ((= i 3) v)
+ ))
+
+(tn "do initialize-time variable isolation")
+(assert-error (tn) (lambda () (do ((v 1)
+ (w v))
+ (#t #t)
+ )))
+(assert-error (tn) (lambda () (do ((w v)
+ (v 1))
+ (#t #t)
+ )))
+
+(tn "do exp is evaluated exactly once")
+(assert-equal? (tn)
+ '(+ v w)
+ (do ((v 1)
+ (w 2))
+ (#t '(+ v w))
+ ))
+
+(tn "do iteration count")
+(assert-equal? (tn)
+ 0
+ (do ((i 0 (+ i 1))
+ (evaled 0))
+ (#t evaled)
+ (set! evaled (+ evaled 1))))
+(assert-equal? (tn)
+ 0
+ (do ((i 0 (+ i 1))
+ (evaled 0))
+ ((= i 0) evaled)
+ (set! evaled (+ evaled 1))))
+(assert-equal? (tn)
+ 1
+ (do ((i 0 (+ i 1))
+ (evaled 0))
+ ((= i 1) evaled)
+ (set! evaled (+ evaled 1))))
+(assert-equal? (tn)
+ 2
+ (do ((i 0 (+ i 1))
+ (evaled 0))
+ ((= i 2) evaled)
+ (set! evaled (+ evaled 1))))
+
+(tn "do variable update")
+(assert-equal? (tn)
+ 10
+ (do ((v 1)
+ (w 2))
+ (#t (set! v (+ v 1))
+ (set! w (+ w v))
+ (set! v (+ v w))
+ (+ w v))
+ ))
+(assert-equal? (tn)
+ 16
+ (do ((i 0 (+ i 1))
+ (v 1)
+ (w 2))
+ ((= i 1)
+ (set! v (+ v 1))
+ (set! w (+ w v))
+ (set! v (+ v w))
+ (+ w v))
+ (set! v 3)))
+(assert-equal? (tn)
+ 20
+ (do ((i 0 (+ i 1))
+ (v 1)
+ (w 2))
+ ((= i 1)
+ (set! v (+ v 1))
+ (set! w (+ w v))
+ (set! v (+ v w))
+ (+ w v))
+ (set! v 3)
+ (set! w 4)))
+
(assert-equal? "do test1" '#(0 1 2 3 4) (do ((vec (make-vector 5))
(i 0 (+ i 1)))
((= i 5) vec)
More information about the uim-commit
mailing list