diff --git a/parse/debug.rkt b/parse/debug.rkt index 1482574..dba7cec 100644 --- a/parse/debug.rkt +++ b/parse/debug.rkt @@ -8,5 +8,7 @@ (my-include "debug.rkt-6-11")] [(version< (version) "6.90.0.29") (my-include "debug.rkt-6-12")] + [(version< (version) "7.0.0.20") + (my-include "debug.rkt-6-90-0-29")] [else - (my-include "debug.rkt-6-90-0-29")]) + (my-include "debug.rkt-7-0-0-20")]) diff --git a/parse/debug.rkt-7-0-0-20 b/parse/debug.rkt-7-0-0-20 new file mode 100644 index 0000000..705ae26 --- /dev/null +++ b/parse/debug.rkt-7-0-0-20 @@ -0,0 +1,127 @@ +#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: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/reflect.rkt b/parse/experimental/reflect.rkt index b5d6dc8..92c790c 100644 --- a/parse/experimental/reflect.rkt +++ b/parse/experimental/reflect.rkt @@ -8,5 +8,7 @@ (my-include "reflect.rkt-6-11")] [(version< (version) "6.90.0.29") (my-include "reflect.rkt-6-12")] + [(version< (version) "7.0.0.20") + (my-include "reflect.rkt-6-90-0-29")] [else - (my-include "reflect.rkt-6-90-0-29")]) + (my-include "reflect.rkt-7-0-0-20")]) diff --git a/parse/experimental/reflect.rkt-7-0-0-20 b/parse/experimental/reflect.rkt-7-0-0-20 new file mode 100644 index 0000000..8f18781 --- /dev/null +++ b/parse/experimental/reflect.rkt-7-0-0-20 @@ -0,0 +1,147 @@ +#lang racket/base +(require (for-syntax racket/base + racket/lazy-require + racket/syntax + syntax/parse/private/residual-ct) ;; keep abs.path + racket/contract/base + racket/contract/combinator + syntax/parse/private/minimatch + syntax/parse/private/keywords + "../private/runtime-reflect.rkt" + syntax/parse/private/kws) +(begin-for-syntax + (lazy-require + [syntax/parse/private/rep-data ;; keep abs. path + (get-stxclass)])) +;; FIXME: workaround for phase>0 bug in racket/runtime-path (and thus lazy-require) +;; Without this, dependencies don't get collected. +(require racket/runtime-path (for-meta 2 '#%kernel)) +(define-runtime-module-path-index _unused_ 'syntax/parse/private/rep-data) + +(define-syntax (reify-syntax-class stx) + (if (eq? (syntax-local-context) 'expression) + (syntax-case stx () + [(rsc sc) + (with-disappeared-uses + (let* ([stxclass (get-stxclass #'sc)] + [splicing? (stxclass-splicing? stxclass)]) + (unless (scopts-delimit-cut? (stxclass-opts stxclass)) + (raise-syntax-error #f "cannot reify syntax class with #:no-delimit-cut option" + stx #'sc)) + (with-syntax ([name (stxclass-name stxclass)] + [parser (stxclass-parser stxclass)] + [arity (stxclass-arity stxclass)] + [(#s(attr aname adepth _) ...) (stxclass-attrs stxclass)] + [ctor + (if splicing? + #'reified-splicing-syntax-class + #'reified-syntax-class)]) + #'(ctor 'name parser 'arity '((aname adepth) ...)))))]) + #`(#%expression #,stx))) + +(define (reified-syntax-class-arity r) + (match (reified-arity r) + [(arity minpos maxpos _ _) + (to-procedure-arity minpos maxpos)])) + +(define (reified-syntax-class-keywords r) + (match (reified-arity r) + [(arity _ _ minkws maxkws) + (values minkws maxkws)])) + +(define (reified-syntax-class-attributes r) + (reified-signature r)) + +(define reified-syntax-class-curry + (make-keyword-procedure + (lambda (kws1 kwargs1 r . rest1) + (match r + [(reified name parser arity1 sig) + (let () + (check-curry arity1 (length rest1) kws1 + (lambda (msg) + (raise-mismatch-error 'reified-syntax-class-curry + (string-append msg ": ") r))) + (let* ([curried-arity + (match arity1 + [(arity minpos maxpos minkws maxkws) + (let* ([rest1-length (length rest1)] + [minpos* (- minpos rest1-length)] + [maxpos* (- maxpos rest1-length)] + [minkws* (sort (remq* kws1 minkws) keyword any/c boolean?)] + [reified-splicing-syntax-class? + (-> any/c boolean?)] + [reified-syntax-class-attributes + (-> (or/c reified-syntax-class? reified-splicing-syntax-class?) + (listof (list/c symbol? exact-nonnegative-integer?)))] + [reified-syntax-class-arity + (-> (or/c reified-syntax-class? reified-splicing-syntax-class?) + procedure-arity?)] + [reified-syntax-class-keywords + (-> (or/c reified-syntax-class? reified-splicing-syntax-class?) + (values (listof keyword?) + (listof keyword?)))] + [reified-syntax-class-curry + (make-contract #:name '(->* ((or/c reified-syntax-class? reified-splicing-syntax-class/c)) + (#: any/c ...) + #:rest list? + (or/c reified-syntax-class? reified-splicing-syntax-class/c)) + #:late-neg-projection + (lambda (blame) + (let ([check-reified + ((contract-late-neg-projection + (or/c reified-syntax-class? reified-splicing-syntax-class?)) + (blame-swap blame))]) + (lambda (f neg-party) + (if (and (procedure? f) + (procedure-arity-includes? f 1)) + (make-keyword-procedure + (lambda (kws kwargs r . args) + (keyword-apply f kws kwargs (check-reified r neg-party) args))) + (raise-blame-error + blame #:missing-party neg-party + f + "expected a procedure of at least one argument, given ~e" + f))))) + #:first-order + (lambda (f) (procedure? f)))]) diff --git a/parse/pre.rkt b/parse/pre.rkt index 6b89a63..9310cff 100644 --- a/parse/pre.rkt +++ b/parse/pre.rkt @@ -8,5 +8,7 @@ (my-include "pre.rkt-6-11")] [(version< (version) "6.90.0.29") (my-include "pre.rkt-6-12")] + [(version< (version) "7.0.0.20") + (my-include "pre.rkt-6-90-0-29")] [else - (my-include "pre.rkt-6-90-0-29")]) + (my-include "pre.rkt-7-0-0-20")]) diff --git a/parse/pre.rkt-7-0-0-20 b/parse/pre.rkt-7-0-0-20 new file mode 100644 index 0000000..215ed6e --- /dev/null +++ b/parse/pre.rkt-7-0-0-20 @@ -0,0 +1,49 @@ +#lang racket/base +(require "private/sc.rkt" + "private/litconv.rkt" + "private/lib.rkt" + "private/residual.rkt") +(provide (except-out (all-from-out "private/sc.rkt") + define-integrable-syntax-class + syntax-parser/template) + (all-from-out "private/litconv.rkt") + (all-from-out "private/lib.rkt") + syntax-parse-state-ref + syntax-parse-state-set! + syntax-parse-state-update! + syntax-parse-state-cons! + syntax-parse-track-literals) + +(define not-given (gensym)) + +(define (state-ref who key default) + (define state (current-state)) + (if (eq? default not-given) + (if (hash-has-key? state key) + (hash-ref state key) + (error who "no value found for key\n key: ~e" key)) + (hash-ref state key default))) + +(define (syntax-parse-state-ref key [default not-given]) + (state-ref 'syntax-parse-state-ref key default)) + +(define (check-update who) + (unless (current-state-writable?) + (error who "cannot update syntax-parse state outside of ~~do/#:do block"))) + +(define (syntax-parse-state-set! key value) + (check-update 'syntax-parse-state-set!) + (current-state (hash-set (current-state) key value))) + +(define (syntax-parse-state-update! key update [default not-given]) + (check-update 'syntax-parse-state-update!) + (define old (state-ref 'syntax-parse-state-update! key default)) + (current-state (hash-set (current-state) key (update old)))) + +(define (syntax-parse-state-cons! key value [default null]) + (check-update 'syntax-parse-state-cons!) + (define old (hash-ref (current-state) key default)) + (current-state (hash-set (current-state) key (cons value old)))) + +(define (syntax-parse-track-literals stx #:introduce? [introduce? #t]) + (track-literals 'syntax-parse-track-literals stx #:introduce? introduce?)) \ No newline at end of file diff --git a/parse/private/opt.rkt-7-0-0-20 b/parse/private/opt.rkt-7-0-0-20 new file mode 100644 index 0000000..7319b4e --- /dev/null +++ b/parse/private/opt.rkt-7-0-0-20 @@ -0,0 +1,430 @@ +#lang racket/base +(require racket/syntax + racket/pretty + syntax/parse/private/residual-ct ;; keep abs. path + syntax/parse/private/minimatch + syntax/parse/private/rep-patterns + syntax/parse/private/kws) +(provide (struct-out pk1) + (rename-out [optimize-matrix0 optimize-matrix])) + +;; controls debugging output for optimization successes and failures +(define DEBUG-OPT-SUCCEED #f) +(define DEBUG-OPT-FAIL #f) + +;; ---- + +;; A Matrix is a (listof PK) where each PK has same number of columns +;; A PK is one of +;; - (pk1 (listof pattern) expr) -- a simple row in a parsing matrix +;; - (pk/same pattern Matrix) -- a submatrix with a common first column factored out +;; - (pk/pair Matrix) -- a submatrix with pair patterns in the first column unfolded +;; - (pk/and Matrix) -- a submatrix with and patterns in the first column unfolded +(struct pk1 (patterns k) #:prefab) +(struct pk/same (pattern inner) #:prefab) +(struct pk/pair (inner) #:prefab) +(struct pk/and (inner) #:prefab) + +(define (pk-columns pk) + (match pk + [(pk1 patterns k) (length patterns)] + [(pk/same p inner) (add1 (pk-columns inner))] + [(pk/pair inner) (sub1 (pk-columns inner))] + [(pk/and inner) (sub1 (pk-columns inner))])) + +;; Can factor pattern P given clauses like +;; [ P P1 ... | e1] [ | [P1 ... | e1] ] +;; [ P ⋮ | ⋮] => [P | [ ⋮ | ⋮] ] + ; [ P PN ... | eN] [ | [PN ... | eN] ] +;; if P cannot cut and P succeeds at most once (otherwise may reorder backtracking) + +;; Can unfold pair patterns as follows: +;; [ (P11 . P12) P1 ... | e1 ] [ P11 P12 P1 ... | e1 ] +;; [ ⋮ ⋮ | ⋮ ] => check pair, [ ⋮ | ⋮ ] +;; [ (PN1 . PN2) PN ... | eN ] [ PN1 PN2 PN ... | eN ] + +;; Can unfold ~and patterns similarly; ~and patterns can hide +;; factoring opportunities. + +;; ---- + +(define (optimize-matrix0 rows) + (define now (current-inexact-milliseconds)) + (when (and DEBUG-OPT-SUCCEED (> (length rows) 1)) + (eprintf "\n%% optimizing (~s):\n" (length rows)) + (pretty-write (matrix->sexpr rows) (current-error-port))) + (define result (optimize-matrix rows)) + (define then (current-inexact-milliseconds)) + (when (and DEBUG-OPT-SUCCEED (> (length rows) 1)) + (cond [(= (length result) (length rows)) + (eprintf "%% !! FAILED !! (~s ms)\n\n" (floor (- then now)))] + [else + (eprintf "==> (~s ms)\n" (floor (- then now))) + (pretty-write (matrix->sexpr result) (current-error-port)) + (eprintf "\n")])) + result) + +;; optimize-matrix : (listof pk1) -> Matrix +(define (optimize-matrix rows) + (cond [(null? rows) null] + [(null? (cdr rows)) rows] ;; no opportunities for 1 row + [(null? (pk1-patterns (car rows))) rows] + [else + ;; first unfold and-patterns + (let-values ([(col1 col2) + (for/lists (col1 col2) ([row (in-list rows)]) + (unfold-and (car (pk1-patterns row)) null))]) + (cond [(ormap pair? col2) + (list + (pk/and + (optimize-matrix* + (for/list ([row (in-list rows)] + [col1 (in-list col1)] + [col2 (in-list col2)]) + (pk1 (list* col1 + (make-and-pattern col2) + (cdr (pk1-patterns row))) + (pk1-k row))))))] + [else (optimize-matrix* rows)]))])) + +;; optimize-matrix* : (listof pk1) -> Matrix +;; The matrix is nonempty, and first column has no unfoldable pat:and. +;; Split into submatrixes (sequences of rows) starting with similar patterns, +;; handle according to similarity, then recursively optimize submatrixes. +(define (optimize-matrix* rows) + (define row1 (car rows)) + (define pat1 (car (pk1-patterns row1))) + (define k1 (pk1-k row1)) + ;; Now accumulate rows starting with patterns like pat1 + (define-values (like? combine) (pattern->partitioner pat1)) + (let loop ([rows (cdr rows)] [rrows (list row1)]) + (cond [(null? rows) + (cons (combine (reverse rrows)) null)] + [else + (define row1 (car rows)) + (define pat1 (car (pk1-patterns row1))) + (cond [(like? pat1) + (loop (cdr rows) (cons row1 rrows))] + [else + (cons (combine (reverse rrows)) + (optimize-matrix* rows))])]))) + +;; pattern->partitioner : pattern -> (values (pattern -> boolean) ((listof pk1) -> PK)) +(define (pattern->partitioner pat1) + (match pat1 + [(pat:pair head tail) + (values (lambda (p) (pat:pair? p)) + (lambda (rows) + (when DEBUG-OPT-SUCCEED + (eprintf "-- accumulated ~s rows like ~e\n" (length rows) (pattern->sexpr pat1))) + (cond [(> (length rows) 1) + (pk/pair (optimize-matrix + (for/list ([row (in-list rows)]) + (let* ([patterns (pk1-patterns row)] + [pat1 (car patterns)]) + (pk1 (list* (pat:pair-head pat1) + (pat:pair-tail pat1) + (cdr patterns)) + (pk1-k row))))))] + [else (car rows)])))] + [(? pattern-factorable?) + (values (lambda (pat2) (pattern-equal? pat1 pat2)) + (lambda (rows) + (when DEBUG-OPT-SUCCEED + (eprintf "-- accumulated ~s rows like ~e\n" (length rows) (pattern->sexpr pat1))) + (cond [(> (length rows) 1) + (pk/same pat1 + (optimize-matrix + (for/list ([row (in-list rows)]) + (pk1 (cdr (pk1-patterns row)) (pk1-k row)))))] + [else (car rows)])))] + [_ + (values (lambda (pat2) + (when DEBUG-OPT-FAIL + (when (pattern-equal? pat1 pat2) + (eprintf "** cannot factor: ~e\n" (syntax->datum #`#,pat2)))) + #f) + (lambda (rows) + ;; (length rows) = 1 + (car rows)))])) + +;; unfold-and : pattern (listof pattern) -> (values pattern (listof pattern)) +(define (unfold-and p onto) + (match p + [(pat:and subpatterns) + ;; pat:and is worth unfolding if first subpattern is not pat:action + ;; if first subpattern is also pat:and, keep unfolding + (let* ([first-sub (car subpatterns)] + [rest-subs (cdr subpatterns)]) + (cond [(not (pat:action? first-sub)) + (when #f ;; DEBUG-OPT-SUCCEED + (eprintf ">> unfolding: ~e\n" p)) + (unfold-and first-sub (*append rest-subs onto))] + [else (values p onto)]))] + [_ (values p onto)])) + +(define (pattern-factorable? p) + ;; Can factor out p if p can succeed at most once, does not cut + ;; - if p can succeed multiple times, then factoring changes success order + ;; - if p can cut, then factoring changes which choice points are discarded (too few) + (match p + [(pat:any) #t] + [(pat:svar _n) #t] + [(pat:var/p _ _ _ _ _ (scopts _ commit? _ _)) + ;; commit? implies delimit-cut + commit?] + [(? pat:integrated?) #t] + [(pat:literal _lit _ip _lp) #t] + [(pat:datum _datum) #t] + [(pat:action _act _pat) #f] + [(pat:head head tail) + (and (pattern-factorable? head) + (pattern-factorable? tail))] + [(pat:dots heads tail) + ;; Conservative approximation for common case: one head pattern + ;; In general, check if heads don't overlap, don't overlap with tail. + (and (= (length heads) 1) + (let ([head (car heads)]) + (and (pattern-factorable? head))) + (equal? tail (pat:datum '())))] + [(pat:and patterns) + (andmap pattern-factorable? patterns)] + [(pat:or _ patterns _) #f] + [(pat:not pattern) #f] ;; FIXME: ? + [(pat:pair head tail) + (and (pattern-factorable? head) + (pattern-factorable? tail))] + [(pat:vector pattern) + (pattern-factorable? pattern)] + [(pat:box pattern) + (pattern-factorable? pattern)] + [(pat:pstruct key pattern) + (pattern-factorable? pattern)] + [(pat:describe pattern _desc _trans _role) + (pattern-factorable? pattern)] + [(pat:delimit pattern) + (pattern-factorable? pattern)] + [(pat:commit pattern) #t] + [(? pat:reflect?) #f] + [(pat:ord pattern _ _) + (pattern-factorable? pattern)] + [(pat:post pattern) + (pattern-factorable? pattern)] + ;; ---- + [(hpat:var/p _ _ _ _ _ (scopts _ commit? _ _)) + commit?] + [(hpat:seq inner) + (pattern-factorable? inner)] + [(hpat:commit inner) #t] + ;; ---- + [(ehpat _ head repc _) + (and (equal? repc #f) + (pattern-factorable? head))] + ;; ---- + [else #f])) + +(define (subpatterns-equal? as bs) + (and (= (length as) (length bs)) + (for/and ([a (in-list as)] + [b (in-list bs)]) + (pattern-equal? a b)))) + +(define (pattern-equal? a b) + (define result + (cond [(and (pat:any? a) (pat:any? b)) #t] + [(and (pat:svar? a) (pat:svar? b)) + (bound-identifier=? (pat:svar-name a) (pat:svar-name b))] + [(and (pat:var/p? a) (pat:var/p? b)) + (and (free-id/f-equal? (pat:var/p-parser a) (pat:var/p-parser b)) + (bound-id/f-equal? (pat:var/p-name a) (pat:var/p-name b)) + (equal-iattrs? (pat:var/p-nested-attrs a) (pat:var/p-nested-attrs b)) + (equal-argu? (pat:var/p-argu a) (pat:var/p-argu b)) + (expr-equal? (pat:var/p-role a) (pat:var/p-role b)))] + [(and (pat:integrated? a) (pat:integrated? b)) + (and (bound-id/f-equal? (pat:integrated-name a) (pat:integrated-name b)) + (free-identifier=? (pat:integrated-predicate a) + (pat:integrated-predicate b)) + (expr-equal? (pat:integrated-role a) (pat:integrated-role b)))] + [(and (pat:literal? a) (pat:literal? b)) + ;; literals are hard to compare, so compare gensyms attached to + ;; literal ids (see rep.rkt) instead + (let ([ka (syntax-property (pat:literal-id a) 'literal)] + [kb (syntax-property (pat:literal-id b) 'literal)]) + (and ka kb (eq? ka kb)))] + [(and (pat:datum? a) (pat:datum? b)) + (equal? (pat:datum-datum a) + (pat:datum-datum b))] + [(and (pat:head? a) (pat:head? b)) + (and (pattern-equal? (pat:head-head a) (pat:head-head b)) + (pattern-equal? (pat:head-tail a) (pat:head-tail b)))] + [(and (pat:dots? a) (pat:dots? b)) + (and (subpatterns-equal? (pat:dots-heads a) (pat:dots-heads b)) + (pattern-equal? (pat:dots-tail a) (pat:dots-tail b)))] + [(and (pat:and? a) (pat:and? b)) + (subpatterns-equal? (pat:and-patterns a) (pat:and-patterns b))] + [(and (pat:or? a) (pat:or? b)) + (subpatterns-equal? (pat:or-patterns a) (pat:or-patterns b))] + [(and (pat:not? a) (pat:not? b)) + (pattern-equal? (pat:not-pattern a) (pat:not-pattern b))] + [(and (pat:pair? a) (pat:pair? b)) + (and (pattern-equal? (pat:pair-head a) (pat:pair-head b)) + (pattern-equal? (pat:pair-tail a) (pat:pair-tail b)))] + [(and (pat:vector? a) (pat:vector? b)) + (pattern-equal? (pat:vector-pattern a) (pat:vector-pattern b))] + [(and (pat:box? a) (pat:box? b)) + (pattern-equal? (pat:box-pattern a) (pat:box-pattern b))] + [(and (pat:pstruct? a) (pat:pstruct? b)) + (and (equal? (pat:pstruct-key a) + (pat:pstruct-key b)) + (pattern-equal? (pat:pstruct-pattern a) + (pat:pstruct-pattern b)))] + [(and (pat:describe? a) (pat:describe? b)) #f] ;; can't compare desc exprs + [(and (pat:delimit? a) (pat:delimit? b)) + (pattern-equal? (pat:delimit-pattern a) (pat:delimit-pattern b))] + [(and (pat:commit? a) (pat:commit? b)) + (pattern-equal? (pat:commit-pattern a) (pat:commit-pattern b))] + [(and (pat:reflect? a) (pat:reflect? b)) #f] ;; FIXME: ? + [(and (pat:ord? a) (pat:ord? b)) + (and (pattern-equal? (pat:ord-pattern a) (pat:ord-pattern b)) + (equal? (pat:ord-group a) (pat:ord-group b)) + (equal? (pat:ord-index a) (pat:ord-index b)))] + [(and (pat:post? a) (pat:post? b)) + (pattern-equal? (pat:post-pattern a) (pat:post-pattern b))] + ;; --- + [(and (hpat:var/p? a) (hpat:var/p? b)) + (and (free-id/f-equal? (hpat:var/p-parser a) (hpat:var/p-parser b)) + (bound-id/f-equal? (hpat:var/p-name a) (hpat:var/p-name b)) + (equal-iattrs? (hpat:var/p-nested-attrs a) (hpat:var/p-nested-attrs b)) + (equal-argu? (hpat:var/p-argu a) (hpat:var/p-argu b)) + (expr-equal? (hpat:var/p-role a) (hpat:var/p-role b)))] + [(and (hpat:seq? a) (hpat:seq? b)) + (pattern-equal? (hpat:seq-inner a) (hpat:seq-inner b))] + ;; --- + [(and (ehpat? a) (ehpat? b)) + (and (equal? (ehpat-repc a) #f) + (equal? (ehpat-repc b) #f) + (pattern-equal? (ehpat-head a) (ehpat-head b)))] + ;; FIXME: more? + [else #f])) + (when DEBUG-OPT-FAIL + (when (and (eq? result #f) + (equal? (syntax->datum #`#,a) (syntax->datum #`#,b))) + (eprintf "** pattern-equal? failed on ~e\n" a))) + result) + +(define (equal-iattrs? as bs) + (and (= (length as) (length bs)) + ;; assumes attrs in same order + (for/and ([aa (in-list as)] + [ba (in-list bs)]) + (and (bound-identifier=? (attr-name aa) (attr-name ba)) + (equal? (attr-depth aa) (attr-depth ba)) + (equal? (attr-syntax? aa) (attr-syntax? ba)))))) + +(define (expr-equal? a b) + ;; Expression equality is undecidable in general. Especially difficult for unexpanded + ;; code, but it would be very difficult to set up correct env for local-expand because of + ;; attr binding rules. So, do *very* conservative approx: simple variables and literals. + ;; FIXME: any other common cases? + (cond [(not (and (syntax? a) (syntax? b))) + (equal? a b)] + [(and (identifier? a) (identifier? b)) + ;; note: "vars" might be identifier macros (unsafe to consider equal), + ;; so check var has no compile-time binding + (and (free-identifier=? a b) + (let/ec k (syntax-local-value a (lambda () (k #t))) #f))] + [(syntax-case (list a b) (quote) + [((quote ad) (quote bd)) + (cons (syntax->datum #'ad) (syntax->datum #'bd))] + [_ #f]) + => (lambda (ad+bd) + (equal? (car ad+bd) (cdr ad+bd)))] + [else + ;; approx: equal? only if both simple data (bool, string, etc), no inner stx + (let ([ad (syntax-e a)] + [bd (syntax-e b)]) + (and (equal? ad bd) + (free-identifier=? (datum->syntax a '#%datum) #'#%datum) + (free-identifier=? (datum->syntax b '#%datum) #'#%datum)))])) + +(define (equal-argu? a b) + (define (unwrap-arguments x) + (match x + [(arguments pargs kws kwargs) + (values pargs kws kwargs)])) + (define (list-equal? as bs inner-equal?) + (and (= (length as) (length bs)) + (andmap inner-equal? as bs))) + (let-values ([(apargs akws akwargs) (unwrap-arguments a)] + [(bpargs bkws bkwargs) (unwrap-arguments b)]) + (and (list-equal? apargs bpargs expr-equal?) + (equal? akws bkws) + (list-equal? akwargs bkwargs expr-equal?)))) + +(define (free-id/f-equal? a b) + (or (and (eq? a #f) + (eq? b #f)) + (and (identifier? a) + (identifier? b) + (free-identifier=? a b)))) + +(define (bound-id/f-equal? a b) + (or (and (eq? a #f) + (eq? b #f)) + (and (identifier? a) + (identifier? b) + (bound-identifier=? a b)))) + +(define (make-and-pattern subs) + (cond [(null? subs) (pat:any)] ;; shouldn't happen + [(null? (cdr subs)) (car subs)] + [else (pat:and subs)])) + +(define (*append a b) (if (null? b) a (append a b))) + +(define (stx-e x) (if (syntax? x) (syntax-e x) x)) + +;; ---- + +(define (matrix->sexpr rows) + (cond [(null? rows) ;; shouldn't happen + '(FAIL)] + [(null? (cdr rows)) + (pk->sexpr (car rows))] + [else + (cons 'TRY (map pk->sexpr rows))])) +(define (pk->sexpr pk) + (match pk + [(pk1 pats k) + (cons 'MATCH (map pattern->sexpr pats))] + [(pk/same pat inner) + (list 'SAME (pattern->sexpr pat) (matrix->sexpr inner))] + [(pk/pair inner) + (list 'PAIR (matrix->sexpr inner))] + [(pk/and inner) + (list 'AND (matrix->sexpr inner))])) +(define (pattern->sexpr p) + (match p + [(pat:any) '_] + [(pat:integrated name pred desc _) + (format-symbol "~a:~a" (or name '_) desc)] + [(pat:svar name) + (syntax-e name)] + [(pat:var/p name parser _ _ _ _) + (cond [(and parser (regexp-match #rx"^parse-(.*)$" (symbol->string (syntax-e parser)))) + => (lambda (m) + (format-symbol "~a:~a" (or name '_) (cadr m)))] + [else + (if name (syntax-e name) '_)])] + [(? pat:literal?) `(quote ,(syntax->datum (pat:literal-id p)))] + [(pat:datum datum) datum] + [(? pat:action?) 'ACTION] + [(pat:pair head tail) + (cons (pattern->sexpr head) (pattern->sexpr tail))] + [(pat:head head tail) + (cons (pattern->sexpr head) (pattern->sexpr tail))] + [(pat:dots (list eh) tail) + (list* (pattern->sexpr eh) '... (pattern->sexpr tail))] + [(ehpat _as hpat '#f _cn) + (pattern->sexpr hpat)] + [_ 'PATTERN])) diff --git a/parse/private/parse.rkt b/parse/private/parse.rkt index 4d25fa9..deec7da 100644 --- a/parse/private/parse.rkt +++ b/parse/private/parse.rkt @@ -8,5 +8,7 @@ (my-include "parse.rkt-6-11")] [(version< (version) "6.90.0.29") (my-include "parse.rkt-6-12")] + [(version< (version) "7.0.0.20") + (my-include "parse.rkt-6-90-0-29")] [else - (my-include "parse.rkt-6-90-0-29")]) + (my-include "parse.rkt-7-0-0-20")]) diff --git a/parse/private/parse.rkt-7-0-0-20 b/parse/private/parse.rkt-7-0-0-20 new file mode 100644 index 0000000..6de5ec6 --- /dev/null +++ b/parse/private/parse.rkt-7-0-0-20 @@ -0,0 +1,1248 @@ +#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)]) + (with-syntax ([name name] + [formals formals] + [desc (cond [(rhs-description the-rhs) => constant-desc] + [else (symbol->string (syntax-e name))])] + [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 #'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 (or description (symbol->string (syntax-e name)))] + [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 3af4c67..7697757 100644 --- a/parse/private/rep.rkt +++ b/parse/private/rep.rkt @@ -8,5 +8,7 @@ (my-include "rep.rkt-6-11")] [(version< (version) "6.90.0.29") (my-include "rep.rkt-6-12")] + [(version< (version) "7.0.0.20") + (my-include "rep.rkt-6-90-0-29")] [else - (my-include "rep.rkt-6-90-0-29")]) + (my-include "rep.rkt-7-0-0-20")]) diff --git a/parse/private/rep.rkt-7-0-0-20 b/parse/private/rep.rkt-7-0-0-20 new file mode 100644 index 0000000..d8fed6a --- /dev/null +++ b/parse/private/rep.rkt-7-0-0-20 @@ -0,0 +1,1829 @@ +#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?) + 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)])) + +;; --- + +;; parse-rhs : Syntax Boolean #:context Syntax -> RHS +(define (parse-rhs stx splicing? #:context ctx) + (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? 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)) + (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)) + (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 role)] + [else ;; Just proper name + (pat:svar name0)])) + +;; ---- + +(define (parse-stxclass-use stx allow-head? varname scname argu role [parser* #f]) + (cond [(and (memq (stxclass-lookup-config) '(yes try)) (get-stxclass scname #t)) + => (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 "." role parser*))] + [(memq (stxclass-lookup-config) '(try no)) + (define bind (name->bind varname)) + (pat:fixup stx bind varname scname argu role parser*)] + [else (wrong-syntax scname "not defined as syntax class (config=~s)" + ;; XXX FIXME + (stxclass-lookup-config))])) + +;; ---- + +(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 role parser*) + (parse-stxclass-use stx allow-head? varname scname argu 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/parse/private/residual.rkt b/parse/private/residual.rkt index a7c6a6b..8f1bdd1 100644 --- a/parse/private/residual.rkt +++ b/parse/private/residual.rkt @@ -8,5 +8,7 @@ (my-include "residual.rkt-6-11")] [(version< (version) "6.90.0.29") (my-include "residual.rkt-6-12")] + [(version< (version) "7.0.0.20") + (my-include "residual.rkt-6-90-0-29")] [else - (my-include "residual.rkt-6-90-0-29")]) + (my-include "residual.rkt-7-0-0-20")]) diff --git a/parse/private/residual.rkt-7-0-0-20 b/parse/private/residual.rkt-7-0-0-20 new file mode 100644 index 0000000..313265b --- /dev/null +++ b/parse/private/residual.rkt-7-0-0-20 @@ -0,0 +1,302 @@ +#lang racket/base +(require (for-syntax racket/base) + racket/stxparam + racket/lazy-require + racket/private/promise) + +;; ============================================================ +;; Compile-time + +(require (for-syntax racket/private/sc syntax/parse/private/residual-ct)) +(provide (for-syntax (all-from-out syntax/parse/private/residual-ct))) + +(require racket/private/template) +(provide (for-syntax attribute-mapping attribute-mapping?)) + +;; ============================================================ +;; Run-time + +(require "runtime-progress.rkt" + "3d-stx.rkt" + auto-syntax-e + syntax/stx + stxparse-info/current-pvars) + +(provide (all-from-out "runtime-progress.rkt") + + this-syntax + this-role + this-context-syntax + attribute + attribute-binding + check-attr-value + stx-list-take + stx-list-drop/cx + datum->syntax/with-clause + check-literal* + error/null-eh-match + begin-for-syntax/once + + name->too-few/once + name->too-few + name->too-many + normalize-context + syntax-patterns-fail) + +;; == from runtime.rkt + +;; this-syntax +;; Bound to syntax being matched inside of syntax class +(define-syntax-parameter this-syntax + (lambda (stx) + (raise-syntax-error #f "used out of context: not within a syntax class" stx))) + +(define-syntax-parameter this-role + (lambda (stx) + (raise-syntax-error #f "used out of context: not within a syntax class" stx))) + +;; this-context-syntax +;; Bound to (expression that extracts) context syntax (bottom frame in progress) +(define-syntax-parameter this-context-syntax + (lambda (stx) + (raise-syntax-error #f "used out of context: not within a syntax class" stx))) + +(define-syntax (attribute stx) + (syntax-case stx () + [(attribute name) + (identifier? #'name) + (let ([mapping (syntax-local-value #'name (lambda () #f))]) + (unless (syntax-pattern-variable? mapping) + (raise-syntax-error #f "not bound as a pattern variable" stx #'name)) + (let ([var (syntax-mapping-valvar mapping)]) + (let ([attr (syntax-local-value var (lambda () #f))]) + (unless (attribute-mapping? attr) + (raise-syntax-error #f "not bound as an attribute" stx #'name)) + (syntax-property (attribute-mapping-var attr) + 'disappeared-use + (list (syntax-local-introduce #'name))))))])) + +;; (attribute-binding id) +;; mostly for debugging/testing +(define-syntax (attribute-binding stx) + (syntax-case stx () + [(attribute-bound? name) + (identifier? #'name) + (let ([value (syntax-local-value #'name (lambda () #f))]) + (if (syntax-pattern-variable? value) + (let ([value (syntax-local-value (syntax-mapping-valvar value) (lambda () #f))]) + (if (attribute-mapping? value) + #`(quote #,(make-attr (attribute-mapping-name value) + (attribute-mapping-depth value) + (if (attribute-mapping-check value) #f #t))) + #'(quote #f))) + #'(quote #f)))])) + +;; stx-list-take : stxish nat -> syntax +(define (stx-list-take stx n) + (datum->syntax #f + (let loop ([stx stx] [n n]) + (if (zero? n) + null + (cons (stx-car stx) + (loop (stx-cdr stx) (sub1 n))))))) + +;; stx-list-drop/cx : stxish stx nat -> (values stxish stx) +(define (stx-list-drop/cx x cx n) + (let loop ([x x] [cx cx] [n n]) + (if (zero? n) + (values x + (if (syntax? x) x cx)) + (loop (stx-cdr x) + (if (syntax? x) x cx) + (sub1 n))))) + +;; check-attr-value : Any d:Nat b:Boolean Syntax/#f -> (Listof^d (if b Syntax Any)) +(define (check-attr-value v0 depth0 base? ctx) + (define (bad kind v) + (raise-syntax-error #f (format "attribute contains non-~s value\n value: ~e" kind v) ctx)) + (define (depthloop depth v) + (if (zero? depth) + (if base? (baseloop v) v) + (let listloop ([v v] [root? #t]) + (cond [(null? v) null] + [(pair? v) (let ([new-car (depthloop (sub1 depth) (car v))] + [new-cdr (listloop (cdr v) #f)]) + (cond [(and (eq? (car v) new-car) (eq? (cdr v) new-cdr)) v] + [else (cons new-car new-cdr)]))] + [(promise? v) (listloop (force v) root?)] + [(and root? (eq? v #f)) (begin (signal-absent-pvar) (bad 'list v))] + [else (bad 'list v)])))) + (define (baseloop v) + (cond [(syntax? v) v] + [(promise? v) (baseloop (force v))] + [(eq? v #f) (begin (signal-absent-pvar) (bad 'syntax v))] + [else (bad 'syntax v)])) + (depthloop depth0 v0)) + +;; datum->syntax/with-clause : any -> syntax +(define (datum->syntax/with-clause x) + (cond [(syntax? x) x] + [(2d-stx? x #:traverse-syntax? #f) + (datum->syntax #f x #f)] + [else + (error 'datum->syntax/with-clause + (string-append + "implicit conversion to 3D syntax\n" + " right-hand side of #:with clause or ~~parse pattern would be 3D syntax\n" + " value: ~e") + x)])) + +;; check-literal* : id phase phase (listof phase) stx -> void +(define (check-literal* id used-phase mod-phase ok-phases/ct-rel ctx) + (unless (or (memv (and used-phase (- used-phase mod-phase)) + ok-phases/ct-rel) + (identifier-binding id used-phase)) + (raise-syntax-error + #f + (format "literal is unbound in phase ~a (phase ~a relative to the enclosing module)" + used-phase + (and used-phase (- used-phase mod-phase))) + ctx id))) + +;; error/null-eh-match : -> (escapes) +(define (error/null-eh-match) + (error 'syntax-parse "an ellipsis-head pattern matched an empty sequence")) + +;; (begin-for-syntax/once expr/phase1 ...) +;; evaluates in pass 2 of module/intdefs expansion +(define-syntax (begin-for-syntax/once stx) + (syntax-case stx () + [(bfs/o e ...) + (cond [(list? (syntax-local-context)) + #`(define-values () + (begin (begin-for-syntax/once e ...) + (values)))] + [else + #'(let-syntax ([m (lambda _ (begin e ...) #'(void))]) + (m))])])) + +;; == parse.rkt + +(define (name->too-few/once name) + (and name (format "missing required occurrence of ~a" name))) + +(define (name->too-few name) + (and name (format "too few occurrences of ~a" name))) + +(define (name->too-many name) + (and name (format "too many occurrences of ~a" name))) + +;; == parse.rkt + +;; normalize-context : Symbol Any Syntax -> (list Symbol/#f Syntax) +(define (normalize-context who ctx stx) + (cond [(syntax? ctx) + (list #f ctx)] + [(symbol? ctx) + (list ctx stx)] + [(eq? ctx #f) + (list #f stx)] + [(and (list? ctx) + (= (length ctx) 2) + (or (symbol? (car ctx)) (eq? #f (car ctx))) + (syntax? (cadr ctx))) + ctx] + [else (error who "bad #:context argument\n expected: ~s\n given: ~e" + '(or/c syntax? symbol? #f (list/c (or/c symbol? #f) syntax?)) + ctx)])) + +;; == parse.rkt + +(lazy-require + ["runtime-report.rkt" + (call-current-failure-handler)]) + +;; syntax-patterns-fail : (list Symbol/#f Syntax) -> (Listof (-> Any)) FailureSet -> escapes +(define ((syntax-patterns-fail ctx) undos fs) + (unwind-to undos null) + (call-current-failure-handler ctx fs)) + +;; == specialized ellipsis parser +;; returns (values 'ok attr-values) or (values 'fail failure) + +(provide predicate-ellipsis-parser) + +(define (predicate-ellipsis-parser x cx pr es pred? desc rl) + (let ([elems (stx->list x)]) + (if (and elems (list? elems) (andmap pred? elems)) + (values 'ok elems) + (let loop ([x x] [cx cx] [i 0]) + (cond [(syntax? x) + (loop (syntax-e x) x i)] + [(pair? x) + (if (pred? (car x)) + (loop (cdr x) cx (add1 i)) + (let* ([pr (ps-add-cdr pr i)] + [pr (ps-add-car pr)] + [es (es-add-thing pr desc #t rl es)]) + (values 'fail (failure pr es))))] + [else ;; not null, because stx->list failed + (let ([pr (ps-add-cdr pr i)] + #| + ;; Don't extend es! That way we don't get spurious "expected ()" + ;; that *should* have been cancelled out by ineffable pair failures. + |#) + (values 'fail (failure pr es)))]))))) + +(provide illegal-cut-error) + +(define (illegal-cut-error . _) + (error 'syntax-parse "illegal use of cut")) + +;; ---- + +(provide unwind-to + maybe-add-state-undo + current-state + current-state-writable? + state-cons! + track-literals) + +(define (unwind-to undos base) + ;; PRE: undos = (list* proc/hash ... base) + (unless (eq? undos base) + (let ([top-undo (car undos)]) + (cond [(procedure? top-undo) (top-undo)] + [(hash? top-undo) (current-state top-undo)])) + (unwind-to (cdr undos) base))) + +(define (maybe-add-state-undo init-state new-state undos) + (if (eq? init-state new-state) + undos + (cons init-state undos))) + +;; To make adding undos to rewind current-state simpler, only allow updates +;; in a few contexts: +;; - literals (handled automatically) +;; - in ~do/#:do blocks (sets current-state-writable? = #t) + +(define current-state (make-parameter (hasheq))) +(define current-state-writable? (make-parameter #f)) + +(define (state-cons! key value) + (define state (current-state)) + (current-state (hash-set state key (cons value (hash-ref state key null))))) + +(define (track-literals who v #:introduce? [introduce? #t]) + (unless (syntax? v) + (raise-argument-error who "syntax?" v)) + (let* ([literals (hash-ref (current-state) 'literals '())]) + (if (null? literals) + v + (let ([literals* (if (and introduce? (syntax-transforming?) (list? literals)) + (for/list ([literal (in-list literals)]) + (if (identifier? literal) + (syntax-local-introduce literal) + literal)) + literals)] + [old-val (syntax-property v 'disappeared-use)]) + (syntax-property v 'disappeared-use + (if old-val + (cons literals* old-val) + literals*)))))) diff --git a/parse/private/sc.rkt b/parse/private/sc.rkt index ed56247..122ed04 100644 --- a/parse/private/sc.rkt +++ b/parse/private/sc.rkt @@ -8,5 +8,7 @@ (my-include "sc.rkt-6-11")] [(version< (version) "6.90.0.29") (my-include "sc.rkt-6-12")] + [(version< (version) "7.0.0.20") + (my-include "sc.rkt-6-90-0-29")] [else - (my-include "sc.rkt-6-90-0-29")]) + (my-include "sc.rkt-7-0-0-20")]) diff --git a/parse/private/sc.rkt-7-0-0-20 b/parse/private/sc.rkt-7-0-0-20 new file mode 100644 index 0000000..d4e5ff6 --- /dev/null +++ b/parse/private/sc.rkt-7-0-0-20 @@ -0,0 +1,32 @@ +#lang racket/base +(require racket/lazy-require + syntax/parse/private/keywords + "residual.rkt") + +(lazy-require-syntax + ["parse.rkt" + (define-syntax-class + define-splicing-syntax-class + define-integrable-syntax-class + syntax-parse + syntax-parser + define/syntax-parse + syntax-parser/template + define-eh-alternative-set)]) + +(provide define-syntax-class + define-splicing-syntax-class + define-integrable-syntax-class + syntax-parse + syntax-parser + define/syntax-parse + + (except-out (all-from-out syntax/parse/private/keywords) + ~reflect + ~splicing-reflect + ~eh-var) + attribute + this-syntax + + syntax-parser/template + define-eh-alternative-set)