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

syntax/parse:

Browse Source 
tweaked error selection algorithm
  added tests

svn: r16533
This commit is contained in:
Ryan Culpepper 2009-11-04 00:31:24 +00:00
parent f3ae0f1875
commit 0feac0f636
9 changed files with 450 additions and 225 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

84
collects/syntax/private/stxparse/codegen-data.ss
View File

@ -6,77 +6,6 @@
"runtime.ss")) "runtime.ss"))
(provide (all-defined-out)) (provide (all-defined-out))
;; Frontiers
;; A FrontierContextExpr (FCE) is one of
;; - (make-fce Id (listof FrontierIndexExpr))
;; A FrontierIndexExpr is
;; - #'(+ Number expr ...)
(define-struct fce (stx indexes) #:prefab)
(define (empty-frontier x)
(make-fce x (list #'(+ 0))))
(define (done-frontier x)
(make-fce x (list #'(+ 0) #'(+ +inf.0))))
(define (frontier:add-car fc x)
(make-fce x (cons #'(+ 0) (fce-indexes fc))))
(define (frontier:add-cdr fc)
(define (fi:add1 fi)
(syntax-case fi (+)
[(+ n . rest)
#`(+ #,(add1 (syntax-e #'n)) . rest)]))
(make-fce (fce-stx fc)
(cons (fi:add1 (stx-car (fce-indexes fc)))
(stx-cdr (fce-indexes fc)))))
(define (frontier:add-index fc expr)
(define (fi:add-index fi expr)
(syntax-case fi (+)
[(+ n . rest)
#`(+ n #,expr . rest)]))
(make-fce (fce-stx fc)
(cons (fi:add-index (stx-car (fce-indexes fc)) expr)
(stx-cdr (fce-indexes fc)))))
(define (frontier:add-unvector fc x)
(frontier:add-car fc x))
(define (frontier:add-unbox fc x)
(frontier:add-car fc x))
(define (frontier:add-unpstruct fc x)
(frontier:add-car fc x))
(define (frontier:add-subparse fc x)
(frontier:add-car
(frontier:add-index (frontier:add-car fc x) +inf.0)
x))
;; A DynamicFrontierContext (DFC) is a list of numbers.
;; More operations on DFCs in runtime.ss
(define (frontier->dfc-expr fc)
(define (fi->qq-part fi)
(syntax-case fi (+)
[(+ n)
#'n]
[expr #`(unquote expr)]))
(let ([fis (reverse (stx->list (fce-indexes fc)))])
(with-syntax ([(part ...) (map fi->qq-part fis)])
#`(quasiquote (part ...)))))
(define (frontier->fstx-expr fc)
(fce-stx fc))
(define (frontier->index-expr fc)
(syntax-case fc ()
[#s(fce stx (index0 index ...))
#'index0]))
;; --------
(define (get-kind kind) (define (get-kind kind)
(syntax-case kind () (syntax-case kind ()
[#:pair pairK] [#:pair pairK]
@ -88,11 +17,10 @@
(and xkey (equal? xkey (quote key))))) (and xkey (equal? xkey (quote key)))))
(list (lambda (s d) (list (lambda (s d)
#`(datum->syntax #,s (cdr (vector->list (struct->vector #,d))) #,s))) #`(datum->syntax #,s (cdr (vector->list (struct->vector #,d))) #,s)))
(list (lambda (fc x) (list #'dfc-add-unpstruct))]))
(frontier:add-unpstruct fc x))))]))
;; A Kind is ;; A Kind is
;; (make-kind id (listof (id id -> stx)) (listof (FCE id -> FCE))) ;; (make-kind id (listof (id id -> stx)) (listof expr))
(define-struct kind (predicate selectors frontier-procs) #:transparent) (define-struct kind (predicate selectors frontier-procs) #:transparent)
@ -100,16 +28,16 @@
(make-kind #'pair? (make-kind #'pair?
(list (lambda (s d) #`(car #,d)) (list (lambda (s d) #`(car #,d))
(lambda (s d) #`(datum->syntax #,s (cdr #,d) #,s))) (lambda (s d) #`(datum->syntax #,s (cdr #,d) #,s)))
(list (lambda (fc x) (frontier:add-car fc x)) (list #'dfc-add-car
(lambda (fc x) (frontier:add-cdr fc))))) #'dfc-add-cdr)))
(define vectorK (define vectorK
(make-kind #'vector? (make-kind #'vector?
(list (lambda (s d) (list (lambda (s d)
#`(datum->syntax #,s (vector->list #,d) #,s))) #`(datum->syntax #,s (vector->list #,d) #,s)))
(list (lambda (fc x) (frontier:add-unvector fc x))))) (list #'dfc-add-unvector)))
(define boxK (define boxK
(make-kind #'box? (make-kind #'box?
(list (lambda (s d) #`(unbox #,d))) (list (lambda (s d) #`(unbox #,d)))
(list (lambda (fc x) (frontier:add-unbox fc x))))) (list #'dfc-add-unbox)))

2
collects/syntax/private/stxparse/lib.ss
View File

@ -36,7 +36,7 @@
kernel-literals) kernel-literals)
(define-syntax-rule (define-pred-stxclass name pred) (define-syntax-rule (define-pred-stxclass name pred)
(define-syntax-class name #:attributes () (define-syntax-class name #:attributes () #:opaque
(pattern x (pattern x
#:fail-unless (pred (syntax-e #'x)) #f))) #:fail-unless (pred (syntax-e #'x)) #f)))

138
collects/syntax/private/stxparse/parse.ss
View File

@ -36,14 +36,13 @@
;; ---- ;; ----
;; An FCE is expr[DFC]
;; (fail expr #:expect expr #:fce FCE) : expr ;; (fail expr #:expect expr #:fce FCE) : expr
(define-syntax (fail stx) (define-syntax (fail stx)
(syntax-case stx () (syntax-case stx ()
[(fail x #:expect p #:fce fce) [(fail x #:expect p #:fce fce)
(let ([fc-expr (frontier->dfc-expr (wash #'fce))] #'(enclosing-fail (make-failure x fce p))]))
[fstx-expr (frontier->fstx-expr (wash #'fce))])
#`(enclosing-fail
(make-failure x #,fc-expr #,fstx-expr p)))]))
;; (parse:rhs RHS (SAttr ...) (id ...) id boolean) ;; (parse:rhs RHS (SAttr ...) (id ...) id boolean)
;; : expr[(values ParseFunction DescriptionFunction)] ;; : expr[(values ParseFunction DescriptionFunction)]
@ -73,15 +72,13 @@
(define-syntax (parse:variant stx) (define-syntax (parse:variant stx)
(syntax-case stx () (syntax-case stx ()
[(parse:variant x relsattrs variant #f) [(parse:variant x relsattrs variant #f)
(with-syntax ([#s(variant _ _ pattern _ (def ...)) #'variant] (with-syntax ([#s(variant _ _ pattern _ (def ...)) #'variant])
[fc (empty-frontier #'x)]) #`(let ([fc (dfc-empty x)])
#`(let ()
def ... def ...
(parse:S x fc pattern (variant-success x relsattrs variant ()))))] (parse:S x fc pattern (variant-success x relsattrs variant ()))))]
[(parse:variant x relsattrs variant #t) [(parse:variant x relsattrs variant #t)
(with-syntax ([#s(variant _ _ pattern _ (def ...)) #'variant] (with-syntax ([#s(variant _ _ pattern _ (def ...)) #'variant])
[fc (empty-frontier #'x)]) #`(let ([fc (dfc-empty x)])
#`(let ()
def ... def ...
(parse:H x fc pattern rest index (parse:H x fc pattern rest index
(variant-success x relsattrs variant (rest index)))))])) (variant-success x relsattrs variant (rest index)))))]))
@ -104,17 +101,19 @@
[(convert-sides x (side0 . sides) (k iattrs . kargs)) [(convert-sides x (side0 . sides) (k iattrs . kargs))
(syntax-case #'side0 () (syntax-case #'side0 ()
[#s(clause:fail condition message) [#s(clause:fail condition message)
#`(let ([c (without-fails condition)]) #`(let* ([c (without-fails condition)]
[fc (dfc-add-post (dfc-empty x) (if (syntax? c) c x))])
(if c (if c
(fail (if (syntax? c) c x) (fail (if (syntax? c) c x)
#:expect (expectation-of-message message) #:expect (expectation-of-message message)
#:fce #,(frontier:add-subparse (done-frontier #'x) #'(if (syntax? c) c x))) #:fce fc)
(convert-sides x sides (k iattrs . kargs))))] (convert-sides x sides (k iattrs . kargs))))]
[#s(clause:with pattern expr (def ...)) [#s(clause:with pattern expr (def ...))
(with-syntax ([(p-iattr ...) (pattern-attrs (wash #'pattern))]) (with-syntax ([(p-iattr ...) (pattern-attrs (wash #'pattern))])
#`(let ([y (datum->syntax #f (without-fails expr))]) #`(let* ([y (datum->syntax #f (without-fails expr))]
[fc (dfc-add-post (dfc-empty x) y)])
def ... def ...
(parse:S y #,(done-frontier #'x) pattern (parse:S y fc pattern
(convert-sides x sides (convert-sides x sides
(k (p-iattr ... . iattrs) . kargs)))))] (k (p-iattr ... . iattrs) . kargs)))))]
[#s(clause:attr a expr) [#s(clause:attr a expr)
@ -156,11 +155,10 @@
#:decls decls0 #:decls decls0
#:context #'ctx)]) #:context #'ctx)])
(with-syntax ([rest rest] (with-syntax ([rest rest]
[fc (empty-frontier #'x)]
[pattern [pattern
(parse-whole-pattern #'p decls2 #:context #'ctx)] (parse-whole-pattern #'p decls2 #:context #'ctx)]
[(local-def ...) defs2]) [(local-def ...) defs2])
#`(let () #`(let ([fc (dfc-empty x)])
local-def ... local-def ...
(parse:S x fc pattern (parse:S x fc pattern
(convert-sides x #,sides (convert-sides x #,sides
@ -194,9 +192,9 @@
(syntax-case stx () (syntax-case stx ()
[(parse:S x fc pattern0 k) [(parse:S x fc pattern0 k)
(syntax-case #'pattern0 () (syntax-case #'pattern0 ()
[#s(internal-rest-pattern rest index index0) [#s(internal-rest-pattern rest rest-fc)
#`(let ([rest x] #`(let ([rest x]
[index (- #,(frontier->index-expr (wash #'fc)) index0)]) [rest-fc fc])
k)] k)]
[#s(pat:name attrs pattern (name ...)) [#s(pat:name attrs pattern (name ...))
#`(let-attributes ([#s(attr name 0 #t) x] ...) #`(let-attributes ([#s(attr name 0 #t) x] ...)
@ -231,8 +229,8 @@
[#s(pat:ghost attrs ghost subpattern) [#s(pat:ghost attrs ghost subpattern)
#'(parse:G x fc ghost (parse:S x fc subpattern k))] #'(parse:G x fc ghost (parse:S x fc subpattern k))]
[#s(pat:head attrs head tail) [#s(pat:head attrs head tail)
#`(parse:H x fc head rest index #`(parse:H x fc head rest rest-fc
(parse:S rest #,(frontier:add-index (wash #'fc) #'index) tail k))] (parse:S rest rest-fc tail k))]
[#s(pat:dots attrs head tail) [#s(pat:dots attrs head tail)
#`(parse:dots x fc head tail k)] #`(parse:dots x fc head tail k)]
[#s(pat:and attrs subpatterns) [#s(pat:and attrs subpatterns)
@ -258,17 +256,16 @@
(let ([kind (get-kind (wash #'kind0))]) (let ([kind (get-kind (wash #'kind0))])
(with-syntax ([(part ...) (generate-temporaries (kind-selectors kind))]) (with-syntax ([(part ...) (generate-temporaries (kind-selectors kind))])
(with-syntax ([predicate (kind-predicate kind)] (with-syntax ([predicate (kind-predicate kind)]
[(part-fc ...) [(part-fc ...) (generate-temporaries #'(part ...))]
(for/list ([fproc (kind-frontier-procs kind)] [(part-fc-proc ...) (kind-frontier-procs kind)]
[part-var (syntax->list #'(part ...))])
(fproc (wash #'fc) part-var))]
[(part-expr ...) [(part-expr ...)
(for/list ([selector (kind-selectors kind)]) (for/list ([selector (kind-selectors kind)])
(selector #'x #'datum))]) (selector #'x #'datum))])
#`(let ([datum (syntax-e x)]) #`(let ([datum (syntax-e x)])
(if (predicate datum) (if (predicate datum)
(let ([part part-expr] ...) (let ([part part-expr] ...)
(parse:S* (part ...) (part-fc ...) (part-pattern ...) k)) (let ([part-fc (part-fc-proc fc part)] ...)
(parse:S* (part ...) (part-fc ...) (part-pattern ...) k)))
(fail x (fail x
#:expect (expectation pattern0) #:expect (expectation pattern0)
#:fce fc))))))] #:fce fc))))))]
@ -280,10 +277,11 @@
#:expect (expectation-of-thing description transparent? failure) #:expect (expectation-of-thing description transparent? failure)
#:fce fc)) #:fce fc))
(with-enclosing-fail* new-fail (with-enclosing-fail* new-fail
(parse:S x #,(empty-frontier #'x) pattern (let ([new-fc (dfc-empty x)])
(parse:S x new-fc pattern
(with-enclosing-cut-fail previous-cut-fail (with-enclosing-cut-fail previous-cut-fail
(with-enclosing-fail previous-fail (with-enclosing-fail previous-fail
k)))))])])) k))))))])]))
;; (parse:S* (id ...) (FCE ...) (SinglePattern ...) expr) : expr ;; (parse:S* (id ...) (FCE ...) (SinglePattern ...) expr) : expr
(define-syntax parse:S* (define-syntax parse:S*
@ -326,16 +324,17 @@
[#s(ghost:bind _ clauses) [#s(ghost:bind _ clauses)
#`(convert-sides x clauses (clause-success () k))] #`(convert-sides x clauses (clause-success () k))]
[#s(ghost:fail _ condition message) [#s(ghost:fail _ condition message)
#`(let ([c (without-fails condition)]) #`(let* ([c (without-fails condition)]
[fc* (dfc-add-post fc (if (syntax? c) c x))])
(if c (if c
(fail (if (syntax? c) c x) (fail (if (syntax? c) c x)
#:expect (expectation pattern0) #:expect (expectation pattern0)
#:fce #,(frontier:add-subparse (wash #'fc) #'(if (syntax? c) c x))) #:fce fc*)
k))] k))]
[#s(ghost:parse _ pattern expr) [#s(ghost:parse _ pattern expr)
#`(let ([y (datum->syntax #f (without-fails expr))]) #`(let* ([y (datum->syntax #f (without-fails expr))]
(parse:S y #,(frontier:add-subparse (wash #'fc) #'y) [fc* (dfc-add-post fc y)])
pattern k))])])) (parse:S y fc* pattern k))])]))
(begin-for-syntax (begin-for-syntax
;; convert-list-pattern : ListPattern id -> SinglePattern ;; convert-list-pattern : ListPattern id -> SinglePattern
@ -348,6 +347,9 @@
[#s(pat:name attrs pattern names) [#s(pat:name attrs pattern names)
(with-syntax ([pattern (convert-list-pattern #'pattern end-pattern)]) (with-syntax ([pattern (convert-list-pattern #'pattern end-pattern)])
#'#s(pat:name attrs pattern names))] #'#s(pat:name attrs pattern names))]
[#s(pat:ghost attrs ghost tail)
(with-syntax ([tail (convert-list-pattern #'tail end-pattern)])
#'#s(pat:ghost attrs ghost tail))]
[#s(pat:head attrs head tail) [#s(pat:head attrs head tail)
(with-syntax ([tail (convert-list-pattern #'tail end-pattern)]) (with-syntax ([tail (convert-list-pattern #'tail end-pattern)])
#'#s(pat:head attrs head tail))] #'#s(pat:head attrs head tail))]
@ -361,7 +363,7 @@
;; (parse:H id FCE HeadPattern id id expr) : expr ;; (parse:H id FCE HeadPattern id id expr) : expr
(define-syntax (parse:H stx) (define-syntax (parse:H stx)
(syntax-case stx () (syntax-case stx ()
[(parse:H x fc head rest index k) [(parse:H x fc head rest rest-fc k)
(syntax-case #'head () (syntax-case #'head ()
[#s(hpat:describe _ description transparent? pattern) [#s(hpat:describe _ description transparent? pattern)
#`(let ([previous-fail enclosing-fail] #`(let ([previous-fail enclosing-fail]
@ -370,70 +372,66 @@
(fail x (fail x
#:expect (expectation-of-thing description transparent? failure) #:expect (expectation-of-thing description transparent? failure)
#:fce fc)) #:fce fc))
(let ([fc* (dfc-empty x)])
(with-enclosing-fail* new-fail (with-enclosing-fail* new-fail
(parse:H x #,(empty-frontier #'x) pattern (parse:H x fc* pattern rest rest-fc
rest index
(with-enclosing-cut-fail previous-cut-fail (with-enclosing-cut-fail previous-cut-fail
(with-enclosing-fail previous-fail (with-enclosing-fail previous-fail
k)))))] k))))))]
[#s(hpat:var _attrs name parser (arg ...) (nested-a ...)) [#s(hpat:var _attrs name parser (arg ...) (nested-a ...))
#`(let ([result (parser x)]) #`(let ([result (parser x)])
(if (ok? result) (if (ok? result)
(let ([rest (car result)] (let* ([rest (car result)]
[index (cadr result)]) [local-fc (cadr result)]
[rest-fc (dfc-append fc local-fc)])
(let-attributes (#,@(if (identifier? #'name) (let-attributes (#,@(if (identifier? #'name)
#'([#s(attr name 0 #t) #'([#s(attr name 0 #t)
(stx-list-take x index)]) (stx-list-take x (dfc->index local-fc))])
#'())) #'()))
(let/unpack ((nested-a ...) (cddr result)) (let/unpack ((nested-a ...) (cddr result))
k))) k)))
(fail x #:expect result #:fce fc)))] (fail x #:expect result #:fce fc)))]
[#s(hpat:and (a ...) head single) [#s(hpat:and (a ...) head single)
#`(parse:H x fc head rest index #`(parse:H x fc head rest rest-fc
(let ([lst (stx-list-take x index)]) (let ([lst (stx-list-take x (dfc-difference fc rest-fc))])
(parse:S lst fc single k)))] (parse:S lst fc single k)))]
[#s(hpat:or (a ...) (subpattern ...)) [#s(hpat:or (a ...) (subpattern ...))
(with-syntax ([(#s(attr id _ _) ...) #'(a ...)]) (with-syntax ([(#s(attr id _ _) ...) #'(a ...)])
#`(let ([success #`(let ([success
(lambda (rest index fail id ...) (lambda (rest rest-fc fail id ...)
(with-enclosing-fail fail (with-enclosing-fail fail
(let-attributes ([a id] ...) k)))]) (let-attributes ([a id] ...) k)))])
(try (parse:H x fc subpattern rest index (try (parse:H x fc subpattern rest rest-fc
(disjunct subpattern success (disjunct subpattern success
(rest index enclosing-fail) (id ...))) (rest rest-fc enclosing-fail) (id ...)))
...)))] ...)))]
[#s(hpat:seq attrs pattern) [#s(hpat:seq attrs pattern)
(with-syntax ([index0 (frontier->index-expr (wash #'fc))])
(with-syntax ([pattern (with-syntax ([pattern
(convert-list-pattern (convert-list-pattern
#'pattern #'pattern
#'#s(internal-rest-pattern rest index index0))]) #'#s(internal-rest-pattern rest rest-fc))])
#'(parse:S x fc pattern k)))] #'(parse:S x fc pattern k))]
[#s(hpat:optional (a ...) pattern defaults) [#s(hpat:optional (a ...) pattern defaults)
(with-syntax ([(#s(attr id _ _) ...) #'(a ...)] (with-syntax ([(#s(attr id _ _) ...) #'(a ...)])
[index0 (frontier->index-expr (wash #'fc))])
#`(let ([success #`(let ([success
(lambda (rest index fail id ...) (lambda (rest rest-fc fail id ...)
(with-enclosing-fail fail (with-enclosing-fail fail
(let-attributes ([a id] ...) k)))]) (let-attributes ([a id] ...) k)))])
(try (parse:H x fc pattern rest index (try (parse:H x fc pattern rest rest-fc
(success rest index enclosing-fail (attribute id) ...)) (success rest rest-fc enclosing-fail (attribute id) ...))
(let ([rest x] (let ([rest x]
[index index0]) [rest-fc fc])
(convert-sides x defaults (convert-sides x defaults
(clause-success () (clause-success ()
(disjunct/sides defaults success (disjunct/sides defaults success
(rest index enclosing-fail) (rest rest-fc enclosing-fail)
(id ...))))))))] (id ...))))))))]
[_ [_
(with-syntax ([attrs (pattern-attrs (wash #'head))] (with-syntax ([attrs (pattern-attrs (wash #'head))])
[index0 (frontier->index-expr (wash #'fc))])
#'(parse:S x fc #'(parse:S x fc
#s(pat:compound attrs #s(pat:compound attrs
#:pair #:pair
(head #s(internal-rest-pattern (head #s(internal-rest-pattern rest rest-fc)))
rest index
index0)))
k))])])) k))])]))
;; (parse:dots id FCE EHPattern SinglePattern expr) : expr ;; (parse:dots id FCE EHPattern SinglePattern expr) : expr
@ -462,34 +460,33 @@
[(rel-rep ...) rel-rep-ids] [(rel-rep ...) rel-rep-ids]
[(rel-repc ...) rel-repcs] [(rel-repc ...) rel-repcs]
[(a ...) attrs] [(a ...) attrs]
[(attr-repc ...) attr-repcs] [(attr-repc ...) attr-repcs])
[loop-fc (frontier:add-index (wash #'fc) #'index)])
(define-pattern-variable alt-map #'((id . alt-id) ...)) (define-pattern-variable alt-map #'((id . alt-id) ...))
(define-pattern-variable loop-k (define-pattern-variable loop-k
#'(dots-loop dx (+ index index2) enclosing-fail rel-rep ... alt-id ...)) #'(dots-loop dx loop-fc* enclosing-fail rel-rep ... alt-id ...))
#`(let () #`(let ()
(define (dots-loop dx index loop-fail rel-rep ... alt-id ...) (define (dots-loop dx loop-fc loop-fail rel-rep ... alt-id ...)
(with-enclosing-fail loop-fail (with-enclosing-fail loop-fail
(try (parse:EH dx loop-fc head head-repc index2 alt-map head-rep (try (parse:EH dx loop-fc head head-repc loop-fc* alt-map head-rep
loop-k) loop-k)
... ...
(cond [(< rel-rep (rep:min-number rel-repc)) (cond [(< rel-rep (rep:min-number rel-repc))
(fail dx (fail dx
#:expect (expectation-of-reps/too-few rel-rep rel-repc) #:expect (expectation-of-reps/too-few rel-rep rel-repc)
#:fce loop-fc)] #:fce (dfc-add-pre loop-fc #f))]
... ...
[else [else
(let-attributes ([a (rep:finalize a attr-repc alt-id)] ...) (let-attributes ([a (rep:finalize a attr-repc alt-id)] ...)
(parse:S dx loop-fc tail k))])))) (parse:S dx loop-fc tail k))]))))
(let ([rel-rep 0] ... (let ([rel-rep 0] ...
[alt-id (rep:initial-value attr-repc)] ...) [alt-id (rep:initial-value attr-repc)] ...)
(dots-loop x 0 enclosing-fail rel-rep ... alt-id ...)))))])) (dots-loop x fc enclosing-fail rel-rep ... alt-id ...)))))]))
;; (parse:EH id FCE EHPattern id id ((id . id) ...) ;; (parse:EH id FCE EHPattern id id ((id . id) ...)
;; RepConstraint/#f expr) : expr ;; RepConstraint/#f expr) : expr
(define-syntax (parse:EH stx) (define-syntax (parse:EH stx)
(syntax-case stx () (syntax-case stx ()
[(parse:EH x fc head repc index alts rep k0) [(parse:EH x fc head repc fc* alts rep k0)
(let () (let ()
(define-pattern-variable k (define-pattern-variable k
(let* ([main-attrs (wash-iattrs (pattern-attrs (wash #'head)))] (let* ([main-attrs (wash-iattrs (pattern-attrs (wash #'head)))]
@ -506,14 +503,13 @@
#`(let ([alt-id (rep:combine repc (attribute id) alt-id)] ...) #`(let ([alt-id (rep:combine repc (attribute id) alt-id)] ...)
k0)))) k0))))
(syntax-case #'repc () (syntax-case #'repc ()
[#f #`(parse:H x fc head x index k)] [#f #`(parse:H x fc head x fc* k)]
[_ #`(parse:H x fc head x index [_ #`(parse:H x fc head x fc*
(if (< rep (rep:max-number repc)) (if (< rep (rep:max-number repc))
(let ([rep (add1 rep)]) k) (let ([rep (add1 rep)]) k)
(fail x (fail x
#:expect (expectation-of-reps/too-many rep repc) #:expect (expectation-of-reps/too-many rep repc)
#:fce #,(frontier:add-index (wash #'fc) #:fce fc*)))]))]))
#'index))))]))]))
;; (rep:initial-value RepConstraint) : expr ;; (rep:initial-value RepConstraint) : expr
(define-syntax (rep:initial-value stx) (define-syntax (rep:initial-value stx)

105
collects/syntax/private/stxparse/runtime-prose.ss
View File

@ -11,23 +11,27 @@
(for-syntax "../util/error.ss") (for-syntax "../util/error.ss")
"runtime.ss") "runtime.ss")
(provide syntax-patterns-fail (provide syntax-patterns-fail
current-failure-handler) current-failure-handler
simplify-failure)
;; Failure reporting parameter & default ;; Failure reporting parameter & default
(define (default-failure-handler stx0 f) (define (default-failure-handler stx0 f)
(match (simplify-failure f) (match (simplify-failure f)
[#s(failure x frontier frontier-stx expectation) [#s(failure x frontier expectation)
(report-failure stx0 x (last frontier) frontier-stx expectation)])) (report-failure stx0 x (dfc->index frontier) (dfc->stx frontier) expectation)]))
(define current-failure-handler (define current-failure-handler
(make-parameter default-failure-handler)) (make-parameter default-failure-handler))
(define ((syntax-patterns-fail stx0) f) (define ((syntax-patterns-fail stx0) f)
(let ([value ((current-failure-handler) stx0 f)]) (call-with-values (lambda () ((current-failure-handler) stx0 f))
(lambda vals
(error 'current-failure-handler (error 'current-failure-handler
"current-failure-handler: did not escape, produced ~e" value))) "current-failure-handler: did not escape, produced ~e"
(case (length vals)
((1) (car vals))
(else (cons 'values vals)))))))
;; report-failure : stx stx number stx Expectation -> (escapes) ;; report-failure : stx stx number stx Expectation -> (escapes)
(define (report-failure stx0 x index frontier-stx expected) (define (report-failure stx0 x index frontier-stx expected)
@ -39,6 +43,7 @@
[(one) [(one)
(err "unexpected term" stx0 #'one)] (err "unexpected term" stx0 #'one)]
[(first . more) [(first . more)
;; TODO: report error with all elements (use improper-stx->list)
(err "unexpected terms starting here" stx0 #'first)] (err "unexpected terms starting here" stx0 #'first)]
[_ [_
(err "unexpected term" stx0 x)])] (err "unexpected term" stx0 x)])]
@ -48,7 +53,6 @@
(err (format "~a~a" (err (format "~a~a"
msg msg
(cond [(zero? index) ""] (cond [(zero? index) ""]
[(= index +inf.0) "" #|" after matching main pattern"|#]
[else (format " after ~s ~a" [else (format " after ~s ~a"
index index
(if (= 1 index) "term" "terms"))])) (if (= 1 index) "term" "terms"))]))
@ -57,50 +61,66 @@
[else [else
(err "bad syntax" stx0 stx0)])) (err "bad syntax" stx0 stx0)]))
;; FIXME: try different selection/simplification algorithms/heuristics ;; simplify-failure : Failure -> SimpleFailure
(define (simplify-failure f) (define (simplify-failure f)
(simplify* f))
;; simplify* : Failure -> SimpleFailure
(define (simplify* f)
(match f (match f
[#s(join-failures f1 f2) [#s(join-failures f1 f2)
(choose-error (simplify-failure f1) (simplify-failure f2))] (choose-error (simplify* f1) (simplify* f2))]
[#s(failure x frontier frontier-stx expectation) [#s(failure x frontier expectation)
(match expectation (match expectation
[#s(expect:thing description '#t chained) [#s(expect:thing description '#t chained)
(let ([new-f (simplify-failure (adjust-failure chained frontier frontier-stx))]) (let ([chained* (simplify* chained)])
(match new-f (match chained*
[#s(failure _ _ _ new-e) [#s(failure _ chained*-frontier chained*-expectation)
(if (ineffable? new-e) (cond [(ineffable? chained*-expectation)
;; If unfolded failure is ineffable, fall back to the one with description ;; If simplified chained failure is ineffable,
f ;; keep (& adjust) its frontier
new-f)] ;; and attach enclosing description
[_ new-f]))] (adjust-failure
(make-failure x chained*-frontier
(make-expect:thing description #f #f))
frontier)]
[else
;; Otherwise, "expose" the chained failure and
;; adjust its frontier
(adjust-failure chained* frontier)])]))]
[_ f])])) [_ f])]))
(define (adjust-failure f base-frontier base-frontier-stx) ;; FIXME: try different selection/simplification algorithms/heuristics
(define (simplify-failure0 f)
(match f (match f
[#s(join-failures f1 f2) [#s(join-failures f1 f2)
(make-join-failures (choose-error (simplify-failure0 f1) (simplify-failure0 f2))]
(adjust-failure f1 base-frontier base-frontier-stx) [#s(failure x frontier expectation)
(adjust-failure f2 base-frontier base-frontier-stx))] (match expectation
[#s(failure x frontier frontier-stx expectation) [#s(expect:thing description '#t chained)
(let-values ([(frontier frontier-stx) (let ([chained* (simplify-failure0 chained)])
(combine-frontiers base-frontier base-frontier-stx (match chained*
frontier frontier-stx)]) [#s(failure _ _ chained*-expectation)
(make-failure x frontier frontier-stx expectation))])) (cond [(ineffable? chained*-expectation)
;; If simplified chained failure is ineffable, ignore it
(define (combine-frontiers dfc0 stx0 dfc stx) ;; and stick to the one with the description
(cond [(null? (cdr dfc0)) f]
(values (cons (+ (car dfc0) (car dfc))
(cdr dfc))
(if (null? (cdr dfc))
stx0
stx))]
[else [else
(let-values ([(f s) (combine-frontiers (cdr dfc0) stx0 dfc stx)]) ;; Otherwise, "expose" the chained failure
(values (cons (car dfc0) f) s))])) ;; and adjust its frontier
(adjust-failure chained* frontier)])]))]
[_ f])]))
;; choose-error : Failure Failure -> Result (define (adjust-failure f base-frontier)
(match f
[#s(failure x frontier expectation)
(let ([frontier (dfc-append base-frontier frontier)])
(make-failure x frontier expectation))]))
;; choose-error : Failure Failure -> Failure
(define (choose-error f1 f2) (define (choose-error f1 f2)
(case (compare-dfcs (failure-frontier f1) (failure-frontier f2)) (case (compare-idfcs (invert-dfc (failure-frontier f1))
(invert-dfc (failure-frontier f2)))
[(>) f1] [(>) f1]
[(<) f2] [(<) f2]
[(=) (merge-failures f1 f2)])) [(=) (merge-failures f1 f2)]))
@ -109,7 +129,6 @@
(define (merge-failures f1 f2) (define (merge-failures f1 f2)
(make-failure (failure-stx f1) (make-failure (failure-stx f1)
(failure-frontier f1) (failure-frontier f1)
(failure-frontier-stx f1)
(merge-expectations (failure-expectation f1) (merge-expectations (failure-expectation f1)
(failure-expectation f2)))) (failure-expectation f2))))
@ -163,3 +182,9 @@
[(2) (format "~a~a ~a~a" prefix (car items) ult (cadr items))] [(2) (format "~a~a ~a~a" prefix (car items) ult (cadr items))]
[else (let ([strings (list* (car items) (loop (cdr items)))]) [else (let ([strings (list* (car items) (loop (cdr items)))])
(apply string-append prefix strings))])) (apply string-append prefix strings))]))
(define (improper-stx->list stx)
(syntax-case stx ()
[(a . b) (cons #'a (improper-stx->list #'b))]
[() null]
[rest (list #'rest)]))

214
collects/syntax/private/stxparse/runtime.ss
View File

@ -2,6 +2,7 @@
(require scheme/contract/base (require scheme/contract/base
scheme/stxparam scheme/stxparam
scheme/list scheme/list
"minimatch.ss"
(for-syntax scheme/base (for-syntax scheme/base
syntax/stx syntax/stx
scheme/private/sc scheme/private/sc
@ -32,8 +33,6 @@
this-syntax this-syntax
compare-dfcs
expect? expect?
expectation? expectation?
(struct-out expect:thing) (struct-out expect:thing)
@ -121,21 +120,161 @@
;; == Dynamic Frontier Contexts (DFCs) ;; == Dynamic Frontier Contexts (DFCs)
;; A DFC is a list of numbers. (provide (struct-out dfc:empty)
(struct-out dfc:car)
(struct-out dfc:cdr)
(struct-out dfc:pre)
(struct-out dfc:post)
dfc-empty
dfc-add-car
dfc-add-cdr
dfc-add-pre
dfc-add-post
dfc-add-unbox
dfc-add-unvector
dfc-add-unpstruct
;; compare-dfcs : DFC DFC -> (one-of '< '= '>) dfc->index
dfc->stx
dfc-difference
dfc-append
invert-dfc
compare-idfcs
idfc>?
idfc=?)
#|
A Dynamic Frontier Context (DFC) is one of
- (make-dfc:empty stx)
- (make-dfc:car DFC stx)
- (make-dfc:cdr DFC positive-integer)
- (make-dfc:pre DFC stx)
- (make-dfc:post DFC stx)
|#
(define-struct dfc:empty (stx) #:prefab)
(define-struct dfc:car (parent stx) #:prefab)
(define-struct dfc:cdr (parent n) #:prefab)
(define-struct dfc:pre (parent stx) #:prefab)
(define-struct dfc:post (parent stx) #:prefab)
(define (dfc-empty x) (make-dfc:empty x))
(define (dfc-add-car parent stx)
(make-dfc:car parent stx))
(define (dfc-add-cdr parent _)
(match parent
[#s(dfc:cdr uberparent n)
(make-dfc:cdr uberparent (add1 n))]
[_ (make-dfc:cdr parent 1)]))
(define (dfc-add-pre parent stx)
(make-dfc:pre parent stx))
(define (dfc-add-post parent stx)
(make-dfc:post parent stx))
(define (dfc-add-unbox parent stx)
(dfc-add-car parent stx))
(define (dfc-add-unvector parent stx)
(dfc-add-car parent stx))
(define (dfc-add-unpstruct parent stx)
(dfc-add-car parent stx))
(define (dfc->index dfc)
(match dfc
[#s(dfc:cdr parent n) n]
[_ 0]))
(define (dfc->stx dfc)
(match dfc
[#s(dfc:empty stx) stx]
[#s(dfc:car parent stx) stx]
[#s(dfc:cdr parent n) (dfc->stx parent)]
[#s(dfc:pre parent stx) stx]
[#s(dfc:post parent stx) stx]))
;; dfc-difference : DFC DFC -> nat
;; Returns N s.t. B = (dfc-add-cdr^N A)
(define (dfc-difference a b)
(define (whoops)
(error 'dfc-difference "~e is not an extension of ~e"
(frontier->sexpr b) (frontier->sexpr a)))
(match (list a b)
[(list #s(dfc:cdr pa na) #s(dfc:cdr pb nb))
(unless (equal? pa pb) (whoops))
(- nb na)]
[(list pa #s(dfc:cdr pb nb))
(unless (equal? pa pb) (whoops))
nb]
[_
(unless (equal? a b) (whoops))
0]))
;; dfc-append : DFC DFC -> DFC
;; puts A at the base, B on top
(define (dfc-append a b)
(match b
[#s(dfc:empty stx) a]
[#s(dfc:car pb stx) (make-dfc:car (dfc-append a pb) stx)]
[#s(dfc:cdr #s(dfc:empty _) nb)
;; Special case to merge "consecutive" cdr frames
(match a
[#s(dfc:cdr pa na) (make-dfc:cdr pa (+ na nb))]
[_ (make-dfc:cdr a nb)])]
[#s(dfc:cdr pb nb) (make-dfc:cdr (dfc-append a pb) nb)]
[#s(dfc:pre pb stx) (make-dfc:pre (dfc-append a pb) stx)]
[#s(dfc:post pb stx) (make-dfc:post (dfc-append a pb) stx)]))
;; An Inverted DFC (IDFC) is a DFC inverted for easy comparison.
(define (invert-dfc dfc)
(define (invert dfc acc)
(match dfc
[#s(dfc:empty _) acc]
[#s(dfc:car parent stx)
(invert parent (make-dfc:car acc stx))]
[#s(dfc:cdr parent n)
(invert parent (make-dfc:cdr acc n))]
[#s(dfc:pre parent stx)
(invert parent (make-dfc:pre acc stx))]
[#s(dfc:post parent stx)
(invert parent (make-dfc:post acc stx))]))
(invert dfc (dfc-empty 'dummy)))
;; compare-idfcs : IDFC IDFC -> (one-of '< '= '>)
;; Note A>B means A is "further along" than B. ;; Note A>B means A is "further along" than B.
(define (compare-dfcs a b) ;; Lexicographic generalization of PRE < CAR < CDR < POST
(cond [(and (null? a) (null? b)) (define (compare-idfcs a b)
'=] (match (list a b)
[(and (pair? a) (null? b)) ;; Same constructors
'>] [(list #s(dfc:empty _) #s(dfc:empty _)) '=]
[(and (null? a) (pair? b)) [(list #s(dfc:car pa _) #s(dfc:car pb _))
'<] (compare-idfcs pa pb)]
[(and (pair? a) (pair? b)) [(list #s(dfc:cdr pa na) #s(dfc:cdr pb nb))
(cond [(> (car a) (car b)) '>] (cond [(< na nb) '<]
[(< (car a) (car b)) '<] [(> na nb) '>]
[else (compare-dfcs (cdr a) (cdr b))])])) [(= na nb) (compare-idfcs pa pb)])]
[(list #s(dfc:pre pa _) #s(dfc:pre pb _))
;; FIXME: possibly just '= here, treat all sides as equiv
(compare-idfcs pa pb)]
[(list #s(dfc:post pa _) #s(dfc:post pb _))
;; FIXME: possibly just '= here, treat all sides as equiv
(compare-idfcs pa pb)]
;; Different constructors
[(list #s(dfc:empty _) _) '<]
[(list _ #s(dfc:empty _)) '>]
[(list #s(dfc:pre _ _) _) '<]
[(list _ #s(dfc:pre _ _)) '>]
[(list #s(dfc:car _ _) _) '<]
[(list _ #s(dfc:car _ _)) '>]
[(list #s(dfc:cdr _ _) _) '<]
[(list _ #s(dfc:cdr _ _)) '>]))
(define (idfc>? a b)
(eq? (compare-idfcs a b) '>))
(define (idfc=? a b)
(eq? (compare-idfcs a b) '=))
;; == Codegen internal syntax parameters ;; == Codegen internal syntax parameters
@ -174,12 +313,12 @@
;; == Success and Failure ;; == Success and Failure
;; A Failure is one of ;; A Failure is one of
;; (make-failure stx DFC stx expectation/c) ;; (make-failure stx DFC expectation/c)
;; (make-join-failures Failure Failure) ;; (make-join-failures Failure Failure)
(define ok? list?) (define ok? list?)
(define-struct failure (stx frontier frontier-stx expectation) #:prefab) (define-struct failure (stx frontier expectation) #:prefab)
(define-struct join-failures (f1 f2) #:prefab) (define-struct join-failures (f1 f2) #:prefab)
;; (try expr ...) ;; (try expr ...)
@ -387,3 +526,44 @@ An Expectation is one of
(for ([x v]) (loop (sub1 n) x)))) (for ([x v]) (loop (sub1 n) x))))
(loop n0 v0) (loop n0 v0)
v0) v0)
;; ----
;; debugging
(provide failure->sexpr
one-failure->sexpr
frontier->sexpr
expectation->sexpr)
(define (failure->sexpr f)
(define fs
(let loop ([f f])
(match f
[#s(join-failures f1 f2)
(append (loop f1) (loop f2))]
[_ (list f)])))
(case (length fs)
((1) (one-failure->sexpr f))
(else `(union ,@(map one-failure->sexpr fs)))))
(define (one-failure->sexpr f)
(match f
[#s(failure x frontier expectation)
`(failure ,(frontier->sexpr frontier)
#:term ,(syntax->datum x)
#:expected ,(expectation->sexpr expectation))]))
(define (frontier->sexpr dfc)
(match (invert-dfc dfc)
[#s(dfc:empty _) '()]
[#s(dfc:car p _) (cons 0 (frontier->sexpr p))]
[#s(dfc:cdr p n) (cons n (frontier->sexpr p))]
[#s(dfc:side p _) (cons 'side (frontier->sexpr p))]))
(define (expectation->sexpr expectation)
(match expectation
[#s(expect:thing thing '#t chained)
(make-expect:thing thing #t (failure->sexpr chained))]
[_ expectation]))

9
collects/syntax/private/stxparse/sc.ss
View File

@ -19,6 +19,7 @@
debug-rhs debug-rhs
debug-pattern debug-pattern
debug-parse
syntax-parse syntax-parse
syntax-parser syntax-parser
@ -175,6 +176,14 @@
(let ([p (parse-whole-pattern #'p (new-declenv null) #:context stx)]) (let ([p (parse-whole-pattern #'p (new-declenv null) #:context stx)])
#`(quote #,p))])) #`(quote #,p))]))
(define-syntax-rule (debug-parse x p)
(let/ec escape
(parameterize ((current-failure-handler
(lambda (_ f)
(escape (failure->sexpr f)
(failure->sexpr (simplify-failure f))))))
(syntax-parse x [p 'success]))))
(define-syntax (syntax-parse stx) (define-syntax (syntax-parse stx)
(syntax-case stx () (syntax-case stx ()
[(syntax-parse stx-expr . clauses) [(syntax-parse stx-expr . clauses)

88
collects/tests/stxparse/select.ss Normal file
View File

@ -0,0 +1,88 @@
#lang scheme
(require schemeunit
syntax/parse)
(require (for-syntax syntax/parse))
(provide (all-defined-out))
;; Error selection tests
(error-print-source-location #f)
(define-syntax-rule (terx s p stuff ...)
(terx* s [p] stuff ...))
(define-syntax terx*
(syntax-parser
[(terx s [p ...] (~optional (~seq #:term term) #:defaults ([term #'#f])) rx ...)
#'(test-case (format "line ~s: ~a match ~s for error"
(syntax-line (quote-syntax s))
's '(p ...))
(let ([exn (let/ec escape
(check-exn (lambda (exn)
(escape exn))
(lambda ()
(syntax-parse (quote-syntax s)
[p 'ok] ...))))])
(let ([msg (exn-message exn)]
[stxs (and (exn:fail:syntax? exn)
(exn:fail:syntax-exprs exn))])
(when 'term
(check-equal? (and (pair? stxs) (syntax->datum (car stxs))) 'term))
(erx rx (exn-message exn)) ... #t))
'ok)]))
(define-syntax erx
(syntax-rules (not)
[(erx (not rx) msg)
(check (compose not regexp-match?) rx msg)]
[(erx rx msg)
(check regexp-match? rx msg)]))
;; ----
(terx* (1 2) [x:nat (y:id z:id)]
#:term 1
#rx"expected identifier")
;; --
(define-syntax-class bindings
(pattern ((var:id rhs:expr) ...)))
(terx* ((x 1 2)) [x:id bs:bindings]
#:term 2
#rx"unexpected term")
;; --
(terx ((a 1) (a 2))
((~or (~once ((~datum a) x) #:name "A clause")
(~optional ((~datum b) y) #:name "B clause"))
...)
;; #:term (a 2)
#rx"too many occurrences of A clause")
;; --
(define-syntax-class A
(pattern ((~datum a) x)))
(define-syntax-class B
(pattern ((~datum b) y)))
(terx ((a 1) (a 2))
((~or (~once a:A #:name "A clause")
(~optional b:B #:name "B clause"))
...)
#rx"too many occurrences of A clause")
(terx ((a 1 2) _)
((~or (~once a:A #:name "A clause")
(~optional b:B #:name "B clause"))
...)
#rx"unexpected term")
(terx ((b 1 2) _)
((~or (~once a:A #:name "A clause")
(~optional b:B #:name "B clause"))
...)
#rx"unexpected term")

13
collects/tests/stxparse/stxclass.ss
View File

@ -1,7 +1,6 @@
#lang scheme/base #lang scheme/base
(require (planet schematics/schemeunit:2:9/test) (require schemeunit
(planet schematics/schemeunit:2:9/graphical-ui)
syntax/parse syntax/parse
(for-syntax scheme/base syntax/parse)) (for-syntax scheme/base syntax/parse))
@ -95,15 +94,15 @@
;; Tests ;; Tests
(define tests (begin ;; define tests
(test-suite "Syntax grammars" (begin ;; test-suite "Syntax grammars"
(test-suite "sc attrs" (begin ;; test-suite "sc attrs"
(test-sc-attrs one ([a 0])) (test-sc-attrs one ([a 0]))
(test-sc-attrs two ([a 0] [b 0])) (test-sc-attrs two ([a 0] [b 0]))
(test-sc-attrs three ([a 0] [b 0] [c 0])) (test-sc-attrs three ([a 0] [b 0] [c 0]))
(test-sc-attrs two-or-three/tag ([a 0] [a.a 0] [a.b 0])) (test-sc-attrs two-or-three/tag ([a 0] [a.a 0] [a.b 0]))
(test-sc-attrs id-num ([x 0] [n 0]))) (test-sc-attrs id-num ([x 0] [n 0])))
(test-suite "parse-sc" (begin ;; test-suite "parse-sc"
(test-parse-sc one #'1 ([a 0 1])) (test-parse-sc one #'1 ([a 0 1]))
(test-parse-sc two #'(1 2) ([a 0 1] [b 0 2])) (test-parse-sc two #'(1 2) ([a 0 1] [b 0 2]))
(test-parse-sc three #'(1 2 3) ([a 0 1] [b 0 2] [c 0 3])) (test-parse-sc three #'(1 2 3) ([a 0 1] [b 0 2] [c 0 3]))
@ -113,7 +112,7 @@
([x 0 this] [n 0 12])) ([x 0 this] [n 0 12]))
(test-parse-sc id-string #'(that "here") (test-parse-sc id-string #'(that "here")
([x 0 that] [label 0 "here"]))) ([x 0 that] [label 0 "here"])))
(test-suite "with-patterns" (begin ;; test-suite "with-patterns"
(test-patterns (t:two-to-four/untagged ...) #'((1 2 3) (4 5) (6 7 8)) (test-patterns (t:two-to-four/untagged ...) #'((1 2 3) (4 5) (6 7 8))
(check-equal? (syntax->datum #'(t.a ...)) '(1 4 6))) (check-equal? (syntax->datum #'(t.a ...)) '(1 4 6)))
(test-patterns (t:two-to-four/untagged ...) #'((1 2 3) (4 5) (6 7 8)) (test-patterns (t:two-to-four/untagged ...) #'((1 2 3) (4 5) (6 7 8))

8
collects/tests/stxparse/test.ss
View File

@ -54,7 +54,7 @@
(syntax-line (quote-syntax s)) (syntax-line (quote-syntax s))
's '(p ...)) 's '(p ...))
(check-exn (lambda (exn) (check-exn (lambda (exn)
(erx rx (exn-message exn)) ...) (erx rx (exn-message exn)) ... #t)
(lambda () (lambda ()
(syntax-parse (quote-syntax s) (syntax-parse (quote-syntax s)
[p 'ok] ...))) [p 'ok] ...)))
@ -63,7 +63,7 @@
(define-syntax erx (define-syntax erx
(syntax-rules (not) (syntax-rules (not)
[(erx (not rx) msg) [(erx (not rx) msg)
(check-false (regexp-match? rx msg))] (check (compose not regexp-match?) rx msg)]
[(erx rx msg) [(erx rx msg)
(check regexp-match? rx msg)])) (check regexp-match? rx msg)]))
@ -220,8 +220,8 @@
;; -- A patterns ;; -- A patterns
;; cut patterns ;; cut patterns
(terx* (1 2 3) [(1 ~! 4) (1 2 3)] (terx* (1 2 3) [(1 ~! 4) (1 _:nat 3)]
"4" (not "2")) "4" (not "exact nonnegative integer"))
;; cut-in-and ;; cut-in-and
(terx* 1 [(~and a:nat ~! 2) b:nat] (terx* 1 [(~and a:nat ~! 2) b:nat]