From 0f08499e54c01a8d52301a0469577658e48a7462 Mon Sep 17 00:00:00 2001 From: Ryan Culpepper Date: Mon, 8 Feb 2010 09:47:52 +0000 Subject: [PATCH] syntax/parse: started support for backtracking into syntax classes incomplete, need to separate descriptions from failure handlers svn: r18013 --- collects/syntax/keyword.ss | 1 + collects/syntax/parse/experimental.ss | 1 + collects/syntax/private/keyword.ss | 1 + collects/syntax/private/stxparse/parse.ss | 152 +++++++++++++----- collects/syntax/private/stxparse/rep-data.ss | 21 +-- .../syntax/private/stxparse/rep-patterns.ss | 16 +- collects/syntax/private/stxparse/rep.ss | 46 +++--- collects/syntax/private/stxparse/sc.ss | 9 +- collects/syntax/scribblings/keyword.scrbl | 7 + 9 files changed, 170 insertions(+), 84 deletions(-) diff --git a/collects/syntax/keyword.ss b/collects/syntax/keyword.ss index b112c32c03..b28c209378 100644 --- a/collects/syntax/keyword.ss +++ b/collects/syntax/keyword.ss @@ -58,4 +58,5 @@ [check-expression checker] [check-identifier checker] [check-stx-string checker] + [check-stx-boolean checker] [check-stx-listof (-> checker checker)]) diff --git a/collects/syntax/parse/experimental.ss b/collects/syntax/parse/experimental.ss index 90ca5cdf76..d067d00eec 100644 --- a/collects/syntax/parse/experimental.ss +++ b/collects/syntax/parse/experimental.ss @@ -37,6 +37,7 @@ '(#s(attr a.name a.depth #f) ...) (quote-syntax parser) (quote-syntax get-description) + #t #t)))])) diff --git a/collects/syntax/private/keyword.ss b/collects/syntax/private/keyword.ss index 4626f1b9c0..be810c58df 100644 --- a/collects/syntax/private/keyword.ss +++ b/collects/syntax/private/keyword.ss @@ -12,6 +12,7 @@ check-expression check-identifier + check-stx-boolean check-stx-string check-stx-listof) diff --git a/collects/syntax/private/stxparse/parse.ss b/collects/syntax/private/stxparse/parse.ss index ac002b221f..c01a6fbf72 100644 --- a/collects/syntax/private/stxparse/parse.ss +++ b/collects/syntax/private/stxparse/parse.ss @@ -44,56 +44,88 @@ [(fail x #:expect p #:fce fce) #'(enclosing-fail (make-failure x fce p))])) +;; ---- + +#| + +syntax-class protocol +--------------------- + +for syntax-class SC with args (P ...) + +if commit? = #t + parser : Stx P ... -> (U list expectation) +if commit? = #f + parser : Stx ((U list expect) FailFunction -> Answer) P ... -> Answer + +|# + ;; (parse:rhs RHS (SAttr ...) (id ...) id boolean) ;; : expr[(values ParseFunction DescriptionFunction)] ;; Takes a list of the relevant attrs; order is significant! ;; Returns either fail or a list having length same as 'relsattrs' (define-syntax (parse:rhs stx) (syntax-case stx () - [(parse:rhs #s(rhs _ _ transparent? _ variants (def ...)) + [(parse:rhs #s(rhs _ _ transparent? _ variants (def ...) commit?) relsattrs (arg ...) get-description splicing?) - #`(with-error-collector - (make-parser - (lambda (x arg ...) - (define (fail-rhs failure) + (with-syntax ([(k-param ...) + (if (syntax-e #'commit?) + #'() + #'(return))] + [k-ref/fail + (if (syntax-e #'commit?) + #'values + #'return)] + [k-ref/ok + (if (syntax-e #'commit?) + #'values + #'(lambda (result) (return (cons enclosing-fail result))))]) + #| #`(with-error-collector + (make-parser + (lambda ___) + (collect-error))) + |# + #'(lambda (x k-param ... arg ...) + (define (fail-rhs failure) + (k-ref/fail (expectation-of-thing (get-description arg ...) transparent? - (if transparent? failure #f))) - def ... - (syntax-parameterize ((this-syntax (make-rename-transformer #'x))) - (with-enclosing-fail* fail-rhs - (parse:variants x relsattrs variants splicing?)))) - (collect-error)))])) + (if transparent? failure #f)))) + def ... + (syntax-parameterize ((this-syntax (make-rename-transformer #'x))) + (with-enclosing-fail* fail-rhs + (parse:variants x relsattrs variants splicing? k-ref/ok)))))])) ;; (parse:variants id (SAttr ...) (Variant ...) boolean) ;; : expr[SyntaxClassResult] (define-syntax (parse:variants stx) (syntax-case stx () - [(parse:variants x relsattrs (variant ...) splicing?) - #'(try (parse:variant x relsattrs variant splicing?) ...)])) + [(parse:variants x relsattrs (variant ...) splicing? k-ref) + #'(try (parse:variant x relsattrs variant splicing? k-ref) ...)])) (define-syntax (parse:variant stx) (syntax-case stx () - [(parse:variant x relsattrs variant #f) + [(parse:variant x relsattrs variant #f k-ref) (with-syntax ([#s(variant _ _ pattern _ (def ...)) #'variant]) #`(let ([fc (dfc-empty x)]) def ... - (parse:S x fc pattern (variant-success x relsattrs variant ()))))] - [(parse:variant x relsattrs variant #t) + (parse:S x fc pattern (variant-success x relsattrs variant () k-ref))))] + [(parse:variant x relsattrs variant #t k-ref) (with-syntax ([#s(variant _ _ pattern _ (def ...)) #'variant]) #`(let ([fc (dfc-empty x)]) def ... (parse:H x fc pattern rest index - (variant-success x relsattrs variant (rest index)))))])) + (variant-success x relsattrs variant (rest index) k-ref))))])) ;; (variant-success id (SAttr ...) Variant (expr ...)) : expr[SyntaxClassResult] (define-syntax (variant-success stx) (syntax-case stx () - [(variant-success x relsattrs #s(variant _ _ pattern sides _) (also ...)) + [(variant-success x relsattrs #s(variant _ _ pattern sides _) (also ...) k-ref) #`(convert-sides x sides (base-success-expr #,(pattern-attrs (wash #'pattern)) relsattrs - (also ...)))])) + (also ...) + k-ref))])) ;; (convert-sides id (Side ...) (m (IAttr ...) . MArgs)) : expr[X] ;; where (m (IAttr ...) MArgs) : expr[X] @@ -126,12 +158,12 @@ ;; (base-success-expr (IAttr ...) (SAttr ...) (expr ...) : expr[SCResult] (define-syntax (base-success-expr stx) (syntax-case stx () - [(base-success-expr iattrs relsattrs (also ...)) + [(base-success-expr iattrs relsattrs (also ...) k-ref) (let ([reliattrs (reorder-iattrs (wash-sattrs #'relsattrs) (wash-iattrs #'iattrs))]) (with-syntax ([(#s(attr name _ _) ...) reliattrs]) - #'(list also ... (attribute name) ...)))])) + #'(k-ref (list also ... (attribute name) ...))))])) ;; ---- @@ -209,18 +241,34 @@ (parse:S x fc pattern k))] [#s(pat:any attrs) #'k] - [#s(pat:var _attrs name #f () ()) + [#s(pat:var _attrs name #f () () _) #'(let-attributes ([#s(attr name 0 #t) x]) k)] - [#s(pat:var _attrs name parser (arg ...) (nested-a ...)) - #`(let ([result (parser x arg ...)]) - (if (ok? result) - (let-attributes (#,@(if (identifier? #'name) - #'([#s(attr name 0 #t) x]) - #'())) - (let/unpack ((nested-a ...) result) - k)) - (fail x #:expect result #:fce fc)))] + [#s(pat:var _attrs name parser (arg ...) (nested-a ...) commit?) + (with-syntax* ([(name-attr ...) + (if (identifier? #'name) + #'([#s(attr name 0 #t) x]) + #'())] + [ok-e + #'(let-attributes (name-attr ...) + (let/unpack ((nested-a ...) result) + k))] + [fail-e + #'(fail x #:expect result #:fce fc)]) + (if (syntax-e #'commit?) + #'(let ([result (parser x arg ...)]) + (if (ok? result) + ok-e + fail-e)) + #'(parser x + (lambda (result) + (if (ok? result) + (let ([fail-k (car result)] + [result (cdr result)]) + (with-enclosing-fail fail-k + ok-e)) + fail-e)) + arg ...)))] [#s(pat:datum attrs datum) #`(let ([d (syntax->datum x)]) (if (equal? d (quote datum)) @@ -387,19 +435,35 @@ (with-enclosing-cut-fail previous-cut-fail (with-enclosing-fail previous-fail k))))))] - [#s(hpat:var _attrs name parser (arg ...) (nested-a ...)) - #`(let ([result (parser x arg ...)]) - (if (ok? result) - (let* ([rest (car result)] - [local-fc (cadr result)] - [rest-fc (dfc-append fc local-fc)]) - (let-attributes (#,@(if (identifier? #'name) - #'([#s(attr name 0 #t) - (stx-list-take x (dfc->index local-fc))]) - #'())) - (let/unpack ((nested-a ...) (cddr result)) - k))) - (fail x #:expect result #:fce fc)))] + [#s(hpat:var _attrs name parser (arg ...) (nested-a ...) commit?) + (with-syntax* ([(name-attr ...) + (if (identifier? #'name) + #'([#s(attr name 0 #t) + (stx-list-take x (dfc->index local-fc))]) + #'())] + [ok-e + #'(let* ([rest (car result)] + [local-fc (cadr result)] + [rest-fc (dfc-append fc local-fc)]) + (let-attributes (name-attr ...) + (let/unpack ((nested-a ...) (cddr result)) + k)))] + [fail-e + #'(fail x #:expect result #:fce fc)]) + (if (syntax-e #'commit?) + #'(let ([result (parser x arg ...)]) + (if (ok? result) + ok-e + fail-e)) + #'(parser x + (lambda (result) + (if (ok? result) + (let ([fail-k (car result)] + [result (cdr result)]) + (with-enclosing-fail fail-k + ok-e)) + fail-e)) + arg ...)))] [#s(hpat:and (a ...) head single) #`(parse:H x fc head rest rest-fc (let ([lst (stx-list-take x (dfc-difference fc rest-fc))]) diff --git a/collects/syntax/private/stxparse/rep-data.ss b/collects/syntax/private/stxparse/rep-data.ss index 1d4330d088..1f2bf750f4 100644 --- a/collects/syntax/private/stxparse/rep-data.ss +++ b/collects/syntax/private/stxparse/rep-data.ss @@ -23,9 +23,10 @@ #| A stxclass is - (make-sc symbol (listof symbol) (list-of SAttr) identifier identifier boolean) + (make-sc symbol (listof symbol) (list-of SAttr) identifier identifier boolean boolean) |# -(define-struct stxclass (name params attrs parser-name description splicing?) +(define-struct stxclass (name params attrs parser-name description + splicing? commit?) #:prefab) (define (stxclass/s? x) @@ -38,7 +39,7 @@ An RHS is (make-rhs stx (listof SAttr) boolean stx/#f (listof Variant) (listof stx)) definitions: auxiliary definitions from #:declare |# -(define-struct rhs (ostx attrs transparent? description variants definitions) +(define-struct rhs (ostx attrs transparent? description variants definitions commit?) #:prefab) #| @@ -73,7 +74,7 @@ A LiteralSet is ;; make-dummy-stxclass : identifier -> SC ;; Dummy stxclass for calculating attributes of recursive stxclasses. (define (make-dummy-stxclass name) - (make stxclass (syntax-e name) null null #f #f #f)) + (make stxclass (syntax-e name) null null #f #f #f #t)) ;; Environments @@ -86,13 +87,13 @@ DeclEnv = DeclEntry = (make-den:lit id id) (make-den:class id id (listof syntax) bool) - (make-den:parser id id (listof SAttr) bool) + (make-den:parser id id (listof SAttr) bool bool) |# (define-struct declenv (table conventions)) (define-struct den:lit (internal external)) (define-struct den:class (name class args)) -(define-struct den:parser (parser description attrs splicing?)) +(define-struct den:parser (parser description attrs splicing? commit?)) (define (new-declenv literals #:conventions [conventions null]) (for/fold ([decls (make-declenv (make-immutable-bound-id-table) conventions)]) @@ -119,7 +120,7 @@ DeclEntry = stxclass-name) (wrong-syntax (if blame-declare? name id) "identifier previously declared"))] - [(struct den:parser (_p _d _a _sp)) + [(struct den:parser (_p _d _a _sp _c)) (wrong-syntax id "(internal error) late unbound check")] ['#f (void)]))) @@ -137,11 +138,11 @@ DeclEntry = (make den:class id stxclass-name args)) (declenv-conventions env))) -(define (declenv-put-parser env id parser get-description attrs splicing?) +(define (declenv-put-parser env id parser get-description attrs splicing? commit?) ;; no unbound check, since replacing 'stxclass entry (make-declenv (bound-id-table-set (declenv-table env) id - (make den:parser parser get-description attrs splicing?)) + (make den:parser parser get-description attrs splicing? commit?)) (declenv-conventions env))) ;; declenv-update/fold : DeclEnv (Id/Regexp DeclEntry a -> DeclEntry a) a @@ -212,7 +213,7 @@ DeclEntry = (-> DeclEnv/c identifier? identifier? DeclEnv/c)] [declenv-put-parser - (-> DeclEnv/c identifier? any/c any/c (listof sattr?) boolean? + (-> DeclEnv/c identifier? any/c any/c (listof sattr?) boolean? boolean? DeclEnv/c)] [declenv-domain-difference (-> DeclEnv/c (listof identifier?) diff --git a/collects/syntax/private/stxparse/rep-patterns.ss b/collects/syntax/private/stxparse/rep-patterns.ss index da3be9f1f8..b789e7235b 100644 --- a/collects/syntax/private/stxparse/rep-patterns.ss +++ b/collects/syntax/private/stxparse/rep-patterns.ss @@ -16,7 +16,7 @@ A Base is (listof IAttr) #| A SinglePattern is one of (make-pat:any Base) - (make-pat:var Base id id (listof stx) (listof IAttr)) + (make-pat:var Base id id (listof stx) (listof IAttr) bool) (make-pat:literal Base identifier) (make-pat:datum Base datum) (make-pat:ghost Base GhostPattern SinglePattern) @@ -37,7 +37,7 @@ A ListPattern is a subtype of SinglePattern; one of |# (define-struct pat:any (attrs) #:prefab) -(define-struct pat:var (attrs name parser args nested-attrs) #:prefab) +(define-struct pat:var (attrs name parser args nested-attrs commit?) #:prefab) (define-struct pat:literal (attrs id) #:prefab) (define-struct pat:datum (attrs datum) #:prefab) (define-struct pat:ghost (attrs ghost inner) #:prefab) @@ -68,7 +68,7 @@ ghost:and is desugared below in create-* procedures #| A HeadPattern is one of - (make-hpat:var Base id id (listof stx) (listof IAttr)) + (make-hpat:var Base id id (listof stx) (listof IAttr) bool) (make-hpat:seq Base ListPattern) (make-hpat:ghost Base GhostPattern HeadPattern) (make-hpat:and Base HeadPattern SinglePattern) @@ -77,7 +77,7 @@ A HeadPattern is one of (make-hpat:describe Base stx/#f boolean HeadPattern) |# -(define-struct hpat:var (attrs name parser args nested-attrs) #:prefab) +(define-struct hpat:var (attrs name parser args nested-attrs commit?) #:prefab) (define-struct hpat:seq (attrs inner) #:prefab) (define-struct hpat:ghost (attrs ghost inner) #:prefab) (define-struct hpat:and (attrs head single) #:prefab) @@ -178,10 +178,10 @@ A Kind is one of (define (create-pat:any) (make pat:any null)) -(define (create-pat:var name parser args nested-attrs) +(define (create-pat:var name parser args nested-attrs commit?) (let ([attrs (if name (cons (make attr name 0 #t) nested-attrs) nested-attrs)]) - (make pat:var attrs name parser args nested-attrs))) + (make pat:var attrs name parser args nested-attrs commit?))) (define (create-pat:datum datum) (make pat:datum null datum)) @@ -239,10 +239,10 @@ A Kind is one of ;; ---- -(define (create-hpat:var name parser args nested-attrs) +(define (create-hpat:var name parser args nested-attrs commit?) (let ([attrs (if name (cons (make attr name 0 #t) nested-attrs) nested-attrs)]) - (make hpat:var attrs name parser args nested-attrs))) + (make hpat:var attrs name parser args nested-attrs commit?))) (define (create-hpat:seq lp) (make hpat:seq (pattern-attrs lp) lp)) diff --git a/collects/syntax/private/stxparse/rep.ss b/collects/syntax/private/stxparse/rep.ss index ec1ce9f8f5..f165d41096 100644 --- a/collects/syntax/private/stxparse/rep.ss +++ b/collects/syntax/private/stxparse/rep.ss @@ -124,8 +124,9 @@ ;; parser requires stxclasses to be bound. (define (parse-rhs stx expected-attrs splicing? #:context ctx) (parameterize ((current-syntax-context ctx)) - (define-values (rest description transp? attributes auto-nested? decls defs) - (parse-rhs/part1 stx (and expected-attrs #t))) + (define-values (rest description transp? attributes auto-nested? + decls defs commit?) + (parse-rhs/part1 stx splicing? (and expected-attrs #t))) (define patterns (parameterize ((stxclass-lookup-config (cond [expected-attrs 'yes] @@ -137,9 +138,9 @@ (let ([sattrs (or attributes (intersect-sattrss (map variant-attrs patterns)))]) - (make rhs stx sattrs transp? description patterns defs)))) + (make rhs stx sattrs transp? description patterns defs commit?)))) -(define (parse-rhs/part1 stx strict?) +(define (parse-rhs/part1 stx splicing? strict?) (define-values (chunks rest) (parse-keyword-options stx rhs-directive-table #:context (current-syntax-context) @@ -149,9 +150,11 @@ (define opaque? (and (assq '#:opaque chunks) #t)) (define transparent? (not opaque?)) (define auto-nested? (and (assq '#:auto-nested-attributes chunks) #t)) + (define commit? ;; FIXME: default value should be (not splicing?) once this works + (options-select-value chunks '#:commit? #:default #t)) (define attributes (options-select-value chunks '#:attributes #:default #f)) (define-values (decls defs) (get-decls+defs chunks strict?)) - (values rest description transparent? attributes auto-nested? decls defs)) + (values rest description transparent? attributes auto-nested? decls defs commit?)) (define (parse-variants rest decls splicing? expected-attrs) (define (gather-patterns stx) @@ -218,13 +221,15 @@ [description (generate-temporary class)] [(arg ...) args]) (values (make den:parser #'parser #'description - (stxclass-attrs sc) (stxclass/h? sc)) + (stxclass-attrs sc) (stxclass/h? sc) + (stxclass-commit? sc)) (list #'(define (parser x) (sc-parser x arg ...)) #'(define (description) (description arg ...))))) (values (make den:parser #'sc-parser #'sc-description - (stxclass-attrs sc) (stxclass/h? sc)) + (stxclass-attrs sc) (stxclass/h? sc) + (stxclass-commit? sc)) null))))] - [(struct den:parser (_p _d _a _sp)) + [(struct den:parser (_p _d _a _sp _c)) (values entry null)])) (define (append-lits+litsets lits litsets) @@ -444,10 +449,10 @@ (error 'parse-pat:id "(internal error) decls had leftover stxclass entry: ~s" entry)] - [(struct den:parser (parser desc attrs splicing?)) + [(struct den:parser (parser desc attrs splicing? commit?)) (if splicing? - (parse-pat:id/h id parser null attrs) - (parse-pat:id/s id parser null attrs))] + (parse-pat:id/h id parser null attrs commit?) + (parse-pat:id/s id parser null attrs commit?))] ['#f (when #t ;; FIXME: right place??? (unless (safe-name? id) @@ -455,7 +460,7 @@ (let-values ([(name sc) (split-id/get-stxclass id decls)]) (if sc (parse-pat:var* id allow-head? name sc null) - (create-pat:var name #f null null)))])) + (create-pat:var name #f null null #t)))])) (define (parse-pat:var stx decls allow-head?) (define name0 @@ -486,31 +491,33 @@ (let ([sc (get-stxclass/check-arg-count scname (length args))]) (parse-pat:var* stx allow-head? name0 sc args))] [else ;; Just proper name - (create-pat:var name0 #f null null)])) + (create-pat:var name0 #f null null #t)])) (define (parse-pat:var* stx allow-head? name sc args) (cond [(stxclass/s? sc) (parse-pat:id/s name (stxclass-parser-name sc) args - (stxclass-attrs sc))] + (stxclass-attrs sc) + (stxclass-commit? sc))] [(stxclass/h? sc) (unless allow-head? (wrong-syntax stx "splicing syntax class not allowed here")) (parse-pat:id/h name (stxclass-parser-name sc) args - (stxclass-attrs sc))])) + (stxclass-attrs sc) + (stxclass-commit? sc))])) -(define (parse-pat:id/s name parser args attrs) +(define (parse-pat:id/s name parser args attrs commit?) (define prefix (name->prefix name)) (define bind (name->bind name)) - (create-pat:var bind parser args (id-pattern-attrs attrs prefix))) + (create-pat:var bind parser args (id-pattern-attrs attrs prefix) commit?)) -(define (parse-pat:id/h name parser args attrs) +(define (parse-pat:id/h name parser args attrs commit?) (define prefix (name->prefix name)) (define bind (name->bind name)) - (create-hpat:var bind parser args (id-pattern-attrs attrs prefix))) + (create-hpat:var bind parser args (id-pattern-attrs attrs prefix) commit?)) (define (name->prefix id) (cond [(wildcard? id) #f] @@ -1038,6 +1045,7 @@ (list '#:opaque) (list '#:attributes check-attr-arity-list) (list '#:auto-nested-attributes) + (list '#:commit? check-stx-boolean) common-parse-directive-table)) ;; pattern-directive-table diff --git a/collects/syntax/private/stxparse/sc.ss b/collects/syntax/private/stxparse/sc.ss index 16dd9ec823..f245c7fe99 100644 --- a/collects/syntax/private/stxparse/sc.ss +++ b/collects/syntax/private/stxparse/sc.ss @@ -59,13 +59,15 @@ (parse-rhs #'rhss #f splicing? #:context stx))]) (with-syntax ([parser (generate-temporary (format-symbol "parse-~a" (syntax-e #'name)))] - [attrs (rhs-attrs the-rhs)]) + [attrs (rhs-attrs the-rhs)] + [commit? (rhs-commit? the-rhs)]) #`(begin (define-syntax name (make stxclass 'name '(arg ...) 'attrs ((syntax-local-certifier) (quote-syntax parser)) ((syntax-local-certifier) (quote-syntax description)) - '#,splicing?)) + '#,splicing? + 'commit?)) (define-values (parser description) (functions/rhs name (arg ...) attrs rhss #,splicing? #,stx)))))))) @@ -103,7 +105,8 @@ (quote-syntax #,(den:parser-parser den)) (quote-syntax #,(den:parser-description den)) (quote #,(den:parser-attrs den)) - (quote #,(den:parser-splicing? den)))) + (quote #,(den:parser-splicing? den)) + (quote #,(den:parser-commit? den)))) defs))))]) #'(begin def ... ... diff --git a/collects/syntax/scribblings/keyword.scrbl b/collects/syntax/scribblings/keyword.scrbl index 1c4a215b96..de18ed1ce1 100644 --- a/collects/syntax/scribblings/keyword.scrbl +++ b/collects/syntax/scribblings/keyword.scrbl @@ -268,3 +268,10 @@ original procedure accepted. A @techlink{check-procedure} that accepts syntax strings. } + +@defproc[(check-stx-boolean [stx syntax?] [ctx (or/c false/c syntax?)]) + syntax?]{ + +A @techlink{check-procedure} that accepts syntax booleans. + +}