From ca38b89ae6f11a141764b9d3fbb8cace418d763f Mon Sep 17 00:00:00 2001 From: Ryan Culpepper Date: Tue, 8 Aug 2017 23:08:48 -0400 Subject: [PATCH] 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). --- .../parse/experimental/private/substitute.rkt | 460 ------------------ .../syntax/parse/experimental/template.rkt | 402 +++++++++------ 2 files changed, 265 insertions(+), 597 deletions(-) delete mode 100644 racket/collects/syntax/parse/experimental/private/substitute.rkt diff --git a/racket/collects/syntax/parse/experimental/private/substitute.rkt b/racket/collects/syntax/parse/experimental/private/substitute.rkt deleted file mode 100644 index b10cdb5b69..0000000000 --- a/racket/collects/syntax/parse/experimental/private/substitute.rkt +++ /dev/null @@ -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)) diff --git a/racket/collects/syntax/parse/experimental/template.rkt b/racket/collects/syntax/parse/experimental/template.rkt index b1d4ca68dd..c13537581b 100644 --- a/racket/collects/syntax/parse/experimental/template.rkt +++ b/racket/collects/syntax/parse/experimental/template.rkt @@ -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))