suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

syntax/parse template: change run-time strategy

Browse Source 
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
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

460
racket/collects/syntax/parse/experimental/private/substitute.rkt
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))

402
racket/collects/syntax/parse/experimental/template.rkt
View File

@ -6,7 +6,8 @@
racket/private/stx ;; syntax/stx racket/private/stx ;; syntax/stx
racket/private/sc) racket/private/sc)
syntax/parse/private/residual syntax/parse/private/residual
"private/substitute.rkt") racket/private/stx
racket/private/promise)
(provide template (provide template
template/loc template/loc
quasitemplate quasitemplate
@ -43,39 +44,35 @@ A HeadTemplate (H) is one of:
(begin-for-syntax (begin-for-syntax
(define-logger template) (define-logger template)
;; do-template : Syntax Syntax Boolean Id/#f -> Syntax
(define (do-template ctx tstx quasi? loc-id) (define (do-template ctx tstx quasi? loc-id)
(with-disappeared-uses (with-disappeared-uses
(parameterize ((current-syntax-context ctx) (parameterize ((current-syntax-context ctx)
(quasi (and quasi? (box null)))) (quasi (and quasi? (box null))))
(let*-values ([(guide deps) (parse-template tstx loc-id)] (define-values (guide pvars) (parse-template tstx loc-id))
[(vars) (define env (make-env pvars (hash)))
(for/list ([dep (in-vector deps)]) (syntax-arm
(cond [(pvar? dep) (pvar-var dep)] (with-syntax ([t tstx]
[(template-metafunction? dep) [((var . pvar-val-var) ...)
(template-metafunction-var dep)] (for/list ([pvar (in-list pvars)])
[else (cons (hash-ref env pvar) (pvar-var pvar)))]
(error 'template [((un-var . un-form) ...)
"internal error: bad environment entry: ~e" (if quasi? (reverse (unbox (quasi))) null)])
dep)]))]) #`(let ([un-var (handle-unsyntax un-form)] ... [var pvar-val-var] ...)
(with-syntax ([t tstx]) (let ([tstx0 (quote-syntax t)])
(syntax-arm (#,(compile-guide guide env) tstx0))))))))
(cond [(equal? guide '1)
;; was (template pvar) ;; parse-template : Syntax Id/#f -> (values Guide (Listof PVar))
(car vars)] (define (parse-template t loc-id)
[(equal? guide '_) (define-values (drivers pre-guide) (parse-t t 0 #f))
#'(quote-syntax t)] (define guide (if loc-id (relocate-guide pre-guide loc-id) pre-guide))
[else (values guide (dset->list drivers)))
(with-syntax ([guide guide]
[vars-vector ;; make-env : (Listof PVar) Hash[Pvar => Identifier] -> Hash[PVar => Identifier]
(if (pair? vars) (define (make-env pvars init-env)
#`(vector . #,vars) (for/fold ([env init-env]) ([pvar (in-list pvars)])
#''#())] (hash-set env pvar (car (generate-temporaries #'(pv_))))))
[((un-var . un-form) ...) )
(if quasi? (reverse (unbox (quasi))) null)])
#'(let ([un-var (handle-unsyntax un-form)] ...)
(substitute (quote-syntax t)
'guide
vars-vector)))]))))))))
(define-syntax (template stx) (define-syntax (template stx)
(syntax-case stx () (syntax-case stx ()
@ -92,7 +89,6 @@ A HeadTemplate (H) is one of:
(do-template stx #'t #t #f)])) (do-template stx #'t #t #f)]))
(define-syntaxes (template/loc quasitemplate/loc) (define-syntaxes (template/loc quasitemplate/loc)
;; FIXME: better to replace unsyntax form, shrink template syntax constant
(let ([make-tx (let ([make-tx
(lambda (quasi?) (lambda (quasi?)
(lambda (stx) (lambda (stx)
@ -112,20 +108,8 @@ A HeadTemplate (H) is one of:
;; FIXME: what lexical context should result of expr get if not syntax? ;; FIXME: what lexical context should result of expr get if not syntax?
(define-syntax handle-unsyntax (define-syntax handle-unsyntax
(syntax-rules (unsyntax unsyntax-splicing) (syntax-rules (unsyntax unsyntax-splicing)
[(handle-syntax (unsyntax expr)) expr] [(handle-unsyntax (unsyntax expr)) expr]
[(handle-syntax (unsyntax-splicing expr)) expr])) [(handle-unsyntax (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)))
;; ---- ;; ----
@ -138,9 +122,7 @@ A HeadTemplate (H) is one of:
#| #|
See private/substitute for definition of Guide (G) and HeadGuide (HG). See private/substitute for definition of Guide (G) and HeadGuide (HG).
A env-entry is one of A env-entry is (pvar syntax-mapping attribute-mapping/#f depth-delta)
- (pvar syntax-mapping attribute-mapping/#f depth-delta)
- template-metafunction
The depth-delta associated with a depth>0 pattern variable is the difference 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 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 (begin-for-syntax
;; quasi : (parameterof (or/c #f (list^n (boxof QuasiPairs)))) ;; compile-guide : guide hash[env-entry => identifier] -> syntax[expr]
;; each list wrapper represents nested quasi wrapping (define (compile-guide g env)
;; QuasiPairs = (listof (cons/c identifier syntax)) (define (lookup var) (hash-ref env var))
(define quasi (make-parameter #f)) (define (compile-t g in-try?)
(define (loop g) (compile-t g in-try?))
;; parse-template : stx id/#f -> (values guide (vectorof env-entry)) (define (loop-h g) (compile-h g in-try?))
(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))))
(match g (match g
['_ '_] ['_
[(cons g1 g2) #`(t-const)]
(cons (loop g1 loop-env) (loop g2 loop-env))]
[(? pvar? pvar) [(? pvar? pvar)
(if (pvar-check? pvar) (if (pvar-check? pvar)
(vector 'check (get-index pvar)) #`(t-check #,(lookup pvar) '#,in-try?)
(get-index pvar))] #`(t-var #,(lookup pvar)))]
[(vector 'dots head new-hdrivers/level nesting '#f tail) [(cons g1 g2)
(let-values ([(sub-loop-env r-uptos) #`(t-cons #,(loop g1) #,(loop g2))]
(for/fold ([env (hash)] [r-uptos null]) [(vector 'dots head new-driverss nesting '#f tail)
([new-hdrivers (in-list new-hdrivers/level)]) (let ()
(let ([new-env (dset->env new-hdrivers env)]) (define cons? (not (head-guide? head)))
(values new-env (cons (hash-count new-env) r-uptos))))]) ;; AccElem = Stx if cons? is true, (Listof Stx) otherwise
(let ([sub-loop-vector (index-hash->vector sub-loop-env get-index)]) ;; gen-level : (Listof PVar) Syntax[(Listof AccElem) -> (Listof AccElem)]
(vector 'dots ;; -> Syntax[(Listof AccElem) -> (Listof AccElem)]
(loop head sub-loop-env) (define (gen-level vars inner)
sub-loop-vector (with-syntax ([(var ...) (map lookup vars)]
nesting [(var-value ...) (map var-value-expr vars)])
(reverse r-uptos) #`(lambda (acc)
(loop tail loop-env))))] (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 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 g1)
(vector 'escaped (loop g1 loop-env))] #`(t-escaped #,(loop g1))]
[(vector 'orelse g1 g2) [(vector 'orelse g1 g2)
(vector 'orelse (loop g1 loop-env) (loop g2 loop-env))] #`(t-orelse #,(compile-t g1 #t) #,(loop g2))]
[(vector 'orelse-h g1 g2)
(vector 'orelse-h (loop g1 loop-env) (loop g2 loop-env))]
[(vector 'metafun mf g1) [(vector 'metafun mf g1)
(vector 'metafun #`(t-metafun #,(template-metafunction-var mf) #,(loop g1))]
(get-index mf)
(loop g1 loop-env))]
[(vector 'vector g1) [(vector 'vector g1)
(vector 'vector (loop g1 loop-env))] #`(t-vector #,(loop g1))]
[(vector 'struct g1) [(vector 'struct g1)
(vector 'struct (loop g1 loop-env))] #`(t-struct #,(loop g1))]
[(vector 'box g1) [(vector 'box g1)
(vector 'box (loop (unbox g) loop-env))] #`(t-box #,(loop g1))]
[(vector 'app-opt g1)
(vector 'app-opt (loop g1 loop-env))]
[(vector 'splice g1)
(vector 'splice (loop g1 loop-env))]
[(vector 'unsyntax var) [(vector 'unsyntax var)
(vector 'unsyntax (get-index var))] #`(t-unsyntax #,var)]
[(vector 'unsyntax-splicing var)
(vector 'unsyntax-splicing (get-index var))]
[(vector 'relocate g1 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)])) [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-guide g0 loc-pvar)
(define (relocate g) (define (relocate g)
(vector 'relocate g loc-pvar)) (vector 'relocate g loc-pvar))
@ -323,7 +312,7 @@ instead of integers and integer vectors.
(error/no-relocate)] (error/no-relocate)]
[(vector 'metafun mf g1) [(vector 'metafun mf g1)
(error/no-relocate)] (error/no-relocate)]
[(vector 'app-opt g1) [(vector 'orelse-h1 g1)
(error/no-relocate)] (error/no-relocate)]
[(vector 'splice g1) [(vector 'splice g1)
(error/no-relocate)] (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) (define (cons-guide g1 g2)
(if (and (eq? g1 '_) (eq? g2 '_)) '_ (cons 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))) (template-metafunction? (lookup #'mf #f)))
(let-values ([(mf) (lookup #'mf #f)] (let-values ([(mf) (lookup #'mf #f)]
[(drivers guide) (parse-t #'template depth esc?)]) [(drivers guide) (parse-t #'template depth esc?)])
(values (dset-add drivers mf) (vector 'metafun mf guide)))] (values drivers (vector 'metafun mf guide)))]
[(unsyntax t1) [(unsyntax t1)
(quasi) (quasi)
(let ([qval (quasi)]) (let ([qval (quasi)])
(cond [(box? qval) (cond [(box? qval)
(with-syntax ([(tmp) (generate-temporaries #'(unsyntax-expr))]) (with-syntax ([(tmp) (generate-temporaries #'(unsyntax-expr))])
(set-box! qval (cons (cons #'tmp t) (unbox qval))) (set-box! qval (cons (cons #'tmp t) (unbox qval)))
(let* ([fake-sm (make-syntax-mapping 0 #'tmp)] (values (dset) (vector 'unsyntax #'tmp)))]
[fake-pvar (pvar fake-sm #f #f)])
(values (dset fake-pvar) (vector 'unsyntax fake-pvar))))]
[else [else
(parameterize ((quasi (car qval))) (parameterize ((quasi (car qval)))
(let-values ([(drivers guide) (parse-t #'t1 depth esc?)]) (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)]) (let loop ([raw hdrivers/level] [last (dset)])
(cond [(null? raw) null] (cond [(null? raw) null]
[else [else
(cons (dset-subtract (car raw) last) (cons (dset->list (dset-subtract (car raw) last))
(loop (cdr raw) (car raw)))]))]) (loop (cdr raw) (car raw)))]))])
(vector 'dots hguide new-hdrivers/level nesting #f tguide)))))] (vector 'dots hguide new-hdrivers/level nesting #f tguide)))))]
[(head . tail) [(head . tail)
@ -465,7 +457,7 @@ instead of integers and integer vectors.
(not esc?) (not esc?)
(let-values ([(drivers splice? guide) (let-values ([(drivers splice? guide)
(parse-h #'t depth esc?)]) (parse-h #'t depth esc?)])
(values drivers #t (vector 'app-opt guide)))] (values drivers #t (vector 'orelse-h1 guide)))]
[(?? t1 t2) [(?? t1 t2)
(not esc?) (not esc?)
(let-values ([(drivers1 splice?1 guide1) (parse-h #'t1 depth 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) (cond [(box? qval)
(with-syntax ([(tmp) (generate-temporaries #'(unsyntax-splicing-expr))]) (with-syntax ([(tmp) (generate-temporaries #'(unsyntax-splicing-expr))])
(set-box! qval (cons (cons #'tmp h) (unbox qval))) (set-box! qval (cons (cons #'tmp h) (unbox qval)))
(let* ([fake-sm (make-syntax-mapping 0 #'tmp)] (values (dset) #t (vector 'unsyntax-splicing #'tmp)))]
[fake-pvar (pvar fake-sm #f #f)])
(values (dset fake-pvar) #t (vector 'unsyntax-splicing fake-pvar))))]
[else [else
(parameterize ((quasi (car qval))) (parameterize ((quasi (car qval)))
(let*-values ([(drivers guide) (parse-t #'t1 depth esc?)] (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 '#f dd) #f]
[(pvar sm attr dd) (not (attribute-mapping-syntax? attr))])) [(pvar sm attr dd) (not (attribute-mapping-syntax? attr))]))
(define (stx-drop n x) (define (stx-drop n x) (for/fold ([x x]) ([i (in-range n)]) (stx-cdr x)))
(cond [(zero? n) x]
[else (stx-drop (sub1 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))