considering continuations

2 files changed, 30 insertions, 12 deletions

diff --git a/lib/cuprate-impl.scm b/lib/cuprate-impl.scm
index 94f1902..dec3959 100644
--- a/lib/cuprate-impl.scm
+++ b/lib/cuprate-impl.scm
@@ -2,7 +2,14 @@
 ;;; Manipulating the test info
 ;;; ;;;;;;;;;;;;;;;;;;;
 
+;;; TODO: test the fact that tests cannot be exited twice, or that test
+;;; infos cannot be modified once exited.
+
 (define (modify-test-info! proc)
+  (when (test-info-exited? (test-info))
+    (assertion-violation 'modify-test-info!
+                         "returned test info is immutable"
+                         (test-info)))
   (set-test-info! (test-info) (inspect-test-info proc)))
 
 (define (inspect-test-info proc)
@@ -82,8 +89,17 @@
     (parameterize ((test-info (test-info-dict)))
       ((test-ref setup!) name)
       ((body))
+      (when (test-info-exited? (test-info))
+        (assertion-violation name
+                             "exit from the same test-info twice"
+                             (test-info)))
+      (set-test-info-exited! (test-info) #t)
       ((test-ref cleanup!) name)
       (test-info-dict)))
+  (when (test-info-exited? (test-info))
+    (assertion-violation name
+                         "attempting to test in the same test-info"
+                         (test-info)))
   (if ((test-ref skip?) name)
       ((test-ref when-skipped) name)
       ((test-ref after) (exec))))
@@ -278,15 +294,16 @@
      (name-stack . ())
      (never-print-dto . ,default-test-dto)
      (pretty-print . ,pretty-print)
-     (never-print . ,(map (lambda (x) (cons x x))
-                          '(skip-test? when-test-skipped before-test! setup-test!
-                                       cleanup-test! after-test report-test
-                                       on-exception-in-test
-                                       skip-group? when-group-skipped before-group!
-                                       setup-group! cleanup-group! after-group
-                                       report-group on-exception-in-group
-                                       never-print name rewriters
-                                       never-print-dto pretty-print))))))
+     (never-print . ,(alist->default-dictionary
+                      (map (lambda (x) (cons x x))
+                           '(skip-test? when-test-skipped before-test! setup-test!
+                                        cleanup-test! after-test report-test
+                                        on-exception-in-test
+                                        skip-group? when-group-skipped before-group!
+                                        setup-group! cleanup-group! after-group
+                                        report-group on-exception-in-group
+                                        never-print name rewriters
+                                        never-print-dto pretty-print)))))))
 
 (define test-dto (make-parameter default-test-dto
                                  (lambda (x)
@@ -299,7 +316,7 @@
                                   (lambda (x)
                                     (if (test-info? x)
                                         x
-                                        (wrap-test-info x)))))
+                                        (wrap-test-info x #f)))))
 (define (test-info-dict) (unwrap-test-info (test-info)))
 
 ;;; ;;;;;;;;;;;;
diff --git a/lib/cuprate.sld b/lib/cuprate.sld
index 91df5ff..a23f55a 100644
--- a/lib/cuprate.sld
+++ b/lib/cuprate.sld
@@ -32,9 +32,10 @@
    pretty-print)
   (begin
     (define-record-type <test-info>
-      (wrap-test-info dict)
+      (wrap-test-info dict exited?)
       test-info?
-      (dict unwrap-test-info set-test-info!))
+      (dict unwrap-test-info set-test-info!)
+      (exited? test-info-exited? set-test-info-exited!))
     (define assertion-violation error))
   (cond-expand
     ((or foment chicken-5) (include "cuprate.simple-define-test-application.scm"))