[uim-commit] r2106 - branches/r5rs/sigscheme/test
yamaken at freedesktop.org
yamaken at freedesktop.org
Tue Nov 8 22:28:26 PST 2005
Author: yamaken
Date: 2005-11-08 22:28:22 -0800 (Tue, 08 Nov 2005)
New Revision: 2106
Modified:
branches/r5rs/sigscheme/test/test-srfi34-2.scm
branches/r5rs/sigscheme/test/test-srfi34.scm
branches/r5rs/sigscheme/test/unittest.scm
Log:
* sigscheme/test/unittest.scm
- (*test-track-progress*): New variable
- (assert): Add progress tracking to locate SEGV point
* sigscheme/test/test-srfi34.scm
* sigscheme/test/test-srfi34-2.scm
- Enable *test-track-progress* to locate SEGV point
- Remove manual printings of progress
- Append tracking number to each test names
- Mark current status as SEGV and FAILED to some tests
- Comment out SEGV'ed tests temporarily
Modified: branches/r5rs/sigscheme/test/test-srfi34-2.scm
===================================================================
--- branches/r5rs/sigscheme/test/test-srfi34-2.scm 2005-11-09 05:05:27 UTC (rev 2105)
+++ branches/r5rs/sigscheme/test/test-srfi34-2.scm 2005-11-09 06:28:22 UTC (rev 2106)
@@ -37,6 +37,8 @@
(use srfi-34))
(else #t))
+(set! *test-track-progress* #t)
+
;; these tests are ported from "Examples" section of SRFI-34
(define print-expected
@@ -46,11 +48,9 @@
(newline)
(display " actual print: ")))
-(display "test #1")
-(newline)
;;PRINTS: condition: an-error
(print-expected "condition: an-error")
-(assert-equal? "Examples of SRFI-34 document"
+(assert-equal? "Examples of SRFI-34 document #1"
'exception
(call-with-current-continuation
(lambda (k)
@@ -62,29 +62,26 @@
(lambda ()
(+ 1 (raise 'an-error)))))))
-(display "test #2")
-(newline)
+;; SEGV
;;PRINTS: something went wrong
;; Then behaves in an unspecified way. Although the behavior when a handler
;; returned is not specified in SRFI-34, SigScheme should produce an error to
;; prevent being misused by users.
-(print-expected "something went wrong")
-(assert-error "Examples of SRFI-34 document"
- (lambda ()
- (call-with-current-continuation
- (lambda (k)
- (with-exception-handler (lambda (x)
- (display "something went wrong")
- (newline)
- 'dont-care)
- (lambda ()
- (+ 1 (raise 'an-error))))))))
+;;(print-expected "something went wrong")
+;;(assert-error "Examples of SRFI-34 document #2"
+;; (lambda ()
+;; (call-with-current-continuation
+;; (lambda (k)
+;; (with-exception-handler (lambda (x)
+;; (display "something went wrong")
+;; (newline)
+;; 'dont-care)
+;; (lambda ()
+;; (+ 1 (raise 'an-error))))))))
-(display "test #3")
-(newline)
;;PRINTS: condition: an-error
(print-expected "condition: an-error")
-(assert-equal? "Examples of SRFI-34 document"
+(assert-equal? "Examples of SRFI-34 document #3"
'exception
(guard (condition
(else
@@ -94,11 +91,9 @@
'exception))
(+ 1 (raise 'an-error))))
-(display "test #4")
-(newline)
;;PRINTS: something went wrong
(print-expected "something went wrong")
-(assert-equal? "Examples of SRFI-34 document"
+(assert-equal? "Examples of SRFI-34 document #4"
'dont-care
(guard (condition
(else
@@ -107,41 +102,37 @@
'dont-care))
(+ 1 (raise 'an-error))))
-(display "test #5")
-(newline)
-(assert-equal? "Examples of SRFI-34 document"
- 'positive
- (call-with-current-continuation
- (lambda (k)
- (with-exception-handler (lambda (x)
- (display "reraised ") (write x) (newline)
- (k 'zero))
- (lambda ()
- (guard (condition
- ((positive? condition) 'positive)
- ((negative? condition) 'negative))
- (raise 1)))))))
+;; SEGV
+;;(assert-equal? "Examples of SRFI-34 document #5"
+;; 'positive
+;; (call-with-current-continuation
+;; (lambda (k)
+;; (with-exception-handler (lambda (x)
+;; (display "reraised ") (write x) (newline)
+;; (k 'zero))
+;; (lambda ()
+;; (guard (condition
+;; ((positive? condition) 'positive)
+;; ((negative? condition) 'negative))
+;; (raise 1)))))))
-(display "test #6")
-(newline)
-(assert-equal? "Examples of SRFI-34 document"
- 'negative
- (call-with-current-continuation
- (lambda (k)
- (with-exception-handler (lambda (x)
- (display "reraised ") (write x) (newline)
- (k 'zero))
- (lambda ()
- (guard (condition
- ((positive? condition) 'positive)
- ((negative? condition) 'negative))
- (raise -1)))))))
+;; SEGV
+;;(assert-equal? "Examples of SRFI-34 document #6"
+;; 'negative
+;; (call-with-current-continuation
+;; (lambda (k)
+;; (with-exception-handler (lambda (x)
+;; (display "reraised ") (write x) (newline)
+;; (k 'zero))
+;; (lambda ()
+;; (guard (condition
+;; ((positive? condition) 'positive)
+;; ((negative? condition) 'negative))
+;; (raise -1)))))))
-(display "test #7")
-(newline)
;;PRINTS: reraised 0
(print-expected "reraised 0")
-(assert-equal? "Examples of SRFI-34 document"
+(assert-equal? "Examples of SRFI-34 document #7"
'zero
(call-with-current-continuation
(lambda (k)
@@ -154,18 +145,14 @@
((negative? condition) 'negative))
(raise 0)))))))
-(display "test #8")
-(newline)
-(assert-equal? "Examples of SRFI-34 document"
+(assert-equal? "Examples of SRFI-34 document #8"
42
(guard (condition
((assq 'a condition) => cdr)
((assq 'b condition)))
(raise (list (cons 'a 42)))))
-(display "test #9")
-(newline)
-(assert-equal? "Examples of SRFI-34 document"
+(assert-equal? "Examples of SRFI-34 document #9"
'(b . 23)
(guard (condition
((assq 'a condition) => cdr)
Modified: branches/r5rs/sigscheme/test/test-srfi34.scm
===================================================================
--- branches/r5rs/sigscheme/test/test-srfi34.scm 2005-11-09 05:05:27 UTC (rev 2105)
+++ branches/r5rs/sigscheme/test/test-srfi34.scm 2005-11-09 06:28:22 UTC (rev 2106)
@@ -37,12 +37,15 @@
(use srfi-34))
(else #t))
+(set! *test-track-progress* #t)
+
+;;
;; with-exception-handler
+;;
+;; FAILED
;; Although the behavior when a handler returned is not specified in SRFI-34,
;; SigScheme should produce an error to prevent being misused by users.
-(display "with-exception-handler #1")
-(newline)
(assert-error "with-exception-handler #1"
(lambda ()
(with-exception-handler
@@ -51,21 +54,16 @@
(lambda ()
(+ 1 (raise 'an-error))))))
-(display "with-exception-handler #2")
-(newline)
-(assert-error "with-exception-handler #3"
- (lambda ()
- (with-exception-handler
- (lambda (x)
- (assert-equal? "with-exception-handler #2" 'an-error x)
- (display "with-exception-handler #3")
- (newline)
- 'a-handler-must-not-return)
- (lambda ()
- (+ 1 (raise 'an-error))))))
+;; SEGV
+;;(assert-error "with-exception-handler #3"
+;; (lambda ()
+;; (with-exception-handler
+;; (lambda (x)
+;; (assert-equal? "with-exception-handler #2" 'an-error x)
+;; 'a-handler-must-not-return)
+;; (lambda ()
+;; (+ 1 (raise 'an-error))))))
-(display "with-exception-handler #4")
-(newline)
(assert-equal? "with-exception-handler #4"
6
(with-exception-handler
@@ -74,8 +72,6 @@
(lambda ()
(+ 1 2 3))))
-(display "with-exception-handler #5")
-(newline)
(assert-equal? "with-exception-handler #5"
'success
(with-exception-handler
@@ -86,20 +82,14 @@
;; guard
-(display "guard #1")
-(newline)
(assert-equal? "guard #1"
'exception
(guard (condition
(else
- (display "guard #2")
- (newline)
(assert-equal? "guard #2" 'an-error condition)
'exception))
(+ 1 (raise 'an-error))))
-(display "guard #3")
-(newline)
(assert-equal? "guard #3"
3
(guard (condition
@@ -107,8 +97,6 @@
'exception))
(+ 1 2)))
-(display "guard #4")
-(newline)
(assert-equal? "guard #4"
'success
(guard (condition
@@ -116,8 +104,6 @@
'exception))
'success))
-(display "guard #5")
-(newline)
(assert-equal? "guard #5"
'exception
(guard (condition
@@ -125,8 +111,6 @@
'exception))
(+ 1 (raise 'error))))
-(display "guard #6")
-(newline)
(assert-equal? "guard #6"
42
(guard (condition
@@ -137,8 +121,6 @@
(newline)))
(raise (list (cons 'a 42)))))
-(display "guard #7")
-(newline)
(assert-equal? "guard #7"
'(b . 23)
(guard (condition
@@ -149,22 +131,21 @@
(newline)))
(raise (list (cons 'b 23)))))
-
+;;
;; mixed use of with-exception-handler and guard
-(display "mixed exception handling #1")
-(newline)
-(assert-equal? "mixed exception handling #1"
- 'guard-ret
- (with-exception-handler (lambda (x)
- (k 'with-exception-ret))
- (lambda ()
- (guard (condition
- (else
- 'guard-ret))
- (raise 1)))))
+;;
-(display "mixed exception handling #2")
-(newline)
+;; SEGV
+;;(assert-equal? "mixed exception handling #1"
+;; 'guard-ret
+;; (with-exception-handler (lambda (x)
+;; (k 'with-exception-ret))
+;; (lambda ()
+;; (guard (condition
+;; (else
+;; 'guard-ret))
+;; (raise 1)))))
+
(assert-equal? "mixed exception handling #2"
'with-exception-ret
(with-exception-handler (lambda (x)
@@ -175,36 +156,32 @@
'guard-ret))
(raise 1)))))
-(display "mixed exception handling #3")
-(newline)
-(assert-equal? "mixed exception handling #3"
- 'positive
- (call-with-current-continuation
- (lambda (k)
- (with-exception-handler (lambda (x)
- (k 'zero))
- (lambda ()
- (guard (condition
- ((positive? condition) 'positive)
- ((negative? condition) 'negative))
- (raise 1)))))))
+;; SEGV
+;;(assert-equal? "mixed exception handling #3"
+;; 'positive
+;; (call-with-current-continuation
+;; (lambda (k)
+;; (with-exception-handler (lambda (x)
+;; (k 'zero))
+;; (lambda ()
+;; (guard (condition
+;; ((positive? condition) 'positive)
+;; ((negative? condition) 'negative))
+;; (raise 1)))))))
-(display "mixed exception handling #4")
-(newline)
-(assert-equal? "mixed exception handling #4"
- 'negative
- (call-with-current-continuation
- (lambda (k)
- (with-exception-handler (lambda (x)
- (k 'zero))
- (lambda ()
- (guard (condition
- ((positive? condition) 'positive)
- ((negative? condition) 'negative))
- (raise -1)))))))
+;; SEGV
+;;(assert-equal? "mixed exception handling #4"
+;; 'negative
+;; (call-with-current-continuation
+;; (lambda (k)
+;; (with-exception-handler (lambda (x)
+;; (k 'zero))
+;; (lambda ()
+;; (guard (condition
+;; ((positive? condition) 'positive)
+;; ((negative? condition) 'negative))
+;; (raise -1)))))))
-(display "mixed exception handling #5")
-(newline)
(assert-equal? "mixed exception handling #5"
'zero
(call-with-current-continuation
Modified: branches/r5rs/sigscheme/test/unittest.scm
===================================================================
--- branches/r5rs/sigscheme/test/unittest.scm 2005-11-09 05:05:27 UTC (rev 2105)
+++ branches/r5rs/sigscheme/test/unittest.scm 2005-11-09 06:28:22 UTC (rev 2106)
@@ -40,6 +40,7 @@
(use srfi-34))
(else #t))
+(define *test-track-progress* #f) ;; for locationg SEGV point
(define *total-testsuites* 1) ;; TODO: introduce test suites and defaults to 0
(define *total-testcases* 1) ;; TODO: introduce testcase and defaults to 0
(define *total-tests* 1) ;; TODO: introduce test group and defaults to 0
@@ -85,6 +86,11 @@
(define assert
(lambda (err-msg exp)
(set! *total-assertions* (+ *total-assertions* 1))
+ (if *test-track-progress*
+ (begin
+ (display "done: ")
+ (display err-msg) ;; FIXME: should indicate test-name
+ (newline)))
(if exp
#t
(begin
More information about the uim-commit
mailing list