Compare commits
No commits in common. "fcd7b62d01f7983f6fa19cf6dd448e122ecbd3de" and "b6017b24edb2eb91552ead9c077f9ee71f4ecc9e" have entirely different histories.
fcd7b62d01
...
b6017b24ed
|
|
@ -15,4 +15,3 @@ srfi.*.scm
|
|||
srfi.*.sld
|
||||
reports
|
||||
snow.*
|
||||
r7rs-tests.scm
|
||||
|
|
|
|||
|
|
@ -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 'cat r7rs-tests-1.log'
|
||||
sh 'chibi-scheme -I ./snow/chibi r7rs-tests.scm> r7rs-test.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 'cat 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-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 'cat r7rs-tests-1.log'
|
||||
sh 'cyclone -A . r7rs-tests.scm && ./r7rs-test && rm r7rs-test> r7rs-test.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 'cat r7rs-tests-1.log'
|
||||
sh 'gsc -exe . -nopreload r7rs-tests.scm && ./r7rs-test && rm r7rs-test> r7rs-test.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 'cat r7rs-tests-1.log'
|
||||
sh 'gosh -r7 -A ./snow r7rs-tests.scm> r7rs-test.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 'cat r7rs-tests-1.log'
|
||||
sh 'guile --fresh-auto-compile --r7rs -L . -L ./snow r7rs-tests.scm> r7rs-test.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 'cat 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-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 'cat 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-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 'cat r7rs-tests-1.log'
|
||||
sh 'mit-scheme --load r7rs-tests.scm> r7rs-test.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 'cat 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-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 'cat r7rs-tests-1.log'
|
||||
sh 'stklos -I ./snow r7rs-tests.scm> r7rs-test.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 'cat r7rs-tests-1.log'
|
||||
sh 'skint --program r7rs-tests.scm> r7rs-test.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 'cat r7rs-tests-1.log'
|
||||
sh 'tr7i r7rs-tests.scm> r7rs-test.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',
|
||||
reportTitles: 'R7RS Conformance Test Report'])
|
||||
reportName: 'R7RS-SRFI Test Report',
|
||||
reportTitles: 'R7RS-SRFI Test Report'])
|
||||
}
|
||||
}
|
||||
}
|
||||
|
|
|
|||
52
Makefile
52
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:
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
||||
|
|
@ -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)))
|
||||
|
|
|
|||
|
|
@ -1,25 +1,25 @@
|
|||
|
||||
(define implementations
|
||||
'(((name . "chibi") (command . "chibi-scheme -I ./snow/chibi"))
|
||||
((name . "chicken")
|
||||
'(((name . chibi) (command . "chibi-scheme -I ./snow/chibi"))
|
||||
((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 . "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 . "loko")
|
||||
((name . gauche) (command . "gosh -r7 -A ./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 . 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 . "sagittarius") (command . "sash -r7 -L ./snow"))
|
||||
((name . "stklos") (command . "stklos -I ./snow"))
|
||||
((name . "skint") (command . "skint --program"))
|
||||
((name . "tr7") (command . "tr7i"))))
|
||||
((name . mit-scheme) (command . "mit-scheme --load"))
|
||||
((name . sagittarius) (command . "sash -r7 -L ./snow"))
|
||||
((name . stklos) (command . "stklos -I ./snow"))
|
||||
((name . skint) (command . "skint --program"))
|
||||
((name . tr7) (command . "tr7i"))))
|
||||
|
|
|
|||
55
report.scm
55
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)
|
||||
(display (string-append "<th>" (cdr (assoc 'name test)) "</th>") out)
|
||||
(lambda (implementation)
|
||||
(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)
|
||||
(let ((name (cdr (assoc 'name implementation))))
|
||||
(lambda (test)
|
||||
(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)
|
||||
(letrec* ((test-name (cdr (assoc 'name test)))
|
||||
(lambda (implementation)
|
||||
(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
|
||||
(if (file-exists? logfile)
|
||||
(file-tail logfile 3)
|
||||
(list "Could not run tests")))
|
||||
(result (apply string-append
|
||||
(map
|
||||
(lambda (line)
|
||||
(string-append line "</br>"))
|
||||
results))))
|
||||
(results (if (not (file-exists? logfile))
|
||||
(list "" "" "" "")
|
||||
(with-input-from-file
|
||||
logfile
|
||||
(lambda ()
|
||||
(read-results (read-line) (list))))))
|
||||
(expected-passes (if (> (length results) 0) (list-ref results 0) 0))
|
||||
(expected-failures (if (> (length results) 1) (list-ref results 1) 0))
|
||||
(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)
|
||||
implementations)
|
||||
(display (string-append "</tr>") out)))
|
||||
implementations)
|
||||
tests)
|
||||
(execute report-bottom '() out)
|
||||
(newline out)))
|
||||
|
|
|
|||
|
|
@ -10,8 +10,8 @@
|
|||
keepAll: true,
|
||||
reportDir: 'reports',
|
||||
reportFiles: '*.html,*.css',
|
||||
reportName: 'R7RS Conformance Test Report',
|
||||
reportTitles: 'R7RS Conformance Test Report'])
|
||||
reportName: 'R7RS-SRFI Test Report',
|
||||
reportTitles: 'R7RS-SRFI Test Report'])
|
||||
}
|
||||
}
|
||||
}
|
||||
|
|
|
|||
|
|
@ -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>
|
||||
|
|
|
|||
|
|
@ -1,3 +1,6 @@
|
|||
<td>
|
||||
{{{result}}}
|
||||
<td style="background-color:{{color}}">
|
||||
{{expected-passes}}
|
||||
{{expected-failures}}
|
||||
{{unexpected-failures}}
|
||||
{{skipped-tests}}
|
||||
</td>
|
||||
|
|
|
|||
|
|
@ -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)))
|
||||
|
|
@ -1,2 +1,2 @@
|
|||
(define tests
|
||||
'(((name . "r7rs-tests-1") (file . "r7rs-tests-1.scm"))))
|
||||
'(((name . "r7rs-test") (file . "r7rs-tests.scm"))))
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
16
util.scm
16
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
|
||||
|
|
|
|||
Loading…
Reference in New Issue