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.

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)
+(define (compute-compiler from to opts)
-  (match (lookup-compilation-order from to)
+  (let lp ((order (or (lookup-compilation-order from to)
-    (((langs . passes) ...) passes)
+                      (error "no way to compile" from "to" to))))
-    (_ (error "no way to compile" from "to" to))))
+    (match order
-
+      (() (lambda (exp env) (values exp env env)))
-(define (compile-fold passes exp env opts)
+      (((lang . pass) . order)
-  (let lp ((passes passes) (x exp) (e env) (cenv env) (first? #t))
+       (let ((head (lambda (exp env)
-    (match passes
+                     (pass exp env opts)))
-      (() (values x e cenv))
+             (tail (lp order)))
-      ((pass . passes)
+         (lambda (exp env)
-       (receive (x e new-cenv) (pass x e opts)
+           (let*-values (((exp env cenv) (head exp env))
-         (lp passes x e (if first? new-cenv cenv) #f))))))
+                         ((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))
+  (let* ((from (ensure-language from))
-        (to (ensure-language to)))
+         (to (ensure-language to))
-    (let ((joint (find-language-joint from to)))
+         (joint (find-language-joint from to)))
-      (parameterize ((current-language from))
+    (parameterize ((current-language from))
-        (let lp ((exps '()) (env #f) (cenv env))
+      (let lp ((exps '()) (env #f) (cenv env) (from #f) (compile1 #f))
-          (let ((x (read-and-parse (current-language) port cenv)))
+        (match (read-and-parse (current-language) port cenv)
-            (cond
+          ((? eof-object?)
-             ((eof-object? x)
+           (close-port port)
-              (close-port port)
+           (compile ((or (language-joiner joint)
-              (compile ((or (language-joiner joint)
+                         (default-language-joiner joint))
-                            (default-language-joiner joint))
+                     (reverse exps)
-                        (reverse exps)
+                     env)
-                        env)
+                    #:from joint #:to to
-                       #:from joint #:to to
+                    ;; env can be false if no expressions were read.
-                       ;; env can be false if no expressions were read.
+                    #:env (or env (default-environment joint))
-                       #:env (or env (default-environment joint))
+                    #:opts opts))
-                       #:opts opts))
+          (exp
-             (else
+           (let with-compiler ((from from) (compile1 compile1))
-              ;; compile-fold instead of compile so we get the env too
+             (cond
-              (receive (jexp jenv jcenv)
+              ((eq? from (current-language))
-                  (compile-fold (compile-passes (current-language) joint opts)
+               (receive (exp env cenv) (compile1 exp cenv)
-                                x cenv opts)
+                 (lp (cons exp exps) env cenv from compile1)))
-                (lp (cons jexp exps) jenv jcenv))))))))))
+              (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)
+  (let ((compile1 (compute-compiler from to opts)))
-      (compile-fold (compile-passes from to opts) x env opts)
+    (receive (exp env cenv) (compile1 x env)
-    exp))
+      exp)))
 
 
 ;;;