fix syntax-local-expand/capture-lifts
svn: r8614
This commit is contained in:
parent
5929f046d5
commit
6f057bd68c
|
@ -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
|
||||
|
|
|
@ -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.}
|
||||
|
|
|
@ -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)))]
|
||||
|
|
|
@ -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)
|
||||
|
||||
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
|
|
|
@ -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)
|
||||
|
|
Loading…
Reference in New Issue
Block a user