diff --git a/module/language/brainfuck/spec.scm b/module/language/brainfuck/spec.scm index f7cd90109..ca488b916 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 b7d6da446..26b28bf41 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 5f23fa8c6..cade9318a 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)))