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

more module source versus module path adjustments, especially for contracts

Browse Source 
svn: r18809
This commit is contained in:
Matthew Flatt 2010-04-13 17:12:51 +00:00
parent 11f6859cb2
commit 536fcacc42
11 changed files with 96 additions and 64 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

5
collects/scheme/contract/private/provide.ss
View File

@ -48,7 +48,7 @@
pos-module-source
(quote-module-source)
'external-id
(quote-srcloc id))))))])
(quote-srcloc id #:module-source pos-module-source))))))])
(when key
(hash-set! saved-id-table key lifted-id))
;; Expand to a use of the lifted expression:
@ -664,7 +664,8 @@
(syntax-local-lift-module-end-declaration
#`(begin
(unless extra-test
(contract contract-id id pos-module-source 'ignored 'id (quote-srcloc id)))
(contract contract-id id pos-module-source 'ignored 'id
(quote-srcloc id #:module-source pos-module-source)))
(void)))
(syntax (code id-rename))))))]))

13
collects/scribblings/reference/stx-ops.scrbl
View File

@ -72,12 +72,15 @@ expression that were directly present in the original expression, as
opposed to @tech{syntax object}s inserted by macros.}
@defproc[(syntax-source-module [stx syntax?])
(or/c module-path-index? symbol? #f)]{
@defproc[(syntax-source-module [stx syntax?] [source? any/c #f])
(or/c module-path-index? symbol? path? #f)]{
Returns a module path index or symbol (see @secref["modpathidx"])
for the module whose source contains @scheme[stx], or @scheme[#f] if
@scheme[stx] has no source module.}
Returns an indication of the module whose source contains
@scheme[stx], or @scheme[#f] if @scheme[stx] has no source module. If
@scheme[source?] is @scheme[#f], then result is a module path index or
symbol (see @secref["modpathidx"]); if @scheme[source?] is true, the
result is a path or symbol corresponding to the loaded module's
source in the sense of @scheme[current-module-declare-source].}
@defproc[(syntax-e [stx syntax?]) any]{

14
collects/unstable/location.ss
View File

@ -17,7 +17,13 @@
[(_) #`(quote-srcloc #,stx)]
[(_ loc)
(with-syntax ([(arg ...) (build-source-location-list #'loc)])
#'(make-srcloc (quote arg) ...))]))
#'(make-srcloc (quote arg) ...))]
[(_ loc #:module-source alt-src)
(with-syntax ([(src arg ...) (build-source-location-list #'loc)])
(with-syntax ([alt-src (if (syntax-source-module #'loc)
#'alt-src
#'(quote src))])
#'(make-srcloc alt-src (quote arg) ...)))]))
(define-syntax (quote-source-file stx)
(syntax-case stx ()
@ -70,5 +76,7 @@
[else 'top-level]))
(define (variable-reference->module-src var)
(or (variable-reference->module-source var)
'top-level))
(let ([v (variable-reference->module-source var)])
(if v
(make-resolved-module-path v)
'top-level)))

39
collects/unstable/scribblings/srcloc.scrbl
View File

@ -213,11 +213,15 @@ Furthermore, the examples illustrate the use of source location quoting inside
macros, and the difference between quoting the source location of the macro
definition itself and quoting the source location of the macro's arguments.
@defform*[[(quote-srcloc) (quote-srcloc expr)]]{
@defform*[[(quote-srcloc) (quote-srcloc form) (quote-srcloc form #:module-source expr)]]{
This form quotes the source location of @scheme[expr] as a @scheme[srcloc]
structure, using the location of the whole @scheme[(quote-srcloc)] expression if
no @scheme[expr] is given.
Quotes the source location of @scheme[form] as a @scheme[srcloc]
structure, using the location of the whole @scheme[(quote-srcloc)]
expression if no @scheme[expr] is given. When @scheme[expr] has a
source module (in the sense of @scheme[syntax-source-module]), the
module's source path is used form source location, unless a
@scheme[#:module-source expr] is specified, in which case
@scheme[expr] provides the source.
@defexamples[#:eval (new-evaluator)
(quote-srcloc)
@ -232,15 +236,15 @@ no @scheme[expr] is given.
}
@deftogether[(
@defform*[[(quote-source-file) (quote-source-file expr)]]
@defform*[[(quote-line-number) (quote-line-number expr)]]
@defform*[[(quote-column-number) (quote-column-number expr)]]
@defform*[[(quote-character-position) (quote-character-position expr)]]
@defform*[[(quote-character-span) (quote-character-span expr)]]
@defform*[[(quote-source-file) (quote-source-file form)]]
@defform*[[(quote-line-number) (quote-line-number form)]]
@defform*[[(quote-column-number) (quote-column-number form)]]
@defform*[[(quote-character-position) (quote-character-position form)]]
@defform*[[(quote-character-span) (quote-character-span form)]]
)]{
These forms quote various fields of the source location of @scheme[expr], or of
the whole macro application if no @scheme[expr] is given.
Quote various fields of the source location of @scheme[form], or of
the whole macro application if no @scheme[form] is given.
@examples[#:eval (new-evaluator)
(list (quote-source-file)
@ -270,13 +274,13 @@ the whole macro application if no @scheme[expr] is given.
@defform[(quote-module-path)]{
This form quotes a module path suitable for use with @scheme[require] which
Quotes a module path suitable for use with @scheme[require] which
refers to the module in which the macro application occurs. If executed at the
top level, it may return @scheme['top-level], or it may return a valid module
path if the current namespace was constructed by @scheme[module->namespace]
(such as at the DrScheme interactions window).
This macro operates by creating a @tech[#:doc reference-path]{variable
The @scheme[quote-module-path] form operates by creating a @tech[#:doc reference-path]{variable
reference} (see @scheme[#%variable-reference]) at the point of its application.
It thus automatically describes its final expanded position, rather than the
module of any macro definition that happens to use it.
@ -308,12 +312,15 @@ b
Like @scheme[quote-module-path], but for the enclosing module's source
name, rather than its module path. The module path and source name are
typically the same, but they can be different. For example, a source
file whose name ends with @filepath{.ss} corersponds to a resolved
module path ending with @filepath{.rkt}.}
file whose name ends with @filepath{.ss} corresponds to a resolved
module path ending with @filepath{.rkt}. The value produced by
@scheme[(quote-module-source)] is either @scheme['top-level] or a
resolved module path, even though the latter may correspond to a
source file rather than a module path.}
@defform[(quote-module-name)]{
This form quotes the name (@tech[#:doc reference-path]{path} or @tech[#:doc
Quotes the name (@tech[#:doc reference-path]{path} or @tech[#:doc
reference-path]{symbol}) of the module in which the macro application occurs, or
@scheme[#f] if it occurs at the top level. As with @scheme[quote-module-path],
@scheme[quote-module-name] uses a @tech[#:doc reference-path]{variable

15
collects/unstable/srcloc.ss
View File

@ -128,7 +128,12 @@
(define ((good-string default) x src line col pos span)
(format "~a~a"
(cond [(path? src) (collects-path src)]
(cond [(resolved-module-path? src)
(let ([p (resolved-module-path-name src)])
(if (path? p)
(collects-path p)
p))]
[(path? src) (collects-path src)]
[(not src) default]
[else src])
(if line
@ -253,12 +258,8 @@
(define (syntax-get-source x)
(cond
[(syntax-source-module x) =>
(lambda (src)
(if (module-path-index? src)
(resolved-module-path-name
(module-path-index-resolve src))
src))]
[(syntax-source-module x #t) =>
(lambda (src) src)]
[else (syntax-source x)]))
(define (process-list x good bad name)

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

@ -3219,24 +3219,6 @@ void scheme_dup_symbol_check(DupCheckRecord *r, const char *where,
scheme_hash_set(r->ht, symbol, scheme_true);
}
int scheme_check_context(Scheme_Env *env, Scheme_Object *name, Scheme_Object *ok_modidx)
{
Scheme_Object *mod, *id = name;
mod = scheme_stx_source_module(id, 0);
if (mod && SCHEME_TRUEP(mod) && NOT_SAME_OBJ(ok_modidx, mod)) {
return 1;
} else {
mod = scheme_stx_module_name(NULL, &id, scheme_make_integer(env->phase), NULL, NULL, NULL,
NULL, NULL, NULL, NULL, NULL);
if (SAME_OBJ(mod, scheme_undefined))
return 1;
}
return 0;
}
/*========================================================================*/
/* compile-time env for optimization */
/*========================================================================*/
@ -4574,7 +4556,7 @@ static Scheme_Object *variable_module_source(int argc, Scheme_Object *argv[])
scheme_wrong_type("variable-reference->module-source", "variable-reference", 0, argc, argv);
if (env->module)
return env->module->modsrc;
return SCHEME_PTR_VAL(env->module->modsrc);
else
return scheme_false;
}
@ -4899,7 +4881,7 @@ local_module_introduce(int argc, Scheme_Object *argv[])
if (!SCHEME_STXP(s))
scheme_wrong_type("syntax-local-module-introduce", "syntax", 0, argc, argv);
v = scheme_stx_source_module(s, 0);
v = scheme_stx_source_module(s, 0, 0);
if (SCHEME_FALSEP(v)) {
if (env->genv->rename_set)
s = scheme_add_rename(s, env->genv->rename_set);

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

@ -505,6 +505,7 @@ void scheme_finish_kernel(Scheme_Env *env)
Scheme_Module_Exports *me;
me = make_module_exports();
kernel->me = me;
kernel->me->modsrc = kernel_modname;
}
kernel->me->rt->provides = exs;
@ -4712,6 +4713,7 @@ Scheme_Env *scheme_primitive_module(Scheme_Object *name, Scheme_Env *for_env)
Scheme_Module_Exports *me;
me = make_module_exports();
m->me = me;
me->modsrc = src;
}
scheme_hash_set(for_env->export_registry, m->modname, (Scheme_Object *)m->me);
@ -5173,7 +5175,8 @@ module_execute(Scheme_Object *data)
et_insps = NULL;
if (!SAME_OBJ(rt_insps, m->me->rt->provide_insps)
|| !SAME_OBJ(et_insps, m->me->et->provide_insps)) {
|| !SAME_OBJ(et_insps, m->me->et->provide_insps)
|| !SAME_OBJ(m->me->modsrc, m->modsrc)) {
/* have to clone m->me, etc. */
Scheme_Module_Exports *naya_me;
Scheme_Module_Phase_Exports *pt;
@ -5181,6 +5184,7 @@ module_execute(Scheme_Object *data)
naya_me = MALLOC_ONE_TAGGED(Scheme_Module_Exports);
memcpy(naya_me, m->me, sizeof(Scheme_Module_Exports));
m->me = naya_me;
m->me->modsrc = m->modsrc;
if (!SAME_OBJ(rt_insps, m->me->rt->provide_insps)) {
pt = MALLOC_ONE_TAGGED(Scheme_Module_Phase_Exports);
@ -5898,6 +5902,7 @@ static Scheme_Object *do_module(Scheme_Object *form, Scheme_Comp_Env *env,
Scheme_Module_Exports *me;
me = make_module_exports();
m->me = me;
me->modsrc = m->modsrc;
}
top_env = env->genv;
@ -10108,6 +10113,7 @@ static Scheme_Object *read_module(Scheme_Object *obj)
if (!SCHEME_PAIRP(obj)) return_NULL();
e = scheme_intern_resolved_module_path(SCHEME_CAR(obj));
m->modsrc = e;
m->me->modsrc = e;
obj = SCHEME_CDR(obj);
if (!SCHEME_PAIRP(obj)) return_NULL();

2
src/mzscheme/src/mzmark.c
View File

@ -2540,6 +2540,7 @@ static int module_exports_val_MARK(void *p, struct NewGC *gc) {
gcMARK2(m->other_phases, gc);
gcMARK2(m->src_modidx, gc);
gcMARK2(m->modsrc, gc);
return
gcBYTES_TO_WORDS(sizeof(Scheme_Module_Exports));
}
@ -2553,6 +2554,7 @@ static int module_exports_val_FIXUP(void *p, struct NewGC *gc) {
gcFIXUP2(m->other_phases, gc);
gcFIXUP2(m->src_modidx, gc);
gcFIXUP2(m->modsrc, gc);
return
gcBYTES_TO_WORDS(sizeof(Scheme_Module_Exports));
}

1
src/mzscheme/src/mzmarksrc.c
View File

@ -1021,6 +1021,7 @@ module_exports_val {
gcMARK2(m->other_phases, gc);
gcMARK2(m->src_modidx, gc);
gcMARK2(m->modsrc, gc);
size:
gcBYTES_TO_WORDS(sizeof(Scheme_Module_Exports));
}

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

@ -950,7 +950,7 @@ 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);
Scheme_Object *scheme_stx_source_module(Scheme_Object *stx, int resolve);
Scheme_Object *scheme_stx_source_module(Scheme_Object *stx, int resolve, int source);
Scheme_Object *scheme_stx_property(Scheme_Object *_stx,
Scheme_Object *key,
@ -2200,7 +2200,6 @@ void scheme_check_identifier(const char *formname, Scheme_Object *id,
const char *where,
Scheme_Comp_Env *env,
Scheme_Object *form);
int scheme_check_context(Scheme_Env *env, Scheme_Object *id, Scheme_Object *ok_modix);
Scheme_Object *scheme_check_immediate_macro(Scheme_Object *first,
Scheme_Comp_Env *env,
@ -2914,6 +2913,7 @@ typedef struct Scheme_Module_Exports
Scheme_Hash_Table *other_phases;
Scheme_Object *src_modidx; /* the one used in marshalled syntax */
Scheme_Object *modsrc; /* module source as loaded */
} Scheme_Module_Exports;
typedef struct Scheme_Modidx {

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

@ -582,9 +582,9 @@ void scheme_init_stx(Scheme_Env *env)
scheme_add_global_constant("syntax-source-module",
scheme_make_folding_prim(syntax_src_module,
"syntax-source-module",
1, 1, 1),
scheme_make_noncm_prim(syntax_src_module,
"syntax-source-module",
1, 2),
env);
scheme_add_global_constant("syntax-recertify",
@ -5316,11 +5316,12 @@ Scheme_Object *scheme_explain_resolve_env(Scheme_Object *a)
}
#endif
Scheme_Object *scheme_stx_source_module(Scheme_Object *stx, int resolve)
Scheme_Object *scheme_stx_source_module(Scheme_Object *stx, int resolve, int source)
{
/* Inspect the wraps to look for a self-modidx shift: */
WRAP_POS w;
Scheme_Object *srcmod = scheme_false, *chain_from = NULL;
Scheme_Object *srcmod = scheme_false, *chain_from = NULL, *er;
Scheme_Hash_Table *export_registry;
WRAP_POS_INIT(w, ((Scheme_Stx *)stx)->wraps);
@ -5346,14 +5347,29 @@ Scheme_Object *scheme_stx_source_module(Scheme_Object *stx, int resolve)
}
chain_from = src;
if (!export_registry) {
er = SCHEME_VEC_ELS(vec)[3];
if (SCHEME_TRUEP(er))
export_registry = (Scheme_Hash_Table *)er;
}
}
}
WRAP_POS_INC(w);
}
if (SCHEME_TRUEP(srcmod) && resolve)
srcmod = scheme_module_resolve(srcmod, 0);
if (SCHEME_TRUEP(srcmod)) {
if (resolve) {
srcmod = scheme_module_resolve(srcmod, 0);
if (export_registry && source) {
er = scheme_hash_get(export_registry, srcmod);
if (er)
srcmod = ((Scheme_Module_Exports *)er)->modsrc;
}
srcmod = SCHEME_PTR_VAL(srcmod);
}
}
return srcmod;
}
@ -9110,10 +9126,15 @@ static Scheme_Object *identifier_prune(int argc, Scheme_Object **argv)
static Scheme_Object *syntax_src_module(int argc, Scheme_Object **argv)
{
int source = 0;
if (!SCHEME_STXP(argv[0]))
scheme_wrong_type("syntax-source-module", "syntax", 0, argc, argv);
return scheme_stx_source_module(argv[0], 0);
if ((argc > 1) && SCHEME_TRUEP(argv[1]))
source = 1;
return scheme_stx_source_module(argv[0], source, source);
}
/**********************************************************************/