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

Adding test-r7rs

This commit is contained in:
retropikzel 2025-09-19 12:52:10 +03:00
parent 4ef67eb5bc
commit 387b2a9d5f
13 changed files with 1270 additions and 760 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

1
.gitignore vendored
View File

@ -2,6 +2,7 @@
*.swo *.swo
*.link *.link
compile-r7rs compile-r7rs
test-r7rs
test test
*.c *.c
*.o *.o

21
Dockerfile
View File

@ -1,27 +1,26 @@
FROM schemers/chicken:5 AS build FROM schemers/chicken:5 AS build
RUN mkdir -p ${HOME}/.snow && echo "()" > ${HOME}/.snow/config.scm
RUN apt-get update && apt-get install -y \ RUN apt-get update && apt-get install -y \
gcc wget ca-certificates xz-utils make git libffi-dev unzip lbzip2 cmake \ gcc wget ca-certificates xz-utils make git libffi-dev unzip lbzip2 cmake \
g++ python3 locate zlib1g-dev g++ python3 locate zlib1g-dev
WORKDIR /build
ENV PATH=/opt/compile-r7rs/bin:${PATH}
RUN git clone https://github.com/ashinn/chibi-scheme.git --depth=1 RUN git clone https://github.com/ashinn/chibi-scheme.git --depth=1
RUN cd chibi-scheme && make DESTDIR=/opt/compile-r7rs/chibi all WORKDIR /chibi-scheme
RUN cd chibi-scheme && make DESTDIR=/opt/compile-r7rs/chibi install RUN make
RUN mkdir -p /opt/compile-r7rs/bin RUN make install
RUN echo "#!/bin/sh" > /opt/compile-r7rs/bin/snow-chibi
RUN echo "PATH=${PATH}:/opt/compile-r7rs/chibi/usr/local/bin CHIBI_MODULE_PATH=/opt/compile-r7rs/chibi/usr/local/share/chibi:/opt/compile-r7rs/chibi/usr/local/lib/chibi LD_LIBRARY_PATH=/opt/compile-r7rs/chibi/usr/local/lib exec /opt/compile-r7rs/chibi/usr/local/bin/chibi-scheme -mchibi.snow.commands -mchibi.snow.interface -mchibi.snow.package -mchibi.snow.utils /opt/compile-r7rs/chibi/usr/local/bin/snow-chibi.scm \"\$@\"" >> /opt/compile-r7rs/bin/snow-chibi WORKDIR /build
RUN chmod +x /opt/compile-r7rs/bin/snow-chibi
ENV SCHEME=chicken ENV SCHEME=chicken
RUN snow-chibi --impls=${SCHEME} --always-yes install "(foreign c)" RUN snow-chibi --impls=${SCHEME} --always-yes install "(foreign c)"
RUN snow-chibi --impls=${SCHEME} --always-yes install "(srfi 170)" RUN snow-chibi --impls=${SCHEME} --always-yes install "(srfi 170)"
COPY Makefile . COPY Makefile .
COPY compile-r7rs.scm . COPY compile-r7rs.scm .
COPY test-r7rs.sh .
COPY libs libs COPY libs libs
RUN make PREFIX=/opt/compile-r7rs build-static RUN make PREFIX=/opt/compile-r7rs build-static
RUN make PREFIX=/opt/compile-r7rs install RUN make PREFIX=/opt/compile-r7rs install
FROM debian:trixie-slim FROM debian:trixie-slim
COPY --from=build /opt/compile-r7rs /opt/compile-r7rs COPY --from=build /opt/compile-r7rs /opt/compile-r7rs
ENV PATH=${PATH}:/opt/compile-r7rs/bin ENV PATH=/opt/compile-r7rs/bin:${PATH}
ENV LD_LIBRARY_PATH=/opt/compile-r7rs/lib

2
Dockerfile.test
View File

