commit a8273221282e64f9b72e4204f485cdde3af5c7b7
parent 1795b7af5f3c57ae829f1e2eaa9cd83bdb090edf
Author: Ryan Culpepper <ryanc@racket-lang.org>
Date: Tue, 8 Aug 2017 23:08:48 -0400
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).
Diffstat:
2 files changed, 287 insertions(+), 620 deletions(-)
diff --git a/parse/experimental/private/substitute.rkt b/parse/experimental/private/substitute.rkt
@@ -1,483 +0,0 @@
-#lang racket/base
-(require syntax/parse/private/minimatch
- racket/private/promise
- racket/private/stx) ;; syntax/stx
-(provide translate
- syntax-local-template-metafunction-introduce)
-
-#|
-;; Doesn't seem to make much difference.
-(require (rename-in racket/unsafe/ops
- [unsafe-vector-ref vector-ref]
- [unsafe-vector-set! vector-set!]
- [unsafe-car car]
- [unsafe-cdr cdr]))
-|#
-
-;; ============================================================
-
-#|
-A Guide (G) is one of:
- - '_
- - VarRef ;; no syntax check
- - (vector 'check VarRef) ;; check value is syntax
- - (cons G G)
- - (vector 'vector G)
- - (vector 'struct G)
- - (vector 'box G)
- - (vector 'dots HG (listof (vector-of VarRef)) nat (listof nat) G)
- - (vector 'app HG G)
- - (vector 'escaped G)
- - (vector 'orelse G G)
- - (vector 'metafun integer G)
- - (vector 'unsyntax VarRef)
- - (vector 'relocate G)
-
-A HeadGuide (HG) is one of:
- - G
- - (vector 'app-opt H)
- - (vector 'orelse-h H H)
- - (vector 'splice G)
- - (vector 'unsyntax-splicing VarRef)
-
-An VarRef is one of
- - positive-exact-integer ;; represents depth=0 pvar ref or metafun ref
- - negative-exact-integer ;; represents depth>0 pvar ref (within ellipsis)
-|#
-
-(define (head-guide? x)
- (match x
- [(vector 'app-opt g) #t]
- [(vector 'splice g) #t]
- [(vector 'orelse-h g1 g2) #t]
- [(vector 'unsyntax-splicing var) #t]
- [_ #f]))
-
-;; ============================================================
-
-;; Used to indicate absent pvar in template; ?? catches
-;; Note: not an exn, don't need continuation marks
-(require (only-in rackunit require/expose))
-#;(require/expose syntax/parse/experimental/private/substitute
- (absent-pvar
- absent-pvar?
- absent-pvar-ctx
- absent-pvar-v
- absent-pvar-wanted-list?))
-;; this struct is only used in this file, and is not exported, so I guess it's
-;; ok to not steal the struct from syntax/parse/experimental/private/substitute
-;; Furthermore, the require/expose above does not work reliably.
-(struct absent-pvar (ctx v wanted-list?))
-
-;; ============================================================
-
-;; A translated-template is (vector loop-env -> syntax)
-;; A loop-env is either a vector of values or a single value,
-;; depending on lenv-mode of enclosing ellipsis ('dots) form.
-
-(define (translate stx g env-length)
- (let ([f (translate-g stx stx g env-length 0)])
- (lambda (env lenv)
- (unless (>= (vector-length env) env-length)
- (error 'template "internal error: environment too short"))
- (with-handlers ([absent-pvar?
- (lambda (ap)
- (err/not-syntax (absent-pvar-ctx ap) (absent-pvar-v ap)))])
- (f env lenv)))))
-
-;; lenv-mode is one of
-;; - 'one ;; lenv is single value; address as -1
-;; - nat ;; lenv is vector; address as (- -1 index); 0 means no loop env
-
-(define (translate-g stx0 stx g env-length lenv-mode)
- (define (loop stx g) (translate-g stx0 stx g env-length lenv-mode))
- (define (loop-h stx hg) (translate-hg stx0 stx hg env-length lenv-mode))
- (define (get index env lenv) (get-var index env lenv lenv-mode))
-
- (match g
-
- ['_ (lambda (env lenv) stx)]
-
- [(? exact-integer? index)
- (check-var index env-length lenv-mode)
- (lambda (env lenv) (get index env lenv))]
-
- [(vector 'check index)
- (check-var index env-length lenv-mode)
- (lambda (env lenv) (check-stx stx (get index env lenv)))]
-
- [(cons g1 g2)
- (let ([f1 (loop (stx-car stx) g1)]
- [f2 (loop (stx-cdr stx) g2)])
- (cond [(syntax? stx)
- (lambda (env lenv)
- (restx stx (cons (f1 env lenv) (f2 env lenv))))]
- [(eq? g1 '_)
- (let ([c1 (stx-car stx)])
- (lambda (env lenv)
- (cons c1 (f2 env lenv))))]
- [(eq? g2 '_)
- (let ([c2 (stx-cdr stx)])
- (lambda (env lenv)
- (cons (f1 env lenv) c2)))]
- [else
- (lambda (env lenv)
- (cons (f1 env lenv) (f2 env lenv)))]))]
-
- [(vector 'dots ghead henv nesting uptos gtail)
- ;; At each nesting depth, indexes [0,upto) of lenv* vary; the rest are fixed.
- ;; An alternative would be to have a list of henvs, but that would inhibit
- ;; the nice simple vector reuse via vector-car/cdr!.
- (let* ([lenv*-len (vector-length henv)]
- [ghead-is-hg? (head-guide? ghead)]
- [ftail (loop (stx-drop (add1 nesting) stx) gtail)])
- (for ([var (in-vector henv)])
- (check-var var env-length lenv-mode))
- (unless (= nesting (length uptos))
- (error 'template "internal error: wrong number of uptos"))
- (let ([last-upto
- (for/fold ([last 1]) ([upto (in-list uptos)])
- (unless (<= upto lenv*-len)
- (error 'template "internal error: upto is too big"))
- (unless (>= upto last)
- (error 'template "internal error: uptos decreased: ~e" uptos))
- upto)])
- (unless (= lenv*-len last-upto)
- (error 'template "internal error: last upto was not full env")))
- (cond [(and (= lenv*-len 1) (= nesting 1) (not ghead-is-hg?)
- (equal? ghead '-1))
- ;; Fast path for (pvar ... . T) template
- ;; - no list? or syntax? checks needed (because ghead is just raw varref,
- ;; no 'check' wrapper)
- ;; - avoid trivial map, just append
- (let ([var-index (vector-ref henv 0)])
- (lambda (env lenv)
- (let ([lenv* (get var-index env lenv)])
- (restx stx (append lenv* (ftail env lenv))))))]
- [(and (= lenv*-len 1) (= nesting 1) (not ghead-is-hg?))
- ;; Fast path for (T ... . T) template
- ;; - specialize lenv to avoid vector allocation/mutation
- ;; - body is deforested (append (map _ _) _) preserving eval order
- ;; - could try to eliminate 'check-list', but probably not worth the bother
- (let* ([fhead (translate-g stx0 (stx-car stx) ghead env-length 'one)]
- [var-index (vector-ref henv 0)])
- (lambda (env lenv)
- (restx stx
- (let ([lenv* (check-list/depth stx (get var-index env lenv) 1)])
- (let dotsloop ([lenv* lenv*])
- (if (null? lenv*)
- (ftail env lenv)
- (cons (fhead env (car lenv*))
- (dotsloop (cdr lenv*)))))))))]
- [else
- ;; Slow/general path for (H ...^n . T)
- (let ([fhead (if ghead-is-hg?
- (translate-hg stx0 (stx-car stx) ghead env-length lenv*-len)
- (translate-g stx0 (stx-car stx) ghead env-length lenv*-len))])
- (lambda (env lenv)
- #|
- The template is "driven" by pattern variables bound to (listof^n syntax).
- For example, in (H ... ... . T), the pvars of H have (listof (listof syntax)),
- and we need a doubly-nested loop, like
- (for/list ([stxlist^1 (in-list stxlist^2)])
- (for/list ([stx (in-list stxlist^1)])
- ___ fhead ___))
- Since we can have arbitrary numbers of ellipses, we have 'nestloop' recur
- over ellipsis levels and 'dotsloop' recur over the contents of the pattern
- variables' (listof^n syntax) values.
-
- Also, we reuse lenv vectors to reduce allocation. There is one aux lenv
- vector per nesting level, preallocated in aux-lenvs. For continuation-safety
- we must install a continuation barrier around metafunction applications.
- |#
- (define (nestloop lenv* nesting uptos aux-lenvs)
- (cond [(zero? nesting)
- (fhead env lenv*)]
- [else
- (let ([iters (check-lenv/get-iterations stx lenv*)])
- (let ([lenv** (car aux-lenvs)]
- [aux-lenvs** (cdr aux-lenvs)]
- [upto** (car uptos)]
- [uptos** (cdr uptos)])
- (let dotsloop ([iters iters])
- (if (zero? iters)
- null
- (begin (vector-car/cdr! lenv** lenv* upto**)
- (let ([row (nestloop lenv** (sub1 nesting) uptos** aux-lenvs**)])
- (cons row (dotsloop (sub1 iters)))))))))]))
- (define initial-lenv*
- (vector-map (lambda (index) (get index env lenv)) henv))
- (define aux-lenvs
- (for/list ([depth (in-range nesting)]) (make-vector lenv*-len)))
-
- ;; Check initial-lenv* contains lists of right depths.
- ;; At each nesting depth, indexes [0,upto) of lenv* vary;
- ;; uptos is monotonic nondecreasing (every variable varies in inner
- ;; loop---this is always counterintuitive to me).
- (let checkloop ([depth nesting] [uptos uptos] [start 0])
- (when (pair? uptos)
- (for ([v (in-vector initial-lenv* start (car uptos))])
- (check-list/depth stx v depth))
- (checkloop (sub1 depth) (cdr uptos) (car uptos))))
-
- (define head-results
- ;; if ghead-is-hg?, is (listof^(nesting+1) stx) -- extra listof for loop-h
- ;; otherwise, is (listof^nesting stx)
- (nestloop initial-lenv* nesting uptos aux-lenvs))
- (define tail-result (ftail env lenv))
- (restx stx
- (nested-append head-results
- (if ghead-is-hg? nesting (sub1 nesting))
- tail-result))))]))]
-
- [(vector 'app ghead gtail)
- (let ([fhead (loop-h (stx-car stx) ghead)]
- [ftail (loop (stx-cdr stx) gtail)])
- (lambda (env lenv)
- (restx stx (append (fhead env lenv) (ftail env lenv)))))]
-
- [(vector 'escaped g1)
- (loop (stx-cadr stx) g1)]
-
- [(vector 'orelse g1 g2)
- (let ([f1 (loop (stx-cadr stx) g1)]
- [f2 (loop (stx-caddr stx) g2)])
- (lambda (env lenv)
- (with-handlers ([absent-pvar?
- (lambda (_e)
- (f2 env lenv))])
- (f1 env lenv))))]
-
- [(vector 'metafun index g1)
- (let ([f1 (loop (stx-cdr stx) g1)])
- (check-var index env-length lenv-mode)
- (lambda (env lenv)
- (let ([v (restx stx (cons (stx-car stx) (f1 env lenv)))]
- [mark (make-syntax-introducer)]
- [old-mark (current-template-metafunction-introducer)]
- [mf (get index env lenv)])
- (parameterize ((current-template-metafunction-introducer mark)
- (old-template-metafunction-introducer old-mark))
- (let ([r (call-with-continuation-barrier (lambda () (mf (mark (old-mark v)))))])
- (unless (syntax? r)
- (raise-syntax-error #f "result of template metafunction was not syntax" stx))
- (restx stx (old-mark (mark r))))))))]
-
- [(vector 'vector g1)
- (let ([f1 (loop (vector->list (syntax-e stx)) g1)])
- (lambda (env lenv)
- (restx stx (list->vector (f1 env lenv)))))]
-
- [(vector 'struct g1)
- (let ([f1 (loop (cdr (vector->list (struct->vector (syntax-e stx)))) g1)]
- [key (prefab-struct-key (syntax-e stx))])
- (lambda (env lenv)
- (restx stx (apply make-prefab-struct key (f1 env lenv)))))]
-
- [(vector 'box g1)
- (let ([f1 (loop (unbox (syntax-e stx)) g1)])
- (lambda (env lenv)
- (restx stx (box (f1 env lenv)))))]
-
- [(vector 'unsyntax var)
- (let ([f1 (loop stx var)])
- (lambda (env lenv)
- (restx stx (f1 env lenv))))]
-
- [(vector 'relocate g1 var)
- (let ([f1 (loop stx g1)])
- (lambda (env lenv)
- (let ([result (f1 env lenv)]
- [loc (get var env lenv)])
- (if (or (syntax-source loc)
- (syntax-position loc))
- (datum->syntax result (syntax-e result) loc result)
- result))))]))
-
-(define (translate-hg stx0 stx hg env-length lenv-mode)
- (define (loop stx g) (translate-g stx0 stx g env-length lenv-mode))
- (define (loop-h stx hg) (translate-hg stx0 stx hg env-length lenv-mode))
- (define (get index env lenv) (get-var index env lenv lenv-mode))
-
- (match hg
-
- [(vector 'app-opt hg1)
- (let ([f1 (loop-h (stx-cadr stx) hg1)])
- (lambda (env lenv)
- (with-handlers ([absent-pvar? (lambda (_e) null)])
- (f1 env lenv))))]
-
- [(vector 'orelse-h hg1 hg2)
- (let ([f1 (loop-h (stx-cadr stx) hg1)]
- [f2 (loop-h (stx-caddr stx) hg2)])
- (lambda (env lenv)
- (with-handlers ([absent-pvar?
- (lambda (_e)
- (f2 env lenv))])
- (f1 env lenv))))]
-
- [(vector 'splice g1)
- (let ([f1 (loop (stx-cdr stx) g1)])
- (lambda (env lenv)
- (let* ([v (f1 env lenv)]
- [v* (stx->list v)])
- (unless (list? v*)
- (raise-syntax-error 'template
- "splicing template did not produce a syntax list"
- stx))
- v*)))]
-
- [(vector 'unsyntax-splicing index)
- (check-var index env-length lenv-mode)
- (lambda (env lenv)
- (let* ([v (get index env lenv)]
- [v* (stx->list v)])
- (unless (list? v*)
- (raise-syntax-error 'template
- "unsyntax-splicing expression did not produce a syntax list"
- stx))
- v*))]
-
- [_
- (let ([f (loop stx hg)])
- (lambda (env lenv)
- (list (f env lenv))))]))
-
-(define (get-var index env lenv lenv-mode)
- (cond [(positive? index)
- (vector-ref env (sub1 index))]
- [(negative? index)
- (case lenv-mode
- ((one) lenv)
- (else (vector-ref lenv (- -1 index))))]))
-
-(define (check-var index env-length lenv-mode)
- (cond [(positive? index)
- (unless (< (sub1 index) env-length)
- (error/bad-index index))]
- [(negative? index)
- (unless (< (- -1 index)
- (case lenv-mode
- ((one) 1)
- (else lenv-mode)))
- (error/bad-index))]))
-
-(define (check-lenv/get-iterations stx lenv)
- (unless (list? (vector-ref lenv 0))
- (error 'template "pattern variable used in ellipsis pattern is not defined"))
- (let ([len0 (length (vector-ref lenv 0))])
- (for ([v (in-vector lenv)])
- (unless (list? v)
- (error 'template "pattern variable used in ellipsis pattern is not defined"))
- (unless (= len0 (length v))
- (raise-syntax-error 'template
- "incompatible ellipsis match counts for template"
- stx)))
- len0))
-
-;; ----
-
-(define current-template-metafunction-introducer
- (make-parameter
- (lambda (stx)
- (if (syntax-transforming?)
- (syntax-local-introduce stx)
- stx))))
-
-(define old-template-metafunction-introducer
- (make-parameter #f))
-
-(define (syntax-local-template-metafunction-introduce stx)
- (let ([mark (current-template-metafunction-introducer)]
- [old-mark (old-template-metafunction-introducer)])
- (unless old-mark
- (error 'syntax-local-template-metafunction-introduce
- "must be called within the dynamic extent of a template metafunction"))
- (mark (old-mark stx))))
-
-;; ----
-
-(define (stx-cadr x) (stx-car (stx-cdr x)))
-(define (stx-cddr x) (stx-cdr (stx-cdr x)))
-(define (stx-caddr x) (stx-car (stx-cdr (stx-cdr x))))
-
-(define (stx-drop n x)
- (cond [(zero? n) x]
- [else (stx-drop (sub1 n) (stx-cdr x))]))
-
-(define (restx basis val)
- (if (syntax? basis)
- (datum->syntax basis val basis 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))
diff --git a/parse/experimental/template.rkt b/parse/experimental/template.rkt
@@ -8,7 +8,8 @@
racket/struct
auto-syntax-e/utils)
stxparse-info/parse/private/residual
- "private/substitute.rkt")
+ racket/private/stx
+ racket/private/promise)
(provide template
template/loc
quasitemplate
@@ -47,39 +48,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 ()
@@ -102,7 +99,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)
@@ -131,20 +127,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]))
;; ----
@@ -157,9 +141,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
@@ -214,96 +196,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-auto-pvar 0 loc-id)]
- [loc-pvar (pvar loc-sm #f #f)])
- (values (dset-add drivers loc-pvar)
- (relocate-guide pre-guide loc-pvar)))
- (values drivers pre-guide))])
- (let* ([main-env (dset->env drivers (hash))]
- [guide (guide-resolve-env pre-guide main-env)])
- (values guide
- (index-hash->vector main-env)))))
-
- ;; 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))
@@ -346,7 +335,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)]
@@ -357,6 +346,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)))
@@ -390,16 +384,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-auto-pvar 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?)])
@@ -452,7 +444,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)
@@ -488,7 +480,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?)]
@@ -507,9 +499,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-auto-pvar 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?)]
@@ -573,7 +563,167 @@ 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)
+ (old-template-metafunction-introducer old-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))))
+
+(define old-template-metafunction-introducer
+ (make-parameter #f))
+
+(define (syntax-local-template-metafunction-introduce stx)
+ (let ([mark (current-template-metafunction-introducer)]
+ [old-mark (old-template-metafunction-introducer)])
+ (unless old-mark
+ (error 'syntax-local-template-metafunction-introduce
+ "must be called within the dynamic extent of a template metafunction"))
+ (mark (old-mark stx))))
+
+;; Used to indicate absent pvar in template; ?? catches
+;; Note: not an exn, don't need continuation marks
+#;(require (only-in rackunit require/expose))
+#;(require/expose syntax/parse/experimental/private/substitute
+ (absent-pvar
+ absent-pvar?
+ absent-pvar-ctx
+ absent-pvar-v
+ absent-pvar-wanted-list?))
+;; this struct is only used in this file, and is not exported, so I guess it's
+;; ok to not steal the struct from syntax/parse/experimental/private/substitute
+;; Furthermore, the require/expose above does not work reliably.
+(struct absent-pvar (ctx))
+
+(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))
