This enables the compilation from "manually" written Tree-IL to
bytecode. See also <https://bugs.gnu.org/45131>.
* system/base/compile.scm (read-and-compile)[(joint #f)]<? eof-object?>:
Join exps using the default joiner for to.
<exp>: Compute compiler for to.
* test-suite/test/compiler.test ("read-and-compile tree-il"): New test.
---
module/system/base/compile.scm | 26 +++++++++++++++-----------
test-suite/tests/compiler.test | 22 ++++++++++++++++++++++
2 files changed, 37 insertions(+), 11 deletions(-)
diff --git a/module/system/base/compile.scm b/module/system/base/compile.scm
index 567765dc0..41ad0158a 100644
--- a/module/system/base/compile.scm
+++ b/module/system/base/compile.scm
@@ -310,16 +310,20 @@
(match (read-and-parse (current-language) port cenv)
((? eof-object?)
(close-port port)
- (compile ((or (language-joiner joint)
- (default-language-joiner joint))
- (reverse exps)
- env)
- #:from joint #:to to
- ;; env can be false if no expressions were read.
- #:env (or env (default-environment joint))
- #:optimization-level optimization-level
- #:warning-level warning-level
- #:opts opts))
+ (if joint
+ (compile ((or (language-joiner joint)
+ (default-language-joiner joint))
+ (reverse exps)
+ env)
+ #:from joint #:to to
+ ;; env can be false if no expressions were read.
+ #:env (or env (default-environment joint))
+ #:optimization-level optimization-level
+ #:warning-level warning-level
+ #:opts opts)
+ ((default-language-joiner to)
+ (reverse exps)
+ env)))
(exp
(let with-compiler ((from from) (compile1 compile1))
(cond
@@ -332,7 +336,7 @@
(let ((from (current-language)))
(with-compiler
from
- (compute-compiler from joint optimization-level
+ (compute-compiler from (or joint to) optimization-level
warning-level opts))))))))))))
(define* (compile x #:key
diff --git a/test-suite/tests/compiler.test b/test-suite/tests/compiler.test
index dc75d0ac7..cdc26c751 100644
--- a/test-suite/tests/compiler.test
+++ b/test-suite/tests/compiler.test
@@ -337,3 +337,25 @@
(pass-if-equal "test terminates without error" 42
(test-proc)))
+(with-test-prefix "read-and-compile tree-il"
+ (let ((code
+ "\
+(seq
+ (define forty-two
+ (lambda ((name . forty-two))
+ (lambda-case ((() #f #f #f () ()) (const 42)))))
+ (toplevel forty-two))")
+ (bytecode #f)
+ (proc #f))
+ (pass-if "compiling tree-il works"
+ (begin
+ (set! bytecode
+ (call-with-input-string code
+ (lambda (port)
+ (read-and-compile port #:from 'tree-il))))
+ #t))
+ (pass-if "bytecode can be read"
+ (begin
+ (set! proc ((load-thunk-from-memory bytecode)))
+ (procedure? proc)))
+ (pass-if-equal "proc executes" 42 (proc))))
--
2.29.2
