Retropikzel
/
compile-scheme
1
0
Fork 0
Code Issues

tr7 fixes

This commit is contained in:
retropikzel 2025-12-01 19:32:13 +02:00
parent da0265e7d6
commit 59240f04b0
3 changed files with 81 additions and 22 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
Makefile
View File

@ -124,7 +124,7 @@ test-r7rs:
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-scheme -I libs --debug main.scm cd ${R7RSTMP} && COMPILE_R7RS=${SCHEME} compile-scheme -I ./libs --debug main.scm
-cd ${R7RSTMP} && ./main 1 2 3 > test-result.txt 2>&1 -cd ${R7RSTMP} && ./main 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)

22
compile-scheme.scm
View File

@ -26,12 +26,34 @@
(newline) (newline)
(exit 0)) (exit 0))
(when (member "--list-r6rs-except" (command-line))
(for-each
(lambda (scheme)
(when (not (member (symbol->string scheme)
(cdr (member "--list-r6rs-except" (command-line)))))
(display scheme)
(display " ")))
r6rs-schemes)
(newline)
(exit 0))
(when (or (member "--list-r7rs" (command-line)) (when (or (member "--list-r7rs" (command-line))
(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 (member "--list-r7rs-except" (command-line))
(for-each
(lambda (scheme)
(when (not (member (symbol->string scheme)
(cdr (member "--list-r7rs-except" (command-line)))))
(display scheme)
(display " ")))
r7rs-schemes)
(newline)
(exit 0))
(when (or (member "--list-all" (command-line)) (when (or (member "--list-all" (command-line))
(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)

79
libs/data.sld
View File

@ -189,13 +189,13 @@
,script-file ,script-file
" " " "
,args))))) ,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?)
`(,(string-append "gsc " `(,(string-append "gsc -:search="
(apply string-append (apply string-append
(map (lambda (item) (map (lambda (item)
(string-append item "/ ")) (string-append item "/, "))
(append prepend-directories (append prepend-directories
append-directories))) append-directories)))
(search-library-file (append append-directories (search-library-file (append append-directories
@ -211,24 +211,61 @@
library-files library-files
r6rs? r6rs?
compilation-target) compilation-target)
(let ((output-tmp-file (string-append output-file ".tmp"))) (let ((library-files-paths
`(,(string-append "echo \"#!/usr/bin/env gsi -:r7rs,search=" (map (lambda (item)
(search-library-file (append prepend-directories
append-directories)
item))
library-files))
(link-file
(string-append
(string-cut-from-end input-file 4) "_.c")))
`(,(string-append "gsc -:search="
(string-cut-from-end
(apply string-append
(map (lambda (item)
(string-append item ","))
(append prepend-directories
append-directories)))
1)
" -link -flat -nopreload "
(string-cut-from-end
(apply string-append
(map (lambda (item)
(string-append item " "))
library-files-paths))
1)
" "
input-file)
,(string-append "gsc -:search="
(string-cut-from-end
(apply string-append
(map (lambda (item)
(string-append item ","))
(append prepend-directories
append-directories)))
1)
" -obj "
(apply string-append (apply string-append
(map (lambda (item) (map (lambda (item)
(string-append item "/ ")) (string-append (string-cut-from-end item 4) ".c "))
(append prepend-directories library-files-paths))
append-directories))) " "
"\" > " output-tmp-file) (string-append (string-cut-from-end input-file 4) ".c")
,(string-append "cat " input-file " >> " output-tmp-file) " "
,(string-append "gsc " (string-append (string-cut-from-end input-file 4) "_.c"))
(apply string-append ,(string-append "gcc -o "
(map (lambda (item) output-file
(string-append item "/ ")) " "
(append prepend-directories (apply string-append
append-directories))) (map (lambda (item)
" -o " output-file (string-append (string-cut-from-end item 4) ".o "))
" -exe -nopreload " library-files-paths))
output-tmp-file)))))) " "
(string-append (string-cut-from-end input-file 4) ".o")
" "
(string-append (string-cut-from-end input-file 4) "_.o"))
)))))
(gauche (gauche
(type . interpreter) (type . interpreter)
(command . ,(lambda (exec-cmd (command . ,(lambda (exec-cmd
@ -666,7 +703,7 @@
append-directories) append-directories)
" " " "
,exec-cmd ,exec-cmd
" tr7i -1 " " tr7i "
,(util-getenv "COMPILE_R7RS_TR7") ,(util-getenv "COMPILE_R7RS_TR7")
,script-file ,script-file
" " " "