@ -18,4 +18,4 @@ FROM schemers/${IMAGE}
COPY --from=build /var/cache/apt/archives /debs COPY --from=build /var/cache/apt/archives /debs
RUN dpkg -i /debs/*.deb RUN dpkg -i /debs/*.deb
COPY --from=local-build-compile-r7rs /opt/compile-r7rs /opt/compile-r7rs COPY --from=local-build-compile-r7rs /opt/compile-r7rs /opt/compile-r7rs
ENV PATH=/opt/compile-r7rs/bin:${PATH} ENV PATH=/opt/compile-r7rs/bin:${PATH}:/opt/compile-r7rs/snow-chibi/bin

44
Makefile
View File

@ -7,19 +7,29 @@ ifeq "${SCHEME}" "chicken"
DOCKERIMG="chicken:5" DOCKERIMG="chicken:5"
endif endif
STATIC_LIBS=libs.util.a libs.library-util.a libs.data.a libs.srfi-64-util.a
all: build all: build
build: build: compile-r7rs test-r7rs
echo "#!/bin/sh" > compile-r7rs
echo "chibi-scheme -A ${PREFIX}/lib/compile-r7rs ${PREFIX}/lib/compile-r7rs/main.scm \"\$$@\"" >> compile-r7rs
build-static: libs.util.a: libs/util.sld libs/util.scm
csc -R r7rs -X r7rs -static -c -J -unit libs.util -o libs.util.o libs/util.sld 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 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 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 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 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 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 \ csc -R r7rs -X r7rs -static \
-o compile-r7rs \ -o compile-r7rs \
-uses libs.util \ -uses libs.util \
@ -29,18 +39,32 @@ build-static:
-uses srfi-170 \ -uses srfi-170 \
compile-r7rs.scm 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/main.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 compile-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
test-r6rs: run-test-r6rs:
rm -rf ${R6RSTMP} rm -rf ${R6RSTMP}
mkdir -p ${R6RSTMP} mkdir -p ${R6RSTMP}
mkdir -p ${R6RSTMP}/libs mkdir -p ${R6RSTMP}/libs
@ -54,11 +78,11 @@ test-r6rs:
build-local-docker: build-local-docker:
docker build -f Dockerfile --tag=local-build-compile-r7rs . docker build -f Dockerfile --tag=local-build-compile-r7rs .
test-r6rs-docker: build-local-docker run-test-r6rs-docker: build-local-docker
docker build -f Dockerfile.test --build-arg IMAGE=${DOCKERIMG} --build-arg SCHEME=${SCHEME} --tag=compile-r7rs-test-${SCHEME} . docker 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"
test-r7rs: run-test-r7rs:
rm -rf ${R7RSTMP} rm -rf ${R7RSTMP}
mkdir -p ${R7RSTMP} mkdir -p ${R7RSTMP}
mkdir -p ${R7RSTMP}/libs mkdir -p ${R7RSTMP}/libs
@ -76,11 +100,13 @@ 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)
test-r7rs-docker: build-local-docker run-test-r7rs-docker: build-local-docker
docker build -f Dockerfile.test --build-arg IMAGE=${DOCKERIMG} --build-arg SCHEME=${SCHEME} --tag=compile-r7rs-test-${SCHEME} . docker 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"
clean: clean:
rm -rf test-r7rs
rm -rf compile-r7rs
find . -name "*.so" -delete find . -name "*.so" -delete
find . -name "*.o*" -delete find . -name "*.o*" -delete
find . -name "*.a*" -delete find . -name "*.a*" -delete

35
compile-r7rs.scm
View File

@ -9,38 +9,6 @@
(libs library-util) (libs library-util)
(srfi 170)) (srfi 170))
(define r6rs-schemes '(chezscheme
guile
ikarus
ironscheme
larceny
loko
mosh
racket
sagittarius
ypsilon))
(define r7rs-schemes '(chibi
chicken
cyclone
gambit
foment
gauche
guile
kawa
larceny
loko
meevax
mit-scheme
mosh
racket
sagittarius
skint
stklos
tr7
ypsilon))
(define all-schemes (append r6rs-schemes r7rs-schemes))
(when (member "--list-r6rs-schemes" (command-line)) (when (member "--list-r6rs-schemes" (command-line))
(for-each (for-each
(lambda (scheme) (lambda (scheme)
@ -69,8 +37,7 @@
(string->symbol (get-environment-variable "COMPILE_R7RS")) (string->symbol (get-environment-variable "COMPILE_R7RS"))
#f)) #f))
(when (not scheme) (error "Environment variable COMPILE_R7RS not set.")) (when (not scheme) (error "Environment variable COMPILE_R7RS not set."))
(when (not (assoc scheme data)) (when (not (assoc scheme data)) (error "Unsupported implementation" scheme))
(error "Unsupported implementation" scheme))
(define compilation-target (if (get-environment-variable "TARGET") (define compilation-target (if (get-environment-variable "TARGET")
(get-environment-variable "TARGET") (get-environment-variable "TARGET")
(cond-expand (windows "windows") (cond-expand (windows "windows")

BIN
dist/setup-compile-r7rs.exe vendored
View File

Binary file not shown.

578
libs/data.scm Normal file
View File

@ -0,0 +1,578 @@
(define data
`((chezscheme
(type . interpreter)
(command . ,(lambda (input-file output-file prepend-directories append-directories library-files r6rs?)
(apply string-append
`("scheme"
" "
,(util-getenv "COMPILE_R7RS_CHEZSCHEME")
" "
"--quiet"
" "
,@(map (lambda (item)
(string-append "--libdirs " " " item ":"))
(append prepend-directories append-directories))
" "
"--program"
" "
,input-file)))))
(chibi
(type . interpreter)
(command . ,(lambda (input-file output-file prepend-directories append-directories library-files r6rs?)
(apply string-append
`("chibi-scheme"
" "
,(util-getenv "COMPILE_R7RS_CHIBI")
" "
,@(map (lambda (item)
(string-append "-I" " " item " "))
prepend-directories)
" "
,@(map (lambda (item)
(string-append "-A" " " item " "))
append-directories)
,input-file)))))
(chicken
(type . compiler)
(library-command . ,(lambda (library-file prepend-directories append-directories r6rs?)
(let ((unit (string-append (if (string-starts-with? library-file "srfi")
(string-replace (string-cut-from-end library-file 4) #\/ #\-)
(string-replace (string-cut-from-end library-file 4) #\/ #\.))))
(out (string-append (if (string-starts-with? library-file "srfi")
(string-replace (string-cut-from-end library-file 4) #\/ #\-)
(string-replace (string-cut-from-end library-file 4) #\/ #\.))
".o"))
(static-out (string-append (if (string-starts-with? library-file "srfi")
(string-replace (string-cut-from-end library-file 4) #\/ #\-)
(string-replace (string-cut-from-end library-file 4) #\/ #\.))
".a")))
(apply string-append `("csc -R r7rs -X r7rs"
" "
,(util-getenv "COMPILE_R7RS_CHICKEN")
" -static -c -J -o "
,out
" "
,(search-library-file (append prepend-directories append-directories) library-file)
" "
,@(map (lambda (item)
(string-append "-I " item " "))
(append append-directories
prepend-directories))
"-unit "
,unit
" "
"&&"
" "
"ar"
" "
"rcs"
" "
,static-out
" "
,out)))))
(command . ,(lambda (input-file output-file prepend-directories append-directories library-files r6rs?)
(apply string-append `("csc -R r7rs -X r7rs"
" "
,(util-getenv "COMPILE_R7RS_CHICKEN")
" "
"-static"
" "
,@(map (lambda (item)
(string-append "-I " item " "))
(append append-directories prepend-directories))
,@(map (lambda (library-file)
(string-append "-uses "
(if (string-starts-with? library-file "srfi")
(string-replace (string-cut-from-end library-file 4) #\/ #\-)
(string-replace (string-cut-from-end library-file 4) #\/ #\.))
" "))
library-files)
"-output-file"
" "
,output-file
" "
,input-file)))))
(cyclone
(type . compiler)
(library-command . ,(lambda (library-file prepend-directories append-directories r6rs?)
(apply string-append
`("cyclone"
" "
,(util-getenv "COMPILE_R7RS_CYCLONE")
" "
,@(map (lambda (item) (string-append "-I " item " ")) prepend-directories)
,@(map (lambda (item) (string-append "-A " item " ")) append-directories)
,(search-library-file (append prepend-directories
append-directories)
library-file)))))
(command . ,(lambda (input-file output-file prepend-directories append-directories library-files r6rs?)
(apply string-append
`("cyclone "
,(util-getenv "COMPILE_R7RS_CYCLONE")
" "
,@(map (lambda (item) (string-append "-I " item " ")) prepend-directories)
,@(map (lambda (item) (string-append "-A " item " ")) append-directories)
,input-file
,(if (not (string=? (string-cut-from-end input-file 4) output-file))
(string-append
" && "
"mv "
(string-cut-from-end input-file 4)
" "
output-file)
""))))))
(foment
(type . interpreter)
(command . ,(lambda (input-file output-file prepend-directories append-directories library-files r6rs?)
(apply string-append
`("foment"
" "
,(util-getenv "COMPILE_R7RS_FOMENT")
" "
,@(map (lambda (item)
(string-append "-I" " " item " "))
prepend-directories)
,@(map (lambda (item)
(string-append "-A" " " item " "))
append-directories)
" "
,input-file)))))
(gambit
(type . compiler)
(library-command . ,(lambda (library-file prepend-directories append-directories r6rs?)
(apply string-append `("gsc -:r7rs -obj "
,@(map (lambda (item)
(string-append item "/ "))
(append prepend-directories
append-directories))
,(search-library-file (append append-directories
prepend-directories)
library-file)))))
(command . ,(lambda (input-file output-file prepend-directories append-directories library-files r6rs?)
(let ((real
(string-append (string-cut-from-end input-file 4)
"-real")))
(apply
string-append
`("gsc -o " ,real
" -exe -nopreload "
,@(map (lambda (item)
(string-append item "/ "))
(append prepend-directories
append-directories))
,input-file
" && "
"printf '#!/bin/sh\\n./" ,real
" -:r7rs,search="
,@(map (lambda (item)
(string-append item "/ "))
(append prepend-directories
append-directories))
""
"\\n"
"'"
" > " ,output-file
" && "
"chmod +x " ,output-file))))))
(gauche
(type . interpreter)
(command . ,(lambda (input-file output-file prepend-directories append-directories library-files r6rs?)
(apply string-append
`("gosh"
" "
,(util-getenv "COMPILE_R7RS_GAUCHE")
" "
"-r7"
" "
,@(map (lambda (item)
(string-append "-I" " " item " "))
prepend-directories)
,@(map (lambda (item)
(string-append "-A" " " item " "))
append-directories)
" "
,input-file)))))
(guile
(type . interpreter)
(command . ,(lambda (input-file output-file prepend-directories append-directories library-files r6rs?)
(apply string-append
`("guile"
" "
,(util-getenv "COMPILE_R7RS_GUILE")
" "
,(if r6rs? "--r6rs" "--r7rs")
" "
,@(map (lambda (item)
(string-append "-L" " " item " "))
(append prepend-directories
append-directories))
" "
,input-file)))))
(husk
(type . compiler)
(command . ,(lambda (input-file output-file prepend-directories append-directories library-files r6rs?)
(apply string-append
`("huskc"
" "
,(util-getenv "COMPILE_R7RS_HUSK")
" "
"-o"
" "
,output-file
" "
;,@(map (lambda (item) (string-append "-L" " " item " ")) prepend-directories)
;,@(map (lambda (item) (string-append "-L" " " item " ")) append-directories)
" "
,input-file)))))
(ikarus
(type . interpreter)
(command . ,(lambda (input-file output-file prepend-directories append-directories library-files r6rs?)
(apply string-append
`("export IKARUS_LIBRARY_PATH="
,@(map (lambda (item)
(string-append item ":"))
prepend-directories)
,@(map (lambda (item)
(string-append item ":"))
append-directories)
"\n"
"ikarus"
" "
,(util-getenv "COMPILE_R7RS_IKARUS")
" "
"--r6rs-script"
" "
,input-file)))))
(ironscheme
(type . interpreter)
(command . ,(lambda (input-file output-file prepend-directories append-directories library-files r6rs?)
(apply string-append
`("ironscheme"
" "
,(util-getenv "COMPILE_R7RS_IRONSCHEME")
" "
,@(map (lambda (item)
(string-append "-I \"" item "\" "))
prepend-directories)
,@(map (lambda (item)
(string-append "-I \"" item "\" "))
append-directories)
" "
,input-file)))))
(kawa
(type . interpreter)
(command . ,(lambda (input-file output-file prepend-directories append-directories library-files r6rs?)
(apply string-append
`("kawa"
" "
,(util-getenv "COMPILE_R7RS_KAWA")
" -J--add-exports=java.base/jdk.internal.foreign.abi=ALL-UNNAMED "
" -J--add-exports=java.base/jdk.internal.foreign.layout=ALL-UNNAMED "
" -J--add-exports=java.base/jdk.internal.foreign=ALL-UNNAMED "
" -J--enable-native-access=ALL-UNNAMED "
"-Dkawa.import.path=\""
,@(map (lambda (item)
(string-append item "/*.sld:"))
(append prepend-directories
append-directories
(list "/usr/local/share/kawa/lib")))
"\" "
"--r7rs"
" "
,input-file)))))
(larceny
(type . interpreter)
(command . ,(lambda (input-file output-file prepend-directories append-directories library-files r6rs?)
(apply string-append
`("larceny"
,(util-getenv "COMPILE_R7RS_LARCENY")
" "
"-nobanner"
" "
"-quiet"
" "
"-utf8"
" "
,(if r6rs? "-r6rs" "-r7rs")
" "
,@(map (lambda (item)
(string-append "-I " item " "))
prepend-directories)
,@(map (lambda (item)
(string-append "-A " item " "))
append-directories)
" "
"-program"
" "
,input-file)))))
(loko
(type . compiler)
(command . ,(lambda (input-file output-file prepend-directories append-directories library-files r6rs?)
(let ((out (string-cut-from-end input-file 4)))
(apply string-append
`("LOKO_LIBRARY_PATH="
,@(map (lambda (item)
(string-append item ":"))
prepend-directories)
,@(map (lambda (item)
(string-append item ":"))
append-directories)
" "
"loko "
" "
,(util-getenv "COMPILE_R7RS_LOKO")
" "
,(if r6rs? "-std=r6rs" "-std=r7rs")
" "
"--compile"
" "
,input-file
" "
"&&"
" "
"mv"
" "
,out
" "
,output-file))))))
(meevax
(type . interpreter)
(command . ,(lambda (input-file output-file prepend-directories append-directories library-files r6rs?)
(apply string-append
`("meevax"
" "
,(util-getenv "COMPILE_R7RS_MEEVAX")
" "
,@(map (lambda (item)
(string-append "-I" " " item " "))
prepend-directories)
" "
,@(map (lambda (item)
(string-append "-A" " " item " "))
append-directories)
,input-file)))))
(mit-scheme
(type . interpreter)
(command . ,(lambda (input-file output-file prepend-directories append-directories library-files r6rs?)
(apply string-append
`("mit-scheme"
" "
,(util-getenv "COMPILE_R7RS_MIT_SCHEME")
" "
,@(map
(lambda (item)
(string-append "--load "
(search-library-file (append append-directories
prepend-directories)
item)
" "))
library-files)
" "
"--load"
" "
,input-file
" "
"--eval \"(exit 0)\"")))))
(mosh
(type . interpreter)
(command . ,(lambda (input-file output-file prepend-directories append-directories library-files r6rs?)
(apply string-append
`("mosh"
" "
,(util-getenv "COMPILE_R7RS_MOSH")
" "
,@(map (lambda (item) (string-append "--loadpath=" item " "))
(append append-directories prepend-directories))
;" "
,input-file)))))
(picrin
(type . interpreter)
(command . ,(lambda (input-file output-file prepend-directories append-directories library-files r6rs?)
(apply string-append
`("picrin"
" "
,(util-getenv "COMPILE_R7RS_PICRIN")
" "
,@(map (lambda (item)
(string-append "-l " item " "))
library-files)
" "
"-e"
" "
,input-file)))))
(racket
(type . interpreter)
(library-command . ,(lambda (library-file prepend-directories append-directories r6rs?)
(let* ((full-path (search-library-file (append append-directories
prepend-directories)
library-file))
(library-rkt-file (change-file-suffix full-path ".rkt")))
(if r6rs?
(apply string-append
`("plt-r6rs"
" "
"--compile"
" "
,library-file))
(apply string-append
`("printf"
" "
"'#lang r7rs\\n"
"(import (except (scheme base) let let-values let*-values string-copy string-copy! string-for-each string-map string-fill! string->list))\\n"
"(include \""
,(path->filename library-file)
"\")\\n"
"'"
" "
">"
" "
,library-rkt-file))))))
(command . ,(lambda (input-file output-file prepend-directories append-directories library-files r6rs?)
(let ((rkt-input-file (if (string=? input-file "")
""
(change-file-suffix input-file ".rkt"))))
(when (not r6rs?)
(when (not (string=? rkt-input-file ""))
(when (file-exists? rkt-input-file)
(delete-file rkt-input-file))
(with-output-to-file
rkt-input-file
(lambda ()
(display "#lang r7rs")
(newline)
(display "(import (except (scheme base) let let-values let*-values string-copy string-copy! string-for-each string-map string-fill! string->list))")
(newline)
(display "(include \"")
(display (path->filename input-file))
(display "\")")
(newline)))))
(apply string-append
`("racket "
,(util-getenv "COMPILE_R7RS_RACKET")
" "
;"-I " ,(if r6rs? "r6rs " "r7rs ")
,@(map (lambda (item)
(string-append "-S " item " "))
(append prepend-directories
append-directories))
" "
,(if r6rs? input-file rkt-input-file)))))))
(sagittarius
(type . interpreter)
(command . ,(lambda (input-file output-file prepend-directories append-directories library-files r6rs?)
(apply string-append
`("sash "
,(util-getenv "COMPILE_R7RS_SAGITTARIUS")
,(if r6rs? " -r6 " " -r7 ")
,@(map (lambda (item)
(string-append " -L " item " "))
prepend-directories)
,@(map (lambda (item)
(string-append " -A " item " "))
append-directories)
" "
,input-file)))))
(skint
(type . interpreter)
(command . ,(lambda (input-file output-file prepend-directories append-directories library-files r6rs?)
(apply string-append
`("skint"
" "
,(util-getenv "COMPILE_R7RS_SKINT")
" "
,@(map (lambda (item)
(string-append "-I " item "/ "))
prepend-directories)
,@(map (lambda (item)
(string-append "-A " item "/ "))
append-directories)
" "
,input-file)))))
(stak
(type . interpreter)
(command . ,(lambda (input-file output-file prepend-directories append-directories library-files r6rs?)
(apply string-append
`("stak"
" "
,(util-getenv "COMPILE_R7RS_STAK")
" "
;,@(map (lambda (item) (string-append "-I " item " ")) prepend-directories)
;,@(map (lambda (item) (string-append "-A " item " ")) append-directories)
" "
,input-file)))))
(stklos
(type . interpreter)
(command . ,(lambda (input-file output-file prepend-directories append-directories library-files r6rs?)
(apply string-append
`("stklos"
" "
,(util-getenv "COMPILE_R7RS_STKLOS")
" "
,@(map (lambda (item)
(string-append "-I " item " "))
prepend-directories)
,@(map (lambda (item)
(string-append "-A " item " "))
append-directories)
" "
,input-file)))))
(tr7
(type . interpreter)
(command . ,(lambda (input-file output-file prepend-directories append-directories library-files r6rs?)
(apply string-append
`("TR7_LIB_PATH="
,@(map (lambda (item)
(string-append item ":"))
prepend-directories)
,@(map (lambda (item)
(string-append item ":"))
append-directories)
" "
"tr7i"
" "
,(util-getenv "COMPILE_R7RS_TR7")
" "
,input-file)))))
(vicare
(type . compiler)
(command . ,(lambda (input-file output-file prepend-directories append-directories library-files r6rs?)
(apply string-append
`("vicare"
" "
,(util-getenv "COMPILE_R7RS_VICARE")
" "
,@(map (lambda (item)
(string-append "-I " item " "))
prepend-directories)
,@(map (lambda (item)
(string-append "-A " item " "))
append-directories)
" "
"--compile-program"
" "
,input-file)))))
(ypsilon
(type . interpreter)
(command . ,(lambda (input-file output-file prepend-directories append-directories library-files r6rs?)
(apply string-append
`("ypsilon"
" "
,(util-getenv "COMPILE_R7RS_YPSILON")
" "
,(if r6rs? "--r6rs" "--r7rs")
" "
"--mute"
" "
"--quiet"
" "
,@(map (lambda (item)
(string-append "--sitelib=" item " "))
prepend-directories)
,@(map (lambda (item)
(string-append "--sitelib=" item " "))
append-directories)
" "
"--top-level-program"
" "
,input-file)))))))

580
libs/data.sld
View File

@ -7,582 +7,4 @@
(srfi 170) (srfi 170)
(libs util)) (libs util))
(export data) (export data)
(begin (include "data.scm"))
(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)))))))))

84
libs/srfi-64-util.scm Normal file
View File

@ -0,0 +1,84 @@
(define (get-number text)
(let
((result
(trim
(string-reverse
(string-copy (string-reverse text) 0 4)))))
(if (not result)
""
result)))
(define (srfi-64-output-read text)
(let ((result (list)))
(for-each
(lambda (line)
(cond
((not (string? line)) #f)
((string-starts-with? line "# of expected passes")
(set! result (append result
(list (cons 'expected-passes
(get-number line))))))
((string-starts-with? line "# of unexpected passes")
(set! result (append result
(list (cons 'unexpected-passes
(get-number line))))))
((string-starts-with? line "# of expected failures")
(set! result (append result
(list (cons 'expected-failures
(get-number line))))))
((string-starts-with? line "# of failures")
(set! result (append result
(list (cons 'failures
(get-number line))))))
((string-starts-with? line "# of skipped")
(set! result (append result
(list (cons 'skipped
(get-number line))))))))
(string-split text #\newline))
(when (not (assoc 'expected-passes result))
(set! result (append result (list (cons 'expected-passes "")))))
(when (not (assoc 'unexpected-passes result))
(set! result (append result (list (cons 'unexpected-passes "")))))
(when (not (assoc 'expected-failures result))
(set! result (append result (list (cons 'expected-failures "")))))
(when (not (assoc 'failures result))
(set! result (append result (list (cons 'failures "")))))
(when (not (assoc 'skipped result))
(set! result (append result (list (cons 'skipped "")))))
result))
(define (line->data line)
(let ((pair (apply cons (map trim-both (string-split line #\:)))))
(cons (string->symbol (car pair)) (cdr pair))))
(define (read-test-data)
(letrec
((looper
(lambda (results line count)
(if (>= count 7)
results
(looper (append results
(if (string-starts-with? line "Test end")
(list)
(list (line->data line))))
(read-line)
(+ count 1))))))
(looper (list) (read-line) 0)))
(define (srfi-64-log-results path)
(letrec
((looper
(lambda (results group line)
(cond
((eof-object? line) results)
((string-starts-with? line "Group begin:")
(looper results `(group . ,(cdr (line->data line))) (read-line)))
((string-starts-with? line "Test begin:")
(looper (append results (list (append (list group) (read-test-data))))
group
(read-line)))
(else (looper results group (read-line)))))))
(with-input-from-file
path
(lambda () (looper (list) '(group . "") (read-line))))))

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

@ -0,0 +1,10 @@
(define-library
(libs srfi-64-util)
(import (scheme base)
(scheme read)
(scheme write)
(scheme file)
(libs util))
(export srfi-64-output-read
srfi-64-log-results)
(include "srfi-64-util.scm"))

213
libs/util.scm Normal file
View File

@ -0,0 +1,213 @@
(define (echo text) (display text) (newline))
(define (cat path) (for-each (lambda (line) (echo line)) (file->list path)))
(define r6rs-schemes '(chezscheme
guile
ikarus
ironscheme
larceny
loko
mosh
racket
sagittarius
ypsilon))
(define r7rs-schemes '(chibi
chicken
cyclone
gambit
foment
gauche
guile
kawa
larceny
loko
meevax
mit-scheme
mosh
racket
sagittarius
skint
stklos
tr7
ypsilon))
(define all-schemes (append r6rs-schemes r7rs-schemes))
(define util-getenv
(lambda (name)
(if (get-environment-variable name)
(get-environment-variable name)
"")))
(define dirname
(lambda (path)
(letrec ((looper (lambda (dirpath)
(cond ((= (string-length dirpath) 0) dirpath)
((char=? (string-ref dirpath 0) #\/) (string-copy dirpath 1))
(else (looper (string-copy dirpath 1)))))))
(string-reverse (looper (string-reverse path))))))
(define string-replace
(lambda (string-content replace with)
(string-map (lambda (c)
(if (char=? c replace)
with c))
string-content)))
(define string-replace-one
(lambda (string-content replace with)
(let ((replaced? #f))
(string-map (lambda (c)
(if (and (not replaced?)
(char=? c replace))
with c))
string-content))))
(define string-replace-one-from-end
(lambda (string-content replace with)
(let ((replaced? #f))
(list->string (reverse (map (lambda (c)
(if (and (not replaced?)
(char=? c replace))
with c))
(reverse (string->list string-content))))))))
(define string-ends-with?
(lambda (string-content end)
(if (and (>= (string-length string-content) (string-length end))
(string=? (string-copy string-content
(- (string-length string-content)
(string-length end)))
end))
#t
#f)))
(define string-starts-with?
(lambda (string-content start)
(if (and (>= (string-length string-content) (string-length start))
(string=? (string-copy string-content
0
(string-length start))
start))
#t
#f)))
(define string-cut-from-end
(lambda (string-content cut-length)
(string-copy string-content
0
(- (string-length string-content) cut-length))))
(define string-find
(lambda (string-content character)
(letrec* ((string-list (string->list string-content))
(looper (lambda (c rest index)
(cond ((null? rest) #f)
((char=? c character) index)
(else (looper (car rest)
(cdr rest)
(+ index 1)))))))
(looper (car string-list)
(cdr string-list)
0))))
(define string-reverse
(lambda (string-content)
(list->string (reverse (string->list string-content)))))
(define (string-split text c)
(letrec* ((looper (lambda (previous rest result)
(if (null? rest)
(append result (list previous))
(if (char=? (car rest) c)
(looper (list)
(cdr rest)
(append result (list previous)))
(looper (append previous (list (car rest)))
(cdr rest)
result)))))
(chars (string->list text)))
(map list->string (looper (list) chars (list)))))
(define path->filename
(lambda (path)
(let ((last-slash-index (string-find (string-reverse path) #\/)))
(cond ((not last-slash-index) path)
(else (string-copy path (- (string-length path)
last-slash-index)))))))
(define change-file-suffix
(lambda (path new-suffix)
(let ((last-dot-index (string-find (string-reverse path) #\.)))
(cond ((not last-dot-index) path)
(else (string-append (string-copy path 0
(- (string-length path)
last-dot-index
1))
new-suffix))))))
(define string-join
(lambda (string-list between)
(apply string-append
(let ((index 0)
(size (length string-list)))
(map
(lambda (item)
(cond ((= index 0) item)
((= index size) item)
(else (string-append item between))))
string-list)))))
(define search-library-file
(lambda (directories path)
(let ((result path))
(for-each
(lambda (directory)
(let ((full-path (string-append directory "/" path)))
(when (file-exists? full-path)
(set! result full-path))))
directories)
result)))
(define (slurp path)
(letrec* ((looper (lambda (result line)
(if (eof-object? line)
result
(looper (append result (list line)) (read-line))))))
(with-input-from-file
path
(lambda ()
(apply string-append
(map (lambda (line)
(string-append line (string #\newline)))
(looper (list) (read-line))))))))
(define (file->list path)
(letrec* ((looper (lambda (result line)
(if (eof-object? line)
result
(looper (append result (list line)) (read-line))))))
(with-input-from-file
path
(lambda ()
(looper (list) (read-line))))))
(define (trim text)
(cond ((not (string? text)) "")
((string=? text "") "")
(else
(letrec* ((looper (lambda (text)
(if (or (null? text)
(not (char-whitespace? (car text))))
(list->string text)
(looper (cdr text))))))
(looper (string->list text))))))
(define (trim-end text)
(string-reverse (trim (string-reverse text))))
(define (trim-both text)
(let ((trimmed (trim text)))
(string-reverse (trim (string-reverse trimmed)))))

141
libs/util.sld
View File

@ -3,141 +3,30 @@
(import (scheme base) (import (scheme base)
(scheme write) (scheme write)
(scheme file) (scheme file)
(scheme char)
(scheme process-context) (scheme process-context)
(foreign c)) (foreign c))
(export string-replace (export echo
cat
r6rs-schemes
r7rs-schemes
all-schemes
string-replace
string-ends-with? string-ends-with?
string-starts-with? string-starts-with?
string-cut-from-end string-cut-from-end
string-find string-find
string-reverse string-reverse
string-split
path->filename path->filename
change-file-suffix change-file-suffix
string-join string-join
util-getenv util-getenv
dirname dirname
search-library-file) search-library-file
(begin slurp
file->list
(define util-getenv trim
(lambda (name) trim-end
(if (get-environment-variable name) trim-both)
(get-environment-variable name) (include "util.scm"))
"")))
(define dirname
(lambda (path)
(letrec ((looper (lambda (dirpath)
(cond ((= (string-length dirpath) 0) dirpath)
((char=? (string-ref dirpath 0) #\/) (string-copy dirpath 1))
(else (looper (string-copy dirpath 1)))))))
(string-reverse (looper (string-reverse path))))))
(define string-replace
(lambda (string-content replace with)
(string-map (lambda (c)
(if (char=? c replace)
with c))
string-content)))
(define string-replace-one
(lambda (string-content replace with)
(let ((replaced? #f))
(string-map (lambda (c)
(if (and (not replaced?)
(char=? c replace))
with c))
string-content))))
(define string-replace-one-from-end
(lambda (string-content replace with)
(let ((replaced? #f))
(list->string (reverse (map (lambda (c)
(if (and (not replaced?)
(char=? c replace))
with c))
(reverse (string->list string-content))))))))
(define string-ends-with?
(lambda (string-content end)
(if (and (>= (string-length string-content) (string-length end))
(string=? (string-copy string-content
(- (string-length string-content)
(string-length end)))
end))
#t
#f)))
(define string-starts-with?
(lambda (string-content start)
(if (and (>= (string-length string-content) (string-length start))
(string=? (string-copy string-content
0
(string-length start))
start))
#t
#f)))
(define string-cut-from-end
(lambda (string-content cut-length)
(string-copy string-content
0
(- (string-length string-content) cut-length))))
(define string-find
(lambda (string-content character)
(letrec* ((string-list (string->list string-content))
(looper (lambda (c rest index)
(cond ((null? rest) #f)
((char=? c character) index)
(else (looper (car rest)
(cdr rest)
(+ index 1)))))))
(looper (car string-list)
(cdr string-list)
0))))
(define string-reverse
(lambda (string-content)
(list->string (reverse (string->list string-content)))))
(define path->filename
(lambda (path)
(let ((last-slash-index (string-find (string-reverse path) #\/)))
(cond ((not last-slash-index) path)
(else (string-copy path (- (string-length path)
last-slash-index)))))))
(define change-file-suffix
(lambda (path new-suffix)
(let ((last-dot-index (string-find (string-reverse path) #\.)))
(cond ((not last-dot-index) path)
(else (string-append (string-copy path 0
(- (string-length path)
last-dot-index
1))
new-suffix))))))
(define string-join
(lambda (string-list between)
(apply string-append
(let ((index 0)
(size (length string-list)))
(map
(lambda (item)
(cond ((= index 0) item)
((= index size) item)
(else (string-append item between))))
string-list)))))
(define search-library-file
(lambda (directories path)
(let ((result path))
(for-each
(lambda (directory)
(let ((full-path (string-append directory "/" path)))
(when (file-exists? full-path)
(set! result full-path))))
directories)
result)))))

321
test-r7rs.scm Normal file
View File

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