diff options
| author | Leo Prikler <leo.prikler@student.tugraz.at> | 2020-12-29 19:09:07 +0100 |
|---|---|---|
| committer | Andy Wingo <wingo@pobox.com> | 2021-05-10 10:16:10 +0200 |
| commit | 5c6a94417302b8f06ce289d3c5f8ecc014f49cb3 (patch) | |
| tree | ca4499a40ba6b43eb406197a0ecde62d6de480d5 | |
| parent | 1432088f2780aff52cad7639d440e2f932478f60 (diff) | |
| download | guile-5c6a94417302b8f06ce289d3c5f8ecc014f49cb3.tar.gz | |
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.
| -rw-r--r-- | module/system/base/compile.scm | 26 | ||||
| -rw-r--r-- | 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 9ec9cbb0f..a33d012bd 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 90eee491b..254aaa720 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)))) |