commit 64edde1f2de2b745dc182352c3e27adeff9ce022
parent dade971dd60b994d801a0cc49cbe93455c0d79f4
Author: Georges Dupéron <georges.duperon@gmail.com>
Date: Wed, 25 Jan 2017 23:11:02 +0100
Re-add syntax/parse/experimental/private/substitute, so that we can apply PR #1514
Diffstat:
2 files changed, 485 insertions(+), 1 deletion(-)
diff --git a/parse/experimental/private/substitute.rkt b/parse/experimental/private/substitute.rkt
@@ -0,0 +1,484 @@
+#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 'copy-props G (listof symbol))
+ - (vector 'set-props G (listof (cons symbol any)))
+ - (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?))
+#;(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 'copy-props g1 keys)
+ (let ([f1 (loop stx g1)])
+ (lambda (env lenv)
+ (for/fold ([v (f1 env lenv)]) ([key (in-list keys)])
+ (let ([pvalue (syntax-property stx key)])
+ (if pvalue
+ (syntax-property v key pvalue)
+ v)))))]
+
+ [(vector 'set-props g1 props-alist)
+ (let ([f1 (loop stx g1)])
+ (lambda (env lenv)
+ (for/fold ([v (f1 env lenv)]) ([entry (in-list props-alist)])
+ (syntax-property v (car entry) (cdr entry)))))]
+
+ [(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)
+ 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
@@ -7,7 +7,7 @@
racket/private/sc
racket/struct)
stxparse-info/parse/private/residual
- syntax/parse/experimental/private/substitute)
+ "private/substitute.rkt")
(provide template
template/loc
quasitemplate
