suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

stxclass: worked on opt/mand/etc error messages

Browse Source 
svn: r13033
This commit is contained in:
Ryan Culpepper 2009-01-08 01:04:13 +00:00
parent f6575759ba
commit cd1c0f41b3
6 changed files with 77 additions and 67 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

4
collects/macro-debugger/stxclass/private/kws.ss
View File

@ -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)

4
collects/macro-debugger/stxclass/private/lib.ss
View File

@ -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?)

29
collects/macro-debugger/stxclass/private/parse.ss
View File

@ -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 ...

101
collects/macro-debugger/stxclass/private/rep.ss
View File

@ -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)

4
collects/macro-debugger/stxclass/private/sc.ss
View File

@ -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))

2
collects/macro-debugger/stxclass/private/util.ss
View File

@ -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))