(define-syntax assert
(syntax-rules ()
((_ expr)
(assert #f expr))
((_ name expr)
(*assert name 'expr (lambda () expr)))))
(define (*assert name expr proc)
(test-begin name expr)
(let ((value (with-exception-handler
(lambda (handler)
(test-error name expr)
(raise handler))
proc)))
(if value
(test-success name expr)
(test-failure name expr)))
(values))
(define-syntax assert-fails
(syntax-rules ()
((_ expr)
(assert-fails #f expr))
((_ name expr)
(*assert-fails name 'expr (lambda () expr)))))
(define (*assert-fails name expr proc)
(test-begin name expr)
(call-with-current-continuation
(lambda (return)
(with-exception-handler
(lambda (c)
(test-success name expr)
(return))
proc)
(test-failure name expr)))
(values))
(define (test-begin name expr)
(if name
(begin
(display name)
(display " ... "))))
(define (test-success name expr)
(if name
(begin
(display "[ OK ]")
(newline))))
(define (test-failure name expr)
(if (not name)
(begin
(display "Testing ")
(write expr)
(display " ... ")))
(display "[FAIL]")
(newline)
(error "Test suite failed."))
(define (test-error name expr)
(if (not name)
(begin
(display "Testing ")
(write expr)
(display " ... ")))
(display "[ERROR]")
(newline))