diff --git a/racket/collects/syntax/parse/private/rep-patterns.rkt b/racket/collects/syntax/parse/private/rep-patterns.rkt index 63dde46ffd..dbe68503e8 100644 --- a/racket/collects/syntax/parse/private/rep-patterns.rkt +++ b/racket/collects/syntax/parse/private/rep-patterns.rkt @@ -42,7 +42,7 @@ A ListPattern is a subtype of SinglePattern; one of (pat:action ActionPattern ListPattern) (pat:head HeadPattern ListPattern) (pat:pair #t SinglePattern ListPattern) - (pat:dots EllipsisHeadPattern SinglePattern) + (pat:dots EllipsisHeadPattern ListPattern) |# (define-struct pat:any () #:prefab) @@ -442,6 +442,47 @@ A RepConstraint is one of (define afp (pattern-AF p)) (and af (AF AbsNullable +(define/memo (lpat-nullable lp) + (match lp + [(pat:datum '()) 'yes] + [(pat:action ap lp) (lpat-nullable lp)] + [(pat:head hp lp) (3and (hpat-nullable hp) (lpat-nullable lp))] + [(pat:pair '#t sp lp) 'no] + [(pat:dots ehp lp) (lpat-nullable lp)])) + +;; hpat-nullable : HeadPattern -> AbsNullable +(define/memo (hpat-nullable hp) + (match hp + [(hpat:seq lp) (lpat-nullable lp)] + [(hpat:action ap hp) (hpat-nullable hp)] + [(hpat:and hp sp) (hpat-nullable hp)] + [(hpat:or _attrs hps _attrss) (foldl 3or 'no (map hpat-nullable hps))] + [(hpat:describe hp _ _ _) (hpat-nullable hp)] + [(hpat:delimit hp) (hpat-nullable hp)] + [(hpat:commit hp) (hpat-nullable hp)] + [(hpat:ord hp _ _) (hpat-nullable hp)] + [(hpat:post hp) (hpat-nullable hp)] + [_ 'unknown])) + +;; ---- + ;; create-post-pattern : *Pattern -> *Pattern (define (create-post-pattern p) (cond [(pattern-cannot-fail? p) diff --git a/racket/collects/syntax/parse/private/rep.rkt b/racket/collects/syntax/parse/private/rep.rkt index 819cc0ef6e..c39178b290 100644 --- a/racket/collects/syntax/parse/private/rep.rkt +++ b/racket/collects/syntax/parse/private/rep.rkt @@ -21,6 +21,8 @@ "kws.rkt" "pattern-expander-prop.rkt") +(define-logger syntax-parse) + ;; Error reporting ;; All entry points should have explicit, mandatory #:context arg ;; (mandatory from outside, at least) @@ -654,6 +656,10 @@ (list (parse*-ehpat/bounds stx decls))] [_ (let ([head (parse-head-pattern stx decls)]) + ;; FIXME: if 'no, can omit null-eh-match check in parse.rkt + (when (eq? (hpat-nullable head) 'yes) + (when #f (wrong-syntax stx "nullable ellipsis-head pattern")) + (when #t (log-syntax-parse-error "nullable ellipsis-head pattern: ~e" stx))) (list (list (create-ehpat head #f) stx)))])) (define (replace-eh-alternative-attrs alt sattrs)