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

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

module/system/base/compile.scm

@@ -236,29 +236,36 @@
       (match (language-compilers lang)
         (((name . pass))
          (cons (lookup-language name) pass))
-        ((_ _)
+        (compilers
-         (error "multiple compilers; language should supply chooser"))
+         (let ((chooser (language-compiler-chooser lang)))
-        (_
+           (unless chooser
-         (error "no way to compile" from "to" to)))))
+             (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))
+  (let ((from (ensure-language from))
-    (match (next-pass from lang to optimization-level opts)
+        (to (ensure-language to)))
-      (#f (lambda (exp env) (values exp env env)))
+    (let lp ((lang from))
-      ((next . pass)
+      (match (next-pass from lang to optimization-level opts)
-       (let* ((analyze (compute-analyzer lang warning-level opts))
+        (#f (lambda (exp env) (values exp env env)))
-              (lower (compute-lowerer lang optimization-level opts))
+        ((next . pass)
-              (compile (lambda (exp env)
+         (let* ((analyze (compute-analyzer lang warning-level opts))
-                         (analyze exp env)
+                (lower (compute-lowerer lang optimization-level opts))
-                         (pass (lower exp env) env opts)))
+                (compile (lambda (exp env)
-              (tail (lp next)))
+                           (analyze exp env)
-         (lambda (exp env)
+                           (pass (lower exp env) env opts)))
-           (let*-values (((exp env cenv) (compile exp env))
+                (tail (lp next)))
-                         ((exp env cenv*) (tail exp env)))
+           (lambda (exp env)
-             ;; Return continuation environment from first pass, to
+             (let*-values (((exp env cenv) (compile exp env))
-             ;; compile an additional expression in the same compilation
+                           ((exp env cenv*) (tail exp env)))
-             ;; unit.
+               ;; Return continuation environment from first pass, to
-             (values exp env cenv))))))))
+               ;; 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)

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-lowerer language-analyzer
-            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)))