diff --git a/collects/scheme/contract/private/provide.ss b/collects/scheme/contract/private/provide.ss index 24f02889fe..37066b509e 100644 --- a/collects/scheme/contract/private/provide.ss +++ b/collects/scheme/contract/private/provide.ss @@ -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))))))])) diff --git a/collects/scribblings/reference/stx-ops.scrbl b/collects/scribblings/reference/stx-ops.scrbl index 3bce8c6399..43f0f14758 100644 --- a/collects/scribblings/reference/stx-ops.scrbl +++ b/collects/scribblings/reference/stx-ops.scrbl @@ -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]{ diff --git a/collects/unstable/location.ss b/collects/unstable/location.ss index 20747356f5..0a32cc9aca 100644 --- a/collects/unstable/location.ss +++ b/collects/unstable/location.ss @@ -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))) diff --git a/collects/unstable/scribblings/srcloc.scrbl b/collects/unstable/scribblings/srcloc.scrbl index 06285898eb..19e54ac0e6 100644 --- a/collects/unstable/scribblings/srcloc.scrbl +++ b/collects/unstable/scribblings/srcloc.scrbl @@ -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 diff --git a/collects/unstable/srcloc.ss b/collects/unstable/srcloc.ss index 200529fa7d..9a1a625ba9 100644 --- a/collects/unstable/srcloc.ss +++ b/collects/unstable/srcloc.ss @@ -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) diff --git a/src/mzscheme/src/env.c b/src/mzscheme/src/env.c index beff176cd2..14ec6b81cd 100644 --- a/src/mzscheme/src/env.c +++ b/src/mzscheme/src/env.c @@ -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); diff --git a/src/mzscheme/src/module.c b/src/mzscheme/src/module.c index 98600c0a37..9ca3ef498a 100644 --- a/src/mzscheme/src/module.c +++ b/src/mzscheme/src/module.c @@ -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(); diff --git a/src/mzscheme/src/mzmark.c b/src/mzscheme/src/mzmark.c index 93a133926f..94783888fd 100644 --- a/src/mzscheme/src/mzmark.c +++ b/src/mzscheme/src/mzmark.c @@ -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)); } diff --git a/src/mzscheme/src/mzmarksrc.c b/src/mzscheme/src/mzmarksrc.c index dc9721125d..88304881b8 100644 --- a/src/mzscheme/src/mzmarksrc.c +++ b/src/mzscheme/src/mzmarksrc.c @@ -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)); } diff --git a/src/mzscheme/src/schpriv.h b/src/mzscheme/src/schpriv.h index 0331768ef2..93a7b2abe0 100644 --- a/src/mzscheme/src/schpriv.h +++ b/src/mzscheme/src/schpriv.h @@ -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 { diff --git a/src/mzscheme/src/stxobj.c b/src/mzscheme/src/stxobj.c index ba3122e079..f6d235ef06 100644 --- a/src/mzscheme/src/stxobj.c +++ b/src/mzscheme/src/stxobj.c @@ -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); } /**********************************************************************/