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

Cleanup, more build options

This commit is contained in:
retropikzel 2025-10-01 21:49:23 +03:00
parent 8d99e06cb3
commit 8cbdf9193d
13 changed files with 1012 additions and 1537 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

53
Dockerfile
View File

@ -1,55 +1,24 @@
FROM debian:trixie-slim AS build FROM debian:trixie-slim AS build
RUN apt-get update && apt-get install -y build-essential ca-certificates wget \ RUN apt-get update && apt-get install -y make gcc gcc chicken-bin git
git autoconf automake libtool texinfo RUN chicken-install r7rs
WORKDIR /build WORKDIR /build
RUN git clone https://github.com/ashinn/chibi-scheme.git --depth=1 chibi RUN git clone https://github.com/ashinn/chibi-scheme.git --depth=1 chibi
WORKDIR /build/chibi WORKDIR /build/chibi
RUN make DESTDIR=/opt/compile-r7rs RUN make
RUN make DESTDIR=/opt/compile-r7rs install RUN make 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
WORKDIR /build WORKDIR /build
RUN mkdir -p ${HOME}/.snow && echo "()" > ${HOME}/.snow/config.scm RUN mkdir -p ${HOME}/.snow && echo "()" > ${HOME}/.snow/config.scm
RUN snow-chibi install \ RUN snow-chibi install --always-yes --impls=chicken "(foreign c)"
--cflags="-I/opt/compile-r7rs/usr/local/include -L/opt/compile-r7rs/usr/local/lib" \ RUN snow-chibi install --always-yes --impls=chicken "(srfi 170)"
--install-source-dir=/opt/compile-r7rs/usr/local/share/chibi \ COPY Makefile .
--install-library-dir=/opt/compile-r7rs/usr/local/lib/chibi \ COPY compile-r7rs.scm .
"(foreign c)" COPY libs ./libs
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 make PREFIX=/opt/compile-r7rs build-chicken
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)" RUN make PREFIX=/opt/compile-r7rs install
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
FROM debian:trixie-slim 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 COPY --from=build /opt/compile-r7rs /opt/compile-r7rs
RUN updatedb
RUN locate foreign-c.so
ENV PATH=/opt/compile-r7rs:${PATH} ENV PATH=/opt/compile-r7rs:${PATH}

24
Dockerfile.alpine Normal file
View File

@ -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}

95
Makefile
View File

@ -9,21 +9,49 @@ endif
STATIC_LIBS=libs.util.a libs.library-util.a libs.data.a libs.srfi-64-util.a STATIC_LIBS=libs.util.a libs.library-util.a libs.data.a libs.srfi-64-util.a
all: build build-chibi:
build:
echo "#!/bin/sh" > compile-r7rs echo "#!/bin/sh" > compile-r7rs
echo "chibi-scheme -A ${PREFIX}/lib/compile-r7rs ${PREFIX}/lib/compile-r7rs/compile-r7rs.scm \"\$$@\"" >> 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: build-sagittarius:
echo "#!/bin/sh" > compile-r7rs echo "#!/bin/sh" > compile-r7rs
echo "sash -A ${PREFIX}/lib/compile-r7rs ${PREFIX}/lib/compile-r7rs/compile-r7rs.scm \"\$$@\"" >> 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 docker-images: build-docker-image-debian build-docker-image-alpine
@ -39,58 +67,18 @@ docker-image-alpine:
docker-image-alpine-push: docker-image-alpine-push:
docker push retropikzel1/compile-r7rs:alpine-latest 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: install:
mkdir -p ${PREFIX}/bin mkdir -p ${PREFIX}/bin
mkdir -p ${PREFIX}/lib/compile-r7rs mkdir -p ${PREFIX}/lib/compile-r7rs
cp -r libs ${PREFIX}/lib/compile-r7rs/ cp -r libs ${PREFIX}/lib/compile-r7rs/
cp compile-r7rs.scm ${PREFIX}/lib/compile-r7rs/compile-r7rs.scm cp compile-r7rs.scm ${PREFIX}/lib/compile-r7rs/compile-r7rs.scm
install compile-r7rs ${PREFIX}/bin/compile-r7rs 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: uninstall:
rm -rf ${PREFIX}/lib/compile-r7rs rm -rf ${PREFIX}/lib/compile-r7rs
rm -rf ${PREFIX}/bin/compile-r7rs rm -rf ${PREFIX}/bin/compile-r7rs
run-test-r6rs: test-r6rs:
rm -rf ${R6RSTMP} rm -rf ${R6RSTMP}
mkdir -p ${R6RSTMP} mkdir -p ${R6RSTMP}
mkdir -p ${R6RSTMP}/libs mkdir -p ${R6RSTMP}/libs
@ -101,14 +89,11 @@ run-test-r6rs:
-cd ${R6RSTMP} && ./main > compile-r7rs-test-result.txt 2>&1 -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) @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: test-r6rs-docker: build-local-docker
docker build -f Dockerfile --tag=local-build-compile-r7rs .
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 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" 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} rm -rf ${R7RSTMP}
mkdir -p ${R7RSTMP} mkdir -p ${R7RSTMP}
mkdir -p ${R7RSTMP}/libs mkdir -p ${R7RSTMP}/libs
@ -126,7 +111,7 @@ run-test-r7rs:
-cd ${R7RSTMP} && ./main > compile-r7rs-test-result.txt 2>&1 -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) @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 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" docker run -v "${PWD}":/workdir -w /workdir -t compile-r7rs-test-${SCHEME} sh -c "make && make install && make SCHEME=${SCHEME} test-r7rs"

