suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

fix context of 'disappeared-binding wher ebinding originates as an internal syntax definition

Browse Source 
svn: r3353
This commit is contained in:
Matthew Flatt 2006-06-14 01:37:23 +00:00
parent a1fe245467
commit 6736c01c8c
2 changed files with 35 additions and 5 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

23
collects/tests/mzscheme/stx.ss
View File

@ -631,6 +631,29 @@
(test #t has-stx-property? (expand #'(let () (define-struct a (x)) (define-struct (b a) (z)) 10))
#f 'a 'disappeared-use)
;; Check that origin is bound by disappeared binding:
(test #t has-stx-property? (expand #'(let () (define-syntax (x stx) #'(quote y)) x)) 'quote 'x 'origin)
(let ([check-expr
(lambda (expr)
(let ([e (expand expr)])
(syntax-case e ()
[(lv () beg)
(let ([db (syntax-property #'beg 'disappeared-binding)])
(syntax-case #'beg ()
[(bg e)
(let ([o (syntax-property #'e 'origin)])
(test #t (lambda (db o)
(and (list? db)
(list? o)
(= 1 (length db))
(= 1 (length o))
(identifier? (car db))
(identifier? (car o))
(bound-identifier=? (car db) (car o))))
db o))]))])))])
(check-expr #'(let () (letrec-syntaxes+values ([(x) (lambda (stx) #'(quote y))]) () x)))
(check-expr #'(let () (define-syntax (x stx) #'(quote y)) x)))
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; protected identifiers
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

17
src/mzscheme/src/syntax.c
View File

@ -4499,11 +4499,18 @@ do_letrec_syntaxes(const char *where,
body = scheme_add_env_renames(body, stx_env, origenv);
if (names_to_disappear) {
Scheme_Object *l, *a;
for (l = names_to_disappear; !SCHEME_NULLP(l); l = SCHEME_CDR(l)) {
a = SCHEME_CAR(l);
a = scheme_add_env_renames(a, stx_env, origenv);
SCHEME_CAR(l) = a;
/* Need to add renaming for disappeared bindings --- unless
they originated for internal definitions, in which case
adding the renaming is unnecessary and intereferes with the
comparsion (due to limitations of the syntax-object
representation for internal definitions). */
if (!(origenv->flags & SCHEME_FOR_INTDEF)) {
Scheme_Object *l, *a;
for (l = names_to_disappear; !SCHEME_NULLP(l); l = SCHEME_CDR(l)) {
a = SCHEME_CAR(l);
a = scheme_add_env_renames(a, stx_env, origenv);
SCHEME_CAR(l) = a;
}
}
}
if (var_env)