diff options
author | Andy Wingo <wingo@pobox.com> | 2020-05-08 11:49:01 +0200 |
---|---|---|
committer | Andy Wingo <wingo@pobox.com> | 2020-05-08 11:49:01 +0200 |
commit | 52f308e272ec5d9a4ba1a059597da2755a70236c (patch) | |
tree | 10fbc8d9f6ea90a4d8d74cb38f068a39a23f83f1 | |
parent | 6bb996ec6679666f6a1c17f8c1c48cbe56b32c19 (diff) | |
download | guile-52f308e272ec5d9a4ba1a059597da2755a70236c.tar.gz |
Rework compile-fold
Instead of returning a list of passes, returns a closure that does it
all.
* module/system/base/compile.scm (compute-compiler): New function.
(read-and-compile, compile): Use compile-compiler.
-rw-r--r-- | module/system/base/compile.scm | 87 |
1 files changed, 49 insertions, 38 deletions
diff --git a/module/system/base/compile.scm b/module/system/base/compile.scm index 0502ad402..3246a0088 100644 --- a/module/system/base/compile.scm +++ b/module/system/base/compile.scm @@ -22,6 +22,7 @@ #:use-module (system base message) #:use-module (ice-9 receive) #:use-module (ice-9 match) + #:use-module (srfi srfi-11) #:export (compiled-file-name compile-file compile-and-load @@ -191,18 +192,22 @@ ;;; Compiler interface ;;; -(define (compile-passes from to opts) - (match (lookup-compilation-order from to) - (((langs . passes) ...) passes) - (_ (error "no way to compile" from "to" to)))) - -(define (compile-fold passes exp env opts) - (let lp ((passes passes) (x exp) (e env) (cenv env) (first? #t)) - (match passes - (() (values x e cenv)) - ((pass . passes) - (receive (x e new-cenv) (pass x e opts) - (lp passes x e (if first? new-cenv cenv) #f)))))) +(define (compute-compiler from to 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 ((head (lambda (exp env) + (pass exp env opts))) + (tail (lp order))) + (lambda (exp env) + (let*-values (((exp env cenv) (head 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) @@ -238,29 +243,35 @@ (to 'bytecode) (env (default-environment from)) (opts '())) - (let ((from (ensure-language from)) - (to (ensure-language to))) - (let ((joint (find-language-joint from to))) - (parameterize ((current-language from)) - (let lp ((exps '()) (env #f) (cenv env)) - (let ((x (read-and-parse (current-language) port cenv))) - (cond - ((eof-object? x) - (close-port port) - (compile ((or (language-joiner joint) - (default-language-joiner joint)) - (reverse exps) - env) - #:from joint #:to to - ;; env can be false if no expressions were read. - #:env (or env (default-environment joint)) - #:opts opts)) - (else - ;; compile-fold instead of compile so we get the env too - (receive (jexp jenv jcenv) - (compile-fold (compile-passes (current-language) joint opts) - x cenv opts) - (lp (cons jexp exps) jenv jcenv)))))))))) + (let* ((from (ensure-language from)) + (to (ensure-language to)) + (joint (find-language-joint from to))) + (parameterize ((current-language from)) + (let lp ((exps '()) (env #f) (cenv env) (from #f) (compile1 #f)) + (match (read-and-parse (current-language) port cenv) + ((? eof-object?) + (close-port port) + (compile ((or (language-joiner joint) + (default-language-joiner joint)) + (reverse exps) + env) + #:from joint #:to to + ;; env can be false if no expressions were read. + #:env (or env (default-environment joint)) + #:opts opts)) + (exp + (let with-compiler ((from from) (compile1 compile1)) + (cond + ((eq? from (current-language)) + (receive (exp env cenv) (compile1 exp cenv) + (lp (cons exp exps) env cenv from compile1))) + (else + ;; compute-compiler instead of compile so we get the + ;; env too. + (let ((from (current-language))) + (with-compiler + from + (compute-compiler from joint opts)))))))))))) (define* (compile x #:key (from (current-language)) @@ -268,9 +279,9 @@ (env (default-environment from)) (opts '())) (validate-options opts) - (receive (exp env cenv) - (compile-fold (compile-passes from to opts) x env opts) - exp)) + (let ((compile1 (compute-compiler from to opts))) + (receive (exp env cenv) (compile1 x env) + exp))) ;;; |