From bf0ae5058e9d2d5268a654b94848ebade28f3546 Mon Sep 17 00:00:00 2001 From: Chris Hanson Date: Wed, 17 Jul 2019 19:46:54 -0400 Subject: [PATCH] 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. --- src/runtime/mit-syntax.scm | 20 ++++---- src/runtime/runtime.pkg | 3 +- src/runtime/syntax-environment.scm | 70 +++++++++++++++++++++++----- tests/runtime/test-syntax-rename.scm | 20 +++++++- 4 files changed, 91 insertions(+), 22 deletions(-) diff --git a/src/runtime/mit-syntax.scm b/src/runtime/mit-syntax.scm index 2a2dfb028..bd0f469bc 100644 --- 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))))) ;;;; Pseudo keywords diff --git a/src/runtime/runtime.pkg b/src/runtime/runtime.pkg index 1189792ef..ba63300ae 100644 --- 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 4f5394459..72f85ba7e 100644 --- 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))) +;;; 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))) + ;;; 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 f6da9dfb8..2fe783a9b 100644 --- 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 -- 2.25.1