From: Chris Hanson <org/chris-hanson/cph>
Date: Mon, 28 Oct 2019 01:08:29 +0000 (-0700)
Subject: Integrate inline tests into testing framework.
X-Git-Tag: mit-scheme-pucked-10.1.20~11^2~17
X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=80655960c0ed1d44ddf8561b889f4953dd4bf465;p=mit-scheme.git

Integrate inline tests into testing framework.
---

diff --git a/src/libraries/inline-testing.scm b/src/libraries/inline-testing.scm
index 064342e00..0cd51b53d 100644
--- a/src/libraries/inline-testing.scm
+++ b/src/libraries/inline-testing.scm
@@ -263,22 +263,24 @@ USA.
   (make-bundle-predicate 'expectation-context))
 
 (define (summarize-test-results results)
-  (if (summarize?)
-      (let ((failing-results (filter failing-test-result? results)))
-	(let ((failures (length failing-results))
-	      (all (length results)))
-	  (fresh-line)
-	  (display "Ran ")
-	  (write all)
-	  (display " test")
-	  (if (not (= 1 all))
-	      (display "s"))
-	  (display "; ")
-	  (write failures)
-	  (display " failure")
-	  (if (not (= 1 failures))
-	      (display "s")))
-	(for-each summarize-failing-result failing-results))))
+  (let ((failing-results (filter failing-test-result? results)))
+    (if (summarize?)
+	(begin
+	  (let ((failures (length failing-results))
+		(all (length results)))
+	    (fresh-line)
+	    (display "Ran ")
+	    (write all)
+	    (display " test")
+	    (if (not (= 1 all))
+		(display "s"))
+	    (display "; ")
+	    (write failures)
+	    (display " failure")
+	    (if (not (= 1 failures))
+		(display "s")))
+	  (for-each summarize-failing-result failing-results)))
+    (null? failing-results)))
 
 (define (failing-test-result? result)
   (pair? (cdr result)))
diff --git a/tests/check.scm b/tests/check.scm
index 29d3a23a2..5de62fae5 100644
--- a/tests/check.scm
+++ b/tests/check.scm
@@ -115,6 +115,7 @@ USA.
     ("runtime/test-wttree" (runtime wt-tree))
     "ffi/test-ffi"
     "sos/test-genmult"
+    ("libraries/test-srfi-133" inline)
     ))
 
 (with-working-directory-pathname
@@ -123,38 +124,59 @@ USA.
     (load "load")
     (let ((results
 	   (map (lambda (entry)
-		  (receive (pathname environment)
-		      (if (pair? entry)
-			  (values (car entry) (->environment (cadr entry)))
-			  (values entry #!default))
+
+		  (define (parse-entry)
+		    (cond ((not (pair? entry))
+			   (values entry #!default #f))
+			  ((eq? (cadr entry) 'inline)
+			   (values (car entry) #!default #t))
+			  (else
+			   (values (car entry)
+				   (->environment (cadr entry))
+				   #f))))
+
+		  (define (normal-test pathname environment)
+		    (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))))
+
+		  (define (inline-test pathname)
+		    (cons pathname
+			  (run-inline-tests pathname
+					    'notify? #f
+					    'summarize? #f)))
+
+		  (receive (pathname environment inline?) (parse-entry)
 		    (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)))))))
+			(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 inline?
+			    (inline-test pathname)
+			    (normal-test pathname environment))))))
 		(let ((test-name (get-environment-variable "TEST")))
 		  (if test-name
 		      (let ((e
diff --git a/tests/load.scm b/tests/load.scm
index 5f2044970..8b6d6eeb5 100644
--- a/tests/load.scm
+++ b/tests/load.scm
@@ -27,12 +27,14 @@ USA.
 (let ((environment (make-top-level-environment)))
   (load (merge-pathnames "unit-testing" (current-load-pathname))
 	environment)
+  (import! '(mit inline-testing) environment)
   (for-each (lambda (name)
 	      (if (environment-bound? system-global-environment name)
 		  (unbind-variable system-global-environment name))
 	      (link-variables system-global-environment name
 			      environment name))
-	    '(run-unit-test
+	    '(run-inline-tests
+	      run-unit-test
 	      run-unit-tests
 	      show-passing-results?
 	      throw-test-errors?)))
\ No newline at end of file