diff --git a/.gitignore b/.gitignore index fc2264c..1a61af8 100644 --- a/.gitignore +++ b/.gitignore @@ -2,6 +2,7 @@ *.swo *.link compile-r7rs +test-r7rs test *.c *.o diff --git a/Dockerfile b/Dockerfile index a6d4fb9..f276f8b 100644 --- a/Dockerfile +++ b/Dockerfile @@ -1,27 +1,26 @@ FROM schemers/chicken:5 AS build -RUN mkdir -p ${HOME}/.snow && echo "()" > ${HOME}/.snow/config.scm RUN apt-get update && apt-get install -y \ gcc wget ca-certificates xz-utils make git libffi-dev unzip lbzip2 cmake \ g++ python3 locate zlib1g-dev -WORKDIR /build -ENV PATH=/opt/compile-r7rs/bin:${PATH} RUN git clone https://github.com/ashinn/chibi-scheme.git --depth=1 -RUN cd chibi-scheme && make DESTDIR=/opt/compile-r7rs/chibi all -RUN cd chibi-scheme && make DESTDIR=/opt/compile-r7rs/chibi install -RUN mkdir -p /opt/compile-r7rs/bin -RUN echo "#!/bin/sh" > /opt/compile-r7rs/bin/snow-chibi -RUN echo "PATH=${PATH}:/opt/compile-r7rs/chibi/usr/local/bin CHIBI_MODULE_PATH=/opt/compile-r7rs/chibi/usr/local/share/chibi:/opt/compile-r7rs/chibi/usr/local/lib/chibi LD_LIBRARY_PATH=/opt/compile-r7rs/chibi/usr/local/lib exec /opt/compile-r7rs/chibi/usr/local/bin/chibi-scheme -mchibi.snow.commands -mchibi.snow.interface -mchibi.snow.package -mchibi.snow.utils /opt/compile-r7rs/chibi/usr/local/bin/snow-chibi.scm \"\$@\"" >> /opt/compile-r7rs/bin/snow-chibi -RUN chmod +x /opt/compile-r7rs/bin/snow-chibi +WORKDIR /chibi-scheme +RUN make +RUN make install + +WORKDIR /build + ENV SCHEME=chicken RUN snow-chibi --impls=${SCHEME} --always-yes install "(foreign c)" RUN snow-chibi --impls=${SCHEME} --always-yes install "(srfi 170)" + COPY Makefile . COPY compile-r7rs.scm . +COPY test-r7rs.sh . COPY libs libs + RUN make PREFIX=/opt/compile-r7rs build-static RUN make PREFIX=/opt/compile-r7rs install FROM debian:trixie-slim COPY --from=build /opt/compile-r7rs /opt/compile-r7rs -ENV PATH=${PATH}:/opt/compile-r7rs/bin -ENV LD_LIBRARY_PATH=/opt/compile-r7rs/lib +ENV PATH=/opt/compile-r7rs/bin:${PATH} diff --git a/Dockerfile.test b/Dockerfile.test index 20e5e99..70adacf 100644 --- a/Dockerfile.test +++ b/Dockerfile.test @@ -18,4 +18,4 @@ FROM schemers/${IMAGE} COPY --from=build /var/cache/apt/archives /debs RUN dpkg -i /debs/*.deb COPY --from=local-build-compile-r7rs /opt/compile-r7rs /opt/compile-r7rs -ENV PATH=/opt/compile-r7rs/bin:${PATH} +ENV PATH=/opt/compile-r7rs/bin:${PATH}:/opt/compile-r7rs/snow-chibi/bin diff --git a/Makefile b/Makefile index 1f52bb8..842ef7b 100644 --- a/Makefile +++ b/Makefile @@ -7,19 +7,29 @@ ifeq "${SCHEME}" "chicken" DOCKERIMG="chicken:5" endif +STATIC_LIBS=libs.util.a libs.library-util.a libs.data.a libs.srfi-64-util.a + all: build -build: - echo "#!/bin/sh" > compile-r7rs - echo "chibi-scheme -A ${PREFIX}/lib/compile-r7rs ${PREFIX}/lib/compile-r7rs/main.scm \"\$$@\"" >> compile-r7rs +build: compile-r7rs test-r7rs -build-static: +libs.util.a: libs/util.sld libs/util.scm csc -R r7rs -X r7rs -static -c -J -unit libs.util -o libs.util.o libs/util.sld ar rcs libs.util.a libs.util.o + +libs.library-util.a: libs/library-util.sld libs/library-util.scm csc -R r7rs -X r7rs -static -c -J -unit libs.library-util -o libs.library-util.o libs/library-util.sld ar rcs libs.library-util.a libs.library-util.o + +libs.data.a: libs/data.sld libs/data.scm csc -R r7rs -X r7rs -static -c -J -unit libs.data -o libs.data.o libs/data.sld ar rcs libs.data.a libs.data.o + +libs.srfi-64-util.a: libs/srfi-64-util.sld libs/srfi-64-util.scm + csc -R r7rs -X r7rs -static -c -J -unit libs.srfi-64-util -o libs.srfi-64-util.o libs/srfi-64-util.sld + ar rcs libs.srfi-64-util.a libs.srfi-64-util.o + +compile-r7rs: compile-r7rs.scm ${STATIC_LIBS} csc -R r7rs -X r7rs -static \ -o compile-r7rs \ -uses libs.util \ @@ -29,18 +39,32 @@ build-static: -uses srfi-170 \ compile-r7rs.scm +test-r7rs: test-r7rs.scm ${STATIC_LIBS} + csc -R r7rs -X r7rs -static \ + -o test-r7rs \ + -uses libs.util \ + -uses libs.library-util \ + -uses libs.data \ + -uses libs.srfi-64-util \ + -uses foreign.c \ + -uses retropikzel.system \ + -uses srfi-170 \ + test-r7rs.scm + install: mkdir -p ${PREFIX}/bin mkdir -p ${PREFIX}/lib/compile-r7rs cp -r libs ${PREFIX}/lib/compile-r7rs/ - cp compile-r7rs.scm ${PREFIX}/lib/compile-r7rs/main.scm + cp compile-r7rs.scm ${PREFIX}/lib/compile-r7rs/compile-r7rs.scm install compile-r7rs ${PREFIX}/bin/compile-r7rs + cp compile-r7rs.scm ${PREFIX}/lib/compile-r7rs/test-r7rs.scm + install test-r7rs ${PREFIX}/bin/test-r7rs uninstall: rm -rf ${PREFIX}/lib/compile-r7rs rm -rf ${PREFIX}/bin/compile-r7rs -test-r6rs: +run-test-r6rs: rm -rf ${R6RSTMP} mkdir -p ${R6RSTMP} mkdir -p ${R6RSTMP}/libs @@ -54,11 +78,11 @@ test-r6rs: build-local-docker: docker build -f Dockerfile --tag=local-build-compile-r7rs . -test-r6rs-docker: build-local-docker +run-test-r6rs-docker: build-local-docker docker build -f Dockerfile.test --build-arg IMAGE=${DOCKERIMG} --build-arg SCHEME=${SCHEME} --tag=compile-r7rs-test-${SCHEME} . docker run -v "${PWD}":/workdir -w /workdir -t compile-r7rs-test-${SCHEME} sh -c "make && make install && make SCHEME=${SCHEME} test-r6rs" -test-r7rs: +run-test-r7rs: rm -rf ${R7RSTMP} mkdir -p ${R7RSTMP} mkdir -p ${R7RSTMP}/libs @@ -76,11 +100,13 @@ test-r7rs: -cd ${R7RSTMP} && ./main > compile-r7rs-test-result.txt 2>&1 @grep "Test successfull" ${R7RSTMP}/compile-r7rs-test-result.txt || (echo "Test failed, output: " && cat ${R7RSTMP}/compile-r7rs-test-result.txt && exit 1) -test-r7rs-docker: build-local-docker +run-test-r7rs-docker: build-local-docker docker build -f Dockerfile.test --build-arg IMAGE=${DOCKERIMG} --build-arg SCHEME=${SCHEME} --tag=compile-r7rs-test-${SCHEME} . docker run -v "${PWD}":/workdir -w /workdir -t compile-r7rs-test-${SCHEME} sh -c "make && make install && make SCHEME=${SCHEME} test-r7rs" clean: + rm -rf test-r7rs + rm -rf compile-r7rs find . -name "*.so" -delete find . -name "*.o*" -delete find . -name "*.a*" -delete diff --git a/compile-r7rs.scm b/compile-r7rs.scm index 7f85a3b..e291f82 100644 --- a/compile-r7rs.scm +++ b/compile-r7rs.scm @@ -9,38 +9,6 @@ (libs library-util) (srfi 170)) -(define r6rs-schemes '(chezscheme - guile - ikarus - ironscheme - larceny - loko - mosh - racket - sagittarius - ypsilon)) -(define r7rs-schemes '(chibi - chicken - cyclone - gambit - foment - gauche - guile - kawa - larceny - loko - meevax - mit-scheme - mosh - racket - sagittarius - skint - stklos - tr7 - ypsilon)) - -(define all-schemes (append r6rs-schemes r7rs-schemes)) - (when (member "--list-r6rs-schemes" (command-line)) (for-each (lambda (scheme) @@ -69,8 +37,7 @@ (string->symbol (get-environment-variable "COMPILE_R7RS")) #f)) (when (not scheme) (error "Environment variable COMPILE_R7RS not set.")) -(when (not (assoc scheme data)) - (error "Unsupported implementation" scheme)) +(when (not (assoc scheme data)) (error "Unsupported implementation" scheme)) (define compilation-target (if (get-environment-variable "TARGET") (get-environment-variable "TARGET") (cond-expand (windows "windows") diff --git a/dist/setup-compile-r7rs.exe b/dist/setup-compile-r7rs.exe deleted file mode 100755 index 6569aa4..0000000 Binary files a/dist/setup-compile-r7rs.exe and /dev/null differ diff --git a/libs/data.scm b/libs/data.scm new file mode 100644 index 0000000..1473821 --- /dev/null +++ b/libs/data.scm @@ -0,0 +1,578 @@ +(define data + `((chezscheme + (type . interpreter) + (command . ,(lambda (input-file output-file prepend-directories append-directories library-files r6rs?) + (apply string-append + `("scheme" + " " + ,(util-getenv "COMPILE_R7RS_CHEZSCHEME") + " " + "--quiet" + " " + ,@(map (lambda (item) + (string-append "--libdirs " " " item ":")) + (append prepend-directories append-directories)) + " " + "--program" + " " + ,input-file))))) + (chibi + (type . interpreter) + (command . ,(lambda (input-file output-file prepend-directories append-directories library-files r6rs?) + (apply string-append + `("chibi-scheme" + " " + ,(util-getenv "COMPILE_R7RS_CHIBI") + " " + ,@(map (lambda (item) + (string-append "-I" " " item " ")) + prepend-directories) + " " + ,@(map (lambda (item) + (string-append "-A" " " item " ")) + append-directories) + ,input-file))))) + (chicken + (type . compiler) + (library-command . ,(lambda (library-file prepend-directories append-directories r6rs?) + (let ((unit (string-append (if (string-starts-with? library-file "srfi") + (string-replace (string-cut-from-end library-file 4) #\/ #\-) + (string-replace (string-cut-from-end library-file 4) #\/ #\.)))) + (out (string-append (if (string-starts-with? library-file "srfi") + (string-replace (string-cut-from-end library-file 4) #\/ #\-) + (string-replace (string-cut-from-end library-file 4) #\/ #\.)) + ".o")) + (static-out (string-append (if (string-starts-with? library-file "srfi") + (string-replace (string-cut-from-end library-file 4) #\/ #\-) + (string-replace (string-cut-from-end library-file 4) #\/ #\.)) + ".a"))) + (apply string-append `("csc -R r7rs -X r7rs" + " " + ,(util-getenv "COMPILE_R7RS_CHICKEN") + " -static -c -J -o " + ,out + " " + ,(search-library-file (append prepend-directories append-directories) library-file) + " " + ,@(map (lambda (item) + (string-append "-I " item " ")) + (append append-directories + prepend-directories)) + "-unit " + ,unit + " " + "&&" + " " + "ar" + " " + "rcs" + " " + ,static-out + " " + ,out))))) + (command . ,(lambda (input-file output-file prepend-directories append-directories library-files r6rs?) + (apply string-append `("csc -R r7rs -X r7rs" + " " + ,(util-getenv "COMPILE_R7RS_CHICKEN") + " " + "-static" + " " + ,@(map (lambda (item) + (string-append "-I " item " ")) + (append append-directories prepend-directories)) + ,@(map (lambda (library-file) + (string-append "-uses " + (if (string-starts-with? library-file "srfi") + (string-replace (string-cut-from-end library-file 4) #\/ #\-) + (string-replace (string-cut-from-end library-file 4) #\/ #\.)) + " ")) + library-files) + + "-output-file" + " " + ,output-file + " " + ,input-file))))) + (cyclone + (type . compiler) + (library-command . ,(lambda (library-file prepend-directories append-directories r6rs?) + (apply string-append + `("cyclone" + " " + ,(util-getenv "COMPILE_R7RS_CYCLONE") + " " + ,@(map (lambda (item) (string-append "-I " item " ")) prepend-directories) + ,@(map (lambda (item) (string-append "-A " item " ")) append-directories) + ,(search-library-file (append prepend-directories + append-directories) + library-file))))) + (command . ,(lambda (input-file output-file prepend-directories append-directories library-files r6rs?) + (apply string-append + `("cyclone " + ,(util-getenv "COMPILE_R7RS_CYCLONE") + " " + ,@(map (lambda (item) (string-append "-I " item " ")) prepend-directories) + ,@(map (lambda (item) (string-append "-A " item " ")) append-directories) + ,input-file + ,(if (not (string=? (string-cut-from-end input-file 4) output-file)) + (string-append + " && " + "mv " + (string-cut-from-end input-file 4) + " " + output-file) + "")))))) + (foment + (type . interpreter) + (command . ,(lambda (input-file output-file prepend-directories append-directories library-files r6rs?) + (apply string-append + `("foment" + " " + ,(util-getenv "COMPILE_R7RS_FOMENT") + " " + ,@(map (lambda (item) + (string-append "-I" " " item " ")) + prepend-directories) + ,@(map (lambda (item) + (string-append "-A" " " item " ")) + append-directories) + " " + ,input-file))))) + (gambit + (type . compiler) + (library-command . ,(lambda (library-file prepend-directories append-directories r6rs?) + (apply string-append `("gsc -:r7rs -obj " + ,@(map (lambda (item) + (string-append item "/ ")) + (append prepend-directories + append-directories)) + ,(search-library-file (append append-directories + prepend-directories) + library-file))))) + (command . ,(lambda (input-file output-file prepend-directories append-directories library-files r6rs?) + (let ((real + (string-append (string-cut-from-end input-file 4) + "-real"))) + (apply + string-append + `("gsc -o " ,real + " -exe -nopreload " + ,@(map (lambda (item) + (string-append item "/ ")) + (append prepend-directories + append-directories)) + ,input-file + " && " + "printf '#!/bin/sh\\n./" ,real + " -:r7rs,search=" + ,@(map (lambda (item) + (string-append item "/ ")) + (append prepend-directories + append-directories)) + "" + "\\n" + "'" + " > " ,output-file + " && " + "chmod +x " ,output-file)))))) + (gauche + (type . interpreter) + (command . ,(lambda (input-file output-file prepend-directories append-directories library-files r6rs?) + (apply string-append + `("gosh" + " " + ,(util-getenv "COMPILE_R7RS_GAUCHE") + " " + "-r7" + " " + ,@(map (lambda (item) + (string-append "-I" " " item " ")) + prepend-directories) + ,@(map (lambda (item) + (string-append "-A" " " item " ")) + append-directories) + " " + ,input-file))))) + (guile + (type . interpreter) + (command . ,(lambda (input-file output-file prepend-directories append-directories library-files r6rs?) + (apply string-append + `("guile" + " " + ,(util-getenv "COMPILE_R7RS_GUILE") + " " + ,(if r6rs? "--r6rs" "--r7rs") + " " + ,@(map (lambda (item) + (string-append "-L" " " item " ")) + (append prepend-directories + append-directories)) + " " + ,input-file))))) + (husk + (type . compiler) + (command . ,(lambda (input-file output-file prepend-directories append-directories library-files r6rs?) + (apply string-append + `("huskc" + " " + ,(util-getenv "COMPILE_R7RS_HUSK") + " " + "-o" + " " + ,output-file + " " + ;,@(map (lambda (item) (string-append "-L" " " item " ")) prepend-directories) + ;,@(map (lambda (item) (string-append "-L" " " item " ")) append-directories) + " " + ,input-file))))) + (ikarus + (type . interpreter) + (command . ,(lambda (input-file output-file prepend-directories append-directories library-files r6rs?) + (apply string-append + `("export IKARUS_LIBRARY_PATH=" + ,@(map (lambda (item) + (string-append item ":")) + prepend-directories) + ,@(map (lambda (item) + (string-append item ":")) + append-directories) + "\n" + "ikarus" + " " + ,(util-getenv "COMPILE_R7RS_IKARUS") + " " + "--r6rs-script" + " " + ,input-file))))) + (ironscheme + (type . interpreter) + (command . ,(lambda (input-file output-file prepend-directories append-directories library-files r6rs?) + (apply string-append + `("ironscheme" + " " + ,(util-getenv "COMPILE_R7RS_IRONSCHEME") + " " + ,@(map (lambda (item) + (string-append "-I \"" item "\" ")) + prepend-directories) + ,@(map (lambda (item) + (string-append "-I \"" item "\" ")) + append-directories) + " " + ,input-file))))) + (kawa + (type . interpreter) + (command . ,(lambda (input-file output-file prepend-directories append-directories library-files r6rs?) + (apply string-append + `("kawa" + " " + ,(util-getenv "COMPILE_R7RS_KAWA") + " -J--add-exports=java.base/jdk.internal.foreign.abi=ALL-UNNAMED " + " -J--add-exports=java.base/jdk.internal.foreign.layout=ALL-UNNAMED " + " -J--add-exports=java.base/jdk.internal.foreign=ALL-UNNAMED " + " -J--enable-native-access=ALL-UNNAMED " + "-Dkawa.import.path=\"" + ,@(map (lambda (item) + (string-append item "/*.sld:")) + (append prepend-directories + append-directories + (list "/usr/local/share/kawa/lib"))) + "\" " + "--r7rs" + " " + ,input-file))))) + (larceny + (type . interpreter) + (command . ,(lambda (input-file output-file prepend-directories append-directories library-files r6rs?) + (apply string-append + `("larceny" + ,(util-getenv "COMPILE_R7RS_LARCENY") + " " + "-nobanner" + " " + "-quiet" + " " + "-utf8" + " " + ,(if r6rs? "-r6rs" "-r7rs") + " " + ,@(map (lambda (item) + (string-append "-I " item " ")) + prepend-directories) + ,@(map (lambda (item) + (string-append "-A " item " ")) + append-directories) + " " + "-program" + " " + ,input-file))))) + (loko + (type . compiler) + (command . ,(lambda (input-file output-file prepend-directories append-directories library-files r6rs?) + (let ((out (string-cut-from-end input-file 4))) + (apply string-append + `("LOKO_LIBRARY_PATH=" + ,@(map (lambda (item) + (string-append item ":")) + prepend-directories) + ,@(map (lambda (item) + (string-append item ":")) + append-directories) + " " + "loko " + " " + ,(util-getenv "COMPILE_R7RS_LOKO") + " " + ,(if r6rs? "-std=r6rs" "-std=r7rs") + " " + "--compile" + " " + ,input-file + " " + "&&" + " " + "mv" + " " + ,out + " " + ,output-file)))))) + (meevax + (type . interpreter) + (command . ,(lambda (input-file output-file prepend-directories append-directories library-files r6rs?) + (apply string-append + `("meevax" + " " + ,(util-getenv "COMPILE_R7RS_MEEVAX") + " " + ,@(map (lambda (item) + (string-append "-I" " " item " ")) + prepend-directories) + " " + ,@(map (lambda (item) + (string-append "-A" " " item " ")) + append-directories) + ,input-file))))) + (mit-scheme + (type . interpreter) + (command . ,(lambda (input-file output-file prepend-directories append-directories library-files r6rs?) + (apply string-append + `("mit-scheme" + " " + ,(util-getenv "COMPILE_R7RS_MIT_SCHEME") + " " + ,@(map + (lambda (item) + (string-append "--load " + (search-library-file (append append-directories + prepend-directories) + item) + " ")) + library-files) + " " + "--load" + " " + ,input-file + " " + "--eval \"(exit 0)\""))))) + (mosh + (type . interpreter) + (command . ,(lambda (input-file output-file prepend-directories append-directories library-files r6rs?) + (apply string-append + `("mosh" + " " + ,(util-getenv "COMPILE_R7RS_MOSH") + " " + ,@(map (lambda (item) (string-append "--loadpath=" item " ")) + (append append-directories prepend-directories)) + ;" " + ,input-file))))) + (picrin + (type . interpreter) + (command . ,(lambda (input-file output-file prepend-directories append-directories library-files r6rs?) + (apply string-append + `("picrin" + " " + ,(util-getenv "COMPILE_R7RS_PICRIN") + " " + ,@(map (lambda (item) + (string-append "-l " item " ")) + library-files) + " " + "-e" + " " + ,input-file))))) + (racket + (type . interpreter) + (library-command . ,(lambda (library-file prepend-directories append-directories r6rs?) + (let* ((full-path (search-library-file (append append-directories + prepend-directories) + library-file)) + (library-rkt-file (change-file-suffix full-path ".rkt"))) + (if r6rs? + (apply string-append + `("plt-r6rs" + " " + "--compile" + " " + ,library-file)) + (apply string-append + `("printf" + " " + "'#lang r7rs\\n" + "(import (except (scheme base) let let-values let*-values string-copy string-copy! string-for-each string-map string-fill! string->list))\\n" + "(include \"" + ,(path->filename library-file) + "\")\\n" + "'" + " " + ">" + " " + ,library-rkt-file)))))) + (command . ,(lambda (input-file output-file prepend-directories append-directories library-files r6rs?) + (let ((rkt-input-file (if (string=? input-file "") + "" + (change-file-suffix input-file ".rkt")))) + (when (not r6rs?) + (when (not (string=? rkt-input-file "")) + (when (file-exists? rkt-input-file) + (delete-file rkt-input-file)) + (with-output-to-file + rkt-input-file + (lambda () + (display "#lang r7rs") + (newline) + (display "(import (except (scheme base) let let-values let*-values string-copy string-copy! string-for-each string-map string-fill! string->list))") + (newline) + (display "(include \"") + (display (path->filename input-file)) + (display "\")") + (newline))))) + (apply string-append + `("racket " + ,(util-getenv "COMPILE_R7RS_RACKET") + " " + ;"-I " ,(if r6rs? "r6rs " "r7rs ") + ,@(map (lambda (item) + (string-append "-S " item " ")) + (append prepend-directories + append-directories)) + " " + ,(if r6rs? input-file rkt-input-file))))))) + (sagittarius + (type . interpreter) + (command . ,(lambda (input-file output-file prepend-directories append-directories library-files r6rs?) + (apply string-append + `("sash " + ,(util-getenv "COMPILE_R7RS_SAGITTARIUS") + ,(if r6rs? " -r6 " " -r7 ") + ,@(map (lambda (item) + (string-append " -L " item " ")) + prepend-directories) + ,@(map (lambda (item) + (string-append " -A " item " ")) + append-directories) + " " + ,input-file))))) + (skint + (type . interpreter) + (command . ,(lambda (input-file output-file prepend-directories append-directories library-files r6rs?) + (apply string-append + `("skint" + " " + ,(util-getenv "COMPILE_R7RS_SKINT") + " " + ,@(map (lambda (item) + (string-append "-I " item "/ ")) + prepend-directories) + ,@(map (lambda (item) + (string-append "-A " item "/ ")) + append-directories) + " " + ,input-file))))) + (stak + (type . interpreter) + (command . ,(lambda (input-file output-file prepend-directories append-directories library-files r6rs?) + (apply string-append + `("stak" + " " + ,(util-getenv "COMPILE_R7RS_STAK") + " " + ;,@(map (lambda (item) (string-append "-I " item " ")) prepend-directories) + ;,@(map (lambda (item) (string-append "-A " item " ")) append-directories) + " " + ,input-file))))) + (stklos + (type . interpreter) + (command . ,(lambda (input-file output-file prepend-directories append-directories library-files r6rs?) + (apply string-append + `("stklos" + " " + ,(util-getenv "COMPILE_R7RS_STKLOS") + " " + ,@(map (lambda (item) + (string-append "-I " item " ")) + prepend-directories) + ,@(map (lambda (item) + (string-append "-A " item " ")) + append-directories) + " " + ,input-file))))) + (tr7 + (type . interpreter) + (command . ,(lambda (input-file output-file prepend-directories append-directories library-files r6rs?) + (apply string-append + `("TR7_LIB_PATH=" + ,@(map (lambda (item) + (string-append item ":")) + prepend-directories) + ,@(map (lambda (item) + (string-append item ":")) + append-directories) + " " + "tr7i" + " " + ,(util-getenv "COMPILE_R7RS_TR7") + " " + ,input-file))))) + (vicare + (type . compiler) + (command . ,(lambda (input-file output-file prepend-directories append-directories library-files r6rs?) + (apply string-append + `("vicare" + " " + ,(util-getenv "COMPILE_R7RS_VICARE") + " " + ,@(map (lambda (item) + (string-append "-I " item " ")) + prepend-directories) + ,@(map (lambda (item) + (string-append "-A " item " ")) + append-directories) + " " + "--compile-program" + " " + ,input-file))))) + (ypsilon + (type . interpreter) + (command . ,(lambda (input-file output-file prepend-directories append-directories library-files r6rs?) + (apply string-append + `("ypsilon" + " " + ,(util-getenv "COMPILE_R7RS_YPSILON") + " " + ,(if r6rs? "--r6rs" "--r7rs") + " " + "--mute" + " " + "--quiet" + " " + ,@(map (lambda (item) + (string-append "--sitelib=" item " ")) + prepend-directories) + ,@(map (lambda (item) + (string-append "--sitelib=" item " ")) + append-directories) + " " + "--top-level-program" + " " + ,input-file))))))) diff --git a/libs/data.sld b/libs/data.sld index 910362d..1c9e782 100644 --- a/libs/data.sld +++ b/libs/data.sld @@ -7,582 +7,4 @@ (srfi 170) (libs util)) (export data) - (begin - (define data - `((chezscheme - (type . interpreter) - (command . ,(lambda (input-file output-file prepend-directories append-directories library-files r6rs?) - (apply string-append - `("scheme" - " " - ,(util-getenv "COMPILE_R7RS_CHEZSCHEME") - " " - "--quiet" - " " - ,@(map (lambda (item) - (string-append "--libdirs " " " item ":")) - (append prepend-directories append-directories)) - " " - "--program" - " " - ,input-file))))) - (chibi - (type . interpreter) - (command . ,(lambda (input-file output-file prepend-directories append-directories library-files r6rs?) - (apply string-append - `("chibi-scheme" - " " - ,(util-getenv "COMPILE_R7RS_CHIBI") - " " - ,@(map (lambda (item) - (string-append "-I" " " item " ")) - prepend-directories) - " " - ,@(map (lambda (item) - (string-append "-A" " " item " ")) - append-directories) - ,input-file))))) - (chicken - (type . compiler) - (library-command . ,(lambda (library-file prepend-directories append-directories r6rs?) - (let ((unit (string-append (if (string-starts-with? library-file "srfi") - (string-replace (string-cut-from-end library-file 4) #\/ #\-) - (string-replace (string-cut-from-end library-file 4) #\/ #\.)))) - (out (string-append (if (string-starts-with? library-file "srfi") - (string-replace (string-cut-from-end library-file 4) #\/ #\-) - (string-replace (string-cut-from-end library-file 4) #\/ #\.)) - ".o")) - (static-out (string-append (if (string-starts-with? library-file "srfi") - (string-replace (string-cut-from-end library-file 4) #\/ #\-) - (string-replace (string-cut-from-end library-file 4) #\/ #\.)) - ".a"))) - (apply string-append `("csc -R r7rs -X r7rs" - " " - ,(util-getenv "COMPILE_R7RS_CHICKEN") - " -static -c -J -o " - ,out - " " - ,(search-library-file (append prepend-directories append-directories) library-file) - " " - ,@(map (lambda (item) - (string-append "-I " item " ")) - (append append-directories - prepend-directories)) - "-unit " - ,unit - " " - "&&" - " " - "ar" - " " - "rcs" - " " - ,static-out - " " - ,out))))) - (command . ,(lambda (input-file output-file prepend-directories append-directories library-files r6rs?) - (apply string-append `("csc -R r7rs -X r7rs" - " " - ,(util-getenv "COMPILE_R7RS_CHICKEN") - " " - "-static" - " " - ,@(map (lambda (item) - (string-append "-I " item " ")) - (append append-directories prepend-directories)) - ,@(map (lambda (library-file) - (string-append "-uses " - (if (string-starts-with? library-file "srfi") - (string-replace (string-cut-from-end library-file 4) #\/ #\-) - (string-replace (string-cut-from-end library-file 4) #\/ #\.)) - " ")) - library-files) - - "-output-file" - " " - ,output-file - " " - ,input-file))))) - (cyclone - (type . compiler) - (library-command . ,(lambda (library-file prepend-directories append-directories r6rs?) - (apply string-append - `("cyclone" - " " - ,(util-getenv "COMPILE_R7RS_CYCLONE") - " " - ,@(map (lambda (item) (string-append "-I " item " ")) prepend-directories) - ,@(map (lambda (item) (string-append "-A " item " ")) append-directories) - ,(search-library-file (append prepend-directories - append-directories) - library-file))))) - (command . ,(lambda (input-file output-file prepend-directories append-directories library-files r6rs?) - (apply string-append - `("cyclone " - ,(util-getenv "COMPILE_R7RS_CYCLONE") - " " - ,@(map (lambda (item) (string-append "-I " item " ")) prepend-directories) - ,@(map (lambda (item) (string-append "-A " item " ")) append-directories) - ,input-file - ,(if (not (string=? (string-cut-from-end input-file 4) output-file)) - (string-append - " && " - "mv " - (string-cut-from-end input-file 4) - " " - output-file) - "")))))) - (foment - (type . interpreter) - (command . ,(lambda (input-file output-file prepend-directories append-directories library-files r6rs?) - (apply string-append - `("foment" - " " - ,(util-getenv "COMPILE_R7RS_FOMENT") - " " - ,@(map (lambda (item) - (string-append "-I" " " item " ")) - prepend-directories) - ,@(map (lambda (item) - (string-append "-A" " " item " ")) - append-directories) - " " - ,input-file))))) - (gambit - (type . compiler) - (library-command . ,(lambda (library-file prepend-directories append-directories r6rs?) - (apply string-append `("gsc -:r7rs -obj " - ,@(map (lambda (item) - (string-append item "/ ")) - (append prepend-directories - append-directories)) - ,(search-library-file (append append-directories - prepend-directories) - library-file))))) - (command . ,(lambda (input-file output-file prepend-directories append-directories library-files r6rs?) - (let ((real - (string-append (string-cut-from-end input-file 4) - "-real"))) - (apply - string-append - `("gsc -o " ,real - " -exe -nopreload " - ,@(map (lambda (item) - (string-append item "/ ")) - (append prepend-directories - append-directories)) - ,input-file - " && " - "printf '#!/bin/sh\\n./" ,real - " -:r7rs,search=" - ,@(map (lambda (item) - (string-append item "/ ")) - (append prepend-directories - append-directories)) - "" - "\\n" - "'" - " > " ,output-file - " && " - "chmod +x " ,output-file)))))) - (gauche - (type . interpreter) - (command . ,(lambda (input-file output-file prepend-directories append-directories library-files r6rs?) - (apply string-append - `("gosh" - " " - ,(util-getenv "COMPILE_R7RS_GAUCHE") - " " - "-r7" - " " - ,@(map (lambda (item) - (string-append "-I" " " item " ")) - prepend-directories) - ,@(map (lambda (item) - (string-append "-A" " " item " ")) - append-directories) - " " - ,input-file))))) - (guile - (type . interpreter) - (command . ,(lambda (input-file output-file prepend-directories append-directories library-files r6rs?) - (apply string-append - `("guile" - " " - ,(util-getenv "COMPILE_R7RS_GUILE") - " " - ,(if r6rs? "--r6rs" "--r7rs") - " " - ,@(map (lambda (item) - (string-append "-L" " " item " ")) - (append prepend-directories - append-directories)) - " " - ,input-file))))) - (husk - (type . compiler) - (command . ,(lambda (input-file output-file prepend-directories append-directories library-files r6rs?) - (apply string-append - `("huskc" - " " - ,(util-getenv "COMPILE_R7RS_HUSK") - " " - "-o" - " " - ,output-file - " " - ;,@(map (lambda (item) (string-append "-L" " " item " ")) prepend-directories) - ;,@(map (lambda (item) (string-append "-L" " " item " ")) append-directories) - " " - ,input-file))))) - (ikarus - (type . interpreter) - (command . ,(lambda (input-file output-file prepend-directories append-directories library-files r6rs?) - (apply string-append - `("export IKARUS_LIBRARY_PATH=" - ,@(map (lambda (item) - (string-append item ":")) - prepend-directories) - ,@(map (lambda (item) - (string-append item ":")) - append-directories) - "\n" - "ikarus" - " " - ,(util-getenv "COMPILE_R7RS_IKARUS") - " " - "--r6rs-script" - " " - ,input-file))))) - (ironscheme - (type . interpreter) - (command . ,(lambda (input-file output-file prepend-directories append-directories library-files r6rs?) - (apply string-append - `("ironscheme" - " " - ,(util-getenv "COMPILE_R7RS_IRONSCHEME") - " " - ,@(map (lambda (item) - (string-append "-I \"" item "\" ")) - prepend-directories) - ,@(map (lambda (item) - (string-append "-I \"" item "\" ")) - append-directories) - " " - ,input-file))))) - (kawa - (type . interpreter) - (command . ,(lambda (input-file output-file prepend-directories append-directories library-files r6rs?) - (apply string-append - `("kawa" - " " - ,(util-getenv "COMPILE_R7RS_KAWA") - " -J--add-exports=java.base/jdk.internal.foreign.abi=ALL-UNNAMED " - " -J--add-exports=java.base/jdk.internal.foreign.layout=ALL-UNNAMED " - " -J--add-exports=java.base/jdk.internal.foreign=ALL-UNNAMED " - " -J--enable-native-access=ALL-UNNAMED " - "-Dkawa.import.path=\"" - ,@(map (lambda (item) - (string-append item "/*.sld:")) - (append prepend-directories - append-directories - (list "/usr/local/share/kawa/lib"))) - "\" " - "--r7rs" - " " - ,input-file))))) - (larceny - (type . interpreter) - (command . ,(lambda (input-file output-file prepend-directories append-directories library-files r6rs?) - (apply string-append - `("larceny" - ,(util-getenv "COMPILE_R7RS_LARCENY") - " " - "-nobanner" - " " - "-quiet" - " " - "-utf8" - " " - ,(if r6rs? "-r6rs" "-r7rs") - " " - ,@(map (lambda (item) - (string-append "-I " item " ")) - prepend-directories) - ,@(map (lambda (item) - (string-append "-A " item " ")) - append-directories) - " " - "-program" - " " - ,input-file))))) - (loko - (type . compiler) - (command . ,(lambda (input-file output-file prepend-directories append-directories library-files r6rs?) - (let ((out (string-cut-from-end input-file 4))) - (apply string-append - `("LOKO_LIBRARY_PATH=" - ,@(map (lambda (item) - (string-append item ":")) - prepend-directories) - ,@(map (lambda (item) - (string-append item ":")) - append-directories) - " " - "loko " - " " - ,(util-getenv "COMPILE_R7RS_LOKO") - " " - ,(if r6rs? "-std=r6rs" "-std=r7rs") - " " - "--compile" - " " - ,input-file - " " - "&&" - " " - "mv" - " " - ,out - " " - ,output-file)))))) - (meevax - (type . interpreter) - (command . ,(lambda (input-file output-file prepend-directories append-directories library-files r6rs?) - (apply string-append - `("meevax" - " " - ,(util-getenv "COMPILE_R7RS_MEEVAX") - " " - ,@(map (lambda (item) - (string-append "-I" " " item " ")) - prepend-directories) - " " - ,@(map (lambda (item) - (string-append "-A" " " item " ")) - append-directories) - ,input-file))))) - (mit-scheme - (type . interpreter) - (command . ,(lambda (input-file output-file prepend-directories append-directories library-files r6rs?) - (apply string-append - `("mit-scheme" - " " - ,(util-getenv "COMPILE_R7RS_MIT_SCHEME") - " " - ,@(map - (lambda (item) - (string-append "--load " - (search-library-file (append append-directories - prepend-directories) - item) - " ")) - library-files) - " " - "--load" - " " - ,input-file - " " - "--eval \"(exit 0)\""))))) - (mosh - (type . interpreter) - (command . ,(lambda (input-file output-file prepend-directories append-directories library-files r6rs?) - (apply string-append - `("mosh" - " " - ,(util-getenv "COMPILE_R7RS_MOSH") - " " - ,@(map (lambda (item) (string-append "--loadpath=" item " ")) - (append append-directories prepend-directories)) - ;" " - ,input-file))))) - (picrin - (type . interpreter) - (command . ,(lambda (input-file output-file prepend-directories append-directories library-files r6rs?) - (apply string-append - `("picrin" - " " - ,(util-getenv "COMPILE_R7RS_PICRIN") - " " - ,@(map (lambda (item) - (string-append "-l " item " ")) - library-files) - " " - "-e" - " " - ,input-file))))) - (racket - (type . interpreter) - (library-command . ,(lambda (library-file prepend-directories append-directories r6rs?) - (let* ((full-path (search-library-file (append append-directories - prepend-directories) - library-file)) - (library-rkt-file (change-file-suffix full-path ".rkt"))) - (if r6rs? - (apply string-append - `("plt-r6rs" - " " - "--compile" - " " - ,library-file)) - (apply string-append - `("printf" - " " - "'#lang r7rs\\n" - "(import (except (scheme base) let let-values let*-values string-copy string-copy! string-for-each string-map string-fill! string->list))\\n" - "(include \"" - ,(path->filename library-file) - "\")\\n" - "'" - " " - ">" - " " - ,library-rkt-file)))))) - (command . ,(lambda (input-file output-file prepend-directories append-directories library-files r6rs?) - (let ((rkt-input-file (if (string=? input-file "") - "" - (change-file-suffix input-file ".rkt")))) - (when (not r6rs?) - (when (not (string=? rkt-input-file "")) - (when (file-exists? rkt-input-file) - (delete-file rkt-input-file)) - (with-output-to-file - rkt-input-file - (lambda () - (display "#lang r7rs") - (newline) - (display "(import (except (scheme base) let let-values let*-values string-copy string-copy! string-for-each string-map string-fill! string->list))") - (newline) - (display "(include \"") - (display (path->filename input-file)) - (display "\")") - (newline))))) - (apply string-append - `("racket " - ,(util-getenv "COMPILE_R7RS_RACKET") - " " - ;"-I " ,(if r6rs? "r6rs " "r7rs ") - ,@(map (lambda (item) - (string-append "-S " item " ")) - (append prepend-directories - append-directories)) - " " - ,(if r6rs? input-file rkt-input-file))))))) - (sagittarius - (type . interpreter) - (command . ,(lambda (input-file output-file prepend-directories append-directories library-files r6rs?) - (apply string-append - `("sash " - ,(util-getenv "COMPILE_R7RS_SAGITTARIUS") - ,(if r6rs? " -r6 " " -r7 ") - ,@(map (lambda (item) - (string-append "-L " item " ")) - prepend-directories) - ,@(map (lambda (item) - (string-append "-A " item " ")) - append-directories) - " " - ,input-file))))) - (skint - (type . interpreter) - (command . ,(lambda (input-file output-file prepend-directories append-directories library-files r6rs?) - (apply string-append - `("skint" - " " - ,(util-getenv "COMPILE_R7RS_SKINT") - " " - ,@(map (lambda (item) - (string-append "-I " item "/ ")) - prepend-directories) - ,@(map (lambda (item) - (string-append "-A " item "/ ")) - append-directories) - " " - ,input-file))))) - (stak - (type . interpreter) - (command . ,(lambda (input-file output-file prepend-directories append-directories library-files r6rs?) - (apply string-append - `("stak" - " " - ,(util-getenv "COMPILE_R7RS_STAK") - " " - ;,@(map (lambda (item) (string-append "-I " item " ")) prepend-directories) - ;,@(map (lambda (item) (string-append "-A " item " ")) append-directories) - " " - ,input-file))))) - (stklos - (type . interpreter) - (command . ,(lambda (input-file output-file prepend-directories append-directories library-files r6rs?) - (apply string-append - `("stklos" - " " - ,(util-getenv "COMPILE_R7RS_STKLOS") - " " - ,@(map (lambda (item) - (string-append "-I " item " ")) - prepend-directories) - ,@(map (lambda (item) - (string-append "-A " item " ")) - append-directories) - " " - ,input-file))))) - (tr7 - (type . interpreter) - (command . ,(lambda (input-file output-file prepend-directories append-directories library-files r6rs?) - (apply string-append - `("TR7_LIB_PATH=" - ,@(map (lambda (item) - (string-append item ":")) - prepend-directories) - ,@(map (lambda (item) - (string-append item ":")) - append-directories) - " " - "tr7i" - " " - ,(util-getenv "COMPILE_R7RS_TR7") - " " - ,input-file))))) - (vicare - (type . compiler) - (command . ,(lambda (input-file output-file prepend-directories append-directories library-files r6rs?) - (apply string-append - `("vicare" - " " - ,(util-getenv "COMPILE_R7RS_VICARE") - " " - ,@(map (lambda (item) - (string-append "-I " item " ")) - prepend-directories) - ,@(map (lambda (item) - (string-append "-A " item " ")) - append-directories) - " " - "--compile-program" - " " - ,input-file))))) - (ypsilon - (type . interpreter) - (command . ,(lambda (input-file output-file prepend-directories append-directories library-files r6rs?) - (apply string-append - `("ypsilon" - " " - ,(util-getenv "COMPILE_R7RS_YPSILON") - " " - ,(if r6rs? "--r6rs" "--r7rs") - " " - "--mute" - " " - "--quiet" - " " - ,@(map (lambda (item) - (string-append "--sitelib=" item " ")) - prepend-directories) - ,@(map (lambda (item) - (string-append "--sitelib=" item " ")) - append-directories) - " " - "--top-level-program" - " " - ,input-file))))))))) + (include "data.scm")) diff --git a/libs/srfi-64-util.scm b/libs/srfi-64-util.scm new file mode 100644 index 0000000..136765e --- /dev/null +++ b/libs/srfi-64-util.scm @@ -0,0 +1,84 @@ + +(define (get-number text) + (let + ((result + (trim + (string-reverse + (string-copy (string-reverse text) 0 4))))) + (if (not result) + "" + result))) + +(define (srfi-64-output-read text) + (let ((result (list))) + (for-each + (lambda (line) + (cond + ((not (string? line)) #f) + ((string-starts-with? line "# of expected passes") + (set! result (append result + (list (cons 'expected-passes + (get-number line)))))) + ((string-starts-with? line "# of unexpected passes") + (set! result (append result + (list (cons 'unexpected-passes + (get-number line)))))) + ((string-starts-with? line "# of expected failures") + (set! result (append result + (list (cons 'expected-failures + (get-number line)))))) + ((string-starts-with? line "# of failures") + (set! result (append result + (list (cons 'failures + (get-number line)))))) + ((string-starts-with? line "# of skipped") + (set! result (append result + (list (cons 'skipped + (get-number line)))))))) + (string-split text #\newline)) + (when (not (assoc 'expected-passes result)) + (set! result (append result (list (cons 'expected-passes ""))))) + (when (not (assoc 'unexpected-passes result)) + (set! result (append result (list (cons 'unexpected-passes ""))))) + (when (not (assoc 'expected-failures result)) + (set! result (append result (list (cons 'expected-failures ""))))) + (when (not (assoc 'failures result)) + (set! result (append result (list (cons 'failures ""))))) + (when (not (assoc 'skipped result)) + (set! result (append result (list (cons 'skipped ""))))) + result)) + +(define (line->data line) + (let ((pair (apply cons (map trim-both (string-split line #\:))))) + (cons (string->symbol (car pair)) (cdr pair)))) + +(define (read-test-data) + (letrec + ((looper + (lambda (results line count) + (if (>= count 7) + results + (looper (append results + (if (string-starts-with? line "Test end") + (list) + (list (line->data line)))) + (read-line) + (+ count 1)))))) + (looper (list) (read-line) 0))) + +(define (srfi-64-log-results path) + (letrec + ((looper + (lambda (results group line) + (cond + ((eof-object? line) results) + ((string-starts-with? line "Group begin:") + (looper results `(group . ,(cdr (line->data line))) (read-line))) + ((string-starts-with? line "Test begin:") + (looper (append results (list (append (list group) (read-test-data)))) + group + (read-line))) + (else (looper results group (read-line))))))) + (with-input-from-file + path + (lambda () (looper (list) '(group . "") (read-line)))))) diff --git a/libs/srfi-64-util.sld b/libs/srfi-64-util.sld new file mode 100644 index 0000000..5f3aac6 --- /dev/null +++ b/libs/srfi-64-util.sld @@ -0,0 +1,10 @@ +(define-library + (libs srfi-64-util) + (import (scheme base) + (scheme read) + (scheme write) + (scheme file) + (libs util)) + (export srfi-64-output-read + srfi-64-log-results) + (include "srfi-64-util.scm")) diff --git a/libs/util.scm b/libs/util.scm new file mode 100644 index 0000000..dcd6962 --- /dev/null +++ b/libs/util.scm @@ -0,0 +1,213 @@ +(define (echo text) (display text) (newline)) +(define (cat path) (for-each (lambda (line) (echo line)) (file->list path))) +(define r6rs-schemes '(chezscheme + guile + ikarus + ironscheme + larceny + loko + mosh + racket + sagittarius + ypsilon)) + +(define r7rs-schemes '(chibi + chicken + cyclone + gambit + foment + gauche + guile + kawa + larceny + loko + meevax + mit-scheme + mosh + racket + sagittarius + skint + stklos + tr7 + ypsilon)) + +(define all-schemes (append r6rs-schemes r7rs-schemes)) + + +(define util-getenv + (lambda (name) + (if (get-environment-variable name) + (get-environment-variable name) + ""))) + +(define dirname + (lambda (path) + (letrec ((looper (lambda (dirpath) + (cond ((= (string-length dirpath) 0) dirpath) + ((char=? (string-ref dirpath 0) #\/) (string-copy dirpath 1)) + (else (looper (string-copy dirpath 1))))))) + (string-reverse (looper (string-reverse path)))))) + +(define string-replace + (lambda (string-content replace with) + (string-map (lambda (c) + (if (char=? c replace) + with c)) + string-content))) + +(define string-replace-one + (lambda (string-content replace with) + (let ((replaced? #f)) + (string-map (lambda (c) + (if (and (not replaced?) + (char=? c replace)) + with c)) + string-content)))) + +(define string-replace-one-from-end + (lambda (string-content replace with) + (let ((replaced? #f)) + (list->string (reverse (map (lambda (c) + (if (and (not replaced?) + (char=? c replace)) + with c)) + (reverse (string->list string-content)))))))) + +(define string-ends-with? + (lambda (string-content end) + (if (and (>= (string-length string-content) (string-length end)) + (string=? (string-copy string-content + (- (string-length string-content) + (string-length end))) + end)) + #t + #f))) + +(define string-starts-with? + (lambda (string-content start) + (if (and (>= (string-length string-content) (string-length start)) + (string=? (string-copy string-content + 0 + (string-length start)) + start)) + #t + #f))) + +(define string-cut-from-end + (lambda (string-content cut-length) + (string-copy string-content + 0 + (- (string-length string-content) cut-length)))) + + +(define string-find + (lambda (string-content character) + (letrec* ((string-list (string->list string-content)) + (looper (lambda (c rest index) + (cond ((null? rest) #f) + ((char=? c character) index) + (else (looper (car rest) + (cdr rest) + (+ index 1))))))) + (looper (car string-list) + (cdr string-list) + 0)))) + +(define string-reverse + (lambda (string-content) + (list->string (reverse (string->list string-content))))) + +(define (string-split text c) + (letrec* ((looper (lambda (previous rest result) + (if (null? rest) + (append result (list previous)) + (if (char=? (car rest) c) + (looper (list) + (cdr rest) + (append result (list previous))) + (looper (append previous (list (car rest))) + (cdr rest) + result))))) + (chars (string->list text))) + (map list->string (looper (list) chars (list))))) + +(define path->filename + (lambda (path) + (let ((last-slash-index (string-find (string-reverse path) #\/))) + (cond ((not last-slash-index) path) + (else (string-copy path (- (string-length path) + last-slash-index))))))) + +(define change-file-suffix + (lambda (path new-suffix) + (let ((last-dot-index (string-find (string-reverse path) #\.))) + (cond ((not last-dot-index) path) + (else (string-append (string-copy path 0 + (- (string-length path) + last-dot-index + 1)) + new-suffix)))))) + +(define string-join + (lambda (string-list between) + (apply string-append + (let ((index 0) + (size (length string-list))) + (map + (lambda (item) + (cond ((= index 0) item) + ((= index size) item) + (else (string-append item between)))) + string-list))))) + +(define search-library-file + (lambda (directories path) + (let ((result path)) + (for-each + (lambda (directory) + (let ((full-path (string-append directory "/" path))) + (when (file-exists? full-path) + (set! result full-path)))) + directories) + result))) + +(define (slurp path) + (letrec* ((looper (lambda (result line) + (if (eof-object? line) + result + (looper (append result (list line)) (read-line)))))) + (with-input-from-file + path + (lambda () + (apply string-append + (map (lambda (line) + (string-append line (string #\newline))) + (looper (list) (read-line)))))))) + +(define (file->list path) + (letrec* ((looper (lambda (result line) + (if (eof-object? line) + result + (looper (append result (list line)) (read-line)))))) + (with-input-from-file + path + (lambda () + (looper (list) (read-line)))))) + +(define (trim text) + (cond ((not (string? text)) "") + ((string=? text "") "") + (else + (letrec* ((looper (lambda (text) + (if (or (null? text) + (not (char-whitespace? (car text)))) + (list->string text) + (looper (cdr text)))))) + (looper (string->list text)))))) + +(define (trim-end text) + (string-reverse (trim (string-reverse text)))) + +(define (trim-both text) + (let ((trimmed (trim text))) + (string-reverse (trim (string-reverse trimmed))))) diff --git a/libs/util.sld b/libs/util.sld index e9c86a6..8a522a9 100644 --- a/libs/util.sld +++ b/libs/util.sld @@ -3,141 +3,30 @@ (import (scheme base) (scheme write) (scheme file) + (scheme char) (scheme process-context) (foreign c)) - (export string-replace + (export echo + cat + r6rs-schemes + r7rs-schemes + all-schemes + string-replace string-ends-with? string-starts-with? string-cut-from-end string-find string-reverse + string-split path->filename change-file-suffix string-join util-getenv dirname - search-library-file) - (begin - - (define util-getenv - (lambda (name) - (if (get-environment-variable name) - (get-environment-variable name) - ""))) - - (define dirname - (lambda (path) - (letrec ((looper (lambda (dirpath) - (cond ((= (string-length dirpath) 0) dirpath) - ((char=? (string-ref dirpath 0) #\/) (string-copy dirpath 1)) - (else (looper (string-copy dirpath 1))))))) - (string-reverse (looper (string-reverse path)))))) - - (define string-replace - (lambda (string-content replace with) - (string-map (lambda (c) - (if (char=? c replace) - with c)) - string-content))) - - (define string-replace-one - (lambda (string-content replace with) - (let ((replaced? #f)) - (string-map (lambda (c) - (if (and (not replaced?) - (char=? c replace)) - with c)) - string-content)))) - - (define string-replace-one-from-end - (lambda (string-content replace with) - (let ((replaced? #f)) - (list->string (reverse (map (lambda (c) - (if (and (not replaced?) - (char=? c replace)) - with c)) - (reverse (string->list string-content)))))))) - - (define string-ends-with? - (lambda (string-content end) - (if (and (>= (string-length string-content) (string-length end)) - (string=? (string-copy string-content - (- (string-length string-content) - (string-length end))) - end)) - #t - #f))) - - (define string-starts-with? - (lambda (string-content start) - (if (and (>= (string-length string-content) (string-length start)) - (string=? (string-copy string-content - 0 - (string-length start)) - start)) - #t - #f))) - - (define string-cut-from-end - (lambda (string-content cut-length) - (string-copy string-content - 0 - (- (string-length string-content) cut-length)))) - - - (define string-find - (lambda (string-content character) - (letrec* ((string-list (string->list string-content)) - (looper (lambda (c rest index) - (cond ((null? rest) #f) - ((char=? c character) index) - (else (looper (car rest) - (cdr rest) - (+ index 1))))))) - (looper (car string-list) - (cdr string-list) - 0)))) - - (define string-reverse - (lambda (string-content) - (list->string (reverse (string->list string-content))))) - - (define path->filename - (lambda (path) - (let ((last-slash-index (string-find (string-reverse path) #\/))) - (cond ((not last-slash-index) path) - (else (string-copy path (- (string-length path) - last-slash-index))))))) - - (define change-file-suffix - (lambda (path new-suffix) - (let ((last-dot-index (string-find (string-reverse path) #\.))) - (cond ((not last-dot-index) path) - (else (string-append (string-copy path 0 - (- (string-length path) - last-dot-index - 1)) - new-suffix)))))) - - (define string-join - (lambda (string-list between) - (apply string-append - (let ((index 0) - (size (length string-list))) - (map - (lambda (item) - (cond ((= index 0) item) - ((= index size) item) - (else (string-append item between)))) - string-list))))) - - (define search-library-file - (lambda (directories path) - (let ((result path)) - (for-each - (lambda (directory) - (let ((full-path (string-append directory "/" path))) - (when (file-exists? full-path) - (set! result full-path)))) - directories) - result))))) + search-library-file + slurp + file->list + trim + trim-end + trim-both) + (include "util.scm")) diff --git a/test-r7rs.scm b/test-r7rs.scm new file mode 100644 index 0000000..4a6f05f --- /dev/null +++ b/test-r7rs.scm @@ -0,0 +1,321 @@ +(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) +