From: Chris Hanson <org/chris-hanson/cph>
Date: Sat, 13 Jan 2018 21:06:23 +0000 (-0800)
Subject: Add "assertion number" to failure reports.
X-Git-Tag: mit-scheme-pucked-x11-0.3.1~7^2~370
X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=9b1fd2056b4bb2e954d5c1fd0cb7d08efe234b30;p=mit-scheme.git

Add "assertion number" to failure reports.

This is clumsy but better than nothing.
---

diff --git a/tests/unit-testing.scm b/tests/unit-testing.scm
index d1c4dfee6..ff4100420 100644
--- a/tests/unit-testing.scm
+++ b/tests/unit-testing.scm
@@ -241,6 +241,12 @@ USA.
 	      (failure-alist failure))))
 
 (define (report-failure failure port)
+  (let ((p (failure-property 'assertion-index failure)))
+    (if p
+	(begin
+	  (write-string "assertion " port)
+	  (write (cdr p) port)
+	  (write-string ": " port))))
   (cond ((failure-property 'CONDITION failure)
 	 => (lambda (p)
 	      (let ((expr (failure-property 'EXPRESSION failure)))
@@ -314,20 +320,22 @@ USA.
 (define-for-tests (run-sub-test thunk . properties)
   (call-with-current-continuation
    (lambda (k)
-     (bind-condition-handlers
-      (list condition-type:failure
-	    (lambda (condition)
-	      (k (extend-failure (condition-failure condition)
-				 properties)))
-	    condition-type:error
-	    (lambda (condition)
-	      (if (not (throw-test-errors?))
-		  (k (apply make-failure
-			    'CONDITION condition
-			    properties)))))
-      (lambda ()
-	(thunk)
-	#f)))))
+     (parameterize ((assertion-index 1))
+       (bind-condition-handlers
+	(list condition-type:failure
+	      (lambda (condition)
+		(k (extend-failure (condition-failure condition)
+				   properties)))
+	      condition-type:error
+	      (lambda (condition)
+		(if (not (throw-test-errors?))
+		    (k (apply make-failure
+			      'condition condition
+			      'assertion-index (assertion-index)
+			      properties)))))
+	(lambda ()
+	  (thunk)
+	  #f))))))
 
 (define-for-tests (with-test-properties thunk . properties)
   (bind-condition-handlers
@@ -359,7 +367,9 @@ USA.
    (lambda (continuation)
      (error
       (make-failure-condition continuation
-			      (apply make-failure plist))))))
+			      (apply make-failure
+				     'assertion-index (assertion-index)
+				     plist))))))
 
 (define (make-failure-condition continuation failure)
   (make-condition condition-type:failure
@@ -380,12 +390,15 @@ USA.
   (lambda (value . properties)
     (%assert predicate value description properties)))
 
+(define assertion-index (make-settable-parameter #f))
+
 (define (%assert predicate value description properties)
   (if (not (predicate value))
       (apply fail
-	     'RESULT-OBJECT value
-	     'EXPECTATION-DESCRIPTION description
-	     properties)))
+	     'result-object value
+	     'expectation-description description
+	     properties))
+  (assertion-index (+ (assertion-index) 1)))
 
 (define-for-tests assert-true
   (predicate-assertion (lambda (x) x) "true"))