Added test suite tools

d-/test.scm

@@ -0,0 +1,37 @@
+(define-module (d- test)
+  #:use-module (ice-9 format)
+  #:use-module (ice-9 control)
+  #:export (define-test-suite assert))
+
+(define (assert expected actual eq? fail)
+  (when (not (eq? expected actual))
+    (format #t "fail - expected ~a but got ~a" expected actual)
+    (newline)
+    (fail)))
+
+(define-syntax define-test-suite
+  (lambda (stx)
+    (with-syntax ([fail (datum->syntax stx 'fail)])
+      (define (assert-stx expr)
+	(syntax-case expr (assert-equal assert-not-equal)
+	  [(assert-equal e a) #'(assert e a equal? fail)]
+	  [(assert-not-equal e a) #'(assert e a (compose not equal?) fail)]
+	  [(assert-unspecified v) #'(assert (when #f 'a) v eq? fail)]
+	  [else #'else]))
+      (define (define-test-stx test)
+	(syntax-case test (define-test)
+	  [(define-test test-name e ...)
+	   #`(call/ec (lambda (fail)
+			(format #t "~a: " test-name)
+			(begin
+			  #,@(map assert-stx #'(e ...)))
+			(display "ok")
+			(newline)))]))
+      (syntax-case stx ()
+	[(define-test-suite name test ...)
+	 #`(begin
+	     (format #t "Suite ~a:" name)
+	     (newline)
+	     #,@(map define-test-stx
+		     #'(test ...))
+	     (newline))]))))