stxclass: fixed static-of doc, added #:transparent behavior

svn: r13434

collects/stxclass/private/codegen-data.ss

@@ -1,6 +1,6 @@
 #lang scheme/base
 (require scheme/match
-         (for-template scheme/base))
+         (for-template scheme/base "kws.ss"))
 (provide (all-defined-out))
 
 ;; A PK is (make-pk (listof Pattern) stx)
@@ -28,8 +28,10 @@
 ;; A FrontierContextExpr (FCE) is one of
 ;;   - (list  FrontierIndexExpr Syntax)
 ;;   - (list* FrontierIndexExpr Syntax FrontierContextExpr)
+;;   - (make-joined-frontier FCE id)
 ;; A FrontierIndexExpr is
 ;;   - `(+ ,Number Syntax ...)
+(define-struct joined-frontier (base ext) #:transparent)
 
 (define (empty-frontier x)
   (list '(+ 0) x))
@@ -52,9 +54,21 @@
 (define (fi:add-index fi expr)
   `(+ ,(cadr fi) ,expr ,@(cddr fi)))
 
+(define (join-frontiers base ext-expr)
+  (make-joined-frontier base ext-expr))
+
 ;; A DynamicFrontierContext (DFC) is one of
 ;;   - (list  Syntax Number)
 ;;   - (list* Syntax Number DynamicFrontierContext)
 
 (define (frontier->expr fc)
-  #`(list #,@(reverse fc)))
+  (define (loop fc)
+    (match fc
+      [(list  fe stx)
+       #`(list #,fe #,stx)]
+      [(list* fe stx rest)
+       #`(list* #,fe #,stx #,(loop rest))]
+      [(struct joined-frontier (base ext))
+       #`(let ([base #,(loop base)])
+           (if #,ext (append (reverse (failed-frontier #,ext)) base) base))]))
+  #`(reverse #,(loop fc)))

collects/stxclass/private/codegen.ss

@@ -25,7 +25,9 @@
          (with-syntax ([(arg ...) args])
            #`(lambda (x arg ...)
                (define (fail-rhs x expected frontier)
-                 (make-failed x expected frontier))
+                 #,(if (rhs-transparent? rhs)
+                       #`(make-failed x expected frontier)
+                       #'#f))
                #,(let ([pks (rhs->pks rhs relsattrs #'x)])
                    (unless (pair? pks)
                      (wrong-syntax (rhs-orig-stx rhs)
@@ -199,9 +201,15 @@
         (let ([result (parser var0 arg-var ...)])
           (if (ok? result)
               #,(parse:pks (cdr vars) (cdr fcs) (shift-pks:id pks #'result) failid)
+              (if (failed? result)
+                  #,(fail failid (car vars)
+                          ;; FIXME: join expectation with this stxclass
+                          ;; for better error message
+                          #:pattern #'(failed-expectation result) ;; join with this-stxclass
+                          #:fce (join-frontiers (car fcs) #'result))
                   #,(fail failid (car vars)
                           #:pattern (expectation-of-stxclass stxclass #'(arg-var ...))
-                      #:fce (car fcs)))))))
+                          #:fce (car fcs))))))))
 
 ;; parse:pk:id/any : (listof id) (listof FCE) id stx (listof pk) -> stx
 (define (parse:pk:id/any vars fcs failid args pks)

collects/stxclass/private/lib.ss

@@ -54,7 +54,7 @@
   (pattern :define-syntaxes-form))
 
 (define-basic-syntax-class static
-  ([datum 0] [value 0])
+  ([value 0])
   (lambda (x)
     (if (identifier? x)
         (let/ec escape

collects/stxclass/private/messages.ss

@@ -43,7 +43,6 @@
       (certify
        #'(make-expc '() #f '((msg)) '())))))
 
-
 (define-syntax (try stx)
   (syntax-case stx ()
     [(try failvar (expr ...) previous-fail)

collects/stxclass/stxclass.scrbl

@@ -487,7 +487,7 @@ static information (see @scheme[syntax-local-value]). Attribute
 
 }
 
-@defform[(static-of predicate description)]{
+@defform[(static-of description predicate)]{
 
 Refines @scheme[static]: matches identifiers that are bound in the
 syntactic environment to static information satisfying the given