stxclass: fixed/simplified error reporting, removed dead code

svn: r13396

collects/stxclass/private/codegen.ss

@@ -24,15 +24,16 @@
   (cond [(rhs:union? rhs)
          (with-syntax ([(arg ...) args])
            #`(lambda (x arg ...)
-               (define (fail-rhs x expected reason frontier)
+               (define (fail-rhs x expected frontier)
-                 (make-failed x expected reason frontier))
+                 (make-failed x expected frontier))
                #,(let ([pks (rhs->pks rhs relsattrs #'x)])
-                   (if (pair? pks)
+                   (unless (pair? pks)
-                       (parse:pks (list #'x)
+                     (wrong-syntax (rhs-orig-stx rhs)
-                                  (list (empty-frontier #'x))
+                                   "syntax class has no variants"))
-                                  pks
+                   (parse:pks (list #'x)
-                                  #'fail-rhs)
+                              (list (empty-frontier #'x))
-                       (fail #'fail-rhs #'x #:fce (empty-frontier #'x))))))]
+                              pks
+                              #'fail-rhs))))]
         [(rhs:basic? rhs)
          (rhs:basic-parser rhs)]))
 
@@ -67,13 +68,12 @@
   (unless (stx-list? clauses-stx)
     (wrong-syntax clauses-stx "expected sequence of clauses"))
   (let ([pks (map clause->pk (stx->list clauses-stx))])
-    (if (pair? pks)
+    (unless (pair? pks)
-        (parse:pks (list var)
+      (wrong-syntax stx "no variants"))
-                   (list (empty-frontier var))
+    (parse:pks (list var)
-                   pks
+               (list (empty-frontier var))
-                   failid)
+               pks
-        (fail failid var #:fce (empty-frontier var)))))
+               failid)))
-
 
 ;; rhs->pks : RHS (listof SAttr) identifier -> (listof PK)
 (define (rhs->pks rhs relsattrs main-var)
@@ -107,7 +107,7 @@
              (if x
                  #,k-rest
                  #,(fail #'enclosing-fail main-var
-                         #:reason "side condition failed"
+                         #:pattern (expectation-of/message "side condition failed")
                          #:fce (done-frontier main-var))))))]
     [(cons (struct clause:with (p e)) rest)
      (let* ([new-iattrs (append (pattern-attrs p) iattrs)]
@@ -139,12 +139,13 @@
   (syntax->list stx))
 
 ;; fail : id id #:pattern datum #:reason datum #:fce FCE -> stx
-(define (fail k x #:pattern [p #'#f] #:reason [reason #f] #:fce fce)
+(define (fail k x #:pattern p #:fce fce)
-  (with-syntax ([k k] [x x] [p p] [reason reason]
+  (with-syntax ([k k]
+                [x x]
+                [p p]
                 [fc-expr (frontier->expr fce)])
     #`(let ([failcontext fc-expr])
-        #;(printf "failed: reason=~s, p=~s\n  fc=~s\n" reason p failcontext)
+        (k x p failcontext))))
-        (k x p 'reason failcontext))))
 
 
 ;; Parsing
@@ -163,8 +164,7 @@
                    #`(with-enclosing-fail #,failvar #,(pk-k pk)))])
            (with-syntax ([failvar failvar]
                          [(expr ...) exprs])
-             #`(let-syntax ([failvar (make-rename-transformer (quote-syntax #,failid))])
+             #`(try failvar [expr ...] #,failid)))]
-                 (try failvar (expr ...)))))]
         [else
          (let-values ([(vars extpks) (split-pks vars pks)])
            (let* ([failvar (car (generate-temporaries #'(fail-k)))]
@@ -173,8 +173,7 @@
                      (parse:extpk vars fcs extpk failvar))])
              (with-syntax ([failvar failvar]
                            [(expr ...) exprs])
-               #`(let-syntax ([failvar (make-rename-transformer (quote-syntax #,failid))])
+               #`(try failvar [expr ...] #,failid))))]))
-                   (try failvar (expr ...))))))]))
 
 
 ;; parse:extpk : (listof identifier) (listof FCE) ExtPK identifier -> stx
@@ -182,29 +181,38 @@
 (define (parse:extpk vars fcs extpk failid)
   (match extpk
     [(struct idpks (stxclass args pks))
-     (parse:pk:id vars fcs failid stxclass args pks)]
+     (if stxclass
+         (parse:pk:id/stxclass vars fcs failid stxclass args pks)
+         (parse:pk:id/any  vars fcs failid args pks))]
     [(struct cpks (pairpks datumpkss literalpkss))
      (parse:pk:c vars fcs failid pairpks datumpkss literalpkss)]
     [(struct pk ((cons (? pat:gseq? gseq-pattern) rest-patterns) k))
      (parse:pk:gseq vars fcs failid gseq-pattern rest-patterns k)]))
 
-;; parse:pk:id : (listof id) (listof FCE) id SC stx (listof pk) -> stx
+;; parse:pk:id/stxclass : (listof id) (listof FCE) id SC stx (listof pk) -> stx
-(define (parse:pk:id vars fcs failid stxclass args pks)
+(define (parse:pk:id/stxclass vars fcs failid stxclass args pks)
-  (define var (car vars))
+  (with-syntax ([var0 (car vars)]
-  (define fc (car fcs))
-  (with-syntax ([var0 var]
                 [(arg ...) args]
                 [(arg-var ...) (generate-temporaries args)]
-                [(result) (generate-temporaries #'(result))])
+                [parser (sc-parser-name stxclass)]
+                [result (generate-temporary 'result)])
     #`(let ([arg-var arg] ...)
-        (let ([result #,(if stxclass
+        (let ([result (parser var0 arg-var ...)])
-                            #`(#,(sc-parser-name stxclass) var0 arg-var ...)
-                            #`(list var0))])
           (if (ok? result)
               #,(parse:pks (cdr vars) (cdr fcs) (shift-pks:id pks #'result) failid)
-              #,(fail failid var
+              #,(fail failid (car vars)
                       #:pattern (expectation-of-stxclass stxclass #'(arg-var ...))
-                      #:fce fc))))))
+                      #: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)
+  (with-syntax ([var0 (car vars)]
+                [(arg ...) args]
+                [(arg-var ...) (generate-temporaries args)]
+                [result (generate-temporary 'result)])
+    #`(let ([arg-var arg] ...)
+        (let ([result (list var0)])
+          #,(parse:pks (cdr vars) (cdr fcs) (shift-pks:id pks #'result) failid)))))
 
 ;; parse:pk:c : (listof id) (listof FCE) id ??? ... -> stx
 (define (parse:pk:c vars fcs failid pairpks datumpkss literalpkss)
@@ -237,7 +245,7 @@
         (cond #,@(if (pair? pairpks)
                      #`([(pair? dvar0)
                          (let ([head-var (car dvar0)]
-                               [tail-var (cdr dvar0)])
+                               [tail-var (datum->syntax var0 (cdr dvar0) var0)])
                            #,(parse:pks (list* #'head-var #'tail-var (cdr vars))
                                         (list* (frontier:add-car (car fcs) #'head-var)
                                                (frontier:add-cdr (car fcs))
@@ -329,6 +337,7 @@
                 (let ([rep (add1 rep)])
                   (parse-loop x #,@hid-args #,@reps enclosing-fail))
                 #,(fail #'enclosing-fail #'var0
+                        #:pattern (expectation-of/message "maximum rep constraint failed")
                         #:fce (frontier:add-index (car fcs)
                                                   #`(calculate-index #,@reps)))))))
 
@@ -337,10 +346,9 @@
                      (for/list ([repvar reps] [minrep mins] #:when minrep)
                        #`[(< #,repvar #,minrep)
                           #,(fail #'enclosing-fail (car vars)
+                                  #:pattern (expectation-of/message "mininum rep constraint failed")
                                   #:fce (frontier:add-index (car fcs)
-                                                            #`(calculate-index #,@reps))
+                                                            #`(calculate-index #,@reps)))])])
-                                  #:pattern (expectation-of-constants
-                                             #f '(minimum-rep-constraint-failed) '()))])])
         #`(cond minrep-clause ...
                 [else
                  (let ([hid (finalize hid-arg)] ... ...
@@ -458,8 +466,6 @@
              (pattern-intersects? (pat:pair-tail p1) (pat:pair-tail p2)))
         ;; FIXME: conservative
         (and (pat:literal? p1) (pat:literal? p2))
-        (pat:splice? p1)
-        (pat:splice? p2)
         (pat:gseq? p1)
         (pat:gseq? p2)))
 

collects/stxclass/private/kws.ss

@@ -88,9 +88,9 @@
 
 ;; A PatternParseResult is one of
 ;;   - (listof value)
-;;   - (make-failed stx sexpr(Pattern) string frontier/#f)
+;;   - (make-failed stx expectation/c frontier/#f)
 (define (ok? x) (or (pair? x) (null? x)))
-(define-struct failed (stx patstx reason frontier)
+(define-struct failed (stx expectation frontier)
   #:transparent)
 
 
@@ -98,4 +98,3 @@
   (syntax-parameterize ((enclosing-fail
                          (make-rename-transformer (quote-syntax failvar))))
     expr))
-

collects/stxclass/private/messages.ss

@@ -1,9 +1,12 @@
 #lang scheme/base
-(require (for-syntax scheme/base "rep-data.ss")
+(require (for-syntax scheme/base syntax/stx "rep-data.ss")
+         scheme/contract
          scheme/match)
 (provide (for-syntax expectation-of-stxclass
-                     expectation-of-constants)
+                     expectation-of-constants
+                     expectation-of/message)
          try
+         expectation/c
          expectation-of-null?
          expectation->string)
 
@@ -13,46 +16,63 @@
 (define-struct expc (stxclasses pairs? data literals)
   #:transparent)
 
+(define expectation/c (or/c expc?))
+
 (define (make-stxclass-expc scdyn)
   (make-expc (list scdyn) #f null null))
 
 (begin-for-syntax
   (define certify (syntax-local-certifier))
   (define (expectation-of-stxclass stxclass args)
-    (if stxclass
+    (unless (sc? stxclass)
-        (with-syntax ([name (sc-name stxclass)]
+      (raise-type-error 'expectation-of-stxclass "stxclass" stxclass))
-                      [desc-var (sc-description stxclass)]
+    (with-syntax ([name (sc-name stxclass)]
-                      [(arg ...) args])
+                  [desc-var (sc-description stxclass)]
-          (certify #'(make-stxclass-expc (make-scdyn 'name (desc-var arg ...)))))
+                  [(arg ...) args])
-        #'#f))
+      (certify #'(make-stxclass-expc (make-scdyn 'name (desc-var arg ...))))))
 
   (define (expectation-of-constants pairs? data literals)
     (with-syntax ([(datum ...) data]
                   [(literal ...) literals]
                   [pairs? pairs?])
       (certify
-       #'(make-expc null 'pairs? (list 'datum ...) (list (quote-syntax literal) ...))))))
+       #'(make-expc null 'pairs? (list 'datum ...) (list (quote-syntax literal) ...)))))
 
-(define-syntax try
+  (define (expectation-of/message msg)
-  (syntax-rules ()
+    (with-syntax ([msg msg])
-    [(try failvar (expr0))
+      (certify
-     expr0]
+       #'(make-expc '() #f '((msg)) '())))))
-    [(try failvar (expr0 . exprs))
-     (let ([failvar
-            (lambda (x1 p1 r1 f1)
-              (let ([failvar
-                     (lambda (x2 p2 r2 f2)
-                       (choose-error failvar x1 x2 p1 p2 r1 r2 f1 f2))])
-                (try failvar exprs)))])
-       expr0)]))
 
-(define (choose-error k x1 x2 p1 p2 r1 r2 frontier1 frontier2)
+
-  (define (go1) (k x1 p1 r1 frontier1))
+(define-syntax (try stx)
-  (define (go2) (k x2 p2 r2 frontier2))
+  (syntax-case stx ()
+    [(try failvar (expr ...) previous-fail)
+     (when (stx-null? #'(expr ...))
+       (raise-syntax-error #f "must have at least one attempt" stx))
+     #'(try* (list (lambda (failvar) expr) ...) previous-fail)]))
+
+;; try* : (nonempty-listof (-> FailFunction Result)) FailFunction -> Result
+;; FailFunction = (stx expectation/c ?? DynamicFrontier) -> Result
+(define (try* attempts fail)
+  (let ([first-attempt (car attempts)]
+        [rest-attempts (cdr attempts)])
+    (if (null? rest-attempts)
+        (first-attempt fail)
+        (let ([next-fail
+               (lambda (x1 p1 f1)
+                 (let ([combining-fail
+                        (lambda (x2 p2 f2)
+                          (choose-error fail x1 x2 p1 p2 f1 f2))])
+                   (try* rest-attempts combining-fail)))])
+          (first-attempt next-fail)))))
+
+(define (choose-error k x1 x2 p1 p2 frontier1 frontier2)
+  (define (go1) (k x1 p1 frontier1))
+  (define (go2) (k x2 p2 frontier2))
   (let loop ([f1 frontier1] [f2 frontier2])
     (cond [(and (null? f1) (null? f2))
            (let ([p (merge-expectations p1 p2)])
-             (k x1 p #f frontier1))]
+             (k x1 p frontier1))]
           [(and (pair? f1) (null? f2)) (go1)]
           [(and (null? f1) (pair? f2)) (go2)]
           [(and (pair? f1) (pair? f2))
@@ -68,7 +88,8 @@
              (union (expc-data e1) (expc-data e2))
              (union (expc-literals e1) (expc-literals e2))))
 
-(define union append)
+(define (union a b)
+  (append a (for/list ([x b] #:when (not (member x a))) x)))
 
 (define (expectation-of-null? e)
   (match e
@@ -141,18 +162,3 @@
     [(2) (format "~a ~a~a" (car items) ult (cadr items))]
     [else (let ([strings (list* (car items) (loop (cdr items)))])
             (apply string-append strings))]))
-
-;; (define (comma-list items0)
-;;   (define items (for/list ([item items0]) (format "~s" item)))
-;;   (define (loop items)
-;;     (cond [(null? items)
-;;            null]
-;;           [(null? (cdr items))
-;;            (list ", or " (car items))]
-;;           [else
-;;            (list* ", " (car items) (loop (cdr items)))]))
-;;   (case (length items)
-;;     [(2) (format "~a or ~a" (car items) (cadr items))]
-;;     [else (let ([strings (list* (car items) (loop (cdr items)))])
-;;             (apply string-append strings))]))
-

collects/stxclass/private/rep-data.ss

@@ -17,10 +17,7 @@
          (struct-out pat:datum)
          (struct-out pat:literal)
          (struct-out pat:pair)
-         (struct-out pat:splice)
          (struct-out pat:gseq)
-         (struct-out splice-pattern)
-         (struct-out pat:splice-id)
          (struct-out head)
          (struct-out clause:when)
          (struct-out clause:with))
@@ -68,16 +65,8 @@
 (define-struct (pat:datum pattern) (datum) #:transparent)
 (define-struct (pat:literal pattern) (literal) #:transparent)
 (define-struct (pat:pair pattern) (head tail) #:transparent)
-(define-struct (pat:splice pattern) (head tail) #:transparent)
 (define-struct (pat:gseq pattern) (heads tail) #:transparent)
 
-;; A SplicePattern is one of
-;;   (make-pat:splice-id <Pattern> identifier SSC (listof stx))
-(define-struct (splice-pattern pattern) ()
-  #:transparent)
-(define-struct (pat:splice-id splice-pattern) (name stx-splice-class args)
-  #:transparent)
-
 ;; A Head is
 ;;   (make-head stx (listof IAttr) nat (listof Pattern) nat/f nat/f boolean id/#f stx/#f)
 (define-struct head (orig-stx attrs depth ps min max as-list? occurs default)
@@ -196,7 +185,7 @@
                                (syntax-e scname))]
                 [_ (void)])
               (let ([sc (get-stxclass scname)])
-                (values id sc null (ssc? sc))))]
+                (values id sc null)))]
         [(decls id0)
          => (lambda (p)
               (define scname (cadr p))
@@ -207,8 +196,8 @@
                               "too few arguments for syntax-class ~a (expected ~s)"
                               (sc-name stxclass)
                               (length (sc-inputs stxclass))))
-              (values id0 stxclass args (ssc? stxclass)))]
+              (values id0 stxclass args))]
-        [else (values id0 #f null #f)]))
+        [else (values id0 #f null)]))
 
 
 ;; intersect-attrss : (listof (listof SAttr)) stx -> (listof SAttr)

collects/stxclass/private/rep.ss

@@ -6,18 +6,16 @@
          syntax/stx
          "../util.ss"
          "rep-data.ss")
+
 (provide/contract
  [parse-pattern 
-  (->* [any/c #|syntax?|# DeclEnv/c exact-nonnegative-integer?]
+  (-> any/c #|syntax?|# DeclEnv/c exact-nonnegative-integer?
-       [boolean?]
+      pattern?)]
-       pattern?)]
  [parse-pattern-directives
   (->* [stx-list?]
        [#:sc? boolean? #:literals (listof identifier?)]
        (values stx-list? DeclEnv/c RemapEnv/c (listof SideClause/c)))]
- [parse-rhs (syntax? boolean? syntax? . -> . rhs?)]
+ [parse-rhs (syntax? boolean? syntax? . -> . rhs?)])
- [parse-splice-rhs (syntax? boolean? syntax? . -> . rhs?)])
-
 
 (define (atomic-datum? stx)
   (let ([datum (syntax-e stx)])
@@ -49,16 +47,6 @@
 ;; If allow-unbound? is true, then unbound stxclass acts as if it has no attrs.
 ;; Used for pass1 (attr collection); parser requires stxclasses to be bound.
 (define (parse-rhs stx allow-unbound? ctx)
-  (parse-rhs* stx allow-unbound? #f ctx))
-
-;; parse-splice-rhs : stx(SyntaxClassRHS) boolean stx -> RHS
-;; If allow-unbound? is true, then unbound stxclass acts as if it has no attrs.
-;; Used for pass1 (attr collection); parser requires stxclasses to be bound.
-(define (parse-splice-rhs stx allow-unbound? ctx)
-  (parse-rhs* stx allow-unbound? #t ctx))
-
-;; parse-rhs* : stx boolean boolean stx -> RHS
-(define (parse-rhs* stx allow-unbound? splice? ctx)
   (define-values (chunks rest)
     (chunk-kw-seq stx rhs-directive-table #:context ctx))
   (define lits0 (assq '#:literals chunks))
@@ -90,7 +78,7 @@
     (define (gather-patterns stx)
       (syntax-case stx (pattern)
         [((pattern . _) . rest)
-         (cons (parse-rhs-pattern (stx-car stx) allow-unbound? splice? literals)
+         (cons (parse-rhs-pattern (stx-car stx) allow-unbound? literals)
                (gather-patterns #'rest))]
         [()
          null]))
@@ -110,7 +98,7 @@
      (parse-rhs*-patterns rest)]))
 
 ;; parse-rhs-pattern : stx boolean boolean (listof identifier) -> RHS
-(define (parse-rhs-pattern stx allow-unbound? splice? literals)
+(define (parse-rhs-pattern stx allow-unbound? literals)
   (syntax-case stx (pattern)
     [(pattern p . rest)
      (parameterize ((allow-unbound-stxclasses allow-unbound?))
@@ -122,8 +110,6 @@
            (wrong-syntax (if (pair? rest) (car rest) rest)
                          "unexpected terms after pattern directives"))
          (let* ([pattern (parse-pattern #'p decls 0)]
-                [_ (when splice?
-                     (check-proper-list-pattern pattern))]
                 [with-patterns
                  (for/list ([c clauses] #:when (clause:with? c))
                    (clause:with-pattern c))]
@@ -141,7 +127,7 @@
         (list '#:transparent)))
 
 ;; parse-pattern : stx(Pattern) env number -> Pattern
-(define (parse-pattern stx decls depth [allow-splice? #f])
+(define (parse-pattern stx decls depth)
   (syntax-case stx ()
     [dots
      (or (dots? #'dots)
@@ -152,10 +138,7 @@
      (make pat:literal stx null depth stx)]
     [id
      (identifier? #'id)
-     (let-values ([(name sc args splice?) (split-id/get-stxclass #'id decls)])
+     (let-values ([(name sc args) (split-id/get-stxclass #'id decls)])
-       (when splice?
-         (unless allow-splice?
-           (wrong-syntax stx "splice-pattern not allowed here")))
        (let ([attrs
               (cond [(wildcard? name) null]
                     [(and (epsilon? name) sc)
@@ -167,9 +150,7 @@
                     [else
                      (list (make attr name depth (if sc (sc-attrs sc) null)))])]
              [name (if (epsilon? name) #f name)])
-         (if splice?
+         (make pat:id stx attrs depth name sc args)))]
-             (make pat:splice-id stx attrs depth name sc args)
-             (make pat:id stx attrs depth name sc args))))]
     [datum
      (atomic-datum? #'datum)
      (make pat:datum stx null depth (syntax->datum #'datum))]
@@ -188,12 +169,10 @@
             [attrs (append-attrs (list (head-attrs head) (pattern-attrs tail)) stx)])
        (make pat:gseq stx attrs depth (list head) tail))]
     [(a . b)
-     (let ([pa (parse-pattern #'a decls depth #t)]
+     (let ([pa (parse-pattern #'a decls depth)]
            [pb (parse-pattern #'b decls depth)])
        (let ([attrs (append-attrs (list (pattern-attrs pa) (pattern-attrs pb)) stx)])
-         (if (splice-pattern? pa)
+         (make pat:pair stx attrs depth pa pb)))]))
-             (make pat:splice stx attrs depth pa pb)
-             (make pat:pair stx attrs depth pa pb))))]))
 
 (define (pattern->head p)
   (match p
@@ -360,20 +339,3 @@
             decls
             remap
             (reverse rclauses))))
-
-;; check-proper-list-pattern : Pattern -> void
-(define (check-proper-list-pattern p)
-  (define (err stx)
-    (wrong-syntax stx "not a proper list pattern"))
-  (match p
-    [(struct pat:id (orig-stx _ _ _ _ _))
-     (err orig-stx)]
-    [(struct pat:datum (orig-stx _ _ datum))
-     (unless (null? datum)
-       (err orig-stx))]
-    [(struct pat:pair (_ _ _ head tail))
-     (check-proper-list-pattern tail)]
-    [(struct pat:splice (_ _ _ head tail))
-     (check-proper-list-pattern tail)]
-    [(struct pat:gseq (_ _ _ heads tail))
-     (check-proper-list-pattern tail)]))