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