88
README.md
View File

@ -9,11 +9,8 @@ Despite it's name it also supports R6RS. Schemers, unite! <3
- [Supported implementations](#supported-implementations) - [Supported implementations](#supported-implementations)
- [Roadmap](#roadmap) - [Roadmap](#roadmap)
- [Dependencies](#dependencies) - [Dependencies](#dependencies)
- [Linux](#dependencies-linux) - [Building](#building)
- [Windows](#dependencies-windows)
- [Installation](#installation) - [Installation](#installation)
- [Linux](#installation-linux)
- [Windows](#installation-windows)
- [Usage](#usage) - [Usage](#usage)
- [Chicken](#usage-chicken) - [Chicken](#usage-chicken)
- [Mosh](#usage-mosh) - [Mosh](#usage-mosh)
@ -164,48 +161,27 @@ as compiler.
## Dependencies ## Dependencies
<a name="#dependencies"></a> <a name="#dependencies"></a>
### Linux - (foreign c)
<a name="#dependencies-linux"></a> - (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 ## Building
chicken-install r7rs <a name="#building"></a>
### Windows The Makefile has build jobs for Schemes that compile-r7rs can be run with. The
<a name="#dependencies-windows"></a> default is chibi. Run:
### Sagittarius Scheme make build-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.
## Installation ## Installation
<a name="#Installation"></a> <a name="#installation"></a>
You will need Chibi scheme and snow-chibi installed. For static build you need Run:
chicken 5.
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 make install
## Usage ## 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 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. and input file to .sps file and other way around is undefined behaviour.
### Chicken
<a name="#usage-chicken"></a>
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
<a name="#usage-mit-scheme"></a>
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
<a name="#usage-compiling-a-single-library"></a>
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=<implementation name> 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=<implementation name> compile-r7rs -I . foo/bar.sld
### Environment variables ### Environment variables
<a name="#usage-environment-variables"></a> <a name="#usage-environment-variables"></a>

578
libs/data.scm
View File

@ -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)))))))

596
libs/data.sld
View File

@ -1,10 +1,588 @@
(define-library (define-library
(libs data) (libs data)
(import (scheme base) (import (scheme base)
(scheme write) (scheme write)
(scheme file) (scheme file)
(scheme process-context) (scheme process-context)
(srfi 170) (srfi 170)
(libs util)) (libs util))
(export data) (export data)
(include "data.scm")) (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)))))))))

122
libs/library-util.scm
View File

@ -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))))))))

124
libs/library-util.sld
View File

@ -6,5 +6,127 @@
(scheme file) (scheme file)
(libs util)) (libs util))
(export library-dependencies) (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))))))))))

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

@ -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)))))))

10
libs/srfi-64-util.sld
View File

@ -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"))

213
libs/util.scm
View File

@ -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)))))

215
libs/util.sld
View File

@ -29,4 +29,217 @@
trim trim
trim-end trim-end
trim-both) 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)))))))

342
test-r7rs.scm
View File

@ -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)