From: Chris Hanson <org/chris-hanson/cph>
Date: Sat, 3 Feb 2018 08:18:48 +0000 (-0800)
Subject: Move the higher-level senv procedures into syntax-environments.
X-Git-Tag: mit-scheme-pucked-x11-0.3.1~7^2~275
X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=6bd22dc3da5bb507003a75a82d2fb197c82687a1;p=mit-scheme.git

Move the higher-level senv procedures into syntax-environments.

* Clean up the high-level interface, making arg order consistent.
* Rename syntactic-environment->environment as syntactic-environment->runtime.
* Eliminate ->syntactic-environment in favor of runtime-environment->syntactic.
* Rename syntactic-environment/top-level? to top-level-syntactic-environment?.
* Export closed-identifier? to (runtime syntax).
---

diff --git a/src/compiler/back/asmmac.scm b/src/compiler/back/asmmac.scm
index dfeb23de7..8104ecf26 100644
--- a/src/compiler/back/asmmac.scm
+++ b/src/compiler/back/asmmac.scm
@@ -82,7 +82,8 @@ USA.
 
   (define (car-constant? components)
     (and (identifier=? environment (caar components)
-		       (->syntactic-environment system-global-environment)
+		       (runtime-environment->syntactic
+			system-global-environment)
 		       'quote)
 	 (bit-string? (cadar components))))
 
diff --git a/src/edwin/clsmac.scm b/src/edwin/clsmac.scm
index cb60369fe..0dc8a1a77 100644
--- a/src/edwin/clsmac.scm
+++ b/src/edwin/clsmac.scm
@@ -101,7 +101,8 @@ USA.
 	 free-names
 	 (compile/expression
 	  `(,(close-syntax 'begin
-			   (->syntactic-environment system-global-environment))
+			   (runtime-environment->syntactic
+			    system-global-environment))
 	    ,@body)
 	  environment)))))))
 
diff --git a/src/ffi/ffi.pkg b/src/ffi/ffi.pkg
index c8c246cde..35bbe9adb 100644
--- a/src/ffi/ffi.pkg
+++ b/src/ffi/ffi.pkg
@@ -12,8 +12,8 @@ FFI System Packaging |#
   (import (runtime ffi)
 	  make-alien-function
 	  alien-function/filename)
-  (import (runtime syntax environment)
-	  syntactic-environment->environment)
+  (import (runtime syntax)
+	  syntactic-environment->runtime)
   (export ()
 	  c-include
 	  load-c-includes
diff --git a/src/ffi/syntax.scm b/src/ffi/syntax.scm
index cad2339cd..11749b824 100644
--- a/src/ffi/syntax.scm
+++ b/src/ffi/syntax.scm
@@ -37,7 +37,7 @@ USA.
      (call-with-destructured-c-include-form
       form
       (lambda (library)
-	(let ((ienv (syntactic-environment->environment usage-env)))
+	(let ((ienv (syntactic-environment->runtime usage-env)))
 	  (if (and (environment-bound? ienv 'C-INCLUDES)
 		   (environment-assigned? ienv 'C-INCLUDES))
 	      (let ((value (environment-lookup ienv 'C-INCLUDES))
@@ -504,7 +504,7 @@ USA.
 (define (find-c-includes env)
   ;; Returns the c-includes structure bound to 'C-INCLUDES in ENV.
   (guarantee syntactic-environment? env 'find-c-includes)
-  (let ((ienv (syntactic-environment->environment env)))
+  (let ((ienv (syntactic-environment->runtime env)))
     (if (and (environment-bound? ienv 'C-INCLUDES)
 	     (environment-assigned? ienv 'C-INCLUDES))
 	(let ((includes (environment-lookup ienv 'C-INCLUDES)))
diff --git a/src/runtime/host-adapter.scm b/src/runtime/host-adapter.scm
index 985a304ad..5b3666e08 100644
--- a/src/runtime/host-adapter.scm
+++ b/src/runtime/host-adapter.scm
@@ -63,8 +63,8 @@ USA.
 		 (vector-ref (gc-space-status) 0))
 	      env))
 
-    (if (unbound? env '->syntactic-environment)
-	(eval '(define (->syntactic-environment object)
+    (if (unbound? env 'runtime-environment->syntactic)
+	(eval '(define (runtime-environment->syntactic object)
 		 object)
 	      env))
 
diff --git a/src/runtime/mit-syntax.scm b/src/runtime/mit-syntax.scm
index cac5e142b..cac848ecb 100644
--- a/src/runtime/mit-syntax.scm
+++ b/src/runtime/mit-syntax.scm
@@ -40,7 +40,7 @@ USA.
       (let ((item
 	     (transformer->expander (transformer-eval transformer senv)
 				    senv)))
-	(if (syntactic-environment/top-level? senv)
+	(if (top-level-syntactic-environment? senv)
 	    (keyword-value-item
 	     item
 	     (expr-item
@@ -82,7 +82,7 @@ USA.
     ;; Force order -- bind names before classifying body.
     (let ((bvl
 	   (map-mit-lambda-list (lambda (identifier)
-				  (bind-variable environment identifier))
+				  (bind-variable identifier environment))
 				bvl)))
       (values bvl
 	      (compile-body-item
@@ -150,7 +150,7 @@ USA.
   (classifier->keyword
    (lambda (form environment)
      (let ((name (cadr form)))
-       (reserve-identifier environment name)
+       (reserve-identifier name environment)
        (variable-binder defn-item
 			environment
 			name
@@ -163,19 +163,19 @@ USA.
     (keyword-binder environment name item)
     ;; User-defined macros at top level are preserved in the output.
     (if (and (keyword-value-item? item)
-	     (syntactic-environment/top-level? environment))
+	     (top-level-syntactic-environment? environment))
 	(defn-item name item)
 	(seq-item '()))))
 
 (define (keyword-binder environment name item)
   (if (not (keyword-item? item))
       (syntax-error "Keyword binding value must be a keyword:" name))
-  (bind-keyword environment name item))
+  (bind-keyword name environment item))
 
 (define (variable-binder k environment name item)
   (if (keyword-item? item)
       (syntax-error "Variable binding value must not be a keyword:" name))
-  (k (bind-variable environment name) item))
+  (k (bind-variable name environment) item))
 
 ;;;; LET-like
 
@@ -225,7 +225,7 @@ USA.
 	(body (cddr form))
 	(binding-env (make-internal-syntactic-environment env)))
     (for-each (lambda (binding)
-		(reserve-identifier binding-env (car binding)))
+		(reserve-identifier (car binding) binding-env))
 	      bindings)
     ;; Classify right-hand sides first, in order to catch references to
     ;; reserved names.  Then bind names prior to classifying body.
@@ -273,7 +273,7 @@ USA.
 
 (define (compiler:the-environment form environment)
   (syntax-check '(KEYWORD) form)
-  (if (not (syntactic-environment/top-level? environment))
+  (if (not (top-level-syntactic-environment? environment))
       (syntax-error "This form allowed only at top level:" form))
   (output/the-environment))
 
diff --git a/src/runtime/runtime.pkg b/src/runtime/runtime.pkg
index 2948ab32a..39fddddd0 100644
--- a/src/runtime/runtime.pkg
+++ b/src/runtime/runtime.pkg
@@ -4387,6 +4387,7 @@ USA.
 	  (make-synthetic-identifier new-identifier)
 	  capture-syntactic-environment
 	  close-syntax
+	  closed-identifier?
 	  identifier->symbol
 	  identifier=?
 	  identifier?
@@ -4402,14 +4403,10 @@ USA.
 	  syntax*
 	  syntax-error)
   (export (runtime syntax)
-	  bind-keyword
-	  bind-variable
 	  classifier->keyword
 	  compile/expression
 	  compiler->keyword
-	  lookup-identifier
-	  raw-identifier?
-	  reserve-identifier))
+	  raw-identifier?))
 
 (define-package (runtime syntax items)
   (files "syntax-items")
@@ -4454,18 +4451,18 @@ USA.
   (files "syntax-environment")
   (parent (runtime syntax))
   (export ()
-	  ->syntactic-environment
+	  runtime-environment->syntactic
 	  syntactic-environment?)
   (export (runtime syntax)
+	  bind-keyword
+	  bind-variable
+	  lookup-identifier
 	  make-internal-syntactic-environment
 	  make-keyword-syntactic-environment
 	  make-partial-syntactic-environment
-	  syntactic-environment->environment
-	  syntactic-environment/bind-keyword
-	  syntactic-environment/bind-variable
-	  syntactic-environment/lookup
-	  syntactic-environment/reserve
-	  syntactic-environment/top-level?
+	  reserve-identifier
+	  syntactic-environment->runtime
+	  top-level-syntactic-environment?
 	  syntactic-environment?))
 
 (define-package (runtime syntax check)
diff --git a/src/runtime/syntax-environment.scm b/src/runtime/syntax-environment.scm
index 0b5834ffd..84763ead7 100644
--- a/src/runtime/syntax-environment.scm
+++ b/src/runtime/syntax-environment.scm
@@ -28,6 +28,56 @@ USA.
 
 (declare (usual-integrations))
 
+(define (runtime-environment->syntactic env)
+  (cond ((interpreter-environment? env) (%top-level-runtime-senv env))
+	((environment? env) (%internal-runtime-senv env))
+	(else (error:not-a environment? env 'runtime-environment->syntactic))))
+
+(define (syntactic-environment->runtime senv)
+  ((senv-get-runtime senv)))
+
+(define (top-level-syntactic-environment? senv)
+  (eq? 'top-level ((senv-get-type senv))))
+
+(define ((id-dispatcher handle-raw caller) identifier senv)
+  (cond ((raw-identifier? identifier)
+	 (handle-raw identifier senv))
+	((closed-identifier? identifier)
+	 (handle-raw (syntactic-closure-form identifier)
+		     (syntactic-closure-senv identifier)))
+	(else
+	 (error:not-a identifier? identifier caller))))
+
+(define lookup-identifier
+  (id-dispatcher (lambda (identifier senv)
+		   (let ((item ((senv-lookup senv) identifier)))
+		     (if (reserved-name-item? item)
+			 (syntax-error "Premature reference to reserved name:"
+				       identifier))
+		     (or item
+			 (var-item identifier))))
+		 'lookup-identifier))
+
+(define reserve-identifier
+  (id-dispatcher (lambda (identifier senv)
+		   ((senv-store senv) identifier (reserved-name-item)))
+		 'reserve-identifier))
+
+(define (bind-keyword identifier senv item)
+  (guarantee keyword-item? item 'bind-keyword)
+  ((id-dispatcher (lambda (identifier senv)
+		    ((senv-store senv) identifier item))
+		  'bind-keyword)
+   identifier
+   senv))
+
+(define bind-variable
+  (id-dispatcher (lambda (identifier senv)
+		   (let ((rename ((senv-rename senv) identifier)))
+		     ((senv-store senv) identifier (var-item rename))
+		     rename))
+		 'bind-variable))
+
 (define-record-type <syntactic-environment>
     (make-senv get-type get-runtime lookup store rename describe)
     syntactic-environment?
@@ -38,46 +88,15 @@ USA.
   (rename senv-rename)
   (describe senv-describe))
 
-(define (senv-type senv)
-  ((senv-get-type senv)))
-
-(define (syntactic-environment/top-level? senv)
-  (eq? 'top-level (senv-type senv)))
-
-(define (syntactic-environment->environment senv)
-  ((senv-get-runtime senv)))
-
-(define (syntactic-environment/lookup senv identifier)
-  (guarantee raw-identifier? identifier 'syntactic-environment/lookup)
-  ((senv-lookup senv) identifier))
-
-(define (syntactic-environment/reserve senv identifier)
-  (guarantee raw-identifier? identifier 'syntactic-environment/reserve)
-  ((senv-store senv) identifier (reserved-name-item)))
-
-(define (syntactic-environment/bind-keyword senv identifier item)
-  (guarantee raw-identifier? identifier 'syntactic-environment/bind-keyword)
-  (guarantee keyword-item? item 'syntactic-environment/bind-keyword)
-  ((senv-store senv) identifier item))
-
-(define (syntactic-environment/bind-variable senv identifier)
-  (guarantee raw-identifier? identifier 'syntactic-environment/bind-variable)
-  (let ((rename ((senv-rename senv) identifier)))
-    ((senv-store senv) identifier (var-item rename))
-    rename))
+(define-unparser-method syntactic-environment?
+  (simple-unparser-method 'syntactic-environment
+    (lambda (senv)
+      (list ((senv-get-type senv))))))
 
 (define-pp-describer syntactic-environment?
   (lambda (senv)
-    (cons `(type ,((senv-get-type senv)))
-	  ((senv-describe senv)))))
+    ((senv-describe senv))))
 
