mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-04-29 19:30:36 +02:00
Code Activity

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

Browse source 
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.
This commit is contained in:
Leo Prikler 2020-12-29 19:09:07 +01:00 • committed by Andy Wingo
parent 1432088f27
commit 5c6a944173
2 changed files with 38 additions and 11 deletions
Download patch file Download diff file Expand all files Collapse all files

26
module/system/base/compile.scm
View file

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

23
test-suite/tests/compiler.test
View file

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