diff --git a/collects/macro-debugger/stxclass/private/kws.ss b/collects/macro-debugger/stxclass/private/kws.ss index f81393efae..0edb3cb651 100644 --- a/collects/macro-debugger/stxclass/private/kws.ss +++ b/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) diff --git a/collects/macro-debugger/stxclass/private/lib.ss b/collects/macro-debugger/stxclass/private/lib.ss index 47e5af9f23..98f5654c4d 100644 --- a/collects/macro-debugger/stxclass/private/lib.ss +++ b/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?) diff --git a/collects/macro-debugger/stxclass/private/parse.ss b/collects/macro-debugger/stxclass/private/parse.ss index dd307096ad..967678ba77 100644 --- a/collects/macro-debugger/stxclass/private/parse.ss +++ b/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 ... diff --git a/collects/macro-debugger/stxclass/private/rep.ss b/collects/macro-debugger/stxclass/private/rep.ss index f8ebe38114..de868a0766 100644 --- a/collects/macro-debugger/stxclass/private/rep.ss +++ b/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-values (chunks rest) (chunk-kw-seq/no-dups stx head-directive-table)) - (reject-duplicate-chunks chunks) +(define (parse-heads stx decls enclosing-depth) + (syntax-case stx () + [({} . 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)))) + (cadr default-row)))) + (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)) + 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)))) - (k rest - (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))))) + (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) diff --git a/collects/macro-debugger/stxclass/private/sc.ss b/collects/macro-debugger/stxclass/private/sc.ss index dc13171f49..bbd192aa76 100644 --- a/collects/macro-debugger/stxclass/private/sc.ss +++ b/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)) diff --git a/collects/macro-debugger/stxclass/private/util.ss b/collects/macro-debugger/stxclass/private/util.ss index af88bb003c..efa24ed302 100644 --- a/collects/macro-debugger/stxclass/private/util.ss +++ b/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))