-(define (->syntactic-environment object #!optional caller)
-  (declare (ignore caller))
-  (cond ((syntactic-environment? object) object)
-	((interpreter-environment? object) (%top-level-runtime-senv object))
-	((environment? object) (%internal-runtime-senv object))
-	(else (error "Unable to convert to a syntactic environment:" object))))
-
 ;;; Runtime syntactic environments are wrappers around runtime environments.
 
 ;;; Wrappers around top-level runtime environments.
@@ -117,7 +136,7 @@ USA.
 (define (%internal-runtime-senv env)
 
   (define (get-type)
-    'runtime)
+    'internal-runtime)
 
   (define (get-runtime)
     env)
diff --git a/src/runtime/syntax-output.scm b/src/runtime/syntax-output.scm
index e384dc2a6..34caa6ba0 100644
--- a/src/runtime/syntax-output.scm
+++ b/src/runtime/syntax-output.scm
@@ -30,7 +30,7 @@ USA.
 (declare (usual-integrations))
 
 (define (transformer-eval output environment)
-  (eval output (syntactic-environment->environment environment)))
+  (eval output (syntactic-environment->runtime environment)))
 
 (define (output/variable name)
   (make-scode-variable name))
diff --git a/src/runtime/syntax-transforms.scm b/src/runtime/syntax-transforms.scm
index 94571e593..7f6e77819 100644
--- a/src/runtime/syntax-transforms.scm
+++ b/src/runtime/syntax-transforms.scm
@@ -31,45 +31,41 @@ USA.
 
 (declare (usual-integrations))
 
-(define (sc-macro-transformer->expander transformer closing-environment)
+(define (sc-macro-transformer->expander transformer closing-env)
   (expander-item
-   (lambda (form use-environment)
-     (close-syntax (transformer form use-environment)
-		   (->syntactic-environment closing-environment)))))
+   (lambda (form use-senv)
+     (close-syntax (transformer form use-senv)
+		   (->senv closing-env)))))
 
-(define (rsc-macro-transformer->expander transformer closing-environment)
+(define (rsc-macro-transformer->expander transformer closing-env)
   (expander-item
-   (lambda (form use-environment)
-     (close-syntax (transformer form
-				(->syntactic-environment closing-environment))
-		   use-environment))))
+   (lambda (form use-senv)
+     (close-syntax (transformer form (->senv closing-env))
+		   use-senv))))
 
