Retropikzel
/
compile-r7rs
1
0
Fork 0
Code Issues 8 Pull Requests Releases Activity

Fixing R6RS

This commit is contained in:
retropikzel 2025-07-15 19:45:42 +03:00
parent 3edd58d75a
commit 7c16e623a7
3 changed files with 47 additions and 25 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

6
Makefile
View File

@ -10,7 +10,7 @@ container:
build: deps build: deps
echo "#!/bin/sh" > compile-r7rs echo "#!/bin/sh" > compile-r7rs
echo "chibi-scheme -A ${PREFIX}/lib/compile-r7rs ${PREFIX}/lib/compile-r7rs/main.scm \$$@" >> compile-r7rs echo "chibi-scheme -A ${PREFIX}/lib/compile-r7rs ${PREFIX}/lib/compile-r7rs/main.scm \"\$$@\"" >> compile-r7rs
deps: deps:
mkdir -p deps mkdir -p deps
@ -34,8 +34,8 @@ test-r6rs:
mkdir -p ${R6RSTMP} mkdir -p ${R6RSTMP}
mkdir -p ${R6RSTMP}/libs mkdir -p ${R6RSTMP}/libs
mkdir -p ${R6RSTMP}/libs/foo mkdir -p ${R6RSTMP}/libs/foo
printf "(library (foo bar) (export baz) (import (rnrs)) (define baz (lambda () (display \"Test successfull\") (newline))))" > ${R6RSTMP}/libs/foo/bar.sls printf "#!r6rs\n(library (foo bar) (export baz) (import (rnrs)) (define baz (lambda () (display \"Test successfull\") (newline))))" > ${R6RSTMP}/libs/foo/bar.sls
printf "(import (rnrs) (foo bar)) (baz)" > ${R6RSTMP}/main.sps printf "#!r6rs\n(import (rnrs) (foo bar)) (baz)" > ${R6RSTMP}/main.sps
cd ${R6RSTMP} && COMPILE_R7RS=${SCHEME} compile-r7rs -I ./libs -o main main.sps cd ${R6RSTMP} && COMPILE_R7RS=${SCHEME} compile-r7rs -I ./libs -o main main.sps
-cd ${R6RSTMP} && timeout 60 ./main > compile-r7rs-test-result.txt 2>&1 -cd ${R6RSTMP} && timeout 60 ./main > compile-r7rs-test-result.txt 2>&1
@grep "Test successfull" ${R6RSTMP}/compile-r7rs-test-result.txt || (echo "Test failed, output: " && cat ${R6RSTMP}/compile-r7rs-test-result.txt && exit 1) @grep "Test successfull" ${R6RSTMP}/compile-r7rs-test-result.txt || (echo "Test failed, output: " && cat ${R6RSTMP}/compile-r7rs-test-result.txt && exit 1)

24
libs/data.sld
View File

@ -432,8 +432,14 @@
(let* ((full-path (search-library-file (append append-directories (let* ((full-path (search-library-file (append append-directories
prepend-directories) prepend-directories)
library-file)) library-file))
(library-rkt-file (change-file-suffix full-path ".rkt")) (library-rkt-file (change-file-suffix full-path ".rkt")))
) (if r6rs?
(apply string-append
`("plt-r6rs"
" "
"--compile"
" "
,library-file))
(apply string-append (apply string-append
`("printf" `("printf"
" " " "
@ -444,13 +450,12 @@
" " " "
">" ">"
" " " "
,library-rkt-file))))) ,library-rkt-file))))))
(command . ,(lambda (input-file output-file prepend-directories append-directories library-files r6rs?) (command . ,(lambda (input-file output-file prepend-directories append-directories library-files r6rs?)
(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"))))
(if r6rs? (when (not r6rs?)
#t
(when (not (string=? rkt-input-file "")) (when (not (string=? rkt-input-file ""))
(when (file-exists? rkt-input-file) (when (file-exists? rkt-input-file)
(delete-file rkt-input-file)) (delete-file rkt-input-file))
@ -476,13 +481,10 @@
" " " "
,@(map (lambda (item) ,@(map (lambda (item)
(string-append "-S " item " ")) (string-append "-S " item " "))
prepend-directories) (append prepend-directories
,@(map (lambda (item) append-directories))
(string-append "-S " item " "))
append-directories)
" " " "
,(if r6rs? input-file rkt-input-file) ,(if r6rs? input-file rkt-input-file)))))))
))))))
(sagittarius (sagittarius
(type . interpreter) (type . interpreter)
(command . ,(lambda (input-file output-file prepend-directories append-directories library-files r6rs?) (command . ,(lambda (input-file output-file prepend-directories append-directories library-files r6rs?)

22
libs/library-util.scm
View File

@ -67,6 +67,26 @@
(list))) (list)))
paths)))) paths))))
;; To get dependencies from R7RS and R6RS libraries we need to read trough all
;; the nonportable stuff first and then when encountering first ( not in
;; comments, read from that
(define read-until-library
(lambda (path)
(letrec
((looper (lambda (c)
(cond ((char=? c #\()
(read))
((char=? c #\;)
(read-line)
(looper (peek-char)))
(else
(read-char)
(looper (peek-char)))))))
(with-input-from-file
path
(lambda ()
(looper (peek-char)))))))
(define library-dependencies (define library-dependencies
(lambda (implementation directories path previous-indent indent) (lambda (implementation directories path previous-indent indent)
(for-each (lambda (item) (display " ")) indent) (for-each (lambda (item) (display " ")) indent)
@ -80,7 +100,7 @@
(list)) (list))
(begin (begin
(newline) (newline)
(letrec* ((raw-data (with-input-from-file full-path (lambda () (read)))) (letrec* ((raw-data (read-until-library full-path))
(data (if (equal? (car raw-data) 'define-library) (data (if (equal? (car raw-data) 'define-library)
(cdr raw-data) (cdr raw-data)
raw-data)) raw-data))