Retropikzel
/
compile-r7rs
1
0
Fork 0
Code Issues 8 Pull Requests Releases Activity

Adding test-r7rs

This commit is contained in:
retropikzel 2025-09-20 07:40:03 +03:00
parent 387b2a9d5f
commit c2fcf4acd8
4 changed files with 86 additions and 53 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

9
Dockerfile
View File

@ -10,17 +10,20 @@ RUN make install
WORKDIR /build
ENV SCHEME=chicken
RUN mkdir -p ${HOME}/.snow && echo "()" > ${HOME}/.snow/config.scm
RUN snow-chibi --impls=${SCHEME} --always-yes install "(foreign c)"
RUN snow-chibi --impls=${SCHEME} --always-yes install "(retropikzel system)"
RUN snow-chibi --impls=${SCHEME} --always-yes install "(srfi 170)"
COPY Makefile .
COPY compile-r7rs.scm .
COPY test-r7rs.sh .
COPY test-r7rs.scm .
COPY libs libs
RUN make PREFIX=/opt/compile-r7rs build-static
RUN make PREFIX=/opt/compile-r7rs build
RUN make PREFIX=/opt/compile-r7rs install
FROM debian:trixie-slim
FROM schemers/chibi
RUN apt-get update && apt-get install -y docker.io podman make
COPY --from=build /opt/compile-r7rs /opt/compile-r7rs
ENV PATH=/opt/compile-r7rs/bin:${PATH}

18
compile-r7rs.scm
View File

