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

syntax/parse: convert datum to be matched to syntax, placeholder expr/c

Browse Source 
svn: r15982
This commit is contained in:
Ryan Culpepper 2009-09-11 21:31:42 +00:00
parent 417b9d16e0
commit 184fbae9b2
3 changed files with 18 additions and 4 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

15
collects/syntax/private/stxparse/lib.ss
View File

@ -29,6 +29,7 @@
char char
expr expr
expr/c
static static
atom-in-list atom-in-list
@ -65,7 +66,8 @@
#:fail-unless (syntax-transforming?) #:fail-unless (syntax-transforming?)
"not within the extent of a macro transformer" "not within the extent of a macro transformer"
#:attr value (syntax-local-value #'x (lambda () notfound)) #:attr value (syntax-local-value #'x (lambda () notfound))
#:fail-when (eq? (attribute value) notfound) #f)) #:fail-when (eq? (attribute value) notfound) #f
#:fail-unless (pred (attribute value)) #f))
(define-syntax-class (atom-in-list atoms name) (define-syntax-class (atom-in-list atoms name)
#:attributes () #:attributes ()
@ -103,6 +105,17 @@
(pattern x (pattern x
#:fail-when (keyword? (syntax-e #'x)) #f)) #:fail-when (keyword? (syntax-e #'x)) #f))
(define-syntax-class (expr/c ctc)
#:attributes (c)
(pattern x:expr
#:with c #`(contract #,ctc
x
(quote #,(string->symbol (or (build-src-loc-string #'x) "")))
(quote #,(or '<this-macro>))
(quote-syntax #,(syntax/loc #'x (<there>))))))
;; Literal sets
(define-syntax kernel-literals (define-syntax kernel-literals
(make-literalset (make-literalset
(list* (quote-syntax module) (list* (quote-syntax module)

2
collects/syntax/private/stxparse/parse.ss
View File

@ -112,7 +112,7 @@
(convert-sides x sides (k iattrs . kargs)))] (convert-sides x sides (k iattrs . kargs)))]
[#s(clause:with pattern expr (def ...)) [#s(clause:with pattern expr (def ...))
(with-syntax ([(p-iattr ...) (pattern-attrs (wash #'pattern))]) (with-syntax ([(p-iattr ...) (pattern-attrs (wash #'pattern))])
#`(let ([y (without-fails expr)]) #`(let ([y (datum->syntax #f (without-fails expr))])
def ... def ...
(parse:S y #,(done-frontier #'x) pattern (parse:S y #,(done-frontier #'x) pattern
(convert-sides x sides (convert-sides x sides

5
collects/syntax/private/stxparse/sc.ss
View File

@ -177,7 +177,7 @@
(syntax-case stx () (syntax-case stx ()
[(syntax-parse stx-expr . clauses) [(syntax-parse stx-expr . clauses)
(quasisyntax/loc stx (quasisyntax/loc stx
(let ([x stx-expr]) (let ([x (datum->syntax #f stx-expr)])
(parse:clauses x clauses #,stx)))])) (parse:clauses x clauses #,stx)))]))
(define-syntax (syntax-parser stx) (define-syntax (syntax-parser stx)
@ -185,7 +185,8 @@
[(syntax-parser . clauses) [(syntax-parser . clauses)
(quasisyntax/loc stx (quasisyntax/loc stx
(lambda (x) (lambda (x)
(parse:clauses x clauses #,stx)))])) (let ([x (datum->syntax #f x)])
(parse:clauses x clauses #,stx))))]))
(define-syntax with-patterns (define-syntax with-patterns
(syntax-rules () (syntax-rules ()