Integrate inline tests into testing framework.

diff --git a/src/libraries/inline-testing.scm b/src/libraries/inline-testing.scm
index 064342e00639b5b8bea4bb87c122eddcdf07b783..0cd51b53d136d75a716a40b254d746472b29e227 100644 (file)
--- a/src/libraries/inline-testing.scm
+++ b/src/libraries/inline-testing.scm
@@ -263,22 +263,24 @@ USA.
   (make-bundle-predicate 'expectation-context))
 \f
 (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 29d3a23a2ce080becbda8bd8eb01454028d1e553..5de62fae5f88a31e35474990f20b001241375da7 100644 (file)
--- 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 5f204497059c2923738fa93ccc4903622dfd7b5e..8b6d6eeb51537fcd59eb09a6aac1ae36ed67597c 100644 (file)
--- 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