From: Chris Hanson <org/chris-hanson/cph>
Date: Thu, 1 Mar 2018 06:18:00 +0000 (-0800)
Subject: Split compile-expr-item into expr and non-expr versions.
X-Git-Tag: mit-scheme-pucked-x11-0.3.1~7^2~223
X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=42b9b093977effe190f3a129450f0387f9f73d20;p=mit-scheme.git

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

diff --git a/src/edwin/clsmac.scm b/src/edwin/clsmac.scm
index f5a68022d..80ce27921 100644
--- 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 327503594..353a4b306 100644
--- 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 e9fbf36f8..eb8dd7319 100644
--- 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 7e24dad97..cdb9a4701 100644
--- 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 778019633..c09b6131d 100644
--- 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 9adfdd391..874724ffa 100644
--- 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.
 
 ;;;; 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 94352cfaf..d0be31fdf 100644
--- 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)))