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,12 +236,19 @@
       (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 ((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)))
@@ -258,7 +265,7 @@
                ;; Return continuation environment from first pass, to
                ;; compile an additional expression in the same compilation
                ;; unit.
-             (values exp env cenv))))))))
+               (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)))