1 files changed, 104 insertions, 0 deletions
diff --git a/testing.csc b/testing.csc
new file mode 100644
index 0000000..f221388
--- /dev/null
+++ b/testing.csc
@@ -0,0 +1,104 @@
+(define-library (csc testing)
+  (export
+    define-test
+    errorf
+    fatalf
+    test-main
+    subtest)
+  (import (scheme base)
+          (only (csc format)
+                printf
+                sprintf)
+          (only (csc vec)
+                vec
+                vec-append
+                vec-length
+                vec-ref))
+  (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 subtest-name succeeded subtests-succeeded)
+      test-handle?
+      (test-name base-test-name)
+      (subtest-name subtest-name)
+      (succeeded test-succeeded? set-succeeded!)
+      (subtests-succeeded subtests-succeeded set-subtests-succeeded!))
+
+
+    (define (test-name t)
+      (let ((sn (subtest-name t)))
+        (if (equal? sn "")
+            (base-test-name t)
+          (sprintf "{}/{}" (base-test-name t) sn))))
+
+
+    (define-record-type <test-error>
+      (make-test-error)
+      test-error?)
+
+
+    (define-syntax define-test
+      (syntax-rules ()
+                    ((_ (name t) body ...)
+                     (let ((t (make-test-handle (symbol->string 'name) "" #t (vec))))
+                       (printf "=== RUN   {}\n" 'name)
+                       (guard (e ((test-error? e))
+                                 #;(else
+                                 (errorf t "{}" e)))
+                       body ...)
+                     (if (test-succeeded? t)
+                         (printf "--- PASS: {}\n" 'name)
+                       (begin
+                         (printf "--- FAIL: {}\n" 'name)
+                         (set-all-succeeded! #f)))
+                     (do ((i 0 (+ 1 i)))
+                         ((>= i (vec-length (subtests-succeeded t))))
+                       (printf "    --- {}: {}/{}\n"
+                               (if (cdr (vec-ref (subtests-succeeded t) i)) "PASS" "FAIL")
+                               'name
+                               (car (vec-ref (subtests-succeeded t) i))))))))
+
+
+  (define-syntax subtest
+    (syntax-rules ()
+                  ((_ t name body ...)
+                   (let ((old-t t)
+                         (t (make-test-handle (test-name t) name #t (vec))))
+                     (printf "=== RUN   {}\n" (test-name t))
+                     (guard (e ((test-error? e))
+                               #;(else
+                               (errorf t "{}" e)))
+                     body ...)
+                   (let ((succ (test-succeeded? t)))
+                     (set-subtests-succeeded! old-t (vec-append (subtests-succeeded old-t) (cons name succ)))
+                     (unless succ
+                       (set-succeeded! old-t #f)))))))
+
+
+    (define-syntax errorf
+      (syntax-rules ()
+                    ((_ t format-string format-args ...)
+                     (begin
+                       (set-succeeded! t #f)
+                       (printf "{}: {}\n" (test-name t) (sprintf format-string format-args ...))))))
+
+
+    (define-syntax fatalf
+      (syntax-rules ()
+                    ((_ t format-string format-args ...)
+                     (begin
+                       (errorf t format-string format-args ...)
+                       (raise (make-test-error))))))
+
+
+    (define (test-main)
+      (if *all-tests-succeeded*
+          (printf "PASS\n")
+        (printf "FAIL\n")))))