diff --git a/racket/collects/syntax/parse/private/parse.rkt b/racket/collects/syntax/parse/private/parse.rkt index 12772962df..a77e9bbde9 100644 --- a/racket/collects/syntax/parse/private/parse.rkt +++ b/racket/collects/syntax/parse/private/parse.rkt @@ -461,11 +461,21 @@ Conventions: [tx (cdr datum)] [tpr (ps-add-cdr pr)]) (parse:matrix ((hx hcx hpr es) (tx tcx tpr es) . ins) inner)) - (let ([es* (if (and 'proper? (null? datum)) (es-add-proper-pair es) es)]) + (let ([es* (if (and 'proper? (null? datum)) + (es-add-proper-pair (first-desc:matrix inner) es) + es)]) (fail (failure pr es*)))))] [(parse:pk (in1 . ins) #s(pk/and inner)) #'(parse:matrix (in1 in1 . ins) inner)])) +(define-syntax (first-desc:matrix stx) + (syntax-case stx () + [(fdm (#s(pk (pat1 . pats) k))) + #'(first-desc:S pat1)] + [(fdm (pk ...)) + ;; FIXME + #'#f])) + ;; ---- ;; (parse:S x cx S-pattern pr es k) : expr[Ans] @@ -582,7 +592,7 @@ Conventions: [tpr (ps-add-cdr pr)]) (parse:S hx hcx head hpr es (parse:S tx cx tail tpr es k))) - (let ([es* (if (and 'proper? (null? datum)) (es-add-proper-pair es) es)]) + (let ([es* (if (and 'proper? (null? datum)) (es-add-proper-pair (first-desc:S head) es) es)]) (fail (failure pr es*)))))] [#s(pat:vector _attrs subpattern) #`(let ([datum (if (syntax? x) (syntax-e x) x)]) @@ -639,6 +649,33 @@ Conventions: (let ([es* (es-add-thing pr 'description #t role es)]) (fail (failure pr es*))))))])])) +;; (first-desc:S S-pattern) : expr[FirstDesc] +(define-syntax (first-desc:S stx) + (syntax-case stx () + [(fds p) + (syntax-case #'p () + [#s(pat:any _as) + #''(any)] + [#s(pat:var _as name #f _ () _ _ _) + #''(any)] + [#s(pat:var _ ...) + #'#f] ;; FIXME: need access to (constant) description as field + [#s(pat:datum _as d) + #''(datum d)] + [#s(pat:literal _as id _ip _lp) + #''(literal id)] + [#s(pat:describe _as _p description _t? _role) + #'description] ;; FIXME??? only constants? + [#s(pat:delimit _a pattern) + #'(first-desc:S pattern)] + [#s(pat:commit _a pattern) + #'(first-desc:S pattern)] + [#s(pat:post _a pattern) + #'(first-desc:S pattern)] + [#s(pat:integrated _as _name _pred description _role) + #''description] + [_ #'#f])])) + ;; (disjunct ???-pattern success (pre:expr ...) (id:id ...)) : expr[Ans] (define-syntax (disjunct stx) (syntax-case stx () diff --git a/racket/collects/syntax/parse/private/runtime-progress.rkt b/racket/collects/syntax/parse/private/runtime-progress.rkt index edbe845a1e..6b141063f9 100644 --- a/racket/collects/syntax/parse/private/runtime-progress.rkt +++ b/racket/collects/syntax/parse/private/runtime-progress.rkt @@ -145,7 +145,7 @@ An ExpectStack (during parsing) is one of * (make-expect:message string ExpectStack) * (make-expect:atom atom ExpectStack) * (make-expect:literal identifier ExpectStack) - * (make-expect:proper-pair ExpectStack) + * (make-expect:proper-pair FirstDesc ExpectStack) The *-marked variants can only occur at the top of the stack. @@ -159,7 +159,7 @@ An Expect is one of * (expect:message string _) * (expect:atom atom _) * (expect:literal identifier _) - * (expect:proper-pair _) + * (expect:proper-pair string/#f _) - (expect:disj (non-empty-listof Expect) _) That is, next link always ignored (replace with #f for sake of equal? cmp) @@ -172,7 +172,7 @@ Goal during reporting is ease of manipulation. (struct expect:atom (atom next) #:prefab) (struct expect:literal (literal next) #:prefab) (struct expect:disj (expects next) #:prefab) -(struct expect:proper-pair (next) #:prefab) +(struct expect:proper-pair (first-desc next) #:prefab) (define (expect? x) (or (expect:thing? x) @@ -198,5 +198,14 @@ Goal during reporting is ease of manipulation. (define (es-add-literal literal next) (expect:literal literal next)) -(define (es-add-proper-pair next) - (expect:proper-pair next)) +(define (es-add-proper-pair first-desc next) + (expect:proper-pair first-desc next)) + +#| +A FirstDesc is one of + - #f -- unknown, multiple possible, etc + - string -- description + - (list 'any) + - (list 'literal symbol) + - (list 'datum datum) +|# diff --git a/racket/collects/syntax/parse/private/runtime-report.rkt b/racket/collects/syntax/parse/private/runtime-report.rkt index 50a6243902..515cc0eb79 100644 --- a/racket/collects/syntax/parse/private/runtime-report.rkt +++ b/racket/collects/syntax/parse/private/runtime-report.rkt @@ -122,8 +122,15 @@ complicated. (format "expected the identifier `~s'" (syntax-e literal))] [(expect:message message _) (format "~a" message)] - [(expect:proper-pair _) - "expected more terms"])) + [(expect:proper-pair '#f _) + "expected more terms"] + [(expect:proper-pair first-desc _) + (format "expected more terms starting with ~a" + (match first-desc + [(? string?) first-desc] + [(list 'any) "any term"] + [(list 'literal id) (format "the literal symbol `~s'" id)] + [(list 'datum d) (format "the literal ~s" d)]))])) (define (context-prose-for-expect e) (match e @@ -208,8 +215,8 @@ complicated. (cons (expect:atom atom #f) (loop rest-es))] [(expect:literal literal rest-es) (cons (expect:literal literal #f) (loop rest-es))] - [(expect:proper-pair rest-es) - (cons (expect:proper-pair #f) (loop rest-es))])))) + [(expect:proper-pair first-desc rest-es) + (cons (expect:proper-pair first-desc #f) (loop rest-es))])))) #| Simplification dilemma