Treat keyword-only syntax environments differently from runtime environments.

The former are those created by let-syntax and the like; the latter are models
of runtime environments as created by lambda.

This fixes a bug when let-syntax contains a bunch of definitions, which should
be defined in the parent environment of the let-syntax, because it's meaningless
to define them in the let-syntax environment itself.  This was previously worked
around by heuristic means, but this change makes the definitions appear in the
correct syntactic environment corresponding to the runtime environment.

diff --git a/src/runtime/mit-syntax.scm b/src/runtime/mit-syntax.scm
index 21acb6ab27a0e56c9e2407b97a606d97aaaa0f8a..36b9e8c2856d605db2198c4843db445b49771b48 100644 (file)
--- a/src/runtime/mit-syntax.scm
+++ b/src/runtime/mit-syntax.scm
@@ -189,7 +189,7 @@ USA.
        (spar-push spar-arg:ctx)
        (spar-subform
         (spar-match identifier? spar-arg:form)
-        (spar-funcall reserve-identifier spar-arg:form spar-arg:senv)
+        (spar-funcall reserve-keyword spar-arg:form spar-arg:senv)
         (spar-push spar-arg:form))
        (spar-subform
         spar-push-classified
@@ -209,7 +209,7 @@ USA.
        (spar-subform)
        (spar-push spar-arg:ctx)
        (spar-push-subform-if mit-lambda-list? spar-arg:form)
-       (spar-push-body)))))
+       (spar-push-body make-internal-senv)))))
 
 (define $named-lambda
   (spar-classifier->runtime
@@ -222,7 +222,7 @@ USA.
        (spar-subform
         (spar-push-subform-if identifier? spar-arg:form)
         (spar-push-form-if mit-lambda-list? spar-arg:form))
-       (spar-push-body)))))
+       (spar-push-body make-internal-senv)))))
 
 (define (assemble-lambda-item ctx name bvl body)
   (let ((frame-senv (make-internal-senv (serror-ctx-senv ctx))))
@@ -235,11 +235,11 @@ USA.
                   (receive (body-ctx body-items) (body frame-senv)
                     (body-item body-ctx body-items))))))
 
-(define (spar-push-body)
+(define (spar-push-body make-senv)
   (spar-call-with-values
       (lambda (ctx . elts)
        (lambda (frame-senv)
-         (let ((body-senv (make-internal-senv frame-senv)))
+         (let ((body-senv (make-senv frame-senv)))
            (values (serror-ctx (serror-ctx-form ctx)
                                body-senv
                                (serror-ctx-hist ctx))
@@ -255,7 +255,7 @@ USA.
   (delay
     (spar-call-with-values
        (lambda (ctx bindings body)
-         (let ((frame-senv (make-internal-senv (serror-ctx-senv ctx))))
+         (let ((frame-senv (make-keyword-internal-senv (serror-ctx-senv ctx))))
            (for-each (lambda (binding)
                        (bind-keyword (car binding) frame-senv (cdr binding)))
                      bindings)
@@ -271,7 +271,7 @@ USA.
                           (spar-subform spar-push-classified)
                           (spar-match-null)))))
        (spar-match-null))
-       (spar-push-body))))
+       (spar-push-body make-keyword-internal-senv))))
 
 (define $let-syntax
   (spar-classifier->runtime spar-promise:let-syntax))
@@ -284,10 +284,11 @@ USA.
    (delay
      (spar-call-with-values
         (lambda (ctx bindings body)
-          (let ((frame-senv (make-internal-senv (serror-ctx-senv ctx)))
+          (let ((frame-senv
+                 (make-keyword-internal-senv (serror-ctx-senv ctx)))
                 (ids (map car bindings)))
             (for-each (lambda (id)
-                        (reserve-identifier id frame-senv))
+                        (reserve-keyword id frame-senv))
                       ids)
             (for-each (lambda (id item)
                         (bind-keyword id frame-senv item))
@@ -307,7 +308,7 @@ USA.
                             (spar-subform spar-push-open-classified)
                             (spar-match-null)))))
         (spar-match-null))
-       (spar-push-body)))))
+       (spar-push-body make-keyword-internal-senv)))))
 \f
 ;;;; Pseudo keywords
 

diff --git a/src/runtime/runtime.pkg b/src/runtime/runtime.pkg
index 0e8bb7665b7ff4f828ca21ad2929f9eb6ea814c2..e4915192dbb8897045aeaf00ae6128aeff1b75fb 100644 (file)
--- a/src/runtime/runtime.pkg
+++ b/src/runtime/runtime.pkg
@@ -4743,10 +4743,11 @@ USA.
          bind-variable
          lookup-identifier
          make-internal-senv
+         make-keyword-internal-senv
          make-keyword-senv
          make-partial-senv
          make-sealed-senv
-         reserve-identifier
+         reserve-keyword
          senv->runtime
          senv-top-level?))
 

diff --git a/src/runtime/syntax-environment.scm b/src/runtime/syntax-environment.scm
index 87393c3f64d0b1a78d6c8bdcf88c0b08b13a6dd9..0e10b617533a698f4b74093c056bf4c7d35fde05 100644 (file)
--- a/src/runtime/syntax-environment.scm
+++ b/src/runtime/syntax-environment.scm
@@ -82,20 +82,20 @@ USA.
                  (syntactic-closure-senv id))
            (var-item id)))))
 
