syntax/parse template: change run-time strategy

Instead of doing run-time interpretation of a "guide" tree,
generate code for procedure (using stx -> stx combinators).
This commit is contained in:
Ryan Culpepper 2017-08-08 23:08:48 -04:00
parent d8b80d7e1d
commit ca38b89ae6
2 changed files with 265 additions and 597 deletions

View File

@ -1,460 +0,0 @@
#lang racket/base
(require syntax/parse/private/minimatch
racket/private/promise
racket/private/stx) ;; syntax/stx
(provide translate)
#|
;; 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 '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
(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))
(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 '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 (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)
(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))

View File

@ -6,7 +6,8 @@
racket/private/stx ;; syntax/stx
racket/private/sc)
syntax/parse/private/residual
"private/substitute.rkt")
racket/private/stx
racket/private/promise)
(provide template
template/loc
quasitemplate
@ -43,39 +44,35 @@ A HeadTemplate (H) is one of:
(begin-for-syntax
(define-logger template)
;; do-template : Syntax Syntax Boolean Id/#f -> 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) (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)
(car vars)]
[(equal? guide '_)
#'(quote-syntax t)]
[else
(with-syntax ([guide 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)
'guide
vars-vector)))]))))))))
(parameterize ((current-syntax-context ctx)
(quasi (and quasi? (box null))))
(define-values (guide pvars) (parse-template tstx loc-id))
(define env (make-env pvars (hash)))
(syntax-arm
(with-syntax ([t tstx]
[((var . pvar-val-var) ...)
(for/list ([pvar (in-list pvars)])
(cons (hash-ref env pvar) (pvar-var pvar)))]
[((un-var . un-form) ...)
(if quasi? (reverse (unbox (quasi))) null)])
#`(let ([un-var (handle-unsyntax un-form)] ... [var pvar-val-var] ...)
(let ([tstx0 (quote-syntax t)])
(#,(compile-guide guide env) tstx0))))))))
;; parse-template : Syntax Id/#f -> (values Guide (Listof PVar))
(define (parse-template t loc-id)
(define-values (drivers pre-guide) (parse-t t 0 #f))
(define guide (if loc-id (relocate-guide pre-guide loc-id) pre-guide))
(values guide (dset->list drivers)))
;; make-env : (Listof PVar) Hash[Pvar => Identifier] -> Hash[PVar => Identifier]
(define (make-env pvars init-env)
(for/fold ([env init-env]) ([pvar (in-list pvars)])
(hash-set env pvar (car (generate-temporaries #'(pv_))))))
)
(define-syntax (template stx)
(syntax-case stx ()
@ -92,7 +89,6 @@ A HeadTemplate (H) is one of:
(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)
@ -112,20 +108,8 @@ A HeadTemplate (H) is one of:
;; 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))
(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)))
[(handle-unsyntax (unsyntax expr)) expr]
[(handle-unsyntax (unsyntax-splicing expr)) expr]))
;; ----
@ -138,9 +122,7 @@ A HeadTemplate (H) is one of:
#|
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
A env-entry is (pvar syntax-mapping attribute-mapping/#f depth-delta)
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
@ -191,96 +173,103 @@ instead of integers and integer vectors.
(begin-for-syntax
;; 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))
(define (parse-template t loc-id)
(let*-values ([(drivers pre-guide) (parse-t t 0 #f)]
[(drivers pre-guide)
(if loc-id
(let* ([loc-sm (make-syntax-mapping 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)))))
;; 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))))
;; compile-guide : guide hash[env-entry => identifier] -> syntax[expr]
(define (compile-guide g env)
(define (lookup var) (hash-ref env var))
(define (compile-t g in-try?)
(define (loop g) (compile-t g in-try?))
(define (loop-h g) (compile-h g in-try?))
(match g
['_ '_]
[(cons g1 g2)
(cons (loop g1 loop-env) (loop g2 loop-env))]
['_
#`(t-const)]
[(? 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))))]
#`(t-check #,(lookup pvar) '#,in-try?)
#`(t-var #,(lookup pvar)))]
[(cons g1 g2)
#`(t-cons #,(loop g1) #,(loop g2))]
[(vector 'dots head new-driverss nesting '#f tail)
(let ()
(define cons? (not (head-guide? head)))
;; AccElem = Stx if cons? is true, (Listof Stx) otherwise
;; gen-level : (Listof PVar) Syntax[(Listof AccElem) -> (Listof AccElem)]
;; -> Syntax[(Listof AccElem) -> (Listof AccElem)]
(define (gen-level vars inner)
(with-syntax ([(var ...) (map lookup vars)]
[(var-value ...) (map var-value-expr vars)])
#`(lambda (acc)
(let loop ([acc acc] [var var-value] ...)
(check-same-length var ...)
(if (and (pair? var) ...)
(loop (let ([var (car var)] ...)
(#,inner acc)) ;; inner has free refs to {var ...}
(cdr var) ...)
acc)))))
;; var-value-expr : PVar -> Syntax[List]
(define (var-value-expr pvar)
(with-syntax ([var (lookup pvar)])
(if (pvar-check? pvar)
#`(check-list/depth stx var 1 '#,in-try?)
#'var)))
(define head-loop-code
(let nestloop ([new-driverss new-driverss] [old-drivers null])
(cond [(null? new-driverss)
(if cons?
#`(lambda (acc) (cons (#,(loop head) stx) acc))
#`(lambda (acc) (cons (#,(loop-h head) stx) acc)))]
[else
(define drivers (append (car new-driverss) old-drivers))
(gen-level drivers (nestloop (cdr new-driverss) drivers))])))
(if cons?
#`(t-dots1 (lambda (stx) (#,head-loop-code null)) '#,nesting #,(loop tail))
#`(t-dots (lambda (stx) (#,head-loop-code null)) '#,nesting #,(loop tail))))]
[(vector 'app head tail)
(vector 'app (loop head loop-env) (loop tail loop-env))]
(if (head-guide? head)
#`(t-app #,(loop-h head) #,(loop tail))
#`(t-cons #,(loop head) #,(loop tail)))]
[(vector 'escaped g1)
(vector 'escaped (loop g1 loop-env))]
#`(t-escaped #,(loop g1))]
[(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))]
#`(t-orelse #,(compile-t g1 #t) #,(loop g2))]
[(vector 'metafun mf g1)
(vector 'metafun
(get-index mf)
(loop g1 loop-env))]
#`(t-metafun #,(template-metafunction-var mf) #,(loop g1))]
[(vector 'vector g1)
(vector 'vector (loop g1 loop-env))]
#`(t-vector #,(loop g1))]
[(vector 'struct g1)
(vector 'struct (loop g1 loop-env))]
#`(t-struct #,(loop g1))]
[(vector 'box g1)
(vector 'box (loop (unbox g) loop-env))]
[(vector 'app-opt g1)
(vector 'app-opt (loop g1 loop-env))]
[(vector 'splice g1)
(vector 'splice (loop g1 loop-env))]
#`(t-box #,(loop g1))]
[(vector 'unsyntax var)
(vector 'unsyntax (get-index var))]
[(vector 'unsyntax-splicing var)
(vector 'unsyntax-splicing (get-index var))]
#`(t-unsyntax #,var)]
[(vector 'relocate g1 var)
(vector 'relocate (loop g1 loop-env) (get-index var))]
#`(t-relocate #,(loop g1) #,var)]
[else (error 'template "internal error: bad pre-guide: ~e" g)]))
(loop g0 '#hash()))
(define (compile-h g in-try?)
(define (loop g) (compile-t g in-try?))
(define (loop-h g) (compile-h g in-try?))
(match g
[(vector 'orelse-h1 g1)
#`(t-orelse-h1 #,(compile-h g1 #t))]
[(vector 'orelse-h g1 g2)
#`(t-orelse #,(compile-h g1 #t) #,(loop-h g2))]
[(vector 'splice g1)
#`(t-splice #,(loop g1))]
[(vector 'unsyntax-splicing var)
#`(t-unsyntax-splicing #,var)]
[else #`(t-h #,(loop g))]))
(compile-t g #f))
(define (head-guide? x)
(match x
[(vector 'orelse-h1 g) #t]
[(vector 'splice g) #t]
[(vector 'orelse-h g1 g2) #t]
[(vector 'unsyntax-splicing var) #t]
[_ #f]))
;; ----------------------------------------
;; relocate-gude : stx guide -> guide
;; relocate-guide : guide pvar -> guide
(define (relocate-guide g0 loc-pvar)
(define (relocate g)
(vector 'relocate g loc-pvar))
@ -323,7 +312,7 @@ instead of integers and integer vectors.
(error/no-relocate)]
[(vector 'metafun mf g1)
(error/no-relocate)]
[(vector 'app-opt g1)
[(vector 'orelse-h1 g1)
(error/no-relocate)]
[(vector 'splice g1)
(error/no-relocate)]
@ -334,6 +323,11 @@ instead of integers and integer vectors.
;; ----------------------------------------
;; 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))
(define (cons-guide g1 g2)
(if (and (eq? g1 '_) (eq? g2 '_)) '_ (cons g1 g2)))
@ -367,16 +361,14 @@ instead of integers and integer vectors.
(template-metafunction? (lookup #'mf #f)))
(let-values ([(mf) (lookup #'mf #f)]
[(drivers guide) (parse-t #'template depth esc?)])
(values (dset-add drivers mf) (vector 'metafun mf guide)))]
(values drivers (vector 'metafun mf 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-syntax-mapping 0 #'tmp)]
[fake-pvar (pvar fake-sm #f #f)])
(values (dset fake-pvar) (vector 'unsyntax fake-pvar))))]
(values (dset) (vector 'unsyntax #'tmp)))]
[else
(parameterize ((quasi (car qval)))
(let-values ([(drivers guide) (parse-t #'t1 depth esc?)])
@ -429,7 +421,7 @@ instead of integers and integer vectors.
(let loop ([raw hdrivers/level] [last (dset)])
(cond [(null? raw) null]
[else
(cons (dset-subtract (car raw) last)
(cons (dset->list (dset-subtract (car raw) last))
(loop (cdr raw) (car raw)))]))])
(vector 'dots hguide new-hdrivers/level nesting #f tguide)))))]
[(head . tail)
@ -465,7 +457,7 @@ instead of integers and integer vectors.
(not esc?)
(let-values ([(drivers splice? guide)
(parse-h #'t depth esc?)])
(values drivers #t (vector 'app-opt guide)))]
(values drivers #t (vector 'orelse-h1 guide)))]
[(?? t1 t2)
(not esc?)
(let-values ([(drivers1 splice?1 guide1) (parse-h #'t1 depth esc?)]
@ -484,9 +476,7 @@ instead of integers and integer vectors.
(cond [(box? qval)
(with-syntax ([(tmp) (generate-temporaries #'(unsyntax-splicing-expr))])
(set-box! qval (cons (cons #'tmp h) (unbox qval)))
(let* ([fake-sm (make-syntax-mapping 0 #'tmp)]
[fake-pvar (pvar fake-sm #f #f)])
(values (dset fake-pvar) #t (vector 'unsyntax-splicing fake-pvar))))]
(values (dset) #t (vector 'unsyntax-splicing #'tmp)))]
[else
(parameterize ((quasi (car qval)))
(let*-values ([(drivers guide) (parse-t #'t1 depth esc?)]
@ -550,7 +540,145 @@ instead of integers and integer vectors.
[(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))]))
(define (stx-drop n x) (for/fold ([x x]) ([i (in-range n)]) (stx-cdr x)))
)
;; ============================================================
#|
A Guide (G) is one of:
- '_
- VarRef ;; no syntax check
- (cons G G)
- (vector 'vector G)
- (vector 'struct G)
- (vector 'box G)
- (vector 'dots HG (listof (listof VarRef)) nat (listof nat) G)
- (vector 'app HG G)
- (vector 'escaped G)
- (vector 'orelse G G)
- (vector 'metafun integer G)
- (vector 'unsyntax Id)
- (vector 'relocate G)
A HeadGuide (HG) is one of:
- G
- (vector 'orelse-h1 H)
- (vector 'orelse-h H H)
- (vector 'splice G)
- (vector 'unsyntax-splicing Id)
A VarRef is an identifier.
|#
(define ((t-const) stx) stx)
(define ((t-var v) stx) v)
(define ((t-check v in-try?) stx) (check-stx stx v in-try?))
(define ((t-app h t) stx) (restx stx (append (h (stx-car stx)) (t (stx-cdr stx)))))
(define ((t-cons h t) stx) (restx stx (cons (h (stx-car stx)) (t (stx-cdr stx)))))
(define ((t-cons* h t) stx) (cons (h (car stx)) (t (cdr stx))))
(define ((t-dots h n t) stx)
(restx stx (revappend* (h (stx-car stx)) (t (stx-drop (add1 n) stx)))))
(define ((t-dots1 h n t) stx)
(restx stx (revappend (h (stx-car stx)) (t (stx-drop (add1 n) stx)))))
(define ((t-escaped g) stx) (g (stx-cadr stx)))
(define ((t-orelse g1 g2) stx)
(with-handlers ([absent-pvar? (lambda (e) (g2 (stx-caddr stx)))])
(g1 (stx-cadr stx))))
(define ((t-metafun mf g) stx)
(define v (restx stx (cons (stx-car stx) (g (stx-cdr stx)))))
(define mark (make-syntax-introducer))
(define old-mark (current-template-metafunction-introducer))
(parameterize ((current-template-metafunction-introducer mark))
(define 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))
(old-mark (mark r))))
(define ((t-vector g) stx) (restx stx (list->vector (g (vector->list (syntax-e stx))))))
(define ((t-struct g) stx)
(define s (syntax-e stx))
(define key (prefab-struct-key s))
(define elems (cdr (vector->list (struct->vector s))))
(restx stx (apply make-prefab-struct key (g elems))))
(define ((t-box g) stx) (restx stx (box (g (unbox (syntax-e stx))))))
(define ((t-h g) stx) (list (g stx)))
(define ((t-orelse-h1 g) stx)
(with-handlers ([absent-pvar? (lambda (e) null)])
(g (stx-cadr stx))))
(define ((t-splice g) stx)
(let ([r (g (stx-cdr stx))])
(or (stx->list r)
(raise-syntax-error 'template "splicing template did not produce a syntax list" stx))))
(define ((t-unsyntax v) stx) (restx stx v))
(define ((t-unsyntax-splicing v) stx) (stx->list v))
(define ((t-relocate g loc) stx)
(define new-stx (g stx))
(datum->syntax new-stx (syntax-e new-stx) loc new-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) (for/fold ([x x]) ([i (in-range n)]) (stx-cdr x)))
(define (restx basis val)
(if (syntax? basis) (datum->syntax basis val basis basis) val))
;; revappend* : (Listof (Listof X)) (Listof X) -> (Listof X)
(define (revappend* xss ys)
(if (null? xss) ys (revappend* (cdr xss) (append (car xss) ys))))
;; revappend : (Listof X) (Listof X) -> (Listof X)
(define (revappend xs ys)
(if (null? xs) ys (revappend (cdr xs) (cons (car xs) ys))))
(define current-template-metafunction-introducer
(make-parameter (lambda (stx) (if (syntax-transforming?) (syntax-local-introduce stx) stx))))
;; Used to indicate absent pvar in template; ?? catches
;; Note: not an exn, don't need continuation marks
(struct absent-pvar (ctx))
(define (check-stx ctx v in-try?)
(cond [(syntax? v) v]
[(promise? v) (check-stx ctx (force v) in-try?)]
[(and in-try? (eq? v #f)) (raise (absent-pvar ctx))]
[else (err/not-syntax ctx v)]))
(define (check-list/depth ctx v0 depth0 in-try?)
(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))]
[(and in-try? (eq? v #f))
(raise (absent-pvar ctx))]
[else (err/not-syntax ctx v0)]))])))
;; FIXME: use raise-syntax-error instead, pass stx args
(define check-same-length
(case-lambda
[(a) (void)]
[(a b)
(unless (= (length a) (length b))
(error 'syntax "incompatible ellipsis match counts for template"))]
[(a . bs)
(define alen (length a))
(for ([b (in-list bs)])
(unless (= alen (length b))
(error 'template "incompatible ellipsis match counts for template")))]))
;; 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))