fixed racket/dict contracts
un-split syntax/id-table (no contract-free version)
This commit is contained in:
Ryan Culpepper
parent
2e4ff119e7
commit
e72244513d
|
|
@ -68,14 +68,7 @@
|
||||||
(define dict-ref-contract
|
(define dict-ref-contract
|
||||||
(->i ([d dict?] [k (d) (dict-key-contract d)])
|
(->i ([d dict?] [k (d) (dict-key-contract d)])
|
||||||
([default any/c])
|
([default any/c])
|
||||||
[_ (d default) (or/c (lambda (x) (eq? x default))
|
any)) ;; because default can be multi-valued procedure
|
||||||
(dict-value-contract d))]))
|
|
||||||
(define dict-ref!-contract
|
|
||||||
(->i ([d (and/c dict? dict-mutable?)]
|
|
||||||
[k (d) (dict-key-contract d)]
|
|
||||||
[default (d) (or/c (dict-value-contract d)
|
|
||||||
(-> (dict-value-contract d)))]) ;; use if/c ??
|
|
||||||
[_ (d) (dict-value-contract d)]))
|
|
||||||
(define dict-set!-contract
|
(define dict-set!-contract
|
||||||
(->i ([d (and/c dict? dict-mutable?)]
|
(->i ([d (and/c dict? dict-mutable?)]
|
||||||
[k (d) (dict-key-contract d)]
|
[k (d) (dict-key-contract d)]
|
||||||
|
|
@ -152,9 +145,8 @@
|
||||||
[dict-ref!
|
[dict-ref!
|
||||||
(->i ([d (and/c dict? dict-mutable?)]
|
(->i ([d (and/c dict? dict-mutable?)]
|
||||||
[k (d) (dict-key-contract d)]
|
[k (d) (dict-key-contract d)]
|
||||||
[default any/c]) ;; use if/c ?
|
[default (d) (or/c (dict-value-contract d) (-> (dict-value-contract d)))]) ;; use if/c ?
|
||||||
[_ (d default) (or/c (lambda (x) (eq? x default))
|
[_ (d) (dict-value-contract d)])]
|
||||||
(dict-value-contract d))])]
|
|
||||||
[dict-set!
|
[dict-set!
|
||||||
dict-set!-contract]
|
dict-set!-contract]
|
||||||
[dict-set
|
[dict-set
|
||||||
|
|
|
||||||
|
|
@ -1,25 +1,64 @@
|
||||||
#lang racket/base
|
#lang racket/base
|
||||||
(require (for-syntax scheme/base)
|
(require (for-syntax racket/base
|
||||||
|
unstable/syntax)
|
||||||
racket/contract/base
|
racket/contract/base
|
||||||
racket/dict
|
racket/dict)
|
||||||
"private/id-table.ss")
|
|
||||||
#|
|
|
||||||
(provide id-table-position?)
|
|
||||||
|
|
||||||
(define id-table-position/c
|
(define-struct id-table-iter (a b))
|
||||||
(flat-named-contract "id-table-position or false"
|
|
||||||
(lambda (x) (or (id-table-position? x)
|
|
||||||
(eq? x #f)))))
|
|
||||||
|#
|
|
||||||
|
|
||||||
(define-for-syntax (format-id stx fmt . args)
|
;; ========
|
||||||
(datum->syntax stx (string->symbol (apply format fmt args))))
|
|
||||||
|
(define (alist-set identifier=? phase l0 id v)
|
||||||
|
;; To minimize allocation
|
||||||
|
;; - add new pairs to front
|
||||||
|
;; - avoid allocation on idempotent sets
|
||||||
|
(let* ([not-found? #f]
|
||||||
|
[new-l
|
||||||
|
(let loop ([l l0])
|
||||||
|
(cond [(null? l) (begin (set! not-found? #t) null)]
|
||||||
|
[(identifier=? (caar l) id phase)
|
||||||
|
(if (eq? v (cdar l)) ;; idempotent; just leave it alone
|
||||||
|
l
|
||||||
|
(cons (cons id v) (cdr l)))]
|
||||||
|
[else
|
||||||
|
(let ([rest* (loop (cdr l))])
|
||||||
|
(if (eq? (cdr l) rest*)
|
||||||
|
l
|
||||||
|
(cons (car l) rest*)))]))])
|
||||||
|
(if not-found?
|
||||||
|
(cons (cons id v) l0)
|
||||||
|
new-l)))
|
||||||
|
|
||||||
|
(define (alist-remove identifier=? phase l0 id)
|
||||||
|
;; To minimize allocation
|
||||||
|
;; - avoid allocation on idempotent removes
|
||||||
|
(let loop ([l l0])
|
||||||
|
(cond [(null? l) null]
|
||||||
|
[(identifier=? (caar l) id phase)
|
||||||
|
(cdr l)]
|
||||||
|
[else
|
||||||
|
(let ([rest* (loop (cdr l))])
|
||||||
|
(if (eq? (cdr l) rest*)
|
||||||
|
l
|
||||||
|
(cons (car l) rest*)))])))
|
||||||
|
|
||||||
|
(define not-given (gensym 'not-given))
|
||||||
|
|
||||||
|
;; ========
|
||||||
|
|
||||||
(define-syntax (make-code stx)
|
(define-syntax (make-code stx)
|
||||||
(syntax-case stx ()
|
(syntax-case stx ()
|
||||||
[(_ idtbl)
|
[(_ idtbl
|
||||||
(with-syntax ([make-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))]
|
(format-id #'idtbl "make-~a" (syntax-e #'idtbl))]
|
||||||
|
[make-mutable-idtbl
|
||||||
|
(format-id #'idtbl "make-mutable-~a" (syntax-e #'idtbl))]
|
||||||
[make-immutable-idtbl
|
[make-immutable-idtbl
|
||||||
(format-id #'idtbl "make-immutable-~a" (syntax-e #'idtbl))]
|
(format-id #'idtbl "make-immutable-~a" (syntax-e #'idtbl))]
|
||||||
[mutable-idtbl?
|
[mutable-idtbl?
|
||||||
|
|
@ -28,6 +67,8 @@
|
||||||
(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)]
|
||||||
|
|
@ -41,32 +82,211 @@
|
||||||
[idtbl-map (s '-map)]
|
[idtbl-map (s '-map)]
|
||||||
[idtbl-for-each (s '-for-each)])
|
[idtbl-for-each (s '-for-each)])
|
||||||
#'(begin
|
#'(begin
|
||||||
(provide idtbl?
|
|
||||||
mutable-idtbl?
|
|
||||||
immutable-idtbl?)
|
|
||||||
(provide/contract
|
|
||||||
[make-idtbl (->* () (dict? #:phase (or/c exact-integer? #f)) any)]
|
|
||||||
[make-immutable-idtbl (->* () (dict? #:phase (or/c exact-integer? #f)) any)]
|
|
||||||
[idtbl-ref (->* (idtbl? any/c) (any/c)
|
|
||||||
any)]
|
|
||||||
[idtbl-set! (-> mutable-idtbl? any/c any/c
|
|
||||||
any)]
|
|
||||||
[idtbl-set (-> immutable-idtbl? any/c any/c
|
|
||||||
immutable-idtbl?)]
|
|
||||||
[idtbl-remove! (-> mutable-idtbl? any/c
|
|
||||||
any)]
|
|
||||||
[idtbl-remove (-> immutable-idtbl? any/c
|
|
||||||
immutable-idtbl?)]
|
|
||||||
[idtbl-count (-> idtbl? exact-nonnegative-integer?)]
|
|
||||||
#|
|
|
||||||
[idtbl-iterate-first (-> idtbl? id-table-position/c)]
|
|
||||||
[idtbl-iterate-next (-> idtbl? id-table-position/c id-table-position/c)]
|
|
||||||
[idtbl-iterate-key (-> idtbl? id-table-position/c identifier?)]
|
|
||||||
[idtbl-iterate-value (-> idtbl? id-table-position/c any)]
|
|
||||||
|#
|
|
||||||
[idtbl-map (-> idtbl? (-> any/c any/c any) any)]
|
|
||||||
[idtbl-for-each (-> idtbl? (-> any/c any/c any) any)]))))]))
|
|
||||||
|
|
||||||
(make-code bound-id-table)
|
;; Struct defs at end, so that dict methods can refer to earlier procs
|
||||||
(make-code free-id-table)
|
|
||||||
;; (make-code free*-id-table)
|
(define (make-idtbl [init-dict null]
|
||||||
|
#:phase [phase (syntax-local-phase-level)])
|
||||||
|
;; init-dict is good candidate for object/c like dict/c
|
||||||
|
(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)])
|
||||||
|
(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])
|
||||||
|
(let ([phase (idtbl-phase d)])
|
||||||
|
(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)
|
||||||
|
(let* ([phase (idtbl-phase d)]
|
||||||
|
[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 d id v)
|
||||||
|
(let* ([phase (idtbl-phase d)]
|
||||||
|
[sym (identifier->symbol id phase)]
|
||||||
|
[l (hash-ref (idtbl-hash d) sym null)])
|
||||||
|
(immutable-idtbl
|
||||||
|
(hash-set (idtbl-hash d)
|
||||||
|
sym
|
||||||
|
(alist-set identifier=? phase l id v))
|
||||||
|
phase)))
|
||||||
|
|
||||||
|
(define (idtbl-remove! d id)
|
||||||
|
(let* ([phase (idtbl-phase d)]
|
||||||
|
[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 d id)
|
||||||
|
(let* ([phase (idtbl-phase d)]
|
||||||
|
[sym (identifier->symbol id phase)]
|
||||||
|
[l (hash-ref (idtbl-hash d) sym null)]
|
||||||
|
[newl (alist-remove identifier=? phase l id)])
|
||||||
|
(immutable-idtbl
|
||||||
|
(if (pair? newl)
|
||||||
|
(hash-set (idtbl-hash d) sym newl)
|
||||||
|
(hash-remove (idtbl-hash d) sym))
|
||||||
|
phase)))
|
||||||
|
|
||||||
|
(define (idtbl-count d)
|
||||||
|
(apply + (hash-map (idtbl-hash d) (lambda (k v) (length v)))))
|
||||||
|
|
||||||
|
(define (idtbl-for-each d p)
|
||||||
|
(define (pp i) (p (car i) (cdr i)))
|
||||||
|
(hash-for-each (idtbl-hash d)
|
||||||
|
(lambda (k v) (for-each pp v))))
|
||||||
|
|
||||||
|
(define (idtbl-map d f)
|
||||||
|
(define (fp i) (f (car i) (cdr i)))
|
||||||
|
(apply append
|
||||||
|
(hash-map (idtbl-hash d)
|
||||||
|
(lambda (k v) (map fp v)))))
|
||||||
|
|
||||||
|
(define (idtbl-iterate-first d)
|
||||||
|
(let ([h (idtbl-hash 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)
|
||||||
|
(let ([h (idtbl-hash d)]
|
||||||
|
[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)
|
||||||
|
(let ([h (idtbl-hash d)]
|
||||||
|
[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)
|
||||||
|
(let ([h (idtbl-hash d)]
|
||||||
|
[a (id-table-iter-a pos)]
|
||||||
|
[b (id-table-iter-b pos)])
|
||||||
|
(dict-iterate-value (dict-iterate-value h a) b)))
|
||||||
|
|
||||||
|
(struct idtbl (hash phase))
|
||||||
|
(struct mutable-idtbl idtbl ()
|
||||||
|
#:property prop:dict/contract
|
||||||
|
(list (vector-immutable idtbl-ref
|
||||||
|
idtbl-set!
|
||||||
|
#f
|
||||||
|
idtbl-remove!
|
||||||
|
#f
|
||||||
|
idtbl-count
|
||||||
|
idtbl-iterate-first
|
||||||
|
idtbl-iterate-next
|
||||||
|
idtbl-iterate-key
|
||||||
|
idtbl-iterate-value)
|
||||||
|
(vector-immutable identifier?
|
||||||
|
any/c
|
||||||
|
id-table-iter?
|
||||||
|
#f #f #f)))
|
||||||
|
(struct immutable-idtbl idtbl ()
|
||||||
|
#:property prop:dict/contract
|
||||||
|
(list (vector-immutable idtbl-ref
|
||||||
|
#f
|
||||||
|
idtbl-set
|
||||||
|
#f
|
||||||
|
idtbl-remove
|
||||||
|
idtbl-count
|
||||||
|
idtbl-iterate-first
|
||||||
|
idtbl-iterate-next
|
||||||
|
idtbl-iterate-key
|
||||||
|
idtbl-iterate-value)
|
||||||
|
(vector-immutable identifier?
|
||||||
|
any/c
|
||||||
|
id-table-iter?
|
||||||
|
#f #f #f)))
|
||||||
|
|
||||||
|
(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)]))))]))
|
||||||
|
|
||||||
|
(define (bound-identifier->symbol id phase) (syntax-e id))
|
||||||
|
|
||||||
|
(make-code bound-id-table
|
||||||
|
bound-identifier->symbol
|
||||||
|
bound-identifier=?)
|
||||||
|
|
||||||
|
(define (free-identifier->symbol id phase)
|
||||||
|
(let ([binding (identifier-binding id phase)])
|
||||||
|
(if (pair? binding)
|
||||||
|
(cadr binding)
|
||||||
|
(syntax-e id))))
|
||||||
|
|
||||||
|
(make-code free-id-table
|
||||||
|
free-identifier->symbol
|
||||||
|
free-identifier=?)
|
||||||
|
|
||||||
|
(provide/contract
|
||||||
|
[id-table-iter? (-> any/c boolean?)])
|
||||||
|
|
|
||||||
|
|
@ -1,331 +0,0 @@
|
||||||
#lang scheme/base
|
|
||||||
(require (for-syntax scheme/base
|
|
||||||
unstable/syntax)
|
|
||||||
scheme/dict)
|
|
||||||
(provide id-table-position?)
|
|
||||||
|
|
||||||
#|
|
|
||||||
(require (rename-in scheme/base [car s:car]))
|
|
||||||
(define-syntax (car stx)
|
|
||||||
(syntax-case stx ()
|
|
||||||
[(car x)
|
|
||||||
#`(begin (unless (pair? x)
|
|
||||||
(error 'car (format "~s:~s"
|
|
||||||
'#,(syntax-line stx)
|
|
||||||
'#,(syntax-column stx))))
|
|
||||||
(s:car x))]))
|
|
||||||
|#
|
|
||||||
|
|
||||||
(define-struct id-table-position (a b))
|
|
||||||
|
|
||||||
(define empty-immutable-hasheq (make-immutable-hasheq null))
|
|
||||||
|
|
||||||
(define (check-id x who)
|
|
||||||
(unless (identifier? x)
|
|
||||||
(raise-type-error who "identifier" x)))
|
|
||||||
|
|
||||||
(define (check-pos x who)
|
|
||||||
(unless (id-table-position? x)
|
|
||||||
(raise-type-error who "id-table-position" x)))
|
|
||||||
|
|
||||||
(define (wrap f protectors [arity (length protectors)])
|
|
||||||
(define name (object-name f))
|
|
||||||
(procedure-reduce-arity
|
|
||||||
(procedure-rename
|
|
||||||
(lambda args
|
|
||||||
(let loop ([args args] [protectors protectors])
|
|
||||||
(when (pair? args)
|
|
||||||
(unless (pair? protectors)
|
|
||||||
(error name "out of guards"))
|
|
||||||
((car protectors) (car args) name)
|
|
||||||
(loop (cdr args) (cdr protectors))))
|
|
||||||
(apply f args))
|
|
||||||
name)
|
|
||||||
arity))
|
|
||||||
;; ========
|
|
||||||
|
|
||||||
;; Inline alist operations...
|
|
||||||
;; id, v args must be variables (to avoid duplicating expressions)
|
|
||||||
|
|
||||||
(define-syntax-rule (alist-set identifier=? phase l0 id v)
|
|
||||||
;; To minimize allocation
|
|
||||||
;; - add new pairs to front
|
|
||||||
;; - avoid allocation on idempotent sets
|
|
||||||
(let* ([not-found? #f]
|
|
||||||
[new-l
|
|
||||||
(let loop ([l l0])
|
|
||||||
(cond [(null? l) (begin (set! not-found? #t) null)]
|
|
||||||
[(identifier=? (caar l) id phase)
|
|
||||||
(if (eq? v (cdar l)) ;; idempotent; just leave it alone
|
|
||||||
l
|
|
||||||
(cons (cons id v) (cdr l)))]
|
|
||||||
[else
|
|
||||||
(let ([rest* (loop (cdr l))])
|
|
||||||
(if (eq? (cdr l) rest*)
|
|
||||||
l
|
|
||||||
(cons (car l) rest*)))]))])
|
|
||||||
(if not-found?
|
|
||||||
(cons (cons id v) l0)
|
|
||||||
new-l)))
|
|
||||||
|
|
||||||
(define-syntax-rule (alist-remove identifier=? phase l0 id)
|
|
||||||
;; To minimize allocation
|
|
||||||
;; - avoid allocation on idempotent removes
|
|
||||||
(let loop ([l l0])
|
|
||||||
(cond [(null? l) null]
|
|
||||||
[(identifier=? (caar l) id phase)
|
|
||||||
(cdr l)]
|
|
||||||
[else
|
|
||||||
(let ([rest* (loop (cdr l))])
|
|
||||||
(if (eq? (cdr l) rest*)
|
|
||||||
l
|
|
||||||
(cons (car l) rest*)))])))
|
|
||||||
|
|
||||||
;; ========
|
|
||||||
|
|
||||||
(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))])
|
|
||||||
(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-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)])
|
|
||||||
#'(begin
|
|
||||||
|
|
||||||
;; Struct defs at end, so that dict methods can refer to earlier procs
|
|
||||||
|
|
||||||
(define mk
|
|
||||||
(let ([make-idtbl
|
|
||||||
(lambda ([init-dict null] #:phase [phase (syntax-local-phase-level)])
|
|
||||||
(let ([t (make-mutable-idtbl (make-hasheq) phase)])
|
|
||||||
(for ([(k v) (in-dict init-dict)])
|
|
||||||
(idtbl-set! t k v))
|
|
||||||
t))])
|
|
||||||
make-idtbl))
|
|
||||||
(define mkimm
|
|
||||||
(let ([make-immutable-idtbl
|
|
||||||
(lambda ([init-dict null] #:phase [phase (syntax-local-phase-level)])
|
|
||||||
(for/fold ([t (make-immutable-idtbl empty-immutable-hasheq phase)])
|
|
||||||
([(k v) (in-dict init-dict)])
|
|
||||||
(idtbl-set t k v)))])
|
|
||||||
make-immutable-idtbl))
|
|
||||||
|
|
||||||
(define (idtbl-ref d id [fail (lambda ()
|
|
||||||
(error 'idtbl-ref
|
|
||||||
"no mapping for ~e" id))])
|
|
||||||
(let ([phase (idtbl-phase d)])
|
|
||||||
(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)
|
|
||||||
(if (procedure? fail)
|
|
||||||
(fail)
|
|
||||||
fail)))))
|
|
||||||
|
|
||||||
(define (idtbl-set! d id v)
|
|
||||||
(let* ([phase (idtbl-phase d)]
|
|
||||||
[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 d id v)
|
|
||||||
(let* ([phase (idtbl-phase d)]
|
|
||||||
[sym (identifier->symbol id phase)]
|
|
||||||
[l (hash-ref (idtbl-hash d) sym null)])
|
|
||||||
(make-immutable-idtbl
|
|
||||||
(hash-set (idtbl-hash d)
|
|
||||||
sym
|
|
||||||
(alist-set identifier=? phase l id v))
|
|
||||||
phase)))
|
|
||||||
|
|
||||||
(define (idtbl-remove! d id)
|
|
||||||
(let* ([phase (idtbl-phase d)]
|
|
||||||
[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 d id)
|
|
||||||
(let* ([phase (idtbl-phase d)]
|
|
||||||
[sym (identifier->symbol id phase)]
|
|
||||||
[l (hash-ref (idtbl-hash d) sym null)]
|
|
||||||
[newl (alist-remove identifier=? phase l id)])
|
|
||||||
(make-immutable-idtbl
|
|
||||||
(if (pair? newl)
|
|
||||||
(hash-set (idtbl-hash d) sym newl)
|
|
||||||
(hash-remove (idtbl-hash d) sym))
|
|
||||||
phase)))
|
|
||||||
|
|
||||||
(define (idtbl-count d)
|
|
||||||
(apply + (hash-map (idtbl-hash d) (lambda (k v) (length v)))))
|
|
||||||
|
|
||||||
(define (idtbl-for-each d p)
|
|
||||||
(define (pp i) (p (car i) (cdr i)))
|
|
||||||
(hash-for-each (idtbl-hash d)
|
|
||||||
(lambda (k v) (for-each pp v))))
|
|
||||||
|
|
||||||
(define (idtbl-map d f)
|
|
||||||
(define (fp i) (f (car i) (cdr i)))
|
|
||||||
(apply append
|
|
||||||
(hash-map (idtbl-hash d)
|
|
||||||
(lambda (k v) (map fp v)))))
|
|
||||||
|
|
||||||
(define (idtbl-iterate-first d)
|
|
||||||
(let ([h (idtbl-hash d)])
|
|
||||||
(let ([a (dict-iterate-first h)])
|
|
||||||
(and a
|
|
||||||
(let ([b (dict-iterate-first (dict-iterate-value h a))])
|
|
||||||
(and b (make-id-table-position a b)))))))
|
|
||||||
|
|
||||||
(define (idtbl-iterate-next d pos)
|
|
||||||
(let ([h (idtbl-hash d)]
|
|
||||||
[a (id-table-position-a pos)]
|
|
||||||
[b (id-table-position-b pos)])
|
|
||||||
(let ([v (dict-iterate-value h a)])
|
|
||||||
(let ([b2 (dict-iterate-next v b)])
|
|
||||||
(if b2
|
|
||||||
(make-id-table-position 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-position a2 b2))))))))))
|
|
||||||
|
|
||||||
(define (idtbl-iterate-key d pos)
|
|
||||||
(let ([h (idtbl-hash d)]
|
|
||||||
[a (id-table-position-a pos)]
|
|
||||||
[b (id-table-position-b pos)])
|
|
||||||
(dict-iterate-key (dict-iterate-value h a) b)))
|
|
||||||
|
|
||||||
(define (idtbl-iterate-value d pos)
|
|
||||||
(let ([h (idtbl-hash d)]
|
|
||||||
[a (id-table-position-a pos)]
|
|
||||||
[b (id-table-position-b pos)])
|
|
||||||
(dict-iterate-value (dict-iterate-value h a) b)))
|
|
||||||
|
|
||||||
(define (check-idtbl x who)
|
|
||||||
(unless (idtbl? x)
|
|
||||||
(raise-type-error who (symbol->string 'idtbl) x)))
|
|
||||||
(define (check-mutable-idtbl x who)
|
|
||||||
(unless (mutable-idtbl? x)
|
|
||||||
(raise-type-error who (symbol->string 'mutable-idtbl) x)))
|
|
||||||
(define (check-immutable-idtbl x who)
|
|
||||||
(unless (immutable-idtbl? x)
|
|
||||||
(raise-type-error who (symbol->string 'immutable-idtbl) x)))
|
|
||||||
|
|
||||||
(define-struct idtbl (hash phase))
|
|
||||||
(define-struct (mutable-idtbl idtbl) ()
|
|
||||||
#:property prop:dict
|
|
||||||
(vector (wrap idtbl-ref (list check-idtbl check-id void) '(2 3))
|
|
||||||
(wrap idtbl-set! (list check-mutable-idtbl check-id void))
|
|
||||||
#f
|
|
||||||
(wrap idtbl-remove! (list check-mutable-idtbl check-id))
|
|
||||||
#f
|
|
||||||
(wrap idtbl-count (list check-idtbl))
|
|
||||||
(wrap idtbl-iterate-first (list check-idtbl))
|
|
||||||
(wrap idtbl-iterate-next (list check-idtbl check-pos))
|
|
||||||
(wrap idtbl-iterate-key (list check-idtbl check-pos))
|
|
||||||
(wrap idtbl-iterate-value (list check-idtbl check-pos))))
|
|
||||||
(define-struct (immutable-idtbl idtbl) ()
|
|
||||||
#:property prop:dict
|
|
||||||
(vector (wrap idtbl-ref (list check-idtbl check-id void) '(2 3))
|
|
||||||
#f
|
|
||||||
(wrap idtbl-set (list check-immutable-idtbl check-id void))
|
|
||||||
#f
|
|
||||||
(wrap idtbl-remove (list check-immutable-idtbl check-id))
|
|
||||||
(wrap idtbl-count (list check-idtbl))
|
|
||||||
(wrap idtbl-iterate-first (list check-idtbl))
|
|
||||||
(wrap idtbl-iterate-next (list check-idtbl check-pos))
|
|
||||||
(wrap idtbl-iterate-key (list check-idtbl check-pos))
|
|
||||||
(wrap idtbl-iterate-value (list check-idtbl check-pos))))
|
|
||||||
|
|
||||||
(#%provide (rename mk make-idtbl)
|
|
||||||
(rename mkimm 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))))]))
|
|
||||||
|
|
||||||
(define (bound-identifier->symbol id phase) (syntax-e id))
|
|
||||||
|
|
||||||
(make-code bound-id-table
|
|
||||||
bound-identifier->symbol
|
|
||||||
bound-identifier=?)
|
|
||||||
|
|
||||||
(define (free-identifier->symbol id phase)
|
|
||||||
(let ([binding (identifier-binding id phase)])
|
|
||||||
(if (pair? binding)
|
|
||||||
(cadr binding)
|
|
||||||
(syntax-e id))))
|
|
||||||
|
|
||||||
(make-code free-id-table
|
|
||||||
free-identifier->symbol
|
|
||||||
free-identifier=?)
|
|
||||||
|
|
||||||
#|
|
|
||||||
;; free*-id-tables only phase = (syntax-local-phase-level)
|
|
||||||
|
|
||||||
(define (resolve id phase)
|
|
||||||
(if (and (syntax-transforming?) (equal? phase (syntax-local-phase-level)))
|
|
||||||
(let-values ([(v next)
|
|
||||||
(syntax-local-value/immediate id (lambda () (values #f #f)))])
|
|
||||||
(if next
|
|
||||||
(resolve next phase)
|
|
||||||
id))
|
|
||||||
id))
|
|
||||||
|
|
||||||
(define (free*-identifier->symbol id phase)
|
|
||||||
(free-identifier->symbol (resolve id phase) phase))
|
|
||||||
|
|
||||||
(define (free*-identifier=? a b phase)
|
|
||||||
(free-identifier=? (resolve a phase) (resolve b phase) phase))
|
|
||||||
|
|
||||||
(make-code free*-id-table
|
|
||||||
free*-identifier->symbol
|
|
||||||
free*-identifier=?)
|
|
||||||
|#
|
|
||||||
Loading…
Reference in New Issue
Block a user