From d6a3a229897faac941cd58dd114542a5bffd6447 Mon Sep 17 00:00:00 2001 From: Ryan Culpepper Date: Sun, 31 Jul 2016 18:13:09 -0400 Subject: [PATCH] syntax/parse: propagate description-if-constant to annotated pvars fixes #1392 --- pkgs/racket-test/tests/stxparse/select.rkt | 10 ++++++ .../collects/syntax/parse/private/parse.rkt | 6 ++-- .../syntax/parse/private/rep-data.rkt | 33 +++++++++---------- .../syntax/parse/private/rep-patterns.rkt | 14 ++++---- racket/collects/syntax/parse/private/rep.rkt | 27 ++++++++------- .../syntax/parse/private/residual-ct.rkt | 4 +-- 6 files changed, 52 insertions(+), 42 deletions(-) diff --git a/pkgs/racket-test/tests/stxparse/select.rkt b/pkgs/racket-test/tests/stxparse/select.rkt index 46770a7778..85031c7f93 100644 --- a/pkgs/racket-test/tests/stxparse/select.rkt +++ b/pkgs/racket-test/tests/stxparse/select.rkt @@ -157,6 +157,16 @@ (a (~describe "thing" b)) #rx"expected more terms starting with thing$") +(let () + (define-syntax-class B1 #:description "B1" (pattern _:id)) + (define-syntax-class B2 (pattern _:id)) + (terx (1) + (a b:B1) + #rx"expected more terms starting with B1") + (terx (1) + (a b:B2) + #rx"expected more terms starting with B2")) + ;; Post: (terx "hello" diff --git a/racket/collects/syntax/parse/private/parse.rkt b/racket/collects/syntax/parse/private/parse.rkt index b473116898..de44de3c79 100644 --- a/racket/collects/syntax/parse/private/parse.rkt +++ b/racket/collects/syntax/parse/private/parse.rkt @@ -521,7 +521,7 @@ Conventions: [#s(pat:svar name) #'(let-attributes ([#s(attr name 0 #t) (datum->syntax cx x cx)]) k)] - [#s(pat:var/p name parser argu (nested-a ...) attr-count commit? role) + [#s(pat:var/p name parser argu (nested-a ...) attr-count commit? role _desc) (with-syntax ([(av ...) (generate-n-temporaries (syntax-e #'attr-count))] [(name-attr ...) (if (identifier? #'name) @@ -691,7 +691,7 @@ Conventions: [#s(pat:svar name) #''(any)] [#s(pat:var/p _ ...) - #'#f] ;; FIXME: need access to (constant) description as field + #`(quote #,(pat:var/p-desc (syntax-e #'p)))] [#s(pat:datum d) #''(datum d)] [#s(pat:literal id _ip _lp) @@ -787,7 +787,7 @@ Conventions: (parse:H x cx rest-x rest-cx rest-pr pattern pr* es* (let ([rest-pr (if 'transparent? rest-pr (ps-pop-opaque rest-pr))]) k)))] - [#s(hpat:var/p name parser argu (nested-a ...) attr-count commit? role) + [#s(hpat:var/p name parser argu (nested-a ...) attr-count commit? role _desc) (with-syntax ([(av ...) (generate-n-temporaries (syntax-e #'attr-count))] [(name-attr ...) (if (identifier? #'name) diff --git a/racket/collects/syntax/parse/private/rep-data.rkt b/racket/collects/syntax/parse/private/rep-data.rkt index 711ba5eca4..aa7b068ba3 100644 --- a/racket/collects/syntax/parse/private/rep-data.rkt +++ b/racket/collects/syntax/parse/private/rep-data.rkt @@ -35,11 +35,13 @@ delimit-cut? ;; Bool ) #:prefab) -#| -A Variant is - (make-variant stx (listof SAttr) Pattern (listof stx)) -|# -(define-struct variant (ostx attrs pattern definitions) #:prefab) +;; A Variant is (variant Stx SAttrs Pattern Stxs) +(define-struct variant + (ostx ;; Stx + attrs ;; (Listof SAttr) + pattern ;; Pattern + definitions ;; (Listof Stx) + ) #:prefab) ;; make-dummy-stxclass : identifier -> SC ;; Dummy stxclass for calculating attributes of recursive stxclasses. @@ -54,12 +56,12 @@ DeclEnv = (listof ConventionRule)) DeclEntry = - (den:lit id id ct-phase ct-phase) - (den:datum-lit id symbol) - (den:class id id Arguments) - (den:magic-class id id Arguments stx) - (den:parser id (listof SAttr) bool bool bool) - (den:delayed id id) +- (den:lit Id Id Stx Stx) +- (den:datum-lit Id Symbol) +- (den:class Id Id Arguments) +- (den:magic-class Id Id Arguments Stx) +- (den:parser Id (Listof SAttr) Bool Bool Bool String/#f) +- (den:delayed Id Id) Arguments is defined in rep-patterns.rkt @@ -88,7 +90,7 @@ expressions are duplicated, and may be evaluated in different scopes. (define-struct den:class (name class argu)) (define-struct den:magic-class (name class argu role)) -(define-struct den:parser (parser attrs splicing? commit? delimit-cut?)) +(define-struct den:parser (parser attrs splicing? commit? delimit-cut? desc)) ;; and from residual.rkt: ;; (define-struct den:lit (internal external input-phase lit-phase)) ;; (define-struct den:datum-lit (internal external)) @@ -133,7 +135,7 @@ expressions are duplicated, and may be evaluated in different scopes. stxclass-name) (wrong-syntax (if blame-declare? name id) "identifier previously declared"))] - [(den:parser _p _a _sp _c _dc?) + [(den:parser _p _a _sp _c _dc? _desc) (wrong-syntax id "(internal error) late unbound check")] ['#f (void)]))) @@ -183,10 +185,6 @@ expressions are duplicated, and may be evaluated in different scopes. (define DeclEntry/c (or/c den:lit? den:datum-lit? den:class? den:magic-class? den:parser? den:delayed?)) -;; ct-phase = syntax, expr that computes absolute phase -;; usually = #'(syntax-local-phase-level) -(define ct-phase/c syntax?) - (provide (struct-out den:class) (struct-out den:magic-class) (struct-out den:parser) @@ -198,7 +196,6 @@ expressions are duplicated, and may be evaluated in different scopes. (provide/contract [DeclEnv/c contract?] [DeclEntry/c contract?] - [ct-phase/c contract?] [make-dummy-stxclass (-> identifier? stxclass?)] [stxclass-lookup-config (parameter/c (symbols 'no 'try 'yes))] diff --git a/racket/collects/syntax/parse/private/rep-patterns.rkt b/racket/collects/syntax/parse/private/rep-patterns.rkt index b912f340d5..57cff901ec 100644 --- a/racket/collects/syntax/parse/private/rep-patterns.rkt +++ b/racket/collects/syntax/parse/private/rep-patterns.rkt @@ -13,8 +13,8 @@ Uses Arguments from kws.rkt A SinglePattern is one of (pat:any) (pat:svar id) -- "simple" var, no stxclass - (pat:var/p id id Arguments (Listof IAttr) nat/#f bool stx) -- var with parser - (pat:literal identifier ct-phase ct-phase) + (pat:var/p Id Id Arguments (Listof IAttr) Nat/#f Bool Stx String/#f) -- var with parser + (pat:literal identifier Stx Stx) (pat:datum datum) (pat:action ActionPattern SinglePattern) (pat:head HeadPattern SinglePattern) @@ -44,7 +44,7 @@ A ListPattern is a subtype of SinglePattern; one of (define-struct pat:any () #:prefab) (define-struct pat:svar (name) #:prefab) -(define-struct pat:var/p (name parser argu nested-attrs attr-count commit? role) #:prefab) +(define-struct pat:var/p (name parser argu nested-attrs attr-count commit? role desc) #:prefab) (define-struct pat:literal (id input-phase lit-phase) #:prefab) (define-struct pat:datum (datum) #:prefab) (define-struct pat:action (action inner) #:prefab) @@ -91,7 +91,7 @@ A SideClause is just an ActionPattern #| A HeadPattern is one of - (hpat:var/p id id Arguments (listof IAttr) nat/#f bool stx) + (hpat:var/p Id Id Arguments (Listof IAttr) Nat/#f Bool Stx String/#f) (hpat:seq ListPattern) (hpat:action ActionPattern HeadPattern) (hpat:and HeadPattern SinglePattern) @@ -106,7 +106,7 @@ A HeadPattern is one of (hpat:peek-not HeadPattern) |# -(define-struct hpat:var/p (name parser argu nested-attrs attr-count commit? role) #:prefab) +(define-struct hpat:var/p (name parser argu nested-attrs attr-count commit? role desc) #:prefab) (define-struct hpat:seq (inner) #:prefab) (define-struct hpat:action (action inner) #:prefab) (define-struct hpat:and (head single) #:prefab) @@ -214,7 +214,7 @@ A RepConstraint is one of null] [(pat:svar name) (list (attr name 0 #t))] - [(pat:var/p name _ _ nested-attrs _ _ _) + [(pat:var/p name _ _ nested-attrs _ _ _ _) (if name (cons (attr name 0 #t) nested-attrs) nested-attrs)] [(pat:reflect _ _ _ name nested-attrs) (if name (cons (attr name 0 #t) nested-attrs) nested-attrs)] @@ -274,7 +274,7 @@ A RepConstraint is one of (pattern-attrs sp)] ;; -- H patterns - [(hpat:var/p name _ _ nested-attrs _ _ _) + [(hpat:var/p name _ _ nested-attrs _ _ _ _) (if name (cons (attr name 0 #t) nested-attrs) nested-attrs)] [(hpat:reflect _ _ _ name nested-attrs) (if name (cons (attr name 0 #t) nested-attrs) nested-attrs)] diff --git a/racket/collects/syntax/parse/private/rep.rkt b/racket/collects/syntax/parse/private/rep.rkt index a1b5fb8038..f376e34d18 100644 --- a/racket/collects/syntax/parse/private/rep.rkt +++ b/racket/collects/syntax/parse/private/rep.rkt @@ -283,7 +283,8 @@ (with-syntax ([parser (generate-temporary class)]) (values (make den:parser #'parser (stxclass-attrs sc) (stxclass/h? sc) - (stxclass-commit? sc) (stxclass-delimit-cut? sc)) + (stxclass-commit? sc) (stxclass-delimit-cut? sc) + (stxclass-desc sc)) (list #`(define-values (parser) (curried-stxclass-parser #,class #,argu)))))))] [(regexp? name) @@ -294,7 +295,7 @@ (values (make den:delayed #'parser class) (list #`(define-values (parser) (curried-stxclass-parser #,class #,argu)))))])] - [(den:parser _p _a _sp _c _dc?) + [(den:parser _p _a _sp _c _dc? _desc) (values entry null)] [(den:delayed _p _c) (values entry null)])) @@ -628,7 +629,7 @@ (let* ([iattrs (id-pattern-attrs (eh-alternative-attrs alt) prefix)] [attr-count (length iattrs)]) (list (create-ehpat - (hpat:var/p #f (eh-alternative-parser alt) no-arguments iattrs attr-count #f #f) + (hpat:var/p #f (eh-alternative-parser alt) no-arguments iattrs attr-count #f #f #f) (eh-alternative-repc alt) #f) (replace-eh-alternative-attrs @@ -702,14 +703,14 @@ (error 'parse-pat:id "(internal error) decls had leftover stxclass entry: ~s" entry)] - [(den:parser parser attrs splicing? commit? delimit-cut?) + [(den:parser parser attrs splicing? commit? delimit-cut? desc) (check-no-delimit-cut-in-not id delimit-cut?) (cond [splicing? (unless allow-head? (wrong-syntax id "splicing syntax class not allowed here")) - (parse-pat:id/h id parser no-arguments attrs commit? "." #f)] + (parse-pat:id/h id parser no-arguments attrs commit? "." #f desc)] [else - (parse-pat:id/s id parser no-arguments attrs commit? "." #f)])] + (parse-pat:id/s id parser no-arguments attrs commit? "." #f desc)])] [(den:delayed parser class) (let ([sc (get-stxclass class)]) (parse-pat:var/sc id allow-head? id sc no-arguments "." #f parser))])) @@ -767,7 +768,8 @@ (stxclass-attrs sc) (stxclass-commit? sc) pfx - role)] + role + (stxclass-desc sc))] [(stxclass/h? sc) (unless allow-head? (wrong-syntax stx "splicing syntax class not allowed here")) @@ -777,21 +779,22 @@ (stxclass-attrs sc) (stxclass-commit? sc) pfx - role)])) + role + (stxclass-desc sc))])) -(define (parse-pat:id/s name parser argu attrs commit? pfx role) +(define (parse-pat:id/s name parser argu attrs commit? pfx role desc) (define prefix (name->prefix name pfx)) (define bind (name->bind name)) - (pat:var/p bind parser argu (id-pattern-attrs attrs prefix) (length attrs) commit? role)) + (pat:var/p bind parser argu (id-pattern-attrs attrs prefix) (length attrs) commit? role desc)) (define (parse-pat:id/s/integrate name predicate description role) (define bind (name->bind name)) (pat:integrated bind predicate description role)) -(define (parse-pat:id/h name parser argu attrs commit? pfx role) +(define (parse-pat:id/h name parser argu attrs commit? pfx role desc) (define prefix (name->prefix name pfx)) (define bind (name->bind name)) - (hpat:var/p bind parser argu (id-pattern-attrs attrs prefix) (length attrs) commit? role)) + (hpat:var/p bind parser argu (id-pattern-attrs attrs prefix) (length attrs) commit? role desc)) (define (name->prefix id pfx) (cond [(wildcard? id) #f] diff --git a/racket/collects/syntax/parse/private/residual-ct.rkt b/racket/collects/syntax/parse/private/residual-ct.rkt index 794d816586..056ff0ebbf 100644 --- a/racket/collects/syntax/parse/private/residual-ct.rkt +++ b/racket/collects/syntax/parse/private/residual-ct.rkt @@ -51,8 +51,8 @@ A ConventionRule is (list regexp DeclEntry) A LiteralSet is (make-literalset (listof LiteralSetEntry)) An LiteralSetEntry is one of - - (make-lse:lit symbol id ct-phase) - - (make-lse:datum-lit symbol symbol) + - (make-lse:lit Symbol Id Stx) + - (make-lse:datum-lit Symbol Symbol) |# (define-struct literalset (literals) #:transparent) (define-struct lse:lit (internal external phase) #:transparent)