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

fix bug in expand when adjusting the lexical-context info of a locally bound identifer

Browse Source 
svn: r5056
This commit is contained in:
Matthew Flatt 2006-12-07 08:42:13 +00:00
parent 4f75452dbd
commit fdfdf1bc92
5 changed files with 607 additions and 673 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -1095,6 +1095,18 @@
(require @!$m)
(test '(10 20 #t) '@!$get @!$get)
(unless building-flat-tests?
(test '(12)
eval
(expand
#'(let ([b 12])
(let-syntax ([goo (lambda (stx)
#`(let ()
(define #,(syntax-local-introduce #'b) 1)
(define z (list b))
z))])
(goo))))))
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Test lazy unmarshaling of renamings and module-name resolution

1127
src/mzscheme/src/cstartup.inc
View File

File diff suppressed because it is too large Load Diff

8
src/mzscheme/src/env.c
View File

@ -2274,7 +2274,13 @@ scheme_lookup_binding(Scheme_Object *find_id, Scheme_Comp_Env *env, int flags,
}
/* Looks ok; return a lexical reference */
if (_lexical_binding_id) {
val = scheme_stx_remove_extra_marks(find_id, frame->values[i]);
if (!(frame->flags & SCHEME_CAPTURE_WITHOUT_RENAME))
val = scheme_stx_remove_extra_marks(find_id, frame->values[i],
((frame->flags & SCHEME_CAPTURE_LIFTED)
? NULL
: uid));
else
val = find_id;
*_lexical_binding_id = val;
}
if (flags & SCHEME_DONT_MARK_USE)

3
src/mzscheme/src/schpriv.h
View File

@ -596,7 +596,8 @@ void scheme_drop_first_rib_rename(Scheme_Object *ro);
Scheme_Object *scheme_add_rename(Scheme_Object *o, Scheme_Object *rename);
Scheme_Object *scheme_add_rename_rib(Scheme_Object *o, Scheme_Object *rib);
Scheme_Object *scheme_stx_remove_extra_marks(Scheme_Object *o, Scheme_Object *relative_to);
Scheme_Object *scheme_stx_remove_extra_marks(Scheme_Object *o, Scheme_Object *relative_to,
Scheme_Object *uid);
#define mzMOD_RENAME_TOPLEVEL 0
#define mzMOD_RENAME_NORMAL 1

130
src/mzscheme/src/stxobj.c
View File

