Clean up creation of identifiers in id-table.rkt
This commit is contained in:
Eric Dobson
Ryan Culpepper
parent
4725775126
commit
d4efe8f5aa
|
|
@ -1,6 +1,7 @@
|
|||
#lang racket/base
|
||||
(require (for-syntax racket/base
|
||||
racket/syntax)
|
||||
(for-meta 2 racket/base)
|
||||
racket/contract/base
|
||||
racket/contract/combinator
|
||||
racket/dict
|
||||
|
|
@ -29,280 +30,268 @@
|
|||
any/c
|
||||
id-table-iter?
|
||||
#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)
|
||||
(syntax-case stx ()
|
||||
[(_ idtbl)
|
||||
(with-syntax ([mutable-idtbl
|
||||
(format-id #'idtbl "mutable-~a" (syntax-e #'idtbl))]
|
||||
[immutable-idtbl
|
||||
(format-id #'idtbl "immutable-~a" (syntax-e #'idtbl))]
|
||||
[mutable-idtbl*
|
||||
(format-id #'idtbl "mutable-~a*" (syntax-e #'idtbl))]
|
||||
[immutable-idtbl*
|
||||
(format-id #'idtbl "immutable-~a*" (syntax-e #'idtbl))]
|
||||
[make-idtbl
|
||||
(format-id #'idtbl "make-~a" (syntax-e #'idtbl))]
|
||||
[make-mutable-idtbl
|
||||
(format-id #'idtbl "make-mutable-~a" (syntax-e #'idtbl))]
|
||||
[make-immutable-idtbl
|
||||
(format-id #'idtbl "make-immutable-~a" (syntax-e #'idtbl))]
|
||||
[mutable-idtbl?
|
||||
(format-id #'idtbl "mutable-~a?" (syntax-e #'idtbl))]
|
||||
[immutable-idtbl?
|
||||
(format-id #'idtbl "immutable-~a?" (syntax-e #'idtbl))]
|
||||
[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
|
||||
(let ()
|
||||
(define-templates "idtbl" #'idtbl
|
||||
(mutable-idtbl* immutable-idtbl* mutable-idtbl immutable-idtbl
|
||||
make-idtbl make-mutable-idtbl make-immutable-idtbl
|
||||
idtbl? immutable-idtbl? mutable-idtbl?
|
||||
idtbl-hash idtbl-phase
|
||||
idtbl-ref
|
||||
idtbl-set! idtbl-set
|
||||
idtbl-remove! idtbl-remove
|
||||
idtbl-set/constructor idtbl-remove/constructor
|
||||
idtbl-count
|
||||
idtbl-iterate-first idtbl-iterate-next
|
||||
idtbl-iterate-key idtbl-iterate-value
|
||||
idtbl-map idtbl-for-each
|
||||
idtbl-mutable-methods idtbl-immutable-methods
|
||||
idtbl/c
|
||||
chaperone-idtbl 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]
|
||||
#:phase [phase (syntax-local-phase-level)])
|
||||
(let ([t (mutable-idtbl (make-hasheq) phase)])
|
||||
(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)])
|
||||
(define (make-idtbl [init-dict null]
|
||||
#:phase [phase (syntax-local-phase-level)])
|
||||
(let ([t (mutable-idtbl (make-hasheq) phase)])
|
||||
(for ([(k v) (in-dict init-dict)])
|
||||
(unless (identifier? k)
|
||||
(raise-type-error 'make-immutable-idtbl
|
||||
(raise-type-error 'make-idtbl
|
||||
"dictionary with identifier keys" init-dict))
|
||||
(idtbl-set t k v)))
|
||||
(idtbl-set! t k v))
|
||||
t))
|
||||
|
||||
;; 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 (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)
|
||||
(raise-type-error 'make-immutable-idtbl
|
||||
"dictionary with identifier keys" init-dict))
|
||||
(idtbl-set t k v)))
|
||||
|
||||
(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)
|
||||
(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-struct base-idtbl/c (dom rng immutable))
|
||||
|
||||
(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 "the keys of" #: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? 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
|
||||
(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)
|
||||
(unless (immutable? val)
|
||||
(raise-blame-error blame val
|
||||
'(expected "an immutable ~a," given: "~e") 'idtbl val))]
|
||||
(list '#:immutable #t)]
|
||||
[(#f)
|
||||
(when (immutable? val)
|
||||
(raise-blame-error blame val
|
||||
'(expected "a mutable ~a," given: "~e") 'idtbl val))]
|
||||
[(dont-care) (void)]))
|
||||
(list '#:immutable #f)]))))
|
||||
|
||||
(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)))))))
|
||||
(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 "the keys of" #: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? 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)
|
||||
(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 ()
|
||||
#: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))
|
||||
(define rng-proj (idtbl/c-rng-pos-proj ctc))
|
||||
(for ([(k v) (in-dict val)])
|
||||
(dom-proj k)
|
||||
(rng-proj v))
|
||||
val)))))
|
||||
(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))
|
||||
(define rng-proj (idtbl/c-rng-pos-proj ctc))
|
||||
(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 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 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
|
||||
dict-contract-methods))
|
||||
(struct immutable-idtbl immutable-idtbl* ()
|
||||
#:property prop:dict/contract
|
||||
(list idtbl-immutable-methods
|
||||
dict-contract-methods))
|
||||
(struct mutable-idtbl mutable-idtbl* ()
|
||||
#:property prop:dict/contract
|
||||
(list idtbl-mutable-methods
|
||||
dict-contract-methods))
|
||||
(struct immutable-idtbl immutable-idtbl* ()
|
||||
#:property prop:dict/contract
|
||||
(list idtbl-immutable-methods
|
||||
dict-contract-methods))
|
||||
|
||||
(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))))
|
||||
(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))))
|
||||
|
||||
(provide/contract
|
||||
[make-idtbl
|
||||
(->* () (dict? #:phase (or/c #f exact-integer?)) mutable-idtbl?)]
|
||||
[make-immutable-idtbl
|
||||
(->* () (dict? #:phase (or/c #f exact-integer?)) immutable-idtbl?)]
|
||||
[idtbl?
|
||||
(-> any/c boolean?)]
|
||||
[mutable-idtbl?
|
||||
(-> any/c boolean?)]
|
||||
[immutable-idtbl?
|
||||
(-> any/c boolean?)]
|
||||
[idtbl-ref
|
||||
(->* (idtbl? identifier?) (any/c) any)]
|
||||
[idtbl-set!
|
||||
(-> mutable-idtbl? identifier? any/c void?)]
|
||||
[idtbl-set
|
||||
(-> immutable-idtbl? identifier? any/c immutable-idtbl?)]
|
||||
[idtbl-remove!
|
||||
(-> mutable-idtbl? identifier? void?)]
|
||||
[idtbl-remove
|
||||
(-> immutable-idtbl? identifier? immutable-idtbl?)]
|
||||
[idtbl-count
|
||||
(-> idtbl? exact-nonnegative-integer?)]
|
||||
[idtbl-iterate-first
|
||||
(-> idtbl? (or/c #f id-table-iter?))]
|
||||
[idtbl-iterate-next
|
||||
(-> idtbl? id-table-iter? (or/c #f id-table-iter?))]
|
||||
[idtbl-iterate-key
|
||||
(-> idtbl? id-table-iter? identifier?)]
|
||||
[idtbl-iterate-value
|
||||
(-> idtbl? id-table-iter? any)]
|
||||
[idtbl-map
|
||||
(-> idtbl? (-> identifier? any/c any) list?)]
|
||||
[idtbl-for-each
|
||||
(-> idtbl? (-> identifier? any/c any) any)]
|
||||
[idtbl/c
|
||||
(->* (chaperone-contract? contract?)
|
||||
(#:immutable (or/c 'dont-care #t #f))
|
||||
contract?)]))))]))
|
||||
(provide/contract
|
||||
[make-idtbl
|
||||
(->* () (dict? #:phase (or/c #f exact-integer?)) mutable-idtbl?)]
|
||||
[make-immutable-idtbl
|
||||
(->* () (dict? #:phase (or/c #f exact-integer?)) immutable-idtbl?)]
|
||||
[idtbl?
|
||||
(-> any/c boolean?)]
|
||||
[mutable-idtbl?
|
||||
(-> any/c boolean?)]
|
||||
[immutable-idtbl?
|
||||
(-> any/c boolean?)]
|
||||
[idtbl-ref
|
||||
(->* (idtbl? identifier?) (any/c) any)]
|
||||
[idtbl-set!
|
||||
(-> mutable-idtbl? identifier? any/c void?)]
|
||||
[idtbl-set
|
||||
(-> immutable-idtbl? identifier? any/c immutable-idtbl?)]
|
||||
[idtbl-remove!
|
||||
(-> mutable-idtbl? identifier? void?)]
|
||||
[idtbl-remove
|
||||
(-> immutable-idtbl? identifier? immutable-idtbl?)]
|
||||
[idtbl-count
|
||||
(-> idtbl? exact-nonnegative-integer?)]
|
||||
[idtbl-iterate-first
|
||||
(-> idtbl? (or/c #f id-table-iter?))]
|
||||
[idtbl-iterate-next
|
||||
(-> idtbl? id-table-iter? (or/c #f id-table-iter?))]
|
||||
[idtbl-iterate-key
|
||||
(-> idtbl? id-table-iter? identifier?)]
|
||||
[idtbl-iterate-value
|
||||
(-> idtbl? id-table-iter? any)]
|
||||
[idtbl-map
|
||||
(-> idtbl? (-> identifier? any/c any) list?)]
|
||||
[idtbl-for-each
|
||||
(-> idtbl? (-> identifier? any/c any) any)]
|
||||
[idtbl/c
|
||||
(->* (chaperone-contract? contract?)
|
||||
(#:immutable (or/c 'dont-care #t #f))
|
||||
contract?)])))]))
|
||||
|
||||
(make-code bound-id-table)
|
||||
(make-code free-id-table)
|
||||
|
|
|
|||
|
|
@ -1,6 +1,7 @@
|
|||
#lang racket/base
|
||||
(require (for-syntax racket/base
|
||||
racket/syntax)
|
||||
(for-meta 2 racket/base)
|
||||
racket/private/dict)
|
||||
|
||||
;; No-contract version.
|
||||
|
|
@ -225,162 +226,155 @@ Notes (FIXME?):
|
|||
(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)
|
||||
(syntax-case stx ()
|
||||
[(_ idtbl
|
||||
identifier->symbol
|
||||
identifier=?)
|
||||
(with-syntax ([mutable-idtbl
|
||||
(format-id #'idtbl "mutable-~a" (syntax-e #'idtbl))]
|
||||
[immutable-idtbl
|
||||
(format-id #'idtbl "immutable-~a" (syntax-e #'idtbl))]
|
||||
[make-idtbl
|
||||
(format-id #'idtbl "make-~a" (syntax-e #'idtbl))]
|
||||
[make-mutable-idtbl
|
||||
(format-id #'idtbl "make-mutable-~a" (syntax-e #'idtbl))]
|
||||
[make-immutable-idtbl
|
||||
(format-id #'idtbl "make-immutable-~a" (syntax-e #'idtbl))]
|
||||
[mutable-idtbl?
|
||||
(format-id #'idtbl "mutable-~a?" (syntax-e #'idtbl))]
|
||||
[immutable-idtbl?
|
||||
(format-id #'idtbl "immutable-~a?" (syntax-e #'idtbl))]
|
||||
[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-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
|
||||
(let ()
|
||||
(define-templates "idtbl" #'idtbl
|
||||
(mutable-idtbl immutable-idtbl
|
||||
make-idtbl make-mutable-idtbl make-immutable-idtbl
|
||||
idtbl? immutable-idtbl? mutable-idtbl?
|
||||
idtbl-hash idtbl-phase
|
||||
idtbl-ref
|
||||
idtbl-set! idtbl-set
|
||||
idtbl-remove! idtbl-remove
|
||||
idtbl-set/constructor idtbl-remove/constructor
|
||||
idtbl-count
|
||||
idtbl-iterate-first idtbl-iterate-next
|
||||
idtbl-iterate-key idtbl-iterate-value
|
||||
idtbl-map idtbl-for-each
|
||||
idtbl-mutable-methods idtbl-immutable-methods
|
||||
chaperone-idtbl idtbl-chaperone-keys+values/constructor))
|
||||
#'(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
|
||||
identifier->symbol identifier=?))
|
||||
;; 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
|
||||
identifier->symbol identifier=?))
|
||||
|
||||
(define (make-immutable-idtbl [init-dict null]
|
||||
#:phase [phase (syntax-local-phase-level)])
|
||||
(make-immutable-id-table/constructor 'make-immutable-idtbl init-dict phase immutable-idtbl
|
||||
identifier->symbol identifier=?))
|
||||
(define (make-immutable-idtbl [init-dict null]
|
||||
#:phase [phase (syntax-local-phase-level)])
|
||||
(make-immutable-id-table/constructor 'make-immutable-idtbl init-dict phase immutable-idtbl
|
||||
identifier->symbol identifier=?))
|
||||
|
||||
(define (chaperone-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-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 (idtbl-ref d id [default not-given])
|
||||
(id-table-ref 'idtbl-ref d id default identifier->symbol identifier=?))
|
||||
(define (idtbl-set! d id v)
|
||||
(id-table-set! 'idtbl-set! d id v identifier->symbol identifier=?))
|
||||
(define (idtbl-set/constructor d id v constructor)
|
||||
(id-table-set/constructor 'idtbl-set d id v constructor identifier->symbol identifier=?))
|
||||
(define (idtbl-set d id v)
|
||||
(idtbl-set/constructor d id v immutable-idtbl))
|
||||
(define (idtbl-remove! d id)
|
||||
(id-table-remove! 'idtbl-remove! d id identifier->symbol identifier=?))
|
||||
(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)
|
||||
(id-table-set! 'idtbl-set! d id v identifier->symbol identifier=?))
|
||||
(define (idtbl-set/constructor d id v constructor)
|
||||
(id-table-set/constructor 'idtbl-set d id v constructor identifier->symbol identifier=?))
|
||||
(define (idtbl-set d id v)
|
||||
(idtbl-set/constructor d id v immutable-idtbl))
|
||||
(define (idtbl-remove! d id)
|
||||
(id-table-remove! 'idtbl-remove! d id identifier->symbol identifier=?))
|
||||
|
||||
(define (idtbl-remove/constructor d id constructor)
|
||||
(id-table-remove/constructor 'idtbl-remove d id constructor identifier->symbol identifier=?))
|
||||
(define (idtbl-remove d id)
|
||||
(idtbl-remove/constructor d id immutable-idtbl))
|
||||
(define (idtbl-count d)
|
||||
(id-table-count d))
|
||||
(define (idtbl-for-each d p)
|
||||
(id-table-for-each d p))
|
||||
(define (idtbl-map d f)
|
||||
(id-table-map d f))
|
||||
(define (idtbl-iterate-first d)
|
||||
(id-table-iterate-first d))
|
||||
(define (idtbl-iterate-next d pos)
|
||||
(id-table-iterate-next 'idtbl-iterate-next d pos))
|
||||
(define (idtbl-iterate-key d pos)
|
||||
(id-table-iterate-key 'idtbl-iterate-key d pos))
|
||||
(define (idtbl-iterate-value d pos)
|
||||
(id-table-iterate-value 'idtbl-iterate-value d pos))
|
||||
(define (idtbl-remove/constructor d id constructor)
|
||||
(id-table-remove/constructor 'idtbl-remove d id constructor identifier->symbol identifier=?))
|
||||
(define (idtbl-remove d id)
|
||||
(idtbl-remove/constructor d id immutable-idtbl))
|
||||
(define (idtbl-count d)
|
||||
(id-table-count d))
|
||||
(define (idtbl-for-each d p)
|
||||
(id-table-for-each d p))
|
||||
(define (idtbl-map d f)
|
||||
(id-table-map d f))
|
||||
(define (idtbl-iterate-first d)
|
||||
(id-table-iterate-first d))
|
||||
(define (idtbl-iterate-next d pos)
|
||||
(id-table-iterate-next 'idtbl-iterate-next d pos))
|
||||
(define (idtbl-iterate-key d pos)
|
||||
(id-table-iterate-key 'idtbl-iterate-key d pos))
|
||||
(define (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)
|
||||
(constructor
|
||||
(for/hasheq (((sym alist) (idtbl-hash d)))
|
||||
(for/list (((key value) (in-dict alist)))
|
||||
(cons (wrap-key key) (wrap-value value))))
|
||||
(idtbl-phase d)))
|
||||
(define (idtbl-chaperone-keys+values/constructor d wrap-key wrap-value constructor)
|
||||
(constructor
|
||||
(for/hasheq (((sym alist) (id-table-hash d)))
|
||||
(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!
|
||||
#f
|
||||
idtbl-remove!
|
||||
#f
|
||||
id-table-count
|
||||
idtbl-iterate-first
|
||||
idtbl-iterate-next
|
||||
idtbl-iterate-key
|
||||
idtbl-iterate-value))
|
||||
(define idtbl-mutable-methods
|
||||
(vector-immutable idtbl-ref
|
||||
idtbl-set!
|
||||
#f
|
||||
idtbl-remove!
|
||||
#f
|
||||
id-table-count
|
||||
idtbl-iterate-first
|
||||
idtbl-iterate-next
|
||||
idtbl-iterate-key
|
||||
idtbl-iterate-value))
|
||||
|
||||
(define idtbl-immutable-methods
|
||||
(vector-immutable idtbl-ref
|
||||
#f
|
||||
idtbl-set
|
||||
#f
|
||||
idtbl-remove
|
||||
id-table-count
|
||||
idtbl-iterate-first
|
||||
idtbl-iterate-next
|
||||
idtbl-iterate-key
|
||||
idtbl-iterate-value))
|
||||
(define idtbl-immutable-methods
|
||||
(vector-immutable idtbl-ref
|
||||
#f
|
||||
idtbl-set
|
||||
#f
|
||||
idtbl-remove
|
||||
id-table-count
|
||||
idtbl-iterate-first
|
||||
idtbl-iterate-next
|
||||
idtbl-iterate-key
|
||||
idtbl-iterate-value))
|
||||
|
||||
(struct idtbl id-table ())
|
||||
(struct mutable-idtbl idtbl ()
|
||||
#:property prop:dict idtbl-mutable-methods)
|
||||
(struct immutable-idtbl idtbl ()
|
||||
#:property prop:dict idtbl-immutable-methods)
|
||||
(struct idtbl id-table ())
|
||||
(struct mutable-idtbl idtbl ()
|
||||
#:property prop:dict idtbl-mutable-methods)
|
||||
(struct immutable-idtbl idtbl ()
|
||||
#:property prop:dict idtbl-immutable-methods)
|
||||
|
||||
(provide make-idtbl
|
||||
make-immutable-idtbl
|
||||
idtbl?
|
||||
mutable-idtbl?
|
||||
immutable-idtbl?
|
||||
idtbl-ref
|
||||
idtbl-set!
|
||||
idtbl-set
|
||||
idtbl-remove!
|
||||
idtbl-remove
|
||||
idtbl-count
|
||||
idtbl-iterate-first
|
||||
idtbl-iterate-next
|
||||
idtbl-iterate-key
|
||||
idtbl-iterate-value
|
||||
idtbl-map
|
||||
idtbl-for-each
|
||||
(provide make-idtbl
|
||||
make-immutable-idtbl
|
||||
idtbl?
|
||||
mutable-idtbl?
|
||||
immutable-idtbl?
|
||||
idtbl-ref
|
||||
idtbl-set!
|
||||
idtbl-set
|
||||
idtbl-remove!
|
||||
idtbl-remove
|
||||
idtbl-count
|
||||
idtbl-iterate-first
|
||||
idtbl-iterate-next
|
||||
idtbl-iterate-key
|
||||
idtbl-iterate-value
|
||||
idtbl-map
|
||||
idtbl-for-each
|
||||
|
||||
;; just for use/extension by syntax/id-table
|
||||
chaperone-idtbl
|
||||
idtbl-chaperone-keys+values/constructor
|
||||
idtbl-set/constructor
|
||||
idtbl-remove/constructor
|
||||
idtbl-mutable-methods
|
||||
mutable-idtbl
|
||||
immutable-idtbl))))]))
|
||||
;; just for use/extension by syntax/id-table
|
||||
chaperone-idtbl
|
||||
idtbl-chaperone-keys+values/constructor
|
||||
idtbl-set/constructor
|
||||
idtbl-remove/constructor
|
||||
idtbl-mutable-methods
|
||||
mutable-idtbl
|
||||
immutable-idtbl)))]))
|
||||
|
||||
(define (bound-identifier->symbol id phase) (syntax-e id))
|
||||
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user