bug#45131: [PATCH] Compile directly to target language if no joint is found.

[Leo Prikler]

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