substitute.rkt (19757B)
1 #lang racket/base 2 (require syntax/parse/private/minimatch 3 racket/private/promise 4 racket/private/stx) ;; syntax/stx 5 (provide translate 6 syntax-local-template-metafunction-introduce) 7 8 #| 9 ;; Doesn't seem to make much difference. 10 (require (rename-in racket/unsafe/ops 11 [unsafe-vector-ref vector-ref] 12 [unsafe-vector-set! vector-set!] 13 [unsafe-car car] 14 [unsafe-cdr cdr])) 15 |# 16 17 ;; ============================================================ 18 19 #| 20 A Guide (G) is one of: 21 - '_ 22 - VarRef ;; no syntax check 23 - (vector 'check VarRef) ;; check value is syntax 24 - (cons G G) 25 - (vector 'vector G) 26 - (vector 'struct G) 27 - (vector 'box G) 28 - (vector 'dots HG (listof (vector-of VarRef)) nat (listof nat) G) 29 - (vector 'app HG G) 30 - (vector 'escaped G) 31 - (vector 'orelse G G) 32 - (vector 'metafun integer G) 33 - (vector 'copy-props G (listof symbol)) 34 - (vector 'set-props G (listof (cons symbol any))) 35 - (vector 'unsyntax VarRef) 36 - (vector 'relocate G) 37 38 A HeadGuide (HG) is one of: 39 - G 40 - (vector 'app-opt H) 41 - (vector 'orelse-h H H) 42 - (vector 'splice G) 43 - (vector 'unsyntax-splicing VarRef) 44 45 An VarRef is one of 46 - positive-exact-integer ;; represents depth=0 pvar ref or metafun ref 47 - negative-exact-integer ;; represents depth>0 pvar ref (within ellipsis) 48 |# 49 50 (define (head-guide? x) 51 (match x 52 [(vector 'app-opt g) #t] 53 [(vector 'splice g) #t] 54 [(vector 'orelse-h g1 g2) #t] 55 [(vector 'unsyntax-splicing var) #t] 56 [_ #f])) 57 58 ;; ============================================================ 59 60 ;; Used to indicate absent pvar in template; ?? catches 61 ;; Note: not an exn, don't need continuation marks 62 (require (only-in rackunit require/expose)) 63 #;(require/expose syntax/parse/experimental/private/substitute 64 (absent-pvar 65 absent-pvar? 66 absent-pvar-ctx 67 absent-pvar-v 68 absent-pvar-wanted-list?)) 69 ;; this struct is only used in this file, and is not exported, so I guess it's 70 ;; ok to not steal the struct from syntax/parse/experimental/private/substitute 71 ;; Furthermore, the require/expose above does not work reliably. 72 (struct absent-pvar (ctx v wanted-list?)) 73 74 ;; ============================================================ 75 76 ;; A translated-template is (vector loop-env -> syntax) 77 ;; A loop-env is either a vector of values or a single value, 78 ;; depending on lenv-mode of enclosing ellipsis ('dots) form. 79 80 (define (translate stx g env-length) 81 (let ([f (translate-g stx stx g env-length 0)]) 82 (lambda (env lenv) 83 (unless (>= (vector-length env) env-length) 84 (error 'template "internal error: environment too short")) 85 (with-handlers ([absent-pvar? 86 (lambda (ap) 87 (err/not-syntax (absent-pvar-ctx ap) (absent-pvar-v ap)))]) 88 (f env lenv))))) 89 90 ;; lenv-mode is one of 91 ;; - 'one ;; lenv is single value; address as -1 92 ;; - nat ;; lenv is vector; address as (- -1 index); 0 means no loop env 93 94 (define (translate-g stx0 stx g env-length lenv-mode) 95 (define (loop stx g) (translate-g stx0 stx g env-length lenv-mode)) 96 (define (loop-h stx hg) (translate-hg stx0 stx hg env-length lenv-mode)) 97 (define (get index env lenv) (get-var index env lenv lenv-mode)) 98 99 (match g 100 101 ['_ (lambda (env lenv) stx)] 102 103 [(? exact-integer? index) 104 (check-var index env-length lenv-mode) 105 (lambda (env lenv) (get index env lenv))] 106 107 [(vector 'check index) 108 (check-var index env-length lenv-mode) 109 (lambda (env lenv) (check-stx stx (get index env lenv)))] 110 111 [(cons g1 g2) 112 (let ([f1 (loop (stx-car stx) g1)] 113 [f2 (loop (stx-cdr stx) g2)]) 114 (cond [(syntax? stx) 115 (lambda (env lenv) 116 (restx stx (cons (f1 env lenv) (f2 env lenv))))] 117 [(eq? g1 '_) 118 (let ([c1 (stx-car stx)]) 119 (lambda (env lenv) 120 (cons c1 (f2 env lenv))))] 121 [(eq? g2 '_) 122 (let ([c2 (stx-cdr stx)]) 123 (lambda (env lenv) 124 (cons (f1 env lenv) c2)))] 125 [else 126 (lambda (env lenv) 127 (cons (f1 env lenv) (f2 env lenv)))]))] 128 129 [(vector 'dots ghead henv nesting uptos gtail) 130 ;; At each nesting depth, indexes [0,upto) of lenv* vary; the rest are fixed. 131 ;; An alternative would be to have a list of henvs, but that would inhibit 132 ;; the nice simple vector reuse via vector-car/cdr!. 133 (let* ([lenv*-len (vector-length henv)] 134 [ghead-is-hg? (head-guide? ghead)] 135 [ftail (loop (stx-drop (add1 nesting) stx) gtail)]) 136 (for ([var (in-vector henv)]) 137 (check-var var env-length lenv-mode)) 138 (unless (= nesting (length uptos)) 139 (error 'template "internal error: wrong number of uptos")) 140 (let ([last-upto 141 (for/fold ([last 1]) ([upto (in-list uptos)]) 142 (unless (<= upto lenv*-len) 143 (error 'template "internal error: upto is too big")) 144 (unless (>= upto last) 145 (error 'template "internal error: uptos decreased: ~e" uptos)) 146 upto)]) 147 (unless (= lenv*-len last-upto) 148 (error 'template "internal error: last upto was not full env"))) 149 (cond [(and (= lenv*-len 1) (= nesting 1) (not ghead-is-hg?) 150 (equal? ghead '-1)) 151 ;; Fast path for (pvar ... . T) template 152 ;; - no list? or syntax? checks needed (because ghead is just raw varref, 153 ;; no 'check' wrapper) 154 ;; - avoid trivial map, just append 155 (let ([var-index (vector-ref henv 0)]) 156 (lambda (env lenv) 157 (let ([lenv* (get var-index env lenv)]) 158 (restx stx (append lenv* (ftail env lenv))))))] 159 [(and (= lenv*-len 1) (= nesting 1) (not ghead-is-hg?)) 160 ;; Fast path for (T ... . T) template 161 ;; - specialize lenv to avoid vector allocation/mutation 162 ;; - body is deforested (append (map _ _) _) preserving eval order 163 ;; - could try to eliminate 'check-list', but probably not worth the bother 164 (let* ([fhead (translate-g stx0 (stx-car stx) ghead env-length 'one)] 165 [var-index (vector-ref henv 0)]) 166 (lambda (env lenv) 167 (restx stx 168 (let ([lenv* (check-list/depth stx (get var-index env lenv) 1)]) 169 (let dotsloop ([lenv* lenv*]) 170 (if (null? lenv*) 171 (ftail env lenv) 172 (cons (fhead env (car lenv*)) 173 (dotsloop (cdr lenv*)))))))))] 174 [else 175 ;; Slow/general path for (H ...^n . T) 176 (let ([fhead (if ghead-is-hg? 177 (translate-hg stx0 (stx-car stx) ghead env-length lenv*-len) 178 (translate-g stx0 (stx-car stx) ghead env-length lenv*-len))]) 179 (lambda (env lenv) 180 #| 181 The template is "driven" by pattern variables bound to (listof^n syntax). 182 For example, in (H ... ... . T), the pvars of H have (listof (listof syntax)), 183 and we need a doubly-nested loop, like 184 (for/list ([stxlist^1 (in-list stxlist^2)]) 185 (for/list ([stx (in-list stxlist^1)]) 186 ___ fhead ___)) 187 Since we can have arbitrary numbers of ellipses, we have 'nestloop' recur 188 over ellipsis levels and 'dotsloop' recur over the contents of the pattern 189 variables' (listof^n syntax) values. 190 191 Also, we reuse lenv vectors to reduce allocation. There is one aux lenv 192 vector per nesting level, preallocated in aux-lenvs. For continuation-safety 193 we must install a continuation barrier around metafunction applications. 194 |# 195 (define (nestloop lenv* nesting uptos aux-lenvs) 196 (cond [(zero? nesting) 197 (fhead env lenv*)] 198 [else 199 (let ([iters (check-lenv/get-iterations stx lenv*)]) 200 (let ([lenv** (car aux-lenvs)] 201 [aux-lenvs** (cdr aux-lenvs)] 202 [upto** (car uptos)] 203 [uptos** (cdr uptos)]) 204 (let dotsloop ([iters iters]) 205 (if (zero? iters) 206 null 207 (begin (vector-car/cdr! lenv** lenv* upto**) 208 (let ([row (nestloop lenv** (sub1 nesting) uptos** aux-lenvs**)]) 209 (cons row (dotsloop (sub1 iters)))))))))])) 210 (define initial-lenv* 211 (vector-map (lambda (index) (get index env lenv)) henv)) 212 (define aux-lenvs 213 (for/list ([depth (in-range nesting)]) (make-vector lenv*-len))) 214 215 ;; Check initial-lenv* contains lists of right depths. 216 ;; At each nesting depth, indexes [0,upto) of lenv* vary; 217 ;; uptos is monotonic nondecreasing (every variable varies in inner 218 ;; loop---this is always counterintuitive to me). 219 (let checkloop ([depth nesting] [uptos uptos] [start 0]) 220 (when (pair? uptos) 221 (for ([v (in-vector initial-lenv* start (car uptos))]) 222 (check-list/depth stx v depth)) 223 (checkloop (sub1 depth) (cdr uptos) (car uptos)))) 224 225 (define head-results 226 ;; if ghead-is-hg?, is (listof^(nesting+1) stx) -- extra listof for loop-h 227 ;; otherwise, is (listof^nesting stx) 228 (nestloop initial-lenv* nesting uptos aux-lenvs)) 229 (define tail-result (ftail env lenv)) 230 (restx stx 231 (nested-append head-results 232 (if ghead-is-hg? nesting (sub1 nesting)) 233 tail-result))))]))] 234 235 [(vector 'app ghead gtail) 236 (let ([fhead (loop-h (stx-car stx) ghead)] 237 [ftail (loop (stx-cdr stx) gtail)]) 238 (lambda (env lenv) 239 (restx stx (append (fhead env lenv) (ftail env lenv)))))] 240 241 [(vector 'escaped g1) 242 (loop (stx-cadr stx) g1)] 243 244 [(vector 'orelse g1 g2) 245 (let ([f1 (loop (stx-cadr stx) g1)] 246 [f2 (loop (stx-caddr stx) g2)]) 247 (lambda (env lenv) 248 (with-handlers ([absent-pvar? 249 (lambda (_e) 250 (f2 env lenv))]) 251 (f1 env lenv))))] 252 253 [(vector 'metafun index g1) 254 (let ([f1 (loop (stx-cdr stx) g1)]) 255 (check-var index env-length lenv-mode) 256 (lambda (env lenv) 257 (let ([v (restx stx (cons (stx-car stx) (f1 env lenv)))] 258 [mark (make-syntax-introducer)] 259 [old-mark (current-template-metafunction-introducer)] 260 [mf (get index env lenv)]) 261 (parameterize ((current-template-metafunction-introducer mark) 262 (old-template-metafunction-introducer old-mark)) 263 (let ([r (call-with-continuation-barrier (lambda () (mf (mark (old-mark v)))))]) 264 (unless (syntax? r) 265 (raise-syntax-error #f "result of template metafunction was not syntax" stx)) 266 (restx stx (old-mark (mark r))))))))] 267 268 [(vector 'vector g1) 269 (let ([f1 (loop (vector->list (syntax-e stx)) g1)]) 270 (lambda (env lenv) 271 (restx stx (list->vector (f1 env lenv)))))] 272 273 [(vector 'struct g1) 274 (let ([f1 (loop (cdr (vector->list (struct->vector (syntax-e stx)))) g1)] 275 [key (prefab-struct-key (syntax-e stx))]) 276 (lambda (env lenv) 277 (restx stx (apply make-prefab-struct key (f1 env lenv)))))] 278 279 [(vector 'box g1) 280 (let ([f1 (loop (unbox (syntax-e stx)) g1)]) 281 (lambda (env lenv) 282 (restx stx (box (f1 env lenv)))))] 283 284 [(vector 'copy-props g1 keys) 285 (let ([f1 (loop stx g1)]) 286 (lambda (env lenv) 287 (for/fold ([v (f1 env lenv)]) ([key (in-list keys)]) 288 (let ([pvalue (syntax-property stx key)]) 289 (if pvalue 290 (syntax-property v key pvalue) 291 v)))))] 292 293 [(vector 'set-props g1 props-alist) 294 (let ([f1 (loop stx g1)]) 295 (lambda (env lenv) 296 (for/fold ([v (f1 env lenv)]) ([entry (in-list props-alist)]) 297 (syntax-property v (car entry) (cdr entry)))))] 298 299 [(vector 'unsyntax var) 300 (let ([f1 (loop stx var)]) 301 (lambda (env lenv) 302 (restx stx (f1 env lenv))))] 303 304 [(vector 'relocate g1 var) 305 (let ([f1 (loop stx g1)]) 306 (lambda (env lenv) 307 (let ([result (f1 env lenv)] 308 [loc (get var env lenv)]) 309 (if (or (syntax-source loc) 310 (syntax-position loc)) 311 (datum->syntax result (syntax-e result) loc result) 312 result))))])) 313 314 (define (translate-hg stx0 stx hg env-length lenv-mode) 315 (define (loop stx g) (translate-g stx0 stx g env-length lenv-mode)) 316 (define (loop-h stx hg) (translate-hg stx0 stx hg env-length lenv-mode)) 317 (define (get index env lenv) (get-var index env lenv lenv-mode)) 318 319 (match hg 320 321 [(vector 'app-opt hg1) 322 (let ([f1 (loop-h (stx-cadr stx) hg1)]) 323 (lambda (env lenv) 324 (with-handlers ([absent-pvar? (lambda (_e) null)]) 325 (f1 env lenv))))] 326 327 [(vector 'orelse-h hg1 hg2) 328 (let ([f1 (loop-h (stx-cadr stx) hg1)] 329 [f2 (loop-h (stx-caddr stx) hg2)]) 330 (lambda (env lenv) 331 (with-handlers ([absent-pvar? 332 (lambda (_e) 333 (f2 env lenv))]) 334 (f1 env lenv))))] 335 336 [(vector 'splice g1) 337 (let ([f1 (loop (stx-cdr stx) g1)]) 338 (lambda (env lenv) 339 (let* ([v (f1 env lenv)] 340 [v* (stx->list v)]) 341 (unless (list? v*) 342 (raise-syntax-error 'template 343 "splicing template did not produce a syntax list" 344 stx)) 345 v*)))] 346 347 [(vector 'unsyntax-splicing index) 348 (check-var index env-length lenv-mode) 349 (lambda (env lenv) 350 (let* ([v (get index env lenv)] 351 [v* (stx->list v)]) 352 (unless (list? v*) 353 (raise-syntax-error 'template 354 "unsyntax-splicing expression did not produce a syntax list" 355 stx)) 356 v*))] 357 358 [_ 359 (let ([f (loop stx hg)]) 360 (lambda (env lenv) 361 (list (f env lenv))))])) 362 363 (define (get-var index env lenv lenv-mode) 364 (cond [(positive? index) 365 (vector-ref env (sub1 index))] 366 [(negative? index) 367 (case lenv-mode 368 ((one) lenv) 369 (else (vector-ref lenv (- -1 index))))])) 370 371 (define (check-var index env-length lenv-mode) 372 (cond [(positive? index) 373 (unless (< (sub1 index) env-length) 374 (error/bad-index index))] 375 [(negative? index) 376 (unless (< (- -1 index) 377 (case lenv-mode 378 ((one) 1) 379 (else lenv-mode))) 380 (error/bad-index))])) 381 382 (define (check-lenv/get-iterations stx lenv) 383 (unless (list? (vector-ref lenv 0)) 384 (error 'template "pattern variable used in ellipsis pattern is not defined")) 385 (let ([len0 (length (vector-ref lenv 0))]) 386 (for ([v (in-vector lenv)]) 387 (unless (list? v) 388 (error 'template "pattern variable used in ellipsis pattern is not defined")) 389 (unless (= len0 (length v)) 390 (raise-syntax-error 'template 391 "incompatible ellipsis match counts for template" 392 stx))) 393 len0)) 394 395 ;; ---- 396 397 (define current-template-metafunction-introducer 398 (make-parameter 399 (lambda (stx) 400 (if (syntax-transforming?) 401 (syntax-local-introduce stx) 402 stx)))) 403 404 (define old-template-metafunction-introducer 405 (make-parameter #f)) 406 407 (define (syntax-local-template-metafunction-introduce stx) 408 (let ([mark (current-template-metafunction-introducer)] 409 [old-mark (old-template-metafunction-introducer)]) 410 (unless old-mark 411 (error 'syntax-local-template-metafunction-introduce 412 "must be called within the dynamic extent of a template metafunction")) 413 (mark (old-mark stx)))) 414 415 ;; ---- 416 417 (define (stx-cadr x) (stx-car (stx-cdr x))) 418 (define (stx-cddr x) (stx-cdr (stx-cdr x))) 419 (define (stx-caddr x) (stx-car (stx-cdr (stx-cdr x)))) 420 421 (define (stx-drop n x) 422 (cond [(zero? n) x] 423 [else (stx-drop (sub1 n) (stx-cdr x))])) 424 425 (define (restx basis val) 426 (if (syntax? basis) 427 (datum->syntax basis val basis) 428 val)) 429 430 ;; nested-append : (listof^(nesting+1) A) nat (listof A) -> (listof A) 431 ;; (Actually, in practice onto is stx, so this is an improper append.) 432 (define (nested-append lst nesting onto) 433 (cond [(zero? nesting) (append lst onto)] 434 [(null? lst) onto] 435 [else (nested-append (car lst) (sub1 nesting) 436 (nested-append (cdr lst) nesting onto))])) 437 438 (define (check-stx ctx v) 439 (let loop ([v v]) 440 (cond [(syntax? v) 441 v] 442 [(promise? v) 443 (loop (force v))] 444 [(eq? v #f) 445 (raise (absent-pvar ctx v #f))] 446 [else (err/not-syntax ctx v)]))) 447 448 (define (check-list/depth ctx v0 depth0) 449 (let depthloop ([v v0] [depth depth0]) 450 (cond [(zero? depth) v] 451 [(and (= depth 1) (list? v)) v] 452 [else 453 (let loop ([v v]) 454 (cond [(null? v) 455 null] 456 [(pair? v) 457 (let ([new-car (depthloop (car v) (sub1 depth))] 458 [new-cdr (loop (cdr v))]) 459 ;; Don't copy unless necessary 460 (if (and (eq? new-car (car v)) (eq? new-cdr (cdr v))) 461 v 462 (cons new-car new-cdr)))] 463 [(promise? v) 464 (loop (force v))] 465 [(eq? v #f) 466 (raise (absent-pvar ctx v0 #t))] 467 [else 468 (err/not-syntax ctx v0)]))]))) 469 470 ;; Note: slightly different from error msg in syntax/parse/private/residual: 471 ;; here says "contains" instead of "is bound to", because might be within list 472 (define (err/not-syntax ctx v) 473 (raise-syntax-error #f 474 (format "attribute contains non-syntax value\n value: ~e" v) 475 ctx)) 476 477 (define (error/bad-index index) 478 (error 'template "internal error: bad index: ~e" index)) 479 480 (define (vector-car/cdr! dest-v src-v upto) 481 (let ([len (vector-length dest-v)]) 482 (let loop ([i 0]) 483 (when (< i upto) 484 (let ([p (vector-ref src-v i)]) 485 (vector-set! dest-v i (car p)) 486 (vector-set! src-v i (cdr p))) 487 (loop (add1 i)))) 488 (let loop ([j upto]) 489 (when (< j len) 490 (vector-set! dest-v j (vector-ref src-v j)) 491 (loop (add1 j)))))) 492 493 (define (vector-map f src-v) 494 (let* ([len (vector-length src-v)] 495 [dest-v (make-vector len)]) 496 (let loop ([i 0]) 497 (when (< i len) 498 (vector-set! dest-v i (f (vector-ref src-v i))) 499 (loop (add1 i)))) 500 dest-v))