Eliminate compile-body-item and simplify.

diff --git a/src/runtime/runtime.pkg b/src/runtime/runtime.pkg
index 96870ccc29840470a16578399fc7ca39044702d2..6a6c8c80f1d9484c023e9c76fdf8759cf92d2217 100644 (file)
--- a/src/runtime/runtime.pkg
+++ b/src/runtime/runtime.pkg
@@ -4424,7 +4424,6 @@ USA.
          classify-forms-cdr
          classify-forms-in-order-cddr
          classify-forms-in-order-cdr
-         compile-body-items
          compile-expr-item
          define-item-compiler
          hist-caddr
@@ -4541,10 +4540,8 @@ USA.
          output/quoted-identifier
          output/runtime-reference
          output/sequence
+         output/syntax-definition
          output/the-environment
-         output/top-level-definition
-         output/top-level-sequence
-         output/top-level-syntax-definition
          output/top-level-syntax-expander
          output/unassigned
          output/unassigned-test

diff --git a/src/runtime/syntax-items.scm b/src/runtime/syntax-items.scm
index 698f721d6e500e362b28e9f628b8bb2278e89411..e48bc50e67f6ff8908afc7776903a4676494736d 100644 (file)
--- a/src/runtime/syntax-items.scm
+++ b/src/runtime/syntax-items.scm
@@ -180,7 +180,7 @@ USA.
 (define (body-item items)
   (expr-item
    (lambda ()
-     (output/body (compile-body-items items)))))
+     (output/body (map compile-expr-item items)))))
 
 (define (if-item predicate consequent alternative)
   (expr-item

diff --git a/src/runtime/syntax-output.scm b/src/runtime/syntax-output.scm
index 989fd9c5abd4f2cede67df5bc631ec11f1908522..f3e4316b9344bbedf20acf52bd4d1eb478a1ea47 100644 (file)
--- a/src/runtime/syntax-output.scm
+++ b/src/runtime/syntax-output.scm
@@ -46,7 +46,7 @@ USA.
 (define (output/assignment name value)
   (make-scode-assignment name value))
 
-(define (output/top-level-definition name value)
+(define (output/definition name value)
   (make-scode-definition name
     (if (scode-lambda? value)
        (lambda-components* value
@@ -56,7 +56,7 @@ USA.
                value)))
        value)))
 
-(define (output/top-level-syntax-definition name value)
+(define (output/syntax-definition name value)
   (make-scode-definition name (make-macro-reference-trap-expression value)))
 
 (define (output/top-level-syntax-expander procedure-name transformer)
@@ -70,16 +70,17 @@ USA.
 (define (output/disjunction exprs)
   (reduce-right make-scode-disjunction '#f exprs))
 
-(define (output/sequence expressions)
-  (make-scode-sequence expressions))
+(define (output/sequence exprs)
+  (if (pair? exprs)
+      (make-scode-sequence exprs)
+      (output/unspecific)))
 
 (define (output/combination operator operands)
   (make-scode-combination operator operands))
 
 (define (output/lambda name lambda-list body)
-  (call-with-values (lambda () (parse-mit-lambda-list lambda-list))
-    (lambda (required optional rest)
-      (make-lambda* name required optional rest body))))
+  (receive (required optional rest) (parse-mit-lambda-list lambda-list)
+    (make-lambda* name required optional rest body)))
 
 (define (output/delay expression)
   (make-scode-delay expression))
@@ -120,23 +121,12 @@ USA.
                   (output/let '() '() body)
                   body))))))))
 
-(define (output/body body)
-  (scan-defines body make-scode-open-block))
+(define (output/body exprs)
+  (scan-defines (output/sequence exprs) make-scode-open-block))
 
 (define (output/declaration text)
   (make-scode-block-declaration text))
 
-(define (output/definition name value)
-  (make-scode-definition name value))
-
-(define (output/top-level-sequence expressions)
-  (if (pair? expressions)
-      (if (pair? (cdr expressions))
-         (scan-defines (make-scode-sequence expressions)
-                       make-scode-open-block)
-         (car expressions))
-      (output/unspecific)))
-
 (define (output/the-environment)
   (make-scode-the-environment))
 

diff --git a/src/runtime/syntax.scm b/src/runtime/syntax.scm
index 85d048824d1eb67a15de87950c3acd4e54ca89af..3bfa73b75e5d6a070f1b823caccb10a631fdaf05 100644 (file)
--- a/src/runtime/syntax.scm
+++ b/src/runtime/syntax.scm
@@ -54,34 +54,11 @@ USA.
             (runtime-environment->syntactic environment))))
     (with-identifier-renaming
      (lambda ()
-       (if (senv-top-level? senv)
-          (%compile-top-level-body (%classify-body-top-level forms senv))
-          (output/sequence
-           (map (lambda (form)
-                  (compile-expr-item
-                   (%classify-form-top-level form senv)))
-                forms)))))))
-
-(define (%classify-form-top-level form senv)
-  (classify-form form senv (initial-hist form)))
-
-(define (%classify-body-top-level forms senv)
-  (seq-item
-   (map-in-order (lambda (form)
-                  (%classify-form-top-level form senv))
-                forms)))
-
-(define (%compile-top-level-body item)
-  (output/top-level-sequence
-   (map (lambda (item)
-         (if (defn-item? item)
-             (let ((name (defn-item-id item))
-                   (value (compile-expr-item (defn-item-value item))))
-               (if (defn-item-syntax? item)
-                   (output/top-level-syntax-definition name value)
-                   (output/top-level-definition name value)))
-             (compile-expr-item item)))
-       (item->list item))))
+       (compile-expr-item
+       (body-item
+        (map-in-order (lambda (form)
+                        (classify-form form senv (initial-hist form)))
+                      forms)))))))
 \f
 ;;;; Classifier
 
@@ -148,22 +125,6 @@ USA.
 \f
 ;;;; Compiler
 
-(define (compile-body-items items)
-  (let ((items (flatten-items items)))
-    (if (not (pair? items))
-       (syntax-error "Empty body"))
-    (output/sequence
-     (append-map
-      (lambda (item)
-       (if (defn-item? item)
-           (if (defn-item-syntax? item)
-               '()
-               (list (output/definition
-                      (defn-item-id item)
-                      (compile-expr-item (defn-item-value item)))))
-           (list (compile-expr-item item))))
-      items))))
-
 (define compile-expr-item)
 (add-boot-init!
  (lambda ()
@@ -188,12 +149,22 @@ USA.
 
 (define-item-compiler seq-item?
   (lambda (item)
-    (compile-body-items (seq-item-elements item))))
+    (output/sequence (map compile-expr-item (seq-item-elements item)))))
 
 (define-item-compiler decl-item?
   (lambda (item)
     (output/declaration (decl-item-text item))))
 
+(define-item-compiler defn-item?
+  (lambda (item)
+    (if (defn-item? item)
+       (let ((name (defn-item-id item))
+             (value (compile-expr-item (defn-item-value item))))
+         (if (defn-item-syntax? item)
+             (output/syntax-definition name value)
+             (output/definition name value)))
+       (compile-expr-item item))))
+
 (define (illegal-expression-compiler description)
   (let ((message (string description " may not be used as an expression:")))
     (lambda (item)
@@ -204,9 +175,6 @@ USA.
 
 (define-item-compiler keyword-item?
   (illegal-expression-compiler "Syntactic keyword"))
-
-(define-item-compiler defn-item?
-  (illegal-expression-compiler "Definition"))
 \f
 ;;;; Syntactic closures