Cleanup, more build options
This commit is contained in:
parent
8d99e06cb3
commit
8cbdf9193d
53
Dockerfile
53
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}
|
||||
|
|
|
@ -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
95
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"
|
||||
|
||||
|
|
88
README.md
88
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
|
||||
<a name="#dependencies"></a>
|
||||
|
||||
### Linux
|
||||
<a name="#dependencies-linux"></a>
|
||||
- (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
|
||||
<a name="#building"></a>
|
||||
|
||||
### Windows
|
||||
<a name="#dependencies-windows"></a>
|
||||
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
|
||||
<a name="#Installation"></a>
|
||||
<a name="#installation"></a>
|
||||
|
||||
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
|
||||
<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
|
||||
<a name="#usage-environment-variables"></a>
|
||||
|
||||
|
|
578
libs/data.scm
578
libs/data.scm
|
@ -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
596
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)))))))))
|
||||
|
|
|
@ -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))))))))
|
|
@ -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))))))))))
|
||||
|
||||
|
|
|
@ -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)))))))
|
|
@ -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
213
libs/util.scm
|
@ -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
215
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)))))))
|
||||
|
|
342
test-r7rs.scm
342
test-r7rs.scm
|
@ -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)
|
||||
|
Loading…
Reference in New Issue