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