[Guile-commits] 02/02: bug#45131: [PATCH] Compile directly to target language if no joint is found.

[Andy Wingo]

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))))