Most interpreters can now produce php file

.gitignore

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

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 .

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 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:
 	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 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:
 	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 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:
 	rm -rf test-r7rs

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")
+  (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)
                  (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))
+  (let ((outfile (if (member "-o" (command-line))
                    (cadr (member "-o" (command-line)))
                    (if input-file
                      "a.out"
-      #f)))
+                     #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,17 +158,21 @@
                                (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) "")
+           (cond
+             ((symbol=? compilation-target 'windows) "")
+             ((symbol=? compilation-target 'php) "")
              (else "exec"))
            ;; How to get the script file
-           (cond ((symbol=? compilation-target 'windows) "%0%")
+           (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) "")
+           (cond
+             ((symbol=? compilation-target 'windows) "")
+             ((symbol=? compilation-target 'php) "")
              (else "\"$@\""))
            (if input-file input-file "")
            (if output-file output-file "")
@@ -207,12 +217,35 @@
     (delete-file output-file))
   (let ((scheme-program (slurp input-file)))
     (with-output-to-file
-      (if (symbol=? compilation-target 'windows)
+      output-file
-        (string-append output-file ".bat")
-        output-file)
       (lambda ()
-      (if (symbol=? compilation-target 'windows)
+        (cond
-        ""
+          ((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
@@ -222,11 +255,11 @@
                 #\newline
                 "|#"
                 #\newline
-            ,scheme-program)))))
+                ,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))
+         `("<?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)))
 

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
                                  " "
@@ -479,9 +488,10 @@
                                       library-files)
                                   " --load "
                                   ,script-file
-                                 " --eval \"(exit 0)\" "
+                                  " --eval '(exit 0)' "
-                                 " --args "
+                                  ,(if (string=? args "")
-                                 ,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
                                  " "

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)

r6rs-php-testfiles/main.sps

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

r7rs-php-testfiles/main.scm

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

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)