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

syntax/parse: cut-prompt is inherited, not threaded

Browse Source
This commit is contained in:
Ryan Culpepper 2012-02-29 04:16:07 -07:00
parent 14089e0ac6
commit a0065b9efa
5 changed files with 38 additions and 45 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
collects/syntax/parse/debug.rkt
View File

@ -40,7 +40,7 @@
[(depth ...) (map attr-depth attrs)])
#'(let ([fh (lambda (fs) fs)])
(app-argu parser x x (ps-empty x x) null fh fh
(lambda (fh cp . attr-values)
(lambda (fh . attr-values)
(map vector '(name ...) '(depth ...) attr-values))
argu)))))]))

2
collects/syntax/parse/experimental/reflect.rkt
View File

@ -74,7 +74,7 @@
(make-keyword-procedure
(lambda (kws2 kwargs2 x cx pr es fh cp success . rest2)
(let-values ([(kws kwargs) (merge2 kws1 kws2 kwargs1 kwargs2)])
(keyword-apply kws kwargs x cx pr es fh cp success
(keyword-apply parser kws kwargs x cx pr es fh cp success
(append rest1 rest2)))))]
[ctor
(cond [(reified-syntax-class? r)

8
collects/syntax/parse/experimental/splicing.rkt
View File

@ -34,7 +34,7 @@
description)
(define parser
(let ([permute (mk-permute '(a.name ...))])
(lambda (x cx pr es fh cp success param ...)
(lambda (x cx pr es fh _cp success param ...)
(let ([stx (datum->syntax cx x cx)])
(let ([result
(let/ec escape
@ -45,7 +45,7 @@
(case (car result)
((ok)
(apply success
((mk-check-result pr 'name (length '(a.name ...)) permute x cx fh cp)
((mk-check-result pr 'name (length '(a.name ...)) permute x cx fh)
(cdr result))))
((error)
(let ([es
@ -76,7 +76,7 @@
(for/list ([index (in-vector indexes)])
(list-ref result index)))))))
(define (mk-check-result pr name attr-count permute x cx fh cp)
(define (mk-check-result pr name attr-count permute x cx fh)
(lambda (result)
(unless (list? result)
(error name "parser returned non-list"))
@ -91,5 +91,5 @@
(error name "expected exact nonnegative integer for first element of result list, got ~e"
skip))
(let-values ([(rest-x rest-cx) (stx-list-drop/cx x cx skip)])
(list* fh cp rest-x rest-cx (ps-add-cdr pr skip)
(list* fh rest-x rest-cx (ps-add-cdr pr skip)
(permute (cdr result))))))))

63
collects/syntax/parse/private/parse.rkt
View File

@ -75,7 +75,7 @@
(integrate (quote-syntax predicate) 'description)))
(define (parser x cx pr es fh0 cp0 success)
(if (predicate x)
(success fh0 cp0)
(success fh0)
(let ([es (cons (expect:thing 'description #t) es)])
(fh0 (failure pr es)))))))]))
@ -179,6 +179,8 @@ x is term to parse, usually syntax but can be pair, empty in cdr patterns
cx is most recent syntax object:
if x must be coerced to syntax, use cx as lexctx and src
success-proc : fail-handler <???> attr-value ... -> Ans
Usually sub-patterns processed in tail position,
but *can* do non-tail calls for:
- ~commit
@ -329,7 +331,7 @@ Conventions:
(reorder-iattrs (wash-sattrs #'relsattrs)
(wash-iattrs #'iattrs))])
(with-syntax ([(#s(attr name _ _) ...) reliattrs])
#'(success fail-handler cut-prompt also ... (attribute name) ...)))]))
#'(success fail-handler also ... (attribute name) ...)))]))
;; ----
@ -426,11 +428,10 @@ Conventions:
(if (not (syntax-e #'commit?))
;; The normal protocol
#'(app-argu parser x cx pr es fail-handler cut-prompt
(lambda (fh cp av ...)
(lambda (fh av ...)
(let-attributes (name-attr ...)
(let-attributes* ((nested-a ...) (av ...))
(with ([fail-handler fh]
[cut-prompt cp])
(with ([fail-handler fh])
k))))
argu)
;; The commit protocol
@ -439,7 +440,7 @@ Conventions:
(with ([fail-handler (lambda (fs) (values fs (let ([av #f]) av) ...))])
(with ([cut-prompt fail-handler])
(app-argu parser x cx pr es fail-handler cut-prompt
(lambda (fh cp av ...) (values #f av ...))
(lambda (fh av ...) (values #f av ...))
argu)))])
(if fs
(fail fs)
@ -454,11 +455,10 @@ Conventions:
(with-syntax ([arity (arguments->arity (syntax->datum #'argu))])
#'(let ([parser (reflect-parser obj 'arity 'attr-decls #f)])
(app-argu parser x cx pr es fail-handler cut-prompt
(lambda (fh cp . result)
(lambda (fh . result)
(let-attributes (name-attr ...)
(let/unpack ((nested-a ...) result)
(with ([fail-handler fh]
[cut-prompt cp])
(with ([fail-handler fh])
k))))
argu))))]
[#s(pat:datum attrs datum)
@ -484,10 +484,9 @@ Conventions:
[#s(pat:or (a ...) (subpattern ...))
(with-syntax ([(#s(attr id _ _) ...) #'(a ...)])
#`(let ([success
(lambda (fh cp id ...)
(lambda (fh id ...)
(let-attributes ([a id] ...)
(with ([fail-handler fh]
[cut-prompt cp])
(with ([fail-handler fh])
k)))])
(try (parse:S x cx subpattern pr es
(disjunct subpattern success () (id ...)))
@ -583,7 +582,7 @@ Conventions:
#`(let ([alt-sub-id (attribute sub-id)] ...)
(let ([id #f] ...)
(let ([sub-id alt-sub-id] ...)
(success fail-handler cut-prompt pre ... id ...))))))]))
(success fail-handler pre ... id ...))))))]))
;; (disjunct/sides clauses success (pre:expr ...) (id:id ...)) : expr[Ans]
(define-syntax (disjunct/sides stx)
@ -594,7 +593,7 @@ Conventions:
#`(let ([alt-sub-id (attribute sub-id)] ...)
(let ([id #f] ...)
(let ([sub-id alt-sub-id] ...)
(success fail-handler cut-prompt pre ... id ...))))))]))
(success fail-handler pre ... id ...))))))]))
;; (parse:A x cx A-pattern pr es k) : expr[Ans]
;; In k: attrs(A-pattern) are bound.
@ -680,11 +679,10 @@ Conventions:
(if (not (syntax-e #'commit?))
;; The normal protocol
#`(app-argu parser x cx pr es fail-handler cut-prompt
(lambda (fh cp rest-x rest-cx rest-pr av ...)
(lambda (fh rest-x rest-cx rest-pr av ...)
(let-attributes (name-attr ...)
(let-attributes* ((nested-a ...) (av ...))
(with ([fail-handler fh]
[cut-prompt cp])
(with ([fail-handler fh])
k))))
argu)
;; The commit protocol
@ -693,7 +691,7 @@ Conventions:
(with ([fail-handler (lambda (fs) (values fs #f #f #f (let ([av #f]) av) ...))])
(with ([cut-prompt fail-handler])
(app-argu parser x cx pr es fail-handler cut-prompt
(lambda (fh cp rest-x rest-cx rest-pr av ...)
(lambda (fh rest-x rest-cx rest-pr av ...)
(values #f rest-x rest-cx rest-pr av ...))
argu)))])
(if fs
@ -710,12 +708,11 @@ Conventions:
(with-syntax ([arity (arguments->arity (syntax->datum #'argu))])
#'(let ([parser (reflect-parser obj 'arity 'attr-decls #t)])
(app-argu parser x cx pr es fail-handler cut-prompt
(lambda (fh cp rest-x rest-cx rest-pr . result)
(lambda (fh rest-x rest-cx rest-pr . result)
(let-attributes (name-attr ...)
(let/unpack ((nested-a ...) result)
(with ([fail-handler fh]
[cut-prompt cp])
k))))
(with ([fail-handler fh])
k))))
argu))))]
[#s(hpat:and (a ...) head single)
#`(let ([cx0 cx])
@ -725,10 +722,9 @@ Conventions:
[#s(hpat:or (a ...) (subpattern ...))
(with-syntax ([(#s(attr id _ _) ...) #'(a ...)])
#`(let ([success
(lambda (fh cp rest-x rest-cx rest-pr id ...)
(lambda (fh rest-x rest-cx rest-pr id ...)
(let-attributes ([a id] ...)
(with ([fail-handler fh]
[cut-prompt cp])
(with ([fail-handler fh])
k)))])
(try (parse:H x cx rest-x rest-cx rest-pr subpattern pr es
(disjunct subpattern success
@ -743,14 +739,12 @@ Conventions:
[#s(hpat:optional (a ...) pattern defaults)
(with-syntax ([(#s(attr id _ _) ...) #'(a ...)])
#`(let ([success
(lambda (fh cp rest-x rest-cx rest-pr id ...)
(lambda (fh rest-x rest-cx rest-pr id ...)
(let-attributes ([a id] ...)
(with ([fail-handler fh]
[cut-prompt cp])
(with ([fail-handler fh])
k)))])
(try (parse:H x cx rest-x rest-cx rest-pr pattern pr es
(success fail-handler cut-prompt
rest-x rest-cx rest-pr (attribute id) ...))
(success fail-handler rest-x rest-cx rest-pr (attribute id) ...))
(let ([rest-x x]
[rest-cx cx]
[rest-pr pr])
@ -858,12 +852,11 @@ Conventions:
(equal? (syntax->datum #'tail) '#s(pat:datum () ()))])
(define/with-syntax alt-map #'((id . alt-id) ...))
(define/with-syntax loop-k
#'(dots-loop dx* dcx* loop-pr* fail-handler cut-prompt rel-rep ... alt-id ...))
#'(dots-loop dx* dcx* loop-pr* fail-handler rel-rep ... alt-id ...))
#`(let ()
;; dots-loop : stx progress rel-rep ... alt-id ... -> Ans
(define (dots-loop dx dcx loop-pr fh cp rel-rep ... alt-id ...)
(with ([fail-handler fh]
[cut-prompt cp])
(define (dots-loop dx dcx loop-pr fh rel-rep ... alt-id ...)
(with ([fail-handler fh])
(try-or-pair/null-check tail-pattern-is-null? dx dcx loop-pr es
(try (parse:EH dx dcx loop-pr head-repc dx* dcx* loop-pr* alt-map head-rep
head es loop-k)
@ -877,7 +870,7 @@ Conventions:
(parse:S dx dcx tail loop-pr es k))]))))
(let ([rel-rep 0] ...
[alt-id (rep:initial-value attr-repc)] ...)
(dots-loop x cx pr fail-handler cut-prompt rel-rep ... alt-id ...)))))]))
(dots-loop x cx pr fail-handler rel-rep ... alt-id ...)))))]))
;; (try-or-pair/null-check bool x cx es pr pair-alt maybe-null-alt)
(define-syntax try-or-pair/null-check

8
collects/syntax/parse/private/runtime-reflect.rkt
View File

@ -69,10 +69,10 @@ A Reified is
(lambda (kws kwargs x cx pr es fh cp success . rest)
(keyword-apply parser kws kwargs x cx pr es fh cp
(if splicing?
(lambda (fh cp x cx . result)
(apply success fh cp x cx (take-indexes result indexes)))
(lambda (fh cp . result)
(apply success fh cp (take-indexes result indexes))))
(lambda (fh x cx pr . result)
(apply success fh x cx pr (take-indexes result indexes)))
(lambda (fh . result)
(apply success fh (take-indexes result indexes))))
rest))))))
(define (wrong-depth who a b)