Retropikzel
/
compile-scheme
1
0
Fork 0
Code Issues

Compare commits

base: Retropikzel:a94e179efbb0c1d594c6ecdfcd1ccbb5cb687fb7
Branches Tags
Retropikzel:main
Retropikzel:release
Retropikzel:v1.1.1
..
compare: Retropikzel:0e4e8890c4af74db133c1ed381e4be9e6fc86dfb
Branches Tags
Retropikzel:main
Retropikzel:release
Retropikzel:v1.1.1

No commits in common. "a94e179efbb0c1d594c6ecdfcd1ccbb5cb687fb7" and "0e4e8890c4af74db133c1ed381e4be9e6fc86dfb" have entirely different histories.
a94e179efb ... 0e4e8890c4

9 changed files with 260 additions and 555 deletions
Show Stats Expand all files Collapse all files

1
.gitignore vendored
View File

@ -17,4 +17,3 @@ deps
tmp tmp
deb deb
*.deb *.deb
test-result.txt

5
Dockerfile.test
View File

@ -10,14 +10,11 @@ RUN make
ARG SCHEME=chibi ARG SCHEME=chibi
ARG IMAGE=chibi:head ARG IMAGE=chibi:head
FROM schemers/${IMAGE} FROM schemers/${IMAGE}
RUN apt-get update && apt-get install -y \ RUN apt-get update && apt-get install -y make gcc libffi-dev unzip
--no-install-recommends \
build-essential libffi-dev unzip php libreadline-dev
COPY --from=cache /cache /cache COPY --from=cache /cache /cache
WORKDIR /cache/chibi-scheme WORKDIR /cache/chibi-scheme
RUN make install RUN make install
WORKDIR / WORKDIR /
RUN mkdir -p ${HOME}/.snow && echo "()" > ${HOME}/.snow/config.scm
RUN snow-chibi install --always-yes "(foreign c)" RUN snow-chibi install --always-yes "(foreign c)"
RUN snow-chibi install --always-yes "(srfi 170)" RUN snow-chibi install --always-yes "(srfi 170)"
COPY Makefile . COPY Makefile .

45
Makefile
View File

