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.

Manual cherry-pick of 8ab22a695b3801e59c5067fb065e7dfad4e59c96.

diff --git a/src/runtime/mit-syntax.scm b/src/runtime/mit-syntax.scm
index 2a2dfb028cd1a3e7431d777ea72c82d776e343a4..bd0f469bc6f5d8843e22eed444f08b128d8247e3 100644 (file)
--- a/src/runtime/mit-syntax.scm
+++ b/src/runtime/mit-syntax.scm
@@ -211,7 +211,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
@@ -225,15 +225,15 @@ 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 (spar-push-body)
+(define (spar-push-body make-senv)
   (spar-and
     (spar-push spar-arg:ctx)
     (spar-encapsulate-values
        (lambda (elts)
          (lambda (frame-senv)
-           (let ((body-senv (make-internal-senv frame-senv)))
+           (let ((body-senv (make-senv frame-senv)))
              (map-in-order (lambda (elt) (elt body-senv))
                            elts))))
       (spar+ (spar-subform spar-push-open-classified))
@@ -255,7 +255,8 @@ USA.
   (delay
     (spar-call-with-values
        (lambda (ctx bindings body-ctx 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)
@@ -270,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))
@@ -283,10 +284,11 @@ USA.
    (delay
      (spar-call-with-values
         (lambda (ctx bindings body-ctx 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))
@@ -305,7 +307,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 1189792ef434871834af0ec5ec8720328c6efb32..ba63300ae47db011771820bf6ca28864ec529d1b 100644 (file)
--- a/src/runtime/runtime.pkg
+++ b/src/runtime/runtime.pkg
@@ -4637,10 +4637,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 4f539445907be253510a8fceb069aa11b605cad2..72f85ba7e3f1ef1f742c2c2f06b81e78ec011e3f 100644 (file)
--- a/src/runtime/syntax-environment.scm
+++ b/src/runtime/syntax-environment.scm
@@ -54,15 +54,15 @@ USA.
                       (var-item identifier)))
                 'lookup-identifier))
 
-(define reserve-identifier
+(define reserve-keyword
   (id-dispatcher (lambda (identifier senv)
-                  ((senv-store senv) identifier (reserved-name-item)))
-                'reserve-identifier))
+                  ((senv-store senv) identifier #t (reserved-name-item)))
+                'reserve-keyword))
 
 (define (bind-keyword identifier senv item)
   (guarantee keyword-item? item 'bind-keyword)
   ((id-dispatcher (lambda (identifier senv)
-                   ((senv-store senv) identifier item))
+                   ((senv-store senv) identifier #t item))
                  'bind-keyword)
    identifier
    senv))
@@ -70,7 +70,7 @@ USA.
 (define bind-variable
   (id-dispatcher (lambda (identifier senv)
                   (let ((rename ((senv-rename senv) identifier)))
-                    ((senv-store senv) identifier (var-item rename))
+                    ((senv-store senv) identifier #f (var-item rename))
                     rename))
                 'bind-variable))
 
@@ -111,7 +111,8 @@ USA.
            (cdr binding)
            (environment-lookup-macro env identifier))))
 
-    (define (store identifier item)
+    (define (store identifier keyword? item)
+      (declare (ignore keyword?))
       (let ((binding (assq identifier bound)))
        (if binding
            (set-cdr! binding item)
@@ -140,7 +141,8 @@ USA.
   (define (lookup identifier)
     (environment-lookup-macro env identifier))
 
-  (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)
@@ -165,7 +167,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)
@@ -202,7 +205,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)))
@@ -219,6 +223,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.
 
@@ -242,7 +288,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:"
@@ -290,7 +337,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 f6da9dfb830ab2dba9285c2e3203b1e36054e4d1..2fe783a9bedf334f4bffb45eb3eb1d1a8df61ad0 100644 (file)
--- a/tests/runtime/test-syntax-rename.scm
+++ b/tests/runtime/test-syntax-rename.scm
@@ -59,4 +59,22 @@ USA.
       (assert-equal (unsyntax (syntax expr test-environment))
                    '(let ((.car.1 13))
                       (let ((.car.2 15))
-                        (.car.2 (car car .car.1 car))))))))
\ No newline at end of file
+                        (.car.2 (car car .car.1 car))))))))
+
+(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