suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

fix struct->vector on some renamed procedures

Browse Source 
The repair is to give the structure type a name symbol. The rest is
cleanup and tests.

Closes #2454
This commit is contained in:
Matthew Flatt 2019-01-25 12:03:38 -07:00
parent a97b3739a3
commit a80952e05f
4 changed files with 32 additions and 15 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

17
pkgs/racket-test-core/tests/racket/struct.rktl
View File

@ -751,6 +751,23 @@
(test 10 a-x (make-b 10 20 30))
(test 100 a-x (make-c 100 200 300 400)))
;; ------------------------------------------------------------
;; struct->vector on non `struct?`
(test #f struct? void)
(test #f struct? (procedure-rename void 'still-void))
(test #f struct? (procedure-reduce-arity void 1))
(test #f struct? (cons 1 2))
(test #f struct? (box 1))
(test #f struct? (vector 1 2 3))
(test '#(struct:procedure ...) struct->vector void)
(test '#(struct:procedure ...) struct->vector (procedure-rename void 'still-void))
(test '#(struct:procedure ...) struct->vector (procedure-reduce-arity void 1))
(test '#(struct:pair ...) struct->vector (cons 1 2))
(test '#(struct:box ...) struct->vector (box 1))
(test '#(struct:vector ...) struct->vector (vector 1 2 3))
;; ------------------------------------------------------------
;; Prefab

2
racket/src/racket/src/fun.c
View File

@ -2813,7 +2813,7 @@ void scheme_init_reduced_proc_struct(Scheme_Startup_Env *env)
while (insp->superior->superior) {
insp = insp->superior;
}
scheme_reduced_procedure_struct = scheme_make_struct_type2(NULL,
scheme_reduced_procedure_struct = scheme_make_struct_type2(scheme_intern_symbol("procedure"),
NULL,
(Scheme_Object *)insp,
4, 0,

24
racket/src/racket/src/struct.c
View File

@ -4739,14 +4739,14 @@ Scheme_Struct_Type *scheme_make_prefab_struct_type_raw(Scheme_Object *base,
return struct_type;
}
static Scheme_Struct_Type *scheme_make_prefab_struct_type(Scheme_Object *base,
static Scheme_Struct_Type *scheme_make_prefab_struct_type(Scheme_Object *name,
Scheme_Object *parent,
int num_fields,
int num_uninit_fields,
Scheme_Object *uninit_val,
char *immutable_array)
{
return scheme_make_prefab_struct_type_raw(base,
return scheme_make_prefab_struct_type_raw(name,
parent,
num_fields,
num_uninit_fields,
@ -4754,7 +4754,7 @@ static Scheme_Struct_Type *scheme_make_prefab_struct_type(Scheme_Object *base,
immutable_array);
}
static Scheme_Object *_make_struct_type(Scheme_Object *base,
static Scheme_Object *_make_struct_type(Scheme_Object *name,
Scheme_Object *parent,
Scheme_Object *inspector,
int num_fields,
@ -4790,7 +4790,7 @@ static Scheme_Object *_make_struct_type(Scheme_Object *base,
struct_type->parent_types[j] = parent_type->parent_types[j];
}
struct_type->name = base;
struct_type->name = name;
struct_type->nonfail_constructor = (parent_type ? parent_type->nonfail_constructor : 1);
struct_type->num_slots = num_fields + num_uninit_fields + (parent_type ? parent_type->num_slots : 0);
@ -5075,7 +5075,7 @@ static Scheme_Object *_make_struct_type(Scheme_Object *base,
return (Scheme_Object *)struct_type;
}
Scheme_Object *scheme_make_struct_type(Scheme_Object *base,
Scheme_Object *scheme_make_struct_type(Scheme_Object *name,
Scheme_Object *parent,
Scheme_Object *inspector,
int num_fields, int num_uninit,
@ -5083,7 +5083,7 @@ Scheme_Object *scheme_make_struct_type(Scheme_Object *base,
Scheme_Object *properties,
Scheme_Object *guard)
{
return _make_struct_type(base,
return _make_struct_type(name,
parent, inspector,
num_fields, num_uninit,
uninit_val, properties,
@ -5091,7 +5091,7 @@ Scheme_Object *scheme_make_struct_type(Scheme_Object *base,
guard);
}
Scheme_Object *scheme_make_struct_type2(Scheme_Object *base,
Scheme_Object *scheme_make_struct_type2(Scheme_Object *name,
Scheme_Object *parent,
Scheme_Object *inspector,
int num_fields, int num_uninit,
@ -5101,7 +5101,7 @@ Scheme_Object *scheme_make_struct_type2(Scheme_Object *base,
char *immutable_array,
Scheme_Object *guard)
{
return _make_struct_type(base,
return _make_struct_type(name,
parent, inspector,
num_fields, num_uninit,
uninit_val, properties,
@ -5109,14 +5109,14 @@ Scheme_Object *scheme_make_struct_type2(Scheme_Object *base,
guard);
}
Scheme_Object *scheme_make_struct_type_from_string(const char *base,
Scheme_Object *scheme_make_struct_type_from_string(const char *name,
Scheme_Object *parent,
int num_fields,
Scheme_Object *props,
Scheme_Object *guard,
int immutable)
{
Scheme_Object *basesym, *r;
Scheme_Object *namesym, *r;
char *immutable_array = NULL;
if (immutable) {
@ -5124,9 +5124,9 @@ Scheme_Object *scheme_make_struct_type_from_string(const char *base,
memset(immutable_array, 1, num_fields);
}
basesym = scheme_intern_exact_symbol(base, strlen(base));
namesym = scheme_intern_exact_symbol(name, strlen(name));
r = _make_struct_type(basesym,
r = _make_struct_type(namesym,
parent, scheme_false,
num_fields, 0,
NULL, props,

4
racket/src/racket/src/type.c
View File

@ -112,8 +112,8 @@ scheme_init_type ()
set_name(scheme_eval_waiting_type, "<eval-waiting>");
set_name(scheme_void_type, "<void>");
set_name(scheme_prim_type, "<primitive>");
set_name(scheme_closed_prim_type, "<primitive-closure>");
set_name(scheme_prim_type, "<procedure>");
set_name(scheme_closed_prim_type, "<procedure>");
set_name(scheme_closure_type, "<procedure>");
set_name(scheme_native_closure_type, "<procedure>");
set_name(scheme_cont_type, "<continuation>");