diff --git a/collects/tests/racket/place-struct-info.rkt b/collects/tests/racket/place-struct-info.rkt new file mode 100644 index 0000000000..fcb2fa9301 --- /dev/null +++ b/collects/tests/racket/place-struct-info.rkt @@ -0,0 +1,20 @@ +#lang racket/base +(require racket/place) + +;; Some results from `struct-type-info' may be created on demand. +;; Check that any sharing of `struct:exn' across places handles +;; that on-demand creation correctly. + +(define (go) + (place + pch + (define-values (sym init auto ref set! imms par skip?) + (struct-type-info struct:exn)) + (unless (procedure? ref) + (error "bad reference procedure")) + (collect-garbage))) + +(module+ main + (void (place-wait (go))) + (collect-garbage) + (void (place-wait (go)))) diff --git a/src/racket/src/error.c b/src/racket/src/error.c index 837ac566ce..cd1a7aec90 100644 --- a/src/racket/src/error.c +++ b/src/racket/src/error.c @@ -4313,6 +4313,7 @@ void scheme_init_exn(Scheme_Env *env) if (exn_table[i].count) { Scheme_Object **values; + scheme_force_struct_type_info((Scheme_Struct_Type *)exn_table[i].type); values = scheme_make_struct_values(exn_table[i].type, exn_table[i].names, exn_table[i].count, diff --git a/src/racket/src/schpriv.h b/src/racket/src/schpriv.h index 9e5a1e27af..e924d9476b 100644 --- a/src/racket/src/schpriv.h +++ b/src/racket/src/schpriv.h @@ -851,6 +851,8 @@ Scheme_Object *scheme_make_serialized_struct_instance(Scheme_Object *s, int num_ Scheme_Object *scheme_struct_getter(int argc, Scheme_Object **args, Scheme_Object *prim); Scheme_Object *scheme_struct_setter(int argc, Scheme_Object **args, Scheme_Object *prim); +void scheme_force_struct_type_info(Scheme_Struct_Type *stype); + Scheme_Object *scheme_extract_checked_procedure(int argc, Scheme_Object **argv); Scheme_Object *scheme_rename_struct_proc(Scheme_Object *p, Scheme_Object *sym); diff --git a/src/racket/src/struct.c b/src/racket/src/struct.c index bfa0c73ffd..db193d4f2f 100644 --- a/src/racket/src/struct.c +++ b/src/racket/src/struct.c @@ -2627,18 +2627,8 @@ static Scheme_Object *check_type_and_inspector(const char *who, int always, int return insp; } -static void get_struct_type_info(int argc, Scheme_Object *argv[], Scheme_Object **a, int always) +void scheme_force_struct_type_info(Scheme_Struct_Type *stype) { - Scheme_Struct_Type *stype, *parent; - Scheme_Object *insp, *ims; - int p, cnt; - - insp = check_type_and_inspector("struct-type-info", always, argc, argv); - if (SCHEME_NP_CHAPERONEP(argv[0])) - stype = (Scheme_Struct_Type *)SCHEME_CHAPERONE_VAL(argv[0]); - else - stype = (Scheme_Struct_Type *)argv[0]; - /* Make sure generic accessor and mutator are created: */ if (!stype->accessor) { Scheme_Object *p; @@ -2651,6 +2641,21 @@ static void get_struct_type_info(int argc, Scheme_Object *argv[], Scheme_Object p = make_struct_proc(stype, fn, SCHEME_GEN_SETTER, 0); stype->mutator = p; } +} + +static void get_struct_type_info(int argc, Scheme_Object *argv[], Scheme_Object **a, int always) +{ + Scheme_Struct_Type *stype, *parent; + Scheme_Object *insp, *ims; + int p, cnt; + + insp = check_type_and_inspector("struct-type-info", always, argc, argv); + if (SCHEME_NP_CHAPERONEP(argv[0])) + stype = (Scheme_Struct_Type *)SCHEME_CHAPERONE_VAL(argv[0]); + else + stype = (Scheme_Struct_Type *)argv[0]; + + scheme_force_struct_type_info(stype); if (stype->name_pos) parent = stype->parent_types[stype->name_pos - 1];