From 8928f8038452d0c1fae6e58f9a0d9ca65c0f5b7f Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Tue, 20 Mar 2007 02:24:11 +0000 Subject: [PATCH] fix certificate problem related to macro-generating macros and transparent result forms svn: r5798 --- src/mzscheme/src/fun.c | 17 ++++++++++++----- src/mzscheme/src/schpriv.h | 1 + src/mzscheme/src/stxobj.c | 12 ++++++++++++ 3 files changed, 25 insertions(+), 5 deletions(-) diff --git a/src/mzscheme/src/fun.c b/src/mzscheme/src/fun.c index 5f38c5f1bd..dd3900341f 100644 --- a/src/mzscheme/src/fun.c +++ b/src/mzscheme/src/fun.c @@ -2296,7 +2296,8 @@ _scheme_tail_apply_to_list (Scheme_Object *rator, Scheme_Object *rands) static Scheme_Object * cert_with_specials(Scheme_Object *code, Scheme_Object *mark, Scheme_Env *menv, - Scheme_Object *orig_code, Scheme_Comp_Env *cenv, int phase, + Scheme_Object *orig_code, Scheme_Object *closest_code, + Scheme_Comp_Env *cenv, int phase, int deflt, int cadr_deflt) { Scheme_Object *prop; @@ -2374,10 +2375,16 @@ cert_with_specials(Scheme_Object *code, Scheme_Object *mark, Scheme_Env *menv, if (SCHEME_STX_PAIRP(code)) { Scheme_Object *a, *d, *v; + if (SCHEME_STXP(code)) + closest_code = code; + a = SCHEME_STX_CAR(code); - a = cert_with_specials(a, mark, menv, orig_code, cenv, phase, cadr_deflt, 0); + a = scheme_stx_propagate_inactive_certs(a, closest_code); + a = cert_with_specials(a, mark, menv, orig_code, closest_code, cenv, phase, cadr_deflt, 0); d = SCHEME_STX_CDR(code); - d = cert_with_specials(d, mark, menv, orig_code, cenv, phase, 1, next_cadr_deflt); + if (SCHEME_STXP(d)) + d = scheme_stx_propagate_inactive_certs(d, closest_code); + d = cert_with_specials(d, mark, menv, orig_code, closest_code, cenv, phase, 1, next_cadr_deflt); v = scheme_make_pair(a, d); @@ -2428,7 +2435,7 @@ scheme_apply_macro(Scheme_Object *name, Scheme_Env *menv, code = scheme_datum_to_syntax(code, orig_code, scheme_sys_wraps(env), 0, 0); } - code = cert_with_specials(code, mark, menv, orig_code, env, env->genv->phase, 0, 0); + code = cert_with_specials(code, mark, menv, orig_code, orig_code, env, env->genv->phase, 0, 0); code = scheme_stx_track(code, orig_code, name); @@ -2463,7 +2470,7 @@ scheme_apply_macro(Scheme_Object *name, Scheme_Env *menv, code = scheme_add_remove_mark(code, mark); - code = cert_with_specials(code, mark, menv, orig_code, env, env->genv->phase, 0, 0); + code = cert_with_specials(code, mark, menv, orig_code, orig_code, env, env->genv->phase, 0, 0); code = scheme_stx_track(code, orig_code, name); diff --git a/src/mzscheme/src/schpriv.h b/src/mzscheme/src/schpriv.h index 77e8872498..6706c40c0c 100644 --- a/src/mzscheme/src/schpriv.h +++ b/src/mzscheme/src/schpriv.h @@ -715,6 +715,7 @@ Scheme_Object *scheme_stx_activate_certs(Scheme_Object *stx); Scheme_Object *scheme_stx_extract_certs(Scheme_Object *o, Scheme_Object *base_certs); Scheme_Object *scheme_stx_add_inactive_certs(Scheme_Object *o, Scheme_Object *certs); +Scheme_Object *scheme_stx_propagate_inactive_certs(Scheme_Object *o, Scheme_Object *orig); int scheme_stx_has_more_certs(Scheme_Object *id, Scheme_Object *certs, Scheme_Object *than_id, Scheme_Object *than_certs); diff --git a/src/mzscheme/src/stxobj.c b/src/mzscheme/src/stxobj.c index 1b0e9d1074..8cea240332 100644 --- a/src/mzscheme/src/stxobj.c +++ b/src/mzscheme/src/stxobj.c @@ -2050,6 +2050,18 @@ Scheme_Object *scheme_stx_add_inactive_certs(Scheme_Object *o, Scheme_Object *ce return add_certs(o, (Scheme_Cert *)certs, NULL, 0); } +Scheme_Object *scheme_stx_propagate_inactive_certs(Scheme_Object *o, Scheme_Object *orig) +{ + Scheme_Cert *certs; + + certs = INACTIVE_CERTS((Scheme_Stx *)orig); + + if (certs) + return scheme_stx_add_inactive_certs(o, (Scheme_Object *)certs); + else + return o; +} + Scheme_Object *scheme_stx_extract_certs(Scheme_Object *o, Scheme_Object *base_certs) { return (Scheme_Object *)append_certs((Scheme_Cert *)base_certs,