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

Simplify a syntax class

Browse Source 
svn: r15977
This commit is contained in:
Sam Tobin-Hochstadt 2009-09-11 19:19:41 +00:00
parent 5fc019ba6c
commit 8001ab7fb0
1 changed files with 7 additions and 12 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -246,21 +246,16 @@
#: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
#:transparent #:transparent
#:attributes (i lower-s first-letter key? (fld-names 1) name keyword tmp-rec-id case printer ht rec-id d-id pred? (accs 1)) #:auto-nested-attributes
(pattern tnb:type-name-base (pattern :type-name-base
#:with i #'tnb.i
#:with lower-s (attribute tnb.lower-s)
#:with first-letter (attribute tnb.first-letter)
#:with key? #'tnb.key?
#:with (fld-names ...) #'(tnb.fld-names ...)
#:with name #'i #:with name #'i
#:with keyword (datum->syntax #f (string->keyword (symbol->string (syntax-e #'i)))) #:with keyword (datum->syntax #f (string->keyword (symbol->string (syntax-e #'i))))
#:with tmp-rec-id (generate-temporary) #:with tmp-rec-id (generate-temporary)
#:with case (mk-id #'i #'lower-s "-case") #:with case (mk-id #'i (attribute lower-s) "-case")
#:with printer (mk-id #'i "print-" #'lower-s "*") #:with printer (mk-id #'i "print-" (attribute lower-s) "*")
#:with ht (mk-id #'i #'lower-s "-name-ht") #:with ht (mk-id #'i (attribute lower-s) "-name-ht")
#:with rec-id (mk-id #'i #'lower-s "-rec-id") #:with rec-id (mk-id #'i (attribute lower-s) "-rec-id")
#:with d-id (mk-id #'i "d" #'first-letter) #:with d-id (mk-id #'i "d" (attribute first-letter))
#:with (_ _ pred? accs ...) #:with (_ _ pred? accs ...)
(datum->syntax #f (build-struct-names #'name (syntax->list #'(fld-names ...)) #f #t #'name)))) (datum->syntax #f (build-struct-names #'name (syntax->list #'(fld-names ...)) #f #t #'name))))
(syntax-parse stx (syntax-parse stx