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

syntax/parse: pinpoint stx from progress, not expectstack

Browse Source
This commit is contained in:
Ryan Culpepper 2010-11-03 14:45:25 -06:00
parent 68e7cda162
commit 95d690d550
2 changed files with 11 additions and 8 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

5
collects/syntax/parse/private/runtime-progress.rkt
View File

@ -12,9 +12,7 @@
ps-add-unpstruct
ps-add-opaque
#|
ps->stx+index
|#
ps-context-syntax
ps-difference
@ -86,7 +84,8 @@ Interpretation: Inner PS structures are applied first.
(match ps
[(cons (? syntax? stx) _) stx]
[(cons 'car parent)
(let ([d (syntax-e (interp parent))])
(let* ([d (interp parent)]
[d (if (syntax? d) (syntax-e d) d)])
(cond [(pair? d) (car d)]
[(vector? d) (vector->list d)]
[(box? d) (unbox d)]

14
collects/syntax/parse/private/runtime-report.rkt
View File

@ -51,16 +51,20 @@ complicated.
[ess (map normalize-expectstack ess)]
[ess (remove-duplicates ess)]
[ess (simplify-common-expectstacks ess)])
(map report/expectstack ess)))
(let-values ([(stx index) (ps->stx+index (failure-progress (car fs)))])
(for/list ([es (in-list ess)])
(report/expectstack es stx index)))))
;; report/expectstack : ExpectStack -> Report
(define (report/expectstack es)
;; report/expectstack : ExpectStack syntax nat -> Report
(define (report/expectstack es stx index)
(let ([top-frame (and (pair? es) (car es))])
(cond [(not top-frame)
(report "bad syntax" #f)]
[else
(let ([frame-expect (and top-frame (car top-frame))]
[frame-stx (and top-frame (cdr top-frame))])
[frame-stx
(let-values ([(x cx) (stx-list-drop/cx stx stx index)])
(datum->syntax cx x cx))])
(cond [(equal? frame-expect (expect:atom '()))
(syntax-case frame-stx ()
[(one . more)
@ -72,7 +76,7 @@ complicated.
[else
(report/expects (list frame-expect) frame-stx)]))])))
;; report/expects : (listof Expect) -> Report
;; report/expects : (listof Expect) syntax -> Report
(define (report/expects expects frame-stx)
(report (join-sep (for/list ([expect expects])
(prose-for-expect expect))