From 669460da3475c285d92255bfa256ec14d58d93a5 Mon Sep 17 00:00:00 2001 From: Ryan Culpepper Date: Sat, 14 May 2016 16:40:36 -0400 Subject: [PATCH] syntax/parse: parse side clauses directly as action patterns Eliminates the clause:* structures. --- .../collects/syntax/parse/private/parse.rkt | 17 +---- .../syntax/parse/private/rep-data.rkt | 14 +--- .../syntax/parse/private/rep-patterns.rkt | 34 +++++----- racket/collects/syntax/parse/private/rep.rkt | 64 ++++++------------- 4 files changed, 39 insertions(+), 90 deletions(-) diff --git a/racket/collects/syntax/parse/private/parse.rkt b/racket/collects/syntax/parse/private/parse.rkt index ce376937f3..8c16f2f978 100644 --- a/racket/collects/syntax/parse/private/parse.rkt +++ b/racket/collects/syntax/parse/private/parse.rkt @@ -712,8 +712,8 @@ Conventions: #`(parse:A x cx #,action pr es #,k))] [#s(action:cut) #'(with ([fail-handler cut-prompt]) k)] - [#s(action:bind (side ...)) - #'(bind/sides (side ...) k)] + [#s(action:bind a expr) + #'(let-attributes ([a (wrap-user-code expr)]) k)] [#s(action:fail condition message) #`(let ([c (wrap-user-code condition)]) (if c @@ -735,17 +735,6 @@ Conventions: #'(let ([pr* (ps-add-post pr)]) (parse:A x cx pattern pr* es k))])])) -;; (bind/sides clauses k) : expr[Ans] -;; In k: attrs(clauses) are bound. -(define-syntax (bind/sides stx) - (syntax-case stx () - [(_ (side ...) k) - (for/fold ([k #'k]) ([side (in-list (reverse (syntax->list #'(side ...))))]) - (syntax-case side () - [#s(clause:attr a expr) - #`(let-attributes ([a (wrap-user-code expr)]) - #,k)]))])) - (begin-for-syntax ;; convert-list-pattern : ListPattern id -> SinglePattern ;; Converts '() datum pattern at end of list to bind (cons stx index) @@ -1017,7 +1006,7 @@ Conventions: (syntax-case stx () [(_ a #s(rep:optional _ _ defaults) v) (with-syntax ([#s(attr name _ _) #'a] - [(#s(clause:attr da de) ...) #'defaults]) + [(#s(action:bind da de) ...) #'defaults]) (let ([default (for/or ([da (in-list (syntax->list #'(da ...)))] [de (in-list (syntax->list #'(de ...)))]) diff --git a/racket/collects/syntax/parse/private/rep-data.rkt b/racket/collects/syntax/parse/private/rep-data.rkt index 8e309c1997..b81727a37c 100644 --- a/racket/collects/syntax/parse/private/rep-data.rkt +++ b/racket/collects/syntax/parse/private/rep-data.rkt @@ -24,11 +24,7 @@ stxclass-commit? stxclass-delimit-cut? (struct-out rhs) - (struct-out variant) - (struct-out clause:fail) - (struct-out clause:with) - (struct-out clause:attr) - (struct-out clause:do)) + (struct-out variant)) (define (stxclass/s? x) (and (stxclass? x) (not (stxclass-splicing? x)))) @@ -54,10 +50,6 @@ A Variant is |# (define-struct variant (ostx attrs pattern definitions) #:prefab) -#| -SideClause is defined in rep-patterns -|# - ;; make-dummy-stxclass : identifier -> SC ;; Dummy stxclass for calculating attributes of recursive stxclasses. (define (make-dummy-stxclass name) @@ -200,9 +192,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?)) -(define SideClause/c - (or/c clause:fail? clause:with? clause:attr? clause:do?)) - ;; ct-phase = syntax, expr that computes absolute phase ;; usually = #'(syntax-local-phase-level) (define ct-phase/c syntax?) @@ -218,7 +207,6 @@ expressions are duplicated, and may be evaluated in different scopes. (provide/contract [DeclEnv/c contract?] [DeclEntry/c contract?] - [SideClause/c contract?] [ct-phase/c contract?] [make-dummy-stxclass (-> identifier? stxclass?)] diff --git a/racket/collects/syntax/parse/private/rep-patterns.rkt b/racket/collects/syntax/parse/private/rep-patterns.rkt index 01ed86494d..63dde46ffd 100644 --- a/racket/collects/syntax/parse/private/rep-patterns.rkt +++ b/racket/collects/syntax/parse/private/rep-patterns.rkt @@ -72,17 +72,20 @@ A ListPattern is a subtype of SinglePattern; one of A ActionPattern is one of (action:cut) (action:fail stx stx) - (action:bind (listof clause:attr)) + (action:bind IAttr Stx) (action:and (listof ActionPattern)) (action:parse SinglePattern stx) (action:do (listof stx)) (action:ord ActionPattern UninternedSymbol Nat) (action:post ActionPattern) + +A BindAction is (action:bind IAttr Stx) +A SideClause is just an ActionPattern |# (define-struct action:cut () #:prefab) (define-struct action:fail (when message) #:prefab) -(define-struct action:bind (clauses) #:prefab) +(define-struct action:bind (attr expr) #:prefab) (define-struct action:and (patterns) #:prefab) (define-struct action:parse (pattern expr) #:prefab) (define-struct action:do (stmts) #:prefab) @@ -122,11 +125,11 @@ A HeadPattern is one of #| An EllipsisHeadPattern is - (ehpat Base HeadPattern RepConstraint) + (ehpat (Listof IAttr) HeadPattern RepConstraint) A RepConstraint is one of (rep:once stx stx stx) - (rep:optional stx stx (listof clause:attr)) + (rep:optional stx stx (listof BindAction)) (rep:bounds nat/#f nat/#f stx stx stx) #f |# @@ -136,19 +139,6 @@ A RepConstraint is one of (define-struct rep:optional (name over-message defaults) #:prefab) (define-struct rep:bounds (min max name under-message over-message) #:prefab) - -#| -A SideClause is one of - (clause:fail stx stx) - (clause:with pattern stx (listof stx)) - (clause:attr IAttr stx) - (clause:do (listof stx)) -|# -(define-struct clause:fail (condition message) #:prefab) -(define-struct clause:with (pattern expr definitions) #:prefab) -(define-struct clause:attr (attr expr) #:prefab) -(define-struct clause:do (stmts) #:prefab) - (define (pattern? x) (or (pat:any? x) (pat:svar? x) @@ -273,8 +263,8 @@ A SideClause is one of null] [(action:fail _ _) null] - [(action:bind clauses) - (map clause:attr-attr clauses)] + [(action:bind attr expr) + (list attr)] [(action:and ps) (append-iattrs (map pattern-attrs ps))] [(action:parse sp _) @@ -485,3 +475,9 @@ A SideClause is one of [else (for/list ([p (in-list patterns)] [index (in-naturals)]) (create-ord-pattern p group index))])) + +;; create-action:and : (Listof ActionPattern) -> ActionPattern +(define (create-action:and actions) + (match actions + [(list action) action] + [_ (action:and actions)])) diff --git a/racket/collects/syntax/parse/private/rep.rkt b/racket/collects/syntax/parse/private/rep.rkt index 53429ef024..819cc0ef6e 100644 --- a/racket/collects/syntax/parse/private/rep.rkt +++ b/racket/collects/syntax/parse/private/rep.rkt @@ -372,13 +372,6 @@ [pattern (combine-pattern+sides pattern0 sides splicing?)]) (values rest pattern defs)))) -(define (side-clauses-attrss clauses) - (for/list ([c (in-list clauses)] - #:when (or (clause:with? c) (clause:attr? c))) - (if (clause:with? c) - (pattern-attrs (clause:with-pattern c)) - (list (clause:attr-attr c))))) - ;; parse-whole-pattern : stx DeclEnv boolean -> Pattern ;; kind is either 'main or 'with, indicates what kind of pattern declare affects (define (parse-whole-pattern stx decls [splicing? #f] @@ -404,12 +397,9 @@ (define (combine-pattern+sides pattern sides splicing?) (check-pattern (cond [(pair? sides) - (define group (gensym*)) (define actions-pattern (create-post-pattern - (action:and - (for/list ([side (in-list sides)] [index (in-naturals)]) - (create-ord-pattern (side-clause->pattern side) group index))))) + (create-action:and (ord-and-patterns sides (gensym*))))) (define and-patterns (ord-and-patterns (list pattern (pat:action actions-pattern (pat:any))) (gensym*))) @@ -417,19 +407,6 @@ [else (pat:and and-patterns)])] [else pattern]))) -;; side-clause->pattern : SideClause -> ActionPattern -(define (side-clause->pattern side) - (match side - [(clause:fail condition message) - (action:fail condition message)] - [(clause:with wpat expr defs) - (let ([ap (action:parse wpat expr)]) - (if (pair? defs) (action:and (list (action:do defs) ap)) ap))] - [(clause:attr attr expr) - (action:bind (list side))] - [(clause:do stmts) - (action:do stmts)])) - ;; gensym* : -> UninternedSymbol ;; Like gensym, but with deterministic name from compilation-local counter. (define gensym*-counter 0) @@ -1022,7 +999,7 @@ (syntax-case stx () [(_ clause ...) (let ([clauses (check-bind-clause-list #'(clause ...) stx)]) - (action:bind clauses))])) + (create-action:and clauses))])) (define (parse-pat:fail stx decls) (syntax-case stx () @@ -1097,11 +1074,11 @@ (parse*-optional-pattern stx decls h-optional-directive-table)) (create-hpat:or (list head - (hpat:action (action:bind defaults) + (hpat:action (create-action:and defaults) (hpat:seq (pat:datum '())))))) ;; parse*-optional-pattern : stx DeclEnv table -;; -> (values Syntax HeadPattern IAttrs Stx Stx Defaults) +;; -> (values Syntax HeadPattern IAttrs Stx Stx (Listof BindClause)) (define (parse*-optional-pattern stx decls optional-directive-table) (syntax-case stx () [(_ p . options) @@ -1118,7 +1095,7 @@ (options-select-value chunks '#:defaults #:default '())] [pattern-iattrs (pattern-attrs head)] [defaults-iattrs - (append-iattrs (side-clauses-attrss defaults))] + (append-iattrs (map pattern-attrs defaults))] [all-iattrs (union-iattrs (list pattern-iattrs defaults-iattrs))]) (when (eq? (stxclass-lookup-config) 'yes) @@ -1212,10 +1189,9 @@ (parse-pattern-sides chunks2 decls)) (define-values (decls3 defs) (decls-create-defs decls2)) - (values rest decls3 defs (parse-pattern-sides chunks2 decls)))) + (values rest decls3 defs sides))) -;; parse-pattern-sides : (listof chunk) DeclEnv -;; -> (listof SideClause/c) +;; parse-pattern-sides : (listof chunk) DeclEnv -> (listof SideClause) ;; Invariant: decls contains only literals bindings (define (parse-pattern-sides chunks decls) (match chunks @@ -1223,28 +1199,28 @@ (wrong-syntax declare-stx "#:declare can only appear immediately after pattern or #:with clause")] [(cons (list '#:role role-stx _) rest) - (wrong-syntax role-stx - "#:role can only appear immediately after #:declare clause")] - [(cons (list '#:fail-when fw-stx when-condition expr) rest) - (cons (make clause:fail when-condition expr) + (wrong-syntax role-stx "#:role can only appear immediately after #:declare clause")] + [(cons (list '#:fail-when fw-stx when-expr msg-expr) rest) + (cons (action:fail when-expr msg-expr) (parse-pattern-sides rest decls))] - [(cons (list '#:fail-unless fu-stx unless-condition expr) rest) - (cons (make clause:fail #`(not #,unless-condition) expr) + [(cons (list '#:fail-unless fu-stx unless-expr msg-expr) rest) + (cons (action:fail #`(not #,unless-expr) msg-expr) (parse-pattern-sides rest decls))] - [(cons (list '#:when w-stx unless-condition) rest) - ;; Bleh: when is basically fail-unless without the msg argument - (cons (make clause:fail #`(not #,unless-condition) #'#f) + [(cons (list '#:when w-stx unless-expr) rest) + (cons (action:fail #`(not #,unless-expr) #'#f) (parse-pattern-sides rest decls))] [(cons (list '#:with with-stx pattern expr) rest) (let-values ([(decls2 rest) (grab-decls rest decls)]) (let-values ([(decls2a defs) (decls-create-defs decls2)]) - (cons (make clause:with (parse-whole-pattern pattern decls2a #:kind 'with) expr defs) + (cons (create-action:and + (list (action:do defs) + (action:parse (parse-whole-pattern pattern decls2a #:kind 'with) expr))) (parse-pattern-sides rest decls))))] [(cons (list '#:attr attr-stx a expr) rest) - (cons (make clause:attr a expr) + (cons (action:bind a expr) (parse-pattern-sides rest decls))] [(cons (list '#:do do-stx stmts) rest) - (cons (make clause:do stmts) + (cons (action:do stmts) (parse-pattern-sides rest decls))] ['() '()])) @@ -1470,7 +1446,7 @@ (define (check-bind-clause clause ctx) (syntax-case clause () [(attr-decl expr) - (make clause:attr (check-attr-arity #'attr-decl ctx) #'expr)] + (action:bind (check-attr-arity #'attr-decl ctx) #'expr)] [_ (raise-syntax-error #f "expected bind clause" ctx clause)])) (define (check-stmt-list stx ctx)