@ -2636,111 +2636,6 @@ static void add_all_marks(Scheme_Object *wraps, Scheme_Hash_Table *marks)
}
}
static Scheme_Object *prune_marks(Scheme_Stx *stx, Scheme_Object *keep_list)
/* Returns a new wrap */
{
WRAP_POS awl, acur_mark_l, shared_tail_l;
Scheme_Object *acur_mark, *w, *save_wraps = scheme_null, *acur_save_wraps = NULL, *shared_tail_save_wraps = NULL;
int wrap_c = 0, shared_tail_wrap_c = 0, acur_wrap_c = 0;
WRAP_POS_INIT(awl, stx->wraps);
/* Just so they're initialized: */
WRAP_POS_COPY(acur_mark_l, awl);
WRAP_POS_COPY(shared_tail_l, awl);
while (1) {
/* Skip over renames and cancelled marks: */
acur_mark = NULL;
while (1) {
if (WRAP_POS_END_P(awl))
break;
w = WRAP_POS_FIRST(awl);
if (SCHEME_NUMBERP(w) && IS_POSMARK(WRAP_POS_FIRST(awl))) {
if (acur_mark) {
if (SAME_OBJ(acur_mark, w)) {
acur_mark = NULL;
WRAP_POS_INC(awl);
} else
break;
} else {
acur_mark = WRAP_POS_FIRST(awl);
WRAP_POS_INC(awl);
WRAP_POS_COPY(acur_mark_l, awl);
acur_wrap_c = wrap_c;
acur_save_wraps = save_wraps;
}
} else {
save_wraps = scheme_make_pair(w, save_wraps);
wrap_c++;
WRAP_POS_INC(awl);
}
}
if (!acur_mark)
break;
/* Same mark? */
if (SCHEME_PAIRP(keep_list) && SAME_OBJ(acur_mark, SCHEME_CAR(keep_list))) {
save_wraps = scheme_make_pair(acur_mark, save_wraps);
wrap_c++;
keep_list = SCHEME_CDR(keep_list);
} else {
/* We need to drop the mark, so shift the shared tail */
WRAP_POS_COPY(shared_tail_l, acur_mark_l);
shared_tail_save_wraps = acur_save_wraps;
shared_tail_wrap_c = acur_wrap_c;
}
}
if (!shared_tail_save_wraps) {
w = scheme_null;
shared_tail_save_wraps = save_wraps;
shared_tail_wrap_c = wrap_c;
} else {
/* save_wraps is the set of wraps (in reverse order) that we want to
keep, but there could be a shared tail; build on shared_tail_l
with shared_tail_save_wraps: */
while (1) {
w = WRAP_POS_PLAIN_TAIL(shared_tail_l);
if (w)
break;
shared_tail_save_wraps = scheme_make_pair(WRAP_POS_FIRST(shared_tail_l),
shared_tail_save_wraps);
shared_tail_wrap_c++;
WRAP_POS_INC(shared_tail_l);
}
}
if (shared_tail_wrap_c) {
Wrap_Chunk *wc;
int i;
wc = MALLOC_WRAP_CHUNK(shared_tail_wrap_c);
wc->type = scheme_wrap_chunk_type;
wc->len = shared_tail_wrap_c;
for (i = shared_tail_wrap_c - 1;
!SCHEME_NULLP(shared_tail_save_wraps);
shared_tail_save_wraps = SCHEME_CDR(shared_tail_save_wraps), --i) {
wc->a[i] = SCHEME_CAR(shared_tail_save_wraps);
}
w = scheme_make_pair((Scheme_Object *)wc, w);
}
/* Construct the new id: */
{
Scheme_Object *certs;
certs = stx->certs;
stx = (Scheme_Stx *)scheme_make_stx(stx->val, stx->srcloc, stx->props);
stx->wraps = w;
stx->certs = certs;
}
return (Scheme_Object *)stx;
}
#define QUICK_STACK_SIZE 10
/* Although resolve_env may call itself recursively, the recursion
@ -3466,7 +3361,8 @@ int scheme_stx_has_more_certs(Scheme_Object *id, Scheme_Object *id_certs,
return 0;
}
Scheme_Object *scheme_stx_remove_extra_marks(Scheme_Object *a, Scheme_Object *relative_to)
Scheme_Object *scheme_stx_remove_extra_marks(Scheme_Object *a, Scheme_Object *relative_to,
Scheme_Object *uid)
{
WRAP_POS aw;
WRAP_POS bw;
@ -3475,9 +3371,25 @@ Scheme_Object *scheme_stx_remove_extra_marks(Scheme_Object *a, Scheme_Object *re
WRAP_POS_INIT(bw, ((Scheme_Stx *)relative_to)->wraps);
if (!same_marks(&aw, &bw, NULL, NULL)) {
return prune_marks((Scheme_Stx *)a,
scheme_stx_extract_marks(relative_to));
}
Scheme_Object *wraps = ((Scheme_Stx *)relative_to)->wraps;
if (uid) {
/* Add a rename record: */
Scheme_Object *rn;
rn = scheme_make_rename(uid, 1);
scheme_set_rename(rn, 0, relative_to);
wraps = scheme_make_pair(rn, wraps);
}
{
Scheme_Stx *stx = (Scheme_Stx *)a;
Scheme_Object *certs;
certs = stx->certs;
stx = (Scheme_Stx *)scheme_make_stx(stx->val, stx->srcloc, stx->props);
stx->wraps = wraps;
stx->certs = certs;
a = (Scheme_Object *)stx;
}
}
return a;
}