@ -3,7 +3,6 @@ SCHEME=chibi
VERSION=1.0.0 VERSION=1.0.0
R6RSTMP=tmp/${SCHEME}-r6rs R6RSTMP=tmp/${SCHEME}-r6rs
R7RSTMP=tmp/${SCHEME}-r7rs R7RSTMP=tmp/${SCHEME}-r7rs
DOCKERTAG=compile-r7rs-test-${SCHEME}
DOCKERIMG=${SCHEME}:head DOCKERIMG=${SCHEME}:head
ifeq "${SCHEME}" "chicken" ifeq "${SCHEME}" "chicken"
DOCKERIMG="chicken:5" DOCKERIMG="chicken:5"
@ -96,20 +95,8 @@ test-r6rs:
@grep "Test successfull (\"1\" \"2\" \"3\")" ${R6RSTMP}/test-result.txt || (echo "Test failed, output: " && cat ${R6RSTMP}/test-result.txt && exit 1) @grep "Test successfull (\"1\" \"2\" \"3\")" ${R6RSTMP}/test-result.txt || (echo "Test failed, output: " && cat ${R6RSTMP}/test-result.txt && exit 1)
test-r6rs-docker: test-r6rs-docker:
docker build -f Dockerfile.test --build-arg IMAGE=${DOCKERIMG} --build-arg SCHEME=${SCHEME} --tag=${DOCKERTAG} . 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 ${DOCKERTAG} sh -c "make SCHEME=${SCHEME} test-r6rs" docker run -v "${PWD}":/workdir -w /workdir -t compile-r7rs-test-${SCHEME} sh -c "make SCHEME=${SCHEME} test-r6rs"
test-r6rs-php:
rm -rf ${R6RSTMP}
mkdir -p ${R6RSTMP}
cp -r r6rs-php-testfiles/* ${R6RSTMP}/
cd ${R6RSTMP} && COMPILE_R7RS=${SCHEME} COMPILE_R7RS_TARGET=php compile-r7rs -o main.php main.sps
-cd ${R6RSTMP} && php main.php > test-result.txt 2>&1
@grep "Test successfull" ${R6RSTMP}/test-result.txt || (echo "Test failed, output: " && cat ${R6RSTMP}/test-result.txt && exit 1)
test-r6rs-php-docker:
docker build -f Dockerfile.test --build-arg IMAGE=${DOCKERIMG} --build-arg SCHEME=${SCHEME} --tag=${DOCKERTAG} .
docker run -v "${PWD}":/workdir -w /workdir -t ${DOCKERTAG} sh -c "make SCHEME=${SCHEME} test-r6rs-php"
test-r7rs: test-r7rs:
rm -rf ${R7RSTMP} rm -rf ${R7RSTMP}
@ -120,32 +107,8 @@ test-r7rs:
@grep "Test successfull (\"1\" \"2\" \"3\")" ${R7RSTMP}/test-result.txt || (echo "Test failed, output: " && cat ${R7RSTMP}/test-result.txt && exit 1) @grep "Test successfull (\"1\" \"2\" \"3\")" ${R7RSTMP}/test-result.txt || (echo "Test failed, output: " && cat ${R7RSTMP}/test-result.txt && exit 1)
test-r7rs-docker: test-r7rs-docker:
docker build -f Dockerfile.test --build-arg IMAGE=${DOCKERIMG} --build-arg SCHEME=${SCHEME} --tag=${DOCKERTAG} . 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 ${DOCKERTAG} sh -c "make SCHEME=${SCHEME} test-r7rs" docker run -v "${PWD}":/workdir -w /workdir -t compile-r7rs-test-${SCHEME} sh -c "make SCHEME=${SCHEME} test-r7rs"
test-r7rs-wine:
rm -rf ${R7RSTMP}
mkdir -p ${R7RSTMP}
cp -r r7rs-testfiles/* ${R7RSTMP}/
cd ${R7RSTMP} && COMPILE_R7RS=${SCHEME} COMPILE_R7RS_TARGET=windows compile-r7rs -I ./libs -o main.bat main.scm
-cd ${R7RSTMP} && wine main.bat 1 2 3 > test-result.txt 2>&1
@grep "Test successfull (\"1\" \"2\" \"3\")" ${R7RSTMP}/test-result.txt || (echo "Test failed, output: " && cat ${R7RSTMP}/test-result.txt && exit 1)
test-r7rs-wine-docker:
docker build -f Dockerfile.test --build-arg IMAGE=${DOCKERIMG} --build-arg SCHEME=${SCHEME} --tag=${DOCKERTAG} .
docker run -v "${PWD}":/workdir -w /workdir -t ${DOCKERTAG} sh -c "make SCHEME=${SCHEME} test-r7rs-wine"
test-r7rs-php:
rm -rf ${R7RSTMP}
mkdir -p ${R7RSTMP}
cp -r r7rs-php-testfiles/* ${R7RSTMP}/
cd ${R7RSTMP} && COMPILE_R7RS=${SCHEME} COMPILE_R7RS_TARGET=php compile-r7rs -o main.php main.scm
-cd ${R7RSTMP} && php main.php > test-result.txt 2>&1
@grep "Test successfull" ${R7RSTMP}/test-result.txt || (echo "Test failed, output: " && cat ${R7RSTMP}/test-result.txt && exit 1)
test-r7rs-php-docker:
docker build -f Dockerfile.test --build-arg IMAGE=${DOCKERIMG} --build-arg SCHEME=${SCHEME} --tag=${DOCKERTAG} .
docker run -v "${PWD}":/workdir -w /workdir -t ${DOCKERTAG} sh -c "make SCHEME=${SCHEME} test-r7rs-php"
clean: clean:
rm -rf test-r7rs rm -rf test-r7rs

192
compile-r7rs.scm
View File

@ -9,20 +9,17 @@
(libs library-util) (libs library-util)
(srfi 170)) (srfi 170))
(when (or (member "--list-r6rs" (command-line)) (when (member "--list-r6rs-schemes" (command-line))
(member "--list-r6rs-schemes" (command-line)))
(for-each (lambda (scheme) (display scheme) (display " ")) r6rs-schemes) (for-each (lambda (scheme) (display scheme) (display " ")) r6rs-schemes)
(newline) (newline)
(exit 0)) (exit 0))
(when (or (member "--list-r7rs" (command-line)) (when (member "--list-r7rs-schemes" (command-line))
(member "--list-r7rs-schemes" (command-line)))
(for-each (lambda (scheme) (display scheme) (display " ")) r7rs-schemes) (for-each (lambda (scheme) (display scheme) (display " ")) r7rs-schemes)
(newline) (newline)
(exit 0)) (exit 0))
(when (or (member "--list" (command-line)) (when (member "--list-schemes" (command-line))
(member "--list-schemes" (command-line)))
(for-each (lambda (scheme) (display scheme) (display " ")) all-schemes) (for-each (lambda (scheme) (display scheme) (display " ")) all-schemes)
(newline) (newline)
(exit 0)) (exit 0))
@ -35,11 +32,10 @@
(newline (current-error-port)) (newline (current-error-port))
(exit 1)) (exit 1))
(when (not (assoc scheme data)) (error "Unsupported implementation" scheme)) (when (not (assoc scheme data)) (error "Unsupported implementation" scheme))
(define compilation-target (define compilation-target (if (get-environment-variable "TARGET")
(if (get-environment-variable "COMPILE_R7RS_TARGET") (get-environment-variable "TARGET")
(string->symbol (get-environment-variable "COMPILE_R7RS_TARGET")) (cond-expand (windows "windows")
(cond-expand (windows 'windows) (else "unix"))))
(else 'unix))))
(define input-file (define input-file
(let ((input-file #f)) (let ((input-file #f))
@ -68,18 +64,12 @@
#t #t
#f)) #f))
(define scheme-type (cdr (assoc 'type (cdr (assoc scheme data)))))
(define output-file (define output-file
(let ((outfile (if (member "-o" (command-line)) (if (member "-o" (command-line))
(cadr (member "-o" (command-line))) (cadr (member "-o" (command-line)))
(if input-file (if input-file
"a.out" "a.out"
#f)))) #f)))
(if (and (symbol=? scheme-type 'compiler)
(symbol=? compilation-target 'php))
(string-append outfile ".bin")
outfile)))
(define prepend-directories (define prepend-directories
(letrec ((looper (lambda (rest result) (letrec ((looper (lambda (rest result)
@ -158,29 +148,16 @@
(list) (list)
(list))) (list)))
(define scheme-type (cdr (assoc 'type (cdr (assoc scheme data)))))
(define scheme-command (define scheme-command
(apply (cdr (assoc 'command (cdr (assoc scheme data)))) (apply (cdr (assoc 'command (cdr (assoc scheme data))))
(list (list (if input-file input-file "")
(cond
((symbol=? compilation-target 'windows) "")
((symbol=? compilation-target 'php) "")
(else "exec"))
;; How to get the script file
(cond
((symbol=? compilation-target 'windows) "%0%")
((symbol=? compilation-target 'php) "$binname")
(else "$(cd -- \"$(dirname \"$0\")\" >/dev/null 2>&1 && pwd -P)/\"$0\""))
(cond
((symbol=? compilation-target 'windows) "")
((symbol=? compilation-target 'php) "")
(else "\"$@\""))
(if input-file input-file "")
(if output-file output-file "") (if output-file output-file "")
prepend-directories prepend-directories
append-directories append-directories
library-files library-files
r6rs? r6rs?)))
compilation-target)))
(define scheme-library-command (define scheme-library-command
(lambda (library-file) (lambda (library-file)
@ -199,95 +176,112 @@
result)))))) result))))))
(looper (command-line) (list)))) (looper (command-line) (list))))
;(display "Scheme ")
;(display scheme)
;(newline)
;(display "Type ")
;(display scheme-type)
;(newline)
;(newline)
; Compile libraries
(when (not (null? library-files)) (when (not (null? library-files))
#;(if single-library-input-file
(display "Given library file: ")
(display "Found library files: "))
;(display library-files)
;(newline)
(when (assoc 'library-command (cdr (assoc scheme data))) (when (assoc 'library-command (cdr (assoc scheme data)))
(for-each (for-each
(lambda (file) (lambda (file)
(let* ((library-command (scheme-library-command file))) (let* ((library-command (scheme-library-command file)))
;(display "Compiling library ")
;(display file)
;(newline)
(for-each (for-each
(lambda (command) (lambda (command)
;(display "Running ")
;(write command)
;(newline)
;(display "Exit code ")
(let ((exit-code (c-system (string->c-utf8 command)))) (let ((exit-code (c-system (string->c-utf8 command))))
;(display exit-code)
;(newline)
(when (not (= exit-code 0)) (when (not (= exit-code 0))
(exit exit-code)))) (exit exit-code))))
library-command))) library-command)))
library-files))) library-files)))
; Create executable file
(when (and (equal? scheme-type 'interpreter) input-file) (when (and (equal? scheme-type 'interpreter) input-file)
(when (and output-file (file-exists? output-file)) (when (and output-file (file-exists? output-file))
(delete-file output-file)) (delete-file output-file))
(let ((scheme-program (slurp input-file))) (let ((shebang-line (string-append
(with-output-to-file (cond ((string=? compilation-target "unix")
output-file (string-append
(lambda () "#!/bin/sh"
(cond (string #\newline)
((symbol=? compilation-target 'windows)
(for-each
display
`(";dir; start /WAIT " ,scheme-command " && exit"
#\newline
,scheme-program
)))
((symbol=? compilation-target 'php)
(for-each
display
`("<?php"
" $descriptorspec = array(0 => fopen('php://stdin', 'r'), 1 => array('pipe', 'w'), 2 => fopen('php://stderr', 'w'));"
" $cwd = '.';"
" $filepath = $_SERVER['SCRIPT_FILENAME'];"
" $filename = $_SERVER['SCRIPT_NAME'];"
" $binname = '/tmp/test.bin';"
" system(\"tail -n+3 $filepath > $binname\");"
" $scheme_command = \"" ,scheme-command "\";"
" $process = proc_open($scheme_command, $descriptorspec, $pipes, $cwd, $_ENV);"
" echo stream_get_contents($pipes[1]);"
" die();"
" ?>"
#\newline
#\newline
,scheme-program)))
(else
(for-each
display
`(#\newline
"#|" "#|"
#\newline (string #\newline)
,scheme-command "tmpfile=$(mktemp)"
#\newline (string #\newline)
"tail -n+9 \"$0\" > ${tmpfile}"
(string #\newline)))
((string=? compilation-target "windows")
(string-append
"@echo off"
(string #\newline)
"start")))
scheme-command
(cond ((string=? compilation-target "unix")
(string-append
" \"$@\""
(string #\newline)
"rm -rf ${tmpfile}"
(string #\newline)
"exit"
(string #\newline)
"|#" "|#"
#\newline (string #\newline)))
,scheme-program)))))) ((string=? compilation-target "windows")
(cond ((symbol=? compilation-target 'unix) ""))))
(scheme-program (slurp input-file)))
;(display "Creating startup script ")
;(display output-file)
;(newline)
;(display "Starting with ")
;(display shebang-line)
;(newline)
(with-output-to-file
(if (string=? compilation-target "windows")
(string-append output-file ".bat")
output-file)
(lambda ()
(display shebang-line)
(newline)
(display scheme-program)
(newline)))
(cond ((string=? compilation-target "unix")
(c-system (string->c-utf8 (string-append "chmod +x " output-file))))))) (c-system (string->c-utf8 (string-append "chmod +x " output-file)))))))
(when (and (symbol=? scheme-type 'compiler) input-file) (when (and (equal? scheme-type 'compiler) input-file)
(when (and output-file (file-exists? output-file)) (when (and output-file (file-exists? output-file))
(delete-file output-file)) (delete-file output-file))
;(display "Compiling file ")
;(display input-file)
;(newline)
(for-each (for-each
(lambda (command) (lambda (command)
;(display "Running ")
;(write command)
;(newline)
;(display "Exit code ")
(let ((exit-code (c-system (string->c-utf8 command)))) (let ((exit-code (c-system (string->c-utf8 command))))
;(display exit-code)
;(newline)
(when (not (= exit-code 0)) (when (not (= exit-code 0))
(exit exit-code)))) (exit exit-code))))
scheme-command) scheme-command)
(cond ;(newline)
((symbol=? compilation-target 'php) )
(let* ((php-file (string-cut-from-end output-file 4))
(port (open-binary-output-file php-file))
(bin (slurp-bytes output-file)))
(for-each
(lambda (item) (write-bytevector (string->utf8 item) port))
`("<?php"
" $descriptorspec = array(0 => fopen('php://stdin', 'r'), 1 => array('pipe', 'w'), 2 => fopen('php://stderr', 'w'));"
" $cwd = '.';"
" $filepath = $_SERVER['SCRIPT_FILENAME'];"
" $binname = '/tmp/test.bin';"
" system(\"tail -n+3 $filepath > $binname\");"
" $process = proc_open($binname, $descriptorspec, $pipes, $cwd, $_ENV);"
" echo stream_get_contents($pipes[1]);"
" die();"
" ?>"
,(string #\newline)
,(string #\newline)))
(write-bytevector bin port)
(close-output-port port)))
(else #t)))

511
libs/data.sld
View File

@ -8,24 +8,13 @@
(libs util)) (libs util))
(export data) (export data)
(begin (begin
(define pwd (cond-expand (windows "%CD%") (else "${PWD}")))
(define data (define data
`((chezscheme `((chezscheme
(type . interpreter) (type . interpreter)
(command . ,(lambda (exec-cmd (command . ,(lambda (input-file output-file prepend-directories append-directories library-files r6rs?)
script-file
args
input-file
output-file
prepend-directories
append-directories
library-files
r6rs?
compilation-target)
(let ((separator (cond-expand (windows ";") (else ":")))) (let ((separator (cond-expand (windows ";") (else ":"))))
(apply string-append (apply string-append
`(,exec-cmd `("chezscheme "
" chezscheme "
,(util-getenv "COMPILE_R7RS_CHEZSCHEME") ,(util-getenv "COMPILE_R7RS_CHEZSCHEME")
" " " "
,(if (and (null? prepend-directories) ,(if (and (null? prepend-directories)
@ -33,41 +22,29 @@
"" ""
(apply string-append (apply string-append
(list "--libdirs " (list "--libdirs "
"'" "\""
(apply string-append (apply string-append
(map (lambda (item) (map (lambda (item)
(string-append item separator)) (string-append item separator))
(append prepend-directories append-directories))) (append prepend-directories append-directories)))
"'"))) "\"")))
" --program " " --program ${tmpfile}"))))))
,script-file
" "
,args))))))
(chibi (chibi
(type . interpreter) (type . interpreter)
(command . ,(lambda (exec-cmd (command . ,(lambda (input-file output-file prepend-directories append-directories library-files r6rs?)
script-file
args
input-file
output-file
prepend-directories
append-directories
library-files
r6rs
compilation-target)
(apply string-append (apply string-append
`(,exec-cmd `("chibi-scheme"
" 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)
,script-file
" " " "
,args))))) ,(util-getenv "COMPILE_R7RS_CHIBI")
" "
,@(map (lambda (item)
(string-append "-I" " " item " "))
prepend-directories)
" "
,@(map (lambda (item)
(string-append "-A" " " item " "))
append-directories)
" ${tmpfile}")))))
(chicken (chicken
(type . compiler) (type . compiler)
(library-command . ,(lambda (library-file prepend-directories append-directories r6rs?) (library-command . ,(lambda (library-file prepend-directories append-directories r6rs?)
@ -97,26 +74,18 @@
"-unit " "-unit "
unit) unit)
,(string-append "ar rcs " static-out " " out))))) ,(string-append "ar rcs " static-out " " out)))))
(command . ,(lambda (exec-cmd (command . ,(lambda (input-file output-file prepend-directories append-directories library-files r6rs?)
script-file
args
input-file
output-file
prepend-directories
append-directories
library-files
r6rs?
compilation-target)
`(,(string-append "csc -R r7rs -X r7rs " `(,(string-append "csc -R r7rs -X r7rs "
(util-getenv "COMPILE_R7RS_CHICKEN") (util-getenv "COMPILE_R7RS_CHICKEN")
" -static " " -static "
" "
(apply string-append (apply string-append
(map (lambda (item) (map (lambda (item)
(string-append " -I " item " ")) (string-append "-I " item " "))
(append append-directories prepend-directories))) (append append-directories prepend-directories)))
(apply string-append (apply string-append
(map (lambda (library-file) (map (lambda (library-file)
(string-append " -uses " (string-append "-uses "
(if (string-starts-with? library-file "srfi") (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) #\/ #\-)
(string-replace (string-cut-from-end library-file 4) #\/ #\.)) (string-replace (string-cut-from-end library-file 4) #\/ #\.))
@ -139,16 +108,7 @@
(search-library-file (append prepend-directories (search-library-file (append prepend-directories
append-directories) append-directories)
library-file))))) library-file)))))
(command . ,(lambda (exec-cmd (command . ,(lambda (input-file output-file prepend-directories append-directories library-files r6rs?)
script-file
args
input-file
output-file
prepend-directories
append-directories
library-files
r6rs?
compilation-target)
`(,(string-append "cyclone " `(,(string-append "cyclone "
(util-getenv "COMPILE_R7RS_CYCLONE") (util-getenv "COMPILE_R7RS_CYCLONE")
" " " "
@ -166,29 +126,18 @@
"sleep 0")))))) "sleep 0"))))))
(foment (foment
(type . interpreter) (type . interpreter)
(command . ,(lambda (exec-cmd (command . ,(lambda (input-file output-file prepend-directories append-directories library-files r6rs?)
script-file
args
input-file
output-file
prepend-directories
append-directories
library-files
r6rs?
compilation-target)
(apply string-append (apply string-append
`(,exec-cmd `("foment "
" foment "
,(util-getenv "COMPILE_R7RS_FOMENT") ,(util-getenv "COMPILE_R7RS_FOMENT")
" "
,@(map (lambda (item) ,@(map (lambda (item)
(string-append " -I" " " item " ")) (string-append "-I" " " item " "))
prepend-directories) prepend-directories)
,@(map (lambda (item) ,@(map (lambda (item)
(string-append " -A" " " item " ")) (string-append "-A" " " item " "))
append-directories) append-directories)
,script-file " ${tmpfile}")))))
" "
,args)))))
#;(gambit #;(gambit
(type . compiler) (type . compiler)
(library-command . ,(lambda (library-file prepend-directories append-directories r6rs?) (library-command . ,(lambda (library-file prepend-directories append-directories r6rs?)
@ -222,32 +171,18 @@
output-tmp-file)))))) output-tmp-file))))))
(gauche (gauche
(type . interpreter) (type . interpreter)
(command . ,(lambda (exec-cmd (command . ,(lambda (input-file output-file prepend-directories append-directories library-files r6rs?)
script-file
args
input-file
output-file
prepend-directories
append-directories
library-files
r6rs?
compilation-target)
(apply string-append (apply string-append
`(,exec-cmd `("gosh "
,(if (symbol=? compilation-target 'windows)
" gosh.exe "
" gosh ")
,(util-getenv "COMPILE_R7RS_GAUCHE") ,(util-getenv "COMPILE_R7RS_GAUCHE")
" -r7 " " -r7 "
,@(map (lambda (item) ,@(map (lambda (item)
(string-append " -I" " " item " ")) (string-append "-I" " " item " "))
prepend-directories) prepend-directories)
,@(map (lambda (item) ,@(map (lambda (item)
(string-append " -A" " " item " ")) (string-append "-A" " " item " "))
append-directories) append-directories)
,script-file " ${tmpfile}")))))
" "
,args)))))
(guile (guile
(type . interpreter) (type . interpreter)
(library-command . ,(lambda (library-file prepend-directories append-directories r6rs?) (library-command . ,(lambda (library-file prepend-directories append-directories r6rs?)
@ -267,69 +202,32 @@
(string-cut-from-end library-path 4) (string-cut-from-end library-path 4)
".go") ".go")
library-path))))) library-path)))))
(command . ,(lambda (exec-cmd (command . ,(lambda (input-file output-file prepend-directories append-directories library-files r6rs?)
script-file
args
input-file
output-file
prepend-directories
append-directories
library-files
r6rs?
compilation-target)
(apply string-append (apply string-append
`(,exec-cmd `("guile "
" guile "
,(util-getenv "COMPILE_R7RS_GUILE") ,(util-getenv "COMPILE_R7RS_GUILE")
,(if r6rs? " --r6rs -x .sls " " --r7rs -x .sld ") ,(if r6rs? " --r6rs -x .sls " " --r7rs -x .sld ")
,@(map (lambda (item) ,@(map (lambda (item)
(string-append " -L " item " " (string-append "-L " item " "
" -L " (dirname item) " ")) "-L " (dirname item) " "))
(append prepend-directories (append prepend-directories
append-directories)) append-directories))
" -s " " -s ${tmpfile}")))))
,script-file
" "
,args)))))
(ikarus (ikarus
(type . interpreter) (type . interpreter)
(command . ,(lambda (exec-cmd (command . ,(lambda (input-file output-file prepend-directories append-directories library-files r6rs?)
script-file
args
input-file
output-file
prepend-directories
append-directories
library-files
r6rs
compilation-target)
(apply string-append (apply string-append
`( "IKARUS_LIBRARY_PATH=" `( "IKARUS_LIBRARY_PATH="
,@(map (lambda (item) (string-append item ":")) prepend-directories) ,@(map (lambda (item) (string-append item ":")) prepend-directories)
,@(map (lambda (item) (string-append item ":")) append-directories) ,@(map (lambda (item) (string-append item ":")) append-directories)
" "
,exec-cmd
" ikarus " " ikarus "
,(util-getenv "COMPILE_R7RS_IKARUS") ,(util-getenv "COMPILE_R7RS_IKARUS")
" --r6rs-script " " --r6rs-script ${tmpfile}")))))
,script-file
" "
,args)))))
(ironscheme (ironscheme
(type . interpreter) (type . interpreter)
(command . ,(lambda (exec-cmd (command . ,(lambda (input-file output-file prepend-directories append-directories library-files r6rs?)
script-file
args
input-file
output-file
prepend-directories
append-directories
library-files
r6rs
compilation-target)
(apply string-append (apply string-append
`(,exec-cmd `("ironscheme "
" ironscheme "
,(util-getenv "COMPILE_R7RS_IRONSCHEME") ,(util-getenv "COMPILE_R7RS_IRONSCHEME")
" " " "
,@(map (lambda (item) ,@(map (lambda (item)
@ -338,83 +236,90 @@
,@(map (lambda (item) ,@(map (lambda (item)
(string-append "-I \"" item "\" ")) (string-append "-I \"" item "\" "))
append-directories) append-directories)
,script-file " ${tmpfile}")))))
" "
,args)))))
(kawa (kawa
(type . interpreter) (type . interpreter)
(command . ,(lambda (exec-cmd (command . ,(lambda (input-file output-file prepend-directories append-directories library-files r6rs?)
script-file
args
input-file
output-file
prepend-directories
append-directories
library-files
r6rs?
compilation-target)
(apply string-append (apply string-append
`("CLASSPATH=" `("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 -J--enable-preview "
,@(map (lambda (item)
(if (char=? (string-ref item 0) #\/)
(string-append item ":")
(string-append pwd "/" item ":")))
(append prepend-directories
append-directories))
" "
,exec-cmd
" 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 -J--enable-preview "
,(util-getenv "COMPILE_R7RS_KAWA") ,(util-getenv "COMPILE_R7RS_KAWA")
" -Dkawa.import.path=" " -Dkawa.import.path="
,@(map (lambda (item) ,@(map (lambda (item)
(if (char=? (string-ref item 0) #\/) (string-append item "/*.sld:"))
(string-append item "/*.sld")
(string-append pwd "/" item "/*.sld")))
(append prepend-directories (append prepend-directories
append-directories)) append-directories))
" -f " " --script1 ${0}"))))
,script-file (command-old . ,(lambda (input-file output-file prepend-directories append-directories library-files r6rs?)
" " (set! append-directories
,args))))) (append append-directories
(list "/usr/local/share/kawa/lib")))
(let* ((output-jar (string-append output-file ".jar"))
(main-class
(string-append (string-cut-from-end (path->filename input-file)
4)))
(kawa-jar-path "/usr/local/share/kawa/lib/kawa.jar")
(classpath
(string-append
kawa-jar-path " "
(apply
string-append
(map (lambda (dir)
(string-append dir " "))
(append prepend-directories append-directories)))))
(import-paths
(apply
string-append
`("-Dkawa.import.path="
,@(map (lambda (dir)
(string-append dir "/*.sld:"))
(append prepend-directories append-directories))
"*.sld")))
(library-dirs (apply string-append
(append (map (lambda (item)
(string-append item " "))
(append prepend-directories
append-directories)))))
(class-files
(apply
string-append
(map
(lambda (lib)
(string-append
(string-cut-from-end
(search-library-file (append prepend-directories
append-directories)
lib)
4)
".class "))
library-files))))
`(,(string-append "rm -rf " output-jar)
,(string-append
"echo 'Main-Class: " main-class "\nClass-Path: . " classpath "' > MANIFEST.mf")
,(string-append "kawa " import-paths " --main -C " input-file)
,(string-append "jar cfm " output-jar " MANIFEST.mf " main-class ".class ")
,(string-append "jar uf " output-jar " " library-dirs)
,(string-append "printf '#!/bin/sh\nMYSELF=$(which \"$0\" 2>/dev/null)\n[ $? -gt 0 -a -f \"$0\" ] && MYSELF=\"./$0\"\njava=java\nif test -n \"$JAVA_HOME\"; then\n java=\"$JAVA_HOME/bin/java\"\nfi\nexec \"$java\" --add-exports=java.base/jdk.internal.foreign.abi=ALL-UNNAMED --add-exports=java.base/jdk.internal.foreign.layout=ALL-UNNAMED --add-exports=java.base/jdk.internal.foreign=ALL-UNNAMED --enable-native-access=ALL-UNNAMED --enable-preview -jar $MYSELF \"$@\"\nexit 1\n' > " output-file)
,(string-append "cat " output-jar " >> " output-file)
,(string-append "rm -rf " output-jar)
,(string-append "chmod +x " output-file))))))
(larceny (larceny
(type . interpreter) (type . interpreter)
(command . ,(lambda (exec-cmd (command . ,(lambda (input-file output-file prepend-directories append-directories library-files r6rs?)
script-file
args
input-file
output-file
prepend-directories
append-directories
library-files
r6rs?
compilation-target)
(apply string-append (apply string-append
`(,exec-cmd `("larceny -nobanner -quiet -utf8 "
" larceny -nobanner -quiet -utf8 "
,(if r6rs? " -r6 " " -r7 ") ,(if r6rs? " -r6 " " -r7 ")
,(util-getenv "COMPILE_R7RS_LARCENY") ,(util-getenv "COMPILE_R7RS_LARCENY")
" "
,@(map (lambda (item) ,@(map (lambda (item)
(string-append " -I " item " ")) (string-append "-I " item " "))
prepend-directories) prepend-directories)
,@(map (lambda (item) ,@(map (lambda (item)
(string-append " -A " item " ")) (string-append "-A " item " "))
append-directories) append-directories)
" -program " " -program ${tmpfile} --")))))
,script-file
" -- "
,args)))))
(loko (loko
(type . compiler) (type . compiler)
(command . ,(lambda (exec-cmd (command . ,(lambda (input-file output-file prepend-directories append-directories library-files r6rs?)
script-file
args
input-file
output-file
prepend-directories
append-directories
library-files
r6rs?
compilation-target)
(let ((out (string-cut-from-end input-file 4))) (let ((out (string-cut-from-end input-file 4)))
`(,(string-append "LOKO_LIBRARY_PATH=" `(,(string-append "LOKO_LIBRARY_PATH="
(apply string-append (apply string-append
@ -436,74 +341,34 @@
,(string-append "mv " out " " output-file)))))) ,(string-append "mv " out " " output-file))))))
(meevax (meevax
(type . interpreter) (type . interpreter)
(command . ,(lambda (exec-cmd (command . ,(lambda (input-file output-file prepend-directories append-directories library-files r6rs?)
script-file
args
input-file
output-file
prepend-directories
append-directories
library-files
r6rs
compilation-target)
(apply string-append (apply string-append
`(,exec-cmd `("meevax "
" meevax "
,(util-getenv "COMPILE_R7RS_MEEVAX") ,(util-getenv "COMPILE_R7RS_MEEVAX")
,@(map (lambda (item) ,@(map (lambda (item)
(if (char=? (string-ref item 0) #\/) (string-append " -I" " " item " "))
(string-append " -I " pwd "/" item " ")
(string-append " -I " item " ")))
prepend-directories) prepend-directories)
,@(map (lambda (item) ,@(map (lambda (item)
(if (char=? (string-ref item 0) #\/) (string-append " -A" " " item " "))
(string-append " -A " pwd "/" item " ")
(string-append " -A " item " ")))
append-directories) append-directories)
,script-file " ${tmpfile}")))))
" "
,args)))))
(mit-scheme (mit-scheme
(type . interpreter) (type . interpreter)
(command . ,(lambda (exec-cmd (command . ,(lambda (input-file output-file prepend-directories append-directories library-files r6rs?)
script-file
args
input-file
output-file
prepend-directories
append-directories
library-files
r6rs
compilation-target)
(apply string-append (apply string-append
`(,exec-cmd `("mit-scheme --batch-mode --no-init-file "
" mit-scheme --batch-mode --no-init-file "
,@(map ,@(map
(lambda (item) (lambda (item)
(string-append " --load " (string-append "--load "
(search-library-file (append append-directories (search-library-file (append append-directories
prepend-directories) prepend-directories)
item) item)
" ")) " "))
library-files) library-files)
" --load " " --load \"${tmpfile}\" --eval \"(exit 0)\" --args")))))
,script-file
" --eval '(exit 0)' "
,(if (string=? args "")
""
(string-append " --args " args)))))))
(mosh (mosh
(type . interpreter) (type . interpreter)
(command . ,(lambda (exec-cmd (command . ,(lambda (input-file output-file prepend-directories append-directories library-files r6rs?)
script-file
args
input-file
output-file
prepend-directories
append-directories
library-files
r6rs
compilation-target)
(let ((dirs (append append-directories prepend-directories))) (let ((dirs (append append-directories prepend-directories)))
(apply string-append (apply string-append
`(,(if (> (length dirs) 0) `(,(if (> (length dirs) 0)
@ -512,13 +377,9 @@
(apply string-append (apply string-append
(map (lambda (item) (string-append item ":")) dirs))) (map (lambda (item) (string-append item ":")) dirs)))
"") "")
" "
,exec-cmd
" mosh " " mosh "
,(util-getenv "COMPILE_R7RS_MOSH") ,(util-getenv "COMPILE_R7RS_MOSH")
,script-file " ${tmpfile}"))))))
" "
,args))))))
(racket (racket
(type . interpreter) (type . interpreter)
(library-command . ,(lambda (library-file prepend-directories append-directories r6rs?) (library-command . ,(lambda (library-file prepend-directories append-directories r6rs?)
@ -527,59 +388,31 @@
library-file)) library-file))
(library-rkt-file (change-file-suffix full-path ".rkt"))) (library-rkt-file (change-file-suffix full-path ".rkt")))
(if r6rs? (if r6rs?
`("sleep 0") ;`(,(string-append "plt-r6rs --compile " library-file)) `(,(string-append "plt-r6rs --compile " library-file))
`(,(string-append "printf " `(,(string-append "printf "
"'#lang r7rs\\n" "'#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" "(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' > " "(include \"" (path->filename library-file) "\")\\n' > "
library-rkt-file)))))) library-rkt-file))))))
(command . ,(lambda (exec-cmd (command . ,(lambda (input-file output-file prepend-directories append-directories library-files r6rs?)
script-file
args
input-file
output-file
prepend-directories
append-directories
library-files
r6rs?
compilation-target)
(let ((rkt-input-file (if (string=? input-file "") (let ((rkt-input-file (if (string=? input-file "")
"" ""
(change-file-suffix input-file ".rkt")))) (change-file-suffix input-file ".rkt"))))
(apply string-append (apply string-append
`(,exec-cmd `("racket "
,(if r6rs?
" plt-r6rs "
" racket ")
,(util-getenv "COMPILE_R7RS_RACKET") ,(util-getenv "COMPILE_R7RS_RACKET")
,(if r6rs? "" " -I r7rs ") ,(if r6rs? " -I r6rs " " -I r7rs ")
,@(map (lambda (item) ,@(map (lambda (item)
(string-append (string-append " -S " item " "))
(if r6rs? " ++path " " -S ")
item " "))
(append prepend-directories (append prepend-directories
append-directories)) append-directories))
,(if r6rs? "" " --script ") ,(if r6rs? "" " --script ")
,script-file " ${tmpfile}"))))))
" "
,args))))))
(sagittarius (sagittarius
(type . interpreter) (type . interpreter)
(command . ,(lambda (exec-cmd (command . ,(lambda (input-file output-file prepend-directories append-directories library-files r6rs?)
script-file
args
input-file
output-file
prepend-directories
append-directories
library-files
r6rs?
compilation-target)
(apply string-append (apply string-append
`(,exec-cmd `("sash -d "
,(if (symbol=? compilation-target 'windows)
" sash.exe -d "
" sash -d ")
,(util-getenv "COMPILE_R7RS_SAGITTARIUS") ,(util-getenv "COMPILE_R7RS_SAGITTARIUS")
,(if r6rs? " -r6 " " -r7 ") ,(if r6rs? " -r6 " " -r7 ")
,@(map (lambda (item) ,@(map (lambda (item)
@ -588,24 +421,12 @@
,@(map (lambda (item) ,@(map (lambda (item)
(string-append " -A " item " ")) (string-append " -A " item " "))
append-directories) append-directories)
,script-file " ${tmpfile}")))))
" "
,args)))))
(skint (skint
(type . interpreter) (type . interpreter)
(command . ,(lambda (exec-cmd (command . ,(lambda (input-file output-file prepend-directories append-directories library-files r6rs?)
script-file
args
input-file
output-file
prepend-directories
append-directories
library-files
r6rs
compilation-target)
(apply string-append (apply string-append
`(,exec-cmd `("skint "
" skint "
,(util-getenv "COMPILE_R7RS_SKINT") ,(util-getenv "COMPILE_R7RS_SKINT")
" " " "
,@(map (lambda (item) ,@(map (lambda (item)
@ -614,25 +435,12 @@
,@(map (lambda (item) ,@(map (lambda (item)
(string-append "-A " item "/ ")) (string-append "-A " item "/ "))
append-directories) append-directories)
" --program=" " --program=${tmpfile}")))))
,script-file
" "
,args)))))
(stklos (stklos
(type . interpreter) (type . interpreter)
(command . ,(lambda (exec-cmd (command . ,(lambda (input-file output-file prepend-directories append-directories library-files r6rs?)
script-file
args
input-file
output-file
prepend-directories
append-directories
library-files
r6rs?
compilation-target)
(apply string-append (apply string-append
`(,exec-cmd `("stklos "
" stklos "
,(util-getenv "COMPILE_R7RS_STKLOS") ,(util-getenv "COMPILE_R7RS_STKLOS")
" " " "
,@(map (lambda (item) ,@(map (lambda (item)
@ -641,48 +449,24 @@
,@(map (lambda (item) ,@(map (lambda (item)
(string-append "-A " item " ")) (string-append "-A " item " "))
append-directories) append-directories)
,script-file " ${tmpfile}")))))
" "
,args)))))
(tr7 (tr7
(type . interpreter) (type . interpreter)
(command . ,(lambda (exec-cmd (command . ,(lambda (input-file output-file prepend-directories append-directories library-files r6rs?)
script-file
args
input-file
output-file
prepend-directories
append-directories
library-files
r6rs?
compilation-target)
(apply string-append (apply string-append
`(" TR7_LIB_PATH=" `("TR7_LIB_PATH="
,@(map (lambda (item) ,@(map (lambda (item)
(string-append item ":")) (string-append item ":"))
prepend-directories) prepend-directories)
,@(map (lambda (item) ,@(map (lambda (item)
(string-append item ":")) (string-append item ":"))
append-directories) append-directories)
" " " tr7i "
,exec-cmd
" tr7i -1 "
,(util-getenv "COMPILE_R7RS_TR7") ,(util-getenv "COMPILE_R7RS_TR7")
,script-file " ${tmpfile}")))))
" "
,args)))))
(vicare (vicare
(type . compiler) (type . compiler)
(command . ,(lambda (exec-cmd (command . ,(lambda (input-file output-file prepend-directories append-directories library-files r6rs?)
script-file
args
input-file
output-file
prepend-directories
append-directories
library-files
r6rs?
compilation-target)
(apply string-append (apply string-append
`("vicare " `("vicare "
,(util-getenv "COMPILE_R7RS_VICARE") ,(util-getenv "COMPILE_R7RS_VICARE")
@ -695,19 +479,9 @@
" --compile-program"))))) " --compile-program")))))
(ypsilon (ypsilon
(type . interpreter) (type . interpreter)
(command . ,(lambda (exec-cmd (command . ,(lambda (input-file output-file prepend-directories append-directories library-files r6rs?)
script-file
args
input-file
output-file
prepend-directories
append-directories
library-files
r6rs?
compilation-target)
(apply string-append (apply string-append
`(,exec-cmd `("ypsilon "
" ypsilon "
,(util-getenv "COMPILE_R7RS_YPSILON") ,(util-getenv "COMPILE_R7RS_YPSILON")
,(if r6rs? " --r6rs " " --r7rs ") ,(if r6rs? " --r6rs " " --r7rs ")
" --mute" " --mute"
@ -718,7 +492,4 @@
,@(map (lambda (item) ,@(map (lambda (item)
(string-append "--sitelib=" item " ")) (string-append "--sitelib=" item " "))
append-directories) append-directories)
" --top-level-program " " --top-level-program ${tmpfile}")))))))))
,script-file
" "
,args)))))))))

12
libs/util.sld
View File

@ -25,7 +25,6 @@
dirname dirname
search-library-file search-library-file
slurp slurp
slurp-bytes
file->list file->list
trim trim
trim-end trim-end
@ -217,17 +216,6 @@
(string-append line (string #\newline))) (string-append line (string #\newline)))
(looper (list) (read-line)))))))) (looper (list) (read-line))))))))
(define (slurp-bytes path)
(letrec* ((looper (lambda (result bytes)
(if (eof-object? bytes)
result
(looper (bytevector-append result bytes)
(read-bytevector 4000))))))
(with-input-from-file
path
(lambda ()
(looper (bytevector) (read-bytevector 4000))))))
(define (file->list path) (define (file->list path)
(letrec* ((looper (lambda (result line) (letrec* ((looper (lambda (result line)
(if (eof-object? line) (if (eof-object? line)

6
r6rs-php-testfiles/main.sps
View File

@ -1,6 +0,0 @@
#!r6rs
(import (rnrs)
(rnrs programs))
(display "Test successfull")
(newline)

6
r7rs-php-testfiles/main.scm
View File

@ -1,6 +0,0 @@
(import (scheme base)
(scheme read)
(scheme write))
(display "Test successfull")
(newline)

9
r7rs-testfiles/main.scm
View File

@ -8,11 +8,16 @@
(hello-world) (hello-world)
(define l (list "1" "2" "3")) (define l (list "1" "2" "3"))
;; Implementations are allowed to give different amout of args
(cond-expand (cond-expand
;; Meevax gives too much args
;; For this test for now this is okay
(meevax (when (> (length (command-line)) 3) (write l))) (meevax (when (> (length (command-line)) 3) (write l)))
;; mit-scheme gives too much args
;; For this test for now this is okay
(mit (when (> (length (command-line)) 3) (write l))) (mit (when (> (length (command-line)) 3) (write l)))
;; tr7 gives too much args
;; For this test for now this is okay
(tr7 (when (> (length (command-line)) 3) (write l)))
(else (write (list-tail (command-line) 1)))) (else (write (list-tail (command-line) 1))))
(over-9000) (over-9000)