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

svn: r15982

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 '<this-macro>))
+                                (quote-syntax #,(syntax/loc #'x (<there>))))))
+
+;; Literal sets
+  
 (define-syntax kernel-literals
   (make-literalset
    (list* (quote-syntax module)

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

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 ()