diff options
Diffstat (limited to 'lib/csc/testing.csc')
| -rw-r--r-- | lib/csc/testing.csc | 91 |
1 files changed, 0 insertions, 91 deletions
diff --git a/lib/csc/testing.csc b/lib/csc/testing.csc deleted file mode 100644 index 68678ca..0000000 --- a/lib/csc/testing.csc +++ /dev/null @@ -1,91 +0,0 @@ -(define-library (csc testing) - (export - assert - assert-equal - assert-raises - test - test-main) - (import (scheme base) - (only (scheme write) - display - write) - (only (csc compare) diff)) - (begin - - - (define *all-tests-succeeded* #t) - - - (define (set-all-succeeded! val) (set! *all-tests-succeeded* val)) - - - (define-record-type <test-handle> - (make-test-handle test-name) - test-handle? - (test-name test-name set-name!)) - - - (define-record-type <test-error> - (make-test-error) - test-error?) - - - (define *test-error* (make-test-error)) - - - (define *test-handle* (make-test-handle "global")) - - - (define (print . xs) - (unless (null? xs) - (let ((x (car xs))) - (if (or (string? x) - (symbol? x)) - (display x) - (write x))) - (apply print (cdr xs)))) - - - (define-syntax test - (syntax-rules () - ((test name body body* ...) - (begin - (set-name! *test-handle* (symbol->string 'name)) - (print "=== RUN " 'name "\n") - (guard (e ((test-error? e) - (print "--- FAIL: " 'name "\n") - (set-all-succeeded! #f))) - body body* ... - (print "--- PASS: " 'name "\n")))))) - - - (define-syntax assert - (syntax-rules () - ((assert expr) - (unless expr - (print (test-name *test-handle*) ": (assert " 'expr ") failed.\n") - (raise *test-error*))))) - - - (define-syntax assert-equal - (syntax-rules () - ((assert-equal left right transformers ...) - (let ((d (diff left right transformers ...))) - (unless (string=? "" d) - (print "Fatal:\n " 'left "\nis not equal to\n " 'right "\ndiff (-left +right):\n" d "\n") - (raise *test-error*)))))) - - - (define-syntax assert-raises - (syntax-rules () - ((assert-raises predicate body body* ...) - (assert - (guard (e ((predicate e) #t)) - body body* ... - #f))))) - - - (define (test-main) - (if *all-tests-succeeded* - (print "PASS\n") - (print "FAIL\n"))))) |
