From b7bef3b3aa5405302b4747d3f3b466ae8f9069a3 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Mon, 12 Sep 2011 16:52:27 -0600 Subject: [PATCH] add `syntax-transforming-module-expression?', `variable-reference->module-base-phase' --- .../scribblings/reference/namespaces.scrbl | 10 ++++++++ .../scribblings/reference/stx-trans.scrbl | 16 +++++++++--- collects/tests/racket/namespac.rktl | 25 ++++++++++++++++--- collects/tests/racket/stx.rktl | 25 +++++++++++++++++++ src/racket/src/compenv.c | 19 +++++++++----- src/racket/src/cstartup.inc | 10 ++++---- src/racket/src/env.c | 19 ++++++++++++++ src/racket/src/schminc.h | 2 +- src/racket/src/schpriv.h | 1 + src/racket/src/schvers.h | 4 +-- 10 files changed, 110 insertions(+), 21 deletions(-) diff --git a/collects/scribblings/reference/namespaces.scrbl b/collects/scribblings/reference/namespaces.scrbl index 2556a2240f..496af3f6fd 100644 --- a/collects/scribblings/reference/namespaces.scrbl +++ b/collects/scribblings/reference/namespaces.scrbl @@ -413,3 +413,13 @@ result is @racket[#f].} Returns the @tech{phase} of the variable referenced by @racket[varref].} +@defproc[(variable-reference->module-base-phase [varref variable-reference?]) + exact-nonnegative-integer?]{ + +Returns the @tech{phase} in which the module is instantiated for the +variable referenced by @racket[varref], or @racket[0] if the variable +for @racket[varref] is not within a module. + +For a variable with a module, the result is less than the result of +@racket[(variable-reference->phase varref)] by @math{n} when the +variable is bound at @tech{phase level} @math{n} within the module.} diff --git a/collects/scribblings/reference/stx-trans.scrbl b/collects/scribblings/reference/stx-trans.scrbl index efbdd493a1..a31e664360 100644 --- a/collects/scribblings/reference/stx-trans.scrbl +++ b/collects/scribblings/reference/stx-trans.scrbl @@ -11,7 +11,8 @@ @(define (transform-time) @t{This procedure must be called during the dynamic extent of a @tech{syntax transformer} application by the -expander or while a module is @tech{visit}ed, otherwise the +expander or while a module is @tech{visit}ed (see +@racket[syntax-transforming?]), otherwise the @exnraise[exn:fail:contract].}) @@ -516,7 +517,7 @@ transformed is not in the module top-level, then @racket[stx] is eventually expanded in an expression context. @transform-time[] If the current expression being transformed is not -within a @racket[module] form, or if it is not a run-time expression, +within a @racket[module] form (see @racket[syntax-transforming-module-expression?]), then the @exnraise[exn:fail:contract].} @@ -554,8 +555,8 @@ Lifts a @racket[#%provide] form corresponding to expanded or to an enclosing @racket[begin-for-syntax]. @transform-time[] If the current expression being transformed is not -within a @racket[module] form, or if it is not a run-time expression, -then the @exnraise[exn:fail:contract]. } +within a @racket[module] form (see @racket[syntax-transforming-module-expression?]), +then the @exnraise[exn:fail:contract].} @defproc[(syntax-local-name) any/c]{ @@ -654,6 +655,13 @@ transformer} application by the expander and while a module is being @tech{visit}ed, @racket[#f] otherwise.} +@defproc[(syntax-transforming-module-expression?) boolean?]{ + +Returns @racket[#t] during the dynamic extent of a @tech{syntax +transformer} application by the expander for an expression +within a @racket[module] form, @racket[#f] otherwise.} + + @defproc[(syntax-local-introduce [stx syntax?]) syntax?]{ Produces a syntax object that is like @racket[stx], except that a diff --git a/collects/tests/racket/namespac.rktl b/collects/tests/racket/namespac.rktl index 4488d01e81..0ef5ccf4b7 100644 --- a/collects/tests/racket/namespac.rktl +++ b/collects/tests/racket/namespac.rktl @@ -140,9 +140,12 @@ (module phaser scheme/base (define x (variable-reference->phase (#%variable-reference x))) - (provide x)) + (define y (variable-reference->module-base-phase + (#%variable-reference y))) + (provide x y)) (test 0 dynamic-require ''phaser 'x) +(test 0 dynamic-require ''phaser 'y) (let ([s (open-output-string)]) (parameterize ([current-output-port s]) @@ -157,8 +160,24 @@ (let ([ns (make-base-namespace)]) (namespace-attach-module (current-namespace) ''phaser ns) (eval '(require 'phaser) ns) - (display (eval 'x ns)))))) - (test "1" get-output-string s)) + (display (eval 'x ns)) + (display (eval 'y ns)))))) + (test "11" get-output-string s)) + +(let ([s (open-output-string)]) + (parameterize ([current-output-port s]) + (let ([ns (make-base-namespace)]) + (eval '(module m racket/base + (require (for-syntax racket/base)) + (begin-for-syntax + (define x 10) + (displayln (variable-reference->phase + (#%variable-reference x))) + (displayln (variable-reference->module-base-phase + (#%variable-reference x)))))) + (eval '(require (for-syntax 'm))) + (eval '(begin-for-syntax 10)))) + (test "1\n0\n2\n1\n" get-output-string s)) ;; ---------------------------------------- diff --git a/collects/tests/racket/stx.rktl b/collects/tests/racket/stx.rktl index 07dfef5b46..cb2cd2520a 100644 --- a/collects/tests/racket/stx.rktl +++ b/collects/tests/racket/stx.rktl @@ -1586,6 +1586,31 @@ (let-syntax ([g (lambda (stx) nonesuch)]) 10)))) +;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; `syntax-transforming?' and `syntax-transforming-module-expression?' + +(test #f syntax-transforming?) +(test #f syntax-transforming-module-expression?) +(test #t 'trans (let-syntax ([m (lambda (stx) + (datum->syntax stx (syntax-transforming?)))]) + (m))) +(test #f 'trans-mod (let-syntax ([m (lambda (stx) + (datum->syntax stx (syntax-transforming-module-expression?)))]) + (m))) +(let ([o (open-output-string)]) + (parameterize ([current-output-port o]) + (eval `(module m racket/base + (require (for-syntax racket/base)) + (define-syntax (m stx) + (displayln (syntax-transforming-module-expression?)) + #'1) + (m))) + (eval `(module m racket/base + (require (for-syntax racket/base)) + (begin-for-syntax + (displayln (syntax-transforming-module-expression?)))))) + (test "#t\n#f\n" get-output-string o)) + ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (report-errs) diff --git a/src/racket/src/compenv.c b/src/racket/src/compenv.c index 0505864fde..d11b12718c 100644 --- a/src/racket/src/compenv.c +++ b/src/racket/src/compenv.c @@ -2213,12 +2213,8 @@ scheme_local_lift_context(Scheme_Comp_Env *env) return SCHEME_VEC_ELS(COMPILE_DATA(env)->lifts)[4]; } -Scheme_Object * -scheme_local_lift_end_statement(Scheme_Object *expr, Scheme_Object *local_mark, Scheme_Comp_Env *env) +Scheme_Comp_Env *scheme_get_module_lift_env(Scheme_Comp_Env *env) { - Scheme_Object *pr; - Scheme_Object *orig_expr; - while (env) { if ((COMPILE_DATA(env)->lifts) && SCHEME_TRUEP(SCHEME_VEC_ELS(COMPILE_DATA(env)->lifts)[3])) @@ -2226,10 +2222,21 @@ scheme_local_lift_end_statement(Scheme_Object *expr, Scheme_Object *local_mark, env = env->next; } + return env; +} + +Scheme_Object * +scheme_local_lift_end_statement(Scheme_Object *expr, Scheme_Object *local_mark, Scheme_Comp_Env *env) +{ + Scheme_Object *pr; + Scheme_Object *orig_expr; + + env = scheme_get_module_lift_env(env); + if (!env) scheme_raise_exn(MZEXN_FAIL_CONTRACT, "syntax-local-lift-module-end-declaration: not currently transforming" - " a run-time expression in a module declaration"); + " an expression within a module declaration"); expr = scheme_add_remove_mark(expr, local_mark); orig_expr = expr; diff --git a/src/racket/src/cstartup.inc b/src/racket/src/cstartup.inc index af411a6375..790cf113c5 100644 --- a/src/racket/src/cstartup.inc +++ b/src/racket/src/cstartup.inc @@ -1,5 +1,5 @@ { - SHARED_OK static MZCOMPILED_STRING_FAR unsigned char expr[] = {35,126,7,53,46,49,46,51,46,55,0,0,0,0,0,0,0,0,0,0,0, + SHARED_OK static MZCOMPILED_STRING_FAR unsigned char expr[] = {35,126,7,53,46,49,46,51,46,56,0,0,0,0,0,0,0,0,0,0,0, 0,0,0,0,0,0,0,0,0,51,0,0,0,1,0,0,10,0,13,0,17, 0,22,0,29,0,42,0,49,0,54,0,59,0,63,0,70,0,73,0,82,0, 85,0,91,0,105,0,119,0,122,0,128,0,132,0,134,0,145,0,147,0,161, @@ -99,7 +99,7 @@ EVAL_ONE_SIZED_STR((char *)expr, 2018); } { - SHARED_OK static MZCOMPILED_STRING_FAR unsigned char expr[] = {35,126,7,53,46,49,46,51,46,55,0,0,0,0,0,0,0,0,0,0,0, + SHARED_OK static MZCOMPILED_STRING_FAR unsigned char expr[] = {35,126,7,53,46,49,46,51,46,56,0,0,0,0,0,0,0,0,0,0,0, 0,0,0,0,0,0,0,0,0,109,0,0,0,1,0,0,8,0,21,0,26, 0,43,0,65,0,94,0,109,0,127,0,143,0,157,0,179,0,195,0,212,0, 234,0,245,0,251,0,4,1,11,1,18,1,30,1,46,1,70,1,102,1,120, @@ -599,7 +599,7 @@ EVAL_ONE_SIZED_STR((char *)expr, 10420); } { - SHARED_OK static MZCOMPILED_STRING_FAR unsigned char expr[] = {35,126,7,53,46,49,46,51,46,55,0,0,0,0,0,0,0,0,0,0,0, + SHARED_OK static MZCOMPILED_STRING_FAR unsigned char expr[] = {35,126,7,53,46,49,46,51,46,56,0,0,0,0,0,0,0,0,0,0,0, 0,0,0,0,0,0,0,0,0,12,0,0,0,1,0,0,15,0,40,0,57, 0,75,0,97,0,120,0,140,0,162,0,169,0,176,0,183,0,0,0,175,1, 0,0,74,35,37,112,108,97,99,101,45,115,116,114,117,99,116,1,23,115,116, @@ -626,7 +626,7 @@ EVAL_ONE_SIZED_STR((char *)expr, 496); } { - SHARED_OK static MZCOMPILED_STRING_FAR unsigned char expr[] = {35,126,7,53,46,49,46,51,46,55,0,0,0,0,0,0,0,0,0,0,0, + SHARED_OK static MZCOMPILED_STRING_FAR unsigned char expr[] = {35,126,7,53,46,49,46,51,46,56,0,0,0,0,0,0,0,0,0,0,0, 0,0,0,0,0,0,0,0,0,65,0,0,0,1,0,0,7,0,18,0,45, 0,51,0,64,0,73,0,80,0,102,0,124,0,150,0,158,0,170,0,185,0, 201,0,219,0,239,0,251,0,11,1,34,1,46,1,77,1,84,1,89,1,94, @@ -927,7 +927,7 @@ EVAL_ONE_SIZED_STR((char *)expr, 6241); } { - SHARED_OK static MZCOMPILED_STRING_FAR unsigned char expr[] = {35,126,7,53,46,49,46,51,46,55,0,0,0,0,0,0,0,0,0,0,0, + SHARED_OK static MZCOMPILED_STRING_FAR unsigned char expr[] = {35,126,7,53,46,49,46,51,46,56,0,0,0,0,0,0,0,0,0,0,0, 0,0,0,0,0,0,0,0,0,11,0,0,0,1,0,0,10,0,16,0,29, 0,44,0,58,0,78,0,90,0,104,0,118,0,170,0,0,0,94,1,0,0, 69,35,37,98,117,105,108,116,105,110,65,113,117,111,116,101,29,94,2,2,67, diff --git a/src/racket/src/env.c b/src/racket/src/env.c index 2a2681b85c..1b4b1802c2 100644 --- a/src/racket/src/env.c +++ b/src/racket/src/env.c @@ -77,8 +77,10 @@ static Scheme_Object *variable_module_source(int, Scheme_Object *[]); static Scheme_Object *variable_namespace(int, Scheme_Object *[]); static Scheme_Object *variable_top_level_namespace(int, Scheme_Object *[]); static Scheme_Object *variable_phase(int, Scheme_Object *[]); +static Scheme_Object *variable_base_phase(int, Scheme_Object *[]); static Scheme_Object *variable_const_p(int, Scheme_Object *[]); static Scheme_Object *now_transforming(int argc, Scheme_Object *argv[]); +static Scheme_Object *now_transforming_module(int argc, Scheme_Object *argv[]); static Scheme_Object *local_exp_time_value(int argc, Scheme_Object *argv[]); static Scheme_Object *local_exp_time_value_one(int argc, Scheme_Object *argv[]); static Scheme_Object *local_exp_time_name(int argc, Scheme_Object *argv[]); @@ -641,6 +643,7 @@ static void make_kernel_env(void) GLOBAL_PRIM_W_ARITY("variable-reference->empty-namespace", variable_namespace, 1, 1, env); GLOBAL_PRIM_W_ARITY("variable-reference->namespace", variable_top_level_namespace, 1, 1, env); GLOBAL_PRIM_W_ARITY("variable-reference->phase", variable_phase, 1, 1, env); + GLOBAL_PRIM_W_ARITY("variable-reference->module-base-phase", variable_base_phase, 1, 1, env); REGISTER_SO(scheme_varref_const_p_proc); scheme_varref_const_p_proc = scheme_make_prim_w_arity(variable_const_p, @@ -649,6 +652,7 @@ static void make_kernel_env(void) scheme_add_global_constant("variable-reference-constant?", scheme_varref_const_p_proc, env); GLOBAL_PRIM_W_ARITY("syntax-transforming?", now_transforming, 0, 0, env); + GLOBAL_PRIM_W_ARITY("syntax-transforming-module-expression?", now_transforming_module, 0, 0, env); GLOBAL_PRIM_W_ARITY("syntax-local-value", local_exp_time_value, 1, 3, env); GLOBAL_PRIM_W_ARITY("syntax-local-value/immediate", local_exp_time_value_one, 1, 3, env); GLOBAL_PRIM_W_ARITY("syntax-local-name", local_exp_time_name, 0, 0, env); @@ -1675,6 +1679,8 @@ static Scheme_Object *do_variable_namespace(const char *who, int tl, int argc, S ph = env->phase; if (tl == 2) { return scheme_make_integer(ph); + } else if (tl == 3) { + return scheme_make_integer(ph - env->mod_phase); } else if (tl) { /* return env directly; need to set up */ if (!env->phase && env->module) @@ -1705,6 +1711,11 @@ static Scheme_Object *variable_phase(int argc, Scheme_Object *argv[]) return do_variable_namespace("variable-reference->phase", 2, argc, argv); } +static Scheme_Object *variable_base_phase(int argc, Scheme_Object *argv[]) +{ + return do_variable_namespace("variable-reference->phase", 3, argc, argv); +} + static Scheme_Object *variable_const_p(int argc, Scheme_Object *argv[]) { Scheme_Object *v; @@ -1780,6 +1791,14 @@ now_transforming(int argc, Scheme_Object *argv[]) : scheme_false); } +static Scheme_Object * +now_transforming_module(int argc, Scheme_Object *argv[]) +{ + if (scheme_get_module_lift_env(scheme_current_thread->current_local_env)) + return scheme_true; + return scheme_false; +} + static Scheme_Object * do_local_exp_time_value(const char *name, int argc, Scheme_Object *argv[], int recur) { diff --git a/src/racket/src/schminc.h b/src/racket/src/schminc.h index 4762f23759..34684a62a3 100644 --- a/src/racket/src/schminc.h +++ b/src/racket/src/schminc.h @@ -13,7 +13,7 @@ #define USE_COMPILED_STARTUP 1 -#define EXPECTED_PRIM_COUNT 1031 +#define EXPECTED_PRIM_COUNT 1033 #define EXPECTED_UNSAFE_COUNT 78 #define EXPECTED_FLFXNUM_COUNT 68 #define EXPECTED_FUTURES_COUNT 11 diff --git a/src/racket/src/schpriv.h b/src/racket/src/schpriv.h index 92403f57f3..23af9c5760 100644 --- a/src/racket/src/schpriv.h +++ b/src/racket/src/schpriv.h @@ -2427,6 +2427,7 @@ Scheme_Object *scheme_local_lift_require(Scheme_Object *form, Scheme_Object *ori Scheme_Comp_Env *env); Scheme_Object *scheme_local_lift_provide(Scheme_Object *form, Scheme_Object *local_mark, Scheme_Comp_Env *env); +Scheme_Comp_Env *scheme_get_module_lift_env(Scheme_Comp_Env *env); void scheme_check_identifier(const char *formname, Scheme_Object *id, const char *where, diff --git a/src/racket/src/schvers.h b/src/racket/src/schvers.h index 9a4c0809ba..9b48cd9733 100644 --- a/src/racket/src/schvers.h +++ b/src/racket/src/schvers.h @@ -13,12 +13,12 @@ consistently.) */ -#define MZSCHEME_VERSION "5.1.3.7" +#define MZSCHEME_VERSION "5.1.3.8" #define MZSCHEME_VERSION_X 5 #define MZSCHEME_VERSION_Y 1 #define MZSCHEME_VERSION_Z 3 -#define MZSCHEME_VERSION_W 7 +#define MZSCHEME_VERSION_W 8 #define MZSCHEME_VERSION_MAJOR ((MZSCHEME_VERSION_X * 100) + MZSCHEME_VERSION_Y) #define MZSCHEME_VERSION_MINOR ((MZSCHEME_VERSION_Z * 1000) + MZSCHEME_VERSION_W)