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 dfeb23de73701cf4576001b558b7847b1e559a5c..8104ecf26acf2422ffed60aae34fecf995106ee7 100644 (file)
--- 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 cb60369fe70b0cdeee44365fd1dd018cba42c340..0dc8a1a775e2154d6b7b122d237511b1e293adf7 100644 (file)
--- 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 c8c246cde815f4c6ade96e49b27d6c9aa49acacb..35bbe9adb87967fbf53dff00ff940103231e396f 100644 (file)
--- 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 cad2339cd4bb0e2d8f2a24e0e2e258920cad8caa..11749b824d7b7a76836b08851240cb6a3ce474a6 100644 (file)
--- 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 985a304ad24ae834730cf045eae1221f5dbdfcf3..5b3666e08d349e5afed79c68124a7e982d459270 100644 (file)
--- 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 cac5e142b7b8d18fd075b4432dd32e0e6109eaf4..cac848ecb0b1c186b318461f1e55cb30b98a4688 100644 (file)
--- 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))
 \f
 ;;;; 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 2948ab32a4de50eaa7cf4ec7a44a2ea9c25f13d5..39fddddd0f29c1aff9ace9476e832225dbe5d05e 100644 (file)
--- 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 0b5834ffdd29ea49388b44efa0eaa5e71a916ea8..84763ead75dcdd4db9d89b8365c90c2b0530660a 100644 (file)
--- a/src/runtime/syntax-environment.scm
+++ b/src/runtime/syntax-environment.scm
@@ -28,6 +28,56 @@ USA.
 
 (declare (usual-integrations))
 \f
+(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))))
 \f
-(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 e384dc2a6ef4a33404f14bbc6ecce9d4a43acfd5..34caa6ba0fe5423af2e4be3680c0b168cb1d7780 100644 (file)
--- a/src/runtime/syntax-output.scm
+++ b/src/runtime/syntax-output.scm
@@ -30,7 +30,7 @@ USA.
 (declare (usual-integrations))
 \f
 (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 94571e593eee167d359a4e3c421fc73b1e37669c..7f6e778191352d75392bca8a0af926b7dd40f583 100644 (file)
--- a/src/runtime/syntax-transforms.scm
+++ b/src/runtime/syntax-transforms.scm
@@ -31,45 +31,41 @@ USA.
 
 (declare (usual-integrations))
 \f
-(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 5ca951cb19627b63f91fbf8992020354c6ff7c70..b393ddd66cbb8c2cd3855258233b647574095a5f 100644 (file)
--- 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))))
 \f
 ;;;; Utilities
 

diff --git a/src/sf/toplev.scm b/src/sf/toplev.scm
index e22fd41e78597a42d884f18f8ce14bfd41b33d7c..889eb8c4327a3c5984acebdf653ce50d6529abb4 100644 (file)
--- 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))