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

stxclass: #:description takes expression now

Browse Source 
svn: r13288
This commit is contained in:
Ryan Culpepper 2009-01-26 23:54:13 +00:00
parent f2fb56d07f
commit 38d4b95da9
5 changed files with 93 additions and 79 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

22
collects/stxclass/private/lib.ss
View File

@ -63,16 +63,18 @@
(list (syntax-e x) value)))
#f)))
(define-basic-syntax-class (static-of name pred)
([value 0])
(lambda (x name pred)
(let/ec escape
(define (bad) (escape #f))
(if (identifier? x)
(let ([value (syntax-local-value x bad)])
(unless (pred value) (bad))
(list value))
(bad)))))
(define-syntax-class (static-of name pred)
#:description name
(basic-syntax-class
([value 0])
(lambda (x name pred)
(let/ec escape
(define (bad) (escape #f))
(if (identifier? x)
(let ([value (syntax-local-value x bad)])
(unless (pred value) (bad))
(list x value))
(bad))))))
(define-basic-syntax-class struct-name
([descriptor 0]

10
collects/stxclass/private/messages.ss
View File

@ -13,13 +13,17 @@
(define-struct expc (stxclasses pairs? data literals)
#:transparent)
(define (make-stxclass-expc scdyn)
(make-expc (list scdyn) #f null null))
(begin-for-syntax
(define certify (syntax-local-certifier))
(define (expectation-of-stxclass stxclass)
(define (expectation-of-stxclass stxclass args)
(if stxclass
(with-syntax ([name (sc-name stxclass)]
[desc (sc-description stxclass)])
(certify #'(make-expc (list (make-scdyn 'name 'desc)) #f null null)))
[desc-var (sc-description stxclass)]
[(arg ...) args])
(certify #'(make-stxclass-expc (make-scdyn 'name (desc-var arg ...)))))
#'#f))
(define (expectation-of-constants pairs? data literals)

23
collects/stxclass/private/parse.ss
View File

@ -225,18 +225,19 @@
(define (parse:extpk vars fcs extpk failid)
(match extpk
[(struct idpks (stxclass args pks))
(with-syntax ([sub-parse-expr
(if stxclass
#`(#,(sc-parser-name stxclass) #,(car vars) #,@args)
#`(list #,(car vars)))]
[var0 (car vars)]
(with-syntax ([var0 (car vars)]
[(arg ...) args]
[(arg-var ...) (generate-temporaries args)]
[(r) (generate-temporaries #'(r))])
#`(let ([r sub-parse-expr])
(if (ok? r)
#,(parse:pks (cdr vars) (cdr fcs) (shift-pks:id pks #'r) failid)
#,(fail failid (car vars)
#:pattern (expectation-of-stxclass stxclass)
#:fc (car fcs)))))]
#`(let ([arg-var arg] ...)
(let ([r #,(if stxclass
#`(#,(sc-parser-name stxclass) #,(car vars) arg-var ...)
#`(list #,(car vars)))])
(if (ok? r)
#,(parse:pks (cdr vars) (cdr fcs) (shift-pks:id pks #'r) failid)
#,(fail failid (car vars)
#:pattern (expectation-of-stxclass stxclass #'(arg-var ...))
#:fc (car fcs))))))]
[(struct cpks (pairpks datumpkss literalpkss))
(with-syntax ([var0 (car vars)]
[(dvar0) (generate-temporaries (list (car vars)))])

4
collects/stxclass/private/rep.ss
View File

@ -45,7 +45,7 @@
(define-struct attr (name depth inner)
#:transparent)
;; RHSBase is stx (listof SAttr) boolean string/#f
;; RHSBase is stx (listof SAttr) boolean stx/#f
(define-struct rhs (orig-stx attrs transparent? description)
#:transparent)
@ -315,7 +315,7 @@
;; rhs-directive-table
(define rhs-directive-table
(list (list '#:literals check-idlist)
(list '#:description check-string)
(list '#:description values)
(list '#:transparent)))
;; parse-pattern : stx(Pattern) env number -> Pattern

113
collects/stxclass/private/sc.ss
View File

@ -32,52 +32,6 @@
current-expression
current-macro-name)
#|
(begin-for-syntax
(define (check-attrlist stx)
(syntax-case stx ()
[(form ...)
(let ([names (for/list ([s (syntax->list #'(form ...))])
(check-attr s)
(stx-car s))])
(check-duplicate-identifier names)
stx)]
[_
(raise-syntax-error 'define-syntax-class
"expected attribute table" stx)]))
(define stxclass-table
`((#:description check-string)
(#:attributes check-attrlist)))
(define (split-rhss rhss stx)
(define-values (chunks rest)
(chunk-kw-seq/no-dups rhss stxclass-table #:context stx))
(define (assq* x alist default)
(cond [(assq x alist) => cdr]
[else default]))
(values (cond [(assq '#:attributes chunks) => caddr]
[else null])
(cond [(assq '#:description chunks) => caddr]
[else #f])
rest)))
(define-syntax (define-syntax-class stx)
(syntax-case stx ()
[(define-syntax-class (name arg ...) . rhss)
(let-values ([(attrs description rhss) (split-rhss #'rhss stx)])
#`(begin (define-syntax name
(make sc
'name
'(arg ...)
'#,attrs
((syntax-local-value) #'parser)
'description))
(define parser
(rhs->parser name #,rhss (arg ...) #,stx))))]
[(define-syntax-class name . rhss)
(syntax/loc stx
(define-syntax-class (name) . rhss))]))
|#
(define-syntax (define-syntax-class stx)
(syntax-case stx ()
[(define-syntax-class (name arg ...) . rhss)
@ -90,8 +44,9 @@
'(arg ...)
(rhs-attrs the-rhs)
((syntax-local-certifier) #'parser)
(rhs-description the-rhs))))
(define parser (rhs->parser name rhss (arg ...) #,stx)))]
#'description)))
(define-values (parser description)
(rhs->parser+description name rhss (arg ...) #,stx)))]
[(define-syntax-class name . rhss)
(syntax/loc stx
(define-syntax-class (name) . rhss))]))
@ -128,15 +83,18 @@
([attr-name attr-depth] ...)
(let ([name parser-expr]) name)))]))
(define-syntax (rhs->parser stx)
(define-syntax (rhs->parser+description stx)
(syntax-case stx ()
[(rhs->parser name rhss (arg ...) ctx)
[(rhs->parser+description name rhss (arg ...) ctx)
(parameterize ((current-syntax-context #'ctx))
(let ([rhs (parse-rhs #'rhss #f #'ctx)]
[sc (syntax-local-value #'name)])
(parse:rhs rhs
(sc-attrs sc)
(syntax->list #'(arg ...)))))]))
#`(values #,(parse:rhs rhs
(sc-attrs sc)
(syntax->list #'(arg ...)))
(lambda (arg ...)
#,(or (rhs-description rhs)
#'(symbol->string 'name))))))]))
(define-syntax (parse-sc stx)
(syntax-case stx ()
@ -237,3 +195,52 @@
(values x n)]
[(list-rest _ _ rest)
(frontier->syntax rest)]))
#|
(begin-for-syntax
(define (check-attrlist stx)
(syntax-case stx ()
[(form ...)
(let ([names (for/list ([s (syntax->list #'(form ...))])
(check-attr s)
(stx-car s))])
(check-duplicate-identifier names)
stx)]
[_
(raise-syntax-error 'define-syntax-class
"expected attribute table" stx)]))
(define stxclass-table
`((#:description check-string)
(#:attributes check-attrlist)))
(define (split-rhss rhss stx)
(define-values (chunks rest)
(chunk-kw-seq/no-dups rhss stxclass-table #:context stx))
(define (assq* x alist default)
(cond [(assq x alist) => cdr]
[else default]))
(values (cond [(assq '#:attributes chunks) => caddr]
[else null])
(cond [(assq '#:description chunks) => caddr]
[else #f])
rest)))
(define-syntax (define-syntax-class stx)
(syntax-case stx ()
[(define-syntax-class (name arg ...) . rhss)
(let-values ([(attrs description rhss) (split-rhss #'rhss stx)])
#`(begin (define-syntax name
(make sc
'name
'(arg ...)
'#,attrs
((syntax-local-value) #'parser)
'#,description))
(define parser
(rhs->parser name #,rhss (arg ...) #,stx))))]
[(define-syntax-class name . rhss)
(syntax/loc stx
(define-syntax-class (name) . rhss))]))
|#