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

fix unsafe-immutable-hash-... on hash table from read

Browse Source 
When `read` parses a literal hash table, it inserts an placeholder
just in case it's needed for cycles. The `unsafe-immutable-hash-...`
operations in some cases did not detect and remove the placeholder.

Closes #1376

Merge to v6.6
This commit is contained in:
Matthew Flatt 2016-07-15 06:21:55 -06:00
parent ad2c229af1
commit ca6c67be68
2 changed files with 16 additions and 2 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

14
pkgs/racket-test-core/tests/racket/unsafe.rktl
View File

@ -679,4 +679,18 @@
(err/rt-test
(unsafe-weak-hash-iterate-next ht i) exn:fail:contract? err-msg)))
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Check that `unsafe-immutable-hash-...` proplerly handles an
;; indirection created by `read`:
(test '((a . 1) (b . 2))
sort
(for/list (((k v) (in-immutable-hash (read (open-input-string "#hash((a . 1) (b . 2))")))))
(cons k v))
<
#:key cdr)
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(report-errs)

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

@ -2885,6 +2885,7 @@ XFORM_NONGCING void scheme_unsafe_hash_tree_subtree(Scheme_Object *obj, Scheme_O
subtree = (Scheme_Hash_Tree *)SCHEME_CHAPERONE_VAL(obj);
else
subtree = (Scheme_Hash_Tree *)obj;
subtree = resolve_placeholder(subtree);
i = SCHEME_INT_VAL(args);
while (i >= (1<<(2*mzHAMT_LOG_WORD_SIZE))) {
subtree = (Scheme_Hash_Tree *)subtree->els[i & ((1<<mzHAMT_LOG_WORD_SIZE)-1)];
@ -2916,6 +2917,7 @@ Scheme_Object *scheme_unsafe_hash_tree_next(Scheme_Hash_Tree *ht, Scheme_Object
stack = SCHEME_CDDR(args);
level = -1; /* -1 = too big */
} else {
ht = resolve_placeholder(ht);
i = SCHEME_INT_VAL(args);
level = 0;
while (i >= (1<<(2*mzHAMT_LOG_WORD_SIZE))) {
@ -2928,8 +2930,6 @@ Scheme_Object *scheme_unsafe_hash_tree_next(Scheme_Hash_Tree *ht, Scheme_Object
i = i & ((1<<mzHAMT_LOG_WORD_SIZE)-1);
}
/* ht = resolve_placeholder(ht); /\* only check this in iterate-first *\/ */
while (1) {
if (!i) { /* pop up the tree */
if (level == -1) {