.gitignore

@@ -15,4 +15,3 @@ srfi.*.scm
 srfi.*.sld
 reports
 snow.*
-r7rs-tests.scm

Jenkinsfile

@@ -67,8 +67,8 @@ pipeline {
                     sh 'find . -name "*.o" -delete'
                     sh 'find . -name "*.o" -delete'
                     
-                    sh 'chibi-scheme -I ./snow/chibi r7rs-tests-1.scm> r7rs-tests-1.log'
+                    sh 'chibi-scheme -I ./snow/chibi r7rs-tests.scm> r7rs-test.log'
-                    sh 'cat r7rs-tests-1.log'
+                    sh 'cat r7rs-test.log'
                     sh 'for f in *.log; do cp -- "$f" "reports/chibi-$f"; done'
                     sh 'ls reports'
                     stash name: 'reports', includes: 'reports/*'
@@ -100,8 +100,8 @@ pipeline {
                     sh 'find . -name "*.o" -delete'
                     sh 'find . -name "*.o" -delete'
                     sh ' ls  && cp snow/chibi/term/ansi.sld snow.chibi.term.ansi.sld && csc -include-path ./snow/chibi -include-path ./snow/chibi/term -X r7rs -R r7rs -s -J snow.chibi.term.ansi.sld && cp snow/chibi/optional.sld snow.chibi.optional.sld && csc -include-path ./snow/chibi -include-path ./snow/chibi/term -X r7rs -R r7rs -s -J snow.chibi.optional.sld && cp snow/chibi/diff.sld snow.chibi.diff.sld && csc -include-path ./snow/chibi -include-path ./snow/chibi/term -X r7rs -R r7rs -s -J snow.chibi.diff.sld && cp snow/chibi/test.sld snow.chibi.test.sld && csc -include-path ./snow/chibi -include-path ./snow/chibi/term -X r7rs -R r7rs -s -J snow.chibi.test.sld'
-                    sh 'csc -include-path ./snow/chibi -X r7rs -R r7rs r7rs-tests-1.scm && ./r7rs-tests-1 && rm r7rs-tests-1> r7rs-tests-1.log'
+                    sh 'csc -include-path ./snow/chibi -X r7rs -R r7rs r7rs-tests.scm && ./r7rs-test && rm r7rs-test> r7rs-test.log'
-                    sh 'cat r7rs-tests-1.log'
+                    sh 'cat r7rs-test.log'
                     sh 'for f in *.log; do cp -- "$f" "reports/chicken-$f"; done'
                     sh 'ls reports'
                     stash name: 'reports', includes: 'reports/*'
@@ -133,8 +133,8 @@ pipeline {
                     sh 'find . -name "*.o" -delete'
                     sh 'find . -name "*.o" -delete'
                     sh ' ls  && cyclone -A . snow/chibi/term/ansi.sld && cyclone -A . snow/chibi/optional.sld && cyclone -A . snow/chibi/diff.sld && cyclone -A . snow/chibi/test.sld'
-                    sh 'cyclone -A . r7rs-tests-1.scm && ./r7rs-tests-1 && rm r7rs-tests-1> r7rs-tests-1.log'
+                    sh 'cyclone -A . r7rs-tests.scm && ./r7rs-test && rm r7rs-test> r7rs-test.log'
-                    sh 'cat r7rs-tests-1.log'
+                    sh 'cat r7rs-test.log'
                     sh 'for f in *.log; do cp -- "$f" "reports/cyclone-$f"; done'
                     sh 'ls reports'
                     stash name: 'reports', includes: 'reports/*'
@@ -166,8 +166,8 @@ pipeline {
                     sh 'find . -name "*.o" -delete'
                     sh 'find . -name "*.o" -delete'
                     sh ' ls  && gsc . snow/chibi/term/ansi && gsc . snow/chibi/optional && gsc . snow/chibi/diff && gsc . snow/chibi/test'
-                    sh 'gsc -exe . -nopreload r7rs-tests-1.scm && ./r7rs-tests-1 && rm r7rs-tests-1> r7rs-tests-1.log'
+                    sh 'gsc -exe . -nopreload r7rs-tests.scm && ./r7rs-test && rm r7rs-test> r7rs-test.log'
-                    sh 'cat r7rs-tests-1.log'
+                    sh 'cat r7rs-test.log'
                     sh 'for f in *.log; do cp -- "$f" "reports/gambit-$f"; done'
                     sh 'ls reports'
                     stash name: 'reports', includes: 'reports/*'
@@ -199,8 +199,8 @@ pipeline {
                     sh 'find . -name "*.o" -delete'
                     sh 'find . -name "*.o" -delete'
                     
-                    sh 'gosh -r7 -A ./snow r7rs-tests-1.scm> r7rs-tests-1.log'
+                    sh 'gosh -r7 -A ./snow r7rs-tests.scm> r7rs-test.log'
-                    sh 'cat r7rs-tests-1.log'
+                    sh 'cat r7rs-test.log'
                     sh 'for f in *.log; do cp -- "$f" "reports/gauche-$f"; done'
                     sh 'ls reports'
                     stash name: 'reports', includes: 'reports/*'
@@ -232,8 +232,8 @@ pipeline {
                     sh 'find . -name "*.o" -delete'
                     sh 'find . -name "*.o" -delete'
                     
-                    sh 'guile --fresh-auto-compile --r7rs -L . -L ./snow r7rs-tests-1.scm> r7rs-tests-1.log'
+                    sh 'guile --fresh-auto-compile --r7rs -L . -L ./snow r7rs-tests.scm> r7rs-test.log'
-                    sh 'cat r7rs-tests-1.log'
+                    sh 'cat r7rs-test.log'
                     sh 'for f in *.log; do cp -- "$f" "reports/guile-$f"; done'
                     sh 'ls reports'
                     stash name: 'reports', includes: 'reports/*'
@@ -265,8 +265,8 @@ pipeline {
                     sh 'find . -name "*.o" -delete'
                     sh 'find . -name "*.o" -delete'
                     
-                    sh 'kawa --r7rs -Dkawa.import.path=./snow/chibi/*.sld:./snow/srfi/*.sld r7rs-tests-1.scm> r7rs-tests-1.log'
+                    sh 'kawa --r7rs -Dkawa.import.path=./snow/chibi/*.sld:./snow/srfi/*.sld r7rs-tests.scm> r7rs-test.log'
-                    sh 'cat r7rs-tests-1.log'
+                    sh 'cat r7rs-test.log'
                     sh 'for f in *.log; do cp -- "$f" "reports/kawa-$f"; done'
                     sh 'ls reports'
                     stash name: 'reports', includes: 'reports/*'
@@ -298,8 +298,8 @@ pipeline {
                     sh 'find . -name "*.o" -delete'
                     sh 'find . -name "*.o" -delete'
                     sh ' ls  && ls snow/chibi/term/ansi.sld && ls snow/chibi/optional.sld && ls snow/chibi/diff.sld && ls snow/chibi/test.sld'
-                    sh 'LOKO_LIBRARY_PATH=./snow loko -std=r7rs --compile r7rs-tests-1.scm && ./r7rs-tests-1 && rm r7rs-tests-1> r7rs-tests-1.log'
+                    sh 'LOKO_LIBRARY_PATH=./snow loko -std=r7rs --compile r7rs-tests.scm && ./r7rs-test && rm r7rs-test> r7rs-test.log'
-                    sh 'cat r7rs-tests-1.log'
+                    sh 'cat r7rs-test.log'
                     sh 'for f in *.log; do cp -- "$f" "reports/loko-$f"; done'
                     sh 'ls reports'
                     stash name: 'reports', includes: 'reports/*'
@@ -331,8 +331,8 @@ pipeline {
                     sh 'find . -name "*.o" -delete'
                     sh 'find . -name "*.o" -delete'
                     
-                    sh 'mit-scheme --load r7rs-tests-1.scm> r7rs-tests-1.log'
+                    sh 'mit-scheme --load r7rs-tests.scm> r7rs-test.log'
-                    sh 'cat r7rs-tests-1.log'
+                    sh 'cat r7rs-test.log'
                     sh 'for f in *.log; do cp -- "$f" "reports/mit-scheme-$f"; done'
                     sh 'ls reports'
                     stash name: 'reports', includes: 'reports/*'
@@ -364,8 +364,8 @@ pipeline {
                     sh 'find . -name "*.o" -delete'
                     sh 'find . -name "*.o" -delete'
                     
-                    sh 'sash -r7 -L ./snow r7rs-tests-1.scm > r7rs-tests-1.log && cat r7rs-tests-1.log> r7rs-tests-1.log'
+                    sh 'sash -r7 -L ./snow r7rs-tests.scm > r7rs-test.log && cat r7rs-test.log> r7rs-test.log'
-                    sh 'cat r7rs-tests-1.log'
+                    sh 'cat r7rs-test.log'
                     sh 'for f in *.log; do cp -- "$f" "reports/sagittarius-$f"; done'
                     sh 'ls reports'
                     stash name: 'reports', includes: 'reports/*'
@@ -397,8 +397,8 @@ pipeline {
                     sh 'find . -name "*.o" -delete'
                     sh 'find . -name "*.o" -delete'
                     
-                    sh 'stklos -I ./snow r7rs-tests-1.scm> r7rs-tests-1.log'
+                    sh 'stklos -I ./snow r7rs-tests.scm> r7rs-test.log'
-                    sh 'cat r7rs-tests-1.log'
+                    sh 'cat r7rs-test.log'
                     sh 'for f in *.log; do cp -- "$f" "reports/stklos-$f"; done'
                     sh 'ls reports'
                     stash name: 'reports', includes: 'reports/*'
@@ -430,8 +430,8 @@ pipeline {
                     sh 'find . -name "*.o" -delete'
                     sh 'find . -name "*.o" -delete'
                     
-                    sh 'skint --program r7rs-tests-1.scm> r7rs-tests-1.log'
+                    sh 'skint --program r7rs-tests.scm> r7rs-test.log'
-                    sh 'cat r7rs-tests-1.log'
+                    sh 'cat r7rs-test.log'
                     sh 'for f in *.log; do cp -- "$f" "reports/skint-$f"; done'
                     sh 'ls reports'
                     stash name: 'reports', includes: 'reports/*'
@@ -463,8 +463,8 @@ pipeline {
                     sh 'find . -name "*.o" -delete'
                     sh 'find . -name "*.o" -delete'
                     
-                    sh 'tr7i r7rs-tests-1.scm> r7rs-tests-1.log'
+                    sh 'tr7i r7rs-tests.scm> r7rs-test.log'
-                    sh 'cat r7rs-tests-1.log'
+                    sh 'cat r7rs-test.log'
                     sh 'for f in *.log; do cp -- "$f" "reports/tr7-$f"; done'
                     sh 'ls reports'
                     stash name: 'reports', includes: 'reports/*'
@@ -485,8 +485,8 @@ pipeline {
                         keepAll: true,
                         reportDir: 'reports',
                         reportFiles: '*.html,*.css',
-                        reportName: 'R7RS Conformance Test Report',
+                        reportName: 'R7RS-SRFI Test Report',
-                        reportTitles: 'R7RS Conformance Test Report'])
+                        reportTitles: 'R7RS-SRFI Test Report'])
                 }
             }
         }

Makefile

@@ -1,66 +1,66 @@
-test-chibi-r7rs-tests-1:
+test-chibi-r7rs-test:
 	
-	docker run -it -v ${PWD}:/workdir:z schemers/chibi bash -c "cd workdir && chibi-scheme -I ./snow/chibi r7rs-tests-1.scm"
+	docker run -it -v ${PWD}:/workdir:z schemers/chibi bash -c "cd workdir && chibi-scheme -I ./snow/chibi r7rs-tests.scm"
 
 
-test-chicken-r7rs-tests-1:
+test-chicken-r7rs-test:
 	docker run -it -v ${PWD}:/workdir:z schemers/chicken bash -c "cd workdir &&  ls  && cp snow/chibi/term/ansi.sld snow.chibi.term.ansi.sld && csc -include-path ./snow/chibi -include-path ./snow/chibi/term -X r7rs -R r7rs -s -J snow.chibi.term.ansi.sld && cp snow/chibi/optional.sld snow.chibi.optional.sld && csc -include-path ./snow/chibi -include-path ./snow/chibi/term -X r7rs -R r7rs -s -J snow.chibi.optional.sld && cp snow/chibi/diff.sld snow.chibi.diff.sld && csc -include-path ./snow/chibi -include-path ./snow/chibi/term -X r7rs -R r7rs -s -J snow.chibi.diff.sld && cp snow/chibi/test.sld snow.chibi.test.sld && csc -include-path ./snow/chibi -include-path ./snow/chibi/term -X r7rs -R r7rs -s -J snow.chibi.test.sld"
-	docker run -it -v ${PWD}:/workdir:z schemers/chicken bash -c "cd workdir && csc -include-path ./snow/chibi -X r7rs -R r7rs r7rs-tests-1.scm && ./r7rs-tests-1 && rm r7rs-tests-1"
+	docker run -it -v ${PWD}:/workdir:z schemers/chicken bash -c "cd workdir && csc -include-path ./snow/chibi -X r7rs -R r7rs r7rs-tests.scm && ./r7rs-test && rm r7rs-test"
 
 
-test-cyclone-r7rs-tests-1:
+test-cyclone-r7rs-test:
 	docker run -it -v ${PWD}:/workdir:z schemers/cyclone bash -c "cd workdir &&  ls  && cyclone -A . snow/chibi/term/ansi.sld && cyclone -A . snow/chibi/optional.sld && cyclone -A . snow/chibi/diff.sld && cyclone -A . snow/chibi/test.sld"
-	docker run -it -v ${PWD}:/workdir:z schemers/cyclone bash -c "cd workdir && cyclone -A . r7rs-tests-1.scm && ./r7rs-tests-1 && rm r7rs-tests-1"
+	docker run -it -v ${PWD}:/workdir:z schemers/cyclone bash -c "cd workdir && cyclone -A . r7rs-tests.scm && ./r7rs-test && rm r7rs-test"
 
 
-test-gambit-r7rs-tests-1:
+test-gambit-r7rs-test:
 	docker run -it -v ${PWD}:/workdir:z schemers/gambit bash -c "cd workdir &&  ls  && gsc . snow/chibi/term/ansi && gsc . snow/chibi/optional && gsc . snow/chibi/diff && gsc . snow/chibi/test"
-	docker run -it -v ${PWD}:/workdir:z schemers/gambit bash -c "cd workdir && gsc -exe . -nopreload r7rs-tests-1.scm && ./r7rs-tests-1 && rm r7rs-tests-1"
+	docker run -it -v ${PWD}:/workdir:z schemers/gambit bash -c "cd workdir && gsc -exe . -nopreload r7rs-tests.scm && ./r7rs-test && rm r7rs-test"
 
 
-test-gauche-r7rs-tests-1:
+test-gauche-r7rs-test:
 	
-	docker run -it -v ${PWD}:/workdir:z schemers/gauche bash -c "cd workdir && gosh -r7 -A ./snow r7rs-tests-1.scm"
+	docker run -it -v ${PWD}:/workdir:z schemers/gauche bash -c "cd workdir && gosh -r7 -A ./snow r7rs-tests.scm"
 
 
-test-guile-r7rs-tests-1:
+test-guile-r7rs-test:
 	
-	docker run -it -v ${PWD}:/workdir:z schemers/guile bash -c "cd workdir && guile --fresh-auto-compile --r7rs -L . -L ./snow r7rs-tests-1.scm"
+	docker run -it -v ${PWD}:/workdir:z schemers/guile bash -c "cd workdir && guile --fresh-auto-compile --r7rs -L . -L ./snow r7rs-tests.scm"
 
 
-test-kawa-r7rs-tests-1:
+test-kawa-r7rs-test:
 	
-	docker run -it -v ${PWD}:/workdir:z schemers/kawa bash -c "cd workdir && kawa --r7rs -Dkawa.import.path=./snow/chibi/*.sld:./snow/srfi/*.sld r7rs-tests-1.scm"
+	docker run -it -v ${PWD}:/workdir:z schemers/kawa bash -c "cd workdir && kawa --r7rs -Dkawa.import.path=./snow/chibi/*.sld:./snow/srfi/*.sld r7rs-tests.scm"
 
 
-test-loko-r7rs-tests-1:
+test-loko-r7rs-test:
 	docker run -it -v ${PWD}:/workdir:z schemers/loko bash -c "cd workdir &&  ls  && ls snow/chibi/term/ansi.sld && ls snow/chibi/optional.sld && ls snow/chibi/diff.sld && ls snow/chibi/test.sld"
-	docker run -it -v ${PWD}:/workdir:z schemers/loko bash -c "cd workdir && LOKO_LIBRARY_PATH=./snow loko -std=r7rs --compile r7rs-tests-1.scm && ./r7rs-tests-1 && rm r7rs-tests-1"
+	docker run -it -v ${PWD}:/workdir:z schemers/loko bash -c "cd workdir && LOKO_LIBRARY_PATH=./snow loko -std=r7rs --compile r7rs-tests.scm && ./r7rs-test && rm r7rs-test"
 
 
-test-mit-scheme-r7rs-tests-1:
+test-mit-scheme-r7rs-test:
 	
-	docker run -it -v ${PWD}:/workdir:z schemers/mit-scheme bash -c "cd workdir && mit-scheme --load r7rs-tests-1.scm"
+	docker run -it -v ${PWD}:/workdir:z schemers/mit-scheme bash -c "cd workdir && mit-scheme --load r7rs-tests.scm"
 
 
-test-sagittarius-r7rs-tests-1:
+test-sagittarius-r7rs-test:
 	
-	docker run -it -v ${PWD}:/workdir:z schemers/sagittarius bash -c "cd workdir && sash -r7 -L ./snow r7rs-tests-1.scm > r7rs-tests-1.log && cat r7rs-tests-1.log"
+	docker run -it -v ${PWD}:/workdir:z schemers/sagittarius bash -c "cd workdir && sash -r7 -L ./snow r7rs-tests.scm > r7rs-test.log && cat r7rs-test.log"
 
 
-test-stklos-r7rs-tests-1:
+test-stklos-r7rs-test:
 	
-	docker run -it -v ${PWD}:/workdir:z schemers/stklos bash -c "cd workdir && stklos -I ./snow r7rs-tests-1.scm"
+	docker run -it -v ${PWD}:/workdir:z schemers/stklos bash -c "cd workdir && stklos -I ./snow r7rs-tests.scm"
 
 
-test-skint-r7rs-tests-1:
+test-skint-r7rs-test:
 	
-	docker run -it -v ${PWD}:/workdir:z schemers/skint bash -c "cd workdir && skint --program r7rs-tests-1.scm"
+	docker run -it -v ${PWD}:/workdir:z schemers/skint bash -c "cd workdir && skint --program r7rs-tests.scm"
 
 
-test-tr7-r7rs-tests-1:
+test-tr7-r7rs-test:
 	
-	docker run -it -v ${PWD}:/workdir:z schemers/tr7 bash -c "cd workdir && tr7i r7rs-tests-1.scm"
+	docker run -it -v ${PWD}:/workdir:z schemers/tr7 bash -c "cd workdir && tr7i r7rs-tests.scm"
 
 
 clean:

README.md

@@ -1,8 +0,0 @@
-Running different R7RS conformance tests on different implementations
-
-- [r7rs-tests-1](https://github.com/ashinn/chibi-scheme/blob/master/tests/r7rs-tests.scm)
-    - Chibi Schemes r7rs tests
-- [r7rs-tests-2](https://github.com/larcenists/larceny/tree/master/test/R7RS)
-    - Larcenys r7rs tests
-    - Not yet added
-

build.scm

@@ -11,7 +11,7 @@
 
 (define full-library-command
   (lambda (implementation test)
-    (let* ((name (cdr (assoc 'name implementation)))
+    (let* ((name (symbol->string (cdr (assoc 'name implementation))))
            (library-command (assoc 'library-command implementation)))
       (cond ((not library-command) #f)
             ; Note that Chicken needs to have the SRFI library as srfi-N.scm in same folder
@@ -37,7 +37,7 @@
 
 (define full-command
   (lambda (implementation test)
-    (let* ((name (cdr (assoc 'name implementation)))
+    (let* ((name (symbol->string (cdr (assoc 'name implementation))))
            (test-name (cdr (assoc 'name test)))
            (test-file (cdr (assoc 'file test)))
            (command
@@ -69,7 +69,7 @@
     (newline out)
     (for-each
       (lambda (implementation)
-        (let ((name (cdr (assoc 'name implementation))))
+        (let ((name (symbol->string (cdr (assoc 'name implementation)))))
           (execute jenkinsfile-job-top
                    `((name . ,name)
                      (dockerimage . ,(if (assoc 'docker-image implementation)
@@ -103,7 +103,7 @@
       (lambda (test)
           (for-each
             (lambda (implementation)
-              (let* ((name (cdr (assoc 'name implementation))))
+              (let* ((name (symbol->string (cdr (assoc 'name implementation)))))
                 (execute makefile-job
                          `((name . ,name)
                            (test-name . ,(cdr (assoc 'name test)))

implementations.scm

@@ -1,25 +1,25 @@
 
 (define implementations
-  '(((name . "chibi") (command . "chibi-scheme -I ./snow/chibi"))
+  '(((name . chibi) (command . "chibi-scheme -I ./snow/chibi"))
-    ((name . "chicken")
+    ((name . chicken)
      (command . "csc -include-path ./snow/chibi -X r7rs -R r7rs")
      (library-command . "csc -include-path ./snow/chibi -include-path ./snow/chibi/term -X r7rs -R r7rs -s -J"))
-    ((name . "cyclone")
+    ((name . cyclone)
      (command . "cyclone -A .")
      (library-command . "cyclone -A ."))
-    ((name . "gambit")
+    ((name . gambit)
      (command . "gsc -exe . -nopreload")
      (library-command . "gsc ."))
-    ((name . "gauche") (command . "gosh -r7 -A ./snow"))
+    ((name . gauche) (command . "gosh -r7 -A ./snow"))
-    ((name . "guile") (command . "guile --fresh-auto-compile --r7rs -L . -L ./snow"))
+    ((name . guile) (command . "guile --fresh-auto-compile --r7rs -L . -L ./snow"))
-    ((name . "kawa") (command . "kawa --r7rs -Dkawa.import.path=./snow/chibi/*.sld:./snow/srfi/*.sld"))
+    ((name . kawa) (command . "kawa --r7rs -Dkawa.import.path=./snow/chibi/*.sld:./snow/srfi/*.sld"))
-    ((name . "loko")
+    ((name . loko)
      (docker-image . "schemers/loko:head")
      (command . "LOKO_LIBRARY_PATH=./snow loko -std=r7rs --compile")
      ; Library command so the executable gets run
      (library-command . "ls"))
-    ((name . "mit-scheme") (command . "mit-scheme --load"))
+    ((name . mit-scheme) (command . "mit-scheme --load"))
-    ((name . "sagittarius") (command . "sash -r7 -L ./snow"))
+    ((name . sagittarius) (command . "sash -r7 -L ./snow"))
-    ((name . "stklos") (command . "stklos -I ./snow"))
+    ((name . stklos) (command . "stklos -I ./snow"))
-    ((name . "skint") (command . "skint --program"))
+    ((name . skint) (command . "skint --program"))
-    ((name . "tr7") (command . "tr7i"))))
+    ((name . tr7) (command . "tr7i"))))

report.scm

@@ -4,7 +4,6 @@
         (scheme char)
         (scheme process-context)
         (scheme file)
-        (srfi 13)
         (arvyy mustache))
 
 (include "util.scm")
@@ -27,23 +26,24 @@
     (newline out)
     (display "<th>Test</th>" out)
     (for-each
-      (lambda (test)
+      (lambda (implementation)
-        (display (string-append "<th>" (cdr (assoc 'name test)) "</th>") out)
+        (display (string-append "<th>" (symbol->string (cdr (assoc 'name implementation))) "</th>") out)
         (newline out))
-      tests)
+      implementations)
     (display "</tr>" out)
     (newline out)
     (newline out)
     (for-each
-      (lambda (implementation)
+      (lambda (test)
-        (let ((name (cdr (assoc 'name implementation))))
+        (let ((test-name (symbol->string (cdr (assoc 'name test))))
+              (name (symbol->string (cdr (assoc 'name implementation)))))
           (display (string-append "<tr>") out)
           (newline out)
-          (display (string-append "<td>" name "</td>") out)
+          (display (string-append "<td>" test-name "</td>") out)
           (newline out)
           (for-each
-            (lambda (test)
+            (lambda (implementation)
-              (letrec* ((test-name (cdr (assoc 'name test)))
+              (letrec* ((name (cdr (assoc 'name implementation)))
                         (command (cdr (assoc 'command implementation)))
                         (logfile (string-append "reports/"
                                                 name
@@ -54,32 +54,41 @@
                                         (if (eof-object? line)
                                           results
                                           (read-results (read-line)
-                                                        (if (string-contains line " out of ")
+                                                        (if (string-starts-with? line "# of")
                                                           (begin
                                                             (append results
-                                                                    (list line)))
+                                                                    (list (number-of-line->number line))))
                                                           results)))))
-                        (results
+                        (results (if (not (file-exists? logfile))
-                          (if (file-exists? logfile)
+                                   (list "" "" "" "")
-                            (file-tail logfile 3)
+                                   (with-input-from-file
-                            (list "Could not run tests")))
+                                     logfile
-                        (result (apply string-append
+                                     (lambda ()
-                                       (map
+                                       (read-results (read-line) (list))))))
-                                         (lambda (line)
+                        (expected-passes (if (> (length results) 0) (list-ref results 0) 0))
-                                           (string-append line "</br>"))
+                        (expected-failures (if (> (length results) 1) (list-ref results 1) 0))
-                                         results))))
+                        (unexpected-failures (if (> (length results) 2) (list-ref results 2) 0))
+                        (skipped-tests (if (> (length results) 3) (list-ref results 3) 0))
+                        (color (cond ((string? expected-passes) "white") ; No logfile
+                                     ((> unexpected-failures 0) "red")
+                                     ((> skipped-tests 0) "yellow")
+                                     (else "green"))))
                 (execute report-row
                          `((name . ,name)
                            (command . ,command)
+                           (color . ,color)
                            (library-command . ,(if (assoc 'library-command implementation)
                                                  (cdr (assoc 'library-command implementation))
                                                  #f))
                            (name . ,name)
-                           (result . ,result))
+                           (expected-passes . ,expected-passes)
+                           (expected-failures . ,expected-failures)
+                           (unexpected-failures . ,unexpected-failures)
+                           (skipped-tests . ,skipped-tests))
                          out)
                 (newline out)))
-            tests)
-          (display (string-append "</tr>") out)))
             implementations)
+          (display (string-append "</tr>") out)))
+      tests)
     (execute report-bottom '() out)
     (newline out)))

templates/Jenkinsfile-bottom

@@ -10,8 +10,8 @@
                         keepAll: true,
                         reportDir: 'reports',
                         reportFiles: '*.html,*.css',
-                        reportName: 'R7RS Conformance Test Report',
+                        reportName: 'R7RS-SRFI Test Report',
-                        reportTitles: 'R7RS Conformance Test Report'])
+                        reportTitles: 'R7RS-SRFI Test Report'])
                 }
             }
         }

templates/Report-bottom

@@ -1,3 +1,17 @@
+
         </table>
+        <ul>
+            Numbers
+            <li># of expected passes</li>
+            <li># of expected failures</li>
+            <li># of unexpected failures</li>
+            <li># of skipped tests</li>
+        </ul>
+        <ul>
+            Colors
+            <li>Red: # of unexpected failures > 0</li>
+            <li>Yellow: # of skipped tests > 0</li>
+            <li>Green: none of the above</li>
+        </ul>
     </body>
 </html>

templates/Report-row

@@ -1,3 +1,6 @@
-<td>
+<td style="background-color:{{color}}">
-    {{{result}}}
+    {{expected-passes}}
+    {{expected-failures}}
+    {{unexpected-failures}}
+    {{skipped-tests}}
 </td>

test.scm

@@ -0,0 +1,985 @@
+;; Copyright (c) 2010-2020 Alex Shinn. All rights reserved.
+;; BSD-style license: http://synthcode.com/license.txt
+
+;;> Simple but extensible testing framework with advanced reporting.
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; list utilities
+
+;; Simplified version of SRFI-1 any.
+(define (any pred ls)
+  (and (pair? ls)
+       (or (pred (car ls))
+           (any pred (cdr ls)))))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; exception utilities
+
+(define (warning msg . args)
+  (display msg (current-error-port))
+  (for-each (lambda (x)
+              (write-char #\space (current-error-port))
+              (write x (current-error-port)))
+            args)
+  (newline (current-error-port)))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; string utilities
+
+(define (string-search pat str)
+  (let* ((pat-len (string-length pat))
+         (limit (- (string-length str) pat-len)))
+    (let lp1 ((i 0))
+      (cond
+       ((>= i limit) #f)
+       (else
+        (let lp2 ((j i) (k 0))
+          (cond ((>= k pat-len) #t)
+                ((not (eqv? (string-ref str j) (string-ref pat k)))
+                 (lp1 (+ i 1)))
+                (else (lp2 (+ j 1) (+ k 1))))))))))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; test interface
+
+;;> \section{Testing}
+
+;;> \macro{(test [name] expect expr)}
+
+;;> The primary interface to testing.  Evaluate \var{expr} and check
+;;> that it is equal to \var{expect}, and report the result, using
+;;> \var{name} or a printed summary of \var{expr}.
+;;>
+;;> If used inside a group this will contribute to the overall group
+;;> reporting, but can be used standalone:
+;;>
+;;> \example{(test 4 (+ 2 2))}
+;;> \example{(test "add two and two" 4 (+ 2 2))}
+;;> \example{(test 3 (+ 2 2))}
+;;> \example{(test 4 (+ 2 "2"))}
+;;>
+;;> The equality comparison is made with
+;;> \scheme{current-test-comparator}, defaulting to
+;;> \scheme{test-equal?}, which is the same as \scheme{equal?} but
+;;> more permissive on floating point comparisons).  Returns the
+;;> status of the test (one of the symbols \scheme{'PASS},
+;;> \scheme{'FAIL}, \scheme{'SKIP}, \scheme{'ERROR}).
+
+(define-syntax test
+  (syntax-rules (quote)
+    ((test expect expr)
+     (test #f expect expr))
+    ((test name expect (expr ...))
+     (test-propagate-info name expect (expr ...) ()))
+    ((test name 'expect expr)
+     (test-propagate-info name 'expect expr ()))
+    ((test name (expect ...) expr)
+     (test-syntax-error
+      'test
+      "the test expression should come last: (test <expected> (<expr> ...)) "
+      (test name (expect ...) expr)))
+    ((test name expect expr)
+     (test-propagate-info name expect expr ()))
+    ((test a ...)
+     (test-syntax-error 'test "test requires 2 or 3 arguments" (test a ...)))))
+
+;;> \macro{(test-equal equal [name] expect expr)}
+
+;;> Equivalent to test, using \var{equal} for comparison instead of
+;;> \scheme{equal?}.
+
+(define-syntax test-equal
+  (syntax-rules ()
+    ((test-equal equal . args)
+     (parameterize ((current-test-comparator equal))
+       (test . args)))))
+
+;;> \macro{(test-assert [name] expr)}
+
+;;> Like \scheme{test} but evaluates \var{expr} and checks that it's true.
+
+(define-syntax test-assert
+  (syntax-rules ()
+    ((_ expr)
+     (test-assert #f expr))
+    ((_ name expr)
+     (test-propagate-info name #f expr ((assertion . #t))))
+    ((test a ...)
+     (test-syntax-error 'test-assert "1 or 2 arguments required"
+                        (test a ...)))))
+
+;;> \macro{(test-not [name] expr)}
+
+;;> Like \scheme{test} but evaluates \var{expr} and checks that it's false.
+
+(define-syntax test-not
+  (syntax-rules ()
+    ((_ expr) (test-assert (not expr)))
+    ((_ name expr) (test-assert name (not expr)))))
+
+;;> \macro{(test-values [name] expect expr)}
+
+;;> Like \scheme{test} but \var{expect} and \var{expr} can both
+;;> return multiple values.
+
+(define-syntax test-values
+  (syntax-rules ()
+    ((_ expect expr)
+     (test-values #f expect expr))
+    ((_ name expect expr)
+     (test name (call-with-values (lambda () expect) (lambda results results))
+       (call-with-values (lambda () expr) (lambda results results))))))
+
+;;> \macro{(test-error [name] expr)}
+
+;;> Like \scheme{test} but evaluates \var{expr} and checks that it
+;;> raises an error.
+
+(define-syntax test-error
+  (syntax-rules ()
+    ((_ expr)
+     (test-error #f expr))
+    ((_ name expr)
+     (test-propagate-info name #f expr ((expect-error . #t))))
+    ((test a ...)
+     (test-syntax-error 'test-error "1 or 2 arguments required"
+                        (test a ...)))))
+
+;;> Low-level macro to pass alist info to the underlying \var{test-run}.
+
+(define-syntax test-propagate-info
+  (syntax-rules ()
+    ;; TODO: Extract interesting variables so we can show their values
+    ;; on failure.  Vars are empty for now.
+    ((test-propagate-info name expect expr info)
+     (test-vars () name expect expr info))))
+
+(define-syntax test-vars
+  (syntax-rules ()
+    ((_ (vars ...) n expect expr ((key . val) ...))
+     (test-run (lambda () expect)
+               (lambda () expr)
+               `((name . ,n)
+                 (source . expr)
+                 (var-names . (vars ...))
+                 (var-values . ,(list vars ...))
+                 (key . val) ...)))))
+
+;;> The procedural interface to testing.  \var{expect} and \var{expr}
+;;> should be thunks, and \var{info} is an alist of properties used in
+;;> test reporting.
+
+(define (test-run expect expr info)
+  (let ((info (test-expand-info info)))
+    (if (and (cond ((current-test-group)
+                    => (lambda (g) (not (test-group-ref g 'skip-group?))))
+                   (else #t))
+             (or (and (not (any (lambda (f) (f info)) (current-test-removers)))
+                      (or (pair? (current-test-removers))
+                          (null? (current-test-filters))))
+                 (any (lambda (f) (f info)) (current-test-filters))))
+        ((current-test-applier) expect expr info)
+        ((current-test-skipper) info))))
+
+;;> Returns true if either \scheme{(equal? expect res)}, or
+;;> \var{expect} is inexact and \var{res} is within
+;;> \scheme{current-test-epsilon} of \var{expect}.
+
+(define (test-equal? expect res)
+  (or (equal? expect res)
+      (if (real? expect)
+          (and (inexact? expect)
+               (real? res)
+               ;; tests which expect an inexact value can
+               ;; accept an equivalent exact value
+               ;; (inexact? res)
+               (approx-equal? expect res (current-test-epsilon)))
+          (and (complex? res)
+               (complex? expect)
+               (test-equal? (real-part expect) (real-part res))
+               (test-equal? (imag-part expect) (imag-part res))))))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; group interface
+
+;;> \section{Test Groups}
+
+;;> Tests can be collected in groups for
+
+;;> Wraps \var{body} as a single test group, which can be filtered
+;;> and summarized separately.
+
+;;> \example{
+;;> (test-group "pi"
+;;>   (test 3.14159 (acos -1))
+;;>   (test 3 (acos -1))
+;;>   (test 3.14159 (acos "-1")))
+;;> }
+
+(define-syntax test-group
+  (syntax-rules ()
+    ((_ name-expr body ...)
+     (let ((name name-expr)
+           (old-group (current-test-group)))
+       (when (not (string? name))
+         (error "a name is required, got " 'name-expr name))
+       (test-begin name)
+       (guard
+           (exn
+            (else
+             (warning "error in group outside of tests")
+             (print-exception exn (current-error-port))
+             (test-group-inc! (current-test-group) 'count)
+             (test-group-inc! (current-test-group) 'ERROR)
+             (test-failure-count (+ 1 (test-failure-count)))))
+         body ...)
+       (test-end name)
+       (current-test-group old-group)))))
+
+;;> Begin testing a new group until the closing \scheme{(test-end)}.
+
+(define (test-begin . o)
+  (let* ((name (if (pair? o) (car o) ""))
+         (parent (current-test-group))
+         (group (make-test-group name parent)))
+    ;; include a newline if we are directly nested in a parent with no
+    ;; tests yet
+    (when (and parent
+               (zero? (test-group-ref parent 'subgroups-count 0))
+               (not (test-group-ref parent 'verbose)))
+      (newline))
+    ;; header
+    (cond
+     ((test-group-ref group 'skip-group?)
+      (display (make-string (or (test-group-indent-width group) 0) #\space))
+      (display (strikethrough (bold (string-append name ":"))))
+      (display " SKIP"))
+     ((test-group-ref group 'verbose)
+      (display
+       (test-header-line
+        (string-append "testing " name)
+        (or (test-group-indent-width group) 0))))
+     (else
+      (display
+       (string-append
+        (make-string (or (test-group-indent-width group) 0)
+                     #\space)
+        (bold (string-append name ": "))))))
+    ;; set the current test group
+    (current-test-group group)))
+
+;;> Ends testing group introduced with \scheme{(test-begin)}, and
+;;> summarizes the results.  The \var{name} is optional, but if
+;;> present should match the corresponding \scheme{test-begin} name,
+;;> or a warning is printed.
+
+(define (test-end . o)
+  (let ((name (and (pair? o) (car o))))
+    (cond
+     ((current-test-group)
+      => (lambda (group)
+           (when (and name (not (equal? name (test-group-name group))))
+             (warning "mismatched test-end:" name (test-group-name group)))
+           (let ((parent (test-group-ref group 'parent)))
+             (when (and (test-group-ref group 'skip-group?)
+                        (zero? (test-group-ref group 'subgroups-count 0)))
+               (newline))
+             ;; only report if there's something to say
+             ((current-test-group-reporter) group)
+             (when parent
+               (test-group-inc! parent 'subgroups-count)
+               (cond
+                ((test-group-ref group 'skip-group?)
+                 (test-group-inc! parent 'subgroups-skip))
+                ((and (zero? (test-group-ref group 'FAIL 0))
+                      (zero? (test-group-ref group 'ERROR 0))
+                      (= (test-group-ref group 'subgroups-pass 0)
+                         (test-group-ref group 'subgroups-count 0)))
+                 (test-group-inc! parent 'subgroups-pass))))
+             (current-test-group parent)
+             group))))))
+
+;;> Exits with a failure status if any tests have failed,
+;;> and a successful status otherwise.
+
+(define (test-exit)
+  (when (current-test-group)
+    (warning "calling test-exit with unfinished test group:"
+             (test-group-name (current-test-group))))
+  (exit (zero? (test-failure-count))))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; utilities
+
+(define-syntax test-syntax-error
+  (syntax-rules ()
+    ((_) (syntax-error "invalid use of test-syntax-error"))))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; test-group representation
+
+;;> \section{Accessors}
+
+;; (name (prop value) ...)
+(define (make-test-group name . o)
+  (let ((parent (and (pair? o) (car o)))
+        (group (list name (cons 'start-time (current-second)))))
+    (test-group-set! group 'parent parent)
+    (test-group-set! group 'verbose
+                     (if parent
+                         (test-group-ref parent 'verbose)
+                         (current-test-verbosity)))
+    (test-group-set! group 'level
+                     (if parent
+                         (+ 1 (test-group-ref parent 'level 0))
+                         0))
+    (test-group-set!
+     group
+     'skip-group?
+     (and (or (and parent (test-group-ref parent 'skip-group?))
+              (any (lambda (f) (f group)) (current-test-group-removers))
+              (and (null? (current-test-group-removers))
+                   (pair? (current-test-group-filters))))
+          (not (any (lambda (f) (f group)) (current-test-group-filters)))))
+    group))
+
+;;> Returns the name of a test group info object.
+
+(define (test-group-name group) (car group))
+
+;;> Returns the value of a \var{field} in a test var{group} info
+;;> object.  \var{field} should be a symbol, and predefined fields
+;;> include \scheme{parent}, \scheme{verbose}, \scheme{level},
+;;> \scheme{start-time}, \scheme{skip-group?}, \scheme{count},
+;;> \scheme{total-pass}, \scheme{total-fail}, \scheme{total-error}.
+
+(define (test-group-ref group field . o)
+  (if group
+      (apply assq-ref (cdr group) field o)
+      (and (pair? o) (car o))))
+
+;;> Sets the value of a \var{field} in a test \var{group} info object.
+
+(define (test-group-set! group field value)
+  (cond
+   ((assq field (cdr group))
+    => (lambda (x) (set-cdr! x value)))
+   (else (set-cdr! group (cons (cons field value) (cdr group))))))
+
+;;> Increments the value of a \var{field} in a test \var{group} info
+;;> object by \var{amount}, defaulting to 1.
+
+(define (test-group-inc! group field . o)
+  (let ((amount (if (pair? o) (car o) 1)))
+    (cond
+     ((assq field (cdr group))
+      => (lambda (x) (set-cdr! x (+ amount (cdr x)))))
+     (else (set-cdr! group (cons (cons field amount) (cdr group)))))))
+
+;;> Updates a \var{field} in a test group info object by consing
+;;> \var{value} onto it.
+
+(define (test-group-push! group field value)
+  (cond
+   ((assq field (cdr group))
+    => (lambda (x) (set-cdr! x (cons value (cdr x)))))
+   (else (set-cdr! group (cons (cons field (list value)) (cdr group))))))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; utilities
+
+(define (assq-ref ls key . o)
+  (cond ((assq key ls) => cdr)
+        ((pair? o) (car o))
+        (else #f)))
+
+(define (approx-equal? a b epsilon)
+  (cond
+   ((> (abs a) (abs b))
+    (approx-equal? b a epsilon))
+   ((zero? a)
+    (< (abs b) epsilon))
+   (else
+    (< (abs (/ (- a b) b)) epsilon))))
+
+(define (call-with-output-string proc)
+  (let ((out (open-output-string)))
+    (proc out)
+    (get-output-string out)))
+
+;; partial pretty printing to abbreviate `quote' forms and the like
+(define (write-to-string x)
+  (call-with-output-string
+    (lambda (out)
+      (let wr ((x x))
+        (if (pair? x)
+            (cond
+             ((and (symbol? (car x)) (pair? (cdr x)) (null? (cddr x))
+                   (assq (car x)
+                         '((quote . "'") (quasiquote . "`")
+                           (unquote . ",") (unquote-splicing . ",@"))))
+              => (lambda (s) (display (cdr s) out) (wr (cadr x))))
+             (else
+              (display "(" out)
+              (wr (car x))
+              (let lp ((ls (cdr x)))
+                (cond ((pair? ls)
+                       (display " " out)
+                       (wr (car ls))
+                       (lp (cdr ls)))
+                      ((not (null? ls))
+                       (display " . " out)
+                       (write ls out))))
+              (display ")" out)))
+            (write x out))))))
+
+(define (display-to-string x)
+  (if (string? x) x (call-with-output-string (lambda (out) (display x out)))))
+
+;; if we need to truncate, try first dropping let's to get at the
+;; heart of the expression
+(define (truncate-source x width . o)
+  (let* ((str (write-to-string x))
+         (len (string-length str)))
+    (cond
+     ((<= len width)
+      str)
+     ((and (pair? x) (eq? 'let (car x)))
+      (if (and (pair? o) (car o))
+          (truncate-source (car (reverse x)) width #t)
+          (string-append "..."
+                         (truncate-source (car (reverse x)) (- width 3) #t))))
+     ((and (pair? x) (eq? 'call-with-current-continuation (car x)))
+      (truncate-source (cons 'call/cc (cdr x)) width (and (pair? o) (car o))))
+     ((and (pair? x) (eq? 'call-with-values (car x)))
+      (string-append
+       "..."
+       (truncate-source (if (and (pair? (cadr x)) (eq? 'lambda (car (cadr x))))
+                            (car (reverse (cadr x)))
+                            (cadr x))
+                        (- width 3)
+                        #t)))
+     (else
+      (string-append
+       (substring str 0 (min (max 0 (- width 3)) (string-length str)))
+       "...")))))
+
+(define (test-get-name! info)
+  (or
+   (assq-ref info 'name)
+   (assq-ref info 'gen-name)
+   (let ((name
+          (cond
+           ((assq 'source info)
+            => (lambda (src)
+                 (truncate-source (cdr src) (- (current-column-width) 12))))
+           ((current-test-group)
+            => (lambda (g)
+                 (display "no source in: " (current-error-port))
+                 (write info (current-error-port))
+                 (display "\n" (current-error-port))
+                 (string-append
+                  "test-"
+                  (number->string (test-group-ref g 'count 0)))))
+           (else ""))))
+     (if (pair? info)
+         (set-cdr! info (cons (cons 'gen-name name) (cdr info))))
+     name)))
+
+(define (test-print-name info . indent)
+  (let ((width (- (current-column-width)
+                  (or (and (pair? indent) (car indent)) 0)))
+        (name (test-get-name! info)))
+    (display name)
+    (display " ")
+    (let ((diff (- width 9 (string-length name))))
+      (cond
+       ((positive? diff)
+        (display (make-string diff #\.)))))
+    (display " ")
+    (flush-output-port)))
+
+(define (test-group-indent-width group)
+  (let ((level (max 0 (+ 1 (- (test-group-ref group 'level 0)
+                              (test-first-indentation))))))
+    (* 4 (min level (test-max-indentation)))))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(define (test-expand-info info)
+  (let ((expr (assq-ref info 'source)))
+    (if (and (pair? expr)
+             (pair-source expr)
+             (not (assq-ref info 'line-number)))
+        `((file-name . ,(car (pair-source expr)))
+          (line-number . ,(cdr (pair-source expr)))
+          ,@info)
+        info)))
+
+(define (test-default-applier expect expr info)
+  (let* ((group (current-test-group))
+         (indent (and group (test-group-indent-width group))))
+    (cond
+     ((or (not group) (test-group-ref group 'verbose))
+      (if (and indent (positive? indent))
+          (display (make-string indent #\space)))
+      (test-print-name info indent)))
+    (let ((expect-val
+           (guard
+               (exn
+                (else
+                 (warning "bad expect value")
+                 (print-exception exn (current-error-port))
+                 #f))
+             (expect))))
+      (guard
+          (exn
+           (else
+            ((current-test-reporter)
+             (if (assq-ref info 'expect-error) 'PASS 'ERROR)
+             (append `((exception . ,exn)) info))))
+        (let ((res (expr)))
+          (let ((status
+                 (if (and (not (assq-ref info 'expect-error))
+                          (if (assq-ref info 'assertion)
+                              res
+                              ((current-test-comparator) expect-val res)))
+                     'PASS
+                     'FAIL))
+                (info `((result . ,res) (expected . ,expect-val) ,@info)))
+            ((current-test-reporter) status info)))))))
+
+(define (test-default-skipper info)
+  ((current-test-reporter) 'SKIP info))
+
+(define (test-status-color status)
+  (case status
+    ((ERROR) (lambda (x) (underline (red x))))
+    ((FAIL) red)
+    ((SKIP) yellow)
+    (else (lambda (x) x))))
+
+(define (test-status-message status)
+  ((test-status-color status) (symbol->string status)))
+
+(define (test-status-code status)
+  ((test-status-color status)
+   ;; alternatively: ❗, ✗, ‒, ✓
+   ;; unfortunately, these have ambiguous width
+   (case status
+     ((ERROR) "!")
+     ((FAIL) "x")
+     ((SKIP) "-")
+     (else "."))))
+
+(define (display-expected/actual expected actual)
+  (let* ((e-str (write-to-string expected))
+         (a-str (write-to-string actual))
+         (diff (diff e-str a-str read-char)))
+    (write-string "expected ")
+    (write-string (edits->string/color (car diff) (car (cddr diff)) 1))
+    (write-string " but got ")
+    (write-string (edits->string/color (cadr diff) (car (cddr diff)) 2))))
+
+(define (test-print-explanation indent status info)
+  (cond
+   ((eq? status 'ERROR)
+    (display indent)
+    (cond ((assq 'exception info)
+           => (lambda (e)
+                (print-exception (cdr e) (current-output-port))))))
+   ((and (eq? status 'FAIL) (assq-ref info 'assertion))
+    (display indent)
+    (display "assertion failed\n"))
+   ((and (eq? status 'FAIL) (assq-ref info 'expect-error))
+    (display indent)
+    (display "expected an error but got ")
+    (write (assq-ref info 'result)) (newline))
+   ((eq? status 'FAIL)
+    (display indent)
+    (display-expected/actual (assq-ref info 'expected) (assq-ref info 'result))
+    (newline)))
+  ;; print variables
+  (cond
+   ((and (memq status '(FAIL ERROR)) (assq-ref info 'var-names))
+    => (lambda (names)
+         (let ((values (assq-ref info 'var-values)))
+           (if (and (pair? names)
+                    (pair? values)
+                    (= (length names) (length values)))
+               (let ((indent2
+                      (string-append indent (make-string 2 #\space))))
+                 (for-each
+                  (lambda (name value)
+                    (display indent2) (write name) (display ": ")
+                    (write value) (newline))
+                  names values))))))))
+
+(define (test-print-source indent status info)
+  (case status
+    ((FAIL ERROR)
+     (cond
+      ((assq-ref info 'line-number)
+       => (lambda (line)
+            (display "    on line ")
+            (write line)
+            (cond ((assq-ref info 'file-name)
+                   => (lambda (file) (display " of file ") (write file))))
+            (newline))))
+     (cond
+      ((assq-ref info 'source)
+       => (lambda (s)
+            (cond
+             ((or (assq-ref info 'name)
+                  (> (string-length (write-to-string s))
+                     (current-column-width)))
+              (display (write-to-string s))
+              (newline))))))
+     (cond
+      ((assq-ref info 'values)
+       => (lambda (v)
+            (for-each
+             (lambda (v)
+               (display "    ") (display (car v))
+               (display ": ") (write (cdr v)) (newline))
+             v)))))))
+
+(define (test-print-failure indent status info)
+  ;; display status explanation
+  (test-print-explanation indent status info)
+  ;; display line, source and values info
+  (test-print-source indent status info))
+
+(define (test-header-line str . indent)
+  (let* ((header (string-append
+                  (make-string (if (pair? indent) (car indent) 0) #\space)
+                  "-- " str " "))
+         (len (string-length header)))
+    (string-append (bold header)
+                   (make-string (max 0 (- (current-column-width) len)) #\-))))
+
+(define (test-default-handler status info)
+  (define indent
+    (make-string
+     (+ 4 (cond ((current-test-group)
+                 => (lambda (group) (or (test-group-indent-width group) 0)))
+                (else 0)))
+     #\space))
+  ;; update group info
+  (cond
+   ((current-test-group)
+    => (lambda (group)
+         (if (not (eq? 'SKIP status))
+             (test-group-inc! group 'count))
+         (test-group-inc! group status)
+         ;; maybe wrap long status lines
+         (let ((width (max (- (current-column-width)
+                              (or (test-group-indent-width group) 0))
+                           4))
+               (column
+                (+ (string-length (or (test-group-name group) ""))
+                   (or (test-group-ref group 'count) 0)
+                   1)))
+           (if (and (zero? (modulo column width))
+                    (not (test-group-ref group 'verbose)))
+               (display (string-append "\n" (string-copy indent 4))))))))
+  ;; update global failure count for exit status
+  (cond
+   ((or (eq? status 'FAIL) (eq? status 'ERROR))
+    (test-failure-count (+ 1 (test-failure-count)))))
+  (cond
+   ((or (not (current-test-group))
+        (test-group-ref (current-test-group) 'verbose))
+    ;; display status
+    (display "[")
+    (if (not (eq? status 'ERROR)) (display " ")) ; pad
+    (display (test-status-message status))
+    (display "]")
+    (newline)
+    (test-print-failure indent status info))
+   ((eq? status 'SKIP))
+   (else
+    (display (test-status-code status))
+    (cond
+     ((and (memq status '(FAIL ERROR)) (current-test-group))
+      => (lambda (group)
+           (test-group-push! group 'failures (list indent status info)))))
+    (cond ((current-test-group)
+           => (lambda (group) (test-group-set! group 'trailing #t))))))
+  (flush-output-port)
+  status)
+
+(define (test-default-group-reporter group)
+  (define (plural word n)
+    (if (= n 1) word (string-append word "s")))
+  (define (percent n d)
+    (string-append " (" (number->string (/ (round (* 1000.0 (/ n d))) 10))
+                   "%)"))
+  (let* ((end-time (current-second))
+         (start-time (test-group-ref group 'start-time))
+         (duration (- end-time start-time))
+         (base-count (or (test-group-ref group 'count) 0))
+         (base-pass (or (test-group-ref group 'PASS) 0))
+         (base-fail (or (test-group-ref group 'FAIL) 0))
+         (base-err (or (test-group-ref group 'ERROR) 0))
+         (skip (or (test-group-ref group 'SKIP) 0))
+         (pass (+ base-pass (or (test-group-ref group 'total-pass) 0)))
+         (fail (+ base-fail (or (test-group-ref group 'total-fail) 0)))
+         (err (+ base-err (or (test-group-ref group 'total-error) 0)))
+         (count (+ pass fail err))
+         (subgroups-count (or (test-group-ref group 'subgroups-count) 0))
+         (subgroups-skip (or (test-group-ref group 'subgroups-skip) 0))
+         (subgroups-run (- subgroups-count subgroups-skip))
+         (subgroups-pass (or (test-group-ref group 'subgroups-pass) 0))
+         (indent (make-string (or (test-group-indent-width group) 0) #\space)))
+    (if (and (not (test-group-ref group 'verbose))
+             (test-group-ref group 'trailing))
+        (newline))
+    (cond
+     ((or (positive? count) (positive? subgroups-count))
+      (if (not (= base-count (+ base-pass base-fail base-err)))
+          (warning "inconsistent count:"
+                   base-count base-pass base-fail base-err))
+      (cond
+       ((positive? count)
+        (display indent)
+        (display
+         ((if (= pass count) green (lambda (x) x))
+          (string-append
+           (number->string pass) " out of " (number->string count)
+           (percent pass count))))
+        (display
+         (string-append
+          (plural " test" pass) " passed in "
+          (number->string duration) " seconds"
+          (cond
+           ((zero? skip) "")
+           (else (string-append " (" (number->string skip)
+                                (plural " test" skip) " skipped)")))
+          ".\n"))))
+      (cond ((positive? fail)
+             (display indent)
+             (display
+              (red
+               (string-append
+                (number->string fail) (plural " failure" fail)
+                (percent fail count) ".\n")))))
+      (cond ((positive? err)
+             (display indent)
+             (display
+              ((lambda (x) (underline (red x)))
+               (string-append
+                (number->string err) (plural " error" err)
+                (percent err count) ".\n")))))
+      (cond
+       ((not (test-group-ref group 'verbose))
+        (for-each
+         (lambda (failure)
+           (display indent)
+           (display (red
+                     (string-append (display-to-string (cadr failure)) ": ")))
+           (display (test-get-name! (car (cddr failure))))
+           (newline)
+           (apply test-print-failure failure))
+         (reverse (or (test-group-ref group 'failures) '())))))
+      (cond
+       ((positive? subgroups-run)
+        (display indent)
+        (display
+         ((if (= subgroups-pass subgroups-run)
+              green (lambda (x) x))
+          (string-append
+           (number->string subgroups-pass) " out of "
+           (number->string subgroups-run)
+           (percent subgroups-pass subgroups-run))))
+        (display (plural " subgroup" subgroups-pass))
+        (display " passed.\n")))))
+    (cond
+     ((test-group-ref group 'verbose)
+      (display
+       (test-header-line
+        (string-append "done testing " (or (test-group-name group) ""))
+        (or (test-group-indent-width group) 0)))
+      (newline)))
+    (cond
+     ((test-group-ref group 'parent)
+      => (lambda (parent)
+           (test-group-set! parent 'trailing #f)
+           (test-group-inc! parent 'total-pass pass)
+           (test-group-inc! parent 'total-fail fail)
+           (test-group-inc! parent 'total-error err))))))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; parameters
+
+;;> \section{Parameters}
+
+;;> The current test group as started by \scheme{test-group} or
+;;> \scheme{test-begin}.
+
+(define current-test-group (make-parameter #f))
+
+;;> If true, show more verbose output per test.  Inferred from the
+;;> environment variable TEST_VERBOSE.
+
+(define current-test-verbosity
+  (make-parameter
+   (cond ((get-environment-variable "TEST_VERBOSE")
+          => (lambda (s) (not (member s '("" "0")))))
+         (else #f))))
+
+;;> The epsilon used for floating point comparisons.
+
+(define current-test-epsilon (make-parameter 1e-5))
+
+;;> The underlying comparator used in testing, defaults to
+;;> \scheme{test-equal?}.
+
+(define current-test-comparator (make-parameter test-equal?))
+
+;;> The test applier - what we do with non-skipped tests.  Takes the
+;;> same signature as \scheme{test-run}, should be responsible for
+;;> evaluating the thunks, determining the status of the test, and
+;;> passing this information to \scheme{current-test-reporter}.
+
+(define current-test-applier (make-parameter test-default-applier))
+
+;;> The test skipper - what we do with non-skipped tests.  This should
+;;> not evaluate the thunks and simply pass off to
+;;> \scheme{current-test-reporter}.
+
+(define current-test-skipper (make-parameter test-default-skipper))
+
+;;> Takes two arguments, the symbol status of the test and the info
+;;> alist.  Reports the result of the test and updates bookkeeping in
+;;> the current test group for reporting.
+
+(define current-test-reporter (make-parameter test-default-handler))
+
+;;> Takes one argument, a test group, and prints a summary of the test
+;;> results for that group.
+
+(define current-test-group-reporter
+  (make-parameter test-default-group-reporter))
+
+;;> A running count of all test failures and errors across all groups
+;;> (and threads).  Used by \scheme{test-exit}.
+
+(define test-failure-count (make-parameter 0))
+
+(define test-first-indentation
+  (make-parameter
+   (or (cond ((get-environment-variable "TEST_FIRST_INDENTATION")
+              => string->number)
+             (else #f))
+       1)))
+
+(define test-max-indentation
+  (make-parameter
+   (or (cond ((get-environment-variable "TEST_MAX_INDENTATION")
+              => string->number)
+             (else #f))
+       5)))
+
+(define (string->info-matcher str)
+  (lambda (info)
+    (cond ((test-get-name! info)
+           => (lambda (n) (string-search str n)))
+          (else #f))))
+
+(define (string->group-matcher str)
+  (lambda (group) (string-search str (test-group-name group))))
+
+;; simplified version from SRFI 130
+(define (string-split str ch)
+  (let ((end (string-length str)))
+    (let lp ((from 0) (to 0) (res '()))
+      (cond
+       ((>= to end)
+        (reverse (if (> to from) (cons (substring str from to) res) res)))
+       ((eqv? ch (string-ref str to))
+        (lp (+ to 1) (+ to 1) (cons (substring str from to) res)))
+       (else
+        (lp from (+ to 1) res))))))
+
+(define (getenv-filter-list proc name)
+  (cond
+   ((get-environment-variable name)
+    => (lambda (s)
+         (let lp ((ls (string-split s #\,))
+                  (res '()))
+           (cond
+            ((null? ls) (reverse res))
+            (else
+             (let* ((s (car ls))
+                    (f (guard
+                           (exn
+                            (else
+                             (warning
+                              (string-append "invalid filter '" s
+                                             "' from environment variable: "
+                                             name))
+                             (print-exception exn (current-error-port))
+                             #f))
+                         (proc s))))
+               (lp (cdr ls) (if f (cons f res) res))))))))
+   (else '())))
+
+(define current-test-group-filters
+  (make-parameter
+   (getenv-filter-list string->group-matcher "TEST_GROUP_FILTER")))
+
+(define current-test-group-removers
+  (make-parameter
+   (getenv-filter-list string->group-matcher "TEST_GROUP_REMOVE")))
+
+;;> Parameters controlling which test groups are skipped.  Each
+;;> parameter is a list of procedures of one argument, a test group
+;;> info, which can be queried with \var{test-group-name} and
+;;> \var{test-group-ref}.  Analogous to SRFI 1, a filter selects a
+;;> group for inclusion and a removers for exclusion.  The defaults
+;;> are set automatically from the environment variables
+;;> TEST_GROUP_FILTER and TEST_GROUP_REMOVE, which should be
+;;> comma-delimited lists of strings which are checked for a substring
+;;> match in the test group name.  A test group is skipped if it does
+;;> not match any filter and:
+;;> \itemlist[
+;;> \item{its parent group is skipped, or}
+;;> \item{it matches a remover, or}
+;;> \item{no removers are specified but some filters are}
+;;> ]
+;;/
+
+(define current-test-filters
+  (make-parameter (getenv-filter-list string->info-matcher "TEST_FILTER")))
+
+(define current-test-removers
+  (make-parameter (getenv-filter-list string->info-matcher "TEST_REMOVE")))
+
+;;> Parameters controlling which tests are skipped.  Each parameter is
+;;> a list of procedures of one argument, a test info alist, which can
+;;> be queried with \scheme{test-get-name!} or \scheme{assq}.
+;;> Analogous to SRFI 1, a filter selects a test for inclusion and a
+;;> removers for exclusion.  The defaults are set automatically from
+;;> the environment variables TEST_FILTER and TEST_REMOVE, which
+;;> should be comma-delimited lists of strings which are checked for a
+;;> substring match in the test name.  A test is skipped if its group
+;;> is skipped, or if it does not match a filter and:
+;;> \itemlist[
+;;> \item{it matches a remover, or}
+;;> \item{no removers are specified but some filters are}
+;;> ]
+;;/
+
+;;> Parameter controlling the current column width for test output,
+;;> can be set from the environment variable TEST_COLUMN_WIDTH,
+;;> otherwise defaults to 78.  For portability of implementation (and
+;;> resulting output), does not attempt to use termios to determine
+;;> the actual available width.
+
+(define current-column-width
+  (make-parameter
+   (or (cond ((get-environment-variable "TEST_COLUMN_WIDTH")
+              => string->number)
+             (else #f))
+       78)))

tests.scm

@@ -1,2 +1,2 @@
 (define tests
-  '(((name . "r7rs-tests-1") (file . "r7rs-tests-1.scm"))))
+  '(((name . "r7rs-test") (file . "r7rs-tests.scm"))))

update-tests

@@ -1,5 +1,4 @@
 #/bin/sh
 
-rm -rf r7rs-tests-1.scm
+rm -rf r7rs-tests.scm
 wget https://raw.githubusercontent.com/ashinn/chibi-scheme/refs/heads/master/tests/r7rs-tests.scm
-mv r7rs-tests.scm r7rs-tests-1.scm

util.scm

@@ -17,22 +17,6 @@
     (and (>= (string-length str) (string-length prefix))
          (string=? (string-copy str 0 (string-length prefix)) prefix))))
 
-(define file-tail
-  (lambda (path linecount)
-    (with-input-from-file
-      path
-      (lambda ()
-        (letrec
-          ((looper
-             (lambda (line count lines)
-               (if (eof-object? line)
-                 (if (< (length lines) linecount)
-                   (list)
-                   (list-tail lines (- (length lines) linecount)))
-                 (looper (read-line) (+ count 1) (append lines (list line)))))))
-          (looper (read-line) 0 (list)))))))
-
-
 (define number-of-line->number
   (lambda (str)
     (letrec