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

fix some strange stxclass strangeness

Browse Source 
svn: r13722
This commit is contained in:
Sam Tobin-Hochstadt 2009-02-18 04:31:28 +00:00
parent c0861fd39b
commit 26fe69d9a7
2 changed files with 10 additions and 11 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

5
collects/typed-scheme/rep/interning.ss
View File

@ -7,8 +7,9 @@
(define-syntax (defintern stx) (define-syntax (defintern stx)
(syntax-parse stx (syntax-parse stx
[(_ name+args make-name key ([#:extra-arg e:expr]) ...*) [(_ name+args make-name:id key:expr . rest)
#'(defintern name+args (lambda () (make-hash #;'weak)) make-name key #:extra-arg e ...)] #:with (_:id _:id ...) #'name+args
#'(defintern name+args (lambda () (make-hash #;'weak)) make-name key . rest)]
[(_ (*name:id arg:id ...) make-ht make-name key-expr ([#:extra-arg e:expr]) ...*) [(_ (*name:id arg:id ...) make-ht make-name key-expr ([#:extra-arg e:expr]) ...*)
#'(define *name #'(define *name
(let ([table (make-ht)]) (let ([table (make-ht)])

16
collects/typed-scheme/rep/rep-utils.ss
View File

@ -80,12 +80,12 @@
(provide ex pred acc ...) (provide ex pred acc ...)
(p/c (rename *maker maker *maker-cnt))))] (p/c (rename *maker maker *maker-cnt))))]
[intern [intern
(let ([mk (lambda (int) #`(defintern (**maker . flds.fs) maker #,int (let ([mk (lambda (int)
#,@(if key? (if key?
#'(#:extra-arg key-expr) #`(defintern (**maker . flds.fs) maker #,int #:extra-arg key-expr)
#'())))]) #`(defintern (**maker . flds.fs) maker #,int)))])
(syntax-parse #'flds.fs (syntax-parse #'flds.fs
[_ #:when #'intern? [_ #:when #'intern?
(mk #'intern?)] (mk #'intern?)]
[() (mk #'#f)] [() (mk #'#f)]
[(f) (mk #'f)] [(f) (mk #'f)]
@ -96,7 +96,7 @@
(list (combiner #'free-vars* #'flds.fs) (list (combiner #'free-vars* #'flds.fs)
(combiner #'free-idxs* #'flds.fs)))]) (combiner #'free-idxs* #'flds.fs)))])
(quasisyntax/loc stx (quasisyntax/loc stx
(w/c nm ([*maker *maker-cnt]) (w/c nm ([*maker *maker-cnt])
(define (*maker . flds.fs) (define (*maker . flds.fs)
(define v (**maker . flds.fs)) (define v (**maker . flds.fs))
(unless-in-table (unless-in-table
@ -128,7 +128,6 @@
#:transparent #:transparent
(pattern i:id (pattern i:id
#:with lower-s (string-downcase (symbol->string #'i.datum)) #:with lower-s (string-downcase (symbol->string #'i.datum))
#:when (printf "loc1: ~a~n" #'lower-s)
#:with (fld-names ...) default-flds #:with (fld-names ...) default-flds
#:with key? #'#f #:with key? #'#f
#:with first-letter (string-ref #'lower-s 0)) #:with first-letter (string-ref #'lower-s 0))
@ -141,7 +140,6 @@
#:with (fld-names ...) (datum->syntax #f (append (syntax->list default-flds) #:with (fld-names ...) (datum->syntax #f (append (syntax->list default-flds)
(syntax->list #'(key)))) (syntax->list #'(key))))
#:with lower-s (string-downcase (symbol->string #'i.datum)) #:with lower-s (string-downcase (symbol->string #'i.datum))
#:when (printf "loc2: ~v~n" (syntax->datum #'lower-s))
#:with key? #'#t #:with key? #'#t
#:with first-letter (string-ref #'lower-s 0))) #:with first-letter (string-ref #'lower-s 0)))
(define-syntax-class type-name (define-syntax-class type-name