diff --git a/.gitignore b/.gitignore index 2619de4..264c275 100644 --- a/.gitignore +++ b/.gitignore @@ -17,3 +17,4 @@ deps tmp deb *.deb +test-result.txt diff --git a/Dockerfile.test b/Dockerfile.test index f212df6..8ee7ba6 100644 --- a/Dockerfile.test +++ b/Dockerfile.test @@ -10,11 +10,14 @@ RUN make ARG SCHEME=chibi ARG IMAGE=chibi:head 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 WORKDIR /cache/chibi-scheme RUN make install 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 "(srfi 170)" COPY Makefile . diff --git a/Makefile b/Makefile index 49035d5..f49e5c7 100644 --- a/Makefile +++ b/Makefile @@ -3,6 +3,7 @@ SCHEME=chibi VERSION=1.0.0 R6RSTMP=tmp/${SCHEME}-r6rs R7RSTMP=tmp/${SCHEME}-r7rs +DOCKERTAG=compile-r7rs-test-${SCHEME} DOCKERIMG=${SCHEME}:head ifeq "${SCHEME}" "chicken" 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) test-r6rs-docker: - docker build -f Dockerfile.test --build-arg IMAGE=${DOCKERIMG} --build-arg SCHEME=${SCHEME} --tag=compile-r7rs-test-${SCHEME} . - docker run -v "${PWD}":/workdir -w /workdir -t compile-r7rs-test-${SCHEME} sh -c "make SCHEME=${SCHEME} test-r6rs" + 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" + +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: 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) test-r7rs-docker: - docker build -f Dockerfile.test --build-arg IMAGE=${DOCKERIMG} --build-arg SCHEME=${SCHEME} --tag=compile-r7rs-test-${SCHEME} . - docker run -v "${PWD}":/workdir -w /workdir -t compile-r7rs-test-${SCHEME} sh -c "make SCHEME=${SCHEME} test-r7rs" + 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" test-r7rs-wine: rm -rf ${R7RSTMP} mkdir -p ${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 @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=compile-r7rs-test-${SCHEME} . - docker run -v "${PWD}":/workdir -w /workdir -t compile-r7rs-test-${SCHEME} sh -c "make SCHEME=${SCHEME} test-r7rs" + 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: rm -rf test-r7rs diff --git a/compile-r7rs.scm b/compile-r7rs.scm index e2d8de0..5744ac9 100644 --- a/compile-r7rs.scm +++ b/compile-r7rs.scm @@ -36,8 +36,8 @@ (exit 1)) (when (not (assoc scheme data)) (error "Unsupported implementation" scheme)) (define compilation-target - (if (get-environment-variable "COMPILE_R7RS_TARGET_OS") - (string->symbol (get-environment-variable "COMPILE_R7RS_TARGET_OS")) + (if (get-environment-variable "COMPILE_R7RS_TARGET") + (string->symbol (get-environment-variable "COMPILE_R7RS_TARGET")) (cond-expand (windows 'windows) (else 'unix)))) @@ -68,12 +68,18 @@ #t #f)) +(define scheme-type (cdr (assoc 'type (cdr (assoc scheme data))))) + (define output-file - (if (member "-o" (command-line)) - (cadr (member "-o" (command-line))) - (if input-file - "a.out" - #f))) + (let ((outfile (if (member "-o" (command-line)) + (cadr (member "-o" (command-line))) + (if input-file + "a.out" + #f)))) + (if (and (symbol=? scheme-type 'compiler) + (symbol=? compilation-target 'php)) + (string-append outfile ".bin") + outfile))) (define prepend-directories (letrec ((looper (lambda (rest result) @@ -152,18 +158,22 @@ (list) (list))) -(define scheme-type (cdr (assoc 'type (cdr (assoc scheme data))))) - (define scheme-command (apply (cdr (assoc 'command (cdr (assoc scheme data)))) (list - (cond ((symbol=? compilation-target 'windows) "") - (else "exec")) + (cond + ((symbol=? compilation-target 'windows) "") + ((symbol=? compilation-target 'php) "") + (else "exec")) ;; How to get the script file - (cond ((symbol=? compilation-target 'windows) "%0%") - (else "$(cd -- \"$(dirname \"$0\")\" >/dev/null 2>&1 && pwd -P)/\"$0\"")) - (cond ((symbol=? compilation-target 'windows) "") - (else "\"$@\"")) + (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 "") prepend-directories @@ -207,26 +217,49 @@ (delete-file output-file)) (let ((scheme-program (slurp input-file))) (with-output-to-file - (if (symbol=? compilation-target 'windows) - (string-append output-file ".bat") - output-file) + output-file (lambda () - (if (symbol=? compilation-target 'windows) - "" - (for-each - display - `(#\newline - "#|" - #\newline - ,scheme-command - #\newline - "|#" - #\newline - ,scheme-program))))) + (cond + ((symbol=? compilation-target 'windows) + (for-each + display + `(";dir; start /WAIT " ,scheme-command " && exit" + #\newline + ,scheme-program + ))) + ((symbol=? compilation-target 'php) + (for-each + display + `(" 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) (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)) (delete-file output-file)) (for-each @@ -234,5 +267,27 @@ (let ((exit-code (c-system (string->c-utf8 command)))) (when (not (= exit-code 0)) (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)) + `(" 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))) diff --git a/libs/data.sld b/libs/data.sld index 16bf035..24075e4 100644 --- a/libs/data.sld +++ b/libs/data.sld @@ -8,6 +8,7 @@ (libs util)) (export data) (begin + (define pwd (cond-expand (windows "%CD%") (else "${PWD}"))) (define data `((chezscheme (type . interpreter) @@ -32,12 +33,12 @@ "" (apply string-append (list "--libdirs " - "\"" + "'" (apply string-append (map (lambda (item) (string-append item separator)) (append prepend-directories append-directories))) - "\""))) + "'"))) " --program " ,script-file " " @@ -355,7 +356,9 @@ (apply string-append `("CLASSPATH=" ,@(map (lambda (item) - (string-append "${PWD}/" item ":")) + (if (char=? (string-ref item 0) #\/) + (string-append item ":") + (string-append pwd "/" item ":"))) (append prepend-directories append-directories)) " " @@ -364,7 +367,9 @@ ,(util-getenv "COMPILE_R7RS_KAWA") " -Dkawa.import.path=" ,@(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-directories)) " -f " @@ -446,10 +451,14 @@ " meevax " ,(util-getenv "COMPILE_R7RS_MEEVAX") ,@(map (lambda (item) - (string-append " -I" " " item " ")) + (if (char=? (string-ref item 0) #\/) + (string-append " -I " pwd "/" item " ") + (string-append " -I " item " "))) prepend-directories) ,@(map (lambda (item) - (string-append " -A" " " item " ")) + (if (char=? (string-ref item 0) #\/) + (string-append " -A " pwd "/" item " ") + (string-append " -A " item " "))) append-directories) ,script-file " " @@ -457,31 +466,32 @@ (mit-scheme (type . interpreter) (command . ,(lambda (exec-cmd - script-file - args - input-file - output-file - prepend-directories - append-directories - library-files - r6rs - compilation-target) + script-file + args + input-file + output-file + prepend-directories + append-directories + library-files + r6rs + compilation-target) (apply string-append `(,exec-cmd - " mit-scheme --batch-mode --no-init-file " - ,@(map - (lambda (item) - (string-append " --load " - (search-library-file (append append-directories - prepend-directories) - item) - " ")) - library-files) - " --load " - ,script-file - " --eval \"(exit 0)\" " - " --args " - ,args))))) + " mit-scheme --batch-mode --no-init-file " + ,@(map + (lambda (item) + (string-append " --load " + (search-library-file (append append-directories + prepend-directories) + item) + " ")) + library-files) + " --load " + ,script-file + " --eval '(exit 0)' " + ,(if (string=? args "") + "" + (string-append " --args " args))))))) (mosh (type . interpreter) (command . ,(lambda (exec-cmd @@ -656,7 +666,7 @@ append-directories) " " ,exec-cmd - " tr7i " + " tr7i -1 " ,(util-getenv "COMPILE_R7RS_TR7") ,script-file " " diff --git a/libs/util.sld b/libs/util.sld index 362637b..4ae162b 100644 --- a/libs/util.sld +++ b/libs/util.sld @@ -25,6 +25,7 @@ dirname search-library-file slurp + slurp-bytes file->list trim trim-end @@ -216,6 +217,17 @@ (string-append line (string #\newline))) (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) (letrec* ((looper (lambda (result line) (if (eof-object? line) diff --git a/r6rs-php-testfiles/main.sps b/r6rs-php-testfiles/main.sps new file mode 100644 index 0000000..862ed6c --- /dev/null +++ b/r6rs-php-testfiles/main.sps @@ -0,0 +1,6 @@ +#!r6rs +(import (rnrs) + (rnrs programs)) + +(display "Test successfull") +(newline) \ No newline at end of file diff --git a/r7rs-php-testfiles/main.scm b/r7rs-php-testfiles/main.scm new file mode 100644 index 0000000..578074f --- /dev/null +++ b/r7rs-php-testfiles/main.scm @@ -0,0 +1,6 @@ +(import (scheme base) + (scheme read) + (scheme write)) + +(display "Test successfull") +(newline) diff --git a/r7rs-testfiles/main.scm b/r7rs-testfiles/main.scm index 4a3a20d..2e38b7d 100644 --- a/r7rs-testfiles/main.scm +++ b/r7rs-testfiles/main.scm @@ -9,11 +9,10 @@ (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 (meevax (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)))) (over-9000)