diff --git a/Dockerfile b/Dockerfile index aa15812..b28ab41 100644 --- a/Dockerfile +++ b/Dockerfile @@ -1,55 +1,24 @@ FROM debian:trixie-slim AS build -RUN apt-get update && apt-get install -y build-essential ca-certificates wget \ - git autoconf automake libtool texinfo +RUN apt-get update && apt-get install -y make gcc gcc chicken-bin git +RUN chicken-install r7rs WORKDIR /build RUN git clone https://github.com/ashinn/chibi-scheme.git --depth=1 chibi WORKDIR /build/chibi -RUN make DESTDIR=/opt/compile-r7rs -RUN make DESTDIR=/opt/compile-r7rs install - -WORKDIR /build -RUN echo "#!/bin/sh" > /opt/compile-r7rs/snow-chibi -RUN echo "PATH=/opt/compile-r7rs/usr/local/bin:${PATH} LD_LIBRARY_PATH=/opt/compile-r7rs/usr/local/lib:/opt/compile-r7rs/usr/local/lib/chibi CHIBI_MODULE_PATH=/opt/compile-r7rs/usr/local/share/chibi:/opt/compile-r7rs/usr/local/lib/chibi /opt/compile-r7rs/usr/local/bin/chibi-scheme -I /opt/compile-r7rs/usr/local/share/chibi -I /opt/compile-r7rs/usr/local/lib/chibi -I /opt/compile/snow -mchibi.snow.commands -mchibi.snow.interface -mchibi.snow.package -mchibi.snow.utils /opt/compile-r7rs/usr/local/bin/snow-chibi.scm \"\$@\"" >> /opt/compile-r7rs/snow-chibi -RUN chmod +x /opt/compile-r7rs/snow-chibi - -ENV PATH=/opt/compile-r7rs:${PATH} - -RUN git clone https://github.com/libffi/libffi.git --branch=v3.5.2 --depth=1 -WORKDIR /build/libffi -RUN sh autogen.sh -RUN ./configure --prefix=/usr/local -RUN make DESTDIR=/opt/compile-r7rs PREFIX=/usr/local -RUN make DESTDIR=/opt/compile-r7rs PREFIX=/usr/local install +RUN make +RUN make install WORKDIR /build RUN mkdir -p ${HOME}/.snow && echo "()" > ${HOME}/.snow/config.scm -RUN snow-chibi install \ - --cflags="-I/opt/compile-r7rs/usr/local/include -L/opt/compile-r7rs/usr/local/lib" \ - --install-source-dir=/opt/compile-r7rs/usr/local/share/chibi \ - --install-library-dir=/opt/compile-r7rs/usr/local/lib/chibi \ - "(foreign c)" -RUN snow-chibi install --install-source-dir=/opt/compile-r7rs/usr/local/share/chibi --install-library-dir=/opt/compile-r7rs/usr/local/lib/chibi "(retropikzel system)" -RUN snow-chibi install --install-source-dir=/opt/compile-r7rs/usr/local/share/chibi --install-library-dir=/opt/compile-r7rs/usr/local/lib/chibi "(srfi 170)" - -COPY compile-r7rs.scm /opt/compile-r7rs/ -COPY test-r7rs.scm /opt/compile-r7rs/ -RUN mkdir -p /opt/compile-r7rs/usr/local/share/chibi/libs -COPY libs/*.sld /opt/compile-r7rs/usr/local/share/chibi/libs/ -COPY libs/*.scm /opt/compile-r7rs/usr/local/share/chibi/libs/ - -RUN echo "#!/bin/sh" > /opt/compile-r7rs/compile-r7rs -RUN echo "LD_LIBRARY_PATH=/opt/compile-r7rs/usr/local/lib:/opt/compile-r7rs/usr/local/lib/chibi CHIBI_MODULE_PATH=/opt/compile-r7rs/usr/local/share/chibi:/opt/compile-r7rs/usr/local/lib/chibi /opt/compile-r7rs/usr/local/bin/chibi-scheme -mchibi.snow.commands -mchibi.snow.interface -mchibi.snow.package -mchibi.snow.utils /opt/compile-r7rs/compile-r7rs.scm \"\$@\"" >> /opt/compile-r7rs/compile-r7rs -RUN chmod +x /opt/compile-r7rs/compile-r7rs - -RUN echo "#!/bin/sh" > /opt/compile-r7rs/test-r7rs -RUN echo "LD_LIBRARY_PATH=/opt/compile-r7rs/usr/local/lib:/opt/compile-r7rs/usr/local/lib/chibi CHIBI_MODULE_PATH=/opt/compile-r7rs/usr/local/share/chibi:/opt/compile-r7rs/usr/local/lib/chibi /opt/compile-r7rs/usr/local/bin/chibi-scheme -mchibi.snow.commands -mchibi.snow.interface -mchibi.snow.package -mchibi.snow.utils /opt/compile-r7rs/test-r7rs.scm \"\$@\"" >> /opt/compile-r7rs/test-r7rs -RUN chmod +x /opt/compile-r7rs/test-r7rs +RUN snow-chibi install --always-yes --impls=chicken "(foreign c)" +RUN snow-chibi install --always-yes --impls=chicken "(srfi 170)" +COPY Makefile . +COPY compile-r7rs.scm . +COPY libs ./libs +RUN make PREFIX=/opt/compile-r7rs build-chicken +RUN make PREFIX=/opt/compile-r7rs install FROM debian:trixie-slim -RUN apt-get update && apt-get install -y libffi-dev docker.io locate COPY --from=build /opt/compile-r7rs /opt/compile-r7rs -RUN updatedb -RUN locate foreign-c.so ENV PATH=/opt/compile-r7rs:${PATH} diff --git a/Dockerfile.alpine b/Dockerfile.alpine new file mode 100644 index 0000000..02f87b4 --- /dev/null +++ b/Dockerfile.alpine @@ -0,0 +1,24 @@ +FROM alpine AS build +RUN apk add make gcc chicken git +RUN chicken-install r7rs + +WORKDIR /build +RUN git clone https://github.com/ashinn/chibi-scheme.git --depth=1 chibi + +WORKDIR /build/chibi +RUN make +RUN make install + +WORKDIR /build +RUN mkdir -p ${HOME}/.snow && echo "()" > ${HOME}/.snow/config.scm +RUN snow-chibi install --always-yes --impls=chicken "(foreign c)" +RUN snow-chibi install --always-yes --impls=chicken "(srfi 170)" +COPY Makefile . +COPY compile-r7rs.scm . +COPY libs ./libs +RUN make PREFIX=/opt/compile-r7rs build-chicken +RUN make PREFIX=/opt/compile-r7rs install + +FROM alpine +COPY --from=build /opt/compile-r7rs /opt/compile-r7rs +ENV PATH=/opt/compile-r7rs:${PATH} diff --git a/Makefile b/Makefile index 89eae4a..d91ab6f 100644 --- a/Makefile +++ b/Makefile @@ -9,21 +9,49 @@ endif STATIC_LIBS=libs.util.a libs.library-util.a libs.data.a libs.srfi-64-util.a -all: build - -build: +build-chibi: echo "#!/bin/sh" > compile-r7rs echo "chibi-scheme -A ${PREFIX}/lib/compile-r7rs ${PREFIX}/lib/compile-r7rs/compile-r7rs.scm \"\$$@\"" >> compile-r7rs - echo "#!/bin/sh" > test-r7rs - echo "chibi-scheme -A ${PREFIX}/lib/compile-r7rs ${PREFIX}/lib/compile-r7rs/test-r7rs.scm \"\$$@\"" >> test-r7rs + +build-chicken: + 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 + 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 + 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 + csc -R r7rs -X r7rs -static \ + -o compile-r7rs \ + -uses libs.util \ + -uses libs.library-util \ + -uses libs.data \ + -uses foreign.c \ + -uses srfi-170 \ + compile-r7rs.scm + +build-gauche: + echo "#!/bin/sh" > compile-r7rs + echo "gosh -r -I ${PREFIX}/lib/compile-r7rs -I ${PREFIX}/lib/compile-r7rs/libs ${PREFIX}/lib/compile-r7rs/compile-r7rs.scm \"\$$@\"" >> compile-r7rs + +build-guile: + echo "#!/bin/sh" > compile-r7rs + echo "guile --r7rs --auto-compile -I -q -L ${PREFIX}/lib/compile-r7rs ${PREFIX}/lib/compile-r7rs/compile-r7rs.scm \"\$$@\" 2> /dev/null" >> compile-r7rs + +build-kawa: + echo "#!/bin/sh" > compile-r7rs + echo "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=/usr/local/share/kawa/lib/*.sld:${PREFIX}/lib/compile-r7rs/*.sld --r7rs ${PREFIX}/lib/compile-r7rs/compile-r7rs.scm \"\$$@\" 2> /dev/null" >> compile-r7rs + +build-racket: + echo "#!/bin/sh" > compile-r7rs + echo "racket -I r7rs -S ${PREFIX}/lib/compile-r7rs --script ${PREFIX}/lib/compile-r7rs/compile-r7rs.scm \"\$$@\"" >> compile-r7rs build-sagittarius: echo "#!/bin/sh" > compile-r7rs echo "sash -A ${PREFIX}/lib/compile-r7rs ${PREFIX}/lib/compile-r7rs/compile-r7rs.scm \"\$$@\"" >> compile-r7rs - echo "#!/bin/sh" > test-r7rs - echo "sash -A ${PREFIX}/lib/compile-r7rs ${PREFIX}/lib/compile-r7rs/test-r7rs.scm \"\$$@\"" >> test-r7rs -build-static: compile-r7rs test-r7rs +build-stklos: + echo "#!/bin/sh" > compile-r7rs + echo "stklos -I ${PREFIX}/lib/compile-r7rs ${PREFIX}/lib/compile-r7rs/compile-r7rs.scm \"\$$@\"" >> compile-r7rs docker-images: build-docker-image-debian build-docker-image-alpine @@ -39,58 +67,18 @@ docker-image-alpine: docker-image-alpine-push: docker push retropikzel1/compile-r7rs:alpine-latest -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 \ - -uses libs.library-util \ - -uses libs.data \ - -uses foreign.c \ - -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/compile-r7rs.scm install compile-r7rs ${PREFIX}/bin/compile-r7rs - cp test-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 -run-test-r6rs: +test-r6rs: rm -rf ${R6RSTMP} mkdir -p ${R6RSTMP} mkdir -p ${R6RSTMP}/libs @@ -101,14 +89,11 @@ run-test-r6rs: -cd ${R6RSTMP} && ./main > compile-r7rs-test-result.txt 2>&1 @grep "Test successfull" ${R6RSTMP}/compile-r7rs-test-result.txt || (echo "Test failed, output: " && cat ${R6RSTMP}/compile-r7rs-test-result.txt && exit 1) -build-local-docker: - docker build -f Dockerfile --tag=local-build-compile-r7rs . - -run-test-r6rs-docker: build-local-docker +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" -run-test-r7rs: +test-r7rs: rm -rf ${R7RSTMP} mkdir -p ${R7RSTMP} mkdir -p ${R7RSTMP}/libs @@ -126,7 +111,7 @@ run-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) -run-test-r7rs-docker: build-local-docker +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" diff --git a/README.md b/README.md index 90112ba..8319c1e 100644 --- a/README.md +++ b/README.md @@ -9,11 +9,8 @@ Despite it's name it also supports R6RS. Schemers, unite! <3 - [Supported implementations](#supported-implementations) - [Roadmap](#roadmap) - [Dependencies](#dependencies) - - [Linux](#dependencies-linux) - - [Windows](#dependencies-windows) +- [Building](#building) - [Installation](#installation) - - [Linux](#installation-linux) - - [Windows](#installation-windows) - [Usage](#usage) - [Chicken](#usage-chicken) - [Mosh](#usage-mosh) @@ -164,48 +161,27 @@ as compiler. ## Dependencies -### Linux - +- (foreign c) +- (srfi 170) -#### Chicken Scheme and R7RS library +To install: -On Debian/Ubuntu/Mint: + snow-chibi --impls=SCHEME "(foreign c)" + snow-chibi --impls=SCHEME "(srfi 170)" - apt-get install -y chicken-bin - chicken-install r7rs +## Building + -### Windows - +The Makefile has build jobs for Schemes that compile-r7rs can be run with. The +default is chibi. Run: -### Sagittarius Scheme -Download the installer from -[https://bitbucket.org/ktakashi/sagittarius-scheme/downloads/](https://bitbucket.org/ktakashi/sagittarius-scheme/downloads/) -and install it into **default location**. - -### libuv - -Libuv is distributed with compile-r7rs on Windows. + make build-SCHEME ## Installation - + -You will need Chibi scheme and snow-chibi installed. For static build you need -chicken 5. +Run: -First install linux dependencies: - - apt-get install build-essential make libffi-dev chicken-bin - -Then install latest Chibi scheme from git. - -And then run: - - make - make install - -Or: - - make build-static make install ## Usage @@ -242,44 +218,6 @@ No other file suffixes are supported at the moment. Setting value of COMPILE\_R7RS to implementation name that supports only r7rs and input file to .sps file and other way around is undefined behaviour. -### Chicken - - -By default Chicken 6 is assumed, for Chicken 5 use environment variable to -add R7RS libraries: - - COMPILE_R7RS_CHIKEN="-X r7r -R r7rs" - -### mit-scheme - - -Only allows one loadpath. Workaround in compile-r7rs is that each library is -loaded individually, like so: - - mit-scheme --load foo/bar.sld --load foo/baz.sld ... main.scm - -This does not require actions from the user and is done automatically. - -### Compiling a single library - - -Sometimes implementations need the libraries compiled in certain order, -specially the compilers. Since doing analysing from the files about which -library depends on which library I've decided to outsource it to you. :) - -To compile single library run the same command (including all the arguments -other than -o) -you would run for executable, except change the input file to the library. - -Example of compiling main program: - - COMPILE_R7RS= compile-r7rs -I . -o main main.scm - -And if the main program needed library called foo/bar.sld, and the compile-r7rs -tried to compile them in wrong order you would run: - - COMPILE_R7RS= compile-r7rs -I . foo/bar.sld - ### Environment variables diff --git a/libs/data.scm b/libs/data.scm deleted file mode 100644 index 1473821..0000000 --- a/libs/data.scm +++ /dev/null @@ -1,578 +0,0 @@ -(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 1c9e782..d03f095 100644 --- a/libs/data.sld +++ b/libs/data.sld @@ -1,10 +1,588 @@ (define-library - (libs data) - (import (scheme base) - (scheme write) - (scheme file) - (scheme process-context) - (srfi 170) - (libs util)) - (export data) - (include "data.scm")) + (libs data) + (import (scheme base) + (scheme write) + (scheme file) + (scheme process-context) + (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))))))))) diff --git a/libs/library-util.scm b/libs/library-util.scm deleted file mode 100644 index c403c42..0000000 --- a/libs/library-util.scm +++ /dev/null @@ -1,122 +0,0 @@ -(define filter-out-scheme-dependencies - (lambda (dependencies) - (let ((result (list))) - (for-each - (lambda (dependency) - (when (not (equal? (car dependency) 'scheme)) - (set! result (append result (list dependency))))) - dependencies) - result))) - -(define flatten-dependencies - (lambda (result dependencies) - (if (null? dependencies) - result - (flatten-dependencies (append result - (list - (if (or (equal? (car (car dependencies)) 'only) - (equal? (car (car dependencies)) 'except) - (equal? (car (car dependencies)) 'prefix) - (equal? (car (car dependencies)) 'rename)) - (car (cdr (car dependencies))) - (car dependencies)))) - (cdr dependencies))))) - -(define library-name->path - (lambda (name) - (string-append - (string-cut-from-end - (apply string-append - (map (lambda (item) - (string-append - (if (symbol? item) - (symbol->string item) - (number->string item)) - "/")) - name)) - 1) - ".sld"))) - -(define get-imports - (lambda (result implementation rest) - (cond ((null? rest) result) - ((equal? (car rest) 'import) (cdr rest)) - ((member 'cond-expand (car rest)) - (if (assoc implementation (cdr (car rest))) - (get-imports result - implementation - (cdr (assoc implementation - (cdr (car rest))))) - (get-imports result - implementation - (cdr (assoc 'else - (cdr (car rest))))))) - ((member 'import (car rest)) - (get-imports (append result (list) (cdr (car rest))) - implementation - (cdr rest))) - (else (get-imports result implementation (cdr rest)))))) - -(define remove-nonexistent - (lambda (directories paths) - (apply append - (map - (lambda (path) - (if (file-exists? (search-library-file directories path)) - (list path) - (list))) - paths)))) - -;; To get dependencies from R7RS and R6RS libraries we need to read trough all -;; the nonportable stuff first and then when encountering first ( not in -;; comments, read from that -(define read-until-library - (lambda (path) - (letrec - ((looper (lambda (c) - (cond ((char=? c #\() - (read)) - ((char=? c #\;) - (read-line) - (looper (peek-char))) - (else - (read-char) - (looper (peek-char))))))) - (with-input-from-file - path - (lambda () - (looper (peek-char))))))) - -(define library-dependencies - (lambda (implementation directories path previous-indent indent) - (for-each (lambda (item) (display " ")) indent) - (display path) - (let ((full-path (search-library-file directories path))) - (if (not (file-exists? full-path)) - (begin - (display #\space) - (display "not found, ignoring") - (newline) - (list)) - (begin - (newline) - (letrec* ((raw-data (read-until-library full-path)) - (data (if (equal? (car raw-data) 'define-library) - (cdr raw-data) - raw-data)) - (imports (flatten-dependencies (list) - (get-imports (list) - implementation - data))) - (filtered-imports (filter-out-scheme-dependencies imports)) - (paths (map library-name->path filtered-imports)) - (flat-tree (apply append - (map (lambda (dependency-path) - (append (list dependency-path) - (reverse (library-dependencies implementation - directories - dependency-path - indent - (append indent (list #\space #\space)))))) - paths)))) - (remove-nonexistent directories (reverse flat-tree)))))))) diff --git a/libs/library-util.sld b/libs/library-util.sld index bfef792..5465ba5 100644 --- a/libs/library-util.sld +++ b/libs/library-util.sld @@ -6,5 +6,127 @@ (scheme file) (libs util)) (export library-dependencies) - (include "library-util.scm")) + (begin + (define filter-out-scheme-dependencies + (lambda (dependencies) + (let ((result (list))) + (for-each + (lambda (dependency) + (when (not (equal? (car dependency) 'scheme)) + (set! result (append result (list dependency))))) + dependencies) + result))) + + (define flatten-dependencies + (lambda (result dependencies) + (if (null? dependencies) + result + (flatten-dependencies (append result + (list + (if (or (equal? (car (car dependencies)) 'only) + (equal? (car (car dependencies)) 'except) + (equal? (car (car dependencies)) 'prefix) + (equal? (car (car dependencies)) 'rename)) + (car (cdr (car dependencies))) + (car dependencies)))) + (cdr dependencies))))) + + (define library-name->path + (lambda (name) + (string-append + (string-cut-from-end + (apply string-append + (map (lambda (item) + (string-append + (if (symbol? item) + (symbol->string item) + (number->string item)) + "/")) + name)) + 1) + ".sld"))) + + (define get-imports + (lambda (result implementation rest) + (cond ((null? rest) result) + ((equal? (car rest) 'import) (cdr rest)) + ((member 'cond-expand (car rest)) + (if (assoc implementation (cdr (car rest))) + (get-imports result + implementation + (cdr (assoc implementation + (cdr (car rest))))) + (get-imports result + implementation + (cdr (assoc 'else + (cdr (car rest))))))) + ((member 'import (car rest)) + (get-imports (append result (list) (cdr (car rest))) + implementation + (cdr rest))) + (else (get-imports result implementation (cdr rest)))))) + + (define remove-nonexistent + (lambda (directories paths) + (apply append + (map + (lambda (path) + (if (file-exists? (search-library-file directories path)) + (list path) + (list))) + paths)))) + + ;; To get dependencies from R7RS and R6RS libraries we need to read trough all + ;; the nonportable stuff first and then when encountering first ( not in + ;; comments, read from that + (define read-until-library + (lambda (path) + (letrec + ((looper (lambda (c) + (cond ((char=? c #\() + (read)) + ((char=? c #\;) + (read-line) + (looper (peek-char))) + (else + (read-char) + (looper (peek-char))))))) + (with-input-from-file + path + (lambda () + (looper (peek-char))))))) + + (define library-dependencies + (lambda (implementation directories path previous-indent indent) + (for-each (lambda (item) (display " ")) indent) + (display path) + (let ((full-path (search-library-file directories path))) + (if (not (file-exists? full-path)) + (begin + (display #\space) + (display "not found, ignoring") + (newline) + (list)) + (begin + (newline) + (letrec* ((raw-data (read-until-library full-path)) + (data (if (equal? (car raw-data) 'define-library) + (cdr raw-data) + raw-data)) + (imports (flatten-dependencies (list) + (get-imports (list) + implementation + data))) + (filtered-imports (filter-out-scheme-dependencies imports)) + (paths (map library-name->path filtered-imports)) + (flat-tree (apply append + (map (lambda (dependency-path) + (append (list dependency-path) + (reverse (library-dependencies implementation + directories + dependency-path + indent + (append indent (list #\space #\space)))))) + paths)))) + (remove-nonexistent directories (reverse flat-tree)))))))))) diff --git a/libs/srfi-64-util.scm b/libs/srfi-64-util.scm deleted file mode 100644 index 4f90ed0..0000000 --- a/libs/srfi-64-util.scm +++ /dev/null @@ -1,89 +0,0 @@ - -(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* ((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) - (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))))))) - (if (not (file-exists? path)) - (list) - (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 deleted file mode 100644 index 5f3aac6..0000000 --- a/libs/srfi-64-util.sld +++ /dev/null @@ -1,10 +0,0 @@ -(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 deleted file mode 100644 index dcd6962..0000000 --- a/libs/util.scm +++ /dev/null @@ -1,213 +0,0 @@ -(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 8a522a9..a1dd345 100644 --- a/libs/util.sld +++ b/libs/util.sld @@ -29,4 +29,217 @@ trim trim-end trim-both) - (include "util.scm")) + (begin + (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/test-r7rs.scm b/test-r7rs.scm deleted file mode 100644 index 3e25e61..0000000 --- a/test-r7rs.scm +++ /dev/null @@ -1,342 +0,0 @@ -(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)) - -(for-each - (lambda (path) (when (not (file-exists? path)) (create-directory path))) - `(".test-r7rs" ".test-r7rs/tmp")) - -(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 (print-header output-file timestamp timeout) - (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" - "" - ,(make-row '("Implementation" - "Passes" - "Unexpected passes" - "Failures" - "Expected failures" - "Skipped tests" - "Build exit code" - "Run exit code")) - ,(make-row (list lines lines lines lines lines lines lines lines))))) - -(define timeout - (if (member "--timeout" (command-line)) - (cadr (member "--timeout" (command-line))) - "6000")) - -(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))) - "")) - -(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))) - "a.out")) - -(define print-header? - (if (member "--no-header" (command-line)) #f #t)) - -(when print-header? - (print-header output-file timestamp timeout)) - -(when (member "--only-header" (command-line)) (exit 0)) - -(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 debug? - (if (member "--debug" (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)) - (else - (string-split compile-r7rs #\space))))) -(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 (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))))))) - (if (file-exists? run-out) - (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 - `(,(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 tree " apt-pkgs) - "RUN mkdir -p ${HOME}/.snow && echo '()' > ${HOME}/.snow/config.scm" - "COPY --from=retropikzel1/compile-r7rs /opt/compile-r7rs /opt/compile-r7rs" - "ENV PATH=/opt/compile-r7rs:${PATH}" - ,(string-append "RUN /opt/compile-r7rs/snow-chibi install --always-yes --impls=" scheme " " snow-pkgs) - ,(string-append "ENV COMPILE_R7RS=" scheme) - "WORKDIR /workdir")))) - dockerfile-path)) - -(define (docker-run-cmd tag cmd) - (string-append "docker run -i -v \"${PWD}:/workdir\" --workdir /workdir " - tag " sh -c \"timeout " timeout " " cmd "\"")) - -(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)) - 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/" 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/" scheme "-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/" scheme "-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)) - (display "Docker container build failed") - (newline) - (display "Command: ") - (display docker-build-cmd) - (newline) - (display "Output: ") - (newline) - (cat docker-build-out) - (newline) - (exit 1)) - (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 "/" 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))) - (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")) - - (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))) - - (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) -