template.rkt (33116B)
1 ;; TODO: should either use directly the official "template.rkt", 2 ;; or import all the structs from there, to avoid having 3 ;; multiple definitions of the same struct. 4 (module template '#%kernel 5 (#%require racket/private/stx racket/private/small-scheme racket/private/performance-hint 6 (rename racket/private/small-scheme define -define) 7 (rename racket/private/small-scheme define-syntax -define-syntax) 8 racket/private/ellipses 9 (for-syntax racket/private/stx racket/private/small-scheme 10 (rename racket/private/small-scheme define -define) 11 (rename racket/private/small-scheme define-syntax -define-syntax) 12 racket/private/member racket/private/sc '#%kernel 13 racket/struct 14 auto-syntax-e/utils)) 15 (#%provide syntax 16 syntax/loc 17 datum 18 ~? ~@ 19 ~@! signal-absent-pvar 20 (protect 21 (for-syntax attribute-mapping 22 attribute-mapping? 23 attribute-mapping-name 24 attribute-mapping-var 25 attribute-mapping-depth 26 attribute-mapping-check 27 metafunction metafunction?))) 28 29 ;; ============================================================ 30 ;; Syntax of templates 31 32 ;; A Template (T) is one of: 33 ;; - pattern-variable 34 ;; - constant (including () and non-pvar identifiers) 35 ;; - (metafunction . T) 36 ;; - (H . T) 37 ;; - (H ... . T), (H ... ... . T), etc 38 ;; - (... T) -- escapes inner ..., ~?, ~@ 39 ;; - (~? T T) 40 ;; - #(T*) -- actually, vector->list interpreted as T 41 ;; - #s(prefab-struct-key T*) -- likewise 42 43 ;; A HeadTemplate (H) is one of: 44 ;; - T 45 ;; - (~? H) 46 ;; - (~? H H) 47 ;; - (~@ . T) 48 49 (define-syntax ~@! #f) ;; private, escape-ignoring version of ~@, used by unsyntax-splicing 50 51 ;; ============================================================ 52 ;; Compile-time 53 54 ;; Parse template syntax into a Guide (AST--the name is left over from 55 ;; when the "guide" was a data structure interpreted at run time). 56 57 ;; The AST representation is designed to coincide with the run-time 58 ;; support, so compilation is just (datum->syntax #'here guide). The 59 ;; variants listed below are the ones recognized and treated specially 60 ;; by other functions (eg optimize-resyntax, relocate-guide). 61 62 ;; A Guide (G) is one of: 63 ;; - (list 't-resyntax Expr Expr G) 64 ;; - (list 't-const Expr) ;; constant 65 ;; - (list 't-var Id) ;; trusted pattern variable 66 ;; - (list 't-list G ...) 67 ;; - (list 't-list* G ... G) 68 ;; - (list 't-append HG G) 69 ;; - (list 't-orelse G G) 70 ;; - (list 't-subst Expr Expr '({Subst} ...) Expr ...) ;; apply susbstitutions 71 ;; -- where Subst = Nat ;; replace nth car with arg 72 ;; | 'tail Nat ;; replace nth cdr with arg 73 ;; | 'append Nat ;; replace nth car by appending arg 74 ;; | 'recur Nat ;; replace nth car by recurring on it with arg 75 ;; - other expression (must be pair!) 76 77 ;; A HeadGuide (HG) is one of: 78 ;; - (list 'h-t G) 79 ;; - other expression (must be pair!) 80 81 ;; A PVar is (pvar Id Id Id/#f Nat/#f) 82 ;; 83 ;; The first identifier (var) is from the syntax-mapping or attribute-binding. 84 ;; The second (lvar) is a local variable name used to hold its value (or parts 85 ;; thereof) in ellipsis iteration. The third is #f if var is trusted to have a 86 ;; (Listof^depth Syntax) value, or an Id reference to a Checker procedure (see 87 ;; below) if it needs to be checked. 88 ;; 89 ;; The depth-delta associated with a depth>0 pattern variable is the difference 90 ;; between the pattern variable's depth and the depth at which it is used. (For 91 ;; depth 0 pvars, it's #f.) For example, in 92 ;; 93 ;; (with-syntax ([x #'0] 94 ;; [(y ...) #'(1 2)] 95 ;; [((z ...) ...) #'((a b) (c d))]) 96 ;; (template (((x y z) ...) ...))) 97 ;; 98 ;; the depth-delta for x is #f, the depth-delta for y is 1, and the depth-delta 99 ;; for z is 0. The depth-delta (or depth "delay") is also the depth of the 100 ;; ellipsis form where the variable begins to be iterated over. That is, the 101 ;; template above should be interpreted roughly as 102 ;; 103 ;; (let ([Lx (pvar-value-of x)] 104 ;; [Ly (pvar-value-of y)] 105 ;; [Lz (pvar-value-of z)]) 106 ;; (for/list ([Lz (in-list Lz)]) ;; depth 0 107 ;; (for/list ([Ly (in-list Ly)] ;; depth 1 108 ;; [Lz (in-list Lz)]) 109 ;; (___ Lx Ly Lz ___)))) 110 111 (begin-for-syntax 112 113 (define here-stx (quote-syntax here)) 114 115 (define template-logger (make-logger 'template (current-logger))) 116 117 ;; (struct pvar (var lvar check dd) #:prefab) 118 (define-values (struct:pv pvar pvar? pvar-ref pvar-set!) 119 (make-struct-type 'pvar #f 4 0 #f null 'prefab #f '(0 1 2 3))) 120 (define (pvar-var pv) (pvar-ref pv 0)) 121 (define (pvar-lvar pv) (pvar-ref pv 1)) 122 (define (pvar-check pv) (pvar-ref pv 2)) 123 (define (pvar-dd pv) (pvar-ref pv 3)) 124 125 ;; An Attribute is an identifier statically bound to a syntax-mapping 126 ;; (see sc.rkt) whose valvar is an identifier statically bound to an 127 ;; attribute-mapping. 128 129 ;; (struct attribute-mapping (var name depth check) ...) 130 ;; check : #f (trusted) or Id, ref to Checker 131 ;; Checker = ( Any d:Nat b:Boolean Syntax/#f -> (Listof^d (if b Syntax Any)) ) 132 (define-values (struct:attribute-mapping attribute-mapping attribute-mapping? 133 attribute-mapping-ref _attribute-mapping-set!) 134 (make-struct-type 'attribute-mapping #f 4 0 #f null (current-inspector) 135 (lambda (self stx) 136 (if (attribute-mapping-check self) 137 (let ([source-name 138 (or (let loop ([p (syntax-property stx 'disappeared-use)]) 139 (cond [(identifier? p) p] 140 [(pair? p) (or (loop (car p)) (loop (cdr p)))] 141 [else #f])) 142 (attribute-mapping-name self))]) 143 (define code 144 `(,(attribute-mapping-check self) 145 ,(attribute-mapping-var self) 146 ,(attribute-mapping-depth self) 147 #t 148 (quote-syntax ,source-name))) 149 (datum->syntax here-stx code stx)) 150 (attribute-mapping-var self))))) 151 (define (attribute-mapping-var a) (attribute-mapping-ref a 0)) 152 (define (attribute-mapping-name a) (attribute-mapping-ref a 1)) 153 (define (attribute-mapping-depth a) (attribute-mapping-ref a 2)) 154 (define (attribute-mapping-check a) (attribute-mapping-ref a 3)) 155 156 ;; (struct metafunction (var)) 157 (define-values (struct:metafunction metafunction metafunction? metafunction-ref _mf-set!) 158 (make-struct-type 'syntax-metafunction #f 1 0 #f null (current-inspector))) 159 (define (metafunction-var mf) (metafunction-ref mf 0)) 160 161 (define (ht-guide? x) 162 (if (and (pair? x) (eq? (car x) 'h-t)) #t #f)) 163 (define (ht-guide-t x) 164 (if (and (pair? x) (eq? (car x) 'h-t)) (cadr x) #f)) 165 166 (define (const-guide? x) (or (and (pair? x) (eq? (car x) 't-const)) (equal? x '(t-list)))) 167 (define (const-guide-v x) 168 (if (eq? (car x) 't-list) 169 null 170 (let ([e (cadr x)]) 171 (if (eq? (car e) 'syntax-e) (syntax-e (cadr (cadr e))) (cadr e))))) 172 173 (define (cons-guide g1 g2) 174 (cond [(eq? (car g2) 't-list) (list* 't-list g1 (cdr g2))] 175 [(eq? (car g2) 't-list*) (list* 't-list* g1 (cdr g2))] 176 [else (list 't-list* g1 g2)])) 177 178 ;; ---------------------------------------- 179 ;; Parsing templates 180 181 ;; parse-template : Syntax Syntax Boolean -> (values (listof PVar) Guide (Listof Id)) 182 (define (parse-template ctx t stx?) 183 ;; env : Hasheq[ (cons syntax-mapping Nat) => PVar ] 184 (define env (make-hasheq)) 185 186 ;; wrong-syntax : Syntax Format-String Any ... -> (error) 187 (define (wrong-syntax x fmt . args) (raise-syntax-error #f (apply format fmt args) ctx x)) 188 189 ;; disappeared-uses : (Listof Id) 190 (define disappeared-uses null) 191 ;; disappeared! : Id -> Void 192 (define (disappeared! id) (set! disappeared-uses (cons id disappeared-uses))) 193 194 ;; parse-t : Stx Nat Boolean -> (values (dsetof PVar) Guide) 195 (define (parse-t t depth esc?) 196 (cond [(stx-pair? t) 197 (if (identifier? (stx-car t)) 198 (parse-t-pair/command t depth esc?) 199 (parse-t-pair/dots t depth esc?))] 200 [else (parse-t-nonpair t depth esc?)])) 201 202 ;; parse-t-pair/command : Stx Nat Boolean -> ... 203 ;; t is a stxpair w/ id in car; check if it is a "command" (metafun, escape, etc) 204 (define (parse-t-pair/command t depth esc?) 205 (cond [esc? 206 (parse-t-pair/dots t depth esc?)] 207 [(parse-form t (quote-syntax ...) 1) 208 => (lambda (t) 209 (disappeared! (car t)) 210 (define-values (drivers guide) (parse-t (cadr t) depth #t)) 211 ;; Preserve t-escaped so that (t-escaped (t-const _)) != (t-const _) 212 (values drivers `(t-escaped ,guide)))] 213 [(parse-form t (quote-syntax ~?) 2) 214 => (lambda (t) 215 (disappeared! (car t)) 216 (define t1 (cadr t)) 217 (define t2 (caddr t)) 218 (define-values (drivers1 guide1) (parse-t t1 depth esc?)) 219 (define-values (drivers2 guide2) (parse-t t2 depth esc?)) 220 (values (dset-union drivers1 drivers2) `(t-orelse ,guide1 ,guide2)))] 221 [(lookup-metafun (stx-car t)) 222 => (lambda (mf) 223 (unless stx? (wrong-syntax (stx-car t) "metafunctions are not supported")) 224 (disappeared! (stx-car t)) 225 (define-values (drivers guide) (parse-t (stx-cdr t) depth esc?)) 226 (values drivers 227 `(t-metafun ,(metafunction-var mf) ,guide 228 (quote-syntax 229 ,(let ([tstx (and (syntax? t) t)]) 230 (datum->syntax tstx (cons (stx-car t) #f) tstx tstx))))))] 231 [else (parse-t-pair/dots t depth esc?)])) 232 233 ;; parse-t-pair/dots : Stx Nat Boolean -> ... 234 ;; t is a stx pair; check for dots 235 (define (parse-t-pair/dots t depth esc?) 236 (define head (stx-car t)) 237 (define-values (tail nesting) 238 (let loop ([tail (stx-cdr t)] [nesting 0]) 239 (if (and (not esc?) (stx-pair? tail) 240 (let ([x (stx-car tail)]) 241 (and (identifier? x) (free-identifier=? x (quote-syntax ...))))) 242 (begin (disappeared! (stx-car tail)) (loop (stx-cdr tail) (add1 nesting))) 243 (values tail nesting)))) 244 (if (zero? nesting) 245 (parse-t-pair/normal t depth esc?) 246 (let-values ([(hdrivers hguide) (parse-h head (+ depth nesting) esc?)] 247 [(tdrivers tguide) (parse-t tail depth esc?)]) 248 (when (dset-empty? hdrivers) 249 (wrong-syntax head "no pattern variables before ellipsis in template")) 250 (when (dset-empty? (dset-filter hdrivers (pvar/dd<=? depth))) 251 (let ([bad-dots ;; select the nestingth (last) ellipsis as the bad one 252 (stx-car (stx-drop nesting t))]) 253 ;; FIXME: improve error message? 254 (wrong-syntax bad-dots "too many ellipses in template"))) 255 ;; hdrivers is (listof (dsetof pvar)) 256 (define hdriverss ;; per level 257 (let loop ([i 0]) 258 (if (< i nesting) 259 (cons (dset-filter hdrivers (pvar/dd<=? (+ depth i))) 260 (loop (add1 i))) 261 null))) 262 (define at-stx (datum->syntax #f '... head)) 263 (define hg 264 (let loop ([hdriverss hdriverss]) 265 (cond [(null? (cdr hdriverss)) 266 (let ([cons? (ht-guide? hguide)] 267 [hguide (if (ht-guide? hguide) (ht-guide-t hguide) hguide)]) 268 `(t-dots ,cons? ,hguide ,(car hdriverss) 269 (quote ,head) (quote-syntax ,at-stx)))] 270 [else (let ([inner (loop (cdr hdriverss))]) 271 `(t-dots #f ,inner ,(car hdriverss) 272 (quote ,head) (quote-syntax ,at-stx)))]))) 273 (values (dset-union hdrivers tdrivers) 274 (if (equal? tguide '(t-list)) 275 (resyntax t hg) 276 (resyntax t `(t-append ,hg ,tguide))))))) 277 278 ;; parse-t-pair/normal : Stx Nat Boolean -> ... 279 ;; t is a normal stx pair 280 (define (parse-t-pair/normal t depth esc?) 281 (define-values (hdrivers hguide) (parse-h (stx-car t) depth esc?)) 282 (define-values (tdrivers tguide) (parse-t (stx-cdr t) depth esc?)) 283 (values (dset-union hdrivers tdrivers) 284 (resyntax t 285 (if (ht-guide? hguide) 286 (let ([hguide (ht-guide-t hguide)]) 287 (if (and (const-guide? hguide) (const-guide? tguide)) 288 (const-guide t) 289 (cons-guide hguide tguide))) 290 (if (equal? tguide '(t-list)) 291 hguide 292 `(t-append ,hguide ,tguide)))))) 293 294 ;; parse-t-nonpair : Syntax Nat Boolean -> ... 295 ;; PRE: t is not a stxpair 296 (define (parse-t-nonpair t depth esc?) 297 (define td (if (syntax? t) (syntax-e t) t)) 298 (cond [(identifier? t) 299 (cond [(and (not esc?) 300 (or (free-identifier=? t (quote-syntax ...)) 301 (free-identifier=? t (quote-syntax ~?)) 302 (free-identifier=? t (quote-syntax ~@)))) 303 (wrong-syntax t "illegal use")] 304 [(lookup-metafun t) 305 (wrong-syntax t "illegal use of syntax metafunction")] 306 [(lookup t depth) 307 => (lambda (pvar) 308 (disappeared! t) 309 (values (dset pvar) 310 (cond [(pvar-check pvar) 311 => (lambda (check) 312 `(#%expression 313 (,check ,(pvar-lvar pvar) 0 #t (quote-syntax ,t))))] 314 [else `(t-var ,(pvar-lvar pvar))])))] 315 [else (values (dset) (const-guide t))])] 316 [(vector? td) 317 (define-values (drivers guide) (parse-t (vector->list td) depth esc?)) 318 (values drivers 319 (cond [(const-guide? guide) (const-guide t)] 320 [else (resyntax t `(t-vector ,guide))]))] 321 [(prefab-struct-key td) 322 => (lambda (key) 323 (define-values (drivers guide) 324 (let ([elems (cdr (vector->list (struct->vector td)))]) 325 (parse-t elems depth esc?))) 326 (values drivers 327 (cond [(const-guide? guide) (const-guide t)] 328 [else (resyntax t `(t-struct (quote ,key) ,guide))])))] 329 [(box? td) 330 (define-values (drivers guide) (parse-t (unbox td) depth esc?)) 331 (values drivers (if (const-guide? guide) (const-guide t) (resyntax t `(t-box ,guide))))] 332 [else (values (dset) (const-guide t))])) 333 334 ;; parse-h : Syntax Nat Boolean -> (values (dsetof PVar) HeadGuide) 335 (define (parse-h h depth esc?) 336 (cond [(and (not esc?) (parse-form h (quote-syntax ~?) 1)) 337 => (lambda (h) 338 (disappeared! (car h)) 339 (define-values (drivers guide) (parse-h (cadr h) depth esc?)) 340 (values drivers `(h-orelse ,guide null)))] 341 [(and (not esc?) (parse-form h (quote-syntax ~?) 2)) 342 => (lambda (h) 343 (disappeared! (car h)) 344 (define-values (drivers1 guide1) (parse-h (cadr h) depth esc?)) 345 (define-values (drivers2 guide2) (parse-h (caddr h) depth esc?)) 346 (values (dset-union drivers1 drivers2) 347 (if (and (ht-guide? guide1) (ht-guide? guide2)) 348 `(h-t (t-orelse ,(ht-guide-t guide1) ,(ht-guide-t guide2))) 349 `(h-orelse ,guide1 ,guide2))))] 350 [(and (stx-pair? h) 351 (let ([h-head (stx-car h)]) 352 (and (identifier? h-head) 353 (or (and (free-identifier=? h-head (quote-syntax ~@)) (not esc?)) 354 (free-identifier=? h-head (quote-syntax ~@!)))))) 355 (disappeared! (stx-car h)) 356 (define-values (drivers guide) (parse-t (stx-cdr h) depth esc?)) 357 (values drivers `(h-splice ,guide (quote ,h) (quote-syntax ,(stx-car h))))] 358 [else 359 (define-values (drivers guide) (parse-t h depth esc?)) 360 (values drivers `(h-t ,guide))])) 361 362 ;; lookup : Identifier Nat -> PVar/#f 363 (define (lookup id depth) 364 (define (make-pvar var check pvar-depth) 365 (cond [(zero? pvar-depth) 366 (pvar var var check #f)] 367 [(>= depth pvar-depth) 368 (pvar var (gentemp) check (- depth pvar-depth))] 369 [(zero? depth) 370 (wrong-syntax id "missing ellipsis with pattern variable in template")] 371 [else 372 (wrong-syntax id "too few ellipses for pattern variable in template")])) 373 (define (hash-ref! h k proc) 374 (let ([v (hash-ref h k #f)]) (if v v (let ([v* (proc)]) (hash-set! h k v*) v*)))) 375 (let ([v (syntax-local-value id (lambda () #f))]) 376 (cond [(syntax-pattern-variable? v) 377 (hash-ref! env (cons v depth) 378 (lambda () 379 (define pvar-depth (syntax-mapping-depth v)) 380 (define attr 381 (let ([attr (syntax-local-value (syntax-mapping-valvar v) (lambda () #f))]) 382 (and (attribute-mapping? attr) attr))) 383 (define var (if attr (attribute-mapping-var attr) (syntax-mapping-valvar v))) 384 (define check (and attr (attribute-mapping-check attr))) 385 (make-pvar var check pvar-depth)))] 386 [(s-exp-pattern-variable? v) 387 (hash-ref! env (cons v depth) 388 (lambda () 389 (define pvar-depth (s-exp-mapping-depth v)) 390 (define var (s-exp-mapping-valvar v)) 391 (make-pvar var #f pvar-depth)))] 392 [else 393 ;; id is a constant; check that for all x s.t. id = x.y, x is not an attribute 394 (for-each 395 (lambda (pfx) 396 (let ([pfx-v (syntax-local-value pfx (lambda () #f))]) 397 (if (and (syntax-pattern-variable? pfx-v) 398 (let ([valvar (syntax-mapping-valvar pfx-v)]) 399 (attribute-mapping? (syntax-local-value valvar (lambda () #f))))) 400 (wrong-syntax id "undefined nested attribute of attribute `~a'" 401 (syntax-e pfx)) 402 (void)))) 403 (dotted-prefixes id)) 404 #f]))) 405 406 ;; resyntax : Stx Guide -> Guide 407 (define (resyntax t0 g) 408 (if (and stx? (syntax? t0)) 409 (cond [(const-guide? g) (const-guide t0)] 410 [else (optimize-resyntax t0 g)]) 411 g)) 412 413 ;; optimize-resyntax : Syntax Guide -> Guide 414 (define (optimize-resyntax t0 g) 415 (define HOLE (datum->syntax #f '_)) 416 (define (finish i rt rs re) 417 (values (sub1 i) (reverse rs) (reverse re) 418 (datum->syntax t0 (apply list* (reverse rt)) t0 t0))) 419 (define (loop-gs list*? gs i rt rs re) 420 (cond [(null? gs) 421 (finish i (cons null rt) rs re)] 422 [(and list*? (null? (cdr gs))) 423 (loop-g (car gs) i rt rs re)] 424 [else 425 (define g0 (car gs)) 426 (cond [(const-guide? g0) 427 (let ([const (const-guide-v g0)]) 428 (loop-gs list*? (cdr gs) (add1 i) (cons const rt) rs re))] 429 [(eq? (car g0) 't-subst) ;; (t-subst LOC STX <substs>) 430 (let ([subt (cadr (list-ref g0 2))] ;; extract from (quote-syntax _) 431 [subargs (list-tail g0 3)]) 432 (loop-gs list*? (cdr gs) (add1 i) (cons subt rt) 433 (list* i 'recur rs) (cons `(list . ,subargs) re)))] 434 [else (loop-gs list*? (cdr gs) (add1 i) (cons HOLE rt) 435 (cons i rs) (cons g0 re))])])) 436 (define (loop-g g i rt rs re) 437 (cond [(eq? (car g) 't-list) (loop-gs #f (cdr g) i rt rs re)] 438 [(eq? (car g) 't-list*) (loop-gs #t (cdr g) i rt rs re)] 439 [(eq? (car g) 't-append) 440 (loop-g (caddr g) (add1 i) (cons HOLE rt) 441 (list* i 'append rs) (cons (cadr g) re))] 442 [(eq? (car g) 't-const) 443 (let ([const (const-guide-v g)]) 444 (finish i (cons const rt) rs re))] 445 [else (finish i (cons HOLE rt) (list* i 'tail rs) (cons g re))])) 446 (define-values (npairs substs exprs t*) (loop-g g 0 null null null)) 447 (cond [(and substs 448 ;; Tunable condition for choosing whether to create a t-subst. 449 ;; Avoid creating useless (t-subst loc stx '(tail 0) g). 450 (<= (length substs) (* 2 npairs))) 451 #;(log-message template-logger 'debug 452 (format "OPTIMIZED ~s" (syntax->datum t0)) #f) 453 `(t-subst #f (quote-syntax ,t*) (quote ,substs) . ,exprs)] 454 [else 455 #;(log-message template-logger 'debug 456 (format "NOT opt ~s" (syntax->datum t0)) #f) 457 (let ([rep (datum->syntax t0 'STX t0 t0)]) 458 `(t-resyntax #f (quote-syntax ,rep) ,g))])) 459 460 ;; const-guide : Any -> Guide 461 (define (const-guide x) 462 (cond [(null? x) `(t-list)] 463 [(not stx?) `(t-const (quote ,x))] 464 [(syntax? x) `(t-const (quote-syntax ,x))] 465 [else `(t-const (syntax-e (quote-syntax ,(datum->syntax #f x))))])) 466 467 (let-values ([(drivers guide) (parse-t t 0 #f)]) 468 (values (dset->list drivers) guide disappeared-uses))) 469 470 ;; parse-form : Stx Id Nat -> (list[arity+1] Syntax) 471 (define (parse-form stx form-id arity) 472 (and (stx-pair? stx) 473 (let ([stx-h (stx-car stx)] [stx-t (stx-cdr stx)]) 474 (and (identifier? stx-h) (free-identifier=? stx-h form-id) 475 (let ([stx-tl (stx->list stx-t)]) 476 (and (list? stx-tl) 477 (= (length stx-tl) arity) 478 (cons stx-h stx-tl))))))) 479 480 ;; lookup-metafun : Identifier -> Metafunction/#f 481 (define (lookup-metafun id) 482 (define v (syntax-local-value id (lambda () #f))) 483 (and (metafunction? v) v)) 484 485 (define (dotted-prefixes id) 486 (let* ([id-string (symbol->string (syntax-e id))] 487 [dot-locations 488 (let loop ([i 0]) 489 (if (< i (string-length id-string)) 490 (if (eqv? (string-ref id-string i) #\.) 491 (cons i (loop (add1 i))) 492 (loop (add1 i))) 493 null))]) 494 (map (lambda (loc) (datum->syntax id (string->symbol (substring id-string 0 loc)))) 495 dot-locations))) 496 497 (define (pvar/dd<=? expected-dd) 498 (lambda (x) (let ([dd (pvar-dd x)]) (and dd (<= dd expected-dd))))) 499 500 (define gentemp-counter 0) 501 (define (gentemp) 502 (set! gentemp-counter (add1 gentemp-counter)) 503 ((make-syntax-introducer) 504 (datum->syntax #f (string->symbol (format "pv_~s" gentemp-counter))))) 505 506 (define (stx-drop n x) 507 (if (zero? n) x (stx-drop (sub1 n) (stx-cdr x)))) 508 509 ;; ---------------------------------------- 510 ;; Deterministic Sets 511 ;; FIXME: detect big unions, use hash table 512 513 (define (dset . xs) xs) 514 (define (dset-empty? ds) (null? ds)) 515 (define (dset-filter ds pred) (filter pred ds)) 516 (define (dset->list ds) ds) 517 (define (dset-union ds1 ds2) 518 (if (pair? ds1) 519 (let ([elem (car ds1)]) 520 (if (member elem ds2) 521 (dset-union (cdr ds1) ds2) 522 (dset-union (cdr ds1) (cons (car ds1) ds2)))) 523 ds2)) 524 525 (define (filter keep? xs) 526 (if (pair? xs) 527 (if (keep? (car xs)) 528 (cons (car xs) (filter keep? (cdr xs))) 529 (filter keep? (cdr xs))) 530 null)) 531 532 ;; ---------------------------------------- 533 ;; Relocating (eg, syntax/loc) 534 535 ;; Only relocate if relocation would affect a syntax pair originating 536 ;; from template structure. For example (x,y are pvars): 537 ;; (syntax/loc loc-stx (1 2 3)) => relocate 538 ;; (syntax/loc loc-stx y) => don't relocate 539 ;; (syntax/loc loc-stx (x ... . y) => relocate iff at least one x! 540 ;; Deciding whether to relocate after the fact is hard. But with explicit 541 ;; t-resyntax, it's much easier. 542 543 ;; relocate-guide : Syntax Guide Id -> Guide 544 (define (relocate-guide ctx g0 loc-id) 545 (define (loop g) 546 (define gtag (car g)) 547 (cond [(eq? gtag 't-resyntax) 548 `(t-resyntax ,loc-id . ,(cddr g))] 549 [(eq? gtag 't-const) 550 `(t-relocate ,g ,loc-id)] 551 [(eq? gtag 't-subst) 552 `(t-subst ,loc-id . ,(cddr g))] 553 ;; ---- 554 [(eq? gtag 't-escaped) 555 `(t-escaped ,(loop (cadr g)))] 556 [(eq? gtag 't-orelse) 557 `(t-orelse ,(loop (cadr g)) ,(loop (caddr g)))] 558 ;; ---- 559 ;; Nothing else should be relocated 560 [else g])) 561 (loop g0)) 562 563 ;; ---------------------------------------- 564 565 ;; do-template : Syntax Syntax Id/#f Boolean -> Syntax 566 (define (do-template ctx tstx loc-id stx?) 567 (define-values (pvars pre-guide disappeared-uses) 568 (parse-template ctx tstx stx?)) 569 (define guide (if loc-id (relocate-guide ctx pre-guide loc-id) pre-guide)) 570 (define ell-pvars (filter pvar-dd pvars)) 571 (define pre-code 572 (if (const-guide? guide) 573 (if stx? `(quote-syntax ,tstx) `(quote ,tstx)) 574 (let ([lvars (map pvar-lvar ell-pvars)] 575 [valvars (map pvar-var ell-pvars)]) 576 `(let (,@(map list lvars valvars)) 577 ,(datum->syntax here-stx guide))))) 578 (define code (syntax-arm (datum->syntax here-stx pre-code ctx))) 579 (syntax-property code 'disappeared-use (map syntax-local-introduce disappeared-uses))) 580 ) 581 582 (define-syntax (syntax stx) 583 (define s (syntax->list stx)) 584 (if (and (list? s) (= (length s) 2)) 585 (do-template stx (cadr s) #f #t) 586 (raise-syntax-error #f "bad syntax" stx))) 587 588 (define-syntax (syntax/loc stx) 589 (define s (syntax->list stx)) 590 (if (and (list? s) (= (length s) 3)) 591 (let ([loc-id (quote-syntax loc)]) 592 (define code 593 `(let ([,loc-id (check-loc (quote ,(car s)) ,(cadr s))]) 594 ,(do-template stx (caddr s) loc-id #t))) 595 (syntax-arm (datum->syntax here-stx code stx))) 596 (raise-syntax-error #f "bad syntax" stx))) 597 598 (define-syntax (datum stx) 599 (define s (syntax->list stx)) 600 (if (and (list? s) (= (length s) 2)) 601 (do-template stx (cadr s) #f #f) 602 (raise-syntax-error #f "bad syntax" stx))) 603 604 ;; check-loc : Symbol Any -> (U Syntax #f) 605 ;; Raise exn if not syntax. Returns same syntax if suitable for srcloc 606 ;; (ie, if at least syntax-source or syntax-position set), #f otherwise. 607 (define (check-loc who x) 608 (if (syntax? x) 609 (if (or (syntax-source x) (syntax-position x)) 610 x 611 #f) 612 (raise-argument-error who "syntax?" x))) 613 614 ;; ============================================================ 615 ;; Run-time support 616 617 ;; (t-dots cons? hguide hdrivers) : Expr[(Listof Syntax)] 618 (define-syntax (t-dots stx) 619 (define s (syntax->list stx)) 620 (define cons? (syntax-e (list-ref s 1))) 621 (define head (list-ref s 2)) 622 (define drivers (map syntax-e (syntax->list (list-ref s 3)))) ;; (Listof PVar) 623 (define in-stx (list-ref s 4)) 624 (define at-stx (list-ref s 5)) 625 (cond 626 ;; Case 1: (x ...) where x is trusted 627 [(and cons? (let ([head-s (syntax->list head)]) 628 (and (pair? head-s) (eq? (syntax-e (car head-s)) 't-var)))) 629 head] 630 ;; General case 631 [else 632 ;; var-value-expr : Id Id/#'#f -> Expr[List] 633 (define (var-value-expr lvar check) 634 (if (syntax-e check) `(,check ,lvar 1 #f #f) lvar)) 635 (define lvars (map pvar-lvar drivers)) 636 (define checks (map pvar-check drivers)) 637 (define code 638 `(let ,(map list lvars (map var-value-expr lvars checks)) 639 ,(if (> (length lvars) 1) `(check-same-length ,in-stx ,at-stx . ,lvars) '(void)) 640 ,(if cons? 641 `(map (lambda ,lvars ,head) . ,lvars) 642 `(apply append (map (lambda ,lvars ,head) . ,lvars))))) 643 (datum->syntax here-stx code stx)])) 644 645 (define-syntaxes (t-orelse h-orelse) 646 (let () 647 (define (orelse-transformer stx) 648 (define s (syntax->list stx)) 649 (datum->syntax here-stx 650 `(t-orelse* (lambda () ,(cadr s)) (lambda () ,(caddr s))))) 651 (values orelse-transformer orelse-transformer))) 652 653 (#%require (rename '#%kernel t-const #%expression) 654 (rename '#%kernel t-var #%expression) 655 ;; (rename '#%kernel t-append append) 656 (rename '#%kernel t-list list) 657 (rename '#%kernel t-list* list*) 658 (rename '#%kernel t-escaped #%expression) 659 (rename '#%kernel t-vector list->vector) 660 (rename '#%kernel t-box box-immutable) 661 (rename '#%kernel h-t list)) 662 663 (begin-encourage-inline 664 665 (define (t-append xs ys) (if (null? ys) xs (append xs ys))) 666 (define (t-resyntax loc stx g) (datum->syntax stx g (or loc stx) stx)) 667 (define (t-relocate g loc) (datum->syntax g (syntax-e g) (or loc g) g)) 668 (define (t-orelse* g1 g2) 669 ((let/ec escape 670 (with-continuation-mark 671 absent-pvar-escape-key 672 (lambda () (escape g2)) 673 (let ([v (g1)]) (lambda () v)))))) 674 (define (t-struct key g) (apply make-prefab-struct key g)) 675 (define (t-metafun mf g stx) 676 (mf (datum->syntax stx (cons (stx-car stx) g) stx stx))) 677 (define (h-splice g in-stx at-stx) 678 (if (stx-list? g) (stx->list g) (error/splice g in-stx at-stx))) 679 680 #| end begin-encourage-inline |#) 681 682 ;; t-subst : Syntax/#f Syntax Substs Any ... -> Syntax 683 ;; where Substs = '() | (cons Nat Substs) | (list* (U 'tail 'append 'recur) Nat Substs) 684 ;; There is one arg for each index in substs. See also defn of Guide above. 685 (define (t-subst loc stx substs . args) 686 (define (loop/mode s i mode seek substs args) 687 (cond [(< i seek) (cons (car s) (loop/mode (cdr s) (add1 i) mode seek substs args))] 688 [(eq? mode #f) (cons (car args) (loop (cdr s) (add1 i) substs (cdr args)))] 689 [(eq? mode 'tail) (car args)] 690 [(eq? mode 'append) (append (car args) (loop (cdr s) (add1 i) substs (cdr args)))] 691 [(eq? mode 'recur) (cons (apply t-subst #f (car s) (car args)) 692 (loop (cdr s) (add1 i) substs (cdr args)))])) 693 (define (loop s i substs args) 694 (cond [(null? substs) s] 695 [(symbol? (car substs)) 696 (loop/mode s i (car substs) (cadr substs) (cddr substs) args)] 697 [else (loop/mode s i #f (car substs) (cdr substs) args)])) 698 (define v (loop (syntax-e stx) 0 substs args)) 699 (datum->syntax stx v (or loc stx) stx)) 700 701 (define absent-pvar-escape-key (gensym 'absent-pvar-escape)) 702 703 ;; signal-absent-pvar : -> escapes or #f 704 ;; Note: Only escapes if in ~? form. 705 (define (signal-absent-pvar) 706 (let ([escape (continuation-mark-set-first #f absent-pvar-escape-key)]) 707 (if escape (escape) #f))) 708 709 ;; error/splice : Any Stx Stx -> (escapes) 710 (define (error/splice r in-stx at-stx) 711 (raise-syntax-error 'syntax 712 (format "splicing template did not produce a syntax list\n got: ~e" r) in-stx at-stx)) 713 714 ;; check-same-length : Stx Stx List ... -> Void 715 (define check-same-length 716 (case-lambda 717 [(in at a) (void)] 718 [(in at a b) 719 (if (= (length a) (length b)) 720 (void) 721 (raise-syntax-error 'syntax "incompatible ellipsis match counts for template" 722 (list in '...) at))] 723 [(in at a . bs) 724 (define alen (length a)) 725 (for-each (lambda (b) 726 (if (= alen (length b)) 727 (void) 728 (raise-syntax-error 'syntax "incompatible ellipsis match counts for template" 729 (list in '...) at))) 730 bs)])) 731 732 )