-(define (reserve-identifier identifier senv)
-  (guarantee identifier? identifier 'reserve-identifier)
-                  ((senv-store senv) identifier (reserved-name-item)))
+(define (reserve-keyword identifier senv)
+  (guarantee identifier? identifier 'reserve-keyword)
+  ((senv-store senv) identifier #t (reserved-name-item)))
 
 (define (bind-keyword identifier senv item)
   (guarantee identifier? identifier 'bind-keyword)
   (guarantee keyword-item? item 'bind-keyword)
-                   ((senv-store senv) identifier item))
+  ((senv-store senv) identifier #t item))
 
 (define (bind-variable identifier senv)
   (guarantee identifier? identifier 'bind-variable)
-                  (let ((rename ((senv-rename senv) identifier)))
-                    ((senv-store senv) identifier (var-item rename))
-                    rename))
+  (let ((rename ((senv-rename senv) identifier)))
+    ((senv-store senv) identifier #f (var-item rename))
+    rename))
 
 (define-record-type <syntactic-environment>
     (make-senv get-type get-runtime lookup store rename describe)
@@ -134,7 +134,8 @@ USA.
            (cdr binding)
            (runtime-lookup identifier env))))
 
-    (define (store identifier item)
+    (define (store identifier keyword? item)
+      (declare (ignore keyword?))
       (let ((binding (assq identifier bound)))
        (if binding
            (set-cdr! binding item)
@@ -163,7 +164,8 @@ USA.
   (define (lookup identifier)
     (runtime-lookup identifier env))
 
-  (define (store identifier item)
+  (define (store identifier keyword? item)
+    (declare (ignore keyword?))
     (error "Can't bind in non-top-level runtime environment:" identifier item))
 
   (define (rename identifier)
@@ -188,7 +190,8 @@ USA.
     (and (eq? name identifier)
         item))
 
-  (define (store identifier item)
+  (define (store identifier keyword? item)
+    (declare (ignore keyword?))
     (error "Can't bind in keyword environment:" identifier item))
 
   (define (rename identifier)
@@ -225,7 +228,8 @@ USA.
              (set! free (cons (cons identifier item) free))
              item))))
 
-    (define (store identifier item)
+    (define (store identifier keyword? item)
+      (declare (ignore keyword?))
       (cond ((assq identifier bound)
             => (lambda (binding)
                  (set-cdr! binding item)))
@@ -242,6 +246,48 @@ USA.
 
     (make-senv get-type get-runtime lookup store rename describe)))
 \f
+;;; Internal keyword syntactic environments represent environments created by
+;;; syntactic scopes, such as let-syntax.
+
+(define (make-keyword-internal-senv parent)
+  (guarantee syntactic-environment? parent 'make-keyword-internal-senv)
+  (let ((bound '())
+       (free '())
+       (get-runtime (senv-get-runtime parent))
+       (rename (senv-rename parent)))
+
+    (define (get-type)
+      'keyword-internal)
+
+    (define (lookup identifier)
+      (let ((binding
+            (or (assq identifier bound)
+                (assq identifier free))))
+       (if binding
+           (cdr binding)
+           (let ((item ((senv-lookup parent) identifier)))
+             (set! free (cons (cons identifier item) free))
+             item))))
+
+    (define (store identifier keyword? item)
+      (if keyword?
+         (cond ((assq identifier bound)
+                => (lambda (binding)
+                     (set-cdr! binding item)))
+               ((assq identifier free)
+                (error "Can't define name; already free:" identifier))
+               (else
+                (set! bound (cons (cons identifier item) bound))
+                unspecific))
+         ((senv-store parent) identifier keyword? item)))
+
+    (define (describe)
+      `((bound ,bound)
+       (free ,free)
+       (parent ,parent)))
+
+    (make-senv get-type get-runtime lookup store rename describe)))
+\f
 ;;; Partial syntactic environments are used to implement syntactic
 ;;; closures that have free names.
 
@@ -265,7 +311,8 @@ USA.
        (define (lookup identifier)
          ((senv-lookup (select-env identifier)) identifier))
 
-       (define (store identifier item)
+       (define (store identifier keyword? item)
+         (declare (ignore keyword?))
          ;; **** Shouldn't this be a syntax error?  It can happen as the
          ;; result of a misplaced definition.  ****
          (error "Can't bind identifier in partial syntactic environment:"
@@ -314,7 +361,8 @@ USA.
               (set! free (cons (cons identifier item) free))
               item))))
 
-    (define (store identifier item)
+    (define (store identifier keyword? item)
+      (declare (ignore keyword?))
       (cond ((assq identifier bound)
             => (lambda (binding)
                  (set-cdr! binding item)))

diff --git a/tests/runtime/test-syntax-rename.scm b/tests/runtime/test-syntax-rename.scm
index 4fca357a6f19119e7e638e0ce8dcefcf27f4dfaf..cf4822d6eea1723122f429293cadb1e1370ef30e 100644 (file)
--- a/tests/runtime/test-syntax-rename.scm
+++ b/tests/runtime/test-syntax-rename.scm
@@ -65,4 +65,22 @@ USA.
       (assert-equal (unsyntax (syntax expr test-environment))
                    '(let ((.car.1 13))
                       (let ((.car.2 15))
-                        (cons .car.2 (list car .car.1))))))))
\ No newline at end of file
+                        (cons .car.2 (list car .car.1))))))))
+
+(define-test 'keyword-environments
+  (lambda ()
+    (assert-equal (unsyntax
+                  (syntax* '((let-syntax
+                                 ((foobar
+                                   (er-macro-transformer
+                                    (lambda (form rename compare)
+                                      `(,(rename 'define)
+                                        ,(cadr form)
+                                        ,(caddr form))))))
+                               (foobar a 3)
+                               (foobar b 4))
+
+                             (define (c x)
+                               (+ a x)))
+                           system-global-environment))
+                 '(begin (define a 3) (define b 4) (define (c x) (+ a x))))))
\ No newline at end of file