322 lines
12 KiB
Scheme
322 lines
12 KiB
Scheme
(import (scheme base)
|
|
(scheme file)
|
|
(scheme read)
|
|
(scheme write)
|
|
(scheme process-context)
|
|
(foreign c)
|
|
(libs util)
|
|
(libs data)
|
|
(libs library-util)
|
|
(libs srfi-64-util)
|
|
(srfi 170)
|
|
(retropikzel system))
|
|
|
|
(define output-file
|
|
(if (member "-o" (command-line))
|
|
(cadr (member "-o" (command-line)))
|
|
(if input-file
|
|
"a.out"
|
|
#f)))
|
|
|
|
(define stop-on-error?
|
|
(if (member "--stop-on-error" (command-line)) #t #f))
|
|
|
|
(define stop-on-fail?
|
|
(if (member "--stop-on-fail" (command-line)) #t #f))
|
|
|
|
(define use-docker-head?
|
|
(if (member "--use-docker-head" (command-line)) #t #f))
|
|
|
|
(define schemes
|
|
(let ((compile-r7rs (get-environment-variable "COMPILE_R7RS")))
|
|
(cond
|
|
((not compile-r7rs)
|
|
#f)
|
|
((not (string? compile-r7rs))
|
|
(error "COMPILE_R7RS is not a string" compile-r7rs))
|
|
((string=? compile-r7rs "all-r6rs")
|
|
(map symbol->string r6rs-schemes))
|
|
((string=? compile-r7rs "all-r7rs")
|
|
(map symbol->string r7rs-schemes))
|
|
(else
|
|
(list compile-r7rs)))))
|
|
(when (not schemes) (error "Environment variable COMPILE_R7RS not set."))
|
|
(when (and (< (length schemes) 2)
|
|
(not (assoc (string->symbol (car schemes)) data)))
|
|
(error "Unsupported implementation" schemes))
|
|
(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 filename (string-cut-from-end input-file 3))
|
|
(define r6rs?
|
|
(if (and input-file
|
|
(or (string-ends-with? input-file ".sps")
|
|
(string-ends-with? input-file ".sls")))
|
|
#t
|
|
#f))
|
|
|
|
(define original-arguments
|
|
(apply string-append
|
|
(map
|
|
(lambda (item)
|
|
(string-append item " "))
|
|
(list-tail (command-line) 1))))
|
|
|
|
(define snow-pkgs
|
|
(let ((pkgs (open-output-string)))
|
|
(for-each
|
|
(lambda (pkg)
|
|
(for-each
|
|
(lambda (i) (display i pkgs))
|
|
`(#\" ,pkg #\" " ")))
|
|
(read
|
|
(open-input-string
|
|
(string-append "((srfi 64) " (util-getenv "SNOW_PKGS") ")"))))
|
|
(get-output-string pkgs)))
|
|
|
|
(define akku-pkgs
|
|
(let ((pkgs (open-output-string)))
|
|
(for-each
|
|
(lambda (pkg)
|
|
(for-each
|
|
(lambda (i) (display i pkgs))
|
|
`(#\" ,pkg #\" " ")))
|
|
(read
|
|
(open-input-string
|
|
(string-append "((srfi 64) " (util-getenv "AKKU_PKGS") ")"))))
|
|
(get-output-string pkgs)))
|
|
|
|
(define apt-pkgs (util-getenv "APT_PKGS"))
|
|
(define lines ":----------------")
|
|
(define cell-width 17)
|
|
(define (make-cell text)
|
|
(letrec* ((looper (lambda (result)
|
|
(if (> (string-length result) cell-width)
|
|
result
|
|
(looper (string-append result " "))))))
|
|
(string-append "| " (looper text))))
|
|
(define (make-row items)
|
|
(string-append (apply string-append (map make-cell items)) "|"))
|
|
(define (string-copy-until text begin-index until-char)
|
|
(letrec* ((end (string->list (string-copy text begin-index)))
|
|
(looper (lambda (c rest result)
|
|
(if (or (null? rest) (char=? c until-char))
|
|
result
|
|
(looper (car rest) (cdr rest) (append result (list c)))))))
|
|
(if (null? end)
|
|
""
|
|
(list->string (looper (car end) (cdr end) (list))))))
|
|
|
|
(define (get-test-name run-out)
|
|
(letrec* ((prefix "%%%% Starting test ")
|
|
(prefix-length (string-length prefix))
|
|
(looper (lambda (line)
|
|
(if (and (not (eof-object? line))
|
|
(string? line)
|
|
(> (string-length line) prefix-length)
|
|
(string=? (string-copy line 0 prefix-length)
|
|
prefix))
|
|
(string-copy-until line prefix-length #\()
|
|
(when (not (eof-object? line))
|
|
(looper (read-line)))))))
|
|
(with-input-from-file
|
|
run-out
|
|
(lambda ()
|
|
(trim-both (looper (read-line)))))))
|
|
|
|
(define (write-dockerfile scheme snow-pkgs akku-pkgs apt-pkgs)
|
|
(let ((dockerfile-path (string-append ".test-r7rs/" scheme "/Dockerfile")))
|
|
(when (file-exists? dockerfile-path) (delete-file dockerfile-path))
|
|
(with-output-to-file
|
|
dockerfile-path
|
|
(lambda ()
|
|
(for-each
|
|
echo
|
|
`("FROM debian:trixie AS build"
|
|
"RUN apt-get update && apt-get install -y git gcc wget make guile-3.0-dev libcurl4-openssl-dev"
|
|
"WORKDIR /cache"
|
|
"RUN git clone https://github.com/ashinn/chibi-scheme.git --depth=1"
|
|
"RUN wget https://gitlab.com/-/project/6808260/uploads/819fd1f988c6af5e7df0dfa70aa3d3fe/akku-1.1.0.tar.gz && tar -xf akku-1.1.0.tar.gz"
|
|
"RUN mv akku-1.1.0 akku"
|
|
|
|
"WORKDIR /cache/chibi-scheme"
|
|
"RUN make"
|
|
|
|
"WORKDIR /cache/akku"
|
|
"RUN ./configure && make"
|
|
|
|
,(string-append "FROM schemers/"
|
|
scheme
|
|
(cond ((and (string=? scheme "chicken")
|
|
use-docker-head?)
|
|
":5")
|
|
(use-docker-head? ":head")
|
|
(else "")))
|
|
,(string-append
|
|
"RUN apt-get update && apt-get install -y make guile-3.0 libcurl4-openssl-dev " apt-pkgs)
|
|
"RUN mkdir -p ${HOME}/.snow && echo \"()\" > ${HOME}/.snow/config.scm"
|
|
|
|
"COPY --from=build /cache /cache"
|
|
|
|
"COPY --from=retropikzel1/compile-r7rs /opt/compile-r7rs /opt/compile-r7rs"
|
|
|
|
"ENV PATH=/opt/compile-r7rs/bin:${PATH}"
|
|
,(string-append "ENV COMPILE_R7RS=" scheme)
|
|
|
|
"WORKDIR /cache/chibi-scheme"
|
|
"RUN make install"
|
|
"WORKDIR /cache/akku"
|
|
"RUN make install"
|
|
|
|
"WORKDIR /akku"
|
|
|
|
"RUN akku update"
|
|
,(string-append "RUN snow-chibi install --always-yes --impls=" scheme " " snow-pkgs)
|
|
,(string-append "RUN akku install " akku-pkgs)
|
|
|
|
"WORKDIR /workdir"))))
|
|
dockerfile-path))
|
|
|
|
(define (docker-run-cmd tag cmd)
|
|
(string-append "docker run -v \"${PWD}:/workdir\" --workdir /workdir "
|
|
tag
|
|
" sh -c \"" cmd "\""))
|
|
|
|
(for-each
|
|
(lambda (path) (when (not (file-exists? path)) (create-directory path)))
|
|
`(".test-r7rs"
|
|
".test-r7rs/tmp"))
|
|
|
|
(for-each
|
|
echo
|
|
`(,(string-append "# Test report - " output-file)
|
|
""
|
|
"Output files are under .test-r7rs/output"
|
|
"Log files are under .test-r7rs/logs"
|
|
"Any other output is under .test-r7rs/tmp for debugging"
|
|
""
|
|
"First run may take a while as docker containers are being built"
|
|
""
|
|
,(make-row '("Implementation"
|
|
"Passes"
|
|
"Unexpected passes"
|
|
"Failures"
|
|
"Expected failures"
|
|
"Skipped tests"))
|
|
,(make-row (list lines lines lines lines lines lines))))
|
|
|
|
(for-each
|
|
(lambda (scheme)
|
|
(let*
|
|
((scheme-dir (let ((path (string-append ".test-r7rs/" scheme)))
|
|
(when (not (file-exists? path)) (create-directory path))
|
|
path))
|
|
(scheme-log-dir (let ((path (string-append scheme-dir "/logs")))
|
|
(when (not (file-exists? path)) (create-directory path))
|
|
path))
|
|
(dockerfile-path (write-dockerfile scheme snow-pkgs akku-pkgs apt-pkgs))
|
|
(docker-tag
|
|
(string-append "test-r7rs-" scheme "-run"))
|
|
(docker-build-out
|
|
(string-append ".test-r7rs/tmp/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"))
|
|
(build-cmd
|
|
(docker-run-cmd docker-tag
|
|
(string-append
|
|
"compile-r7rs -I /akku/.akku/lib "
|
|
original-arguments
|
|
(string-append " > " build-out " 2>&1"))))
|
|
(run-out
|
|
(string-append ".test-r7rs/tmp/last-run"))
|
|
(run-cmd
|
|
(docker-run-cmd docker-tag
|
|
(string-append
|
|
"./" output-file
|
|
(string-append " > " run-out " 2>&1")))))
|
|
(when (file-exists? build-out) (delete-file build-out))
|
|
(when (file-exists? run-out) (delete-file run-out))
|
|
(when (not (= (system docker-build-cmd) 0))
|
|
(error (string-append "Docker container build failed, see output in "
|
|
docker-build-out)
|
|
docker-build-cmd))
|
|
(let* ((build-exit-code (number->string (system build-cmd)))
|
|
(run-exit-code (number->string (system run-cmd)))
|
|
(testname (if (and (string? run-exit-code)
|
|
(not (string=? run-exit-code "0")))
|
|
""
|
|
(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"))
|
|
(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)))
|
|
(unexpected-passes (cdr (assoc 'unexpected-passes short-test-results)))
|
|
(expected-failures (cdr (assoc 'expected-failures short-test-results)))
|
|
(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"))
|
|
|
|
(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:")
|
|
(newline)
|
|
(display scheme-build-out)
|
|
(display ": ")
|
|
(newline)
|
|
(cat scheme-build-out)
|
|
(exit 1)
|
|
)
|
|
(when (not (string=? run-exit-code "0"))
|
|
(display "Error on run:")
|
|
(newline)
|
|
(display scheme-run-out)
|
|
(display ": ")
|
|
(newline)
|
|
(cat scheme-run-out)
|
|
(exit 1)
|
|
))
|
|
(when stop-on-fail?
|
|
(when (and (string->number failures) (> (string->number failures) 0))
|
|
(let ((pretty-print (lambda (pair)
|
|
(display (car pair))
|
|
(display ": ")
|
|
(display (cdr pair))
|
|
(newline))))
|
|
(display "Test failures:")
|
|
(newline)
|
|
(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)))
|
|
test-results)
|
|
(exit 1)))))))
|
|
schemes)
|
|
|