syntax/id-table: more work on *-id-table/c
This commit is contained in:
Ryan Culpepper
parent
e7c7e14485
commit
3ccc93590a
|
|
@ -30,6 +30,7 @@
|
|||
any/c
|
||||
id-table-iter?
|
||||
#f #f #f))
|
||||
|
||||
(begin-for-syntax
|
||||
(define (replace old new template)
|
||||
(datum->syntax new
|
||||
|
|
@ -44,6 +45,116 @@
|
|||
#`(begin
|
||||
(define/with-syntax template (replace old new 'template)) ...)])))
|
||||
|
||||
;; ========
|
||||
|
||||
(define-struct base-id-table/c (dom rng immutable))
|
||||
|
||||
(define-values (id-table/c-dom-pos-proj
|
||||
id-table/c-dom-neg-proj
|
||||
id-table/c-rng-pos-proj
|
||||
id-table/c-rng-neg-proj)
|
||||
(let ()
|
||||
(define (proj acc location swap)
|
||||
(lambda (ctc blame)
|
||||
((contract-projection (acc ctc))
|
||||
(blame-add-context blame location #:swap? swap))))
|
||||
(values
|
||||
(proj base-id-table/c-dom "the keys of" #f)
|
||||
(proj base-id-table/c-dom "the keys of" #t)
|
||||
(proj base-id-table/c-rng "the values of" #f)
|
||||
(proj base-id-table/c-rng "the values of" #t))))
|
||||
|
||||
(define (make-id-table/c-functions idtbl/c-symbol
|
||||
idtbl?
|
||||
mutable-idtbl?
|
||||
immutable-idtbl?
|
||||
immutable-idtbl)
|
||||
(define (id-table/c-name ctc)
|
||||
(apply build-compound-type-name
|
||||
idtbl/c-symbol
|
||||
(base-id-table/c-dom ctc)
|
||||
(base-id-table/c-rng ctc)
|
||||
(case (base-id-table/c-immutable ctc)
|
||||
[(dont-care) null]
|
||||
[(#t)
|
||||
(list '#:immutable #t)]
|
||||
[(#f)
|
||||
(list '#:immutable #f)])))
|
||||
|
||||
(define (id-table/c-first-order ctc)
|
||||
(define dom-ctc (base-id-table/c-dom ctc))
|
||||
(define rng-ctc (base-id-table/c-rng ctc))
|
||||
(define immutable (base-id-table/c-immutable ctc))
|
||||
(λ (val)
|
||||
(and (idtbl? val)
|
||||
(case immutable
|
||||
[(#t) (immutable-idtbl? val)]
|
||||
[(#f) (mutable-idtbl? val)]
|
||||
[else #t])
|
||||
(for/and ([(k v) (in-dict val)])
|
||||
(and (contract-first-order-passes? dom-ctc k)
|
||||
(contract-first-order-passes? rng-ctc v))))))
|
||||
|
||||
(define (check-id-table/c ctc val blame)
|
||||
(define immutable (base-id-table/c-immutable ctc))
|
||||
(case immutable
|
||||
[(#t)
|
||||
(unless (immutable-idtbl? val)
|
||||
(raise-blame-error blame val
|
||||
'(expected "an immutable ~a," given: "~e") 'idtbl val))]
|
||||
[(#f)
|
||||
(unless (mutable-idtbl? val)
|
||||
(raise-blame-error blame val
|
||||
'(expected "a mutable ~a," given: "~e") 'idtbl val))]
|
||||
[(dont-care)
|
||||
(unless (idtbl? val)
|
||||
(raise-blame-error blame val
|
||||
'(expected "a ~a," given: "~e") 'idtbl val))]))
|
||||
|
||||
(define (fo-projection ctc)
|
||||
(λ (blame)
|
||||
(define dom-proj (id-table/c-dom-pos-proj ctc blame))
|
||||
(define rng-proj (id-table/c-rng-pos-proj ctc blame))
|
||||
(λ (val)
|
||||
(check-id-table/c ctc val blame)
|
||||
(for ([(k v) (in-dict val)])
|
||||
(dom-proj k)
|
||||
(rng-proj v))
|
||||
val)))
|
||||
|
||||
(define (ho-projection ctc)
|
||||
(lambda (blame)
|
||||
(define pos-dom-proj (id-table/c-dom-pos-proj ctc blame))
|
||||
(define neg-dom-proj (id-table/c-dom-neg-proj ctc blame))
|
||||
(define pos-rng-proj (id-table/c-rng-pos-proj ctc blame))
|
||||
(define neg-rng-proj (id-table/c-rng-neg-proj ctc blame))
|
||||
(lambda (tbl)
|
||||
(check-id-table/c ctc tbl blame)
|
||||
;;TODO for immutable hash tables optimize this chaperone to a flat
|
||||
;;check if possible
|
||||
(if (immutable-idtbl? tbl)
|
||||
(chaperone-immutable-id-table tbl pos-dom-proj pos-rng-proj
|
||||
impersonator-prop:contracted ctc)
|
||||
(chaperone-mutable-id-table tbl
|
||||
(λ (t k)
|
||||
(values (neg-dom-proj k)
|
||||
(λ (h k v) (pos-rng-proj v))))
|
||||
(λ (t k v)
|
||||
(values (neg-dom-proj k)
|
||||
(neg-rng-proj v)))
|
||||
(λ (t k)
|
||||
(neg-dom-proj k))
|
||||
(λ (t k)
|
||||
(pos-dom-proj k))
|
||||
impersonator-prop:contracted ctc)))))
|
||||
|
||||
(values id-table/c-name
|
||||
id-table/c-first-order
|
||||
check-id-table/c
|
||||
fo-projection
|
||||
ho-projection))
|
||||
|
||||
;; ========
|
||||
|
||||
(define-syntax (make-code stx)
|
||||
(syntax-case stx ()
|
||||
|
|
@ -64,7 +175,7 @@
|
|||
idtbl-map idtbl-for-each
|
||||
idtbl-mutable-methods idtbl-immutable-methods
|
||||
idtbl/c
|
||||
chaperone-mutable-idtbl chaperone-immutable-idtbl))
|
||||
chaperone-mutable-idtbl))
|
||||
#'(begin
|
||||
|
||||
;; Struct defs at end, so that dict methods can refer to earlier procs
|
||||
|
|
@ -105,133 +216,6 @@
|
|||
idtbl-iterate-key
|
||||
idtbl-iterate-value))
|
||||
|
||||
(define-struct base-idtbl/c (dom rng immutable))
|
||||
|
||||
(define (idtbl/c-name ctc)
|
||||
(apply
|
||||
build-compound-type-name
|
||||
'idtbl/c (base-idtbl/c-dom ctc) (base-idtbl/c-rng ctc)
|
||||
(append
|
||||
(if (flat-idtbl/c? ctc)
|
||||
(list '#:flat? #t)
|
||||
null)
|
||||
(case (base-idtbl/c-immutable ctc)
|
||||
[(dont-care) null]
|
||||
[(#t)
|
||||
(list '#:immutable #t)]
|
||||
[(#f)
|
||||
(list '#:immutable #f)]))))
|
||||
|
||||
(define-values (idtbl/c-dom-pos-proj
|
||||
idtbl/c-dom-neg-proj
|
||||
idtbl/c-rng-pos-proj
|
||||
idtbl/c-rng-neg-proj)
|
||||
(let ()
|
||||
(define (proj acc location swap)
|
||||
(lambda (ctc blame)
|
||||
((contract-projection (acc ctc))
|
||||
(blame-add-context blame location #:swap? swap))))
|
||||
(values
|
||||
(proj base-idtbl/c-dom "the keys of" #f)
|
||||
(proj base-idtbl/c-dom "the keys of" #t)
|
||||
(proj base-idtbl/c-rng "the values of" #f)
|
||||
(proj base-idtbl/c-rng "the values of" #t))))
|
||||
|
||||
(define (idtbl/c-first-order ctc)
|
||||
(define dom-ctc (base-idtbl/c-dom ctc))
|
||||
(define rng-ctc (base-idtbl/c-rng ctc))
|
||||
(define immutable (base-idtbl/c-immutable ctc))
|
||||
(λ (val)
|
||||
(and (idtbl? val)
|
||||
(case immutable
|
||||
[(#t) (immutable-idtbl? val)]
|
||||
[(#f) (mutable-idtbl? val)]
|
||||
[else #t])
|
||||
(for/and ([(k v) (in-dict val)])
|
||||
(and (contract-first-order-passes? dom-ctc k)
|
||||
(contract-first-order-passes? rng-ctc v))))))
|
||||
|
||||
(define (check-idtbl/c ctc val blame)
|
||||
(define immutable (base-idtbl/c-immutable ctc))
|
||||
(unless (idtbl? val)
|
||||
(raise-blame-error blame val
|
||||
'(expected "a ~a," given: "~e") 'idtbl val))
|
||||
(case immutable
|
||||
[(#t)
|
||||
(unless (immutable-idtbl? val)
|
||||
(raise-blame-error blame val
|
||||
'(expected "an immutable ~a," given: "~e") 'idtbl val))]
|
||||
[(#f)
|
||||
(unless (mutable-idtbl? val)
|
||||
(raise-blame-error blame val
|
||||
'(expected "a mutable ~a," given: "~e") 'idtbl val))]
|
||||
[(dont-care) (void)]))
|
||||
|
||||
(define ho-projection
|
||||
(lambda (ctc)
|
||||
(lambda (blame)
|
||||
(define pos-dom-proj (idtbl/c-dom-pos-proj ctc blame))
|
||||
(define neg-dom-proj (idtbl/c-dom-neg-proj ctc blame))
|
||||
(define pos-rng-proj (idtbl/c-rng-pos-proj ctc blame))
|
||||
(define neg-rng-proj (idtbl/c-rng-neg-proj ctc blame))
|
||||
(lambda (tbl)
|
||||
(check-idtbl/c ctc tbl blame)
|
||||
;TODO for immutable hash tables optimize this chaperone to a flat
|
||||
;check if possible
|
||||
(if (immutable-idtbl? tbl)
|
||||
(chaperone-immutable-idtbl tbl pos-dom-proj pos-rng-proj
|
||||
impersonator-prop:contracted ctc)
|
||||
(chaperone-mutable-idtbl tbl
|
||||
(λ (t k)
|
||||
(values (neg-dom-proj k)
|
||||
(λ (h k v)
|
||||
(pos-rng-proj v))))
|
||||
(λ (t k v)
|
||||
(values (neg-dom-proj k)
|
||||
(neg-rng-proj v)))
|
||||
(λ (t k)
|
||||
(neg-dom-proj k))
|
||||
(λ (t k)
|
||||
(pos-dom-proj k))
|
||||
impersonator-prop:contracted ctc))))))
|
||||
|
||||
|
||||
|
||||
(struct flat-idtbl/c base-idtbl/c ()
|
||||
#:omit-define-syntaxes
|
||||
#:property prop:flat-contract
|
||||
(build-flat-contract-property
|
||||
#:name idtbl/c-name
|
||||
#:first-order idtbl/c-first-order
|
||||
#:projection
|
||||
(λ (ctc)
|
||||
(λ (blame)
|
||||
(λ (val)
|
||||
(check-idtbl/c ctc val blame)
|
||||
(define dom-proj (idtbl/c-dom-pos-proj ctc blame))
|
||||
(define rng-proj (idtbl/c-rng-pos-proj ctc blame))
|
||||
(for ([(k v) (in-dict val)])
|
||||
(dom-proj k)
|
||||
(rng-proj v))
|
||||
val)))))
|
||||
|
||||
(struct chaperone-idtbl/c base-idtbl/c ()
|
||||
#:omit-define-syntaxes
|
||||
#:property prop:chaperone-contract
|
||||
(build-chaperone-contract-property
|
||||
#:name idtbl/c-name
|
||||
#:first-order idtbl/c-first-order
|
||||
#:projection ho-projection))
|
||||
|
||||
(struct impersonator-idtbl/c base-idtbl/c ()
|
||||
#:omit-define-syntaxes
|
||||
#:property prop:contract
|
||||
(build-contract-property
|
||||
#:name idtbl/c-name
|
||||
#:first-order idtbl/c-first-order
|
||||
#:projection ho-projection))
|
||||
|
||||
|
||||
(struct mutable-idtbl mutable-idtbl* ()
|
||||
#:property prop:dict/contract
|
||||
(list idtbl-mutable-methods
|
||||
|
|
@ -241,18 +225,52 @@
|
|||
(list idtbl-immutable-methods
|
||||
dict-contract-methods))
|
||||
|
||||
(define (idtbl/c key/c value/c #:immutable (immutable 'dont-care))
|
||||
(define-values (idtbl/c-name
|
||||
idtbl/c-first-order
|
||||
check-idtbl/c
|
||||
fo-projection
|
||||
ho-projection)
|
||||
(make-id-table/c-functions 'idtbl/c
|
||||
idtbl?
|
||||
mutable-idtbl?
|
||||
immutable-idtbl?
|
||||
immutable-idtbl))
|
||||
|
||||
(struct flat-idtbl/c base-id-table/c ()
|
||||
#:omit-define-syntaxes
|
||||
#:property prop:flat-contract
|
||||
(build-flat-contract-property
|
||||
#:name idtbl/c-name
|
||||
#:first-order idtbl/c-first-order
|
||||
#:projection fo-projection))
|
||||
|
||||
(struct chaperone-idtbl/c base-id-table/c ()
|
||||
#:omit-define-syntaxes
|
||||
#:property prop:chaperone-contract
|
||||
(build-chaperone-contract-property
|
||||
#:name idtbl/c-name
|
||||
#:first-order idtbl/c-first-order
|
||||
#:projection ho-projection))
|
||||
|
||||
(struct impersonator-idtbl/c base-id-table/c ()
|
||||
#:omit-define-syntaxes
|
||||
#:property prop:contract
|
||||
(build-contract-property
|
||||
#:name idtbl/c-name
|
||||
#:first-order idtbl/c-first-order
|
||||
#:projection ho-projection))
|
||||
|
||||
(define (idtbl/c key/c value/c #:immutable [immutable 'dont-care])
|
||||
(define key/ctc (coerce-contract 'idtbl/c key/c))
|
||||
(define value/ctc (coerce-contract 'idtbl/c value/c))
|
||||
(cond
|
||||
((and (eq? immutable #t)
|
||||
(flat-contract? key/ctc)
|
||||
(flat-contract? value/ctc))
|
||||
(flat-idtbl/c key/ctc value/ctc immutable))
|
||||
((chaperone-contract? value/ctc)
|
||||
(chaperone-idtbl/c key/ctc value/ctc immutable))
|
||||
(else
|
||||
(impersonator-idtbl/c key/ctc value/ctc immutable))))
|
||||
(cond [(and (eq? immutable #t)
|
||||
(flat-contract? key/ctc)
|
||||
(flat-contract? value/ctc))
|
||||
(flat-idtbl/c key/ctc value/ctc immutable)]
|
||||
[(chaperone-contract? value/ctc)
|
||||
(chaperone-idtbl/c key/ctc value/ctc immutable)]
|
||||
[else
|
||||
(impersonator-idtbl/c key/ctc value/ctc immutable)]))
|
||||
|
||||
(provide/contract
|
||||
[make-idtbl
|
||||
|
|
@ -290,7 +308,7 @@
|
|||
[idtbl-for-each
|
||||
(-> idtbl? (-> identifier? any/c any) any)]
|
||||
[idtbl/c
|
||||
(->* (chaperone-contract? contract?)
|
||||
(->* (flat-contract? contract?)
|
||||
(#:immutable (or/c 'dont-care #t #f))
|
||||
contract?)])))]))
|
||||
|
||||
|
|
|
|||
|
|
@ -11,13 +11,21 @@
|
|||
;; where hash maps symbol => (listof (cons identifier value))
|
||||
;; phase is a phase-level (integer or #f)
|
||||
|
||||
(define (make-id-table-hash-code identifier->symbol)
|
||||
(lambda (d hash-code)
|
||||
(+ (hash-code (id-table-phase d))
|
||||
(for/sum (((k v) (in-dict d)))
|
||||
(* (hash-code (identifier->symbol k)) (hash-code v))))))
|
||||
|
||||
|
||||
(define (id-table-hash-code d hash-code)
|
||||
(+ (hash-code (id-table-phase d))
|
||||
(for/sum (((k v) (in-dict d)))
|
||||
(* (hash-code (syntax-e k)) (hash-code v)))))
|
||||
|
||||
(define (make-id-table-equal? idtbl-count idtbl-ref)
|
||||
(lambda (left right equal?)
|
||||
;; gen:equal+hash guarantees that left, right are same kind of hash
|
||||
(and (equal? (id-table-phase left) (id-table-phase right))
|
||||
(equal? (idtbl-count left) (idtbl-count right))
|
||||
(let/ec k
|
||||
(for*/and ([l-alist (in-hash-values (id-table-hash left))]
|
||||
[entry (in-list l-alist)])
|
||||
(equal? (idtbl-ref right (car entry) (lambda () (k #f))) (cdr entry)))))))
|
||||
|
||||
(define-values (prop:id-table-impersonator
|
||||
id-table-impersonator?
|
||||
|
|
@ -34,7 +42,24 @@
|
|||
(vector-ref (id-table-impersonator-value d) i)))))
|
||||
(apply values (build-list 5 extractor))))
|
||||
|
||||
(define (chaperone-mutable-id-table d ref set! remove! key . args)
|
||||
(apply chaperone-struct d
|
||||
;; FIXME: chaperone-struct currently demands at least one orig-proc+redirect-proc pair
|
||||
id-table-phase (lambda (d p) p)
|
||||
prop:id-table-impersonator (vector d ref set! remove! key)
|
||||
args))
|
||||
|
||||
(define (chaperone-immutable-id-table d wrap-key wrap-value . args)
|
||||
(apply chaperone-struct d
|
||||
id-table-hash
|
||||
(let ([hash (for/hasheq ([(sym alist) (id-table-hash d)])
|
||||
(values sym
|
||||
(for/list ([entry (in-list alist)])
|
||||
(cons (wrap-key (car entry)) (wrap-value (cdr entry))))))])
|
||||
(lambda (d v) hash))
|
||||
args))
|
||||
|
||||
;; ========
|
||||
|
||||
(define (make-id-table/constructor who init-dict phase make identifier->symbol identifier=?)
|
||||
(let ([t (make (make-hasheq) phase)])
|
||||
|
|
@ -51,25 +76,27 @@
|
|||
(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 loop ((d d) (id id) (return values))
|
||||
(if (id-table-impersonator? d)
|
||||
(let-values (((new-id return-wrapper)
|
||||
((id-table-imp-ref-wrapper d) d id)))
|
||||
(loop (id-table-imp-wrapped d) new-id
|
||||
(lambda (new-v) (return-wrapper d new-id new-v))))
|
||||
(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
|
||||
(return (cdr i))
|
||||
(cond [(eq? default not-given)
|
||||
(error who "no mapping for ~e" id)]
|
||||
[(procedure? default) (default)]
|
||||
[else default])))))))
|
||||
(let-values (((new-id return-wrapper)
|
||||
((id-table-imp-ref-wrapper d) d id)))
|
||||
(loop (id-table-imp-wrapped d) new-id
|
||||
(lambda (new-v) (return-wrapper d new-id new-v))))
|
||||
(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
|
||||
(return (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 loop ((d d) (id id) (v v))
|
||||
|
|
@ -83,7 +110,6 @@
|
|||
[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 loop ((d d) (id id))
|
||||
(if (id-table-impersonator? d)
|
||||
|
|
@ -117,8 +143,8 @@
|
|||
phase)))
|
||||
|
||||
(define (id-table-count d)
|
||||
(apply + (hash-map (id-table-hash d) (lambda (k v) (length v)))))
|
||||
|
||||
(for/sum ([(k v) (in-hash (id-table-hash d))])
|
||||
(length v)))
|
||||
|
||||
(define-struct id-table-iter (d a br b))
|
||||
;; where d is an id-table
|
||||
|
|
@ -229,6 +255,7 @@ Notes (FIXME?):
|
|||
(define not-given (gensym 'not-given))
|
||||
|
||||
;; ========
|
||||
|
||||
(begin-for-syntax
|
||||
(define (replace old new template)
|
||||
(datum->syntax new
|
||||
|
|
@ -262,11 +289,11 @@ Notes (FIXME?):
|
|||
idtbl-iterate-first idtbl-iterate-next
|
||||
idtbl-iterate-key idtbl-iterate-value
|
||||
idtbl-map idtbl-for-each
|
||||
idtbl-mutable-methods idtbl-immutable-methods
|
||||
chaperone-mutable-idtbl chaperone-immutable-idtbl))
|
||||
idtbl-mutable-methods idtbl-immutable-methods))
|
||||
#'(begin
|
||||
|
||||
;; Struct defs at end, so that dict methods can refer to earlier procs
|
||||
|
||||
(define (make-idtbl [init-dict null]
|
||||
#:phase [phase (syntax-local-phase-level)])
|
||||
(make-id-table/constructor 'make-idtbl init-dict phase mutable-idtbl
|
||||
|
|
@ -277,27 +304,6 @@ Notes (FIXME?):
|
|||
(make-immutable-id-table/constructor 'make-immutable-idtbl init-dict phase immutable-idtbl
|
||||
identifier->symbol identifier=?))
|
||||
|
||||
(define (chaperone-mutable-idtbl d ref set! remove! key . args)
|
||||
(apply chaperone-struct d
|
||||
id-table-phase (lambda (d p) p)
|
||||
prop:id-table-impersonator
|
||||
(vector d ref set! remove! key)
|
||||
args))
|
||||
|
||||
(define (chaperone-immutable-idtbl d wrap-key wrap-value . args)
|
||||
(define cached-hash
|
||||
(delay
|
||||
(for/hasheq (((sym alist) (id-table-hash d)))
|
||||
(values sym
|
||||
(for/list (((key value) (in-dict alist)))
|
||||
(cons (wrap-key key) (wrap-value value)))))))
|
||||
(apply chaperone-struct d
|
||||
id-table-hash (lambda (d h)
|
||||
(force cached-hash))
|
||||
args))
|
||||
|
||||
|
||||
|
||||
(define (idtbl-ref d id [default not-given])
|
||||
(id-table-ref 'idtbl-ref d id default identifier->symbol identifier=?))
|
||||
(define (idtbl-set! d id v)
|
||||
|
|
@ -328,14 +334,6 @@ Notes (FIXME?):
|
|||
(define (idtbl-iterate-value d pos)
|
||||
(id-table-iterate-value 'idtbl-iterate-value d pos identifier->symbol identifier=?))
|
||||
|
||||
(define (idtbl-chaperone-keys+values/constructor d wrap-key wrap-value constructor)
|
||||
(constructor
|
||||
(for/hasheq (((sym alist) (id-table-hash d)))
|
||||
(values sym
|
||||
(for/list (((key value) (in-dict alist)))
|
||||
(cons (wrap-key key) (wrap-value value)))))
|
||||
(id-table-phase d)))
|
||||
|
||||
(define idtbl-mutable-methods
|
||||
(vector-immutable idtbl-ref
|
||||
idtbl-set!
|
||||
|
|
@ -360,22 +358,20 @@ Notes (FIXME?):
|
|||
idtbl-iterate-key
|
||||
idtbl-iterate-value))
|
||||
|
||||
(define (idtbl-equal? left right equal?)
|
||||
(let/ec k
|
||||
(and (equal? (id-table-phase left) (id-table-phase right))
|
||||
(equal? (idtbl-count left) (idtbl-count right))
|
||||
(for/and (((l-key l-value) (in-dict left)))
|
||||
(equal? (idtbl-ref right l-key (lambda () (k #f))) l-value)))))
|
||||
|
||||
|
||||
(struct idtbl id-table ())
|
||||
(struct mutable-idtbl idtbl ()
|
||||
#:property prop:dict idtbl-mutable-methods
|
||||
#:property prop:equal+hash (list idtbl-equal? id-table-hash-code id-table-hash-code))
|
||||
#:property prop:equal+hash
|
||||
(let ([hash-code (make-id-table-hash-code identifier->symbol)]
|
||||
[eql (make-id-table-equal? idtbl-count idtbl-ref)])
|
||||
(list eql hash-code hash-code)))
|
||||
|
||||
(struct immutable-idtbl idtbl ()
|
||||
#:property prop:dict idtbl-immutable-methods
|
||||
#:property prop:equal+hash (list idtbl-equal? id-table-hash-code id-table-hash-code))
|
||||
#:property prop:equal+hash
|
||||
(let ([hash-code (make-id-table-hash-code identifier->symbol)]
|
||||
[eql (make-id-table-equal? idtbl-count idtbl-ref)])
|
||||
(list eql hash-code hash-code)))
|
||||
|
||||
(provide make-idtbl
|
||||
make-immutable-idtbl
|
||||
|
|
@ -396,8 +392,6 @@ Notes (FIXME?):
|
|||
idtbl-for-each
|
||||
|
||||
;; just for use/extension by syntax/id-table
|
||||
chaperone-mutable-idtbl
|
||||
chaperone-immutable-idtbl
|
||||
idtbl-set/constructor
|
||||
idtbl-remove/constructor
|
||||
idtbl-mutable-methods
|
||||
|
|
@ -420,4 +414,6 @@ Notes (FIXME?):
|
|||
free-identifier->symbol
|
||||
free-identifier=?)
|
||||
|
||||
(provide id-table-iter?)
|
||||
(provide id-table-iter?
|
||||
chaperone-mutable-id-table
|
||||
chaperone-immutable-id-table)
|
||||
|
|
|
|||
|
|
@ -154,11 +154,15 @@ identifier table (free or bound, mutable or immutable), @racket[#f]
|
|||
otherwise.
|
||||
}
|
||||
|
||||
@defproc[(free-id-table/c [val contract?]
|
||||
[#:immutable immutable (or/c #t #f 'dont-care) 'dont-care])
|
||||
@defproc[(free-id-table/c [key-ctc flat-contract?]
|
||||
[val-ctc contract?]
|
||||
[#:immutable immutable? (or/c #t #f 'dont-care) 'dont-care])
|
||||
contract?]{
|
||||
|
||||
Like @racket[hash/c], but more limited. It only supports contracts on the values in the identifier table.
|
||||
Like @racket[hash/c], but for free-identifier tables. If
|
||||
@racket[immutable?] is @racket[#t], the contract accepts only
|
||||
immutable identifier tables; if @racket[immutable?] is @racket[#f],
|
||||
the contract accepts only mutable identifier tables.
|
||||
}
|
||||
|
||||
@;{----------}
|
||||
|
|
|
|||
|
|
@ -298,8 +298,9 @@
|
|||
|
||||
(test/blame-pos (app-ctc (free-id-table/c symbol? symbol? #:immutable #t) im-tbl))
|
||||
(test/blame-pos (app-ctc (free-id-table/c identifier? number? #:immutable #t) im-tbl))
|
||||
(test #t free-id-table? (app-ctc (free-id-table/c identifier? number?) im-tbl))
|
||||
(test #t free-id-table? (app-ctc (free-id-table/c symbol? symbol?) im-tbl))
|
||||
;; --- ryanc: I don't think these should be checked lazily.
|
||||
;; (test #t free-id-table? (app-ctc (free-id-table/c identifier? number?) im-tbl))
|
||||
;; (test #t free-id-table? (app-ctc (free-id-table/c symbol? symbol?) im-tbl))
|
||||
|
||||
; These are not failures yet because they are not flat contracts
|
||||
; Looking at the hash ensures that the contract fails
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user