picrin/contrib/30.test/test.scm

105 lines
3.3 KiB
Scheme
Raw Blame History

This file contains invisible Unicode characters

This file contains invisible Unicode characters that are indistinguishable to humans but may be processed differently by a computer. If you think that this is intentional, you can safely ignore this warning. Use the Escape button to reveal them.

(define-library (picrin test)
(import (scheme base)
(scheme write))
(define test-counter 0)
(define counter 0)
(define failure-counter 0)
(define fails '())
(define (print-statistics)
(newline)
(display "Test Result: ")
(write (- counter failure-counter))
(display " / ")
(write counter)
(display " (")
(write (* (/ (- counter failure-counter) counter) 100))
(display "%)")
(display " [PASS/TOTAL]")
(display "")
(newline)
(for-each
(lambda (fail)
(display fail))
(reverse fails)))
(define (test-begin . o)
(set! test-counter (+ test-counter 1)))
(define (test-end . o)
(set! test-counter (- test-counter 1))
(if (= test-counter 0)
(print-statistics)))
(define-syntax test
(syntax-rules ()
((test expected expr)
(test expected expr equal?))
((test expected expr =)
(begin
(display "case ")
(write counter)
(let ((res (call/cc
(lambda (k)
(with-exception-handler
(lambda (e) (k (cons 'raised e)))
(lambda ()
(cons #f expr)))))))
(if (eq? (car res) 'raised)
(let ((out (open-output-string)))
(display " ERROR: " out)
(write 'expr out)
(newline out)
(display " expected " out)
(write expected out)
(display " but got an error " out)
(write (cdr res) out)
(display "" out)
(newline out)
(let ((str (get-output-string out)))
(set! fails (cons str fails))
(display str)))
(let ((res (cdr res)))
(if (= res expected)
(begin
(display " PASS: ")
(write 'expr)
(display " equals ")
(write expected)
(display "")
(newline))
(begin
(set! failure-counter (+ failure-counter 1))
(let ((out (open-output-string)))
(display " FAIL: " out)
(write 'expr out)
(newline out)
(display " expected " out)
(write expected out)
(display " but got " out)
(write res out)
(display "" out)
(newline out)
(let ((str (get-output-string out)))
(set! fails (cons str fails))
(display str)))))))
(set! counter (+ counter 1)))))))
(define-syntax test-values
(syntax-rules ()
((_ expect expr)
(test (call-with-values (lambda () expect) (lambda results results))
(call-with-values (lambda () expr) (lambda results results))))))
(define (test-failure-count)
(length fails))
(define-syntax test-syntax-error
(syntax-rules ()
((_) (syntax-error "invalid use of test-syntax-error"))))
(export test test-begin test-end test-values test-syntax-error))