Retropikzel
/
compile-r7rs
1
0
Fork 0
Code Issues

Most interpreters can now produce php file

This commit is contained in:
retropikzel 2025-11-05 15:45:36 +02:00
parent 45e80037cf
commit a94e179efb
9 changed files with 189 additions and 72 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

1
.gitignore vendored
View File

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

5
Dockerfile.test
View File

@ -10,11 +10,14 @@ 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 make gcc libffi-dev unzip RUN apt-get update && apt-get install -y \
--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 .

39
Makefile
View File

@ -3,6 +3,7 @@ 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"
@ -95,8 +96,20 @@ 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=compile-r7rs-test-${SCHEME} . docker build -f Dockerfile.test --build-arg IMAGE=${DOCKERIMG} --build-arg SCHEME=${SCHEME} --tag=${DOCKERTAG} .
docker run -v "${PWD}":/workdir -w /workdir -t compile-r7rs-test-${SCHEME} sh -c "make SCHEME=${SCHEME} test-r6rs" docker run -v "${PWD}":/workdir -w /workdir -t ${DOCKERTAG} 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}
@ -107,20 +120,32 @@ 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=compile-r7rs-test-${SCHEME} . docker build -f Dockerfile.test --build-arg IMAGE=${DOCKERIMG} --build-arg SCHEME=${SCHEME} --tag=${DOCKERTAG} .
docker run -v "${PWD}":/workdir -w /workdir -t compile-r7rs-test-${SCHEME} sh -c "make SCHEME=${SCHEME} test-r7rs" docker run -v "${PWD}":/workdir -w /workdir -t ${DOCKERTAG} sh -c "make SCHEME=${SCHEME} test-r7rs"
test-r7rs-wine: test-r7rs-wine:
rm -rf ${R7RSTMP} rm -rf ${R7RSTMP}
mkdir -p ${R7RSTMP} mkdir -p ${R7RSTMP}
cp -r r7rs-testfiles/* ${R7RSTMP}/ cp -r r7rs-testfiles/* ${R7RSTMP}/
cd ${R7RSTMP} && COMPILE_R7RS=${SCHEME} COMPILE_R7RS_TARGET_OS=windows compile-r7rs -I ./libs -o main main.scm 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 -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) @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: test-r7rs-wine-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=${DOCKERTAG} .
docker run -v "${PWD}":/workdir -w /workdir -t compile-r7rs-test-${SCHEME} sh -c "make SCHEME=${SCHEME} test-r7rs" 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

119
compile-r7rs.scm
View File

@ -36,8 +36,8 @@
(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 "COMPILE_R7RS_TARGET_OS") (if (get-environment-variable "COMPILE_R7RS_TARGET")
(string->symbol (get-environment-variable "COMPILE_R7RS_TARGET_OS")) (string->symbol (get-environment-variable "COMPILE_R7RS_TARGET"))
(cond-expand (windows 'windows) (cond-expand (windows 'windows)
(else 'unix)))) (else 'unix))))
@ -68,12 +68,18 @@
#t #t
#f)) #f))
(define scheme-type (cdr (assoc 'type (cdr (assoc scheme data)))))
(define output-file (define output-file
(if (member "-o" (command-line)) (let ((outfile (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)
@ -152,18 +158,22 @@
(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
(cond ((symbol=? compilation-target 'windows) "") (cond
(else "exec")) ((symbol=? compilation-target 'windows) "")
((symbol=? compilation-target 'php) "")
(else "exec"))
;; How to get the script file ;; How to get the script file
(cond ((symbol=? compilation-target 'windows) "%0%") (cond
(else "$(cd -- \"$(dirname \"$0\")\" >/dev/null 2>&1 && pwd -P)/\"$0\"")) ((symbol=? compilation-target 'windows) "%0%")
(cond ((symbol=? compilation-target 'windows) "") ((symbol=? compilation-target 'php) "$binname")
(else "\"$@\"")) (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 input-file input-file "")
(if output-file output-file "") (if output-file output-file "")
prepend-directories prepend-directories
@ -207,26 +217,49 @@
(delete-file output-file)) (delete-file output-file))
(let ((scheme-program (slurp input-file))) (let ((scheme-program (slurp input-file)))
(with-output-to-file (with-output-to-file
(if (symbol=? compilation-target 'windows) output-file
(string-append output-file ".bat")
output-file)
(lambda () (lambda ()
(if (symbol=? compilation-target 'windows) (cond
"" ((symbol=? compilation-target 'windows)
(for-each (for-each
display display
`(#\newline `(";dir; start /WAIT " ,scheme-command " && exit"
"#|" #\newline
#\newline ,scheme-program
,scheme-command )))
#\newline ((symbol=? compilation-target 'php)
"|#" (for-each
#\newline display
,scheme-program))))) `("<?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
,scheme-command
#\newline
"|#"
#\newline
,scheme-program))))))
(cond ((symbol=? compilation-target 'unix) (cond ((symbol=? 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 (equal? scheme-type 'compiler) input-file) (when (and (symbol=? 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))
(for-each (for-each
@ -234,5 +267,27 @@
(let ((exit-code (c-system (string->c-utf8 command)))) (let ((exit-code (c-system (string->c-utf8 command))))
(when (not (= exit-code 0)) (when (not (= exit-code 0))
(exit exit-code)))) (exit exit-code))))
scheme-command)) scheme-command)
(cond
((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)))

70
libs/data.sld
View File

@ -8,6 +8,7 @@
(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)
@ -32,12 +33,12 @@
"" ""
(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 "
,script-file ,script-file
" " " "
@ -355,7 +356,9 @@
(apply string-append (apply string-append
`("CLASSPATH=" `("CLASSPATH="
,@(map (lambda (item) ,@(map (lambda (item)
(string-append "${PWD}/" item ":")) (if (char=? (string-ref item 0) #\/)
(string-append item ":")
(string-append pwd "/" item ":")))
(append prepend-directories (append prepend-directories
append-directories)) append-directories))
" " " "
@ -364,7 +367,9 @@
,(util-getenv "COMPILE_R7RS_KAWA") ,(util-getenv "COMPILE_R7RS_KAWA")
" -Dkawa.import.path=" " -Dkawa.import.path="
,@(map (lambda (item) ,@(map (lambda (item)
(string-append "${PWD}/" item "/*.sld:")) (if (char=? (string-ref item 0) #\/)
(string-append item "/*.sld")
(string-append pwd "/" item "/*.sld")))
(append prepend-directories (append prepend-directories
append-directories)) append-directories))
" -f " " -f "
@ -446,10 +451,14 @@
" meevax " " meevax "
,(util-getenv "COMPILE_R7RS_MEEVAX") ,(util-getenv "COMPILE_R7RS_MEEVAX")
,@(map (lambda (item) ,@(map (lambda (item)
(string-append " -I" " " item " ")) (if (char=? (string-ref item 0) #\/)
(string-append " -I " pwd "/" item " ")
(string-append " -I " item " ")))
prepend-directories) prepend-directories)
,@(map (lambda (item) ,@(map (lambda (item)
(string-append " -A" " " item " ")) (if (char=? (string-ref item 0) #\/)
(string-append " -A " pwd "/" item " ")
(string-append " -A " item " ")))
append-directories) append-directories)
,script-file ,script-file
" " " "
@ -457,31 +466,32 @@
(mit-scheme (mit-scheme
(type . interpreter) (type . interpreter)
(command . ,(lambda (exec-cmd (command . ,(lambda (exec-cmd
script-file script-file
args args
input-file input-file
output-file output-file
prepend-directories prepend-directories
append-directories append-directories
library-files library-files
r6rs r6rs
compilation-target) compilation-target)
(apply string-append (apply string-append
`(,exec-cmd `(,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 "
,script-file ,script-file
" --eval \"(exit 0)\" " " --eval '(exit 0)' "
" --args " ,(if (string=? args "")
,args))))) ""
(string-append " --args " args)))))))
(mosh (mosh
(type . interpreter) (type . interpreter)
(command . ,(lambda (exec-cmd (command . ,(lambda (exec-cmd
@ -656,7 +666,7 @@
append-directories) append-directories)
" " " "
,exec-cmd ,exec-cmd
" tr7i " " tr7i -1 "
,(util-getenv "COMPILE_R7RS_TR7") ,(util-getenv "COMPILE_R7RS_TR7")
,script-file ,script-file
" " " "

12
libs/util.sld
View File

@ -25,6 +25,7 @@
dirname dirname
search-library-file search-library-file
slurp slurp
slurp-bytes
file->list file->list
trim trim
trim-end trim-end
@ -216,6 +217,17 @@
(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 Normal file
View File

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

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

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

3
r7rs-testfiles/main.scm
View File

@ -9,11 +9,10 @@
(define l (list "1" "2" "3")) (define l (list "1" "2" "3"))
;; Implementations are allowed to give diffrent amout of args ;; Implementations are allowed to give different amout of args
(cond-expand (cond-expand
(meevax (when (> (length (command-line)) 3) (write l))) (meevax (when (> (length (command-line)) 3) (write l)))
(mit (when (> (length (command-line)) 3) (write l))) (mit (when (> (length (command-line)) 3) (write l)))
(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)