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

change id-tables so iterators not invalidated by mutation of existing keys

Browse Source 
id-table fixes

test for id-table
This commit is contained in:
Ryan Culpepper 2012-07-20 01:13:32 -04:00
parent abb616e6d6
commit 510d3937a7
2 changed files with 196 additions and 107 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

269
collects/syntax/private/id-table.rkt
View File

@ -5,7 +5,146 @@
;; No-contract version. ;; No-contract version.
(define-struct id-table-iter (a b)) (define-struct id-table (hash phase))
;; where hash maps symbol => (listof (cons identifier value))
;; phase is a phase-level (integer or #f)
(define (make-id-table/constructor who init-dict phase make identifier->symbol identifier=?)
(let ([t (make (make-hasheq) phase)])
(for ([(k v) (in-dict init-dict)])
(unless (identifier? k)
(raise-type-error who "dictionary with identifier keys" init-dict))
(id-table-set! who t k v identifier->symbol identifier=?))
t))
(define (make-immutable-id-table/constructor who init-dict phase make identifier->symbol identifier=?)
(for/fold ([t (make '#hasheq() phase)])
([(k v) (in-dict init-dict)])
(unless (identifier? k)
(raise-type-error who "dictionary with identifier keys" init-dict))
(id-table-set/constructor who t k v make identifier->symbol identifier=?)))
(define (id-table-ref who d id default identifier->symbol identifier=?)
(let ([phase (id-table-phase d)])
(let ([i (for/first ([i (in-list (hash-ref (id-table-hash d)
(identifier->symbol id phase)
null))]
#:when (identifier=? (car i) id phase))
i)])
(if i
(cdr i)
(cond [(eq? default not-given)
(error who "no mapping for ~e" id)]
[(procedure? default) (default)]
[else default])))))
(define (id-table-set! who d id v identifier->symbol identifier=?)
(let* ([phase (id-table-phase d)]
[sym (identifier->symbol id phase)]
[l (hash-ref (id-table-hash d) sym null)]
[new-l (alist-set identifier=? phase l id v)])
(hash-set! (id-table-hash d) sym new-l)))
(define (id-table-remove! who d id identifier->symbol identifier=?)
(let* ([phase (id-table-phase d)]
[sym (identifier->symbol id phase)]
[l (hash-ref (id-table-hash d) sym null)]
[newl (alist-remove identifier=? phase l id)])
(if (pair? newl)
(hash-set! (id-table-hash d) sym newl)
(hash-remove! (id-table-hash d) sym))))
(define (id-table-set/constructor who d id v constructor identifier->symbol identifier=?)
(let* ([phase (id-table-phase d)]
[sym (identifier->symbol id phase)]
[l (hash-ref (id-table-hash d) sym null)]
[new-l (alist-set identifier=? phase l id v)])
(constructor (hash-set (id-table-hash d) sym new-l)
phase)))
(define (id-table-remove/constructor who d id constructor identifier->symbol identifier=?)
(let* ([phase (id-table-phase d)]
[sym (identifier->symbol id phase)]
[l (hash-ref (id-table-hash d) sym null)]
[newl (alist-remove identifier=? phase l id)])
(constructor
(if (pair? newl)
(hash-set (id-table-hash d) sym newl)
(hash-remove (id-table-hash d) sym))
phase)))
(define (id-table-count d)
(apply + (hash-map (id-table-hash d) (lambda (k v) (length v)))))
(define (id-table-for-each d p)
(define (pp i) (p (car i) (cdr i)))
(hash-for-each (id-table-hash d) (lambda (k v) (for-each pp v))))
(define (id-table-map d f)
(define (fp i) (f (car i) (cdr i)))
(apply append (hash-map (id-table-hash d) (lambda (k v) (map fp v)))))
(define-struct id-table-iter (d a br b))
;; where d is an id-table
;; a is hash iter
;; br is non-empty-alist "root"
;; b is non-empty-alist current position, b = (list-tail br N) for some N
#|
For mutable table, the alist iter can be invalidated because we replace entire
alist on update. So, we store alist root and if root has been replaced, we
try to re-find the previous position in the new alist (see rebase-iter).
Not an issue for immutable tables.
Notes (FIXME?):
- we don't (can't?) check that hash iter is okay (would require hash revision?)
so internal errors raised by hash-iterate-{next,value} can slip out
|#
(define (id-table-iterate-first d)
(let* ([h (id-table-hash d)]
[a (hash-iterate-first h)])
(and a
(let ([b (hash-iterate-value h a)])
(make-id-table-iter d a b b)))))
(define (id-table-iterate-next who d pos)
(let-values ([(h a br b) (rebase-iter who d pos)])
(let ([b2 (cdr b)])
(if (pair? b2)
(make-id-table-iter d a br b2)
(let ([a2 (hash-iterate-next h a)])
(and a2
(let ([b2 (hash-iterate-value h a2)])
(make-id-table-iter d a2 b2 b2))))))))
(define (id-table-iterate-key who d pos)
(let-values ([(h a br b) (rebase-iter who d pos)])
(caar b)))
(define (id-table-iterate-value who d pos)
(let-values ([(h a br b) (rebase-iter who d pos)])
(cdar b)))
(define (rebase-iter who d pos)
(unless (eq? d (id-table-iter-d pos))
(error who "invalid iteration position for identifier table"))
(let* ([h (id-table-hash d)]
[a (id-table-iter-a pos)]
[br (id-table-iter-br pos)]
[b (id-table-iter-b pos)]
[v (hash-iterate-value h a)]) ;; FIXME: may expose internal error
(if (eq? br v)
(values h a br b)
;; hash entry has changed from br to v, so find (caar b) in v
(let ([id (caar b)])
(let loop ([v* v])
(cond [(null? v*)
(error who "invalid iteration position for identifier table")]
[(eq? (caar v*) id) ;; relies on id staying same; see alist-set
(values h a v v*)]
[else (loop (cdr v*))]))))))
;; ======== ;; ========
@ -20,7 +159,9 @@
[(identifier=? (caar l) id phase) [(identifier=? (caar l) id phase)
(if (eq? v (cdar l)) ;; idempotent; just leave it alone (if (eq? v (cdar l)) ;; idempotent; just leave it alone
l l
(cons (cons id v) (cdr l)))] ;; Note: use (caar l) instead of id so that rebase-iter
;; above can find entry by stxobj identity.
(cons (cons (caar l) v) (cdr l)))]
[else [else
(let ([rest* (loop (cdr l))]) (let ([rest* (loop (cdr l))])
(if (eq? (cdr l) rest*) (if (eq? (cdr l) rest*)
@ -68,8 +209,6 @@
(format-id #'idtbl "immutable-~a?" (syntax-e #'idtbl))]) (format-id #'idtbl "immutable-~a?" (syntax-e #'idtbl))])
(define (s x) (format-id #'idtbl "~a~a" (syntax-e #'idtbl) x)) (define (s x) (format-id #'idtbl "~a~a" (syntax-e #'idtbl) x))
(with-syntax ([idtbl? (s '?)] (with-syntax ([idtbl? (s '?)]
[idtbl-hash (s '-hash)]
[idtbl-phase (s '-phase)]
[idtbl-ref (s '-ref)] [idtbl-ref (s '-ref)]
[idtbl-set! (s '-set!)] [idtbl-set! (s '-set!)]
[idtbl-set (s '-set)] [idtbl-set (s '-set)]
@ -92,123 +231,42 @@
(define (make-idtbl [init-dict null] (define (make-idtbl [init-dict null]
#:phase [phase (syntax-local-phase-level)]) #:phase [phase (syntax-local-phase-level)])
(let ([t (mutable-idtbl (make-hasheq) phase)]) (make-id-table/constructor 'make-idtbl init-dict phase mutable-idtbl
(for ([(k v) (in-dict init-dict)]) identifier->symbol identifier=?))
(unless (identifier? k)
(raise-type-error 'make-idtbl
"dictionary with identifier keys" init-dict))
(idtbl-set! t k v))
t))
(define (make-immutable-idtbl [init-dict null] (define (make-immutable-idtbl [init-dict null]
#:phase [phase (syntax-local-phase-level)]) #:phase [phase (syntax-local-phase-level)])
(for/fold ([t (immutable-idtbl '#hasheq() phase)]) (make-immutable-id-table/constructor 'make-immutable-idtbl init-dict phase immutable-idtbl
([(k v) (in-dict init-dict)]) identifier->symbol identifier=?))
(unless (identifier? k)
(raise-type-error 'make-immutable-idtbl
"dictionary with identifier keys" init-dict))
(idtbl-set t k v)))
(define (idtbl-ref d id [default not-given]) (define (idtbl-ref d id [default not-given])
(let ([phase (idtbl-phase d)]) (id-table-ref 'idtbl-ref d id default identifier->symbol identifier=?))
(let ([i (ormap (lambda (i) (and (identifier=? (car i) id phase) i))
(hash-ref (idtbl-hash d)
(identifier->symbol id phase)
null))])
(if i
(cdr i)
(cond [(eq? default not-given)
(error 'idtbl-ref "no mapping for ~e" id)]
[(procedure? default) (default)]
[else default])))))
(define (idtbl-set! d id v) (define (idtbl-set! d id v)
(let* ([phase (idtbl-phase d)] (id-table-set! 'idtbl-set! d id v identifier->symbol identifier=?))
[sym (identifier->symbol id phase)]
[l (hash-ref (idtbl-hash d) sym null)])
(hash-set! (idtbl-hash d)
sym
(alist-set identifier=? phase l id v))))
(define (idtbl-set/constructor d id v constructor) (define (idtbl-set/constructor d id v constructor)
(let* ([phase (idtbl-phase d)] (id-table-set/constructor 'idtbl-set d id v constructor identifier->symbol identifier=?))
[sym (identifier->symbol id phase)]
[l (hash-ref (idtbl-hash d) sym null)])
(constructor
(hash-set (idtbl-hash d)
sym
(alist-set identifier=? phase l id v))
phase)))
(define (idtbl-set d id v) (define (idtbl-set d id v)
(idtbl-set/constructor d id v immutable-idtbl)) (idtbl-set/constructor d id v immutable-idtbl))
(define (idtbl-remove! d id) (define (idtbl-remove! d id)
(let* ([phase (idtbl-phase d)] (id-table-remove! 'idtbl-remove! d id identifier->symbol identifier=?))
[sym (identifier->symbol id phase)]
[l (hash-ref (idtbl-hash d) sym null)]
[newl (alist-remove identifier=? phase l id)])
(if (pair? newl)
(hash-set! (idtbl-hash d) sym newl)
(hash-remove! (idtbl-hash d) sym))))
(define (idtbl-remove/constructor d id constructor) (define (idtbl-remove/constructor d id constructor)
(let* ([phase (idtbl-phase d)] (id-table-remove/constructor 'idtbl-remove d id constructor identifier->symbol identifier=?))
[sym (identifier->symbol id phase)]
[l (hash-ref (idtbl-hash d) sym null)]
[newl (alist-remove identifier=? phase l id)])
(constructor
(if (pair? newl)
(hash-set (idtbl-hash d) sym newl)
(hash-remove (idtbl-hash d) sym))
phase)))
(define (idtbl-remove d id) (define (idtbl-remove d id)
(idtbl-remove/constructor d id immutable-idtbl)) (idtbl-remove/constructor d id immutable-idtbl))
(define (idtbl-count d) (define (idtbl-count d)
(apply + (hash-map (idtbl-hash d) (lambda (k v) (length v))))) (id-table-count d))
(define (idtbl-for-each d p) (define (idtbl-for-each d p)
(define (pp i) (p (car i) (cdr i))) (id-table-for-each d p))
(hash-for-each (idtbl-hash d)
(lambda (k v) (for-each pp v))))
(define (idtbl-map d f) (define (idtbl-map d f)
(define (fp i) (f (car i) (cdr i))) (id-table-map d f))
(apply append
(hash-map (idtbl-hash d)
(lambda (k v) (map fp v)))))
(define (idtbl-iterate-first d) (define (idtbl-iterate-first d)
(let ([h (idtbl-hash d)]) (id-table-iterate-first d))
(let ([a (dict-iterate-first h)])
(and a
(let ([b (dict-iterate-first (dict-iterate-value h a))])
(and b (make-id-table-iter a b)))))))
(define (idtbl-iterate-next d pos) (define (idtbl-iterate-next d pos)
(let ([h (idtbl-hash d)] (id-table-iterate-next 'idtbl-iterate-next d pos))
[a (id-table-iter-a pos)]
[b (id-table-iter-b pos)])
(let ([v (dict-iterate-value h a)])
(let ([b2 (dict-iterate-next v b)])
(if b2
(make-id-table-iter a b2)
(let ([a2 (dict-iterate-next h a)])
(and a2
(let ([b2 (dict-iterate-first
(dict-iterate-value h a2))])
(and b2 (make-id-table-iter a2 b2))))))))))
(define (idtbl-iterate-key d pos) (define (idtbl-iterate-key d pos)
(let ([h (idtbl-hash d)] (id-table-iterate-key 'idtbl-iterate-key d pos))
[a (id-table-iter-a pos)]
[b (id-table-iter-b pos)])
(dict-iterate-key (dict-iterate-value h a) b)))
(define (idtbl-iterate-value d pos) (define (idtbl-iterate-value d pos)
(let ([h (idtbl-hash d)] (id-table-iterate-value 'idtbl-iterate-value d pos))
[a (id-table-iter-a pos)]
[b (id-table-iter-b pos)])
(dict-iterate-value (dict-iterate-value h a) b)))
(define idtbl-mutable-methods (define idtbl-mutable-methods
(vector-immutable idtbl-ref (vector-immutable idtbl-ref
@ -216,7 +274,7 @@
#f #f
idtbl-remove! idtbl-remove!
#f #f
idtbl-count id-table-count
idtbl-iterate-first idtbl-iterate-first
idtbl-iterate-next idtbl-iterate-next
idtbl-iterate-key idtbl-iterate-key
@ -228,16 +286,15 @@
idtbl-set idtbl-set
#f #f
idtbl-remove idtbl-remove
idtbl-count id-table-count
idtbl-iterate-first idtbl-iterate-first
idtbl-iterate-next idtbl-iterate-next
idtbl-iterate-key idtbl-iterate-key
idtbl-iterate-value)) idtbl-iterate-value))
(struct idtbl (hash phase)) (struct idtbl id-table ())
(struct mutable-idtbl idtbl () (struct mutable-idtbl idtbl ()
#:property prop:dict idtbl-mutable-methods) #:property prop:dict idtbl-mutable-methods)
(struct immutable-idtbl idtbl () (struct immutable-idtbl idtbl ()
#:property prop:dict idtbl-immutable-methods) #:property prop:dict idtbl-immutable-methods)

34
collects/tests/racket/id-table-test.rktl
View File

@ -1,7 +1,7 @@
(load-relative "loadtest.rktl") (load-relative "loadtest.rktl")
(require syntax/id-table (require syntax/id-table
scheme/dict) racket/dict)
(Section 'id-table) (Section 'id-table)
@ -11,6 +11,38 @@
(test #t mutable-bound-id-table? (make-bound-id-table)) (test #t mutable-bound-id-table? (make-bound-id-table))
(test #t immutable-bound-id-table? (make-immutable-bound-id-table)) (test #t immutable-bound-id-table? (make-immutable-bound-id-table))
(let ()
(define a #'a)
(define b #'b)
(define b2 (let ([b 0]) #'b))
(define b3 ((make-syntax-introducer) #'b)) ;; free=? to b
(define alist (list (cons a 1) (cons b 2) (cons b2 3) (cons b3 4)))
(test 4 bound-id-table-count (make-bound-id-table alist))
(test 4 bound-id-table-count (make-immutable-bound-id-table alist))
(test 3 free-id-table-count (make-free-id-table alist))
(test 3 free-id-table-count (make-immutable-free-id-table alist))
(let ()
;; Test in-dict, iteration methods for immutable id-tables
(define d1 (make-immutable-bound-id-table alist))
(test (+ 1 2 3 4) (lambda () (for/sum ([(id v) (in-dict d1)]) v)))
(define d2 (for/fold ([d (make-immutable-bound-id-table)])
([(id v) (in-dict d1)])
(dict-set d id (add1 v))))
(test 2 bound-id-table-ref d2 a)
(test 3 bound-id-table-ref d2 b)
(test 4 bound-id-table-ref d2 b2)
(test 5 bound-id-table-ref d2 b3))
(let ()
;; Test in-dict, iteration methods for mutable id-tables
;; In particular, test that -set! of *existing* key does not disrupt iter.
(define d1 (make-bound-id-table alist))
(test (+ 1 2 3 4) (lambda () (for/sum ([(id v) (in-dict d1)]) v)))
(for ([(id v) (in-dict d1)])
(bound-id-table-set! d1 id (add1 v)))
(test (+ 2 3 4 5) (lambda () (for/sum ([(id v) (in-dict d1)]) v)))))
(let () (let ()
;; contains-same? : (listof x) (listof x) -> boolean ;; contains-same? : (listof x) (listof x) -> boolean
(define (contains-same? l1 l2) (define (contains-same? l1 l2)