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

allow different phases for `free-identifier=?' arguments

Browse Source
This commit is contained in:
Matthew Flatt 2011-09-12 14:57:54 -06:00
parent 481a92f272
commit c352ef8fce
5 changed files with 53 additions and 30 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

12
collects/scribblings/reference/stx-comp.scrbl
View File

@ -33,15 +33,19 @@ suitable expression context at the @tech{phase level} indicated by
@defproc[(free-identifier=? [a-id syntax?] [b-id syntax?]
[phase-level (or/c exact-integer? #f)
(syntax-local-phase-level)])
[a-phase-level (or/c exact-integer? #f)
(syntax-local-phase-level)]
[b-phase-level (or/c exact-integer? #f)
a-phase-level])
boolean?]{
Returns @racket[#t] if @racket[a-id] and @racket[b-id] access the same
@tech{local binding}, @tech{module binding}, or @tech{top-level
binding}---perhaps via @tech{rename transformers}---at the @tech{phase
level} indicated by @racket[phase-level]. A @racket[#f] value for
@racket[phase-level] corresponds to the @tech{label phase level}.
levels} indicated by @racket[a-phase-level] and
@racket[b-phase-level], respectively. A @racket[#f] value for
@racket[a-phase-level] or @racket[b-phase-level] corresponds to the
@tech{label phase level}.
``Same module binding'' means that the identifiers refer to the same
original definition site, and not necessarily to the same

14
collects/syntax/kerncase.rkt
View File

@ -32,17 +32,9 @@
free-identifier=?]
[(and #,(syntax-e #'rel?) (= p 1))
free-transformer-identifier=?]
[else (let ([id (namespace-module-identifier p)])
(lambda (a b)
(free-identifier=? (datum->syntax id
(let ([s (syntax-e b)])
(case s
[(#%plain-app) '#%app]
[(#%plain-lambda) 'lambda]
[else s])))
a
p)))]))
clause ...))])))
[else (lambda (a b)
(free-identifier=? a b p '#,(syntax-local-phase-level)))]))
clause ...))])))
(define-syntax kernel-syntax-case
(lambda (stx)

5
collects/tests/racket/stx.rktl
View File

@ -1269,6 +1269,11 @@
(test #t eval '(free-identifier=? (f) #'x))
(test #f eval `(free-identifier=? (f) (quote-syntax ,x-id))))))))
(test #t free-identifier=? #'lambda #'lambda 0 1)
(test #f free-identifier=? #'lambda #'lambda 0 4)
(require (for-meta 4 racket/base))
(test #t free-identifier=? #'lambda #'lambda 0 4)
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; certification example from the manual

5
src/racket/src/schpriv.h
View File

@ -1008,6 +1008,9 @@ Scheme_Object *scheme_flatten_syntax_list(Scheme_Object *lst, int *islist);
int scheme_stx_module_eq(Scheme_Object *a, Scheme_Object *b, intptr_t phase);
int scheme_stx_module_eq2(Scheme_Object *a, Scheme_Object *b, Scheme_Object *phase, Scheme_Object *asym);
int scheme_stx_module_eq3(Scheme_Object *a, Scheme_Object *b,
Scheme_Object *a_phase, Scheme_Object *b_phase,
Scheme_Object *asym);
Scheme_Object *scheme_stx_get_module_eq_sym(Scheme_Object *a, Scheme_Object *phase);
Scheme_Object *scheme_stx_module_name(Scheme_Hash_Table *recur,
Scheme_Object **name, Scheme_Object *phase,
@ -1026,6 +1029,8 @@ int scheme_stx_ribs_matter(Scheme_Object *a, Scheme_Object *skip_ribs);
int scheme_stx_bound_eq(Scheme_Object *a, Scheme_Object *b, Scheme_Object *phase);
int scheme_stx_env_bound_eq(Scheme_Object *a, Scheme_Object *b, Scheme_Object *uid, Scheme_Object *phase);
int scheme_stx_env_bound_eq2(Scheme_Object *a, Scheme_Object *b, Scheme_Object *uid,
Scheme_Object *a_phase, Scheme_Object *b_phase);
Scheme_Object *scheme_stx_source_module(Scheme_Object *stx, int resolve, int source);

47
src/racket/src/syntax.c
View File

@ -425,8 +425,8 @@ void scheme_init_stx(Scheme_Env *env)
GLOBAL_IMMED_PRIM("make-syntax-delta-introducer" , scheme_syntax_make_transfer_intro, 2, 3, env);
GLOBAL_IMMED_PRIM("bound-identifier=?" , bound_eq , 2, 3, env);
GLOBAL_IMMED_PRIM("free-identifier=?" , module_eq , 2, 3, env);
GLOBAL_IMMED_PRIM("bound-identifier=?" , bound_eq , 2, 4, env);
GLOBAL_IMMED_PRIM("free-identifier=?" , module_eq , 2, 4, env);
GLOBAL_IMMED_PRIM("free-transformer-identifier=?" , module_trans_eq , 2, 2, env);
GLOBAL_IMMED_PRIM("free-template-identifier=?" , module_templ_eq , 2, 2, env);
GLOBAL_IMMED_PRIM("free-label-identifier=?" , module_label_eq , 2, 2, env);
@ -4485,7 +4485,9 @@ static Scheme_Object *get_module_src_name(Scheme_Object *a, Scheme_Object *orig_
}
}
int scheme_stx_module_eq2(Scheme_Object *a, Scheme_Object *b, Scheme_Object *phase, Scheme_Object *asym)
int scheme_stx_module_eq3(Scheme_Object *a, Scheme_Object *b,
Scheme_Object *a_phase, Scheme_Object *b_phase,
Scheme_Object *asym)
{
Scheme_Object *bsym;
Scheme_Hash_Table *free_id_recur;
@ -4498,7 +4500,7 @@ int scheme_stx_module_eq2(Scheme_Object *a, Scheme_Object *b, Scheme_Object *pha
free_id_recur = make_recur_table();
else
free_id_recur = NULL;
bsym = get_module_src_name(b, phase, free_id_recur);
bsym = get_module_src_name(b, b_phase, free_id_recur);
if (!asym)
release_recur_table(free_id_recur);
} else
@ -4506,7 +4508,7 @@ int scheme_stx_module_eq2(Scheme_Object *a, Scheme_Object *b, Scheme_Object *pha
if (!asym) {
if (SCHEME_STXP(a)) {
free_id_recur = make_recur_table();
asym = get_module_src_name(a, phase, free_id_recur);
asym = get_module_src_name(a, a_phase, free_id_recur);
release_recur_table(free_id_recur);
} else
asym = a;
@ -4520,11 +4522,11 @@ int scheme_stx_module_eq2(Scheme_Object *a, Scheme_Object *b, Scheme_Object *pha
return 1;
free_id_recur = make_recur_table();
a = resolve_env(a, phase, 1, NULL, NULL, NULL, NULL, 0, free_id_recur);
a = resolve_env(a, a_phase, 1, NULL, NULL, NULL, NULL, 0, free_id_recur);
release_recur_table(free_id_recur);
free_id_recur = make_recur_table();
b = resolve_env(b, phase, 1, NULL, NULL, NULL, NULL, 0, free_id_recur);
b = resolve_env(b, b_phase, 1, NULL, NULL, NULL, NULL, 0, free_id_recur);
release_recur_table(free_id_recur);
if (SAME_TYPE(SCHEME_TYPE(a), scheme_module_index_type))
@ -4536,9 +4538,14 @@ int scheme_stx_module_eq2(Scheme_Object *a, Scheme_Object *b, Scheme_Object *pha
return SAME_OBJ(a, b);
}
int scheme_stx_module_eq2(Scheme_Object *a, Scheme_Object *b, Scheme_Object *phase, Scheme_Object *asym)
{
return scheme_stx_module_eq3(a, b, phase, phase, NULL);
}
int scheme_stx_module_eq(Scheme_Object *a, Scheme_Object *b, intptr_t phase)
{
return scheme_stx_module_eq2(a, b, scheme_make_integer(phase), NULL);
return scheme_stx_module_eq3(a, b, scheme_make_integer(phase), scheme_make_integer(phase), NULL);
}
Scheme_Object *scheme_stx_get_module_eq_sym(Scheme_Object *a, Scheme_Object *phase)
@ -4647,7 +4654,8 @@ Scheme_Object *scheme_stx_moduleless_env(Scheme_Object *a)
return scheme_false;
}
int scheme_stx_env_bound_eq(Scheme_Object *a, Scheme_Object *b, Scheme_Object *uid, Scheme_Object *phase)
int scheme_stx_env_bound_eq2(Scheme_Object *a, Scheme_Object *b, Scheme_Object *uid,
Scheme_Object *a_phase, Scheme_Object *b_phase)
/* If uid is given, it's the environment for b. */
{
Scheme_Object *asym, *bsym, *ae, *be;
@ -4668,13 +4676,13 @@ int scheme_stx_env_bound_eq(Scheme_Object *a, Scheme_Object *b, Scheme_Object *u
if (!SAME_OBJ(asym, bsym))
return 0;
ae = resolve_env(a, phase, 0, NULL, NULL, NULL, NULL, 0, NULL);
ae = resolve_env(a, a_phase, 0, NULL, NULL, NULL, NULL, 0, NULL);
/* No need to module_resolve ae, because we ignored module renamings. */
if (uid)
be = uid;
else {
be = resolve_env(b, phase, 0, NULL, NULL, NULL, NULL, 0, NULL);
be = resolve_env(b, b_phase, 0, NULL, NULL, NULL, NULL, 0, NULL);
/* No need to module_resolve be, because we ignored module renamings. */
}
@ -4695,9 +4703,14 @@ int scheme_stx_env_bound_eq(Scheme_Object *a, Scheme_Object *b, Scheme_Object *u
return 1;
}
int scheme_stx_env_bound_eq(Scheme_Object *a, Scheme_Object *b, Scheme_Object *uid, Scheme_Object *phase)
{
return scheme_stx_env_bound_eq2(a, b, uid, phase, phase);
}
int scheme_stx_bound_eq(Scheme_Object *a, Scheme_Object *b, Scheme_Object *phase)
{
return scheme_stx_env_bound_eq(a, b, NULL, phase);
return scheme_stx_env_bound_eq2(a, b, NULL, phase, phase);
}
#if EXPLAIN_RESOLVE
@ -8116,14 +8129,14 @@ static Scheme_Object *bound_eq(int argc, Scheme_Object **argv)
phase = extract_phase("bound-identifier=?", 2, argc, argv, scheme_make_integer(0), 0);
return (scheme_stx_bound_eq(argv[0], argv[1], phase)
return (scheme_stx_env_bound_eq2(argv[0], argv[1], NULL, phase, phase)
? scheme_true
: scheme_false);
}
static Scheme_Object *do_module_eq(const char *who, int delta, int argc, Scheme_Object **argv)
{
Scheme_Object *phase;
Scheme_Object *phase, *phase2;
if (!SCHEME_STX_IDP(argv[0]))
scheme_wrong_type(who, "identifier syntax", 0, argc, argv);
@ -8135,8 +8148,12 @@ static Scheme_Object *do_module_eq(const char *who, int delta, int argc, Scheme_
? scheme_false
: scheme_make_integer(delta)),
0);
if (argc > 3)
phase2 = extract_phase(who, 3, argc, argv, phase, 0);
else
phase2 = phase;
return (scheme_stx_module_eq2(argv[0], argv[1], phase, NULL)
return (scheme_stx_module_eq3(argv[0], argv[1], phase, phase2, NULL)
? scheme_true
: scheme_false);
}