bug#45131: guild fails to compile a Tree-IL file

[Andy Wingo]

Thanks for the patch; applied!

Andy

On Tue 29 Dec 2020 19:09, Leo Prikler <leo.prikler@student.tugraz.at> writes:

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