Split compile-expr-item into expr and non-expr versions.

diff --git a/src/edwin/clsmac.scm b/src/edwin/clsmac.scm
index f5a68022d3561f46d3cd087da92035b6af6ef8a3..80ce279211f632d11a616f933b2c389fa28d839b 100644 (file)
--- a/src/edwin/clsmac.scm
+++ b/src/edwin/clsmac.scm
@@ -108,7 +108,7 @@ USA.
            (name->class (identifier->symbol class-name)))
           (compile-expr-item self-item)
           free-names
-          (compile-expr-item body-item))))))))
+          (compile-item body-item))))))))
 
 (define-syntax ==>
   (syntax-rules ()

diff --git a/src/edwin/edwin.pkg b/src/edwin/edwin.pkg
index 327503594cb01612edc0ce2ab8efa735fbe20e0a..353a4b3061976f220e41e6ee0e99f5c3e4603767 100644 (file)
--- a/src/edwin/edwin.pkg
+++ b/src/edwin/edwin.pkg
@@ -288,6 +288,7 @@ USA.
          classifier->runtime
          classify-form
          compile-expr-item
+         compile-item
          expr-item))
 
 (define-package (edwin class-macros transform-instance-variables)

diff --git a/src/runtime/host-adapter.scm b/src/runtime/host-adapter.scm
index e9fbf36f8ae4e7b27e33a5dc25ce45927482f1b5..eb8dd7319a69da608a08368e7333c586c1a6430a 100644 (file)
--- a/src/runtime/host-adapter.scm
+++ b/src/runtime/host-adapter.scm
@@ -191,6 +191,10 @@ USA.
   (let ((env (->environment '(runtime syntax))))
     (provide-rename env 'make-expression-item 'expr-item)
     (provide-rename env 'compile-item/expression 'compile-expr-item)
+    (if (unbound? env 'compile-item)
+       (eval '(define (compile-item body-item)
+                (compile-body-items (item->list body-item)))
+             env))
     (if (unbound? env 'classify-form)
        (eval '(define (classify-form form senv #!optional hist)
                 (classify/form form senv senv))

diff --git a/src/runtime/mit-syntax.scm b/src/runtime/mit-syntax.scm
index 7e24dad97b233dd70c838d7b50813603ecb6d94f..cdb9a4701ffbbf085a0820a287465a582a8948a9 100644 (file)
--- a/src/runtime/mit-syntax.scm
+++ b/src/runtime/mit-syntax.scm
@@ -329,7 +329,7 @@ USA.
        (spar-elt spar-push-classified)
        spar-match-null))))
 
-(define-item-compiler access-item?
+(define-expr-item-compiler access-item?
   (lambda (item)
     (output/access-reference (access-item-name item)
                             (compile-expr-item (access-item-env item)))))

diff --git a/src/runtime/runtime.pkg b/src/runtime/runtime.pkg
index 77801963314931dc52e7391b3e89a59ae4d336da..c09b6131daeca0e638c84271fb307e2a5e328954 100644 (file)
--- a/src/runtime/runtime.pkg
+++ b/src/runtime/runtime.pkg
@@ -4481,9 +4481,10 @@ USA.
          body-item
          combination-item
          compile-expr-item
+         compile-item
          constant-item
          decl-item
-         define-item-compiler
+         define-expr-item-compiler
          defn-item
          defn-item-id
          defn-item-syntax?

diff --git a/src/runtime/syntax-items.scm b/src/runtime/syntax-items.scm
index 9adfdd39174e9a155831ecd5baba6d14c42d2919..874724ffa0b301412122f3a3d53a40fd758edf1e 100644 (file)
--- a/src/runtime/syntax-items.scm
+++ b/src/runtime/syntax-items.scm
@@ -134,19 +134,19 @@ USA.
 (define (lambda-item name bvl classify-body)
   (expr-item
    (lambda ()
-     (output/lambda name bvl (compile-expr-item (classify-body))))))
+     (output/lambda name bvl (compile-item (classify-body))))))
 
 (define (let-item names value-items body-item)
   (expr-item
    (lambda ()
      (output/let names
                 (map compile-expr-item value-items)
-                (compile-expr-item body-item)))))
+                (compile-item body-item)))))
 
 (define (body-item items)
   (expr-item
    (lambda ()
-     (output/body (map compile-expr-item (flatten-items items))))))
+     (output/body (map compile-item (flatten-items items))))))
 
 (define (if-item predicate consequent alternative)
   (expr-item
@@ -198,14 +198,28 @@ USA.
 \f
 ;;;; Compiler
 
+(define compile-item)
 (define compile-expr-item)
 (add-boot-init!
  (lambda ()
+   (set! compile-item
+        (standard-predicate-dispatcher 'compile-item 1))
    (set! compile-expr-item
         (standard-predicate-dispatcher 'compile-expr-item 1))
    (run-deferred-boot-actions 'define-item-compiler)))
 
-(define (define-item-compiler predicate compiler)
+(define (define-item-compiler predicate compiler #!optional expr-compiler)
+  (defer-boot-action 'define-item-compiler
+    (lambda ()
+      (define-predicate-dispatch-handler compile-item
+       (list predicate)
+       compiler)
+      (if expr-compiler
+         (define-predicate-dispatch-handler compile-expr-item
+           (list predicate)
+           (if (default-object? expr-compiler) compiler expr-compiler))))))
+
+(define (define-expr-item-compiler predicate compiler)
   (defer-boot-action 'define-item-compiler
     (lambda ()
       (define-predicate-dispatch-handler compile-expr-item
@@ -221,24 +235,28 @@ USA.
     ((expr-item-compiler item))))
 
 (define-item-compiler seq-item?
+  (lambda (item)
+    (output/sequence (map compile-item (seq-item-elements item))))
   (lambda (item)
     (output/sequence (map compile-expr-item (seq-item-elements 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))))
+    (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))))
+  #f)
 
 (define (illegal-expression-compiler description)
   (let ((message (string description " may not be used as an expression:")))
     (lambda (item)
       (error message item))))
 
+(define-expr-item-compiler defn-item?
+  (illegal-expression-compiler "Definition"))
+
 (define-item-compiler reserved-name-item?
   (illegal-expression-compiler "Reserved name"))
 

diff --git a/src/runtime/syntax.scm b/src/runtime/syntax.scm
index 94352cfaf3c7bc5001268a24a3001b492777c007..d0be31fdfddd9639a54c41bda5b800a34f2a7f07 100644 (file)
--- a/src/runtime/syntax.scm
+++ b/src/runtime/syntax.scm
@@ -54,7 +54,7 @@ USA.
             (runtime-environment->syntactic environment))))
     (with-identifier-renaming
      (lambda ()
-       (compile-expr-item
+       (compile-item
        (body-item
         (map-in-order (lambda (form)
                         (classify-form form senv (initial-hist form)))