From a097b2ef6ac9e8e0549cd4ca6f0ef09cab47a813 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Mon, 3 May 2010 17:12:08 -0600 Subject: [PATCH] fix chaperone-hash to be more consistent with key handling --- .../scribblings/reference/chaperones.scrbl | 27 +++++++------ collects/tests/racket/chaperone.rktl | 30 ++++++++------ src/racket/src/list.c | 39 ++++++++++++------- 3 files changed, 60 insertions(+), 36 deletions(-) diff --git a/collects/scribblings/reference/chaperones.scrbl b/collects/scribblings/reference/chaperones.scrbl index 7e0fdb0c45..8699fbbacb 100644 --- a/collects/scribblings/reference/chaperones.scrbl +++ b/collects/scribblings/reference/chaperones.scrbl @@ -231,18 +231,20 @@ or override chaperone-property values of @scheme[bx].} @defproc[(chaperone-hash [hash hash?] - [ref-proc (hash? any/c any/c . -> . any/c)] - [set-proc (hash? any/c any/c . -> . any/c)] + [ref-proc (hash? any/c . -> . (values + any/c + (hash? any/c any/c . -> . any/c)))] + [set-proc (hash? any/c any/c . -> . (values any/c any/c))] [remove-proc (hash? any/c . -> . any/c)] [key-proc (hash? any/c . -> . any/c)] [prop chaperone-property?] [val any] ... ...) - (and/c vector? chaperone?)]{ + (and/c hash? chaperone?)]{ Returns a chaperoned value like @scheme[hash], but with @scheme[hash-ref], @scheme[hash-set!] or @scheme[hash-set] (as applicable) and @scheme[hash-remove] or @scheme[hash-remove!] (as -application) operations on the chaperoned hash table redirected. When +application) operations on the chaperoned hash table redirected. When @scheme[hash-set] or @scheme[hash-remove] is used on a chaperoned hash table, the resulting hash table is given all of the chaperones of the given hash table. In addition, operations like @@ -252,16 +254,19 @@ from the table. Operations like @scheme[hash-iterate-value] or @scheme[hash-iterate-map] implicitly use @scheme[hash-ref] and therefore redirect through @scheme[ref-proc]. -The @scheme[ref-proc] must accept @scheme[hash], an key passed -@scheme[hash-ref], and the value that @scheme[hash-ref] on -@scheme[hash] produces for the given key; it must produce the same -value or a chaperone of the value, which is the result of -@scheme[hash-ref] on the chaperone. +The @scheme[ref-proc] must accept @scheme[hash] and a key passed +@scheme[hash-ref]. It must returned the key or a chaperone of the key +as well as a procedure. The returned procedure is called only if the +returned key is found in @scheme[hash] via @scheme[hash-ref], in which +case the procedure is called with @scheme[hash], the previously +returned key, and the found value. The returned procedure must itself +return the found value or a chaperone of the value. The @scheme[set-proc] must accept @scheme[hash], a key passed to @scheme[hash-set!] or @scheme[hash-set], and the value passed to -@scheme[hash-set!] or @scheme[hash-set]; it must produce the same -value or a chaperone of the value, which is used with +@scheme[hash-set!] or @scheme[hash-set]; it must produce two values: +the same key or a chaperone of the key and the same value or a +chaperone of the value. The returned key and value are used with @scheme[hash-set!] or @scheme[hash-set] on the original @scheme[hash] to install the value. diff --git a/collects/tests/racket/chaperone.rktl b/collects/tests/racket/chaperone.rktl index 3face65c7d..5bc13a6751 100644 --- a/collects/tests/racket/chaperone.rktl +++ b/collects/tests/racket/chaperone.rktl @@ -430,7 +430,8 @@ (for-each (lambda (make-hash) (let ([h (chaperone-hash (make-hash) - (lambda (h k v) v) (lambda (h k v) (values k v)) + (lambda (h k) (values k (lambda (h k v) v))) + (lambda (h k v) (values k v)) (lambda (h k) k) (lambda (h k) k))]) (test #t chaperone? h) (test #t hash? h) @@ -450,10 +451,12 @@ [remove-k #f] [access-k #f] [h2 (chaperone-hash h1 - (lambda (h k v) + (lambda (h k) (set! get-k k) - (set! get-v v) - v) + (values k + (lambda (h k v) + (set! get-v v) + v))) (lambda (h k v) (set! set-k k) (set! set-v v) @@ -470,8 +473,9 @@ (test #t (format "~s ~s ~s" proc val got) (equal? val got))))]) (test #f hash-ref h1 'key #f) (test '(#f #f #f #f #f #f) list get-k get-v set-k set-v remove-k access-k) - (test #f hash-ref h2 'key #f) - (test '(#f #f #f #f #f #f) list get-k get-v set-k set-v remove-k access-k) + (test 'nope hash-ref h2 'key 'nope) + (test '(key #f #f #f #f #f) list get-k get-v set-k set-v remove-k access-k) + (set! get-k #f) (test (void) hash-set! h1 'key 'val) (test '(#f #f #f #f #f #f) list get-k get-v set-k set-v remove-k access-k) (test 'val hash-ref h1 'key #f) @@ -508,10 +512,12 @@ [remove-k #f] [access-k #f] [h2 (chaperone-hash h1 - (lambda (h k v) + (lambda (h k) (set! get-k k) - (set! get-v v) - v) + (values k + (lambda (h k v) + (set! get-v v) + v))) (lambda (h k v) (set! set-k k) (set! set-v v) @@ -528,10 +534,10 @@ (test #t (format "~s ~s ~s" proc val got) (equal? val got))))]) (test #f hash-ref h1 'key #f) (test '(#f #f #f #f #f #f) list get-k get-v set-k set-v remove-k access-k) - (test #f hash-ref h2 'key #f) - (test '(#f #f #f #f #f #f) list get-k get-v set-k set-v remove-k access-k) + (test 'nope hash-ref h2 'key 'nope) + (test '(key #f #f #f #f #f) list get-k get-v set-k set-v remove-k access-k) (let ([h2 (hash-set h2 'key 'val)]) - (test '(#f #f key val #f #f) list get-k get-v set-k set-v remove-k access-k) + (test '(key #f key val #f #f) list get-k get-v set-k set-v remove-k access-k) (test 'val hash-ref h2 'key #f) (test '(key val key val #f #f) list get-k get-v set-k set-v remove-k access-k) (let ([h2 (hash-set h2 'key2 'val2)]) diff --git a/src/racket/src/list.c b/src/racket/src/list.c index cac3c2e694..ef3836a01f 100644 --- a/src/racket/src/list.c +++ b/src/racket/src/list.c @@ -2601,7 +2601,7 @@ static Scheme_Object *chaperone_hash(int argc, Scheme_Object **argv) if (!SCHEME_HASHTP(val) && !SCHEME_HASHTRP(val) && !SCHEME_BUCKTP(val)) scheme_wrong_type("chaperone-hash", "hash", 0, argc, argv); - scheme_check_proc_arity("chaperone-hash", 3, 1, argc, argv); /* ref */ + scheme_check_proc_arity("chaperone-hash", 2, 1, argc, argv); /* ref */ scheme_check_proc_arity("chaperone-hash", 3, 2, argc, argv); /* set! */ scheme_check_proc_arity("chaperone-hash", 2, 3, argc, argv); /* remove */ scheme_check_proc_arity("chaperone-hash", 2, 4, argc, argv); /* key */ @@ -2721,10 +2721,9 @@ static Scheme_Object *chaperone_hash_op(const char *who, Scheme_Object *o, Schem } #endif - if (mode == 0) { - orig = chaperone_hash_op(who, px->prev, k, v, mode); - if (!orig) return NULL; - } else if ((mode == 2) || (mode == 3)) + if (mode == 0) + orig = NULL; + else if ((mode == 2) || (mode == 3)) orig = k; else orig = v; @@ -2733,7 +2732,6 @@ static Scheme_Object *chaperone_hash_op(const char *who, Scheme_Object *o, Schem /* chaperone was on property accessors */ o = orig; } else { - red = SCHEME_BOX_VAL(px->redirects); red = SCHEME_VEC_ELS(red)[mode]; @@ -2741,17 +2739,13 @@ static Scheme_Object *chaperone_hash_op(const char *who, Scheme_Object *o, Schem a[1] = k; a[2] = orig; - if (mode == 0) { - /* hash-ref */ - o = _scheme_apply(red, 3, a); - what = "result"; - } else if (mode == 1) { + if ((mode == 0) || (mode == 1)) { /* hash-set! */ Scheme_Object **vals; int cnt; Scheme_Thread *p; - o = _scheme_apply_multi(red, 3, a); + o = _scheme_apply_multi(red, ((mode == 0) ? 2 : 3), a); if (SAME_OBJ(o, SCHEME_MULTIPLE_VALUES)) { p = scheme_current_thread; @@ -2781,7 +2775,26 @@ static Scheme_Object *chaperone_hash_op(const char *who, Scheme_Object *o, Schem k); k = vals[0]; o = vals[1]; - what = "value"; + + if (mode == 0) { + red = o; + if (!scheme_check_proc_arity(NULL, 3, 1, 2, vals)) + scheme_raise_exn(MZEXN_FAIL_CONTRACT, + "%s: chaperone produced second value that is not a procedure (arity 3): %V", + who, + red); + + orig = chaperone_hash_op(who, px->prev, k, v, mode); + if (!orig) return NULL; + + /* hash-ref */ + a[0] = px->prev; + a[1] = k; + a[2] = orig; + o = _scheme_apply(red, 3, a); + what = "result"; + } else + what = "value"; } else { /* hash-remove! and key extraction */ o = _scheme_apply(red, 2, a);