diff --git a/parse/debug.rkt-6-11 b/parse/debug.rkt-6-11
new file mode 100644
index 0000000..efb87b9
--- /dev/null
+++ b/parse/debug.rkt-6-11
@@ -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 (fs) fs)])
+ (app-argu parser x x (ps-empty x x) #f fh fh #f
+ (lambda (fh . 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 #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/private/substitute.rkt-6-11 b/parse/experimental/private/substitute.rkt-6-11
new file mode 100644
index 0000000..5d8ba95
--- /dev/null
+++ b/parse/experimental/private/substitute.rkt-6-11
@@ -0,0 +1,500 @@
+#lang racket/base
+(require syntax/parse/private/minimatch
+ racket/private/promise
+ racket/private/stx) ;; syntax/stx
+(provide translate
+ syntax-local-template-metafunction-introduce)
+
+#|
+;; Doesn't seem to make much difference.
+(require (rename-in racket/unsafe/ops
+ [unsafe-vector-ref vector-ref]
+ [unsafe-vector-set! vector-set!]
+ [unsafe-car car]
+ [unsafe-cdr cdr]))
+|#
+
+;; ============================================================
+
+#|
+A Guide (G) is one of:
+ - '_
+ - VarRef ;; no syntax check
+ - (vector 'check VarRef) ;; check value is syntax
+ - (cons G G)
+ - (vector 'vector G)
+ - (vector 'struct G)
+ - (vector 'box G)
+ - (vector 'dots HG (listof (vector-of VarRef)) nat (listof nat) G)
+ - (vector 'app HG G)
+ - (vector 'escaped G)
+ - (vector 'orelse G G)
+ - (vector 'metafun integer G)
+ - (vector 'copy-props G (listof symbol))
+ - (vector 'set-props G (listof (cons symbol any)))
+ - (vector 'unsyntax VarRef)
+ - (vector 'relocate G)
+
+A HeadGuide (HG) is one of:
+ - G
+ - (vector 'app-opt H)
+ - (vector 'orelse-h H H)
+ - (vector 'splice G)
+ - (vector 'unsyntax-splicing VarRef)
+
+An VarRef is one of
+ - positive-exact-integer ;; represents depth=0 pvar ref or metafun ref
+ - negative-exact-integer ;; represents depth>0 pvar ref (within ellipsis)
+|#
+
+(define (head-guide? x)
+ (match x
+ [(vector 'app-opt g) #t]
+ [(vector 'splice g) #t]
+ [(vector 'orelse-h g1 g2) #t]
+ [(vector 'unsyntax-splicing var) #t]
+ [_ #f]))
+
+;; ============================================================
+
+;; Used to indicate absent pvar in template; ?? catches
+;; Note: not an exn, don't need continuation marks
+(require (only-in rackunit require/expose))
+#;(require/expose syntax/parse/experimental/private/substitute
+ (absent-pvar
+ absent-pvar?
+ absent-pvar-ctx
+ absent-pvar-v
+ absent-pvar-wanted-list?))
+;; this struct is only used in this file, and is not exported, so I guess it's
+;; ok to not steal the struct from syntax/parse/experimental/private/substitute
+;; Furthermore, the require/expose above does not work reliably.
+(struct absent-pvar (ctx v wanted-list?))
+
+;; ============================================================
+
+;; A translated-template is (vector loop-env -> syntax)
+;; A loop-env is either a vector of values or a single value,
+;; depending on lenv-mode of enclosing ellipsis ('dots) form.
+
+(define (translate stx g env-length)
+ (let ([f (translate-g stx stx g env-length 0)])
+ (lambda (env lenv)
+ (unless (>= (vector-length env) env-length)
+ (error 'template "internal error: environment too short"))
+ (with-handlers ([absent-pvar?
+ (lambda (ap)
+ (err/not-syntax (absent-pvar-ctx ap) (absent-pvar-v ap)))])
+ (f env lenv)))))
+
+;; lenv-mode is one of
+;; - 'one ;; lenv is single value; address as -1
+;; - nat ;; lenv is vector; address as (- -1 index); 0 means no loop env
+
+(define (translate-g stx0 stx g env-length lenv-mode)
+ (define (loop stx g) (translate-g stx0 stx g env-length lenv-mode))
+ (define (loop-h stx hg) (translate-hg stx0 stx hg env-length lenv-mode))
+ (define (get index env lenv) (get-var index env lenv lenv-mode))
+
+ (match g
+
+ ['_ (lambda (env lenv) stx)]
+
+ [(? exact-integer? index)
+ (check-var index env-length lenv-mode)
+ (lambda (env lenv) (get index env lenv))]
+
+ [(vector 'check index)
+ (check-var index env-length lenv-mode)
+ (lambda (env lenv) (check-stx stx (get index env lenv)))]
+
+ [(cons g1 g2)
+ (let ([f1 (loop (stx-car stx) g1)]
+ [f2 (loop (stx-cdr stx) g2)])
+ (cond [(syntax? stx)
+ (lambda (env lenv)
+ (restx stx (cons (f1 env lenv) (f2 env lenv))))]
+ [(eq? g1 '_)
+ (let ([c1 (stx-car stx)])
+ (lambda (env lenv)
+ (cons c1 (f2 env lenv))))]
+ [(eq? g2 '_)
+ (let ([c2 (stx-cdr stx)])
+ (lambda (env lenv)
+ (cons (f1 env lenv) c2)))]
+ [else
+ (lambda (env lenv)
+ (cons (f1 env lenv) (f2 env lenv)))]))]
+
+ [(vector 'dots ghead henv nesting uptos gtail)
+ ;; At each nesting depth, indexes [0,upto) of lenv* vary; the rest are fixed.
+ ;; An alternative would be to have a list of henvs, but that would inhibit
+ ;; the nice simple vector reuse via vector-car/cdr!.
+ (let* ([lenv*-len (vector-length henv)]
+ [ghead-is-hg? (head-guide? ghead)]
+ [ftail (loop (stx-drop (add1 nesting) stx) gtail)])
+ (for ([var (in-vector henv)])
+ (check-var var env-length lenv-mode))
+ (unless (= nesting (length uptos))
+ (error 'template "internal error: wrong number of uptos"))
+ (let ([last-upto
+ (for/fold ([last 1]) ([upto (in-list uptos)])
+ (unless (<= upto lenv*-len)
+ (error 'template "internal error: upto is too big"))
+ (unless (>= upto last)
+ (error 'template "internal error: uptos decreased: ~e" uptos))
+ upto)])
+ (unless (= lenv*-len last-upto)
+ (error 'template "internal error: last upto was not full env")))
+ (cond [(and (= lenv*-len 1) (= nesting 1) (not ghead-is-hg?)
+ (equal? ghead '-1))
+ ;; Fast path for (pvar ... . T) template
+ ;; - no list? or syntax? checks needed (because ghead is just raw varref,
+ ;; no 'check' wrapper)
+ ;; - avoid trivial map, just append
+ (let ([var-index (vector-ref henv 0)])
+ (lambda (env lenv)
+ (let ([lenv* (get var-index env lenv)])
+ (restx stx (append lenv* (ftail env lenv))))))]
+ [(and (= lenv*-len 1) (= nesting 1) (not ghead-is-hg?))
+ ;; Fast path for (T ... . T) template
+ ;; - specialize lenv to avoid vector allocation/mutation
+ ;; - body is deforested (append (map _ _) _) preserving eval order
+ ;; - could try to eliminate 'check-list', but probably not worth the bother
+ (let* ([fhead (translate-g stx0 (stx-car stx) ghead env-length 'one)]
+ [var-index (vector-ref henv 0)])
+ (lambda (env lenv)
+ (restx stx
+ (let ([lenv* (check-list/depth stx (get var-index env lenv) 1)])
+ (let dotsloop ([lenv* lenv*])
+ (if (null? lenv*)
+ (ftail env lenv)
+ (cons (fhead env (car lenv*))
+ (dotsloop (cdr lenv*)))))))))]
+ [else
+ ;; Slow/general path for (H ...^n . T)
+ (let ([fhead (if ghead-is-hg?
+ (translate-hg stx0 (stx-car stx) ghead env-length lenv*-len)
+ (translate-g stx0 (stx-car stx) ghead env-length lenv*-len))])
+ (lambda (env lenv)
+ #|
+ The template is "driven" by pattern variables bound to (listof^n syntax).
+ For example, in (H ... ... . T), the pvars of H have (listof (listof syntax)),
+ and we need a doubly-nested loop, like
+ (for/list ([stxlist^1 (in-list stxlist^2)])
+ (for/list ([stx (in-list stxlist^1)])
+ ___ fhead ___))
+ Since we can have arbitrary numbers of ellipses, we have 'nestloop' recur
+ over ellipsis levels and 'dotsloop' recur over the contents of the pattern
+ variables' (listof^n syntax) values.
+
+ Also, we reuse lenv vectors to reduce allocation. There is one aux lenv
+ vector per nesting level, preallocated in aux-lenvs. For continuation-safety
+ we must install a continuation barrier around metafunction applications.
+ |#
+ (define (nestloop lenv* nesting uptos aux-lenvs)
+ (cond [(zero? nesting)
+ (fhead env lenv*)]
+ [else
+ (let ([iters (check-lenv/get-iterations stx lenv*)])
+ (let ([lenv** (car aux-lenvs)]
+ [aux-lenvs** (cdr aux-lenvs)]
+ [upto** (car uptos)]
+ [uptos** (cdr uptos)])
+ (let dotsloop ([iters iters])
+ (if (zero? iters)
+ null
+ (begin (vector-car/cdr! lenv** lenv* upto**)
+ (let ([row (nestloop lenv** (sub1 nesting) uptos** aux-lenvs**)])
+ (cons row (dotsloop (sub1 iters)))))))))]))
+ (define initial-lenv*
+ (vector-map (lambda (index) (get index env lenv)) henv))
+ (define aux-lenvs
+ (for/list ([depth (in-range nesting)]) (make-vector lenv*-len)))
+
+ ;; Check initial-lenv* contains lists of right depths.
+ ;; At each nesting depth, indexes [0,upto) of lenv* vary;
+ ;; uptos is monotonic nondecreasing (every variable varies in inner
+ ;; loop---this is always counterintuitive to me).
+ (let checkloop ([depth nesting] [uptos uptos] [start 0])
+ (when (pair? uptos)
+ (for ([v (in-vector initial-lenv* start (car uptos))])
+ (check-list/depth stx v depth))
+ (checkloop (sub1 depth) (cdr uptos) (car uptos))))
+
+ (define head-results
+ ;; if ghead-is-hg?, is (listof^(nesting+1) stx) -- extra listof for loop-h
+ ;; otherwise, is (listof^nesting stx)
+ (nestloop initial-lenv* nesting uptos aux-lenvs))
+ (define tail-result (ftail env lenv))
+ (restx stx
+ (nested-append head-results
+ (if ghead-is-hg? nesting (sub1 nesting))
+ tail-result))))]))]
+
+ [(vector 'app ghead gtail)
+ (let ([fhead (loop-h (stx-car stx) ghead)]
+ [ftail (loop (stx-cdr stx) gtail)])
+ (lambda (env lenv)
+ (restx stx (append (fhead env lenv) (ftail env lenv)))))]
+
+ [(vector 'escaped g1)
+ (loop (stx-cadr stx) g1)]
+
+ [(vector 'orelse g1 g2)
+ (let ([f1 (loop (stx-cadr stx) g1)]
+ [f2 (loop (stx-caddr stx) g2)])
+ (lambda (env lenv)
+ (with-handlers ([absent-pvar?
+ (lambda (_e)
+ (f2 env lenv))])
+ (f1 env lenv))))]
+
+ [(vector 'metafun index g1)
+ (let ([f1 (loop (stx-cdr stx) g1)])
+ (check-var index env-length lenv-mode)
+ (lambda (env lenv)
+ (let ([v (restx stx (cons (stx-car stx) (f1 env lenv)))]
+ [mark (make-syntax-introducer)]
+ [old-mark (current-template-metafunction-introducer)]
+ [mf (get index env lenv)])
+ (parameterize ((current-template-metafunction-introducer mark)
+ (old-template-metafunction-introducer old-mark))
+ (let ([r (call-with-continuation-barrier (lambda () (mf (mark (old-mark v)))))])
+ (unless (syntax? r)
+ (raise-syntax-error #f "result of template metafunction was not syntax" stx))
+ (restx stx (old-mark (mark r))))))))]
+
+ [(vector 'vector g1)
+ (let ([f1 (loop (vector->list (syntax-e stx)) g1)])
+ (lambda (env lenv)
+ (restx stx (list->vector (f1 env lenv)))))]
+
+ [(vector 'struct g1)
+ (let ([f1 (loop (cdr (vector->list (struct->vector (syntax-e stx)))) g1)]
+ [key (prefab-struct-key (syntax-e stx))])
+ (lambda (env lenv)
+ (restx stx (apply make-prefab-struct key (f1 env lenv)))))]
+
+ [(vector 'box g1)
+ (let ([f1 (loop (unbox (syntax-e stx)) g1)])
+ (lambda (env lenv)
+ (restx stx (box (f1 env lenv)))))]
+
+ [(vector 'copy-props g1 keys)
+ (let ([f1 (loop stx g1)])
+ (lambda (env lenv)
+ (for/fold ([v (f1 env lenv)]) ([key (in-list keys)])
+ (let ([pvalue (syntax-property stx key)])
+ (if pvalue
+ (syntax-property v key pvalue)
+ v)))))]
+
+ [(vector 'set-props g1 props-alist)
+ (let ([f1 (loop stx g1)])
+ (lambda (env lenv)
+ (for/fold ([v (f1 env lenv)]) ([entry (in-list props-alist)])
+ (syntax-property v (car entry) (cdr entry)))))]
+
+ [(vector 'unsyntax var)
+ (let ([f1 (loop stx var)])
+ (lambda (env lenv)
+ (restx stx (f1 env lenv))))]
+
+ [(vector 'relocate g1 var)
+ (let ([f1 (loop stx g1)])
+ (lambda (env lenv)
+ (let ([result (f1 env lenv)]
+ [loc (get var env lenv)])
+ (if (or (syntax-source loc)
+ (syntax-position loc))
+ (datum->syntax result (syntax-e result) loc result)
+ result))))]))
+
+(define (translate-hg stx0 stx hg env-length lenv-mode)
+ (define (loop stx g) (translate-g stx0 stx g env-length lenv-mode))
+ (define (loop-h stx hg) (translate-hg stx0 stx hg env-length lenv-mode))
+ (define (get index env lenv) (get-var index env lenv lenv-mode))
+
+ (match hg
+
+ [(vector 'app-opt hg1)
+ (let ([f1 (loop-h (stx-cadr stx) hg1)])
+ (lambda (env lenv)
+ (with-handlers ([absent-pvar? (lambda (_e) null)])
+ (f1 env lenv))))]
+
+ [(vector 'orelse-h hg1 hg2)
+ (let ([f1 (loop-h (stx-cadr stx) hg1)]
+ [f2 (loop-h (stx-caddr stx) hg2)])
+ (lambda (env lenv)
+ (with-handlers ([absent-pvar?
+ (lambda (_e)
+ (f2 env lenv))])
+ (f1 env lenv))))]
+
+ [(vector 'splice g1)
+ (let ([f1 (loop (stx-cdr stx) g1)])
+ (lambda (env lenv)
+ (let* ([v (f1 env lenv)]
+ [v* (stx->list v)])
+ (unless (list? v*)
+ (raise-syntax-error 'template
+ "splicing template did not produce a syntax list"
+ stx))
+ v*)))]
+
+ [(vector 'unsyntax-splicing index)
+ (check-var index env-length lenv-mode)
+ (lambda (env lenv)
+ (let* ([v (get index env lenv)]
+ [v* (stx->list v)])
+ (unless (list? v*)
+ (raise-syntax-error 'template
+ "unsyntax-splicing expression did not produce a syntax list"
+ stx))
+ v*))]
+
+ [_
+ (let ([f (loop stx hg)])
+ (lambda (env lenv)
+ (list (f env lenv))))]))
+
+(define (get-var index env lenv lenv-mode)
+ (cond [(positive? index)
+ (vector-ref env (sub1 index))]
+ [(negative? index)
+ (case lenv-mode
+ ((one) lenv)
+ (else (vector-ref lenv (- -1 index))))]))
+
+(define (check-var index env-length lenv-mode)
+ (cond [(positive? index)
+ (unless (< (sub1 index) env-length)
+ (error/bad-index index))]
+ [(negative? index)
+ (unless (< (- -1 index)
+ (case lenv-mode
+ ((one) 1)
+ (else lenv-mode)))
+ (error/bad-index))]))
+
+(define (check-lenv/get-iterations stx lenv)
+ (unless (list? (vector-ref lenv 0))
+ (error 'template "pattern variable used in ellipsis pattern is not defined"))
+ (let ([len0 (length (vector-ref lenv 0))])
+ (for ([v (in-vector lenv)])
+ (unless (list? v)
+ (error 'template "pattern variable used in ellipsis pattern is not defined"))
+ (unless (= len0 (length v))
+ (raise-syntax-error 'template
+ "incompatible ellipsis match counts for template"
+ stx)))
+ len0))
+
+;; ----
+
+(define current-template-metafunction-introducer
+ (make-parameter
+ (lambda (stx)
+ (if (syntax-transforming?)
+ (syntax-local-introduce stx)
+ stx))))
+
+(define old-template-metafunction-introducer
+ (make-parameter #f))
+
+(define (syntax-local-template-metafunction-introduce stx)
+ (let ([mark (current-template-metafunction-introducer)]
+ [old-mark (old-template-metafunction-introducer)])
+ (unless old-mark
+ (error 'syntax-local-template-metafunction-introduce
+ "must be called within the dynamic extent of a template metafunction"))
+ (mark (old-mark stx))))
+
+;; ----
+
+(define (stx-cadr x) (stx-car (stx-cdr x)))
+(define (stx-cddr x) (stx-cdr (stx-cdr x)))
+(define (stx-caddr x) (stx-car (stx-cdr (stx-cdr x))))
+
+(define (stx-drop n x)
+ (cond [(zero? n) x]
+ [else (stx-drop (sub1 n) (stx-cdr x))]))
+
+(define (restx basis val)
+ (if (syntax? basis)
+ (datum->syntax basis val basis)
+ val))
+
+;; nested-append : (listof^(nesting+1) A) nat (listof A) -> (listof A)
+;; (Actually, in practice onto is stx, so this is an improper append.)
+(define (nested-append lst nesting onto)
+ (cond [(zero? nesting) (append lst onto)]
+ [(null? lst) onto]
+ [else (nested-append (car lst) (sub1 nesting)
+ (nested-append (cdr lst) nesting onto))]))
+
+(define (check-stx ctx v)
+ (let loop ([v v])
+ (cond [(syntax? v)
+ v]
+ [(promise? v)
+ (loop (force v))]
+ [(eq? v #f)
+ (raise (absent-pvar ctx v #f))]
+ [else (err/not-syntax ctx v)])))
+
+(define (check-list/depth ctx v0 depth0)
+ (let depthloop ([v v0] [depth depth0])
+ (cond [(zero? depth) v]
+ [(and (= depth 1) (list? v)) v]
+ [else
+ (let loop ([v v])
+ (cond [(null? v)
+ null]
+ [(pair? v)
+ (let ([new-car (depthloop (car v) (sub1 depth))]
+ [new-cdr (loop (cdr v))])
+ ;; Don't copy unless necessary
+ (if (and (eq? new-car (car v)) (eq? new-cdr (cdr v)))
+ v
+ (cons new-car new-cdr)))]
+ [(promise? v)
+ (loop (force v))]
+ [(eq? v #f)
+ (raise (absent-pvar ctx v0 #t))]
+ [else
+ (err/not-syntax ctx v0)]))])))
+
+;; Note: slightly different from error msg in syntax/parse/private/residual:
+;; here says "contains" instead of "is bound to", because might be within list
+(define (err/not-syntax ctx v)
+ (raise-syntax-error #f
+ (format "attribute contains non-syntax value\n value: ~e" v)
+ ctx))
+
+(define (error/bad-index index)
+ (error 'template "internal error: bad index: ~e" index))
+
+(define (vector-car/cdr! dest-v src-v upto)
+ (let ([len (vector-length dest-v)])
+ (let loop ([i 0])
+ (when (< i upto)
+ (let ([p (vector-ref src-v i)])
+ (vector-set! dest-v i (car p))
+ (vector-set! src-v i (cdr p)))
+ (loop (add1 i))))
+ (let loop ([j upto])
+ (when (< j len)
+ (vector-set! dest-v j (vector-ref src-v j))
+ (loop (add1 j))))))
+
+(define (vector-map f src-v)
+ (let* ([len (vector-length src-v)]
+ [dest-v (make-vector len)])
+ (let loop ([i 0])
+ (when (< i len)
+ (vector-set! dest-v i (f (vector-ref src-v i)))
+ (loop (add1 i))))
+ dest-v))
\ No newline at end of file
diff --git a/parse/experimental/provide.rkt-6-11 b/parse/experimental/provide.rkt-6-11
new file mode 100644
index 0000000..280a73d
--- /dev/null
+++ b/parse/experimental/provide.rkt-6-11
@@ -0,0 +1,156 @@
+#lang racket/base
+(require racket/contract/base
+ racket/contract/combinator
+ syntax/location
+ (for-syntax racket/base
+ racket/syntax
+ syntax/parse/private/minimatch
+ stxparse-info/parse/pre
+ syntax/parse/private/residual-ct ;; keep abs. path
+ syntax/parse/private/kws
+ syntax/contract))
+(provide provide-syntax-class/contract
+ syntax-class/c
+ splicing-syntax-class/c)
+
+;; FIXME:
+;; - seems to get first-requiring-module wrong, not surprising
+;; - extend to contracts on attributes?
+;; - syntax-class/c etc just a made-up name, for now
+;; (connect to dynamic syntax-classes, eventually)
+
+(define-syntaxes (syntax-class/c splicing-syntax-class/c)
+ (let ([nope
+ (lambda (stx)
+ (raise-syntax-error #f "not within `provide-syntax-class/contract form" stx))])
+ (values nope nope)))
+
+(begin-for-syntax
+ (define-struct ctcrec (mpcs mkws mkwcs opcs okws okwcs) #:prefab
+ #:omit-define-syntaxes))
+
+(begin-for-syntax
+ ;; do-one-contract : stx id stxclass ctcrec id -> stx
+ (define (do-one-contract stx scname stxclass rec pos-module-source)
+ ;; First, is the contract feasible?
+ (match (stxclass-arity stxclass)
+ [(arity minpos maxpos minkws maxkws)
+ (let* ([minpos* (length (ctcrec-mpcs rec))]
+ [maxpos* (+ minpos* (length (ctcrec-opcs rec)))]
+ [minkws* (sort (map syntax-e (ctcrec-mkws rec)) keyword<?)]
+ [maxkws* (sort (append minkws* (map syntax-e (ctcrec-okws rec))) keyword<?)])
+ (define (err msg . args)
+ (apply wrong-syntax scname msg args))
+ (unless (<= minpos minpos*)
+ (err (string-append "expected a syntax class with at most ~a "
+ "required positional arguments, got one with ~a")
+ minpos* minpos))
+ (unless (<= maxpos* maxpos)
+ (err (string-append "expected a syntax class with at least ~a "
+ "total positional arguments (required and optional), "
+ "got one with ~a")
+ maxpos* maxpos))
+ (unless (null? (diff/sorted/eq minkws minkws*))
+ (err (string-append "expected a syntax class with at most the "
+ "required keyword arguments ~a, got one with ~a")
+ (join-sep (map kw->string minkws*) "," "and")
+ (join-sep (map kw->string minkws) "," "and")))
+ (unless (null? (diff/sorted/eq maxkws* maxkws))
+ (err (string-append "expected a syntax class with at least the optional "
+ "keyword arguments ~a, got one with ~a")
+ (join-sep (map kw->string maxkws*) "," "and")
+ (join-sep (map kw->string maxkws) "," "and")))
+ (with-syntax ([scname scname]
+ [#s(stxclass name arity attrs parser splicing? opts inline)
+ stxclass]
+ [#s(ctcrec (mpc ...) (mkw ...) (mkwc ...)
+ (opc ...) (okw ...) (okwc ...))
+ rec]
+ [arity* (arity minpos* maxpos* minkws* maxkws*)]
+ [(parser-contract contracted-parser contracted-scname)
+ (generate-temporaries #`(contract parser #,scname))])
+ (with-syntax ([(mpc-id ...) (generate-temporaries #'(mpc ...))]
+ [(mkwc-id ...) (generate-temporaries #'(mkwc ...))]
+ [(opc-id ...) (generate-temporaries #'(opc ...))]
+ [(okwc-id ...) (generate-temporaries #'(okwc ...))])
+ (with-syntax ([((mkw-c-part ...) ...) #'((mkw mkwc-id) ...)]
+ [((okw-c-part ...) ...) #'((okw okwc-id) ...)]
+ [((mkw-name-part ...) ...) #'((mkw ,(contract-name mkwc-id)) ...)]
+ [((okw-name-part ...) ...) #'((okw ,(contract-name okwc-id)) ...)])
+ #`(begin
+ (define parser-contract
+ (let ([mpc-id mpc] ...
+ [mkwc-id mkwc] ...
+ [opc-id opc] ...
+ [okwc-id okwc] ...)
+ (rename-contract
+ (->* (any/c any/c any/c any/c any/c any/c any/c any/c
+ mpc-id ... mkw-c-part ... ...)
+ (okw-c-part ... ...)
+ any)
+ `(,(if 'splicing? 'splicing-syntax-class/c 'syntax-class/c)
+ [,(contract-name mpc-id) ... mkw-name-part ... ...]
+ [okw-name-part ... ...]))))
+ (define-module-boundary-contract contracted-parser
+ parser parser-contract #:pos-source #,pos-module-source)
+ (define-syntax contracted-scname
+ (make-stxclass
+ (quote-syntax name)
+ 'arity*
+ 'attrs
+ (quote-syntax contracted-parser)
+ 'splicing?
+ 'opts #f)) ;; must disable inlining
+ (provide (rename-out [contracted-scname scname])))))))])))
+
+(define-syntax (provide-syntax-class/contract stx)
+
+ (define-syntax-class stxclass-ctc
+ #:description "syntax-class/c or splicing-syntax-class/c form"
+ #:literals (syntax-class/c splicing-syntax-class/c)
+ #:attributes (rec)
+ #:commit
+ (pattern ((~or syntax-class/c splicing-syntax-class/c)
+ mand:ctclist
+ (~optional opt:ctclist))
+ #:attr rec (make-ctcrec (attribute mand.pc.c)
+ (attribute mand.kw)
+ (attribute mand.kwc.c)
+ (or (attribute opt.pc.c) '())
+ (or (attribute opt.kw) '())
+ (or (attribute opt.kwc.c) '()))))
+
+ (define-syntax-class ctclist
+ #:attributes ([pc.c 1] [kw 1] [kwc.c 1])
+ #:commit
+ (pattern ((~or pc:expr (~seq kw:keyword kwc:expr)) ...)
+ #:with (pc.c ...) (for/list ([pc-expr (in-list (syntax->list #'(pc ...)))])
+ (wrap-expr/c #'contract? pc-expr))
+ #:with (kwc.c ...) (for/list ([kwc-expr (in-list (syntax->list #'(kwc ...)))])
+ (wrap-expr/c #'contract? kwc-expr))))
+
+ (syntax-parse stx
+ [(_ [scname c:stxclass-ctc] ...)
+ #:declare scname (static stxclass? "syntax class")
+ (parameterize ((current-syntax-context stx))
+ (with-disappeared-uses
+ #`(begin (define pos-module-source (quote-module-name))
+ #,@(for/list ([scname (in-list (syntax->list #'(scname ...)))]
+ [stxclass (in-list (attribute scname.value))]
+ [rec (in-list (attribute c.rec))])
+ (do-one-contract stx scname stxclass rec #'pos-module-source)))))]))
+
+;; Copied from unstable/contract,
+;; which requires racket/contract, not racket/contract/base
+
+;; rename-contract : contract any/c -> contract
+;; If the argument is a flat contract, so is the result.
+(define (rename-contract ctc name)
+ (let ([ctc (coerce-contract 'rename-contract ctc)])
+ (if (flat-contract? ctc)
+ (flat-named-contract name (flat-contract-predicate ctc))
+ (let* ([ctc-fo (contract-first-order ctc)]
+ [late-neg-proj (contract-late-neg-projection ctc)])
+ (make-contract #:name name
+ #:late-neg-projection late-neg-proj
+ #:first-order ctc-fo)))))
diff --git a/parse/experimental/reflect.rkt-6-11 b/parse/experimental/reflect.rkt-6-11
new file mode 100644
index 0000000..460d964
--- /dev/null
+++ b/parse/experimental/reflect.rkt-6-11
@@ -0,0 +1,149 @@
+#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<?)]
+ [maxkws* (sort (remq* kws1 maxkws) keyword<?)])
+ (arity minpos* maxpos* minkws* maxkws*))])]
+ [curried-parser
+ (make-keyword-procedure
+ (lambda (kws2 kwargs2 x cx pr es fh cp rl success . rest2)
+ (let-values ([(kws kwargs) (merge2 kws1 kws2 kwargs1 kwargs2)])
+ (keyword-apply parser kws kwargs x cx pr es fh cp rl success
+ (append rest1 rest2)))))]
+ [ctor
+ (cond [(reified-syntax-class? r)
+ reified-syntax-class]
+ [(reified-splicing-syntax-class? r)
+ reified-splicing-syntax-class]
+ [else
+ (error 'curry-reified-syntax-class "INTERNAL ERROR: ~e" r)])])
+ (ctor name curried-parser curried-arity sig)))]))))
+
+(define (merge2 kws1 kws2 kwargs1 kwargs2)
+ (cond [(null? kws1)
+ (values kws2 kwargs2)]
+ [(null? kws2)
+ (values kws1 kwargs1)]
+ [(keyword<? (car kws1) (car kws2))
+ (let-values ([(m-kws m-kwargs)
+ (merge2 (cdr kws1) kws2 (cdr kwargs1) kwargs2)])
+ (values (cons (car kws1) m-kws) (cons (car kwargs1) m-kwargs)))]
+ [else
+ (let-values ([(m-kws m-kwargs)
+ (merge2 kws1 (cdr kws2) kwargs1 (cdr kwargs2))])
+ (values (cons (car kws2) m-kws) (cons (car kwargs2) m-kwargs)))]))
+
+;; ----
+
+(provide reify-syntax-class
+ ~reflect
+ ~splicing-reflect)
+
+(provide/contract
+ [reified-syntax-class?
+ (-> 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))
+ (#:<kw> 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)
+ (and (procedure? f) (procedure-arity-includes? f))))])
+
diff --git a/parse/experimental/specialize.rkt-6-11 b/parse/experimental/specialize.rkt-6-11
new file mode 100644
index 0000000..72f1e6c
--- /dev/null
+++ b/parse/experimental/specialize.rkt-6-11
@@ -0,0 +1,40 @@
+#lang racket/base
+(require (for-syntax racket/base
+ racket/syntax
+ syntax/parse/private/kws
+ syntax/parse/private/rep-data
+ "../private/rep.rkt")
+ "../private/runtime.rkt")
+(provide define-syntax-class/specialize)
+
+(define-syntax (define-syntax-class/specialize stx)
+ (parameterize ((current-syntax-context stx))
+ (syntax-case stx ()
+ [(dscs header sc-expr)
+ (with-disappeared-uses
+ (let-values ([(name formals arity)
+ (let ([p (check-stxclass-header #'header stx)])
+ (values (car p) (cadr p) (caddr p)))]
+ [(target-scname argu)
+ (let ([p (check-stxclass-application #'sc-expr stx)])
+ (values (car p) (cdr p)))])
+ (let* ([pos-count (length (arguments-pargs argu))]
+ [kws (arguments-kws argu)]
+ [target (get-stxclass/check-arity target-scname target-scname pos-count kws)])
+ (with-syntax ([name name]
+ [formals formals]
+ [parser (generate-temporary (format-symbol "parser-~a" #'name))]
+ [splicing? (stxclass-splicing? target)]
+ [arity arity]
+ [attrs (stxclass-attrs target)]
+ [opts (stxclass-opts target)]
+ [target-parser (stxclass-parser target)]
+ [argu argu])
+ #`(begin (define-syntax name
+ (stxclass 'name 'arity 'attrs
+ (quote-syntax parser)
+ 'splicing?
+ 'opts #f))
+ (define-values (parser)
+ (lambda (x cx pr es fh0 cp0 rl success . formals)
+ (app-argu target-parser x cx pr es fh0 cp0 rl success argu))))))))])))
diff --git a/parse/experimental/splicing.rkt-6-11 b/parse/experimental/splicing.rkt-6-11
new file mode 100644
index 0000000..e0694aa
--- /dev/null
+++ b/parse/experimental/splicing.rkt-6-11
@@ -0,0 +1,95 @@
+#lang racket/base
+(require (for-syntax racket/base
+ stxparse-info/parse
+ racket/lazy-require
+ syntax/parse/private/kws)
+ stxparse-info/parse/private/residual) ;; keep abs. path
+(provide define-primitive-splicing-syntax-class)
+
+(begin-for-syntax
+ (lazy-require
+ [syntax/parse/private/rep-attrs
+ (sort-sattrs)]))
+;; 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-attrs)
+
+(define-syntax (define-primitive-splicing-syntax-class stx)
+
+ (define-syntax-class attr
+ #:commit
+ (pattern name:id
+ #:with depth #'0)
+ (pattern [name:id depth:nat]))
+
+ (syntax-parse stx
+ [(dssp (name:id param:id ...)
+ (~or (~once (~seq #:attributes (a:attr ...))
+ #:name "attributes declaration")
+ (~once (~seq #:description description)
+ #:name "description declaration")) ...
+ proc:expr)
+ #'(begin
+ (define (get-description param ...)
+ description)
+ (define parser
+ (let ([permute (mk-permute '(a.name ...))])
+ (lambda (x cx pr es fh _cp rl success param ...)
+ (let ([stx (datum->syntax cx x cx)])
+ (let ([result
+ (let/ec escape
+ (cons 'ok
+ (proc stx
+ (lambda ([msg #f] [stx #f])
+ (escape (list 'error msg stx))))))])
+ (case (car result)
+ ((ok)
+ (apply success
+ ((mk-check-result pr 'name (length '(a.name ...)) permute x cx fh)
+ (cdr result))))
+ ((error)
+ (let ([es
+ (es-add-message (cadr result)
+ (es-add-thing pr (get-description param ...) #f rl es))])
+ (fh (failure pr es))))))))))
+ (define-syntax name
+ (stxclass 'name (arity (length '(param ...)) (length '(param ...)) '() '())
+ (sort-sattrs '(#s(attr a.name a.depth #f) ...))
+ (quote-syntax parser)
+ #t
+ (scopts (length '(a.name ...)) #t #t #f)
+ #f)))]))
+
+(define (mk-permute unsorted-attrs)
+ (let ([sorted-attrs
+ (sort unsorted-attrs string<? #:key symbol->string #:cache-keys? #t)])
+ (if (equal? unsorted-attrs sorted-attrs)
+ values
+ (let* ([pos-table
+ (for/hasheq ([a (in-list unsorted-attrs)] [i (in-naturals)])
+ (values a i))]
+ [indexes
+ (for/vector ([a (in-list sorted-attrs)])
+ (hash-ref pos-table a))])
+ (lambda (result)
+ (for/list ([index (in-vector indexes)])
+ (list-ref result index)))))))
+
+(define (mk-check-result pr name attr-count permute x cx fh)
+ (lambda (result)
+ (unless (list? result)
+ (error name "parser returned non-list"))
+ (let ([rlength (length result)])
+ (unless (= rlength (+ 1 attr-count))
+ (error name "parser returned list of wrong length; expected length ~s, got ~e"
+ (+ 1 attr-count)
+ result))
+ (let ([skip (car result)])
+ ;; Compute rest-x & rest-cx from skip
+ (unless (exact-nonnegative-integer? skip)
+ (error name "expected exact nonnegative integer for first element of result list, got ~e"
+ skip))
+ (let-values ([(rest-x rest-cx) (stx-list-drop/cx x cx skip)])
+ (list* fh rest-x rest-cx (ps-add-cdr pr skip)
+ (permute (cdr result))))))))
diff --git a/parse/experimental/template.rkt-6-11 b/parse/experimental/template.rkt-6-11
new file mode 100644
index 0000000..0cad7a1
--- /dev/null
+++ b/parse/experimental/template.rkt-6-11
@@ -0,0 +1,684 @@
+#lang racket/base
+(require (for-syntax racket/base
+ "dset.rkt"
+ racket/syntax
+ syntax/parse/private/minimatch
+ racket/private/stx ;; syntax/stx
+ racket/private/sc
+ racket/struct
+ auto-syntax-e/utils)
+ stxparse-info/parse/private/residual
+ "private/substitute.rkt")
+(provide template
+ template/loc
+ quasitemplate
+ quasitemplate/loc
+ define-template-metafunction
+ syntax-local-template-metafunction-introduce
+ ??
+ ?@
+ (for-syntax template-metafunction?))
+
+#|
+To do:
+- improve error messages
+|#
+
+#|
+A Template (T) is one of:
+ - pvar
+ - const (including () and non-pvar identifiers)
+ - (metafunction . T)
+ - (H . T)
+ - (H ... . T), (H ... ... . T), etc
+ - (?? T T)
+ - #(T*)
+ - #s(prefab-struct-key T*)
+ * (unquote expr)
+
+A HeadTemplate (H) is one of:
+ - T
+ - (?? H)
+ - (?? H H)
+ - (?@ . T)
+ * (unquote-splicing expr)
+|#
+
+(begin-for-syntax
+ (define (do-template ctx tstx quasi? loc-id)
+ (with-disappeared-uses
+ (parameterize ((current-syntax-context ctx)
+ (quasi (and quasi? (box null))))
+ (let*-values ([(guide deps props-guide) (parse-template tstx loc-id)]
+ [(vars)
+ (for/list ([dep (in-vector deps)])
+ (cond [(pvar? dep) (pvar-var dep)]
+ [(template-metafunction? dep)
+ (template-metafunction-var dep)]
+ [else
+ (error 'template
+ "internal error: bad environment entry: ~e"
+ dep)]))])
+ (with-syntax ([t tstx])
+ (syntax-arm
+ (cond [(equal? guide '1)
+ ;; was (template pvar), implies props-guide = '_
+ (car vars)]
+ [(and (equal? guide '_) (equal? props-guide '_))
+ #'(quote-syntax t)]
+ [else
+ (with-syntax ([guide guide]
+ [props-guide props-guide]
+ [vars-vector
+ (if (pair? vars)
+ #`(vector . #,vars)
+ #''#())]
+ [((un-var . un-form) ...)
+ (if quasi? (reverse (unbox (quasi))) null)])
+ #'(let ([un-var (handle-unsyntax un-form)] ...)
+ (substitute (quote-syntax t)
+ 'props-guide
+ 'guide
+ vars-vector)))]))))))))
+
+(define-syntax (template stx)
+ (syntax-case stx ()
+ [(template t)
+ (do-template stx #'t #f #f)]
+ [(template t #:properties (prop ...))
+ (andmap identifier? (syntax->list #'(prop ...)))
+ (parameterize ((props-to-serialize (syntax->datum #'(prop ...)))
+ (props-to-transfer (syntax->datum #'(prop ...))))
+ (do-template stx #'t #f #f))]))
+
+(define-syntax (quasitemplate stx)
+ (syntax-case stx ()
+ [(quasitemplate t)
+ (do-template stx #'t #t #f)]
+ [(quasitemplate t #:properties (prop ...))
+ (andmap identifier? (syntax->list #'(prop ...)))
+ (parameterize ((props-to-serialize (syntax->datum #'(prop ...)))
+ (props-to-transfer (syntax->datum #'(prop ...))))
+ ;; Same as above
+ (do-template stx #'t #t #f))]))
+
+(define-syntaxes (template/loc quasitemplate/loc)
+ ;; FIXME: better to replace unsyntax form, shrink template syntax constant
+ (let ([make-tx
+ (lambda (quasi?)
+ (lambda (stx)
+ (syntax-case stx ()
+ [(?/loc loc-expr t)
+ (syntax-arm
+ (with-syntax ([main-expr (do-template stx #'t quasi? #'loc-stx)])
+ #'(let ([loc-stx (handle-loc '?/loc loc-expr)])
+ main-expr)))]
+ [(?/loc loc-expr t #:properties (prop ...))
+ (andmap identifier? (syntax->list #'(prop ...)))
+ (parameterize ((props-to-serialize (syntax->datum #'(prop ...)))
+ (props-to-transfer (syntax->datum #'(prop ...))))
+ ;; Same as above
+ (syntax-arm
+ (with-syntax ([main-expr (do-template stx #'t quasi? #'loc-stx)])
+ #'(let ([loc-stx (handle-loc '?/loc loc-expr)])
+ main-expr))))])))])
+ (values (make-tx #f) (make-tx #t))))
+
+(define (handle-loc who x)
+ (if (syntax? x)
+ x
+ (raise-argument-error who "syntax?" x)))
+
+;; FIXME: what lexical context should result of expr get if not syntax?
+(define-syntax handle-unsyntax
+ (syntax-rules (unsyntax unsyntax-splicing)
+ [(handle-syntax (unsyntax expr)) expr]
+ [(handle-syntax (unsyntax-splicing expr)) expr]))
+
+;; substitute-table : hash[stx => translated-template]
+;; Cache for closure-compiled templates. Key is just syntax of
+;; template, since eq? templates must have equal? guides.
+(define substitute-table (make-weak-hasheq))
+
+;; props-syntax-table : hash[stx => stx]
+(define props-syntax-table (make-weak-hasheq))
+
+(define (substitute stx props-guide g main-env)
+ (let* ([stx (if (eq? props-guide '_)
+ stx
+ (or (hash-ref props-syntax-table stx #f)
+ (let* ([pf (translate stx props-guide 0)]
+ [pstx (pf '#() #f)])
+ (hash-set! props-syntax-table stx pstx)
+ pstx)))]
+ [f (or (hash-ref substitute-table stx #f)
+ (let ([f (translate stx g (vector-length main-env))])
+ (hash-set! substitute-table stx f)
+ f))])
+ (f main-env #f)))
+
+;; ----
+
+(define-syntaxes (?? ?@)
+ (let ([tx (lambda (stx) (raise-syntax-error #f "not allowed as an expression" stx))])
+ (values tx tx)))
+
+;; ============================================================
+
+#|
+See private/substitute for definition of Guide (G) and HeadGuide (HG).
+
+A env-entry is one of
+ - (pvar syntax-mapping attribute-mapping/#f depth-delta)
+ - template-metafunction
+
+The depth-delta associated with a depth>0 pattern variable is the difference
+between the pattern variable's depth and the depth at which it is used. (For
+depth 0 pvars, it's #f.) For example, in
+
+ (with-syntax ([x #'0]
+ [(y ...) #'(1 2)]
+ [((z ...) ...) #'((a b) (c d))])
+ (template (((x y) ...) ...)))
+
+the depth-delta for x is #f, the depth-delta for y is 1, and the depth-delta for
+z is 0. Coincidentally, the depth-delta is the same as the depth of the ellipsis
+form at which the variable should be moved to the loop-env. That is, the
+template above should be interpreted as roughly similar to
+
+ (let ([x (pvar-value-of x)]
+ [y (pvar-value-of y)]
+ [z (pvar-value-of z)])
+ (for ([Lz (in-list z)]) ;; depth 0
+ (for ([Ly (in-list y)] ;; depth 1
+ [Lz (in-list Lz)])
+ (___ x Ly Lz ___))))
+
+A Pre-Guide is like a Guide but with env-entry and (setof env-entry)
+instead of integers and integer vectors.
+|#
+
+(begin-for-syntax
+ (struct pvar (sm attr dd) #:prefab))
+
+;; ============================================================
+
+
+;; TODO: once PR https://github.com/racket/racket/pull/1591 is merged, use
+;; the exported prop:template-metafunction, template-metafunction? and
+;; template-metafunction-accessor.
+(define-syntax (define-template-metafunction stx)
+ (syntax-case stx ()
+ [(dsm (id arg ...) . body)
+ #'(dsm id (lambda (arg ...) . body))]
+ [(dsm id expr)
+ (identifier? #'id)
+ (with-syntax ([(internal-id) (generate-temporaries #'(id))])
+ #'(begin (define internal-id expr)
+ (define-syntax id
+ (template-metafunction (quote-syntax internal-id)))))]))
+
+(begin-for-syntax
+ (struct template-metafunction (var)))
+
+;; ============================================================
+
+(begin-for-syntax
+
+ ;; props-to-serialize determines what properties are saved even when
+ ;; code is compiled. (Unwritable values are dropped.)
+ ;; props-to-transfer determines what properties are transferred from
+ ;; template to stx constructed.
+ ;; If a property is in props-to-transfer but not props-to-serialize,
+ ;; compiling the module may have caused the property to disappear.
+ ;; If a property is in props-to-serialize but not props-to-transfer,
+ ;; it will show up only in constant subtrees.
+ ;; The behavior of 'syntax' is serialize '(), transfer '(paren-shape).
+
+ ;; props-to-serialize : (parameterof (listof symbol))
+ (define props-to-serialize (make-parameter '()))
+
+ ;; props-to-transfer : (parameterof (listof symbol))
+ (define props-to-transfer (make-parameter '(paren-shape)))
+
+ ;; quasi : (parameterof (or/c #f (list^n (boxof QuasiPairs))))
+ ;; each list wrapper represents nested quasi wrapping
+ ;; QuasiPairs = (listof (cons/c identifier syntax))
+ (define quasi (make-parameter #f))
+
+ ;; parse-template : stx id/#f -> (values guide (vectorof env-entry) guide)
+ (define (parse-template t loc-id)
+ (let*-values ([(drivers pre-guide props-guide) (parse-t t 0 #f)]
+ [(drivers pre-guide)
+ (if loc-id
+ (let* ([loc-sm (make-auto-pvar 0 loc-id)]
+ [loc-pvar (pvar loc-sm #f #f)])
+ (values (dset-add drivers loc-pvar)
+ (relocate-guide pre-guide loc-pvar)))
+ (values drivers pre-guide))])
+ (let* ([main-env (dset->env drivers (hash))]
+ [guide (guide-resolve-env pre-guide main-env)])
+ (values guide
+ (index-hash->vector main-env)
+ props-guide))))
+
+ ;; dset->env : (dsetof env-entry) -> hash[env-entry => nat]
+ (define (dset->env drivers init-env)
+ (for/fold ([env init-env])
+ ([pvar (in-list (dset->list drivers))]
+ [n (in-naturals (+ 1 (hash-count init-env)))])
+ (hash-set env pvar n)))
+
+ ;; guide-resolve-env : pre-guide hash[env-entry => nat] -> guide
+ (define (guide-resolve-env g0 main-env)
+ (define (loop g loop-env)
+ (define (get-index x)
+ (let ([loop-index (hash-ref loop-env x #f)])
+ (if loop-index
+ (- loop-index)
+ (hash-ref main-env x))))
+ (match g
+ ['_ '_]
+ [(cons g1 g2)
+ (cons (loop g1 loop-env) (loop g2 loop-env))]
+ [(? pvar? pvar)
+ (if (pvar-check? pvar)
+ (vector 'check (get-index pvar))
+ (get-index pvar))]
+ [(vector 'dots head new-hdrivers/level nesting '#f tail)
+ (let-values ([(sub-loop-env r-uptos)
+ (for/fold ([env (hash)] [r-uptos null])
+ ([new-hdrivers (in-list new-hdrivers/level)])
+ (let ([new-env (dset->env new-hdrivers env)])
+ (values new-env (cons (hash-count new-env) r-uptos))))])
+ (let ([sub-loop-vector (index-hash->vector sub-loop-env get-index)])
+ (vector 'dots
+ (loop head sub-loop-env)
+ sub-loop-vector
+ nesting
+ (reverse r-uptos)
+ (loop tail loop-env))))]
+ [(vector 'app head tail)
+ (vector 'app (loop head loop-env) (loop tail loop-env))]
+ [(vector 'escaped g1)
+ (vector 'escaped (loop g1 loop-env))]
+ [(vector 'orelse g1 g2)
+ (vector 'orelse (loop g1 loop-env) (loop g2 loop-env))]
+ [(vector 'orelse-h g1 g2)
+ (vector 'orelse-h (loop g1 loop-env) (loop g2 loop-env))]
+ [(vector 'metafun mf g1)
+ (vector 'metafun
+ (get-index mf)
+ (loop g1 loop-env))]
+ [(vector 'vector g1)
+ (vector 'vector (loop g1 loop-env))]
+ [(vector 'struct g1)
+ (vector 'struct (loop g1 loop-env))]
+ [(vector 'box g1)
+ (vector 'box (loop (unbox g) loop-env))]
+ [(vector 'copy-props g1 keys)
+ (vector 'copy-props (loop g1 loop-env) keys)]
+ [(vector 'set-props g1 props-alist)
+ (vector 'set-props (loop g1 loop-env) props-alist)]
+ [(vector 'app-opt g1)
+ (vector 'app-opt (loop g1 loop-env))]
+ [(vector 'splice g1)
+ (vector 'splice (loop g1 loop-env))]
+ [(vector 'unsyntax var)
+ (vector 'unsyntax (get-index var))]
+ [(vector 'unsyntax-splicing var)
+ (vector 'unsyntax-splicing (get-index var))]
+ [(vector 'relocate g1 var)
+ (vector 'relocate (loop g1 loop-env) (get-index var))]
+ [else (error 'template "internal error: bad pre-guide: ~e" g)]))
+ (loop g0 '#hash()))
+
+ ;; ----------------------------------------
+
+ ;; relocate-gude : stx guide -> guide
+ (define (relocate-guide g0 loc-pvar)
+ (define (relocate g)
+ (vector 'relocate g loc-pvar))
+ (define (error/no-relocate)
+ (wrong-syntax #f "cannot apply syntax location to template"))
+ (define (loop g)
+ (match g
+ ['_
+ (relocate g)]
+ [(cons g1 g2)
+ (relocate g)]
+ [(? pvar? g)
+ g]
+ [(vector 'dots head new-hdrivers/level nesting '#f tail)
+ ;; Ideally, should error. For perfect backwards compatability,
+ ;; should relocate. But if there are zero iterations, that
+ ;; means we'd relocate tail (which might be bad). Making
+ ;; relocation depend on number of iterations would be
+ ;; complicated. So just ignore.
+ g]
+ [(vector 'escaped g1)
+ (vector 'escaped (loop g1))]
+ [(vector 'vector g1)
+ (relocate g)]
+ [(vector 'struct g1)
+ (relocate g)]
+ [(vector 'box g1)
+ (relocate g)]
+ [(vector 'copy-props g1 keys)
+ (vector 'copy-props (loop g1) keys)]
+ [(vector 'unsyntax var)
+ g]
+ ;; ----
+ [(vector 'app ghead gtail)
+ (match ghead
+ [(vector 'unsyntax-splicing _) g]
+ [_ (error/no-relocate)])]
+ ;; ----
+ [(vector 'orelse g1 g2)
+ (error/no-relocate)]
+ [(vector 'orelse-h g1 g2)
+ (error/no-relocate)]
+ [(vector 'metafun mf g1)
+ (error/no-relocate)]
+ [(vector 'app-opt g1)
+ (error/no-relocate)]
+ [(vector 'splice g1)
+ (error/no-relocate)]
+ [(vector 'unsyntax-splicing var)
+ g]
+ [else (error 'template "internal error: bad guide for relocation: ~e" g0)]))
+ (loop g0))
+
+ ;; ----------------------------------------
+
+ (define (wrap-props stx env-set pre-guide props-guide)
+ (let ([saved-prop-values
+ (if (syntax? stx)
+ (for/fold ([entries null]) ([prop (in-list (props-to-serialize))])
+ (let ([v (syntax-property stx prop)])
+ (if (and v (quotable? v))
+ (cons (cons prop v) entries)
+ entries)))
+ null)]
+ [copy-props
+ (if (syntax? stx)
+ (for/list ([prop (in-list (props-to-transfer))]
+ #:when (syntax-property stx prop))
+ prop)
+ null)])
+ (values env-set
+ (cond [(eq? pre-guide '_)
+ ;; No need to copy props; already on constant
+ '_]
+ [(pair? copy-props)
+ (vector 'copy-props pre-guide copy-props)]
+ [else pre-guide])
+ (if (pair? saved-prop-values)
+ (vector 'set-props props-guide saved-prop-values)
+ props-guide))))
+
+ (define (quotable? v)
+ (or (null? v)
+ (string? v)
+ (bytes? v)
+ (number? v)
+ (boolean? v)
+ (char? v)
+ (keyword? v)
+ (regexp? v)
+ (byte-regexp? v)
+ (and (box? v) (quotable? (unbox v)))
+ (and (symbol? v) (symbol-interned? v))
+ (and (pair? v) (quotable? (car v)) (quotable? (cdr v)))
+ (and (vector? v) (andmap quotable? (vector->list v)))
+ (and (hash? v) (andmap quotable? (hash->list v)))
+ (and (prefab-struct-key v) (andmap quotable? (struct->list v)))))
+
+ (define (cons-guide g1 g2)
+ (if (and (eq? g1 '_) (eq? g2 '_)) '_ (cons g1 g2)))
+
+ (define (list-guide . gs)
+ (foldr cons-guide '_ gs))
+
+ ;; parse-t : stx nat boolean -> (values (dsetof env-entry) pre-guide props-guide)
+ (define (parse-t t depth esc?)
+ (syntax-case t (?? ?@ unsyntax quasitemplate)
+ [id
+ (identifier? #'id)
+ (cond [(or (and (not esc?)
+ (or (free-identifier=? #'id (quote-syntax ...))
+ (free-identifier=? #'id (quote-syntax ??))
+ (free-identifier=? #'id (quote-syntax ?@))))
+ (and (quasi)
+ (or (free-identifier=? #'id (quote-syntax unsyntax))
+ (free-identifier=? #'id (quote-syntax unsyntax-splicing)))))
+ (wrong-syntax #'id "illegal use")]
+ [else
+ (let ([pvar (lookup #'id depth)])
+ (cond [(pvar? pvar)
+ (values (dset pvar) pvar '_)]
+ [(template-metafunction? pvar)
+ (wrong-syntax t "illegal use of syntax metafunction")]
+ [else
+ (wrap-props #'id (dset) '_ '_)]))])]
+ [(mf . template)
+ (and (not esc?)
+ (identifier? #'mf)
+ (template-metafunction? (lookup #'mf #f)))
+ (let-values ([(mf) (lookup #'mf #f)]
+ [(drivers guide props-guide) (parse-t #'template depth esc?)])
+ (values (dset-add drivers mf)
+ (vector 'metafun mf guide)
+ (cons-guide '_ props-guide)))]
+ [(unsyntax t1)
+ (quasi)
+ (let ([qval (quasi)])
+ (cond [(box? qval)
+ (with-syntax ([(tmp) (generate-temporaries #'(unsyntax-expr))])
+ (set-box! qval (cons (cons #'tmp t) (unbox qval)))
+ (let* ([fake-sm (make-auto-pvar 0 #'tmp)]
+ [fake-pvar (pvar fake-sm #f #f)])
+ (values (dset fake-pvar) (vector 'unsyntax fake-pvar) '_)))]
+ [else
+ (parameterize ((quasi (car qval)))
+ (let-values ([(drivers guide props-guide) (parse-t #'t1 depth esc?)])
+ (wrap-props t
+ drivers
+ (list-guide '_ guide)
+ (list-guide '_ props-guide))))]))]
+ [(quasitemplate t1)
+ ;; quasitemplate escapes inner unsyntaxes
+ (quasi)
+ (parameterize ((quasi (list (quasi))))
+ (let-values ([(drivers guide props-guide) (parse-t #'t1 depth esc?)])
+ (wrap-props t
+ drivers
+ (list-guide '_ guide)
+ (list-guide '_ props-guide))))]
+ [(DOTS template)
+ (and (not esc?)
+ (identifier? #'DOTS) (free-identifier=? #'DOTS (quote-syntax ...)))
+ (let-values ([(drivers guide props-guide) (parse-t #'template depth #t)])
+ (values drivers (vector 'escaped guide)
+ (list-guide '_ props-guide)))]
+ [(?? t1 t2)
+ (not esc?)
+ (let-values ([(drivers1 guide1 props-guide1) (parse-t #'t1 depth esc?)]
+ [(drivers2 guide2 props-guide2) (parse-t #'t2 depth esc?)])
+ (values (dset-union drivers1 drivers2)
+ (vector 'orelse guide1 guide2)
+ (list-guide '_ props-guide1 props-guide2)))]
+ [(head DOTS . tail)
+ (and (not esc?)
+ (identifier? #'DOTS) (free-identifier=? #'DOTS (quote-syntax ...)))
+ (let-values ([(nesting tail)
+ (let loop ([nesting 1] [tail #'tail])
+ (syntax-case tail ()
+ [(DOTS . tail)
+ (and (identifier? #'DOTS) (free-identifier=? #'DOTS (quote-syntax ...)))
+ (loop (add1 nesting) #'tail)]
+ [else (values nesting tail)]))])
+ (let-values ([(hdrivers _hsplice? hguide hprops-guide)
+ (parse-h #'head (+ depth nesting) esc?)]
+ [(tdrivers tguide tprops-guide)
+ (parse-t tail depth esc?)])
+ (when (dset-empty? hdrivers)
+ (wrong-syntax #'head "no pattern variables before ellipsis in template"))
+ (when (dset-empty? (dset-filter hdrivers (pvar/dd<=? depth)))
+ ;; FIXME: improve error message?
+ (let ([bad-dots
+ ;; select the nestingth (last) ellipsis as the bad one
+ (stx-car (stx-drop nesting t))])
+ (wrong-syntax bad-dots "too many ellipses in template")))
+ (wrap-props t
+ (dset-union hdrivers tdrivers)
+ ;; pre-guide hdrivers is (listof (setof pvar))
+ ;; set of pvars new to each level
+ (let* ([hdrivers/level
+ (for/list ([i (in-range nesting)])
+ (dset-filter hdrivers (pvar/dd<=? (+ depth i))))]
+ [new-hdrivers/level
+ (let loop ([raw hdrivers/level] [last (dset)])
+ (cond [(null? raw) null]
+ [else
+ (cons (dset-subtract (car raw) last)
+ (loop (cdr raw) (car raw)))]))])
+ (vector 'dots hguide new-hdrivers/level nesting #f tguide))
+ (cons-guide hprops-guide (cons-guide '_ tprops-guide)))))]
+ [(head . tail)
+ (let-values ([(hdrivers hsplice? hguide hprops-guide)
+ (parse-h #'head depth esc?)]
+ [(tdrivers tguide tprops-guide)
+ (parse-t #'tail depth esc?)])
+ (wrap-props t
+ (dset-union hdrivers tdrivers)
+ (cond [(and (eq? hguide '_) (eq? tguide '_)) '_]
+ [hsplice? (vector 'app hguide tguide)]
+ [else (cons hguide tguide)])
+ (cons-guide hprops-guide tprops-guide)))]
+ [vec
+ (vector? (syntax-e #'vec))
+ (let-values ([(drivers guide props-guide)
+ (parse-t (vector->list (syntax-e #'vec)) depth esc?)])
+ (wrap-props t drivers
+ (if (eq? guide '_) '_ (vector 'vector guide))
+ (if (eq? props-guide '_) '_ (vector 'vector props-guide))))]
+ [pstruct
+ (prefab-struct-key (syntax-e #'pstruct))
+ (let-values ([(drivers guide props-guide)
+ (parse-t (cdr (vector->list (struct->vector (syntax-e #'pstruct)))) depth esc?)])
+ (wrap-props t drivers
+ (if (eq? guide '_) '_ (vector 'struct guide))
+ (if (eq? props-guide '_) '_ (vector 'struct props-guide))))]
+ [#&template
+ (let-values ([(drivers guide props-guide)
+ (parse-t #'template depth esc?)])
+ (wrap-props t drivers
+ (if (eq? guide '_) '_ (vector 'box guide))
+ (if (eq? props-guide '_) '_ (vector 'box props-guide))))]
+ [const
+ (wrap-props t (dset) '_ '_)]))
+
+ ;; parse-h : stx nat boolean -> (values (dsetof env-entry) boolean pre-head-guide props-guide)
+ (define (parse-h h depth esc?)
+ (syntax-case h (?? ?@ unsyntax-splicing)
+ [(?? t)
+ (not esc?)
+ (let-values ([(drivers splice? guide props-guide)
+ (parse-h #'t depth esc?)])
+ (values drivers #t
+ (vector 'app-opt guide)
+ (list-guide '_ props-guide)))]
+ [(?? t1 t2)
+ (not esc?)
+ (let-values ([(drivers1 splice?1 guide1 props-guide1) (parse-h #'t1 depth esc?)]
+ [(drivers2 splice?2 guide2 props-guide2) (parse-h #'t2 depth esc?)])
+ (values (dset-union drivers1 drivers2)
+ (or splice?1 splice?2)
+ (vector (if (or splice?1 splice?2) 'orelse-h 'orelse)
+ guide1 guide2)
+ (list-guide '_ props-guide1 props-guide2)))]
+ [(?@ . t)
+ (not esc?)
+ (let-values ([(drivers guide props-guide) (parse-t #'t depth esc?)])
+ (values drivers #t (vector 'splice guide) (cons-guide '_ props-guide)))]
+ [(unsyntax-splicing t1)
+ (quasi)
+ (let ([qval (quasi)])
+ (cond [(box? qval)
+ (with-syntax ([(tmp) (generate-temporaries #'(unsyntax-splicing-expr))])
+ (set-box! qval (cons (cons #'tmp h) (unbox qval)))
+ (let* ([fake-sm (make-auto-pvar 0 #'tmp)]
+ [fake-pvar (pvar fake-sm #f #f)])
+ (values (dset fake-pvar) #t (vector 'unsyntax-splicing fake-pvar) '_)))]
+ [else
+ (parameterize ((quasi (car qval)))
+ (let*-values ([(drivers guide props-guide) (parse-t #'t1 depth esc?)]
+ [(drivers guide props-guide)
+ (wrap-props h
+ drivers
+ (list-guide '_ guide)
+ (list-guide '_ props-guide))])
+ (values drivers #f guide props-guide)))]))]
+ [t
+ (let-values ([(drivers guide props-guide) (parse-t #'t depth esc?)])
+ (values drivers #f guide props-guide))]))
+
+ (define (lookup id depth)
+ (let ([v (syntax-local-value/record id (lambda (v) (or (syntax-pattern-variable? v)
+ (template-metafunction? v))))])
+ (cond [(syntax-pattern-variable? v)
+ (let* ([pvar-depth (syntax-mapping-depth v)]
+ [attr (syntax-local-value (syntax-mapping-valvar v) (lambda () #f))]
+ [attr (and (attribute-mapping? attr) attr)])
+ (cond [(not depth) ;; not looking for pvars, only for metafuns
+ #f]
+ [(zero? pvar-depth)
+ (pvar v attr #f)]
+ [(>= depth pvar-depth)
+ (pvar v attr (- depth pvar-depth))]
+ [else
+ (wrong-syntax id "missing ellipses with pattern variable in template")]))]
+ [(template-metafunction? v)
+ v]
+ [else
+ ;; id is a literal; check that for all x s.t. id = x.y, x is not an attribute
+ (for ([pfx (in-list (dotted-prefixes id))])
+ (let ([pfx-v (syntax-local-value pfx (lambda () #f))])
+ (when (and (syntax-pattern-variable? pfx-v)
+ (let ([valvar (syntax-mapping-valvar pfx-v)])
+ (attribute-mapping? (syntax-local-value valvar (lambda () #f)))))
+ (wrong-syntax id "undefined nested attribute of attribute `~a'" (syntax-e pfx)))))
+ #f])))
+
+ (define (dotted-prefixes id)
+ (let* ([id-string (symbol->string (syntax-e id))]
+ [dot-locations (map car (regexp-match-positions* #rx"\\.[^.]" id-string))])
+ (for/list ([loc (in-list dot-locations)])
+ (datum->syntax id (string->symbol (substring id-string 0 loc))))))
+
+ (define (index-hash->vector hash [f values])
+ (let ([vec (make-vector (hash-count hash))])
+ (for ([(value index) (in-hash hash)])
+ (vector-set! vec (sub1 index) (f value)))
+ vec))
+
+ (define ((pvar/dd<=? expected-dd) x)
+ (match x
+ [(pvar sm attr dd) (and dd (<= dd expected-dd))]
+ [_ #f]))
+
+ (define (pvar-var x)
+ (match x
+ [(pvar sm '#f dd) (syntax-mapping-valvar sm)]
+ [(pvar sm attr dd) (attribute-mapping-var attr)]))
+
+ (define (pvar-check? x)
+ (match x
+ [(pvar sm '#f dd) #f]
+ [(pvar sm attr dd) (not (attribute-mapping-syntax? attr))]))
+
+ (define (stx-drop n x)
+ (cond [(zero? n) x]
+ [else (stx-drop (sub1 n) (stx-cdr x))]))
+ )
diff --git a/parse/pre.rkt-6-11 b/parse/pre.rkt-6-11
new file mode 100644
index 0000000..b9f801e
--- /dev/null
+++ b/parse/pre.rkt-6-11
@@ -0,0 +1,10 @@
+#lang racket/base
+(require "private/sc.rkt"
+ "private/litconv.rkt"
+ "private/lib.rkt")
+(provide (except-out (all-from-out "private/sc.rkt")
+ define-integrable-syntax-class
+ syntax-parser/template
+ parser/rhs)
+ (all-from-out "private/litconv.rkt")
+ (all-from-out "private/lib.rkt"))
diff --git a/parse/private/lib.rkt-6-11 b/parse/private/lib.rkt-6-11
new file mode 100644
index 0000000..647e201
--- /dev/null
+++ b/parse/private/lib.rkt-6-11
@@ -0,0 +1,75 @@
+#lang racket/base
+(require "sc.rkt"
+ syntax/parse/private/keywords
+ (for-syntax racket/base))
+
+(provide identifier
+ boolean
+ str
+ character
+ keyword
+ number
+ integer
+ exact-integer
+ exact-nonnegative-integer
+ exact-positive-integer
+
+ id
+ nat
+ char
+
+ expr
+ static)
+
+
+(define (expr-stx? x)
+ (not (keyword-stx? x)))
+
+(define ((stxof pred?) x) (and (syntax? x) (pred? (syntax-e x))))
+(define keyword-stx? (stxof keyword?))
+(define boolean-stx? (stxof boolean?))
+(define string-stx? (stxof string?))
+(define char-stx? (stxof char?))
+(define number-stx? (stxof number?))
+(define integer-stx? (stxof integer?))
+(define exact-integer-stx? (stxof exact-integer?))
+(define exact-nonnegative-integer-stx? (stxof exact-nonnegative-integer?))
+(define exact-positive-integer-stx? (stxof exact-positive-integer?))
+
+;; == Integrable syntax classes ==
+
+(define-integrable-syntax-class identifier (quote "identifier") identifier?)
+(define-integrable-syntax-class expr (quote "expression") expr-stx?)
+(define-integrable-syntax-class keyword (quote "keyword") keyword-stx?)
+(define-integrable-syntax-class boolean (quote "boolean") boolean-stx?)
+(define-integrable-syntax-class character (quote "character") char-stx?)
+(define-integrable-syntax-class str (quote "string") string-stx?)
+(define-integrable-syntax-class number (quote "number") number-stx?)
+(define-integrable-syntax-class integer (quote "integer") integer-stx?)
+(define-integrable-syntax-class exact-integer (quote "exact-integer") exact-integer-stx?)
+(define-integrable-syntax-class exact-nonnegative-integer
+ (quote "exact-nonnegative-integer")
+ exact-nonnegative-integer-stx?)
+(define-integrable-syntax-class exact-positive-integer
+ (quote "exact-positive-integer")
+ exact-positive-integer-stx?)
+
+;; Aliases
+(define-syntax id (make-rename-transformer #'identifier))
+(define-syntax nat (make-rename-transformer #'exact-nonnegative-integer))
+(define-syntax char (make-rename-transformer #'character))
+
+;; == Normal syntax classes ==
+
+(define notfound (box 'notfound))
+
+(define-syntax-class (static pred [name #f])
+ #:attributes (value)
+ #:description name
+ #:commit
+ (pattern x:id
+ #:fail-unless (syntax-transforming?)
+ "not within the dynamic extent of a macro transformation"
+ #:attr value (syntax-local-value #'x (lambda () notfound))
+ #:fail-when (eq? (attribute value) notfound) #f
+ #:fail-unless (pred (attribute value)) #f))
diff --git a/parse/private/parse-aux.rkt-6-11 b/parse/private/parse-aux.rkt-6-11
new file mode 100644
index 0000000..2c0b2d5
--- /dev/null
+++ b/parse/private/parse-aux.rkt-6-11
@@ -0,0 +1,21 @@
+#lang racket/base
+(require (for-template "parse.rkt"))
+(provide id:define-syntax-class
+ id:define-splicing-syntax-class
+ id:define-integrable-syntax-class
+ id:syntax-parse
+ id:syntax-parser
+ id:define/syntax-parse
+ id:syntax-parser/template
+ id:parser/rhs
+ id:define-eh-alternative-set)
+
+(define (id:define-syntax-class) #'define-syntax-class)
+(define (id:define-splicing-syntax-class) #'define-splicing-syntax-class)
+(define (id:define-integrable-syntax-class) #'define-integrable-syntax-class)
+(define (id:syntax-parse) #'syntax-parse)
+(define (id:syntax-parser) #'syntax-parser)
+(define (id:define/syntax-parse) #'define/syntax-parse)
+(define (id:syntax-parser/template) #'syntax-parser/template)
+(define (id:parser/rhs) #'parser/rhs)
+(define (id:define-eh-alternative-set) #'define-eh-alternative-set)
diff --git a/parse/private/parse.rkt-6-11 b/parse/private/parse.rkt-6-11
new file mode 100644
index 0000000..266d2bb
--- /dev/null
+++ b/parse/private/parse.rkt-6-11
@@ -0,0 +1,1199 @@
+#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/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
+ stxparse-info/parse/private/runtime ;; keep abs.path
+ 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 #f 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)])
+ #`(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 rhss #,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 fh0 cp0 rl success)
+ (if (predicate x)
+ (success fh0)
+ (let ([es (es-add-thing pr 'description #t rl es)])
+ (fh0 (failure* pr es)))))))]))
+
+(define-syntax (parser/rhs stx)
+ (syntax-case stx ()
+ [(parser/rhs name formals relsattrs rhss splicing? ctx)
+ (with-disappeared-uses
+ (let ()
+ (define the-rhs
+ (parameterize ((current-syntax-context #'ctx))
+ (parse-rhs #'rhss (syntax->datum #'relsattrs) (syntax-e #'splicing?)
+ #:context #'ctx)))
+ (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 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])
+ ;; 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)])
+ (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]
+ [(def ...) defs]
+ [expr expr])
+ #'(defattrs/unpack (a ...)
+ (let* ([x (datum->syntax #f expr)]
+ [cx x]
+ [pr (ps-empty x x)]
+ [es #f]
+ [fh0 (syntax-patterns-fail x)])
+ (parameterize ((current-syntax-context x))
+ def ...
+ (#%expression
+ (with ([fail-handler fh0]
+ [cut-prompt fh0])
+ (parse:S x cx pattern pr es
+ (list (attribute name) ...)))))))))))]))
+
+;; ============================================================
+
+#|
+Parsing protocols:
+
+(parse:<X> <X-args> pr es success-expr) : Ans
+
+ <S-args> : x cx
+ <H-args> : x cx rest-x rest-cx rest-pr
+ <EH-args> : x cx ???
+ <A-args> : 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 fail-handler cut-prompt role success-proc arg ...) : Ans
+
+ success-proc:
+ for stxclass, is (fail-handler attr-value ... -> Ans)
+ for splicing-stxclass, is (fail-handler rest-x rest-cx rest-pr attr-value -> Ans)
+ fail-handler, cut-prompt : 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.
+
+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 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-values (decls0 defs)
+ (get-decls+defs chunks #t #: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)]))
+ (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)))
+ (with ([fail-handler fh0]
+ [cut-prompt fh0])
+ #,(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 fail-handler cut-prompt role
+ (lambda (fh av ...)
+ (let-attributes (name-attr ...)
+ (let-attributes* ((nested-a ...) (av ...))
+ (with ([fail-handler fh])
+ k))))
+ argu)
+ ;; The commit protocol
+ ;; (Avoids putting k in procedure)
+ #'(let-values ([(fs av ...)
+ (with ([fail-handler (lambda (fs) (values fs (let ([av #f]) av) ...))])
+ (with ([cut-prompt fail-handler])
+ (app-argu parser x cx pr es fail-handler cut-prompt role
+ (lambda (fh av ...) (values #f av ...))
+ argu)))])
+ (if fs
+ (fail fs)
+ (let-attributes (name-attr ...)
+ (let-attributes* ((nested-a ...) (av ...))
+ 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 fail-handler cut-prompt #f
+ (lambda (fh . result)
+ (let-attributes (name-attr ...)
+ (let/unpack ((nested-a ...) result)
+ (with ([fail-handler fh])
+ 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))
+ 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 id ...)
+ (let-attributes ([a id] ...)
+ (with ([fail-handler fh])
+ 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 (fs) k)])
+ ;; ~not implicitly prompts to be safe,
+ ;; but ~! not allowed within ~not (unless within ~delimit-cut, etc)
+ ;; (statically checked!)
+ (with ([fail-handler fail-to-succeed]
+ [cut-prompt fail-to-succeed]) ;; to be safe
+ (parse:S x cx subpattern pr es
+ (fh0 (failure* pr0 es0)))))]
+ [#s(pat:pair 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 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 ...))
+ #'(let () (no-shadow stmt) ... (#%expression 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 fail-handler cut-prompt role
+ (lambda (fh rest-x rest-cx rest-pr av ...)
+ (let-attributes (name-attr ...)
+ (let-attributes* ((nested-a ...) (av ...))
+ (with ([fail-handler fh])
+ k))))
+ argu)
+ ;; The commit protocol
+ ;; (Avoids putting k in procedure)
+ #'(let-values ([(fs rest-x rest-cx rest-pr av ...)
+ (with ([fail-handler (lambda (fs) (values fs #f #f #f (let ([av #f]) av) ...))])
+ (with ([cut-prompt fail-handler])
+ (app-argu parser x cx pr es fail-handler cut-prompt role
+ (lambda (fh rest-x rest-cx rest-pr av ...)
+ (values #f rest-x rest-cx rest-pr av ...))
+ argu)))])
+ (if fs
+ (fail fs)
+ (let-attributes (name-attr ...)
+ (let-attributes* ((nested-a ...) (av ...))
+ 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 fail-handler cut-prompt #f
+ (lambda (fh rest-x rest-cx rest-pr . result)
+ (let-attributes (name-attr ...)
+ (let/unpack ((nested-a ...) result)
+ (with ([fail-handler fh])
+ 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 rest-x rest-cx rest-pr id ...)
+ (let-attributes ([a id] ...)
+ (with ([fail-handler fh])
+ 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 (fs)
+ (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 (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* fail-handler rel-rep ... alt-id ...))
+ #`(let ()
+ ;; dots-loop : stx progress rel-rep ... alt-id ... -> Ans
+ (define (dots-loop dx dcx loop-pr fh rel-rep ... alt-id ...)
+ (with ([fail-handler fh])
+ (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 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)
+ (with-syntax ([(parser) (generate-temporaries '(eh-alt-parser))])
+ (let ([attrs (iattrs->sattrs (pattern-attrs (ehpat-head ehpat)))])
+ (list (eh-alternative (ehpat-repc ehpat) attrs #'parser)
+ (list #`(define parser
+ (parser/rhs parser () #,attrs
+ [#:description #f (pattern #,hstx)]
+ #t
+ #,stx))))))]
+ [(eh-alternative? hstx)
+ (list hstx null)]
+ [else
+ (error 'define-eh-alternative-set "internal error: unexpected ~e"
+ hstx)])))]
+ [eh-alts (map car eh-alt+defs-list)]
+ [defs (apply append (map cadr eh-alt+defs-list))])
+ (with-syntax ([(def ...) defs]
+ [(alt-expr ...)
+ (for/list ([alt (in-list eh-alts)])
+ (with-syntax ([repc-expr
+ ;; 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-6-11 b/parse/private/rep.rkt-6-11
new file mode 100644
index 0000000..9327159
--- /dev/null
+++ b/parse/private/rep.rkt-6-11
@@ -0,0 +1,1646 @@
+#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/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? (or/c false/c (listof sattr?)) 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? boolean? #: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?))])
+
+;; ----
+
+(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 ~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 ...+)
+ (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))
+
+;; ---
+
+(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 : stx boolean (or #f (listof SAttr)) stx -> RHS
+;; If expected-attrs is true, then referenced stxclasses must be defined and
+;; literals must be bound. Set to #f for pass1 (attr collection);
+;; parser requires stxclasses to be bound.
+(define (parse-rhs stx expected-attrs 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? (and expected-attrs #t)))
+ (define variants
+ (parameterize ((stxclass-lookup-config
+ (cond [expected-attrs 'yes]
+ [auto-nested? 'try]
+ [else 'no]))
+ (stxclass-colon-notation? colon-notation?))
+ (parse-variants rest decls splicing? expected-attrs)))
+ (let ([sattrs
+ (or attributes
+ (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? strict?)
+ (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 strict?))
+ (values rest description transparent? attributes auto-nested? colon-notation?
+ decls defs commit? delimit-cut?))
+
+;; ----
+
+(define (parse-variants rest decls splicing? expected-attrs)
+ (define (gather-variants stx)
+ (syntax-case stx (pattern)
+ [((pattern . _) . rest)
+ (begin (disappeared! (stx-car stx))
+ (cons (parse-variant (stx-car stx) splicing? decls expected-attrs)
+ (gather-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 strict?
+ #:context [ctx (current-syntax-context)])
+ (parameterize ((current-syntax-context ctx))
+ (let*-values ([(decls defs1) (get-decls chunks strict?)]
+ [(decls defs2) (decls-create-defs decls)])
+ (values decls (append defs1 defs2)))))
+
+;; get-decls : chunks -> (values DeclEnv (listof syntax))
+(define (get-decls chunks strict?)
+ (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 class argu)
+ ;; FIXME: integrable syntax classes?
+ ;; FIXME: what if no-arity, no-args?
+ (cond [(identifier? name)
+ (let* ([pos-count (length (arguments-pargs argu))]
+ [kws (arguments-kws argu)]
+ [sc (get-stxclass/check-arity class class pos-count kws)])
+ (with-syntax ([sc-parser (stxclass-parser sc)])
+ (with-syntax ([parser (generate-temporary class)])
+ (values (make den:parser #'parser
+ (stxclass-attrs sc) (stxclass/h? sc)
+ (stxclass-opts sc))
+ (list #`(define-values (parser)
+ (curried-stxclass-parser #,class #,argu)))))))]
+ [(regexp? name)
+ ;; Conventions rule; delay class lookup until module/intdefs pass2
+ ;; to allow forward references
+ (with-syntax ([parser (generate-temporary class)]
+ [description (generate-temporary class)])
+ (values (make den:delayed #'parser class)
+ (list #`(define-values (parser)
+ (curried-stxclass-parser #,class #,argu)))))])]
+ [(? den:parser?)
+ (values entry null)]
+ [(? 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 #f/(listof Sattr) -> RHS
+(define (parse-variant stx splicing? decls0 expected-attrs)
+ (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)])
+ (when expected-attrs
+ (parameterize ((current-syntax-context stx))
+ ;; Called just for error-reporting
+ (reorder-iattrs expected-attrs attrs)))
+ (make variant stx sattrs pattern defs)))]))
+
+;; parse-pattern+sides : stx stx <options> -> (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 ~not ~rest ~describe
+ ~seq ~optional ~! ~bind ~fail ~parse ~do
+ ~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?)]
+ [(~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))]
+ [(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)]
+ [introducer (make-syntax-introducer)]
+ [mstx (introducer (syntax-local-introduce stx))]
+ [mresult (parameterize ([current-syntax-parse-pattern-introducer introducer])
+ (proc mstx))]
+ [result (syntax-local-introduce (introducer mresult))])
+ result))
+
+;; 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 not-shadowed? (make-not-shadowed? decls))
+ (syntax-case* stx (~eh-var ~or ~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 . _)
+ allow-or?
+ (begin
+ (disappeared! stx)
+ (unless (stx-list? stx)
+ (wrong-syntax stx "expected sequence of patterns"))
+ (apply append
+ (for/list ([sub (in-list (cdr (stx->list stx)))])
+ (parse*-ellipsis-head-pattern sub decls allow-or?))))]
+ [(~optional . _)
+ (disappeared! stx)
+ (list (parse*-ehpat/optional stx decls))]
+ [(~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)]))
+
+;; ----
+
+(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")]
+ [else
+ (let-values ([(name suffix) (split-id/get-stxclass id decls)])
+ (cond [(stxclass? suffix)
+ (parse-pat:var/sc id allow-head? name suffix no-arguments "." #f #f)]
+ [(or (den:lit? suffix) (den:datum-lit? suffix))
+ (pat:and
+ (list (pat:svar name)
+ (parse-pat:id/entry id allow-head? suffix)))]
+ [(declenv-apply-conventions decls id)
+ => (lambda (entry) (parse-pat:id/entry id allow-head? entry))]
+ [else (pat:svar name)]))]))
+
+;; 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 class argu role)
+ (let* ([pos-count (length (arguments-pargs argu))]
+ [kws (arguments-kws argu)]
+ [sc (get-stxclass/check-arity class class pos-count kws)])
+ (parse-pat:var/sc id allow-head? id sc argu "." role #f))]
+ [(den:class _n _c _a)
+ (error 'parse-pat:id
+ "(internal error) decls had leftover stxclass entry: ~s"
+ entry)]
+ [(den:parser parser attrs splicing? opts)
+ (check-no-delimit-cut-in-not id (scopts-delimit-cut? opts))
+ (cond [splicing?
+ (unless allow-head?
+ (wrong-syntax id "splicing syntax class not allowed here"))
+ (parse-pat:id/h id parser no-arguments attrs "." #f opts)]
+ [else
+ (parse-pat:id/s id parser no-arguments attrs "." #f opts)])]
+ [(den:delayed parser class)
+ (let ([sc (get-stxclass class)])
+ (parse-pat:var/sc id allow-head? id sc 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
+ (let ([sc (get-stxclass/check-arity scname sc+args-stx
+ (length (arguments-pargs argu))
+ (arguments-kws argu))])
+ (parse-pat:var/sc stx allow-head? name0 sc argu pfx role #f))]
+ [else ;; Just proper name
+ (pat:svar name0)]))
+
+(define (parse-pat:var/sc 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)))
+ (cond [(and (stxclass/s? sc)
+ (stxclass-inline sc)
+ (equal? argu no-arguments))
+ (parse-pat:id/s/integrate name (stxclass-inline sc) (scopts-desc (stxclass-opts sc)) role)]
+ [(stxclass/s? sc)
+ (parse-pat:id/s name
+ (or parser* (stxclass-parser sc))
+ argu
+ (stxclass-attrs sc)
+ pfx
+ role
+ (stxclass-opts sc))]
+ [(stxclass/h? sc)
+ (unless allow-head?
+ (wrong-syntax stx "splicing syntax class not allowed here"))
+ (parse-pat:id/h name
+ (or parser* (stxclass-parser sc))
+ argu
+ (stxclass-attrs sc)
+ pfx
+ role
+ (stxclass-opts sc))]))
+
+(define (parse-pat:id/s name parser argu attrs pfx role opts)
+ (define prefix (name->prefix name pfx))
+ (define bind (name->bind name))
+ (pat:var/p bind parser argu (id-pattern-attrs attrs prefix) role opts))
+
+(define (parse-pat:id/s/integrate name predicate description role)
+ (define bind (name->bind name))
+ (pat:integrated bind predicate description role))
+
+(define (parse-pat:id/h name parser argu attrs pfx role opts)
+ (define prefix (name->prefix name pfx))
+ (define bind (name->bind name))
+ (hpat:var/p bind parser argu (id-pattern-attrs attrs prefix) 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))
+
+;; ----
+
+(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 (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 (parse-pat:and stx decls allow-head? allow-action?)
+ ;; allow-action? = allowed to *return* pure action pattern;
+ ;; all ~and patterns are allowed to *contain* action patterns
+ (define patterns0 (parse-cdr-patterns stx decls allow-head? #t))
+ (define patterns1 (ord-and-patterns patterns0 (gensym*)))
+ (define-values (actions patterns) (split-prefix patterns1 action-pattern?))
+ (cond [(null? patterns)
+ (cond [allow-action?
+ (action:and actions)]
+ [allow-head?
+ (wrong-syntax stx "expected at least one head pattern")]
+ [else
+ (wrong-syntax stx "expected at least one single-term pattern")])]
+ [else
+ (let ([p (parse-pat:and* stx patterns)])
+ (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:and* stx patterns)
+ ;; patterns is non-empty (empty case handled above)
+ (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 (stx->list (stx-cdr stx)))])
+ (unless (or (action-pattern? pattern) (head-pattern? pattern))
+ (wrong-syntax
+ pattern-stx
+ "single-term pattern not allowed after head pattern")))
+ (let ([p0 (car patterns)]
+ [lps (map 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 (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 now 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: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)))]))
+
+;; -----
+
+;; parse-pattern-directives : stxs(PatternDirective) <kw-args>
+;; -> 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))]
+ ['()
+ '()]))
+
+;; 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<?)
+ (sort (hash-map kw-h (lambda (k v) k))
+ keyword<?)))
+ (loop formals)))
+
+;; parse-formal : stx -> (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)
+ 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)))
+
+;; 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-6-11 b/parse/private/residual.rkt-6-11
new file mode 100644
index 0000000..beafc67
--- /dev/null
+++ b/parse/private/residual.rkt-6-11
@@ -0,0 +1,311 @@
+#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)))
+
+(begin-for-syntax
+ ;; == from runtime.rkt
+
+ (provide make-attribute-mapping
+ attribute-mapping?
+ attribute-mapping-var
+ attribute-mapping-name
+ attribute-mapping-depth
+ attribute-mapping-syntax?)
+
+ (require (only-in (for-template syntax/parse/private/residual)
+ make-attribute-mapping
+ attribute-mapping?
+ attribute-mapping-var
+ attribute-mapping-name
+ attribute-mapping-depth
+ attribute-mapping-syntax?))
+ #;(define-struct attribute-mapping (var name depth syntax?)
+ #:omit-define-syntaxes
+ #:property prop:procedure
+ (lambda (self stx)
+ (if (attribute-mapping-syntax? self)
+ #`(#%expression #,(attribute-mapping-var self))
+ (let ([source-name
+ (or (let loop ([p (syntax-property stx 'disappeared-use)])
+ (cond [(identifier? p) p]
+ [(pair? p) (or (loop (car p)) (loop (cdr p)))]
+ [else #f]))
+ (attribute-mapping-name self))])
+ #`(let ([value #,(attribute-mapping-var self)])
+ (if (syntax-list^depth? '#,(attribute-mapping-depth self) value)
+ value
+ (check/force-syntax-list^depth '#,(attribute-mapping-depth self)
+ value
+ (quote-syntax #,source-name))))))))
+ )
+
+;; ============================================================
+;; 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
+ stx-list-take
+ stx-list-drop/cx
+ datum->syntax/with-clause
+ check/force-syntax-list^depth
+ 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)
+ (attribute-mapping-syntax? value)))
+ #'(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/force-syntax-list^depth : nat any id -> (listof^depth syntax)
+;; Checks that value is (listof^depth syntax); forces promises.
+;; Slow path for attribute-mapping code, assumes value is not syntax-list^depth? already.
+(define (check/force-syntax-list^depth depth value0 source-id)
+ (define (bad sub-depth sub-value)
+ (attribute-not-syntax-error depth value0 source-id sub-depth sub-value))
+ (define (loop depth value)
+ (cond [(promise? value)
+ (loop depth (force value))]
+ [(zero? depth)
+ (if (syntax? value) value (bad depth value))]
+ [else (loop-list depth value)]))
+ (define (loop-list depth value)
+ (cond [(promise? value)
+ (loop-list depth (force value))]
+ [(pair? value)
+ (let ([new-car (loop (sub1 depth) (car value))]
+ [new-cdr (loop-list depth (cdr value))])
+ ;; Don't copy unless necessary
+ (if (and (eq? new-car (car value))
+ (eq? new-cdr (cdr value)))
+ value
+ (cons new-car new-cdr)))]
+ [(null? value)
+ null]
+ [else
+ (bad depth value)]))
+ (loop depth value0))
+
+(define (attribute-not-syntax-error depth0 value0 source-id sub-depth sub-value)
+ (raise-syntax-error #f
+ (format (string-append "bad attribute value for syntax template"
+ "\n attribute value: ~e"
+ "\n expected for attribute: ~a"
+ "\n sub-value: ~e"
+ "\n expected for sub-value: ~a")
+ value0
+ (describe-depth depth0)
+ sub-value
+ (describe-depth sub-depth))
+ source-id))
+
+(define (describe-depth depth)
+ (cond [(zero? depth) "syntax"]
+ [else (format "list of depth ~s of syntax" depth)]))
+
+;; syntax-list^depth? : nat any -> boolean
+;; Returns true iff value is (listof^depth syntax).
+(define (syntax-list^depth? depth value)
+ (if (zero? depth)
+ (syntax? value)
+ (and (list? value)
+ (for/and ([part (in-list value)])
+ (syntax-list^depth? (sub1 depth) part)))))
+
+;; 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 ctx fs)])
+
+;; syntax-patterns-fail : (list Symbol/#f Syntax) -> FailureSet -> (escapes)
+(define ((syntax-patterns-fail ctx) fs)
+ (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)))])))))
diff --git a/parse/private/runtime-reflect.rkt-6-11 b/parse/private/runtime-reflect.rkt-6-11
new file mode 100644
index 0000000..d561684
--- /dev/null
+++ b/parse/private/runtime-reflect.rkt-6-11
@@ -0,0 +1,97 @@
+#lang racket/base
+(require stxparse-info/parse/private/residual ;; keep abs. path
+ (only-in syntax/parse/private/residual-ct ;; keep abs. path
+ attr-name attr-depth)
+ syntax/parse/private/kws)
+(provide reflect-parser
+ (struct-out reified)
+ (struct-out reified-syntax-class)
+ (struct-out reified-splicing-syntax-class))
+
+#|
+A Reified is
+ (reified symbol ParserFunction nat (listof (list symbol nat)))
+|#
+(require (only-in syntax/parse/private/runtime-reflect
+ reified
+ reified?
+ reified-parser
+ reified-arity
+ reified-signature
+ make-reified
+ struct:reified
+
+ reified-syntax-class
+ reified-syntax-class?
+ make-reified-syntax-class
+ struct:reified-syntax-class
+
+ reified-splicing-syntax-class
+ reified-splicing-syntax-class?
+ make-reified-splicing-syntax-class
+ struct:reified-splicing-syntax-class))
+#;(define-struct reified-base (name) #:transparent)
+#;(define-struct (reified reified-base) (parser arity signature))
+#;(define-struct (reified-syntax-class reified) ())
+#;(define-struct (reified-splicing-syntax-class reified) ())
+
+(define (reflect-parser obj e-arity e-attrs splicing?)
+ ;; e-arity represents single call; min and max are same
+ (define who (if splicing? 'reflect-splicing-syntax-class 'reflect-syntax-class))
+ (if splicing?
+ (unless (reified-splicing-syntax-class? obj)
+ (raise-type-error who "reified splicing-syntax-class" obj))
+ (unless (reified-syntax-class? obj)
+ (raise-type-error who "reified syntax-class" obj)))
+ (check-params who e-arity (reified-arity obj) obj)
+ (adapt-parser who
+ (for/list ([a (in-list e-attrs)])
+ (list (attr-name a) (attr-depth a)))
+ (reified-signature obj)
+ (reified-parser obj)
+ splicing?))
+
+(define (check-params who e-arity r-arity obj)
+ (let ([e-pos (arity-minpos e-arity)]
+ [e-kws (arity-minkws e-arity)])
+ (check-arity r-arity e-pos e-kws (lambda (msg) (error who "~a" msg)))))
+
+(define (adapt-parser who esig0 rsig0 parser splicing?)
+ (if (equal? esig0 rsig0)
+ parser
+ (let ([indexes
+ (let loop ([esig esig0] [rsig rsig0] [index 0])
+ (cond [(null? esig)
+ null]
+ [(and (pair? rsig) (eq? (caar esig) (caar rsig)))
+ (unless (= (cadar esig) (cadar rsig))
+ (wrong-depth who (car esig) (car rsig)))
+ (cons index (loop (cdr esig) (cdr rsig) (add1 index)))]
+ [(and (pair? rsig)
+ (string>? (symbol->string (caar esig))
+ (symbol->string (caar rsig))))
+ (loop esig (cdr rsig) (add1 index))]
+ [else
+ (error who "reified syntax-class is missing declared attribute `~s'"
+ (caar esig))]))])
+ (define (take-indexes result indexes)
+ (let loop ([result result] [indexes indexes] [i 0])
+ (cond [(null? indexes) null]
+ [(= (car indexes) i)
+ (cons (car result) (loop (cdr result) (cdr indexes) (add1 i)))]
+ [else
+ (loop (cdr result) indexes (add1 i))])))
+ (make-keyword-procedure
+ (lambda (kws kwargs x cx pr es fh cp rl success . rest)
+ (keyword-apply parser kws kwargs x cx pr es fh cp rl
+ (if splicing?
+ (lambda (fh x cx pr . result)
+ (apply success fh x cx pr (take-indexes result indexes)))
+ (lambda (fh . result)
+ (apply success fh (take-indexes result indexes))))
+ rest))))))
+
+(define (wrong-depth who a b)
+ (error who
+ "reified syntax-class has wrong depth for attribute `~s'; expected ~s, got ~s instead"
+ (car a) (cadr a) (cadr b)))
diff --git a/parse/private/runtime-report.rkt-6-11 b/parse/private/runtime-report.rkt-6-11
new file mode 100644
index 0000000..87429ae
--- /dev/null
+++ b/parse/private/runtime-report.rkt-6-11
@@ -0,0 +1,784 @@
+#lang racket/base
+(require racket/list
+ racket/format
+ syntax/stx
+ racket/struct
+ syntax/srcloc
+ syntax/parse/private/minimatch
+ stxparse-info/parse/private/residual
+ syntax/parse/private/kws)
+(provide call-current-failure-handler
+ current-failure-handler
+ invert-failure
+ maximal-failures
+ invert-ps
+ ps->stx+index)
+
+#|
+TODO: given (expect:thing _ D _ R) and (expect:thing _ D _ #f),
+ simplify to (expect:thing _ D _ #f)
+ thus, "expected D" rather than "expected D or D for R" (?)
+|#
+
+#|
+Note: there is a cyclic dependence between residual.rkt and this module,
+broken by a lazy-require of this module into residual.rkt
+|#
+
+(define (call-current-failure-handler ctx fs)
+ (call-with-values (lambda () ((current-failure-handler) ctx fs))
+ (lambda vals
+ (error 'current-failure-handler
+ "current-failure-handler: did not escape, produced ~e"
+ (case (length vals)
+ ((1) (car vals))
+ (else (cons 'values vals)))))))
+
+(define (default-failure-handler ctx fs)
+ (handle-failureset ctx fs))
+
+(define current-failure-handler
+ (make-parameter default-failure-handler))
+
+
+;; ============================================================
+;; Processing failure sets
+
+#|
+We use progress to select the maximal failures and determine the syntax
+they're complaining about. After that, we no longer care about progress.
+
+Old versions of syntax-parse (through 6.4) grouped failures into
+progress-equivalence-classes and generated reports by class, but only showed
+one report. New syntax-parse just mixes all maximal failures together and
+deals with the fact that they might not be talking about the same terms.
+|#
+
+;; handle-failureset : (list Symbol/#f Syntax) FailureSet -> escapes
+(define (handle-failureset ctx fs)
+ (define inverted-fs (map invert-failure (reverse (flatten fs))))
+ (define maximal-classes (maximal-failures inverted-fs))
+ (define ess (map failure-expectstack (append* maximal-classes)))
+ (define report (report/sync-shared ess))
+ ;; Hack: alternative to new (primitive) phase-crossing exn type is to store
+ ;; extra information in exn continuation marks. Currently for debugging only.
+ (with-continuation-mark 'syntax-parse-error
+ (hasheq 'raw-failures fs
+ 'maximal maximal-classes)
+ (error/report ctx report)))
+
+;; An RFailure is (failure IPS RExpectList)
+
+;; invert-failure : Failure -> RFailure
+(define (invert-failure f)
+ (match f
+ [(failure ps es)
+ (failure (invert-ps ps) (invert-expectstack es (ps->stx+index ps)))]))
+
+;; A Report is (report String (Listof String) Syntax/#f Syntax/#f)
+(define-struct report (message context stx within-stx) #:prefab)
+
+
+;; ============================================================
+;; Progress
+
+;; maximal-failures : (listof InvFailure) -> (listof (listof InvFailure))
+(define (maximal-failures fs)
+ (maximal/progress
+ (for/list ([f (in-list fs)])
+ (cons (failure-progress f) f))))
+
+#|
+Progress ordering
+-----------------
+
+Nearly a lexicographic generalization of partial order on frames.
+ (( CAR < CDR ) || stx ) < POST )
+ - stx incomparable except with self
+
+But ORD prefixes are sorted out (and discarded) before comparison with
+rest of progress. Like post, ord comparable only w/in same group:
+ - (ord g n1) < (ord g n2) if n1 < n2
+ - (ord g1 n1) || (ord g2 n2) when g1 != g2
+
+
+Progress equality
+-----------------
+
+If ps1 = ps2 then both must "blame" the same term,
+ie (ps->stx+index ps1) = (ps->stx+index ps2).
+|#
+
+;; An Inverted PS (IPS) is a PS inverted for easy comparison.
+;; An IPS may not contain any 'opaque frames.
+
+;; invert-ps : PS -> IPS
+;; Reverse and truncate at earliest 'opaque frame.
+(define (invert-ps ps)
+ (reverse (ps-truncate-opaque ps)))
+
+;; ps-truncate-opaque : PS -> PS
+;; Returns maximal tail with no 'opaque frame.
+(define (ps-truncate-opaque ps)
+ (let loop ([ps ps] [acc ps])
+ ;; acc is the biggest tail that has not been seen to contain 'opaque
+ (cond [(null? ps) acc]
+ [(eq? (car ps) 'opaque)
+ (loop (cdr ps) (cdr ps))]
+ [else (loop (cdr ps) acc)])))
+
+;; maximal/progress : (listof (cons IPS A)) -> (listof (listof A))
+;; Eliminates As with non-maximal progress, then groups As into
+;; equivalence classes according to progress.
+(define (maximal/progress items)
+ (cond [(null? items)
+ null]
+ [(null? (cdr items))
+ (list (list (cdr (car items))))]
+ [else
+ (let loop ([items items] [non-ORD-items null])
+ (define-values (ORD non-ORD)
+ (partition (lambda (item) (ord? (item-first-prf item))) items))
+ (cond [(pair? ORD)
+ (loop (maximal-prf1/ord ORD) (append non-ORD non-ORD-items))]
+ [else
+ (maximal/prf1 (append non-ORD non-ORD-items))]))]))
+
+;; maximal/prf1 : (Listof (Cons IPS A) -> (Listof (Listof A))
+(define (maximal/prf1 items)
+ (define-values (POST rest1)
+ (partition (lambda (item) (eq? 'post (item-first-prf item))) items))
+ (cond [(pair? POST)
+ (maximal/progress (map item-pop-prf POST))]
+ [else
+ (define-values (STX rest2)
+ (partition (lambda (item) (syntax? (item-first-prf item))) rest1))
+ (define-values (CDR rest3)
+ (partition (lambda (item) (exact-integer? (item-first-prf item))) rest2))
+ (define-values (CAR rest4)
+ (partition (lambda (item) (eq? 'car (item-first-prf item))) rest3))
+ (define-values (NULL rest5)
+ (partition (lambda (item) (eq? '#f (item-first-prf item))) rest4))
+ (unless (null? rest5)
+ (error 'syntax-parse "INTERNAL ERROR: bad progress: ~e\n" rest5))
+ (cond [(pair? CDR)
+ (define leastCDR (apply min (map item-first-prf CDR)))
+ (append
+ (maximal/stx STX)
+ (maximal/progress (map (lambda (item) (item-pop-prf-ncdrs item leastCDR)) CDR)))]
+ [(pair? CAR)
+ (append
+ (maximal/stx STX)
+ (maximal/progress (map item-pop-prf CAR)))]
+ [(pair? STX)
+ (maximal/stx STX)]
+ [(pair? NULL)
+ (list (map cdr NULL))]
+ [else null])]))
+
+;; maximal-prf1/ord : (NEListof (Cons IPS A)) -> (NEListof (Cons IPS A))
+;; PRE: each item has ORD first frame
+;; Keep only maximal by first frame and pop first frame from each item.
+(define (maximal-prf1/ord items)
+ ;; groups : (NEListof (NEListof (cons A IPS)))
+ (define groups (group-by (lambda (item) (ord-group (item-first-prf item))) items))
+ (append*
+ (for/list ([group (in-list groups)])
+ (define group* (filter-max group (lambda (item) (ord-index (item-first-prf item)))))
+ (map item-pop-prf group*))))
+
+;; maximal/stx : (NEListof (cons IPS A)) -> (NEListof (NEListof A))
+;; PRE: Each IPS starts with a stx frame.
+(define (maximal/stx items)
+ ;; groups : (Listof (Listof (cons IPS A)))
+ (define groups (group-by item-first-prf items))
+ (append*
+ (for/list ([group (in-list groups)])
+ (maximal/progress (map item-pop-prf group)))))
+
+;; filter-max : (Listof X) (X -> Nat) -> (Listof X)
+(define (filter-max xs x->nat)
+ (let loop ([xs xs] [nmax -inf.0] [r-keep null])
+ (cond [(null? xs)
+ (reverse r-keep)]
+ [else
+ (define n0 (x->nat (car xs)))
+ (cond [(> n0 nmax)
+ (loop (cdr xs) n0 (list (car xs)))]
+ [(= n0 nmax)
+ (loop (cdr xs) nmax (cons (car xs) r-keep))]
+ [else
+ (loop (cdr xs) nmax r-keep)])])))
+
+;; item-first-prf : (cons IPS A) -> prframe/#f
+(define (item-first-prf item)
+ (define ips (car item))
+ (and (pair? ips) (car ips)))
+
+;; item-split-ord : (cons IPS A) -> (cons IPS (cons IPS A))
+(define (item-split-ord item)
+ (define ips (car item))
+ (define a (cdr item))
+ (define-values (rest-ips r-ord)
+ (let loop ([ips ips] [r-ord null])
+ (cond [(and (pair? ips) (ord? (car ips)))
+ (loop (cdr ips) (cons (car ips) r-ord))]
+ [else (values ips r-ord)])))
+ (list* (reverse r-ord) rest-ips a))
+
+;; item-pop-prf : (cons IPS A) -> (cons IPS A)
+(define (item-pop-prf item)
+ (let ([ips (car item)]
+ [a (cdr item)])
+ (cons (cdr ips) a)))
+
+;; item-pop-prf-ncdrs : (cons IPS A) -> (cons IPS A)
+;; Assumes first frame is nat > ncdrs.
+(define (item-pop-prf-ncdrs item ncdrs)
+ (let ([ips (car item)]
+ [a (cdr item)])
+ (cond [(= (car ips) ncdrs) (cons (cdr ips) a)]
+ [else (cons (cons (- (car ips) ncdrs) (cdr ips)) a)])))
+
+;; ps->stx+index : Progress -> (cons Syntax Nat)
+;; Gets the innermost stx that should have a real srcloc, and the offset
+;; (number of cdrs) within that where the progress ends.
+(define (ps->stx+index ps)
+ (define (interp ps)
+ (match ps
+ [(cons (? syntax? stx) _) stx]
+ [(cons 'car parent)
+ (let* ([d (interp parent)]
+ [d (if (syntax? d) (syntax-e d) d)])
+ (cond [(pair? d) (car d)]
+ [(vector? d) (vector->list d)]
+ [(box? d) (unbox d)]
+ [(prefab-struct-key d) (struct->list d)]
+ [else (error 'ps->stx+index "INTERNAL ERROR: unexpected: ~e" d)]))]
+ [(cons (? exact-positive-integer? n) parent)
+ (for/fold ([stx (interp parent)]) ([i (in-range n)])
+ (stx-cdr stx))]
+ [(cons (? ord?) parent)
+ (interp parent)]
+ [(cons 'post parent)
+ (interp parent)]))
+ (let ([ps (ps-truncate-opaque ps)])
+ (match ps
+ [(cons (? syntax? stx) _)
+ (cons stx 0)]
+ [(cons 'car parent)
+ (cons (interp ps) 0)]
+ [(cons (? exact-positive-integer? n) parent)
+ (cons (interp parent) n)]
+ [(cons (? ord?) parent)
+ (ps->stx+index parent)]
+ [(cons 'post parent)
+ (ps->stx+index parent)])))
+
+
+;; ============================================================
+;; Expectation simplification
+
+;; normalize-expectstack : ExpectStack StxIdx -> ExpectList
+;; Converts to list, converts expect:thing term rep, and truncates
+;; expectstack after opaque (ie, transparent=#f) frames.
+(define (normalize-expectstack es stx+index [truncate-opaque? #t])
+ (reverse (invert-expectstack es stx+index truncate-opaque?)))
+
+;; invert-expectstack : ExpectStack StxIdx -> RExpectList
+;; Converts to reversed list, converts expect:thing term rep,
+;; and truncates expectstack after opaque (ie, transparent=#f) frames.
+(define (invert-expectstack es stx+index [truncate-opaque? #t])
+ (let loop ([es es] [acc null])
+ (match es
+ ['#f acc]
+ ['#t acc]
+ [(expect:thing ps desc tr? role rest-es)
+ (cond [(and truncate-opaque? (not tr?))
+ (loop rest-es (cons (expect:thing #f desc #t role (ps->stx+index ps)) null))]
+ [else
+ (loop rest-es (cons (expect:thing #f desc tr? role (ps->stx+index ps)) acc))])]
+ [(expect:message message rest-es)
+ (loop rest-es (cons (expect:message message stx+index) acc))]
+ [(expect:atom atom rest-es)
+ (loop rest-es (cons (expect:atom atom stx+index) acc))]
+ [(expect:literal literal rest-es)
+ (loop rest-es (cons (expect:literal literal stx+index) acc))]
+ [(expect:proper-pair first-desc rest-es)
+ (loop rest-es (cons (expect:proper-pair first-desc stx+index) acc))])))
+
+;; expect->stxidx : Expect -> StxIdx
+(define (expect->stxidx e)
+ (cond [(expect:thing? e) (expect:thing-next e)]
+ [(expect:message? e) (expect:message-next e)]
+ [(expect:atom? e) (expect:atom-next e)]
+ [(expect:literal? e) (expect:literal-next e)]
+ [(expect:proper-pair? e) (expect:proper-pair-next e)]
+ [(expect:disj? e) (expect:disj-next e)]))
+
+#| Simplification
+
+A list of ExpectLists represents a tree, with shared tails meaning shared
+branches of the tree. We need a "reasonable" way to simplify it to a list to
+show to the user. Here we develop "reasonable" by example. (It would be nice,
+of course, to also have some way of exploring the full failure trees.)
+
+Notation: [A B X] means an ExpectList with class/description A at root and X
+at leaf. If the term sequences differ, write [t1:A ...] etc.
+
+Options:
+ (o) = "old behavior (through 6.4)"
+ (f) = "first divergence"
+ (s) = "sync on shared"
+
+Case 1: [A B X], [A B Y]
+
+ This is nearly the ideal situation: report as
+
+ expected X or Y, while parsing B, while parsing A
+
+Case 2: [A X], [A]
+
+ For example, matching #'1 as (~describe A (x:id ...)) yields [A], [A '()],
+ but we don't want to see "expected ()".
+
+ So simplify to [A]---that is, drop X.
+
+But there are other cases that are more problematic.
+
+Case 3: [t1:A t2:B t3:X], [t1:A t2:C t3:Y]
+
+ Could report as:
+ (o) expected X for t3, while parsing t2 as B, while parsing t1 as A (also other errors)
+ (f) expected B or C for t2, while parsing t1 as A
+ (x) expected X or Y for t3, while parsing t2 as B or C, while parsing t1 as A
+
+ (o) is not good
+ (b) loses the most specific error information
+ (x) implies spurious contexts (eg, X while parsing C)
+
+ I like (b) best for this situation, but ...
+
+Case 4: [t1:A t2:B t4:X], [t1:A t3:C t4:Y]
+
+ Could report as:
+ (f') expected B or C, while parsing t1 as A
+ (s) expected X or Y for t4, while ..., while parsing t1 as A
+ (f) expected A for t1
+
+ (f') is problematic, since terms are different!
+ (s) okay, but nothing good to put in that ... space
+ (f) loses a lot of information
+
+Case 5: [t1:A t2:B t3:X], [t1:A t4:C t5:Y]
+
+ Only feasible choice (no other sync points):
+ (f,s) expected A for t1
+
+Case 6: [t1:A _ t2:B t3:X], [t1:A _ t2:C t3:Y]
+
+ Could report as:
+ (s') expected X or Y for t3, while parsing t2 as B or C, while ..., while parsing t1 as A
+ (s) expected X or Y for t3, while ..., while parsing t1 as A
+
+ (s') again implies spurious contexts, bad
+ (s) okay
+
+Case 7: [_ t2:B t3:C _], [_ t3:C t2:B _]
+
+ Same frames show up in different orders. (Can this really happen? Probably,
+ with very weird uses of ~parse.)
+
+--
+
+This suggests the following new algorithm based on (s):
+- Step 1: emit an intermediate "unified" expectstack (extended with "..." markers)
+ - make a list (in order) of frames shared by all expectstacks
+ - emit those frames with "..." markers if (sometimes) unshared stuff between
+ - continue processing with the tails after the last shared frame:
+ - find the last term shared by all expectstacks (if any)
+ - find the last frame for that term for each expectstack
+ - combine in expect:disj and emit
+- Step 2:
+ - remove trailing and collapse adjacent "..." markers
+
+|#
+
+;; report* : (NEListof RExpectList) ((NEListof (NEListof RExpectList)) -> ExpectList)
+;; -> Report
+(define (report* ess handle-divergence)
+ (define es ;; ExpectList
+ (let loop ([ess ess] [acc null])
+ (cond [(ormap null? ess) acc]
+ [else
+ (define groups (group-by car ess))
+ (cond [(singleton? groups)
+ (define group (car groups))
+ (define frame (car (car group)))
+ (loop (map cdr group) (cons frame acc))]
+ [else ;; found point of divergence
+ (append (handle-divergence groups) acc)])])))
+ (define stx+index (if (pair? es) (expect->stxidx (car es)) (cons #f 0)))
+ (report/expectstack (clean-up es) (car stx+index) (cdr stx+index)))
+
+;; clean-up : ExpectList -> ExpectList
+;; Remove leading and collapse adjacent '... markers
+(define (clean-up es)
+ (if (and (pair? es) (eq? (car es) '...))
+ (clean-up (cdr es))
+ (let loop ([es es])
+ (cond [(null? es) null]
+ [(eq? (car es) '...)
+ (cons '... (clean-up es))]
+ [else (cons (car es) (loop (cdr es)))]))))
+
+;; --
+
+;; report/first-divergence : (NEListof RExpectList) -> Report
+;; Generate a single report, using frames from root to first divergence.
+(define (report/first-divergence ess)
+ (report* ess handle-divergence/first))
+
+;; handle-divergence/first : (NEListof (NEListof RExpectList)) -> ExpectList
+(define (handle-divergence/first ess-groups)
+ (define representative-ess (map car ess-groups))
+ (define first-frames (map car representative-ess))
+ ;; Do all of the first frames talk about the same term?
+ (cond [(all-equal? (map expect->stxidx first-frames))
+ (list (expect:disj first-frames #f))]
+ [else null]))
+
+;; --
+
+;; report/sync-shared : (NEListof RExpectList) -> Report
+;; Generate a single report, syncing on shared frames (and later, terms).
+(define (report/sync-shared ess)
+ (report* ess handle-divergence/sync-shared))
+
+;; handle-divergence/sync-shared : (NEListof (NEListof RExpectList)) -> ExpectList
+(define (handle-divergence/sync-shared ess-groups)
+ (define ess (append* ess-groups)) ;; (NEListof RExpectList)
+ (define shared-frames (get-shared ess values))
+ ;; rsegs : (NEListof (Rev2n+1-Listof RExpectList))
+ (define rsegs (for/list ([es (in-list ess)]) (rsplit es values shared-frames)))
+ (define final-seg (map car rsegs)) ;; (NEListof RExpectList), no common frames
+ (define ctx-rsegs (transpose (map cdr rsegs))) ;; (Rev2n-Listof (NEListof RExpectList))
+ (append (hd/sync-shared/final final-seg)
+ (hd/sync-shared/ctx ctx-rsegs)))
+
+;; hd/sync-shared/final : (NEListof RExpectList) -> ExpectList
+;; PRE: ess has no shared frames, but may have shared terms.
+(define (hd/sync-shared/final ess0)
+ (define ess (remove-extensions ess0))
+ (define shared-terms (get-shared ess expect->stxidx))
+ (cond [(null? shared-terms) null]
+ [else
+ ;; split at the last shared term
+ (define rsegs ;; (NEListof (3-Listof RExpectList))
+ (for/list ([es (in-list ess)])
+ (rsplit es expect->stxidx (list (last shared-terms)))))
+ ;; only care about the got segment and pre, not post
+ (define last-term-ess ;; (NEListof RExpectList)
+ (map cadr rsegs))
+ (define pre-term-ess ;; (NEListof RExpectList)
+ (map caddr rsegs))
+ ;; last is most specific
+ (append
+ (list (expect:disj (remove-duplicates (reverse (map last last-term-ess)))
+ (last shared-terms)))
+ (if (ormap pair? pre-term-ess) '(...) '()))]))
+
+;; hd/sync-shared/ctx : (Rev2n-Listof (NEListof RExpectList)) -> ExpectList
+;; In [gotN preN ... got1 pre1] order, where 1 is root-most, N is leaf-most.
+;; We want leaf-most-first, so just process naturally.
+(define (hd/sync-shared/ctx rsegs)
+ (let loop ([rsegs rsegs])
+ (cond [(null? rsegs) null]
+ [(null? (cdr rsegs)) (error 'syntax-parse "INTERNAL ERROR: bad segments")]
+ [else (append
+ ;; shared frame: possible for duplicate ctx frames, but unlikely
+ (let ([ess (car rsegs)]) (list (car (car ess))))
+ ;; inter frames:
+ (let ([ess (cadr rsegs)]) (if (ormap pair? ess) '(...) '()))
+ ;; recur
+ (loop (cddr rsegs)))])))
+
+;; transpose : (Listof (Listof X)) -> (Listof (Listof X))
+(define (transpose xss)
+ (cond [(ormap null? xss) null]
+ [else (cons (map car xss) (transpose (map cdr xss)))]))
+
+;; get-shared : (Listof (Listof X)) (X -> Y) -> (Listof Y)
+;; Return a list of Ys s.t. occur in order in (map of) each xs in xss.
+(define (get-shared xss get-y)
+ (cond [(null? xss) null]
+ [else
+ (define yhs ;; (Listof (Hash Y => Nat))
+ (for/list ([xs (in-list xss)])
+ (for/hash ([x (in-list xs)] [i (in-naturals 1)])
+ (values (get-y x) i))))
+ (remove-duplicates
+ (let loop ([xs (car xss)] [last (for/list ([xs (in-list xss)]) 0)])
+ ;; last is list of indexes of last accepted y; only accept next if occurs
+ ;; after last in every sequence (see Case 7 above)
+ (cond [(null? xs) null]
+ [else
+ (define y (get-y (car xs)))
+ (define curr (for/list ([yh (in-list yhs)]) (hash-ref yh y -1)))
+ (cond [(andmap > curr last)
+ (cons y (loop (cdr xs) curr))]
+ [else (loop (cdr xs) last)])])))]))
+
+;; rsplit : (Listof X) (X -> Y) (Listof Y) -> (Listof (Listof X))
+;; Given [y1 ... yN], splits xs into [rest gotN preN ... got1 pre1].
+;; Thus the result has 2N+1 elements. The sublists are in original order.
+(define (rsplit xs get-y ys)
+ (define (loop xs ys segsacc)
+ (cond [(null? ys) (cons xs segsacc)]
+ [else (pre-loop xs ys segsacc null)]))
+ (define (pre-loop xs ys segsacc preacc)
+ (cond [(and (pair? xs) (equal? (get-y (car xs)) (car ys)))
+ (got-loop (cdr xs) ys segsacc preacc (list (car xs)))]
+ [else
+ (pre-loop (cdr xs) ys segsacc (cons (car xs) preacc))]))
+ (define (got-loop xs ys segsacc preacc gotacc)
+ (cond [(and (pair? xs) (equal? (get-y (car xs)) (car ys)))
+ (got-loop (cdr xs) ys segsacc preacc (cons (car xs) gotacc))]
+ [else
+ (loop xs (cdr ys) (list* (reverse gotacc) (reverse preacc) segsacc))]))
+ (loop xs ys null))
+
+;; singleton? : list -> boolean
+(define (singleton? x) (and (pair? x) (null? (cdr x))))
+
+;; remove-extensions : (Listof (Listof X)) -> (Listof (Listof X))
+;; Remove any element that is an extension of another.
+(define (remove-extensions xss)
+ (cond [(null? xss) null]
+ [else
+ (let loop ([xss xss])
+ (cond [(singleton? xss) xss]
+ [(ormap null? xss) (list null)]
+ [else
+ (define groups (group-by car xss))
+ (append*
+ (for/list ([group (in-list groups)])
+ (define group* (loop (map cdr group)))
+ (map (lambda (x) (cons (caar group) x)) group*)))]))]))
+
+;; all-equal? : (Listof Any) -> Boolean
+(define (all-equal? xs) (for/and ([x (in-list xs)]) (equal? x (car xs))))
+
+
+;; ============================================================
+;; Reporting
+
+;; report/expectstack : ExpectList Syntax Nat -> Report
+(define (report/expectstack es stx index)
+ (define frame-expect (and (pair? es) (car es)))
+ (define context-frames (if (pair? es) (cdr es) null))
+ (define context (append* (map context-prose-for-expect context-frames)))
+ (cond [(not frame-expect)
+ (report "bad syntax" context #f #f)]
+ [else
+ (define-values (x cx) (stx-list-drop/cx stx stx index))
+ (define frame-stx (datum->syntax cx x cx))
+ (define within-stx (if (syntax? x) #f cx))
+ (cond [(and (match frame-expect [(expect:atom '() _) #t] [_ #f])
+ (stx-pair? frame-stx))
+ (report "unexpected term" context (stx-car frame-stx) #f)]
+ [(expect:disj? frame-expect)
+ (report (prose-for-expects (expect:disj-expects frame-expect))
+ context frame-stx within-stx)]
+ [else
+ (report (prose-for-expects (list frame-expect))
+ context frame-stx within-stx)])]))
+
+;; prose-for-expects : (listof Expect) -> string
+(define (prose-for-expects expects)
+ (define msgs (filter expect:message? expects))
+ (define things (filter expect:thing? expects))
+ (define literal (filter expect:literal? expects))
+ (define atom/symbol
+ (filter (lambda (e) (and (expect:atom? e) (symbol? (expect:atom-atom e)))) expects))
+ (define atom/nonsym
+ (filter (lambda (e) (and (expect:atom? e) (not (symbol? (expect:atom-atom e))))) expects))
+ (define proper-pairs (filter expect:proper-pair? expects))
+ (join-sep
+ (append (map prose-for-expect (append msgs things))
+ (prose-for-expects/literals literal "identifiers")
+ (prose-for-expects/literals atom/symbol "literal symbols")
+ (prose-for-expects/literals atom/nonsym "literals")
+ (prose-for-expects/pairs proper-pairs))
+ ";" "or"))
+
+(define (prose-for-expects/literals expects whats)
+ (cond [(null? expects) null]
+ [(singleton? expects) (map prose-for-expect expects)]
+ [else
+ (define (prose e)
+ (match e
+ [(expect:atom (? symbol? atom) _)
+ (format "`~s'" atom)]
+ [(expect:atom atom _)
+ (format "~s" atom)]
+ [(expect:literal literal _)
+ (format "`~s'" (syntax-e literal))]))
+ (list (string-append "expected one of these " whats ": "
+ (join-sep (map prose expects) "," "or")))]))
+
+(define (prose-for-expects/pairs expects)
+ (if (pair? expects) (list (prose-for-proper-pair-expects expects)) null))
+
+;; prose-for-expect : Expect -> string
+(define (prose-for-expect e)
+ (match e
+ [(expect:thing _ description transparent? role _)
+ (if role
+ (format "expected ~a for ~a" description role)
+ (format "expected ~a" description))]
+ [(expect:atom (? symbol? atom) _)
+ (format "expected the literal symbol `~s'" atom)]
+ [(expect:atom atom _)
+ (format "expected the literal ~s" atom)]
+ [(expect:literal literal _)
+ (format "expected the identifier `~s'" (syntax-e literal))]
+ [(expect:message message _)
+ message]
+ [(expect:proper-pair '#f _)
+ "expected more terms"]))
+
+;; prose-for-proper-pair-expects : (listof expect:proper-pair) -> string
+(define (prose-for-proper-pair-expects es)
+ (define descs (remove-duplicates (map expect:proper-pair-first-desc es)))
+ (cond [(for/or ([desc descs]) (equal? desc #f))
+ ;; FIXME: better way to indicate unknown ???
+ "expected more terms"]
+ [else
+ (format "expected more terms starting with ~a"
+ (join-sep (map prose-for-first-desc descs)
+ "," "or"))]))
+
+;; prose-for-first-desc : FirstDesc -> string
+(define (prose-for-first-desc desc)
+ (match desc
+ [(? string?) desc]
+ [(list 'any) "any term"] ;; FIXME: maybe should cancel out other descs ???
+ [(list 'literal id) (format "the identifier `~s'" id)]
+ [(list 'datum (? symbol? s)) (format "the literal symbol `~s'" s)]
+ [(list 'datum d) (format "the literal ~s" d)]))
+
+;; context-prose-for-expect : (U '... expect:thing) -> (listof string)
+(define (context-prose-for-expect e)
+ (match e
+ ['...
+ (list "while parsing different things...")]
+ [(expect:thing '#f description transparent? role stx+index)
+ (let ([stx (stx+index->stx stx+index)])
+ (cons (~a "while parsing " description
+ (if role (~a " for " role) ""))
+ (if (error-print-source-location)
+ (list (~a " term: "
+ (~s (syntax->datum stx)
+ #:limit-marker "..."
+ #:max-width 50))
+ (~a " location: "
+ (or (source-location->string stx) "not available")))
+ null)))]))
+
+(define (stx+index->stx stx+index)
+ (let*-values ([(stx) (car stx+index)]
+ [(index) (cdr stx+index)]
+ [(x cx) (stx-list-drop/cx stx stx index)])
+ (datum->syntax cx x cx)))
+
+
+;; ============================================================
+;; Raise exception
+
+(define (error/report ctx report)
+ (let* ([message (report-message report)]
+ [context (report-context report)]
+ [stx (cadr ctx)]
+ [who (or (car ctx) (infer-who stx))]
+ [sub-stx (report-stx report)]
+ [within-stx (report-within-stx report)]
+ [message
+ (format "~a: ~a~a~a~a~a"
+ who message
+ (format-if "at" (stx-if-loc sub-stx))
+ (format-if "within" (stx-if-loc within-stx))
+ (format-if "in" (stx-if-loc stx))
+ (if (null? context)
+ ""
+ (apply string-append
+ "\n parsing context: "
+ (for/list ([c (in-list context)])
+ (format "\n ~a" c)))))]
+ [message
+ (if (error-print-source-location)
+ (let ([source-stx (or stx sub-stx within-stx)])
+ (string-append (source-location->prefix source-stx) message))
+ message)])
+ (raise
+ (exn:fail:syntax message (current-continuation-marks)
+ (map syntax-taint
+ (cond [within-stx (list within-stx)]
+ [sub-stx (list sub-stx)]
+ [stx (list stx)]
+ [else null]))))))
+
+(define (format-if prefix val)
+ (if val
+ (format "\n ~a: ~a" prefix val)
+ ""))
+
+(define (stx-if-loc stx)
+ (and (syntax? stx)
+ (error-print-source-location)
+ (format "~.s" (syntax->datum stx))))
+
+(define (infer-who stx)
+ (let* ([maybe-id (if (stx-pair? stx) (stx-car stx) stx)])
+ (if (identifier? maybe-id) (syntax-e maybe-id) '?)))
+
+(define (comma-list items)
+ (join-sep items "," "or"))
+
+(define (improper-stx->list stx)
+ (syntax-case stx ()
+ [(a . b) (cons #'a (improper-stx->list #'b))]
+ [() null]
+ [rest (list #'rest)]))
+
+
+;; ============================================================
+;; Debugging
+
+(provide failureset->sexpr
+ failure->sexpr
+ expectstack->sexpr
+ expect->sexpr)
+
+(define (failureset->sexpr fs)
+ (let ([fs (flatten fs)])
+ (case (length fs)
+ ((1) (failure->sexpr (car fs)))
+ (else `(union ,@(map failure->sexpr fs))))))
+
+(define (failure->sexpr f)
+ (match f
+ [(failure progress expectstack)
+ `(failure ,(progress->sexpr progress)
+ #:expected ,(expectstack->sexpr expectstack))]))
+
+(define (expectstack->sexpr es)
+ (map expect->sexpr es))
+
+(define (expect->sexpr e) e)
+
+(define (progress->sexpr ps)
+ (for/list ([pf (in-list ps)])
+ (match pf
+ [(? syntax? stx) 'stx]
+ [_ pf])))
diff --git a/parse/private/runtime.rkt-6-11 b/parse/private/runtime.rkt-6-11
new file mode 100644
index 0000000..7b6cb19
--- /dev/null
+++ b/parse/private/runtime.rkt-6-11
@@ -0,0 +1,224 @@
+#lang racket/base
+(require racket/stxparam
+ stxparse-info/parse/private/residual ;; keep abs. path
+ stxparse-info/current-pvars
+ (for-syntax racket/base
+ racket/list
+ syntax/kerncase
+ syntax/strip-context
+ racket/private/sc
+ auto-syntax-e/utils
+ racket/syntax
+ syntax/parse/private/rep-data))
+
+(provide with
+ fail-handler
+ cut-prompt
+ wrap-user-code
+
+ fail
+ try
+
+ let-attributes
+ let-attributes*
+ let/unpack
+
+ defattrs/unpack
+
+ check-literal
+ no-shadow
+ curried-stxclass-parser
+ app-argu)
+
+#|
+TODO: rename file
+
+This file contains "runtime" (ie, phase 0) auxiliary *macros* used in
+expansion of syntax-parse etc. This file must not contain any
+reference that persists in a compiled program; those must go in
+residual.rkt.
+|#
+
+;; == with ==
+
+(define-syntax (with stx)
+ (syntax-case stx ()
+ [(with ([stxparam expr] ...) . body)
+ (with-syntax ([(var ...) (generate-temporaries #'(stxparam ...))])
+ (syntax/loc stx
+ (let ([var expr] ...)
+ (syntax-parameterize ((stxparam (make-rename-transformer (quote-syntax var)))
+ ...)
+ . body))))]))
+
+;; == Control information ==
+
+(define-syntax-parameter fail-handler
+ (lambda (stx)
+ (wrong-syntax stx "internal error: fail-handler used out of context")))
+(define-syntax-parameter cut-prompt
+ (lambda (stx)
+ (wrong-syntax stx "internal error: cut-prompt used out of context")))
+
+(define-syntax-rule (wrap-user-code e)
+ (with ([fail-handler #f]
+ [cut-prompt #t])
+ e))
+
+(define-syntax-rule (fail fs)
+ (fail-handler fs))
+
+(define-syntax (try stx)
+ (syntax-case stx ()
+ [(try e0 e ...)
+ (with-syntax ([(re ...) (reverse (syntax->list #'(e ...)))])
+ (with-syntax ([(fh ...) (generate-temporaries #'(re ...))])
+ (with-syntax ([(next-fh ...) (drop-right (syntax->list #'(fail-handler fh ...)) 1)]
+ [(last-fh) (take-right (syntax->list #'(fail-handler fh ...)) 1)])
+ #'(let* ([fh (lambda (fs1)
+ (with ([fail-handler
+ (lambda (fs2)
+ (next-fh (cons fs1 fs2)))])
+ re))]
+ ...)
+ (with ([fail-handler last-fh])
+ e0)))))]))
+
+;; == Attributes
+
+(define-for-syntax (parse-attr x)
+ (syntax-case x ()
+ [#s(attr name depth syntax?) #'(name depth syntax?)]))
+
+(define-syntax (let-attributes stx)
+ (syntax-case stx ()
+ [(let-attributes ([a value] ...) . body)
+ (with-syntax ([((name depth syntax?) ...)
+ (map parse-attr (syntax->list #'(a ...)))])
+ (with-syntax ([(vtmp ...) (generate-temporaries #'(name ...))]
+ [(stmp ...) (generate-temporaries #'(name ...))])
+ #'(letrec-syntaxes+values
+ ([(stmp) (make-attribute-mapping (quote-syntax vtmp)
+ 'name 'depth 'syntax?)] ...)
+ ([(vtmp) value] ...)
+ (letrec-syntaxes+values
+ ([(name) (make-auto-pvar 'depth (quote-syntax stmp))] ...)
+ ()
+ (with-pvars (name ...)
+ . body)))))]))
+
+;; (let-attributes* (([id num] ...) (expr ...)) expr) : expr
+;; Special case: empty attrs need not match number of value exprs.
+(define-syntax let-attributes*
+ (syntax-rules ()
+ [(la* (() _) . body)
+ (let () . body)]
+ [(la* ((a ...) (val ...)) . body)
+ (let-attributes ([a val] ...) . body)]))
+
+;; (let/unpack (([id num] ...) expr) expr) : expr
+;; Special case: empty attrs need not match packed length
+(define-syntax (let/unpack stx)
+ (syntax-case stx ()
+ [(let/unpack (() packed) body)
+ #'body]
+ [(let/unpack ((a ...) packed) body)
+ (with-syntax ([(tmp ...) (generate-temporaries #'(a ...))])
+ #'(let-values ([(tmp ...) (apply values packed)])
+ (let-attributes ([a tmp] ...) body)))]))
+
+(define-syntax (defattrs/unpack stx)
+ (syntax-case stx ()
+ [(defattrs (a ...) packed)
+ (with-syntax ([((name depth syntax?) ...)
+ (map parse-attr (syntax->list #'(a ...)))])
+ (with-syntax ([(vtmp ...) (generate-temporaries #'(name ...))]
+ [(stmp ...) (generate-temporaries #'(name ...))])
+ #'(begin (define-values (vtmp ...) (apply values packed))
+ (define-syntax stmp
+ (make-attribute-mapping (quote-syntax vtmp)
+ 'name 'depth 'syntax?))
+ ...
+ (define-syntax name (make-auto-pvar 'depth (quote-syntax stmp)))
+ ...
+ (define-pvars name ...))))]))
+
+(define-syntax-rule (phase-of-enclosing-module)
+ (variable-reference->module-base-phase
+ (#%variable-reference)))
+
+;; (check-literal id phase-level-expr ctx) -> void
+(define-syntax (check-literal stx)
+ (syntax-case stx ()
+ [(check-literal id used-phase-expr ctx)
+ (let* ([ok-phases/ct-rel
+ ;; id is bound at each of ok-phases/ct-rel
+ ;; (phase relative to the compilation of the module in which the
+ ;; 'syntax-parse' (or related) form occurs)
+ (filter (lambda (p) (identifier-binding #'id p)) '(0 1 -1 #f))])
+ ;; so we can avoid run-time call to identifier-binding if
+ ;; (+ (phase-of-enclosing-module) ok-phase/ct-rel) = used-phase
+ (with-syntax ([ok-phases/ct-rel ok-phases/ct-rel])
+ #`(check-literal* (quote-syntax id)
+ used-phase-expr
+ (phase-of-enclosing-module)
+ 'ok-phases/ct-rel
+ ;; If context is not stripped, racket complains about
+ ;; being unable to restore bindings for compiled code;
+ ;; and all we want is the srcloc, etc.
+ (quote-syntax #,(strip-context #'ctx)))))]))
+
+;; ====
+
+(begin-for-syntax
+ (define (check-shadow def)
+ (syntax-case def ()
+ [(_def (x ...) . _)
+ (parameterize ((current-syntax-context def))
+ (for ([x (in-list (syntax->list #'(x ...)))])
+ (let ([v (syntax-local-value x (lambda _ #f))])
+ (when (syntax-pattern-variable? v)
+ (wrong-syntax
+ x
+ ;; FIXME: customize "~do pattern" vs "#:do block" as appropriate
+ "definition in ~~do pattern must not shadow attribute binding")))))])))
+
+(define-syntax (no-shadow stx)
+ (syntax-case stx ()
+ [(no-shadow e)
+ (let ([ee (local-expand #'e (syntax-local-context)
+ (kernel-form-identifier-list))])
+ (syntax-case ee (begin define-values define-syntaxes)
+ [(begin d ...)
+ #'(begin (no-shadow d) ...)]
+ [(define-values . _)
+ (begin (check-shadow ee)
+ ee)]
+ [(define-syntaxes . _)
+ (begin (check-shadow ee)
+ ee)]
+ [_
+ ee]))]))
+
+(define-syntax (curried-stxclass-parser stx)
+ (syntax-case stx ()
+ [(_ class argu)
+ (with-syntax ([#s(arguments (parg ...) (kw ...) _) #'argu])
+ (let ([sc (get-stxclass/check-arity #'class #'class
+ (length (syntax->list #'(parg ...)))
+ (syntax->datum #'(kw ...)))])
+ (with-syntax ([parser (stxclass-parser sc)])
+ #'(lambda (x cx pr es fh cp rl success)
+ (app-argu parser x cx pr es fh cp rl success argu)))))]))
+
+(define-syntax (app-argu stx)
+ (syntax-case stx ()
+ [(aa proc extra-parg ... #s(arguments (parg ...) (kw ...) (kwarg ...)))
+ #|
+ Use keyword-apply directly?
+ #'(keyword-apply proc '(kw ...) (list kwarg ...) parg ... null)
+ If so, create separate no-keyword clause.
+ |#
+ ;; For now, let #%app handle it.
+ (with-syntax ([((kw-part ...) ...) #'((kw kwarg) ...)])
+ #'(proc kw-part ... ... extra-parg ... parg ...))]))
diff --git a/parse/private/sc.rkt-6-11 b/parse/private/sc.rkt-6-11
new file mode 100644
index 0000000..dc6bdda
--- /dev/null
+++ b/parse/private/sc.rkt-6-11
@@ -0,0 +1,75 @@
+#lang racket/base
+(require (for-syntax racket/base
+ racket/lazy-require)
+ syntax/parse/private/keywords)
+
+;; keep and keep as abs. path -- lazy-loaded macros produce references to this
+;; must be required via *absolute module path* from any disappearing module
+;; (so for consistency etc, require absolutely from all modules)
+(require stxparse-info/parse/private/residual
+ racket/syntax
+ racket/stxparam
+ syntax/stx)
+
+(begin-for-syntax
+ (lazy-require
+ ;; load macro transformers lazily via identifier
+ ;; This module path must also be absolute (not sure why,
+ ;; but it definitely breaks on relative module path).
+ [stxparse-info/parse/private/parse-aux
+ (id:define-syntax-class
+ id:define-splicing-syntax-class
+ id:define-integrable-syntax-class
+ id:syntax-parse
+ id:syntax-parser
+ id:define/syntax-parse
+ id:syntax-parser/template
+ id:parser/rhs
+ id:define-eh-alternative-set)]))
+;; 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_ 'stxparse-info/parse/private/parse-aux)
+
+(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
+ parser/rhs
+ define-eh-alternative-set)
+
+(define-syntaxes (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)
+ (let ([tx (lambda (get-id)
+ (lambda (stx)
+ (syntax-case stx ()
+ [(_ . args)
+ (datum->syntax stx (cons (get-id) #'args) stx)])))])
+ (values
+ (tx id:define-syntax-class)
+ (tx id:define-splicing-syntax-class)
+ (tx id:define-integrable-syntax-class)
+ (tx id:syntax-parse)
+ (tx id:syntax-parser)
+ (tx id:define/syntax-parse)
+ (tx id:syntax-parser/template)
+ (tx id:parser/rhs)
+ (tx id:define-eh-alternative-set))))
diff --git a/scribblings/stxparse-info.scrbl-6-11 b/scribblings/stxparse-info.scrbl-6-11
new file mode 100644
index 0000000..2f0e86a
--- /dev/null
+++ b/scribblings/stxparse-info.scrbl-6-11
@@ -0,0 +1,350 @@
+#lang scribble/manual
+@require[racket/require
+ @for-label[stxparse-info/parse
+ stxparse-info/parse/experimental/template
+ stxparse-info/case
+ stxparse-info/current-pvars
+ (subtract-in racket/syntax stxparse-info/case)
+ (subtract-in racket/base stxparse-info/case)]
+ version-case
+ @for-syntax[racket/base]
+ "ovl.rkt"]
+
+@; Circumvent https://github.com/racket/scribble/issues/79
+@(require scribble/struct
+ scribble/decode)
+@(define (nested-inset . vs)
+ (nested #:style 'inset vs))
+
+@(version-case
+ [(version< (version) "6.4")
+ ]
+ [else
+ (require scribble/example)
+ (define ev ((make-eval-factory '(racket))))])
+
+@title{@racketmodname[stxparse-info]: Track @racket[syntax-parse] and @racket[syntax-case] pattern vars}
+@author[@author+email["Georges Dupéron" "georges.duperon@gmail.com"]]
+
+Source code: @url{https://github.com/jsmaniac/stxparse-info}
+
+@defmodule[stxparse-info]
+
+This library provides some patched versions of @orig:syntax-parse and of the
+@orig:syntax-case family. These patched versions track which syntax pattern
+variables are bound. This allows some libraries to change the way syntax
+pattern variables work.
+
+For example, @tt{subtemplate} automatically derives temporary
+identifiers when a template contains @racket[yᵢ …], and @racket[xᵢ] is a
+pattern variable. To know from which @racket[varᵢ] the @racket[yᵢ …]
+identifiers must be derived, @tt{subtemplate} needs to know which
+syntax pattern variables are within scope.
+
+@section{Tracking currently-bound pattern variables with @racket[syntax-parse]}
+
+@defmodule[stxparse-info/parse]
+
+The module @racketmodname[stxparse-info/parse] provides patched versions of
+@orig:syntax-parse, @orig:syntax-parser and @orig:define/syntax-parse which
+track which syntax pattern variables are bound.
+
+@(ovl syntax/parse
+ syntax-parse
+ syntax-parser
+ define/syntax-parse)
+
+Additionally, the following identifiers are overridden as they are part of the
+duplicated implementation of @racketmodname[syntax/parse].
+
+@(ovl #:wrapper nested-inset
+ syntax/parse
+ ...+
+ attribute
+ boolean
+ char
+ character
+ define-conventions
+ define-eh-alternative-set
+ define-literal-set
+ define-splicing-syntax-class
+ define-syntax-class
+ exact-integer
+ exact-nonnegative-integer
+ exact-positive-integer
+ expr
+ expr/c
+ id
+ identifier
+ integer
+ kernel-literals
+ keyword
+ literal-set->predicate
+ nat
+ number
+ pattern
+ static
+ str
+ this-syntax
+ ~!
+ ~and
+ ~between
+ ~bind
+ ~commit
+ ~datum
+ ~delimit-cut
+ ~describe
+ ~do
+ ~fail
+ ~literal
+ ~not
+ ~once
+ ~optional
+ ~or
+ ~parse
+ ~peek
+ ~peek-not
+ ~post
+ ~rest
+ ~seq
+ ~var)
+
+@(version-case
+ [(version>= (version) "6.9.0.6")
+ (ovl #:wrapper nested-inset
+ syntax/parse
+ ~alt
+ ~or*)]
+ [else (begin)])
+
+@(ovl #:wrapper nested-inset
+ #:require (for-template syntax/parse)
+ syntax/parse
+ pattern-expander?
+ pattern-expander
+ prop:pattern-expander
+ syntax-local-syntax-parse-pattern-introduce)
+
+@section{Tracking currently-bound pattern variables with @racket[syntax-case]}
+
+@defmodule[stxparse-info/case]
+
+The module @racketmodname[stxparse-info/case] provides patched versions of
+@orig:syntax-case, @orig:syntax-case*, @orig:with-syntax,
+@orig:define/with-syntax, @orig:datum-case and @orig:with-datum which
+track which syntax or datum pattern variables are bound.
+
+@(ovl racket/base
+ syntax-case
+ syntax-case*
+ with-syntax)
+
+@(ovl syntax/datum
+ datum-case
+ with-datum)
+
+@(ovl racket/syntax
+ define/with-syntax)
+
+@section{Reading and updating the list of currently-bound pattern variables}
+
+@defmodule[stxparse-info/current-pvars]
+
+@defproc[#:kind "procedure at phase 1"
+ (current-pvars) (listof identifier?)]{
+ This for-syntax procedure returns the list of syntax pattern variables which
+ are known to be bound. The most recently bound variables are at the beginning
+ of the list.
+
+ It is the responsibility of the reader to check that the identifiers are
+ bound, and that they are bound to syntax pattern variables, for example using
+ @racket[identifier-binding] and @racket[syntax-pattern-variable?]. This allows
+ libraries to also track variables bound by match-like forms, for example.}
+
+@defproc[#:kind "procedure at phase 1"
+ (current-pvars+unique) (listof (pairof identifier? identifier?))]{
+ This for-syntax procedure works like @racket[current-pvars], but associates
+ each syntax pattern variable with an identifier containing a unique symbol
+ which is generated at each execution of the code recording the pattern
+ variable via @racket[with-pvars] or @racket[define-pvars].
+
+ The @racket[car] of each pair in the returned list is the syntax pattern
+ variable (as produced by @racket[current-pvars]). It is the responsibility of
+ the reader to check that the identifiers present in the @racket[car] of each
+ element of the returned list are bound, and that they are bound to syntax
+ pattern variables, for example using @racket[identifier-binding] and
+ @racket[syntax-pattern-variable?]. This allows libraries to also track
+ variables bound by match-like forms, for example.
+
+ The @racket[cdr] of each pair is the identifier of a temporary variable.
+ Reading that temporary variable produces a @racket[gensym]-ed symbol, which
+ was generated at run-time at the point where @racket[with-pvars] or
+ @racket[define-pvars] was used to record the corresponding pattern variable.
+
+ This can be used to associate run-time data with each syntax pattern
+ variable, via a weak hash table created with @racket[make-weak-hasheq]. For
+ example, the @tt{subtemplate} library implicitly derives
+ identifiers (similarly to @racket[generate-temporaries]) for uses of
+ @racket[yᵢ ...] from a @racket[xᵢ] pattern variable bearing the same
+ subscript. The generated identifiers are associated with @racket[xᵢ] via this
+ weak hash table mechanism, so that two uses of @racket[yᵢ ...] within the
+ scope of the same @racket[xᵢ] binding derive the same identifiers.
+
+ The code @racket[(with-pvars (v) body)] roughly expands to:
+
+ @racketblock[
+ (let-values ([(tmp) (gensym 'v)])
+ (letrec-syntaxes+values ([(shadow-current-pvars)
+ (list* (cons (quote-syntax v)
+ (quote-syntax tmp))
+ old-current-pvars)])
+ body))]
+
+ @bold{Caveat:} this entails that the fresh symbol stored in @racket[tmp] is
+ generated when @racket[with-pvars] or @racket[define-pvars] is called, not
+ when the syntax pattern variable is actually bound. For example:
+
+ @RACKETBLOCK[
+ (define-syntax (get-current-pvars+unique stx)
+ #`'#,(current-pvars+unique))
+
+ (require racket/private/sc)
+ (let ([my-valvar (quote-syntax x)])
+ (let-syntax ([my-pvar (make-syntax-mapping 0 (quote-syntax my-valvar))])
+ (with-pvars (x)
+ (get-current-pvars+unique)) (code:comment "'([x . g123])")
+ (with-pvars (x)
+ (get-current-pvars+unique)))) (code:comment "'([x . g124])")]
+
+ Under normal circumstances, @racket[with-pvars] @racket[define-pvars] should
+ be called immediately after binding the syntax pattern variable, but the code
+ above shows that it is technically possible to do otherwise.
+
+ This caveat is not meant to dissuade the use of
+ @racket[current-pvars+unique], it rather serves as an explanation of the
+ behaviour encountered when @racket[with-pvars] or @racket[define-pvars] are
+ incorrectly used more than once to record the same pattern variable.}
+
+@defform[(with-pvars (pvar ...) . body)
+ #:contracts ([pvar identifier?])]{
+ Prepends the given @racket[pvar ...] to the list of pattern variables which
+ are known to be bound. The @racket[pvar ...] are prepended in reverse order,
+ so within the body of
+
+ @racketblock[(with-pvars (v₁ v₂ v₃) . body)]
+
+ a call to the for-syntax function @racket[(current-pvars)] returns:
+
+ @racketblock[(list* (quote-syntax v₃) (quote-syntax v₂) (quote-syntax v₁)
+ old-current-pvars)]
+
+ This can be used to implement macros which work similarly to
+ @racket[syntax-parse] or @racket[syntax-case], and have them record the syntax
+ pattern variables which they bind.
+
+ Note that the identifiers @racket[pvar ...] must already be bound to syntax
+ pattern variables when @racket[with-pvars] is used, e.g.
+
+ @racketblock[
+ (let-syntax ([v₁ (make-syntax-mapping depth (quote-syntax valvar))]
+ [v₂ (make-syntax-mapping depth (quote-syntax valvar))])
+ (with-pvars (v₁ v₂)
+ code))]
+
+ instead of:
+
+ @racketblock[
+ (with-pvars (v₁ v₂)
+ (let-syntax ([v₁ (make-syntax-mapping depth (quote-syntax valvar))]
+ [v₂ (make-syntax-mapping depth (quote-syntax valvar))])
+ code))]}
+
+@defform[(define-pvars pvar ...)
+ #:contracts ([pvar identifier?])]{
+
+ Prepends the given @racket[pvar ...] to the list of pattern variables which
+ are known to be bound, in the same way as @racket[with-pvars]. Whereas
+ @racket[with-pvars] makes the modified list visible in the @racket[_body],
+ @racket[define-pvars] makes the modified list visible in the statements
+ following @racket[define-pvars]. @racket[define-pvars] can be used multiple
+ times within the same @racket[let] or equivalent.
+
+ This can be used to implement macros which work similarly to
+ @racket[define/syntax-parse] or @racket[define/with-syntax], and have them
+ record the syntax pattern variables which they bind.
+
+ @(version-case
+ [(version< (version) "6.4")
+ @RACKETBLOCK[
+ (let ()
+ (code:comment "Alternate version of define/syntax-parse which")
+ (code:comment "contains (define-pvars x) in its expanded form.")
+ (define/syntax-parse x #'1)
+ (define/syntax-parse y #'2)
+ (define-syntax (get-pvars stx)
+ #`'#,(current-pvars))
+ (get-pvars))
+ (code:comment "=> '(y x)")]]
+ [else
+ @examples[
+ #:eval ev
+ #:hidden
+ (require stxparse-info/parse
+ stxparse-info/current-pvars
+ racket/syntax
+ (for-syntax racket/base))]
+
+ @examples[
+ #:eval ev
+ #:escape UNSYNTAX
+ (eval:check
+ (let ()
+ (code:comment "Alternate version of define/syntax-parse which")
+ (code:comment "contains (define-pvars x) in its expanded form.")
+ (define/syntax-parse x #'1)
+ (define/syntax-parse y #'2)
+ (define-syntax (get-pvars stx)
+ #`'#,(current-pvars))
+ (get-pvars))
+ '(y x))]])}
+
+@section{Extensions to @racketmodname[syntax/parse/experimental/template]}
+
+@defmodule[stxparse-info/parse/experimental/template]
+
+@(orig syntax/parse/experimental/template
+ define-template-metafunction)
+
+@defidform[define-template-metafunction]{
+ Overloaded version of @orig:define-template-metafunction from
+ @racketmodname[syntax/parse/experimental/template].
+
+ Note that currently, template metafunctions defined via
+ @racketmodname[stxparse-info/parse/experimental/template] are not compatible
+ with the forms from @racketmodname[syntax/parse/experimental/template], and
+ vice versa. There is a pending Pull Request which would make the necessary
+ primitives from @racketmodname[syntax/parse/experimental/template] public, so
+ hopefully this problem will be solved in future versions.}
+
+@defform[(syntax-local-template-metafunction-introduce stx)]{
+ Like @racket[syntax-local-introduce], but for
+ @tech[#:doc '(lib "syntax/scribblings/syntax.scrbl")]{template metafunctions}.
+
+ This change is also available in the package
+ @racketmodname{backport-template-pr1514}. It has been submitted as a Pull
+ Request to Racket, but can already be used in
+ @racketmodname[stxparse-info/parse/experimental/template] right now.}
+
+@(ovl syntax/parse/experimental/template
+ template
+ quasitemplate
+ template/loc
+ quasitemplate/loc)
+
+Additionally, the following identifiers are overridden as they are part of the
+duplicated implementation of @racketmodname[syntax/parse].
+
+@(ovl #:wrapper nested-inset
+ syntax/parse/experimental/template
+ ??
+ ?@)