From 6f057bd68cee802c418ffba423dbff12e6a962b6 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Sun, 10 Feb 2008 15:52:46 +0000 Subject: [PATCH] fix syntax-local-expand/capture-lifts svn: r8614 --- collects/scheme/private/define.ss | 14 +++-- .../scribblings/reference/stx-trans.scrbl | 13 ++--- collects/setup/setup-cmdline.ss | 2 +- collects/tests/mzscheme/stx.ss | 29 +++++++--- src/mzscheme/src/eval.c | 55 +++++++++++++------ 5 files changed, 75 insertions(+), 38 deletions(-) diff --git a/collects/scheme/private/define.ss b/collects/scheme/private/define.ss index 70eba8516f..e2e938045c 100644 --- a/collects/scheme/private/define.ss +++ b/collects/scheme/private/define.ss @@ -56,19 +56,21 @@ #%require)))]) (syntax-case* e (begin define-values define-syntaxes require require-for-template) free-transformer-identifier=? - [(begin v ...) + [(begin (begin v ...)) #'(begin-for-syntax v ...)] - [(define-values (id ...) expr) + [(begin (define-values (id ...) expr)) #'(define-values-for-syntax (id ...) expr)] - [(require v ...) + [(begin (require v ...)) #'(require (for-syntax v ...))] - [(define-syntaxes (id ...) expr) + [(begin (define-syntaxes (id ...) expr)) (raise-syntax-error #f "syntax definitions not allowed within begin-for-syntax" #'elem)] - [other - #'(define-values-for-syntax () (begin other (values)))]))] + [(begin other) + #'(define-values-for-syntax () (begin other (values)))] + [(begin v ...) + #'(begin-for-syntax v ...)]))] [(_ elem ...) ;; We split up the elems so that someone else can ;; worry about the fact that properly expanding the second diff --git a/collects/scribblings/reference/stx-trans.scrbl b/collects/scribblings/reference/stx-trans.scrbl index bfe8d72825..2f9682be76 100644 --- a/collects/scribblings/reference/stx-trans.scrbl +++ b/collects/scribblings/reference/stx-trans.scrbl @@ -171,13 +171,12 @@ transformer expression instead of a run-time expression.} [lift-ctx any/c (gensym 'lifts)]) syntax?]{ -Like @scheme[local-expand], but if -@scheme[syntax-local-lift-expression] is called during the expansion -of @scheme[stx], the result is a syntax object that represents a -@scheme[begin] expression; lifted expression appear with their -identifiers in @scheme[define-values] forms, and the expansion of -@scheme[stx] is the last expression in the @scheme[begin]. The -@scheme[lift-ctx] value is reported by +Like @scheme[local-expand], the result is a syntax object that +represents a @scheme[begin] expression. Lifted expressions---from +calls to @scheme[syntax-local-lift-expression] during the expansion of +@scheme[stx]---appear with their identifiers in @scheme[define-values] +forms, and the expansion of @scheme[stx] is the last expression in the +@scheme[begin]. The @scheme[lift-ctx] value is reported by @scheme[syntax-local-lift-context] during local expansion. The lifted expressions are not expanded, but instead left as provided in the @scheme[begin] form.} diff --git a/collects/setup/setup-cmdline.ss b/collects/setup/setup-cmdline.ss index 1cc7713e7e..7677670605 100644 --- a/collects/setup/setup-cmdline.ss +++ b/collects/setup/setup-cmdline.ss @@ -46,7 +46,7 @@ (add-flags '((make-info-domain #f)))] [("-D" "--no-docs") "Do not produce documentation" (add-flags '((make-docs #f)))] - [("-U" "--no-user-specific") "Do not setup user-specific collections (incl. planet)" + [("-U" "--no-user") "Do not setup user-specific collections (implies --no-planet)" (add-flags '((make-user #f) (make-planet #f)))] [("--no-planet") "Do not setup PLaneT packages" (add-flags '((make-planet #f)))] diff --git a/collects/tests/mzscheme/stx.ss b/collects/tests/mzscheme/stx.ss index ed6b2766e7..a0dc5bee2b 100644 --- a/collects/tests/mzscheme/stx.ss +++ b/collects/tests/mzscheme/stx.ss @@ -1047,20 +1047,33 @@ (test #t symbol? prev-ctx) (set! prev-ctx #f) -(define-syntax (@@local-top stx) - (syntax-case stx () - [(_ expr) - (local-expand/capture-lifts #'expr - (list (gensym)) - (list #'begin #'#%top) - #f - 'the-key)])) +(define-syntaxes (@@local-top @@local-top2 @@local-top3) + (let ([mk + (lambda (stops) + (lambda (stx) + (syntax-case stx () + [(_ expr) + (let ([v (local-expand/capture-lifts #'expr + (list (gensym)) + stops + #f + 'the-key)]) + ;; make sure that it's a `begin' form: + (syntax-case v (begin) + [(begin e ... e0) v]))])))]) + (values + (mk (list #'begin #'#%top)) + (mk null) + (mk #f)))) (test 1 'let-foo (let ([x 5]) (@@foo 1))) (test 1 eval (expand #'(let ([x 5]) (@@foo 1)))) (test 1 'local-foo (let ([x 5]) (@@local-top (@@foo 1)))) (test 'the-key values prev-ctx) (test 1 eval (expand #'(let ([x 5]) (@@local-top (@@foo 1))))) +(test 1 eval (expand #'(@@local-top (@@foo 1)))) +(test 1 eval (expand #'(@@local-top2 (@@foo 1)))) +(test 1 eval (expand #'(@@local-top3 (@@foo 1)))) (test 'the-key values prev-ctx) ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; diff --git a/src/mzscheme/src/eval.c b/src/mzscheme/src/eval.c index cca389e803..e404003b3d 100644 --- a/src/mzscheme/src/eval.c +++ b/src/mzscheme/src/eval.c @@ -8410,13 +8410,23 @@ Scheme_Object *scheme_eval_compiled_stx_string(Scheme_Object *expr, Scheme_Env * return expr; } +static Scheme_Object *add_lifts_as_begin(Scheme_Object *obj, Scheme_Object *l, Scheme_Comp_Env *env) +{ + obj = scheme_append(l, scheme_make_pair(obj, scheme_null)); + obj = icons(scheme_datum_to_syntax(begin_symbol, scheme_false, scheme_sys_wraps(env), 0, 0), + obj); + obj = scheme_datum_to_syntax(obj, scheme_false, scheme_false, 0, 0); + return obj; + +} + static void *expand_k(void) { Scheme_Thread *p = scheme_current_thread; Scheme_Object *obj, *certs, *observer, *catch_lifts_key; Scheme_Comp_Env *env; Scheme_Expand_Info erec1; - int depth, rename, just_to_top; + int depth, rename, just_to_top, as_local; obj = (Scheme_Object *)p->ku.k.p1; env = (Scheme_Comp_Env *)p->ku.k.p2; @@ -8425,6 +8435,7 @@ static void *expand_k(void) just_to_top = p->ku.k.i3; catch_lifts_key = p->ku.k.p4; certs = (Scheme_Object *)p->ku.k.p3; + as_local = p->ku.k.i4; p->ku.k.p1 = NULL; p->ku.k.p2 = NULL; @@ -8463,15 +8474,15 @@ static void *expand_k(void) Scheme_Object *l; l = scheme_frame_get_lifts(env); if (SCHEME_PAIRP(l)) { - obj = scheme_append(l, scheme_make_pair(obj, scheme_null)); - obj = icons(scheme_datum_to_syntax(begin_symbol, scheme_false, scheme_sys_wraps(env), 0, 0), - obj); - obj = scheme_datum_to_syntax(obj, scheme_false, scheme_false, 0, 0); + obj = add_lifts_as_begin(obj, l, env); SCHEME_EXPAND_OBSERVE_LIFT_LOOP(erec1.observer,obj); - if (depth >= 0) + if ((depth >= 0) || as_local) break; - } else + } else { + if (as_local) + obj = add_lifts_as_begin(obj, scheme_null, env); break; + } } else break; } @@ -8486,7 +8497,7 @@ static void *expand_k(void) static Scheme_Object *_expand(Scheme_Object *obj, Scheme_Comp_Env *env, int depth, int rename, int just_to_top, Scheme_Object *catch_lifts_key, int eb, - Scheme_Object *certs) + Scheme_Object *certs, int as_local) { Scheme_Thread *p = scheme_current_thread; @@ -8497,6 +8508,7 @@ static Scheme_Object *_expand(Scheme_Object *obj, Scheme_Comp_Env *env, p->ku.k.i3 = just_to_top; p->ku.k.p4 = catch_lifts_key; p->ku.k.p3 = certs; + p->ku.k.i4 = as_local; return (Scheme_Object *)scheme_top_level_do(expand_k, eb); } @@ -8504,7 +8516,7 @@ static Scheme_Object *_expand(Scheme_Object *obj, Scheme_Comp_Env *env, Scheme_Object *scheme_expand(Scheme_Object *obj, Scheme_Env *env) { return _expand(obj, scheme_new_expand_env(env, NULL, SCHEME_TOPLEVEL_FRAME), - -1, 1, 0, scheme_true, -1, NULL); + -1, 1, 0, scheme_true, -1, NULL, 0); } Scheme_Object *scheme_tail_eval_expr(Scheme_Object *obj) @@ -8678,7 +8690,7 @@ static Scheme_Object *expand(int argc, Scheme_Object **argv) env = scheme_get_env(NULL); return _expand(argv[0], scheme_new_expand_env(env, NULL, SCHEME_TOPLEVEL_FRAME), - -1, 1, 0, scheme_true, 0, NULL); + -1, 1, 0, scheme_true, 0, NULL, 0); } static Scheme_Object *expand_stx(int argc, Scheme_Object **argv) @@ -8691,7 +8703,7 @@ static Scheme_Object *expand_stx(int argc, Scheme_Object **argv) env = scheme_get_env(NULL); return _expand(argv[0], scheme_new_expand_env(env, NULL, SCHEME_TOPLEVEL_FRAME), - -1, -1, 0, scheme_true, 0, NULL); + -1, -1, 0, scheme_true, 0, NULL, 0); } static Scheme_Object *stop_syntax(Scheme_Object *form, Scheme_Comp_Env *env, @@ -8894,18 +8906,29 @@ do_local_expand(const char *name, int for_stx, int catch_lifts, int for_expr, in if (SCHEME_FALSEP(argv[2])) { Scheme_Object *xl, *gval; Scheme_Compile_Expand_Info drec[1]; + + if (catch_lifts_key) + scheme_frame_captures_lifts(env, scheme_make_lifted_defn, scheme_sys_wraps(env), scheme_false, + catch_lifts_key); + memset(drec, 0, sizeof(drec)); drec[0].value_name = scheme_false; /* or scheme_current_thread->current_local_name ? */ drec[0].certs = scheme_current_thread->current_local_certs; drec[0].depth = -2; + xl = scheme_check_immediate_macro(l, env, drec, 0, 0, &gval, NULL, NULL); + if (SAME_OBJ(xl, l)) return orig_l; + + if (catch_lifts_key) + xl = add_lifts_as_begin(xl, scheme_frame_get_lifts(env), env); + l = xl; } else { /* Expand the expression. depth = -2 means expand all the way, but preserve letrec-syntax. */ - l = _expand(l, env, -2, 0, 0, catch_lifts_key, 0, scheme_current_thread->current_local_certs); + l = _expand(l, env, -2, 0, 0, catch_lifts_key, 0, scheme_current_thread->current_local_certs, 1); } SCHEME_EXPAND_OBSERVE_LOCAL_POST(observer, l); @@ -8986,7 +9009,7 @@ expand_once(int argc, Scheme_Object **argv) env = scheme_get_env(NULL); return _expand(argv[0], scheme_new_expand_env(env, NULL, SCHEME_TOPLEVEL_FRAME), - 1, 1, 0, scheme_true, 0, NULL); + 1, 1, 0, scheme_true, 0, NULL, 0); } static Scheme_Object * @@ -9000,7 +9023,7 @@ expand_stx_once(int argc, Scheme_Object **argv) env = scheme_get_env(NULL); return _expand(argv[0], scheme_new_expand_env(env, NULL, SCHEME_TOPLEVEL_FRAME), - 1, -1, 0, scheme_true, 0, NULL); + 1, -1, 0, scheme_true, 0, NULL, 0); } static Scheme_Object * @@ -9011,7 +9034,7 @@ expand_to_top_form(int argc, Scheme_Object **argv) env = scheme_get_env(NULL); return _expand(argv[0], scheme_new_expand_env(env, NULL, SCHEME_TOPLEVEL_FRAME), - 1, 1, 1, scheme_true, 0, NULL); + 1, 1, 1, scheme_true, 0, NULL, 0); } static Scheme_Object * @@ -9025,7 +9048,7 @@ expand_stx_to_top_form(int argc, Scheme_Object **argv) env = scheme_get_env(NULL); return _expand(argv[0], scheme_new_expand_env(env, NULL, SCHEME_TOPLEVEL_FRAME), - 1, -1, 1, scheme_true, 0, NULL); + 1, -1, 1, scheme_true, 0, NULL, 0); } static Scheme_Object *do_eval_string_all(const char *str, Scheme_Env *env, int cont, int w_prompt)