From 91a03eecb3f6518e9f24e396a204b47b5e526dc0 Mon Sep 17 00:00:00 2001 From: Ryan Culpepper Date: Wed, 4 May 2016 19:38:57 -0400 Subject: [PATCH] syntax/parse: add separate pattern for simple vars --- racket/collects/syntax/parse/private/opt.rkt | 31 +++++++++------- .../collects/syntax/parse/private/parse.rkt | 14 +++---- .../syntax/parse/private/rep-patterns.rkt | 37 +++++++++++-------- racket/collects/syntax/parse/private/rep.rkt | 27 +++++++------- 4 files changed, 58 insertions(+), 51 deletions(-) diff --git a/racket/collects/syntax/parse/private/opt.rkt b/racket/collects/syntax/parse/private/opt.rkt index 3c72594088..ec032026ea 100644 --- a/racket/collects/syntax/parse/private/opt.rkt +++ b/racket/collects/syntax/parse/private/opt.rkt @@ -176,7 +176,8 @@ ;; - if p can cut, then factoring changes which choice points are discarded (too few) (match p [(pat:any _as) #t] - [(pat:var _as _n _p _argu _na _ac commit? _r) + [(pat:svar _as _n) #t] + [(pat:var/p _as _n _p _argu _na _ac commit? _r) ;; commit? implies delimit-cut commit?] [(? pat:integrated?) #t] @@ -215,7 +216,7 @@ [(pat:post _as pattern) (pattern-factorable? pattern)] ;; ---- - [(hpat:var _as _name _parser _argu _na _ac commit? _role) + [(hpat:var/p _as _name _parser _argu _na _ac commit? _role) commit?] [(hpat:seq _as inner) (pattern-factorable? inner)] @@ -236,11 +237,13 @@ (define (pattern-equal? a b) (define result (cond [(and (pat:any? a) (pat:any? b)) #t] - [(and (pat:var? a) (pat:var? b)) - (and (free-id/f-equal? (pat:var-parser a) (pat:var-parser b)) - (equal-iattrs? (pat:var-attrs a) (pat:var-attrs b)) - (equal-argu? (pat:var-argu a) (pat:var-argu b)) - (expr-equal? (pat:var-role a) (pat:var-role b)))] + [(and (pat:svar? a) (pat:svar? b)) + (equal-iattrs? (pat:svar-attrs a) (pat:svar-attrs b))] + [(and (pat:var/p? a) (pat:var/p? b)) + (and (free-id/f-equal? (pat:var/p-parser a) (pat:var/p-parser b)) + (equal-iattrs? (pat:var/p-attrs a) (pat:var/p-attrs b)) + (equal-argu? (pat:var/p-argu a) (pat:var/p-argu b)) + (expr-equal? (pat:var/p-role a) (pat:var/p-role b)))] [(and (pat:integrated? a) (pat:integrated? b)) (and (free-identifier=? (pat:integrated-predicate a) (pat:integrated-predicate b)) @@ -290,11 +293,11 @@ [(and (pat:post? a) (pat:post? b)) (pattern-equal? (pat:post-pattern a) (pat:post-pattern b))] ;; --- - [(and (hpat:var? a) (hpat:var? b)) - (and (free-id/f-equal? (hpat:var-parser a) (hpat:var-parser b)) - (equal-iattrs? (hpat:var-attrs a) (hpat:var-attrs b)) - (equal-argu? (hpat:var-argu a) (hpat:var-argu b)) - (expr-equal? (hpat:var-role a) (hpat:var-role b)))] + [(and (hpat:var/p? a) (hpat:var/p? b)) + (and (free-id/f-equal? (hpat:var/p-parser a) (hpat:var/p-parser b)) + (equal-iattrs? (hpat:var/p-attrs a) (hpat:var/p-attrs b)) + (equal-argu? (hpat:var/p-argu a) (hpat:var/p-argu b)) + (expr-equal? (hpat:var/p-role a) (hpat:var/p-role b)))] [(and (hpat:seq? a) (hpat:seq? b)) (pattern-equal? (hpat:seq-inner a) (hpat:seq-inner b))] ;; --- @@ -399,7 +402,9 @@ [(pat:any _as) '_] [(pat:integrated _as name pred desc _) (format-symbol "~a:~a" (or name '_) desc)] - [(pat:var _as name parser _ _ _ _ _) + [(pat:svar _as name) + (syntax-e name)] + [(pat:var/p _as name parser _ _ _ _ _) (cond [(and parser (regexp-match #rx"^parse-(.*)$" (symbol->string (syntax-e parser)))) => (lambda (m) (format-symbol "~a:~a" (or name '_) (cadr m)))] diff --git a/racket/collects/syntax/parse/private/parse.rkt b/racket/collects/syntax/parse/private/parse.rkt index a0ba0464df..1a322037ca 100644 --- a/racket/collects/syntax/parse/private/parse.rkt +++ b/racket/collects/syntax/parse/private/parse.rkt @@ -499,10 +499,10 @@ Conventions: k)] [#s(pat:any _attrs) #'k] - [#s(pat:var _attrs name #f _ () _ _ _) + [#s(pat:svar _attrs name) #'(let-attributes ([#s(attr name 0 #t) (datum->syntax cx x cx)]) k)] - [#s(pat:var _attrs name parser argu (nested-a ...) attr-count commit? role) + [#s(pat:var/p _attrs name parser argu (nested-a ...) attr-count commit? role) (with-syntax ([(av ...) (generate-n-temporaries (syntax-e #'attr-count))] [(name-attr ...) (if (identifier? #'name) @@ -668,9 +668,9 @@ Conventions: (syntax-case #'p () [#s(pat:any _as) #''(any)] - [#s(pat:var _as name #f _ () _ _ _) + [#s(pat:svar _as name) #''(any)] - [#s(pat:var _ ...) + [#s(pat:var/p _ ...) #'#f] ;; FIXME: need access to (constant) description as field [#s(pat:datum _as d) #''(datum d)] @@ -784,7 +784,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 _attrs name parser argu (nested-a ...) attr-count commit? role) + [#s(hpat:var/p _attrs name parser argu (nested-a ...) attr-count commit? role) (with-syntax ([(av ...) (generate-n-temporaries (syntax-e #'attr-count))] [(name-attr ...) (if (identifier? #'name) @@ -920,9 +920,7 @@ Conventions: (syntax-case stx () ;; == Specialized cases ;; -- (x ... . ()) - [(parse:dots x cx (#s(ehpat (attr0) - #s(pat:var _attrs name #f _ () _ _ _) - #f)) + [(parse:dots x cx (#s(ehpat (attr0) #s(pat:svar _attrs name) #f)) #s(pat:datum () ()) pr es k) #'(let-values ([(status result) (predicate-ellipsis-parser x cx pr es void #f #f)]) (case status diff --git a/racket/collects/syntax/parse/private/rep-patterns.rkt b/racket/collects/syntax/parse/private/rep-patterns.rkt index 1477c080de..e2f0828fd0 100644 --- a/racket/collects/syntax/parse/private/rep-patterns.rkt +++ b/racket/collects/syntax/parse/private/rep-patterns.rkt @@ -22,7 +22,8 @@ A Base is (listof IAttr) #| A SinglePattern is one of (pat:any Base) - (pat:var Base id id Arguments (listof IAttr) nat/#f bool stx) + (pat:svar Base id) -- "simple" var, no stxclass + (pat:var/p Base id id Arguments (Listof IAttr) nat/#f bool stx) -- var with parser (pat:literal Base identifier ct-phase ct-phase) (pat:datum Base datum) (pat:action Base ActionPattern SinglePattern) @@ -51,7 +52,8 @@ A ListPattern is a subtype of SinglePattern; one of |# (define-struct pat:any (attrs) #:prefab) -(define-struct pat:var (attrs name parser argu nested-attrs attr-count commit? role) #:prefab) +(define-struct pat:svar (attrs name) #:prefab) +(define-struct pat:var/p (attrs name parser argu nested-attrs attr-count commit? role) #:prefab) (define-struct pat:literal (attrs id input-phase lit-phase) #:prefab) (define-struct pat:datum (attrs datum) #:prefab) (define-struct pat:action (attrs action inner) #:prefab) @@ -94,7 +96,7 @@ action:and is desugared below in create-* procedures #| A HeadPattern is one of - (hpat:var Base id id Arguments (listof IAttr) nat/#f bool stx) + (hpat:var/p Base id id Arguments (listof IAttr) nat/#f bool stx) (hpat:seq Base ListPattern) (hpat:action Base ActionPattern HeadPattern) (hpat:and Base HeadPattern SinglePattern) @@ -109,7 +111,7 @@ A HeadPattern is one of (hpat:peek-not Base HeadPattern) |# -(define-struct hpat:var (attrs name parser argu nested-attrs attr-count commit? role) #:prefab) +(define-struct hpat:var/p (attrs name parser argu nested-attrs attr-count commit? role) #:prefab) (define-struct hpat:seq (attrs inner) #:prefab) (define-struct hpat:action (attrs action inner) #:prefab) (define-struct hpat:and (attrs head single) #:prefab) @@ -154,7 +156,8 @@ A SideClause is one of (define (pattern? x) (or (pat:any? x) - (pat:var? x) + (pat:svar? x) + (pat:var/p? x) (pat:literal? x) (pat:datum? x) (pat:action? x) @@ -184,7 +187,7 @@ A SideClause is one of (action:post? x))) (define (head-pattern? x) - (or (hpat:var? x) + (or (hpat:var/p? x) (hpat:seq? x) (hpat:action? x) (hpat:and? x) @@ -220,13 +223,13 @@ A SideClause is one of #'(lambda (x) (cond [(pred x) (accessor x)] ... [else (raise-type-error 'pattern-attrs "pattern" x)])))])) - (mk-get-attrs pat:any pat:var pat:datum pat:literal pat:action pat:head + (mk-get-attrs pat:any pat:svar pat:var/p pat:datum pat:literal pat:action pat:head pat:dots pat:and pat:or pat:not pat:describe pat:pair pat:vector pat:box pat:pstruct pat:delimit pat:commit pat:reflect pat:post pat:integrated action:cut action:bind action:fail action:and action:parse action:do action:post - hpat:var hpat:seq hpat:action hpat:and hpat:or hpat:describe + hpat:var/p hpat:seq hpat:action hpat:and hpat:or hpat:describe hpat:optional hpat:delimit hpat:commit hpat:reflect hpat:post hpat:peek hpat:peek-not ehpat))) @@ -239,10 +242,13 @@ A SideClause is one of (define (create-pat:any) (make pat:any null)) -(define (create-pat:var name parser argu nested-attrs attr-count commit? role) - (let ([attrs - (if name (cons (make attr name 0 #t) nested-attrs) nested-attrs)]) - (make pat:var attrs name parser argu nested-attrs attr-count commit? role))) +(define (create-pat:svar name) + (let ([attrs (list (make attr name 0 #t))]) + (make pat:svar attrs name))) + +(define (create-pat:var/p name parser argu nested-attrs attr-count commit? role) + (let ([attrs (if name (cons (make attr name 0 #t) nested-attrs) nested-attrs)]) + (make pat:var/p attrs name parser argu nested-attrs attr-count commit? role))) (define (create-pat:reflect obj argu attr-decls name nested-attrs) (let ([attrs @@ -338,10 +344,9 @@ A SideClause is one of ;; ---- -(define (create-hpat:var name parser argu nested-attrs attr-count commit? role) - (let ([attrs - (if name (cons (make attr name 0 #t) nested-attrs) nested-attrs)]) - (make hpat:var attrs name parser argu nested-attrs attr-count commit? role))) +(define (create-hpat:var/p name parser argu nested-attrs attr-count commit? role) + (let ([attrs (if name (cons (make attr name 0 #t) nested-attrs) nested-attrs)]) + (make hpat:var/p attrs name parser argu nested-attrs attr-count commit? role))) (define (create-hpat:reflect obj argu attr-decls name nested-attrs) (let ([attrs diff --git a/racket/collects/syntax/parse/private/rep.rkt b/racket/collects/syntax/parse/private/rep.rkt index c110dd1254..3a9428fa20 100644 --- a/racket/collects/syntax/parse/private/rep.rkt +++ b/racket/collects/syntax/parse/private/rep.rkt @@ -653,7 +653,7 @@ (let* ([iattrs (id-pattern-attrs (eh-alternative-attrs alt) prefix)] [attr-count (length iattrs)]) (list (create-ehpat - (create-hpat:var #f (eh-alternative-parser alt) no-arguments iattrs attr-count #f #f) + (create-hpat:var/p #f (eh-alternative-parser alt) no-arguments iattrs attr-count #f #f) (eh-alternative-repc alt)) (replace-eh-alternative-attrs alt (iattrs->sattrs iattrs))))))] @@ -700,19 +700,19 @@ [else (let-values ([(name suffix) (split-id/get-stxclass id decls)]) (cond [(stxclass? suffix) - (parse-pat:var* id allow-head? name suffix no-arguments "." #f #f)] + (parse-pat:var/sc id allow-head? name suffix no-arguments "." #f #f)] [(or (den:lit? suffix) (den:datum-lit? suffix)) (create-pat:and (list - (create-pat:var name #f no-arguments null #f #t #f) + (create-pat:svar name) (parse-pat:id/entry id decls allow-head? suffix)))] [(declenv-apply-conventions decls id) - => (lambda (entry) (parse-pat:id/entry id decls allow-head? entry))] - [else (create-pat:var name #f no-arguments null #f #t #f)]))])) + => (lambda (entry) (parse-pat:id/entry id allow-head? entry))] + [else (create-pat:svar name)]))])) ;; parse-pat:id/entry : Identifier .... DeclEntry -> SinglePattern ;; Handle when meaning of identifier pattern is given by declenv entry. -(define (parse-pat:id/entry id decls allow-head? entry) +(define (parse-pat:id/entry id allow-head? entry) (match entry [(den:lit internal literal input-phase lit-phase) (create-pat:literal literal input-phase lit-phase)] @@ -722,7 +722,7 @@ (let* ([pos-count (length (arguments-pargs argu))] [kws (arguments-kws argu)] [sc (get-stxclass/check-arity class class pos-count kws)]) - (parse-pat:var* id allow-head? id sc argu "." role #f))] + (parse-pat:var/sc id allow-head? id sc argu "." role #f))] [(den:class _n _c _a) (error 'parse-pat:id "(internal error) decls had leftover stxclass entry: ~s" @@ -737,8 +737,7 @@ (parse-pat:id/s id parser no-arguments attrs commit? "." #f)])] [(den:delayed parser class) (let ([sc (get-stxclass class)]) - (parse-pat:var* id allow-head? id sc no-arguments "." #f parser))])) - + (parse-pat:var/sc id allow-head? id sc no-arguments "." #f parser))])) (define (parse-pat:var stx decls allow-head?) (define name0 @@ -775,11 +774,11 @@ (let ([sc (get-stxclass/check-arity scname sc+args-stx (length (arguments-pargs argu)) (arguments-kws argu))]) - (parse-pat:var* stx allow-head? name0 sc argu pfx role #f))] + (parse-pat:var/sc stx allow-head? name0 sc argu pfx role #f))] [else ;; Just proper name - (create-pat:var name0 #f (arguments null null null) null #f #t #f)])) + (create-pat:svar name0)])) -(define (parse-pat:var* stx allow-head? name sc argu pfx role parser*) +(define (parse-pat:var/sc stx allow-head? name sc argu pfx role parser*) ;; if parser* not #f, overrides sc parser (check-no-delimit-cut-in-not stx (stxclass-delimit-cut? sc)) (cond [(and (stxclass/s? sc) @@ -808,7 +807,7 @@ (define (parse-pat:id/s name parser argu attrs commit? pfx role) (define prefix (name->prefix name pfx)) (define bind (name->bind name)) - (create-pat:var bind parser argu (id-pattern-attrs attrs prefix) (length attrs) commit? role)) + (create-pat:var/p bind parser argu (id-pattern-attrs attrs prefix) (length attrs) commit? role)) (define (parse-pat:id/s/integrate name integrate role) (define bind (name->bind name)) @@ -819,7 +818,7 @@ (define (parse-pat:id/h name parser argu attrs commit? pfx role) (define prefix (name->prefix name pfx)) (define bind (name->bind name)) - (create-hpat:var bind parser argu (id-pattern-attrs attrs prefix) (length attrs) commit? role)) + (create-hpat:var/p bind parser argu (id-pattern-attrs attrs prefix) (length attrs) commit? role)) (define (name->prefix id pfx) (cond [(wildcard? id) #f]