From: Chris Hanson <org/chris-hanson/cph>
Date: Fri, 2 Feb 2018 05:55:33 +0000 (-0800)
Subject: Don't generate keyword-value-item except at top level.
X-Git-Tag: mit-scheme-pucked-x11-0.3.1~7^2~277
X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=defd1ded50dc905d055da536b799cd72058aa5b8;p=mit-scheme.git

Don't generate keyword-value-item except at top level.

They aren't needed for internal environments.
---

diff --git a/src/runtime/mit-syntax.scm b/src/runtime/mit-syntax.scm
index 38ad6e38e..cac5e142b 100644
--- a/src/runtime/mit-syntax.scm
+++ b/src/runtime/mit-syntax.scm
@@ -31,33 +31,36 @@ USA.
 
 ;;;; Macro transformers
 
-(define (transformer-keyword name transformer->expander)
-  (lambda (form environment)
+(define (transformer-keyword procedure-name transformer->expander)
+  (lambda (form senv)
     (syntax-check '(KEYWORD EXPRESSION) form)
-    (let ((item (classify/expression (cadr form) environment)))
-      (keyword-value-item
-       (transformer->expander (transformer-eval (compile-item/expression item)
-						environment)
-			      environment)
-       (expr-item
-	(lambda ()
-	  (output/combination (output/runtime-reference name)
-			      (list (compile-item/expression item)
-				    (output/the-environment)))))))))
+    (let ((transformer
+	   (compile-item/expression
+	    (classify/expression (cadr form) senv))))
+      (let ((item
+	     (transformer->expander (transformer-eval transformer senv)
+				    senv)))
+	(if (syntactic-environment/top-level? senv)
+	    (keyword-value-item
+	     item
+	     (expr-item
+	      (lambda ()
+		(output/top-level-syntax-expander procedure-name transformer))))
+	    item)))))
 
 (define classifier:sc-macro-transformer
   ;; "Syntactic Closures" transformer
-  (transformer-keyword 'SC-MACRO-TRANSFORMER->EXPANDER
+  (transformer-keyword 'sc-macro-transformer->expander
 		       sc-macro-transformer->expander))
 
 (define classifier:rsc-macro-transformer
   ;; "Reversed Syntactic Closures" transformer
-  (transformer-keyword 'RSC-MACRO-TRANSFORMER->EXPANDER
+  (transformer-keyword 'rsc-macro-transformer->expander
 		       rsc-macro-transformer->expander))
 
 (define classifier:er-macro-transformer
   ;; "Explicit Renaming" transformer
-  (transformer-keyword 'ER-MACRO-TRANSFORMER->EXPANDER
+  (transformer-keyword 'er-macro-transformer->expander
 		       er-macro-transformer->expander))
 
 ;;;; Core primitives
diff --git a/src/runtime/runtime.pkg b/src/runtime/runtime.pkg
index 7c04ffdea..2948ab32a 100644
--- a/src/runtime/runtime.pkg
+++ b/src/runtime/runtime.pkg
@@ -4531,6 +4531,7 @@ USA.
 	  output/top-level-definition
 	  output/top-level-sequence
 	  output/top-level-syntax-definition
+	  output/top-level-syntax-expander
 	  output/unassigned
 	  output/unassigned-test
 	  output/unspecific
diff --git a/src/runtime/syntax-output.scm b/src/runtime/syntax-output.scm
index 58446894c..e384dc2a6 100644
--- a/src/runtime/syntax-output.scm
+++ b/src/runtime/syntax-output.scm
@@ -59,6 +59,11 @@ USA.
 (define (output/top-level-syntax-definition name value)
   (make-scode-definition name (make-macro-reference-trap-expression value)))
 
+(define (output/top-level-syntax-expander procedure-name transformer)
+  (output/combination (output/runtime-reference procedure-name)
+		      (list transformer
+			    (output/the-environment))))
+
 (define (output/conditional predicate consequent alternative)
   (make-scode-conditional predicate consequent alternative))