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

77
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,53 +30,41 @@
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))]
[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 #'(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
@ -302,7 +291,7 @@
[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)

72
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,48 +226,41 @@ 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))
(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 #'(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
@ -320,10 +314,10 @@ Notes (FIXME?):
(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
@ -380,7 +374,7 @@ Notes (FIXME?):
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))