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
This commit is contained in:
Ryan Culpepper
parent
f77467311a
commit
6c369f2563
297
collects/syntax/parse/experimental/private/substitute.rkt
Normal file
297
collects/syntax/parse/experimental/private/substitute.rkt
Normal file
|
|
@ -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))
|
||||
|
|
@ -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))
|
||||
|
|
|
|||
|
|
@ -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)]
|
||||
|
|
|
|||
77
collects/tests/stxparse/stress-template.rkt
Normal file
77
collects/tests/stxparse/stress-template.rkt
Normal file
|
|
@ -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)))
|
||||
Loading…
Reference in New Issue
Block a user