diff --git a/module/system/base/compile.scm b/module/system/base/compile.scm index 3ea1e7aca..b7d6da446 100644 --- a/module/system/base/compile.scm +++ b/module/system/base/compile.scm @@ -230,18 +230,28 @@ (#f (lambda (exp env) exp)) (proc (proc optimization-level opts)))) +(define (next-pass from lang to optimization-level opts) + (if (eq? lang to) + #f ;; Done. + (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))))) + (define (compute-compiler from to optimization-level warning-level opts) - (let lp ((order (or (lookup-compilation-order from to) - (error "no way to compile" from "to" to)))) - (match order - (() (lambda (exp env) (values exp env env))) - (((lang . pass) . order) + (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 order))) + (tail (lp next))) (lambda (exp env) (let*-values (((exp env cenv) (compile exp env)) ((exp env cenv*) (tail exp env)))