From: Chris Hanson <org/chris-hanson/cph>
Date: Fri, 26 Jan 2018 04:05:28 +0000 (-0800)
Subject: Introduce syntactic-environment/reserve to handle common case.
X-Git-Tag: mit-scheme-pucked-x11-0.3.1~7^2~307
X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=d935033e13939e184aaab677ad492a5433f361a6;p=mit-scheme.git

Introduce syntactic-environment/reserve to handle common case.

This also means that syntactic-environment/define is only used for keyword
items.
---

diff --git a/src/runtime/mit-syntax.scm b/src/runtime/mit-syntax.scm
index e508e0a72..ba8b33b2e 100644
--- a/src/runtime/mit-syntax.scm
+++ b/src/runtime/mit-syntax.scm
@@ -144,9 +144,7 @@ USA.
    (lambda (form environment)
      (let ((name (cadr form)))
        (if (not (syntactic-environment/top-level? environment))
-	   (syntactic-environment/define environment
-					 name
-					 (make-reserved-name-item)))
+	   (syntactic-environment/reserve environment name))
        (variable-binder environment name
 			(classify/expression (caddr form) environment))))))
 
@@ -217,11 +215,8 @@ USA.
   (let ((bindings (cadr form))
 	(body (cddr form))
 	(binding-env (make-internal-syntactic-environment env)))
-    (for-each (let ((item (make-reserved-name-item)))
-		(lambda (binding)
-		  (syntactic-environment/define binding-env
-						(car binding)
-						item)))
+    (for-each (lambda (binding)
+		(syntactic-environment/reserve binding-env (car binding)))
 	      bindings)
     ;; Classify right-hand sides first, in order to catch references to
     ;; reserved names.  Then bind names prior to classifying body.
diff --git a/src/runtime/runtime.pkg b/src/runtime/runtime.pkg
index 2f5c91754..a9341e35a 100644
--- a/src/runtime/runtime.pkg
+++ b/src/runtime/runtime.pkg
@@ -4471,6 +4471,7 @@ USA.
 	  syntactic-environment->environment
 	  syntactic-environment/define
 	  syntactic-environment/lookup
+	  syntactic-environment/reserve
 	  syntactic-environment/top-level?
 	  syntactic-environment?))
 
diff --git a/src/runtime/syntax-environment.scm b/src/runtime/syntax-environment.scm
index 827a55627..a56ec2b0d 100644
--- a/src/runtime/syntax-environment.scm
+++ b/src/runtime/syntax-environment.scm
@@ -51,21 +51,15 @@ USA.
   (guarantee identifier? identifier 'syntactic-environment/lookup)
   ((senv-lookup senv) identifier))
 
+(define (syntactic-environment/reserve senv identifier)
+  (guarantee identifier? identifier 'syntactic-environment/reserve)
+  ((senv-store senv) identifier (make-reserved-name-item)))
+
 (define (syntactic-environment/define senv identifier item)
   (guarantee identifier? identifier 'syntactic-environment/define)
-  (guarantee senv-value-item? item 'syntactic-environment/define)
+  (guarantee keyword-item? item 'syntactic-environment/define)
   ((senv-store senv) identifier item))
 
-(define (senv-value-item? object)
-  (or (reserved-name-item? object)
-      (keyword-item? object)
-      (variable-item? object)))
-(register-predicate! senv-value-item? 'syntactic-environment-value-item)
-
-(define (syntactic-environment/rename senv identifier)
-  (guarantee identifier? identifier 'syntactic-environment/rename)
-  ((senv-rename senv) identifier))
-
 (define (bind-variable! senv identifier)
   (guarantee identifier? identifier 'bind-variable!)
   (let ((rename ((senv-rename senv) identifier)))