From 8ab22a695b3801e59c5067fb065e7dfad4e59c96 Mon Sep 17 00:00:00 2001 From: Chris Hanson Date: Wed, 17 Jul 2019 18:54:49 -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. --- src/runtime/mit-syntax.scm | 21 ++++---- src/runtime/runtime.pkg | 3 +- src/runtime/syntax-environment.scm | 74 +++++++++++++++++++++++----- tests/runtime/test-syntax-rename.scm | 20 +++++++- 4 files changed, 93 insertions(+), 25 deletions(-) diff --git a/src/runtime/mit-syntax.scm b/src/runtime/mit-syntax.scm index 21acb6ab2..36b9e8c28 100644 --- 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))))) ;;;; Pseudo keywords diff --git a/src/runtime/runtime.pkg b/src/runtime/runtime.pkg index 0e8bb7665..e4915192d 100644 --- 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 87393c3f6..0e10b6175 100644 --- 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 (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))) +;;; 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. @@ -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 4fca357a6..cf4822d6e 100644 --- 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 -- 2.25.1