patch-arrows.rkt (4340B)
1 #lang racket 2 3 (require (for-template (only-in '#%kernel [module* k:module*]) 4 '#%kernel) 5 phc-toolkit/untyped 6 syntax/parse 7 racket/syntax 8 racket/list 9 racket/contract 10 syntax/id-table 11 syntax/strip-context 12 "fully-expanded-grammar-extract-bindings.rkt") 13 14 (provide patch-arrows) 15 16 17 (define/contract (patch-arrows stx) 18 (-> syntax? syntax?) 19 (define fully-expanded 20 ;; TODO: local-expand/capture-lifts is probably not what we want here, 21 ;; instead we should just let the lifted expressions pass through. 22 (local-expand/capture-lifts stx 'expression (list #'k:module*)) 23 #;(local-expand stx 'expression (list #'k:module*))) 24 (define extracted-list (extract-bindings fully-expanded)) 25 (define bindings-table (make-immutable-free-id-table (map cons 26 extracted-list 27 extracted-list))) 28 (define patched-acc '()) 29 30 (define/contract (patch-srcloc id) 31 (-> identifier? (or/c #f identifier?)) 32 (define table-ref (free-id-table-ref bindings-table id #f)) 33 (if (and table-ref 34 ;; all info missing, i.e. (datum->syntax #'lctx 'sym #f) was used 35 (not (or (syntax-source id) 36 (syntax-position id) 37 (syntax-line id) 38 (syntax-column id)))) 39 (datum->syntax id (syntax-e id) table-ref id) 40 #f)) 41 42 (fold-syntax 43 (λ (stx rec) 44 (define maybe-patched-binders 45 (for*/list ([p* (in-value (syntax-property stx 'sub-range-binders))] 46 #:when p* 47 [p (in-list (flatten p*))]) 48 (match p 49 [(vector (? identifier? d) d-start d-len 50 (? identifier? s) s-start s-len) 51 (let ([patched-d (patch-srcloc d)] 52 [patched-s (patch-srcloc s)]) 53 (and (or patched-d patched-s) 54 (vector (or patched-d d) d-start d-len 55 (or patched-s s) s-start s-len)))] 56 [(vector (? identifier? d) d-start d-len d-x d-y 57 (? identifier? s) s-start s-len s-x s-y) 58 (let ([patched-d (patch-srcloc d)] 59 [patched-s (patch-srcloc s)]) 60 (and (or patched-d patched-s) 61 (vector (or patched-d d) d-start d-len d-x d-y 62 (or patched-s s) s-start s-len s-x s-y)))] 63 [other #| not a sub-range-binder |# #f]))) 64 (define patched-binders (filter identity maybe-patched-binders)) 65 (when (not (null? patched-binders)) 66 (set! patched-acc (cons patched-binders patched-acc))) 67 68 (rec stx)) 69 fully-expanded) 70 71 (define existing-property (or (syntax-property fully-expanded 72 'sub-range-binders) 73 '())) 74 (syntax-property fully-expanded 75 'sub-range-binders 76 (cons patched-acc existing-property))) 77 78 ;Example usage: 79 #;(module* test racket 80 (require phc-toolkit/untyped) 81 (require (for-syntax (submod ".."))) 82 (require (for-syntax phc-toolkit/untyped 83 racket/syntax)) 84 85 (define-for-syntax saved (box #f)) 86 87 (define-syntax/case (foo y) () 88 (with-arrows 89 (record-sub-range-binders! (vector #'y 90 1 1 91 (datum->syntax #'y 92 (unbox saved) 93 #f) 94 1 1)) 95 (record-disappeared-uses #'y) 96 #'(define y 1))) 97 98 (define-syntax/case (bar body) () 99 (set-box! saved 'aa) 100 (patch-arrows #'body)) 101 102 103 (bar 104 (begin 105 'aa 106 (let ([aa 1]) 107 (let ([aa 1]) 108 ;; The arrow is drawn from bb to the binding of aa above, thanks to 109 ;; the fact that the srcloc is #f for the arrow's origin id. The 110 ;; patch-arrows function detects that, and substitutes the 111 ;; corresponding definition. 112 ;; 113 ;; Note that it correctly binds to the nearest let, not the outer aa. 114 (foo bb) 115 aa)))))