stxclass: worked on opt/mand/etc error messages
svn: r13033
This commit is contained in:
parent
f6575759ba
commit
cd1c0f41b3
|
@ -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)
|
||||
|
||||
|
||||
|
|
|
@ -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?)
|
||||
|
|
|
@ -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 ...
|
||||
|
|
|
@ -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)
|
||||
|
|
|
@ -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))
|
||||
|
|
|
@ -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))
|
||||
|
|
Loading…
Reference in New Issue
Block a user