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

Clean up creation of identifiers in id-table.rkt

Browse Source
This commit is contained in:
Eric Dobson 2012-06-24 00:11:26 -07:00 committed by Ryan Culpepper
parent 4725775126
commit d4efe8f5aa
2 changed files with 371 additions and 388 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

489
collects/syntax/id-table.rkt
View File

@ -1,6 +1,7 @@
#lang racket/base #lang racket/base
(require (for-syntax racket/base (require (for-syntax racket/base
racket/syntax) racket/syntax)
(for-meta 2 racket/base)
racket/contract/base racket/contract/base
racket/contract/combinator racket/contract/combinator
racket/dict racket/dict
@ -29,280 +30,268 @@
any/c any/c
id-table-iter? id-table-iter?
#f #f #f)) #f #f #f))
(begin-for-syntax
(define (replace old new template)
(datum->syntax new
(string->symbol
(regexp-replace
(regexp-quote old)
(symbol->string template)
(regexp-replace-quote (symbol->string (syntax-e new)))))))
(define-syntax (define-templates stx)
(syntax-case stx ()
[(_ old new (template ...))
#`(begin
(define/with-syntax template (replace old new 'template)) ...)])))
(define-syntax (make-code stx) (define-syntax (make-code stx)
(syntax-case stx () (syntax-case stx ()
[(_ idtbl) [(_ idtbl)
(with-syntax ([mutable-idtbl (let ()
(format-id #'idtbl "mutable-~a" (syntax-e #'idtbl))] (define-templates "idtbl" #'idtbl
[immutable-idtbl (mutable-idtbl* immutable-idtbl* mutable-idtbl immutable-idtbl
(format-id #'idtbl "immutable-~a" (syntax-e #'idtbl))] make-idtbl make-mutable-idtbl make-immutable-idtbl
[mutable-idtbl* idtbl? immutable-idtbl? mutable-idtbl?
(format-id #'idtbl "mutable-~a*" (syntax-e #'idtbl))] idtbl-hash idtbl-phase
[immutable-idtbl* idtbl-ref
(format-id #'idtbl "immutable-~a*" (syntax-e #'idtbl))] idtbl-set! idtbl-set
[make-idtbl idtbl-remove! idtbl-remove
(format-id #'idtbl "make-~a" (syntax-e #'idtbl))] idtbl-set/constructor idtbl-remove/constructor
[make-mutable-idtbl idtbl-count
(format-id #'idtbl "make-mutable-~a" (syntax-e #'idtbl))] idtbl-iterate-first idtbl-iterate-next
[make-immutable-idtbl idtbl-iterate-key idtbl-iterate-value
(format-id #'idtbl "make-immutable-~a" (syntax-e #'idtbl))] idtbl-map idtbl-for-each
[mutable-idtbl? idtbl-mutable-methods idtbl-immutable-methods
(format-id #'idtbl "mutable-~a?" (syntax-e #'idtbl))] idtbl/c
[immutable-idtbl? chaperone-idtbl idtbl-chaperone-keys+values/constructor))
(format-id #'idtbl "immutable-~a?" (syntax-e #'idtbl))] #'(begin
[chaperone-idtbl
(format-id #'idtbl "chaperone-~a" (syntax-e #'idtbl))])
(define (s x) (format-id #'idtbl "~a~a" (syntax-e #'idtbl) x))
(with-syntax ([idtbl? (s '?)]
[idtbl-hash (s '-hash)]
[idtbl-phase (s '-phase)]
[idtbl-ref (s '-ref)]
[idtbl-set! (s '-set!)]
[idtbl-set (s '-set)]
[idtbl-remove! (s '-remove!)]
[idtbl-remove (s '-remove)]
[idtbl-set/constructor (s '-set/constructor)]
[idtbl-remove/constructor (s '-remove/constructor)]
[idtbl-count (s '-count)]
[idtbl-iterate-first (s '-iterate-first)]
[idtbl-iterate-next (s '-iterate-next)]
[idtbl-iterate-key (s '-iterate-key)]
[idtbl-iterate-value (s '-iterate-value)]
[idtbl-map (s '-map)]
[idtbl-for-each (s '-for-each)]
[idtbl-mutable-methods (s '-mutable-methods)]
[idtbl-immutable-methods (s '-immutable-methods)]
[idtbl-chaperone-keys+values/constructor
(s 'idtbl-chaperone-keys+values/constructor)]
[idtbl/c (s '/c)])
#'(begin
;; Struct defs at end, so that dict methods can refer to earlier procs ;; Struct defs at end, so that dict methods can refer to earlier procs
(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)]) (let ([t (mutable-idtbl (make-hasheq) phase)])
(for ([(k v) (in-dict init-dict)]) (for ([(k v) (in-dict init-dict)])
(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]
#:phase [phase (syntax-local-phase-level)])
(for/fold ([t (immutable-idtbl '#hasheq() phase)])
([(k v) (in-dict init-dict)])
(unless (identifier? k) (unless (identifier? k)
(raise-type-error 'make-immutable-idtbl (raise-type-error 'make-idtbl
"dictionary with identifier keys" init-dict)) "dictionary with identifier keys" init-dict))
(idtbl-set t k v))) (idtbl-set! t k v))
t))
;; Replace to use new constructor (define (make-immutable-idtbl [init-dict null]
(define (idtbl-set d id v) #:phase [phase (syntax-local-phase-level)])
(idtbl-set/constructor d id v immutable-idtbl)) (for/fold ([t (immutable-idtbl '#hasheq() phase)])
(define (idtbl-remove d id) ([(k v) (in-dict init-dict)])
(idtbl-remove/constructor d id immutable-idtbl)) (unless (identifier? k)
(define idtbl-immutable-methods (raise-type-error 'make-immutable-idtbl
(vector-immutable idtbl-ref "dictionary with identifier keys" init-dict))
#f (idtbl-set t k v)))
idtbl-set
#f
idtbl-remove
idtbl-count
idtbl-iterate-first
idtbl-iterate-next
idtbl-iterate-key
idtbl-iterate-value))
(define-struct base-idtbl/c (dom rng immutable)) ;; Replace to use new constructor
(define (idtbl-set d id v)
(idtbl-set/constructor d id v immutable-idtbl))
(define (idtbl-remove d id)
(idtbl-remove/constructor d id immutable-idtbl))
(define idtbl-immutable-methods
(vector-immutable idtbl-ref
#f
idtbl-set
#f
idtbl-remove
idtbl-count
idtbl-iterate-first
idtbl-iterate-next
idtbl-iterate-key
idtbl-iterate-value))
(define (idtbl/c-name ctc) (define-struct base-idtbl/c (dom rng immutable))
(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 (define (idtbl/c-name ctc)
idtbl/c-dom-neg-proj (apply
idtbl/c-rng-pos-proj build-compound-type-name
idtbl/c-rng-neg-proj) 'idtbl/c (base-idtbl/c-dom ctc) (base-idtbl/c-rng ctc)
(let () (append
(define (proj acc location swap) (if (flat-idtbl/c? ctc)
(lambda (ctc blame) (list '#:flat? #t)
((contract-projection (acc ctc)) null)
(blame-add-context blame "the keys of" #:swap swap)))) (case (base-idtbl/c-immutable ctc)
(values [(dont-care) null]
(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? val)]
[(#f) (not (immutable? 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) [(#t)
(unless (immutable? val) (list '#:immutable #t)]
(raise-blame-error blame val
'(expected "an immutable ~a," given: "~e") 'idtbl val))]
[(#f) [(#f)
(when (immutable? val) (list '#:immutable #f)]))))
(raise-blame-error blame val
'(expected "a mutable ~a," given: "~e") 'idtbl val))]
[(dont-care) (void)]))
(define ho-projection (define-values (idtbl/c-dom-pos-proj
(lambda (ctc) idtbl/c-dom-neg-proj
(lambda (blame) idtbl/c-rng-pos-proj
(lambda (b) idtbl/c-rng-neg-proj)
(define pos-dom-proj (idtbl/c-dom-pos-proj ctc blame)) (let ()
(define neg-dom-proj (idtbl/c-dom-pos-proj ctc blame)) (define (proj acc location swap)
(define pos-rng-proj (idtbl/c-dom-pos-proj ctc blame)) (lambda (ctc blame)
(define neg-rng-proj (idtbl/c-dom-pos-proj ctc blame)) ((contract-projection (acc ctc))
(lambda (tbl) (blame-add-context blame "the keys of" #:swap swap))))
(check-idtbl/c ctc tbl blame) (values
(if (immutable? tbl) (proj base-idtbl/c-dom "the keys of" #f)
(idtbl-chaperone-keys+values/constructor (proj base-idtbl/c-dom "the keys of" #t)
tbl pos-dom-proj pos-rng-proj immutable-idtbl) (proj base-idtbl/c-rng "the values of" #f)
(chaperone-idtbl tbl (proj base-idtbl/c-rng "the values of" #t))))
(λ (t k)
(values (neg-dom-proj k) (define (idtbl/c-first-order ctc)
(λ (h k v) (define dom-ctc (base-idtbl/c-dom ctc))
(pos-rng-proj v)))) (define rng-ctc (base-idtbl/c-rng ctc))
(λ (t k v) (define immutable (base-idtbl/c-immutable ctc))
(values (neg-dom-proj k) (λ (val)
(neg-rng-proj v))) (and (idtbl? val)
(λ (t k) (case immutable
(neg-dom-proj k)) [(#t) (immutable? val)]
(λ (t k) [(#f) (not (immutable? val))]
(pos-dom-proj k)) [else #t])
impersonator-prop:contracted ctc))))))) (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? val)
(raise-blame-error blame val
'(expected "an immutable ~a," given: "~e") 'idtbl val))]
[(#f)
(when (immutable? val)
(raise-blame-error blame val
'(expected "a mutable ~a," given: "~e") 'idtbl val))]
[(dont-care) (void)]))
(define ho-projection
(lambda (ctc)
(lambda (blame)
(lambda (b)
(define pos-dom-proj (idtbl/c-dom-pos-proj ctc blame))
(define neg-dom-proj (idtbl/c-dom-pos-proj ctc blame))
(define pos-rng-proj (idtbl/c-dom-pos-proj ctc blame))
(define neg-rng-proj (idtbl/c-dom-pos-proj ctc blame))
(lambda (tbl)
(check-idtbl/c ctc tbl blame)
(if (immutable? tbl)
(idtbl-chaperone-keys+values/constructor
tbl pos-dom-proj pos-rng-proj immutable-idtbl)
(chaperone-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 () (struct flat-idtbl/c base-idtbl/c ()
#:omit-define-syntaxes #:omit-define-syntaxes
#:property prop:flat-contract #:property prop:flat-contract
(build-flat-contract-property (build-flat-contract-property
#:name idtbl/c-name #:name idtbl/c-name
#:first-order idtbl/c-first-order #:first-order idtbl/c-first-order
#:projection #:projection
(λ (ctc) (λ (ctc)
(λ (blame) (λ (blame)
(λ (val) (λ (val)
(check-idtbl/c ctc val blame) (check-idtbl/c ctc val blame)
(define dom-proj (idtbl/c-dom-pos-proj ctc)) (define dom-proj (idtbl/c-dom-pos-proj ctc))
(define rng-proj (idtbl/c-rng-pos-proj ctc)) (define rng-proj (idtbl/c-rng-pos-proj ctc))
(for ([(k v) (in-dict val)]) (for ([(k v) (in-dict val)])
(dom-proj k) (dom-proj k)
(rng-proj v)) (rng-proj v))
val))))) val)))))
(struct chaperone-idtbl/c base-idtbl/c () (struct chaperone-idtbl/c base-idtbl/c ()
#:omit-define-syntaxes #:omit-define-syntaxes
#:property prop:chaperone-contract #:property prop:chaperone-contract
(build-chaperone-contract-property (build-chaperone-contract-property
#:name idtbl/c-name #:name idtbl/c-name
#:first-order idtbl/c-first-order #:first-order idtbl/c-first-order
#:projection ho-projection)) #:projection ho-projection))
(struct impersonator-idtbl/c base-idtbl/c () (struct impersonator-idtbl/c base-idtbl/c ()
#:omit-define-syntaxes #:omit-define-syntaxes
#:property prop:contract #:property prop:contract
(build-contract-property (build-contract-property
#:name idtbl/c-name #:name idtbl/c-name
#:first-order idtbl/c-first-order #:first-order idtbl/c-first-order
#:projection ho-projection)) #:projection ho-projection))
(struct mutable-idtbl mutable-idtbl* () (struct mutable-idtbl mutable-idtbl* ()
#:property prop:dict/contract #:property prop:dict/contract
(list idtbl-mutable-methods (list idtbl-mutable-methods
dict-contract-methods)) dict-contract-methods))
(struct immutable-idtbl immutable-idtbl* () (struct immutable-idtbl immutable-idtbl* ()
#:property prop:dict/contract #:property prop:dict/contract
(list idtbl-immutable-methods (list idtbl-immutable-methods
dict-contract-methods)) dict-contract-methods))
(define (idtbl/c key/c value/c #:immutable (immutable 'dont-care)) (define (idtbl/c key/c value/c #:immutable (immutable 'dont-care))
(define key/ctc (coerce-contract 'idtbl/c key/c)) (define key/ctc (coerce-contract 'idtbl/c key/c))
(define value/ctc (coerce-contract 'idtbl/c value/c)) (define value/ctc (coerce-contract 'idtbl/c value/c))
(cond (cond
((and (eq? immutable #t) ((and (eq? immutable #t)
(flat-contract? key/ctc) (flat-contract? key/ctc)
(flat-contract? value/ctc)) (flat-contract? value/ctc))
(flat-idtbl/c key/ctc value/ctc immutable)) (flat-idtbl/c key/ctc value/ctc immutable))
((chaperone-contract? value/ctc) ((chaperone-contract? value/ctc)
(chaperone-idtbl/c key/ctc value/ctc immutable)) (chaperone-idtbl/c key/ctc value/ctc immutable))
(else (else
(impersonator-idtbl/c key/ctc value/ctc immutable)))) (impersonator-idtbl/c key/ctc value/ctc immutable))))
(provide/contract (provide/contract
[make-idtbl [make-idtbl
(->* () (dict? #:phase (or/c #f exact-integer?)) mutable-idtbl?)] (->* () (dict? #:phase (or/c #f exact-integer?)) mutable-idtbl?)]
[make-immutable-idtbl [make-immutable-idtbl
(->* () (dict? #:phase (or/c #f exact-integer?)) immutable-idtbl?)] (->* () (dict? #:phase (or/c #f exact-integer?)) immutable-idtbl?)]
[idtbl? [idtbl?
(-> any/c boolean?)] (-> any/c boolean?)]
[mutable-idtbl? [mutable-idtbl?
(-> any/c boolean?)] (-> any/c boolean?)]
[immutable-idtbl? [immutable-idtbl?
(-> any/c boolean?)] (-> any/c boolean?)]
[idtbl-ref [idtbl-ref
(->* (idtbl? identifier?) (any/c) any)] (->* (idtbl? identifier?) (any/c) any)]
[idtbl-set! [idtbl-set!
(-> mutable-idtbl? identifier? any/c void?)] (-> mutable-idtbl? identifier? any/c void?)]
[idtbl-set [idtbl-set
(-> immutable-idtbl? identifier? any/c immutable-idtbl?)] (-> immutable-idtbl? identifier? any/c immutable-idtbl?)]
[idtbl-remove! [idtbl-remove!
(-> mutable-idtbl? identifier? void?)] (-> mutable-idtbl? identifier? void?)]
[idtbl-remove [idtbl-remove
(-> immutable-idtbl? identifier? immutable-idtbl?)] (-> immutable-idtbl? identifier? immutable-idtbl?)]
[idtbl-count [idtbl-count
(-> idtbl? exact-nonnegative-integer?)] (-> idtbl? exact-nonnegative-integer?)]
[idtbl-iterate-first [idtbl-iterate-first
(-> idtbl? (or/c #f id-table-iter?))] (-> idtbl? (or/c #f id-table-iter?))]
[idtbl-iterate-next [idtbl-iterate-next
(-> idtbl? id-table-iter? (or/c #f id-table-iter?))] (-> idtbl? id-table-iter? (or/c #f id-table-iter?))]
[idtbl-iterate-key [idtbl-iterate-key
(-> idtbl? id-table-iter? identifier?)] (-> idtbl? id-table-iter? identifier?)]
[idtbl-iterate-value [idtbl-iterate-value
(-> idtbl? id-table-iter? any)] (-> idtbl? id-table-iter? any)]
[idtbl-map [idtbl-map
(-> idtbl? (-> identifier? any/c any) list?)] (-> idtbl? (-> identifier? any/c any) list?)]
[idtbl-for-each [idtbl-for-each
(-> idtbl? (-> identifier? any/c any) any)] (-> idtbl? (-> identifier? any/c any) any)]
[idtbl/c [idtbl/c
(->* (chaperone-contract? contract?) (->* (chaperone-contract? contract?)
(#:immutable (or/c 'dont-care #t #f)) (#:immutable (or/c 'dont-care #t #f))
contract?)]))))])) contract?)])))]))
(make-code bound-id-table) (make-code bound-id-table)
(make-code free-id-table) (make-code free-id-table)

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

@ -1,6 +1,7 @@
#lang racket/base #lang racket/base
(require (for-syntax racket/base (require (for-syntax racket/base
racket/syntax) racket/syntax)
(for-meta 2 racket/base)
racket/private/dict) racket/private/dict)
;; No-contract version. ;; No-contract version.
@ -225,162 +226,155 @@ Notes (FIXME?):
(define not-given (gensym 'not-given)) (define not-given (gensym 'not-given))
;; ======== ;; ========
(begin-for-syntax
(define (replace old new template)
(datum->syntax new
(string->symbol
(regexp-replace
(regexp-quote old)
(symbol->string template)
(regexp-replace-quote (symbol->string (syntax-e new)))))))
(define-syntax (define-templates stx)
(syntax-case stx ()
[(_ old new (template ...))
#`(begin
(define/with-syntax template (replace old new 'template)) ...)])))
(define-syntax (make-code stx) (define-syntax (make-code stx)
(syntax-case stx () (syntax-case stx ()
[(_ idtbl [(_ idtbl
identifier->symbol identifier->symbol
identifier=?) identifier=?)
(with-syntax ([mutable-idtbl (let ()
(format-id #'idtbl "mutable-~a" (syntax-e #'idtbl))] (define-templates "idtbl" #'idtbl
[immutable-idtbl (mutable-idtbl immutable-idtbl
(format-id #'idtbl "immutable-~a" (syntax-e #'idtbl))] make-idtbl make-mutable-idtbl make-immutable-idtbl
[make-idtbl idtbl? immutable-idtbl? mutable-idtbl?
(format-id #'idtbl "make-~a" (syntax-e #'idtbl))] idtbl-hash idtbl-phase
[make-mutable-idtbl idtbl-ref
(format-id #'idtbl "make-mutable-~a" (syntax-e #'idtbl))] idtbl-set! idtbl-set
[make-immutable-idtbl idtbl-remove! idtbl-remove
(format-id #'idtbl "make-immutable-~a" (syntax-e #'idtbl))] idtbl-set/constructor idtbl-remove/constructor
[mutable-idtbl? idtbl-count
(format-id #'idtbl "mutable-~a?" (syntax-e #'idtbl))] idtbl-iterate-first idtbl-iterate-next
[immutable-idtbl? idtbl-iterate-key idtbl-iterate-value
(format-id #'idtbl "immutable-~a?" (syntax-e #'idtbl))] idtbl-map idtbl-for-each
[chaperone-idtbl idtbl-mutable-methods idtbl-immutable-methods
(format-id #'idtbl "chaperone-~a" (syntax-e #'idtbl))]) chaperone-idtbl idtbl-chaperone-keys+values/constructor))
(define (s x) (format-id #'idtbl "~a~a" (syntax-e #'idtbl) x)) #'(begin
(with-syntax ([idtbl? (s '?)]
[idtbl-ref (s '-ref)]
[idtbl-set! (s '-set!)]
[idtbl-set (s '-set)]
[idtbl-remove! (s '-remove!)]
[idtbl-remove (s '-remove)]
[idtbl-set/constructor (s '-set/constructor)]
[idtbl-remove/constructor (s '-remove/constructor)]
[idtbl-count (s '-count)]
[idtbl-iterate-first (s '-iterate-first)]
[idtbl-iterate-next (s '-iterate-next)]
[idtbl-iterate-key (s '-iterate-key)]
[idtbl-iterate-value (s '-iterate-value)]
[idtbl-map (s '-map)]
[idtbl-for-each (s '-for-each)]
[idtbl-mutable-methods (s '-mutable-methods)]
[idtbl-immutable-methods (s '-immutable-methods)]
[idtbl-chaperone-keys+values/constructor
(s 'idtbl-chaperone-keys+values/constructor)])
#'(begin
;; Struct defs at end, so that dict methods can refer to earlier procs ;; Struct defs at end, so that dict methods can refer to earlier procs
(define (make-idtbl [init-dict null] (define (make-idtbl [init-dict null]
#:phase [phase (syntax-local-phase-level)]) #:phase [phase (syntax-local-phase-level)])
(make-id-table/constructor 'make-idtbl init-dict phase mutable-idtbl (make-id-table/constructor 'make-idtbl init-dict phase mutable-idtbl
identifier->symbol identifier=?)) identifier->symbol identifier=?))
(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)])
(make-immutable-id-table/constructor 'make-immutable-idtbl init-dict phase immutable-idtbl (make-immutable-id-table/constructor 'make-immutable-idtbl init-dict phase immutable-idtbl
identifier->symbol identifier=?)) identifier->symbol identifier=?))
(define (chaperone-idtbl d ref set! remove! key . args) (define (chaperone-idtbl d ref set! remove! key . args)
(apply chaperone-struct d (apply chaperone-struct d
id-table-phase (lambda (d p) p) id-table-phase (lambda (d p) p)
prop:id-table-impersonator prop:id-table-impersonator
(vector d ref set! remove! key) (vector d ref set! remove! key)
args)) args))
(define (idtbl-ref d id [default not-given]) (define (idtbl-ref d id [default not-given])
(id-table-ref 'idtbl-ref d id default identifier->symbol identifier=?)) (id-table-ref 'idtbl-ref d id default identifier->symbol identifier=?))
(define (idtbl-set! d id v) (define (idtbl-set! d id v)
(id-table-set! 'idtbl-set! d id v identifier->symbol identifier=?)) (id-table-set! 'idtbl-set! d id v identifier->symbol identifier=?))
(define (idtbl-set/constructor d id v constructor) (define (idtbl-set/constructor d id v constructor)
(id-table-set/constructor 'idtbl-set d id v constructor identifier->symbol identifier=?)) (id-table-set/constructor 'idtbl-set d id v constructor identifier->symbol identifier=?))
(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)
(id-table-remove! 'idtbl-remove! d id identifier->symbol identifier=?)) (id-table-remove! 'idtbl-remove! d id identifier->symbol identifier=?))
(define (idtbl-remove/constructor d id constructor) (define (idtbl-remove/constructor d id constructor)
(id-table-remove/constructor 'idtbl-remove d id constructor identifier->symbol identifier=?)) (id-table-remove/constructor 'idtbl-remove d id constructor identifier->symbol identifier=?))
(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)
(id-table-count d)) (id-table-count d))
(define (idtbl-for-each d p) (define (idtbl-for-each d p)
(id-table-for-each d p)) (id-table-for-each d p))
(define (idtbl-map d f) (define (idtbl-map d f)
(id-table-map d f)) (id-table-map d f))
(define (idtbl-iterate-first d) (define (idtbl-iterate-first d)
(id-table-iterate-first d)) (id-table-iterate-first d))
(define (idtbl-iterate-next d pos) (define (idtbl-iterate-next d pos)
(id-table-iterate-next 'idtbl-iterate-next d pos)) (id-table-iterate-next 'idtbl-iterate-next d pos))
(define (idtbl-iterate-key d pos) (define (idtbl-iterate-key d pos)
(id-table-iterate-key 'idtbl-iterate-key d pos)) (id-table-iterate-key 'idtbl-iterate-key d pos))
(define (idtbl-iterate-value d pos) (define (idtbl-iterate-value d pos)
(id-table-iterate-value 'idtbl-iterate-value d pos)) (id-table-iterate-value 'idtbl-iterate-value d pos))
(define (idtbl-chaperone-keys+values/constructor d wrap-key wrap-value constructor) (define (idtbl-chaperone-keys+values/constructor d wrap-key wrap-value constructor)
(constructor (constructor
(for/hasheq (((sym alist) (idtbl-hash d))) (for/hasheq (((sym alist) (id-table-hash d)))
(for/list (((key value) (in-dict alist))) (for/list (((key value) (in-dict alist)))
(cons (wrap-key key) (wrap-value value)))) (cons (wrap-key key) (wrap-value value))))
(idtbl-phase d))) (id-table-phase d)))
(define idtbl-mutable-methods (define idtbl-mutable-methods
(vector-immutable idtbl-ref (vector-immutable idtbl-ref
idtbl-set! idtbl-set!
#f #f
idtbl-remove! idtbl-remove!
#f #f
id-table-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))
(define idtbl-immutable-methods (define idtbl-immutable-methods
(vector-immutable idtbl-ref (vector-immutable idtbl-ref
#f #f
idtbl-set idtbl-set
#f #f
idtbl-remove idtbl-remove
id-table-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 id-table ()) (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)
(provide make-idtbl (provide make-idtbl
make-immutable-idtbl make-immutable-idtbl
idtbl? idtbl?
mutable-idtbl? mutable-idtbl?
immutable-idtbl? immutable-idtbl?
idtbl-ref idtbl-ref
idtbl-set! idtbl-set!
idtbl-set idtbl-set
idtbl-remove! idtbl-remove!
idtbl-remove idtbl-remove
idtbl-count idtbl-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
idtbl-map idtbl-map
idtbl-for-each idtbl-for-each
;; just for use/extension by syntax/id-table ;; just for use/extension by syntax/id-table
chaperone-idtbl chaperone-idtbl
idtbl-chaperone-keys+values/constructor idtbl-chaperone-keys+values/constructor
idtbl-set/constructor idtbl-set/constructor
idtbl-remove/constructor idtbl-remove/constructor
idtbl-mutable-methods idtbl-mutable-methods
mutable-idtbl mutable-idtbl
immutable-idtbl))))])) immutable-idtbl)))]))
(define (bound-identifier->symbol id phase) (syntax-e id)) (define (bound-identifier->symbol id phase) (syntax-e id))