-(define (er-macro-transformer->expander transformer closing-environment)
+(define (er-macro-transformer->expander transformer closing-env)
   (expander-item
-   (lambda (form use-environment)
+   (lambda (form use-senv)
      (close-syntax (transformer form
-				(make-er-rename
-				 (->syntactic-environment closing-environment))
-				(make-er-compare use-environment))
-		   use-environment))))
+				(make-er-rename (->senv closing-env))
+				(make-er-compare use-senv))
+		   use-senv))))
+
+(define (->senv env)
+  (if (syntactic-environment? env)
+      env
+      (runtime-environment->syntactic env)))
 
-(define (make-er-rename closing-environment)
-  (let ((renames '()))
-    (lambda (identifier)
-      (let ((p (assq identifier renames)))
-	(if p
-	    (cdr p)
-	    (let ((rename (close-syntax identifier closing-environment)))
-	      (set! renames (cons (cons identifier rename) renames))
-	      rename))))))
+(define (make-er-rename closing-senv)
+  (lambda (identifier)
+    (close-syntax identifier closing-senv)))
 
-(define (make-er-compare use-environment)
+(define (make-er-compare use-senv)
   (lambda (x y)
-    (identifier=? use-environment x
-		  use-environment y)))
+    (identifier=? use-senv x use-senv y)))
 
 (define (syntactic-keyword->item keyword environment)
   (let ((item (environment-lookup-macro environment keyword)))
     (if (not item)
-	(error:bad-range-argument keyword 'SYNTACTIC-KEYWORD->ITEM))
+	(error:bad-range-argument keyword 'syntactic-keyword->item))
     item))
\ No newline at end of file
diff --git a/src/runtime/syntax.scm b/src/runtime/syntax.scm
index 5ca951cb1..b393ddd66 100644
--- a/src/runtime/syntax.scm
+++ b/src/runtime/syntax.scm
@@ -48,10 +48,13 @@ USA.
 
 (define (syntax* forms environment)
   (guarantee list? forms 'syntax*)
-  (let ((senv (->syntactic-environment environment 'syntax*)))
+  (let ((senv
+	 (if (syntactic-environment? environment)
+	     environment
+	     (runtime-environment->syntactic environment))))
     (with-identifier-renaming
      (lambda ()
-       (if (syntactic-environment/top-level? senv)
+       (if (top-level-syntactic-environment? senv)
 	   (compile-body-item/top-level (classify/body forms senv))
 	   (output/sequence (compile/expressions forms senv)))))))
 
@@ -133,22 +136,6 @@ USA.
 	((closed-identifier? identifier) (syntactic-closure-form identifier))
 	(else (error:not-a identifier? identifier 'identifier->symbol))))
 
-(define (lookup-identifier identifier senv)
-  (cond ((raw-identifier? identifier)
-	 (%lookup-raw-identifier identifier senv))
-	((closed-identifier? identifier)
-	 (%lookup-raw-identifier (syntactic-closure-form identifier)
-				 (syntactic-closure-senv identifier)))
-	(else
-	 (error:not-a identifier? identifier 'lookup-identifier))))
-
-(define (%lookup-raw-identifier identifier senv)
-  (let ((item (syntactic-environment/lookup senv identifier)))
-    (if (reserved-name-item? item)
-	(syntax-error "Premature reference to reserved name:" identifier))
-    (or item
-	(var-item identifier))))
-
 (define (identifier=? environment-1 identifier-1 environment-2 identifier-2)
   (let ((item-1 (lookup-identifier identifier-1 environment-1))
 	(item-2 (lookup-identifier identifier-2 environment-2)))
@@ -161,36 +148,6 @@ USA.
 	     (var-item? item-2)
 	     (eq? (var-item-id item-1)
 		  (var-item-id item-2))))))
-
-(define (reserve-identifier senv identifier)
-  (cond ((raw-identifier? identifier)
-	 (syntactic-environment/reserve senv identifier))
-	((closed-identifier? identifier)
-	 (syntactic-environment/reserve (syntactic-closure-senv identifier)
-					(syntactic-closure-form identifier)))
-	(else
-	 (error:not-a identifier? identifier 'reserve-identifier))))
-
-(define (bind-keyword senv identifier item)
-  (cond ((raw-identifier? identifier)
-	 (syntactic-environment/bind-keyword senv identifier item))
-	((closed-identifier? identifier)
-	 (syntactic-environment/bind-keyword
-	  (syntactic-closure-senv identifier)
-	  (syntactic-closure-form identifier)
-	  item))
-	(else
-	 (error:not-a identifier? identifier 'bind-keyword))))
-
-(define (bind-variable senv identifier)
-  (cond ((raw-identifier? identifier)
-	 (syntactic-environment/bind-variable senv identifier))
-	((closed-identifier? identifier)
-	 (syntactic-environment/bind-variable
-	  (syntactic-closure-senv identifier)
-	  (syntactic-closure-form identifier)))
-	(else
-	 (error:not-a identifier? identifier 'bind-variable))))
 
 ;;;; Utilities
 
diff --git a/src/sf/toplev.scm b/src/sf/toplev.scm
index e22fd41e7..889eb8c43 100644
--- a/src/sf/toplev.scm
+++ b/src/sf/toplev.scm
@@ -285,7 +285,7 @@ USA.
       (syntax* (if (null? declarations)
 		   s-expressions
 		   (cons (cons (close-syntax 'declare
-					     (->syntactic-environment
+					     (runtime-environment->syntactic
 					      system-global-environment))
 			       declarations)
 			 s-expressions))