stxclass: worked on opt/mand/etc error messages

svn: r13033

collects/macro-debugger/stxclass/private/kws.ss

@@ -88,9 +88,9 @@
 
 ;; A PatternParseResult is one of
 ;;   - (listof value)
-;;   - (make-failed stx sexpr(Pattern) string)
+;;   - (make-failed stx sexpr(Pattern) string frontier/#f)
 (define (ok? x) (or (pair? x) (null? x)))
-(define-struct failed (stx patstx reason)
+(define-struct failed (stx patstx reason frontier)
   #:transparent)
 
 

collects/macro-debugger/stxclass/private/lib.ss

@@ -14,11 +14,11 @@
 
 (define-syntax-rule (define-pred-stxclass name pred)
   (define-basic-syntax-class name
-    ([datum 0])
+    () ;; ([datum 0])
     (lambda (x)
       (let ([d (if (syntax? x) (syntax-e x) x)])
         (if (pred d)
-            (list d)
+            null ;; (list d)
             (fail-sc x #:pattern 'name))))))
 
 (define-pred-stxclass identifier symbol?)

collects/macro-debugger/stxclass/private/parse.ss

@@ -23,10 +23,12 @@
 ;;   - 'fail' stxparameterized to (non-escaping!) failure procedure
 (define-struct pk (ps k) #:transparent)
 
-;; A FrontierContext (FC) is ({FrontierIndex stx}*)
+;; A FrontierContext (FC) is one of
+;;   - (list  FrontierIndex Syntax)
+;;   - (list* FrontierIndex Syntax FrontierContext)
 ;; A FrontierIndex is one of
 ;;   - nat
-;;   - `(+ ,nat expr ...)
+;;   - `(+ ,nat Syntax ...)
 
 (define (empty-frontier x)
   (list 0 x))
@@ -59,7 +61,7 @@
          (with-syntax ([(arg ...) args])
            #`(lambda (x arg ...)
                (define (fail-rhs x expected reason frontier)
-                 (make-failed x expected reason))
+                 (make-failed x expected reason frontier))
                #,(parse:pks (list #'x)
                             (list (empty-frontier #'x))
                             (rhs->pks rhs relsattrs #'x)
@@ -72,7 +74,7 @@
   (with-syntax ([k k] [x x] [p p] [reason reason]
                 [fc-expr (frontier->expr fc)])
     #`(let ([failcontext fc-expr])
-        #;(printf "failing at ~s\n" failcontext)
+        (printf "failed: reason=~s, p=~s\n  fc=~s\n" reason p failcontext)
         (k x p 'reason failcontext))))
 
 ;; rhs->pks : RHS (listof SAttr) identifier -> (listof PK)
@@ -309,7 +311,7 @@
                         [sub-parse-expr
                          #`(#,(ssc-parser-name ssc) #,(car vars) #,@args)])
            #'sub-parse-expr)))]
-    [(struct pk ((cons (struct pat:gseq (orig-stx attrs depth heads tail))
+    [(struct pk ((cons (and the-pattern (struct pat:gseq (orig-stx attrs depth heads tail)))
                        rest-ps)
                  k))
      (let* ([xvar (car (generate-temporaries (list #'x)))]
@@ -360,11 +362,6 @@
                         (if maxrep
                             #`(< #,repvar #,maxrep)
                             #`#t))]
-                     [(minrepclause ...)
-                      (for/list ([repvar reps] [minrep mins] #:when minrep)
-                        #`[(< #,repvar #,minrep)
-                           #,(fail #'enclosing-fail (car vars)
-                                   #:reason "minimum repetition constraint failed")])]
                      [(occurs-binding ...)
                       (for/list ([head heads] [rep reps] #:when (head-occurs head))
                         #`[#,(head-occurs head) (positive? #,rep)])]
@@ -376,10 +373,20 @@
                                  (let ([rep (add1 rep)])
                                    (parse-loop x #,@hid-args #,@reps enclosing-fail))
                                  #,(fail #'enclosing-fail #'var0
+                                         #:fc (frontier:add-index (car fcs) 
+                                                                  #'(calculate-index rep ...))
                                          #:reason "maxiumum repetition constraint failed")))
                            ...]]
                        [tail-rhs
-                        #`(cond minrepclause ...
+                        #`(cond #,@(for/list ([repvar reps] [minrep mins] #:when minrep)
+                                     #`[(< #,repvar #,minrep)
+                                        #,(fail #'enclosing-fail (car vars)
+                                                #:fc (frontier:add-index 
+                                                      (car fcs)
+                                                      #'(calculate-index rep ...))
+                                                #:pattern (expectation-of-constants 
+                                                           #f '(mininum-rep-constraint-failed) '())
+                                                #:reason "minimum repetition constraint failed")])
                                 [else
                                  (let ([hid (finalize hid-arg)] ... ...
                                        occurs-binding ...

collects/macro-debugger/stxclass/private/rep.ss

@@ -347,7 +347,7 @@
      (make pat:datum stx null depth (syntax->datum #'datum))]
     [(heads gdots . tail)
      (gdots? #'gdots)
-     (let* ([heads (parse-heads #'heads decls (add1 depth))]
+     (let* ([heads (parse-heads #'heads decls depth)]
             [tail (parse-pattern #'tail decls depth)]
             [hattrs (append-attrs (for/list ([head heads]) (head-attrs head)) stx)]
             [tattrs (pattern-attrs tail)])
@@ -372,40 +372,6 @@
     [(struct pattern (orig-stx iattrs depth))
      (make head orig-stx iattrs depth (list p) #f #f #t #f #f)]))
 
-(define (parse-heads stx decls depth)
-  (syntax-case stx ()
-    [({} . more)
-     (raise-syntax-error 'pattern "empty head sequence not allowed" (stx-car stx))]
-    [({p ...} . more)
-     (let* ([heads
-             (for/list ([p (syntax->list #'(p ...))])
-               (parse-pattern p decls depth))]
-            [heads-attrs
-             (append-attrs (map pattern-attrs heads) (stx-car stx))])
-       (parse-heads-k #'more
-                      heads
-                      heads-attrs
-                      depth
-                      (lambda (more min max as-list? occurs-pvar default)
-                        (let ([occurs-attrs
-                               (if occurs-pvar
-                                   (list (make-attr occurs-pvar depth null))
-                                   null)])
-                          (cons (make head (stx-car stx)
-                                      (append-attrs (list occurs-attrs heads-attrs)
-                                                    (stx-car stx))
-                                      depth
-                                      heads
-                                      min max as-list?
-                                      occurs-pvar
-                                      default)
-                                (parse-heads more decls depth))))))]
-    [()
-     null]
-    [_
-     (raise-syntax-error 'pattern "expected sequence of patterns or sequence directive"
-                         (if (pair? stx) (car stx) stx))]))
-
 (define head-directive-table
   (list (list '#:min check-nat/f)
         (list '#:max check-nat/f)
@@ -414,9 +380,24 @@
         (list '#:opt)
         (list '#:mand)))
 
-(define (parse-heads-k stx heads heads-attrs heads-depth k)
+(define (parse-heads stx decls enclosing-depth)
-  (define-values (chunks rest) (chunk-kw-seq/no-dups stx head-directive-table))
+  (syntax-case stx ()
-  (reject-duplicate-chunks chunks)
+    [({} . more)
+     (raise-syntax-error 'pattern "empty head sequence not allowed" (stx-car stx))]
+    [({p ...} . more)
+     (let-values ([(chunks rest) (chunk-kw-seq/no-dups #'more head-directive-table)])
+       (reject-duplicate-chunks chunks) ;; FIXME: needed?
+       (cons (parse-head/chunks (stx-car stx) decls enclosing-depth chunks)
+             (parse-heads rest decls enclosing-depth)))]
+    [()
+     null]
+    [_
+     (raise-syntax-error 'pattern "expected sequence of patterns or sequence directive"
+                         (cond [(pair? stx) (car stx)]
+                               [(syntax? stx) stx]
+                               [else #f]))]))
+
+(define (parse-head/chunks pstx decls enclosing-depth chunks)
   (let* ([min-row (assq '#:min chunks)]
          [max-row (assq '#:max chunks)]
          [occurs-row (assq '#:occurs chunks)]
@@ -443,20 +424,42 @@
       (unless opt-row
         (raise-syntax-error #f
                             "default only allowed for optional patterns"
-                            (cadr default-row)))
-      (unless (and (pair? head-attrs)
-                   (null? (cdr head-attrs))
-                   (= heads-depth (attr-depth (car head-attrs)))
-                   (null? (attr-inner (car head-attrs))))
-        (raise-syntax-error #f
-                            "default only allowed for patterns with single simple pattern variable"
                             (cadr default-row))))
-    (k rest
+    (parse-head/options pstx
+                        decls
+                        enclosing-depth
                         (cond [opt-row 0] [mand-row 1] [else min])
                         (cond [opt-row 1] [mand-row 1] [else max])
                         (not (or opt-row mand-row))
                         (and occurs-row (caddr occurs-row))
-       (and default-row (caddr default-row)))))
+                        default-row)))
+
+(define (parse-head/options pstx decls enclosing-depth 
+                            min max as-list? occurs-pvar default-row)
+  (let* ([depth (if as-list? (add1 enclosing-depth) enclosing-depth)]
+         [heads
+          (for/list ([p (syntax->list pstx)])
+            (parse-pattern p decls depth))]
+         [heads-attrs
+          (append-attrs (map pattern-attrs heads) pstx)])
+    (when default-row
+      (unless (and (= (length heads-attrs) 1)
+                   (= enclosing-depth (attr-depth (car heads-attrs)))
+                   (null? (attr-inner (car heads-attrs))))
+        (raise-syntax-error #f
+                            "default only allowed for patterns with single simple pattern variable"
+                            (cadr default-row))))
+    (let ([occurs-attrs
+           (if occurs-pvar
+               (list (make-attr occurs-pvar depth null))
+               null)])
+      (make head pstx
+            (append-attrs (list occurs-attrs heads-attrs) pstx)
+            depth
+            heads
+            min max as-list?
+            occurs-pvar
+            (and default-row (caddr default-row))))))
 
 ;; append-attrs : (listof (listof IAttr)) stx -> (listof IAttr)
 (define (append-attrs attrss stx)

collects/macro-debugger/stxclass/private/sc.ss

@@ -214,7 +214,7 @@
      (frontier->syntax rest)]))
 
 (define (fail-sc stx #:pattern [pattern #f] #:reason [reason #f])
-  (make-failed stx pattern reason))
+  (make-failed stx pattern reason #f))
 
 (define (syntax-class-fail stx #:reason [reason #f])
-  (make-failed stx #f reason))
+  (make-failed stx #f reason #f))

collects/macro-debugger/stxclass/private/util.ss

@@ -86,7 +86,7 @@
              (raise-syntax-error #f "too few arguments for keyword" #'kw ctx)))]
       [(kw . more)
        (keyword? (syntax-e #'kw))
-       (raise-syntax-error #f "unexpected keyword" #'kw ctx)]
+       (raise-syntax-error #f "unexpected keyword" ctx #'kw)]
       [_
        (values (reverse rchunks) stx)]))
   (loop stx null))