From f49af7c4fad3340902ae07db23f8d1dd490b7abd Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Thu, 10 Sep 2009 15:27:41 +0000 Subject: [PATCH] fix problem with code inspectors and unmarshaling syntax (PR 10429) svn: r15957 --- src/mzscheme/src/env.c | 8 ++++---- src/mzscheme/src/read.c | 15 +++++++-------- src/mzscheme/src/schpriv.h | 6 +++++- src/mzscheme/src/stxobj.c | 29 +++++++++++++++++------------ src/mzscheme/src/type.c | 18 +++++++++++++----- 5 files changed, 46 insertions(+), 30 deletions(-) diff --git a/src/mzscheme/src/env.c b/src/mzscheme/src/env.c index 4ff3f2e1b2..0d283e10b1 100644 --- a/src/mzscheme/src/env.c +++ b/src/mzscheme/src/env.c @@ -134,7 +134,7 @@ static Scheme_Object *write_local(Scheme_Object *obj); static Scheme_Object *read_local(Scheme_Object *obj); static Scheme_Object *read_local_unbox(Scheme_Object *obj); static Scheme_Object *write_resolve_prefix(Scheme_Object *obj); -static Scheme_Object *read_resolve_prefix(Scheme_Object *obj); +static Scheme_Object *read_resolve_prefix(Scheme_Object *obj, Scheme_Object *insp); static void skip_certain_things(Scheme_Object *o, Scheme_Close_Custodian_Client *f, void *data); int scheme_is_module_begin_env(Scheme_Comp_Env *env); @@ -624,7 +624,7 @@ static void make_kernel_env(void) scheme_install_type_writer(scheme_local_unbox_type, write_local); scheme_install_type_reader(scheme_local_unbox_type, read_local_unbox); scheme_install_type_writer(scheme_resolve_prefix_type, write_resolve_prefix); - scheme_install_type_reader(scheme_resolve_prefix_type, read_resolve_prefix); + scheme_install_type_reader2(scheme_resolve_prefix_type, read_resolve_prefix); REGISTER_SO(kernel_symbol); kernel_symbol = scheme_intern_symbol("#%kernel"); @@ -5513,7 +5513,7 @@ static Scheme_Object *write_resolve_prefix(Scheme_Object *obj) return tv; } -static Scheme_Object *read_resolve_prefix(Scheme_Object *obj) +static Scheme_Object *read_resolve_prefix(Scheme_Object *obj, Scheme_Object *insp) { Resolve_Prefix *rp; Scheme_Object *tv, *sv, **a, *stx; @@ -5546,7 +5546,7 @@ static Scheme_Object *read_resolve_prefix(Scheme_Object *obj) rp->num_stxes = SCHEME_VEC_SIZE(sv); rp->num_lifts = i; if (uses_unsafe) - rp->uses_unsafe = scheme_true; /* reset in read_marshalled */ + rp->uses_unsafe = insp; i = rp->num_toplevels; a = MALLOC_N(Scheme_Object *, i); diff --git a/src/mzscheme/src/read.c b/src/mzscheme/src/read.c index f2a6dcb7a4..526bf8395e 100644 --- a/src/mzscheme/src/read.c +++ b/src/mzscheme/src/read.c @@ -5062,7 +5062,7 @@ static Scheme_Object *read_compact_quote(CPort *port, int embedded) static Scheme_Object *read_marshalled(int type, CPort *port) { Scheme_Object *l; - Scheme_Type_Reader reader; + Scheme_Type_Reader2 reader; l = read_compact(port, 1); @@ -5076,17 +5076,11 @@ static Scheme_Object *read_marshalled(int type, CPort *port) scheme_ill_formed_code(port); } - l = reader(l); + l = reader(l, port->insp); if (!l) scheme_ill_formed_code(port); - if (type == scheme_resolve_prefix_type) { - /* If unsafe_insp is set, need to use the one in port: */ - if (((Resolve_Prefix *)l)->uses_unsafe) - ((Resolve_Prefix *)l)->uses_unsafe = port->insp; - } - return l; } @@ -5541,6 +5535,11 @@ void scheme_unmarshal_wrap_set(Scheme_Unmarshal_Tables *ut, ut->decoded[l] = 1; } +Scheme_Object *scheme_get_cport_inspector(struct CPort *rp) +{ + return rp->insp; +} + /*========================================================================*/ /* readtable support */ /*========================================================================*/ diff --git a/src/mzscheme/src/schpriv.h b/src/mzscheme/src/schpriv.h index b0f37a2134..ae50325f25 100644 --- a/src/mzscheme/src/schpriv.h +++ b/src/mzscheme/src/schpriv.h @@ -236,9 +236,10 @@ void scheme_free_dynamic_extensions(void); /* Type readers & writers for compiled code data */ typedef Scheme_Object *(*Scheme_Type_Reader)(Scheme_Object *list); +typedef Scheme_Object *(*Scheme_Type_Reader2)(Scheme_Object *list, Scheme_Object *insp); typedef Scheme_Object *(*Scheme_Type_Writer)(Scheme_Object *obj); -extern Scheme_Type_Reader *scheme_type_readers; +extern Scheme_Type_Reader2 *scheme_type_readers; extern Scheme_Type_Writer *scheme_type_writers; extern Scheme_Equal_Proc *scheme_type_equals; @@ -1801,6 +1802,7 @@ extern Scheme_Object *scheme_default_global_print_handler; /* Type readers & writers for compiled code data */ void scheme_install_type_reader(Scheme_Type type, Scheme_Type_Reader f); +void scheme_install_type_reader2(Scheme_Type type, Scheme_Type_Reader2 f); void scheme_install_type_writer(Scheme_Type type, Scheme_Type_Writer f); Scheme_Object *scheme_make_default_readtable(void); @@ -2545,6 +2547,8 @@ typedef struct Scheme_Unmarshal_Tables { char *decoded; } Scheme_Unmarshal_Tables; +Scheme_Object *scheme_get_cport_inspector(struct CPort *rp); + Scheme_Object *scheme_unmarshal_wrap_get(Scheme_Unmarshal_Tables *ut, Scheme_Object *wraps_key, int *_decoded); diff --git a/src/mzscheme/src/stxobj.c b/src/mzscheme/src/stxobj.c index 09a9cb9d55..2fef8c7d76 100644 --- a/src/mzscheme/src/stxobj.c +++ b/src/mzscheme/src/stxobj.c @@ -73,7 +73,7 @@ static Scheme_Object *syntax_recertify(int argc, Scheme_Object **argv); static Scheme_Object *lift_inactive_certs(Scheme_Object *o, int as_active); static Scheme_Object *write_free_id_info_prefix(Scheme_Object *obj); -static Scheme_Object *read_free_id_info_prefix(Scheme_Object *obj); +static Scheme_Object *read_free_id_info_prefix(Scheme_Object *obj, Scheme_Object *insp); static Scheme_Object *source_symbol; /* uninterned! */ static Scheme_Object *share_symbol; /* uninterned! */ @@ -629,7 +629,7 @@ void scheme_init_stx(Scheme_Env *env) scheme_install_type_writer(scheme_free_id_info_type, write_free_id_info_prefix); - scheme_install_type_reader(scheme_free_id_info_type, read_free_id_info_prefix); + scheme_install_type_reader2(scheme_free_id_info_type, read_free_id_info_prefix); } void scheme_init_stx_places() { @@ -7119,7 +7119,8 @@ static int ok_phase_index(Scheme_Object *o) { return ok_phase(o); } -static Scheme_Object *datum_to_module_renames(Scheme_Object *a, Scheme_Hash_Table *ht, int lex_ok) +static Scheme_Object *datum_to_module_renames(Scheme_Object *a, Scheme_Hash_Table *ht, int lex_ok, + Scheme_Unmarshal_Tables *ut) { int count, i; Scheme_Object *key, *p0, *p; @@ -7138,7 +7139,10 @@ static Scheme_Object *datum_to_module_renames(Scheme_Object *a, Scheme_Hash_Tabl if (SCHEME_PAIRP(p) && SCHEME_INTP(SCHEME_CAR(p))) { /* reconstruct inspector info */ Scheme_Object *insp; - insp = scheme_get_param(scheme_current_config(), MZCONFIG_CODE_INSPECTOR); + if (ut) + insp = scheme_get_cport_inspector(ut->rp); + else + insp = scheme_get_param(scheme_current_config(), MZCONFIG_CODE_INSPECTOR); if (!SAME_OBJ(scheme_make_integer(1), SCHEME_CAR(p))) { insp = CONS(scheme_make_inspector(insp), insp); } @@ -7485,7 +7489,7 @@ static Scheme_Object *datum_to_wraps(Scheme_Object *w, mns = SCHEME_CDR(mns); } - if (!datum_to_module_renames(a, mrn->ht, 0)) + if (!datum_to_module_renames(a, mrn->ht, 0, ut)) return_NULL; /* Extract free-id=? renames, if any */ @@ -7493,7 +7497,7 @@ static Scheme_Object *datum_to_wraps(Scheme_Object *w, Scheme_Hash_Table *ht; ht = scheme_make_hash_table(SCHEME_hash_ptr); mrn->free_id_renames = ht; - if (!datum_to_module_renames(SCHEME_CAR(mns), mrn->free_id_renames, 1)) + if (!datum_to_module_renames(SCHEME_CAR(mns), mrn->free_id_renames, 1, ut)) return_NULL; mns = SCHEME_CDR(mns); } @@ -7650,7 +7654,10 @@ Scheme_Object *cert_marks_to_certs(Scheme_Object *cert_marks, cert_marks = a; } - insp = scheme_get_param(scheme_current_config(), MZCONFIG_CODE_INSPECTOR); + if (ut) + insp = scheme_get_cport_inspector(ut->rp); + else + insp = scheme_get_param(scheme_current_config(), MZCONFIG_CODE_INSPECTOR); while (SCHEME_PAIRP(cert_marks)) { a = SCHEME_CAR(cert_marks); @@ -9168,9 +9175,9 @@ static Scheme_Object *write_free_id_info_prefix(Scheme_Object *obj) return vec; } -static Scheme_Object *read_free_id_info_prefix(Scheme_Object *obj) +static Scheme_Object *read_free_id_info_prefix(Scheme_Object *obj, Scheme_Object *insp) { - Scheme_Object *vec, *insp; + Scheme_Object *vec; int i; if (!SCHEME_VECTORP(obj) @@ -9182,10 +9189,8 @@ static Scheme_Object *read_free_id_info_prefix(Scheme_Object *obj) SCHEME_VEC_ELS(vec)[i] = SCHEME_VEC_ELS(obj)[i]; } - if (SCHEME_TRUEP(SCHEME_VEC_ELS(vec)[7])) { - insp = scheme_get_param(scheme_current_config(), MZCONFIG_CODE_INSPECTOR); + if (SCHEME_TRUEP(SCHEME_VEC_ELS(vec)[7])) SCHEME_VEC_ELS(vec)[7] = insp; - } vec->type = scheme_free_id_info_type; diff --git a/src/mzscheme/src/type.c b/src/mzscheme/src/type.c index 4f5f5b4a4a..9ec85a27d5 100644 --- a/src/mzscheme/src/type.c +++ b/src/mzscheme/src/type.c @@ -26,7 +26,7 @@ #include "schpriv.h" #include -Scheme_Type_Reader *scheme_type_readers; +Scheme_Type_Reader2 *scheme_type_readers; Scheme_Type_Writer *scheme_type_writers; Scheme_Equal_Proc *scheme_type_equals; Scheme_Primary_Hash_Proc *scheme_type_hash1s; @@ -54,7 +54,7 @@ static void init_type_arrays() allocmax = maxtype + 100; type_names = MALLOC_N(char *, allocmax); - scheme_type_readers = MALLOC_N_ATOMIC(Scheme_Type_Reader, allocmax); + scheme_type_readers = MALLOC_N_ATOMIC(Scheme_Type_Reader2, allocmax); n = allocmax * sizeof(Scheme_Type_Reader); memset((char *)scheme_type_readers, 0, n); @@ -295,10 +295,10 @@ Scheme_Type scheme_make_type(const char *name) memcpy(naya, type_names, maxtype * sizeof(char *)); type_names = (char **)naya; - naya = scheme_malloc_atomic(n = allocmax * sizeof(Scheme_Type_Reader)); + naya = scheme_malloc_atomic(n = allocmax * sizeof(Scheme_Type_Reader2)); memset((char *)naya, 0, n); - memcpy(naya, scheme_type_readers, maxtype * sizeof(Scheme_Type_Reader)); - scheme_type_readers = (Scheme_Type_Reader *)naya; + memcpy(naya, scheme_type_readers, maxtype * sizeof(Scheme_Type_Reader2)); + scheme_type_readers = (Scheme_Type_Reader2 *)naya; naya = scheme_malloc_atomic(n = allocmax * sizeof(Scheme_Type_Writer)); memset((char *)naya, 0, n); @@ -344,6 +344,14 @@ char *scheme_get_type_name(Scheme_Type t) } void scheme_install_type_reader(Scheme_Type t, Scheme_Type_Reader f) +{ + if (t < 0 || t >= maxtype) + return; + + scheme_type_readers[t] = (Scheme_Type_Reader2)f; +} + +void scheme_install_type_reader2(Scheme_Type t, Scheme_Type_Reader2 f) { if (t < 0 || t >= maxtype) return;