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

repairs for {impersonator,chaperone}-struct

Browse Source 
Commit 0b71b8481d didn't have the tests that I thought I had
written, and so the changes were unsurprisingly buggy.
This commit is contained in:
Matthew Flatt 2014-10-21 20:46:13 -06:00
parent 2d422da25a
commit d9f2a84951
2 changed files with 51 additions and 8 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

37
pkgs/racket-pkgs/racket-test/tests/racket/chaperone.rktl
View File

@ -584,7 +584,42 @@
(err/rt-test (a-x a3))) (err/rt-test (a-x a3)))
(begin (begin
(test 'bad a-x a2) (test 'bad a-x a2)
(test 'bad a-x a3))))))) (test 'bad a-x a3)))))
(let* ([a1 (make-a 0 1)]
[a2 (chaperone-struct a1
a-x #f
set-a-x! #f
prop:blue 'blue)]
[a3 (chaperone-struct a1
set-a-x! #f
prop:blue 'cyan)])
(test #f eq? a1 a2)
(test #f eq? a1 a3)
(test #t eq? a1 (chaperone-struct a1
a-x #f
set-a-x! #f))
(test #t eq? a1 (chaperone-struct a1
set-a-x! #f))
(test 0 a-x a2)
(test (void) set-a-x! a2 1)
(test 1 a-x a2)
(test 'blue blue-ref a2)
(test 'cyan blue-ref a3))
(when is-chaperone
(let* ([p1 (make-p 0)]
[p2 (chaperone-struct p1
p-u #f
green-ref #f
prop:blue 'blue)])
(test #t eq? p1 (chaperone-struct p1
p-u #f
green-ref #f))
(test #t eq? p1 (chaperone-struct p1
p-u #f))
(test #t eq? p1 (chaperone-struct p1
p-u #f))
(test 0 p-u p2)
(test 'green green-ref p2)))))
;; test to see if the guard is actually called even when impersonated ;; test to see if the guard is actually called even when impersonated
(let () (let ()

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

@ -5800,7 +5800,7 @@ static Scheme_Object *do_chaperone_struct(const char *name, int is_impersonator,
const char *kind; const char *kind;
Scheme_Hash_Tree *props = NULL, *red_props = NULL, *empty_red_props = NULL, *setter_positions = NULL; Scheme_Hash_Tree *props = NULL, *red_props = NULL, *empty_red_props = NULL, *setter_positions = NULL;
intptr_t field_pos; intptr_t field_pos;
int empty_si_chaperone = 0, *empty_redirects = NULL; int empty_si_chaperone = 0, *empty_redirects = NULL, has_redirect = 0;
if (argc == 1) return argv[0]; if (argc == 1) return argv[0];
@ -5995,27 +5995,32 @@ static Scheme_Object *do_chaperone_struct(const char *name, int is_impersonator,
} }
if (prop) { if (prop) {
if (SCHEME_TRUEP(prop)) { if (SCHEME_TRUEP(proc)) {
if (!red_props) if (!red_props)
red_props = scheme_make_hash_tree(0); red_props = scheme_make_hash_tree(0);
red_props = scheme_hash_tree_set(red_props, prop, proc); red_props = scheme_hash_tree_set(red_props, prop, proc);
has_redirect = 1;
} else { } else {
if (!empty_red_props) if (!empty_red_props)
empty_red_props = scheme_make_hash_tree(0); empty_red_props = scheme_make_hash_tree(0);
empty_red_props = scheme_hash_tree_set(empty_red_props, prop, proc); empty_red_props = scheme_hash_tree_set(empty_red_props, prop, proc);
} }
} else if (st) { } else if (st) {
if (SCHEME_TRUEP(proc)) if (SCHEME_TRUEP(proc)) {
SCHEME_VEC_ELS(redirects)[PRE_REDIRECTS + offset + field_pos] = proc; SCHEME_VEC_ELS(redirects)[PRE_REDIRECTS + offset + field_pos] = proc;
else { has_redirect = 1;
if (!empty_redirects) } else {
if (!empty_redirects) {
empty_redirects = MALLOC_N_ATOMIC(int, 2 * stype->num_slots); empty_redirects = MALLOC_N_ATOMIC(int, 2 * stype->num_slots);
memset(empty_redirects, 0, sizeof(int) * 2 * stype->num_slots);
}
empty_redirects[offset + field_pos] = 1; empty_redirects[offset + field_pos] = 1;
} }
} else { } else {
if (SCHEME_TRUEP(proc)) if (SCHEME_TRUEP(proc)) {
si_chaperone = proc; si_chaperone = proc;
else has_redirect = 1;
} else
empty_si_chaperone = 1; empty_si_chaperone = 1;
} }
} }
@ -6039,6 +6044,9 @@ static Scheme_Object *do_chaperone_struct(const char *name, int is_impersonator,
} }
} }
if (!has_redirect && !props)
return argv[0];
if (!redirects) { if (!redirects) {
/* a non-structure chaperone */ /* a non-structure chaperone */
redirects = scheme_make_vector(1, NULL); redirects = scheme_make_vector(1, NULL);