From 7c16e623a742061ab35c209491118fbfab5fa05d Mon Sep 17 00:00:00 2001 From: retropikzel Date: Tue, 15 Jul 2025 19:45:42 +0300 Subject: [PATCH] Fixing R6RS --- Makefile | 6 +++--- libs/data.sld | 44 ++++++++++++++++++++++--------------------- libs/library-util.scm | 22 +++++++++++++++++++++- 3 files changed, 47 insertions(+), 25 deletions(-) diff --git a/Makefile b/Makefile index 69ff65a..628d03e 100644 --- a/Makefile +++ b/Makefile @@ -10,7 +10,7 @@ container: build: deps 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: mkdir -p deps @@ -34,8 +34,8 @@ test-r6rs: mkdir -p ${R6RSTMP} mkdir -p ${R6RSTMP}/libs 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 "(import (rnrs) (foo bar)) (baz)" > ${R6RSTMP}/main.sps + printf "#!r6rs\n(library (foo bar) (export baz) (import (rnrs)) (define baz (lambda () (display \"Test successfull\") (newline))))" > ${R6RSTMP}/libs/foo/bar.sls + 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} && 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) diff --git a/libs/data.sld b/libs/data.sld index c4dd1a3..abcf18d 100644 --- a/libs/data.sld +++ b/libs/data.sld @@ -432,25 +432,30 @@ (let* ((full-path (search-library-file (append append-directories prepend-directories) library-file)) - (library-rkt-file (change-file-suffix full-path ".rkt")) - ) - (apply string-append - `("printf" - " " - "'#lang r7rs\\n(import (scheme base))\\n(include \"" - ,(path->filename library-file) - "\")\\n" - "'" - " " - ">" - " " - ,library-rkt-file))))) + (library-rkt-file (change-file-suffix full-path ".rkt"))) + (if r6rs? + (apply string-append + `("plt-r6rs" + " " + "--compile" + " " + ,library-file)) + (apply string-append + `("printf" + " " + "'#lang r7rs\\n(import (scheme base))\\n(include \"" + ,(path->filename library-file) + "\")\\n" + "'" + " " + ">" + " " + ,library-rkt-file)))))) (command . ,(lambda (input-file output-file prepend-directories append-directories library-files r6rs?) (let ((rkt-input-file (if (string=? input-file "") "" (change-file-suffix input-file ".rkt")))) - (if r6rs? - #t + (when (not r6rs?) (when (not (string=? rkt-input-file "")) (when (file-exists? rkt-input-file) (delete-file rkt-input-file)) @@ -476,13 +481,10 @@ " " ,@(map (lambda (item) (string-append "-S " item " ")) - prepend-directories) - ,@(map (lambda (item) - (string-append "-S " item " ")) - append-directories) + (append prepend-directories + append-directories)) " " - ,(if r6rs? input-file rkt-input-file) - )))))) + ,(if r6rs? input-file rkt-input-file))))))) (sagittarius (type . interpreter) (command . ,(lambda (input-file output-file prepend-directories append-directories library-files r6rs?) diff --git a/libs/library-util.scm b/libs/library-util.scm index 2583c26..c403c42 100644 --- a/libs/library-util.scm +++ b/libs/library-util.scm @@ -67,6 +67,26 @@ (list))) 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 (lambda (implementation directories path previous-indent indent) (for-each (lambda (item) (display " ")) indent) @@ -80,7 +100,7 @@ (list)) (begin (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) (cdr raw-data) raw-data))