From d7a87c79e0211071fecb8474e6f7f66317b089d4 Mon Sep 17 00:00:00 2001 From: Ryan Culpepper Date: Mon, 30 Aug 2010 22:47:23 -0600 Subject: [PATCH] Merged changes to syntax/parse Changed backtracking algorithm, runtime representations - syntax classes, ~describe no longer implicitly commit - ~describe no longer delimits effect of cut Added keyword & optional args for stxclasses Added ~do and #:do, ~post, ~commit and #:commit, ~delimit-cut and #:no-delimit-cut Added syntax/parse/debug, syntax/parse/experimental/* - expr/c for contracting macro sub-expressions moved from syntax/parse to syntax/parse/experimental/contract - syntax class reflection (~reflect, ~splicing-reflect) - eh-alternative-sets (~eh-var) - provide-syntax-class/contract (only for params, not attrs so far) Changed ~fail to not include POST progress (#:fail still does) old (~fail _) is now (~post (~fail _)) Made msg argument of ~fail optional Removed generic "repetition constraint violated" msg Removed atom-in-list stxclass Removed unnecessary datum->syntax on cdr of pair pattern massive improvements to long-list microbenchmarks Optimization: integrable syntax classes (id, expr, keyword) need better measurements Optimization: ad hoc elimination of head/tail choice point for (EH ... . ()) patterns Added unstable/wrapc (proc version of expr/c) --- .../model/reductions-engine.rkt | 3 +- collects/meta/props | 4 + collects/syntax/parse.rkt | 19 +- collects/syntax/parse/debug.rkt | 106 ++ collects/syntax/parse/experimental.rkt | 98 +- .../syntax/parse/experimental/contract.rkt | 35 + collects/syntax/parse/experimental/eh.rkt | 78 ++ .../syntax/parse/experimental/provide.rkt | 160 +++ .../syntax/parse/experimental/reflect.rkt | 118 +++ .../syntax/parse/experimental/splicing.rkt | 71 ++ collects/syntax/parse/private/keywords.rkt | 37 + collects/syntax/parse/private/kws.rkt | 176 ++++ collects/syntax/parse/private/lib.rkt | 86 ++ collects/syntax/parse/private/litconv.rkt | 137 +++ .../stxparse => parse/private}/minimatch.rkt | 27 +- collects/syntax/parse/private/parse.rkt | 781 +++++++++++++++ .../stxparse => parse/private}/rep-attrs.rkt | 39 +- .../stxparse => parse/private}/rep-data.rkt | 163 ++-- .../syntax/parse/private/rep-patterns.rkt | 383 ++++++++ .../stxparse => parse/private}/rep.rkt | 908 ++++++++++++------ .../syntax/parse/private/runtime-failure.rkt | 200 ++++ .../syntax/parse/private/runtime-progress.rkt | 266 +++++ .../syntax/parse/private/runtime-reflect.rkt | 108 +++ .../syntax/parse/private/runtime-report.rkt | 131 +++ collects/syntax/parse/private/runtime.rkt | 340 +++++++ collects/syntax/parse/private/sc.rkt | 142 +++ .../util => parse/private}/txlift.rkt | 0 collects/syntax/parse/todo.txt | 35 + .../syntax/private/stxparse/codegen-data.rkt | 44 - collects/syntax/private/stxparse/lib.rkt | 144 --- collects/syntax/private/stxparse/parse.rkt | 709 -------------- .../syntax/private/stxparse/rep-patterns.rkt | 280 ------ .../syntax/private/stxparse/runtime-prose.rkt | 238 ----- collects/syntax/private/stxparse/runtime.rkt | 652 ------------- collects/syntax/private/stxparse/sc.rkt | 291 ------ collects/syntax/scribblings/parse.scrbl | 903 +---------------- collects/syntax/scribblings/parse/debug.scrbl | 56 ++ .../syntax/scribblings/parse/ex-exprc.scrbl | 42 + .../syntax/scribblings/parse/ex-kw-args.scrbl | 86 ++ .../scribblings/parse/ex-many-kws.scrbl | 137 +++ .../parse/ex-mods-stxclasses.scrbl | 107 +++ .../syntax/scribblings/parse/ex-uniform.scrbl | 143 +++ .../syntax/scribblings/parse/ex-varied.scrbl | 107 +++ .../syntax/scribblings/parse/examples.scrbl | 27 + .../scribblings/parse/experimental.scrbl | 258 +++++ collects/syntax/scribblings/parse/intro.scrbl | 353 +++++++ collects/syntax/scribblings/parse/lib.scrbl | 75 ++ .../syntax/scribblings/parse/litconv.scrbl | 122 +++ .../syntax/scribblings/parse/parse-common.rkt | 116 +++ .../parse/parse-dummy-bindings.rkt | 4 + .../syntax/scribblings/parse/parsing.scrbl | 462 +++++++++ .../patterns.scrbl} | 291 +++--- collects/tests/stxparse/litset-phases.rkt | 21 + collects/tests/stxparse/select.rkt | 26 +- collects/tests/stxparse/setup.rkt | 131 +++ collects/tests/stxparse/stress.rkt | 248 +++++ collects/tests/stxparse/stxclass.rkt | 71 +- .../{more-tests.rkt => test-errors.rkt} | 79 +- collects/tests/stxparse/test-exp.rkt | 79 ++ collects/tests/stxparse/test.rkt | 282 ++++-- collects/unstable/scribblings/unstable.scrbl | 1 + collects/unstable/scribblings/wrapc.scrbl | 124 +++ collects/unstable/syntax.rkt | 9 +- collects/unstable/wrapc.rkt | 95 ++ 64 files changed, 7407 insertions(+), 4057 deletions(-) create mode 100644 collects/syntax/parse/debug.rkt create mode 100644 collects/syntax/parse/experimental/contract.rkt create mode 100644 collects/syntax/parse/experimental/eh.rkt create mode 100644 collects/syntax/parse/experimental/provide.rkt create mode 100644 collects/syntax/parse/experimental/reflect.rkt create mode 100644 collects/syntax/parse/experimental/splicing.rkt create mode 100644 collects/syntax/parse/private/keywords.rkt create mode 100644 collects/syntax/parse/private/kws.rkt create mode 100644 collects/syntax/parse/private/lib.rkt create mode 100644 collects/syntax/parse/private/litconv.rkt rename collects/syntax/{private/stxparse => parse/private}/minimatch.rkt (78%) create mode 100644 collects/syntax/parse/private/parse.rkt rename collects/syntax/{private/stxparse => parse/private}/rep-attrs.rkt (86%) rename collects/syntax/{private/stxparse => parse/private}/rep-data.rkt (67%) create mode 100644 collects/syntax/parse/private/rep-patterns.rkt rename collects/syntax/{private/stxparse => parse/private}/rep.rkt (55%) create mode 100644 collects/syntax/parse/private/runtime-failure.rkt create mode 100644 collects/syntax/parse/private/runtime-progress.rkt create mode 100644 collects/syntax/parse/private/runtime-reflect.rkt create mode 100644 collects/syntax/parse/private/runtime-report.rkt create mode 100644 collects/syntax/parse/private/runtime.rkt create mode 100644 collects/syntax/parse/private/sc.rkt rename collects/syntax/{private/util => parse/private}/txlift.rkt (100%) create mode 100644 collects/syntax/parse/todo.txt delete mode 100644 collects/syntax/private/stxparse/codegen-data.rkt delete mode 100644 collects/syntax/private/stxparse/lib.rkt delete mode 100644 collects/syntax/private/stxparse/parse.rkt delete mode 100644 collects/syntax/private/stxparse/rep-patterns.rkt delete mode 100644 collects/syntax/private/stxparse/runtime-prose.rkt delete mode 100644 collects/syntax/private/stxparse/runtime.rkt delete mode 100644 collects/syntax/private/stxparse/sc.rkt create mode 100644 collects/syntax/scribblings/parse/debug.scrbl create mode 100644 collects/syntax/scribblings/parse/ex-exprc.scrbl create mode 100644 collects/syntax/scribblings/parse/ex-kw-args.scrbl create mode 100644 collects/syntax/scribblings/parse/ex-many-kws.scrbl create mode 100644 collects/syntax/scribblings/parse/ex-mods-stxclasses.scrbl create mode 100644 collects/syntax/scribblings/parse/ex-uniform.scrbl create mode 100644 collects/syntax/scribblings/parse/ex-varied.scrbl create mode 100644 collects/syntax/scribblings/parse/examples.scrbl create mode 100644 collects/syntax/scribblings/parse/experimental.scrbl create mode 100644 collects/syntax/scribblings/parse/intro.scrbl create mode 100644 collects/syntax/scribblings/parse/lib.scrbl create mode 100644 collects/syntax/scribblings/parse/litconv.scrbl create mode 100644 collects/syntax/scribblings/parse/parse-common.rkt create mode 100644 collects/syntax/scribblings/parse/parse-dummy-bindings.rkt create mode 100644 collects/syntax/scribblings/parse/parsing.scrbl rename collects/syntax/scribblings/{parse-patterns.scrbl => parse/patterns.scrbl} (78%) create mode 100644 collects/tests/stxparse/litset-phases.rkt create mode 100644 collects/tests/stxparse/setup.rkt create mode 100644 collects/tests/stxparse/stress.rkt rename collects/tests/stxparse/{more-tests.rkt => test-errors.rkt} (74%) create mode 100644 collects/tests/stxparse/test-exp.rkt create mode 100644 collects/unstable/scribblings/wrapc.scrbl create mode 100644 collects/unstable/wrapc.rkt diff --git a/collects/macro-debugger/model/reductions-engine.rkt b/collects/macro-debugger/model/reductions-engine.rkt index c51b318323..5970a70a3e 100644 --- a/collects/macro-debugger/model/reductions-engine.rkt +++ b/collects/macro-debugger/model/reductions-engine.rkt @@ -1,6 +1,7 @@ #lang racket/base (require (for-syntax racket/base - syntax/parse) + syntax/parse + syntax/parse/experimental/contract) racket/list racket/contract "deriv.rkt" diff --git a/collects/meta/props b/collects/meta/props index 0d85253513..e2c1c4d610 100755 --- a/collects/meta/props +++ b/collects/meta/props @@ -1318,6 +1318,10 @@ path/s is either such a string or a list of them. "collects/swindle" responsible (eli) "collects/swindle/tool.rkt" drdr:command-line (gracket-text "-t" *) "collects/syntax" responsible (mflatt) +"collects/syntax/parse" responsible (ryanc) +"collects/syntax/parse.rkt" responsible (ryanc) +"collects/syntax/scribblings/parse" responsible (ryanc) +"collects/syntax/scribblings/parse.scrbl" responsible (ryanc) "collects/syntax-color" responsible (mflatt) "collects/teachpack" responsible (matthias) "collects/teachpack/2htdp/scribblings/image-gen.rkt" responsible (robby) drdr:command-line (gracket-text *) diff --git a/collects/syntax/parse.rkt b/collects/syntax/parse.rkt index 85838ccdee..b528ba353c 100644 --- a/collects/syntax/parse.rkt +++ b/collects/syntax/parse.rkt @@ -1,6 +1,13 @@ - -#lang scheme/base -(require "private/stxparse/sc.ss" - "private/stxparse/lib.ss") -(provide (all-from-out "private/stxparse/sc.ss") - (all-from-out "private/stxparse/lib.ss")) +#lang racket/base +(require racket/contract/base + "parse/private/sc.rkt" + "parse/private/litconv.rkt" + "parse/private/lib.rkt" + "parse/experimental/provide.rkt") +(provide (except-out (all-from-out "parse/private/sc.rkt") + parser/rhs) + (all-from-out "parse/private/litconv.rkt") + (except-out (all-from-out "parse/private/lib.rkt") + static)) +(provide-syntax-class/contract + [static (syntax-class/c [(-> any/c any/c) (or/c string? symbol? #f)])]) diff --git a/collects/syntax/parse/debug.rkt b/collects/syntax/parse/debug.rkt new file mode 100644 index 0000000000..1054e045f5 --- /dev/null +++ b/collects/syntax/parse/debug.rkt @@ -0,0 +1,106 @@ +#lang racket/base +(require (for-syntax racket/base + racket/private/sc + syntax/stx + unstable/syntax + unstable/struct + "private/rep-data.rkt" + "private/rep.rkt" + "private/kws.rkt") + racket/list + syntax/stx + unstable/markparam + "../parse.rkt" + "private/parse.rkt" + "private/keywords.rkt" + "private/runtime.rkt" + "private/runtime-progress.rkt" + "private/runtime-report.rkt" + "private/kws.rkt") + +(provide syntax-class-parse + syntax-class-attributes + syntax-class-arity + syntax-class-keywords + + debug-rhs + debug-pattern + debug-parse) + +(define-syntax (syntax-class-parse stx) + (syntax-case stx () + [(_ s x arg ...) + (parameterize ((current-syntax-context stx)) + (let* ([argu (parse-argu (syntax->list #'(arg ...)) #:context stx)] + [stxclass + (get-stxclass/check-arity #'s stx + (length (arguments-pargs argu)) + (arguments-kws argu))] + [attrs (stxclass-attrs stxclass)]) + (with-syntax ([parser (stxclass-parser stxclass)] + [argu argu] + [(name ...) (map attr-name attrs)] + [(depth ...) (map attr-depth attrs)]) + #'(let ([fh (lambda (fs) fs)]) + (app-argu parser x x (ps-empty x x) null fh fh + (lambda (fh cp . attr-values) + (map vector '(name ...) '(depth ...) attr-values)) + argu)))))])) + +(define-syntaxes (syntax-class-attributes + syntax-class-arity + syntax-class-keywords) + (let () + (define ((mk handler) stx) + (syntax-case stx () + [(_ s) + (parameterize ((current-syntax-context stx)) + (handler (get-stxclass #'s)))])) + (values (mk (lambda (s) + (let ([attrs (stxclass-attrs s)]) + (with-syntax ([(a ...) (map attr-name attrs)] + [(d ...) (map attr-depth attrs)]) + #'(quote ((a d) ...)))))) + (mk (lambda (s) + (let ([a (stxclass-arity s)]) + #`(to-procedure-arity '#,(arity-minpos a) '#,(arity-maxpos a))))) + (mk (lambda (s) + (let ([a (stxclass-arity s)]) + #`(values '#,(arity-minkws a) '#,(arity-maxkws a)))))))) + +(define-syntax (debug-rhs stx) + (syntax-case stx () + [(debug-rhs rhs) + (let ([rhs (parse-rhs #'rhs #f #f #:context stx)]) + #`(quote #,rhs))])) + +(define-syntax (debug-pattern stx) + (syntax-case stx () + [(debug-pattern p . rest) + (let-values ([(rest pattern defs) + (parse-pattern+sides #'p #'rest + #:splicing? #f + #:decls (new-declenv null) + #:context stx)]) + (unless (stx-null? rest) + (raise-syntax-error #f "unexpected terms" stx rest)) + #`(quote ((definitions . #,defs) + (pattern #,pattern))))])) + +(define-syntax-rule (debug-parse x p ...) + (let/ec escape + (parameterize ((current-failure-handler + (lambda (_ fs) + (escape + `(parse-failure + #:raw-failures + ,(failureset->sexpr fs) + #:maximal-failures + ,(let ([selected (map (lambda (fs) + (cons 'equivalence-class + (map failure->sexpr fs))) + (maximal-failures fs))]) + (if (= (length selected) 1) + (car selected) + (cons 'union selected)))))))) + (syntax-parse x [p 'success] ...)))) diff --git a/collects/syntax/parse/experimental.rkt b/collects/syntax/parse/experimental.rkt index d067d00eec..7555839b76 100644 --- a/collects/syntax/parse/experimental.rkt +++ b/collects/syntax/parse/experimental.rkt @@ -1,95 +1,3 @@ -#lang scheme/base -(require (for-syntax scheme/base - syntax/parse - syntax/private/stxparse/rep-data)) -(provide define-primitive-splicing-syntax-class) - -(define-syntax (define-primitive-splicing-syntax-class stx) - - (define-syntax-class attr - (pattern name:id - #:with depth #'0) - (pattern [name:id depth:nat])) - - (syntax-parse stx - [(dssp (name:id param:id ...) - (~or (~once (~seq #:attrs (a:attr ...)) - #:name "attributes declaration") - (~once (~seq #:description description) - #:name "description declaration")) ... - proc:expr) - #'(begin - (define (get-description param ...) - description) - (define parser - (lambda (stx param ...) - (let/ec escape - ((mk-check-result 'name '(a.name ...) stx) - (proc stx - (lambda ([msg #f]) - (escape - (if msg - `#s(expect:message ,msg) - `#s(expect:thing - ,(get-description param ...) #f #f))))))))) - (define-syntax name - (make-stxclass 'name '(param ...) - '(#s(attr a.name a.depth #f) ...) - (quote-syntax parser) - (quote-syntax get-description) - #t - #t)))])) - - -(define (mk-check-result name attr-names stx) - (lambda (result) - (unless (list? result) - (error name "parser returned non-list")) - (let ([rlength (length result)]) - (unless (= rlength (+ 2 (length attr-names))) - (error name "parser returned list of wrong length; expected length ~s, got ~e" - (+ 2 (length attr-names)) - result)) - (unless (exact-nonnegative-integer? (cadr result)) - (error name "expected exact nonnegative integer for second element of result list, got ~e" - (cadr result))) - (list* (car result) - (nat->dfc (cadr result) stx) - (cddr result))))) - -(define (nat->dfc nat stx) - (if (zero? nat) - `#s(dfc:empty ,stx) - `#s(dfc:cdr #s(dfc:empty ,stx) ,nat))) - - -#| - -(define-primitive-splicing-syntax-class (name param ...) - #:attrs (attr-decl ...) - #:description description-expr - proc) - -'proc' must take two arguments, 'stx' and 'fail', where 'fail' is an -escaping procedure that indicates failure. 'fail' takes an optional -argument, an error message to attach to the failure. If no message is -given, the syntax class description is used. - -'proc' must return a list of 2+|attrs| elements. The first element is -the rest of the input syntax. The second element is the number of -elements consumed from the input. The rest are the attribute values, -in the same order as given in the #:attrs directive. - -Example: - -(define-primitive-splicing-syntax-class (a-expr) - #:attrs (x) - #:description "a-expr" - (lambda (stx fail) - (syntax-case stx () - [(a b c . rest) - (list #'rest 3 #'(printf "got an A\n"))] - [_ - (fail)]))) - -|# +#lang racket/base +(require "experimental/splicing.rkt") +(provide (all-from-out "experimental/splicing.rkt")) diff --git a/collects/syntax/parse/experimental/contract.rkt b/collects/syntax/parse/experimental/contract.rkt new file mode 100644 index 0000000000..4e8e847718 --- /dev/null +++ b/collects/syntax/parse/experimental/contract.rkt @@ -0,0 +1,35 @@ +#lang racket/base +(require "../private/sc.rkt" + "../private/lib.rkt" + "provide.rkt" + unstable/wrapc + (only-in "../private/runtime.rkt" + this-context-syntax) + racket/contract/base) + +(define-syntax-class (expr/c ctc-stx + #:positive [pos-blame 'use-site] + #:negative [neg-blame 'from-macro] + #:macro [macro-name #f] + #:name [expr-name #f] + #:context [ctx #f]) + #:attributes (c) + (pattern y:expr + #:with + c (wrap-expr/c ctc-stx + #'y + #:positive pos-blame + #:negative neg-blame + #:name expr-name + #:macro macro-name + #:context (or ctx (this-context-syntax))))) + +(provide-syntax-class/contract + [expr/c (syntax-class/c (syntax?) + (#:positive (or/c syntax? string? module-path-index? + 'from-macro 'use-site 'unknown) + #:negative (or/c syntax? string? module-path-index? + 'from-macro 'same-as-use-site 'unknown) + #:name (or/c identifier? string? symbol? #f) + #:macro (or/c identifier? string? symbol? #f) + #:context (or/c syntax? #f)))]) diff --git a/collects/syntax/parse/experimental/eh.rkt b/collects/syntax/parse/experimental/eh.rkt new file mode 100644 index 0000000000..6479924633 --- /dev/null +++ b/collects/syntax/parse/experimental/eh.rkt @@ -0,0 +1,78 @@ +#lang racket/base +(require (for-syntax racket/base + syntax/parse + unstable/syntax + "../private/minimatch.rkt" + "../private/rep.rkt" + "../private/rep-data.rkt" + "../private/rep-patterns.rkt" + "../private/kws.rkt") + "../private/keywords.rkt" + "../private/sc.rkt") + +(provide ~eh-var + define-eh-alternative-set) + +(define-syntax (define-eh-alternative-set stx) + (define-syntax-class alt + #:description "eh-alternate-set alternative" + #:literals (pattern) + (pattern (pattern alt))) + (syntax-parse stx + #:literals (pattern) + [(_ name:id a:alt ...) + (parameterize ((current-syntax-context stx)) + (let* ([decls (new-declenv null #:conventions null)] + [ehpat+hstx-list + (apply append + (for/list ([alt (in-list (syntax->list #'(a.alt ...)))]) + (parse*-ellipsis-head-pattern alt decls #t #:context stx)))] + [eh-alt+defs-list + (for/list ([ehpat+hstx (in-list ehpat+hstx-list)]) + (let ([ehpat (car ehpat+hstx)] + [hstx (cadr ehpat+hstx)]) + (cond [(syntax? hstx) + (with-syntax ([(parser) (generate-temporaries '(eh-alt-parser))]) + (let ([attrs (iattrs->sattrs (pattern-attrs (ehpat-head ehpat)))]) + (list (eh-alternative (ehpat-repc ehpat) attrs #'parser) + (list #`(define parser + (parser/rhs parser () #,attrs + [#:description #f (pattern #,hstx)] + #t + #,stx))))))] + [(eh-alternative? hstx) + (list hstx null)] + [else + (error 'define-eh-alternative-set "internal error: unexpected ~e" + hstx)])))] + [eh-alts (map car eh-alt+defs-list)] + [defs (apply append (map cadr eh-alt+defs-list))]) + (with-syntax ([(def ...) defs] + [(alt-expr ...) + (for/list ([alt (in-list eh-alts)]) + (with-syntax ([repc-expr + (match (eh-alternative-repc alt) + ['#f + #'(quote #f)] + [(rep:once n u o) + #`(rep:once (quote-syntax #,n) + (quote-syntax #,u) + (quote-syntax #,o))] + [(rep:optional n o d) + #`(rep:optional (quote-syntax #,n) + (quote-syntax #,o) + (quote-syntax #,d))] + [(rep:bounds min max n u o) + #`(rep:bounds (quote #,min) + (quote #,max) + (quote-syntax #,n) + (quote-syntax #,u) + (quote-syntax #,o))])] + [attrs-expr + #`(quote #,(eh-alternative-attrs alt))] + [parser-expr + #`(quote-syntax #,(eh-alternative-parser alt))]) + #'(eh-alternative repc-expr attrs-expr parser-expr)))]) + #'(begin def ... + (define-syntax name + (eh-alternative-set (list alt-expr ...)))))))])) diff --git a/collects/syntax/parse/experimental/provide.rkt b/collects/syntax/parse/experimental/provide.rkt new file mode 100644 index 0000000000..87e9615fc8 --- /dev/null +++ b/collects/syntax/parse/experimental/provide.rkt @@ -0,0 +1,160 @@ +#lang racket/base +(require racket/contract/base + unstable/location + (for-syntax racket/base + unstable/syntax + "../private/minimatch.rkt" + "../private/sc.rkt" + "../private/lib.rkt" + "../private/rep-data.ss" + "../private/kws.rkt" + (only-in "../private/runtime.rkt" + this-context-syntax) + unstable/wrapc)) +(provide provide-syntax-class/contract + syntax-class/c + splicing-syntax-class/c) + +;; FIXME: +;; - seems to get first-requiring-module wrong, not surprising +;; - extend to contracts on attributes? +;; - syntax-class/c etc just a made-up name, for now +;; (connect to dynamic syntax-classes, eventually) + +(define-syntaxes (syntax-class/c splicing-syntax-class/c) + (let ([nope + (lambda (stx) + (raise-syntax-error #f "not within `provide-syntax-class/contract form" stx))]) + (values nope nope))) + +(begin-for-syntax + (define-struct ctcrec (mpcs mkws mkwcs opcs okws okwcs) #:prefab + #:omit-define-syntaxes)) + +(begin-for-syntax + ;; do-one-contract : stx id stxclass ctcrec id -> stx + (define (do-one-contract stx scname stxclass rec pos-module-source) + ;; First, is the contract feasible? + (match (stxclass-arity stxclass) + [(arity minpos maxpos minkws maxkws) + (let* ([minpos* (length (ctcrec-mpcs rec))] + [maxpos* (+ minpos* (length (ctcrec-opcs rec)))] + [minkws* (sort (map syntax-e (ctcrec-mkws rec)) keywordstring minkws*) "," "and") + (join-sep (map kw->string minkws) "," "and"))) + (unless (null? (diff/sorted/eq maxkws* maxkws)) + (err (string-append "expected a syntax class with at least the optional " + "keyword arguments ~a, got one with ~a") + (join-sep (map kw->string maxkws*) "," "and") + (join-sep (map kw->string maxkws) "," "and"))) + (with-syntax ([scname scname] + [#s(stxclass name arity attrs parser splicing? options integrate) + stxclass] + [#s(ctcrec (mpc ...) (mkw ...) (mkwc ...) + (opc ...) (okw ...) (okwc ...)) + rec] + [arity* (arity minpos* maxpos* minkws* maxkws*)] + [(parser-contract contracted-parser contracted-scname) + (generate-temporaries #`(contract parser #,scname))]) + (with-syntax ([(mpc-id ...) (generate-temporaries #'(mpc ...))] + [(mkwc-id ...) (generate-temporaries #'(mkwc ...))] + [(opc-id ...) (generate-temporaries #'(opc ...))] + [(okwc-id ...) (generate-temporaries #'(okwc ...))]) + (with-syntax ([((mkw-c-part ...) ...) #'((mkw mkwc-id) ...)] + [((okw-c-part ...) ...) #'((okw okwc-id) ...)] + [((mkw-name-part ...) ...) #'((mkw ,(contract-name mkwc-id)) ...)] + [((okw-name-part ...) ...) #'((okw ,(contract-name okwc-id)) ...)]) + #`(begin + (define parser-contract + (let ([mpc-id mpc] ... + [mkwc-id mkwc] ... + [opc-id opc] ... + [okwc-id okwc] ...) + (rename-contract + (->* (any/c any/c any/c any/c any/c any/c any/c + mpc-id ... mkw-c-part ... ...) + (okw-c-part ... ...) + any) + `(,(if 'splicing? 'splicing-syntax-class/c 'syntax-class/c) + [,(contract-name mpc-id) ... mkw-name-part ... ...] + [okw-name-part ... ...])))) + (define-syntax contracted-parser + (make-provide/contract-transformer + (quote-syntax parser-contract) + (quote-syntax parser) + (quote-syntax scname) + (quote-syntax #,pos-module-source))) + (define-syntax contracted-scname + (make-stxclass + (quote-syntax name) + 'arity* + 'attrs + (quote-syntax contracted-parser) + 'splicing? + 'options + #f)) ;; must disable integration + (provide (rename-out [contracted-scname scname])))))))]))) + +(define-syntax (provide-syntax-class/contract stx) + + (define-syntax-class stxclass-ctc + #:description "syntax-class/c or splicing-syntax-class/c form" + #:literals (syntax-class/c) + #:attributes (rec) + (pattern ((~or syntax-class/c splicing-syntax-class/c) + mand:ctclist + (~optional opt:ctclist)) + #:attr rec (make-ctcrec (attribute mand.pc.c) + (attribute mand.kw) + (attribute mand.kwc.c) + (or (attribute opt.pc.c) '()) + (or (attribute opt.kw) '()) + (or (attribute opt.kwc.c) '())))) + + (define-syntax-class ctclist + #:attributes ([pc.c 1] [kw 1] [kwc.c 1]) + (pattern ((~or pc:expr (~seq kw:keyword kwc:expr)) ...) + #:with (pc.c ...) (for/list ([pc-expr (in-list (syntax->list #'(pc ...)))]) + (wrap-expr/c #'contract? pc-expr)) + #:with (kwc.c ...) (for/list ([kwc-expr (in-list (syntax->list #'(kwc ...)))]) + (wrap-expr/c #'contract? kwc-expr)))) + + (syntax-parse stx + [(_ [scname c:stxclass-ctc] ...) + #:declare scname (static stxclass? "syntax class") + (parameterize ((current-syntax-context stx)) + #`(begin (define pos-module-source (quote-module-path)) + #,@(for/list ([scname (in-list (syntax->list #'(scname ...)))] + [stxclass (in-list (attribute scname.value))] + [rec (in-list (attribute c.rec))]) + (do-one-contract stx scname stxclass rec #'pos-module-source))))])) + +;; Copied from unstable/contract, +;; which requires racket/contract, not racket/contract/base + +;; rename-contract : contract any/c -> contract +;; If the argument is a flat contract, so is the result. +(define (rename-contract ctc name) + (let ([ctc (coerce-contract 'rename-contract ctc)]) + (if (flat-contract? ctc) + (flat-named-contract name (flat-contract-predicate ctc)) + (let* ([ctc-fo (contract-first-order ctc)] + [proj (contract-projection ctc)]) + (make-contract #:name name + #:projection proj + #:first-order ctc-fo))))) diff --git a/collects/syntax/parse/experimental/reflect.rkt b/collects/syntax/parse/experimental/reflect.rkt new file mode 100644 index 0000000000..30aa716278 --- /dev/null +++ b/collects/syntax/parse/experimental/reflect.rkt @@ -0,0 +1,118 @@ +#lang racket/base +(require racket/contract/base + (for-syntax racket/base + "../../parse.rkt" + "../private/rep-data.rkt") + "../private/minimatch.rkt" + "../private/keywords.rkt" + "../private/runtime-reflect.rkt" + "../private/kws.rkt") + +(define (reified-syntax-class-arity r) + (match (reified-arity r) + [(arity minpos maxpos _ _) + (to-procedure-arity minpos maxpos)])) + +(define (reified-syntax-class-keywords r) + (match (reified-arity r) + [(arity _ _ minkws maxkws) + (values minkws maxkws)])) + +(define (reified-syntax-class-attributes r) + (reified-signature r)) + +(define reified-syntax-class-curry + (make-keyword-procedure + (lambda (kws1 kwargs1 r . rest1) + (match r + [(reified name parser arity1 sig) + (let () + (check-curry arity1 (length rest1) kws1 + (lambda (msg) + (raise-mismatch-error 'reified-syntax-class-curry + (string-append msg ": ") r))) + (let* ([curried-arity + (match arity1 + [(arity minpos maxpos minkws maxkws) + (let* ([rest1-length (length rest1)] + [minpos* (- minpos rest1-length)] + [maxpos* (- maxpos rest1-length)] + [minkws* (sort (remq* kws1 minkws) keyword any/c boolean?)] + [reified-splicing-syntax-class? + (-> any/c boolean?)] + [reified-syntax-class-attributes + (-> (or/c reified-syntax-class? reified-splicing-syntax-class?) + (listof (list/c symbol? exact-nonnegative-integer?)))] + [reified-syntax-class-arity + (-> (or/c reified-syntax-class? reified-splicing-syntax-class?) + procedure-arity?)] + [reified-syntax-class-keywords + (-> (or/c reified-syntax-class? reified-splicing-syntax-class?) + (values (listof keyword?) + (listof keyword?)))] + [reified-syntax-class-curry + (make-contract #:name '(->* ((or/c reified-syntax-class? reified-splicing-syntax-class/c)) + (#: any/c ...) + #:rest list? + (or/c reified-syntax-class? reified-splicing-syntax-class/c)) + #:projection + (lambda (blame) + (let ([check-reified + ((contract-projection + (or/c reified-syntax-class? reified-splicing-syntax-class?)) + (blame-swap blame))]) + (lambda (f) + (if (and (procedure? f) + (procedure-arity-includes? f 1)) + (make-keyword-procedure + (lambda (kws kwargs r . args) + (keyword-apply f kws kwargs (check-reified r) args))) + (raise-blame-error + blame + f + "expected a procedure of at least one argument, given ~e" + f))))) + #:first-order + (lambda (f) + (and (procedure? f) (procedure-arity-includes? f))))]) + diff --git a/collects/syntax/parse/experimental/splicing.rkt b/collects/syntax/parse/experimental/splicing.rkt new file mode 100644 index 0000000000..23f14b962c --- /dev/null +++ b/collects/syntax/parse/experimental/splicing.rkt @@ -0,0 +1,71 @@ +#lang racket/base +(require (for-syntax racket/base + "../../parse.ss" + "../private/rep-data.rkt" + "../private/kws.rkt") + "../private/runtime-progress.rkt" + "../private/runtime.rkt") +(provide define-primitive-splicing-syntax-class) + +(define-syntax (define-primitive-splicing-syntax-class stx) + + (define-syntax-class attr + (pattern name:id + #:with depth #'0) + (pattern [name:id depth:nat])) + + (syntax-parse stx + [(dssp (name:id param:id ...) + (~or (~once (~seq #:attrs (a:attr ...)) + #:name "attributes declaration") + (~once (~seq #:description description) + #:name "description declaration")) ... + proc:expr) + #'(begin + (define (get-description param ...) + description) + (define parser + (lambda (x cx pr es fh cp success param ...) + (let ([stx (datum->syntax cx x cx)]) + (let ([result + (let/ec escape + (cons 'ok + (proc stx + (lambda ([msg #f] [stx #f]) + (escape (list 'error msg stx))))))]) + (case (car result) + ((ok) + (apply success + ((mk-check-result pr 'name '(a.name ...) x cx fh cp) (cdr result)))) + ((error) + (let ([es + (list* (cons (expect:thing (get-description param ...) #f) stx) + (cons (expect:message (cadr result)) (caddr result)) + es)]) + (fh (failure pr es))))))))) + (define-syntax name + (make-stxclass 'name (arity (length '(param ...)) (length '(param ...)) '() '()) + '(#s(attr a.name a.depth #f) ...) + (quote-syntax parser) + #t + #s(options #t #t) + #f)))])) + +(define (mk-check-result pr name attr-names x cx fh cp) + (lambda (result) + (unless (list? result) + (error name "parser returned non-list")) + (let ([rlength (length result)]) + (unless (= rlength (+ 2 (length attr-names))) + (error name "parser returned list of wrong length; expected length ~s, got ~e" + (+ 2 (length attr-names)) + result)) + ;; Ignore (car result), supposed to be rest-x + ;; Easier to recompute it and get rest-cx right, too. + (let ([skip (cadr result)]) + (unless (exact-nonnegative-integer? skip) + (error name "expected exact nonnegative integer for second element of result list, got ~e" + skip)) + (let-values ([(rest-x rest-cx) (stx-list-drop/cx x cx skip)]) + (list* fh cp rest-x rest-cx (ps-add-cdr pr skip) + (cddr result))))))) diff --git a/collects/syntax/parse/private/keywords.rkt b/collects/syntax/parse/private/keywords.rkt new file mode 100644 index 0000000000..e9aa33f44d --- /dev/null +++ b/collects/syntax/parse/private/keywords.rkt @@ -0,0 +1,37 @@ +#lang racket/base +(require (for-syntax racket/base)) + +;; == Keywords + +(define-syntax-rule (define-keyword name) + (begin + (provide name) + (define-syntax name + (lambda (stx) + (raise-syntax-error #f "keyword used out of context" stx))))) + +(define-keyword pattern) +(define-keyword ~var) +(define-keyword ~datum) +(define-keyword ~literal) +(define-keyword ~and) +(define-keyword ~or) +(define-keyword ~not) +(define-keyword ~seq) +(define-keyword ~between) +(define-keyword ~once) +(define-keyword ~optional) +(define-keyword ~rest) +(define-keyword ~describe) +(define-keyword ~!) +(define-keyword ~bind) +(define-keyword ~fail) +(define-keyword ~parse) +(define-keyword ~do) +(define-keyword ...+) +(define-keyword ~delimit-cut) +(define-keyword ~commit) +(define-keyword ~reflect) +(define-keyword ~splicing-reflect) +(define-keyword ~post) +(define-keyword ~eh-var) diff --git a/collects/syntax/parse/private/kws.rkt b/collects/syntax/parse/private/kws.rkt new file mode 100644 index 0000000000..fa85f51f99 --- /dev/null +++ b/collects/syntax/parse/private/kws.rkt @@ -0,0 +1,176 @@ +#lang racket/base +(require racket/list) +(provide (struct-out arguments) + (struct-out arity) + no-arguments + no-arity + to-procedure-arity + arguments->arity + check-arity + check-arity/neg + check-curry + join-sep + kw->string + diff/sorted/eq) + +#| +An Arguments is + #s(arguments (listof stx) (listof keyword) (listof stx)) +|# +(define-struct arguments (pargs kws kwargs) #:prefab) + +(define no-arguments (arguments null null null)) + +#| +An Arity is + #s(arity nat nat/+inf.0 (listof keyword) (listof keyword)) +|# +(define-struct arity (minpos maxpos minkws maxkws) + #:prefab) + +(define no-arity (arity 0 0 null null)) + +;; ---- + +(define (to-procedure-arity minpos maxpos) + (cond [(= minpos maxpos) minpos] + [(= maxpos +inf.0) (arity-at-least minpos)] + [else (for/list ([i (in-range minpos (add1 maxpos))]) i)])) + +(define (arguments->arity argu) + (let ([pos (length (arguments-pargs argu))] + [kws (arguments-kws argu)]) + (arity pos pos kws kws))) + +(define (check-arity arity pos-count keywords proc) + (let ([msg (gen-arity-msg (arity-minpos arity) + (arity-maxpos arity) + (arity-minkws arity) + (arity-maxkws arity) + pos-count keywords)]) + (when msg + (proc msg)))) + +(define (check-arity/neg arity pos-count keywords proc) + (let ([msg (gen-arity-msg/neg (arity-minpos arity) + (arity-maxpos arity) + (arity-minkws arity) + (arity-maxkws arity) + pos-count keywords)]) + (when msg + (proc msg)))) + +(define (arity-sat? minpos maxpos minkws maxkws pos-count keywords) + (and (<= minpos pos-count maxpos) + (null? (diff/sorted/eq minkws keywords)) + (null? (diff/sorted/eq keywords maxkws)))) + +(define (gen-arity-msg minpos maxpos minkws maxkws pos-count keywords) + (if (arity-sat? minpos maxpos minkws maxkws pos-count keywords) + #f + (let ([pos-exp (gen-pos-exp-msg minpos maxpos)] + [minkws-exp (gen-minkws-exp-msg minkws)] + [optkws-exp (gen-optkws-exp-msg minkws maxkws)] + [pos-got (gen-pos-got-msg pos-count)] + [kws-got (gen-kws-got-msg keywords maxkws)]) + (string-append + "expected " + (join-sep (filter string? (list pos-exp minkws-exp optkws-exp)) + "," "and") + "; got " + (join-sep (filter string? (list pos-got kws-got)) + "," "and"))))) + +(define (gen-arity-msg/neg minpos maxpos minkws maxkws pos-count keywords) + (if (arity-sat? minpos maxpos minkws maxkws pos-count keywords) + #f + (let ([pos-exp (gen-pos-exp-msg minpos maxpos)] + [minkws-exp (gen-minkws-exp-msg minkws)] + [optkws-exp (gen-optkws-exp-msg minkws maxkws)] + [pos-got (gen-pos-got-msg pos-count)] + [kws-got (gen-kws-got-msg keywords maxkws)]) + (string-append + "expected a syntax class that accepts " + (join-sep (filter string? (list pos-got kws-got)) + "," "and") + "; got one that accepts " + (join-sep (filter string? (list pos-exp minkws-exp optkws-exp)) + "," "and"))))) + +(define (check-curry arity pos-count keywords proc) + (let ([maxpos (arity-maxpos arity)] + [maxkws (arity-maxkws arity)]) + (when (> pos-count maxpos) + (proc (format "too many arguments: expected at most ~s, got ~s" + maxpos pos-count))) + (let ([extrakws (diff/sorted/eq keywords maxkws)]) + (when (pair? extrakws) + (proc (format "syntax class does not accept keyword arguments for ~a" + (join-sep (map kw->string extrakws) "," "and"))))))) + +;; ---- + +(define (gen-pos-exp-msg minpos maxpos) + (format "~a positional argument~a" + (cond [(= maxpos minpos) minpos] + [(= maxpos +inf.0) (format "at least ~a" minpos)] + [else + (format "between ~a and ~a" minpos maxpos)]) + (if (= minpos maxpos 1) "" "s"))) + +(define (gen-minkws-exp-msg minkws) + (and (pair? minkws) + (format "~amandatory keyword argument~a for ~a" + (if (= (length minkws) 1) "a " "") + (if (= (length minkws) 1) "" "s") + (join-sep (map kw->string minkws) "," "and")))) + +(define (gen-optkws-exp-msg minkws maxkws) + (let ([optkws (diff/sorted/eq maxkws minkws)]) + (and (pair? optkws) + (format "~aoptional keyword argument~a for ~a" + (if (= (length optkws) 1) "an " "") + (if (= (length optkws) 1) "" "s") + (join-sep (map kw->string optkws) "," "and"))))) + +(define (gen-pos-got-msg pos-count) + (format "~a positional argument~a" + pos-count (if (= pos-count 1) "" "s"))) + +(define (gen-kws-got-msg keywords maxkws) + (cond [(pair? keywords) + (format "~akeyword argument~a for ~a" + (if (= (length keywords) 1) "a " "") + (if (= (length keywords) 1) "" "s") + (join-sep (map kw->string keywords) "," "and"))] + [(pair? maxkws) "no keyword arguments"] + [else #f])) + +;; ---- + +(define (kw->string kw) (format "~a" kw)) + +(define (diff/sorted/eq xs ys) + (if (pair? xs) + (let ([ys* (memq (car xs) ys)]) + (if ys* + (diff/sorted/eq (cdr xs) (cdr ys*)) + (cons (car xs) (diff/sorted/eq (cdr xs) ys)))) + null)) + +(define (join-sep items sep0 ult0 [prefix ""]) + (define sep (string-append sep0 " ")) + (define ult (string-append ult0 " ")) + (define (loop items) + (cond [(null? items) + null] + [(null? (cdr items)) + (list sep ult (car items))] + [else + (list* sep (car items) (loop (cdr items)))])) + (case (length items) + [(0) #f] + [(1) (string-append prefix (car items))] + [(2) (format "~a~a ~a~a" prefix (car items) ult (cadr items))] + [else (let ([strings (list* (car items) (loop (cdr items)))]) + (apply string-append prefix strings))])) diff --git a/collects/syntax/parse/private/lib.rkt b/collects/syntax/parse/private/lib.rkt new file mode 100644 index 0000000000..ffc75b686b --- /dev/null +++ b/collects/syntax/parse/private/lib.rkt @@ -0,0 +1,86 @@ +#lang racket/base +(require "sc.rkt" + "keywords.rkt" + syntax/stx + unstable/syntax + (for-syntax racket/base + "rep.rkt")) + +(provide identifier + boolean + str + character + keyword + number + integer + exact-integer + exact-nonnegative-integer + exact-positive-integer + + id + nat + char + + expr + static) + +;; == Integrable syntax classes == + +(define-syntax-class identifier + #:description (quote "identifier") + (pattern (~fail #:unless (identifier? this-syntax)))) + +(define-syntax-class keyword + #:description (quote "keyword") + (pattern (~fail #:unless (and (syntax? this-syntax) (keyword? (syntax-e this-syntax)))))) + +(define-syntax-class expr + #:description (quote "expression") + (pattern (~fail #:when (and (syntax? this-syntax) (keyword? (syntax-e this-syntax)))))) + +;; == Normal syntax classes == + +(define-syntax-rule (define-pred-stxclass name pred) + (define-syntax-class name #:attributes () #:opaque #:commit + (pattern (~and x (~fail #:unless (pred (syntax-e #'x))))))) + +;;(define-pred-stxclass identifier symbol?) +;;(define-pred-stxclass keyword keyword?) +(define-pred-stxclass boolean boolean?) +(define-pred-stxclass character char?) + +(define-syntax-class str #:attributes () #:opaque #:commit + #:description "string" + (pattern (~and x (~fail #:unless (string? (syntax-e #'x)))))) + +(define-pred-stxclass number number?) +(define-pred-stxclass integer integer?) +(define-pred-stxclass exact-integer exact-integer?) +(define-pred-stxclass exact-nonnegative-integer exact-nonnegative-integer?) +(define-pred-stxclass exact-positive-integer exact-positive-integer?) + +;; Aliases +(define-syntax id (make-rename-transformer #'identifier)) +(define-syntax nat (make-rename-transformer #'exact-nonnegative-integer)) +(define-syntax char (make-rename-transformer #'character)) + +(define notfound (box 'notfound)) + +(define-syntax-class (static pred name) + #:attributes (value) + #:description name + #:commit + (pattern (~and x:id + (~fail #:unless (syntax-transforming?) + "not within the extent of a macro transformer") + (~bind [value (syntax-local-value #'x (lambda () notfound))]) + (~fail #:when (eq? (attribute value) notfound)) + (~fail #:unless (pred (attribute value)))))) + +#| +(define-syntax-class expr + #:attributes () + #:description "expression" + #:commit + (pattern (~and x (~fail #:when (keyword? (syntax-e #'x)))))) +|# diff --git a/collects/syntax/parse/private/litconv.rkt b/collects/syntax/parse/private/litconv.rkt new file mode 100644 index 0000000000..95924b27c8 --- /dev/null +++ b/collects/syntax/parse/private/litconv.rkt @@ -0,0 +1,137 @@ +#lang racket/base +(require (for-syntax racket/base + "sc.rkt" + "lib.rkt" + unstable/syntax + "rep-data.rkt" + "rep.rkt" + "kws.rkt") + "runtime.rkt") +(provide define-conventions + define-literal-set + kernel-literals) + +(define-syntax (define-conventions stx) + + (define-syntax-class header + #:description "name or name with formal parameters" + (pattern name:id + #:with formals #'() + #:attr arity (arity 0 0 null null)) + (pattern (name:id . formals) + #:attr arity (parse-kw-formals #'formals #:context stx))) + + (syntax-parse stx + [(define-conventions h:header rule ...) + (let () + (define rules (check-conventions-rules #'(rule ...) stx)) + (define rxs (map car rules)) + (define dens0 (map cadr rules)) + (define den+defs-list + (for/list ([den0 (in-list dens0)]) + (let-values ([(den defs) (create-aux-def den0)]) + (cons den defs)))) + (define dens (map car den+defs-list)) + (define defs (apply append (map cdr den+defs-list))) + + (define/with-syntax (rx ...) rxs) + (define/with-syntax (def ...) defs) + (define/with-syntax (parser ...) + (map den:delayed-parser dens)) + (define/with-syntax (class-name ...) + (map den:delayed-class dens)) + + #'(begin + (define-syntax h.name + (make-conventions + (quote-syntax get-parsers) + (lambda () + (let ([class-names (list (quote-syntax class-name) ...)]) + (map list + (list 'rx ...) + (map make-den:delayed + (generate-temporaries class-names) + class-names)))))) + (define get-parsers + (lambda formals + def ... + (list parser ...)))))])) + +(define-syntax (define-literal-set stx) + (syntax-case stx () + [(define-literal-set name (lit ...)) + (let ([phase-of-definition (syntax-local-phase-level)]) + (unless (identifier? #'name) + (raise-syntax-error #f "expected identifier" stx #'name)) + (let ([lits (check-literals-list/litset #'(lit ...) stx)]) + (with-syntax ([((internal external) ...) lits]) + #`(begin + (define phase-of-literals + (phase-of-enclosing-module)) + (define-syntax name + (make-literalset + (list (list 'internal (quote-syntax external)) ...) + (quote-syntax phase-of-literals))) + (begin-for-syntax/once + (for ([x (in-list (syntax->list #'(external ...)))]) + (unless (identifier-binding x 0) + (raise-syntax-error #f "literal is unbound in phase 0" + (quote-syntax #,stx) x))))))))])) + +(define-syntax (phase-of-enclosing-module stx) + (syntax-case stx () + [(poem) + (let ([phase-within-module (syntax-local-phase-level)]) + #`(let ([phase-of-this-expression + (variable-reference->phase (#%variable-reference))]) + (- phase-of-this-expression + #,(if (zero? phase-within-module) 0 1))))])) + +#| +Literal sets: The goal is for literals to refer to their bindings at + + phase 0 relative to the enclosing module + +Use cases, explained: +1) module X with def-lit-set is required-for-syntax + phase-of-mod-inst = 1 + phase-of-def = 0 + literals looked up at abs phase 1 + which is phase 0 rel to module X +2) module X with local def-lit-set within define-syntax + phase-of-mod-inst = 1 (mod at 0, but +1 within define-syntax) + phase-of-def = 1 + literals looked up at abs phase 0 + which is phase 0 rel to module X +3) module X with def-lit-set in phase-2 position (really uncommon case!) + phase-of-mod-inst = 1 (not 2, apparently) + phase-of-def = 2 + literals looked up at abs phase 0 + (that's why the weird (if (z?) 0 1) term) +|# + + +;; Literal sets + +(define-literal-set kernel-literals + (begin + begin0 + define-values + define-syntaxes + define-values-for-syntax + set! + let-values + letrec-values + #%plain-lambda + case-lambda + if + quote + letrec-syntaxes+values + with-continuation-mark + #%expression + #%plain-app + #%top + #%datum + #%variable-reference + module #%provide #%require + #%plain-module-begin)) diff --git a/collects/syntax/private/stxparse/minimatch.rkt b/collects/syntax/parse/private/minimatch.rkt similarity index 78% rename from collects/syntax/private/stxparse/minimatch.rkt rename to collects/syntax/parse/private/minimatch.rkt index 91ab958810..34c4f4aff4 100644 --- a/collects/syntax/private/stxparse/minimatch.rkt +++ b/collects/syntax/parse/private/minimatch.rkt @@ -1,7 +1,7 @@ #lang racket/base (require unstable/struct (for-syntax racket/base racket/struct-info unstable/struct)) -(provide match make) +(provide match make ?) (define-syntax (match stx) (syntax-case stx () @@ -25,7 +25,7 @@ ;; (match-p id Pattern SuccessExpr FailureExpr) (define-syntax (match-p stx) - (syntax-case stx (quote cons list make struct) + (syntax-case stx (quote cons list make struct ?) [(match-p x wildcard success failure) (and (identifier? #'wildcard) (free-identifier=? #'wildcard #'_)) #'success] @@ -67,6 +67,15 @@ (let ([y (list (accessor x) ...)]) (match-p y (list p ...) success failure)) failure))))] + [(match-p x (? predicate pat ...) success failure) + #'(if (predicate x) + (match-p* ((x pat) ...) success failure) + failure)] + [(match-p x (S p ...) success failure) + (identifier? #'S) + (if (struct-info? (syntax-local-value #'S (lambda () #f))) + #'(match-p x (struct S (p ...)) success failure) + (raise-syntax-error #f "bad minimatch form" stx #'S))] [(match-p x s success failure) (prefab-struct-key (syntax-e #'s)) (with-syntax ([key (prefab-struct-key (syntax-e #'s))] @@ -75,9 +84,21 @@ (if (equal? xkey 'key) (let ([xps (struct->list x)]) (match-p xps (list p ...) success failure)) - failure)))])) + failure)))] + )) + +(define-syntax match-p* + (syntax-rules () + [(match-p* () success failure) + success] + [(match-p* ((x1 p1) . rest) success failure) + (match-p x1 p1 (match-p* rest success failure) failure)])) #; (define-syntax struct (lambda (stx) (raise-syntax-error #f "illegal use of keyword" stx))) + +(define-syntax ? + (lambda (stx) + (raise-syntax-error #f "illegal use of minimatch form '?'" stx))) diff --git a/collects/syntax/parse/private/parse.rkt b/collects/syntax/parse/private/parse.rkt new file mode 100644 index 0000000000..5aaf8ac498 --- /dev/null +++ b/collects/syntax/parse/private/parse.rkt @@ -0,0 +1,781 @@ +#lang racket/base +(require (for-syntax racket/base + racket/private/sc + syntax/stx + syntax/id-table + syntax/keyword + unstable/syntax + "rep-data.rkt" + "rep.rkt" + "kws.rkt" + "txlift.rkt") + racket/stxparam + racket/list + syntax/stx + unstable/struct + "runtime.rkt" + "runtime-report.rkt" + "runtime-reflect.rkt") +(provide (all-defined-out)) + +#| +Parsing protocol: + +(parse:* <*> * progress-var expectstack-var success-expr) : Ans + +*-stxclass-parser + : stxish stx progress expectstack fail-handler cut-prompt success-proc arg ... -> Ans + + : x cx + : x cx rest-x rest-cx rest-pr + : x cx ??? + : x cx + +x is term to parse, usually syntax but can be pair, empty in cdr patterns +cx is most recent syntax object: + if x must be coerced to syntax, use cx as lexctx and src + +Usually sub-patterns processed in tail position, +but *can* do non-tail calls for: + - ~commit + - var of stxclass with ~commit +(Also safe to keep normal tail-call protocol.) +There is no real benefit to specializing ~commit, since it does not involve +creating a success closure. + +|# + +#| +Optimizations + - commit protocol for stxclasses (but not ~commit, no point) + - avoid choice point in (EH ... . ()) by eager pair check + - integrable stxclasses (identifier, keyword, expr) +|# + +;; ---- + +(begin-for-syntax + (define (wash stx) + (syntax-e stx)) + (define (wash-list washer stx) + (let ([l (stx->list stx)]) + (unless l (raise-type-error 'wash-list "stx-list" stx)) + (map washer l))) + (define (wash-iattr stx) + (with-syntax ([#s(attr name depth syntax?) stx]) + (attr #'name (wash #'depth) (wash #'syntax?)))) + (define (wash-sattr stx) + (with-syntax ([#s(attr name depth syntax?) stx]) + (attr (wash #'name) (wash #'depth) (wash #'syntax?)))) + (define (wash-iattrs stx) + (wash-list wash-iattr stx)) + (define (wash-sattrs stx) + (wash-list wash-sattr stx))) + +;; ---- + +#| +Conventions: + - rhs : RHS + - iattr : IAttr + - relsattr : SAttr + - splicing? : bool + - x : id (var) + - cx : id (var, may be shadowed) + - pr : id (var, may be shadowed) + - es : id (var, may be shadowed) + - success : var (bound to success procedure) + - k : expr + - rest-x, rest-cx, rest-pr : id (to be bound) + - fh, cp : id (var) +|# + +;; (parse:rhs rhs relsattrs (arg:id ...) get-description:id splicing?) +;; : expr[stxclass-parser] +;; Takes a list of the relevant attrs; order is significant! +(define-syntax (parse:rhs stx) + (syntax-case stx () + [(parse:rhs #s(rhs _ _ transparent? _ variants (def ...) + #s(options commit? delimit-cut?) _integrate) + relsattrs formals splicing? description) + #'(lambda (x cx pr es fh0 cp0 success . formals) + def ... + (#%expression + (with ([this-syntax x]) + (syntax-parameterize ((this-context-syntax + (syntax-rules () + [(tbs) (ps-context-syntax pr)]))) + (let ([es (cons (cons (expect:thing description 'transparent?) x) es)] + [pr (if 'transparent? pr (ps-add-opaque pr))]) + (with ([fail-handler fh0] + [cut-prompt cp0]) + ;; Update the prompt, if required + ;; FIXME: can be optimized away if no cut immediately within variants... + (with-maybe-delimit-cut delimit-cut? + (parse:variants x cx relsattrs variants splicing? + pr es success cp0 commit?))))))))])) + +;; (with-maybe-delimit-cut bool expr) +(define-syntax with-maybe-delimit-cut + (syntax-rules () + [(wmdc #t k) + (with ([cut-prompt fail-handler]) k)] + [(wmdc #f k) + k])) + +;; (parse:variants x cx relsattrs variants splicing? pr es success cp0) : expr[Ans] +(define-syntax (parse:variants stx) + (syntax-case stx () + [(parse:variants x cx relsattrs (variant ...) splicing? pr es success cp0 commit?) + #'(try (parse:variant x cx relsattrs variant splicing? pr es success cp0 commit?) ...)])) + +;; (parse:variant x cx relsattrs variant splicing? pr es success cp0) : expr[Ans] +(define-syntax (parse:variant stx) + (syntax-case stx () + [(parse:variant x cx relsattrs variant #f pr es success cp0 commit?) + (with-syntax ([#s(variant _ _ pattern (def ...)) #'variant]) + #`(let () + def ... + (parse:S x cx pattern pr es + (variant-success relsattrs variant () success cp0 commit?))))] + [(parse:variant x cx relsattrs variant #t pr es success cp0 commit?) + (with-syntax ([#s(variant _ _ pattern (def ...)) #'variant]) + #`(let () + def ... + (parse:H x cx rest-x rest-cx rest-pr pattern pr es + (variant-success relsattrs variant (rest-x rest-cx rest-pr) + success cp0 commit?))))])) + +;; (variant-success relsattrs variant (also:id ...) success bool) : expr[Ans] +(define-syntax (variant-success stx) + (syntax-case stx () + [(variant-success relsattrs #s(variant _ _ pattern _) (also ...) success cp0 commit?) + #`(with-maybe-reset-fail commit? cp0 + (base-success-expr #,(pattern-attrs (wash #'pattern)) + relsattrs + (also ...) + success))])) + +;; (with-maybe-reset-fail bool id expr) +(define-syntax with-maybe-reset-fail + (syntax-rules () + [(wmrs #t cp0 k) + (with ([fail-handler cp0]) k)] + [(wmrs #f cp0 k) + k])) + +;; (base-success-expr iattrs relsattrs (also:id ...) success) : expr[Ans] +(define-syntax (base-success-expr stx) + (syntax-case stx () + [(base-success-expr iattrs relsattrs (also ...) success) + (let ([reliattrs + (reorder-iattrs (wash-sattrs #'relsattrs) + (wash-iattrs #'iattrs))]) + (with-syntax ([(#s(attr name _ _) ...) reliattrs]) + #'(success fail-handler cut-prompt also ... (attribute name) ...)))])) + +;; ---- + +;; (parse:clauses x clauses ctx) +(define-syntax (parse:clauses stx) + (syntax-case stx () + [(parse:clauses x clauses ctx) + (with-disappeared-uses + (with-txlifts + (lambda () + (define-values (chunks clauses-stx) + (parse-keyword-options #'clauses parse-directive-table + #:context #'ctx + #:no-duplicates? #t)) + (define context + (options-select-value chunks '#:context #:default #'x)) + (define-values (decls0 defs) + (get-decls+defs chunks #t #:context #'ctx)) + (define (for-clause clause) + (syntax-case clause () + [[p . rest] + (let-values ([(rest pattern defs2) + (parse-pattern+sides #'p #'rest + #:splicing? #f + #:decls decls0 + #:context #'ctx)]) + (unless (and (stx-list? rest) (stx-pair? rest)) + (raise-syntax-error #f + "expected non-empty clause body" + #'ctx + clause)) + (with-syntax ([rest rest] + [pattern pattern] + [(local-def ...) (append defs defs2)]) + #`(let () + local-def ... + (parse:S x cx pattern pr es (let () . rest)))))])) + (unless (and (stx-list? clauses-stx) (stx-pair? clauses-stx)) + (raise-syntax-error #f "expected non-empty sequence of clauses" #'ctx)) + (with-syntax ([(def ...) (append (get-txlifts-as-definitions) defs)] + [(alternative ...) + (map for-clause (stx->list clauses-stx))]) + #`(let* ([ctx0 #,context] + [pr (ps-empty x ctx0)] + [es null] + [cx x] + [fh0 (syntax-patterns-fail ctx0)]) + (with ([fail-handler fh0] + [cut-prompt fh0]) + (try alternative ...)))))))])) + +;; ---- + +;; (parse:S x cx S-pattern pr es k) : expr[Ans] +;; In k: attrs(S-pattern) are bound. +(define-syntax (parse:S stx) + (syntax-case stx () + [(parse:S x cx pattern0 pr es k) + (syntax-case #'pattern0 () + [#s(internal-rest-pattern rest-x rest-cx rest-pr) + #`(let ([rest-x x] + [rest-cx cx] + [rest-pr pr]) + k)] + [#s(pat:any _attrs) + #'k] + [#s(pat:var _attrs name #f _ () _) + #'(let-attributes ([#s(attr name 0 #t) (datum->syntax cx x cx)]) + k)] + [#s(pat:var _attrs name parser argu (nested-a ...) commit?) + (with-syntax ([(name-attr ...) + (if (identifier? #'name) + #'([#s(attr name 0 #t) (datum->syntax cx x cx)]) + #'())]) + (if (not (syntax-e #'commit?)) + ;; The normal protocol + #'(app-argu parser x cx pr es fail-handler cut-prompt + (lambda (fh cp . result) + (let-attributes (name-attr ...) + (let/unpack ((nested-a ...) result) + (with ([fail-handler fh] + [cut-prompt cp]) + k)))) + argu) + ;; The commit protocol + ;; (Avoids putting k in procedure) + #'(let ([result + (with ([fail-handler (lambda (fs) (cons 'fail fs))]) + (with ([cut-prompt fail-handler]) + (app-argu parser x cx pr es fail-handler cut-prompt + (lambda (fh cp . result) (cons 'ok result)) + argu)))]) + (case (car result) + ((fail) (fail (cdr result))) + ((ok) + (let-attributes (name-attr ...) + (let/unpack ((nested-a ...) (cdr result)) + k)))))))] + [#s(pat:reflect _attrs obj argu attr-decls name (nested-a ...)) + (with-syntax ([(name-attr ...) + (if (identifier? #'name) + #'([#s(attr name 0 #t) (datum->syntax cx x cx)]) + #'())]) + (with-syntax ([arity (arguments->arity (syntax->datum #'argu))]) + #'(let ([parser (reflect-parser obj 'arity 'attr-decls #f)]) + (app-argu parser x cx pr es fail-handler cut-prompt + (lambda (fh cp . result) + (let-attributes (name-attr ...) + (let/unpack ((nested-a ...) result) + (with ([fail-handler fh] + [cut-prompt cp]) + k)))) + argu))))] + [#s(pat:datum attrs datum) + #`(let ([d (if (syntax? x) (syntax-e x) x)]) + (if (equal? d (quote datum)) + k + (fail (failure pr (cons (cons (expect:atom 'datum) x) es)))))] + [#s(pat:literal attrs literal input-phase lit-phase) + #`(if (and (identifier? x) + (free-identifier=?/phases + x input-phase + (quote-syntax literal) lit-phase)) + k + (fail (failure pr (cons (cons (expect:literal (quote-syntax literal)) x) es))))] + [#s(pat:action attrs action subpattern) + #'(parse:A x cx action pr es (parse:S x cx subpattern pr es k))] + [#s(pat:head attrs head tail) + #`(parse:H x cx rest-x rest-cx rest-pr head pr es + (parse:S rest-x rest-cx tail rest-pr es k))] + [#s(pat:dots attrs head tail) + #`(parse:dots x cx head tail pr es k)] + [#s(pat:and attrs subpatterns) + (for/fold ([k #'k]) ([subpattern (in-list (reverse (syntax->list #'subpatterns)))]) + #`(parse:S x cx #,subpattern pr es #,k))] + [#s(pat:or (a ...) (subpattern ...)) + (with-syntax ([(#s(attr id _ _) ...) #'(a ...)]) + #`(let ([success + (lambda (fh cp id ...) + (let-attributes ([a id] ...) + (with ([fail-handler fh] + [cut-prompt cp]) + k)))]) + (try (parse:S x cx subpattern pr es + (disjunct subpattern success () (id ...))) + ...)))] + [#s(pat:not () subpattern) + #`(let* ([fh0 fail-handler] + [pr0 pr] + [es0 es] + [fail-to-succeed + (lambda (fs) k)]) + ;; ~not implicitly prompts to be safe, + ;; but ~! not allowed within ~not (unless within ~delimit-cut, etc) + ;; (statically checked!) + (with ([fail-handler fail-to-succeed] + [cut-prompt fail-to-succeed]) ;; to be safe + (parse:S x cx subpattern pr es + (fh0 (failure pr0 es0)))))] + [#s(pat:pair _attrs head tail) + #`(let-values ([(datum cx) + (if (syntax? x) + (values (syntax-e x) x) + (values x cx))]) + (if (pair? datum) + (let ([hx (car datum)] + [hcx (car datum)] + [hpr (ps-add-car pr)] + [tx (cdr datum)] + [tpr (ps-add-cdr pr)]) + (parse:S hx hcx head hpr es + (parse:S tx cx tail tpr es k))) + (fail (failure pr es))))] + [#s(pat:vector _attrs subpattern) + #`(let ([datum (if (syntax? x) (syntax-e x) x)]) + (if (vector? datum) + (let ([datum (vector->list datum)] + [vcx (if (syntax? x) x cx)] ;; FIXME: (vector? datum) => (syntax? x) ??? + [pr (ps-add-unvector pr)]) + (parse:S datum vcx subpattern pr es k)) + (fail (failure pr es))))] + [#s(pat:box _attrs subpattern) + #`(let ([datum (if (syntax? x) (syntax-e x) x)]) + (if (box? datum) + (let ([datum (unbox datum)] + [bcx (if (syntax? x) x cx)] ;; FIXME: (box? datum) => (syntax? x) ??? + [pr (ps-add-unbox pr)]) + (parse:S datum bcx subpattern pr es k)) + (fail (failure pr es))))] + [#s(pat:pstruct _attrs key subpattern) + #`(let ([datum (if (syntax? x) (syntax-e x) x)]) + (if (let ([xkey (prefab-struct-key datum)]) + (and xkey (equal? xkey 'key))) + (let ([datum (struct->list datum)] + [scx (if (syntax? x) x cx)] ;; FIXME: (struct? datum) => (syntax? x) ??? + [pr (ps-add-unpstruct pr)]) + (parse:S datum scx subpattern pr es k)) + (fail (failure pr es))))] + [#s(pat:describe attrs description transparent? pattern) + #`(let ([es (cons (cons (expect:thing description transparent?) x) es)] + [pr (if 'transparent? pr (ps-add-opaque pr))]) + (parse:S x cx pattern pr es k))] + [#s(pat:delimit attrs pattern) + #`(let ([cp0 cut-prompt]) + (with ([cut-prompt fail-handler]) + (parse:S x cx pattern pr es (with ([cut-prompt cp0]) k))))] + [#s(pat:commit attrs pattern) + #`(let ([fh0 fail-handler] + [cp0 cut-prompt]) + (with ([cut-prompt fh0]) + (parse:S x cx pattern pr es + (with ([cut-prompt cp0] + [fail-handler fh0]) + k))))] + [#s(pat:post attrs pattern) + #`(let ([pr (ps-add-post pr)]) + (parse:S x cx pattern pr es k))] + [#s(pat:integrated _attrs name argu predicate description) + (with-syntax ([(name-attr ...) + (if (identifier? #'name) + #'([#s(attr name 0 #t) x]) + #'())]) + ;; NOTE: predicate must not assume x (ie, this-syntax) is stx + #'(if (app-argu predicate x argu) + (let-attributes (name-attr ...) k) + (let ([es (cons (cons (expect:thing 'description #t) x) es)]) + (fail (failure pr es)))))])])) + +;; (disjunct ???-pattern success (pre:expr ...) (id:id ...)) : expr[Ans] +(define-syntax (disjunct stx) + (syntax-case stx () + [(disjunct pattern success (pre ...) (id ...)) + (with-syntax ([(#s(attr sub-id _ _) ...) (pattern-attrs (wash #'pattern))]) + (with-syntax ([(alt-sub-id ...) (generate-temporaries #'(sub-id ...))]) + #`(let ([alt-sub-id (attribute sub-id)] ...) + (let ([id #f] ...) + (let ([sub-id alt-sub-id] ...) + (success fail-handler cut-prompt pre ... id ...))))))])) + +;; (disjunct/sides clauses success (pre:expr ...) (id:id ...)) : expr[Ans] +(define-syntax (disjunct/sides stx) + (syntax-case stx () + [(disjunct/sides clauses success (pre ...) (id ...)) + (with-syntax ([(#s(clause:attr #s(attr sub-id _ _) _) ...) #'clauses]) + (with-syntax ([(alt-sub-id ...) (generate-temporaries #'(sub-id ...))]) + #`(let ([alt-sub-id (attribute sub-id)] ...) + (let ([id #f] ...) + (let ([sub-id alt-sub-id] ...) + (success fail-handler cut-prompt pre ... id ...))))))])) + +;; (parse:A x cx A-pattern pr es k) : expr[Ans] +;; In k: attrs(A-pattern) are bound. +(define-syntax (parse:A stx) + (syntax-case stx () + [(parse:A x cx pattern0 pr es k) + (syntax-case #'pattern0 () + [#s(action:cut _) + #'(with ([fail-handler cut-prompt]) k)] + [#s(action:bind _ (side ...)) + #'(bind/sides (side ...) k)] + [#s(action:fail _ condition message) + #`(let ([c (wrap-user-code condition)]) + (if c + (let ([pr* (if (syntax? c) + (ps-add-stx pr c) + pr)] + [es* (cons (cons (expect:message message) + (if (syntax? c) c x)) + es)]) + (fail (failure pr* es*))) + k))] + [#s(action:parse _ pattern expr) + #`(let* ([y (datum->syntax #f (wrap-user-code expr) #f)] + [cy y] + [pr* (ps-add-stx pr y)]) + (parse:S y cy pattern pr* es k))] + [#s(action:do _ (stmt ...)) + #'(let () (no-shadow stmt) ... (#%expression k))] + [#s(action:post _ pattern) + #'(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 (check-list^depth a expr))]) + #,k)]))])) + +(begin-for-syntax + ;; convert-list-pattern : ListPattern id -> SinglePattern + ;; Converts '() datum pattern at end of list to bind (cons stx index) + ;; to rest-var. + (define (convert-list-pattern pattern end-pattern) + (syntax-case pattern () + [#s(pat:datum () ()) + end-pattern] + [#s(pat:action attrs action tail) + (with-syntax ([tail (convert-list-pattern #'tail end-pattern)]) + #'#s(pat:action attrs action tail))] + [#s(pat:head attrs head tail) + (with-syntax ([tail (convert-list-pattern #'tail end-pattern)]) + #'#s(pat:head attrs head tail))] + [#s(pat:dots attrs head tail) + (with-syntax ([tail (convert-list-pattern #'tail end-pattern)]) + #'#s(pat:dots attrs head tail))] + [#s(pat:pair attrs head-part tail-part) + (with-syntax ([tail-part (convert-list-pattern #'tail-part end-pattern)]) + #'#s(pat:pair attrs head-part tail-part))]))) + +;; (parse:H x cx rest-x rest-cx rest-pr H-pattern pr es k) +;; In k: rest, rest-pr, attrs(H-pattern) are bound. +(define-syntax (parse:H stx) + (syntax-case stx () + [(parse:H x cx rest-x rest-cx rest-pr head pr es k) + (syntax-case #'head () + [#s(hpat:describe _ description transparent? pattern) + #`(let ([es (cons (cons (expect:thing description transparent?) x) es)]) + (parse:H x cx rest-x rest-cx rest-pr pattern pr es k))] + [#s(hpat:var _attrs name parser argu (nested-a ...) commit?) + (with-syntax ([(name-attr ...) + (if (identifier? #'name) + #'([#s(attr name 0 #t) + (stx-list-take x (ps-difference pr rest-pr))]) + #'())]) + (if (not (syntax-e #'commit?)) + ;; The normal protocol + #`(app-argu parser x cx pr es fail-handler cut-prompt + (lambda (fh cp rest-x rest-cx rest-pr . result) + (let-attributes (name-attr ...) + (let/unpack ((nested-a ...) result) + (with ([fail-handler fh] + [cut-prompt cp]) + k)))) + argu) + ;; The commit protocol + ;; (Avoids putting k in procedure) + #'(let ([result + (with ([fail-handler (lambda (fs) (cons 'fail fs))]) + (with ([cut-prompt fail-handler]) + (app-argu parser x cx pr es fail-handler cut-prompt + (lambda result (cons 'ok result)) + argu)))]) + (case (car result) + ((fail) (fail (cdr result))) + ((ok) + (let ([_fh (car result)] + [_cp (cadr result)] + [result (cddr result)]) + (let ([rest-x (cadr result)] + [rest-cx (caddr result)] + [rest-pr (cadddr result)] + [result (cddddr result)]) + (let-attributes (name-attr ...) + (let/unpack ((nested-a ...) result) + k)))))))))] + [#s(hpat:reflect _attrs obj argu attr-decls name (nested-a ...)) + (with-syntax ([(name-attr ...) + (if (identifier? #'name) + #'([#s(attr name 0 #t) + (stx-list-take x (ps-difference pr rest-pr))]) + #'())]) + (with-syntax ([arity (arguments->arity (syntax->datum #'argu))]) + #'(let ([parser (reflect-parser obj 'arity 'attr-decls #t)]) + (app-argu parser x cx pr es fail-handler cut-prompt + (lambda (fh cp rest-x rest-cx rest-pr . result) + (let-attributes (name-attr ...) + (let/unpack ((nested-a ...) result) + (with ([fail-handler fh] + [cut-prompt cp]) + k)))) + argu))))] + [#s(hpat:and (a ...) head single) + #`(let ([cx0 cx]) + (parse:H x cx rest-x rest-cx rest-pr head pr es + (let ([lst (stx-list-take x (ps-difference pr rest-pr))]) + (parse:S lst cx0 single pr es k))))] + [#s(hpat:or (a ...) (subpattern ...)) + (with-syntax ([(#s(attr id _ _) ...) #'(a ...)]) + #`(let ([success + (lambda (fh cp rest-x rest-cx rest-pr id ...) + (let-attributes ([a id] ...) + (with ([fail-handler fh] + [cut-prompt cp]) + k)))]) + (try (parse:H x cx rest-x rest-cx rest-pr subpattern pr es + (disjunct subpattern success + (rest-x rest-cx rest-pr) (id ...))) + ...)))] + [#s(hpat:seq attrs pattern) + (with-syntax ([pattern + (convert-list-pattern + #'pattern + #'#s(internal-rest-pattern rest-x rest-cx rest-pr))]) + #'(parse:S x cx pattern pr es k))] + [#s(hpat:optional (a ...) pattern defaults) + (with-syntax ([(#s(attr id _ _) ...) #'(a ...)]) + #`(let ([success + (lambda (fh cp rest-x rest-cx rest-pr id ...) + (let-attributes ([a id] ...) + (with ([fail-handler fh] + [cut-prompt cp]) + k)))]) + (try (parse:H x cx rest-x rest-cx rest-pr pattern pr es + (success fail-handler cut-prompt + rest-x rest-cx rest-pr (attribute id) ...)) + (let ([rest-x x] + [rest-cx cx] + [rest-pr pr]) + (bind/sides defaults + (disjunct/sides defaults success + (rest-x rest-cx rest-pr) + (id ...)))))))] + [#s(hpat:delimit _attrs pattern) + #'(let ([cp0 cut-prompt]) + (with ([cut-prompt fail-handler]) + (parse:H x cx rest-x rest-cx rest-pr pattern pr es + (with ([cut-prompt cp0]) k))))] + [#s(hpat:commit attrs pattern) + #`(let ([fh0 fail-handler] + [cp0 cut-prompt]) + (with ([cut-prompt fh0]) + (parse:H x cx rest-x rest-cx rest-pr pattern pr es + (with ([cut-prompt cp0] + [fail-handler fh0]) + k))))] + [#s(hpat:post _ pattern) + #'(let ([pr (ps-add-post pr)]) + (parse:H x cx rest-x rest-cx rest-pr pattern pr es k))] + [_ + (with-syntax ([attrs (pattern-attrs (wash #'head))]) + #'(parse:S x cx + #s(pat:pair attrs head #s(internal-rest-pattern rest-x rest-cx rest-pr)) + pr es k))])])) + +;; (parse:dots x cx EH-pattern S-pattern pr es k) : expr[Ans] +;; In k: attrs(EH-pattern, S-pattern) are bound. +(define-syntax (parse:dots stx) + (syntax-case stx () + [(parse:dots x cx (#s(ehpat head-attrs head head-repc) ...) tail pr es k) + (let () + (define repcs (wash-list wash #'(head-repc ...))) + (define rep-ids (for/list ([repc (in-list repcs)]) + (and repc (generate-temporary 'rep)))) + (define rel-repcs (filter values repcs)) + (define rel-rep-ids (filter values rep-ids)) + (define aattrs + (for/list ([head-attrs (in-list (syntax->list #'(head-attrs ...)))] + [repc (in-list repcs)] + #:when #t + [a (in-list (wash-iattrs head-attrs))]) + (cons a repc))) + (define attrs (map car aattrs)) + (define attr-repcs (map cdr aattrs)) + (define ids (map attr-name attrs)) + (with-syntax ([(id ...) ids] + [(alt-id ...) (generate-temporaries ids)] + [reps rel-rep-ids] + [(head-rep ...) rep-ids] + [(rel-rep ...) rel-rep-ids] + [(rel-repc ...) rel-repcs] + [(a ...) attrs] + [(attr-repc ...) attr-repcs] + [tail-pattern-is-null? + (equal? (syntax->datum #'tail) '#s(pat:datum () ()))]) + (define-pattern-variable alt-map #'((id . alt-id) ...)) + (define-pattern-variable loop-k + #'(dots-loop dx* dcx* loop-pr* fail-handler cut-prompt rel-rep ... alt-id ...)) + #`(let () + ;; dots-loop : stx progress rel-rep ... alt-id ... -> Ans + (define (dots-loop dx dcx loop-pr fh cp rel-rep ... alt-id ...) + (with ([fail-handler fh] + [cut-prompt cp]) + (try-or-pair/null-check tail-pattern-is-null? dx dcx loop-pr es + (try (parse:EH dx dcx loop-pr head-repc dx* dcx* loop-pr* alt-map head-rep + head es loop-k) + ...) + (cond [(< rel-rep (rep:min-number rel-repc)) + (let ([es (cons (cons (expectation-of-reps/too-few rel-rep rel-repc) dx) es)]) + (fail (failure loop-pr es)))] + ... + [else + (let-attributes ([a (rep:finalize a attr-repc alt-id)] ...) + (parse:S dx dcx tail loop-pr es k))])))) + (let ([rel-rep 0] ... + [alt-id (rep:initial-value attr-repc)] ...) + (dots-loop x cx pr fail-handler cut-prompt rel-rep ... alt-id ...)))))])) + +;; (try-or-pair/null-check bool x cx es pr pair-alt maybe-null-alt) +(define-syntax try-or-pair/null-check + (syntax-rules () + [(topc #t x cx pr es pair-alt null-alt) + (cond [(stx-pair? x) pair-alt] + [(stx-null? x) null-alt] + [else (fail (failure pr es))])] + [(topc _ x cx pr es alt1 alt2) + (try alt1 alt2)])) + +;; (parse:EH x cx pr repc x* cx* pr* alts rep H-pattern es k) : expr[Ans] +;; In k: x*, cx*, pr*, alts`attrs(H-pattern) are bound and rep is shadowed. +(define-syntax (parse:EH stx) + (syntax-case stx () + [(parse:EH x cx pr repc x* cx* pr* alts rep head es k) + (let () + (define-pattern-variable k* + (let* ([main-attrs (wash-iattrs (pattern-attrs (wash #'head)))] + [ids (map attr-name main-attrs)] + [alt-ids + (let ([table (make-bound-id-table)]) + (for ([entry (in-list (syntax->list #'alts))]) + (let ([entry (syntax-e entry)]) + (bound-id-table-set! table (car entry) (cdr entry)))) + (for/list ([id (in-list ids)]) (bound-id-table-ref table id)))]) + (with-syntax ([(id ...) ids] + [(alt-id ...) alt-ids] + [(alt-a ...) (map rename-attr main-attrs alt-ids)]) + #`(let ([alt-id (rep:combine repc (attribute id) alt-id)] ...) + k)))) + (syntax-case #'repc () + [#f #`(parse:H x cx x* cx* pr* head pr es k*)] + [_ #`(parse:H x cx x* cx* pr* head pr es + (if (< rep (rep:max-number repc)) + (let ([rep (add1 rep)]) k*) + (let ([es (cons (cons (expectation-of-reps/too-many rep repc) x*) es)]) + (fail (failure pr* es)))))]))])) + +;; (rep:initial-value RepConstraint) : expr +(define-syntax (rep:initial-value stx) + (syntax-case stx () + [(_ #s(rep:once _ _ _)) #'#f] + [(_ #s(rep:optional _ _ _)) #'#f] + [(_ _) #'null])) + +;; (rep:finalize RepConstraint expr) : expr +(define-syntax (rep:finalize stx) + (syntax-case stx () + [(_ a #s(rep:optional _ _ defaults) v) + (with-syntax ([#s(attr name _ _) #'a] + [(#s(clause:attr da de) ...) #'defaults]) + (let ([default + (for/or ([da (in-list (syntax->list #'(da ...)))] + [de (in-list (syntax->list #'(de ...)))]) + (with-syntax ([#s(attr dname _ _) da]) + (and (bound-identifier=? #'name #'dname) de)))]) + (if default + #`(or v #,default) + #'v)))] + [(_ a #s(rep:once _ _ _) v) #'v] + [(_ a _ v) #'(reverse v)])) + +;; (rep:min-number RepConstraint) : expr +(define-syntax (rep:min-number stx) + (syntax-case stx () + [(_ #s(rep:once _ _ _)) #'1] + [(_ #s(rep:optional _ _ _)) #'0] + [(_ #s(rep:bounds min max _ _ _)) #'min])) + +;; (rep:max-number RepConstraint) : expr +(define-syntax (rep:max-number stx) + (syntax-case stx () + [(_ #s(rep:once _ _ _)) #'1] + [(_ #s(rep:optional _ _ _)) #'1] + [(_ #s(rep:bounds min max _ _ _)) #'max])) + +;; (rep:combine RepConstraint expr expr) : expr +(define-syntax (rep:combine stx) + (syntax-case stx () + [(_ #s(rep:once _ _ _) a b) #'a] + [(_ #s(rep:optional _ _ _) a b) #'a] + [(_ _ a b) #'(cons a b)])) + +;; ---- + +(define-syntax-rule (expectation-of-message message) + (expect:message message)) + +(define-syntax expectation-of-reps/too-few + (syntax-rules () + [(_ rep #s(rep:once name too-few-msg too-many-msg)) + (expect:message (or too-few-msg (name->too-few/once name)))] + [(_ rep #s(rep:optional name too-many-msg _)) + (error 'syntax-parse "INTERNAL ERROR: impossible (too-few)")] + [(_ rep #s(rep:bounds min max name too-few-msg too-many-msg)) + (expect:message (or too-few-msg (name->too-few name)))])) + +(define-syntax expectation-of-reps/too-many + (syntax-rules () + [(_ rep #s(rep:once name too-few-msg too-many-msg)) + (expect:message (or too-many-msg (name->too-many name)))] + [(_ rep #s(rep:optional name too-many-msg _)) + (expect:message (or too-many-msg (name->too-many name)))] + [(_ rep #s(rep:bounds min max name too-few-msg too-many-msg)) + (expect:message (or too-many-msg (name->too-many name)))])) + +(define (name->too-few/once name) + (and name (format "missing required occurrence of ~a" name))) + +(define (name->too-few name) + (and name (format "too few occurrences of ~a" name))) + +(define (name->too-many name) + (and name (format "too many occurrences of ~a" name))) diff --git a/collects/syntax/private/stxparse/rep-attrs.rkt b/collects/syntax/parse/private/rep-attrs.rkt similarity index 86% rename from collects/syntax/private/stxparse/rep-attrs.rkt rename to collects/syntax/parse/private/rep-attrs.rkt index 4b1a85643e..00a6b29d5d 100644 --- a/collects/syntax/private/stxparse/rep-attrs.rkt +++ b/collects/syntax/parse/private/rep-attrs.rkt @@ -2,7 +2,8 @@ (require racket/contract/base syntax/stx syntax/id-table - "../util.ss") + unstable/syntax + unstable/struct) (provide (struct-out attr)) #| @@ -14,6 +15,11 @@ attr is guaranteed to be bound to a value which is a syntax object (or a list^depth of syntax objects). |# +#| +SAttr lists are always stored in sorted order, to make comparison +of signatures easier for reified syntax-classes. +|# + (define-struct attr (name depth syntax?) #:prefab) (define (iattr? a) @@ -56,6 +62,9 @@ a list^depth of syntax objects). [iattrs->sattrs (-> (listof iattr?) (listof sattr?))] + [sort-sattrs + (-> (listof sattr?) + (listof sattr?))] [intersect-sattrss (-> (listof (listof sattr?)) @@ -83,13 +92,13 @@ a list^depth of syntax objects). (define count-t (make-bound-id-table)) (define attr-t (make-bound-id-table)) (define list-count (length attrss)) - (for* ([attrs attrss] [attr attrs]) + (for* ([attrs (in-list attrss)] [attr (in-list attrs)]) (define name (attr-name attr)) (define prev (bound-id-table-ref attr-t name #f)) (bound-id-table-set! attr-t name (join-attrs attr prev)) (let ([pc (bound-id-table-ref count-t name 0)]) (bound-id-table-set! count-t name (add1 pc)))) - (for/list ([a (bound-id-table-map attr-t (lambda (_ v) v))]) + (for/list ([a (in-list (bound-id-table-map attr-t (lambda (_ v) v)))]) (if (= (bound-id-table-ref count-t (attr-name a)) list-count) a (attr-make-uncertain a)))) @@ -120,12 +129,18 @@ a list^depth of syntax objects). (make attr (syntax-e name) depth syntax?))) (define (iattrs->sattrs as) - (map iattr->sattr as)) + (sort-sattrs (map iattr->sattr as))) + +(define (sort-sattrs as) + (sort as stringstring (attr-name a))) + #:cache-keys? #t)) (define (rename-attr a name) (make attr name (attr-depth a) (attr-syntax? a))) ;; intersect-sattrss : (listof (listof SAttr)) -> (listof SAttr) +;; FIXME: rely on sorted inputs, simplify algorithm and avoid second sort? (define (intersect-sattrss attrss) (cond [(null? attrss) null] [else @@ -137,21 +152,18 @@ a list^depth of syntax objects). [ht (make-hasheq)] [put (lambda (attr) (hash-set! ht (attr-name attr) attr))] [fetch-like (lambda (attr) (hash-ref ht (attr-name attr) #f))]) - (for* ([attrs attrss] - [attr attrs] + (for* ([attrs (in-list attrss)] + [attr (in-list attrs)] #:when (memq (attr-name attr) names)) (put (join-attrs attr (fetch-like attr)))) - (sort (hash-map ht (lambda (k v) v)) - (lambda (a b) - (stringstring (attr-name a)) - (symbol->string (attr-name b))))))])) + (sort-sattrs (hash-map ht (lambda (k v) v))))])) ;; reorder-iattrs : (listof SAttr) (listof IAttr) -> (listof IAttr) ;; Reorders iattrs (and restricts) based on relsattrs ;; If a relsattr is not found, or if depth or contents mismatches, raises error. (define (reorder-iattrs relsattrs iattrs) (let ([ht (make-hasheq)]) - (for ([iattr iattrs]) + (for ([iattr (in-list iattrs)]) (let ([remap-name (syntax-e (attr-name iattr))]) (hash-set! ht remap-name iattr))) (let loop ([relsattrs relsattrs]) @@ -178,8 +190,9 @@ a list^depth of syntax objects). ;; check-iattrs-subset : (listof IAttr) (listof IAttr) stx -> void (define (check-iattrs-subset little big ctx) (define big-t (make-bound-id-table)) - (for ([a big]) (bound-id-table-set! big-t (attr-name a) #t)) - (for ([a little]) + (for ([a (in-list big)]) + (bound-id-table-set! big-t (attr-name a) #t)) + (for ([a (in-list little)]) (unless (bound-id-table-ref big-t (attr-name a) #f) (raise-syntax-error #f "attribute bound in defaults but not in pattern" diff --git a/collects/syntax/private/stxparse/rep-data.rkt b/collects/syntax/parse/private/rep-data.rkt similarity index 67% rename from collects/syntax/private/stxparse/rep-data.rkt rename to collects/syntax/parse/private/rep-data.rkt index dea6735990..a87fc367ec 100644 --- a/collects/syntax/private/stxparse/rep-data.rkt +++ b/collects/syntax/parse/private/rep-data.rkt @@ -4,55 +4,45 @@ racket/list syntax/stx syntax/id-table - "../util.ss" - "minimatch.ss" - "rep-attrs.ss" - "rep-patterns.ss") -(provide (all-from-out "rep-attrs.ss") - (all-from-out "rep-patterns.ss") + unstable/syntax + "minimatch.rkt" + "kws.rkt" + "rep-attrs.rkt" + "rep-patterns.rkt") +(provide (all-from-out "rep-attrs.rkt") + (all-from-out "rep-patterns.rkt") (struct-out stxclass) + (struct-out options) + (struct-out integrate) stxclass/s? stxclass/h? + stxclass-commit? + stxclass-delimit-cut? (struct-out attr) (struct-out rhs) (struct-out variant) (struct-out clause:fail) (struct-out clause:with) (struct-out clause:attr) + (struct-out clause:do) (struct-out conventions) - (struct-out literalset)) - -#| - -NOTES - -syntax-class protocol ---------------------- - -Two kinds of syntax class: commit? = #t, commit? = #f - -let syntax-class SC have params (P ...) - if commit? = #t - parser : Stx P ... -> (U list expectation) - if commit? = #f - parser : Stx ((U list expect) FailFunction -> Answer) P ... -> Answer - - -conventions ------------ - -let conventions C have params (P ...) - get-procedures : - (P ... -> (values (listof ParserFun) (listof DescriptionFun))) - -|# + (struct-out literalset) + (struct-out eh-alternative-set) + (struct-out eh-alternative)) #| A stxclass is - (make-sc symbol (listof symbol) (list-of SAttr) identifier identifier boolean boolean) + #s(stxclass symbol (listof symbol) (list-of SAttr) identifier bool Options Integrate/#f) +where Options = #s(options boolean boolean) + Integrate = #s(integrate id string) +Arity is defined in kws.rkt |# -(define-struct stxclass (name params attrs parser-name description - splicing? commit?) +(define-struct stxclass (name arity attrs parser splicing? options integrate) + #:prefab) + +(define-struct options (commit? delimit-cut?) + #:prefab) +(define-struct integrate (predicate description) #:prefab) (define (stxclass/s? x) @@ -60,29 +50,28 @@ A stxclass is (define (stxclass/h? x) (and (stxclass? x) (stxclass-splicing? x))) +(define (stxclass-commit? x) + (options-commit? (stxclass-options x))) +(define (stxclass-delimit-cut? x) + (options-delimit-cut? (stxclass-options x))) + #| An RHS is - (make-rhs stx (listof SAttr) boolean stx/#f (listof Variant) (listof stx)) + #s(rhs stx (listof SAttr) bool stx/#f (listof Variant) (listof stx) Options Integrate/#f) definitions: auxiliary definitions from #:declare |# -(define-struct rhs (ostx attrs transparent? description variants definitions commit?) +(define-struct rhs (ostx attrs transparent? description variants definitions options integrate) #:prefab) #| A Variant is - (make-variant stx (listof SAttr) Pattern (listof SideClause)) + (make-variant stx (listof SAttr) Pattern (listof stx)) |# -(define-struct variant (ostx attrs pattern sides definitions) #:prefab) +(define-struct variant (ostx attrs pattern definitions) #:prefab) #| -A SideClause is one of - (make-clause:fail stx stx) - (make-clause:with pattern stx (listof stx)) - (make-clause:attr IAttr stx) +SideClause is defined in rep-patterns |# -(define-struct clause:fail (condition message) #:prefab) -(define-struct clause:with (pattern expr definitions) #:prefab) -(define-struct clause:attr (attr expr) #:prefab) #| A Conventions is @@ -100,8 +89,16 @@ 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 #t)) + (make stxclass (syntax-e name) #f null #f #f #s(options #f #t) #f)) +#| +An EH-alternative-set is + (eh-alternative-set (listof EH-alternative) +An EH-alternative is + (eh-alternative RepetitionConstraint (listof SAttr) id) +|# +(define-struct eh-alternative-set (alts)) +(define-struct eh-alternative (repc attrs parser)) ;; Environments @@ -111,22 +108,24 @@ DeclEnv = (listof ConventionRule)) DeclEntry = - (make-den:lit id id ct-phase ct-phase) - (make-den:class id id (listof syntax) bool) - (make-den:parser id id (listof SAttr) bool bool) - (make-den:delayed id id id) + (den:lit id id ct-phase ct-phase) + (den:class id id Arguments) + (den:parser id (listof SAttr) bool bool bool) + (den:delayed id id) + +Arguments is defined in rep-patterns.rkt |# (define-struct declenv (table conventions)) (define-struct den:lit (internal external input-phase lit-phase)) -(define-struct den:class (name class args)) -(define-struct den:parser (parser description attrs splicing? commit?)) -(define-struct den:delayed (parser description class)) +(define-struct den:class (name class argu)) +(define-struct den:parser (parser attrs splicing? commit? delimit-cut?)) +(define-struct den:delayed (parser class)) (define (new-declenv literals #:conventions [conventions null]) (make-declenv (for/fold ([table (make-immutable-bound-id-table)]) - ([literal literals]) + ([literal (in-list literals)]) (bound-id-table-set table (car literal) (make den:lit (first literal) (second literal) (third literal) (fourth literal)))) @@ -152,15 +151,15 @@ DeclEntry = stxclass-name) (wrong-syntax (if blame-declare? name id) "identifier previously declared"))] - [(struct den:parser (_p _d _a _sp _c)) + [(struct den:parser (_p _a _sp _c _dc?)) (wrong-syntax id "(internal error) late unbound check")] ['#f (void)]))) -(define (declenv-put-stxclass env id stxclass-name args) +(define (declenv-put-stxclass env id stxclass-name argu) (declenv-check-unbound env id) (make-declenv (bound-id-table-set (declenv-table env) id - (make den:class id stxclass-name args)) + (make den:class id stxclass-name argu)) (declenv-conventions env))) ;; declenv-update/fold : DeclEnv (Id/Regexp DeclEntry a -> DeclEntry a) a @@ -168,7 +167,7 @@ DeclEntry = (define (declenv-update/fold env0 f acc0) (define-values (acc1 rules1) (for/fold ([acc acc0] [newrules null]) - ([rule (declenv-conventions env0)]) + ([rule (in-list (declenv-conventions env0))]) (let-values ([(val acc) (f (car rule) (cadr rule) acc)]) (values acc (cons (list (car rule) val) newrules))))) (define-values (acc2 table2) @@ -182,7 +181,7 @@ DeclEntry = ;; returns ids in domain of env but not in given list (define (declenv-domain-difference env ids) (define idbm (make-bound-id-table)) - (for ([id ids]) (bound-id-table-set! idbm id #t)) + (for ([id (in-list ids)]) (bound-id-table-set! idbm id #t)) (for/list ([(k v) (in-dict (declenv-table env))] #:when (or (den:class? v) (den:parser? v)) #:when (not (bound-id-table-ref idbm k #f))) @@ -192,7 +191,7 @@ DeclEntry = (define (conventions-lookup conventions id) (let ([sym (symbol->string (syntax-e id))]) - (for/or ([c conventions]) + (for/or ([c (in-list conventions)]) (and (regexp-match? (car c) sym) (cadr c))))) ;; Contracts @@ -205,7 +204,7 @@ DeclEntry = (or/c den:lit? den:class? den:parser? den:delayed?))) (define SideClause/c - (or/c clause:fail? clause:with? clause:attr?)) + (or/c clause:fail? clause:with? clause:attr? clause:do?)) ;; ct-phase = syntax, expr that computes absolute phase ;; usually = #'(syntax-local-phase-level) @@ -232,7 +231,7 @@ DeclEntry = [declenv-lookup (-> DeclEnv/c identifier? any)] [declenv-put-stxclass - (-> DeclEnv/c identifier? identifier? (listof syntax?) + (-> DeclEnv/c identifier? identifier? arguments? DeclEnv/c)] [declenv-domain-difference (-> DeclEnv/c (listof identifier?) @@ -244,11 +243,13 @@ DeclEntry = (values DeclEnv/c any/c))] [get-stxclass - (-> identifier? any)] - [get-stxclass/check-arg-count - (-> identifier? exact-nonnegative-integer? any)] + (-> identifier? stxclass?)] + [get-stxclass/check-arity + (-> identifier? syntax? exact-nonnegative-integer? (listof keyword?) + stxclass?)] [split-id/get-stxclass - (-> identifier? DeclEnv/c any)]) + (-> identifier? DeclEnv/c + (values identifier? (or/c stxclass? #f)))]) ;; stxclass-lookup-config : (parameterof (U 'no 'try 'yes)) ;; 'no means don't lookup, always use dummy (no nested attrs) @@ -265,16 +266,12 @@ DeclEntry = (make-dummy-stxclass id)] [else (wrong-syntax id "not defined as syntax class")]))) -(define (get-stxclass/check-arg-count id arg-count) - (let* ([sc (get-stxclass id)] - [expected-arg-count (length (stxclass-params sc))]) - (unless (or (= expected-arg-count arg-count) - (memq (stxclass-lookup-config) '(try no))) - ;; (above: don't check error if stxclass may not be defined yet) - (wrong-syntax id - "too few arguments for syntax-class ~a (expected ~s)" - (syntax-e id) - expected-arg-count)) +(define (get-stxclass/check-arity id stx pos-count keywords) + (let ([sc (get-stxclass id)]) + (unless (memq (stxclass-lookup-config) '(try no)) + (check-arity (stxclass-arity sc) pos-count keywords + (lambda (msg) + (raise-syntax-error #f msg stx)))) sc)) (define (split-id/get-stxclass id0 decls) @@ -286,6 +283,16 @@ DeclEntry = (datum->syntax id0 (string->symbol (caddr m)) id0 id0)) (declenv-check-unbound decls id (syntax-e scname) #:blame-declare? #t) - (let ([sc (get-stxclass/check-arg-count scname 0)]) + (let ([sc (get-stxclass/check-arity scname id0 0 null)]) (values id sc)))] [else (values id0 #f)])) + +;; ---- + +(provide get-eh-alternative-set) + +(define (get-eh-alternative-set id) + (let ([v (syntax-local-value id (lambda () #f))]) + (unless (eh-alternative-set? v) + (wrong-syntax id "not defined as an eh-alternative-set")) + v)) diff --git a/collects/syntax/parse/private/rep-patterns.rkt b/collects/syntax/parse/private/rep-patterns.rkt new file mode 100644 index 0000000000..4f39ab9289 --- /dev/null +++ b/collects/syntax/parse/private/rep-patterns.rkt @@ -0,0 +1,383 @@ +#lang racket/base +(require "rep-attrs.rkt" + "kws.rkt" + unstable/struct + (for-syntax racket/base + syntax/stx + unstable/syntax)) +(provide (all-defined-out)) + +#| +Uses Arguments from kws.rkt +|# + +#| +A Base is (listof IAttr) + If P = (make-pattern Attrs ...) and A is in Attrs, + the depth of A is with respect to P, + not with respect to the entire enclosing pattern. +|# + +#| +A SinglePattern is one of + (pat:any Base) + (pat:var Base id id Arguments (listof IAttr) bool) + (pat:literal Base identifier ct-phase ct-phase) + (pat:datum Base datum) + (pat:action Base ActionPattern SinglePattern) + (pat:head Base HeadPattern SinglePattern) + (pat:dots Base (listof EllipsisHeadPattern) SinglePattern) + (pat:and Base (listof SinglePattern)) + (pat:or Base (listof SinglePattern)) + (pat:not Base SinglePattern) + (pat:pair Base SinglePattern SinglePattern) + (pat:vector Base SinglePattern) + (pat:box Base SinglePattern) + (pat:pstruct Base key SinglePattern) + (pat:describe Base stx boolean SinglePattern) + (pat:delimit Base SinglePattern) + (pat:commit Base SinglePattern) + (pat:reflect Base stx Arguments (listof SAttr) id (listof IAttr)) + (pat:post Base SinglePattern) + (pat:integrated Base id/#f Arguments id string) + +A ListPattern is a subtype of SinglePattern; one of + (pat:datum Base '()) + (pat:action Base ActionPattern ListPattern) + (pat:head Base HeadPattern ListPattern) + (pat:pair Base SinglePattern ListPattern) + (pat:dots Base EllipsisHeadPattern SinglePattern) +|# + +(define-struct pat:any (attrs) #:prefab) +(define-struct pat:var (attrs name parser argu nested-attrs commit?) #: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) +(define-struct pat:head (attrs head tail) #:prefab) +(define-struct pat:dots (attrs heads tail) #:prefab) +(define-struct pat:and (attrs patterns) #:prefab) +(define-struct pat:or (attrs patterns) #:prefab) +(define-struct pat:not (attrs pattern) #:prefab) +(define-struct pat:pair (attrs head tail) #:prefab) +(define-struct pat:vector (attrs pattern) #:prefab) +(define-struct pat:box (attrs pattern) #:prefab) +(define-struct pat:pstruct (attrs key pattern) #:prefab) +(define-struct pat:describe (attrs description transparent? pattern) #:prefab) +(define-struct pat:delimit (attrs pattern) #:prefab) +(define-struct pat:commit (attrs pattern) #:prefab) +(define-struct pat:reflect (attrs obj argu attr-decls name nested-attrs) #:prefab) +(define-struct pat:post (attrs pattern) #:prefab) +(define-struct pat:integrated (attrs name argu predicate description) #:prefab) + +#| +A ActionPattern is one of + (action:cut Base) + (action:fail Base stx stx) + (action:bind Base (listof clause:attr)) +* (action:and Base (listof ActionPattern)) + (action:parse Base SinglePattern stx) + (action:do Base (listof stx)) + (action:post Base ActionPattern) + +action:and is desugared below in create-* procedures +|# + +(define-struct action:cut (attrs) #:prefab) +(define-struct action:fail (attrs when message) #:prefab) +(define-struct action:bind (attrs clauses) #:prefab) +(define-struct action:and (attrs patterns) #:prefab) +(define-struct action:parse (attrs pattern expr) #:prefab) +(define-struct action:do (attrs stmts) #:prefab) +(define-struct action:post (attrs pattern) #:prefab) + +#| +A HeadPattern is one of + (hpat:var Base id id Arguments (listof IAttr) bool) + (hpat:seq Base ListPattern) + (hpat:action Base ActionPattern HeadPattern) + (hpat:and Base HeadPattern SinglePattern) + (hpat:or Base (listof HeadPattern)) + (hpat:optional Base HeadPattern (listof clause:attr)) + (hpat:describe Base stx/#f boolean HeadPattern) + (hpat:delimit Base HeadPattern) + (hpat:commit Base HeadPattern) + (hpat:reflect Base stx Arguments (listof SAttr) id (listof IAttr)) + (hpat:post Base HeadPattern) +|# + +(define-struct hpat:var (attrs name parser argu nested-attrs commit?) #:prefab) +(define-struct hpat:seq (attrs inner) #:prefab) +(define-struct hpat:action (attrs action inner) #:prefab) +(define-struct hpat:and (attrs head single) #:prefab) +(define-struct hpat:or (attrs patterns) #:prefab) +(define-struct hpat:optional (attrs inner defaults) #:prefab) +(define-struct hpat:describe (attrs description transparent? pattern) #:prefab) +(define-struct hpat:delimit (attrs pattern) #:prefab) +(define-struct hpat:commit (attrs pattern) #:prefab) +(define-struct hpat:reflect (attrs obj argu attr-decls name nested-attrs) #:prefab) +(define-struct hpat:post (attrs pattern) #:prefab) + +#| +An EllipsisHeadPattern is + (ehpat Base HeadPattern RepConstraint) + +A RepConstraint is one of + (rep:once stx stx stx) + (rep:optional stx stx (listof clause:attr)) + (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 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:var? x) + (pat:literal? x) + (pat:datum? x) + (pat:action? x) + (pat:head? x) + (pat:dots? x) + (pat:and? x) + (pat:or? x) + (pat:not? x) + (pat:pair? x) + (pat:vector? x) + (pat:box? x) + (pat:pstruct? x) + (pat:describe? x) + (pat:delimit? x) + (pat:commit? x) + (pat:reflect? x) + (pat:post? x) + (pat:integrated? x))) + +(define (action-pattern? x) + (or (action:cut? x) + (action:bind? x) + (action:fail? x) + (action:and? x) + (action:parse? x) + (action:do? x) + (action:post? x))) + +(define (head-pattern? x) + (or (hpat:var? x) + (hpat:seq? x) + (hpat:action? x) + (hpat:and? x) + (hpat:or? x) + (hpat:optional? x) + (hpat:describe? x) + (hpat:delimit? x) + (hpat:commit? x) + (hpat:reflect? x) + (hpat:post? x))) + +(define (ellipsis-head-pattern? x) + (ehpat? x)) + +(define single-pattern? pattern?) + +(define (single-or-head-pattern? x) + (or (single-pattern? x) + (head-pattern? x))) + +(define pattern-attrs + (let () + (define-syntax (mk-get-attrs stx) + (syntax-case stx () + [(_ struct ...) + (with-syntax + ([([pred accessor] ...) + (for/list ([s (in-list (stx->list #'(struct ...)))]) + (list (format-id s "~a?" (syntax-e s)) + (format-id s "~a-attrs" (syntax-e s))))]) + #'(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 + 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:optional hpat:delimit hpat:commit hpat:reflect hpat:post + ehpat))) + +;; ---- + +;; Helpers to handle attribute calculations +;; Too complicated for a few pattern forms; those are handled in rep.rkt + +(define (create-pat:any) + (make pat:any null)) + +(define (create-pat:var name parser argu nested-attrs commit?) + (let ([attrs + (if name (cons (make attr name 0 #t) nested-attrs) nested-attrs)]) + (make pat:var attrs name parser argu nested-attrs commit?))) + +(define (create-pat:reflect obj argu attr-decls name nested-attrs) + (let ([attrs + (if name (cons (make attr name 0 #t) nested-attrs) nested-attrs)]) + (make pat:reflect attrs obj argu attr-decls name nested-attrs))) + +(define (create-pat:datum datum) + (make pat:datum null datum)) + +(define (create-pat:literal literal input-phase lit-phase) + (make pat:literal null literal input-phase lit-phase)) + +(define (create-pat:action g sp) + (cond [(action:and? g) + (for/fold ([sp sp]) ([g (in-list (reverse (action:and-patterns g)))]) + (create-pat:action g sp))] + [else + (let ([attrs (append-iattrs (map pattern-attrs (list g sp)))]) + (make pat:action attrs g sp))])) + +(define (create-pat:head headp tailp) + (let ([attrs (append-iattrs (map pattern-attrs (list headp tailp)))]) + (make pat:head attrs headp tailp))) + +(define (create-pat:pair headp tailp) + (make pat:pair (append-iattrs (map pattern-attrs (list headp tailp))) headp tailp)) + +(define (create-pat:vector pattern) + (make pat:vector (pattern-attrs pattern) pattern)) + +(define (create-pat:box pattern) + (make pat:box (pattern-attrs pattern) pattern)) + +(define (create-pat:pstruct key pattern) + (make pat:pstruct (pattern-attrs pattern) key pattern)) + +(define (create-pat:describe description transparent? p) + (make pat:describe (pattern-attrs p) description transparent? p)) + +(define (create-pat:and patterns) + (let ([attrs (append-iattrs (map pattern-attrs patterns))]) + (make pat:and attrs patterns))) + +(define (create-pat:or patterns) + (let ([attrs (union-iattrs (map pattern-attrs patterns))]) + (make pat:or attrs patterns))) + +(define (create-pat:not pattern) + (make pat:not null pattern)) + +(define (create-pat:dots headps tailp) + (let ([attrs (append-iattrs (map pattern-attrs (cons tailp headps)))]) + (make pat:dots attrs headps tailp))) + +(define (create-pat:delimit pattern) + (make pat:delimit (pattern-attrs pattern) pattern)) + +(define (create-pat:commit pattern) + (make pat:commit (pattern-attrs pattern) pattern)) + +(define (create-pat:post pattern) + (make pat:post (pattern-attrs pattern) pattern)) + +(define (create-pat:integrated name argu predicate description) + (let ([attrs (if name (list (make attr name 0 #t)) null)]) + (make pat:integrated attrs name argu predicate description))) + +;; ---- + +(define (create-action:cut) + (make action:cut null)) + +(define (create-action:fail condition message) + (make action:fail null condition message)) + +(define (create-action:bind clauses) + (make action:bind (map clause:attr-attr clauses) clauses)) + +(define (create-action:and patterns) + (let ([attrs (append-iattrs (map pattern-attrs patterns))]) + (make action:and attrs patterns))) + +(define (create-action:parse pattern expr) + (make action:parse (pattern-attrs pattern) pattern expr)) + +(define (create-action:do stmts) + (make action:do null stmts)) + +(define (create-action:post pattern) + (make action:post (pattern-attrs pattern) pattern)) + +;; ---- + +(define (create-hpat:var name parser argu nested-attrs commit?) + (let ([attrs + (if name (cons (make attr name 0 #t) nested-attrs) nested-attrs)]) + (make hpat:var attrs name parser argu nested-attrs commit?))) + +(define (create-hpat:reflect obj argu attr-decls name nested-attrs) + (let ([attrs + (if name (cons (make attr name 0 #t) nested-attrs) nested-attrs)]) + (make hpat:reflect attrs obj argu attr-decls name nested-attrs))) + +(define (create-hpat:seq lp) + (make hpat:seq (pattern-attrs lp) lp)) + +(define (create-hpat:action g hp) + (cond [(action:and? g) + (for/fold ([hp hp]) ([g (in-list (reverse (action:and-patterns g)))]) + (create-hpat:action g hp))] + [else + (let ([attrs (append-iattrs (map pattern-attrs (list g hp)))]) + (make hpat:action attrs g hp))])) + +(define (create-hpat:describe description transparent? p) + (make hpat:describe (pattern-attrs p) description transparent? p)) + +(define (create-hpat:and hp sp) + (make hpat:and (append-iattrs (map pattern-attrs (list hp sp))) hp sp)) + +(define (create-hpat:or patterns) + (let ([attrs (union-iattrs (map pattern-attrs patterns))]) + (make hpat:or attrs patterns))) + +(define (create-hpat:delimit pattern) + (make hpat:delimit (pattern-attrs pattern) pattern)) + +(define (create-hpat:commit pattern) + (make hpat:commit (pattern-attrs pattern) pattern)) + +(define (create-hpat:post pattern) + (make hpat:post (pattern-attrs pattern) pattern)) + +;; ---- + +(define (action/head-pattern->list-pattern p) + (cond [(action-pattern? p) + (create-pat:action p (create-pat:any))] + [(hpat:seq? p) + ;; simplification: just extract list pattern from hpat:seq + (hpat:seq-inner p)] + [else + (create-pat:head p (create-pat:datum '()))])) + +(define (action-pattern->single-pattern gp) + (create-pat:action gp (create-pat:any))) diff --git a/collects/syntax/private/stxparse/rep.rkt b/collects/syntax/parse/private/rep.rkt similarity index 55% rename from collects/syntax/private/stxparse/rep.rkt rename to collects/syntax/parse/private/rep.rkt index 16b81895b7..e529bd29d4 100644 --- a/collects/syntax/private/stxparse/rep.rkt +++ b/collects/syntax/parse/private/rep.rkt @@ -1,17 +1,19 @@ #lang racket/base -(require (for-template racket/base) - (for-template "runtime.ss") +(require (for-template racket/base + racket/stxparam + "keywords.rkt" + "runtime.rkt") racket/contract/base - "minimatch.ss" + "minimatch.rkt" racket/dict syntax/id-table syntax/stx syntax/keyword unstable/syntax unstable/struct - "../util/txlift.ss" - "rep-data.ss" - "codegen-data.ss") + "txlift.rkt" + "rep-data.rkt" + "kws.rkt") ;; Error reporting ;; All entry points should have explicit, mandatory #:context arg @@ -19,29 +21,37 @@ (provide/contract [parse-rhs - (-> syntax? (or/c false/c (listof sattr?)) boolean? #:context (or/c false/c syntax?) - rhs?)] - [parse-whole-pattern - (-> syntax? DeclEnv/c #:context (or/c false/c syntax?) - pattern?)] - [parse-pattern-directives - (-> stx-list? - #:allow-declare? boolean? - #:decls (or/c false/c DeclEnv/c) + (-> syntax? (or/c false/c (listof sattr?)) boolean? #:context (or/c false/c syntax?) - (values stx-list? DeclEnv/c (listof syntax?) (listof SideClause/c)))] + rhs?)] + [optimize-rhs + (-> rhs? any/c + (or/c #f (list/c rhs? syntax?)))] + [parse-pattern+sides + (-> syntax? syntax? + #:splicing? boolean? + #:decls DeclEnv/c + #:context syntax? + any)] + [parse*-ellipsis-head-pattern + (-> syntax? DeclEnv/c boolean? + #:context syntax? + any)] [parse-directive-table any/c] [get-decls+defs (-> list? boolean? #:context (or/c false/c syntax?) (values DeclEnv/c (listof syntax?)))] - #| - [decls-create-defs - (-> DeclEnv/c - (values DeclEnv/c (listof syntax?)))] - |# [create-aux-def (-> DeclEntry/c (values DeclEntry/c (listof syntax?)))] + [parse-argu + (-> (listof syntax?) + #:context syntax? + arguments?)] + [parse-kw-formals + (-> syntax? + #:context syntax? + arity?)] #| [check-literals-list ;; NEEDS txlift context @@ -59,7 +69,10 @@ |# [check-conventions-rules (-> syntax? syntax? - (listof (list/c regexp? any/c)))]) + (listof (list/c regexp? any/c)))] + [check-attr-arity-list + (-> syntax? syntax? + (listof sattr?))]) (define (atomic-datum? stx) (let ([datum (syntax-e stx)]) @@ -100,19 +113,29 @@ (quote-syntax ~!) (quote-syntax ~bind) (quote-syntax ~fail) - (quote-syntax ~early-fail) (quote-syntax ~parse) - (quote-syntax ...+))) + (quote-syntax ~do) + (quote-syntax ...+) + (quote-syntax ~delimit-cut) + (quote-syntax ~commit) + (quote-syntax ~reflect) + (quote-syntax ~splicing-reflect) + (quote-syntax ~eh-var))) (define (reserved? stx) (and (identifier? stx) - (for/or ([kw keywords]) + (for/or ([kw (in-list keywords)]) (free-identifier=? stx kw)))) (define (safe-name? stx) (and (identifier? stx) (not (regexp-match? #rx"^~" (symbol->string (syntax-e stx)))))) +;; cut-allowed? : (paramter/c boolean?) +;; Used to detect ~cut within ~not pattern. +;; (Also #:no-delimit-cut stxclass within ~not) +(define cut-allowed? (make-parameter #t)) + ;; --- (define (disappeared! x) @@ -136,51 +159,114 @@ (lambda () (parameterize ((current-syntax-context ctx)) (define-values (rest description transp? attributes auto-nested? - decls defs commit?) + decls defs options) (parse-rhs/part1 stx splicing? (and expected-attrs #t))) - (define patterns + (define variants (parameterize ((stxclass-lookup-config (cond [expected-attrs 'yes] - [auto-nested? 'try] - [else 'no]))) + [auto-nested? 'try] + [else 'no]))) (parse-variants rest decls splicing? expected-attrs))) - (when (null? patterns) + (when (null? variants) (wrong-syntax #f "expected at least one variant")) (let ([sattrs (or attributes - (intersect-sattrss (map variant-attrs patterns)))]) - (make rhs stx sattrs transp? description patterns + (intersect-sattrss (map variant-attrs variants)))]) + (make rhs stx sattrs transp? description variants (append (get-txlifts-as-definitions) defs) - commit?)))))) + options #f)))))) (define (parse-rhs/part1 stx splicing? strict?) (define-values (chunks rest) (parse-keyword-options stx rhs-directive-table #:context (current-syntax-context) - #:incompatible '((#:attributes #:auto-nested-attributes)) + #:incompatible '((#:attributes #:auto-nested-attributes) + (#:commit #:no-delimit-cut)) #:no-duplicates? #t)) (define description (options-select-value chunks '#:description #:default #f)) (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 commit? + (and (assq '#:commit chunks) #t)) + (define delimit-cut? + (not (assq '#:no-delimit-cut chunks))) (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 commit?)) + (values rest description transparent? attributes auto-nested? decls defs + (make options commit? delimit-cut?))) + +;; ---- + +#| +A syntax class is integrable if + - only positional params without defaults + - no attributes + - description is a string constant + - one variant: (~fail #:when/unless cond) ... no message + - and thus no txlifted definitions, no convention definitions, etc + - don't care about commit?, delimit-cut?, transparent? + because other restrictions make them irrelevant +|# + +;; optimize-rhs : RHS stxlist -> (list RHS stx)/#f +;; Returns #f to indicate cannot integrate. +(define (optimize-rhs rhs0 params) + (define (check-stx-string x) + (syntax-case x (quote) + [(quote str) (string? (syntax-e #'str)) #'str] + [_ #f])) + (define (stx-false? x) + (syntax-case x (quote) + [(quote #f) #t] + [_ #f])) + (match rhs0 + [(rhs _o '() _trans? (? check-stx-string description) (list variant0) '() _opts '#f) + (match variant0 + [(variant _o '() pattern0 '()) + (match pattern0 + [(pat:action '() (action:fail '() cond-stx msg-stx) (pat:any '())) + (cond [(stx-false? msg-stx) + ;; Yes! + (with-syntax ([(predicate) (generate-temporaries #'(predicate))] + [(param ...) params] + [fail-condition cond-stx]) + (let* ([predicate-def + #'(define (predicate x param ...) + (syntax-parameterize ((this-syntax + (make-rename-transformer + (quote-syntax x)))) + (#%expression (not fail-condition))))] + [integrate* (make integrate #'predicate + (check-stx-string description))] + [pattern* + (create-pat:action + (create-action:fail #'(not (predicate this-syntax param ...)) #'#f) + (create-pat:any))] + [variant* + (variant _o '() pattern* '())]) + (list + (make rhs _o '() _trans? description (list variant*) '() _opts integrate*) + predicate-def)))] + [else #f])] + [_ #f])] + [_ #f])] + [_ #f])) + +;; ---- (define (parse-variants rest decls splicing? expected-attrs) - (define (gather-patterns stx) + (define (gather-variants stx) (syntax-case stx (pattern) [((pattern . _) . rest) (begin (disappeared! (stx-car stx)) (cons (parse-variant (stx-car stx) splicing? decls expected-attrs) - (gather-patterns #'rest)))] + (gather-variants #'rest)))] [(bad-variant . rest) (wrong-syntax #'bad-variant "expected syntax-class variant")] [() null])) - (gather-patterns rest)) + (gather-variants rest)) ;; get-decls+defs : chunks boolean -> (values DeclEnv (listof syntax)) (define (get-decls+defs chunks strict? @@ -200,26 +286,25 @@ (append-lits+litsets lits litsets)) (define-values (convs-rules convs-defs) (for/fold ([convs-rules null] [convs-defs null]) - ([conv-entry convs]) + ([conv-entry (in-list convs)]) (let* ([c (car conv-entry)] - [args (cdr conv-entry)] + [argu (cdr conv-entry)] [get-parser-id (conventions-get-procedures c)] [rules ((conventions-get-rules c))]) (values (append rules convs-rules) - (cons (make-conventions-def (map cadr rules) get-parser-id args) + (cons (make-conventions-def (map cadr rules) get-parser-id argu) convs-defs))))) (define convention-rules (append localconvs convs-rules)) (values (new-declenv literals #:conventions convention-rules) (reverse convs-defs))) -;; make-conventions-def : (listof den:delay) id (listof syntax) -> syntax -(define (make-conventions-def dens get-procedures-id args) +;; make-conventions-def : (listof den:delay) id Argument -> syntax +(define (make-conventions-def dens get-parsers-id argu) (with-syntax ([(parser ...) (map den:delayed-parser dens)] - [get-procedures get-procedures-id] - [(arg ...) args]) + [get-parsers get-parsers-id] + [argu argu]) #'(define-values (parser ...) - (let-values ([(parsers descriptions) (get-procedures arg ...)]) - (apply values parsers))))) + (apply values (app-argu get-parsers argu))))) ;; decls-create-defs : DeclEnv -> (values DeclEnv (listof stx)) (define (decls-create-defs decls0) @@ -234,37 +319,36 @@ (match entry [(struct den:lit (_i _e _ip _lp)) (values entry null)] - [(struct den:class (name class args)) + [(struct den:class (name class argu)) + ;; FIXME: integrable syntax classes? (cond [(identifier? name) - (let ([sc (get-stxclass/check-arg-count class (length args))]) - (with-syntax ([sc-parser (stxclass-parser-name sc)] - [sc-description (stxclass-description sc)]) - (with-syntax ([parser (generate-temporary class)] - [description (generate-temporary class)]) - (values (make den:parser #'parser #'description + (let* ([pos-count (length (arguments-pargs argu))] + [kws (arguments-kws argu)] + [sc (get-stxclass/check-arity class class pos-count kws)]) + (with-syntax ([sc-parser (stxclass-parser sc)]) + (with-syntax ([parser (generate-temporary class)]) + (values (make den:parser #'parser (stxclass-attrs sc) (stxclass/h? sc) - (stxclass-commit? sc)) - (list #`(define-values (parser description) - (curried-stxclass-procedures - #,class #,args)))))))] + (stxclass-commit? sc) (stxclass-delimit-cut? sc)) + (list #`(define-values (parser) + (curried-stxclass-parser #,class #,argu)))))))] [(regexp? name) ;; Conventions rule; delay class lookup until module/intdefs pass2 ;; to allow forward references (with-syntax ([parser (generate-temporary class)] [description (generate-temporary class)]) - (values (make den:delayed #'parser #'description class) - (list #`(define-values (parser description) - (curried-stxclass-procedures - #,class #,args)))))])] - [(struct den:parser (_p _d _a _sp _c)) + (values (make den:delayed #'parser class) + (list #`(define-values (parser) + (curried-stxclass-parser #,class #,argu)))))])] + [(struct den:parser (_p _a _sp _c _dc?)) (values entry null)] - [(struct den:delayed (_p _d _c)) + [(struct den:delayed (_p _c)) (values entry null)])) (define (append-lits+litsets lits litsets) (define seen (make-bound-id-table lits)) - (for ([litset litsets]) - (for ([lit litset]) + (for ([litset (in-list litsets)]) + (for ([lit (in-list litset)]) (when (bound-id-table-ref seen (car lit) #f) (wrong-syntax (car lit) "duplicate literal declaration")) (bound-id-table-set! seen (car lit) #t))) @@ -274,29 +358,40 @@ (define (parse-variant stx splicing? decls0 expected-attrs) (syntax-case stx (pattern) [(pattern p . rest) - (let-values ([(rest decls defs clauses) - (parse-pattern-directives #'rest - #:allow-declare? #t - #:decls decls0)]) + (let-values ([(rest pattern defs) + (parse-pattern+sides #'p #'rest + #:splicing? splicing? + #:decls decls0 + #:context stx)]) (disappeared! stx) (unless (stx-null? rest) (wrong-syntax (if (pair? rest) (car rest) rest) "unexpected terms after pattern directives")) - (let* ([pattern - (parse-whole-pattern #'p decls splicing?)] - [attrs - (append-iattrs - (cons (pattern-attrs pattern) - (side-clauses-attrss clauses)))] + (let* ([attrs (pattern-attrs pattern)] [sattrs (iattrs->sattrs attrs)]) (when expected-attrs (parameterize ((current-syntax-context stx)) ;; Called just for error-reporting (reorder-iattrs expected-attrs attrs))) - (make variant stx sattrs pattern clauses defs)))])) + (make variant stx sattrs pattern defs)))])) + +;; parse-pattern+sides : stx stx -> (values stx Pattern (listof stx)) +;; Parses pattern, side clauses; desugars side clauses & merges with pattern +(define (parse-pattern+sides p-stx s-stx + #:splicing? splicing? + #:decls decls0 + #:context ctx) + (let-values ([(rest decls defs sides) + (parse-pattern-directives s-stx + #:allow-declare? #t + #:decls decls0 + #:context ctx)]) + (let* ([pattern0 (parse-whole-pattern p-stx decls splicing? #:context ctx)] + [pattern (combine-pattern+sides pattern0 sides splicing?)]) + (values rest pattern defs)))) (define (side-clauses-attrss clauses) - (for/list ([c 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)) @@ -317,40 +412,71 @@ #:extra excess-domain)) pattern)) +;; combine-pattern+sides : Pattern (listof SideClause) -> Pattern +(define (combine-pattern+sides pattern sides splicing?) + (define actions-pattern + (create-action:and + (for/list ([side (in-list sides)]) + (match side + [(make clause:fail condition message) + (create-action:post + (create-action:fail condition message))] + [(make clause:with wpat expr defs) + (let ([ap (create-action:post + (create-action:parse wpat expr))]) + (if (pair? defs) + (create-action:and (list (create-action:do defs) ap)) + ap))] + [(make clause:attr attr expr) + (create-action:bind (list side))] + [(make clause:do stmts) + (create-action:do stmts)])))) + (define dummy-pattern + (and (pair? sides) + (create-pat:action actions-pattern (create-pat:any)))) + (if dummy-pattern + (if splicing? + (create-hpat:and pattern dummy-pattern) + (create-pat:and (list pattern dummy-pattern))) + pattern)) + ;; ---- ;; parse-single-pattern : stx DeclEnv -> SinglePattern (define (parse-single-pattern stx decls) - ;; FIXME: allow ghosts, convert to single-term pattern??? - (let ([p (parse-*-pattern stx decls #f #f)]) - p)) + (parse-*-pattern stx decls #f #f)) ;; parse-head-pattern : stx DeclEnv -> HeadPattern (define (parse-head-pattern stx decls) (parse-*-pattern stx decls #t #f)) ;; parse-*-pattern : stx DeclEnv boolean boolean -> Pattern -(define (parse-*-pattern stx decls allow-head? allow-ghost?) +(define (parse-*-pattern stx decls allow-head? allow-action?) (define (check-head! x) (unless allow-head? (wrong-syntax stx "head pattern not allowed here")) x) - (define (check-ghost! x) + (define (check-action! x) ;; Coerce to S-pattern IF only S-patterns allowed - (cond [allow-ghost? x] - [(not allow-head?) (ghost-pattern->single-pattern x)] + (cond [allow-action? x] + [(not allow-head?) (action-pattern->single-pattern x)] [else (wrong-syntax stx "action pattern not allowed here")])) (syntax-case stx (~var ~literal ~datum ~and ~or ~not ~rest ~describe - ~seq ~optional ~! ~bind ~fail ~early-fail ~parse) + ~seq ~optional ~! ~bind ~fail ~parse ~do + ~post ~delimit-cut ~commit ~reflect ~splicing-reflect) [wildcard (wildcard? #'wildcard) (begin (disappeared! stx) (create-pat:any))] [~! (disappeared! stx) - (check-ghost! - (create-ghost:cut))] + (begin + (unless (cut-allowed?) + (wrong-syntax stx + "cut (~~!) not allowed within ~~not pattern")) + (check-action! + (create-action:cut)))] [reserved (reserved? #'reserved) (wrong-syntax stx "pattern keyword not allowed here")] @@ -374,7 +500,7 @@ (parse-pat:literal stx decls)] [(~and . rest) (disappeared! stx) - (parse-pat:and stx decls allow-head? allow-ghost?)] + (parse-pat:and stx decls allow-head? allow-action?)] [(~or . rest) (disappeared! stx) (parse-pat:or stx decls allow-head?)] @@ -387,6 +513,15 @@ [(~describe . rest) (disappeared! stx) (parse-pat:describe stx decls allow-head?)] + [(~delimit-cut . rest) + (disappeared! stx) + (parse-pat:delimit stx decls allow-head?)] + [(~commit . rest) + (disappeared! stx) + (parse-pat:commit stx decls allow-head?)] + [(~reflect . rest) + (disappeared! stx) + (parse-pat:reflect stx decls #f)] [(~seq . rest) (disappeared! stx) (check-head! @@ -395,22 +530,29 @@ (disappeared! stx) (check-head! (parse-hpat:optional stx decls))] + [(~splicing-reflect . rest) + (disappeared! stx) + (check-head! + (parse-pat:reflect stx decls #t))] [(~bind . rest) (disappeared! stx) - (check-ghost! + (check-action! (parse-pat:bind stx decls))] [(~fail . rest) (disappeared! stx) - (check-ghost! - (parse-pat:fail stx decls #f))] - [(~early-fail . rest) + (check-action! + (parse-pat:fail stx decls))] + [(~post . rest) (disappeared! stx) - (check-ghost! - (parse-pat:fail stx decls #t))] + (parse-pat:post stx decls allow-head? allow-action?)] [(~parse . rest) (disappeared! stx) - (check-ghost! + (check-action! (parse-pat:parse stx decls))] + [(~do . rest) + (disappeared! stx) + (check-action! + (parse-pat:do stx decls))] [(head dots . tail) (dots? #'dots) (begin (disappeared! #'dots) @@ -422,57 +564,93 @@ [(head . tail) (let ([headp (parse-*-pattern #'head decls #t #t)] [tailp (parse-single-pattern #'tail decls)]) - ;; Only make pat:head if head is complicated; - ;; otherwise simple compound/pair - ;; FIXME: Could also inline ~seq patterns from head...? - (cond [(ghost-pattern? headp) - (create-pat:ghost headp tailp)] + (cond [(action-pattern? headp) + (create-pat:action headp tailp)] [(head-pattern? headp) (create-pat:head headp tailp)] [else - (create-pat:compound '#:pair (list headp tailp))]))] + (create-pat:pair headp tailp)]))] [#(a ...) (let ([lp (parse-single-pattern (syntax/loc stx (a ...)) decls)]) - (create-pat:compound '#:vector (list lp)))] + (create-pat:vector lp))] [b (box? (syntax-e #'b)) (let ([bp (parse-single-pattern (unbox (syntax-e #'b)) decls)]) - (create-pat:compound '#:box (list bp)))] + (create-pat:box bp))] [s (and (struct? (syntax-e #'s)) (prefab-struct-key (syntax-e #'s))) (let* ([s (syntax-e #'s)] [key (prefab-struct-key s)] [contents (struct->list s)]) (let ([lp (parse-single-pattern (datum->syntax #f contents #'s) decls)]) - (create-pat:compound `(#:pstruct ,key) (list lp))))])) + (create-pat:pstruct key lp)))])) -;; parse-ellipsis-head-pattern : stx DeclEnv number -> (listof EllipsisHeadPattern) +;; parse-ellipsis-head-pattern : stx DeclEnv -> (listof EllipsisHeadPattern) (define (parse-ellipsis-head-pattern stx decls) - (syntax-case stx (~or ~between ~optional ~once) + (for/list ([ehpat+hstx (in-list (parse*-ellipsis-head-pattern stx decls #t))]) + (car ehpat+hstx))) + +;; parse*-ellipsis-head-pattern : stx DeclEnv bool +;; -> (listof (list EllipsisHeadPattern stx/eh-alternative)) +(define (parse*-ellipsis-head-pattern stx decls allow-or? + #:context [ctx (current-syntax-context)]) + (syntax-case stx (~eh-var ~or ~between ~optional ~once) + [(~eh-var name eh-alt-set-id) + (let () + (define prefix (name->prefix #'name ".")) + (define eh-alt-set (get-eh-alternative-set #'eh-alt-set-id)) + (for/list ([alt (in-list (eh-alternative-set-alts eh-alt-set))]) + (let ([iattrs (id-pattern-attrs (eh-alternative-attrs alt) prefix)]) + (list (make ehpat (repc-adjust-attrs iattrs (eh-alternative-repc alt)) + (create-hpat:var #f (eh-alternative-parser alt) no-arguments iattrs #f) + (eh-alternative-repc alt)) + (replace-eh-alternative-attrs + alt (iattrs->sattrs iattrs))))))] [(~or . _) + allow-or? (begin (unless (stx-list? stx) (wrong-syntax stx "expected sequence of patterns")) (apply append - (for/list ([sub (cdr (stx->list stx))]) - (parse-ellipsis-head-pattern sub decls))))] + (for/list ([sub (in-list (cdr (stx->list stx)))]) + (parse*-ellipsis-head-pattern sub decls allow-or?))))] [(~optional . _) (disappeared! stx) - (list (parse-ehpat/optional stx decls))] + (list (parse*-ehpat/optional stx decls))] [(~once . _) (disappeared! stx) - (list (parse-ehpat/once stx decls))] + (list (parse*-ehpat/once stx decls))] [(~between . _) (disappeared! stx) - (list (parse-ehpat/bounds stx decls))] + (list (parse*-ehpat/bounds stx decls))] [_ (let ([head (parse-head-pattern stx decls)]) - (list (make ehpat (map increase-depth (pattern-attrs head)) - head - #f)))])) + (list (list (make ehpat (map increase-depth (pattern-attrs head)) + head + #f) + stx)))])) + +(define (repc-adjust-attrs iattrs repc) + (cond [(or (rep:once? repc) (rep:optional? repc)) + iattrs] + [(or (rep:bounds? repc) (eq? #f repc)) + (map increase-depth iattrs)] + [else + (error 'repc-adjust-attrs "INTERNAL ERROR: unexpected: ~e" repc)])) + +(define (replace-eh-alternative-attrs alt sattrs) + (match alt + [(eh-alternative repc _attrs parser) + (eh-alternative repc sattrs parser)])) ;; ---- +(define (check-no-delimit-cut-in-not id delimit-cut?) + (unless (or delimit-cut? (cut-allowed?)) + (wrong-syntax id + (string-append "syntax class with #:no-delimit-cut option " + "not allowed within ~~not pattern")))) + (define (parse-pat:id id decls allow-head?) (define entry (declenv-lookup decls id)) (match entry @@ -482,20 +660,22 @@ (error 'parse-pat:id "(internal error) decls had leftover stxclass entry: ~s" entry)] - [(struct den:parser (parser desc attrs splicing? commit?)) - ;; FIXME: why no allow-head? check??? - (if splicing? - (begin - (unless allow-head? - (wrong-syntax id "splicing syntax class not allowed here")) - (parse-pat:id/h id parser null attrs commit?)) - (parse-pat:id/s id parser null attrs commit?))] - [(struct den:delayed (parser desc class)) + [(struct den:parser (parser attrs splicing? commit? delimit-cut?)) + (begin + (check-no-delimit-cut-in-not id delimit-cut?) + (if splicing? + (begin + (unless allow-head? + (wrong-syntax id "splicing syntax class not allowed here")) + (parse-pat:id/h id parser no-arguments attrs commit?)) + (parse-pat:id/s id parser no-arguments attrs commit?)))] + [(struct den:delayed (parser class)) (let ([sc (get-stxclass class)]) + (check-no-delimit-cut-in-not id (stxclass-delimit-cut? sc)) (cond [(stxclass/s? sc) (parse-pat:id/s id parser - null + no-arguments (stxclass-attrs sc) (stxclass-commit? sc))] [(stxclass/h? sc) @@ -503,17 +683,16 @@ (wrong-syntax id "splicing syntax class not allowed here")) (parse-pat:id/h id parser - null + no-arguments (stxclass-attrs sc) (stxclass-commit? sc))]))] ['#f - (when #t ;; FIXME: right place??? - (unless (safe-name? id) - (wrong-syntax id "expected identifier not starting with ~~ character"))) + (unless (safe-name? id) + (wrong-syntax id "expected identifier not starting with ~~ character")) (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 #t)))])) + (parse-pat:var* id allow-head? name sc no-arguments) + (create-pat:var name #f no-arguments null #t)))])) (define (parse-pat:var stx decls allow-head?) (define name0 @@ -524,19 +703,19 @@ #'name] [_ (wrong-syntax stx "bad ~~var form")])) - (define-values (scname args pfx) + (define-values (scname argu pfx) (syntax-case stx (~var) [(~var _name) (values #f null #f)] [(~var _name sc/sc+args . rest) - (let-values ([(sc args) + (let-values ([(sc argu) (syntax-case #'sc/sc+args () [sc (identifier? #'sc) - (values #'sc null)] + (values #'sc no-arguments)] [(sc arg ...) (identifier? #'sc) - (values #'sc (syntax->list #'(arg ...)))] + (values #'sc (parse-argu (syntax->list #'(arg ...))))] [_ (wrong-syntax stx "bad ~~var form")])]) (define chunks @@ -545,7 +724,7 @@ #:context stx)) (define sep (options-select-value chunks '#:attr-name-separator #:default #f)) - (values sc args (if sep (syntax-e sep) ".")))] + (values sc argu (if sep (syntax-e sep) ".")))] [_ (wrong-syntax stx "bad ~~var form")])) (cond [(and (epsilon? name0) (not scname)) @@ -553,38 +732,49 @@ [(and (wildcard? name0) (not scname)) (create-pat:any)] [scname - (let ([sc (get-stxclass/check-arg-count scname (length args))]) - (parse-pat:var* stx allow-head? name0 sc args pfx))] + (let ([sc (get-stxclass/check-arity scname stx + (length (arguments-pargs argu)) + (arguments-kws argu))]) + (parse-pat:var* stx allow-head? name0 sc argu pfx))] [else ;; Just proper name - (create-pat:var name0 #f null null #t)])) + (create-pat:var name0 #f (arguments null null null) null #t)])) -(define (parse-pat:var* stx allow-head? name sc args [pfx "."]) +(define (parse-pat:var* stx allow-head? name sc argu [pfx "."]) + (check-no-delimit-cut-in-not stx (stxclass-delimit-cut? sc)) (cond [(stxclass/s? sc) - (parse-pat:id/s name - (stxclass-parser-name sc) - args - (stxclass-attrs sc) - (stxclass-commit? sc) - pfx)] + (if (and (stxclass-integrate sc) (null? (arguments-kws argu))) + (parse-pat:id/s/integrate name (stxclass-integrate sc) argu) + (parse-pat:id/s name + (stxclass-parser sc) + argu + (stxclass-attrs sc) + (stxclass-commit? sc) + pfx))] [(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-parser sc) + argu (stxclass-attrs sc) (stxclass-commit? sc) pfx)])) -(define (parse-pat:id/s name parser args attrs commit? [pfx "."]) +(define (parse-pat:id/s name parser argu attrs commit? [pfx "."]) (define prefix (name->prefix name pfx)) (define bind (name->bind name)) - (create-pat:var bind parser args (id-pattern-attrs attrs prefix) commit?)) + (create-pat:var bind parser argu (id-pattern-attrs attrs prefix) commit?)) -(define (parse-pat:id/h name parser args attrs commit? [pfx "."]) +(define (parse-pat:id/s/integrate name integrate argu) + (define bind (name->bind name)) + (create-pat:integrated bind argu + (integrate-predicate integrate) + (integrate-description integrate))) + +(define (parse-pat:id/h name parser argu attrs commit? [pfx "."]) (define prefix (name->prefix name pfx)) (define bind (name->bind name)) - (create-hpat:var bind parser args (id-pattern-attrs attrs prefix) commit?)) + (create-hpat:var bind parser argu (id-pattern-attrs attrs prefix) commit?)) (define (name->prefix id pfx) (cond [(wildcard? id) #f] @@ -599,7 +789,7 @@ ;; id-pattern-attrs : (listof SAttr)IdPrefix -> (listof IAttr) (define (id-pattern-attrs sattrs prefix) (if prefix - (for/list ([a sattrs]) + (for/list ([a (in-list sattrs)]) (prefix-attr a prefix)) null)) @@ -615,6 +805,26 @@ ;; ---- +(define (parse-pat:reflect stx decls splicing?) + (syntax-case stx () + [(_ name (obj arg ...) . maybe-signature) + (let () + (unless (identifier? #'var) + (raise-syntax-error #f "expected identifier" stx #'name)) + (define attr-decls + (syntax-case #'maybe-signature () + [(#:attributes attr-decls) + (check-attr-arity-list #'attr-decls stx)] + [() null] + [_ (raise-syntax-error #f "bad syntax" stx)])) + (define prefix (name->prefix #'name ".")) + (define bind (name->bind #'name)) + (define ctor (if splicing? create-hpat:reflect create-pat:reflect)) + (ctor #'obj (parse-argu (syntax->list #'(arg ...))) attr-decls bind + (id-pattern-attrs attr-decls prefix)))])) + +;; --- + (define (parse-pat:literal stx decls) (syntax-case stx (~literal) [(~literal lit . more) @@ -636,7 +846,7 @@ (parse-keyword-options #'rest describe-option-table #:no-duplicates? #t #:context stx)]) - (define transparent? (and (assq '#:transparent chunks) #t)) + (define transparent? (not (assq '#:opaque chunks))) (syntax-case rest () [(description pattern) (let ([p (parse-*-pattern #'pattern decls allow-head? #f)]) @@ -644,6 +854,24 @@ (create-hpat:describe #'description transparent? p) (create-pat:describe #'description transparent? p)))]))])) +(define (parse-pat:delimit stx decls allow-head?) + (syntax-case stx () + [(_ pattern) + (let ([p (parameterize ((cut-allowed? #t)) + (parse-*-pattern #'pattern decls allow-head? #f))]) + (if (head-pattern? p) + (create-hpat:delimit p) + (create-pat:delimit p)))])) + +(define (parse-pat:commit stx decls allow-head?) + (syntax-case stx () + [(_ pattern) + (let ([p (parameterize ((cut-allowed? #t)) + (parse-*-pattern #'pattern decls allow-head? #f))]) + (if (head-pattern? p) + (create-hpat:commit p) + (create-pat:commit p)))])) + (define (split-prefix xs pred) (let loop ([xs xs] [rprefix null]) (cond [(and (pair? xs) (pred (car xs))) @@ -651,14 +879,14 @@ [else (values (reverse rprefix) xs)]))) -(define (parse-pat:and stx decls allow-head? allow-ghost?) - ;; allow-ghost? = allowed to *return* pure ghost pattern; - ;; all ~and patterns are allowed to *contain* ghost patterns +(define (parse-pat:and stx decls allow-head? allow-action?) + ;; allow-action? = allowed to *return* pure action pattern; + ;; all ~and patterns are allowed to *contain* action patterns (define patterns0 (parse-cdr-patterns stx decls allow-head? #t)) - (define-values (ghosts patterns) (split-prefix patterns0 ghost-pattern?)) + (define-values (actions patterns) (split-prefix patterns0 action-pattern?)) (cond [(null? patterns) - (cond [allow-ghost? - (create-ghost:and ghosts)] + (cond [allow-action? + (create-action:and actions)] [allow-head? (wrong-syntax stx "expected at least one head pattern")] [else @@ -666,10 +894,10 @@ [else (let ([p (parse-pat:and* stx patterns)]) (if (head-pattern? p) - (for/fold ([p p]) ([ghost (reverse ghosts)]) - (create-hpat:ghost ghost p)) - (for/fold ([p p]) ([ghost (reverse ghosts)]) - (create-pat:ghost ghost p))))])) + (for/fold ([p p]) ([action (in-list (reverse actions))]) + (create-hpat:action action p)) + (for/fold ([p p]) ([action (in-list (reverse actions))]) + (create-pat:action action p))))])) (define (parse-pat:and* stx patterns) ;; patterns is non-empty (empty case handled above) @@ -677,20 +905,20 @@ (car patterns)] [(ormap head-pattern? patterns) ;; Check to make sure *all* are head patterns - (for ([pattern patterns] - [pattern-stx (stx->list (stx-cdr stx))]) - (unless (or (ghost-pattern? pattern) (head-pattern? pattern)) + (for ([pattern (in-list patterns)] + [pattern-stx (in-list (stx->list (stx-cdr stx)))]) + (unless (or (action-pattern? pattern) (head-pattern? pattern)) (wrong-syntax pattern-stx "single-term pattern not allowed after head pattern"))) (let ([p0 (car patterns)] - [lps (map ghost/head-pattern->list-pattern (cdr patterns))]) + [lps (map action/head-pattern->list-pattern (cdr patterns))]) (create-hpat:and p0 (create-pat:and lps)))] [else (create-pat:and - (for/list ([p patterns]) - (if (ghost-pattern? p) - (ghost-pattern->single-pattern p) + (for/list ([p (in-list patterns)]) + (if (action-pattern? p) + (action-pattern->single-pattern p) p)))])) (define (parse-pat:or stx decls allow-head?) @@ -706,7 +934,8 @@ (define (parse-pat:not stx decls) (syntax-case stx (~not) [(~not pattern) - (let ([p (parse-single-pattern #'pattern decls)]) + (let ([p (parameterize ((cut-allowed? #f)) + (parse-single-pattern #'pattern decls))]) (create-pat:not p))] [_ (wrong-syntax stx "expected a single subpattern")])) @@ -716,12 +945,12 @@ (check-list-pattern pattern stx) (create-hpat:seq pattern)) -(define (parse-cdr-patterns stx decls allow-head? allow-ghost?) +(define (parse-cdr-patterns stx decls allow-head? allow-action?) (unless (stx-list? stx) (wrong-syntax stx "expected sequence of patterns")) (let ([result - (for/list ([sub (cdr (stx->list stx))]) - (parse-*-pattern sub decls allow-head? allow-ghost?))]) + (for/list ([sub (in-list (cdr (stx->list stx)))]) + (parse-*-pattern sub decls allow-head? allow-action?))]) (when (null? result) (wrong-syntax stx "expected at least one pattern")) result)) @@ -746,11 +975,11 @@ (syntax-case stx () [(_ clause ...) (let ([clauses (check-bind-clause-list #'(clause ...) stx)]) - (make ghost:bind + (make action:bind (append-iattrs (side-clauses-attrss clauses)) clauses))])) -(define (parse-pat:fail stx decls early?) +(define (parse-pat:fail stx decls) (syntax-case stx () [(_ . rest) (let-values ([(chunks rest) @@ -767,20 +996,40 @@ #`(not #,(caddr chunk)))))]) (syntax-case rest () [(message) - (create-ghost:fail early? condition #'message)] + (create-action:fail condition #'message)] [() - (wrong-syntax stx "missing message expression")] + (create-action:fail condition #''#f)] [_ (wrong-syntax stx "bad ~~fail pattern")])))])) +(define (parse-pat:post stx decls allow-head? allow-action?) + (syntax-case stx () + [(_ pattern) + (let ([p (parse-*-pattern #'pattern decls allow-head? allow-action?)]) + (cond [(action-pattern? p) + (cond [allow-action? (create-action:post p)] + [(not allow-head?) (create-pat:post (action-pattern->single-pattern p))] + [else (wrong-syntax stx "action pattern not allowed here")])] + [(head-pattern? p) + (cond [allow-head? (create-hpat:post p)] + [else (wrong-syntax stx "head pattern now allowed here")])] + [else + (create-pat:post p)]))])) + (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))] + (create-action:parse p #'expr))] [_ (wrong-syntax stx "bad ~~parse pattern")])) +(define (parse-pat:do stx decls) + (syntax-case stx (~do) + [(~do stmt ...) + (create-action:do (syntax->list #'(stmt ...)))] + [_ + (wrong-syntax stx "bad ~~do pattern")])) (define (parse-pat:rest stx decls) (syntax-case stx () @@ -793,72 +1042,85 @@ #t] [(make pat:head _base _head tail) (check-list-pattern tail stx)] - [(make pat:ghost _base _ghost tail) + [(make pat:action _base _action tail) (check-list-pattern tail stx)] [(make pat:dots _base _head tail) (check-list-pattern tail stx)] - [(make pat:compound _base '#:pair (list _head tail)) + [(make pat:pair _base _head tail) (check-list-pattern tail stx)] [_ (wrong-syntax stx "expected proper list pattern")])) (define (parse-hpat:optional stx decls) - (define-values (head all-iattrs _name _tmm defaults) - (parse-optional-pattern stx decls h-optional-directive-table)) - (make hpat:optional all-iattrs head defaults)) + (define-values (head-stx head iattrs _name _tmm defaults) + (parse*-optional-pattern stx decls h-optional-directive-table)) + (make hpat:optional iattrs head defaults)) -(define (parse-ehpat/optional stx decls) - (define-values (head all-iattrs name too-many-msg defaults) - (parse-optional-pattern stx decls eh-optional-directive-table)) - (make ehpat all-iattrs head - (make rep:optional name too-many-msg defaults))) - -(define (parse-optional-pattern stx decls optional-directive-table) +;; parse*-optional-pattern : stx DeclEnv table +;; -> (values +(define (parse*-optional-pattern stx decls optional-directive-table) (syntax-case stx (~optional) [(~optional p . options) - (let ([head (parse-head-pattern #'p decls)]) - (define chunks - (parse-keyword-options/eol #'options optional-directive-table - #:no-duplicates? #t - #:context stx)) - (let ([too-many-msg - (options-select-value chunks '#:too-many #:default #'#f)] - [name - (options-select-value chunks '#:name #:default #'#f)] - [defaults - (options-select-value chunks '#:defaults #:default '())]) - (define pattern-iattrs (pattern-attrs head)) - (define defaults-iattrs - (append-iattrs (side-clauses-attrss defaults))) - (define all-iattrs - (union-iattrs (list pattern-iattrs defaults-iattrs))) - (check-iattrs-subset defaults-iattrs pattern-iattrs stx) - (values head all-iattrs name too-many-msg defaults)))])) + (let* ([head (parse-head-pattern #'p decls)] + [chunks + (parse-keyword-options/eol #'options optional-directive-table + #:no-duplicates? #t + #:context stx)] + [too-many-msg + (options-select-value chunks '#:too-many #:default #'#f)] + [name + (options-select-value chunks '#:name #:default #'#f)] + [defaults + (options-select-value chunks '#:defaults #:default '())] + [pattern-iattrs (pattern-attrs head)] + [defaults-iattrs + (append-iattrs (side-clauses-attrss defaults))] + [all-iattrs + (union-iattrs (list pattern-iattrs defaults-iattrs))]) + (check-iattrs-subset defaults-iattrs pattern-iattrs stx) + (values #'p head all-iattrs name too-many-msg defaults))])) -(define (parse-ehpat/once stx decls) +;; -- EH patterns +;; Only parse the rep-constraint part; don't parse the head pattern within. +;; (To support eh-alternative-sets.) + +;; parse*-ehpat/optional : stx DeclEnv -> (list EllipsisHeadPattern stx) +(define (parse*-ehpat/optional stx decls) + (define-values (head-stx head iattrs name too-many-msg defaults) + (parse*-optional-pattern stx decls eh-optional-directive-table)) + (list (make ehpat iattrs + head + (make rep:optional name too-many-msg defaults)) + head-stx)) + +;; parse*-ehpat/once : stx DeclEnv -> (list EllipsisHeadPattern stx) +(define (parse*-ehpat/once stx decls) (syntax-case stx (~once) [(~once p . options) - (let ([head (parse-head-pattern #'p decls)]) - (define chunks - (parse-keyword-options/eol #'options - (list (list '#:too-few check-expression) - (list '#:too-many check-expression) - (list '#:name check-expression)) - #:context stx)) - (let ([too-few-msg - (options-select-value chunks '#:too-few #:default #'#f)] - [too-many-msg - (options-select-value chunks '#:too-many #:default #'#f)] - [name - (options-select-value chunks '#:name #:default #'#f)]) - (make ehpat (pattern-attrs head) - head - (make rep:once name too-few-msg too-many-msg))))])) + (let* ([head (parse-head-pattern #'p decls)] + [chunks + (parse-keyword-options/eol #'options + (list (list '#:too-few check-expression) + (list '#:too-many check-expression) + (list '#:name check-expression)) + #:context stx)] + [too-few-msg + (options-select-value chunks '#:too-few #:default #'#f)] + [too-many-msg + (options-select-value chunks '#:too-many #:default #'#f)] + [name + (options-select-value chunks '#:name #:default #'#f)]) + (list (make ehpat (pattern-attrs head) + head + (make rep:once name too-few-msg too-many-msg)) + #'p))])) -(define (parse-ehpat/bounds stx decls) +;; parse*-ehpat/bounds : stx DeclEnv -> (list EllipsisHeadPattern stx) +(define (parse*-ehpat/bounds stx decls) (syntax-case stx (~between) [(~between p min max . options) - (let ([head (parse-head-pattern #'p decls)]) + (let () + (define head (parse-head-pattern #'p decls)) (define minN (syntax-e #'min)) (define maxN (syntax-e #'max)) (unless (exact-nonnegative-integer? minN) @@ -869,22 +1131,23 @@ "expected exact nonnegative integer or +inf.0")) (when (> minN maxN) (wrong-syntax stx "minimum larger than maximum repetition constraint")) - (let ([chunks (parse-keyword-options/eol - #'options - (list (list '#:too-few check-expression) - (list '#:too-many check-expression) - (list '#:name check-expression)) - #:context stx)]) - (let ([too-few-msg - (options-select-value chunks '#:too-few #:default #'#f)] - [too-many-msg - (options-select-value chunks '#:too-many #:default #'#f)] - [name - (options-select-value chunks '#:name #:default #'#f)]) - (make ehpat (map increase-depth (pattern-attrs head)) - head - (make rep:bounds #'min #'max - name too-few-msg too-many-msg)))))])) + (let* ([chunks (parse-keyword-options/eol + #'options + (list (list '#:too-few check-expression) + (list '#:too-many check-expression) + (list '#:name check-expression)) + #:context stx)] + [too-few-msg + (options-select-value chunks '#:too-few #:default #'#f)] + [too-many-msg + (options-select-value chunks '#:too-many #:default #'#f)] + [name + (options-select-value chunks '#:name #:default #'#f)]) + (list (make ehpat (map increase-depth (pattern-attrs head)) + head + (make rep:bounds #'min #'max + name too-few-msg too-many-msg)) + #'p)))])) ;; ----- @@ -893,7 +1156,7 @@ (define (parse-pattern-directives stx #:allow-declare? allow-declare? #:decls decls - #:context [ctx (current-syntax-context)]) + #:context ctx) (parameterize ((current-syntax-context ctx)) (define-values (chunks rest) (parse-keyword-options stx pattern-directive-table #:context ctx)) @@ -935,6 +1198,9 @@ [(cons (list '#:attr attr-stx a expr) rest) (cons (make clause:attr a expr) (parse-pattern-sides rest decls))] + [(cons (list '#:do do-stx stmts) rest) + (cons (make clause:do stmts) + (parse-pattern-sides rest decls))] ['() '()])) @@ -945,15 +1211,15 @@ (syntax-case stx () [(#:declare name sc) (identifier? #'sc) - (add-decl* decls #'name #'sc null)] + (add-decl* decls #'name #'sc (parse-argu null))] [(#:declare name (sc expr ...)) (identifier? #'sc) - (add-decl* decls #'name #'sc (syntax->list #'(expr ...)))] + (add-decl* decls #'name #'sc (parse-argu (syntax->list #'(expr ...))))] [(#:declare name bad-sc) (wrong-syntax #'bad-sc "expected syntax class name (possibly with parameters)")])) - (define (add-decl* decls id sc-name args) - (declenv-put-stxclass decls id sc-name args)) + (define (add-decl* decls id sc-name argu) + (declenv-put-stxclass decls id sc-name argu)) (define (loop chunks decls) (match chunks [(cons (cons '#:declare decl-stx) rest) @@ -970,7 +1236,9 @@ (define (check-attr-arity-list stx ctx) (unless (stx-list? stx) (raise-syntax-error #f "expected list of attribute declarations" ctx stx)) - (let ([iattrs (for/list ([x (stx->list stx)]) (check-attr-arity x ctx))]) + (let ([iattrs + (for/list ([x (in-list (stx->list stx))]) + (check-attr-arity x ctx))]) (iattrs->sattrs (append-iattrs (map list iattrs))))) ;; check-attr-arity : stx stx -> IAttr @@ -994,7 +1262,9 @@ (define (check-literals-list stx ctx) (unless (stx-list? stx) (raise-syntax-error #f "expected literals list" ctx stx)) - (let ([lits (for/list ([x (stx->list stx)]) (check-literal-entry x ctx))]) + (let ([lits + (for/list ([x (in-list (stx->list stx))]) + (check-literal-entry x ctx))]) (let ([dup (check-duplicate-identifier (map car lits))]) (when dup (raise-syntax-error #f "duplicate literal identifier" ctx dup))) lits)) @@ -1023,7 +1293,7 @@ ;; check-literals-list/litset : stx stx -> (listof (list id id)) (define (check-literals-list/litset stx ctx) - (let ([lits (for/list ([x (stx->list stx)]) + (let ([lits (for/list ([x (in-list (stx->list stx))]) (check-literal-entry/litset x ctx))]) (let ([dup (check-duplicate-identifier (map car lits))]) (when dup (raise-syntax-error #f "duplicate literal identifier" ctx dup))) @@ -1048,7 +1318,7 @@ (define (check-literal-sets-list stx ctx) (unless (stx-list? stx) (raise-syntax-error #f "expected literal-set list" ctx stx)) - (for/list ([x (stx->list stx)]) + (for/list ([x (in-list (stx->list stx))]) (check-literal-set-entry x ctx))) ;; check-literal-set-entry : stx stx -> (listof (list id id ct-phase^2)) @@ -1060,7 +1330,7 @@ ctx litset-id)) (elaborate2 litset lctx phase))) (define (elaborate2 litset lctx phase) - (for/list ([entry (literalset-literals litset)]) + (for/list ([entry (in-list (literalset-literals litset))]) (list (datum->syntax lctx (car entry) stx) (cadr entry) phase @@ -1087,24 +1357,24 @@ (define (check-conventions-list stx ctx) (unless (stx-list? stx) (raise-syntax-error #f "expected conventions list" ctx stx)) - (for/list ([x (stx->list stx)]) + (for/list ([x (in-list (stx->list stx))]) (check-conventions x ctx))) ;; returns (cons Conventions (listof syntax)) (define (check-conventions stx ctx) - (define (elaborate conventions-id args) + (define (elaborate conventions-id argu) (let ([cs (syntax-local-value/record conventions-id conventions?)]) (unless cs (raise-syntax-error #f "expected identifier defined as a conventions" ctx conventions-id)) - (cons cs args))) + (cons cs argu))) (syntax-case stx () [(conventions arg ...) (identifier? #'conventions) - (elaborate #'conventions (syntax->list #'(arg ...)))] + (elaborate #'conventions (parse-argu (syntax->list #'(arg ...))))] [conventions (identifier? #'conventions) - (elaborate #'conventions null)] + (elaborate #'conventions no-arguments)] [_ (raise-syntax-error "expected conventions entry" ctx stx)])) @@ -1112,7 +1382,7 @@ (define (check-conventions-rules stx ctx) (unless (stx-list? stx) (raise-syntax-error #f "expected convention rule list" ctx stx)) - (for/list ([x (stx->list stx)]) + (for/list ([x (in-list (stx->list stx))]) (check-conventions-rule x ctx))) ;; returns (list regexp DeclEntry) @@ -1128,10 +1398,10 @@ (syntax-case x () [sc (identifier? #'sc) - (make den:class rx #'sc null)] + (make den:class rx #'sc no-arguments)] [(sc arg ...) (identifier? #'sc) - (make den:class rx #'sc (syntax->list #'(arg ...)))] + (make den:class rx #'sc (parse-argu (syntax->list #'(arg ...))))] [_ (raise-syntax-error #f "expected syntax class use" ctx x)])) (syntax-case stx () [(rx sc) @@ -1143,7 +1413,7 @@ (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)]) + (for/list ([clause (in-list (stx->list stx))]) (check-bind-clause clause ctx))) (define (check-bind-clause clause ctx) @@ -1152,6 +1422,104 @@ (make clause:attr (check-attr-arity #'attr-decl ctx) #'expr)] [_ (raise-syntax-error #f "expected bind clause" ctx clause)])) +(define (check-stmt-list stx ctx) + (syntax-case stx () + [(e ...) + (syntax->list #'(e ...))] + [_ + (raise-syntax-error #f "expected list of expressions and definitions" ctx stx)])) + +;; Arguments and Arities + +;; parse-argu : (listof stx) -> Arguments +(define (parse-argu args #:context [ctx (current-syntax-context)]) + (parameterize ((current-syntax-context ctx)) + (define (loop args rpargs rkws rkwargs) + (cond [(null? args) + (arguments (reverse rpargs) (reverse rkws) (reverse rkwargs))] + [(keyword? (syntax-e (car args))) + (let ([kw (syntax-e (car args))] + [rest (cdr args)]) + (cond [(memq kw rkws) + (wrong-syntax (car args) "duplicate keyword")] + [(null? rest) + (wrong-syntax (car args) + "missing argument expression after keyword")] + #| Overzealous, perhaps? + [(keyword? (syntax-e (car rest))) + (wrong-syntax (car rest) "expected expression following keyword")] + |# + [else + (loop (cdr rest) rpargs (cons kw rkws) (cons (car rest) rkwargs))]))] + [else + (loop (cdr args) (cons (car args) rpargs) rkws rkwargs)])) + (loop args null null null))) + +;; parse-kw-formals : stx -> Arity +(define (parse-kw-formals formals #:context [ctx (current-syntax-context)]) + (parameterize ((current-syntax-context ctx)) + (define id-h (make-bound-id-table)) + (define kw-h (make-hasheq)) ;; keyword => 'mandatory or 'optional + (define pos 0) + (define opts 0) + (define (add-id! id) + (when (bound-id-table-ref id-h id #f) + (wrong-syntax id "duplicate formal parameter" )) + (bound-id-table-set! id-h id #t)) + (define (loop formals) + (cond [(and (stx-pair? formals) (keyword? (syntax-e (stx-car formals)))) + (let* ([kw-stx (stx-car formals)] + [kw (syntax-e kw-stx)] + [rest (stx-cdr formals)]) + (cond [(hash-ref kw-h kw #f) + (wrong-syntax kw-stx "duplicate keyword")] + [(stx-null? rest) + (wrong-syntax kw-stx "missing formal parameter after keyword")] + [else + (let-values ([(formal opt?) (parse-formal (stx-car rest))]) + (add-id! formal) + (hash-set! kw-h kw (if opt? 'optional 'mandatory))) + (loop (stx-cdr rest))]))] + [(stx-pair? formals) + (let-values ([(formal opt?) (parse-formal (stx-car formals))]) + (when (and (positive? opts) (not opt?)) + (wrong-syntax (stx-car formals) + "mandatory argument may not follow optional argument")) + (add-id! formal) + (set! pos (add1 pos)) + (when opt? (set! opts (add1 opts))) + (loop (stx-cdr formals)))] + [(identifier? formals) + (add-id! formals) + (finish #t)] + [(stx-null? formals) + (finish #f)] + [else + (wrong-syntax formals "bad argument sequence")])) + (define (finish has-rest?) + (arity (- pos opts) + (if has-rest? +inf.0 pos) + (sort (for/list ([(k v) (in-hash kw-h)] + #:when (eq? v 'mandatory)) + k) + keyword (values id bool) +(define (parse-formal formal) + (syntax-case formal () + [param + (identifier? #'param) + (values #'param #f)] + [(param default) + (identifier? #'param) + (values #'param #t)] + [_ + (wrong-syntax formal + "expected formal parameter with optional default")])) + ;; Directive tables @@ -1174,7 +1542,8 @@ (list '#:opaque) (list '#:attributes check-attr-arity-list) (list '#:auto-nested-attributes) - (list '#:commit? check-stx-boolean) + (list '#:commit) + (list '#:no-delimit-cut) common-parse-directive-table)) ;; pattern-directive-table @@ -1184,7 +1553,8 @@ (list '#:fail-unless check-expression check-expression) (list '#:when check-expression) (list '#:with check-expression check-expression) - (list '#:attr check-attr-arity check-expression))) + (list '#:attr check-attr-arity check-expression) + (list '#:do check-stmt-list))) ;; fail-directive-table (define fail-directive-table @@ -1193,7 +1563,7 @@ ;; describe-option-table (define describe-option-table - (list (list '#:transparent))) + (list (list '#:opaque))) ;; eh-optional-directive-table (define eh-optional-directive-table diff --git a/collects/syntax/parse/private/runtime-failure.rkt b/collects/syntax/parse/private/runtime-failure.rkt new file mode 100644 index 0000000000..2f33ee7696 --- /dev/null +++ b/collects/syntax/parse/private/runtime-failure.rkt @@ -0,0 +1,200 @@ +#lang racket/base +(require "minimatch.rkt" + "runtime-progress.rkt") +(provide (struct-out failure) + + expect? + (struct-out expect:thing) + (struct-out expect:atom) + (struct-out expect:literal) + (struct-out expect:message) + (struct-out expect:disj) + + normalize-expectstack + simplify-common-expectstacks + maximal-failures + partition/equal?) + +;; A Failure is (make-failure PS ExpectStack) +;; A FailureSet is one of +;; - Failure +;; - (cons FailureSet FailureSet) + +;; FailFunction = (FailureSet -> Answer) + +(define-struct failure (progress expectstack) #:prefab) + +;; == Expectations + +;; FIXME: add phase to expect:literal + +#| +An ExpectStack is (listof (cons Expect syntax)) + +FIXME: (cons Expect syntax) -> struct instead? +FIXME: replace syntax with progress (better cdr handling) + +An Expect is one of + - (make-expect:thing string boolean) + * (make-expect:message string) + * (make-expect:atom atom) + * (make-expect:literal identifier) + * (make-expect:disj (non-empty-listof Expect)) + +The *-marked variants can only occur at the top of the stack. +|# +(define-struct expect:thing (description transparent?) #:prefab) +(define-struct expect:message (message) #:prefab) +(define-struct expect:atom (atom) #:prefab) +(define-struct expect:literal (literal) #:prefab) +(define-struct expect:disj (expects) #:prefab) + +(define (expect? x) + (or (expect:thing? x) + (expect:message? x) + (expect:atom? x) + (expect:literal? x) + (expect:disj? x))) + + +;; == Failure simplification == + +;; maximal-failures : FailureSet -> (listof (listof Failure)) +(define (maximal-failures fs) + (define ann-failures + (for/list ([f (in-list (flatten fs null))]) + (cons f (invert-ps (failure-progress f))))) + (maximal/progress ann-failures)) + +(define (flatten fs onto) + (cond [(pair? fs) + (flatten (car fs) (flatten (cdr fs) onto))] + [else + (cons fs onto)])) + +;; == Expectation simplification == + +;; normalize-expectstack : ExpectStack -> ExpectStack +(define (normalize-expectstack es) + (filter-expectstack (truncate-opaque-expectstack es))) + +;; truncate-opaque-expectstack : ExpectStack -> ExpectStack +;; Eliminates expectations on top of opaque (ie, transparent=#f) frames. +(define (truncate-opaque-expectstack es) + (let/ec return + (let loop ([es es]) + (match es + ['() '()] + [(cons (cons (expect:thing description '#f) stx) rest-es) + ;; Tricky! If multiple opaque frames, multiple "returns", + ;; but innermost one called first, so jumps past the rest. + (return (cons (car es) (loop rest-es)))] + [(cons expect+stx rest-es) + (cons expect+stx (loop rest-es))])))) + +;; filter-expectstack : ExpectStack -> ExpectStack +;; Eliminates missing (ie, #f) messages and descriptions +(define (filter-expectstack es) + (filter (lambda (expect) + (match expect + [(cons (expect:thing '#f _) _) + #f] + [(cons (expect:message '#f) _) + #f] + [_ #t])) + es)) + +#| +Simplification dilemma + +What if we have (e1 e2) and (e2)? How do we report that? +Options: + 1) consider them separate + 2) simplify to (e2), drop e1 + +Big problem with Option 1: + eg (x:id ...) matching #'1 yields + (union (failure #:progress () #:expectstack ()) + (failure #:progress () #:expectstack (#s(expect:atom ())))) +but we don't want to see "expected ()" + +So we go with option 2. +|# + +;; simplify-common-expectstacks : (listof ExpectStack) -> (listof ExpectStack) +;; Should call remove-duplicates first. +(define (simplify-common-expectstacks ess) + ;; simplify : (listof ReversedExpectStack) -> (listof ReversedExpectStack) + (define (simplify ress) + (let ([ress-partitions (partition/car ress)]) + (if ress-partitions + (apply append + (for/list ([ress-partition (in-list ress-partitions)]) + (let ([proto-frame (car (car ress-partition))] + [cdr-ress (map cdr ress-partition)]) + (map (lambda (res) (cons proto-frame res)) + (simplify/check-leafs cdr-ress))))) + (list null)))) + ;; simplify/check-leafs : (listof ReversedExpectStack) -> (listof ReversedExpectStack) + (define (simplify/check-leafs ress) + (let ([ress (simplify ress)]) + (cond [(andmap singleton? ress) + ;; Assume the syntax parts are the same + (let* ([frames (map car ress)] + [frame-stx (cdr (car frames))]) + (list (list (cons (if (singleton? frames) + (car (car frames)) + (expect:disj (map car frames))) + frame-stx))))] + [else ress]))) + ;; singleton? : list -> boolean + (define (singleton? res) + (and (pair? res) (null? (cdr res)))) + (map reverse (simplify/check-leafs (map reverse ess)))) + +;; partition/car : (listof list) -> (listof (listof list))/#f +;; Returns #f if any of lists is empty. +(define (partition/car lists) + (and (andmap pair? lists) + (partition/equal? lists car))) + +(define (partition/equal? items key) + (let ([r-keys null] ;; mutated + [key-t (make-hash)]) + (for ([item (in-list items)]) + (let ([k (key item)]) + (let ([entry (hash-ref key-t k null)]) + (when (null? entry) + (set! r-keys (cons k r-keys))) + (hash-set! key-t k (cons item entry))))) + (let loop ([r-keys r-keys] [acc null]) + (cond [(null? r-keys) acc] + [else + (loop (cdr r-keys) + (cons (reverse (hash-ref key-t (car r-keys))) + acc))])))) + +;; ==== Debugging + +(provide failureset->sexpr + failure->sexpr + expectstack->sexpr + expect->sexpr) + +(define (failureset->sexpr fs) + (let ([fs (flatten fs null)]) + (case (length fs) + ((1) (failure->sexpr (car fs))) + (else `(union ,@(map failure->sexpr fs)))))) + +(define (failure->sexpr f) + (match f + [(failure progress expectstack) + `(failure ,(progress->sexpr progress) + #:expected ,(expectstack->sexpr expectstack))])) + +(define (expectstack->sexpr es) + (map expect->sexpr es)) + +(define (expect->sexpr e) + e) diff --git a/collects/syntax/parse/private/runtime-progress.rkt b/collects/syntax/parse/private/runtime-progress.rkt new file mode 100644 index 0000000000..ac69e222d2 --- /dev/null +++ b/collects/syntax/parse/private/runtime-progress.rkt @@ -0,0 +1,266 @@ +#lang racket/base +(require unstable/struct + syntax/stx + "minimatch.rkt") +(provide ps-empty + ps-add-car + ps-add-cdr + ps-add-post + ps-add-stx + ps-add-unbox + ps-add-unvector + ps-add-unpstruct + ps-add-opaque + + #| + ps->stx+index + |# + ps-context-syntax + ps-difference + + invert-ps + maximal/progress + + progress->sexpr) + +#| +Progress (PS) is a non-empty list of Progress Frames (PF). + +A PF is one of + - stx ;; "Base" frame + - 'car + - nat ;; Represents that many repeated cdrs + - 'post + - 'opaque + +stx frame introduced + - always at base (that is, by syntax-parse) + - if syntax-parse has #:context arg, then two stx frames at bottom: + (list to-match-stx context-stx) + - by #:with/~parse + - by #:fail-*/#:when/~fail & stx + +Interpretation: Inner PS structures are applied first. + eg, (list 'car 1 #'___) + means ( car of ( cdr once of the term ) ) + NOT apply car, then apply cdr once, then stop +|# + +(define (ps-empty stx ctx) + (if (eq? stx ctx) + (list stx) + (list stx ctx))) +(define (ps-add-car parent) + (cons 'car parent)) +(define (ps-add-cdr parent [times 1]) + (if (zero? times) + parent + (match (car parent) + [(? exact-positive-integer? n) + (cons (+ times n) (cdr parent))] + [_ + (cons times parent)]))) +(define (ps-add-post parent) + (cons 'post parent)) +(define (ps-add-stx parent stx) + (cons stx parent)) +(define (ps-add-unbox parent) + (ps-add-car parent)) +(define (ps-add-unvector parent) + (ps-add-car parent)) +(define (ps-add-unpstruct parent) + (ps-add-car parent)) +(define (ps-add-opaque parent) + (cons 'opaque parent)) + +;; ps-context-syntax : Progress -> syntax +(define (ps-context-syntax ps) + ;; Bottom frame is always syntax + (car (reverse ps))) + +;; ps->stx+index : Progress -> (values stx nat) +;; Gets the innermost stx that should have a real srcloc, and the offset +;; (number of cdrs) within that where the progress ends. +(define (ps->stx+index ps) + (define (interp ps) + (match ps + [(cons (? syntax? stx) _) stx] + [(cons 'car parent) + (let ([d (syntax-e (interp parent))]) + (cond [(pair? d) (car d)] + [(vector? d) (vector->list d)] + [(box? d) (unbox d)] + [(prefab-struct-key d) (struct->list d)] + [else (error 'ps->stx+index "INTERNAL ERROR: unexpected: ~e" d)]))] + [(cons (? exact-positive-integer? n) parent) + (for/fold ([stx (interp parent)]) ([i (in-range n)]) + (stx-cdr stx))] + [(cons 'post parent) + (interp parent)])) + (match ps + [(cons (? syntax? stx) _) + (values stx 0)] + [(cons 'car parent) + (values (interp ps) 0)] + [(cons (? exact-positive-integer? n) parent) + (values (interp parent) n)] + [(cons 'post parent) + (ps->stx+index parent)])) + +;; ps-difference : PS PS -> nat +;; Returns N s.t. B = (ps-add-cdr^N A) +(define (ps-difference a b) + (define (whoops) + (error 'ps-difference "~e is not an extension of ~e" + (progress->sexpr b) (progress->sexpr a))) + (match (list a b) + [(list (cons (? exact-positive-integer? na) pa) + (cons (? exact-positive-integer? nb) pb)) + (unless (equal? pa pb) (whoops)) + (- nb na)] + [(list pa (cons (? exact-positive-integer? nb) pb)) + (unless (equal? pa pb) (whoops)) + nb] + [_ + (unless (equal? a b) (whoops)) + 0])) + +;; ps-truncate-opaque : PS -> PS +(define (ps-truncate-opaque ps) + (let/ec return + (let loop ([ps ps]) + (cond [(null? ps) + null] + [(eq? (car ps) 'opaque) + ;; Tricky! We only jump after loop returns, + ;; so jump closest to end wins. + (return (loop (cdr ps)))] + [else + ;; Either (loop _) jumps, or it is identity + (loop (cdr ps)) + ps])))) + +#| +Progress ordering +----------------- + +Lexicographic generalization of partial order on frames + CAR < CDR < POST, stx incomparable except to self + +Progress equality +----------------- + +If ps1 = ps2 then both must "blame" the same term, +ie (ps->stx+index ps1) = (ps->stx+index ps2). +|# + +;; An Inverted PS (IPS) is a PS inverted for easy comparison. +;; An IPS may not contain any 'opaque frames. + +;; invert-ps : PS -> IPS +(define (invert-ps ps) + (reverse (ps-truncate-opaque ps))) + +;; maximal/progress : (listof (cons A IPS)) -> (listof (listof A)) +;; Returns a list of equivalence sets. +(define (maximal/progress items) + (cond [(null? items) + null] + [(null? (cdr items)) + (list (list (car (car items))))] + [else + (let-values ([(rNULL rCAR rCDR rPOST rSTX leastCDR) + (partition/pf items)]) + (append (maximal/pf rNULL rCAR rCDR rPOST leastCDR) + (if (pair? rSTX) + (maximal/stx rSTX) + null)))])) + +;; partition/pf : (listof (cons A IPS)) -> (listof (cons A IPS))^5 & nat/+inf.0 +(define (partition/pf items) + (let ([rNULL null] + [rCAR null] + [rCDR null] + [rPOST null] + [rSTX null] + [leastCDR #f]) + (for ([a+ips (in-list items)]) + (let ([ips (cdr a+ips)]) + (cond [(null? ips) + (set! rNULL (cons a+ips rNULL))] + [(eq? (car ips) 'car) + (set! rCAR (cons a+ips rCAR))] + [(exact-positive-integer? (car ips)) + (set! rCDR (cons a+ips rCDR)) + (set! leastCDR + (if leastCDR + (min leastCDR (car ips)) + (car ips)))] + [(eq? (car ips) 'post) + (set! rPOST (cons a+ips rPOST))] + [(syntax? (car ips)) + (set! rSTX (cons a+ips rSTX))] + [else + (error 'syntax-parse "INTERNAL ERROR in partition/pf: ~e" ips)]))) + (values rNULL rCAR rCDR rPOST rSTX leastCDR))) + +;; maximal/pf : (listof (cons A IPS))^4 & nat/+inf.0-> (listof (listof A)) +(define (maximal/pf rNULL rCAR rCDR rPOST leastCDR) + (cond [(pair? rPOST) + (maximal/progress (rmap pop-item-ips rPOST))] + [(pair? rCDR) + (maximal/progress + (rmap (lambda (a+ips) + (let ([a (car a+ips)] [ips (cdr a+ips)]) + (cond [(= (car ips) leastCDR) + (cons a (cdr ips))] + [else + (cons a (cons (- (car ips) leastCDR) (cdr ips)))]))) + rCDR))] + [(pair? rCAR) + (maximal/progress (rmap pop-item-ips rCAR))] + [(pair? rNULL) + (list (map car rNULL))] + [else + null])) + +;; maximal/stx : (listof (cons A IPS)) -> (listof (listof A)) +(define (maximal/stx rSTX) + (let ([stxs null] + [table (make-hasheq)]) + (for ([a+ips (in-list rSTX)]) + (let* ([ips (cdr a+ips)] + [entry (hash-ref table (car ips) null)]) + (when (null? entry) + (set! stxs (cons (car ips) stxs))) + (hash-set! table (car ips) (cons a+ips entry)))) + (apply append + (map (lambda (key) + (maximal/progress (map pop-item-ips (hash-ref table key)))) + stxs)))) + +;; pop-item-ips : (cons A IPS) -> (cons A IPS) +(define (pop-item-ips a+ips) + (let ([a (car a+ips)] + [ips (cdr a+ips)]) + (cons a (cdr ips)))) + +(define (rmap f xs) + (let rmaploop ([xs xs] [accum null]) + (cond [(pair? xs) + (rmaploop (cdr xs) (cons (f (car xs)) accum))] + [else + accum]))) + +;; == Debugging == + +(provide progress->sexpr) + +(define (progress->sexpr ps) + (for/list ([pf (in-list (invert-ps ps))]) + (match pf + [(? syntax? stx) 'stx] + ['car 'car] + ['post 'post] + [(? exact-positive-integer? n) n] + ['opaque 'opaque]))) diff --git a/collects/syntax/parse/private/runtime-reflect.rkt b/collects/syntax/parse/private/runtime-reflect.rkt new file mode 100644 index 0000000000..6be678b4b7 --- /dev/null +++ b/collects/syntax/parse/private/runtime-reflect.rkt @@ -0,0 +1,108 @@ +#lang racket/base +(require (for-syntax racket/base + "rep-data.rkt") + "rep-attrs.rkt" + "kws.rkt") +(provide (struct-out reified) + (struct-out reified-syntax-class) + (struct-out reified-splicing-syntax-class) + reify-syntax-class + reified-syntax-class? + reified-splicing-syntax-class? + reflect-parser) + +#| +A Reified is + (reified symbol ParserFunction nat (listof (list symbol nat))) +|# +(define-struct reified-base (name) #:transparent) +(define-struct (reified reified-base) (parser arity signature)) +(define-struct (reified-syntax-class reified) ()) +(define-struct (reified-splicing-syntax-class reified) ()) + +;; ---- + +(define-syntax (reify-syntax-class stx) + (if (eq? (syntax-local-context) 'expression) + (syntax-case stx () + [(rsc sc) + (let* ([stxclass (get-stxclass #'sc)] + [splicing? (stxclass-splicing? stxclass)]) + (unless (stxclass-delimit-cut? stxclass) + (raise-syntax-error #f "cannot reify syntax class with #:no-delimit-cut option" + stx #'sc)) + (with-syntax ([name (stxclass-name stxclass)] + [parser (stxclass-parser stxclass)] + [arity (stxclass-arity stxclass)] + [(#s(attr aname adepth _) ...) (stxclass-attrs stxclass)] + [ctor + (if splicing? + #'reified-splicing-syntax-class + #'reified-syntax-class)]) + #'(ctor 'name parser 'arity '((aname adepth) ...))))]) + #`(#%expression #,stx))) + +;; ---- + +;; e-arity represents single call; min and max are same +(define (reflect-parser obj e-arity e-attrs splicing?) + (define who (if splicing? 'reflect-splicing-syntax-class 'reflect-syntax-class)) + (if splicing? + (unless (reified-splicing-syntax-class? obj) + (raise-type-error who "reified splicing-syntax-class" obj)) + (unless (reified-syntax-class? obj) + (raise-type-error who "reified syntax-class" obj))) + (check-params who e-arity (reified-arity obj) obj) + (adapt-parser who + (for/list ([a (in-list e-attrs)]) + (list (attr-name a) (attr-depth a))) + (reified-signature obj) + (reified-parser obj) + splicing?)) + +(define (check-params who e-arity r-arity obj) + (let ([e-pos (arity-minpos e-arity)] + [e-kws (arity-minkws e-arity)]) + (check-arity/neg r-arity e-pos e-kws + (lambda (msg) + (raise-mismatch-error who (string-append msg ": ") obj))))) + +(define (adapt-parser who esig0 rsig0 parser splicing?) + (if (equal? esig0 rsig0) + parser + (let ([indexes + (let loop ([esig esig0] [rsig rsig0] [index 0]) + (cond [(null? esig) + null] + [(and (pair? rsig) (eq? (caar esig) (caar rsig))) + (unless (= (cadar esig) (cadar rsig)) + (wrong-depth who (car esig) (car rsig))) + (cons index (loop (cdr esig) (cdr rsig) (add1 index)))] + [(and (pair? rsig) + (string>? (symbol->string (caar esig)) + (symbol->string (caar rsig)))) + (loop esig (cdr rsig) (add1 index))] + [else + (error who "reified syntax-class is missing declared attribute `~s'" + (caar esig))]))]) + (define (take-indexes result indexes) + (let loop ([result result] [indexes indexes] [i 0]) + (cond [(null? indexes) null] + [(= (car indexes) i) + (cons (car result) (loop (cdr result) (cdr indexes) (add1 i)))] + [else + (loop (cdr result) indexes (add1 i))]))) + (make-keyword-procedure + (lambda (kws kwargs x cx pr es fh cp success . rest) + (keyword-apply parser kws kwargs x cx pr es fh cp + (if splicing? + (lambda (fh cp x cx . result) + (apply success fh cp x cx (take-indexes result indexes))) + (lambda (fh cp . result) + (apply success fh cp (take-indexes result indexes)))) + rest)))))) + +(define (wrong-depth who a b) + (error who + "reified syntax-class has wrong depth for attribute `~s'; expected ~s, got ~s instead" + (car a) (cadr a) (cadr b))) diff --git a/collects/syntax/parse/private/runtime-report.rkt b/collects/syntax/parse/private/runtime-report.rkt new file mode 100644 index 0000000000..b1adac8354 --- /dev/null +++ b/collects/syntax/parse/private/runtime-report.rkt @@ -0,0 +1,131 @@ +#lang racket/base +(require racket/contract/base + racket/list + "minimatch.rkt" + racket/stxparam + syntax/stx + (for-syntax racket/base + syntax/stx + racket/private/sc + "rep-data.rkt") + "runtime.rkt" + "kws.rkt") +(provide syntax-patterns-fail + current-failure-handler) + +(define ((syntax-patterns-fail stx0) fs) + (call-with-values (lambda () ((current-failure-handler) stx0 fs)) + (lambda vals + (error 'current-failure-handler + "current-failure-handler: did not escape, produced ~e" + (case (length vals) + ((1) (car vals)) + (else (cons 'values vals))))))) + +(define (default-failure-handler stx0 fs) + (report-failureset stx0 fs)) + +(define current-failure-handler + (make-parameter default-failure-handler)) + +;; ---- + +#| +Reporting +--------- + +First, failures with maximal (normalized) progresses are selected and +grouped into equivalence classes. In principle, each failure in an +equivalence class complains about the same term, but in practice, +special handling of failures like "unexpected term" make things more +complicated. + +|# + +;; report-failureset : stx FailureSet -> escapes +(define (report-failureset stx0 fs) + (let* ([classes (maximal-failures fs)] + [reports (apply append (map report/class classes))]) + (raise-syntax-error/reports stx0 reports))) + +;; A Report is +;; - (report string stx) +(define-struct report (message stx) #:prefab) + +;; report/class : (non-empty-listof Failure) -> (listof Report) +(define (report/class fs) + (let* ([ess (map failure-expectstack fs)] + [ess (map normalize-expectstack ess)] + [ess (remove-duplicates ess)] + [ess (simplify-common-expectstacks ess)]) + (map report/expectstack ess))) + +;; report/expectstack : ExpectStack -> Report +(define (report/expectstack es) + (let ([top-frame (and (pair? es) (car es))]) + (cond [(not top-frame) + (report "bad syntax" #f)] + [else + (let ([frame-expect (and top-frame (car top-frame))] + [frame-stx (and top-frame (cdr top-frame))]) + (cond [(equal? frame-expect (expect:atom '())) + (syntax-case frame-stx () + [(one . more) + (report "unexpected term" #'one)] + [_ + (report/expects (list frame-expect) frame-stx)])] + [(expect:disj? frame-expect) + (report/expects (expect:disj-expects frame-expect) frame-stx)] + [else + (report/expects (list frame-expect) frame-stx)]))]))) + +;; report/expects : (listof Expect) -> Report +(define (report/expects expects frame-stx) + (report (join-sep (for/list ([expect expects]) + (prose-for-expect expect)) + ";" "or") + frame-stx)) + +;; prose-for-expect : Expect -> string +(define (prose-for-expect e) + (match e + [(expect:thing description transparent?) + (format "expected ~a" description)] + [(expect:atom atom) + (format "expected the literal ~a~s~a" + (if (symbol? atom) "symbol `" "") + atom + (if (symbol? atom) "'" ""))] + [(expect:literal literal) + (format "expected the identifier `~s'" (syntax-e literal))] + [(expect:message message) + (format "~a" message)])) + +;; == Do Report == + +(define (raise-syntax-error/reports stx0 reports) + (cond [(= (length reports) 1) + (raise-syntax-error/report stx0 (car reports))] + [else + (raise-syntax-error/report* stx0 (car reports))])) + +(define (raise-syntax-error/report stx0 report) + (raise-syntax-error #f (report-message report) stx0 (report-stx report))) + +(define (raise-syntax-error/report* stx0 report) + (let ([message + (string-append + "There were multiple syntax errors. The first error follows:\n" + (report-message report))]) + (raise-syntax-error #f message stx0 (report-stx report)))) + +;; ==== + +(define (comma-list items) + (join-sep items "," "or")) + +(define (improper-stx->list stx) + (syntax-case stx () + [(a . b) (cons #'a (improper-stx->list #'b))] + [() null] + [rest (list #'rest)])) diff --git a/collects/syntax/parse/private/runtime.rkt b/collects/syntax/parse/private/runtime.rkt new file mode 100644 index 0000000000..c9db713ff5 --- /dev/null +++ b/collects/syntax/parse/private/runtime.rkt @@ -0,0 +1,340 @@ +#lang racket/base +(require racket/contract/base + racket/list + racket/stxparam + unstable/struct + "minimatch.rkt" + "runtime-progress.rkt" + "runtime-failure.rkt" + "kws.rkt" + (for-syntax racket/base + racket/list + syntax/stx + syntax/kerncase + racket/private/sc + unstable/syntax + "rep-data.rkt" + "rep-attrs.rkt")) + +(provide (all-from-out "runtime-progress.rkt") + (all-from-out "runtime-failure.rkt") + + this-syntax + this-context-syntax + + stx-list-take + stx-list-drop/cx + + let-attributes + attribute + let/unpack + attribute-binding + check-list^depth) + +;; == Syntax Parameters + +;; this-syntax +;; Bound to syntax being matched inside of syntax class +(define-syntax-parameter this-syntax + (lambda (stx) + (wrong-syntax stx "used out of context: not within a syntax class"))) + +;; this-context-syntax +;; Bound to (expression that extracts) context syntax (bottom frame in progress) +(define-syntax-parameter this-context-syntax + (lambda (stx) + (wrong-syntax stx "used out of context: not within a syntax class"))) + +;; == with == + +(provide with) + +(define-syntax (with stx) + (syntax-case stx () + [(with ([stxparam expr] ...) . body) + (with-syntax ([(var ...) (generate-temporaries #'(stxparam ...))]) + (syntax/loc stx + (let ([var expr] ...) + (syntax-parameterize ((stxparam (make-rename-transformer (quote-syntax var))) + ...) + . body))))])) + +;; == Control information == + +(provide fail-handler + cut-prompt + wrap-user-code + + fail + try) + +(define-syntax-parameter fail-handler + (lambda (stx) + (wrong-syntax stx "internal error: used out of context"))) +(define-syntax-parameter cut-prompt + (lambda (stx) + (wrong-syntax stx "internal error: used out of context"))) + +(define-syntax-rule (wrap-user-code e) + (with ([fail-handler #f] + [cut-prompt #t]) + e)) + +(define-syntax-rule (fail fs) + (fail-handler fs)) + +(define-syntax (try stx) + (syntax-case stx () + [(try e0 e ...) + (with-syntax ([(re ...) (reverse (syntax->list #'(e ...)))]) + (with-syntax ([(fh ...) (generate-temporaries #'(re ...))]) + (with-syntax ([(next-fh ...) (drop-right (syntax->list #'(fail-handler fh ...)) 1)] + [(last-fh) (take-right (syntax->list #'(fail-handler fh ...)) 1)]) + #'(let* ([fh (lambda (fs1) + (with ([fail-handler + (lambda (fs2) + (next-fh (cons fs1 fs2)))]) + re))] + ...) + (with ([fail-handler last-fh]) + e0)))))])) + +;; ----- + +(require syntax/stx) +(define (stx-list-take stx n) + (let loop ([stx stx] [n n]) + (if (zero? n) + null + (cons (stx-car stx) + (loop (stx-cdr stx) (sub1 n)))))) + +;; stx-list-drop/cx : stxish stx nat -> (values stxish stx) +(define (stx-list-drop/cx x cx n) + (let loop ([x x] [cx cx] [n n]) + (if (zero? n) + (values x + (if (syntax? x) x cx)) + (loop (stx-cdr x) + (if (syntax? x) x cx) + (sub1 n))))) + +;; == Attributes + +(begin-for-syntax + (define-struct attribute-mapping (var name depth syntax?) + #:omit-define-syntaxes + #:property prop:procedure + (lambda (self stx) + (if (attribute-mapping-syntax? self) + #`(#%expression #,(attribute-mapping-var self)) + #`(let ([value #,(attribute-mapping-var self)]) + (if (check-syntax '#,(attribute-mapping-depth self) value) + value + (raise-syntax-error + #f + (format "attribute is bound to non-syntax value: ~e" value) + (quote-syntax #,(attribute-mapping-name self))))))))) + +;; check-syntax : nat any -> boolean +;; Returns #t if value is a (listof^depth syntax) +(define (check-syntax depth value) + (if (zero? depth) + (syntax? value) + (and (list? value) + (for/and ([part (in-list value)]) + (check-syntax (sub1 depth) part))))) + +(define-syntax (let-attributes stx) + (define (parse-attr x) + (syntax-case x () + [#s(attr name depth syntax?) #'(name depth syntax?)])) + (syntax-case stx () + [(let-attributes ([a value] ...) . body) + (with-syntax ([((name depth syntax?) ...) + (map parse-attr (syntax->list #'(a ...)))]) + (with-syntax ([(vtmp ...) (generate-temporaries #'(name ...))] + [(stmp ...) (generate-temporaries #'(name ...))]) + #'(letrec-syntaxes+values + ([(stmp) (make-attribute-mapping (quote-syntax vtmp) + 'name 'depth 'syntax?)] ...) + ([(vtmp) value] ...) + (letrec-syntaxes+values + ([(name) (make-syntax-mapping 'depth (quote-syntax stmp))] ...) + () + . body))))])) + +(define-syntax (attribute stx) + (parameterize ((current-syntax-context stx)) + (syntax-case stx () + [(attribute name) + (identifier? #'name) + (let ([mapping (syntax-local-value #'name (lambda () #f))]) + (unless (syntax-pattern-variable? mapping) + (wrong-syntax #'name "not bound as a pattern variable")) + (let ([var (syntax-mapping-valvar mapping)]) + (let ([attr (syntax-local-value var (lambda () #f))]) + (unless (attribute-mapping? attr) + (wrong-syntax #'name "not bound as an attribute")) + (syntax-property (attribute-mapping-var attr) + 'disappeared-use + #'name))))]))) + +;; (let/unpack (([id num] ...) expr) expr) : expr +;; Special case: empty attrs need not match packed length +(define-syntax (let/unpack stx) + (syntax-case stx () + [(let/unpack (() packed) body) + #'body] + [(let/unpack ((a ...) packed) body) + (with-syntax ([(tmp ...) (generate-temporaries #'(a ...))]) + #'(let-values ([(tmp ...) (apply values packed)]) + (let-attributes ([a tmp] ...) body)))])) + +;; (attribute-binding id) +;; mostly for debugging/testing +(define-syntax (attribute-binding stx) + (syntax-case stx () + [(attribute-bound? name) + (identifier? #'name) + (let ([value (syntax-local-value #'name (lambda () #f))]) + (if (syntax-pattern-variable? value) + (let ([value (syntax-local-value (syntax-mapping-valvar value) (lambda () #f))]) + (if (attribute-mapping? value) + #`(quote #,(make-attr (attribute-mapping-name value) + (attribute-mapping-depth value) + (attribute-mapping-syntax? value))) + #'(quote #f))) + #'(quote #f)))])) + +;; (check-list^depth attr expr) +(define-syntax (check-list^depth stx) + (syntax-case stx () + [(_ a expr) + (with-syntax ([#s(attr name depth syntax?) #'a]) + (quasisyntax/loc #'expr + (check-list^depth* 'name 'depth expr)))])) + +(define (check-list^depth* aname n0 v0) + (define (loop n v) + (when (positive? n) + (unless (list? v) + (raise-type-error aname (format "lists nested ~s deep" n0) v)) + (for ([x (in-list v)]) (loop (sub1 n) x)))) + (loop n0 v0) + v0) + + +;; ==== + +(provide check-literal + free-identifier=?/phases) + +;; check-literal : id phase-level stx -> void +;; FIXME: change to normal 'error', if src gets stripped away +(define (check-literal id phase ctx) + (unless (identifier-binding id phase) + (raise-syntax-error #f + (format "literal is unbound in phase ~s" phase) + ctx id))) + +;; free-identifier=?/phases : id phase-level id phase-level -> boolean +;; Determines whether x has the same binding at phase-level phase-x +;; that y has at phase-level y. +;; At least one of the identifiers MUST have a binding (module or lexical) +(define (free-identifier=?/phases x phase-x y phase-y) + (let ([bx (identifier-binding x phase-x)] + [by (identifier-binding y phase-y)]) + (cond [(and (list? bx) (list? by)) + (let ([modx (module-path-index-resolve (first bx))] + [namex (second bx)] + [phasex (fifth bx)] + [mody (module-path-index-resolve (first by))] + [namey (second by)] + [phasey (fifth by)]) + (and (eq? modx mody) ;; resolved-module-paths are interned + (eq? namex namey) + (equal? phasex phasey)))] + [else + ;; One must be lexical (can't be #f, since one must be bound) + ;; lexically-bound names bound in only one phase; just compare + (free-identifier=? x y)]))) + +;; ---- + +(provide begin-for-syntax/once) + +;; (begin-for-syntax/once expr/phase1 ...) +;; evaluates in pass 2 of module/intdefs expansion +(define-syntax (begin-for-syntax/once stx) + (syntax-case stx () + [(bfs/o e ...) + (cond [(list? (syntax-local-context)) + #`(define-values () + (begin (begin-for-syntax/once e ...) + (values)))] + [else + #'(let-syntax ([m (lambda _ (begin e ...) #'(void))]) + (m))])])) + +;; ==== + +(provide no-shadow) + +(begin-for-syntax + (define (check-shadow def) + (syntax-case def () + [(_def (x ...) . _) + (parameterize ((current-syntax-context def)) + (for ([x (in-list (syntax->list #'(x ...)))]) + (let ([v (syntax-local-value x (lambda _ #f))]) + (when (syntax-pattern-variable? v) + (wrong-syntax + x + ;; FIXME: customize "~do pattern" vs "#:do block" as appropriate + "definition in ~~do pattern must not shadow attribute binding")))))]))) + +(define-syntax (no-shadow stx) + (syntax-case stx () + [(no-shadow e) + (let ([ee (local-expand #'e (syntax-local-context) + (kernel-form-identifier-list))]) + (syntax-case ee (begin define-values defines-syntaxes) + [(begin d ...) + #'(begin (no-shadow d) ...)] + [(define-values . _) + (check-shadow ee) + ee] + [(define-syntaxes . _) + (check-shadow ee) + ee] + [_ + ee]))])) + +;; ---- + +(provide curried-stxclass-parser + app-argu) + +(define-syntax (curried-stxclass-parser stx) + (syntax-case stx () + [(cp class argu) + (with-syntax ([#s(arguments (parg ...) (kw ...) _) #'argu]) + (let ([sc (get-stxclass/check-arity #'class #'class + (length (syntax->list #'(parg ...))) + (syntax->datum #'(kw ...)))]) + (with-syntax ([parser (stxclass-parser sc)]) + #'(lambda (x cx pr es fh cp success) + (app-argu parser x cx pr es fh cp success argu)))))])) + +(define-syntax (app-argu stx) + (syntax-case stx () + [(aa proc extra-parg ... #s(arguments (parg ...) (kw ...) (kwarg ...))) + #| + Use keyword-apply directly? + #'(keyword-apply proc '(kw ...) (list kwarg ...) parg ... null) + If so, create separate no-keyword clause. + |# + ;; For now, let #%app handle it. + (with-syntax ([((kw-part ...) ...) #'((kw kwarg) ...)]) + #'(proc kw-part ... ... extra-parg ... parg ...))])) diff --git a/collects/syntax/parse/private/sc.rkt b/collects/syntax/parse/private/sc.rkt new file mode 100644 index 0000000000..6974808f5d --- /dev/null +++ b/collects/syntax/parse/private/sc.rkt @@ -0,0 +1,142 @@ +#lang racket/base +(require (for-syntax racket/base + syntax/stx + unstable/syntax + "rep-data.rkt" + "rep.rkt") + racket/list + syntax/stx + "parse.rkt" + "keywords.rkt" + "runtime.rkt" + "runtime-report.rkt" + "kws.rkt") + +(provide define-syntax-class + define-splicing-syntax-class + + syntax-parse + syntax-parser + + (except-out (all-from-out "keywords.rkt") + ~do + ~reflect + ~splicing-reflect + ~eh-var) + + attribute + this-syntax + + ;;---- + parser/rhs) + +(begin-for-syntax + (define (defstxclass stx name formals rhss splicing?) + (parameterize ((current-syntax-context stx)) + (with-syntax ([name name] + [formals formals] + [rhss rhss]) + (let* ([the-rhs (parse-rhs #'rhss #f splicing? #:context stx)] + [arity (parse-kw-formals #'formals #:context stx)] + [opt-rhs+def + (and (stx-list? #'formals) (andmap identifier? (syntax->list #'formals)) + (optimize-rhs the-rhs (syntax->list #'formals)))] + [the-rhs (if opt-rhs+def (car opt-rhs+def) the-rhs)]) + (with-syntax ([parser (generate-temporary + (format-symbol "parse-~a" (syntax-e #'name)))] + [arity arity] + [attrs (rhs-attrs the-rhs)] + [(opt-def ...) + (if opt-rhs+def + (list (cadr opt-rhs+def)) + '())] + [options (rhs-options the-rhs)] + [integrate-expr + (syntax-case (rhs-integrate the-rhs) () + [#s(integrate predicate description) + #'(integrate (quote-syntax predicate) + 'description)] + [#f + #''#f])]) + #`(begin (define-syntax name + (stxclass 'name 'arity + 'attrs + (quote-syntax parser) + '#,splicing? + options + integrate-expr)) + opt-def ... + (define-values (parser) + ;; If opt-rhs, do not reparse: + ;; need to keep same generated predicate name + #,(if opt-rhs+def + (begin + ;; (printf "Integrable syntax class: ~s\n" (syntax->datum #'name)) + #`(parser/rhs/parsed + name formals attrs #,the-rhs + #,(and (rhs-description the-rhs) #t) + #,splicing? #,stx)) + #`(parser/rhs + name formals attrs rhss #,splicing? #,stx)))))))))) + +(define-syntax (define-syntax-class stx) + (syntax-case stx () + [(define-syntax-class name . rhss) + (identifier? #'name) + (defstxclass stx #'name #'() #'rhss #f)] + [(define-syntax-class (name . formals) . rhss) + (identifier? #'name) + (defstxclass stx #'name #'formals #'rhss #f)])) + +(define-syntax (define-splicing-syntax-class stx) + (syntax-case stx () + [(define-splicing-syntax-class name . rhss) + (identifier? #'name) + (defstxclass stx #'name #'() #'rhss #t)] + [(define-splicing-syntax-class (name . formals) . rhss) + (identifier? #'name) + (defstxclass stx #'name #'formals #'rhss #t)])) + +;; ---- + +(define-syntax (parser/rhs stx) + (syntax-case stx () + [(parser/rhs name formals attrs rhss splicing? ctx) + (with-disappeared-uses + (let ([rhs + (parameterize ((current-syntax-context #'ctx)) + (parse-rhs #'rhss (syntax->datum #'attrs) (syntax-e #'splicing?) + #:context #'ctx))]) + #`(parser/rhs/parsed name formals attrs + #,rhs #,(and (rhs-description rhs) #t) + splicing? ctx)))])) + +(define-syntax (parser/rhs/parsed stx) + (syntax-case stx () + [(prp name formals attrs rhs rhs-has-description? splicing? ctx) + #`(let ([get-description + (lambda formals + (if 'rhs-has-description? + #,(rhs-description (syntax-e #'rhs)) + (symbol->string 'name)))]) + (parse:rhs rhs attrs formals splicing? + (if 'rhs-has-description? + #,(rhs-description (syntax-e #'rhs)) + (symbol->string 'name))))])) + +;; ==== + +(define-syntax (syntax-parse stx) + (syntax-case stx () + [(syntax-parse stx-expr . clauses) + (quasisyntax/loc stx + (let ([x (datum->syntax #f stx-expr)]) + (parse:clauses x clauses #,((make-syntax-introducer) stx))))])) + +(define-syntax (syntax-parser stx) + (syntax-case stx () + [(syntax-parser . clauses) + (quasisyntax/loc stx + (lambda (x) + (let ([x (datum->syntax #f x)]) + (parse:clauses x clauses #,((make-syntax-introducer) stx)))))])) diff --git a/collects/syntax/private/util/txlift.rkt b/collects/syntax/parse/private/txlift.rkt similarity index 100% rename from collects/syntax/private/util/txlift.rkt rename to collects/syntax/parse/private/txlift.rkt diff --git a/collects/syntax/parse/todo.txt b/collects/syntax/parse/todo.txt new file mode 100644 index 0000000000..b68c0c3e4c --- /dev/null +++ b/collects/syntax/parse/todo.txt @@ -0,0 +1,35 @@ +Things to do for syntax/parse +============================= + +TEST & DOC - Generalize stxclass arities. +TEST & DOC - provide-syntax-class/contract + +Refine expr/c. + +Wrap default args in stxclass parameters with 'this-syntax' + - other stxparams? like 'this-base-syntax' etc? + +Add debugging mode that records *all* intermediate patterns +on expectstack. + +Add "roles" to error messages, eg + expected identifier for foo thingummy name +instead of the current + expected identifier + +Improve ~do. + +Improve reflection. + +More cowbell. + +Reorganize tests. + +Allow reflected syntax classes in conventions. + +Rename "conventions" to "convention-set"? + +For documentation, talk about "primary attributes" vs "nested +attributes". Helps explain ~eh-var and #:auto-nested-attributes. + +Fix syntaxes pinpointed for repetition constraint violations. diff --git a/collects/syntax/private/stxparse/codegen-data.rkt b/collects/syntax/private/stxparse/codegen-data.rkt deleted file mode 100644 index 36d6812111..0000000000 --- a/collects/syntax/private/stxparse/codegen-data.rkt +++ /dev/null @@ -1,44 +0,0 @@ -#lang scheme/base -(require syntax/stx - (for-template scheme/base - syntax/stx - scheme/stxparam - unstable/struct - "runtime.ss")) -(provide (all-defined-out)) - -(define (get-kind kind) - (syntax-case kind () - [#:pair pairK] - [#:vector vectorK] - [#:box boxK] - [(#:pstruct key) - (make-kind #`(lambda (x) - (let ([xkey (prefab-struct-key x)]) - (and xkey (equal? xkey (quote key))))) - (list (lambda (s d) - #`(datum->syntax #,s (struct->list #,d) #,s))) - (list #'dfc-add-unpstruct))])) - -;; A Kind is -;; (make-kind id (listof (id id -> stx)) (listof expr)) - -(define-struct kind (predicate selectors frontier-procs) #:transparent) - -(define pairK - (make-kind #'pair? - (list (lambda (s d) #`(car #,d)) - (lambda (s d) #`(datum->syntax #,s (cdr #,d) #,s))) - (list #'dfc-add-car - #'dfc-add-cdr))) - -(define vectorK - (make-kind #'vector? - (list (lambda (s d) - #`(datum->syntax #,s (vector->list #,d) #,s))) - (list #'dfc-add-unvector))) - -(define boxK - (make-kind #'box? - (list (lambda (s d) #`(unbox #,d))) - (list #'dfc-add-unbox))) diff --git a/collects/syntax/private/stxparse/lib.rkt b/collects/syntax/private/stxparse/lib.rkt deleted file mode 100644 index 859b0ce874..0000000000 --- a/collects/syntax/private/stxparse/lib.rkt +++ /dev/null @@ -1,144 +0,0 @@ -#lang racket/base - -(require "sc.ss" - "../util.ss" - syntax/stx - racket/struct-info - unstable/srcloc - (for-syntax racket/base - "rep.ss" - (only-in "rep-data.ss" make-literalset)) - (for-template racket/base - racket/contract/base)) - -(provide identifier - boolean - str - character - keyword - number - integer - exact-integer - exact-nonnegative-integer - exact-positive-integer - - id - nat - char - - expr - expr/c - static - atom-in-list - - kernel-literals) - -(define-syntax-rule (define-pred-stxclass name pred) - (define-syntax-class name #:attributes () #:opaque - (pattern x - #:fail-unless (pred (syntax-e #'x)) #f))) - -(define-pred-stxclass identifier symbol?) -(define-pred-stxclass boolean boolean?) -(define-pred-stxclass character char?) -(define-pred-stxclass keyword keyword?) - -(define-syntax-class str #:attributes () #:opaque - #:description "string" - (pattern x - #:fail-unless (string? (syntax-e #'x)) #f)) - -(define-pred-stxclass number number?) -(define-pred-stxclass integer integer?) -(define-pred-stxclass exact-integer exact-integer?) -(define-pred-stxclass exact-nonnegative-integer exact-nonnegative-integer?) -(define-pred-stxclass exact-positive-integer exact-positive-integer?) - -;; Aliases -(define-syntax id (make-rename-transformer #'identifier)) -(define-syntax nat (make-rename-transformer #'exact-nonnegative-integer)) -(define-syntax char (make-rename-transformer #'character)) - -(define notfound (box 'notfound)) - -(define-syntax-class (static pred name) - #:attributes (value) - #:description name - (pattern x:id - #:fail-unless (syntax-transforming?) - "not within the extent of a macro transformer" - #:attr value (syntax-local-value #'x (lambda () notfound)) - #:fail-when (eq? (attribute value) notfound) #f - #:fail-unless (pred (attribute value)) #f)) - -(define-syntax-class (atom-in-list atoms name) - #:attributes () - #:description name - (pattern x - #:fail-unless (memv (syntax-e #'x) atoms) #f)) - -(define-syntax-class struct-name - #:description "struct name" - #:attributes (descriptor - constructor - predicate - [accessor 1] - super - complete?) - (pattern s - #:declare s (static struct-info? "struct name") - #:with info (extract-struct-info (attribute s.value)) - #:with descriptor (list-ref (attribute info) 0) - #:with constructor (list-ref (attribute info) 1) - #:with predicate (list-ref (attribute info) 2) - #:with r-accessors (reverse (list-ref (attribute info) 3)) - #:with (accessor ...) - (datum->syntax #f (let ([r-accessors (attribute r-accessors)]) - (if (and (pair? r-accessors) (eq? #f (car r-accessors))) - (cdr r-accessors) - r-accessors))) - #:with super (list-ref (attribute info) 5) - #:attr complete? (or (null? (attribute r-accessors)) - (and (pair? (attribute r-accessors)) - (not (eq? #f (car (attribute r-accessors)))))))) - -(define-syntax-class expr - #:attributes () - (pattern x - #:fail-when (keyword? (syntax-e #'x)) #f)) - -(define-syntax-class (expr/c ctc) - #:attributes (c) - (pattern x:expr - #:with - c #`(contract #,ctc - x - (quote #,(source-location->string #'x "<>")) - ' - #f - (quote-syntax x)))) - -;; Literal sets - -(define-literal-set kernel-literals - (begin - begin0 - define-values - define-syntaxes - define-values-for-syntax - set! - let-values - letrec-values - #%plain-lambda - case-lambda - if - quote - letrec-syntaxes+values - with-continuation-mark - #%expression - #%plain-app - #%top - #%datum - #%variable-reference - module #%provide #%require - #%plain-module-begin)) diff --git a/collects/syntax/private/stxparse/parse.rkt b/collects/syntax/private/stxparse/parse.rkt deleted file mode 100644 index 5b7210cd75..0000000000 --- a/collects/syntax/private/stxparse/parse.rkt +++ /dev/null @@ -1,709 +0,0 @@ -#lang scheme/base -(require (for-syntax scheme/base - racket/private/sc - syntax/stx - syntax/id-table - syntax/keyword - unstable/syntax - "rep-data.ss" - "rep.ss" - "codegen-data.ss" - "../util/txlift.ss" - "../util.ss") - scheme/stxparam - scheme/list - syntax/stx - "runtime.ss" - "runtime-prose.ss") -(provide (all-defined-out)) - -(define-for-syntax (wash stx) - (syntax-e stx)) -(define-for-syntax (wash-list washer stx) - (let ([l (stx->list stx)]) - (unless l (raise-type-error 'wash-list "stx-list" stx)) - (map washer l))) -(define-for-syntax (wash-iattr stx) - (with-syntax ([#s(attr name depth syntax?) stx]) - (make-attr #'name (wash #'depth) (wash #'syntax?)))) -(define-for-syntax (wash-sattr stx) - (with-syntax ([#s(attr name depth syntax?) stx]) - (make-attr (wash #'name) (wash #'depth) (wash #'syntax?)))) - -(define-for-syntax (wash-iattrs stx) - (wash-list wash-iattr stx)) -(define-for-syntax (wash-sattrs stx) - (wash-list wash-sattr stx)) - -;; ---- - -;; An FCE is expr[DFC] - -;; (fail expr #:expect expr #:fce FCE) : expr -(define-syntax (fail stx) - (syntax-case stx () - [(fail x #:expect p #:fce fce) - #'(enclosing-fail (make-failure x fce p))])) - -;; ---- - -;; (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 ...) commit?) - relsattrs (arg ...) get-description splicing?) - (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? 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? 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 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 () 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) 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 ...) k-ref) - #`(convert-sides x sides - (base-success-expr #,(pattern-attrs (wash #'pattern)) - relsattrs - (also ...) - k-ref))])) - -;; (convert-sides id (Side ...) (m (IAttr ...) . MArgs)) : expr[X] -;; where (m (IAttr ...) MArgs) : expr[X] -(define-syntax (convert-sides stx) - (syntax-case stx () - [(convert-sides x () kexpr) - #'kexpr] - [(convert-sides x (side0 . sides) (k iattrs . kargs)) - (syntax-case #'side0 () - [#s(clause:fail condition message) - #`(let* ([c (without-fails condition)] - [fc (dfc-add-post (dfc-empty x) (if (syntax? c) c x))]) - (if c - (fail (if (syntax? c) c x) - #:expect (expectation-of-message message) - #:fce fc) - (convert-sides x sides (k iattrs . kargs))))] - [#s(clause:with pattern expr (def ...)) - (with-syntax ([(p-iattr ...) (pattern-attrs (wash #'pattern))]) - #`(let* ([y (datum->syntax #f (without-fails expr))] - [fc (dfc-add-post (dfc-empty x) y)]) - def ... - (parse:S y fc pattern - (convert-sides x sides - (k (p-iattr ... . iattrs) . kargs)))))] - [#s(clause:attr a expr) - #`(let-attributes ([a (without-fails (check-list^depth a expr))]) - (convert-sides x sides (k (a . iattrs) . kargs)))])])) - -;; (base-success-expr (IAttr ...) (SAttr ...) (expr ...) : expr[SCResult] -(define-syntax (base-success-expr stx) - (syntax-case stx () - [(base-success-expr iattrs relsattrs (also ...) k-ref) - (let ([reliattrs - (reorder-iattrs (wash-sattrs #'relsattrs) - (wash-iattrs #'iattrs))]) - (with-syntax ([(#s(attr name _ _) ...) reliattrs]) - #'(k-ref (list also ... (attribute name) ...))))])) - -;; ---- - -;; (parse:clauses id (Clause ...)) -(define-syntax (parse:clauses stx) - (syntax-case stx () - [(parse:clauses x clauses ctx) - (with-disappeared-uses - (with-txlifts - (lambda () - (define-values (chunks clauses-stx) - (parse-keyword-options #'clauses parse-directive-table - #:context #'ctx - #:no-duplicates? #t)) - (define context - (options-select-value chunks '#:context #:default #'x)) - (define-values (decls0 defs) - (get-decls+defs chunks #t #:context #'ctx)) - (define (for-clause clause) - (syntax-case clause () - [[p . rest] - (let-values ([(rest decls2 defs2 sides) - (parse-pattern-directives #'rest - #:allow-declare? #t - #:decls decls0 - #:context #'ctx)]) - (unless (and (stx-list? rest) (stx-pair? rest)) - (raise-syntax-error #f - "expected non-empty clause body" - #'ctx - clause)) - (with-syntax ([rest rest] - [pattern - (parse-whole-pattern #'p decls2 #:context #'ctx)] - [(local-def ...) defs2]) - #`(let ([fc (dfc-empty x)]) - local-def ... - (parse:S x fc pattern - (convert-sides x #,sides - (clause-success () (let () . rest)))))))])) - (unless (and (stx-list? clauses-stx) (stx-pair? clauses-stx)) - (raise-syntax-error #f "expected non-empty sequence of clauses" #'ctx)) - (with-syntax ([(def ...) (append (get-txlifts-as-definitions) defs)] - [(alternative ...) - (map for-clause (stx->list clauses-stx))]) - #`(let ([fail (syntax-patterns-fail #,context)]) - def ... - (with-enclosing-fail* fail - (try alternative ...)))))))])) - -;; (clause-success (IAttr ...) expr) : expr -(define-syntax (clause-success stx) - (syntax-case stx () - [(clause-success _ expr) - #'expr])) - -;; ---- - -;; (parse:S id FCE SinglePattern expr) : expr -(define-syntax (parse:S stx) - (syntax-case stx () - [(parse:S x fc pattern0 k) - (syntax-case #'pattern0 () - [#s(internal-rest-pattern rest rest-fc) - #`(let ([rest x] - [rest-fc fc]) - k)] - [#s(pat:name attrs pattern (name ...)) - #`(let-attributes ([#s(attr name 0 #t) x] ...) - (parse:S x fc pattern k))] - [#s(pat:any attrs) - #'k] - [#s(pat:var _attrs name #f () () _) - #'(let-attributes ([#s(attr name 0 #t) x]) - k)] - [#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)) - k - (fail x - #:expect (expectation pattern0) - #:fce fc)))] - [#s(pat:literal attrs literal input-phase lit-phase) - #`(if (and (identifier? x) - (free-identifier=?/phases x input-phase - (quote-syntax literal) lit-phase)) - k - (fail x - #:expect (expectation pattern0) - #:fce fc))] - [#s(pat:ghost attrs ghost subpattern) - #'(parse:G x fc ghost (parse:S x fc subpattern k))] - [#s(pat:head attrs head tail) - #`(parse:H x fc head rest rest-fc - (parse:S rest rest-fc tail k))] - [#s(pat:dots attrs head tail) - #`(parse:dots x fc head tail k)] - [#s(pat:and attrs subpatterns) - (for/fold ([k #'k]) ([subpattern (reverse (syntax->list #'subpatterns))]) - #`(parse:S x fc #,subpattern #,k))] - [#s(pat:or (a ...) (subpattern ...)) - (with-syntax ([(#s(attr id _ _) ...) #'(a ...)]) - #`(let ([success - (lambda (fail id ...) - (with-enclosing-fail fail - (let-attributes ([a id] ...) k)))]) - (try (parse:S x fc subpattern - (disjunct subpattern success (enclosing-fail) (id ...))) - ...)))] - [#s(pat:not () subpattern) - #`(let ([fail-to-succeed (lambda (_failure) k)] - [outer-fail enclosing-fail]) - (with-enclosing-fail* fail-to-succeed - (parse:S x fc subpattern - (with-enclosing-fail outer-fail - (fail x #:expect (expectation pattern0) #:fce fc)))))] - [#s(pat:compound attrs kind0 (part-pattern ...)) - (let ([kind (get-kind (wash #'kind0))]) - (with-syntax ([(part ...) (generate-temporaries (kind-selectors kind))]) - (with-syntax ([predicate (kind-predicate kind)] - [(part-fc ...) (generate-temporaries #'(part ...))] - [(part-fc-proc ...) (kind-frontier-procs kind)] - [(part-expr ...) - (for/list ([selector (kind-selectors kind)]) - (selector #'x #'datum))]) - #`(let ([datum (syntax-e x)]) - (if (predicate datum) - (let ([part part-expr] ...) - (let ([part-fc (part-fc-proc fc part)] ...) - (parse:S* (part ...) (part-fc ...) (part-pattern ...) k))) - (fail x - #:expect (expectation pattern0) - #:fce fc))))))] - [#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 transparent? failure) - #:fce fc)) - (with-enclosing-fail* new-fail - (let ([new-fc (dfc-empty x)]) - (parse:S x new-fc pattern - (with-enclosing-cut-fail previous-cut-fail - (with-enclosing-fail previous-fail - k))))))])])) - -;; (parse:S* (id ...) (FCE ...) (SinglePattern ...) expr) : expr -(define-syntax parse:S* - (syntax-rules () - [(parse:S* () () () k) - k] - [(parse:S* (part0 . parts) (fc0 . fcs) (pattern0 . patterns) k) - (parse:S part0 fc0 pattern0 (parse:S* parts fcs patterns k))])) - -;; (disjunct Pattern id (expr ...) (id ...)) : expr -(define-syntax (disjunct stx) - (syntax-case stx () - [(disjunct pattern success (pre ...) (id ...)) - (with-syntax ([(#s(attr sub-id _ _) ...) (pattern-attrs (wash #'pattern))]) - (with-syntax ([(alt-sub-id ...) (generate-temporaries #'(sub-id ...))]) - #`(let ([alt-sub-id (attribute sub-id)] ...) - (let ([id #f] ...) - (let ([sub-id alt-sub-id] ...) - (success pre ... id ...))))))])) - -;; (disjunct (clause:attr ...) id (expr ...) (id ...)) : expr -(define-syntax (disjunct/sides stx) - (syntax-case stx () - [(disjunct/sides clauses success (pre ...) (id ...)) - (with-syntax ([(#s(clause:attr #s(attr sub-id _ _) _) ...) #'clauses]) - (with-syntax ([(alt-sub-id ...) (generate-temporaries #'(sub-id ...))]) - #`(let ([alt-sub-id (attribute sub-id)] ...) - (let ([id #f] ...) - (let ([sub-id alt-sub-id] ...) - (success pre ... id ...))))))])) - - -;; (parse:G id FCE SinglePattern expr) : expr -(define-syntax (parse:G stx) - (syntax-case stx () - [(parse:G x fc pattern0 k) - (syntax-case #'pattern0 () - [#s(ghost:cut _) - #`(with-enclosing-fail enclosing-cut-fail k)] - [#s(ghost:bind _ clauses) - #`(convert-sides x clauses (clause-success () k))] - [#s(ghost:fail _ early? condition message) - #`(let* ([c (without-fails condition)] - [fc* (if (quote early?) - fc - (dfc-add-post fc (if (syntax? c) c x)))]) - (if c - (fail (if (syntax? c) c x) - #:expect (expectation pattern0) - #:fce fc*) - k))] - [#s(ghost:parse _ pattern expr) - #`(let* ([y (datum->syntax #f (without-fails expr))] - [fc* (dfc-add-post fc y)]) - (parse:S y fc* pattern k))])])) - -(begin-for-syntax - ;; convert-list-pattern : ListPattern id -> SinglePattern - ;; Converts '() datum pattern at end of list to bind (cons stx index) - ;; to rest-var. - (define (convert-list-pattern pattern end-pattern) - (syntax-case pattern () - [#s(pat:datum () ()) - end-pattern] - [#s(pat:name attrs pattern names) - (with-syntax ([pattern (convert-list-pattern #'pattern end-pattern)]) - #'#s(pat:name attrs pattern names))] - [#s(pat:ghost attrs ghost tail) - (with-syntax ([tail (convert-list-pattern #'tail end-pattern)]) - #'#s(pat:ghost attrs ghost tail))] - [#s(pat:head attrs head tail) - (with-syntax ([tail (convert-list-pattern #'tail end-pattern)]) - #'#s(pat:head attrs head tail))] - [#s(pat:dots attrs head tail) - (with-syntax ([tail (convert-list-pattern #'tail end-pattern)]) - #'#s(pat:dots attrs head tail))] - [#s(pat:compound attrs #:pair (head-part tail-part)) - (with-syntax ([tail-part (convert-list-pattern #'tail-part end-pattern)]) - #'#s(pat:compound attrs #:pair (head-part tail-part)))]))) - -;; (parse:H id FCE HeadPattern id id expr) : expr -;; x must not alias rest -(define-syntax (parse:H stx) - (syntax-case stx () - [(parse:H x fc head rest rest-fc k) - (syntax-case #'head () - [#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 transparent? failure) - #:fce fc)) - (let ([fc* (dfc-empty x)]) - (with-enclosing-fail* new-fail - (parse:H x fc* pattern rest rest-fc - (with-enclosing-cut-fail previous-cut-fail - (with-enclosing-fail previous-fail - k))))))] - [#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))]) - (parse:S lst fc single k)))] - [#s(hpat:or (a ...) (subpattern ...)) - (with-syntax ([(#s(attr id _ _) ...) #'(a ...)]) - #`(let ([success - (lambda (rest rest-fc fail id ...) - (with-enclosing-fail fail - (let-attributes ([a id] ...) k)))]) - (try (parse:H x fc subpattern rest rest-fc - (disjunct subpattern success - (rest rest-fc enclosing-fail) (id ...))) - ...)))] - [#s(hpat:seq attrs pattern) - (with-syntax ([pattern - (convert-list-pattern - #'pattern - #'#s(internal-rest-pattern rest rest-fc))]) - #'(parse:S x fc pattern k))] - [#s(hpat:optional (a ...) pattern defaults) - (with-syntax ([(#s(attr id _ _) ...) #'(a ...)]) - #`(let ([success - (lambda (rest rest-fc fail id ...) - (with-enclosing-fail fail - (let-attributes ([a id] ...) k)))]) - (try (parse:H x fc pattern rest rest-fc - (success rest rest-fc enclosing-fail (attribute id) ...)) - (let ([rest x] - [rest-fc fc]) - (convert-sides x defaults - (clause-success () - (disjunct/sides defaults success - (rest rest-fc enclosing-fail) - (id ...))))))))] - [_ - (with-syntax ([attrs (pattern-attrs (wash #'head))]) - #'(parse:S x fc - #s(pat:compound attrs - #:pair - (head #s(internal-rest-pattern rest rest-fc))) - k))])])) - -;; (parse:dots id FCE EHPattern SinglePattern expr) : expr -(define-syntax (parse:dots stx) - (syntax-case stx () - [(parse:dots x fc (#s(ehpat head-attrs head head-repc) ...) tail k) - (let () - (define repcs (wash-list wash #'(head-repc ...))) - (define rep-ids (for/list ([repc repcs]) - (and repc (generate-temporary 'rep)))) - (define rel-repcs (filter values repcs)) - (define rel-rep-ids (filter values rep-ids)) - (define aattrs - (for/list ([head-attrs (syntax->list #'(head-attrs ...))] - [repc repcs] - #:when #t - [a (wash-iattrs head-attrs)]) - (cons a repc))) - (define attrs (map car aattrs)) - (define attr-repcs (map cdr aattrs)) - (define ids (map attr-name attrs)) - (with-syntax ([(id ...) ids] - [(alt-id ...) (generate-temporaries ids)] - [reps rel-rep-ids] - [(head-rep ...) rep-ids] - [(rel-rep ...) rel-rep-ids] - [(rel-repc ...) rel-repcs] - [(a ...) attrs] - [(attr-repc ...) attr-repcs]) - (define-pattern-variable alt-map #'((id . alt-id) ...)) - (define-pattern-variable loop-k - #'(dots-loop dx* loop-fc* enclosing-fail rel-rep ... alt-id ...)) - #`(let () - (define (dots-loop dx loop-fc loop-fail rel-rep ... alt-id ...) - (with-enclosing-fail loop-fail - (try (parse:EH dx loop-fc head head-repc dx* loop-fc* alt-map head-rep - loop-k) - ... - (cond [(< rel-rep (rep:min-number rel-repc)) - (fail dx - #:expect (expectation-of-reps/too-few rel-rep rel-repc) - #:fce (dfc-add-pre loop-fc #f))] - ... - [else - (let-attributes ([a (rep:finalize a attr-repc alt-id)] ...) - (parse:S dx loop-fc tail k))])))) - (let ([rel-rep 0] ... - [alt-id (rep:initial-value attr-repc)] ...) - (dots-loop x fc enclosing-fail rel-rep ... alt-id ...)))))])) - -;; (parse:EH id FCE EHPattern id id ((id . id) ...) -;; RepConstraint/#f expr) : expr -(define-syntax (parse:EH stx) - (syntax-case stx () - [(parse:EH x fc head repc x* fc* alts rep k0) - (let () - (define-pattern-variable k - (let* ([main-attrs (wash-iattrs (pattern-attrs (wash #'head)))] - [ids (map attr-name main-attrs)] - [alt-ids - (let ([table (make-bound-id-table)]) - (for ([entry (syntax->list #'alts)]) - (let ([entry (syntax-e entry)]) - (bound-id-table-set! table (car entry) (cdr entry)))) - (for/list ([id ids]) (bound-id-table-ref table id)))]) - (with-syntax ([(id ...) ids] - [(alt-id ...) alt-ids] - [(alt-a ...) (map rename-attr main-attrs alt-ids)]) - #`(let ([alt-id (rep:combine repc (attribute id) alt-id)] ...) - k0)))) - (syntax-case #'repc () - [#f #`(parse:H x fc head x* fc* k)] - [_ #`(parse:H x fc head x* fc* - (if (< rep (rep:max-number repc)) - (let ([rep (add1 rep)]) k) - (fail x* - #:expect (expectation-of-reps/too-many rep repc) - #:fce fc*)))]))])) - -;; (rep:initial-value RepConstraint) : expr -(define-syntax (rep:initial-value stx) - (syntax-case stx () - [(_ #s(rep:once _ _ _)) #'#f] - [(_ #s(rep:optional _ _ _)) #'#f] - [(_ _) #'null])) - -;; (rep:finalize RepConstraint expr) : expr -(define-syntax (rep:finalize stx) - (syntax-case stx () - [(_ a #s(rep:optional _ _ defaults) v) - (with-syntax ([#s(attr name _ _) #'a] - [(#s(clause:attr da de) ...) #'defaults]) - (let ([default - (for/or ([da (syntax->list #'(da ...))] - [de (syntax->list #'(de ...))]) - (with-syntax ([#s(attr dname _ _) da]) - (and (bound-identifier=? #'name #'dname) de)))]) - (if default - #`(or v #,default) - #'v)))] - [(_ a #s(rep:once _ _ _) v) #'v] - [(_ a _ v) #'(reverse v)])) - -;; (rep:min-number RepConstraint) : expr -(define-syntax (rep:min-number stx) - (syntax-case stx () - [(_ #s(rep:once _ _ _)) #'1] - [(_ #s(rep:optional _ _ _)) #'0] - [(_ #s(rep:bounds min max _ _ _)) #'min])) - -;; (rep:max-number RepConstraint) : expr -(define-syntax (rep:max-number stx) - (syntax-case stx () - [(_ #s(rep:once _ _ _)) #'1] - [(_ #s(rep:optional _ _ _)) #'1] - [(_ #s(rep:bounds min max _ _ _)) #'max])) - -;; (rep:combine RepConstraint expr expr) : expr -(define-syntax (rep:combine stx) - (syntax-case stx () - [(_ #s(rep:once _ _ _) a b) #'a] - [(_ #s(rep:optional _ _ _) a b) #'a] - [(_ _ a b) #'(cons a b)])) - -;; ---- - -;; (expectation Pattern) -(define-syntax (expectation stx) - (syntax-case stx () - [(_ #s(pat:datum attrs d)) - #'(begin (collect-error '(datum d)) - (make-expect:atom 'd))] - [(_ #s(pat:literal attrs lit input-phase lit-phase)) - #'(begin (collect-error '(literal lit)) - (make-expect:literal (quote-syntax lit)))] - ;; 2 pat:compound patterns - ;;[(_ #s(pat:compound attrs #:pair (head-pattern tail-pattern))) - ;; #'(make-expect:pair)] - [(_ #s(pat:compound attrs kind0 (part-pattern ...))) - #'(collect-error 'ineffable)] - [(_ #s(pat:not _ pattern)) - #'(collect-error 'ineffable)] - [(_ #s(ghost:fail _ _e condition message)) - #'(expectation-of-message message)])) - -;; ---- - -(define-syntax-rule (expectation-of-thing description transparent? chained) - (make-expect:thing description transparent? chained)) - -(define-syntax-rule (expectation-of-message message) - (let ([msg (collect-error message)]) - (if msg - (make-expect:message msg) - 'ineffable))) - -(define-syntax expectation-of-reps/too-few - (syntax-rules () - [(_ rep #s(rep:once name too-few-msg too-many-msg)) - (expectation-of-message/too-few too-few-msg name)] - [(_ rep #s(rep:optional name too-many-msg _)) - (error 'impossible)] - [(_ rep #s(rep:bounds min max name too-few-msg too-many-msg)) - (expectation-of-message/too-few too-few-msg name)])) - -(define-syntax expectation-of-reps/too-many - (syntax-rules () - [(_ rep #s(rep:once name too-few-msg too-many-msg)) - (expectation-of-message/too-many too-many-msg name)] - [(_ rep #s(rep:optional name too-many-msg _)) - (expectation-of-message/too-many too-many-msg name)] - [(_ rep #s(rep:bounds min max name too-few-msg too-many-msg)) - (expectation-of-message/too-many too-many-msg name)])) - -(define-syntax expectation-of-message/too-few - (syntax-rules () - [(emtf #f #f) - (expectation-of-message "repetition constraint violated")] - [(emtf #f name) - (expectation-of-message - (format "missing required occurrence of ~a" name))] - [(emtf msg _) - (expectation-of-message msg)])) - -(define-syntax expectation-of-message/too-many - (syntax-rules () - [(emtm #f #f) - (expectation-of-message - (format "repetition constraint violated"))] - [(emtm #f name) - (expectation-of-message - (format "too many occurrences of ~a" name))] - [(emtm msg _) - (expectation-of-message msg)])) - -;; - -(define-syntax-parameter collect-error - (syntax-rules () - [(ce thing) thing] - [(ce) '()])) - -(define-syntax-rule (with-error-collector body) - (... - (let-syntax ([tmp (box null)]) - (syntax-parameterize ((collect-error - (lambda (stx) - (let ([b (syntax-local-value #'tmp)]) - (syntax-case stx () - [(ce thing) - (begin (set-box! b (cons #'thing (unbox b))) - #'thing)] - [(ce) - (with-syntax ([(thing ...) (reverse (unbox b))]) - #'(list #'thing ...))]))))) - body)))) diff --git a/collects/syntax/private/stxparse/rep-patterns.rkt b/collects/syntax/private/stxparse/rep-patterns.rkt deleted file mode 100644 index a4dcc4be46..0000000000 --- a/collects/syntax/private/stxparse/rep-patterns.rkt +++ /dev/null @@ -1,280 +0,0 @@ -#lang scheme/base -(require "rep-attrs.ss" - unstable/struct - (for-syntax scheme/base - syntax/stx - unstable/syntax)) -(provide (all-defined-out)) - -#| -A Base is (listof IAttr) - If P = (make-pattern Attrs ...) and A is in Attrs, - the depth of A is with respect to P, - not with respect to the entire enclosing pattern. -|# - -#| -A SinglePattern is one of - (make-pat:any Base) - (make-pat:var Base id id (listof stx) (listof IAttr) bool) - (make-pat:literal Base identifier ct-phase ct-phase) - (make-pat:datum Base datum) - (make-pat:ghost Base GhostPattern SinglePattern) - (make-pat:head Base HeadPattern SinglePattern) - (make-pat:dots Base (listof EllipsisHeadPattern) SinglePattern) - (make-pat:and Base (listof SinglePattern)) - (make-pat:or Base (listof SinglePattern)) - (make-pat:not Base SinglePattern) - (make-pat:compound Base Kind (listof SinglePattern)) - (make-pat:describe Base stx boolean SinglePattern) - -A ListPattern is a subtype of SinglePattern; one of - (make-pat:datum Base '()) - (make-pat:ghost Base GhostPattern ListPattern) - (make-pat:head Base HeadPattern ListPattern) - (make-pat:compound Base '#:pair (list SinglePattern ListPattern)) - (make-pat:dots Base EllipsisHeadPattern SinglePattern) -|# - -(define-struct pat:any (attrs) #:prefab) -(define-struct pat:var (attrs name parser args nested-attrs commit?) #:prefab) -(define-struct pat:literal (attrs id input-phase lit-phase) #:prefab) -(define-struct pat:datum (attrs datum) #:prefab) -(define-struct pat:ghost (attrs ghost inner) #:prefab) -(define-struct pat:head (attrs head tail) #:prefab) -(define-struct pat:dots (attrs heads tail) #:prefab) -(define-struct pat:and (attrs patterns) #:prefab) -(define-struct pat:or (attrs patterns) #:prefab) -(define-struct pat:not (attrs pattern) #:prefab) -(define-struct pat:compound (attrs kind patterns) #:prefab) -(define-struct pat:describe (attrs description transparent? pattern) #:prefab) - -#| -A GhostPattern is one of - (make-ghost:cut Base) - (make-ghost:fail Base bool 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 -|# - -(define-struct ghost:cut (attrs) #:prefab) -(define-struct ghost:fail (attrs early? 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 - (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) - (make-hpat:or Base (listof HeadPattern)) - (make-hpat:optional Base HeadPattern (listof clause:attr)) - (make-hpat:describe Base stx/#f boolean HeadPattern) -|# - -(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) -(define-struct hpat:or (attrs patterns) #:prefab) -(define-struct hpat:optional (attrs inner defaults) #:prefab) -(define-struct hpat:describe (attrs description transparent? pattern) #:prefab) - -#| -An EllipsisHeadPattern is - (make-ehpat Base HeadPattern RepConstraint) - -A RepConstraint is one of - (make-rep:once stx 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 defaults) #:prefab) -(define-struct rep:bounds (min max name under-message over-message) #:prefab) - - -#| -A Kind is one of - '#:pair - '#:box - '#:vector - (list '#:pstruct prefab-struct-key) -|# - -(define (pattern? x) - (or (pat:any? x) - (pat:var? x) - (pat:literal? x) - (pat:datum? x) - (pat:ghost? x) - (pat:head? x) - (pat:dots? x) - (pat:and? x) - (pat:or? x) - (pat:not? x) - (pat:compound? x) - (pat:describe? x))) - -(define (ghost-pattern? x) - (or (ghost:cut? x) - (ghost:bind? x) - (ghost:fail? x) - (ghost:and? x) - (ghost:parse? x))) - -(define (head-pattern? x) - (or (hpat:var? x) - (hpat:seq? x) - (hpat:ghost? x) - (hpat:and? x) - (hpat:or? x) - (hpat:optional? x) - (hpat:describe? x))) - -(define (ellipsis-head-pattern? x) - (ehpat? x)) - -(define single-pattern? pattern?) - -(define (single-or-head-pattern? x) - (or (single-pattern? x) - (head-pattern? x))) - -(define pattern-attrs - (let () - (define-syntax (mk-get-attrs stx) - (syntax-case stx () - [(_ struct ...) - (with-syntax - ([([pred accessor] ...) - (for/list ([s (stx->list #'(struct ...))]) - (list (format-id s "~a?" (syntax-e s)) - (format-id s "~a-attrs" (syntax-e s))))]) - #'(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:ghost pat:head - pat:dots pat:and pat:or pat:not pat:compound pat:describe - 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))) - - -;; ---- - -;; Helpers to handle attribute calculations -;; Too complicated for a few pattern forms; those are handled in rep.ss - -(define (create-pat:any) - (make pat:any null)) - -(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 commit?))) - -(define (create-pat:datum datum) - (make pat:datum null datum)) - -(define (create-pat:literal literal input-phase lit-phase) - (make pat:literal null literal input-phase lit-phase)) - -(define (create-pat:ghost g sp) - (cond [(ghost:and? g) - (for/fold ([sp sp]) ([g (reverse (ghost:and-patterns g))]) - (create-pat:ghost g sp))] - [else - (let ([attrs (append-iattrs (map pattern-attrs (list g sp)))]) - (make pat:ghost attrs g sp))])) - -(define (create-pat:head headp tailp) - (let ([attrs (append-iattrs (map pattern-attrs (list headp tailp)))]) - (make pat:head attrs headp tailp))) - -(define (create-pat:compound kind ps) - (make pat:compound (append-iattrs (map pattern-attrs ps)) kind ps)) - -(define (create-pat:describe description transparent? p) - (make pat:describe (pattern-attrs p) description transparent? p)) - -(define (create-pat:and patterns) - (let ([attrs (append-iattrs (map pattern-attrs patterns))]) - (make pat:and attrs patterns))) - -(define (create-pat:or patterns) - (let ([attrs (union-iattrs (map pattern-attrs patterns))]) - (make pat:or attrs patterns))) - -(define (create-pat:not pattern) - (make pat:not null pattern)) - -(define (create-pat:dots headps tailp) - (let ([attrs (append-iattrs (map pattern-attrs (cons tailp headps)))]) - (make pat:dots attrs headps tailp))) - -;; ---- - -(define (create-ghost:cut) - (make ghost:cut null)) - -(define (create-ghost:fail early? condition message) - (make ghost:fail null early? condition message)) - -(define (create-ghost:and patterns) - (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 commit?) - (let ([attrs - (if name (cons (make attr name 0 #t) nested-attrs) nested-attrs)]) - (make hpat:var attrs name parser args nested-attrs commit?))) - -(define (create-hpat:seq lp) - (make hpat:seq (pattern-attrs lp) lp)) - -(define (create-hpat:ghost g hp) - (cond [(ghost:and? g) - (for/fold ([hp hp]) ([g (reverse (ghost:and-patterns g))]) - (create-hpat:ghost g hp))] - [else - (let ([attrs (append-iattrs (map pattern-attrs (list g hp)))]) - (make hpat:ghost attrs g hp))])) - -(define (create-hpat:describe description transparent? p) - (make hpat:describe (pattern-attrs p) description transparent? p)) - -(define (create-hpat:and hp sp) - (make hpat:and (append-iattrs (map pattern-attrs (list hp sp))) hp sp)) - -(define (create-hpat:or patterns) - (let ([attrs (union-iattrs (map pattern-attrs patterns))]) - (make hpat:or attrs patterns))) - -;; ---- - -(define (ghost/head-pattern->list-pattern p) - (cond [(ghost-pattern? p) - (create-pat:ghost p (create-pat:any))] - [(hpat:seq? p) - ;; simplification: just extract list pattern from hpat:seq - (hpat:seq-inner p)] - [else - (create-pat:head p (create-pat:datum '()))])) - -(define (ghost-pattern->single-pattern gp) - (create-pat:ghost gp (create-pat:any))) diff --git a/collects/syntax/private/stxparse/runtime-prose.rkt b/collects/syntax/private/stxparse/runtime-prose.rkt deleted file mode 100644 index 3e1b0eb9ed..0000000000 --- a/collects/syntax/private/stxparse/runtime-prose.rkt +++ /dev/null @@ -1,238 +0,0 @@ -#lang racket/base -(require racket/contract/base - racket/list - "minimatch.ss" - racket/stxparam - syntax/stx - (for-syntax racket/base) - (for-syntax syntax/stx) - (for-syntax racket/private/sc) - (for-syntax "rep-data.ss") - (for-syntax "../util.ss") - "runtime.ss") -(provide syntax-patterns-fail - current-failure-handler - simplify-failure) - -;; Failure reporting parameter & default - -(define (default-failure-handler stx0 f) - (match (simplify-failure f) - [(make failure x frontier expectation) - (report-failure stx0 x (dfc->index frontier) (dfc->stx frontier) expectation)])) - -(define current-failure-handler - (make-parameter default-failure-handler)) - -(define ((syntax-patterns-fail stx0) f) - (call-with-values (lambda () ((current-failure-handler) stx0 f)) - (lambda vals - (error 'current-failure-handler - "current-failure-handler: did not escape, produced ~e" - (case (length vals) - ((1) (car vals)) - (else (cons 'values vals))))))) - -;; report-failure : stx stx number stx Expectation -> (escapes) -(define (report-failure stx0 x index frontier-stx expected) - (define (err msg stx0 stx) - (raise-syntax-error #f msg stx0 stx)) - (cond [(expectation-of-null? expected) - ;; FIXME: "extra term(s) after " - (syntax-case x () - [(one) - (err "unexpected term" stx0 #'one)] - [(first . more) - ;; TODO: report error with all elements (use improper-stx->list) - (err "unexpected terms starting here" stx0 #'first)] - [_ - (err "unexpected term" stx0 x)])] - [(and expected (prose-for-expectation expected index x)) - => - (lambda (msg) - (err (format "~a~a" - msg - (cond [(zero? index) ""] - [else (format " after ~s ~a" - index - (if (= 1 index) "term" "terms"))])) - stx0 - frontier-stx))] - [else - (err "bad syntax" stx0 stx0)])) - -;; simplify-failure : Failure -> SimpleFailure -(define (simplify-failure f) - (simplify* f)) - -;; simplify* : Failure -> SimpleFailure -(define (simplify* f) - (match f - [(make join-failures f1 f2) - (choose-error (simplify* f1) (simplify* f2))] - [(make failure x frontier expectation) - (match expectation - [(make expect:thing description '#t chained) - (let ([chained* (simplify* chained)]) - (match chained* - [(make failure _ chained*-frontier chained*-expectation) - (cond [(ineffable? chained*-expectation) - ;; If simplified chained failure is ineffable, - ;; keep (& adjust) its frontier - ;; and attach enclosing description - (adjust-failure - (make-failure x chained*-frontier - (make-expect:thing description #f #f)) - frontier)] - [else - ;; Otherwise, "expose" the chained failure and - ;; adjust its frontier - (adjust-failure chained* frontier)])]))] - [_ f])])) - -;; FIXME: try different selection/simplification algorithms/heuristics -(define (simplify-failure0 f) - (match f - [(make join-failures f1 f2) - (choose-error (simplify-failure0 f1) (simplify-failure0 f2))] - [(make failure x frontier expectation) - (match expectation - [(make expect:thing description '#t chained) - (let ([chained* (simplify-failure0 chained)]) - (match chained* - [(make failure _ _ chained*-expectation) - (cond [(ineffable? chained*-expectation) - ;; If simplified chained failure is ineffable, ignore it - ;; and stick to the one with the description - f] - [else - ;; Otherwise, "expose" the chained failure - ;; and adjust its frontier - (adjust-failure chained* frontier)])]))] - [_ f])])) - -(define (adjust-failure f base-frontier) - (match f - [(make failure x frontier expectation) - (let ([frontier (dfc-append base-frontier frontier)]) - (make-failure x frontier expectation))])) - -;; choose-error : Failure Failure -> Failure -(define (choose-error f1 f2) - (case (compare-idfcs (invert-dfc (failure-frontier f1)) - (invert-dfc (failure-frontier f2))) - [(>) f1] - [(<) f2] - [(=) (merge-failures f1 f2)])) - -;; merge-failures : failure failure -> failure -(define (merge-failures f1 f2) - (make-failure (failure-stx f1) - (failure-frontier f1) - (merge-expectations (failure-expectation f1) - (failure-expectation f2)))) - -;; ---- - -;; prose-for-expectation : Expectation syntax -> string/#f -(define (prose-for-expectation e index stx) - (cond [(expect? e) - (let ([alts (expect->alternatives e)]) - (and alts - (join-sep (for/list ([alt alts]) - (for-alternative alt index stx)) - ";" "or")))] - [(eq? e 'ineffable) - #f] - [else (error 'prose-for-expectation "unexpected: ~e" e)])) - -(define (for-alternative e index stx) - (match e - [(make expect:thing description transparent? chained) - (format "expected ~a" description)] - [(make expect:atom atom) - (format "expected the literal ~s" atom)] - [(make expect:literal literal) - (format "expected the literal identifier ~s" (syntax-e literal))] - [(make expect:message message) - (format "~a" message)] - [(make expect:pair) - (cond [(= index 0) - "expected sequence of terms"] - [else - (if (stx-null? stx) - "expected more terms in sequence" - "expected sequence of terms")])])) - -(define (comma-list items) - (join-sep items "," "or")) - -(define (join-sep items sep0 ult0 [prefix ""]) - (define sep (string-append sep0 " ")) - (define ult (string-append ult0 " ")) - (define (loop items) - (cond [(null? items) - null] - [(null? (cdr items)) - (list sep ult (car items))] - [else - (list* sep (car items) (loop (cdr items)))])) - (case (length items) - [(0) #f] - [(1) (string-append prefix (car items))] - [(2) (format "~a~a ~a~a" prefix (car items) ult (cadr items))] - [else (let ([strings (list* (car items) (loop (cdr items)))]) - (apply string-append prefix strings))])) - -(define (improper-stx->list stx) - (syntax-case stx () - [(a . b) (cons #'a (improper-stx->list #'b))] - [() null] - [rest (list #'rest)])) - - -;; Ad-hoc interpretation of error message expressions -(provide interpret-error-expression) - -;; Recognize application of 'format' procedure -(define (interpret-error-expression e) - (define vars '(X Y Z)) - - ;; minieval : syntax -> (or syntax datum) - ;; Returns syntax on NON-evalable stuff, datum otherwise - (define (minieval x) - (syntax-case x (format quote datum literal) - [(format str arg ...) - (string? (syntax-e #'str)) - (let ([args (map minieval (syntax->list #'(arg ...)))]) - (define args* - (cond [(<= (length (filter syntax? args)) (length vars)) - (for/list ([arg args]) - (if (syntax? arg) - (begin0 (car vars) (set! vars (cdr vars))) - arg))] - [else - (let ([counter 1]) - (for/list ([arg args]) - (if (syntax? arg) - (begin0 (format "Q~a" counter) - (set! counter (add1 counter))) - arg)))])) - (apply format (syntax-e #'str) args*))] - [(quote (datum d)) - (format "expected the literal ~a" (syntax->datum #'d))] - [(quote (literal lit)) - (format "expected the literal identifier ~s" (syntax-e #'lit))] - [(quote thing) - (syntax->datum #'thing)] - [d - (let ([d (syntax->datum #'d)]) - (or (string? d) (number? d) (boolean? d))) - (syntax->datum #'d)] - [_ - x])) - (let ([ie (minieval e)]) - (if (syntax? ie) - (syntax->datum ie) - ie))) - diff --git a/collects/syntax/private/stxparse/runtime.rkt b/collects/syntax/private/stxparse/runtime.rkt deleted file mode 100644 index 033ccd7d5d..0000000000 --- a/collects/syntax/private/stxparse/runtime.rkt +++ /dev/null @@ -1,652 +0,0 @@ -#lang racket/base -(require racket/contract/base - racket/stxparam - racket/list - unstable/struct - "minimatch.ss" - (for-syntax racket/base - syntax/stx - racket/private/sc - "rep-data.ss" - "rep-attrs.ss" - "../util.ss")) - -(provide pattern - ~var - ~datum - ~literal - ~and - ~or - ~not - ~seq - ~between - ~once - ~optional - ~rest - ~describe - ~! - ~bind - ~fail - ~early-fail - ~parse - ...+ - - current-expression - current-macro-name - - this-syntax - - expect? - expectation? - (struct-out expect:thing) - (struct-out expect:atom) - (struct-out expect:literal) - (struct-out expect:message) - (struct-out expect:pair) - (struct-out expect:disj) - merge-expectations - expect->alternatives - ineffable? - - expectation-of-null? - - enclosing-fail - enclosing-cut-fail - with-enclosing-fail - with-enclosing-cut-fail - with-enclosing-fail* - without-fails - - ok? - (struct-out failure) - (struct-out join-failures) - - try - - stx-list-take - - let-attributes - attribute - let/unpack - attribute-binding - check-list^depth) - -;; == Keywords - -(define-syntax-rule (define-keyword name) - (define-syntax name - (lambda (stx) - (raise-syntax-error #f "keyword used out of context" stx)))) - -(define-keyword pattern) -(define-keyword ~var) -(define-keyword ~datum) -(define-keyword ~literal) -(define-keyword ~and) -(define-keyword ~or) -(define-keyword ~not) -(define-keyword ~seq) -(define-keyword ~between) -(define-keyword ~once) -(define-keyword ~optional) -(define-keyword ~rest) -(define-keyword ~describe) -(define-keyword ~!) -(define-keyword ~bind) -(define-keyword ~fail) -(define-keyword ~early-fail) -(define-keyword ~parse) -(define-keyword ...+) - -;; == Parameters & Syntax Parameters - -;; this-syntax -;; Bound to syntax being matched inside of syntax class -(define-syntax-parameter this-syntax - (lambda (stx) - (wrong-syntax stx "used out of context: not within a syntax class"))) - -(define current-expression (make-parameter #f)) - -(define (current-macro-name) - (let ([expr (current-expression)]) - (and expr - (syntax-case expr (set!) - [(set! kw . _) - #'kw] - [(kw . _) - (identifier? #'kw) - #'kw] - [kw - (identifier? #'kw) - #'kw] - [_ #f])))) - - -;; == Dynamic Frontier Contexts (DFCs) - -(provide (struct-out dfc:empty) - (struct-out dfc:car) - (struct-out dfc:cdr) - (struct-out dfc:pre) - (struct-out dfc:post) - dfc-empty - dfc-add-car - dfc-add-cdr - dfc-add-pre - dfc-add-post - dfc-add-unbox - dfc-add-unvector - dfc-add-unpstruct - - dfc->index - dfc->stx - dfc-difference - dfc-append - - invert-dfc - compare-idfcs - idfc>? - idfc=?) - -#| -A Dynamic Frontier Context (DFC) is one of - - (make-dfc:empty stx) - - (make-dfc:car DFC stx) - - (make-dfc:cdr DFC positive-integer) - - (make-dfc:pre DFC stx) - - (make-dfc:post DFC stx) -|# - -(define-struct dfc:empty (stx) #:prefab) -(define-struct dfc:car (parent stx) #:prefab) -(define-struct dfc:cdr (parent n) #:prefab) -(define-struct dfc:pre (parent stx) #:prefab) -(define-struct dfc:post (parent stx) #:prefab) - -(define (dfc-empty x) (make dfc:empty x)) -(define (dfc-add-car parent stx) - (make dfc:car parent stx)) -(define (dfc-add-cdr parent _) - (match parent - [(make dfc:cdr uberparent n) - (make dfc:cdr uberparent (add1 n))] - [_ (make dfc:cdr parent 1)])) -(define (dfc-add-pre parent stx) - (make dfc:pre parent stx)) -(define (dfc-add-post parent stx) - (make dfc:post parent stx)) - -(define (dfc-add-unbox parent stx) - (dfc-add-car parent stx)) -(define (dfc-add-unvector parent stx) - (dfc-add-car parent stx)) -(define (dfc-add-unpstruct parent stx) - (dfc-add-car parent stx)) - -(define (dfc->index dfc) - (match dfc - [(make dfc:cdr parent n) n] - [_ 0])) - -(define (dfc->stx dfc) - (match dfc - [(make dfc:empty stx) stx] - [(make dfc:car parent stx) stx] - [(make dfc:cdr parent n) (dfc->stx parent)] - [(make dfc:pre parent stx) stx] - [(make dfc:post parent stx) stx])) - -;; dfc-difference : DFC DFC -> nat -;; Returns N s.t. B = (dfc-add-cdr^N A) -(define (dfc-difference a b) - (define (whoops) - (error 'dfc-difference "~e is not an extension of ~e" - (frontier->sexpr b) (frontier->sexpr a))) - (match (list a b) - [(list (make dfc:cdr pa na) (make dfc:cdr pb nb)) - (unless (equal? pa pb) (whoops)) - (- nb na)] - [(list pa (make dfc:cdr pb nb)) - (unless (equal? pa pb) (whoops)) - nb] - [_ - (unless (equal? a b) (whoops)) - 0])) - -;; dfc-append : DFC DFC -> DFC -;; puts A at the base, B on top -(define (dfc-append a b) - (match b - [(make dfc:empty stx) a] - [(make dfc:car pb stx) (make dfc:car (dfc-append a pb) stx)] - [(make dfc:cdr (make dfc:empty _) nb) - ;; Special case to merge "consecutive" cdr frames - (match a - [(make dfc:cdr pa na) (make dfc:cdr pa (+ na nb))] - [_ (make dfc:cdr a nb)])] - [(make dfc:cdr pb nb) (make dfc:cdr (dfc-append a pb) nb)] - [(make dfc:pre pb stx) (make dfc:pre (dfc-append a pb) stx)] - [(make dfc:post pb stx) (make dfc:post (dfc-append a pb) stx)])) - - -;; An Inverted DFC (IDFC) is a DFC inverted for easy comparison. - -(define (invert-dfc dfc) - (define (invert dfc acc) - (match dfc - [(make dfc:empty _) acc] - [(make dfc:car parent stx) - (invert parent (make dfc:car acc stx))] - [(make dfc:cdr parent n) - (invert parent (make dfc:cdr acc n))] - [(make dfc:pre parent stx) - (invert parent (make dfc:pre acc stx))] - [(make dfc:post parent stx) - (invert parent (make dfc:post acc stx))])) - (invert dfc (dfc-empty 'dummy))) - -;; compare-idfcs : IDFC IDFC -> (one-of '< '= '>) -;; Note A>B means A is "further along" than B. -;; Lexicographic generalization of PRE < CAR < CDR < POST -(define (compare-idfcs a b) - (match (list a b) - ;; Same constructors - [(list (make dfc:empty _) (make dfc:empty _)) '=] - [(list (make dfc:car pa _) (make dfc:car pb _)) - (compare-idfcs pa pb)] - [(list (make dfc:cdr pa na) (make dfc:cdr pb nb)) - (cond [(< na nb) (compare-idfcs pa (make dfc:cdr pb (- nb na)))] - [(> na nb) (compare-idfcs (make-dfc:cdr pa (- na nb)) pb)] - [(= na nb) (compare-idfcs pa pb)])] - [(list (make dfc:pre pa _) (make dfc:pre pb _)) - ;; FIXME: possibly just '= here, treat all sides as equiv - (compare-idfcs pa pb)] - [(list (make dfc:post pa _) (make dfc:post pb _)) - ;; FIXME: possibly just '= here, treat all sides as equiv - (compare-idfcs pa pb)] - ;; Different constructors - [(list (make dfc:empty _) _) '<] - [(list _ (make dfc:empty _)) '>] - [(list (make dfc:pre _ _) _) '<] - [(list _ (make dfc:pre _ _)) '>] - [(list (make dfc:car _ _) _) '<] - [(list _ (make dfc:car _ _)) '>] - [(list (make dfc:cdr _ _) _) '<] - [(list _ (make dfc:cdr _ _)) '>])) - -(define (idfc>? a b) - (eq? (compare-idfcs a b) '>)) - -(define (idfc=? a b) - (eq? (compare-idfcs a b) '=)) - -;; == Codegen internal syntax parameters - -(define-for-syntax not-allowed/not-parsing - (lambda (stx) - (wrong-syntax stx "used out of context: not parsing pattern"))) - -(define-syntax-parameter pattern-source not-allowed/not-parsing) - -;; Two levels of fail continuation: -;; - enclosing-fail : ordinary fail -;; - enclosing-cut-fail : last cut "prompt" - -(define-syntax-parameter enclosing-fail not-allowed/not-parsing) -(define-syntax-parameter enclosing-cut-fail not-allowed/not-parsing) - -(define-syntax-rule (with-enclosing-fail failvar expr) - (syntax-parameterize ((enclosing-fail (make-rename-transformer (quote-syntax failvar)))) - expr)) - -(define-syntax-rule (with-enclosing-cut-fail failvar expr) - (syntax-parameterize ((enclosing-cut-fail (make-rename-transformer (quote-syntax failvar)))) - expr)) - -(define-syntax-rule (with-enclosing-fail* failvar expr) - (syntax-parameterize ((enclosing-fail (make-rename-transformer (quote-syntax failvar))) - (enclosing-cut-fail (make-rename-transformer (quote-syntax failvar)))) - expr)) - -(define-syntax-rule (without-fails body) - (syntax-parameterize ((enclosing-fail not-allowed/not-parsing) - (enclosing-cut-fail not-allowed/not-parsing)) - body)) - - -;; == Success and Failure - -;; A Failure is one of -;; (make-failure stx DFC expectation/c) -;; (make-join-failures Failure Failure) - -(define ok? list?) - -(define-struct failure (stx frontier expectation) #:prefab) -(define-struct join-failures (f1 f2) #:prefab) - -;; (try expr ...) -(define-syntax (try stx) - (syntax-case stx () - [(try expr ...) - (when (stx-null? #'(expr ...)) - (raise-syntax-error #f "must have at least one attempt" stx)) - #'(try* (list (lambda (fail) - (with-enclosing-fail fail expr)) - ...) - enclosing-fail)])) - -;; FailFunction = (Failure -> Result) - -;; try* : (nonempty-listof (-> FailFunction Result)) FailFunction -> Result -(define (try* attempts fail) - (let ([first-attempt (car attempts)] - [rest-attempts (cdr attempts)]) - (if (null? rest-attempts) - (first-attempt fail) - (let ([next-fail - (lambda (f1) - (let ([combining-fail - (lambda (f2) - (fail (make join-failures f1 f2)))]) - (try* rest-attempts combining-fail)))]) - (first-attempt next-fail))))) - - -;; == Expectations - -;; FIXME: add phase to expect:literal - -#| -An Expectation is one of - 'ineffable - (make-expect:thing string boolean Failure/#f) - (make-expect:atom atom) - (make-expect:literal identifier) - (make-expect:message string) - (make-expect:pair) - (make-expect:disj Expectation Expectation) -|# -(define-struct expect:thing (description transparent? chained) #:prefab) -(define-struct expect:atom (atom) #:prefab) -(define-struct expect:literal (literal) #:prefab) -(define-struct expect:message (message) #:prefab) -(define-struct expect:pair () #:prefab) -(define-struct expect:disj (a b) #:prefab) - -(define (expect? x) - (or (expect:thing? x) - (expect:atom? x) - (expect:literal? x) - (expect:message? x) - (expect:pair? x) - (expect:disj? x))) - -(define expectation? - (or/c expect? (symbols 'ineffable))) - -(define (merge-expectations a b) - (make expect:disj a b)) - -;; expect->alternatives : Expectation -> (listof Expectation)/#f -;; #f indicates 'ineffable somewhere in expectation -(define (expect->alternatives e) - (define (loop-onto e rest) - (cond [(expect:disj? 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))) - -(define (expectation-of-null? e) - (or (equal? e '#s(expect:atom ())) - (and (expect:disj? e) - (expectation-of-null? (expect:disj-a e)) - (expectation-of-null? (expect:disj-b e))))) - -(define (ineffable? e) - (or (eq? e 'ineffable) - (and (expect:disj? e) - (or (ineffable? (expect:disj-a e)) - (ineffable? (expect:disj-b e)))))) - - -;; ----- - -(require syntax/stx) -(define (stx-list-take stx n) - (datum->syntax stx - (let loop ([stx stx] [n n]) - (if (zero? n) - null - (cons (stx-car stx) - (loop (stx-cdr stx) (sub1 n))))) - stx)) - -;; == Attributes - -(begin-for-syntax - (define-struct attribute-mapping (var name depth syntax?) - #:omit-define-syntaxes - #:property prop:procedure - (lambda (self stx) - (if (attribute-mapping-syntax? self) - #`(#%expression #,(attribute-mapping-var self)) - #`(let ([value #,(attribute-mapping-var self)]) - (if (check-syntax '#,(attribute-mapping-depth self) value) - value - (raise-syntax-error - #f - (format "attribute is bound to non-syntax value: ~e" value) - (quote-syntax #,(attribute-mapping-name self))))))))) - -;; check-syntax : nat any -> boolean -;; Returns #t if value is a (listof^depth syntax) -(define (check-syntax depth value) - (if (zero? depth) - (syntax? value) - (and (list? value) - (for/and ([part value]) - (check-syntax (sub1 depth) part))))) - -(define-syntax (let-attributes stx) - (define (parse-attr x) - (syntax-case x () - [#s(attr name depth syntax?) #'(name depth syntax?)])) - (syntax-case stx () - [(let-attributes ([a value] ...) . body) - (with-syntax ([((name depth syntax?) ...) - (map parse-attr (syntax->list #'(a ...)))]) - (with-syntax ([(vtmp ...) (generate-temporaries #'(name ...))] - [(stmp ...) (generate-temporaries #'(name ...))]) - #'(letrec-syntaxes+values - ([(stmp) (make-attribute-mapping (quote-syntax vtmp) 'name 'depth 'syntax?)] ...) - ([(vtmp) value] ...) - (letrec-syntaxes+values - ([(name) (make-syntax-mapping 'depth (quote-syntax stmp))] ...) - () - . body))))])) - -(define-syntax (attribute stx) - (parameterize ((current-syntax-context stx)) - (syntax-case stx () - [(attribute name) - (identifier? #'name) - (let ([mapping (syntax-local-value #'name (lambda () #f))]) - (unless (syntax-pattern-variable? mapping) - (wrong-syntax #'name "not bound as a pattern variable")) - (let ([var (syntax-mapping-valvar mapping)]) - (let ([attr (syntax-local-value var (lambda () #f))]) - (unless (attribute-mapping? attr) - (wrong-syntax #'name "not bound as an attribute")) - (syntax-property (attribute-mapping-var attr) - 'disappeared-use - #'name))))]))) - -;; (let/unpack (([id num] ...) expr) expr) : expr -;; Special case: empty attrs need not match packed length -(define-syntax (let/unpack stx) - (syntax-case stx () - [(let/unpack (() packed) body) - #'body] - [(let/unpack ((a ...) packed) body) - (with-syntax ([(tmp ...) (generate-temporaries #'(a ...))]) - #'(let-values ([(tmp ...) (apply values packed)]) - (let-attributes ([a tmp] ...) body)))])) - -;; (attribute-binding id) -;; mostly for debugging/testing -(define-syntax (attribute-binding stx) - (syntax-case stx () - [(attribute-bound? name) - (identifier? #'name) - (let ([value (syntax-local-value #'name (lambda () #f))]) - (if (syntax-pattern-variable? value) - (let ([value (syntax-local-value (syntax-mapping-valvar value) (lambda () #f))]) - (if (attribute-mapping? value) - #`(quote #,(make-attr (attribute-mapping-name value) - (attribute-mapping-depth value) - (attribute-mapping-syntax? value))) - #'(quote #f))) - #'(quote #f)))])) - -;; (check-list^depth attr expr) -(define-syntax (check-list^depth stx) - (syntax-case stx () - [(_ a expr) - (with-syntax ([#s(attr name depth syntax?) #'a]) - (quasisyntax/loc #'expr - (check-list^depth* 'name 'depth expr)))])) - -(define (check-list^depth* aname n0 v0) - (define (loop n v) - (when (positive? n) - (unless (list? v) - (raise-type-error aname (format "lists nested ~s deep" n0) v)) - (for ([x v]) (loop (sub1 n) x)))) - (loop n0 v0) - v0) - - -;; ---- - -;; debugging - -(provide failure->sexpr - one-failure->sexpr - frontier->sexpr - expectation->sexpr) - -(define (failure->sexpr f) - (define fs - (let loop ([f f]) - (match f - [(make join-failures f1 f2) - (append (loop f1) (loop f2))] - [_ (list f)]))) - (case (length fs) - ((1) (one-failure->sexpr f)) - (else `(union ,@(map one-failure->sexpr fs))))) - -(define (one-failure->sexpr f) - (match f - [(make failure x frontier expectation) - `(failure ,(frontier->sexpr frontier) - #:term ,(syntax->datum x) - #:expected ,(expectation->sexpr expectation))])) - -(define (frontier->sexpr dfc) - (match (invert-dfc dfc) - [(make dfc:empty _) '()] - [(make dfc:car p _) (cons 'car (frontier->sexpr p))] - [(make dfc:cdr p n) (cons n (frontier->sexpr p))] - [(make dfc:pre p _) (cons 'pre (frontier->sexpr p))] - [(make dfc:post p _) (cons 'post (frontier->sexpr p))])) - -(define (expectation->sexpr expectation) - (match expectation - [(make expect:thing thing '#t chained) - (make expect:thing thing #t (failure->sexpr chained))] - [_ expectation])) - - -;; - -(provide (struct-out parser)) - -(define-struct parser (proc errors) - #:property prop:procedure (struct-field-index proc)) - -;; - -(provide curried-stxclass-procedures) - -(define-syntax (curried-stxclass-procedures stx) - (syntax-case stx () - [(cp class (arg ...)) - (let* ([args (syntax->list #'(arg ...))] - [sc (get-stxclass/check-arg-count #'class (length args))]) - (with-syntax ([parser (stxclass-parser-name sc)] - [get-description (stxclass-description sc)] - [(extra ...) - (if (stxclass-commit? sc) - #'() - #'(k))]) - #'(values (lambda (x extra ...) (parser x extra ... arg ...)) - (lambda () (get-description arg ...)))))])) - -;; - -(provide check-literal - free-identifier=?/phases) - -;; check-literal : id phase-level stx -> void -;; FIXME: change to normal 'error', if src gets stripped away -(define (check-literal id phase ctx) - (unless (identifier-binding id phase) - (raise-syntax-error #f - (format "literal is unbound in phase ~s" phase) - ctx id))) - -;; free-identifier=?/phases : id phase-level id phase-level -> boolean -;; Determines whether x has the same binding at phase-level phase-x -;; that y has at phase-level y. -;; At least one of the identifiers MUST have a binding (module or lexical) -(define (free-identifier=?/phases x phase-x y phase-y) - (let ([bx (identifier-binding x phase-x)] - [by (identifier-binding y phase-y)]) - (cond [(and (list? bx) (list? by)) - (let ([modx (module-path-index-resolve (first bx))] - [namex (second bx)] - [phasex (fifth bx)] - [mody (module-path-index-resolve (first by))] - [namey (second by)] - [phasey (fifth by)]) - (and (eq? modx mody) ;; resolved-module-paths are interned - (eq? namex namey) - (equal? phasex phasey)))] - [else - ;; One must be lexical (can't be #f, since one must be bound) - ;; lexically-bound names bound in only one phase; just compare - (free-identifier=? x y)]))) - -;; ---- - -(provide begin-for-syntax/once) - -;; (begin-for-syntax/once expr/phase1 ...) -;; evaluates in pass 2 of module/intdefs expansion -(define-syntax (begin-for-syntax/once stx) - (syntax-case stx () - [(bfs/o e ...) - (cond [(list? (syntax-local-context)) - #`(define-values () - (begin (begin-for-syntax/once e ...) - (values)))] - [else - #'(let-syntax ([m (lambda _ (begin e ...) #'(void))]) - (m))])])) diff --git a/collects/syntax/private/stxparse/sc.rkt b/collects/syntax/private/stxparse/sc.rkt deleted file mode 100644 index 636f7fcb7f..0000000000 --- a/collects/syntax/private/stxparse/sc.rkt +++ /dev/null @@ -1,291 +0,0 @@ -#lang racket/base -(require (for-syntax racket/base - racket/private/sc - unstable/syntax - unstable/struct - "minimatch.ss" - "../util/txlift.ss" - "rep-data.ss" - "rep.ss") - racket/list - syntax/stx - "parse.ss" - "runtime.ss" - "runtime-prose.ss") - -(provide define-syntax-class - define-splicing-syntax-class - - define-literal-set - define-conventions - syntax-class-parse - syntax-class-attributes - syntax-class-possible-errors - - debug-rhs - debug-pattern - debug-parse - - syntax-parse - syntax-parser - - pattern - ~var - ~datum - ~literal - ~and - ~or - ~not - ~seq - ~between - ~once - ~optional - ~rest - ~describe - ~! - ~bind - ~fail - ;; ~early-fail - ~parse - ...+ - - attribute - this-syntax) - -(begin-for-syntax - (define (defstxclass stx name args rhss splicing?) - (with-syntax ([name name] - [(arg ...) args] - [rhss rhss]) - (let ([the-rhs - (parameterize ((current-syntax-context stx)) - (parse-rhs #'rhss #f splicing? #:context stx))]) - (with-syntax ([parser (generate-temporary - (format-symbol "parse-~a" (syntax-e #'name)))] - [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? - 'commit?)) - (define-values (parser description) - (functions/rhs name (arg ...) attrs rhss #,splicing? #,stx)))))))) - -(define-syntax (define-syntax-class stx) - (syntax-case stx () - [(define-syntax-class name . rhss) - (identifier? #'name) - (defstxclass stx #'name #'() #'rhss #f)] - [(define-syntax-class (name arg ...) . rhss) - (andmap identifier? (syntax->list #'(name arg ...))) - (defstxclass stx #'name #'(arg ...) #'rhss #f)])) - -(define-syntax (define-splicing-syntax-class stx) - (syntax-case stx () - [(define-splicing-syntax-class name . rhss) - (identifier? #'name) - (defstxclass stx #'name #'() #'rhss #t)] - [(define-splicing-syntax-class (name arg ...) . rhss) - (andmap identifier? (syntax->list #'(name arg ...))) - (defstxclass stx #'name #'(arg ...) #'rhss #t)])) - -(define-syntax (define-conventions stx) - (syntax-case stx () - [(define-conventions (name param ...) rule ...) - (let ([params (syntax->list #'(param ...))]) - (for ([x (syntax->list #'(name param ...))]) - (unless (identifier? x) - (raise-syntax-error #f "expected identifier" stx x))) - (let () - (define rules (check-conventions-rules #'(rule ...) stx)) - (define rxs (map car rules)) - (define dens0 (map cadr rules)) - (define den+defs-list - (for/list ([den0 dens0]) - (let-values ([(den defs) (create-aux-def den0)]) - (cons den defs)))) - (define dens (map car den+defs-list)) - (define defs (apply append (map cdr den+defs-list))) - - (define/with-syntax (rx ...) rxs) - (define/with-syntax (def ...) defs) - (define/with-syntax (parser ...) - (map den:delayed-parser dens)) - (define/with-syntax (description ...) - (map den:delayed-description dens)) - (define/with-syntax (class-name ...) - (map den:delayed-class dens)) - - #'(begin - (define-syntax name - (make-conventions - (quote-syntax get-procedures) - (lambda () - (let ([class-names (list (quote-syntax class-name) ...)]) - (map list - (list 'rx ...) - (map make-den:delayed - (generate-temporaries class-names) - (generate-temporaries class-names) - class-names)))))) - (define get-procedures - (lambda (param ...) - def ... - (values (list parser ...) - (list description ...)))))))] - - [(define-conventions name rule ...) - (identifier? #'name) - #'(define-conventions (name) rule ...)])) - -(define-syntax (define-literal-set stx) - (syntax-case stx () - [(define-literal-set name (lit ...)) - (let ([phase-of-definition (syntax-local-phase-level)]) - (unless (identifier? #'name) - (raise-syntax-error #f "expected identifier" stx #'name)) - (let ([lits (check-literals-list/litset #'(lit ...) stx)]) - (with-syntax ([((internal external) ...) lits]) - #`(begin - (define phase-of-literals - (phase-of-enclosing-module)) - (define-syntax name - (make-literalset - (list (list 'internal (quote-syntax external)) ...) - (quote-syntax phase-of-literals))) - (begin-for-syntax/once - (for ([x (syntax->list #'(external ...))]) - (unless (identifier-binding x 0) - (raise-syntax-error #f "literal is unbound in phase 0" - (quote-syntax #,stx) x))))))))])) - -(define-syntax (phase-of-enclosing-module stx) - (syntax-case stx () - [(poem) - (let ([phase-within-module (syntax-local-phase-level)]) - #`(let ([phase-of-this-expression - (variable-reference->phase (#%variable-reference))]) - (- phase-of-this-expression - #,(if (zero? phase-within-module) 0 1))))])) - -#| -Literal sets: The goal is for literals to refer to their bindings at - - phase 0 relative to the enclosing module - -Use cases, explained: -1) module X with def-lit-set is required-for-syntax - phase-of-mod-inst = 1 - phase-of-def = 0 - literals looked up at abs phase 1 - which is phase 0 rel to module X -2) module X with local def-lit-set within define-syntax - phase-of-mod-inst = 1 (mod at 0, but +1 within define-syntax) - phase-of-def = 1 - literals looked up at abs phase 0 - which is phase 0 rel to module X -3) module X with def-lit-set in phase-2 position (really uncommon case!) - phase-of-mod-inst = 1 (not 2, apparently) - phase-of-def = 2 - literals looked up at abs phase 0 - (that's why the weird (if (z?) 0 1) term) -|# - -;; ---- - -(define-syntax (functions/rhs stx) - (syntax-case stx () - [(functions/S-rhs name args attrs rhss splicing? ctx) - (with-disappeared-uses - (let ([rhs - (parameterize ((current-syntax-context #'ctx)) - (parse-rhs #'rhss (syntax->datum #'attrs) (syntax-e #'splicing?) - #:context #'ctx))]) - #`(let ([get-description - (lambda args - #,(or (rhs-description rhs) - #'(symbol->string 'name)))]) - (values (parse:rhs #,rhs - attrs - args - get-description - splicing?) - get-description))))])) - -(define-syntax (syntax-class-parse stx) - (syntax-case stx () - [(_ s x arg ...) - (parameterize ((current-syntax-context stx)) - (let* ([arg-count (length (syntax->list #'(arg ...)))] - [stxclass (get-stxclass/check-arg-count #'s arg-count)] - [attrs (stxclass-attrs stxclass)]) - (with-syntax ([parser (stxclass-parser-name stxclass)] - [(name ...) (map attr-name attrs)] - [(depth ...) (map attr-depth attrs)]) - #'(let ([raw (parser x arg ...)]) - (if (ok? raw) - (map vector '(name ...) '(depth ...) raw) - raw)))))])) - -(define-syntax (syntax-class-attributes stx) - (syntax-case stx () - [(_ s) - (parameterize ((current-syntax-context stx)) - (let ([attrs (stxclass-attrs (get-stxclass #'s))]) - (with-syntax ([(a ...) (map attr-name attrs)] - [(depth ...) (map attr-depth attrs)]) - #'(quote ((a depth) ...)))))])) - -(define-syntax (syntax-class-possible-errors stx) - (syntax-case stx () - [(_ s) - (parameterize ((current-syntax-context stx)) - (with-syntax ([p (stxclass-parser-name (get-stxclass #'s))]) - #'(remove-duplicates - (map interpret-error-expression - (parser-errors p)))))])) - -(define-syntax (debug-rhs stx) - (syntax-case stx () - [(debug-rhs rhs) - (let ([rhs (parse-rhs #'rhs #f #f #:context stx)]) - #`(quote #,rhs))])) - -(define-syntax (debug-pattern stx) - (syntax-case stx () - [(debug-pattern p) - (let ([p (parse-whole-pattern #'p (new-declenv null) #:context stx)]) - #`(quote #,p))])) - -(define-syntax-rule (debug-parse x p) - (let/ec escape - (parameterize ((current-failure-handler - (lambda (_ f) - (escape (failure->sexpr f) - (failure->sexpr (simplify-failure f)))))) - (syntax-parse x [p 'success])))) - -(define-syntax (syntax-parse stx) - (syntax-case stx () - [(syntax-parse stx-expr . clauses) - (quasisyntax/loc stx - (let ([x (datum->syntax #f stx-expr)]) - (parse:clauses x clauses #,((make-syntax-introducer) stx))))])) - -(define-syntax (syntax-parser stx) - (syntax-case stx () - [(syntax-parser . clauses) - (quasisyntax/loc stx - (lambda (x) - (let ([x (datum->syntax #f x)]) - (parse:clauses x clauses #,((make-syntax-introducer) stx)))))])) - -(define-syntax with-patterns - (syntax-rules () - [(with-patterns () . b) - (let () . b)] - [(with-patterns ([p x] . more) . b) - (syntax-parse x [p (with-patterns more . b)])])) diff --git a/collects/syntax/scribblings/parse.scrbl b/collects/syntax/scribblings/parse.scrbl index 23dbb8b140..7bf33733b2 100644 --- a/collects/syntax/scribblings/parse.scrbl +++ b/collects/syntax/scribblings/parse.scrbl @@ -1,898 +1,31 @@ #lang scribble/doc @(require scribble/manual - scribble/struct - scribble/decode - scribble/eval - scheme/sandbox - (for-label scheme/base - scheme/contract - (except-in syntax/parse ...+) - syntax/kerncase)) - -@(define ellipses @scheme[...]) - -@(begin - (define (fixup exn) - (let ([src (ormap values (exn:fail:syntax-exprs exn))]) - (if src - (make-exn:fail:syntax - (format "~a at: ~a" (exn-message exn) (syntax->datum src)) - (exn-continuation-marks exn) - (exn:fail:syntax-exprs exn)) - exn))) - (define the-eval - (parameterize ((sandbox-output 'string) - (sandbox-error-output 'string) - (sandbox-make-code-inspector current-code-inspector) - (sandbox-eval-handlers - (list #f - (lambda (thunk) - (with-handlers ([exn:fail:syntax? - (lambda (e) (raise (fixup e)))]) - (thunk)))))) - (make-evaluator 'scheme/base - #:requires '(syntax/parse (for-syntax scheme/base))))) - (the-eval '(error-print-source-location #f)) - (define-syntax-rule (myexamples e ...) - (examples #:eval the-eval e ...))) + (for-label syntax/parse)) @title[#:tag "stxparse" #:style '(toc)]{Parsing and classifying syntax} The @schememodname[syntax/parse] library provides a framework for -describing and parsing syntax. Using @schememodname[syntax/parse], -macro writers can define new syntactic categories, specify their legal -syntax, and use them to write clear, concise, and robust macros. The -library also provides a pattern-matching form, @scheme[syntax-parse], -which offers many improvements over @scheme[syntax-case]. - +writing macros and processing syntax. The library provides a powerful +language of syntax patterns, used by the pattern-matching form +@scheme[syntax-parse] and the specification form +@scheme[define-syntax-class]. Macros that use @scheme[syntax-parse] +automatically generate error messages based on descriptions and +messages embedded in the macro's syntax patterns. @defmodule[syntax/parse] @local-table-of-contents[] -@;{----------} +@include-section["parse/intro.scrbl"] +@include-section["parse/examples.scrbl"] +@include-section["parse/parsing.scrbl"] +@include-section["parse/patterns.scrbl"] +@include-section["parse/litconv.scrbl"] +@include-section["parse/lib.scrbl"] -@section{Quick Start} +@;{Description of how error reporting works} +@;{and designing for good errors} -This section provides a rapid introduction to the -@schememodname[syntax/parse] library for the macro programmer. +@;{Cut and Commit for efficiency and error reporting.} -To use @scheme[syntax-parse] to write a macro transformer, import it -@scheme[for-syntax]: - -@schemeblock[(require (for-syntax syntax/parse))] - -For example, here is is a module that defines -@schemekeywordfont{mylet}, a macro that has the same behavior as the -standard @scheme[let] form (including ``named @scheme[let]''): - -@schemeblock[ -(module example racket/base - (require (for-syntax scheme/base syntax/parse)) - (define-syntax (mylet stx) - (syntax-parse stx - [(_ loop:id ((x:id e:expr) ...) . body) - #'(letrec ([loop (lambda (x ...) . body)]) - (loop e ...))] - [(_ ((x:id e:expr) ...) . body) - #'((lambda (x ...) . body) e ...)]))) -] - -The macro is defined as a procedure that takes one argument, -@scheme[stx]. The @scheme[syntax-parse] form is similar to -@scheme[syntax-case], except that there is no literals list between -the syntax argument and the sequence of clauses. - -@bold{Note: } Remember not to put a @scheme[syntax-case] style -literals list between the syntax argument and the clauses! - -The patterns contain identifiers consisting of two parts separated by -a colon character, such as @scheme[loop:id] or @scheme[e:expr]. These -are pattern variables annotated with syntax classes. For example, -@scheme[loop:id] is a pattern variable named @scheme[loop] with the -syntax class @scheme[id] (identifier). Note that only the pattern -variable part is used in the syntax template. - -Syntax classes restrict what a pattern variable can match. Above, -@scheme[loop] only matches an identifier, so the first clause only -matches the ``named-let'' syntax. Syntax classes replace some uses of -@scheme[syntax-case]'s ``fenders'' or guard expressions. They also -enable @scheme[syntax-parse] to automatically give specific error -messages. - -The @schememodname[syntax/parse] library provides several built-in -syntax classes (see @secref{lib} for a list). Programmers can also -define their own using @scheme[define-syntax-class]: - -@schemeblock[ -(module example-syntax racket/base - (require syntax/parse) - (provide binding) - (define-syntax-class binding - #:attributes (x e) - (pattern (x:id e:expr)))) - -(module example racket/base - (require (for-syntax racket/base - syntax/parse - 'example-syntax)) - (define-syntax (mylet stx) - (syntax-parse stx - [(_ loop:id (b:binding ...) . body) - #'(letrec ([loop (lambda (b.x ...) . body)]) - (loop b.e ...))] - [(_ (b:binding ...) . body) - #'((lambda (b.x ...) . body) b.e ...)]))) -] - -@bold{Note:} Syntax classes must be defined in the same phase as the -@scheme[syntax-parse] expression they're used in. The right-hand side -of a macro is at phase 1, so syntax classes it uses must be defined in -a separate module and required @scheme[for-syntax]. Since the -auxiliary module uses @scheme[define-syntax-class] at phase 0, it has -@scheme[(require syntax/parse)], with no @scheme[for-syntax]. - -Alternatively, the syntax class could be made a local definition, -thus: - -@schemeblock[ -(module example racket/base - (require (for-syntax scheme/base - syntax/parse)) - (define-syntax (mylet stx) - (define-syntax-class binding - #:attributes (x e) - (pattern (x:id e:expr))) - (syntax-parse stx - [(_ loop:id (b:binding ...) . body) - #'(letrec ([loop (lambda (b.x ...) . body)]) - (loop b.e ...))] - [(_ (b:binding ...) . body) - #'((lambda (b.x ...) . body) b.e ...)]))) -] - -A syntax class is an abstraction of a syntax pattern. The syntax class -@scheme[binding] gives a name to the repeated pattern fragment -@scheme[(x:id e:expr)]. The components of the fragment, @scheme[x] and -@scheme[e], become @tech{attributes} of the syntax class. When -@scheme[b:binding] matches, @scheme[b] gets bound to the whole binding -pair, and @scheme[b.x] and @scheme[b.e] get bound to the variable name -and expression, respectively. Actually, all of them are bound to -sequences, because of the ellipses. - -Syntax classes can have multiple alternative patterns. Suppose we -wanted to extend @schemekeywordfont{mylet} to allow a simple -identifier as a binding, in which case it would get the value -@scheme[#f]: - -@schemeblock[ -(mylet ([a 1] b [c 'foo]) ....) -] - -Here's how the syntax class would change: - -@margin-note{The @scheme[(require (for-template scheme/base))] is -needed for the @scheme[quote] expression. If the syntax class -definition were a local definition in the same module, the -@scheme[for-template] would be unnecessary.} -@; -@SCHEMEBLOCK[ -(module example-syntax scheme/base - (require syntax/parse) - (require (for-template scheme/base)) - (provide binding) - (define-syntax-class binding - #:attributes (x e) - (pattern (x:id e:expr)) - (pattern x:id - #:with e #'(quote #f)))) -] - -The second pattern matches unparenthesized identifiers. The @scheme[e] -attribute is bound using a @scheme[#:with] clause, which matches the -pattern @scheme[e] against the syntax from evaluating @scheme[#'#f]. - -Optional keyword arguments are supported via @tech{head -patterns}. Unlike normal patterns, which match one term, head patterns -can match a variable number of subterms in a list. - -Suppose @schemekeywordfont{mylet} accepted an optional -@scheme[#:check] keyword with one argument, a procedure that would be -applied to every variable's value. Here's one way to write it -(dropping the named-let variant for simplicity): - -@SCHEMEBLOCK[ -(define-syntax (mylet stx) - (syntax-parse stx - [(_ (~optional (~seq #:check pred)) (b:binding ...) . body) - #`((lambda (b.x ...) - #,(if (attribute pred) - #'(unless (and (pred b.x) ...) (error 'check)) - #'(void)) - . body) - b.e ...)])) -] - -An optional subpattern might not match, so attributes within an -@scheme[~optional] form might not be bound to syntax. Such -non-syntax-valued attributes may not be used within syntax -templates. The @scheme[attribute] special form is used to get the -value of an attribute; if the attribute didn't get matched, the value -is @scheme[#f]. - -Here's another way write it, using @scheme[#:defaults] to give the -@scheme[pred] attribute a default value: - -@schemeblock[ -(define-syntax (mylet stx) - (syntax-parse stx - [(_ (~optional (~seq #:check pred) - #:defaults ([pred #'(lambda (x) #t)])) - (b:binding ...) . body) - #`((lambda (b.x ...) - (unless (and (pred b.x) ...) (error 'check)) - . body) - b.e ...)])) -] - -Programmers can also create abstractions over head patterns, using -@scheme[define-splicing-syntax-class]. Here it is, rewritten to use -multiple alternatives instead of @scheme[~optional]: - -@schemeblock[ -(define-splicing-syntax-class optional-check - #:attributes (pred) - (pattern (~seq #:check pred)) - (pattern (~seq) - #:with pred #'(lambda (x) #t))) -] - -@bold{Note: } When defining a splicing syntax class, remember to -include @scheme[~seq] in the pattern! - -Here is the corresponding macro: - -@schemeblock[ -(define-syntax (mylet stx) - (syntax-parse stx - [(_ c:optional-check (b:binding ...) . body) - #'((lambda (b.x ...) - (unless (and (c.pred b.x) ...) (error 'check)) - . body) - b.e ...)])) -] - -The documentation in the following sections contains additional -examples of @schememodname[syntax/parse] features. - - -@;{----------} - -@section{Parsing and classifying syntax} - -This section describes @schememodname[syntax/parse]'s facilities for -parsing and classifying syntax. These facilities use a common language -of @tech{syntax patterns}, which is described in detail in the next -section, @secref{syntax-patterns}. - -@subsection{Parsing syntax} - -Two parsing forms are provided: @scheme[syntax-parse] and -@scheme[syntax-parser]. - -@defform/subs[(syntax-parse stx-expr parse-option ... clause ...+) - ([parse-option (code:line #:context context-expr) - (code:line #:literals (literal ...)) - (code:line #:literal-sets (literal-set ...)) - (code:line #:conventions (convention-id ...)) - (code:line #:local-conventions (convention-rule ...))] - [literal literal-id - (pattern-id literal-id) - (pattern-id literal-id #:phase phase-expr)] - [literal-set literal-set-id - (literal-set-id literal-set-option ...)] - [literal-set-option (code:line #:at context-id) - (code:line #:phase phase-expr)] - [clause (syntax-pattern pattern-directive ... expr ...+)]) - #:contracts ([stx-expr syntax?])]{ - -Evaluates @scheme[stx-expr], which should produce a syntax object, and -matches it against the @scheme[clause]s in order. If some clause's -pattern matches, its attributes are bound to the corresponding -subterms of the syntax object and that clause's side conditions and -@scheme[expr] is evaluated. The result is the result of @scheme[expr]. - -If the syntax object fails to match any of the patterns (or all -matches fail the corresponding clauses' side conditions), a syntax -error is raised. - -The following options are supported: - -@specsubform[(code:line #:context context-expr) - #:contracts ([context-expr syntax?])]{ - -When present, @scheme[context-expr] is used in reporting parse -failures; otherwise @scheme[stx-expr] is used. - -@(myexamples - (syntax-parse #'(a b 3) - [(x:id ...) 'ok]) - (syntax-parse #'(a b 3) - #:context #'(lambda (a b 3) (+ a b)) - [(x:id ...) 'ok])) -} - -@specsubform/subs[(code:line #:literals (literal ...)) - ([literal literal-id - (pattern-id literal-id) - (pattern-id literal-id #:phase phase-expr)])]{ -@margin-note{ - Unlike @scheme[syntax-case], @scheme[syntax-parse] requires all - literals to have a binding. To match identifiers by their symbolic - names, use the @scheme[~datum] pattern form instead. -} -@; -The @scheme[#:literals] option specifies identifiers that should be -treated as @tech{literals} rather than @tech{pattern variables}. An -entry in the literals list has two components: the identifier used -within the pattern to signify the positions to be matched -(@scheme[pattern-id]), and the identifier expected to occur in those -positions (@scheme[literal-id]). If the entry is a single identifier, -that identifier is used for both purposes. - -If the @scheme[#:phase] option is given, then the literal is compared -at phase @scheme[phase-expr]. Specifically, the binding of the -@scheme[literal-id] at phase @scheme[phase-expr] must match the -input's binding at phase @scheme[phase-expr]. -} - -@specsubform/subs[(code:line #:literal-sets (literal-set ...)) - ([literal-set literal-set-id - (literal-set-id literal-set-option ...)] - [literal-set-option (code:line #:at context-id) - (code:line #:phase phase-expr)])]{ - -Many literals can be declared at once via one or more @tech{literal -sets}, imported with the @scheme[#:literal-sets] option. See -@tech{literal sets} for more information. -} - -@specsubform[(code:line #:conventions (conventions-id ...))]{ - -Imports @tech{convention}s that give default syntax classes to pattern -variables that do not explicitly specify a syntax class. -} - -@specsubform[(code:line #:local-conventions (convention-rule ...))]{ - -Uses the @tech{conventions} specified. The advantage of -@scheme[#:local-conventions] over @scheme[#:conventions] is that local -conventions can be in the scope of syntax-class parameter -bindings. See the section on @tech{conventions} for examples. -} - -Each clause consists of a @tech{syntax pattern}, an optional sequence -of @tech{pattern directives}, and a non-empty sequence of body -expressions. -} - -@defform[(syntax-parser parse-option ... clause ...+)]{ - -Like @scheme[syntax-parse], but produces a matching procedure. The -procedure accepts a single argument, which should be a syntax object. -} - -@;{----------} - -@subsection{Classifying syntax} - -Syntax classes provide an abstraction mechanism for @tech{syntax -patterns}. Built-in syntax classes are supplied that recognize basic -classes such as @scheme[identifier] and @scheme[keyword]. Programmers -can compose basic syntax classes to build specifications of more -complex syntax, such as lists of distinct identifiers and formal -arguments with keywords. Macros that manipulate the same syntactic -structures can share syntax class definitions. - -@defform*/subs[#:literals (pattern) - [(define-syntax-class name-id stxclass-option ... - stxclass-variant ...+) - (define-syntax-class (name-id arg-id ...) stxclass-option ... - stxclass-variant ...+)] - ([stxclass-option - (code:line #:attributes (attr-arity-decl ...)) - (code:line #:description description-expr) - (code:line #:opaque) - (code:line #:literals (literal-entry ...)) - (code:line #:literal-sets (literal-set ...)) - (code:line #:conventions (convention-id ...)) - (code:line #:local-conventions (convention-rule ...))] - [attr-arity-decl - attr-name-id - (attr-name-id depth)] - [stxclass-variant - (pattern syntax-pattern pattern-directive ...)])]{ - -Defines @scheme[name-id] as a @deftech{syntax class}, which -encapsulates one or more @tech{single-term patterns}. - -When the @scheme[arg-id]s are present, they are bound as variables in -the body. The body of the syntax-class definition contains a non-empty -sequence of @scheme[pattern] variants. - -The following options are supported: - -@specsubform/subs[(code:line #:attributes (attr-arity-decl ...)) - ([attr-arity-decl attr-id - (attr-id depth)])]{ - -Declares the attributes of the syntax class. An attribute arity -declaration consists of the attribute name and optionally its ellipsis -depth (zero if not explicitly specified). - -If the attributes are not explicitly listed, they are inferred as the -set of all @tech{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 from -@tech{annotated pattern variables}. -} - -@specsubform[(code:line #:description description-expr)]{ - -The @scheme[description] argument is an expression (evaluated in a -scope containing the syntax class's parameters) that should evaluate -to a string. It is used in error messages involving the syntax -class. For example, if a term is rejected by the syntax class, an -error of the form @schemevalfont{"expected @scheme[description]"} may -be synthesized. - -If absent, the name of the syntax class is used instead. -} - -@specsubform[#:opaque]{ - -Indicates that errors should not be reported with respect to the -internal structure of the syntax class. -} - -@specsubform[(code:line #:literals (literal-entry))] -@specsubform[(code:line #:literal-sets (literal-set ...))] -@specsubform[(code:line #:conventions (convention-id ...))]{ - -Declares the literals and conventions that apply to the syntax class's -variant patterns and their immediate @scheme[#:with] clauses. Patterns -occuring within subexpressions of the syntax class (for example, on -the right-hand side of a @scheme[#:fail-when] clause) are not -affected. - -These options have the same meaning as in @scheme[syntax-parse]. -} - -Each variant of a syntax class is specified as a separate -@scheme[pattern]-form whose syntax pattern is a @tech{single-term -pattern}. -} - -@defform*[#:literals (pattern) - [(define-splicing-syntax-class name-id stxclass-option ... - stxclass-variant ...+) - (define-splicing-syntax-class (name-id arg-id ...) stxclass-option ... - stxclass-variant ...+)]]{ - -Defines @scheme[name-id] as a @deftech{splicing syntax class}, -analogous to a @tech{syntax class} but encapsulating @tech{head -patterns} rather than @tech{single-term patterns}. - -The options are the same as for @scheme[define-syntax-class]. - -Each variant of a splicing syntax class is specified as a separate -@scheme[pattern]-form whose syntax pattern is a @tech{head pattern}. -} - -@defform[#:literals (pattern) - (pattern syntax-pattern pattern-directive ...)]{ - -Used to indicate a variant of a syntax class or splicing syntax -class. The variant accepts syntax matching the given syntax pattern -with the accompanying @tech{pattern directives}. - -When used within @scheme[define-syntax-class], @scheme[syntax-pattern] -should be a @tech{single-term pattern}; within -@scheme[define-splicing-syntax-class], it should be a @tech{head -pattern}. - -The attributes of the variant are the attributes of the pattern -together with all attributes bound by @scheme[#:with] clauses, -including nested attributes produced by syntax classes associated with -the pattern variables. -} - -@;{--------} - -@subsection{Pattern directives} - -Both the parsing forms and syntax class definition forms support -@deftech{pattern directives} for annotating syntax patterns and -specifying side conditions. The grammar for pattern directives -follows: - -@schemegrammar[pattern-directive - (code:line #:declare pattern-id syntax-class-id) - (code:line #:declare pattern-id (syntax-class-id expr ...)) - (code:line #:with syntax-pattern expr) - (code:line #:attr attr-id expr) - (code:line #:fail-when condition-expr message-expr) - (code:line #:fail-unless condition-expr message-expr) - (code:line #:when condition-expr)] - -@specsubform[(code:line #:declare pvar-id syntax-class-id)] -@specsubform[(code:line #:declare pvar-id (syntax-class-id expr ...))]{ - -The first form is equivalent to using the -@svar[pvar-id:syntax-class-id] form in the pattern (but it is illegal -to use both for the same pattern variable). - -The second form allows the use of parameterized syntax classes, which -cannot be expressed using the ``colon'' notation. The @scheme[expr]s -are evaluated outside the scope of any of the attribute bindings from -pattern that the @scheme[#:declare] directive applies to. - -} - -@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 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)]{ - -Evaluates the @scheme[condition-expr] in the context of all previous -attribute bindings. If the value is any true value (not @scheme[#f]), -the matching process backtracks (with the given message); otherwise, -it continues. If the value of the condition expression is a syntax -object, it is indicated as the cause of the error. -} - -@specsubform[(code:line #:fail-unless condition-expr message-expr)]{ - -Like @scheme[#:fail-when] with the condition negated. -} - -@specsubform[(code:line #:when condition-expr)]{ - -Evaluates the @scheme[condition-expr] in the context of all previous -attribute bindings. If the value is @scheme[#f], the matching process -backtracks. In other words, @scheme[#:when] is like -@scheme[#:fail-unless] without the message argument. - -} - - -@;{----------} - -@subsection{Pattern variables and attributes} - -An @deftech{attribute} is a name bound by a syntax pattern. An -attribute can be a @tech{pattern variable} itself, or it can be a -@tech{nested attribute} bound by an @tech{annotated pattern -variable}. The name of a nested attribute is computed by concatenating -the pattern variable name with the syntax class's exported attribute's -name, separated by a dot (see the example below). - -Attribute names cannot be used directly as expressions; that is, -attributes are not variables. Instead, an attribute's value can be -gotten using the @scheme[attribute] special form. - -@defform[(attribute attr-id)]{ - -Returns the value associated with the attribute named -@scheme[attr-id]. If @scheme[attr-id] is not bound as an attribute, an -error is raised. -} - -The value of an attribute need not be syntax. Non-syntax-valued -attributes can be used to return a parsed representation of a subterm -or the results of an analysis on the subterm. A non-syntax-valued -attribute should be bound using the @scheme[#:attr] directive or a -@scheme[~bind] pattern. - -@myexamples[ -(define-syntax-class table - (pattern ((key value) ...) - #:attr hash - (for/hash ([k (syntax->datum #'(key ...))] - [v (syntax->datum #'(value ...))]) - (values k v)))) -(syntax-parse #'((a 1) (b 2) (c 3)) - [t:table - (attribute t.hash)]) -] - -A syntax-valued attribute is an attribute whose value is a syntax -object or a syntax list of the appropriate @tech{ellipsis -depth}. Syntax-valued attributes can be used within @scheme[syntax], -@scheme[quasisyntax], etc as part of a syntax template. If a -non-syntax-valued attribute is used in a syntax template, a runtime -error is signalled. - -@myexamples[ -(syntax-parse #'((a 1) (b 2) (c 3)) - [t:table - #'(t.key ...)]) -(syntax-parse #'((a 1) (b 2) (c 3)) - [t:table - #'t.hash]) -] - -Every attribute has an associated @deftech{ellipsis depth} that -determines how it can be used in a syntax template (see the discussion -of ellipses in @scheme[syntax]). For a pattern variable, the ellipsis -depth is the number of ellipses the pattern variable ``occurs under'' -in the pattern. For a nested attribute the depth is the sum of the -pattern variable's depth and the depth of the attribute in the syntax -class. Consider the following code: - -@schemeblock[ -(define-syntax-class quark - (pattern (a b ...))) -(syntax-parse some-term - [(x (y:quark ...) ... z:quark) - some-code]) -] - -The syntax class @scheme[quark] exports two attributes: @scheme[a] at -depth 0 and @scheme[b] at depth 1. The @scheme[syntax-parse] pattern -has three pattern variables: @scheme[x] at depth 0, @scheme[y] at -depth 2, and @scheme[z] at depth 0. Since @scheme[x] and @scheme[y] -are annotated with the @scheme[quark] syntax class, the pattern also -binds the following nested attributes: @scheme[y.a] at depth 2, -@scheme[y.b] at depth 3, @scheme[z.a] at depth 0, and @scheme[z.b] at -depth 1. - -An attribute's ellipsis nesting depth is @emph{not} a guarantee that -its value has that level of list nesting. In particular, @scheme[~or] -and @scheme[~optional] patterns may result in attributes with fewer -than expected levels of list nesting. - -@(myexamples - (syntax-parse #'(1 2 3) - [(~or (x:id ...) _) - (attribute x)])) - - -@;{--------} - -@subsection{Inspection tools} - -The following special forms are for debugging syntax classes. - -@defform[(syntax-class-attributes syntax-class-id)]{ - -Returns a list of the syntax class's attributes. Each attribute is -listed by its name and ellipsis depth. -} - -@defform[(syntax-class-parse syntax-class-id stx-expr arg-expr ...)]{ - -Runs the parser for the syntax class (parameterized by the -@scheme[arg-expr]s) on the syntax object produced by -@scheme[stx-expr]. On success, the result is a list of vectors -representing the attribute bindings of the syntax class. Each vector -contains the attribute name, depth, and associated value. On failure, -the result is some internal representation of the failure. -} - - -@;{----------} - -@include-section["parse-patterns.scrbl"] - - -@;{----------} - -@section{Literal sets and Conventions} - -Sometimes the same literals are recognized in a number of different -places. The most common example is the literals for fully expanded -programs, which are used in many analysis and transformation -tools. Specifying literals individually is burdensome and error-prone. -As a remedy, @schememodname[syntax/parse] offers @deftech{literal -sets}. A literal set is defined via @scheme[define-literal-set] and -used via the @scheme[#:literal-set] option of @scheme[syntax-parse]. - -@defform/subs[(define-literal-set name-id (literal ...)) - ([literal literal-id - (pattern-id literal-id)])]{ - -Defines @scheme[name] as a @tech{literal set}. Each @scheme[literal] -can have a separate @scheme[pattern-id] and @scheme[literal-id]. The -@scheme[pattern-id] determines what identifiers in the pattern are -treated as literals. The @scheme[literal-id] determines what -identifiers the literal matches. - -@myexamples[ -(define-literal-set def-litset - (define-values define-syntaxes)) -(syntax-parse #'(define-syntaxes (x) 12) - #:literal-sets (def-litset) - [(define-values (x:id ...) e:expr) 'v] - [(define-syntaxes (x:id ...) e:expr) 's]) -] - -The literals in a literal set always refer to the phase-0 bindings of -the enclosing module. For example: - -@myexamples[ -(module common racket/base - (define x 'something) - (provide x)) - -(module lits racket/base - (require syntax/parse 'common) - (define-literal-set common-lits (x)) - (provide common-lits)) -] - -In the literal set @scheme[common-lits], the literal @scheme[x] always -recognizes identifiers bound to the variable @scheme[x] defined in -module @schememodname['common]. - -When a literal set is used with the @scheme[#:phase phase-expr] -option, the literals' fixed bindings are compared against the binding of -the input literal at the specified phase. Continuing the example: - -@myexamples[ -(require syntax/parse 'lits (for-syntax 'common)) -(syntax-parse #'x #:literal-sets ([common-lits #:phase 1]) - [x 'yes] - [_ 'no]) -] - -The occurrence of @scheme[x] in the pattern matches any identifier -whose binding at phase 1 is the @scheme[x] from module -@schememodname['common]. -} - -@defform/subs[(define-conventions name-id convention-rule ...) - ([convention-rule (name-pattern syntax-class)] - [name-pattern exact-id - name-rx] - [syntax-class syntax-class-id - (syntax-class-id expr ...)])]{ - -Defines @deftech{conventions} that supply default syntax classes for -pattern variables. A pattern variable that has no explicit syntax -class is checked against each @scheme[id-pattern], and the first one -that matches determines the syntax class for the pattern. If no -@scheme[id-pattern] matches, then the pattern variable has no syntax -class. - -@myexamples[ -(define-conventions xyz-as-ids - [x id] [y id] [z id]) -(syntax-parse #'(a b c 1 2 3) - #:conventions (xyz-as-ids) - [(x ... n ...) (syntax->datum #'(x ...))]) -(define-conventions xn-prefixes - [#rx"^x" id] - [#rx"^n" nat]) -(syntax-parse #'(a b c 1 2 3) - #:conventions (xn-prefixes) - [(x0 x ... n0 n ...) - (syntax->datum #'(x0 (x ...) n0 (n ...)))]) -] - -Local conventions, introduced with the @scheme[#:local-conventions] -keyword argument of @scheme[syntax-parse] and syntax class -definitions, may refer to local bindings: - -@myexamples[ -(define-syntax-class (nat> bound) - (pattern n:nat - #:fail-unless (> (syntax-e #'n) bound) - (format "expected number > ~s" bound))) - -(define-syntax-class (natlist> bound) - #:local-conventions ([N (nat> bound)]) - (pattern (N ...))) - -(define (parse-natlist> bound x) - (syntax-parse x - #:local-conventions ([NS (natlist> bound)]) - [NS 'ok])) -(parse-natlist> 0 #'(1 2 3)) -(parse-natlist> 5 #'(8 6 4 2)) -] - -} - -@;{----------} - -@section[#:tag "lib"]{Library syntax classes and literal sets} - -@subsection{Syntax classes} - -@(begin - (define-syntax-rule (defstxclass name . pre-flows) - (defidform name . pre-flows)) - (define-syntax-rule (defstxclass* (name arg ...) . pre-flows) - (defform (name arg ...) . pre-flows))) - -@defstxclass[expr]{ - -Matches anything except a keyword literal (to distinguish expressions -from the start of a keyword argument sequence). The term is not -otherwise inspected, and no guarantee is made that the term is -actually a valid expression. - -} - -@deftogether[( -@defstxclass[identifier] -@defstxclass[boolean] -@defstxclass[str] -@defstxclass[char] -@defstxclass[keyword] -@defstxclass[number] -@defstxclass[integer] -@defstxclass[exact-integer] -@defstxclass[exact-nonnegative-integer] -@defstxclass[exact-positive-integer])]{ - -Match syntax satisfying the corresponding predicates. - -} - -@defstxclass[id]{ Alias for @scheme[identifier]. } -@defstxclass[nat]{ Alias for @scheme[exact-nonnegative-integer]. } - -@defform[(static predicate description)]{ - -Matches an identifier that is bound in the syntactic environment to -static information (see @scheme[syntax-local-value]) satisfying the -given @scheme[predicate]. If the term does not match, the -@scheme[description] argument is used to describe the expected syntax. - -When used outside of the dynamic extent of a macro transformer (see -@scheme[syntax-transforming?]), matching fails. - -The attribute @var[value] contains the value the name is bound to. -} - -@defform[(atom-in-list atoms description)]{ - -Matches a syntax object whose inner datum is @scheme[eqv?] to some -atom in the given list. - -Use @scheme[atom-in-list] instead of a literals list when recognizing -identifier based on their symbolic names rather than their bindings. - -} - - -@subsection{Literal sets} - -@defidform[kernel-literals]{ - -Literal set containing the identifiers for fully-expanded code -(@secref[#:doc '(lib "scribblings/reference/reference.scrbl") -"fully-expanded"]). The set contains all of the forms listed by -@scheme[kernel-form-identifier-list], plus @scheme[module], -@scheme[#%plain-module-begin], @scheme[#%require], and -@scheme[#%provide]. - -Note that the literal-set uses the names @scheme[#%plain-lambda] and -@scheme[#%plain-app], not @scheme[lambda] and @scheme[#%app]. -} +@include-section["parse/debug.scrbl"] +@include-section["parse/experimental.scrbl"] diff --git a/collects/syntax/scribblings/parse/debug.scrbl b/collects/syntax/scribblings/parse/debug.scrbl new file mode 100644 index 0000000000..ecaa44f8f6 --- /dev/null +++ b/collects/syntax/scribblings/parse/debug.scrbl @@ -0,0 +1,56 @@ +#lang scribble/doc +@(require scribble/manual + scribble/struct + scribble/decode + scribble/eval + "parse-common.rkt") + +@title{Debugging and inspection tools} + +@defmodule[syntax/parse/debug] + +The following special forms are for debugging syntax classes. + +@defform[(syntax-class-attributes syntax-class-id)]{ + +Returns a list of the syntax class's attributes. Each attribute entry +consists of the attribute's name and ellipsis depth. +} + +@deftogether[[ +@defform[(syntax-class-arity syntax-class-id)] +@defform[(syntax-class-keywords syntax-class-id)]]]{ + +Returns the syntax class's arity and keywords, respectively. Compare +with @scheme[procedure-arity] and @scheme[procedure-keywords]. +} + +@defform[(syntax-class-parse syntax-class-id stx-expr arg ...) + #:contracts ([stx-expr syntax?])]{ + +Runs the parser for the syntax class (parameterized by the +@scheme[arg-expr]s) on the syntax object produced by +@scheme[stx-expr]. On success, the result is a list of vectors +representing the attribute bindings of the syntax class. Each vector +contains the attribute name, depth, and associated value. On failure, +the result is some internal representation of the failure. +} + +@defform[(debug-parse stx-expr S-pattern ...+) + #:contracts ([stx-expr syntax?])]{ + +Tries to match @scheme[stx-expr] against the @scheme[S-pattern]s. If +matching succeeds, the the symbol @scheme['success] is +returned. Otherwise, an S-expression describing the failure is returned. + +The failure S-expression shows both the raw set of failures (unsorted) +and the failures with maximal progress. The maximal failures are +divided into equivalence classes based on their progress (progress is +a partial order); that is, failures within an equivalence class have +the same progress and, in principle, pinpoint the same term as the +problematic term. Multiple equivalence classes only arise from +@scheme[~parse] patterns (or equivalently, @scheme[#:with] clauses) +that match computed terms or @scheme[~fail] (@scheme[#:fail-when], +etc) clauses that allow a computed term to be pinpointed. + +} diff --git a/collects/syntax/scribblings/parse/ex-exprc.scrbl b/collects/syntax/scribblings/parse/ex-exprc.scrbl new file mode 100644 index 0000000000..89167d8ef3 --- /dev/null +++ b/collects/syntax/scribblings/parse/ex-exprc.scrbl @@ -0,0 +1,42 @@ +#lang scribble/doc +@(require scribble/manual + scribble/struct + scribble/decode + scribble/eval + "parse-common.rkt" + (for-label racket/class)) + +@title[#:tag "exprc"]{Experimental: Contracts on macro sub-expressions} + +@emph{This section involves facilities that are experimental and +subject to change.} + +Just as procedures often expect certain kinds of values as arguments, +macros often have expectations about the expressions they are +given. And just as procedures express those expectations via +contracts, so can macros, using the @scheme[expr/c] syntax class. + +For example, here is a macro @scheme[myparameterize] that behaves like +@scheme[parameterize] but enforces the @scheme[parameter?] contract on +the parameter expressions. + +@myinteraction[ +(define-syntax (myparameterize stx) + (syntax-parse stx + [(_ ((p v:expr) ...) body:expr) + #:declare p (expr/c #'parameter? + #:name "parameter argument") + #'(parameterize ((p.c v) ...) body)])) +(myparameterize ((current-input-port + (open-input-string "(1 2 3)"))) + (read)) +(myparameterize (('whoops 'something)) + 'whatever) +] + +@bold{Important:} Make sure when using @scheme[expr/c] to use the +@scheme[c] attribute. If the macro above had used @scheme[p] in the +template, the expansion would have used the raw, unchecked +expressions. The @scheme[expr/c] syntax class does not change how +pattern variables are bound; it only computes an attribute that +represents the checked expression. diff --git a/collects/syntax/scribblings/parse/ex-kw-args.scrbl b/collects/syntax/scribblings/parse/ex-kw-args.scrbl new file mode 100644 index 0000000000..1511047f67 --- /dev/null +++ b/collects/syntax/scribblings/parse/ex-kw-args.scrbl @@ -0,0 +1,86 @@ +#lang scribble/doc +@(require scribble/manual + scribble/struct + scribble/decode + scribble/eval + "parse-common.rkt" + (for-label racket/class)) + +@title{Optional keyword arguments} + +This section explains how to write a macro that accepts (simple) +optional keyword arguments. We use the example @scheme[mycond], which +is like Racket's @scheme[cond] except that it takes an optional +keyword argument that controls what happens if none of the clauses +match. + +Optional keyword arguments are supported via @tech{head +patterns}. Unlike normal patterns, which match one term, head patterns +can match a variable number of subterms in a list. Some important +head-pattern forms are @scheme[~seq], @scheme[~or], and +@scheme[~optional]. + +Here's one way to do it: + +@myinteraction[ +(define-syntax (mycond stx) + (syntax-parse stx + [(mycond (~or (~seq #:error-on-fallthrough who:expr) (~seq)) + clause ...) + (with-syntax ([error? (if (attribute who) #'#t #'#f)] + [who (or (attribute who) #'#f)]) + #'(mycond* error? who clause ...))])) + +(define-syntax mycond* + (syntax-rules () + [(mycond error? who [question answer] . clauses) + (if question answer (mycond* error? who . clauses))] + [(mycond #t who) + (error who "no clauses matched")] + [(mycond #f _) + (void)])) +] + +We cannot write @scheme[#'who] in the macro's right-hand side, because +the @scheme[who] attribute does not receive a value if the keyword +argument is omitted. Instead we must write @scheme[(attribute who)], +which produces @scheme[#f] if matching did not assign a value to the +attribute. + +@myinteraction[ +(mycond [(even? 13) 'blue] + [(odd? 4) 'red]) +(mycond #:error-on-fallthrough 'myfun + [(even? 13) 'blue] + [(odd? 4) 'red]) +] + +There's a simpler way of writing the @scheme[~or] pattern above: +@schemeblock[ +(~optional (~seq #:error-on-fallthrough who:expr)) +] + +Yet another way is to introduce a @tech{splicing syntax class}, which +is like an ordinary syntax class but for head patterns. +@myinteraction[ +(define-syntax (mycond stx) + + (define-splicing-syntax-class maybe-fallthrough-option + (pattern (~seq #:error-on-fallthough who:expr) + #:with error? #'#t) + (pattern (~seq) + #:with error? #'#f + #:with who #'#f)) + + (syntax-parse stx + [(mycond fo:maybe-fallthrough-option clause ...) + #'(mycond* fo.error? fo.who clause ...)])) +] + +Defining a splicing syntax class also makes it easy to eliminate the +case analysis we did before using @scheme[attribute] by defining +@scheme[error?] and @scheme[who] as attributes within both of the +syntax class's variants. (This is possible to do in the inline pattern +version too, using @scheme[~and] and @scheme[~parse], just less +convenient.) Splicing syntax classes also closely parallel the style +of grammars in macro documentation. diff --git a/collects/syntax/scribblings/parse/ex-many-kws.scrbl b/collects/syntax/scribblings/parse/ex-many-kws.scrbl new file mode 100644 index 0000000000..e6cd248c5d --- /dev/null +++ b/collects/syntax/scribblings/parse/ex-many-kws.scrbl @@ -0,0 +1,137 @@ +#lang scribble/doc +@(require scribble/manual + scribble/struct + scribble/decode + scribble/eval + "parse-common.rkt" + (for-label racket/class)) + +@title{More keyword arguments} + +This section shows how to express the syntax of @scheme[struct]'s +optional keyword arguments using @scheme[syntax-parse] patterns. + +The part of @scheme[struct]'s syntax that is difficult to specify is +the sequence of struct options. Let's get the easy part out of the way +first. + +@myinteraction[ +(define-splicing-syntax-class maybe-super + (pattern (~seq super:id)) + (pattern (~seq))) + +(define-syntax-class field-option + (pattern #:mutable) + (pattern #:auto)) + +(define-syntax-class field + (pattern field:id + #:with (option ...) '()) + (pattern [field:id option:field-option ...])) +] + +Given those auxiliary syntax classes, here is a first approximation of +the main pattern, including the struct options: +@schemeblock[ +(struct name:id super:maybe-super (field:field ...) + (~or (~seq #:mutable) + (~seq #:super super-expr:expr) + (~seq #:inspector inspector:expr) + (~seq #:auto-value auto:expr) + (~seq #:guard guard:expr) + (~seq #:property prop:expr prop-val:expr) + (~seq #:transparent) + (~seq #:prefab) + (~seq #:constructor-name constructor-name:id) + (~seq #:extra-constructor-name extra-constructor-name:id) + (~seq #:omit-define-syntaxes) + (~seq #:omit-define-values)) + ...) +] +The fact that @scheme[expr] does not match keywords helps in the case +where the programmer omits a keyword's argument; instead of accepting +the next keyword as the argument expression, @scheme[syntax-parse] +reports that an expression was expected. + +There are two main problems with the pattern above: +@itemize[ +@item{There's no way to tell whether a zero-argument keyword like +@scheme[#:mutable] was seen.} +@item{Some options, like @scheme[#:mutable], should appear at most +once.} +] + +The first problem can be remedied using @scheme[~and] patterns to bind +a pattern variable to the keyword itself, as in this sub-pattern: +@schemeblock[ +(~seq (~and #:mutable mutable-kw)) +] +The second problem can be solved using @emph{repetition constraints}: +@schemeblock[ +(struct name:id super:maybe-super (field:field ...) + (~or (~optional (~seq (~and #:mutable) mutable-kw)) + (~optional (~seq #:super super-expr:expr)) + (~optional (~seq #:inspector inspector:expr)) + (~optional (~seq #:auto-value auto:expr)) + (~optional (~seq #:guard guard:expr)) + (~seq #:property prop:expr prop-val:expr) + (~optional (~seq (~and #:transparent transparent-kw))) + (~optional (~seq (~and #:prefab prefab-kw))) + (~optional (~seq #:constructor-name constructor-name:id)) + (~optional + (~seq #:extra-constructor-name extra-constructor-name:id)) + (~optional + (~seq (~and #:omit-define-syntaxes omit-def-stxs-kw))) + (~optional (~seq (~and #:omit-define-values omit-def-vals-kw)))) + ...) +] +The @scheme[~optional] repetition constraint indicates that an +alternative can appear at most once. (There is a @scheme[~once] form +that means it must appear exactly once.) In @scheme[struct]'s keyword +options, only @scheme[#:property] may occur any number of times. + +There are still some problems, though. Without additional help, +@scheme[~optional] does not report particularly good errors. We must +give it the language to use, just as we had to give descriptions to +sub-patterns via syntax classes. Also, some related options are +mutually exclusive, such as @scheme[#:inspector], +@scheme[#:transparent], and @scheme[#:prefab]. + +@schemeblock[ +(struct name:id super:maybe-super (field:field ...) + (~or (~optional + (~or (~seq #:inspector inspector:expr) + (~seq (~and #:transparent transparent-kw)) + (~seq (~and #:prefab prefab-kw))) + #:name "#:inspector, #:transparent, or #:prefab option") + (~optional (~seq (~and #:mutable) mutable-kw) + #:name "#:mutable option") + (~optional (~seq #:super super-expr:expr) + #:name "#:super option") + (~optional (~seq #:auto-value auto:expr) + #:name "#:auto-value option") + (~optional (~seq #:guard guard:expr) + #:name "#:guard option") + (~seq #:property prop:expr prop-val:expr) + (~optional (~seq #:constructor-name constructor-name:id) + #:name "#:constructor-name option") + (~optional + (~seq #:extra-constructor-name extra-constructor-name:id) + #:name "#:extra-constructor-name option") + (~optional (~seq (~and #:omit-define-syntaxes omit-def-stxs-kw)) + #:name "#:omit-define-syntaxes option") + (~optional (~seq (~and #:omit-define-values omit-def-vals-kw)) + #:name "#:omit-define-values option")) + ...) +] +Here we have grouped the three incompatible options together under a +single @scheme[~optional] constraint. That means that at most one of +any of those options is allowed. We have given names to the optional +clauses. See @scheme[~optional] for other customization options. + +Note that there are other constraints that we have not represented in +the pattern. For example, @scheme[#:prefab] is also incompatible with +both @scheme[#:guard] and @scheme[#:property]. Repetition constraints +cannot express arbitrary incompatibility relations. The best way to +handle such contraints is with a side condition using +@scheme[#:fail-when]. diff --git a/collects/syntax/scribblings/parse/ex-mods-stxclasses.scrbl b/collects/syntax/scribblings/parse/ex-mods-stxclasses.scrbl new file mode 100644 index 0000000000..c5ff0639e8 --- /dev/null +++ b/collects/syntax/scribblings/parse/ex-mods-stxclasses.scrbl @@ -0,0 +1,107 @@ +#lang scribble/doc +@(require scribble/manual + scribble/struct + scribble/decode + scribble/eval + "parse-common.rkt" + (for-label racket/class)) + +@title{Modules and reusable syntax classes} + +As demonstrated in the @secref{stxparse-intro}, the simplest place to +define a syntax class is within the macro definition that uses it. But +this location, of course, limits the scope of the syntax class to the +one client macro. Creating reusable syntax classes is slightly +complicated, however, by the Racket @tech[#:doc '(lib +"scribblings/reference/reference.scrbl")]{phase level} separation. A +syntax class defined within a module cannot be used by macros in the +same module; it is defined at the wrong phase. + +@myinteraction[ +(module phase-mismatch-mod racket + (require syntax/parse (for-syntax syntax/parse)) + (define-syntax-class foo + (pattern (a b c))) + (define-syntax (macro stx) + (syntax-parse stx + [(_ f:foo) #'(+ f.a f.b f.c)]))) +] + +In the module above, the syntax class @scheme[foo] is defined at phase +level 0. The reference to @scheme[foo] within @scheme[macro], however, +is at phase level 1, being the implementation of a macro +transformer. (Needing to require @schememodname[syntax/parse] twice, +once normally and once @scheme[for-syntax] is another sign of the +phase level incompatibility.) The only way to define reusable syntax +classes that can be used within macros is to define them in a separate +module and require that module @scheme[for-syntax]. + +@myinteraction[ +(module stxclass-mod racket + (require syntax/parse) + (define-syntax-class foo + (pattern (a b c))) + (provide foo)) +(module macro-mod racket + (require (for-syntax syntax/parse + 'stxclass-mod)) + (define-syntax (macro stx) + (syntax-parse stx + [(_ f:foo) #'(+ f.a f.b f.c)])) + (provide macro)) +(require 'macro-mod) +(macro (1 2 3)) +] + +If the syntax classes refer to keywords, or if they compute +expressions via syntax templates, then the module containing the +syntax classes must generally require the keywords or bindings used in +the syntax templates @scheme[for-template]. + +@myinteraction[ +(module arith-keywords-mod racket + (define-syntax plus (syntax-rules ())) + (define-syntax times (syntax-rules ())) + (provide plus times)) + +(module arith-stxclass-mod racket + (require syntax/parse + (for-template 'arith-keywords-mod + racket)) + (define-syntax-class arith + #:literals (plus times) + (pattern n:nat + #:with expr #'n) + (pattern (plus a:arith b:arith) + #:with expr #'(+ a.expr b.expr)) + (pattern (times a:arith b:arith) + #:with expr #'(* a.expr b.expr))) + (provide arith)) + +(module arith-macro-mod racket + (require (for-syntax syntax/parse + 'arith-stxclass-mod) + 'arith-keywords-mod) + (define-syntax (arith-macro stx) + (syntax-parse stx + [(_ a:arith) + #'(values 'a.expr a.expr)])) + (provide arith-macro + (all-from-out 'arith-keywords-mod))) + +(require 'arith-macro-mod) +(arith-macro (plus 1 (times 2 3))) +] + +In @scheme['arith-stxclass-mod], the module +@scheme['arith-keywords-mod] must be required @scheme[for-template] +because the keywords are used in phase-0 expressions. Likewise, the +module @schememodname[racket] must be required @scheme[for-template] +because the syntax class contains syntax templates involving +@scheme[+] and @scheme[*] (and, in fact, the implicit @scheme[#%app] +syntax). All of these identifiers (the keywords @scheme[plus] and +@scheme[times]; the procedures @scheme[+] and @scheme[*]; and the +implicit syntax @scheme[#%app]) must be bound at ``absolute'' phase +level 0. Since the module @scheme['arith-stxclass-mod] is required +with a phase level offset of 1 (that is, @scheme[for-syntax]), it must +compensate with a phase level offset of -1, or @scheme[for-template]. diff --git a/collects/syntax/scribblings/parse/ex-uniform.scrbl b/collects/syntax/scribblings/parse/ex-uniform.scrbl new file mode 100644 index 0000000000..65425b9d17 --- /dev/null +++ b/collects/syntax/scribblings/parse/ex-uniform.scrbl @@ -0,0 +1,143 @@ +#lang scribble/doc +@(require scribble/manual + scribble/struct + scribble/decode + scribble/eval + "parse-common.rkt" + (for-label racket/class)) + +@title[#:tag "uniform-meanings"]{Variants with uniform meanings} + +Syntax classes not only validate syntax, they also extract some +measure of meaning from it. From the perspective of meaning, there are +essentially two kinds of syntax class. In the first, all of the syntax +class's variants have the same kind of meaning. In the second, +variants may have different kinds of meaning.@margin-note*{In other +words, some syntax classes' meanings are products and others' meanings +are sums.} This section discusses the first kind, syntax classes with +uniform meanings. The next section discusses @secref{varied-meanings}. + +If all of a syntax class's variants express the same kind of +information, that information can be cleanly represented via +attributes, and it can be concisely processed using ellipses. + +One example of a syntax class with uniform meaning: the +@scheme[init-decl] syntax of the @scheme[class] macro. Here is the +specification of @scheme[init-decl]: + +@schemegrammar*[[init-decl + id + (maybe-renamed) + (maybe-renamed default-expr)] + [maybe-renamed + id + (internal-id external-id)]] + +The @scheme[init-decl] syntax class has three variants, plus an +auxiliary syntax class that has two variants of its own. But all forms +of @scheme[init-decl] ultimately carry just three pieces of +information: an internal name, an external name, and a default +configuration of some sort. The simpler syntactic variants are just +abbreviations for the full information. + +The three pieces of information determine the syntax class's +attributes. It is useful to declare the attributes explicitly using +the @scheme[#:attributes] keyword; the declaration acts both as +in-code documentation and as a check on the variants. + +@schemeblock[ +(define-syntax-class init-decl + #:attributes (internal external default) + ___) +] + +Next we fill in the syntactic variants, deferring the computation of +the attributes: + +@schemeblock[ +(define-syntax-class init-decl + #:attributes (internal external default) + (pattern ???:id + ___) + (pattern (???:maybe-renamed) + ___) + (pattern (???:maybe-renamed ???:expr) + ___)) +] + +We perform a similar analysis of @scheme[maybe-renamed]: +@schemeblock[ +(define-syntax-class maybe-renamed + #:attributes (internal external) + (pattern ???:id + ___) + (pattern (???:id ???:id) + ___)) +] + +Here's one straightforward way of matching syntactic structure with +attributes for @scheme[maybe-renamed]: + +@schemeblock[ +(define-syntax-class maybe-renamed + #:attributes (internal external) + (pattern internal:id + #:with external #'internal) + (pattern (internal:id external:id))) +] + +Given that definition of @scheme[maybe-renamed], we can fill in most +of the definition of @scheme[init-decl]: + +@schemeblock[ +(define-syntax-class init-decl + #:attributes (internal external default) + (pattern internal:id + #:with external #:internal + #:with default ???) + (pattern (mr:maybe-renamed) + #:with internal #'mr.internal + #:with external #'mr.external + #:with default ???) + (pattern (mr:maybe-renamed default0:expr) + #:with internal #'mr.internal + #:with external #'mr.external + #:with default ???)) +] + +At this point we realize we have not decided on a representation for +the default configuration. In fact, it is an example of +@seclink["varied-meanings"]{syntax with varied meanings} (aka sum or +disjoint union). The following section discusses representation +options in greater detail; for the sake of completeness, we present +one of them here. + +There are two kinds of default configuration. One indicates that the +initialization argument is optional, with a default value computed +from the given expression. The other indicates that the initialization +argument is mandatory. We represent the variants as a (syntax) list +containing the default expression and as the empty (syntax) list, +respectively. More precisely: + +@schemeblock[ +(define-syntax-class init-decl + #:attributes (internal external default) + (pattern internal:id + #:with external #:internal + #:with default #'()) + (pattern (mr:maybe-renamed) + #:with internal #'mr.internal + #:with external #'mr.external + #:with default #'()) + (pattern (mr:maybe-renamed default0:expr) + #:with internal #'mr.internal + #:with external #'mr.external + #:with default #'(default0))) +] + +Another way to look at this aspect of syntax class design is as the +algebraic factoring of sums-of-products (concrete syntax variants) +into products-of-sums (attributes and abstract syntax variants). The +advantages of the latter form are the ``dot'' notation for data +extraction, avoiding or reducing additional case analysis, and the +ability to concisely manipulate sequences using ellipses. diff --git a/collects/syntax/scribblings/parse/ex-varied.scrbl b/collects/syntax/scribblings/parse/ex-varied.scrbl new file mode 100644 index 0000000000..660d4f76d3 --- /dev/null +++ b/collects/syntax/scribblings/parse/ex-varied.scrbl @@ -0,0 +1,107 @@ +#lang scribble/doc +@(require scribble/manual + scribble/struct + scribble/decode + scribble/eval + "parse-common.rkt" + (for-label racket/class)) + +@title[#:tag "varied-meanings"]{Variants with varied meanings} + +As explained in the @seclink["uniform-meanings"]{previous section}, +the meaning of a syntax class can be uniform, or it can be varied; +that is, different instances of the syntax class can carry different +kinds of information. This section discusses the latter kind of syntax +class. + +A good example of a syntax class with varied meanings is the +@scheme[for-clause] of the @scheme[for] family of special forms. + +@schemegrammar[for-clause + [id seq-expr] + [(id ...) seq-expr] + (code:line #:when guard-expr)] + +The first two variants carry the same kind of information; both +consist of identifiers to bind and a sequence expression. The third +variant, however, means something totally different: a condition that +determines whether to continue the current iteration of the loop, plus +a change in scoping for subsequent @scheme[seq-expr]s. The information +of a @scheme[for-clause] must be represented in a way that a client +macro can do further case analysis to distinguish the ``bind variables +from a sequence'' case from the ``skip or continue this iteration and +enter a new scope'' case. + +This section discusses two ways of representing varied kinds of +information. + +@section{Syntactic normalization} + +One approach is based on the observation that the syntactic variants +already constitute a representation of the information they carry. So +why not adapt that representation, removing redundancies and +eliminating simplifying the syntax to make subsequent re-parsing +trivial. + +@schemeblock[ +(define-splicing-syntax-class for-clause + #:attribute (norm) + (pattern [var:id seq:expr] + #:with norm #'[(var) seq]) + (pattern [(var:id ...) seq:expr] + #:with norm #'[(var ...) seq]) + (pattern (~seq #:when guard:expr) + #:with norm #'[#:when guard])) +] + +First, note that since the @scheme[#:when] variant consists of two +separate terms, we define @scheme[for-clause] as a splicing syntax +class. Second, that kind of irregularity is just the sort of thing +we'd like to remove so we don't have to deal with it again later. Thus +we represent the normalized syntax as a single term beginning with +either a sequence of identifiers (the first two cases) or the keyword +@scheme[#:when] (the third case). The two normalized cases are easy to +process and easy to tell apart. We have also taken the opportunity to +desugar the first case into the second. + +A normalized syntactic representation is most useful when the +subsequent case analysis is performed by @scheme[syntax-parse] or a +similar form. + +@section{Non-syntax-valued attributes} + +When the information carried by the syntax is destined for complicated +processing by Racket code, it is often better to parse it into an +intermediate representation using idiomatic Racket data structures, +such as lists, hashes, structs, and even objects. + +Thus far we have only used syntax pattern variables and the +@scheme[#:with] keyword to bind attribues, and the values of the +attributes have always been syntax. To bind attributes to values other +than syntax, use the @scheme[#:attr] keyword. + +@schemeblock[ +(code:comment "A ForClause is either") +(code:comment " - (bind-clause (listof identifier) syntax)") +(code:comment " - (when-clause syntax)") +(struct bind-clause (vars seq-expr)) +(struct when-clause (guard)) + +(define-splicing-syntax-class for-clause + #:attributes (ast) + (pattern [var:id seq:expr] + #:attr ast (bind-clause (list #'var) #'seq)) + (pattern [(var:id ...) seq:expr] + #:attr ast (bind-clause (syntax->list #'(var ...)) + #'seq)) + (pattern (~seq #:when guard:expr) + #:attr ast (when-clause #'guard))) +] + +Be careful! If we had used @scheme[#:with] instead of @scheme[#:attr], +the @scheme[#f] would have been coerced to a syntax object before +being matched against the pattern @scheme[default]. + +Attributes with non-syntax values cannot be used in syntax +templates. Use the @scheme[attribute] form to get the value of an +attribute. diff --git a/collects/syntax/scribblings/parse/examples.scrbl b/collects/syntax/scribblings/parse/examples.scrbl new file mode 100644 index 0000000000..47918526ea --- /dev/null +++ b/collects/syntax/scribblings/parse/examples.scrbl @@ -0,0 +1,27 @@ +#lang scribble/doc +@(require scribble/manual + scribble/struct + scribble/decode + scribble/eval + "parse-common.rkt" + (for-label racket/class)) + +@title[#:tag "stxparse-examples" #:style '(toc)]{Examples} + +This section provides an extended introduction to +@schememodname[syntax/parse] as a series of worked examples. + +@local-table-of-contents[] + +@include-section["ex-mods-stxclasses.scrbl"] +@include-section["ex-kw-args.scrbl"] +@include-section["ex-uniform.scrbl"] +@include-section["ex-varied.scrbl"] +@include-section["ex-many-kws.scrbl"] @;{needs revision} +@include-section["ex-exprc.scrbl"] + +@;{ +@section{Communication via static bindings} +@section{Control: cut and commit} +@section{Analyzing expanded code} +} diff --git a/collects/syntax/scribblings/parse/experimental.scrbl b/collects/syntax/scribblings/parse/experimental.scrbl new file mode 100644 index 0000000000..46257e05a3 --- /dev/null +++ b/collects/syntax/scribblings/parse/experimental.scrbl @@ -0,0 +1,258 @@ +#lang scribble/doc +@(require scribble/manual + scribble/struct + scribble/decode + scribble/eval + "parse-common.rkt") + +@title{Experimental} + +The following facilities are experimental. + +@section{Contracts for macro sub-expressions} + +@defmodule[syntax/parse/experimental/contract] + +Macros can apply contracts to their sub-expressions using the +@defidentifier[#'expr/c #:form? #t] syntax class. + +@defproc[(expr/c [contract-expr syntax?] + [#:positive pos-blame 'use-site] + [#:negative neg-blame 'from-macro] + [#:name expr-name #f] + [#:macro macro-name #f] + [#:context ctx #f]) + (attributes c)]{ + +Accepts an expression (@scheme[expr]) and computes an attribute +@scheme[c] that represents the expression wrapped with the contract +represented by @scheme[contract-expr]. + +See @secref{exprc} for an example. +} + +@section{Contracts for syntax classes} + +@defmodule[syntax/parse/experimental/provide] + +@defform/subs[#:literals (syntax-class/c) + (provide-syntax-class/contract + [syntax-class-id syntax-class-contract] ...) + ([syntax-class-contract + (syntax-class/c (mandatory-arg ...)) + (syntax-class/c (mandatory-arg ...) + (optional-arg ...))] + [arg contract-expr (code:line keyword contract-expr)]) + #:contracts ([contract-expr contract?])]{ + +Provides the syntax class (or splicing syntax class) +@scheme[syntax-class-id] with the given contracts imposed on its +formal parameters. +} + +@defidform[syntax-class/c]{ + +Keyword recognized by @scheme[provide-syntax-class/contract]. +} + +@section{Reflection} + +@defmodule[syntax/parse/experimental/reflect] + +A syntax class can be reified into a run-time value, and a reified +syntax class can be used in a pattern via the @scheme[~reflect] and +@scheme[~splicing-reflect] pattern forms. + +@defform[(reify-syntax-class syntax-class-id)]{ + +Reifies the syntax class named @scheme[syntax-class-id] as a run-time +value. The same form also handles splicing syntax classes. Syntax +classes with the @scheme[#:no-delimit-cut] option cannot be reified. +} + +@deftogether[( +@defproc[(reified-syntax-class? [x any/c]) boolean?] +@defproc[(reified-splicing-syntax-class? [x any/c]) boolean?])]{ + +Returns @scheme[#t] if @scheme[x] is a reified (normal) syntax class +or a reified splicing syntax class, respectively. +} + +@defproc[(reified-syntax-class-attributes + [r (or/c reified-syntax-class? reified-splicing-syntax-class?)]) + (listof (list/c symbol? exact-nonnegative-integer?))]{ + +Returns the reified syntax class's attributes. +} + +@deftogether[[ +@defproc[(reified-syntax-class-arity + [r (or/c reified-syntax-class? reified-splicing-syntax-class?)]) + procedure-arity?] +@defproc[(reified-syntax-class-keywords + [r (or/c reified-syntax-class? reified-splicing-syntax-class?)]) + (values (listof keyword?) (listof keyword?))]]]{ + +Returns the reified syntax class's arity and keywords, +respectively. Compare with @scheme[procedure-arity] and +@scheme[procedure-keywords]. +} + +@defproc[(reified-syntax-class-curry + [r (or/c reified-syntax-class? reified-splicing-syntax-class?)] + [arg any/c] ... + [#: kw-arg any/c] ...) + (or/c reified-syntax-class? reified-splicing-syntax-class?)]{ + +Partially applies the reified syntax class to the given arguments. If +more arguments are given than the reified syntax class accepts, an +error is raised. +} + +@schemegrammar*[#:literals (~reflect ~splicing-reflect) + [S-pattern .... + (~reflect var-id (reified-expr arg-expr ...) maybe-attrs)] + [H-pattern .... + (~splicing-reflect var-id (reified-expr arg-expr ...) + maybe-attrs)]] + +@specsubform/subs[(@#,(defhere ~reflect) var-id (reified-expr arg-expr ...) maybe-attrs) + ([maybe-attrs (code:line) + (code:line #:attributes (attr-arity-decl ...))])]{ + +Like @scheme[~var], except that the syntax class position is an +expression evaluating to a reified syntax object, not a syntax class +name, and the attributes bound by the reified syntax class (if any) +must be specified explicitly. +} + +@specsubform[(@#,(defhere ~splicing-reflect) var-id (reified-expr arg-expr ...) maybe-attrs)]{ + +Like @scheme[~reflect] but for reified splicing syntax classes. +} + +@myexamples[ +(define-syntax-class (nat> x) + #:description (format "natural number greater than ~s" x) + #:attributes (diff) + (pattern n:nat + #:when (> (syntax-e #'n) x) + #:with diff (- (syntax-e #'n) x))) +(define-syntax-class (nat/mult x) + #:description (format "natural number multiple of ~s" x) + #:attributes (quot) + (pattern n:nat + #:when (zero? (remainder (syntax-e #'n) x)) + #:with quot (quotient (syntax-e #'n) x))) + +(define r-nat> (reify-syntax-class nat>)) +(define r-nat/mult (reify-syntax-class nat/mult)) + +(define (partition/r stx r n) + (syntax-parse stx + [((~or (~reflect yes (r n)) no) ...) + #'((yes ...) (no ...))])) + +(partition/r #'(1 2 3 4 5) r-nat> 3) +(partition/r #'(1 2 3 4 5) r-nat/mult 2) + +(define (bad-attrs r) + (syntax-parse #'6 + [(~reflect x (r 3) #:attributes (diff)) + #'x.diff])) + +(bad-attrs r-nat>) +(bad-attrs r-nat/mult) +] + +@;{--------} + +@section{Procedural splicing syntax classes} + +@defmodule[syntax/parse/experimental/splicing] + +@defform[(define-primitive-splicing-syntax-class (name-id param-id ...) + maybe-description maybe-attrs + parser-expr) + #:contracts ([parser (-> syntax? + (->* () ((or/c string? #f) -> any)) + (list syntax? exact-positive-integer? any/c ...))])]{ + +Defines a splicing syntax via a procedural parser. + +The parser procedure is given two arguments, the syntax to parse and a +failure procedure. To signal a successful parse, the parser procedure +returns a list of 2+@scheme[N] elements, where @scheme[N] is the +number of attributes declared by the splicing syntax class. The first +two elements are the unconsumed part of the syntax and the size of the +prefix consumed. The rest of the list contains the values of the +attributes. + +To indicate failure, the parser calls the failure procedure with an +optional message argument. +} + +@;{--------} + +@section{Ellipsis-head alternative sets} + +@defmodule[syntax/parse/experimental/eh] + +Unlike @tech{@Spatterns} and @tech{@Hpatterns}, @tech{@EHpatterns} +cannot be encapsulated by syntax classes, since they describe not only +sets of terms but also repetition constraints. + +This module provides @deftech{ellipsis-head alternative sets}, +reusable encapsulations of @|EHpatterns|. + +@defform/subs[#:literals (pattern) + (define-eh-alternative-set name eh-alternative ...) + ([alternative (pattern EH-pattern)])]{ + +Defines @scheme[name] as an ellipsis-head alternative set. Using +@scheme[name] (via @scheme[~eh-var]) in an ellipsis-head pattern is +equivalent to including each of the alternatives in the pattern via +@ref[~or eh], except that the attributes bound by the alternatives are +prefixed with the name given to @scheme[~eh-var]. + +Unlike syntax classes, ellipsis-head alternative sets must be defined +before they are referenced. +} + +@schemegrammar*[#:literals (~eh-var) + [EH-pattern .... + (~eh-var name eh-alternative-set-id)]] + +@specsubform[(@#,(defhere ~eh-var) name eh-alternative-set-id)]{ + +Includes the alternatives of @scheme[eh-alternative-set-id], prefixing +their attributes with @scheme[name]. +} + +@myexamples[ +(define-eh-alternative-set options + (pattern (~once (~seq #:a a:expr) #:name "#:a option")) + (pattern (~seq #:b b:expr))) +(define (parse/options stx) + (syntax-parse stx + [(_ (~eh-var s options) ...) + #'(s.a (s.b ...))])) +(parse/options #'(m #:a 1 #:b 2 #:b 3)) +(parse/options #'(m #:a 1 #:a 2)) + +(define (parse/more-options stx) + (syntax-parse stx + [(_ (~or (~eh-var s options) + (~seq #:c c1:expr c2:expr)) + ...) + #'(s.a (s.b ...) ((c1 c2) ...))])) +(parse/more-options #'(m #:a 1 #:b 2 #:c 3 4 #:c 5 6)) + +(define-eh-alternative-set ext-options + (pattern (~eh-var s options)) + (pattern (~seq #:c c1 c2))) + +(syntax-parse #'(m #:a 1 #:b 2 #:c 3 4 #:c 5 6) + [(_ (~eh-var x ext-options) ...) + #'(x.s.a (x.s.b ...) ((x.c1 x.c2) ...))]) +] diff --git a/collects/syntax/scribblings/parse/intro.scrbl b/collects/syntax/scribblings/parse/intro.scrbl new file mode 100644 index 0000000000..69847cd612 --- /dev/null +++ b/collects/syntax/scribblings/parse/intro.scrbl @@ -0,0 +1,353 @@ +#lang scribble/doc +@(require scribble/manual + scribble/struct + scribble/decode + scribble/eval + "parse-common.rkt" + (for-label (only-in syntax/parse ...+))) + +@(define-syntax-rule (defdummy id) + (defidentifier (quote-syntax id) + #:form? #t #:index? #f #:show-libs? #f)) + +@title[#:tag "stxparse-intro"]{Introduction} + +@;{Dummy declaration} +@declare-exporting[syntax/scribblings/parse/parse-dummy-bindings] + +This section provides an introduction to writing robust macros with +@scheme[syntax-parse] and syntax classes. + +The task is to write a macro named @scheme[mylet] that has the same +syntax and behavior as Racket's @scheme[let] form. The macro should +good error messages when used incorrectly. + +Here is the specification of @scheme[mylet]'s syntax: + +@;{bleh!} +@specform[#:literals (mylet) + (code:line (@#,(defdummy mylet) ([var-id rhs-expr] ...) body ...+) + (mylet loop-id ([var-id rhs-expr] ...) body ...+))] + +For simplicify, we handle only the first case for now. We return to +the second case later in the introduction. + +First, we import @scheme[syntax-parse] @scheme[for-syntax], since we +will use it to implement a macro transformer. + +@myinteraction[(require (for-syntax syntax/parse))] + +We get the first version of @scheme[mylet] by essentially +transliterating the syntax specification above. The result is similar +to what one would write using @scheme[syntax-rules] or perhaps +@scheme[syntax-case]. + +@myinteraction[ +(define-syntax (mylet stx) + (syntax-parse stx + [(_ ([var-id rhs-expr] ...) body ...+) + #'((lambda (var-id ...) body ...) rhs-expr ...)])) +] + +Note the use of @scheme[...] and @scheme[...+] in the pattern; +@scheme[...] means match zero or more repetitions of the preceeding +pattern; @scheme[...+] means match one or more. Only @scheme[...] may +be used in the template, however. + +@myinteraction[ +(mylet ([a 1] [b 2]) (+ a b)) +(mylet (b 2) (sub1 b)) +(mylet ([1 a]) (add1 a)) +(mylet ([#:x 1] [y 2]) (* x y)) +] + +When used correctly, the macro works, but it behaves very badly in the +presence of errors. In some cases, @scheme[mylet] blithely accepts +illegal syntax and passes it along to @scheme[lambda], with strange +consequences. + +These examples of illegal syntax are not to suggest that a typical +programmer would make such mistakes attempting to use +@scheme[mylet]. At least, not often. After an initial learning +curve. But macros are also used by inexpert programmers and as targets +of other macros (or code generators), and many macros are far more +complex than @scheme[mylet]. Macros must validate their syntax and +report appropriate errors. Furthermore, the macro writer benefits from +the @emph{machine-checked} specification of syntax in the form of more +readable, maintainable code. + +The first step toward validation and high-quality error reporting is +annotating each of the macro's pattern variables with the @tech{syntax +class} that describes its acceptable syntax. In @scheme[mylet], each +variable must be an @scheme[identifier] (@scheme[id] for short) and +each right-hand side must be an @scheme[expr] (expression). An +@tech{annotated pattern variable} is written by concatenating the +pattern variable name, a colon character, and the syntax class +name.@margin-note*{For an alternative to the ``colon'' syntax, see the +@scheme[~var] pattern form.} + +@myinteraction[ +(define-syntax (mylet stx) + (syntax-parse stx + [(_ ((var:id rhs:expr) ...) body ...+) + #'((lambda (var ...) body ...) rhs ...)])) +] +Note that the syntax class annotations do not appear in the template +(i.e., @scheme[var], not @scheme[var:id]). + +The syntax class annotations are checked when we use the macro. +@myinteraction[ +(mylet ([a 1] [b 2]) (+ a b)) +(mylet (["a" 1]) (add1 a)) +] +The @scheme[expr] syntax class does not actually check that the term +it matches is a valid expression---that would require calling that +macro expander. Instead, @scheme[expr] just means not a keyword. +@myinteraction[ +(mylet ([a #:whoops]) 1) +] +Also, @scheme[syntax-parse] knows how to report a few kinds of errors +without any help: +@myinteraction[ +(mylet ([a 1 2]) (* a a)) +] +There are other kinds of errors, however, that this macro does not +handle gracefully: +@myinteraction[ +(mylet (a 1) (+ a 2)) +] +It's too much to ask for the macro to respond, ``This expression is +missing a pair of parentheses around @scheme[(a 1)].'' The pattern +matcher is not that smart. But it can pinpoint the source of the +error: when it encountered @scheme[a] it was expecting what we might +call a ``binding pair,'' but that term is not in its vocabulary yet. + +To allow @scheme[syntax-parse] to synthesize better errors, we must +attach @emph{descriptions} to the patterns we recognize as discrete +syntactic categories. One way of doing that is by defining new syntax +classes:@margin-note*{Another way is the @scheme[~describe] pattern +form.} + +@myinteraction[ +(define-syntax (mylet stx) + + (define-syntax-class binding + #:description "binding pair" + (pattern (var:id rhs:expr))) + + (syntax-parse stx + [(_ (b:binding ...) body ...+) + #'((lambda (b.var ...) body ...) b.rhs ...)])) +] + +Note that we write @scheme[b.var] and @scheme[b.rhs] now. They are the +@tech{nested attributes} formed from the annotated pattern variable +@scheme[b] and the attributes @scheme[var] and @scheme[rhs] of the +syntax class @scheme[binding]. + +Now the error messages can talk about ``binding pairs.'' +@myinteraction[ +(mylet (a 1) (+ a 2)) +] +Errors are still reported in more specific terms when possible: +@myinteraction[ +(mylet (["a" 1]) (+ a 2)) +] + +There is one other constraint on the legal syntax of +@scheme[mylet]. The variables bound by the different binding pairs +must be distinct. Otherwise the macro creates an illegal +@scheme[lambda] form: +@myinteraction[ +(mylet ([a 1] [a 2]) (+ a a)) +] + +Constraints such as the distinctness requirement are expressed as side +conditions, thus: +@myinteraction[ +(define-syntax (mylet stx) + + (define-syntax-class binding + #:description "binding pair" + (pattern (var:id rhs:expr))) + + (syntax-parse stx + [(_ (b:binding ...) body ...+) + #:fail-when (check-duplicate-identifier + (syntax->list #'(b.var ...))) + "duplicate variable name" + #'((lambda (b.var ...) body ...) b.rhs ...)])) +] +@myinteraction[ +(mylet ([a 1] [a 2]) (+ a a)) +] +The @scheme[#:fail-when] keyword is followed by two expressions: the +condition and the error message. When the condition evaluates to +anything but @scheme[#f], the pattern fails. Additionally, if the +condition evaluates to a syntax object, that syntax object is used to +pinpoint the cause of the failure. + +Syntax classes can have side conditions, too. Here is the macro +rewritten to include another syntax class representing a ``sequence of +distinct binding pairs.'' +@myinteraction[ +(define-syntax (mylet stx) + + (define-syntax-class binding + #:description "binding pair" + (pattern (var:id rhs:expr))) + + (define-syntax-class distinct-bindings + #:description "sequence of distinct binding pairs" + (pattern (b:binding ...) + #:fail-when (check-duplicate-identifier + (syntax->list #'(b.var ...))) + "duplicate variable name" + #:with (var ...) #'(b.var ...) + #:with (rhs ...) #'(b.rhs ...))) + + (syntax-parse stx + [(_ bs:distinct-bindings . body) + #'((lambda (bs.var ...) . body) bs.rhs ...)])) +] +Here we've introduced the @scheme[#:with] clause. A @scheme[#:with] +clause matches a pattern with a computed term. Here we use it to bind +@scheme[var] and @scheme[rhs] as attributes of +@scheme[distinct-bindings]. By default, a syntax class only exports +its patterns' pattern variables as attributes, not their nested +attributes.@margin-note*{The alternative would be to explicitly declare +the attributes of @scheme[distinct-bindings] to include the nested +attributes @scheme[b.var] and @scheme[b.rhs], using the +@scheme[#:attribute] option. Then the macro would refer to +@scheme[bs.b.var] and @scheme[bs.b.rhs].} + +Alas, so far the macro only implements half of the functionality +offered by Racket's @scheme[let]. We must add the +``named-@scheme[let]'' form. That turns out to be as simple as adding +a new clause: + +@myinteraction[ +(define-syntax (mylet stx) + + (define-syntax-class binding + #:description "binding pair" + (pattern (var:id rhs:expr))) + + (define-syntax-class distinct-bindings + #:description "sequence of distinct binding pairs" + (pattern (b:binding ...) + #:fail-when (check-duplicate-identifier + (syntax->list #'(b.var ...))) + "duplicate variable name" + #:with (var ...) #'(b.var ...) + #:with (rhs ...) #'(b.rhs ...))) + + (syntax-parse stx + [(_ bs:distinct-bindings body ...+) + #'((lambda (bs.var ...) body ...) bs.rhs ...)] + [(_ loop:id bs:distinct-bindings body ...+) + #'(letrec ([loop (lambda (bs.var ...) body ...)]) + (loop bs.rhs ...))])) +] +We are able to reuse the @scheme[distinct-bindings] syntax class, so +the addition of the ``named-@scheme[let]'' syntax requires only three +lines. + +But does adding this new case affect @scheme[syntax-parse]'s ability +to pinpoint and report errors? +@myinteraction[ +(mylet ([a 1] [b 2]) (+ a b)) +(mylet (["a" 1]) (add1 a)) +(mylet ([a #:whoops]) 1) +(mylet ([a 1 2]) (* a a)) +(mylet (a 1) (+ a 2)) +(mylet ([a 1] [a 2]) (+ a a)) +] +The error reporting for the original syntax seems intact. We should +verify that the named-@scheme[let] syntax is working, that +@scheme[syntax-parse] is not simply ignoring that clause. +@myinteraction[ +(mylet loop ([a 1] [b 2]) (+ a b)) +(mylet loop (["a" 1]) (add1 a)) +(mylet loop ([a #:whoops]) 1) +(mylet loop ([a 1 2]) (* a a)) +(mylet loop (a 1) (+ a 2)) +(mylet loop ([a 1] [a 2]) (+ a a)) +] + +How does @scheme[syntax-parse] decide which clause the programmer was +attempting, so it can use it as a basis for error reporting? After +all, each of the bad uses of the named-@scheme[let] syntax are also +bad uses of the normal syntax, and vice versa. And yet the macro doen +not produce errors like ``@scheme[mylet]: expected sequence of +distinct binding pairs at: @scheme[loop].'' + +The answer is that @scheme[syntax-parse] records a list of all the +potential errors (including ones like @scheme[loop] not matching +@scheme[distinct-binding]) along with the @emph{progress} made before +each error. Only the error with the most progress is reported. + +For example, in this bad use of the macro, +@myinteraction[ +(mylet loop (["a" 1]) (add1 a)) +] +there are two potential errors: expected @scheme[distinct-bindings] at +@scheme[loop] and expected @scheme[identifier] at @scheme["a"]. The +second error occurs further in the term than the first, so it is +reported. + +For another example, consider this term: +@myinteraction[ +(mylet (["a" 1]) (add1 a)) +] +Again, there are two potential errors: expected @scheme[identifier] at +@scheme[(["a" 1])] and expected @scheme[identifier] at +@scheme["a"]. They both occur at the second term (or first argument, +if you prefer), but the second error occurs deeper in the +term. Progress is based on a left-to-right traversal of the syntax. + +A final example: consider the following: +@myinteraction[ +(mylet ([a 1] [a 2]) (+ a a)) +] +There are two errors again: duplicate variable name at @scheme[([a 1] +[a 2])] and expected @scheme[identifier] at @scheme[([a 1] [a +2])]. Note that as far as @scheme[syntax-parse] is concerned, the +progress associated with the duplicate error message is the second +term (first argument), not the second occurrence of @scheme[a]. That's +because the check is associated with the entire +@scheme[distinct-bindings] pattern. It would seem that both errors +have the same progress, and yet only the first one is reported. The +difference between the two is that the first error is from a +@emph{post-traversal} check, whereas the second is from a normal +(i.e., pre-traversal) check. A post-traveral check is considered to +have made more progress than a pre-traversal check of the same term; +indeed, it also has greater progress than any failure @emph{within} +the term. + +It is, however, possible for multiple potential errors to occur with +the same progress. Here's one example: +@myinteraction[ +(mylet "not-even-close") +] +In this case @scheme[syntax-parse] reports both errors. + +Even with all of the annotations we have added to our macro, there are +still some misuses that defy @scheme[syntax-parse]'s error reporting +capabilities, such as this example: +@myinteraction[ +(mylet) +] +The philosophy behind @scheme[syntax-parse] is that in these +situations, a generic error such as ``bad syntax'' is justified. The +use of @scheme[mylet] here is so far off that the only informative +error message would include a complete recapitulation of the syntax of +@scheme[mylet]. That is not the role of error messages, however; it is +the role of documentation. + +This section has provided an introduction to syntax classes, side +conditions, and progress-ordered error reporting. But +@scheme[syntax-parse] has many more features. Continue to the +@secref{stxparse-examples} section for samples of other features in +working code, or skip to the subsequent sections for the complete +reference documentation. diff --git a/collects/syntax/scribblings/parse/lib.scrbl b/collects/syntax/scribblings/parse/lib.scrbl new file mode 100644 index 0000000000..682df96143 --- /dev/null +++ b/collects/syntax/scribblings/parse/lib.scrbl @@ -0,0 +1,75 @@ +#lang scribble/doc +@(require scribble/manual + scribble/struct + scribble/decode + scribble/eval + "parse-common.rkt" + (for-label syntax/kerncase)) + +@title[#:tag "stxparse-lib"]{Library syntax classes and literal sets} + +@section{Syntax classes} + +@(begin + (define-syntax-rule (defstxclass name . pre-flows) + (defidform name . pre-flows)) + (define-syntax-rule (defstxclass* (name arg ...) . pre-flows) + (defform (name arg ...) . pre-flows))) + +@defstxclass[expr]{ + +Matches anything except a keyword literal (to distinguish expressions +from the start of a keyword argument sequence). The term is not +otherwise inspected, since it is not feasible to check if it is +actually a valid expression. +} + +@deftogether[( +@defstxclass[identifier] +@defstxclass[boolean] +@defstxclass[str] +@defstxclass[char] +@defstxclass[keyword] +@defstxclass[number] +@defstxclass[integer] +@defstxclass[exact-integer] +@defstxclass[exact-nonnegative-integer] +@defstxclass[exact-positive-integer])]{ + +Match syntax satisfying the corresponding predicates. +} + +@defstxclass[id]{ Alias for @scheme[identifier]. } +@defstxclass[nat]{ Alias for @scheme[exact-nonnegative-integer]. } + +@defproc[(static [predicate (-> any/c any/c)] + [description (or/c string? #f)]) + (attributes value)]{ + +The @defidentifier[#'static #:form? #t] syntax class matches an +identifier that is bound in the syntactic environment to static +information (see @scheme[syntax-local-value]) satisfying the given +@scheme[predicate]. If the term does not match, the +@scheme[description] argument is used to describe the expected syntax. + +When used outside of the dynamic extent of a macro transformer (see +@scheme[syntax-transforming?]), matching fails. + +The attribute @var[value] contains the value the name is bound to. +} + + +@section{Literal sets} + +@defidform[kernel-literals]{ + +Literal set containing the identifiers for fully-expanded code +(@secref[#:doc '(lib "scribblings/reference/reference.scrbl") +"fully-expanded"]). The set contains all of the forms listed by +@scheme[kernel-form-identifier-list], plus @scheme[module], +@scheme[#%plain-module-begin], @scheme[#%require], and +@scheme[#%provide]. + +Note that the literal-set uses the names @scheme[#%plain-lambda] and +@scheme[#%plain-app], not @scheme[lambda] and @scheme[#%app]. +} diff --git a/collects/syntax/scribblings/parse/litconv.scrbl b/collects/syntax/scribblings/parse/litconv.scrbl new file mode 100644 index 0000000000..f37b87abfe --- /dev/null +++ b/collects/syntax/scribblings/parse/litconv.scrbl @@ -0,0 +1,122 @@ +#lang scribble/doc +@(require scribble/manual + scribble/struct + scribble/decode + scribble/eval + "parse-common.rkt") + +@title[#:tag "stxparse-litconv"]{Literal sets and Conventions} + +Sometimes the same literals are recognized in a number of different +places. The most common example is the literals for fully expanded +programs, which are used in many analysis and transformation +tools. Specifying literals individually is burdensome and error-prone. +As a remedy, @schememodname[syntax/parse] offers @deftech{literal +sets}. A literal set is defined via @scheme[define-literal-set] and +used via the @scheme[#:literal-set] option of @scheme[syntax-parse]. + +@defform/subs[(define-literal-set name-id (literal ...)) + ([literal literal-id + (pattern-id literal-id)])]{ + +Defines @scheme[name] as a @tech{literal set}. Each @scheme[literal] +can have a separate @scheme[pattern-id] and @scheme[literal-id]. The +@scheme[pattern-id] determines what identifiers in the pattern are +treated as literals. The @scheme[literal-id] determines what +identifiers the literal matches. + +@myexamples[ +(define-literal-set def-litset + (define-values define-syntaxes)) +(syntax-parse #'(define-syntaxes (x) 12) + #:literal-sets (def-litset) + [(define-values (x:id ...) e:expr) 'v] + [(define-syntaxes (x:id ...) e:expr) 's]) +] + +The literals in a literal set always refer to the phase-0 bindings of +the enclosing module. For example: + +@myexamples[ +(module common racket/base + (define x 'something) + (provide x)) + +(module lits racket/base + (require syntax/parse 'common) + (define-literal-set common-lits (x)) + (provide common-lits)) +] + +In the literal set @scheme[common-lits], the literal @scheme[x] always +recognizes identifiers bound to the variable @scheme[x] defined in +module @schememodname['common]. + +When a literal set is used with the @scheme[#:phase phase-expr] +option, the literals' fixed bindings are compared against the binding of +the input literal at the specified phase. Continuing the example: + +@myexamples[ +(require syntax/parse 'lits (for-syntax 'common)) +(syntax-parse #'x #:literal-sets ([common-lits #:phase 1]) + [x 'yes] + [_ 'no]) +] + +The occurrence of @scheme[x] in the pattern matches any identifier +whose binding at phase 1 is the @scheme[x] from module +@schememodname['common]. +} + +@defform/subs[(define-conventions name-id convention-rule ...) + ([convention-rule (name-pattern syntax-class)] + [name-pattern exact-id + name-rx] + [syntax-class syntax-class-id + (syntax-class-id expr ...)])]{ + +Defines @deftech{conventions} that supply default syntax classes for +pattern variables. A pattern variable that has no explicit syntax +class is checked against each @scheme[id-pattern], and the first one +that matches determines the syntax class for the pattern. If no +@scheme[id-pattern] matches, then the pattern variable has no syntax +class. + +@myexamples[ +(define-conventions xyz-as-ids + [x id] [y id] [z id]) +(syntax-parse #'(a b c 1 2 3) + #:conventions (xyz-as-ids) + [(x ... n ...) (syntax->datum #'(x ...))]) +(define-conventions xn-prefixes + [#rx"^x" id] + [#rx"^n" nat]) +(syntax-parse #'(a b c 1 2 3) + #:conventions (xn-prefixes) + [(x0 x ... n0 n ...) + (syntax->datum #'(x0 (x ...) n0 (n ...)))]) +] + +Local conventions, introduced with the @scheme[#:local-conventions] +keyword argument of @scheme[syntax-parse] and syntax class +definitions, may refer to local bindings: + +@myexamples[ +(define-syntax-class (nat> bound) + (pattern n:nat + #:fail-unless (> (syntax-e #'n) bound) + (format "expected number > ~s" bound))) + +(define-syntax-class (natlist> bound) + #:local-conventions ([N (nat> bound)]) + (pattern (N ...))) + +(define (parse-natlist> bound x) + (syntax-parse x + #:local-conventions ([NS (natlist> bound)]) + [NS 'ok])) +(parse-natlist> 0 #'(1 2 3)) +(parse-natlist> 5 #'(8 6 4 2)) +] + +} diff --git a/collects/syntax/scribblings/parse/parse-common.rkt b/collects/syntax/scribblings/parse/parse-common.rkt new file mode 100644 index 0000000000..17baad6f1a --- /dev/null +++ b/collects/syntax/scribblings/parse/parse-common.rkt @@ -0,0 +1,116 @@ +#lang racket/base +(require scribble/manual + scribble/eval + racket/sandbox) + +(provide ellipses + the-eval + myexamples + myinteraction) + +(define ellipses (scheme ...)) + +(define (fixup exn) + (let ([src (ormap values (exn:fail:syntax-exprs exn))]) + (if src + (make-exn:fail:syntax + (format "~a at: ~s" (exn-message exn) (syntax->datum src)) + (exn-continuation-marks exn) + (exn:fail:syntax-exprs exn)) + exn))) +(define the-eval + (parameterize ((sandbox-output 'string) + (sandbox-error-output 'string) + (sandbox-make-code-inspector current-code-inspector) + (sandbox-eval-handlers + (list #f + (lambda (thunk) + (with-handlers ([exn:fail:syntax? + (lambda (e) (raise (fixup e)))]) + (thunk)))))) + (make-evaluator 'racket/base + #:requires (let ([mods '(syntax/parse + syntax/parse/debug + syntax/parse/experimental/splicing + syntax/parse/experimental/contract + syntax/parse/experimental/reflect + syntax/parse/experimental/eh)]) + `((for-syntax racket/base ,@mods) + ,@mods))))) +(the-eval '(error-print-source-location #f)) + +(define-syntax-rule (myexamples e ...) + (examples #:eval the-eval e ...)) + +(define-syntax-rule (myinteraction e ...) + (interaction #:eval the-eval e ...)) + +;; ---- + +(define Spattern "single-term pattern") +(define Lpattern "list pattern") +(define Hpattern "head pattern") +(define EHpattern "ellipsis-head pattern") +(define Apattern "action pattern") + +(define Spatterns "single-term patterns") +(define Lpatterns "list patterns") +(define Hpatterns "head patterns") +(define EHpatterns "ellipsis-head patterns") +(define Apatterns "action patterns") + +(provide Spattern + Lpattern + Hpattern + EHpattern + Apattern + Spatterns + Lpatterns + Hpatterns + EHpatterns + Apatterns) + +;; ---- + +(define-syntax-rule (defhere id) (defidentifier #'id #:form? #t)) + +(define-syntax ref + (syntax-rules () + [(ref id suffix ...) + (elemref (list 'pattern-link (list 'id 'suffix ...)) + (schemekeywordfont (symbol->string 'id)) + (superscript (symbol->string 'suffix)) ... + #:underline? #f)])) +(define-syntax def + (syntax-rules () + [(def id suffix ...) + (elemtag (list 'pattern-link (list 'id 'suffix ...)) + (scheme id) + #|(superscript (symbol->string 'suffix)) ...|# )])) + +(provide defhere + ref + def) + +;; ---- + +(require (for-label racket/base + racket/contract + (except-in syntax/parse ...+) + syntax/parse/debug + syntax/parse/experimental/contract + syntax/parse/experimental/splicing + syntax/parse/experimental/reflect + syntax/parse/experimental/provide + syntax/parse/experimental/eh + "parse-dummy-bindings.rkt")) +(provide (for-label (all-from-out racket/base) + (all-from-out racket/contract) + (all-from-out syntax/parse) + (all-from-out syntax/parse/debug) + (all-from-out syntax/parse/experimental/contract) + (all-from-out syntax/parse/experimental/splicing) + (all-from-out syntax/parse/experimental/reflect) + (all-from-out syntax/parse/experimental/provide) + (all-from-out syntax/parse/experimental/eh) + (all-from-out "parse-dummy-bindings.rkt"))) diff --git a/collects/syntax/scribblings/parse/parse-dummy-bindings.rkt b/collects/syntax/scribblings/parse/parse-dummy-bindings.rkt new file mode 100644 index 0000000000..9cc238a4bf --- /dev/null +++ b/collects/syntax/scribblings/parse/parse-dummy-bindings.rkt @@ -0,0 +1,4 @@ +#lang racket/base +(provide mylet) + +(define mylet 'dummy-binding) diff --git a/collects/syntax/scribblings/parse/parsing.scrbl b/collects/syntax/scribblings/parse/parsing.scrbl new file mode 100644 index 0000000000..3558c0a883 --- /dev/null +++ b/collects/syntax/scribblings/parse/parsing.scrbl @@ -0,0 +1,462 @@ +#lang scribble/doc +@(require scribble/manual + scribble/struct + scribble/decode + scribble/eval + "parse-common.rkt") + +@title[#:tag "stxparse-parsing"]{Parsing and classifying syntax} + +This section describes @schememodname[syntax/parse]'s facilities for +parsing and classifying syntax. These facilities use a common language +of @tech{syntax patterns}, which is described in detail in the next +section, @secref{stxparse-patterns}. + +@declare-exporting[syntax/parse] + +@section{Parsing syntax} + +Two parsing forms are provided: @scheme[syntax-parse] and +@scheme[syntax-parser]. + +@defform/subs[(syntax-parse stx-expr parse-option ... clause ...+) + ([parse-option (code:line #:context context-expr) + (code:line #:literals (literal ...)) + (code:line #:literal-sets (literal-set ...)) + (code:line #:conventions (convention-id ...)) + (code:line #:local-conventions (convention-rule ...))] + [literal literal-id + (pattern-id literal-id) + (pattern-id literal-id #:phase phase-expr)] + [literal-set literal-set-id + (literal-set-id literal-set-option ...)] + [literal-set-option (code:line #:at context-id) + (code:line #:phase phase-expr)] + [clause (syntax-pattern pattern-directive ... expr ...+)]) + #:contracts ([stx-expr syntax?] + [context-expr syntax?] + [phase-expr (or/c exact-integer? #f)])]{ + +Evaluates @scheme[stx-expr], which should produce a syntax object, and +matches it against the @scheme[clause]s in order. If some clause's +pattern matches, its attributes are bound to the corresponding +subterms of the syntax object and that clause's side conditions and +@scheme[expr] is evaluated. The result is the result of @scheme[expr]. + +If the syntax object fails to match any of the patterns (or all +matches fail the corresponding clauses' side conditions), a syntax +error is raised. + +The following options are supported: + +@specsubform[(code:line #:context context-expr) + #:contracts ([context-expr syntax?])]{ + +When present, @scheme[context-expr] is used in reporting parse +failures; otherwise @scheme[stx-expr] is used. + +@(myexamples + (syntax-parse #'(a b 3) + [(x:id ...) 'ok]) + (syntax-parse #'(a b 3) + #:context #'(lambda (a b 3) (+ a b)) + [(x:id ...) 'ok])) +} + +@specsubform/subs[(code:line #:literals (literal ...)) + ([literal literal-id + (pattern-id literal-id) + (pattern-id literal-id #:phase phase-expr)]) + #:contracts ([phase-expr (or/c exact-integer? #f)])]{ +@margin-note*{ + Unlike @scheme[syntax-case], @scheme[syntax-parse] requires all + literals to have a binding. To match identifiers by their symbolic + names, use the @scheme[~datum] pattern form instead. +} +@; +The @scheme[#:literals] option specifies identifiers that should be +treated as @tech{literals} rather than @tech{pattern variables}. An +entry in the literals list has two components: the identifier used +within the pattern to signify the positions to be matched +(@scheme[pattern-id]), and the identifier expected to occur in those +positions (@scheme[literal-id]). If the entry is a single identifier, +that identifier is used for both purposes. + +If the @scheme[#:phase] option is given, then the literal is compared +at phase @scheme[phase-expr]. Specifically, the binding of the +@scheme[literal-id] at phase @scheme[phase-expr] must match the +input's binding at phase @scheme[phase-expr]. +} + +@specsubform/subs[(code:line #:literal-sets (literal-set ...)) + ([literal-set literal-set-id + (literal-set-id literal-set-option ...)] + [literal-set-option (code:line #:at context-id) + (code:line #:phase phase-expr)]) + #:contracts ([phase-expr (or/c exact-integer? #f)])]{ + +Many literals can be declared at once via one or more @tech{literal +sets}, imported with the @scheme[#:literal-sets] option. See +@tech{literal sets} for more information. +} + +@specsubform[(code:line #:conventions (conventions-id ...))]{ + +Imports @tech{convention}s that give default syntax classes to pattern +variables that do not explicitly specify a syntax class. +} + +@specsubform[(code:line #:local-conventions (convention-rule ...))]{ + +Uses the @tech{conventions} specified. The advantage of +@scheme[#:local-conventions] over @scheme[#:conventions] is that local +conventions can be in the scope of syntax-class parameter +bindings. See the section on @tech{conventions} for examples. +} + +Each clause consists of a @tech{syntax pattern}, an optional sequence +of @tech{pattern directives}, and a non-empty sequence of body +expressions. +} + +@defform[(syntax-parser parse-option ... clause ...+)]{ + +Like @scheme[syntax-parse], but produces a matching procedure. The +procedure accepts a single argument, which should be a syntax object. +} + +@;{----------} + +@section{Classifying syntax} + +Syntax classes provide an abstraction mechanism for @tech{syntax +patterns}. Built-in syntax classes are supplied that recognize basic +classes such as @scheme[identifier] and @scheme[keyword]. Programmers +can compose basic syntax classes to build specifications of more +complex syntax, such as lists of distinct identifiers and formal +arguments with keywords. Macros that manipulate the same syntactic +structures can share syntax class definitions. + +@defform*/subs[#:literals (pattern) + [(define-syntax-class name-id stxclass-option ... + stxclass-variant ...+) + (define-syntax-class (name-id . kw-formals) stxclass-option ... + stxclass-variant ...+)] + ([stxclass-option + (code:line #:attributes (attr-arity-decl ...)) + (code:line #:description description-expr) + (code:line #:opaque) + (code:line #:commit) + (code:line #:no-delimit-cut) + (code:line #:literals (literal-entry ...)) + (code:line #:literal-sets (literal-set ...)) + (code:line #:conventions (convention-id ...)) + (code:line #:local-conventions (convention-rule ...))] + [attr-arity-decl + attr-name-id + (attr-name-id depth)] + [stxclass-variant + (pattern syntax-pattern pattern-directive ...)]) + #:contracts ([description-expr (or/c string? #f)])]{ + +Defines @scheme[name-id] as a @deftech{syntax class}, which +encapsulates one or more @tech{single-term patterns}. + +A syntax class may have formal parameters, in which case they are +bound as variables in the body. Syntax classes support optional +arguments and keyword arguments using the same syntax as +@scheme[lambda]. The body of the syntax-class definition contains a +non-empty sequence of @scheme[pattern] variants. + +The following options are supported: + +@specsubform/subs[(code:line #:attributes (attr-arity-decl ...)) + ([attr-arity-decl attr-id + (attr-id depth)])]{ + +Declares the attributes of the syntax class. An attribute arity +declaration consists of the attribute name and optionally its ellipsis +depth (zero if not explicitly specified). + +If the attributes are not explicitly listed, they are inferred as the +set of all @tech{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 from +@tech{annotated pattern variables}. +} + +@specsubform[(code:line #:description description-expr) + #:contracts ([description-expr (or/c string? #f)])]{ + +The @scheme[description] argument is evaluated in a scope containing +the syntax class's parameters. If the result is a string, it is used +in error messages involving the syntax class. For example, if a term +is rejected by the syntax class, an error of the form +@schemevalfont{"expected @scheme[description]"} may be synthesized. If +the result is @scheme[#f], the syntax class is skipped in the search +for a description to report. + +If the option is not given absent, the name of the syntax class is +used instead. +} + +@specsubform[#:opaque]{ + +Indicates that errors should not be reported with respect to the +internal structure of the syntax class. +} + +@specsubform[#:commit]{ + +Directs the syntax class to ``commit'' to the first successful +match. When a variant succeeds, all choice points within the syntax +class are discarded. See also @scheme[~commit]. +} + +@specsubform[#:no-delimit-cut]{ + +By default, a cut (@scheme[~!]) within a syntax class only discards +choice points within the syntax class. That is, the body of the syntax +class acts as though it is wrapped in a @scheme[~delimit-cut] form. If +@scheme[#:no-delimit-cut] is specified, a cut may affect choice points +of the syntax class's calling context (another syntax class's patterns +or a @scheme[syntax-parse] form). + +It is an error to use both @scheme[#:commit] and +@scheme[#:no-delimit-cut]. +} + +@specsubform[(code:line #:literals (literal-entry))] +@specsubform[(code:line #:literal-sets (literal-set ...))] +@specsubform[(code:line #:conventions (convention-id ...))]{ + +Declares the literals and conventions that apply to the syntax class's +variant patterns and their immediate @scheme[#:with] clauses. Patterns +occuring within subexpressions of the syntax class (for example, on +the right-hand side of a @scheme[#:fail-when] clause) are not +affected. + +These options have the same meaning as in @scheme[syntax-parse]. +} + +Each variant of a syntax class is specified as a separate +@scheme[pattern]-form whose syntax pattern is a @tech{single-term +pattern}. +} + +@defform*[#:literals (pattern) + [(define-splicing-syntax-class name-id stxclass-option ... + stxclass-variant ...+) + (define-splicing-syntax-class (name-id kw-formals) stxclass-option ... + stxclass-variant ...+)]]{ + +Defines @scheme[name-id] as a @deftech{splicing syntax class}, +analogous to a @tech{syntax class} but encapsulating @tech{head +patterns} rather than @tech{single-term patterns}. + +The options are the same as for @scheme[define-syntax-class]. + +Each variant of a splicing syntax class is specified as a separate +@scheme[pattern]-form whose syntax pattern is a @tech{head pattern}. +} + +@defform[#:literals (pattern) + (pattern syntax-pattern pattern-directive ...)]{ + +Used to indicate a variant of a syntax class or splicing syntax +class. The variant accepts syntax matching the given syntax pattern +with the accompanying @tech{pattern directives}. + +When used within @scheme[define-syntax-class], @scheme[syntax-pattern] +should be a @tech{single-term pattern}; within +@scheme[define-splicing-syntax-class], it should be a @tech{head +pattern}. + +The attributes of the variant are the attributes of the pattern +together with all attributes bound by @scheme[#:with] clauses, +including nested attributes produced by syntax classes associated with +the pattern variables. +} + +@;{--------} + +@subsection{Pattern directives} + +Both the parsing forms and syntax class definition forms support +@deftech{pattern directives} for annotating syntax patterns and +specifying side conditions. The grammar for pattern directives +follows: + +@schemegrammar[pattern-directive + (code:line #:declare pattern-id syntax-class-id) + (code:line #:declare pattern-id (syntax-class-id arg ...)) + (code:line #:with syntax-pattern expr) + (code:line #:attr attr-id expr) + (code:line #:fail-when condition-expr message-expr) + (code:line #:fail-unless condition-expr message-expr) + (code:line #:when condition-expr) + (code:line #:do [def-or-expr ...])] + +@specsubform[(code:line #:declare pvar-id syntax-class-id)] +@specsubform[(code:line #:declare pvar-id (syntax-class-id arg ...))]{ + +The first form is equivalent to using the +@svar[pvar-id:syntax-class-id] form in the pattern (but it is illegal +to use both for the same pattern variable). + +The second form allows the use of parameterized syntax classes, which +cannot be expressed using the ``colon'' notation. The @scheme[arg]s +are evaluated outside the scope of any of the attribute bindings from +pattern that the @scheme[#:declare] directive applies to. Keyword +arguments are supported, using the same syntax as in @scheme[#%app]. +} + +@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 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) + #:contracts ([message-expr (or/c string? #f)])]{ + +Evaluates the @scheme[condition-expr] in the context of all previous +attribute bindings. If the value is any true value (not @scheme[#f]), +the matching process backtracks (with the given message); otherwise, +it continues. If the value of the condition expression is a syntax +object, it is indicated as the cause of the error. + +If the @scheme[message-expr] produces a string it is used as the +failure message; otherwise the failure is reported in terms of the +enclosing descriptions. +} + +@specsubform[(code:line #:fail-unless condition-expr message-expr) + #:contracts ([message-expr (or/c string? #f)])]{ + +Like @scheme[#:fail-when] with the condition negated. +} + +@specsubform[(code:line #:when condition-expr)]{ + +Evaluates the @scheme[condition-expr] in the context of all previous +attribute bindings. If the value is @scheme[#f], the matching process +backtracks. In other words, @scheme[#:when] is like +@scheme[#:fail-unless] without the message argument. +} + +@specsubform[(code:line #:do [def-or-expr ...])]{ + +Takes a sequence of definitions and expressions, which may be +intermixed, and evaluates them in the scope of all previous attribute +bindings. The names bound by the definitions are in scope in +the expressions of subsequent patterns and clauses. + +There is currently no way to bind attributes using a @scheme[#:do] +block. It is an error to shadow an attribute binding with a definition +in a @scheme[#:do] block. +} + + +@;{----------} + +@section{Pattern variables and attributes} + +An @deftech{attribute} is a name bound by a syntax pattern. An +attribute can be a @tech{pattern variable} itself, or it can be a +@tech{nested attribute} bound by an @tech{annotated pattern +variable}. The name of a nested attribute is computed by concatenating +the pattern variable name with the syntax class's exported attribute's +name, separated by a dot (see the example below). + +Attribute names cannot be used directly as expressions; that is, +attributes are not variables. Instead, an attribute's value can be +gotten using the @scheme[attribute] special form. + +@defform[(attribute attr-id)]{ + +Returns the value associated with the attribute named +@scheme[attr-id]. If @scheme[attr-id] is not bound as an attribute, an +error is raised. +} + +The value of an attribute need not be syntax. Non-syntax-valued +attributes can be used to return a parsed representation of a subterm +or the results of an analysis on the subterm. A non-syntax-valued +attribute should be bound using the @scheme[#:attr] directive or a +@scheme[~bind] pattern. + +@myexamples[ +(define-syntax-class table + (pattern ((key value) ...) + #:attr hash + (for/hash ([k (syntax->datum #'(key ...))] + [v (syntax->datum #'(value ...))]) + (values k v)))) +(syntax-parse #'((a 1) (b 2) (c 3)) + [t:table + (attribute t.hash)]) +] + +A syntax-valued attribute is an attribute whose value is a syntax +object or a syntax list of the appropriate @tech{ellipsis +depth}. Syntax-valued attributes can be used within @scheme[syntax], +@scheme[quasisyntax], etc as part of a syntax template. If a +non-syntax-valued attribute is used in a syntax template, a runtime +error is signalled. + +@myexamples[ +(syntax-parse #'((a 1) (b 2) (c 3)) + [t:table + #'(t.key ...)]) +(syntax-parse #'((a 1) (b 2) (c 3)) + [t:table + #'t.hash]) +] + +Every attribute has an associated @deftech{ellipsis depth} that +determines how it can be used in a syntax template (see the discussion +of ellipses in @scheme[syntax]). For a pattern variable, the ellipsis +depth is the number of ellipses the pattern variable ``occurs under'' +in the pattern. For a nested attribute the depth is the sum of the +pattern variable's depth and the depth of the attribute in the syntax +class. Consider the following code: + +@schemeblock[ +(define-syntax-class quark + (pattern (a b ...))) +(syntax-parse some-term + [(x (y:quark ...) ... z:quark) + some-code]) +] + +The syntax class @scheme[quark] exports two attributes: @scheme[a] at +depth 0 and @scheme[b] at depth 1. The @scheme[syntax-parse] pattern +has three pattern variables: @scheme[x] at depth 0, @scheme[y] at +depth 2, and @scheme[z] at depth 0. Since @scheme[x] and @scheme[y] +are annotated with the @scheme[quark] syntax class, the pattern also +binds the following nested attributes: @scheme[y.a] at depth 2, +@scheme[y.b] at depth 3, @scheme[z.a] at depth 0, and @scheme[z.b] at +depth 1. + +An attribute's ellipsis nesting depth is @emph{not} a guarantee that +its value has that level of list nesting. In particular, @scheme[~or] +and @scheme[~optional] patterns may result in attributes with fewer +than expected levels of list nesting. + +@(myexamples + (syntax-parse #'(1 2 3) + [(~or (x:id ...) _) + (attribute x)])) diff --git a/collects/syntax/scribblings/parse-patterns.scrbl b/collects/syntax/scribblings/parse/patterns.scrbl similarity index 78% rename from collects/syntax/scribblings/parse-patterns.scrbl rename to collects/syntax/scribblings/parse/patterns.scrbl index c47fea6dd7..47916d1dac 100644 --- a/collects/syntax/scribblings/parse-patterns.scrbl +++ b/collects/syntax/scribblings/parse/patterns.scrbl @@ -3,12 +3,7 @@ scribble/struct scribble/decode scribble/eval - scheme/sandbox - (for-syntax scheme/base) - (for-label scheme/base - scheme/contract - (rename-in syntax/parse [...+ DOTSPLUS]) - syntax/kerncase)) + "parse-common.rkt") @(define-syntax-rule (define-dotsplus-names dotsplus def-dotsplus) (begin (require (for-label (only-in syntax/parse ...+))) @@ -16,63 +11,7 @@ (define def-dotsplus (defhere ...+)))) @(define-dotsplus-names dotsplus def-dotsplus) -@(define-syntax-rule (defhere id) (defidentifier #'id #:form? #t)) - -@(define ellipses @scheme[...]) - -@(define Spattern "single-term pattern") -@(define Lpattern "list pattern") -@(define Hpattern "head pattern") -@(define EHpattern "ellipsis-head pattern") -@(define Apattern "action pattern") - -@(define Spatterns "single-term patterns") -@(define Lpatterns "list patterns") -@(define Hpatterns "head patterns") -@(define EHpatterns "ellipsis-head patterns") -@(define Apatterns "action patterns") - -@(begin - (define-syntax ref - (syntax-rules () - [(ref id suffix ...) - (elemref (list 'pattern-link (list 'id 'suffix ...)) - (schemekeywordfont (symbol->string 'id)) - (superscript (symbol->string 'suffix)) ... - #:underline? #f)])) - (define-syntax def - (syntax-rules () - [(def id suffix ...) - (elemtag (list 'pattern-link (list 'id 'suffix ...)) - (scheme id) - #|(superscript (symbol->string 'suffix)) ...|# )]))) - -@(begin - (define (fixup exn) - (let ([src (ormap values (exn:fail:syntax-exprs exn))]) - (if src - (make-exn:fail:syntax - (format "~a at: ~a" (exn-message exn) (syntax->datum src)) - (exn-continuation-marks exn) - (exn:fail:syntax-exprs exn)) - exn))) - (define the-eval - (parameterize ((sandbox-output 'string) - (sandbox-error-output 'string) - (sandbox-make-code-inspector current-code-inspector) - (sandbox-eval-handlers - (list #f - (lambda (thunk) - (with-handlers ([exn:fail:syntax? - (lambda (e) (raise (fixup e)))]) - (thunk)))))) - (make-evaluator 'scheme/base - #:requires '(syntax/parse (for-syntax scheme/base))))) - (the-eval '(error-print-source-location #f)) - (define-syntax-rule (myexamples e ...) - (examples #:eval the-eval e ...))) - -@title[#:tag "syntax-patterns"]{Syntax patterns} +@title[#:tag "stxparse-patterns"]{Syntax patterns} The grammar of @deftech{syntax patterns} used by @schememodname[syntax/parse] facilities is given in the following @@ -99,7 +38,8 @@ means specifically @tech{@Spattern}. pvar-id:syntax-class-id literal-id (@#,ref[~var s-] id) - (@#,ref[~var s+] id syntax-class) + (@#,ref[~var s+] id syntax-class-id) + (@#,ref[~var s+] id (syntax-class-id arg ...)) (~literal literal-id) atomic-datum (~datum datum) @@ -114,7 +54,9 @@ means specifically @tech{@Spattern}. #s(prefab-struct-key (unsyntax @svar[pattern-part]) ...) #&@#,svar[S-pattern] (~rest S-pattern) - (@#,ref[~describe s] expr S-pattern) + (@#,ref[~describe s] maybe-opaque expr S-pattern) + (@#,ref[~commit s] S-pattern) + (@#,ref[~delimit-cut s] S-pattern) A-pattern] [L-pattern () @@ -125,12 +67,15 @@ means specifically @tech{@Spattern}. (~rest L-pattern)] [H-pattern pvar-id:splicing-syntax-class-id - (@#,ref[~var h] id splicing-syntax-class) + (@#,ref[~var h] id splicing-syntax-class-id) + (@#,ref[~var h] id (splicing-syntax-class-id arg ...)) (~seq . L-pattern) (@#,ref[~and h] proper-H/A-pattern ...+) (@#,ref[~or h] H-pattern ...+) (@#,ref[~optional h] H-pattern maybe-optional-option) - (@#,ref[~describe h] expr H-pattern) + (@#,ref[~describe h] maybe-opaque expr H-pattern) + (@#,ref[~commit h] H-pattern) + (@#,ref[~delimit-cut h] H-pattern) proper-S-pattern] [EH-pattern (@#,ref[~or eh] EH-pattern ...) @@ -141,7 +86,7 @@ means specifically @tech{@Spattern}. [A-pattern ~! (~bind [attr-id expr] ...) - (~fail maybe-fail-condition message-expr) + (~fail maybe-fail-condition maybe-message-expr) (~parse S-pattern stx-expr) (@#,ref[~and a] A-pattern ...+)] [proper-S-pattern @@ -188,6 +133,24 @@ One of @ref[~describe s] or @ref[~describe h]: ] } +@defidform[~commit]{ + +One of @ref[~commit s] or @ref[~commit h]: +@itemize[ +@item{@ref[~commit h] if the subpattern is a @tech{proper @Hpattern}} +@item{@ref[~commit s] otherwise} +] +} + +@defidform[~delimit-cut]{ + +One of @ref[~delimit-cut s] or @ref[~describe h]: +@itemize[ +@item{@ref[~delimit-cut h] if the subpattern is a @tech{proper @Hpattern}} +@item{@ref[~delimit-cut s] otherwise} +] +} + @defidform[~optional]{ One of @ref[~optional h] or @ref[~optional eh]: @@ -289,9 +252,9 @@ like an @tech{annotated pattern variable} with the implicit syntax class inserted. } -@specsubform/subs[(@#,def[~var s+] pvar-id syntax-class) - ([syntax-class syntax-class-id - (syntax-class-id arg-expr ...)])]{ +@specsubform/subs[(@#,def[~var s+] pvar-id syntax-class-use) + ([syntax-class-use syntax-class-id + (syntax-class-id arg ...)])]{ An @deftech{annotated pattern variable}. The pattern matches only terms accepted by @svar[syntax-class-id] (parameterized by the @@ -489,9 +452,11 @@ to have a value if the whole pattern matches. @myexamples[ (syntax-parse #'a - [(~or x:id (~and x #f)) (syntax->datum #'x)]) -(syntax-parse #'#f - [(~or x:id (~and x #f)) (syntax->datum #'x)]) + [(~or x:id y:nat) (values (attribute x) (attribute y))]) +(syntax-parse #'(a 1) + [(~or (x:id y:nat) (x:id)) (values #'x (attribute y))]) +(syntax-parse #'(b) + [(~or (x:id y:nat) (x:id)) (values #'x (attribute y))]) ] } @@ -567,25 +532,49 @@ above). ] } -@specsubform[(@#,def[~describe s] expr S-pattern)]{ +@specsubform/subs[(@#,def[~describe s] maybe-opaque expr S-pattern) + ([maybe-opaque (code:line) + (code:line #:opaque)]) + #:contracts ([expr (or/c string? #f)])]{ The @scheme[~describe] pattern form annotates a pattern with a description, a string expression that is evaluated in the scope of all prior attribute bindings. If parsing the inner pattern fails, then the description is used to synthesize the error message. -A describe-pattern also affects backtracking in two ways: - -@itemize{ - -@item{A cut (@scheme[~!]) within a describe-pattern only -eliminates choice-points created within the describe-pattern.} - -@item{If a describe-pattern succeeds, then all choice points -created within the describe-pattern are discarded, and a failure -@emph{after} the describe-pattern backtracks to a choice point -@emph{before} the describe-pattern, never one @emph{within} it.} +A @scheme[~describe] pattern has no effect on backtracking. } + +@specsubform[(@#,def[~commit s] S-pattern)]{ + +The @scheme[~commit] pattern form affects backtracking in two ways: + +@itemize[ + +@item{If the pattern succeeds, then all choice points created within +the subpattern are discarded, and a failure @emph{after} the +@scheme[~commit] pattern backtracks only to choice points +@emph{before} the @scheme[~commit] pattern, never one @emph{within} +it.} + +@item{A cut (@scheme[~!]) within a @scheme[~commit] pattern only +eliminates choice-points created within the @scheme[~commit] +pattern. In this sense, it acts just like @scheme[~delimit-cut].} +] +} + +@specsubform[(@#,def[~delimit-cut s] S-pattern)]{ + +The @scheme[~delimit-cut] pattern form affects backtracking in the +following way: + +@itemize[ + +@item{A cut (@scheme[~!]) within a @scheme[~delimit-cut] pattern only +eliminates choice-points created within the @scheme[~delimit-cut] +pattern.} + +] } @specsubform[A-pattern]{ @@ -613,9 +602,9 @@ Equivalent to @scheme[(~var pvar-id splicing-syntax-class-id)]. } -@specsubform/subs[(@#,def[~var h] pvar-id splicing-syntax-class) - ([splicing-syntax-class splicing-syntax-class-id - (splicing-syntax-class-id arg-expr ...)])]{ +@specsubform/subs[(@#,def[~var h] pvar-id splicing-syntax-class-use) + ([splicing-syntax-class-use splicing-syntax-class-id + (splicing-syntax-class-id arg ...)])]{ Pattern variable annotated with a @tech{splicing syntax class}. Similar to a normal @tech{annotated pattern variable}, except @@ -624,8 +613,8 @@ matches a head pattern. @specsubform[(@#,defhere[~seq] . L-pattern)]{ -Matches a head whose elements, if put in a list, would match -@scheme[L-pattern]. +Matches a sequence of terms whose elements, if put in a list, would +match @scheme[L-pattern]. @myexamples[ (syntax-parse #'(1 2 3 4) @@ -638,8 +627,8 @@ examples of @scheme[~seq]. @specsubform[(@#,def[~and h] H-pattern ...)]{ -Like the @Spattern version of @scheme[~and], but matches a term head -instead. +Like the @Spattern version, @ref[~and s], but matches a sequence of +terms instead. @myexamples[ (syntax-parse #'(#:a 1 #:b 2 3 4 5) @@ -671,8 +660,8 @@ example with the second @scheme[~seq] omitted: @specsubform[(@#,def[~or h] H-pattern ...)]{ -Like the @Spattern version of @scheme[~or], but matches a term head -instead. +Like the @Spattern version, @ref[~or s], but matches a sequence of +terms instead. @myexamples[ (syntax-parse #'(m #:foo 2 a b c) @@ -689,10 +678,10 @@ instead. (code:line) (code:line #:defaults ([attr-id expr] ...))])]{ -Matches either the given head subpattern or an empty head. If the -@scheme[#:defaults] option is given, the subsequent attribute bindings -are used if the subpattern does not match. The default attributes must -be a subset of the subpattern's attributes. +Matches either the given head subpattern or an empty sequence of +terms. If the @scheme[#:defaults] option is given, the subsequent +attribute bindings are used if the subpattern does not match. The +default attributes must be a subset of the subpattern's attributes. @myexamples[ (syntax-parse #'(m #:foo 2 a b c) @@ -710,13 +699,25 @@ be a subset of the subpattern's attributes. @specsubform[(@#,def[~describe h] expr H-pattern)]{ -Like the @Spattern version of @scheme[~describe], but matches a head +Like the @Spattern version, @ref[~describe s], but matches a head +pattern instead. +} + +@specsubform[(@#,def[~commit h] H-pattern)]{ + +Like the @Spattern version, @ref[~commit s], but matches a head +pattern instead. +} + +@specsubform[(@#,def[~delimit-cut h] H-pattern)]{ + +Like the @Spattern version, @ref[~delimit-cut s], but matches a head pattern instead. } @specsubform[S-pattern]{ -Matches a head of one element, which must be a term matching +Matches a sequence of one element, which must be a term matching @scheme[S-pattern]. } @@ -726,11 +727,11 @@ Matches a head of one element, which must be a term matching @section{Ellipsis-head patterns} An @deftech{@EHpattern} (abbreviated @svar[EH-pattern]) is pattern -that describes some number of terms, like a @tech{@Hpattern}, but may -also place contraints on the number of times it occurs in a -repetition. They are useful for matching keyword arguments where the -keywords may come in any order. Multiple alternatives can be grouped -together via @ref[~or eh]. +that describes some number of terms, like a @tech{@Hpattern}, but also +places contraints on the number of times it occurs in a +repetition. They are useful for matching, for example, keyword +arguments where the keywords may come in any order. Multiple +alternatives are grouped together via @ref[~or eh]. @myexamples[ (define parser1 @@ -754,23 +755,26 @@ Here are the variants of @elem{@EHpattern}: @specsubform[(@#,def[~or eh] EH-pattern ...)]{ Matches if any of the inner @scheme[EH-pattern] alternatives match. - } @specsubform/subs[(@#,defhere[~once] H-pattern once-option ...) ([once-option (code:line #:name name-expr) (code:line #:too-few too-few-message-expr) - (code:line #:too-many too-many-message-expr)])]{ + (code:line #:too-many too-many-message-expr)]) + #:contracts ([name-expr (or/c string? #f)] + [too-few-message-expr (or/c string? #f)] + [too-many-message-expr (or/c string? #f)])]{ Matches if the inner @scheme[H-pattern] matches. This pattern must be -selected exactly once in the match of the entire repetition sequence. +matched exactly once in the match of the entire repetition sequence. -If the pattern is not chosen in the repetition sequence, then an error -is raised with the message either @scheme[too-few-message-expr] or -@schemevalfont{"missing required occurrence of @scheme[name-expr]"}. +If the pattern is not matched in the repetition sequence, then the +ellipsis pattern fails with the message either +@scheme[too-few-message-expr] or @schemevalfont{"missing required +occurrence of @scheme[name-expr]"}. If the pattern is chosen more than once in the repetition sequence, -then an error is raised with the message either +then the ellipsis pattern fails with the message either @scheme[too-many-message-expr] or @schemevalfont{"too many occurrences of @scheme[name-expr]"}. } @@ -778,13 +782,15 @@ of @scheme[name-expr]"}. @specsubform/subs[(@#,def[~optional eh] H-pattern optional-option ...) ([optional-option (code:line #:name name-expr) (code:line #:too-many too-many-message-expr) - (code:line #:defaults ([attr-id expr] ...))])]{ + (code:line #:defaults ([attr-id expr] ...))]) + #:contracts ([name-expr (or/c string? #f)] + [too-many-message-expr (or/c string? #f)])]{ Matches if the inner @scheme[H-pattern] matches. This pattern may be used at most once in the match of the entire repetition. -If the pattern is chosen more than once in the repetition sequence, -then an error is raised with the message either +If the pattern is matched more than once in the repetition sequence, +then the ellipsis pattern fails with the message either @scheme[too-many-message-expr] or @schemevalfont{"too many occurrences of @scheme[name-expr]"}. @@ -797,18 +803,20 @@ attributes. @specsubform/subs[(@#,defhere[~between] H-pattern min-number max-number between-option ...) ([reps-option (code:line #:name name-expr) (code:line #:too-few too-few-message-expr) - (code:line #:too-many too-many-message-expr)])]{ + (code:line #:too-many too-many-message-expr)]) + #:contracts ([name-expr (or/c syntax? #f)] + [too-few-message-expr (or/c syntax? #f)])]{ Matches if the inner @scheme[H-pattern] matches. This pattern must be -selected at least @scheme[min-number] and at most @scheme[max-number] +matched at least @scheme[min-number] and at most @scheme[max-number] times in the entire repetition. -If the pattern is chosen too few times, then an error is raised with a -message, either @scheme[too-few-message-expr] or @schemevalfont{"too -few occurrences of @scheme[name-expr]"}. +If the pattern is matched too few times, then the ellipsis pattern +fails with the message either @scheme[too-few-message-expr] or +@schemevalfont{"too few occurrences of @scheme[name-expr]"}. -If the pattern is chosen too many times, then an error is raised with -the message either @scheme[too-many-message-expr] or +If the pattern is chosen too many times, then the ellipsis pattern +fails with the message either @scheme[too-many-message-expr] or @schemevalfont{"too few occurrences of @scheme[name-expr]"}. } @@ -822,11 +830,6 @@ An @deftech{@Apattern} (abbreviated @svar[A-pattern]) does not describe any syntax; rather, it has an effect such as the binding of attributes or the modification of the matching process. -The grammar describing where an @Apattern may occur may look -complicated, but the essence is this: ``@Apatterns don't take up -space.'' They can be freely added to a list pattern or inserted into -an @scheme[~and] pattern. - @specsubform[@#,defhere[~!]]{ The @deftech{cut} operator, written @scheme[~!], eliminates @@ -848,7 +851,7 @@ expression tries the first clause, fails to match @scheme[a] against the pattern @scheme[(x:id ...)], and then backtracks to the second clause and ultimately the third clause, producing the value @scheme['expression]. But the term is not an expression; it is an -ill-formed use of @scheme[define-values]! The proper way to write the +ill-formed use of @scheme[define-values]. The proper way to write the @scheme[syntax-parse] expression follows: @interaction[#:eval the-eval @@ -865,10 +868,12 @@ points for the second and third clauses. So when the clause fails to match, the @scheme[syntax-parse] expression raises an error. The effect of a @scheme[~!] pattern is delimited by the nearest -enclosing @scheme[~describe] pattern. If there is no enclosing -@scheme[~describe] pattern but the cut occurs within a syntax class -definition, then only choice points within the syntax class definition -are discarded. +enclosing @scheme[~delimit-cut] or @scheme[~commit] pattern. If there +is no enclosing @scheme[~describe] pattern but the cut occurs within a +syntax class definition, then only choice points within the syntax +class definition are discarded. A @scheme[~!] pattern is not allowed +within a @scheme[~not] pattern unless there is an intervening +@scheme[~delimit-cut] or @scheme[~commit] pattern. } @specsubform[(@#,defhere[~bind] [attr-id expr] ...)]{ @@ -877,19 +882,23 @@ Evaluates the @scheme[expr]s and binds them to the given @scheme[attr-id]s as attributes. } -@specsubform/subs[(@#,defhere[~fail] maybe-fail-condition message-expr) +@specsubform/subs[(@#,defhere[~fail] maybe-fail-condition maybe-message-expr) ([maybe-fail-condition (code:line) (code:line #:when condition-expr) - (code:line #:unless condition-expr)])]{ + (code:line #:unless condition-expr)] + [maybe-message-expr (code:line) + (code:line message-expr)]) + #:contracts ([message-expr (or/c string? #f)])]{ -If the condition is absent, or if the @scheme[#:when] -condition evaluates to a true value, or if the @scheme[#:unless] -condition evaluates to @scheme[#f], then the pattern fails with the -given message. +If the condition is absent, or if the @scheme[#:when] condition +evaluates to a true value, or if the @scheme[#:unless] condition +evaluates to @scheme[#f], then the pattern fails with the given +message. If the message is omitted, the default value @scheme[#f] is +used, representing ``no message.'' Fail patterns can be used together with cut patterns to recognize -specific ill-formed terms and address them with specially-created -failure messages. +specific ill-formed terms and address them with custom failure +messages. } @specsubform[(@#,defhere[~parse] S-pattern stx-expr) diff --git a/collects/tests/stxparse/litset-phases.rkt b/collects/tests/stxparse/litset-phases.rkt new file mode 100644 index 0000000000..abcd9ee7c1 --- /dev/null +++ b/collects/tests/stxparse/litset-phases.rkt @@ -0,0 +1,21 @@ +#lang racket/load + +(module a racket + (require syntax/parse) + (define-literal-set lits (begin)) + (provide lits)) + +(module b racket + (require (for-syntax 'a syntax/parse)) + (require (for-syntax syntax/parse/private/runtime)) + (define-syntax (snarf stx) + ;;(printf "slpl of snarf: ~s\n" (syntax-local-phase-level)) + (syntax-parse stx + #:literal-sets (lits) + [(snarf (begin e)) #'e])) + (provide snarf)) + +(module c racket + (require (for-syntax 'b racket/base)) + (begin-for-syntax + (displayln (snarf (begin 5))))) diff --git a/collects/tests/stxparse/select.rkt b/collects/tests/stxparse/select.rkt index e4598fb063..3ea559f0c4 100644 --- a/collects/tests/stxparse/select.rkt +++ b/collects/tests/stxparse/select.rkt @@ -22,14 +22,14 @@ (escape exn)) (lambda () (syntax-parse (quote-syntax s) - [p 'ok] ...))))]) + [p (void)] ...))))]) (let ([msg (exn-message exn)] [stxs (and (exn:fail:syntax? exn) (exn:fail:syntax-exprs exn))]) (when 'term (check-equal? (and (pair? stxs) (syntax->datum (car stxs))) 'term)) (erx rx (exn-message exn)) ... #t)) - 'ok)])) + (void))])) (define-syntax erx (syntax-rules (not) @@ -40,6 +40,12 @@ ;; ---- +(terx (a b c 7) (x:id ...) + #:term 7 + #rx"expected identifier") + +;; ---- + (terx* (1 2) [x:nat (y:id z:id)] #:term 1 #rx"expected identifier") @@ -86,3 +92,19 @@ (~optional b:B #:name "B clause")) ...) #rx"unexpected term") + +;; Ellipses + +(terx (a b c 4) + (x:id ...) + #rx"expected identifier") + +;; Repetition constraints + +(terx (1 2) + ((~or (~once x:id #:name "identifier") n:nat) ...) + #rx"missing required occurrence of identifier") + +(terx (1 a 2 b) + ((~or (~once x:id #:name "identifier") n:nat) ...) + #rx"too many occurrences of identifier") diff --git a/collects/tests/stxparse/setup.rkt b/collects/tests/stxparse/setup.rkt new file mode 100644 index 0000000000..5625430d55 --- /dev/null +++ b/collects/tests/stxparse/setup.rkt @@ -0,0 +1,131 @@ +#lang racket/base +(require rackunit + syntax/parse + syntax/parse/private/rep-attrs + (only-in syntax/parse/private/runtime attribute-binding) + (for-syntax racket/base)) + +(provide tok + terx + terx* + tcerr + + bound + s= + a= + convert-syntax-error) + +#| +Testing forms +------------- + +(tok stx-template pattern [#:pre pre-pattern ...] [#:post post-pattern ...]) +-- pattern should succeed parsing stx (pre and post patterns should fail) + +(terx stx-template pattern ErrorPattern ...) +(terx* stx-template (pattern ...) ErrorPattern ...) + where ErrorPattern is regexp | (not regexp) +-- pattern should fail with exn message matching every ErrorPattern + +(tcerr tc-name-expr expr ErrorPattern ...) +-- delays syntax errors in expr until runtime, error msg must every pattern + + +Auxiliaries +----------- + +(bound (name depth [syntax?]) ...) +-- checks that name is an attr w/ proper depth and syntax? + +(s= stx-template sexpr) +-- checks that stx-template produces stx w/ datum equivalent to sexpr + +(a= attr expr) +-- checks that attr has value equal to expr + +|# + +;; tok = test pattern ok +(define-syntax tok + (syntax-rules () + [(tok s p expr #:pre [pre-p ...] #:post [post-p ...]) + (test-case (format "line ~s: ~s match ~s" + (syntax-line (quote-syntax s)) + 's 'p) + (syntax-parse (quote-syntax s) + [pre-p (error 'wrong-pattern "~s" 'pre-p)] ... + [p expr] + [post-p (error 'wrong-pattern "~s" 'post-p)] ...) + (void))] + [(tok s p expr) + (tok s p expr #:pre () #:post ())] + [(tok s p) + (tok s p 'ok)])) + +(define-syntax-rule (bound b ...) + (begin (bound1 b) ...)) + +(define-syntax bound1 + (syntax-rules () + [(bound1 (name depth)) + (let ([a (attribute-binding name)]) + (check-pred attr? a) + (when (attr? a) + (check-equal? (attr-depth a) 'depth)))] + [(bound1 (name depth syntax?)) + (let ([a (attribute-binding name)]) + (check-pred attr? a) + (when (attr? a) + (check-equal? (attr-depth a) 'depth) + (check-equal? (attr-syntax? a) 'syntax?)))])) + +(define-syntax-rule (s= t v) + (check-equal? (syntax->datum #'t) v)) + +(define-syntax-rule (a= a v) + (check-equal? (attribute a) v)) + +(define-syntax-rule (terx s p rx ...) + (terx* s [p] rx ...)) + +(define-syntax terx* + (syntax-rules () + [(terx s [p ...] rx ...) + (test-case (format "line ~s: ~a match ~s for error" + (syntax-line (quote-syntax s)) + 's '(p ...)) + (check-exn (lambda (exn) + (erx rx (exn-message exn)) ... #t) + (lambda () + (syntax-parse (quote-syntax s) + [p 'ok] ...))) + (void))])) + +(define-syntax erx + (syntax-rules (not) + [(erx (not rx) msg) + (check (compose not regexp-match?) rx msg)] + [(erx rx msg) + (check regexp-match? rx msg)])) + +;; ==== + +(define-syntax-rule (tcerr name expr rx ...) + (test-case name + (check-exn (lambda (exn) + (define msg (exn-message exn)) + (erx rx msg) ... + #t) + (lambda () + (parameterize ((error-print-source-location #f)) + (convert-syntax-error expr)))) + (void))) + +(define-syntax (convert-syntax-error stx) + (syntax-case stx () + [(_ expr) + (with-handlers ([exn:fail:syntax? + (lambda (e) + #`(error '#,(exn-message e)))]) + (parameterize ((error-print-source-location #f)) + (local-expand #'expr 'expression null)))])) diff --git a/collects/tests/stxparse/stress.rkt b/collects/tests/stxparse/stress.rkt new file mode 100644 index 0000000000..c3833b136d --- /dev/null +++ b/collects/tests/stxparse/stress.rkt @@ -0,0 +1,248 @@ +(begin + (require syntax/parse) + (define (mkstx n) (datum->syntax #f (for/list ([i (in-range n)]) #'hello))) + + (define stx1 (mkstx 10)) + (define stx2 (mkstx 100)) + (define stx3 (mkstx 1000)) + (define stx4 (mkstx 10000)) + + (define bad-stx (datum->syntax #f (append (for/list ([i (in-range 10000)]) #'hello) (list #'#f)))) + (define-syntax-class plain-id + #:attributes () + (pattern x #:when (identifier? #'x))) + (define-syntax-class commit-id #:commit + #:attributes () + (pattern x #:when (identifier? #'x))) + (define (parse/id x n) + (for ([i (in-range n)]) + (syntax-parse x [(z:id ...) 'ok] [_ 'bad!]))) + (define (parse/plain-id x n) + (for ([i (in-range n)]) + (syntax-parse x [(z:plain-id ...) 'ok] [_ 'bad!]))) + (define (parse/commit-id x n) + (for ([i (in-range n)]) + (syntax-parse x [(z:commit-id ...) 'ok] [_ 'bad!]))) + (define (parse/listpred x n) + (for ([i (in-range n)]) + (syntax-case x () + [(x ...) (andmap identifier? (syntax->list #'(x ...))) 'ok] + [_ 'bad!]))) + (define (parse/pred x n) + (for ([i (in-range n)]) + (let loop ([x x]) + (syntax-case x () + [(x . y) (identifier? #'x) (loop #'y)] + [() 'ok]))))) + +(begin + (define (stx->list1 x) + (cond [(syntax? x) + (stx->list1 (syntax-e x))] + [(pair? x) + (cons (car x) (stx->list1 (cdr x)))] + [(null? x) + null])) + (define (stx->list2 x) + (let ([d (syntax-e x)]) + (cond [(pair? d) + (cons (car d) (stx->list2 (datum->syntax x (cdr d) x)))] + [(null? d) + null]))) + (define (stx->list3 x) + (cond [(syntax? x) + (stx->list3 (syntax-e x))] + [(box? x) + (stx->list3 (unbox x))] + [(pair? x) + (cons (car x) (stx->list3 (box (cdr x))))] + [(null? x) + null]))) + +#| +> (time (parse/id stx 10)) +cpu time: 2829 real time: 2826 gc time: 20 +> (time (parse/plain-id stx 10)) +cpu time: 3072 real time: 3090 gc time: 40 +> (time (parse/commit-id stx 10)) +cpu time: 3076 real time: 3125 gc time: 24 +> (time (parse/listpred stx 10)) +cpu time: 4 real time: 7 gc time: 0 + +> (time (parse/pred stx 10)) +cpu time: 2760 real time: 2757 gc time: 8 +> (collect-garbage) +> (collect-garbage) +> (time (parse/pred stx 10)) +cpu time: 2808 real time: 2813 gc time: 64 +> (collect-garbage) +> (collect-garbage) +> (time (parse/id stx 10)) +cpu time: 2880 real time: 2876 gc time: 84 +> (time (parse/id stx 10)) +cpu time: 2821 real time: 2810 gc time: 8 +> (time (parse/id stx 10)) +cpu time: 2816 real time: 2812 gc time: 16 +> (time (parse/plain-id stx 10)) +cpu time: 2912 real time: 2906 gc time: 24 +> (time (parse/plain-id stx 10)) +cpu time: 2908 real time: 2910 gc time: 24 +> (time (parse/plain-id stx 10)) +cpu time: 3128 real time: 3144 gc time: 32 +> (time (parse/plain-id stx 10)) +cpu time: 2925 real time: 2922 gc time: 36 +> (time (parse/plain-id stx 10)) +cpu time: 2908 real time: 2901 gc time: 12 +|# + + + +given pattern (E ...) where E = A _ | A +the sequence (A A B A A B A A B ...) +causes each E to backtrack + +(begin + (define-syntax-class id/nat + #:attributes () + (pattern x:id) + (pattern n:nat)) + (define-splicing-syntax-class trip + #:attributes () + (pattern (~seq #:a _)) + (pattern (~seq #:a))) + (define (mktripstx n) + (apply append (for/list ([i (in-range n)]) (list #'#:a #'#:a #'#:b)))) + (define tripstx3 (mktripstx 1000)) + (define tripstx4 (mktripstx 10000)) + (define (parse/trip x n) + (for ([i (in-range n)]) + (syntax-parse x + [(t:trip ...) 'ok]))) + + (define (mknatstx n) + (datum->syntax #f (for/list ([i (in-range n)]) (add1 i)))) + (define (solve n rep) + (let ([stx (mknatstx n)]) + (for ([i (in-range rep)]) + (syntax-parse stx + [((~or x:nat y:nat) ...) + #:when (= (apply + (syntax->datum #'(x ...))) + (apply + (syntax->datum #'(y ...)))) + (syntax->datum #'(y ...))]))))) + +;; (solve 35 _) and (solve 36 _) seem manageable + +#| before markparams |# + +> (time (parse/trip tripstx3 100)) +cpu time: 812 real time: 817 gc time: 92 +> (time (parse/trip tripstx3 100)) +cpu time: 788 real time: 791 gc time: 76 +> (time (parse/trip tripstx3 100)) +cpu time: 772 real time: 774 gc time: 52 +> (time (parse/trip tripstx4 10)) +cpu time: 1148 real time: 1147 gc time: 436 +> (time (parse/trip tripstx4 10)) +cpu time: 1368 real time: 1385 gc time: 520 +> (time (parse/trip tripstx4 10)) +cpu time: 1240 real time: 1240 gc time: 516 + +> (time (solve 35 20)) +cpu time: 1572 real time: 1568 gc time: 332 +> (time (solve 35 20)) +cpu time: 1548 real time: 1551 gc time: 304 +> (time (solve 35 20)) +cpu time: 1548 real time: 1548 gc time: 304 +> (time (solve 36 20)) +cpu time: 716 real time: 714 gc time: 80 +> (time (solve 36 20)) +cpu time: 704 real time: 703 gc time: 64 +> (time (solve 36 20)) +cpu time: 700 real time: 701 gc time: 72 + + +#| with partial defunctionalization (failures-so-far) |# + +> (time (parse/trip tripstx3 100)) +cpu time: 1932 real time: 1933 gc time: 88 +> (time (parse/trip tripstx3 100)) +cpu time: 1900 real time: 1903 gc time: 76 +> (time (parse/trip tripstx3 100)) +cpu time: 2052 real time: 2052 gc time: 224 +> (time (parse/trip tripstx4 10)) +cpu time: 2536 real time: 2535 gc time: 708 +> (time (parse/trip tripstx4 10)) +cpu time: 2620 real time: 2622 gc time: 756 +> (time (parse/trip tripstx4 10)) +cpu time: 2372 real time: 2372 gc time: 556 + +> (time (solve 35 20)) +cpu time: 3409 real time: 3404 gc time: 340 +> (time (solve 35 20)) +cpu time: 3244 real time: 3244 gc time: 312 +> (time (solve 35 20)) +cpu time: 3240 real time: 3242 gc time: 312 +> (time (solve 36 20)) +cpu time: 1588 real time: 1589 gc time: 76 +> (time (solve 36 20)) +cpu time: 1576 real time: 1579 gc time: 64 +> (time (solve 36 20)) +cpu time: 1580 real time: 1575 gc time: 52 + + +#| with failure function as markparam |# + +> (time (parse/trip tripstx3 100)) +cpu time: 1840 real time: 1843 gc time: 116 +> (time (parse/trip tripstx3 100)) +cpu time: 1792 real time: 1789 gc time: 48 +> (time (parse/trip tripstx3 100)) +cpu time: 1956 real time: 1960 gc time: 228 +> (time (parse/trip tripstx4 10)) +cpu time: 2352 real time: 2353 gc time: 608 +> (time (parse/trip tripstx4 10)) +cpu time: 2488 real time: 2495 gc time: 748 +> (time (parse/trip tripstx4 10)) +cpu time: 2416 real time: 2415 gc time: 684 + +> (time (solve 35 20)) +cpu time: 3205 real time: 3201 gc time: 324 +> (time (solve 35 20)) +cpu time: 3208 real time: 3203 gc time: 316 +> (time (solve 35 20)) +cpu time: 3048 real time: 3050 gc time: 184 +> (time (solve 36 20)) +cpu time: 1692 real time: 1695 gc time: 208 +> (time (solve 36 20)) +cpu time: 1564 real time: 1566 gc time: 84 +> (time (solve 36 20)) +cpu time: 1540 real time: 1542 gc time: 64 + + +#| with fail & cut-prompt as stxparams |# + +> (time (parse/trip tripstx3 100)) +cpu time: 532 real time: 534 gc time: 68 +> (time (parse/trip tripstx3 100)) +cpu time: 524 real time: 524 gc time: 48 +> (time (parse/trip tripstx3 100)) +cpu time: 656 real time: 657 gc time: 168 +> (time (parse/trip tripstx4 10)) +cpu time: 992 real time: 993 gc time: 512 +> (time (parse/trip tripstx4 10)) +cpu time: 860 real time: 861 gc time: 380 +> (time (parse/trip tripstx4 10)) +cpu time: 1004 real time: 999 gc time: 516 + +> (time (solve 35 20)) +cpu time: 1132 real time: 1129 gc time: 140 +> (time (solve 35 20)) +cpu time: 1320 real time: 1316 gc time: 340 +> (time (solve 35 20)) +cpu time: 1300 real time: 1299 gc time: 296 +> (time (solve 36 20)) +cpu time: 588 real time: 588 gc time: 76 +> (time (solve 36 20)) +cpu time: 580 real time: 584 gc time: 68 +> (time (solve 36 20)) +cpu time: 580 real time: 586 gc time: 56 diff --git a/collects/tests/stxparse/stxclass.rkt b/collects/tests/stxparse/stxclass.rkt index 0b0fdb40f3..b64a984b9c 100644 --- a/collects/tests/stxparse/stxclass.rkt +++ b/collects/tests/stxparse/stxclass.rkt @@ -1,15 +1,11 @@ #lang scheme/base - (require rackunit syntax/parse + syntax/parse/debug (for-syntax scheme/base syntax/parse)) ;; Testing stuff -(define-namespace-anchor anchor) -(define tns (namespace-anchor->namespace anchor)) -(define (teval expr) (eval expr tns)) - (define-syntax-rule (stx-like? expr template) (equal? (stx->datum expr) 'template)) @@ -88,9 +84,9 @@ (check-equal? (vector-ref rec 1) (cadr ex)) (check-equal? (stx->datum (vector-ref rec 2)) (caddr ex))))))) -(define-syntax-rule (test-patterns pattern stx . body) +(define-syntax-rule (test-patterns pattern stx body ...) (test-case (format "~s" 'pattern) - (syntax-parse stx [pattern . body]))) + (syntax-parse stx [pattern body ... (void)]))) ;; Tests @@ -127,11 +123,12 @@ (~once 2) (~once 3)} ...) #'(1 2 3) - 'ok) + (void)) (test-patterns ({~or a:id b:nat c:str} ...) #'("one" 2 three) (check-equal? (stx->datum #'(a ...)) '(three)) (check-equal? (stx->datum #'(b ...)) '(2)) - (check-equal? (stx->datum #'(c ...)) '("one"))) + (check-equal? (stx->datum #'(c ...)) '("one")) + (void)) (test-patterns ({~or (~once 1) (~once 2) (~once 3) @@ -143,13 +140,15 @@ (check-equal? (sort (map symbol->string (stx->datum #'(x y w))) stringdatum #'(x ...)) '(x y z))) + (check-equal? (stx->datum #'(x ...)) '(x y z)) + (void)) ))) (define-syntax-class bindings @@ -169,19 +168,22 @@ (loop ns -inf.0)) (define-syntax-class Opaque + #:opaque (pattern (a:id n:nat))) (define-syntax-class Transparent - #:transparent (pattern (a:id n:nat))) +#| (with-handlers ([exn? exn-message]) - (syntax-parse #'(0 1) [_:Opaque 'ok])) + (syntax-parse #'(0 1) [_:Opaque (void)])) (with-handlers ([exn? exn-message]) - (syntax-parse #'(0 1) [_:Transparent 'ok])) + (syntax-parse #'(0 1) [_:Transparent (void)])) +|# (syntax-parse #'(+) #:literals ([plus +]) [(plus) (void)]) + (define-syntax-class (Nat> n) #:description (format "Nat > ~s" n) (pattern x:nat #:fail-unless (> (syntax-e #'x) n) #f)) @@ -192,44 +194,3 @@ #:with c #'c0 #:declare c (Nat> (syntax-e #'b0)) (void)]) - -(define-syntax-class (nat> bound) - #:opaque - #:description (format "natural number greater than ~s" bound) - (pattern n:nat - #:when (> (syntax-e #'n) bound))) - -(define-conventions nat-convs - [N (nat> 0)]) - -(syntax-parse #'(5 4) #:conventions (nat-convs) - [(N ...) (void)]) - -(let/ec escape - (with-handlers ([exn? (compose escape void)]) - (syntax-parse #'(4 -1) #:conventions (nat-convs) - [(N ...) (void)])) - (error 'test-conv1 "didn't work")) - -;; Local conventions - -(define-syntax-class (nats> bound) - #:local-conventions ([N (nat> bound)]) - (pattern (N ...))) - -(define (p1 bound x) - (syntax-parse x - #:local-conventions ([ns (nats> bound)]) - [ns 'yes] - [_ 'no])) - -(eq? (p1 0 #'(1 2 3)) 'yes) -(eq? (p1 2 #'(1 2 3)) 'no) - -;; Regression (2/2/2010) - -(define-splicing-syntax-class twoseq - (pattern (~seq a b))) - -(syntax-parse #'(1 2 3 4) - [(x:twoseq ...) 'ok]) diff --git a/collects/tests/stxparse/more-tests.rkt b/collects/tests/stxparse/test-errors.rkt similarity index 74% rename from collects/tests/stxparse/more-tests.rkt rename to collects/tests/stxparse/test-errors.rkt index 6af2f73fbb..c238bf8be9 100644 --- a/collects/tests/stxparse/more-tests.rkt +++ b/collects/tests/stxparse/test-errors.rkt @@ -1,67 +1,16 @@ #lang scheme (require syntax/parse - rackunit) + syntax/parse/debug + rackunit + "setup.rkt") (require (for-syntax syntax/parse)) -(define-syntax (convert-syntax-error stx) - (syntax-case stx () - [(_ expr) - (with-handlers ([exn:fail:syntax? - (lambda (e) - #`(error '#,(exn-message e)))]) - (local-expand #'expr 'expression null))])) - -(define-syntax-rule (tcerr name expr erx ...) - (test-case name - (check-exn (lambda (exn) - (define msg (exn-message exn)) - (check regexp-match? erx msg) ... - #t) - (lambda () (convert-syntax-error expr))))) - -;; Test #:auto-nested-attributes - -(define-syntax-class two - (pattern (x y))) - -(define-syntax-class square0 - (pattern (x:two y:two))) - -(define-syntax-class square - #:auto-nested-attributes - (pattern (x:two y:two))) - -(test-case "nested attributes omitted by default" - (check-equal? (syntax-class-attributes square0) - '((x 0) (y 0)))) - -(test-case "nested attributes work okay" - (check-equal? (syntax-class-attributes square) - '((x 0) (x.x 0) (x.y 0) (y 0) (y.x 0) (y.y 0)))) - -;; Test static-of - -(define-syntax zero 0) -(define-syntax (m stx) - (syntax-parse stx - [(_ x) - #:declare x (static number? "identifier bound to number") - #`(quote #,(attribute x.value))])) - -(tcerr "static: right error" - (m twelve) - #rx"identifier bound to number") - -(test-case "static: works" - (check-equal? (convert-syntax-error (m zero)) - 0)) - ;; Error message tests (tcerr "define-conventions non id" (let () (define-conventions "foo") 0) #rx"^define-conventions: " - #rx"expected identifier") + #rx"expected name or name with formal parameters") (tcerr "define-literal-set non id" (let () (define-literal-set "foo" (+ -)) 0) @@ -78,6 +27,16 @@ #rx"^define-splicing-syntax-class: " #rx"expected at least one variant") +(tcerr "parse-rhs: commit and not delimit-cut" + (let () + (define-syntax-class foo + #:commit + #:no-delimit-cut + (pattern x)) + 0) + #rx"^define-syntax-class: " + #rx"not allowed after") + (tcerr "parse-rhs: incompatible attrs flags" (let () (define-syntax-class foo @@ -101,12 +60,12 @@ (tcerr "check-literals-bound: unbound literal" (let () (define-literal-set x (foo)) 0) #rx"^define-literal-set: " - #rx"unbound identifier not allowed as literal") + #rx"literal is unbound in phase 0") (tcerr "check-literals-bound: unbound literal" (syntax-parse #'x #:literals (define defunky) [_ 'ok]) #rx"^syntax-parse: " - #rx"unbound identifier not allowed as literal") + #rx"literal is unbound in phase 0") (tcerr "append-lits+litsets: duplicate" (let () @@ -178,12 +137,6 @@ #rx"^syntax-parser: " #rx"expected at least one pattern") -(tcerr "parse-pat:fail: missing message" - (syntax-parser - [(~fail) 'ok]) - #rx"^syntax-parser: " - #rx"missing message expression") - (tcerr "parse-pat:fail: bad" (syntax-parser [(~fail . x) 'ok]) diff --git a/collects/tests/stxparse/test-exp.rkt b/collects/tests/stxparse/test-exp.rkt new file mode 100644 index 0000000000..824bdf86a6 --- /dev/null +++ b/collects/tests/stxparse/test-exp.rkt @@ -0,0 +1,79 @@ +#lang racket +(require rackunit + syntax/parse + syntax/parse/debug + syntax/parse/experimental/reflect + syntax/parse/experimental/splicing + syntax/parse/experimental/eh + "setup.rkt" + (for-syntax syntax/parse)) + +;; Reflection + +(define-syntax-class (nat> x) + #:description (format "natural number greater than ~s" x) + (pattern n:nat + #:when (> (syntax-e #'n) x) + #:with diff (- (syntax-e #'n) x))) +(define r-nat> (reify-syntax-class nat>)) + +(tok (1 2 -3 -4 5) ((~or (~reflect yes (r-nat> 1) #:attributes (diff)) no) ...) + (and (s= (yes ...) '(2 5)) + (s= (yes.diff ...) '(1 4)) + (s= (no ...) '(1 -3 -4)))) +(terx 3 (~reflect pos (r-nat> 5)) + #rx"expected natural number greater than 5") +(terx whatever (~reflect x (r-nat> 0) #:attributes (wrong nope))) + +(define-splicing-syntax-class opt + (pattern (~seq #:a a:expr))) +(define r-opt (reify-syntax-class opt)) + +(tok (#:a 1) ((~splicing-reflect s (r-opt) #:attributes (a))) + (s= s.a '1)) +(tok (#:a 1 #:a 2 #:a 3) ((~splicing-reflect s (r-opt) #:attributes (a)) ...) + (s= (s.a ...) '(1 2 3))) + + +;; EH-alternative-sets + +(define-eh-alternative-set opts + (pattern (~once (~seq #:a a:expr) #:name "A option")) + (pattern (~seq #:b b:expr))) + +(tok (#:a 1) ((~eh-var s opts) ...) + (and (s= s.a 1) (s= (s.b ...) '()))) +(tok (#:a 1 #:b 2 #:b 3) ((~eh-var s opts) ...) + (and (s= s.a 1) (s= (s.b ...) '(2 3)))) + +(terx (#:b 2 #:b 3) ((~eh-var s opts) ...) + #rx"missing required occurrence of A option") +(terx (#:a 1 #:a 2) ((~eh-var s opts) ...) + #rx"too many occurrences of A option") + +(define-eh-alternative-set extopts + (pattern (~eh-var s opts)) + (pattern (~seq #:c c1:expr c2:expr))) + +(tok (#:a 1 #:c 2 3 #:c 4 5) ((~eh-var x extopts) ...) + (and (s= x.s.a 1) (s= (x.s.b ...) '()) + (s= ((x.c1 x.c2) ...) '((2 3) (4 5))))) +(terx (#:c 1 2) ((~eh-var x extopts) ...) + #rx"missing required occurrence of A option") + +;; Splicing + +(define-primitive-splicing-syntax-class (foo) + #:attrs (z x y) + #:description "foo" + (lambda (stx fail) + (syntax-case stx () + [(a b c . rest) + (list #'rest 3 #'a #'b #'c)] + [_ (fail)]))) + +(tok (1 2 3 4) (f:foo 4) + (and (s= f.z 1) (s= f.x 2) (s= f.y 3))) + +(terx (1) (f:foo) + #rx"expected foo") diff --git a/collects/tests/stxparse/test.rkt b/collects/tests/stxparse/test.rkt index 4409ccec00..37d1de34c4 100644 --- a/collects/tests/stxparse/test.rkt +++ b/collects/tests/stxparse/test.rkt @@ -1,72 +1,11 @@ -#lang scheme -(require syntax/parse - syntax/private/stxparse/rep-attrs - syntax/private/stxparse/runtime) -(require rackunit) - -;; tok = test pattern ok -(define-syntax tok - (syntax-rules () - [(tok s p expr #:pre [pre-p ...] #:post [post-p ...]) - (test-case (format "line ~s: ~s match ~s" - (syntax-line (quote-syntax s)) - 's 'p) - (syntax-parse (quote-syntax s) - [pre-p (error 'wrong-pattern "~s" 'pre-p)] ... - [p expr] - [post-p (error 'wrong-pattern "~s" 'post-p)] ...) - (void))] - [(tok s p expr) - (tok s p expr #:pre () #:post ())] - [(tok s p) - (tok s p 'ok)])) - -(define-syntax-rule (bound b ...) - (begin (bound1 b) ...)) - -(define-syntax bound1 - (syntax-rules () - [(bound1 (name depth)) - (let ([a (attribute-binding name)]) - (check-pred attr? a) - (when (attr? a) - (check-equal? (attr-depth a) 'depth)))] - [(bound1 (name depth syntax?)) - (let ([a (attribute-binding name)]) - (check-pred attr? a) - (when (attr? a) - (check-equal? (attr-depth a) 'depth) - (check-equal? (attr-syntax? a) 'syntax?)))])) - -(define-syntax-rule (s= t v) - (check-equal? (syntax->datum #'t) v)) - -(define-syntax-rule (a= a v) - (check-equal? (attribute a) v)) - -(define-syntax-rule (terx s p rx ...) - (terx* s [p] rx ...)) - -(define-syntax terx* - (syntax-rules () - [(terx s [p ...] rx ...) - (test-case (format "line ~s: ~a match ~s for error" - (syntax-line (quote-syntax s)) - 's '(p ...)) - (check-exn (lambda (exn) - (erx rx (exn-message exn)) ... #t) - (lambda () - (syntax-parse (quote-syntax s) - [p 'ok] ...))) - (void))])) - -(define-syntax erx - (syntax-rules (not) - [(erx (not rx) msg) - (check (compose not regexp-match?) rx msg)] - [(erx rx msg) - (check regexp-match? rx msg)])) +#lang racket +(require rackunit + syntax/parse + syntax/parse/debug + "setup.rkt" + (for-syntax syntax/parse)) +;; Main syntax class and pattern tests ;; ======== @@ -77,9 +16,6 @@ ;; ======== - -;; == Parsing tests - ;; -- S patterns ;; name patterns (tok 1 a @@ -131,14 +67,17 @@ (terx (1 2) (1 1) "literal 1") ;; literal patterns -(syntax-parse #'+ #:literals (+ -) - [+ (void)]) -(syntax-parse #'+ #:literals (+ -) - [- (error 'wrong)] - [+ (void)]) -(syntax-parse #'+ #:literals (+ -) - [+ (void)] - [_ (error 'wrong)]) +(test-case "literals: +" + (syntax-parse #'+ #:literals (+ -) + [+ (void)])) +(test-case "literals: - +" + (syntax-parse #'+ #:literals (+ -) + [- (error 'wrong)] + [+ (void)])) +(test-case "literals: + _" + (syntax-parse #'+ #:literals (+ -) + [+ (void)] + [_ (error 'wrong)])) ;; compound patterns (tok (a b c) (x y z) @@ -151,9 +90,16 @@ (and (bound (x 0) (y 0) (z 0)) (s= x 'a) (s= y 'b))) (tok #(a b c) #(x y z) (and (bound (x 0) (y 0) (z 0)) (s= x 'a) (s= y 'b))) +(tok #(1 2 3 4 5) #(a b ~rest c) + (s= c '(3 4 5))) (tok #&1 #&x (and (bound (x 0)) (s= x 1))) +(tok #s(foo 1 2) #s(foo a b) + (and (s= a 1) (s= b 2))) +(tok #s(foo 1 2 3 4 5) #s(foo a b ~rest c) + (s= c '(3 4 5))) + ;; head patterns ;; See H-patterns @@ -174,6 +120,9 @@ (tok (1 2 3) (~and (x _ _) (_ y _) (_ _ z)) (and (bound (x 0) (y 0) (z 0)))) +;; and scoping +(tok 1 (~and a (~fail #:unless (equal? (syntax->datum #'a) 1)))) + ;; or patterns (tok 1 (~or 1 2 3) 'ok) @@ -190,6 +139,15 @@ (tok #t (~or (~and #t x) (~and #f x)) (and (bound (x 0 #t)))) +;; describe +(tok ((1 2) 3) ((~describe "one-two" (1 2)) 3)) +(terx ((1 3) 3) ((~describe #:opaque "one-two" (1 2)) 3) + "one-two") +(terx ((1 3) 3) ((~describe "one-two" (1 2)) 3) + "2") +(terx (1 3) ((~describe "one-two" (1 2)) 3) + "one-two") + ;; epsilon-name patterns (tok (1) :one (and (bound (a 0)) (s= a 1))) @@ -198,6 +156,48 @@ (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))) +;; delimit-cut +(tok (1 (2 3)) (1 (~or (~delimit-cut (2 ~! 4)) (2 3)))) +(tok (1 2 3) (1 2 3) + 'ok + #:pre [(~delimit-cut (1 2 ~! 4))] #:post []) + +(define-syntax-class def + #:no-delimit-cut + #:literals (define-values) + (pattern (define-values ~! (x:id ...) e:expr))) + +(tok (define-values (a b c) 1) d:def + 'ok) +(terx (define-values (a 2) 3) (~or d:def e:expr) + #rx"expected identifier") +(terx* (define-values (a 2) 3) [d:def e:expr] + #rx"expected identifier") + +;; commit +(define-syntax-class xyseq + #:commit + (pattern ((~or x y) ...))) + +(tok (1 2 3 4 5 6 7 8) + (~and ((~or s.x s.y) ...) + (~fail #:unless (= (apply + (syntax->datum #'(s.x ...))) + (apply + (syntax->datum #'(s.y ...)))) + "nope")) + (equal? (syntax->datum #'(s.x ...)) '(1 2 3 4 8))) +(terx (1 2 3 4 5 6 7 8) + (~and s:xyseq + (~fail #:unless (= (apply + (syntax->datum #'(s.x ...))) + (apply + (syntax->datum #'(s.y ...)))) + "nope")) + #rx"nope") +(terx (1 2 3 4 5 6 7 8) + (~and (~commit ((~or s.x s.y) ...)) + (~fail #:unless (= (apply + (syntax->datum #'(s.x ...))) + (apply + (syntax->datum #'(s.y ...)))) + "nope")) + #rx"nope") + ;; -- H patterns ;; seq @@ -214,9 +214,14 @@ ;; describe (tok (1 2 3) ((~describe "one-two" (~seq 1 2)) 3)) -(terx (1 3 3) ((~describe "one-two" (~seq 1 2)) 3) +(terx (1 3 3) ((~describe #:opaque "one-two" (~seq 1 2)) 3) "one-two") +;; Regression (2/2/2010) +(define-splicing-syntax-class twoseq + (pattern (~seq a b))) +(tok (1 2 3 4) (x:twoseq ...)) + ;; -- A patterns ;; cut patterns @@ -227,12 +232,6 @@ (terx* 1 [(~and a:nat ~! 2) b:nat] "2") -;; cut&describe interaction -(tok (1 (2 3)) (1 (~or (~describe "foo" (2 ~! 4)) (2 3)))) -(tok (1 2 3) (1 2 3) - 'ok - #:pre [(~describe "foo" (1 2 ~! 4))] #:post []) - ;; bind patterns (tok 1 (~and x (~bind [y #'x])) (s= y '1)) @@ -258,6 +257,115 @@ (terx (1 2 3) (x:nat y:nat (~parse (2 4) #'(x y))) "expected the literal 2") +;; == syntax-parse: other feature tests + +(test-case "syntax-parse: #:context" + (check-exn + (lambda (exn) + (regexp-match #rx"me: expected exact-nonnegative-integer" (exn-message exn))) + (lambda () + (syntax-parse #'(m x) #:context #'me + [(_ n:nat) 'ok]))) + (void)) + +(test-case "syntax-parse: #:literals" + (syntax-parse #'(0 + 1 * 2) + #:literals (+ [times *]) + [(a + b * c) (void)])) + + +;; == syntax classes: other feature tests + +;; #:auto-nested-attributes + +(define-syntax-class square0 + (pattern (x:two y:two))) + +(define-syntax-class square + #:auto-nested-attributes + (pattern (x:two y:two))) + +(test-case "nested attributes omitted by default" + (check-equal? (syntax-class-attributes square0) + '((x 0) (y 0))) + (void)) + +(test-case "nested attributes work okay" + (check-equal? (syntax-class-attributes square) + '((x 0) (x.a 0) (x.b 0) (y 0) (y.a 0) (y.b 0))) + (void)) + +;; conventions + +(define-syntax-class (nat> bound) + #:description (format "natural number greater than ~s" bound) + (pattern n:nat #:when (> (syntax-e #'n) bound))) + +(define-conventions nat-convs + [N (nat> 0)]) + +(test-case "syntax-parse: #:conventions" + (syntax-parse #'(5 4) + #:conventions (nat-convs) + [(N ...) (void)])) + +(test-case "syntax-parse: #:conventions fail" + (check-exn + (lambda (exn) + (check regexp-match? #rx"expected natural number greater than 0" + (exn-message exn))) + (lambda () + (syntax-parse #'(4 0) + #:conventions (nat-convs) + [(N ...) (void)]))) + (void)) + +;; local conventions + +(define-syntax-class (nats> bound) + #:local-conventions ([N (nat> bound)]) + (pattern (N ...))) + +(test-case "local conventions 1" + (syntax-parse #'(1 2 3) + #:local-conventions ([ns (nats> 0)]) + [ns (void)])) +(test-case "local conventions 2" + (check-exn + (lambda (exn) + (check regexp-match? #rx"expected natural number greater than 2" + (exn-message exn))) + (lambda () + (syntax-parse #'(1 2 3) + #:local-conventions ([ns (nats> 2)]) + [ns (void)]))) + (void)) + ;; == Lib tests -;; == Error tests +;; static + +(tcerr "static: correct error" + (let () + (define-syntax zero 0) + (define-syntax (m stx) + (syntax-parse stx + [(_ x) + #:declare x (static number? "identifier bound to number") + #`(quote #,(attribute x.value))])) + (m twelve)) + #rx"identifier bound to number") + +(test-case "static: works" + (check-equal? + (convert-syntax-error + (let () + (define-syntax zero 0) + (define-syntax (m stx) + (syntax-parse stx + [(_ x) + #:declare x (static number? "identifier bound to number") + #`(quote #,(attribute x.value))])) + (m zero))) + 0) + (void)) diff --git a/collects/unstable/scribblings/unstable.scrbl b/collects/unstable/scribblings/unstable.scrbl index 5995e260fe..1520a5aa29 100644 --- a/collects/unstable/scribblings/unstable.scrbl +++ b/collects/unstable/scribblings/unstable.scrbl @@ -110,6 +110,7 @@ Keep documentation and tests up to date. @include-section["generics.scrbl"] @include-section["markparam.scrbl"] @include-section["debug.scrbl"] +@include-section["wrapc.scrbl"] @;{--------} diff --git a/collects/unstable/scribblings/wrapc.scrbl b/collects/unstable/scribblings/wrapc.scrbl new file mode 100644 index 0000000000..d27c8d76c2 --- /dev/null +++ b/collects/unstable/scribblings/wrapc.scrbl @@ -0,0 +1,124 @@ +#lang scribble/manual +@(require scribble/struct + scribble/decode + scribble/eval + "utils.rkt" + (for-label racket/base + racket/contract + unstable/wrapc + unstable/syntax)) + +@(begin + (define the-eval (make-base-eval)) + (the-eval '(require racket/contract (for-syntax racket/base unstable/wrapc)))) + +@title[#:tag "wrapc"]{Contracts for macro subexpressions} + +This library provides a procedure @scheme[wrap-expr/c] for applying +contracts to macro subexpressions. + +@defmodule[unstable/wrapc] + +@unstable[@author+email["Ryan Culpepper" "ryanc@racket-lang.org"]] + +@defproc[(wrap-expr/c [contract-expr syntax?] + [expr syntax?] + [#:positive pos-blame + (or/c syntax? string? module-path-index? + 'from-macro 'use-site 'unknown) + 'use-site] + [#:negative neg-blame + (or/c syntax? string? module-path-index? + 'from-macro 'use-site 'unknown) + 'from-macro] + [#:name expr-name + (or/c identifier? symbol? string? #f) #f] + [#:macro macro-name + (or/c identifier? symbol? string? #f) #f] + [#:context context (or/c syntax? #f) (current-syntax-context)]) + syntax?]{ + +Returns a syntax object representing an expression that applies the +contract represented by @scheme[contract-expr] to the value produced +by @scheme[expr]. + +The contract's positive blame represents the obligations of the +expression being wrapped. The negative blame represents the +obligations of the macro imposing the contract---the ultimate caller +of @scheme[wrap-expr/c]. By default, the positive blame is taken as +the module currently being expanded, and the negative blame is +inferred from the definition site of the macro (itself inferred from +the @scheme[context] argument). But both blame locations can be +overridden. + +Positive and negative blame locations are determined from +@scheme[pos-blame] and @scheme[neg-blame], respectively, as follows: +@itemize[ +@item{If the argument is a string, it is used directly as the blame +label.} +@item{If the argument is syntax, its source location is used +to produce the blame label.} +@item{If the argument is a module path index, its resolved module path +is used.} +@item{If the argument is @scheme['from-macro], the macro is inferred +from either the @scheme[macro-name] argument (if @scheme[macro-name] +is an identifier) or the @scheme[context] argument, and the module +where it is @emph{defined} is used as the negative blame location. If +neither an identifier @scheme[macro-name] nor a @scheme[context] +argument is given, the location is @scheme["unknown"].} +@item{If the argument is @scheme['same-as-use-site], the module being +expanded is used.} +@item{If the argument is @scheme['unknown], the blame label is +@scheme["unknown"].} +] + +The @scheme[macro-name] argument is used to determine the macro's +binding, if it is an identifier. If @scheme[expr-name] is given, +@scheme[macro-name] is also included in the contract error message. If +@scheme[macro-name] is omitted or @scheme[#f], but @scheme[context] is +a syntax object, then @scheme[macro-name] is determined from +@scheme[context]. + +If @scheme[expr-name] is not @scheme[#f], it is used in the contract's +error message to describe the expression the contract is applied to. + +The @scheme[context] argument is used, when necessary, to infer the +macro name for the negative blame party and the contract error +message. The @scheme[context] should be either an identifier or a +syntax pair with an identifer in operator position; in either case, +that identifier is taken as the macro ultimately requesting the +contract wrapping. + +@examples[#:eval the-eval +(define-syntax (myparameterize1 stx) + (syntax-case stx () + [(_ ((p v)) body) + (with-syntax ([cp (wrap-expr/c + #'parameter? #'p + #:expr-name "the parameter argument" + #:context stx)]) + #'(parameterize ((cp v)) body))])) +(myparameterize1 ((current-input-port + (open-input-string "(1 2 3)"))) + (read)) +(myparameterize1 (('whoops 'something)) + 'whatever) + +(module mod racket + (require (for-syntax unstable/wrapc)) + (define-syntax (app stx) + (syntax-case stx () + [(app f arg) + (with-syntax ([cf (wrap-expr/c + #'(-> number? number?) + #'f + #:expr-name "the function argument" + #:context stx)]) + #'(cf arg))])) + (provide app)) +(require 'mod) +(app add1 5) +(app add1 'apple) +(app (lambda (x) 'pear) 5) +] +} diff --git a/collects/unstable/syntax.rkt b/collects/unstable/syntax.rkt index e8d4033108..886c7c040a 100644 --- a/collects/unstable/syntax.rkt +++ b/collects/unstable/syntax.rkt @@ -175,7 +175,14 @@ ;; Error reporting -(define current-syntax-context (make-parameter #f)) +(define current-syntax-context + (make-parameter #f + (lambda (new-value) + (unless (or (syntax? new-value) (eq? new-value #f)) + (raise-type-error 'current-syntax-context + "syntax or #f" + new-value)) + new-value))) (define (wrong-syntax stx #:extra [extras null] format-string . args) (unless (or (eq? stx #f) (syntax? stx)) diff --git a/collects/unstable/wrapc.rkt b/collects/unstable/wrapc.rkt new file mode 100644 index 0000000000..fb9ef95579 --- /dev/null +++ b/collects/unstable/wrapc.rkt @@ -0,0 +1,95 @@ +#lang racket/base +(require racket/contract/base + (for-template racket/base + racket/contract/base + unstable/location) + unstable/srcloc + unstable/syntax) + +(provide/contract + [wrap-expr/c + (->* (syntax? syntax?) + (#:positive (or/c syntax? string? module-path-index? + 'from-macro 'use-site 'unknown) + #:negative (or/c syntax? string? module-path-index? + 'from-macro 'same-as-use-site 'unknown) + #:name (or/c identifier? symbol? string? #f) + #:macro (or/c identifier? symbol? string? #f) + #:context (or/c syntax? #f)) + syntax?)]) + +(define (wrap-expr/c ctc-expr expr + #:positive [pos-source 'use-site] + #:negative [neg-source 'from-macro] + #:name [expr-name #f] + #:macro [macro-name #f] + #:context [ctx (current-syntax-context)]) + (let* ([pos-source-expr + (get-source-expr pos-source + (if (identifier? macro-name) macro-name ctx))] + [neg-source-expr + (get-source-expr neg-source + (if (identifier? macro-name) macro-name ctx))] + [macro-name + (cond [(identifier? macro-name) (syntax-e macro-name)] + [(or (string? macro-name) (symbol? macro-name)) macro-name] + [(syntax? ctx) + (syntax-case ctx () + [(x . _) (identifier? #'x) (syntax-e #'x)] + [x (identifier? #'#'x)] + [_ #f])] + [else #f])]) + (base-wrap-expr/c expr ctc-expr + #:positive #'(quote-module-path) + #:negative neg-source-expr + #:expr-name (cond [(and expr-name macro-name) + (format "~a of ~a" expr-name macro-name)] + [expr-name expr-name] + [else #f]) + #:source #`(quote-syntax #,expr)))) + +(define (base-wrap-expr/c expr ctc-expr + #:positive positive + #:negative negative + #:expr-name [expr-name #f] + #:source [source #f]) + (let ([expr-name (or expr-name #'#f)] + [source (or source #'#f)]) + #`(contract #,ctc-expr + #,expr + #,positive + #,negative + #,expr-name + #,source))) + +(define (get-source-expr source ctx) + (cond [(eq? source 'use-site) + #'(quote-module-path)] + [(eq? source 'unknown) + #'(quote "unknown")] + [(eq? source 'from-macro) + (if (syntax? ctx) + (get-source-expr (extract-source ctx) #f) + (get-source-expr 'unknown #f))] + [else + (let ([source-string + (cond [(string? source) source] + [(syntax? source) (source-location->string source)] + [(module-path-index? source) + ;; FIXME: share with unstable/location ?? + (let ([name (resolved-module-path-name + (module-path-index-resolve source))]) + (cond [(path? name) (format "(file ~s)" (path->string name))] + [(symbol? name) (format "(quote ~s)" name)]))])]) + #`(quote #,source-string))])) + +(define (extract-source stx) + (let ([id (syntax-case stx () + [(x . _) (identifier? #'x) #'x] + [x (identifier? #'x) #'x] + [_ #f])]) + (if id + (let ([b (identifier-binding id)]) + (cond [(list? b) (car b)] ;; module-path-index + [else 'use-site])) + 'unknown)))