diff --git a/parse.rkt b/parse.rkt index c28072d..99868d2 100644 --- a/parse.rkt +++ b/parse.rkt @@ -1,31 +1,10 @@ #lang racket/base -(require (for-syntax racket/base) - racket/contract/base - "parse/pre.rkt" - "parse/experimental/provide.rkt" - "parse/experimental/contract.rkt") -(provide (except-out (all-from-out "parse/pre.rkt") - static) - expr/c) -(provide-syntax-class/contract - [static (syntax-class/c [(-> any/c any/c) (or/c string? symbol? #f)])]) - -(begin-for-syntax - (require racket/contract/base - syntax/parse/private/residual-ct) - (provide pattern-expander? - (contract-out - [pattern-expander - (-> (-> syntax? syntax?) pattern-expander?)] - [prop:pattern-expander - (struct-type-property/c (-> pattern-expander? (-> syntax? syntax?)))] - [syntax-local-syntax-parse-pattern-introduce - (-> syntax? syntax?)])) - - (require (only-in (for-template syntax/parse) pattern-expander)) - #;(define pattern-expander - (let () - #;(struct pattern-expander (proc) #:transparent - #:omit-define-syntaxes - #:property prop:pattern-expander (λ (this) (pattern-expander-proc this))) - pattern-expander))) +(#%require version-case + (for-syntax (only racket/base version) + (only racket/base #%app #%datum)) + stxparse-info/my-include) +(version-case + [(version< (version) "7.3.0.1") + (my-include "parse.rkt-7-0-0-20")] + [else + (my-include "parse.rkt-7-3-0-1")]) diff --git a/parse.rkt-7-0-0-20 b/parse.rkt-7-0-0-20 new file mode 100644 index 0000000..c28072d --- /dev/null +++ b/parse.rkt-7-0-0-20 @@ -0,0 +1,31 @@ +#lang racket/base +(require (for-syntax racket/base) + racket/contract/base + "parse/pre.rkt" + "parse/experimental/provide.rkt" + "parse/experimental/contract.rkt") +(provide (except-out (all-from-out "parse/pre.rkt") + static) + expr/c) +(provide-syntax-class/contract + [static (syntax-class/c [(-> any/c any/c) (or/c string? symbol? #f)])]) + +(begin-for-syntax + (require racket/contract/base + syntax/parse/private/residual-ct) + (provide pattern-expander? + (contract-out + [pattern-expander + (-> (-> syntax? syntax?) pattern-expander?)] + [prop:pattern-expander + (struct-type-property/c (-> pattern-expander? (-> syntax? syntax?)))] + [syntax-local-syntax-parse-pattern-introduce + (-> syntax? syntax?)])) + + (require (only-in (for-template syntax/parse) pattern-expander)) + #;(define pattern-expander + (let () + #;(struct pattern-expander (proc) #:transparent + #:omit-define-syntaxes + #:property prop:pattern-expander (λ (this) (pattern-expander-proc this))) + pattern-expander))) diff --git a/parse.rkt-7-3-0-1 b/parse.rkt-7-3-0-1 new file mode 100644 index 0000000..83c94a0 --- /dev/null +++ b/parse.rkt-7-3-0-1 @@ -0,0 +1,33 @@ +#lang racket/base +(require (for-syntax racket/base) + racket/contract/base + "parse/pre.rkt" + "parse/experimental/provide.rkt" + "parse/experimental/contract.rkt") +(provide (except-out (all-from-out "parse/pre.rkt") + static) + expr/c) +(provide-syntax-class/contract + [static (syntax-class/c [(-> any/c any/c) (or/c string? symbol? #f)])]) + +(begin-for-syntax + (require racket/contract/base + syntax/parse/private/residual-ct) + (provide pattern-expander? + (contract-out + [prop:syntax-class + (struct-type-property/c (or/c identifier? (-> any/c identifier?)))] + [pattern-expander + (-> (-> syntax? syntax?) pattern-expander?)] + [prop:pattern-expander + (struct-type-property/c (-> pattern-expander? (-> syntax? syntax?)))] + [syntax-local-syntax-parse-pattern-introduce + (-> syntax? syntax?)])) + + (require (only-in (for-template syntax/parse) pattern-expander)) + #;(define pattern-expander + (let () + #;(struct pattern-expander (proc) #:transparent + #:omit-define-syntaxes + #:property prop:pattern-expander (λ (this) (pattern-expander-proc this))) + pattern-expander))) diff --git a/parse/debug.rkt b/parse/debug.rkt index dba7cec..8b086e5 100644 --- a/parse/debug.rkt +++ b/parse/debug.rkt @@ -10,5 +10,7 @@ (my-include "debug.rkt-6-12")] [(version< (version) "7.0.0.20") (my-include "debug.rkt-6-90-0-29")] + [(version< (version) "7.3.0.1") + (my-include "debug.rkt-7-0-0-20")] [else - (my-include "debug.rkt-7-0-0-20")]) + (my-include "debug.rkt-7-3-0-1")]) diff --git a/parse/debug.rkt-7-3-0-1 b/parse/debug.rkt-7-3-0-1 new file mode 100644 index 0000000..c62849b --- /dev/null +++ b/parse/debug.rkt-7-3-0-1 @@ -0,0 +1,129 @@ +#lang racket/base +(require (for-syntax racket/base + syntax/stx + racket/syntax + syntax/parse/private/rep-data + "private/rep.rkt" + syntax/parse/private/kws) + racket/list + racket/pretty + "../parse.rkt" + (except-in stxparse-info/parse/private/residual + prop:syntax-class + prop:pattern-expander + syntax-local-syntax-parse-pattern-introduce) + "private/runtime.rkt" + "private/runtime-progress.rkt" + "private/runtime-report.rkt" + syntax/parse/private/kws) + +;; No lazy loading for this module's dependencies. + +(provide syntax-class-parse + syntax-class-attributes + syntax-class-arity + syntax-class-keywords + + debug-rhs + debug-pattern + debug-parse + debug-syntax-parse!) + +(define-syntax (syntax-class-parse stx) + (syntax-case stx () + [(_ s x arg ...) + (parameterize ((current-syntax-context stx)) + (with-disappeared-uses + (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 (undos fs) fs)]) + (app-argu parser x x (ps-empty x x) #f null fh fh #f + (lambda (fh undos . 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)) + (with-disappeared-uses + (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 #: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) + (define-values (raw-fs-sexpr maximal-fs-sexpr) (fs->sexprs fs)) + (escape + `(parse-failure + #:raw-failures + ,raw-fs-sexpr + #:maximal-failures + ,maximal-fs-sexpr))))) + (syntax-parse x [p 'success] ...)))) + +(define (fs->sexprs fs) + (let* ([raw-fs (map invert-failure (reverse (flatten fs)))] + [selected-groups (maximal-failures raw-fs)]) + (values (failureset->sexpr raw-fs) + (let ([selected (map (lambda (fs) + (cons 'progress-class + (map failure->sexpr fs))) + selected-groups)]) + (if (= (length selected) 1) + (car selected) + (cons 'union selected)))))) + +(define (debug-syntax-parse!) + (define old-failure-handler (current-failure-handler)) + (current-failure-handler + (lambda (ctx fs) + (define-values (raw-fs-sexpr maximal-fs-sexpr) (fs->sexprs fs)) + (eprintf "*** syntax-parse debug info ***\n") + (eprintf "Raw failures:\n") + (pretty-write raw-fs-sexpr (current-error-port)) + (eprintf "Maximal failures:\n") + (pretty-write maximal-fs-sexpr (current-error-port)) + (old-failure-handler ctx fs)))) diff --git a/parse/experimental/contract.rkt b/parse/experimental/contract.rkt index 5d5144b..ecc2ac1 100644 --- a/parse/experimental/contract.rkt +++ b/parse/experimental/contract.rkt @@ -1,40 +1,10 @@ #lang racket/base -(require stxparse-info/parse/pre - "provide.rkt" - syntax/contract - (only-in stxparse-info/parse/private/residual ;; keep abs. path - this-context-syntax - this-role) - racket/contract/base) - -(define not-given (gensym)) - -(define-syntax-class (expr/c ctc-stx - #:positive [pos-blame 'use-site] - #:negative [neg-blame 'from-macro] - #:macro [macro-name #f] - #:name [expr-name not-given] - #:context [ctx #f]) - #:attributes (c) - #:commit - (pattern y:expr - #:with - c (wrap-expr/c ctc-stx - #'y - #:positive pos-blame - #:negative neg-blame - #:name (if (eq? expr-name not-given) - this-role - 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 'use-site 'unknown) - #:name (or/c identifier? string? symbol? #f) - #:macro (or/c identifier? string? symbol? #f) - #:context (or/c syntax? #f)))]) +(#%require version-case + (for-syntax (only racket/base version) + (only racket/base #%app #%datum)) + stxparse-info/my-include) +(version-case + [(version< (version) "7.3.0.1") + (my-include "contract.rkt-7-0-0-20")] + [else + (my-include "contract.rkt-7-3-0-1")]) diff --git a/parse/experimental/contract.rkt-7-0-0-20 b/parse/experimental/contract.rkt-7-0-0-20 new file mode 100644 index 0000000..5d5144b --- /dev/null +++ b/parse/experimental/contract.rkt-7-0-0-20 @@ -0,0 +1,40 @@ +#lang racket/base +(require stxparse-info/parse/pre + "provide.rkt" + syntax/contract + (only-in stxparse-info/parse/private/residual ;; keep abs. path + this-context-syntax + this-role) + racket/contract/base) + +(define not-given (gensym)) + +(define-syntax-class (expr/c ctc-stx + #:positive [pos-blame 'use-site] + #:negative [neg-blame 'from-macro] + #:macro [macro-name #f] + #:name [expr-name not-given] + #:context [ctx #f]) + #:attributes (c) + #:commit + (pattern y:expr + #:with + c (wrap-expr/c ctc-stx + #'y + #:positive pos-blame + #:negative neg-blame + #:name (if (eq? expr-name not-given) + this-role + 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 '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/parse/experimental/contract.rkt-7-3-0-1 b/parse/experimental/contract.rkt-7-3-0-1 new file mode 100644 index 0000000..8dd8684 --- /dev/null +++ b/parse/experimental/contract.rkt-7-3-0-1 @@ -0,0 +1,43 @@ +#lang racket/base +(require stxparse-info/parse/pre + "provide.rkt" + syntax/contract + (only-in stxparse-info/parse/private/residual ;; keep abs. path + this-context-syntax + this-role) + racket/contract/base) + +(define not-given (gensym)) + +(define-syntax-class (expr/c ctc-stx + #:arg? [arg? #t] + #:positive [pos-blame 'from-macro] + #:negative [neg-blame 'use-site] + #:macro [macro-name #f] + #:name [expr-name not-given] + #:context [ctx #f]) + #:attributes (c) + #:commit + (pattern y:expr + #:with + c (wrap-expr/c ctc-stx + #'y + #:arg? arg? + #:positive pos-blame + #:negative neg-blame + #:name (if (eq? expr-name not-given) + this-role + expr-name) + #:macro macro-name + #:context (or ctx (this-context-syntax))))) + +(provide-syntax-class/contract + [expr/c (syntax-class/c (syntax?) + (#:arg? any/c + #:positive (or/c syntax? string? module-path-index? + 'from-macro 'use-site 'unknown) + #:negative (or/c syntax? string? module-path-index? + 'from-macro '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/parse/private/lib.rkt b/parse/private/lib.rkt index b9bf6bd..c433c10 100644 --- a/parse/private/lib.rkt +++ b/parse/private/lib.rkt @@ -8,5 +8,7 @@ (my-include "lib.rkt-6-11")] [(version< (version) "6.90.0.29") (my-include "lib.rkt-6-12")] + [(version< (version) "7.0.0.20") + (my-include "lib.rkt-6-90-0-29")] [else - (my-include "lib.rkt-6-90-0-29")]) + (my-include "lib.rkt-7-3-0-1")]) diff --git a/parse/private/lib.rkt-7-3-0-1 b/parse/private/lib.rkt-7-3-0-1 new file mode 100644 index 0000000..01e110c --- /dev/null +++ b/parse/private/lib.rkt-7-3-0-1 @@ -0,0 +1,96 @@ +#lang racket/base +(require "sc.rkt" + syntax/parse/private/keywords + (only-in "residual.rkt" state-cons!) + (for-syntax syntax/parse/private/residual-ct) + (for-syntax racket/base)) + +(provide identifier + boolean + str + character + keyword + number + integer + exact-integer + exact-nonnegative-integer + exact-positive-integer + + id + nat + char + + expr + static) + + +(define (expr-stx? x) + (not (keyword-stx? x))) + +(define ((stxof pred?) x) (and (syntax? x) (pred? (syntax-e x)))) +(define keyword-stx? (stxof keyword?)) +(define boolean-stx? (stxof boolean?)) +(define string-stx? (stxof string?)) +(define bytes-stx? (stxof bytes?)) +(define char-stx? (stxof char?)) +(define number-stx? (stxof number?)) +(define integer-stx? (stxof integer?)) +(define exact-integer-stx? (stxof exact-integer?)) +(define exact-nonnegative-integer-stx? (stxof exact-nonnegative-integer?)) +(define exact-positive-integer-stx? (stxof exact-positive-integer?)) +(define regexp-stx? (stxof regexp?)) +(define byte-regexp-stx? (stxof byte-regexp?)) + + +;; == Integrable syntax classes == + +(define-integrable-syntax-class identifier (quote "identifier") identifier?) +(define-integrable-syntax-class expr (quote "expression") expr-stx?) +(define-integrable-syntax-class keyword (quote "keyword") keyword-stx?) +(define-integrable-syntax-class boolean (quote "boolean") boolean-stx?) +(define-integrable-syntax-class character (quote "character") char-stx?) +(define-integrable-syntax-class number (quote "number") number-stx?) +(define-integrable-syntax-class integer (quote "integer") integer-stx?) +(define-integrable-syntax-class exact-integer (quote "exact-integer") exact-integer-stx?) +(define-integrable-syntax-class exact-nonnegative-integer + (quote "exact-nonnegative-integer") + exact-nonnegative-integer-stx?) +(define-integrable-syntax-class exact-positive-integer + (quote "exact-positive-integer") + exact-positive-integer-stx?) + +(define-integrable-syntax-class -string (quote "string") string-stx?) +(define-integrable-syntax-class -bytes (quote "bytes") bytes-stx?) +(define-integrable-syntax-class -regexp (quote "regexp") regexp-stx?) +(define-integrable-syntax-class -byte-regexp (quote "byte-regexp") byte-regexp-stx?) + +;; Overloading the meaning of existing identifiers +(begin-for-syntax + (set-box! alt-stxclass-mapping + (list (cons #'string (syntax-local-value #'-string)) + (cons #'bytes (syntax-local-value #'-bytes)) + (cons #'regexp (syntax-local-value #'-regexp)) + (cons #'byte-regexp (syntax-local-value #'-byte-regexp))))) + +;; 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-syntax str (make-rename-transformer #'-string)) + + +;; == Normal syntax classes == + +(define notfound (box 'notfound)) + +(define-syntax-class (static pred [name #f]) + #:attributes (value) + #:description name + #:commit + (pattern x:id + #:fail-unless (syntax-transforming?) + "not within the dynamic extent of a macro transformation" + #:attr value (syntax-local-value #'x (lambda () notfound)) + #:fail-when (eq? (attribute value) notfound) #f + #:fail-unless (pred (attribute value)) #f + #:do [(state-cons! 'literals #'x)])) diff --git a/parse/private/parse.rkt b/parse/private/parse.rkt index deec7da..b6cf825 100644 --- a/parse/private/parse.rkt +++ b/parse/private/parse.rkt @@ -10,5 +10,7 @@ (my-include "parse.rkt-6-12")] [(version< (version) "7.0.0.20") (my-include "parse.rkt-6-90-0-29")] + [(version< (version) "7.3.0.1") + (my-include "parse.rkt-7-0-0-20")] [else - (my-include "parse.rkt-7-0-0-20")]) + (my-include "parse.rkt-7-3-0-1")]) diff --git a/parse/private/parse.rkt-7-3-0-1 b/parse/private/parse.rkt-7-3-0-1 new file mode 100644 index 0000000..c7b0bf6 --- /dev/null +++ b/parse/private/parse.rkt-7-3-0-1 @@ -0,0 +1,1249 @@ +#lang racket/base +(require (for-syntax racket/base + syntax/stx + syntax/private/id-table + syntax/keyword + racket/syntax + syntax/parse/private/minimatch + syntax/parse/private/datum-to-expr + syntax/parse/private/rep-attrs + syntax/parse/private/rep-data + syntax/parse/private/rep-patterns + "rep.rkt" + syntax/parse/private/kws + "opt.rkt" + "txlift.rkt") + syntax/parse/private/keywords + racket/syntax + racket/stxparam + syntax/stx + stxparse-info/parse/private/residual ;; keep abs. path + "runtime.rkt" + stxparse-info/parse/private/runtime-reflect) ;; keep abs. path + +;; ============================================================ + +(provide define-syntax-class + define-splicing-syntax-class + define-integrable-syntax-class + syntax-parse + syntax-parser + define/syntax-parse + syntax-parser/template + parser/rhs + define-eh-alternative-set + (for-syntax rhs->parser)) + +(begin-for-syntax + ;; constant-desc : Syntax -> String/#f + (define (constant-desc stx) + (syntax-case stx (quote) + [(quote datum) + (let ([d (syntax-e #'datum)]) + (and (string? d) d))] + [expr + (let ([d (syntax-e #'expr)]) + (and (string? d) + (free-identifier=? #'#%datum (datum->syntax #'expr '#%datum)) + d))])) + + (define (tx:define-*-syntax-class stx splicing?) + (syntax-case stx () + [(_ header . rhss) + (parameterize ((current-syntax-context stx)) + (let-values ([(name formals arity) + (let ([p (check-stxclass-header #'header stx)]) + (values (car p) (cadr p) (caddr p)))]) + (let ([the-rhs (parse-rhs #'rhss splicing? #:context stx + #:default-description (symbol->string (syntax-e name)))]) + (with-syntax ([name name] + [formals formals] + [desc (cond [(rhs-description the-rhs) => constant-desc] [else #f])] + [parser (generate-temporary (format-symbol "parse-~a" name))] + [arity arity] + [attrs (rhs-attrs the-rhs)] + [commit? (rhs-commit? the-rhs)] + [delimit-cut? (rhs-delimit-cut? the-rhs)] + [the-rhs-expr (datum->expression the-rhs)]) + #`(begin (define-syntax name + (stxclass 'name 'arity + 'attrs + (quote-syntax parser) + '#,splicing? + (scopts (length 'attrs) 'commit? 'delimit-cut? desc) + #f)) + (define-values (parser) + (parser/rhs name formals attrs the-rhs-expr #,splicing? #,stx)))))))]))) + +(define-syntax define-syntax-class + (lambda (stx) (tx:define-*-syntax-class stx #f))) +(define-syntax define-splicing-syntax-class + (lambda (stx) (tx:define-*-syntax-class stx #t))) + +(define-syntax (define-integrable-syntax-class stx) + (syntax-case stx (quote) + [(_ name (quote description) predicate) + (with-syntax ([parser (generate-temporary (format-symbol "parse-~a" (syntax-e #'name)))] + [no-arity no-arity]) + #'(begin (define-syntax name + (stxclass 'name no-arity '() + (quote-syntax parser) + #f + (scopts 0 #t #t 'description) + (quote-syntax predicate))) + (define (parser x cx pr es undos fh0 cp0 rl success) + (if (predicate x) + (success fh0 undos) + (let ([es (es-add-thing pr 'description #t rl es)]) + (fh0 undos (failure* pr es)))))))])) + +(define-syntax (parser/rhs stx) + (syntax-case stx () + [(parser/rhs name formals relsattrs the-rhs-expr splicing? ctx) + (with-disappeared-uses + (let () + (define the-rhs + (parameterize ((current-syntax-context #'ctx)) + (fixup-rhs (syntax-local-eval + (syntax-local-introduce #'the-rhs-expr)) + (syntax-e #'splicing?) + (syntax->datum #'relsattrs)))) + (rhs->parser #'name #'formals #'relsattrs the-rhs (syntax-e #'splicing?) #'ctx)))])) + +(begin-for-syntax + (define (rhs->parser name formals relsattrs the-rhs splicing? [ctx #f]) + (define-values (transparent? description variants defs commit? delimit-cut?) + (match the-rhs + [(rhs _ transparent? description variants defs commit? delimit-cut?) + (values transparent? description variants defs commit? delimit-cut?)])) + (define vdefss (map variant-definitions variants)) + (define formals* (rewrite-formals formals #'x #'rl)) + (define patterns (map variant-pattern variants)) + (define no-fail? + (and (not splicing?) ;; FIXME: commit? needed? + (patterns-cannot-fail? patterns))) + (when no-fail? (log-syntax-parse-debug "(stxclass) cannot fail: ~e" ctx)) + (define body + (cond [(null? patterns) + #'(fail (failure* pr es))] + [splicing? + (with-syntax ([(alternative ...) + (for/list ([pattern (in-list patterns)]) + (with-syntax ([pattern pattern] + [relsattrs relsattrs] + [iattrs (pattern-attrs pattern)] + [commit? commit?] + [result-pr + (if transparent? + #'rest-pr + #'(ps-pop-opaque rest-pr))]) + #'(parse:H x cx rest-x rest-cx rest-pr pattern pr es + (variant-success relsattrs iattrs (rest-x rest-cx result-pr) + success cp0 commit?))))]) + #'(try alternative ...))] + [else + (with-syntax ([matrix + (optimize-matrix + (for/list ([pattern (in-list patterns)]) + (with-syntax ([iattrs (pattern-attrs pattern)] + [relsattrs relsattrs] + [commit? commit?]) + (pk1 (list pattern) + #'(variant-success relsattrs iattrs () + success cp0 commit?)))))]) + #'(parse:matrix ((x cx pr es)) matrix))])) + (with-syntax ([formals* formals*] + [(def ...) defs] + [((vdef ...) ...) vdefss] + [description description] + [transparent? transparent?] + [delimit-cut? delimit-cut?] + [body body]) + #`(lambda (x cx pr es undos fh0 cp0 rl success . formals*) + (with ([this-syntax x] + [this-role rl]) + def ... + vdef ... ... + (#%expression + (syntax-parameterize ((this-context-syntax + (syntax-rules () + [(tbs) (ps-context-syntax pr)]))) + (let ([es (es-add-thing pr description 'transparent? rl + #,(if no-fail? #'#f #'es))] + [pr (if 'transparent? pr (ps-add-opaque pr))]) + (with ([fail-handler fh0] + [cut-prompt cp0] + [undo-stack undos]) + ;; Update the prompt, if required + ;; FIXME: can be optimized away if no cut exposed within variants + (with-maybe-delimit-cut delimit-cut? + body)))))))))) + +(define-syntax (syntax-parse stx) + (syntax-case stx () + [(syntax-parse stx-expr . clauses) + (quasisyntax/loc stx + (let ([x (datum->syntax #f stx-expr)]) + (with ([this-syntax x]) + (parse:clauses x clauses body-sequence #,((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)]) + (with ([this-syntax x]) + (parse:clauses x clauses body-sequence #,((make-syntax-introducer) stx))))))])) + +(define-syntax (syntax-parser/template stx) + (syntax-case stx () + [(syntax-parser/template ctx . clauses) + (quasisyntax/loc stx + (lambda (x) + (let ([x (datum->syntax #f x)]) + (with ([this-syntax x]) + (parse:clauses x clauses one-template ctx)))))])) + +(define-syntax (define/syntax-parse stx) + (syntax-case stx () + [(define/syntax-parse pattern . rest) + (with-disappeared-uses + (let-values ([(rest pattern defs) + (parse-pattern+sides #'pattern + #'rest + #:splicing? #f + #:decls (new-declenv null) + #:context stx)]) + (define no-fail? (patterns-cannot-fail? (list pattern))) + (let ([expr + (syntax-case rest () + [( expr ) #'expr] + [_ (raise-syntax-error #f "bad syntax" stx)])] + [attrs (pattern-attrs pattern)]) + (with-syntax ([(a ...) attrs] + [(#s(attr name _ _) ...) attrs] + [pattern pattern] + [es0 (if no-fail? #'#f #'#t)] + [(def ...) defs] + [expr expr]) + #'(defattrs/unpack (a ...) + (let* ([x (datum->syntax #f expr)] + [cx x] + [pr (ps-empty x x)] + [es es0] + [fh0 (syntax-patterns-fail + (normalize-context 'define/syntax-parse + '|define/syntax-parse pattern| + x))]) + (parameterize ((current-syntax-context x)) + def ... + (#%expression + (with ([fail-handler fh0] + [cut-prompt fh0] + [undo-stack null]) + (parse:S x cx pattern pr es + (list (attribute name) ...)))))))))))])) + +;; ============================================================ + +#| +Parsing protocols: + +(parse: pr es success-expr) : 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/null (stx-list?) in cdr patterns + cx is most recent syntax object: if x must be coerced to syntax, use cx as lexctx and src + pr, es are progress and expectstack, respectively + rest-x, rest-cx, rest-pr are variable names to bind in context of success-expr + +(stxclass-parser x cx pr es undos fail-handler cut-prompt role success-proc arg ...) : Ans + + success-proc: + for stxclass, is (fail-handler undos attr-value ... -> Ans) + for splicing-stxclass, is (undos fail-handler rest-x rest-cx rest-pr attr-value -> Ans) + fail-handler, cut-prompt : undos failure -> Ans + +Fail-handler is normally represented with stxparam 'fail-handler', but must be +threaded through stxclass calls (in through stxclass-parser, out through +success-proc) to support backtracking. Cut-prompt is never changed within +stxclass or within alternative, so no threading needed. + +The undo stack is normally represented with stxparam 'undo-stack', but must be +threaded through stxclass calls (like fail-handler). A failure handler closes +over a base undo stack and receives an extended current undo stack; the failure +handler unwinds effects by performing every action in the difference between +them and then restores the saved undo stack. + +Usually sub-patterns processed in tail position, but *can* do non-tail calls for: + - ~commit + - var of stxclass with ~commit +It is also safe to keep normal tail-call protocol and just adjust fail-handler. +There is no real benefit to specializing ~commit, since it does not involve +creating a success closure. + +Some optimizations: + - commit protocol for stxclasses (but not ~commit, no point) + - avoid continue-vs-end choice point in (EH ... . ()) by eager pair check + - integrable stxclasses, specialize ellipses of integrable stxclasses + - pattern lists that cannot fail set es=#f to disable ExpectStack allocation +|# + +;; ---- + +(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)) + (define (generate-n-temporaries n) + (generate-temporaries + (for/list ([i (in-range n)]) + (string->symbol (format "g~sx" i)))))) + +;; ---- + +#| +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, rl : id (var) +|# + +(begin-for-syntax + (define (rewrite-formals fstx x-id rl-id) + (with-syntax ([x x-id] + [rl rl-id]) + (let loop ([fstx fstx]) + (syntax-case fstx () + [([kw arg default] . more) + (keyword? (syntax-e #'kw)) + (cons #'(kw arg (with ([this-syntax x] [this-role rl]) default)) + (loop #'more))] + [([arg default] . more) + (not (keyword? (syntax-e #'kw))) + (cons #'(arg (with ([this-syntax x] [this-role rl]) default)) + (loop #'more))] + [(formal . more) + (cons #'formal (loop #'more))] + [_ fstx]))))) + +;; (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])) + +;; (variant-success relsattrs variant (also:id ...) success bool) : expr[Ans] +(define-syntax (variant-success stx) + (syntax-case stx () + [(variant-success relsattrs iattrs (also ...) success cp0 commit?) + #`(with-maybe-reset-fail commit? cp0 + (base-success-expr iattrs 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 undo-stack also ... (attribute name) ...)))])) + +;; ---- + +;; (parse:clauses x clauses ctx) +(define-syntax (parse:clauses stx) + (syntax-case stx () + [(parse:clauses x clauses body-mode ctx) + ;; if templates? is true, expect one form after kwargs in clause, wrap it with syntax + ;; otherwise, expect non-empty body sequence (defs and exprs) + (with-disappeared-uses + (with-txlifts + (lambda () + (define who + (syntax-case #'ctx () + [(m . _) (identifier? #'m) #'m] + [_ 'syntax-parse])) + (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 colon-notation? + (not (assq '#:disable-colon-notation chunks))) + (define track-literals? + (or (assq '#:track-literals chunks) + (eq? (syntax-e #'body-mode) 'one-template))) + (define-values (decls0 defs) + (get-decls+defs chunks #:context #'ctx)) + ;; for-clause : stx -> (values pattern stx (listof stx)) + (define (for-clause clause) + (syntax-case clause () + [[p . rest] + (let-values ([(rest pattern defs2) + (parameterize ((stxclass-colon-notation? colon-notation?)) + (parse-pattern+sides #'p #'rest + #:splicing? #f + #:decls decls0 + #:context #'ctx))]) + (let ([body-expr + (case (syntax-e #'body-mode) + ((one-template) + (syntax-case rest () + [(template) + #'(syntax template)] + [_ (raise-syntax-error #f "expected exactly one template" #'ctx)])) + ((body-sequence) + (syntax-case rest () + [(e0 e ...) + ;; Should we use a shadower (works on the whole file, unhygienically), + ;; or use the context of the syntax-parse identifier? + (let ([the-#%intdef-begin (datum->syntax #'ctx '#%intdef-begin)]) + (if (syntax-local-value the-#%intdef-begin (λ () #f)) ;; Defined as a macro + #`(let () (#,the-#%intdef-begin e0 e ...)) + #'(let () e0 e ...)))] + [_ (raise-syntax-error #f "expected non-empty clause body" + #'ctx clause)])) + (else + (raise-syntax-error #f "internal error: unknown body mode" #'ctx #'body-mode)))]) + (values pattern body-expr defs2)))] + [_ (raise-syntax-error #f "expected clause" #'ctx clause)])) + (define (wrap-track-literals stx) + (if track-literals? (quasisyntax/loc stx (track-literals '#,who #,stx)) stx)) + (unless (stx-list? clauses-stx) + (raise-syntax-error #f "expected sequence of clauses" #'ctx)) + (define-values (patterns body-exprs defs2s) + (for/lists (patterns body-exprs defs2s) ([clause (in-list (stx->list clauses-stx))]) + (for-clause clause))) + (define no-fail? (patterns-cannot-fail? patterns)) + (when no-fail? (log-syntax-parse-debug "cannot fail: ~e" #'ctx)) + (with-syntax ([(def ...) (apply append (get-txlifts-as-definitions) defs defs2s)]) + #`(let* ([ctx0 (normalize-context '#,who #,context x)] + [pr (ps-empty x (cadr ctx0))] + [es #,(if no-fail? #'#f #'#t)] + [cx x] + [fh0 (syntax-patterns-fail ctx0)]) + def ... + (parameterize ((current-syntax-context (cadr ctx0)) + (current-state '#hasheq()) + (current-state-writable? #f)) + #,(wrap-track-literals + #`(with ([fail-handler fh0] + [cut-prompt fh0] + [undo-stack null]) + #,(cond [(pair? patterns) + (with-syntax ([matrix + (optimize-matrix + (for/list ([pattern (in-list patterns)] + [body-expr (in-list body-exprs)]) + (pk1 (list pattern) body-expr)))]) + #'(parse:matrix ((x cx pr es)) matrix)) + #| + (with-syntax ([(alternative ...) + (for/list ([pattern (in-list patterns)] + [body-expr (in-list body-exprs)]) + #`(parse:S x cx #,pattern pr es #,body-expr))]) + #`(try alternative ...)) + |#] + [else + #`(fail (failure* pr es))])))))))))])) + +;; ---- + +;; (parse:matrix ((x cx pr es) ...) (PK ...)) : expr[Ans] +;; (parse:matrix (in1 ... inN) (#s(pk1 (P11 ... P1N) e1) ... #s(pk1 (PM1 ... PMN) eM))) +;; represents the matching matrix +;; [_in1_..._inN_|____] +;; [ P11 ... P1N | e1 ] +;; [ ⋮ ⋮ | ⋮ ] +;; [ PM1 ... PMN | eM ] + +(define-syntax (parse:matrix stx) + (syntax-case stx () + [(parse:matrix ins (pk ...)) + #'(try (parse:pk ins pk) ...)])) + +(define-syntax (parse:pk stx) + (syntax-case stx () + [(parse:pk () #s(pk1 () k)) + #'k] + [(parse:pk ((x cx pr es) . ins) #s(pk1 (pat1 . pats) k)) + #'(parse:S x cx pat1 pr es (parse:pk ins #s(pk1 pats k)))] + [(parse:pk ((x cx pr es) . ins) #s(pk/same pat1 inner)) + #'(parse:S x cx pat1 pr es (parse:matrix ins inner))] + [(parse:pk ((x cx pr es) . ins) #s(pk/pair inner)) + #'(let-values ([(datum tcx) + (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:matrix ((hx hcx hpr es) (tx tcx tpr es) . ins) inner)) + (let ([es* (if (null? datum) (es-add-proper-pair (first-desc:matrix inner) es) es)]) + (fail (failure* pr es*)))))] + [(parse:pk (in1 . ins) #s(pk/and inner)) + #'(parse:matrix (in1 in1 . ins) inner)])) + +(define-syntax (first-desc:matrix stx) + (syntax-case stx () + [(fdm (#s(pk1 (pat1 . pats) k))) + #'(first-desc:S pat1)] + [(fdm (#s(pk/same pat1 pks))) + #'(first-desc:S pat1)] + [(fdm (pk ...)) ;; FIXME + #'#f])) + +;; ---- + +;; (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) + #'k] + [#s(pat:svar name) + #'(let-attributes ([#s(attr name 0 #t) (datum->syntax cx x cx)]) + k)] + [#s(pat:var/p name parser argu (nested-a ...) role + #s(scopts attr-count commit? _delimit? _desc)) + (with-syntax ([(av ...) (generate-n-temporaries (syntax-e #'attr-count))] + [(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 undo-stack fail-handler cut-prompt role + (lambda (fh undos av ...) + (let-attributes (name-attr ...) + (let-attributes* ((nested-a ...) (av ...)) + (with ([fail-handler fh] [undo-stack undos]) + k)))) + argu) + ;; The commit protocol + ;; (Avoids putting k in procedure) + #'(let-values ([(fs undos av ...) + (with ([fail-handler + (lambda (undos fs) + (unwind-to undos undo-stack) + (values fs undo-stack (let ([av #f]) av) ...))]) + (with ([cut-prompt fail-handler]) + (app-argu parser x cx pr es undo-stack + fail-handler cut-prompt role + (lambda (fh undos av ...) (values #f undos av ...)) + argu)))]) + (if fs + (fail fs) + (let-attributes (name-attr ...) + (let-attributes* ((nested-a ...) (av ...)) + (with ([undo-stack undos]) + k)))))))] + [#s(pat:reflect 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 undo-stack fail-handler cut-prompt #f + (lambda (fh undos . result) + (let-attributes (name-attr ...) + (let/unpack ((nested-a ...) result) + (with ([fail-handler fh] [undo-stack undos]) + k)))) + argu))))] + [#s(pat:datum datum) + (with-syntax ([unwrap-x + (if (atomic-datum-stx? #'datum) + #'(if (syntax? x) (syntax-e x) x) + #'(syntax->datum (datum->syntax #f x)))]) + #`(let ([d unwrap-x]) + (if (equal? d (quote datum)) + k + (fail (failure* pr (es-add-atom 'datum es))))))] + [#s(pat:literal literal input-phase lit-phase) + #`(if (and (identifier? x) + (free-identifier=? x (quote-syntax literal) input-phase lit-phase)) + (with ([undo-stack (cons (current-state) undo-stack)]) + (state-cons! 'literals x) + k) + (fail (failure* pr (es-add-literal (quote-syntax literal) es))))] + [#s(pat:action action subpattern) + #'(parse:A x cx action pr es (parse:S x cx subpattern pr es k))] + [#s(pat:head 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 head tail) + #`(parse:dots x cx head tail pr es k)] + [#s(pat:and 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 ...) (subattrs ...)) + (with-syntax ([(#s(attr id _ _) ...) #'(a ...)]) + #`(let ([success + (lambda (fh undos id ...) + (let-attributes ([a id] ...) + (with ([fail-handler fh] [undo-stack undos]) + k)))]) + (try (parse:S x cx subpattern pr es + (disjunct subattrs success () (id ...))) + ...)))] + [#s(pat:not subpattern) + #`(let* ([fh0 fail-handler] + [pr0 pr] + [es0 es] + [fail-to-succeed + (lambda (undos fs) (unwind-to undos undo-stack) 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 undo-stack (failure* pr0 es0)))))] + [#s(pat:pair head tail) + #`(let ([datum (if (syntax? x) (syntax-e x) x)] + [cx (if (syntax? x) x cx)]) ;; FIXME: shadowing 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))) + (let ([es* (if (null? datum) (es-add-proper-pair (first-desc:S head) es) es)]) + (fail (failure* pr es*)))))] + [#s(pat:vector 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 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 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 (cdr (vector->list (struct->vector 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 pattern description transparent? role) + #`(let ([es* (es-add-thing pr description transparent? role es)] + [pr* (if 'transparent? pr (ps-add-opaque pr))]) + (parse:S x cx pattern pr* es* k))] + [#s(pat:delimit 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 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:ord pattern group index) + #`(let ([pr* (ps-add pr '#s(ord group index))]) + (parse:S x cx pattern pr* es k))] + [#s(pat:post pattern) + #`(let ([pr* (ps-add-post pr)]) + (parse:S x cx pattern pr* es k))] + [#s(pat:integrated name predicate description role) + (with-syntax ([(name-attr ...) + (if (identifier? #'name) + #'([#s(attr name 0 #t) x*]) + #'())]) + #'(let ([x* (datum->syntax cx x cx)]) + (if (predicate x*) + (let-attributes (name-attr ...) k) + (let ([es* (es-add-thing pr 'description #t role es)]) + (fail (failure* pr es*))))))])])) + +;; (first-desc:S S-pattern) : expr[FirstDesc] +(define-syntax (first-desc:S stx) + (syntax-case stx () + [(fds p) + (syntax-case #'p () + [#s(pat:any) + #''(any)] + [#s(pat:svar name) + #''(any)] + [#s(pat:var/p _ _ _ _ _ #s(scopts _ _ _ desc)) + #'(quote desc)] + [#s(pat:datum d) + #''(datum d)] + [#s(pat:literal id _ip _lp) + #''(literal id)] + [#s(pat:describe _p desc _t? _role) + #`(quote #,(or (constant-desc #'desc) #'#f))] + [#s(pat:delimit pattern) + #'(first-desc:S pattern)] + [#s(pat:commit pattern) + #'(first-desc:S pattern)] + [#s(pat:ord pattern _ _) + #'(first-desc:S pattern)] + [#s(pat:post pattern) + #'(first-desc:S pattern)] + [#s(pat:integrated _name _pred description _role) + #''description] + [_ #'#f])])) + +;; (first-desc:H HeadPattern) : Expr +(define-syntax (first-desc:H stx) + (syntax-case stx () + [(fdh hpat) + (syntax-case #'hpat () + [#s(hpat:var/p _ _ _ _ _ #s(scopts _ _ _ desc)) #'(quote desc)] + [#s(hpat:seq lp) #'(first-desc:L lp)] + [#s(hpat:describe _hp desc _t? _r) + #`(quote #,(or (constant-desc #'desc) #'#f))] + [#s(hpat:delimit hp) #'(first-desc:H hp)] + [#s(hpat:commit hp) #'(first-desc:H hp)] + [#s(hpat:ord hp _ _) #'(first-desc:H hp)] + [#s(hpat:post hp) #'(first-desc:H hp)] + [_ #'(first-desc:S hpat)])])) + +(define-syntax (first-desc:L stx) + (syntax-case stx () + [(fdl lpat) + (syntax-case #'lpat () + [#s(pat:pair sp lp) #'(first-desc:S sp)] + [_ #'#f])])) + +;; (disjunct (iattr ...) success (pre:expr ...) (id:id ...)) : expr[Ans] +(define-syntax (disjunct stx) + (syntax-case stx () + [(disjunct (#s(attr sub-id _ _) ...) success (pre ...) (id ...)) + (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 undo-stack 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:and (action ...)) + (for/fold ([k #'k]) ([action (in-list (reverse (syntax->list #'(action ...))))]) + #`(parse:A x cx #,action pr es #,k))] + [#s(action:cut) + #'(with ([fail-handler cut-prompt]) k)] + [#s(action:bind a expr) + #'(let-attributes ([a (wrap-user-code expr)]) k)] + [#s(action:fail condition message) + #`(let ([c (wrap-user-code condition)]) + (if c + (let ([pr* (if (syntax? c) (ps-add-stx pr c) pr)] + [es* (es-add-message message es)]) + (fail (failure* pr* es*))) + k))] + [#s(action:parse pattern expr) + #`(let* ([y (datum->syntax/with-clause (wrap-user-code expr))] + [cy y] + [pr* (ps-add-stx pr y)]) + (parse:S y cy pattern pr* es k))] + [#s(action:do (stmt ...)) + #'(parameterize ((current-state-writable? #t)) + (let ([init-state (current-state)]) + (no-shadow stmt) ... + (parameterize ((current-state-writable? #f)) + (with ([undo-stack (maybe-add-state-undo init-state (current-state) undo-stack)]) + (#%expression k)))))] + [#s(action:undo (stmt ...)) + #'(with ([undo-stack (cons (lambda () stmt ... (void)) undo-stack)] + [cut-prompt illegal-cut-error]) + k)] + [#s(action:ord pattern group index) + #'(let ([pr* (ps-add pr '#s(ord group index))]) + (parse:A x cx pattern pr* es k))] + [#s(action:post pattern) + #'(let ([pr* (ps-add-post pr)]) + (parse:A x cx pattern pr* es 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 action tail) + (with-syntax ([tail (convert-list-pattern #'tail end-pattern)]) + #'#s(pat:action action tail))] + [#s(pat:head head tail) + (with-syntax ([tail (convert-list-pattern #'tail end-pattern)]) + #'#s(pat:head head tail))] + [#s(pat:dots head tail) + (with-syntax ([tail (convert-list-pattern #'tail end-pattern)]) + #'#s(pat:dots head tail))] + [#s(pat:pair head-part tail-part) + (with-syntax ([tail-part (convert-list-pattern #'tail-part end-pattern)]) + #'#s(pat:pair 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 pattern description transparent? role) + #`(let ([es* (es-add-thing pr description transparent? role es)] + [pr* (if 'transparent? pr (ps-add-opaque pr))]) + (parse:H x cx rest-x rest-cx rest-pr pattern pr* es* + (let ([rest-pr (if 'transparent? rest-pr (ps-pop-opaque rest-pr))]) + k)))] + [#s(hpat:var/p name parser argu (nested-a ...) role + #s(scopts attr-count commit? _delimit? _desc)) + (with-syntax ([(av ...) (generate-n-temporaries (syntax-e #'attr-count))] + [(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 undo-stack fail-handler cut-prompt role + (lambda (fh undos rest-x rest-cx rest-pr av ...) + (let-attributes (name-attr ...) + (let-attributes* ((nested-a ...) (av ...)) + (with ([fail-handler fh] [undo-stack undos]) + k)))) + argu) + ;; The commit protocol + ;; (Avoids putting k in procedure) + #'(let-values ([(fs undos rest-x rest-cx rest-pr av ...) + (with ([fail-handler + (lambda (undos fs) + (unwind-to undos undo-stack) + (values fs undo-stack #f #f #f (let ([av #f]) av) ...))]) + (with ([cut-prompt fail-handler]) + (app-argu parser x cx pr es undo-stack + fail-handler cut-prompt role + (lambda (fh undos rest-x rest-cx rest-pr av ...) + (values #f undos rest-x rest-cx rest-pr av ...)) + argu)))]) + (if fs + (fail fs) + (let-attributes (name-attr ...) + (let-attributes* ((nested-a ...) (av ...)) + (with ([undo-stack undos]) + k)))))))] + [#s(hpat:reflect 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 undo-stack fail-handler cut-prompt #f + (lambda (fh undos rest-x rest-cx rest-pr . result) + (let-attributes (name-attr ...) + (let/unpack ((nested-a ...) result) + (with ([fail-handler fh] [undo-stack undos]) + k)))) + argu))))] + [#s(hpat:and 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 ...) (subattrs ...)) + (with-syntax ([(#s(attr id _ _) ...) #'(a ...)]) + #`(let ([success + (lambda (fh undos rest-x rest-cx rest-pr id ...) + (let-attributes ([a id] ...) + (with ([fail-handler fh] [undo-stack undos]) + k)))]) + (try (parse:H x cx rest-x rest-cx rest-pr subpattern pr es + (disjunct subattrs success (rest-x rest-cx rest-pr) (id ...))) + ...)))] + [#s(hpat:seq 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:action action subpattern) + #'(parse:A x cx action pr es (parse:H x cx rest-x rest-cx rest-pr subpattern pr es k))] + [#s(hpat:delimit 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 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:ord pattern group index) + #`(let ([pr* (ps-add pr '#s(ord group index))]) + (parse:H x cx rest-x rest-cx rest-pr pattern pr* es + (let ([rest-pr (ps-pop-ord rest-pr)]) k)))] + [#s(hpat:post pattern) + #'(let ([pr* (ps-add-post pr)]) + (parse:H x cx rest-x rest-cx rest-pr pattern pr* es + (let ([rest-pr (ps-pop-post rest-pr)]) k)))] + [#s(hpat:peek pattern) + #`(let ([saved-x x] [saved-cx cx] [saved-pr pr]) + (parse:H x cx dummy-x dummy-cx dummy-pr pattern pr es + (let ([rest-x saved-x] [rest-cx saved-cx] [rest-pr saved-pr]) + k)))] + [#s(hpat:peek-not subpattern) + #`(let* ([fh0 fail-handler] + [pr0 pr] + [es0 es] + [fail-to-succeed + (lambda (undos fs) + (unwind-to undos undo-stack) + (let ([rest-x x] + [rest-cx cx] + [rest-pr pr]) + 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:H x cx rest-x rest-cx rest-pr subpattern pr es + (fh0 undo-stack (failure* pr0 es0)))))] + [_ + #'(parse:S x cx + ;; FIXME: consider proper-list-pattern? (yes is consistent with ~seq) + #s(pat:pair 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 () + ;; == Specialized cases + ;; -- (x ... . ()) + [(parse:dots x cx (#s(ehpat (attr0) #s(pat:svar name) #f #f)) + #s(pat:datum ()) pr es k) + #'(let-values ([(status result) (predicate-ellipsis-parser x cx pr es void #f #f)]) + (case status + ((ok) (let-attributes ([attr0 result]) k)) + (else (fail result))))] + ;; -- (x:sc ... . ()) where sc is an integrable stxclass like id or expr + [(parse:dots x cx (#s(ehpat (attr0) #s(pat:integrated _name pred? desc role) #f #f)) + #s(pat:datum ()) pr es k) + #'(let-values ([(status result) (predicate-ellipsis-parser x cx pr es pred? desc role)]) + (case status + ((ok) (let-attributes ([attr0 result]) k)) + (else (fail result))))] + ;; -- (x:sc ... . ()) where sc is a stxclass with commit + ;; Since head pattern does commit, no need to thread fail-handler, cut-prompt through. + ;; Microbenchmark suggests this isn't a useful specialization + ;; (probably try-or-pair/null-check already does the useful part) + ;; == General case + [(parse:dots x cx (#s(ehpat head-attrs head head-repc check-null?) ...) 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 rel-heads (for/list ([head (in-list (syntax->list #'(head ...)))] + [repc (in-list repcs)] + #:when repc) + head)) + (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)) + (define tail-pattern-is-null? (equal? (syntax->datum #'tail) '#s(pat:datum ()))) + (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] + [(rel-head ...) rel-heads] + [(a ...) attrs] + [(attr-repc ...) attr-repcs] + [do-pair/null? + ;; FIXME: do pair/null check only if no nullable head patterns + ;; (and tail-pattern-is-null? (andmap not (syntax->datum #'(nullable? ...)))) + tail-pattern-is-null?]) + (define/with-syntax alt-map #'((id . alt-id) ...)) + (define/with-syntax loop-k + #'(dots-loop dx* dcx* loop-pr* undo-stack fail-handler rel-rep ... alt-id ...)) + #`(let () + ;; dots-loop : stx progress rel-rep ... alt-id ... -> Ans + (define (dots-loop dx dcx loop-pr undos fh rel-rep ... alt-id ...) + (with ([fail-handler fh] [undo-stack undos]) + (try-or-pair/null-check do-pair/null? dx dcx loop-pr es + (try (parse:EH dx dcx loop-pr head-attrs check-null? head-repc dx* dcx* loop-pr* + alt-map head-rep head es loop-k) + ...) + (cond [(< rel-rep (rep:min-number rel-repc)) + (let ([es (expectation-of-reps/too-few es rel-rep rel-repc rel-head)]) + (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 undo-stack fail-handler 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 attrs check-null? repc x* cx* pr* alts rep head es k) + (let () + (define/with-syntax k* + (let* ([main-attrs (wash-iattrs #'attrs)] + [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]) + #`(let ([alt-id (rep:combine repc (attribute id) alt-id)] ...) + #,(if (syntax->datum #'check-null?) + #'(if (zero? (ps-difference pr pr*)) (error/null-eh-match) k) + #'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* (expectation-of-reps/too-many es rep repc)]) + (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(action:bind 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 expectation-of-reps/too-few + (syntax-rules () + [(_ es rep #s(rep:once name too-few-msg too-many-msg) hpat) + (cond [(or too-few-msg (name->too-few/once name)) + => (lambda (msg) (es-add-message msg es))] + [(first-desc:H hpat) => (lambda (fd) (es-add-proper-pair fd es))] + [else es])] + [(_ es rep #s(rep:optional name too-many-msg _) hpat) + (error 'syntax-parse "INTERNAL ERROR: impossible (too-few)")] + [(_ es rep #s(rep:bounds min max name too-few-msg too-many-msg) hpat) + (cond [(or too-few-msg (name->too-few name)) + => (lambda (msg) (es-add-message msg es))] + [(first-desc:H hpat) => (lambda (fd) (es-add-proper-pair fd es))] + [else es])])) + +(define-syntax expectation-of-reps/too-many + (syntax-rules () + [(_ es rep #s(rep:once name too-few-msg too-many-msg)) + (es-add-message (or too-many-msg (name->too-many name)) es)] + [(_ es rep #s(rep:optional name too-many-msg _)) + (es-add-message (or too-many-msg (name->too-many name)) es)] + [(_ es rep #s(rep:bounds min max name too-few-msg too-many-msg)) + (es-add-message (or too-many-msg (name->too-many name)) es)])) + +;; ==== + +(define-syntax (define-eh-alternative-set stx) + (define (parse-alt x) + (syntax-case x (pattern) + [(pattern alt) + #'alt] + [else + (wrong-syntax x "expected eh-alternative-set alternative")])) + (parameterize ((current-syntax-context stx)) + (syntax-case stx () + [(_ name a ...) + (unless (identifier? #'name) + (wrong-syntax #'name "expected identifier")) + (let* ([alts (map parse-alt (syntax->list #'(a ...)))] + [decls (new-declenv null #:conventions null)] + [ehpat+hstx-list + (apply append + (for/list ([alt (in-list alts)]) + (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) + (define the-pattern (ehpat-head ehpat)) + (define attrs (iattrs->sattrs (pattern-attrs the-pattern))) + (define the-variant (variant hstx attrs the-pattern null)) + (define the-rhs (rhs attrs #f #f (list the-variant) null #f #f)) + (with-syntax ([(parser) (generate-temporaries '(eh-alt-parser))] + [the-rhs-expr (datum->expression the-rhs)]) + (list (eh-alternative (ehpat-repc ehpat) attrs #'parser) + (list #`(define parser + (parser/rhs parser () #,attrs + the-rhs-expr #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 + ;; repc structs are prefab; recreate using prefab + ;; quasiquote exprs to avoid moving constructors + ;; to residual module + (syntax-case (eh-alternative-repc alt) () + [#f + #''#f] + [#s(rep:once n u o) + #'`#s(rep:once ,(quote-syntax n) + ,(quote-syntax u) + ,(quote-syntax o))] + [#s(rep:optional n o d) + #'`#s(rep:optional ,(quote-syntax n) + ,(quote-syntax o) + ,(quote-syntax d))] + [#s(rep:bounds min max n u o) + #'`#s(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/parse/private/rep.rkt b/parse/private/rep.rkt index 7697757..8de1934 100644 --- a/parse/private/rep.rkt +++ b/parse/private/rep.rkt @@ -10,5 +10,7 @@ (my-include "rep.rkt-6-12")] [(version< (version) "7.0.0.20") (my-include "rep.rkt-6-90-0-29")] + [(version< (version) "7.3.0.1") + (my-include "rep.rkt-7-0-0-20")] [else - (my-include "rep.rkt-7-0-0-20")]) + (my-include "rep.rkt-7-3-0-1")]) diff --git a/parse/private/rep.rkt-7-3-0-1 b/parse/private/rep.rkt-7-3-0-1 new file mode 100644 index 0000000..2200c83 --- /dev/null +++ b/parse/private/rep.rkt-7-3-0-1 @@ -0,0 +1,1833 @@ +#lang racket/base +(require (for-template racket/base + syntax/parse/private/keywords + stxparse-info/parse/private/residual ;; keep abs. path + stxparse-info/parse/private/runtime) + racket/list + racket/contract/base + "make.rkt" + syntax/parse/private/minimatch + syntax/apply-transformer + syntax/private/id-table + syntax/stx + syntax/keyword + racket/syntax + racket/struct + "txlift.rkt" + syntax/parse/private/rep-attrs + syntax/parse/private/rep-data + syntax/parse/private/rep-patterns + syntax/parse/private/residual-ct ;; keep abs. path + syntax/parse/private/kws) + +;; Error reporting +;; All entry points should have explicit, mandatory #:context arg +;; (mandatory from outside, at least) + +(provide/contract + [atomic-datum-stx? + (-> syntax? + boolean?)] + [parse-rhs + (->* [syntax? boolean? #:context (or/c false/c syntax?)] + [#:default-description (or/c #f string?)] + rhs?)] + [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? #:context (or/c false/c syntax?) + (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-stxclass-header + (-> syntax? syntax? + (list/c identifier? syntax? arity?))] + [check-stxclass-application + (-> syntax? syntax? + (cons/c identifier? arguments?))] + [check-conventions-rules + (-> syntax? syntax? + (listof (list/c regexp? any/c)))] + [check-datum-literals-list + (-> syntax? syntax? + (listof den:datum-lit?))] + [check-attr-arity-list + (-> syntax? syntax? + (listof sattr?))] + [stxclass-colon-notation? + (parameter/c boolean?)] + [fixup-rhs + (-> rhs? boolean? (listof sattr?) rhs?)]) + +;; ---- + +(define (atomic-datum-stx? stx) + (let ([datum (syntax-e stx)]) + (or (null? datum) + (boolean? datum) + (string? datum) + (number? datum) + (keyword? datum) + (bytes? datum) + (char? datum) + (regexp? datum) + (byte-regexp? datum)))) + +(define (id-predicate kw) + (lambda (stx) + (and (identifier? stx) + (free-identifier=? stx kw) + (begin (disappeared! stx) #t)))) + +(define wildcard? (id-predicate (quote-syntax _))) +(define epsilon? (id-predicate (quote-syntax ||))) +(define dots? (id-predicate (quote-syntax ...))) +(define plus-dots? (id-predicate (quote-syntax ...+))) + +(define keywords + (list (quote-syntax _) + (quote-syntax ||) + (quote-syntax ...) + (quote-syntax ~var) + (quote-syntax ~datum) + (quote-syntax ~literal) + (quote-syntax ~and) + (quote-syntax ~or) + (quote-syntax ~or*) + (quote-syntax ~alt) + (quote-syntax ~not) + (quote-syntax ~seq) + (quote-syntax ~rep) + (quote-syntax ~once) + (quote-syntax ~optional) + (quote-syntax ~between) + (quote-syntax ~rest) + (quote-syntax ~describe) + (quote-syntax ~!) + (quote-syntax ~bind) + (quote-syntax ~fail) + (quote-syntax ~parse) + (quote-syntax ~do) + (quote-syntax ~undo) + (quote-syntax ...+) + (quote-syntax ~delimit-cut) + (quote-syntax ~commit) + (quote-syntax ~reflect) + (quote-syntax ~splicing-reflect) + (quote-syntax ~eh-var) + (quote-syntax ~peek) + (quote-syntax ~peek-not))) + +(define (reserved? stx) + (and (identifier? stx) + (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)) + +;; A LookupConfig is one of 'no, 'try, 'yes +;; 'no means don't lookup, always use dummy (no nested attrs) +;; 'try means lookup, but on failure use dummy (-> nested attrs only from prev.) +;; 'yes means lookup, raise error on failure + +;; stxclass-lookup-config : parameterof LookupConfig +(define stxclass-lookup-config (make-parameter 'yes)) + +;; stxclass-colon-notation? : (parameterof boolean) +;; if #t, then x:sc notation means (~var x sc) +;; otherwise, just a var +(define stxclass-colon-notation? (make-parameter #t)) + + +;; --- + +(define (disappeared! x) + (cond [(identifier? x) + (record-disappeared-uses (list x))] + [(and (stx-pair? x) (identifier? (stx-car x))) + (record-disappeared-uses (list (stx-car x)))] + [else + (raise-type-error 'disappeared! + "identifier or syntax with leading identifier" + x)])) + +(define (propagate-disappeared! stx) + (cond [(and (syntax? stx) (syntax-property stx 'disappeared-use)) + => (lambda (xs) (record-disappeared-uses (filter identifier? (flatten xs)) #f))])) + +;; --- + +;; parse-rhs : Syntax Boolean #:context Syntax #:default-description (U String #f) -> RHS +(define (parse-rhs stx splicing? #:context ctx #:default-description [default-description #f]) + (call/txlifts + (lambda () + (parameterize ((current-syntax-context ctx)) + (define-values (rest description transp? attributes auto-nested? colon-notation? + decls defs commit? delimit-cut?) + (parse-rhs/part1 stx splicing?)) + (define variants + (parameterize ((stxclass-lookup-config (if auto-nested? 'try 'no)) + (stxclass-colon-notation? colon-notation?)) + (parse-variants rest decls splicing?))) + (define sattrs + (or attributes + (filter (lambda (a) (symbol-interned? (attr-name a))) + (intersect-sattrss (map variant-attrs variants))))) + (make rhs sattrs transp? (or description #`(quote #,default-description)) variants + (append (get-txlifts-as-definitions) defs) + commit? delimit-cut?))))) + +(define (parse-rhs/part1 stx splicing?) + (define-values (chunks rest) + (parse-keyword-options stx rhs-directive-table + #:context (current-syntax-context) + #: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 colon-notation? (not (assq '#:disable-colon-notation chunks))) + (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)) + (values rest description transparent? attributes auto-nested? colon-notation? + decls defs commit? delimit-cut?)) + +;; ---- + +(define (parse-variants rest decls splicing?) + (define (gather-variants stx) + (syntax-case stx (pattern) + [((pattern . _) . rest) + (begin (disappeared! (stx-car stx)) + (cons (parse-variant (stx-car stx) splicing? decls) + (gather-variants #'rest)))] + [(bad-variant . rest) + (wrong-syntax #'bad-variant "expected syntax-class variant")] + [() + null])) + (gather-variants rest)) + +;; get-decls+defs : chunks boolean -> (values DeclEnv (listof syntax)) +(define (get-decls+defs chunks #:context [ctx (current-syntax-context)]) + (parameterize ((current-syntax-context ctx)) + (let*-values ([(decls defs1) (get-decls chunks)] + [(decls defs2) (decls-create-defs decls)]) + (values decls (append defs1 defs2))))) + +;; get-decls : chunks -> (values DeclEnv (listof syntax)) +(define (get-decls chunks) + (define lits (options-select-value chunks '#:literals #:default null)) + (define datum-lits (options-select-value chunks '#:datum-literals #:default null)) + (define litsets (options-select-value chunks '#:literal-sets #:default null)) + (define convs (options-select-value chunks '#:conventions #:default null)) + (define localconvs (options-select-value chunks '#:local-conventions #:default null)) + (define literals + (append/check-lits+litsets lits datum-lits litsets)) + (define-values (convs-rules convs-defs) + (for/fold ([convs-rules null] [convs-defs null]) + ([conv-entry (in-list convs)]) + (let* ([c (car 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 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 Argument -> syntax +(define (make-conventions-def dens get-parsers-id argu) + (with-syntax ([(parser ...) (map den:delayed-parser dens)] + [get-parsers get-parsers-id] + [argu argu]) + #'(define-values (parser ...) + (apply values (app-argu get-parsers argu))))) + +;; decls-create-defs : DeclEnv -> (values DeclEnv (listof stx)) +(define (decls-create-defs decls0) + (define (updater key value defs) + (let-values ([(value newdefs) (create-aux-def value)]) + (values value (append newdefs defs)))) + (declenv-update/fold decls0 updater null)) + +;; create-aux-def : DeclEntry -> (values DeclEntry (listof stx)) +;; FIXME: replace with txlift mechanism +(define (create-aux-def entry) + (match entry + [(? den:lit?) + (values entry null)] + [(? den:datum-lit?) + (values entry null)] + [(? den:magic-class?) + (values entry null)] + [(den:class name scname argu) + (with-syntax ([parser (generate-temporary scname)]) + (values (make den:delayed #'parser scname) + (list #`(define-values (parser) (curried-stxclass-parser #,scname #,argu)))))] + [(? den:delayed?) + (values entry null)])) + +;; append/check-lits+litsets : .... -> (listof (U den:lit den:datum-lit)) +(define (append/check-lits+litsets lits datum-lits litsets) + (define seen (make-bound-id-table)) + (define (check-id id [blame-ctx id]) + (if (bound-id-table-ref seen id #f) + (wrong-syntax blame-ctx "duplicate literal declaration: ~s" (syntax-e id)) + (bound-id-table-set! seen id #t)) + id) + (let* ([litsets* + (for/list ([entry (in-list litsets)]) + (let ([litset-id (first entry)] + [litset (second entry)] + [lctx (third entry)] + [input-phase (fourth entry)]) + (define (get/check-id sym) + (check-id (datum->syntax lctx sym) litset-id)) + (for/list ([lse (in-list (literalset-literals litset))]) + (match lse + [(lse:lit internal external lit-phase) + (let ([internal (get/check-id internal)] + [external (syntax-property external 'literal (gensym))]) + (make den:lit internal external input-phase lit-phase))] + [(lse:datum-lit internal external) + (let ([internal (get/check-id internal)]) + (make den:datum-lit internal external))]))))] + [lits* + (for/list ([lit (in-list lits)]) + (check-id (den:lit-internal lit)) + lit)] + [datum-lits* + (for/list ([datum-lit (in-list datum-lits)]) + (check-id (den:datum-lit-internal datum-lit)) + datum-lit)]) + (apply append lits* datum-lits* litsets*))) + +;; parse-variant : stx boolean DeclEnv -> RHS +(define (parse-variant stx splicing? decls0) + (syntax-case stx (pattern) + [(pattern p . rest) + (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* ([attrs (pattern-attrs pattern)] + [sattrs (iattrs->sattrs attrs)]) + (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 #:kind 'main)] + [pattern (combine-pattern+sides pattern0 sides splicing?)]) + (values rest pattern defs)))) + +;; parse-whole-pattern : stx DeclEnv boolean -> Pattern +;; kind is either 'main or 'with, indicates what kind of pattern declare affects +(define (parse-whole-pattern stx decls [splicing? #f] + #:kind kind + #:context [ctx (current-syntax-context)]) + (parameterize ((current-syntax-context ctx)) + (define pattern + (if splicing? + (parse-head-pattern stx decls) + (parse-single-pattern stx decls))) + (define pvars (map attr-name (pattern-attrs pattern))) + (define excess-domain (declenv-domain-difference decls pvars)) + (when (pair? excess-domain) + (wrong-syntax (car excess-domain) + (string-append + "identifier in #:declare clause does not appear in pattern" + (case kind + [(main) ""] ;; ";\n this #:declare clause affects only the main pattern"] + [(with) ";\n this #:declare clause affects only the preceding #:with pattern"])))) + pattern)) + +;; combine-pattern+sides : Pattern (listof SideClause) -> Pattern +(define (combine-pattern+sides pattern sides splicing?) + (check-pattern + (cond [(pair? sides) + (define actions-pattern + (create-action:and (ord-and-patterns sides (gensym*)))) + (define and-patterns + (ord-and-patterns (list pattern (pat:action actions-pattern (pat:any))) + (gensym*))) + (cond [splicing? (apply hpat:and and-patterns)] + [else (pat:and and-patterns)])] + [else pattern]))) + +;; gensym* : -> UninternedSymbol +;; Like gensym, but with deterministic name from compilation-local counter. +(define gensym*-counter 0) +(define (gensym*) + (set! gensym*-counter (add1 gensym*-counter)) + (string->uninterned-symbol (format "group~a" gensym*-counter))) + +;; ---- + +;; parse-single-pattern : stx DeclEnv -> SinglePattern +(define (parse-single-pattern stx decls) + (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-action-pattern : Stx DeclEnv -> ActionPattern +(define (parse-action-pattern stx decls) + (define p (parse-*-pattern stx decls #f #t)) + (unless (action-pattern? p) + (wrong-syntax stx "expected action pattern")) + p) + +(define ((make-not-shadowed? decls) id) + ;; Returns #f if id is in literals/datum-literals list. + ;; Conventions to not shadow pattern-form bindings, under the + ;; theory that conventions only apply to things already determined + ;; to be pattern variables. + (not (declenv-lookup decls id))) +;; suitable as id=? argument to syntax-case* +(define ((make-not-shadowed-id=? decls) lit-id pat-id) + (and (free-identifier=? lit-id pat-id) + (not (declenv-lookup decls pat-id)))) + +;; parse-*-pattern : stx DeclEnv boolean boolean -> Pattern +(define (parse-*-pattern stx decls allow-head? allow-action?) + (define (recur stx) + (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-action! x) + ;; Coerce to S-pattern IF only S-patterns allowed + (cond [allow-action? x] + [(not allow-head?) (action-pattern->single-pattern x)] + [else + (wrong-syntax stx "action pattern not allowed here")])) + (define not-shadowed? (make-not-shadowed? decls)) + (propagate-disappeared! stx) + (check-pattern + (syntax-case* stx (~var ~literal ~datum ~and ~or ~or* ~alt ~not ~rest ~describe + ~seq ~optional ~! ~bind ~fail ~parse ~do ~undo + ~post ~peek ~peek-not ~delimit-cut ~commit ~reflect + ~splicing-reflect) + (make-not-shadowed-id=? decls) + [id + (and (identifier? #'id) + (not-shadowed? #'id) + (pattern-expander? (syntax-local-value #'id (λ () #f)))) + (begin (disappeared! #'id) + (recur (expand-pattern (syntax-local-value #'id) stx)))] + [(id . rst) + (and (identifier? #'id) + (not-shadowed? #'id) + (pattern-expander? (syntax-local-value #'id (λ () #f)))) + (begin (disappeared! #'id) + (recur (expand-pattern (syntax-local-value #'id) stx)))] + [wildcard + (and (wildcard? #'wildcard) + (not-shadowed? #'wildcard)) + (begin (disappeared! stx) + (pat:any))] + [~! + (disappeared! stx) + (begin + (unless (cut-allowed?) + (wrong-syntax stx + "cut (~~!) not allowed within ~~not pattern")) + (check-action! + (action:cut)))] + [reserved + (and (reserved? #'reserved) + (not-shadowed? #'reserved)) + (wrong-syntax stx "pattern keyword not allowed here")] + [id + (identifier? #'id) + (parse-pat:id stx decls allow-head?)] + [datum + (atomic-datum-stx? #'datum) + (pat:datum (syntax->datum #'datum))] + [(~var . rest) + (disappeared! stx) + (parse-pat:var stx decls allow-head?)] + [(~datum . rest) + (disappeared! stx) + (syntax-case stx (~datum) + [(~datum d) + (pat:datum (syntax->datum #'d))] + [_ (wrong-syntax stx "bad ~~datum form")])] + [(~literal . rest) + (disappeared! stx) + (parse-pat:literal stx decls)] + [(~and . rest) + (disappeared! stx) + (parse-pat:and stx decls allow-head? allow-action?)] + [(~or . rest) + (disappeared! stx) + (parse-pat:or stx decls allow-head?)] + [(~or* . rest) + (disappeared! stx) + (parse-pat:or stx decls allow-head?)] + [(~alt . rest) + (wrong-syntax stx "ellipsis-head pattern allowed only before ellipsis")] + [(~not . rest) + (disappeared! stx) + (parse-pat:not stx decls)] + [(~rest . rest) + (disappeared! stx) + (parse-pat:rest stx decls)] + [(~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! + (parse-hpat:seq stx #'rest decls))] + [(~optional . rest) + (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-action! + (parse-pat:bind stx decls))] + [(~fail . rest) + (disappeared! stx) + (check-action! + (parse-pat:fail stx decls))] + [(~post . rest) + (disappeared! stx) + (parse-pat:post stx decls allow-head? allow-action?)] + [(~peek . rest) + (disappeared! stx) + (check-head! + (parse-pat:peek stx decls))] + [(~peek-not . rest) + (disappeared! stx) + (check-head! + (parse-pat:peek-not stx decls))] + [(~parse . rest) + (disappeared! stx) + (check-action! + (parse-pat:parse stx decls))] + [(~do . rest) + (disappeared! stx) + (check-action! + (parse-pat:do stx decls))] + [(~undo . rest) + (disappeared! stx) + (check-action! + (parse-pat:undo stx decls))] + [(head dots . tail) + (and (dots? #'dots) (not-shadowed? #'dots)) + (begin (disappeared! #'dots) + (parse-pat:dots stx #'head #'tail decls))] + [(head plus-dots . tail) + (and (plus-dots? #'plus-dots) (not-shadowed? #'plus-dots)) + (begin (disappeared! #'plus-dots) + (parse-pat:plus-dots stx #'head #'tail decls))] + [(head . tail) + (let ([headp (parse-*-pattern #'head decls #t #t)] + [tailp (parse-single-pattern #'tail decls)]) + (cond [(action-pattern? headp) + (pat:action headp tailp)] + [(head-pattern? headp) + (pat:head headp tailp)] + [else (pat:pair headp tailp)]))] + [#(a ...) + (let ([lp (parse-single-pattern (syntax/loc stx (a ...)) decls)]) + (pat:vector lp))] + [b + (box? (syntax-e #'b)) + (let ([bp (parse-single-pattern (unbox (syntax-e #'b)) decls)]) + (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)]) + (pat:pstruct key lp)))]))) + +;; expand-pattern : pattern-expander Syntax -> Syntax +(define (expand-pattern pe stx) + (let ([proc (pattern-expander-proc pe)]) + (local-apply-transformer proc stx 'expression))) + +;; parse-ellipsis-head-pattern : stx DeclEnv -> (listof EllipsisHeadPattern) +(define (parse-ellipsis-head-pattern stx decls) + (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)]) + (define (recur stx) (parse*-ellipsis-head-pattern stx decls allow-or? #:context ctx)) + (define (recur-cdr-list stx) + (unless (stx-list? stx) (wrong-syntax stx "expected sequence of patterns")) + (apply append (map recur (cdr (stx->list stx))))) + (define not-shadowed? (make-not-shadowed? decls)) + (propagate-disappeared! stx) + (syntax-case* stx (~eh-var ~or ~alt ~between ~optional ~once) + (make-not-shadowed-id=? decls) + [id + (and (identifier? #'id) + (not-shadowed? #'id) + (pattern-expander? (syntax-local-value #'id (lambda () #f)))) + (begin (disappeared! #'id) + (recur (expand-pattern (syntax-local-value #'id) stx)))] + [(id . rst) + (and (identifier? #'id) + (not-shadowed? #'id) + (pattern-expander? (syntax-local-value #'id (lambda () #f)))) + (begin (disappeared! #'id) + (recur (expand-pattern (syntax-local-value #'id) stx)))] + [(~eh-var name eh-alt-set-id) + (disappeared! stx) + (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)] + [attr-count (length iattrs)]) + (list (create-ehpat + (hpat:var/p #f (eh-alternative-parser alt) no-arguments iattrs #f + (scopts attr-count #f #t #f)) + (eh-alternative-repc alt) + #f) + (replace-eh-alternative-attrs + alt (iattrs->sattrs iattrs))))))] + [(~or . _) + (disappeared! stx) + (recur-cdr-list stx)] + [(~alt . _) + (disappeared! stx) + (recur-cdr-list stx)] + [(~optional . _) + (disappeared! stx) + (list (parse*-ehpat/optional stx decls))] + [(~once . _) + (disappeared! stx) + (list (parse*-ehpat/once stx decls))] + [(~between . _) + (disappeared! stx) + (list (parse*-ehpat/bounds stx decls))] + [_ + (let ([head (parse-head-pattern stx decls)]) + (list (list (create-ehpat head #f stx) stx)))])) + +(define (replace-eh-alternative-attrs alt sattrs) + (match alt + [(eh-alternative repc _attrs parser) + (eh-alternative repc sattrs parser)])) + +;; ---------------------------------------- +;; Identifiers, ~var, and stxclasses + +(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?) + (cond [(declenv-lookup decls id) + => (lambda (entry) (parse-pat:id/entry id allow-head? entry))] + [(not (safe-name? id)) + (wrong-syntax id "expected identifier not starting with ~~ character")] + [(and (stxclass-colon-notation?) (split-id id)) + => (match-lambda + [(cons name suffix) + (declenv-check-unbound decls name (syntax-e suffix) #:blame-declare? #t) + (define entry (declenv-lookup decls suffix)) + (cond [(or (den:lit? entry) (den:datum-lit? entry)) + (pat:and (list (pat:svar name) (parse-pat:id/entry id allow-head? entry)))] + [else (parse-stxclass-use id allow-head? name suffix no-arguments "." #f)])])] + [(declenv-apply-conventions decls id) + => (lambda (entry) (parse-pat:id/entry id allow-head? entry))] + [else (pat:svar id)])) + +(define (split-id id0) + (cond [(regexp-match #rx"^([^:]*):(.+)$" (symbol->string (syntax-e id0))) + => (lambda (m) + (define src (syntax-source id0)) + (define ln (syntax-line id0)) + (define col (syntax-column id0)) + (define pos (syntax-position id0)) + (define span (syntax-span id0)) + (define id-str (cadr m)) + (define id-len (string-length id-str)) + (define suffix-str (caddr m)) + (define suffix-len (string-length suffix-str)) + (define id + (datum->syntax id0 (string->symbol id-str) + (list src ln col pos id-len) + id0)) + (define suffix + (datum->syntax id0 (string->symbol suffix-str) + (list src ln (and col (+ col id-len 1)) (and pos (+ pos id-len 1)) suffix-len) + id0)) + (cons id suffix))] + [else #f])) + +;; parse-pat:id/entry : Identifier .... DeclEntry -> SinglePattern +;; Handle when meaning of identifier pattern is given by declenv entry. +(define (parse-pat:id/entry id allow-head? entry) + (match entry + [(den:lit internal literal input-phase lit-phase) + (pat:literal literal input-phase lit-phase)] + [(den:datum-lit internal sym) + (pat:datum sym)] + [(den:magic-class name scname argu role) + (parse-stxclass-use scname allow-head? id scname argu "." role)] + [(den:class _n _c _a) + (error 'parse-pat:id + "(internal error) decls had leftover stxclass entry: ~s" + entry)] + [(den:delayed parser scname) + (parse-stxclass-use id allow-head? id scname no-arguments "." #f parser)])) + +(define (parse-pat:var stx decls allow-head?) + (define name0 + (syntax-case stx () + [(_ name . _) + (unless (identifier? #'name) + (wrong-syntax #'name "expected identifier")) + #'name] + [_ + (wrong-syntax stx "bad ~~var form")])) + (define-values (scname sc+args-stx argu pfx role) + (syntax-case stx () + [(_ _name) + (values #f #f null #f #f)] + [(_ _name sc/sc+args . rest) + (let-values ([(sc argu) + (let ([p (check-stxclass-application #'sc/sc+args stx)]) + (values (car p) (cdr p)))]) + (define chunks + (parse-keyword-options/eol #'rest var-pattern-directive-table + #:no-duplicates? #t + #:context stx)) + (define sep + (options-select-value chunks '#:attr-name-separator #:default #f)) + (define role (options-select-value chunks '#:role #:default #'#f)) + (values sc #'sc/sc+args argu (if sep (syntax-e sep) ".") role))] + [_ + (wrong-syntax stx "bad ~~var form")])) + (cond [(and (epsilon? name0) (not scname)) + (wrong-syntax name0 "illegal pattern variable name")] + [(and (wildcard? name0) (not scname)) + (pat:any)] + [scname + (parse-stxclass-use stx allow-head? name0 scname argu pfx role)] + [else ;; Just proper name + (pat:svar name0)])) + +;; ---- + +(define (parse-stxclass-use stx allow-head? varname scname argu pfx role [parser* #f]) + (define config (stxclass-lookup-config)) + (cond [(and (memq config '(yes try)) (get-stxclass scname (eq? config 'try))) + => (lambda (sc) + (unless parser* + (check-stxclass-arity sc stx (length (arguments-pargs argu)) (arguments-kws argu))) + (parse-stxclass-use* stx allow-head? varname sc argu pfx role parser*))] + [else + (define bind (name->bind varname)) + (pat:fixup stx bind varname scname argu pfx role parser*)])) + +;; ---- + +(define (parse-stxclass-use* stx allow-head? name sc argu pfx role parser*) + ;; if parser* not #f, overrides sc parser + (check-no-delimit-cut-in-not stx (scopts-delimit-cut? (stxclass-opts sc))) + (define bind (name->bind name)) + (define prefix (name->prefix name pfx)) + (define parser (or parser* (stxclass-parser sc))) + (define nested-attrs (id-pattern-attrs (stxclass-attrs sc) prefix)) + (define opts (stxclass-opts sc)) + (cond [(and (stxclass/s? sc) (stxclass-inline sc) (equal? argu no-arguments)) + (pat:integrated bind (stxclass-inline sc) (scopts-desc opts) role)] + [(stxclass/s? sc) + (pat:var/p bind parser argu nested-attrs role opts)] + [(stxclass/h? sc) + (unless allow-head? + (wrong-syntax stx "splicing syntax class not allowed here")) + (hpat:var/p bind parser argu nested-attrs role opts)])) + +(define (name->prefix id pfx) + (cond [(wildcard? id) #f] + [(epsilon? id) id] + [else (format-id id "~a~a" (syntax-e id) pfx #:source id)])) + +(define (name->bind id) + (cond [(wildcard? id) #f] + [(epsilon? id) #f] + [else id])) + +;; id-pattern-attrs : (listof SAttr)IdPrefix -> (listof IAttr) +(define (id-pattern-attrs sattrs prefix) + (if prefix + (for/list ([a (in-list sattrs)]) + (prefix-attr a prefix)) + null)) + +;; prefix-attr : SAttr identifier -> IAttr +(define (prefix-attr a prefix) + (make attr (prefix-attr-name prefix (attr-name a)) + (attr-depth a) + (attr-syntax? a))) + +;; prefix-attr-name : id symbol -> id +(define (prefix-attr-name prefix name) + (orig (format-id prefix "~a~a" (syntax-e prefix) name #:source prefix))) + +(define (orig stx) + (syntax-property stx 'original-for-check-syntax #t)) + +;; ---------------------------------------- +;; Other pattern forms + +(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? hpat:reflect 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 () + [(_ lit . more) + (unless (identifier? #'lit) + (wrong-syntax #'lit "expected identifier")) + (let* ([chunks (parse-keyword-options/eol #'more phase-directive-table + #:no-duplicates? #t + #:context stx)] + [phase (options-select-value chunks '#:phase + #:default #'(syntax-local-phase-level))]) + ;; FIXME: Duplicates phase expr! + (pat:literal #'lit phase phase))] + [_ + (wrong-syntax stx "bad ~~literal pattern")])) + +(define (parse-pat:describe stx decls allow-head?) + (syntax-case stx () + [(_ . rest) + (let-values ([(chunks rest) + (parse-keyword-options #'rest describe-option-table + #:no-duplicates? #t + #:context stx)]) + (define transparent? (not (assq '#:opaque chunks))) + (define role (options-select-value chunks '#:role #:default #'#f)) + (syntax-case rest () + [(description pattern) + (let ([p (parse-*-pattern #'pattern decls allow-head? #f)]) + (if (head-pattern? p) + (hpat:describe p #'description transparent? role) + (pat:describe p #'description transparent? role)))]))])) + +(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) + (hpat:delimit p) + (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) + (hpat:commit p) + (pat:commit p)))])) + +(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)) + (cond [(andmap action-pattern? patterns0) + (cond [allow-action? + (define patterns1 (ord-and-patterns patterns0 (gensym*))) + (action:and patterns1)] + [allow-head? + (wrong-syntax stx "expected at least one head or single-term pattern")] + [else + (wrong-syntax stx "expected at least one single-term pattern")])] + [(memq (stxclass-lookup-config) '(no try)) + (pat:and/fixup stx patterns0)] + [else (parse-pat:and/k stx patterns0)])) + +(define (parse-pat:and/k stx patterns0) + ;; PRE: patterns0 not all action patterns + (define patterns1 (ord-and-patterns patterns0 (gensym*))) + (define-values (actions patterns) (split-prefix patterns1 action-pattern?)) + (add-actions actions (parse-pat:and/k* stx (length actions) patterns))) + +(define (parse-pat:and/k* stx actions-len patterns) + ;; PRE: patterns non-empty, starts with non-action pattern + (cond [(null? (cdr patterns)) + (car patterns)] + [(ormap head-pattern? patterns) + ;; Check to make sure *all* are head patterns + (for ([pattern (in-list patterns)] + [pattern-stx (in-list (drop (stx->list (stx-cdr stx)) actions-len))]) + (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 action/head-pattern->list-pattern (cdr patterns))]) + (hpat:and p0 (pat:and lps)))] + [else + (pat:and + (for/list ([p (in-list patterns)]) + (if (action-pattern? p) + (action-pattern->single-pattern p) + p)))])) + +(define (split-prefix xs pred) + (let loop ([xs xs] [rprefix null]) + (cond [(and (pair? xs) (pred (car xs))) + (loop (cdr xs) (cons (car xs) rprefix))] + [else + (values (reverse rprefix) xs)]))) + +(define (add-actions actions p) + (if (head-pattern? p) + (for/fold ([p p]) ([action (in-list (reverse actions))]) + (hpat:action action p)) + (for/fold ([p p]) ([action (in-list (reverse actions))]) + (pat:action action p)))) + +(define (parse-pat:or stx decls allow-head?) + (define patterns (parse-cdr-patterns stx decls allow-head? #f)) + (cond [(null? (cdr patterns)) + (car patterns)] + [else + (cond [(ormap head-pattern? patterns) + (create-hpat:or patterns)] + [else + (create-pat:or patterns)])])) + +(define (parse-pat:not stx decls) + (syntax-case stx () + [(_ pattern) + (let ([p (parameterize ((cut-allowed? #f)) + (parse-single-pattern #'pattern decls))]) + (pat:not p))] + [_ + (wrong-syntax stx "expected a single subpattern")])) + +(define (parse-hpat:seq stx list-stx decls) + (define pattern (parse-single-pattern list-stx decls)) + (unless (proper-list-pattern? pattern) + (wrong-syntax stx "expected proper list pattern")) + (hpat:seq pattern)) + +(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 (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)) + +(define (parse-pat:dots stx head tail decls) + (define headps (parse-ellipsis-head-pattern head decls)) + (define tailp (parse-single-pattern tail decls)) + (unless (pair? headps) + (wrong-syntax head "expected at least one pattern")) + (pat:dots headps tailp)) + +(define (parse-pat:plus-dots stx head tail decls) + (define headp (parse-head-pattern head decls)) + (define tailp (parse-single-pattern tail decls)) + (define head/rep (create-ehpat headp (make-rep:bounds 1 +inf.0 #f #f #f) head)) + (pat:dots (list head/rep) tailp)) + +(define (parse-pat:bind stx decls) + (syntax-case stx () + [(_ clause ...) + (let ([clauses (check-bind-clause-list #'(clause ...) stx)]) + (create-action:and clauses))])) + +(define (parse-pat:fail stx decls) + (syntax-case stx () + [(_ . rest) + (let-values ([(chunks rest) + (parse-keyword-options #'rest fail-directive-table + #:context stx + #:incompatible '((#:when #:unless)) + #:no-duplicates? #t)]) + (let ([condition + (if (null? chunks) + #'#t + (let ([chunk (car chunks)]) + (if (eq? (car chunk) '#:when) + (caddr chunk) + #`(not #,(caddr chunk)))))]) + (syntax-case rest () + [(message) + (action:fail condition #'message)] + [() + (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? (action:post p)] + [(not allow-head?) (pat:post (action-pattern->single-pattern p))] + [else (wrong-syntax stx "action pattern not allowed here")])] + [(head-pattern? p) + (cond [allow-head? (hpat:post p)] + [else (wrong-syntax stx "head pattern not allowed here")])] + [else (pat:post p)]))])) + +(define (parse-pat:peek stx decls) + (syntax-case stx () + [(_ pattern) + (let ([p (parse-head-pattern #'pattern decls)]) + (hpat:peek p))])) + +(define (parse-pat:peek-not stx decls) + (syntax-case stx () + [(_ pattern) + (let ([p (parse-head-pattern #'pattern decls)]) + (hpat:peek-not p))])) + +(define (parse-pat:parse stx decls) + (syntax-case stx () + [(_ pattern expr) + (let ([p (parse-single-pattern #'pattern decls)]) + (action:parse p #'expr))] + [_ + (wrong-syntax stx "bad ~~parse pattern")])) + +(define (parse-pat:do stx decls) + (syntax-case stx () + [(_ stmt ...) + (action:do (syntax->list #'(stmt ...)))] + [_ + (wrong-syntax stx "bad ~~do pattern")])) + +(define (parse-pat:undo stx decls) + (syntax-case stx () + [(_ stmt ...) + (action:undo (syntax->list #'(stmt ...)))] + [_ + (wrong-syntax stx "bad ~~undo pattern")])) + +(define (parse-pat:rest stx decls) + (syntax-case stx () + [(_ pattern) + (parse-single-pattern #'pattern decls)])) + +(define (parse-hpat:optional stx decls) + (define-values (head-stx head iattrs _name _tmm defaults) + (parse*-optional-pattern stx decls h-optional-directive-table)) + (create-hpat:or + (list head + (hpat:action (create-action:and defaults) + (hpat:seq (pat:datum '())))))) + +;; parse*-optional-pattern : stx DeclEnv table +;; -> (values Syntax HeadPattern IAttrs Stx Stx (Listof BindClause)) +(define (parse*-optional-pattern stx decls optional-directive-table) + (syntax-case stx () + [(_ p . options) + (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 (map pattern-attrs defaults))] + [all-iattrs + (union-iattrs (list pattern-iattrs defaults-iattrs))]) + (when (eq? (stxclass-lookup-config) 'yes) + ;; Only check that attrs in defaults clause agree with attrs + ;; in pattern when attrs in pattern are known to be complete. + (check-iattrs-subset defaults-iattrs pattern-iattrs stx)) + (values #'p head all-iattrs name too-many-msg defaults))])) + +;; -- 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 (create-ehpat head (make rep:optional name too-many-msg defaults) head-stx) + head-stx)) + +;; parse*-ehpat/once : stx DeclEnv -> (list EllipsisHeadPattern stx) +(define (parse*-ehpat/once stx decls) + (syntax-case stx () + [(_ p . options) + (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 (create-ehpat head (make rep:once name too-few-msg too-many-msg) #'p) + #'p))])) + +;; parse*-ehpat/bounds : stx DeclEnv -> (list EllipsisHeadPattern stx) +(define (parse*-ehpat/bounds stx decls) + (syntax-case stx () + [(_ p min max . options) + (let () + (define head (parse-head-pattern #'p decls)) + (define minN (syntax-e #'min)) + (define maxN (syntax-e #'max)) + (unless (exact-nonnegative-integer? minN) + (wrong-syntax #'min + "expected exact nonnegative integer")) + (unless (or (exact-nonnegative-integer? maxN) (equal? maxN +inf.0)) + (wrong-syntax #'max + "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)] + [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 (create-ehpat head + (make rep:bounds #'min #'max + name too-few-msg too-many-msg) + #'p) + #'p)))])) + + +;; ============================================================ + +(define (fixup-rhs the-rhs allow-head? expected-attrs) + (match the-rhs + [(rhs attrs tr? desc vs defs commit? delimit-cut?) + (define vs* (for/list ([v (in-list vs)]) (fixup-variant v allow-head? expected-attrs))) + (rhs attrs tr? desc vs* defs commit? delimit-cut?)])) + +(define (fixup-variant v allow-head? expected-attrs) + (match v + [(variant stx sattrs p defs) + (parameterize ((current-syntax-context stx)) + (define p* + (parameterize ((stxclass-lookup-config 'yes)) + (fixup-pattern p allow-head?))) + ;; (eprintf "~v\n===>\n~v\n\n" p p*) + ;; Called just for error-reporting + (reorder-iattrs expected-attrs (pattern-attrs p*)) + (variant stx sattrs p* defs))])) + +(define (fixup-pattern p0 allow-head?) + (define (S p) (fixup p #f)) + (define (S* p) (fixup p #t)) + (define (A/S* p) (if (action-pattern? p) (A p) (S* p))) + + (define (A p) + (match p + ;; [(action:cut) + ;; (action:cut)] + ;; [(action:fail when msg) + ;; (action:fail when msg)] + ;; [(action:bind attr expr) + ;; (action:bind attr expr)] + [(action:and ps) + (action:and (map A ps))] + [(action:parse sp expr) + (action:parse (S sp) expr)] + ;; [(action:do stmts) + ;; (action:do stmts)] + ;; [(action:undo stmts) + ;; (action:undo stmts)] + [(action:ord sp group index) + (create-ord-pattern (A sp) group index)] + [(action:post sp) + (create-post-pattern (A sp))] + ;; ---- + ;; Default: no sub-patterns, just return + [p p])) + (define (EH p) + (match p + [(ehpat iattrs hp repc check-null?) + (create-ehpat (H hp) repc #f)])) + + (define (fixup p allow-head?) + (define (I p) (fixup p allow-head?)) + (match p + [(pat:fixup stx bind varname scname argu pfx role parser*) + (parse-stxclass-use stx allow-head? varname scname argu pfx role parser*)] + ;; ---- + ;; [(pat:any) + ;; (pat:any)] + ;; [(pat:svar name) + ;; (pat:svar name)] + ;; [(pat:var/p name parser argu nested-attrs role opts) + ;; (pat:var/p name parser argu nested-attrs role opts)] + ;; [(pat:integrated name predicate desc role) + ;; (pat:integrated name predicate desc role)] + ;; [(pat:reflect obj argu attr-decls name nested-attrs) + ;; (pat:reflect obj argu attr-decls name nested-attrs)] + ;; [(pat:datum d) + ;; (pat:datum d)] + ;; [(pat:literal id input-phase lit-phase) + ;; (pat:literal id input-phase lit-phase)] + [(pat:vector sp) + (pat:vector (S sp))] + [(pat:box sp) + (pat:box (S sp))] + [(pat:pstruct key sp) + (pat:pstruct key (S sp))] + [(pat:not sp) + (parameterize ((cut-allowed? #f)) + (pat:not (S sp)))] + [(pat:dots headps tailp) + (pat:dots (map EH headps) (S tailp))] + [(pat:head headp tailp) + (pat:head (H headp) (S tailp))] + ;; --- The following patterns may change if a subpattern switches to head pattern ---- + [(pat:pair headp tailp) + (let ([headp (S* headp)] [tailp (S tailp)]) + (if (head-pattern? headp) (pat:head headp tailp) (pat:pair headp tailp)))] + [(pat:action a sp) + (let ([a (A a)] [sp (I sp)]) + (if (head-pattern? sp) (hpat:action a sp) (pat:action a sp)))] + [(pat:describe sp desc tr? role) + (let ([sp (I sp)]) + (if (head-pattern? sp) (hpat:describe sp desc tr? role) (pat:describe sp desc tr? role)))] + [(pat:and ps) + (let ([ps (map I ps)]) + (pat:and ps))] + [(pat:and/fixup stx ps) + (let ([ps (for/list ([p (in-list ps)]) + (cond [(action-pattern? p) (A p)] + [allow-head? (H p)] + [else (I p)]))]) + (parse-pat:and/k stx ps))] + [(pat:or _ ps _) + (let ([ps (map I ps)]) + (if (ormap head-pattern? ps) (create-hpat:or ps) (create-pat:or ps)))] + [(pat:delimit sp) + (let ([sp (parameterize ((cut-allowed? #t)) (I sp))]) + (if (head-pattern? sp) (hpat:delimit sp) (pat:delimit sp)))] + [(pat:commit sp) + (let ([sp (parameterize ((cut-allowed? #t)) (I sp))]) + (if (head-pattern? sp) (hpat:commit sp) (pat:commit sp)))] + [(pat:ord sp group index) + (create-ord-pattern (I sp) group index)] + [(pat:post sp) + (create-post-pattern (I sp))] + ;; ---- + ;; Default: no sub-patterns, just return + [p p])) + + (define (H p) + (match p + ;; [(hpat:var/p name parser argu nested-attrs role scopts) + ;; (hpat:var/p name parser argu nested-attrs role scopts)] + ;; [(hpat:reflect obj argu attr-decls name nested-attrs) + ;; (hpat:reflect obj argu attr-decls name nested-attrs)] + [(hpat:seq lp) + (hpat:seq (S lp))] + [(hpat:action a hp) + (hpat:action (A a) (H hp))] + [(hpat:describe hp desc tr? role) + (hpat:describe (H hp) desc tr? role)] + [(hpat:and hp sp) + (hpat:and (H hp) (S sp))] + [(hpat:or _ ps _) + (create-hpat:or (map H ps))] + [(hpat:delimit hp) + (parameterize ((cut-allowed? #t)) + (hpat:delimit (H hp)))] + [(hpat:commit hp) + (parameterize ((cut-allowed? #t)) + (hpat:commit (H hp)))] + [(hpat:ord hp group index) + (create-ord-pattern (H hp) group index)] + [(hpat:post hp) + (create-post-pattern (H hp))] + [(hpat:peek hp) + (hpat:peek (H hp))] + [(hpat:peek-not hp) + (hpat:peek-not (H hp))] + [(? pattern? sp) + (S* sp)] + ;; ---- + ;; Default: no sub-patterns, just return + [p p])) + + (if allow-head? (H p0) (S p0))) + +;; ============================================================ + +;; parse-pattern-directives : stxs(PatternDirective) +;; -> stx DeclEnv (listof stx) (listof SideClause) +(define (parse-pattern-directives stx + #:allow-declare? allow-declare? + #:decls decls + #:context ctx) + (parameterize ((current-syntax-context ctx)) + (define-values (chunks rest) + (parse-keyword-options stx pattern-directive-table #:context ctx)) + (define-values (decls2 chunks2) + (if allow-declare? + (grab-decls chunks decls) + (values decls chunks))) + (define sides + ;; NOTE: use *original* decls + ;; because decls2 has #:declares for *above* pattern + (parse-pattern-sides chunks2 decls)) + (define-values (decls3 defs) + (decls-create-defs decls2)) + (values rest decls3 defs sides))) + +;; parse-pattern-sides : (listof chunk) DeclEnv -> (listof SideClause) +;; Invariant: decls contains only literals bindings +(define (parse-pattern-sides chunks decls) + (match chunks + [(cons (list '#:declare declare-stx _ _) rest) + (wrong-syntax declare-stx + "#:declare can only appear immediately after pattern or #:with clause")] + [(cons (list '#:role role-stx _) rest) + (wrong-syntax role-stx "#:role can only appear immediately after #:declare clause")] + [(cons (list '#:fail-when fw-stx when-expr msg-expr) rest) + (cons (create-post-pattern (action:fail when-expr msg-expr)) + (parse-pattern-sides rest decls))] + [(cons (list '#:fail-unless fu-stx unless-expr msg-expr) rest) + (cons (create-post-pattern (action:fail #`(not #,unless-expr) msg-expr)) + (parse-pattern-sides rest decls))] + [(cons (list '#:when w-stx unless-expr) rest) + (cons (create-post-pattern (action:fail #`(not #,unless-expr) #'#f)) + (parse-pattern-sides rest decls))] + [(cons (list '#:with with-stx pattern expr) rest) + (let-values ([(decls2 rest) (grab-decls rest decls)]) + (let-values ([(decls2a defs) (decls-create-defs decls2)]) + (list* (action:do defs) + (create-post-pattern + (action:parse (parse-whole-pattern pattern decls2a #:kind 'with) expr)) + (parse-pattern-sides rest decls))))] + [(cons (list '#:attr attr-stx a expr) rest) + (cons (action:bind a expr) ;; no POST wrapper, cannot fail + (parse-pattern-sides rest decls))] + [(cons (list '#:post post-stx pattern) rest) + (cons (create-post-pattern (parse-action-pattern pattern decls)) + (parse-pattern-sides rest decls))] + [(cons (list '#:and and-stx pattern) rest) + (cons (parse-action-pattern pattern decls) ;; no POST wrapper + (parse-pattern-sides rest decls))] + [(cons (list '#:do do-stx stmts) rest) + (cons (action:do stmts) + (parse-pattern-sides rest decls))] + [(cons (list '#:undo undo-stx stmts) rest) + (cons (action:undo stmts) + (parse-pattern-sides rest decls))] + [(cons (list '#:cut cut-stx) rest) + (cons (action:cut) + (parse-pattern-sides rest decls))] + ['() + '()])) + +;; grab-decls : (listof chunk) DeclEnv +;; -> (values DeclEnv (listof chunk)) +(define (grab-decls chunks decls0) + (define (add-decl stx role-stx decls) + (let ([role + (and role-stx + (syntax-case role-stx () + [(#:role role) #'role]))]) + (syntax-case stx () + [(#:declare name sc) + (identifier? #'sc) + (add-decl* decls #'name #'sc (parse-argu null) role)] + [(#:declare name (sc expr ...)) + (identifier? #'sc) + (add-decl* decls #'name #'sc (parse-argu (syntax->list #'(expr ...))) role)] + [(#:declare name bad-sc) + (wrong-syntax #'bad-sc + "expected syntax class name (possibly with parameters)")]))) + (define (add-decl* decls id sc-name argu role) + (declenv-put-stxclass decls id sc-name argu role)) + (define (loop chunks decls) + (match chunks + [(cons (cons '#:declare decl-stx) + (cons (cons '#:role role-stx) rest)) + (loop rest (add-decl decl-stx role-stx decls))] + [(cons (cons '#:declare decl-stx) rest) + (loop rest (add-decl decl-stx #f decls))] + [_ (values decls chunks)])) + (loop chunks decls0)) + + +;; ---- + +;; Keyword Options & Checkers + +;; check-attr-arity-list : stx stx -> (listof SAttr) +(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 (in-list (stx->list stx))]) + (check-attr-arity x ctx))]) + (iattrs->sattrs (append-iattrs (map list iattrs))))) + +;; check-attr-arity : stx stx -> IAttr +(define (check-attr-arity stx ctx) + (syntax-case stx () + [attr + (identifier? #'attr) + (make-attr #'attr 0 #f)] + [(attr depth) + (begin (unless (identifier? #'attr) + (raise-syntax-error #f "expected attribute name" ctx #'attr)) + (unless (exact-nonnegative-integer? (syntax-e #'depth)) + (raise-syntax-error #f "expected depth (nonnegative integer)" ctx #'depth)) + (make-attr #'attr (syntax-e #'depth) #f))] + [_ + (raise-syntax-error #f "expected attribute name with optional depth declaration" ctx stx)])) + +;; check-literals-list : stx stx -> (listof den:lit) +;; - txlifts defs of phase expressions +;; - txlifts checks that literals are bound +(define (check-literals-list stx ctx) + (unless (stx-list? stx) + (raise-syntax-error #f "expected literals list" ctx stx)) + (for/list ([x (in-list (stx->list stx))]) + (check-literal-entry x ctx))) + +;; check-literal-entry : stx stx -> den:lit +(define (check-literal-entry stx ctx) + (define (go internal external phase) + (txlift #`(check-literal #,external #,phase #,ctx)) + (let ([external (syntax-property external 'literal (gensym))]) + (make den:lit internal external phase phase))) + (syntax-case stx () + [(internal external #:phase phase) + (and (identifier? #'internal) (identifier? #'external)) + (go #'internal #'external (txlift #'phase))] + [(internal external) + (and (identifier? #'internal) (identifier? #'external)) + (go #'internal #'external #'(syntax-local-phase-level))] + [id + (identifier? #'id) + (go #'id #'id #'(syntax-local-phase-level))] + [_ + (raise-syntax-error #f "expected literal entry" ctx stx)])) + +;; check-datum-literals-list : stx stx -> (listof den:datum-lit) +(define (check-datum-literals-list stx ctx) + (unless (stx-list? stx) + (raise-syntax-error #f "expected datum-literals list" ctx stx)) + (for/list ([x (in-list (stx->list stx))]) + (check-datum-literal-entry x ctx))) + +;; check-datum-literal-entry : stx stx -> den:datum-lit +(define (check-datum-literal-entry stx ctx) + (syntax-case stx () + [(internal external) + (and (identifier? #'internal) (identifier? #'external)) + (make den:datum-lit #'internal (syntax-e #'external))] + [id + (identifier? #'id) + (make den:datum-lit #'id (syntax-e #'id))] + [_ + (raise-syntax-error #f "expected datum-literal entry" ctx stx)])) + +;; Literal sets - Import + +;; check-literal-sets-list : stx stx -> (listof (list id literalset stx stx)) +(define (check-literal-sets-list stx ctx) + (unless (stx-list? stx) + (raise-syntax-error #f "expected literal-set list" ctx stx)) + (for/list ([x (in-list (stx->list stx))]) + (check-literal-set-entry x ctx))) + +;; check-literal-set-entry : stx stx -> (list id literalset stx stx) +(define (check-literal-set-entry stx ctx) + (define (elaborate litset-id lctx phase) + (let ([litset (syntax-local-value/record litset-id literalset?)]) + (unless litset + (raise-syntax-error #f "expected identifier defined as a literal-set" + ctx litset-id)) + (list litset-id litset lctx phase))) + (syntax-case stx () + [(litset . more) + (and (identifier? #'litset)) + (let* ([chunks (parse-keyword-options/eol #'more litset-directive-table + #:no-duplicates? #t + #:context ctx)] + [lctx (options-select-value chunks '#:at #:default #'litset)] + [phase (options-select-value chunks '#:phase + #:default #'(syntax-local-phase-level))]) + (elaborate #'litset lctx (txlift phase)))] + [litset + (identifier? #'litset) + (elaborate #'litset #'litset #'(syntax-local-phase-level))] + [_ + (raise-syntax-error #f "expected literal-set entry" ctx stx)])) + +;; Conventions + +;; returns (listof (cons Conventions (listof syntax))) +(define (check-conventions-list stx ctx) + (unless (stx-list? stx) + (raise-syntax-error #f "expected conventions list" ctx 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 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 argu))) + (syntax-case stx () + [(conventions arg ...) + (identifier? #'conventions) + (elaborate #'conventions (parse-argu (syntax->list #'(arg ...))))] + [conventions + (identifier? #'conventions) + (elaborate #'conventions no-arguments)] + [_ + (raise-syntax-error "expected conventions entry" ctx stx)])) + +;; returns (listof (list regexp DeclEntry)) +(define (check-conventions-rules stx ctx) + (unless (stx-list? stx) + (raise-syntax-error #f "expected convention rule list" ctx stx)) + (for/list ([x (in-list (stx->list stx))]) + (check-conventions-rule x ctx))) + +;; returns (list regexp DeclEntry) +(define (check-conventions-rule stx ctx) + (define (check-conventions-pattern x blame) + (cond [(symbol? x) + (regexp (string-append "^" (regexp-quote (symbol->string x)) "$"))] + [(regexp? x) x] + [else + (raise-syntax-error #f "expected identifier convention pattern" + ctx blame)])) + (define (check-sc-expr x rx) + (let ([x (check-stxclass-application x ctx)]) + (make den:class rx (car x) (cdr x)))) + (syntax-case stx () + [(rx sc) + (let ([name-pattern (check-conventions-pattern (syntax-e #'rx) #'rx)]) + (list name-pattern (check-sc-expr #'sc name-pattern)))])) + +(define (check-stxclass-header stx ctx) + (syntax-case stx () + [name + (identifier? #'name) + (list #'name #'() no-arity)] + [(name . formals) + (identifier? #'name) + (list #'name #'formals (parse-kw-formals #'formals #:context ctx))] + [_ (raise-syntax-error #f "expected syntax class header" stx ctx)])) + +(define (check-stxclass-application stx ctx) + ;; Doesn't check "operator" is actually a stxclass + (syntax-case stx () + [op + (identifier? #'op) + (cons #'op no-arguments)] + [(op arg ...) + (identifier? #'op) + (cons #'op (parse-argu (syntax->list #'(arg ...))))] + [_ (raise-syntax-error #f "expected syntax class use" ctx stx)])) + +;; bind clauses +(define (check-bind-clause-list stx ctx) + (unless (stx-list? stx) + (raise-syntax-error #f "expected sequence of bind clauses" ctx stx)) + (for/list ([clause (in-list (stx->list stx))]) + (check-bind-clause clause ctx))) + +(define (check-bind-clause clause ctx) + (syntax-case clause () + [(attr-decl expr) + (action:bind (check-attr-arity #'attr-decl ctx) #'expr)] + [_ (raise-syntax-error #f "expected bind clause" ctx clause)])) + +(define (check-stmt-list stx ctx) + (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 + +;; common-parse-directive-table +(define common-parse-directive-table + (list (list '#:disable-colon-notation) + (list '#:literals check-literals-list) + (list '#:datum-literals check-datum-literals-list) + (list '#:literal-sets check-literal-sets-list) + (list '#:conventions check-conventions-list) + (list '#:local-conventions check-conventions-rules))) + +;; parse-directive-table +(define parse-directive-table + (list* (list '#:context check-expression) + (list '#:track-literals) + common-parse-directive-table)) + +;; rhs-directive-table +(define rhs-directive-table + (list* (list '#:description check-expression) + (list '#:transparent) + (list '#:opaque) + (list '#:attributes check-attr-arity-list) + (list '#:auto-nested-attributes) + (list '#:commit) + (list '#:no-delimit-cut) + common-parse-directive-table)) + +;; pattern-directive-table +(define pattern-directive-table + (list (list '#:declare check-identifier check-expression) + (list '#:role check-expression) ;; attached to preceding #:declare + (list '#:fail-when check-expression check-expression) + (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 '#:and check-expression) + (list '#:post check-expression) + (list '#:do check-stmt-list) + (list '#:undo check-stmt-list) + (list '#:cut))) + +;; fail-directive-table +(define fail-directive-table + (list (list '#:when check-expression) + (list '#:unless check-expression))) + +;; describe-option-table +(define describe-option-table + (list (list '#:opaque) + (list '#:role check-expression))) + +;; eh-optional-directive-table +(define eh-optional-directive-table + (list (list '#:too-many check-expression) + (list '#:name check-expression) + (list '#:defaults check-bind-clause-list))) + +;; h-optional-directive-table +(define h-optional-directive-table + (list (list '#:defaults check-bind-clause-list))) + +;; phase-directive-table +(define phase-directive-table + (list (list '#:phase check-expression))) + +;; litset-directive-table +(define litset-directive-table + (cons (list '#:at (lambda (stx ctx) stx)) + phase-directive-table)) + +;; var-pattern-directive-table +(define var-pattern-directive-table + (list (list '#:attr-name-separator check-stx-string) + (list '#:role check-expression))) diff --git a/scribblings/stxparse-info.scrbl b/scribblings/stxparse-info.scrbl index 4ab213d..d68a463 100644 --- a/scribblings/stxparse-info.scrbl +++ b/scribblings/stxparse-info.scrbl @@ -8,5 +8,7 @@ (my-include "stxparse-info.scrbl-6-11")] [(version< (version) "6.90.0.29") (my-include "stxparse-info.scrbl-6-12")] + [(version< (version) "7.3.0.1") + (my-include "stxparse-info.scrbl-6-90-0-29")] [else - (my-include "stxparse-info.scrbl-6-90-0-29")]) + (my-include "stxparse-info.scrbl-7-3-0-1")]) diff --git a/scribblings/stxparse-info.scrbl-7-3-0-1 b/scribblings/stxparse-info.scrbl-7-3-0-1 new file mode 100644 index 0000000..4032037 --- /dev/null +++ b/scribblings/stxparse-info.scrbl-7-3-0-1 @@ -0,0 +1,357 @@ +#lang scribble/manual +@require[racket/require + @for-label[stxparse-info/parse + stxparse-info/parse/experimental/template + stxparse-info/case + stxparse-info/current-pvars + (subtract-in racket/syntax stxparse-info/case) + (subtract-in racket/base stxparse-info/case)] + version-case + @for-syntax[racket/base] + "ovl.rkt"] + +@; Circumvent https://github.com/racket/scribble/issues/79 +@(require scribble/struct + scribble/decode) +@(define (nested-inset . vs) + (nested #:style 'inset vs)) + +@(version-case + [(version< (version) "6.4") + ] + [else + (require scribble/example) + (define ev ((make-eval-factory '(racket))))]) + +@title{@racketmodname[stxparse-info]: Track @racket[syntax-parse] and @racket[syntax-case] pattern vars} +@author[@author+email["Georges Dupéron" "georges.duperon@gmail.com"]] + +Source code: @url{https://github.com/jsmaniac/stxparse-info} + +@defmodule[stxparse-info] + +This library provides some patched versions of @orig:syntax-parse and of the +@orig:syntax-case family. These patched versions track which syntax pattern +variables are bound. This allows some libraries to change the way syntax +pattern variables work. + +For example, @tt{subtemplate} automatically derives temporary +identifiers when a template contains @racket[yᵢ …], and @racket[xᵢ] is a +pattern variable. To know from which @racket[varᵢ] the @racket[yᵢ …] +identifiers must be derived, @tt{subtemplate} needs to know which +syntax pattern variables are within scope. + +@section{Tracking currently-bound pattern variables with @racket[syntax-parse]} + +@defmodule[stxparse-info/parse] + +The module @racketmodname[stxparse-info/parse] provides patched versions of +@orig:syntax-parse, @orig:syntax-parser and @orig:define/syntax-parse which +track which syntax pattern variables are bound. + +@(ovl syntax/parse + syntax-parse + syntax-parser + define/syntax-parse) + +Additionally, the following identifiers are overridden as they are part of the +duplicated implementation of @racketmodname[syntax/parse]. + +@(ovl #:wrapper nested-inset + syntax/parse + ...+ + attribute + boolean + char + character + define-conventions + define-eh-alternative-set + define-literal-set + define-splicing-syntax-class + define-syntax-class + exact-integer + exact-nonnegative-integer + exact-positive-integer + expr + expr/c + id + identifier + integer + kernel-literals + keyword + literal-set->predicate + nat + number + pattern + prop:syntax-class + static + str + syntax-parse-state-cons! + syntax-parse-state-ref + syntax-parse-state-set! + syntax-parse-state-update! + syntax-parse-track-literals + this-syntax + ~! + ~and + ~between + ~bind + ~commit + ~datum + ~delimit-cut + ~describe + ~do + ~fail + ~literal + ~not + ~once + ~optional + ~or + ~parse + ~peek + ~peek-not + ~post + ~rest + ~seq + ~undo + ~var) + +@(version-case + [(version>= (version) "6.9.0.6") + (ovl #:wrapper nested-inset + syntax/parse + ~alt + ~or*)] + [else (begin)]) + +@(ovl #:wrapper nested-inset + #:require (for-template syntax/parse) + syntax/parse + pattern-expander? + pattern-expander + prop:pattern-expander + syntax-local-syntax-parse-pattern-introduce) + +@section{Tracking currently-bound pattern variables with @racket[syntax-case]} + +@defmodule[stxparse-info/case] + +The module @racketmodname[stxparse-info/case] provides patched versions of +@orig:syntax-case, @orig:syntax-case*, @orig:with-syntax, +@orig:define/with-syntax, @orig:datum-case and @orig:with-datum which +track which syntax or datum pattern variables are bound. + +@(ovl racket/base + syntax-case + syntax-case* + with-syntax) + +@(ovl syntax/datum + datum-case + with-datum) + +@(ovl racket/syntax + define/with-syntax) + +@section{Reading and updating the list of currently-bound pattern variables} + +@defmodule[stxparse-info/current-pvars] + +@defproc[#:kind "procedure at phase 1" + (current-pvars) (listof identifier?)]{ + This for-syntax procedure returns the list of syntax pattern variables which + are known to be bound. The most recently bound variables are at the beginning + of the list. + + It is the responsibility of the reader to check that the identifiers are + bound, and that they are bound to syntax pattern variables, for example using + @racket[identifier-binding] and @racket[syntax-pattern-variable?]. This allows + libraries to also track variables bound by match-like forms, for example.} + +@defproc[#:kind "procedure at phase 1" + (current-pvars+unique) (listof (pairof identifier? identifier?))]{ + This for-syntax procedure works like @racket[current-pvars], but associates + each syntax pattern variable with an identifier containing a unique symbol + which is generated at each execution of the code recording the pattern + variable via @racket[with-pvars] or @racket[define-pvars]. + + The @racket[car] of each pair in the returned list is the syntax pattern + variable (as produced by @racket[current-pvars]). It is the responsibility of + the reader to check that the identifiers present in the @racket[car] of each + element of the returned list are bound, and that they are bound to syntax + pattern variables, for example using @racket[identifier-binding] and + @racket[syntax-pattern-variable?]. This allows libraries to also track + variables bound by match-like forms, for example. + + The @racket[cdr] of each pair is the identifier of a temporary variable. + Reading that temporary variable produces a @racket[gensym]-ed symbol, which + was generated at run-time at the point where @racket[with-pvars] or + @racket[define-pvars] was used to record the corresponding pattern variable. + + This can be used to associate run-time data with each syntax pattern + variable, via a weak hash table created with @racket[make-weak-hasheq]. For + example, the @tt{subtemplate} library implicitly derives + identifiers (similarly to @racket[generate-temporaries]) for uses of + @racket[yᵢ ...] from a @racket[xᵢ] pattern variable bearing the same + subscript. The generated identifiers are associated with @racket[xᵢ] via this + weak hash table mechanism, so that two uses of @racket[yᵢ ...] within the + scope of the same @racket[xᵢ] binding derive the same identifiers. + + The code @racket[(with-pvars (v) body)] roughly expands to: + + @racketblock[ + (let-values ([(tmp) (gensym 'v)]) + (letrec-syntaxes+values ([(shadow-current-pvars) + (list* (cons (quote-syntax v) + (quote-syntax tmp)) + old-current-pvars)]) + body))] + + @bold{Caveat:} this entails that the fresh symbol stored in @racket[tmp] is + generated when @racket[with-pvars] or @racket[define-pvars] is called, not + when the syntax pattern variable is actually bound. For example: + + @RACKETBLOCK[ + (define-syntax (get-current-pvars+unique stx) + #`'#,(current-pvars+unique)) + + (require racket/private/sc) + (let ([my-valvar (quote-syntax x)]) + (let-syntax ([my-pvar (make-syntax-mapping 0 (quote-syntax my-valvar))]) + (with-pvars (x) + (get-current-pvars+unique)) (code:comment "'([x . g123])") + (with-pvars (x) + (get-current-pvars+unique)))) (code:comment "'([x . g124])")] + + Under normal circumstances, @racket[with-pvars] @racket[define-pvars] should + be called immediately after binding the syntax pattern variable, but the code + above shows that it is technically possible to do otherwise. + + This caveat is not meant to dissuade the use of + @racket[current-pvars+unique], it rather serves as an explanation of the + behaviour encountered when @racket[with-pvars] or @racket[define-pvars] are + incorrectly used more than once to record the same pattern variable.} + +@defform[(with-pvars (pvar ...) . body) + #:contracts ([pvar identifier?])]{ + Prepends the given @racket[pvar ...] to the list of pattern variables which + are known to be bound. The @racket[pvar ...] are prepended in reverse order, + so within the body of + + @racketblock[(with-pvars (v₁ v₂ v₃) . body)] + + a call to the for-syntax function @racket[(current-pvars)] returns: + + @racketblock[(list* (quote-syntax v₃) (quote-syntax v₂) (quote-syntax v₁) + old-current-pvars)] + + This can be used to implement macros which work similarly to + @racket[syntax-parse] or @racket[syntax-case], and have them record the syntax + pattern variables which they bind. + + Note that the identifiers @racket[pvar ...] must already be bound to syntax + pattern variables when @racket[with-pvars] is used, e.g. + + @racketblock[ + (let-syntax ([v₁ (make-syntax-mapping depth (quote-syntax valvar))] + [v₂ (make-syntax-mapping depth (quote-syntax valvar))]) + (with-pvars (v₁ v₂) + code))] + + instead of: + + @racketblock[ + (with-pvars (v₁ v₂) + (let-syntax ([v₁ (make-syntax-mapping depth (quote-syntax valvar))] + [v₂ (make-syntax-mapping depth (quote-syntax valvar))]) + code))]} + +@defform[(define-pvars pvar ...) + #:contracts ([pvar identifier?])]{ + + Prepends the given @racket[pvar ...] to the list of pattern variables which + are known to be bound, in the same way as @racket[with-pvars]. Whereas + @racket[with-pvars] makes the modified list visible in the @racket[_body], + @racket[define-pvars] makes the modified list visible in the statements + following @racket[define-pvars]. @racket[define-pvars] can be used multiple + times within the same @racket[let] or equivalent. + + This can be used to implement macros which work similarly to + @racket[define/syntax-parse] or @racket[define/with-syntax], and have them + record the syntax pattern variables which they bind. + + @(version-case + [(version< (version) "6.4") + @RACKETBLOCK[ + (let () + (code:comment "Alternate version of define/syntax-parse which") + (code:comment "contains (define-pvars x) in its expanded form.") + (define/syntax-parse x #'1) + (define/syntax-parse y #'2) + (define-syntax (get-pvars stx) + #`'#,(current-pvars)) + (get-pvars)) + (code:comment "=> '(y x)")]] + [else + @examples[ + #:eval ev + #:hidden + (require stxparse-info/parse + stxparse-info/current-pvars + racket/syntax + (for-syntax racket/base))] + + @examples[ + #:eval ev + #:escape UNSYNTAX + (eval:check + (let () + (code:comment "Alternate version of define/syntax-parse which") + (code:comment "contains (define-pvars x) in its expanded form.") + (define/syntax-parse x #'1) + (define/syntax-parse y #'2) + (define-syntax (get-pvars stx) + #`'#,(current-pvars)) + (get-pvars)) + '(y x))]])} + +@section{Extensions to @racketmodname[syntax/parse/experimental/template]} + +@defmodule[stxparse-info/parse/experimental/template] + +@(orig syntax/parse/experimental/template + define-template-metafunction) + +@defidform[define-template-metafunction]{ + Overloaded version of @orig:define-template-metafunction from + @racketmodname[syntax/parse/experimental/template]. + + Note that currently, template metafunctions defined via + @racketmodname[stxparse-info/parse/experimental/template] are not compatible + with the forms from @racketmodname[syntax/parse/experimental/template], and + vice versa. There is a pending Pull Request which would make the necessary + primitives from @racketmodname[syntax/parse/experimental/template] public, so + hopefully this problem will be solved in future versions.} + +@defform[(syntax-local-template-metafunction-introduce stx)]{ + Like @racket[syntax-local-introduce], but for + @tech[#:doc '(lib "syntax/scribblings/syntax.scrbl")]{template metafunctions}. + + This change is also available in the package + @racketmodname{backport-template-pr1514}. It has been submitted as a Pull + Request to Racket, but can already be used in + @racketmodname[stxparse-info/parse/experimental/template] right now.} + +@(ovl syntax/parse/experimental/template + template + quasitemplate + template/loc + quasitemplate/loc) + +Additionally, the following identifiers are overridden as they are part of the +duplicated implementation of @racketmodname[syntax/parse]. + +@(ovl #:wrapper nested-inset + syntax/parse/experimental/template + ?? + ?@)