From 5ababfac9cc954cc6380ffca38d9660c4a5f4934 Mon Sep 17 00:00:00 2001 From: Ryan Culpepper Date: Sun, 20 Sep 2009 23:49:41 +0000 Subject: [PATCH] syntax/parse: added ~parse action pattern svn: r16097 --- .../syntax/private/stxparse/codegen-data.ss | 7 ++- collects/syntax/private/stxparse/parse.ss | 6 ++- .../syntax/private/stxparse/rep-patterns.ss | 10 +++- collects/syntax/private/stxparse/rep.ss | 23 ++++++++-- collects/syntax/private/stxparse/runtime.ss | 6 ++- collects/syntax/private/stxparse/sc.ss | 3 +- .../syntax/scribblings/parse-patterns.scrbl | 14 ++++-- collects/tests/stxclass/test.ss | 46 ++++++++++++------- 8 files changed, 83 insertions(+), 32 deletions(-) diff --git a/collects/syntax/private/stxparse/codegen-data.ss b/collects/syntax/private/stxparse/codegen-data.ss index 8a39de4a1a..7ca2577453 100644 --- a/collects/syntax/private/stxparse/codegen-data.ss +++ b/collects/syntax/private/stxparse/codegen-data.ss @@ -19,7 +19,7 @@ (make-fce x (list #'(+ 0)))) (define (done-frontier x) - (make-fce x (list #'(+ +inf.0)))) + (make-fce x (list #'(+ 0) #'(+ +inf.0)))) (define (frontier:add-car fc x) (make-fce x (cons #'(+ 0) (fce-indexes fc)))) @@ -49,6 +49,11 @@ (define (frontier:add-unpstruct fc x) (frontier:add-car fc x)) +(define (frontier:add-subparse fc x) + (frontier:add-car + (frontier:add-index (frontier:add-car fc x) +inf.0) + x)) + ;; A DynamicFrontierContext (DFC) is a list of numbers. ;; More operations on DFCs in runtime.ss diff --git a/collects/syntax/private/stxparse/parse.ss b/collects/syntax/private/stxparse/parse.ss index a4462947f3..dea714cfd3 100644 --- a/collects/syntax/private/stxparse/parse.ss +++ b/collects/syntax/private/stxparse/parse.ss @@ -329,7 +329,11 @@ (fail x #:expect (expectation pattern0) #:fce fc) - k)])])) + k)] + [#s(ghost:parse _ pattern expr) + #`(let ([y (datum->syntax #f (without-fails expr))]) + (parse:S y #,(frontier:add-subparse (wash #'fc) #'y) + pattern k))])])) (begin-for-syntax ;; convert-list-pattern : ListPattern id -> SinglePattern diff --git a/collects/syntax/private/stxparse/rep-patterns.ss b/collects/syntax/private/stxparse/rep-patterns.ss index 796e8de40c..ef36742e12 100644 --- a/collects/syntax/private/stxparse/rep-patterns.ss +++ b/collects/syntax/private/stxparse/rep-patterns.ss @@ -55,6 +55,7 @@ A GhostPattern is one of (make-ghost:fail Base stx stx) (make-ghost:bind Base (listof clause:attr)) * (make-ghost:and Base (listof GhostPattern)) + (make-ghost:parse Base SinglePattern stx) ghost:and is desugared below in create-* procedures |# @@ -63,6 +64,7 @@ ghost:and is desugared below in create-* procedures (define-struct ghost:fail (attrs when message) #:prefab) (define-struct ghost:bind (attrs clauses) #:prefab) (define-struct ghost:and (attrs patterns) #:prefab) +(define-struct ghost:parse (attrs pattern expr) #:prefab) #| A HeadPattern is one of @@ -126,7 +128,8 @@ A Kind is one of (or (ghost:cut? x) (ghost:bind? x) (ghost:fail? x) - (ghost:and? x))) + (ghost:and? x) + (ghost:parse? x))) (define (head-pattern? x) (or (hpat:var? x) @@ -163,7 +166,7 @@ A Kind is one of [else (raise-type-error 'pattern-attrs "pattern" x)])))])) (mk-get-attrs pat:any pat:var pat:datum pat:literal pat:ghost pat:head pat:dots pat:and pat:or pat:not pat:compound pat:describe - ghost:cut ghost:bind ghost:fail ghost:and + ghost:cut ghost:bind ghost:fail ghost:and ghost:parse hpat:var hpat:seq hpat:ghost hpat:and hpat:or hpat:describe hpat:optional ehpat))) @@ -233,6 +236,9 @@ A Kind is one of (let ([attrs (append-iattrs (map pattern-attrs patterns))]) (make ghost:and attrs patterns))) +(define (create-ghost:parse pattern expr) + (make ghost:parse (pattern-attrs pattern) pattern expr)) + ;; ---- (define (create-hpat:var name parser args nested-attrs) diff --git a/collects/syntax/private/stxparse/rep.ss b/collects/syntax/private/stxparse/rep.ss index 64d4076d4f..6b8162f61b 100644 --- a/collects/syntax/private/stxparse/rep.ss +++ b/collects/syntax/private/stxparse/rep.ss @@ -85,10 +85,11 @@ (quote-syntax ~bounds) (quote-syntax ~rest) (quote-syntax ~struct) - (quote-syntax ~!) (quote-syntax ~describe) + (quote-syntax ~!) (quote-syntax ~bind) - (quote-syntax ~fail))) + (quote-syntax ~fail) + (quote-syntax ~parse))) (define (reserved? stx) (and (identifier? stx) @@ -279,8 +280,8 @@ [(not allow-head?) (ghost-pattern->single-pattern x)] [else (wrong-syntax stx "action pattern not allowed here")])) - (syntax-case stx (~var ~literal ~and ~or ~not ~rest ~struct - ~! ~describe ~bind ~fail ~seq ~optional) + (syntax-case stx (~var ~literal ~and ~or ~not ~rest ~struct ~describe + ~seq ~optional ~! ~bind ~fail ~parse) [wildcard (wildcard? #'wildcard) (create-pat:any)] @@ -322,6 +323,9 @@ [(~fail . rest) (check-ghost! (parse-pat:fail stx decls))] + [(~parse . rest) + (check-ghost! + (parse-pat:parse stx decls))] [(head dots . tail) (dots? #'dots) (parse-pat:dots stx #'head #'tail decls)] @@ -630,7 +634,16 @@ [() (wrong-syntax stx "missing message expression")] [_ - (wrong-syntax stx "bad fail pattern")])))])) + (wrong-syntax stx "bad ~fail pattern")])))])) + +(define (parse-pat:parse stx decls) + (syntax-case stx (~parse) + [(~parse pattern expr) + (let ([p (parse-single-pattern #'pattern decls)]) + (create-ghost:parse p #'expr))] + [_ + (wrong-syntax stx "bad ~parse pattern")])) + (define (parse-pat:rest stx decls) (syntax-case stx () diff --git a/collects/syntax/private/stxparse/runtime.ss b/collects/syntax/private/stxparse/runtime.ss index 6e008c9e2f..7c3882fa8a 100644 --- a/collects/syntax/private/stxparse/runtime.ss +++ b/collects/syntax/private/stxparse/runtime.ss @@ -22,10 +22,11 @@ ~optional ~rest ~struct - ~! ~describe + ~! ~bind ~fail + ~parse current-expression current-macro-name @@ -88,10 +89,11 @@ (define-keyword ~optional) (define-keyword ~rest) (define-keyword ~struct) -(define-keyword ~!) (define-keyword ~describe) +(define-keyword ~!) (define-keyword ~bind) (define-keyword ~fail) +(define-keyword ~parse) ;; == Parameters & Syntax Parameters diff --git a/collects/syntax/private/stxparse/sc.ss b/collects/syntax/private/stxparse/sc.ss index 6f268f2029..eb97674b3c 100644 --- a/collects/syntax/private/stxparse/sc.ss +++ b/collects/syntax/private/stxparse/sc.ss @@ -37,10 +37,11 @@ ~optional ~rest ~struct - ~! ~describe + ~! ~bind ~fail + ~parse attribute this-syntax) diff --git a/collects/syntax/scribblings/parse-patterns.scrbl b/collects/syntax/scribblings/parse-patterns.scrbl index 23d8965d72..fd7f06c3b9 100644 --- a/collects/syntax/scribblings/parse-patterns.scrbl +++ b/collects/syntax/scribblings/parse-patterns.scrbl @@ -83,9 +83,9 @@ When a special form in this manual refers to @svar[syntax-pattern] (eg, the description of the @scheme[syntax-parse] special form), it means specifically @tech{@Spattern}. -@schemegrammar*[#:literals (_ ~var ~literal ~or ~and ~not ~seq - ~rep ~once ~optional - ~rest ~struct ~! ~describe ~bind ~fail) +@schemegrammar*[#:literals (_ ~var ~literal ~or ~and ~not ~rest ~struct + ~describe ~seq ~optional ~rep ~once + ~! ~bind ~fail ~parse) [S-pattern pvar-id pvar-id:syntax-class-id @@ -130,6 +130,7 @@ means specifically @tech{@Spattern}. ~! (~bind [attr-id expr] ...) (~fail maybe-fail-condition message-expr) + (~parse S-pattern stx-expr) (@#,ref[~and a] A-pattern ...+)] [proper-S-pattern #, @elem{a @svar{S-pattern} that is not a @svar{A-pattern}}] @@ -800,6 +801,13 @@ specific ill-formed terms and address them with specially-created failure messages. } +@specsubform[(@#,defhere[~parse] S-pattern stx-expr) + #:contracts ([stx-expr syntax?])]{ + +Evaluates @scheme[stx-expr] to a syntax object and matches it against +@scheme[S-pattern]. +} + @specsubform[(@#,def[~and a] A-pattern ...+)]{ Performs the actions of each @scheme[A-pattern]. diff --git a/collects/tests/stxclass/test.ss b/collects/tests/stxclass/test.ss index 734b8fc4c5..f31c7186c3 100644 --- a/collects/tests/stxclass/test.ss +++ b/collects/tests/stxclass/test.ss @@ -198,6 +198,27 @@ (tok (1 2) (~and x:two :two) (and (bound (x 0) (x.a 0) (a 0)) (s= x '(1 2)) (s= x.a 1) (s= a 1))) +;; -- H patterns + +;; seq +(tok (1 2 3) ((~seq 1 2) 3)) +(tok (1 2 3) (1 (~seq 2) 3)) +(tok (1 2 3) ((~seq) 1 2 3)) + +;; or +(tok (1 2 3) ((~or (~seq 1 2) 1) 3)) +(tok (1 2 3) ((~or 1 (~seq 1 2)) 3)) +(tok (1 2 3) ((~or (~seq 1) (~seq 1 2)) 3)) +(tok (1 2 3) ((~or (~seq 1) (~seq)) 1 2 3)) +(tok (1 2 3) ((~or (~seq 1) (~seq)) 1 2 3 (~or (~seq 4) (~seq)))) + +;; describe +(tok (1 2 3) ((~describe "one-two" (~seq 1 2)) 3)) +(terx (1 3 3) ((~describe "one-two" (~seq 1 2)) 3) + "one-two") + +;; -- A patterns + ;; cut patterns (terx* (1 2 3) [(1 ~! 4) (1 2 3)] "4" (not "2")) @@ -227,24 +248,15 @@ (terx 1 (~and n:nat (~fail #:unless (even? (syntax-e #'n)) "wanted even number")) #rx"wanted even number") -;; -- H patterns +;; fail as S-pattern +(terx 1 (~fail "grr") + #rx"grr") -;; seq -(tok (1 2 3) ((~seq 1 2) 3)) -(tok (1 2 3) (1 (~seq 2) 3)) -(tok (1 2 3) ((~seq) 1 2 3)) - -;; or -(tok (1 2 3) ((~or (~seq 1 2) 1) 3)) -(tok (1 2 3) ((~or 1 (~seq 1 2)) 3)) -(tok (1 2 3) ((~or (~seq 1) (~seq 1 2)) 3)) -(tok (1 2 3) ((~or (~seq 1) (~seq)) 1 2 3)) -(tok (1 2 3) ((~or (~seq 1) (~seq)) 1 2 3 (~or (~seq 4) (~seq)))) - -;; describe -(tok (1 2 3) ((~describe "one-two" (~seq 1 2)) 3)) -(terx (1 3 3) ((~describe "one-two" (~seq 1 2)) 3) - "one-two") +(tok (1 2 3) (x:nat y:nat (~parse (~or 2 3) (+ (syntax-e #'x) (syntax-e #'y))) z:nat)) +(terx (1 2 3) (x:nat y:nat (~parse 4 (+ (syntax-e #'x) (syntax-e #'y))) z:nat) + "expected the literal 4") +(terx (1 2 3) (x:nat y:nat (~parse (2 4) #'(x y))) + "expected the literal 2") ;; == Lib tests