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,53 +30,41 @@
|
|||
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)])
|
||||
(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
|
||||
|
|
@ -302,7 +291,7 @@
|
|||
[idtbl/c
|
||||
(->* (chaperone-contract? contract?)
|
||||
(#:immutable (or/c 'dont-care #t #f))
|
||||
contract?)]))))]))
|
||||
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,48 +226,41 @@ 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)])
|
||||
(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
|
||||
|
|
@ -320,10 +314,10 @@ Notes (FIXME?):
|
|||
|
||||
(define (idtbl-chaperone-keys+values/constructor d wrap-key wrap-value constructor)
|
||||
(constructor
|
||||
(for/hasheq (((sym alist) (idtbl-hash d)))
|
||||
(for/hasheq (((sym alist) (id-table-hash d)))
|
||||
(for/list (((key value) (in-dict alist)))
|
||||
(cons (wrap-key key) (wrap-value value))))
|
||||
(idtbl-phase d)))
|
||||
(id-table-phase d)))
|
||||
|
||||
(define idtbl-mutable-methods
|
||||
(vector-immutable idtbl-ref
|
||||
|
|
@ -380,7 +374,7 @@ Notes (FIXME?):
|
|||
idtbl-remove/constructor
|
||||
idtbl-mutable-methods
|
||||
mutable-idtbl
|
||||
immutable-idtbl))))]))
|
||||
immutable-idtbl)))]))
|
||||
|
||||
(define (bound-identifier->symbol id phase) (syntax-e id))
|
||||
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user