@ -10,27 +10,15 @@
(srfi 170))
(when (member "--list-r6rs-schemes" (command-line))
(for-each
(lambda (scheme)
(display scheme)
(newline))
r6rs-schemes)
(for-each (lambda (scheme) (display scheme) (display " ")) r6rs-schemes)
(exit 0))
(when (member "--list-r7rs-schemes" (command-line))
(for-each
(lambda (scheme)
(display scheme)
(newline))
r7rs-schemes)
(for-each (lambda (scheme) (display scheme) (display " ")) r7rs-schemes)
(exit 0))
(when (member "--list-schemes" (command-line))
(for-each
(lambda (scheme)
(display scheme)
(newline))
all-schemes)
(for-each (lambda (scheme) (display scheme) (display " ")) all-schemes)
(exit 0))
(define scheme (if (get-environment-variable "COMPILE_R7RS")

13
libs/srfi-64-util.scm
View File

@ -49,7 +49,10 @@
result))
(define (line->data line)
(let ((pair (apply cons (map trim-both (string-split line #\:)))))
(let* ((splitted (map trim-both (string-split line #\:)))
(pair (if (= (length splitted) 2)
(cons (list-ref splitted 0) (list-ref splitted 1))
(cons (list-ref splitted 0) #f))))
(cons (string->symbol (car pair)) (cdr pair))))
(define (read-test-data)
@ -79,6 +82,8 @@
group
(read-line)))
(else (looper results group (read-line)))))))
(with-input-from-file
path
(lambda () (looper (list) '(group . "") (read-line))))))
(if (not (file-exists? path))
(list)
(with-input-from-file
path
(lambda () (looper (list) '(group . "") (read-line)))))))

99
test-r7rs.scm
View File

@ -11,6 +11,21 @@
(srfi 170)
(retropikzel system))
(define timeout
(if (get-environment-variable "TEST_R7RS_TIMEOUT")
(get-environment-variable "TEST_R7RS_TIMEOUT")
"6000"))
(define input-file
(let ((input-file #f))
(for-each
(lambda (item)
(when (or (string-ends-with? item ".scm")
(string-ends-with? item ".sps"))
(set! input-file item)))
(list-tail (command-line) 1))
input-file))
(define output-file
(if (member "-o" (command-line))
(cadr (member "-o" (command-line)))
@ -184,22 +199,32 @@
dockerfile-path))
(define (docker-run-cmd tag cmd)
(string-append "docker run -v \"${PWD}:/workdir\" --workdir /workdir "
tag
" sh -c \"" cmd "\""))
(string-append "docker run -it -v \"${PWD}:/workdir\" --workdir /workdir "
tag " sh -c \"timeout " timeout " " cmd "\""))
(for-each
(lambda (path) (when (not (file-exists? path)) (create-directory path)))
`(".test-r7rs"
".test-r7rs/tmp"))
`(".test-r7rs" ".test-r7rs/tmp"))
(define timestamp-path ".test-r7rs/timestamp")
(system (string-append "date --iso-8601=minutes --utc > " timestamp-path))
(define timestamp
(if (file-exists? timestamp-path)
(with-input-from-file timestamp-path (lambda () (read-line)))
""))
(for-each
echo
`(,(string-append "# Test report - " output-file)
""
,(string-append "Timestamp(UTC): " timestamp)
""
"Output files are under .test-r7rs/output"
"Log files are under .test-r7rs/logs"
"Any other output is under .test-r7rs/tmp for debugging"
,(string-append "Timeout: " timeout)
""
;"Exit code 124 means timed out."
""
"First run may take a while as docker containers are being built"
""
@ -208,11 +233,15 @@
"Unexpected passes"
"Failures"
"Expected failures"
"Skipped tests"))
,(make-row (list lines lines lines lines lines lines))))
"Skipped tests"
"Build exit code"
"Run exit code"))
,(make-row (list lines lines lines lines lines lines lines lines))))
(for-each
(lambda (scheme)
(display (make-cell scheme))
(flush-output-port)
(let*
((scheme-dir (let ((path (string-append ".test-r7rs/" scheme)))
(when (not (file-exists? path)) (create-directory path))
@ -224,14 +253,14 @@
(docker-tag
(string-append "test-r7rs-" scheme "-run"))
(docker-build-out
(string-append ".test-r7rs/tmp/last-docker-build"))
(string-append ".test-r7rs/tmp/" scheme "-last-docker-build"))
(docker-build-cmd
(string-append "docker build"
" -f " dockerfile-path
" --tag=" docker-tag
" > " docker-build-out " 2>&1"))
(build-out
(string-append ".test-r7rs/tmp/last-build"))
(string-append ".test-r7rs/tmp/" scheme "-last-build"))
(build-cmd
(docker-run-cmd docker-tag
(string-append
@ -239,7 +268,7 @@
original-arguments
(string-append " > " build-out " 2>&1"))))
(run-out
(string-append ".test-r7rs/tmp/last-run"))
(string-append ".test-r7rs/tmp/" scheme "-last-run"))
(run-cmd
(docker-run-cmd docker-tag
(string-append
@ -258,10 +287,10 @@
""
(get-test-name run-out)))
(logfile (string-append testname ".log"))
(scheme-docker-build-out (string-append scheme-log-dir "/" testname "-docker.log"))
(scheme-build-out (string-append scheme-log-dir "/" testname "-build.log"))
(scheme-run-out (string-append scheme-log-dir "/" testname "-run.log"))
(scheme-results-out (string-append scheme-log-dir "/" testname "-srfi-64.log"))
(scheme-docker-build-out (string-append scheme-log-dir "/" output-file "-docker.log"))
(scheme-build-out (string-append scheme-log-dir "/" output-file "-build.log"))
(scheme-run-out (string-append scheme-log-dir "/" output-file "-run.log"))
(scheme-results-out (string-append scheme-log-dir "/" output-file "-results.log"))
(short-test-results (srfi-64-output-read (if (file-exists? run-out) (slurp run-out) "")))
(passes (cdr (assoc 'expected-passes short-test-results)))
(failures (cdr (assoc 'failures short-test-results)))
@ -270,12 +299,22 @@
(skipped (cdr (assoc 'skipped short-test-results)))
(test-results (srfi-64-log-results logfile)))
(system (string-append "mv " docker-build-out " " scheme-docker-build-out " > /dev/null 2>&1"))
(system (string-append "mv " build-out " " scheme-build-out " > /dev/null 2>&1"))
(system (string-append "mv " run-out " " scheme-run-out " > /dev/null 2>&1"))
(system (string-append "mv " logfile " " scheme-results-out " > /dev/null 2>&1"))
(system (string-append "mv " docker-build-out " " scheme-docker-build-out " > /dev/null 2>&1"))
(system (string-append "mv " build-out " " scheme-build-out " > /dev/null 2>&1"))
(system (string-append "mv " run-out " " scheme-run-out " > /dev/null 2>&1"))
(when (not (string=? testname ""))
(system (string-append "mv " logfile " " scheme-results-out " > /dev/null 2>&1")))
(echo
(make-row
(list passes
unexpected-passes
failures
expected-failures
skipped
build-exit-code
run-exit-code)))
(echo (make-row (list scheme passes unexpected-passes failures expected-failures skipped)))
(when stop-on-error?
(when (not (string=? build-exit-code "0"))
(display "Error on build:")
@ -284,8 +323,7 @@
(display ": ")
(newline)
(cat scheme-build-out)
(exit 1)
)
(exit 1))
(when (not (string=? run-exit-code "0"))
(display "Error on run:")
(newline)
@ -293,8 +331,7 @@
(display ": ")
(newline)
(cat scheme-run-out)
(exit 1)
))
(exit 1)))
(when stop-on-fail?
(when (and (string->number failures) (> (string->number failures) 0))
(let ((pretty-print (lambda (pair)
@ -307,14 +344,14 @@
(for-each
(lambda (result)
(when (string=? (cdr (assoc 'result-kind result)) "fail")
(pretty-print (assq 'test-name result))
(for-each
(lambda (item)
(when (not (equal? (car item) 'test-name))
(display " ")
(pretty-print item)))
(cdr result))
(newline)))
(pretty-print (assq 'test-name result))
(for-each
(lambda (item)
(when (not (equal? (car item) 'test-name))
(display " ")
(pretty-print item)))
(cdr result))
(newline)))
test-results)
(exit 1)))))))
schemes)