From: Chris Hanson <org/chris-hanson/cph>
Date: Fri, 27 Jan 2017 20:58:56 +0000 (-0800)
Subject: Summarize test results at end of run.
X-Git-Tag: mit-scheme-pucked-9.2.12~227^2~49
X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=48f360674a79b7eca47998675c6de02263329c36;p=mit-scheme.git

Summarize test results at end of run.
---

diff --git a/tests/check.scm b/tests/check.scm
index 2595ff50f..2518aa98e 100644
--- a/tests/check.scm
+++ b/tests/check.scm
@@ -78,36 +78,53 @@ USA.
     (directory-pathname (current-load-pathname))
   (lambda ()
     (load "load")
-    (for-each (lambda (entry)
-                (receive (pathname environment)
-                         (if (pair? entry)
-                             (values (car entry) (->environment (cadr entry)))
-                             (values entry #!default))
-                  (with-notification
-                      (lambda (output-port)
-                        (write-string "Running tests in " output-port)
-                        (write pathname output-port)
-                        (if (not (default-object? environment))
-                            (begin
-                              (write-string " in environment " output-port)
-                              (write (cond ((environment->package environment)
-                                            => package/name)
-                                           (else environment))
-                                     output-port))))
-                    (lambda ()
-                      (if (not (pathname-type pathname))
-                          (with-working-directory-pathname
-                              (directory-pathname pathname)
-                            (lambda ()
-                              ;++ Kludge around a bug in SF...
-                              (compile-file (file-pathname pathname)
-                                            '()
-                                            environment))))
-                      (let* ((t (pathname-type pathname))
-                             (p (if (and t (string=? "com" t)
-                                         (eq? 'C
-                                              microcode-id/compiled-code-type))
-                                    (pathname-new-type pathname "so")
-                                    pathname)))
-                        (run-unit-tests p environment))))))
-              known-tests)))
\ No newline at end of file
+    (let ((results
+	   (map (lambda (entry)
+		  (receive (pathname environment)
+		      (if (pair? entry)
+			  (values (car entry) (->environment (cadr entry)))
+			  (values entry #!default))
+		    (with-notification
+		     (lambda (output-port)
+		       (write-string "Running tests in " output-port)
+		       (write pathname output-port)
+		       (if (not (default-object? environment))
+			   (begin
+			     (write-string " in environment " output-port)
+			     (write (cond ((environment->package environment)
+					   => package/name)
+					  (else environment))
+				    output-port))))
+		     (lambda ()
+		       (if (not (pathname-type pathname))
+			   (with-working-directory-pathname
+			    (directory-pathname pathname)
+			    (lambda ()
+					       ;++ Kludge around a bug in SF...
+			      (compile-file (file-pathname pathname)
+					    '()
+					    environment))))
+		       (let* ((t (pathname-type pathname))
+			      (p (if (and t (string=? "com" t)
+					  (eq? 'C
+					       microcode-id/compiled-code-type))
+				     (pathname-new-type pathname "so")
+				     pathname)))
+			 (cons pathname
+			       (run-unit-tests p environment)))))))
+		known-tests)))
+
+      (define (show-results results)
+	(for-each (lambda (p)
+		    (write-string (if (cdr p) "PASSED" "FAILED"))
+		    (write-string ": ")
+		    (write (car p))
+		    (newline))
+		  results))
+
+      (fresh-line)
+      (newline)
+      (write-string "Test results:")
+      (newline)
+      (show-results (filter cdr results))
+      (show-results (remove cdr results)))))
\ No newline at end of file