From 6c369f25632cf99a874f3fa34e074d2a38b9efbb Mon Sep 17 00:00:00 2001 From: Ryan Culpepper Date: Sun, 18 Mar 2012 00:31:47 -0600 Subject: [PATCH] updates to syntax/parse/experimental/template - changed substitute to use closure-compilation - added stress/perf test for templates - updated minimatch with vector patterns - split substitute into separate file, minimize dependencies - do ellipsis optimization dynamically - validate guides: check var indexes --- .../parse/experimental/private/substitute.rkt | 297 +++++++++++++ .../syntax/parse/experimental/template.rkt | 398 ++++++------------ collects/syntax/parse/private/minimatch.rkt | 7 +- collects/tests/stxparse/stress-template.rkt | 77 ++++ 4 files changed, 501 insertions(+), 278 deletions(-) create mode 100644 collects/syntax/parse/experimental/private/substitute.rkt create mode 100644 collects/tests/stxparse/stress-template.rkt diff --git a/collects/syntax/parse/experimental/private/substitute.rkt b/collects/syntax/parse/experimental/private/substitute.rkt new file mode 100644 index 0000000000..30ae72d8a1 --- /dev/null +++ b/collects/syntax/parse/experimental/private/substitute.rkt @@ -0,0 +1,297 @@ +#lang racket/base +(require syntax/parse/private/minimatch + racket/private/stx) ;; syntax/stx +(provide translate + error/not-stx) + +#| +;; 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: + - '_ + - positive-exact-integer ;; represents depth=0 pvar ref or metafun ref + - negative-exact-integer ;; represents depth>0 pvar ref (within ellipsis) + - (cons G G) + - (vector 'vector G) + - (vector 'struct G) + - (vector 'box G) + - (vector 'dots HG (vector-of integer) nat G) + - (vector 'app HG G) + - (vector 'escaped G) + - (vector 'orelse G (vector-of integer) G) + - (vector 'metafun integer G) + +A HeadGuide (HG) is one of: + - G + - (vector 'app-opt G (vector-of integer)) + - (vector 'splice G) +|# + +(define (head-guide? x) + (match x + [(vector 'app-opt g vars) #t] + [(vector 'splice g) #t] + [_ #f])) + +;; ============================================================ + +;; 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")) + (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) (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 gtail) + (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)) + (cond [(and (= lenv*-len 1) (= nesting 1) (not ghead-is-hg?) (equal? ghead '-1)) + ;; template was just (pvar ... . T) + (let ([fhead (translate-g stx0 (stx-car stx) ghead env-length 'one)]) + (lambda (env lenv) + (let ([lenv* (get (vector-ref henv 0) env lenv)]) + (restx stx (append lenv* (ftail env lenv))))))] + [(and (= lenv*-len 1) (= nesting 1) (not ghead-is-hg?)) + (let ([fhead (translate-g stx0 (stx-car stx) ghead env-length 'one)]) + (lambda (env lenv) + (restx stx + (let dotsloop ([lenv* (get (vector-ref henv 0) env lenv)]) + (if (null? lenv*) + (ftail env lenv) + (cons (fhead env (car lenv*)) + (dotsloop (cdr lenv*))))))))] + [else + (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) + (define (nestloop lenv* nesting) + (cond [(zero? nesting) + (fhead env lenv*)] + [else + (check-lenv stx lenv*) + (let ([len0 (length (vector-ref lenv* 0))]) + (let ([lenv** (make-vector (vector-length lenv*))]) + (let dotsloop ([len0 len0]) + (if (zero? len0) + null + (begin (vector-car/cdr! lenv** lenv*) + (cons (nestloop lenv** (sub1 nesting)) + (dotsloop (sub1 len0))))))))])) + (let ([head-results + ;; if ghead-is-hg?, is (listof^(nesting+1) stx) -- extra listof for loop-h + ;; otherwise, is (listof^nesting stx) + (nestloop (vector-map (lambda (index) (get index env lenv)) henv) + nesting)] + [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 drivers1 g2) + (let ([f1 (loop (stx-cadr stx) g1)] + [f2 (loop (stx-caddr stx) g2)]) + (for ([var (in-vector drivers1)]) + (check-var var env-length lenv-mode)) + (lambda (env lenv) + (if (for/and ([index (in-vector drivers1)]) (get index env lenv)) + (f1 env lenv) + (f2 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)) + (let ([r (mf (mark (old-mark v)))]) + (unless (syntax? r) + (raise-syntax-error 'template "result of 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)))))])) + +(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 g1 drivers1) + (let ([f1 (loop (stx-cadr stx) g1)]) + (for ([var (in-vector drivers1)]) + (check-var var env-length lenv-mode)) + (lambda (env lenv) + (if (for/and ([index (in-vector drivers1)]) (get index env lenv)) + (list (f1 env lenv)) + null)))] + [(vector 'splice g1) + (let ([f1 (loop (stx-cdr stx) g1)]) + (lambda (env lenv) + (let* ([v (f1 env lenv)] + [v* (stx->list v)]) + (unless v* + (raise-syntax-error 'template + "splicing template did not produce a syntax list" + stx)) + v*)))] + [else + (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 stx lenv) + (for ([v (in-vector lenv)]) + (unless v + (error 'template "pattern variable used in ellipsis pattern is not defined"))) + (let ([len0 (length (vector-ref lenv 0))]) + (for ([v (in-vector lenv)]) + (unless (= len0 (length v)) + (raise-syntax-error 'template + "incomplatible ellipsis match counts for template" + stx))))) + +;; ---- + +(define current-template-metafunction-introducer + (make-parameter + (lambda (stx) + (if (syntax-transforming?) + (syntax-local-introduce stx) + 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 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) + (if (syntax? v) + v + (error/not-stx ctx v))) + +(define (error/not-stx ctx v) + (raise-syntax-error 'template "pattern variable is not syntax-valued" ctx)) + +(define (error/bad-index index) + (error 'template "internal error: bad index: ~e" index)) + +(define (vector-car/cdr! dest-v src-v) + (let ([len (vector-length dest-v)]) + (let loop ([i 0]) + (when (< i len) + (let ([p (vector-ref src-v i)]) + (vector-set! dest-v i (car p)) + (vector-set! src-v i (cdr p))) + (loop (add1 i)))))) + +(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)) diff --git a/collects/syntax/parse/experimental/template.rkt b/collects/syntax/parse/experimental/template.rkt index eae4b53219..321221617f 100644 --- a/collects/syntax/parse/experimental/template.rkt +++ b/collects/syntax/parse/experimental/template.rkt @@ -2,14 +2,10 @@ (require (for-syntax racket/base racket/set racket/syntax - racket/match - racket/private/sc - unstable/struct) - racket/match - racket/vector - syntax/stx + syntax/parse/private/minimatch + racket/private/sc) syntax/parse/private/residual - unstable/struct) + "private/substitute.rkt") (provide template define-template-metafunction ?? @@ -22,6 +18,7 @@ To do: (with-syntax ([(a ...) #'(1 2 3)] [((b ...) ...) #'((1 2 3) (4 5 6) (7 8 9))]) #'(((a b) ...) ...)) ;; a has depth 1, used at depth 2 +- support #hash templates, etc (check for other atomic & compound forms) |# #| @@ -71,6 +68,20 @@ A HeadTemplate (H) is one of: 'guide (vector var ...)))]))))]))) +;; 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)) + +(define (substitute stx g main-env) + (let ([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))) @@ -78,51 +89,16 @@ A HeadTemplate (H) is one of: ;; ============================================================ #| -A Guide (G) is one of: - - _ - - (G . G) - - integer - - #s(stxvector G) - - #s(stxstruct G) - - #&G - - #s(dots HG (vector-of integer) nat G) - - #s(app HG G) - - #s(escaped G) - - #s(orelse G (vector-of integer) G) - - #s(metafun integer G) - "optimized" forms: - - #s(sdots G integer G) ; simple head template, one driver, nesting=1 +See private/substitute for definition of Guide (G) and HeadGuide (HG). -A HeadGuide (HG) is one of: - - G - - #s(app-opt G (vector-of integer)) - - #s(splice G) +An env-entry is one of + - syntax-mapping (for pattern variables) + - template-metafunction -A Pre-Guide is like a Guide but with pvars and pvar sets instead of -integers and integer vectors. +A Pre-Guide is like a Guide but with env-entry and (setof env-entry) +instead of integers and integer vectors. |# -(define-syntax-rule (begin-both-phases form ...) - (begin (begin-for-syntax form ...) - (begin form ...))) - -(begin-both-phases - (struct stxvector (g) #:prefab) - (struct stxstruct (g) #:prefab) - (struct dots (head hdrivers nesting tail) #:prefab) - (struct app (head tail) #:prefab) - (struct escaped (body) #:prefab) - (struct orelse (g1 drivers1 g2) #:prefab) - (struct metafun (index g) #:prefab) - (struct app-opt (g drivers) #:prefab) - (struct splice (g) #:prefab) - - (struct sdots (head driver tail) #:prefab) - - (define (head-guide? x) - (or (app-opt? x) (splice? x))) - ) - ;; ============================================================ (define-syntax (define-template-metafunction stx) @@ -143,70 +119,73 @@ integers and integer vectors. (begin-for-syntax + ;; parse-template : stx -> (values guide (vectorof env-entry)) (define (parse-template t) - (let-values ([(_const? drivers pre-guide) (parse-t t 0 #f)]) - (define (set->env drivers) - (for/hash ([pvar (in-set drivers)] - [n (in-naturals 1)]) - (values pvar n))) + (let-values ([(drivers pre-guide) (parse-t t 0 #f)]) (define main-env (set->env drivers)) - (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))] - [(? syntax-pattern-variable? pvar) (get-index pvar)] - [(dots head hdrivers nesting tail) - (cond [(and (= nesting 1) - (= (set-count hdrivers) 1) - (not (head-guide? head))) - (let* ([pvar (for/first ([pvar (in-set hdrivers)]) pvar)] - [sub-loop-env (hash pvar 0)]) - (sdots (loop head sub-loop-env) - (get-index pvar) - (loop tail loop-env)))] - [else - (let* ([sub-loop-env (set->env hdrivers)] - [sub-loop-vector (index-hash->vector sub-loop-env get-index)]) - (dots (loop head sub-loop-env) - sub-loop-vector - nesting - (loop tail loop-env)))])] - [(app head tail) - (app (loop head loop-env) (loop tail loop-env))] - [(escaped g1) - (escaped (loop g1 loop-env))] - [(orelse g1 drivers1 g2) - (orelse (loop g1 loop-env) - (for/vector ([pvar (in-set drivers1)]) - (get-index pvar)) - (loop g2 loop-env))] - [(metafun mf g1) - (metafun (get-index mf) - (loop g1 loop-env))] - [(stxvector g1) - (stxvector (loop g1 loop-env))] - [(stxstruct g1) - (stxstruct (loop g1 loop-env))] - [(? box?) - (box (loop (unbox g) loop-env))] - [(app-opt g1 drivers1) - (app-opt (loop g1 loop-env) - (for/vector ([pvar (in-set drivers1)]) - (get-index pvar)))] - [(splice g1) - (splice (loop g1 loop-env))] - [else (error 'template "internal error: bad pre-guide: ~e" g)])) - (define guide (loop pre-guide #hash())) + (define guide (guide-resolve-env pre-guide main-env)) (values guide (index-hash->vector main-env)))) + ;; set->env : (setof env-entry) -> hash[env-entry => nat] + (define (set->env drivers) + (for/hash ([pvar (in-set drivers)] + [n (in-naturals 1)]) + (values 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))] + [(? syntax-pattern-variable? pvar) (get-index pvar)] + [(vector 'dots head hdrivers nesting tail) + (let* ([sub-loop-env (set->env hdrivers)] + [sub-loop-vector (index-hash->vector sub-loop-env get-index)]) + (vector 'dots + (loop head sub-loop-env) + sub-loop-vector + nesting + (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 drivers1 g2) + (vector 'orelse + (loop g1 loop-env) + (for/vector ([pvar (in-set drivers1)]) + (get-index pvar)) + (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 'app-opt g1 drivers1) + (vector 'app-opt + (loop g1 loop-env) + (for/vector ([pvar (in-set drivers1)]) + (get-index pvar)))] + [(vector 'splice g1) + (vector 'splice (loop g1 loop-env))] + [else (error 'template "internal error: bad pre-guide: ~e" g)])) + (loop g0 '#hash())) + ;; ---------------------------------------- + ;; parse-t : stx nat boolean -> (values (setof env-entry) pre-guide) (define (parse-t t depth esc?) (syntax-case t (?? ?@) [id @@ -219,34 +198,32 @@ integers and integer vectors. [else (let ([pvar (lookup #'id depth)]) (cond [(syntax-pattern-variable? pvar) - (values #f (set pvar) pvar)] + (values (set pvar) pvar)] [(template-metafunction? pvar) (wrong-syntax t "illegal use of syntax metafunction")] - [else (values #t (set) '_)]))])] + [else (values (set) '_)]))])] [atom (atom? (syntax-e #'atom)) - (values #t (set) '_)] + (values (set) '_)] [(mf . template) (and (not esc?) (identifier? #'mf) (template-metafunction? (lookup #'mf #f))) (let-values ([(mf) (lookup #'mf #f)] - [(const? drivers guide) (parse-t #'template depth esc?)]) - (values #f - (set-union (set mf) drivers) - (metafun mf guide)))] + [(drivers guide) (parse-t #'template depth esc?)]) + (values (set-union (set mf) drivers) + (vector 'metafun mf guide)))] [(DOTS template) (and (not esc?) (identifier? #'DOTS) (free-identifier=? #'DOTS (quote-syntax ...))) - (let-values ([(const? drivers guide) (parse-t #'template depth #t)]) - (values #f drivers (escaped guide)))] + (let-values ([(drivers guide) (parse-t #'template depth #t)]) + (values drivers (vector 'escaped guide)))] [(?? t1 t2) (not esc?) - (let-values ([(const1? drivers1 guide1) (parse-t #'t1 depth esc?)] - [(const2? drivers2 guide2) (parse-t #'t2 depth esc?)]) - (values #f - (set-union drivers1 drivers2) - (orelse guide1 (set-filter drivers1 syntax-pattern-variable?) guide2)))] + (let-values ([(drivers1 guide1) (parse-t #'t1 depth esc?)] + [(drivers2 guide2) (parse-t #'t2 depth esc?)]) + (values (set-union drivers1 drivers2) + (vector 'orelse guide1 (set-filter drivers1 syntax-pattern-variable?) guide2)))] [(head DOTS . tail) (and (not esc?) (identifier? #'DOTS) (free-identifier=? #'DOTS (quote-syntax ...))) @@ -257,48 +234,47 @@ integers and integer vectors. (and (identifier? #'DOTS) (free-identifier=? #'DOTS (quote-syntax ...))) (loop (add1 nesting) #'tail)] [else (values nesting tail)]))]) - (let-values ([(hconst? hdrivers _hsplice? hguide) (parse-h #'head (+ depth nesting) esc?)] - [(tconst? tdrivers tguide) (parse-t tail depth esc?)]) + (let-values ([(hdrivers _hsplice? hguide) (parse-h #'head (+ depth nesting) esc?)] + [(tdrivers tguide) (parse-t tail depth esc?)]) (unless (positive? (set-count hdrivers)) (wrong-syntax #'head "no pattern variables in term before ellipsis")) - (values #f - (set-union hdrivers tdrivers) - (dots hguide (set-filter hdrivers pvar/depth>0?) nesting tguide))))] + (values (set-union hdrivers tdrivers) + (vector 'dots hguide (set-filter hdrivers pvar/depth>0?) nesting tguide))))] [(head . tail) - (let-values ([(hconst? hdrivers hsplice? hguide) (parse-h #'head depth esc?)] - [(tconst? tdrivers tguide) (parse-t #'tail depth esc?)]) - (let ([const? (and hconst? tconst?)]) - (values const? - (set-union hdrivers tdrivers) - (cond [const? '_] - [hsplice? (app hguide tguide)] - [else (cons hguide tguide)]))))] + (let-values ([(hdrivers hsplice? hguide) (parse-h #'head depth esc?)] + [(tdrivers tguide) (parse-t #'tail depth esc?)]) + (values (set-union hdrivers tdrivers) + (cond [(and (eq? hguide '_) (eq? tguide '_)) '_] + [hsplice? (vector 'app hguide tguide)] + [else (cons hguide tguide)])))] [vec (vector? (syntax-e #'vec)) - (let-values ([(const? drivers guide) (parse-t (vector->list (syntax-e #'vec)) depth esc?)]) - (values const? drivers (if const? '_ (stxvector guide))))] + (let-values ([(drivers guide) (parse-t (vector->list (syntax-e #'vec)) depth esc?)]) + (values drivers (if (eq? guide '_) '_ (vector 'vector guide))))] [pstruct (prefab-struct-key (syntax-e #'pstruct)) - (let-values ([(const? drivers guide) (parse-t (struct->list (syntax-e #'pstruct)) depth esc?)]) - (values const? drivers (if const? '_ (stxstruct guide))))] + (let-values ([(drivers guide) + (parse-t (cdr (vector->list (struct->vector (syntax-e #'pstruct)))) depth esc?)]) + (values drivers (if (eq? guide '_) '_ (vector 'struct guide))))] [#&template - (let-values ([(const? drivers guide) (parse-t #'template depth esc?)]) - (values const? drivers (if const? '_ (box guide))))] - [_ (wrong-syntax t "bad pattern")])) + (let-values ([(drivers guide) (parse-t #'template depth esc?)]) + (values drivers (if (eq? guide '_) '_ (vector 'box guide))))] + [_ (wrong-syntax t "bad template")])) + ;; parse-h : stx nat boolean -> (values (setof env-entry) boolean pre-head-guide) (define (parse-h h depth esc?) (syntax-case h (?? ?@) [(?? t) (not esc?) - (let-values ([(const? drivers guide) (parse-t #'t depth esc?)]) - (values #f drivers #t (app-opt guide (set-filter drivers syntax-pattern-variable?))))] + (let-values ([(drivers guide) (parse-t #'t depth esc?)]) + (values drivers #t (vector 'app-opt guide (set-filter drivers syntax-pattern-variable?))))] [(?@ . t) (not esc?) - (let-values ([(const? drivers guide) (parse-t #'t depth esc?)]) - (values #f drivers #t (splice guide)))] + (let-values ([(drivers guide) (parse-t #'t depth esc?)]) + (values drivers #t (vector 'splice guide)))] [t - (let-values ([(const? drivers guide) (parse-t #'t depth esc?)]) - (values const? drivers #f guide))])) + (let-values ([(drivers guide) (parse-t #'t depth esc?)]) + (values drivers #f guide))])) (define (atom? x) (or (null? x) @@ -349,136 +325,4 @@ integers and integer vectors. (define (pvar/depth>0? x) (and (syntax-pattern-variable? x) (positive? (syntax-mapping-depth x)))) - ) - -;; ============================================================ - -(define (substitute stx g main-env) - (define (get index lenv) - (cond [(positive? index) - (vector-ref main-env (sub1 index))] - [(negative? index) - (vector-ref lenv (- -1 index))] - [(zero? index) lenv])) - (define (loop stx g lenv) - (match g - ['_ stx] - [(cons g1 g2) - (restx stx (cons (loop (stx-car stx) g1 lenv) (loop (stx-cdr stx) g2 lenv)))] - [(? exact-integer? index) - (let ([v (get index lenv)]) - (if (syntax? v) - v - (error/not-stx stx v)))] - [(sdots ghead loop-var gtail) - (let ([lenv* (get loop-var lenv)]) - (unless lenv* (error 'template "pattern variable used in ellipsis pattern is not defined")) - (restx stx - (if (equal? ghead '0) ;; pattern was just (pvar ... . T) - (append lenv* (loop (stx-cddr stx) gtail lenv)) - (let ([head-stx (stx-car stx)]) - (let dotsloop ([lenv* lenv*]) - (if (null? lenv*) - (loop (stx-cddr stx) gtail lenv) - (cons (loop head-stx ghead (car lenv*)) - (dotsloop (cdr lenv*)))))))))] - [(dots ghead henv nesting gtail) - (define head-stx (stx-car stx)) - (define (nestloop lenv* nesting) - (cond [(zero? nesting) - (loop-h head-stx ghead lenv*)] - [else - (for ([v (in-vector lenv*)]) - (unless v (error 'template "pattern variable used in ellipsis pattern is not defined"))) - (let ([len0 (length (vector-ref lenv* 0))]) - (for ([v (in-vector lenv*)]) - (unless (= len0 (length v)) - (raise-syntax-error 'template - "incomplatible ellipsis match counts for template" - stx))) - (let dotsloop ([len0 len0] [lenv* lenv*]) - (if (zero? len0) - null - (let ([lenv** (vector-map car lenv*)]) - (cons (nestloop lenv** (sub1 nesting)) - (dotsloop (sub1 len0) (vector-map! cdr lenv*)))))))])) - (let ([head-results ;; (listof^nesting (listof stx)) -- extra listof for loop-h - (nestloop (vector-map (lambda (index) (get index lenv)) henv) nesting)] - [tail-result (loop (stx-drop nesting (stx-cdr stx)) gtail lenv)]) - (restx stx (deep-append head-results nesting tail-result)))] - [(app ghead gtail) - (restx stx (append (loop-h (stx-car stx) ghead lenv) - (loop (stx-cdr stx) gtail lenv)))] - [(escaped g1) - (loop (stx-cadr stx) g1 lenv)] - [(orelse g1 drivers1 g2) - (if (for/and ([index (in-vector drivers1)]) (get index lenv)) - (loop (stx-cadr stx) g1 lenv) - (loop (stx-caddr stx) g2 lenv))] - [(metafun index g1) - (let ([v (restx stx (cons (stx-car stx) (loop (stx-cdr stx) g1 lenv)))] - [mark (make-syntax-introducer)] - [old-mark (current-template-metafunction-introducer)] - [mf (get index lenv)]) - (parameterize ((current-template-metafunction-introducer mark)) - (let ([r (mf (mark (old-mark v)))]) - (unless (syntax? r) - (raise-syntax-error 'template "result of metafunction was not syntax" stx)) - (restx stx (old-mark (mark r))))))] - [(stxvector g1) - (restx stx (list->vector (loop (vector->list (syntax-e stx)) g1 lenv)))] - [(stxstruct g1) - (let ([s (syntax-e stx)]) - (restx stx (apply make-prefab-struct - (prefab-struct-key s) - (loop (struct->list s) g1 lenv))))] - [(box g1) - (restx stx (box (loop (unbox (syntax-e stx)) g1 lenv)))])) - (define (loop-h stx hg lenv) - (match hg - [(app-opt g1 drivers1) - (if (for/and ([index (in-vector drivers1)]) (get index lenv)) - (list (loop (stx-cadr stx) g1 lenv)) - null)] - [(splice g1) - (let* ([v (loop (stx-cdr stx) g1 lenv)] - [v* (stx->list v)]) - (unless v* - (raise-syntax-error 'template - "splicing template did not produce a syntax list" - stx)) - v*)] - [else (list (loop stx hg lenv))])) - (loop stx g #f)) - -(define current-template-metafunction-introducer - (make-parameter - (lambda (stx) - (if (syntax-transforming?) - (syntax-local-introduce stx) - 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 basis) - val)) - -;; deep-append : (listof^(nesting+1) A) nat (listof A) -> (listof A) -;; (Actually, in practice onto is stx, so this is an improper append.) -(define (deep-append lst nesting onto) - (cond [(null? lst) onto] - [(zero? nesting) (append lst onto)] - [else (deep-append (car lst) (sub1 nesting) - (deep-append (cdr lst) nesting onto))])) - -(define (error/not-stx stx val) - (raise-syntax-error 'template "pattern variable is not syntax-valued" stx)) diff --git a/collects/syntax/parse/private/minimatch.rkt b/collects/syntax/parse/private/minimatch.rkt index 34c4f4aff4..fc1396455d 100644 --- a/collects/syntax/parse/private/minimatch.rkt +++ b/collects/syntax/parse/private/minimatch.rkt @@ -25,7 +25,7 @@ ;; (match-p id Pattern SuccessExpr FailureExpr) (define-syntax (match-p stx) - (syntax-case stx (quote cons list make struct ?) + (syntax-case stx (quote cons list vector make struct ?) [(match-p x wildcard success failure) (and (identifier? #'wildcard) (free-identifier=? #'wildcard #'_)) #'success] @@ -43,6 +43,11 @@ #'(match-p x (quote ()) success failure)] [(match-p x (list p1 p ...) success failure) #'(match-p x (cons p1 (list p ...)) success failure)] + [(match-p x (vector p ...) success failure) + #'(if (and (vector? x) (= (vector-length x) (length '(p ...)))) + (let ([x* (vector->list x)]) + (match-p x* (list p ...) success failure)) + failure)] [(match-p x var success failure) (identifier? #'var) #'(let ([var x]) success)] diff --git a/collects/tests/stxparse/stress-template.rkt b/collects/tests/stxparse/stress-template.rkt new file mode 100644 index 0000000000..6d7a2272d4 --- /dev/null +++ b/collects/tests/stxparse/stress-template.rkt @@ -0,0 +1,77 @@ +#lang racket/base +(require syntax/parse/experimental/template) +(provide (all-defined-out)) + +(define (f1-stx stx) + (syntax-case stx () + [(_ body) + #'(discard-exn body #f)] + [(_ body on-exn) + #'(with-handlers ([not-break-exn? (lambda (_) on-exn)]) + body)])) + +(define (f1-tmpl stx) + (syntax-case stx () + [(_ body) + (template (discard-exn body #f))] + [(_ body on-exn) + (template (with-handlers ([not-break-exn? (lambda (_) on-exn)]) + body))])) + +(define (f2-stx stx) + (syntax-case stx () + [(_ (x ...) (y ...) z) + #'((x z) ... ((y x) ... z))])) + +(define (f2-tmpl stx) + (syntax-case stx () + [(_ (x ...) (y ...) z) + (template ((x z) ... ((y x) ... z)))])) + +(define (f3-stx stx) + (syntax-case stx () + [(_ (x ...) (y ...) z) + #'((x 1) ... ((y 2) ... z))])) + +(define (f3-tmpl stx) + (syntax-case stx () + [(_ (x ...) (y ...) z) + (template ((x 1) ... ((y 2) ... z)))])) + +(define (test f term) + (collect-garbage) + (time (void (for ([i #e1e5]) (f term))))) + +(define stx2a + #`(_ + #,(for/list ([i 10]) i) + #,(for/list ([i 10]) 'a) + z)) + +(define stx2 + #`(_ + #,(for/list ([i 100]) i) + #,(for/list ([i 100]) 'a) + z)) + +(define prog + '((test f1-stx #'(_ e)) + (test f1-tmpl #'(_ e)) + + (test f2-stx stx2a) + (test f2-tmpl stx2a) + + (test f2-stx stx2) + (test f2-tmpl stx2) + + (test f3-stx stx2a) + (test f3-tmpl stx2a) + + (test f3-stx stx2) + (test f3-tmpl stx2))) + +(define-namespace-anchor nsa) + +(for ([p prog]) + (printf "> ~s\n" p) + (eval p (namespace-anchor->namespace nsa)))