diff --git a/collects/syntax/private/stxparse/lib.ss b/collects/syntax/private/stxparse/lib.ss index 5ad2b104e4..6e8a1b1a26 100644 --- a/collects/syntax/private/stxparse/lib.ss +++ b/collects/syntax/private/stxparse/lib.ss @@ -29,6 +29,7 @@ char expr + expr/c static atom-in-list @@ -65,7 +66,8 @@ #:fail-unless (syntax-transforming?) "not within the extent of a macro transformer" #: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) #:attributes () @@ -103,6 +105,17 @@ (pattern x #: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 ')) + (quote-syntax #,(syntax/loc #'x ()))))) + +;; Literal sets + (define-syntax kernel-literals (make-literalset (list* (quote-syntax module) diff --git a/collects/syntax/private/stxparse/parse.ss b/collects/syntax/private/stxparse/parse.ss index 75d7672023..61c6203154 100644 --- a/collects/syntax/private/stxparse/parse.ss +++ b/collects/syntax/private/stxparse/parse.ss @@ -112,7 +112,7 @@ (convert-sides x sides (k iattrs . kargs)))] [#s(clause:with pattern expr (def ...)) (with-syntax ([(p-iattr ...) (pattern-attrs (wash #'pattern))]) - #`(let ([y (without-fails expr)]) + #`(let ([y (datum->syntax #f (without-fails expr))]) def ... (parse:S y #,(done-frontier #'x) pattern (convert-sides x sides diff --git a/collects/syntax/private/stxparse/sc.ss b/collects/syntax/private/stxparse/sc.ss index 5a3b28dd7e..464f598428 100644 --- a/collects/syntax/private/stxparse/sc.ss +++ b/collects/syntax/private/stxparse/sc.ss @@ -177,7 +177,7 @@ (syntax-case stx () [(syntax-parse stx-expr . clauses) (quasisyntax/loc stx - (let ([x stx-expr]) + (let ([x (datum->syntax #f stx-expr)]) (parse:clauses x clauses #,stx)))])) (define-syntax (syntax-parser stx) @@ -185,7 +185,8 @@ [(syntax-parser . clauses) (quasisyntax/loc stx (lambda (x) - (parse:clauses x clauses #,stx)))])) + (let ([x (datum->syntax #f x)]) + (parse:clauses x clauses #,stx))))])) (define-syntax with-patterns (syntax-rules ()