[Guile-commits] branch master updated: Add compiler chooser implementation; fix bugs with previous commit

[Andy Wingo]

This is an automated email from the git hooks/post-receive script.

wingo pushed a commit to branch master
in repository guile.

The following commit(s) were added to refs/heads/master by this push:
     new f711ab8  Add compiler chooser implementation; fix bugs with previous 
commit
f711ab8 is described below

commit f711ab85b2028cc7f6521b3aa393cfcca9365898
Author: Andy Wingo <address@hidden>
AuthorDate: Fri May 8 22:56:37 2020 +0200

    Add compiler chooser implementation; fix bugs with previous commit
    
    * module/system/base/compile.scm (next-pass): Invoke the language's
      compiler chooser if there is more than one compiler.
      (compute-compiler): Ensure from and to are languages.
    * module/system/base/language.scm (<language>): Add compiler-chooser
      field.
    * module/language/brainfuck/spec.scm (choose-compiler, brainfuck):
      Define a compiler chooser.
---
 module/language/brainfuck/spec.scm |  6 ++++-
 module/system/base/compile.scm     | 49 ++++++++++++++++++++++----------------
 module/system/base/language.scm    |  9 +++----
 3 files changed, 38 insertions(+), 26 deletions(-)

diff --git a/module/language/brainfuck/spec.scm 
b/module/language/brainfuck/spec.scm
index f7cd901..ca488b9 100644
--- a/module/language/brainfuck/spec.scm
+++ b/module/language/brainfuck/spec.scm
@@ -1,6 +1,6 @@
 ;;; Brainfuck for GNU Guile.
 
-;; Copyright (C) 2009, 2010 Free Software Foundation, Inc.
+;; Copyright (C) 2009-2010,2020 Free Software Foundation, Inc.
 
 ;; This library is free software; you can redistribute it and/or
 ;; modify it under the terms of the GNU Lesser General Public
@@ -34,10 +34,14 @@
 ; in #:compilers.  This is the basic set of fields needed to specify a new
 ; language.
 
+(define (choose-compiler compilers optimization-level opts)
+  (cons 'tree-il compile-tree-il))
+
 (define-language brainfuck
   #:title      "Brainfuck"
   #:reader     (lambda (port env) (read-brainfuck port))
   #:compilers  `((tree-il . ,compile-tree-il)
                   (scheme . ,compile-scheme))
+  #:compiler-chooser choose-compiler
   #:printer    write
   )
diff --git a/module/system/base/compile.scm b/module/system/base/compile.scm
index b7d6da4..26b28bf 100644
--- a/module/system/base/compile.scm
+++ b/module/system/base/compile.scm
@@ -236,29 +236,36 @@
       (match (language-compilers lang)
         (((name . pass))
          (cons (lookup-language name) pass))
-        ((_ _)
-         (error "multiple compilers; language should supply chooser"))
-        (_
-         (error "no way to compile" from "to" to)))))
+        (compilers
+         (let ((chooser (language-compiler-chooser lang)))
+           (unless chooser
+             (if (null? compilers)
+                 (error "no way to compile" from "to" to)
+                 (error "multiple compilers; language should supply chooser")))
+           (match (chooser to optimization-level opts)
+             ((name . pass)
+              (cons (lookup-language name) pass))))))))
 
 (define (compute-compiler from to optimization-level warning-level opts)
-  (let lp ((lang from))
-    (match (next-pass from lang to optimization-level opts)
-      (#f (lambda (exp env) (values exp env env)))
-      ((next . pass)
-       (let* ((analyze (compute-analyzer lang warning-level opts))
-              (lower (compute-lowerer lang optimization-level opts))
-              (compile (lambda (exp env)
-                         (analyze exp env)
-                         (pass (lower exp env) env opts)))
-              (tail (lp next)))
-         (lambda (exp env)
-           (let*-values (((exp env cenv) (compile exp env))
-                         ((exp env cenv*) (tail exp env)))
-             ;; Return continuation environment from first pass, to
-             ;; compile an additional expression in the same compilation
-             ;; unit.
-             (values exp env cenv))))))))
+  (let ((from (ensure-language from))
+        (to (ensure-language to)))
+    (let lp ((lang from))
+      (match (next-pass from lang to optimization-level opts)
+        (#f (lambda (exp env) (values exp env env)))
+        ((next . pass)
+         (let* ((analyze (compute-analyzer lang warning-level opts))
+                (lower (compute-lowerer lang optimization-level opts))
+                (compile (lambda (exp env)
+                           (analyze exp env)
+                           (pass (lower exp env) env opts)))
+                (tail (lp next)))
+           (lambda (exp env)
+             (let*-values (((exp env cenv) (compile exp env))
+                           ((exp env cenv*) (tail exp env)))
+               ;; Return continuation environment from first pass, to
+               ;; compile an additional expression in the same compilation
+               ;; unit.
+               (values exp env cenv)))))))))
 
 (define (find-language-joint from to)
   (match (lookup-compilation-order from to)
diff --git a/module/system/base/language.scm b/module/system/base/language.scm
index 5f23fa8..cade931 100644
--- a/module/system/base/language.scm
+++ b/module/system/base/language.scm
@@ -1,6 +1,6 @@
 ;;; Multi-language support
 
-;; Copyright (C) 2001, 2009, 2010, 2011, 2013 Free Software Foundation, Inc.
+;; Copyright (C) 2001,2005,2008-2011,2013,2020 Free Software Foundation, Inc.
 
 ;; This library is free software; you can redistribute it and/or
 ;; modify it under the terms of the GNU Lesser General Public
@@ -27,8 +27,8 @@
             language-compilers language-decompilers language-evaluator
             language-joiner language-for-humans?
             language-make-default-environment
-            language-lowerer
-            language-analyzer
+            language-lowerer language-analyzer
+            language-compiler-chooser
 
             lookup-compilation-order lookup-decompilation-order
             default-environment)
@@ -53,7 +53,8 @@
   (for-humans? #t)
   (make-default-environment make-fresh-user-module)
   (lowerer #f)
-  (analyzer #f))
+  (analyzer #f)
+  (compiler-chooser #f))
 
 (define-syntax-rule (define-language name . spec)
   (define name (make-language #:name 'name . spec)))