From 783d37a0d3d2f80939c04fa5e936fde87520c048 Mon Sep 17 00:00:00 2001 From: Ryan Culpepper Date: Sun, 30 Aug 2009 00:15:48 +0000 Subject: [PATCH] syntax/parse added #:opaque syntax class option changed expectation handling svn: r15831 --- collects/syntax/private/stxparse/parse.ss | 46 ++++++----- .../syntax/private/stxparse/rep-patterns.ss | 12 +-- collects/syntax/private/stxparse/rep.ss | 78 +++++++++++++------ .../syntax/private/stxparse/runtime-prose.ss | 11 +-- collects/syntax/private/stxparse/runtime.ss | 15 ++-- collects/syntax/scribblings/parse.scrbl | 25 +++--- 6 files changed, 116 insertions(+), 71 deletions(-) diff --git a/collects/syntax/private/stxparse/parse.ss b/collects/syntax/private/stxparse/parse.ss index 5fb6ed8f90..c0cdffde62 100644 --- a/collects/syntax/private/stxparse/parse.ss +++ b/collects/syntax/private/stxparse/parse.ss @@ -235,13 +235,13 @@ (if (equal? d (quote datum)) k (fail x - #:expect (expectation-of-constant datum) + #:expect (expectation pattern0) #:fce fc)))] [#s(pat:literal attrs literal) #`(if (and (identifier? x) (free-identifier=? x (quote-syntax literal))) k (fail x - #:expect (expectation-of-literal literal) + #:expect (expectation pattern0) #:fce fc))] [#s(pat:head attrs head tail) #`(parse:H x fc head rest index @@ -276,17 +276,17 @@ (let ([part part-expr] ...) (parse:S* (part ...) (part-fc ...) (part-pattern ...) k)) (fail x - #:expect (expectation-of-compound kind0 (part-pattern ...)) + #:expect (expectation pattern0) #:fce fc))))))] [#s(pat:cut attrs pattern) #`(with-enclosing-fail enclosing-cut-fail (parse:S x fc pattern k))] - [#s(pat:describe attrs description pattern) + [#s(pat:describe attrs description transparent? pattern) #`(let ([previous-fail enclosing-fail] [previous-cut-fail enclosing-cut-fail]) (define (new-fail failure) (fail x - #:expect (expectation-of-thing description #f failure) + #:expect (expectation-of-thing description transparent? failure) #:fce fc)) (with-enclosing-fail* new-fail (parse:S x #,(empty-frontier #'x) pattern @@ -298,7 +298,7 @@ [#s(pat:fail _ condition message) #`(if condition (fail x - #:expect (expectation-of-message message) + #:expect (expectation pattern0) #:fce fc) k)])])) @@ -347,12 +347,12 @@ (syntax-case stx () [(parse:H x fc head rest index k) (syntax-case #'head () - [#s(hpat:describe _ description pattern) + [#s(hpat:describe _ description transparent? pattern) #`(let ([previous-fail enclosing-fail] [previous-cut-fail enclosing-cut-fail]) (define (new-fail failure) (fail x - #:expect (expectation-of-thing description #f failure) + #:expect (expectation-of-thing description transparent? failure) #:fce fc)) (with-enclosing-fail* new-fail (parse:H x #,(empty-frontier #'x) pattern @@ -522,6 +522,24 @@ ;; ---- +;; (expectation Pattern) +(define-syntax (expectation stx) + (syntax-case stx () + [(_ #s(pat:datum attrs datum)) + #'(make-expect:atom 'datum)] + [(_ #s(pat:literal attrs literal)) + #'(make-expect:literal (quote-syntax literal))] + ;; 2 pat:compound patterns + ;;[(_ #s(pat:compound attrs #:pair (head-pattern tail-pattern))) + ;; #'(make-expect:pair)] + [(_ #s(pat:compound attrs kind0 (part-pattern ...))) + #''ineffable] + [(_ #s(pat:fail _ condition message)) + #'(expectation-of-message message)] + )) + +;; ---- + (define-syntax-rule (expectation-of-thing description transparent? chained) (make-expect:thing description transparent? chained)) @@ -529,18 +547,6 @@ (let ([msg message]) (if msg (make-expect:message msg) 'ineffable))) -(define-syntax-rule (expectation-of-constant constant) - (make-expect:atom 'constant)) - -(define-syntax-rule (expectation-of-literal literal) - (make-expect:literal (quote-syntax literal))) - -(define-syntax expectation-of-compound - (syntax-rules () - [(_ #:pair (head-pattern tail-pattern)) - (make-expect:pair)] - [(_ _ _) 'ineffable])) - (define-syntax expectation-of-reps/too-few (syntax-rules () [(_ rep #s(rep:once name too-few-msg too-many-msg)) diff --git a/collects/syntax/private/stxparse/rep-patterns.ss b/collects/syntax/private/stxparse/rep-patterns.ss index 7450f47902..695d2c0863 100644 --- a/collects/syntax/private/stxparse/rep-patterns.ss +++ b/collects/syntax/private/stxparse/rep-patterns.ss @@ -29,7 +29,7 @@ A SinglePattern is one of (make-pat:or SPBase (listof SinglePattern)) (make-pat:compound SPBase Kind (listof SinglePattern)) (make-pat:cut SPBase SinglePattern) - (make-pat:describe SPBase stx SinglePattern) + (make-pat:describe SPBase stx boolean SinglePattern) (make-pat:bind SPBase (listof clause:attr)) (make-pat:fail SPBase stx stx) @@ -52,7 +52,7 @@ A ListPattern is a subtype of SinglePattern; one of (define-struct pat:or (attrs patterns) #:prefab) (define-struct pat:compound (attrs kind patterns) #:prefab) (define-struct pat:cut (attrs pattern) #:prefab) -(define-struct pat:describe (attrs description pattern) #:prefab) +(define-struct pat:describe (attrs description transparent? pattern) #:prefab) (define-struct pat:bind (attrs clauses) #:prefab) (define-struct pat:fail (attrs when message) #:prefab) @@ -62,13 +62,13 @@ A HeadPattern is one of (make-hpat:ssc HPBase id id boolean boolean) (make-hpat:seq HPBase ListPattern) (make-hpat:or HPBase (listof HeadPattern)) - (make-hpat:describe HPBase stx/#f HeadPattern) + (make-hpat:describe HPBase stx/#f boolean HeadPattern) |# (define-struct hpat:ssc (attrs parser description bind-term? bind-attrs?) #:prefab) (define-struct hpat:seq (attrs inner) #:prefab) (define-struct hpat:or (attrs patterns) #:prefab) -(define-struct hpat:describe (attrs description pattern) #:prefab) +(define-struct hpat:describe (attrs description transparent? pattern) #:prefab) #| An EllipsisHeadPattern is @@ -76,13 +76,13 @@ An EllipsisHeadPattern is A RepConstraint is one of (make-rep:once stx stx stx) - (make-rep:optional stx stx) + (make-rep:optional stx stx (listof clause:attr)) (make-rep:bounds nat/#f nat/#f stx stx stx) #f |# (define-struct ehpat (attrs head repc) #:prefab) (define-struct rep:once (name under-message over-message) #:prefab) -(define-struct rep:optional (name over-message) #:prefab) +(define-struct rep:optional (name over-message #| defaults |#) #:prefab) (define-struct rep:bounds (min max name under-message over-message) #:prefab) diff --git a/collects/syntax/private/stxparse/rep.ss b/collects/syntax/private/stxparse/rep.ss index 63096f03e2..db1f9c4407 100644 --- a/collects/syntax/private/stxparse/rep.ss +++ b/collects/syntax/private/stxparse/rep.ss @@ -70,6 +70,7 @@ (quote-syntax ~rep) (quote-syntax ~once) (quote-syntax ~optional) + (quote-syntax ~bounds) (quote-syntax ~rest) (quote-syntax ~struct) (quote-syntax ~!) @@ -109,11 +110,14 @@ #:context ctx #:no-duplicates? #t)) (define desc0 (assq '#:description chunks)) - (define trans0 (assq '#:transparent chunks)) + ;; (define trans0 (assq '#:transparent chunks)) + (define opaque0 (assq '#:opaque chunks)) (define attrs0 (assq '#:attributes chunks)) (define auto-nested0 (assq '#:auto-nested-attributes chunks)) (define description (and desc0 (caddr desc0))) - (define transparent? (and trans0 #t)) + (define opaque? (and opaque0 #t)) + (define transparent? (not opaque?)) + ;;(define transparent? (and trans0 #t)) (define attributes (cond [(and attrs0 auto-nested0) (raise-syntax-error #f "cannot use both #:attributes and #:auto-nested-attributes" @@ -406,11 +410,21 @@ (define (parse-pat:describe stx decls allow-head?) (syntax-case stx () - [(_ description pattern) - (let ([p (parse-some-pattern #'pattern decls allow-head?)]) - (if (head-pattern? p) - (make hpat:describe (pattern-attrs p) #'description p) - (make pat:describe (pattern-attrs p) #'description p)))])) + [(_ . rest) + (let-values ([(chunks rest) + (parse-keyword-options #'rest describe-option-table + #:no-duplicates? #t + #:context stx)]) + (define trans0 (assq '#:transparent chunks)) + (define transparent? (and trans0 #t)) + (syntax-case rest () + [(description pattern) + (let ([p (parse-some-pattern #'pattern decls allow-head?)]) + (if (head-pattern? p) + (make hpat:describe (pattern-attrs p) + #'description transparent? p) + (make pat:describe (pattern-attrs p) + #'description transparent? p)))]))])) (define (parse-pat:or stx decls allow-head?) (define patterns (parse-cdr-patterns stx decls allow-head? #f)) @@ -500,17 +514,10 @@ (define (parse-pat:bind stx decls) (syntax-case stx () [(_ clause ...) - (parameterize ((current-syntax-context stx)) - (let ([clauses (map parse-bind-clause (syntax->list #'(clause ...)))]) - (make pat:bind - (append-iattrs (side-clauses-attrss clauses)) - clauses)))])) - -(define (parse-bind-clause clause) - (syntax-case clause () - [(attr-decl expr) - (make clause:attr (check-attr-arity #'attr-decl #f) #'expr)] - [_ (wrong-syntax clause "expected bind clause")])) + (let ([clauses (check-bind-clause-list #'(clause ...) stx)]) + (make pat:bind + (append-iattrs (side-clauses-attrss clauses)) + clauses))])) (define (parse-pat:fail stx decls) (syntax-case stx () @@ -576,17 +583,20 @@ [(~optional p . options) (let ([head (parse-head-pattern #'p decls)]) (define chunks - (parse-keyword-options/eol #'options - (list (list '#:too-many check-expression) - (list '#:name check-expression)) + (parse-keyword-options/eol #'options optional-directive-table + #:no-duplicates? #t #:context stx)) + #| + (define defaults + (car (options-select-one chunks '#:defaults #:default '(())))) + |# (with-syntax ([(too-many-msg) (options-select-one chunks '#:too-many #:default #'(#f))] [(name) (options-select-one chunks '#:name #:default #'(#f))]) (make ehpat (map attr-make-uncertain (pattern-attrs head)) head - (make rep:optional #'name #'too-many-msg))))])) + (make rep:optional #'name #'too-many-msg #| defaults |#))))])) (define (parse-ehpat/once stx decls) (syntax-case stx (~once) @@ -817,6 +827,19 @@ (list (check-conventions-pattern (syntax-e #'rx) #'rx) (check-sc-expr #'sc))])) +;; bind clauses +(define (check-bind-clause-list stx ctx) + (unless (stx-list? stx) + (raise-syntax-error #f "expected sequence of bind clauses" ctx stx)) + (for/list ([clause (stx->list stx)]) + (check-bind-clause clause ctx))) + +(define (check-bind-clause clause ctx) + (syntax-case clause () + [(attr-decl expr) + (make clause:attr (check-attr-arity #'attr-decl ctx) #'expr)] + [_ (raise-syntax-error #f "expected bind clause" ctx clause)])) + ;; common-parse-directive-table (define common-parse-directive-table (list (list '#:literals check-literals-list) @@ -832,6 +855,7 @@ (define rhs-directive-table (list* (list '#:description check-expression) (list '#:transparent) + (list '#:opaque) (list '#:attributes check-attr-arity-list) (list '#:auto-nested-attributes) common-parse-directive-table)) @@ -848,3 +872,13 @@ (define fail-directive-table (list (list '#:when check-expression) (list '#:unless check-expression))) + +;; describe-option-table +(define describe-option-table + (list (list '#:transparent))) + +;; optional-directive-table +(define optional-directive-table + (list (list '#:too-many check-expression) + (list '#:name check-expression) + #| (list '#:defaults check-bind-clause-list) |#)) diff --git a/collects/syntax/private/stxparse/runtime-prose.ss b/collects/syntax/private/stxparse/runtime-prose.ss index de5cfa0aa4..4a0b4f28c0 100644 --- a/collects/syntax/private/stxparse/runtime-prose.ss +++ b/collects/syntax/private/stxparse/runtime-prose.ss @@ -55,7 +55,7 @@ stx0 frontier-stx))] [else - (err #f stx0 stx0)])) + (err "bad syntax" stx0 stx0)])) ;; FIXME: try different selection/simplification algorithms/heuristics (define (simplify-failure f) @@ -115,10 +115,11 @@ ;; prose-for-expectation : Expectation syntax -> string/#f (define (prose-for-expectation e index stx) (cond [(expect? e) - (let ([parts - (for/list ([alt (expect->alternatives e)]) - (for-alternative alt index stx))]) - (join-sep parts ";" "or"))] + (let ([alts (expect->alternatives e)]) + (and alts + (join-sep (for/list ([alt alts]) + (for-alternative alt index stx)) + ";" "or")))] [(eq? e 'ineffable) #f])) diff --git a/collects/syntax/private/stxparse/runtime.ss b/collects/syntax/private/stxparse/runtime.ss index 47d611463a..d9767d09c7 100644 --- a/collects/syntax/private/stxparse/runtime.ss +++ b/collects/syntax/private/stxparse/runtime.ss @@ -2,6 +2,7 @@ (require scheme/contract scheme/match scheme/stxparam + scheme/list (for-syntax scheme/base syntax/stx scheme/private/sc @@ -238,20 +239,16 @@ An Expectation is one of ;; expect->alternatives : Expectation -> (listof Expectation)/#f ;; #f indicates 'ineffable somewhere in expectation (define (expect->alternatives e) - (define (loop e) + (define (loop-onto e rest) (cond [(expect:disj? e) - (union (expect->alternatives (expect:disj-a e)) - (expect->alternatives (expect:disj-b e)))] - [else (list e)])) - (let ([alts (loop e)]) + (loop-onto (expect:disj-a e) + (loop-onto (expect:disj-b e) rest))] + [else (cons e rest)])) + (let ([alts (remove-duplicates (loop-onto e null))]) (if (for/or ([alt alts]) (eq? alt 'ineffable)) #f alts))) -;; FIXME: n^2 use of union above -(define (union a b) - (append a (for/list ([x b] #:when (not (member x a))) x))) - (define (expectation-of-null? e) (or (equal? e '#s(expect:atom ())) (and (expect:disj? e) diff --git a/collects/syntax/scribblings/parse.scrbl b/collects/syntax/scribblings/parse.scrbl index 4eb62bcd19..bd2864fe92 100644 --- a/collects/syntax/scribblings/parse.scrbl +++ b/collects/syntax/scribblings/parse.scrbl @@ -578,15 +578,22 @@ pattern that the @scheme[#:declare] directive applies to. } -@specsubform[(code:line #:with syntax-pattern expr)]{ +@specsubform[(code:line #:with syntax-pattern stx-expr)]{ + +Evaluates the @scheme[stx-expr] in the context of all previous +attribute bindings and matches it against the pattern. If the match +succeeds, the pattern's attributes are added to environment for the +evaluation of subsequent side conditions. If the @scheme[#:with] match +fails, the matching process backtracks. Since a syntax object may +match a pattern in several ways, backtracking may cause the same +clause to be tried multiple times before the next clause is reached. +} + +@specsubform[(code:line #:attr attr-id expr)]{ Evaluates the @scheme[expr] in the context of all previous attribute -bindings and matches it against the pattern. If the match succeeds, -the pattern's attributes are added to environment for the evaluation -of subsequent side conditions. If the @scheme[#:with] match fails, the -matching process backtracks. Since a syntax object may match a pattern -in several ways, backtracking may cause the same clause to be tried -multiple times before the next clause is reached. +bindings and binds it to the attribute named by @scheme[attr-id]. The +value of @scheme[expr] need not be syntax. } @specsubform[(code:line #:fail-when condition-expr message-expr)] @@ -735,8 +742,8 @@ depth (zero if not explicitly specified). If the attributes are not explicitly listed, they are inferred as the set of all pattern variables occurring in every variant of the syntax class. Pattern variables that occur at different ellipsis depths are -not included, nor are nested attributes. - +not included. Only nested attributes from previously declared syntax +classes are included. } @specsubform[(code:line #:description description)]{