Install the check-info stack in continuation marks. This means that if an exception is thrown within a check some useful information about that check (e.g. name, location) can still be extracted.

svn: r15147

original commit: 7b5753163c42dbfbd70721b20f193e20d67c2129

collects/schemeunit/all-schemeunit-tests.ss

@@ -50,5 +50,6 @@
    (test-case "Also intended to fail" (check-eq? 'apples 'orange))
    (test-equal? "Yet again intended to fail" "apples" "oranges")
    (test-case "Intended to throw error" (error 'testing "<<This is an error message>>"))
+   (test-case "Error within a check" (check error 'foo 'bar))
    ))
 

collects/schemeunit/check-info-test.ss

@@ -1,6 +1,6 @@
 ;;;
 ;;; <check-util-test.ss> ---- Tests for check-util
-;;; Time-stamp: <2008-06-19 21:04:14 noel>
+;;; Time-stamp: <2009-06-11 17:03:21 noel>
 ;;;
 ;;; Copyright (C) 2003 by Noel Welsh. 
 ;;;
@@ -40,7 +40,7 @@
                              (('1 1)
                               ('2 2)
                               ('3 3))
-                             (check-info-stack))))
+                             (check-info-stack (current-continuation-marks)))))
                  (for-each (lambda (actual expected)
                              (check-eq? (check-info-name actual)
                                         expected))
@@ -57,7 +57,7 @@
                               (('4 4)
                                ('5 5)
                                ('6 6))
-                              (check-info-stack)))))
+                              (check-info-stack (current-continuation-marks))))))
                  (for-each (lambda (actual expected)
                              (check-eq? (check-info-name actual)
                                         expected))

collects/schemeunit/check-info.ss

@@ -10,29 +10,28 @@
 
 ;; Infrastructure ----------------------------------------------
 
-;; parameter check-info-stack : (listof check-info)
-(define check-info-stack
-  (make-parameter
-   (list)
-   (lambda (v)
-     (if (list? v)
-         v
-         (raise-type-error 'check-info-stack "list" v)))))
+;; The continuation mark under which all check-info is keyed
+(define check-info-mark (gensym 'schemeunit))
+
+;; (continuation-mark-set -> (listof check-info))
+(define (check-info-stack marks)
+  (apply append (continuation-mark-set->list marks check-info-mark)))
 
 ;; with-check-info* : (list-of check-info) thunk -> any
 (define (with-check-info* info thunk)
-  (parameterize
-      ((check-info-stack (append (check-info-stack) info)))
+  (define current-marks
+    (continuation-mark-set-first #f check-info-mark))
+  (with-continuation-mark
+   check-info-mark
+   (append (if current-marks current-marks null) info)
    (thunk)))
 
 (define-syntax with-check-info
   (syntax-rules ()
-    ((_ ((name val) ...) body ...)
+    [(_ ((name val) ...) body ...)
      (with-check-info*
       (list (make-check-info name val) ...)
-      (lambda ()
-        body ...)))))
-
+      (lambda () body ...))]))
 
 (define (make-check-name name)
   (make-check-info 'name name))

collects/schemeunit/check.ss

@@ -75,20 +75,22 @@
 (define-syntax fail-check
   (syntax-rules ()
     ((_)
+     (let ([marks (current-continuation-marks)])
        (raise
         (make-exn:test:check
          "Check failure"
-       (current-continuation-marks)
-       (check-info-stack))))))
+         marks
+         (check-info-stack marks)))))))
 
 (define-syntax fail-internal
   (syntax-rules ()
     ((_)
+     (let ([marks (current-continuation-marks)])
        (raise
         (make-exn:test:check:internal
          "Internal failure"
-       (current-continuation-marks)
-       (check-info-stack))))))
+         marks
+         (check-info-stack marks)))))))
 
 ;; refail-check : exn:test:check -> (exception raised)
 ;;

collects/schemeunit/text-ui.ss

@@ -1,5 +1,5 @@
 ;;;
-;;; Time-stamp: <2008-08-08 21:38:07 noel>
+;;; Time-stamp: <2009-06-11 17:11:22 noel>
 ;;;
 ;;; Copyright (C) 2005 by Noel Welsh.
 ;;;
@@ -39,6 +39,7 @@
          "location.ss"
          "result.ss"
          "test.ss"
+         "check-info.ss"
          "monad.ss"
          "hash-monad.ss"
          "name-collector.ss"
@@ -127,6 +128,14 @@
    [(test-failure? result)
     (let* ([exn (test-failure-result result)]
            [stack (exn:test:check-stack exn)])
+      (textui-display-check-info-stack stack verbose?))]
+   [(test-error? result)
+    (let ([exn (test-error-result result)])
+      (textui-display-check-info-stack (check-info-stack (exn-continuation-marks exn)))
+      (display-exn exn))]
+   [else (void)]))
+
+(define (textui-display-check-info-stack stack [verbose? #f])
   (for-each
    (lambda (info)
      (cond
@@ -161,10 +170,7 @@
        (display-check-info info)]))
    (if verbose?
        stack
-           (strip-redundant-params stack))))]
-   [(test-error? result)
-    (display-exn (test-error-result result))]
-   [else (void)]))
+       (strip-redundant-params stack))))
 
 ;; display-verbose-check-info : test-result -> void
 (define (display-verbose-check-info result)