[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
[Guile-commits] 02/02: bug#45131: [PATCH] Compile directly to target lan
From: |
Andy Wingo |
Subject: |
[Guile-commits] 02/02: bug#45131: [PATCH] Compile directly to target language if no joint is found. |
Date: |
Mon, 10 May 2021 04:17:37 -0400 (EDT) |
wingo pushed a commit to branch master
in repository guile.
commit 5c6a94417302b8f06ce289d3c5f8ecc014f49cb3
Author: Leo Prikler <leo.prikler@student.tugraz.at>
AuthorDate: Tue Dec 29 19:09:07 2020 +0100
bug#45131: [PATCH] Compile directly to target language if no joint is found.
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 | 23 +++++++++++++++++++++++
2 files changed, 38 insertions(+), 11 deletions(-)
diff --git a/module/system/base/compile.scm b/module/system/base/compile.scm
index 9ec9cbb..a33d012 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 90eee49..254aaa7 100644
--- a/test-suite/tests/compiler.test
+++ b/test-suite/tests/compiler.test
@@ -368,3 +368,26 @@
(pass-if-equal "test terminates without error" '(#t #t)
(test-proc '((V X) (Y Z)))))
+
+(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))))