parameterize-lexical-context.rkt (5610B)
1 #lang racket 2 3 (require (for-template racket/base) 4 syntax/parse 5 syntax/id-table 6 (for-syntax syntax/parse 7 racket/syntax 8 syntax/parse/experimental/template) 9 debug-scopes) 10 11 (provide with-bindings 12 with-rec-bindings 13 tl-redirections 14 start-tl-redirections 15 f-start-tl-redirections 16 binding-table-find-best 17 binding-table-set! 18 make-binding-table) 19 20 (struct binding-table-struct (val)) 21 22 (define/contract tl-redirections 23 (parameter/c (or/c binding-table-struct? #f)) 24 (make-parameter #f)) 25 26 (define (make-binding-table) 27 (-> binding-table-struct?) 28 (binding-table-struct (make-hasheq))) 29 30 (define/contract (binding-table-set! table id value) 31 (-> binding-table-struct? identifier? any/c void?) 32 (let ([group (hash-ref! (binding-table-struct-val table) 33 (syntax-e id) 34 (make-bound-id-table))]) 35 (when (dict-has-key? group id) 36 (raise-syntax-error 37 'type-expander 38 "Attempted to re-bind the same identifier with the same scopes" 39 id)) 40 (bound-id-table-set! group id value))) 41 42 (define (binding-table-find-best table id fallback) 43 (-> binding-table-struct? identifier? (or/c procedure? any/c) void?) 44 (define (scopes-of i) 45 (list->set (map (λ (v) (vector-ref v 0)) 46 (hash-ref (syntax-debug-info i) 'context)))) 47 (define scopes-of-id (scopes-of id)) 48 (let* ([group (hash-ref (binding-table-struct-val table) 49 (syntax-e id) 50 (λ () (make-bound-id-table)))] 51 [candidates (filter (λ (other) 52 (subset? (car other) scopes-of-id)) 53 (bound-id-table-map group 54 (λ (a b) 55 (list (scopes-of a) a b))))]) 56 (if (= 0 (length candidates)) 57 (if (procedure? fallback) 58 (fallback) 59 fallback) 60 (let* ([best-candidate (argmax (λ (c) (set-count (car c))) 61 candidates)]) 62 (for ([c candidates]) 63 (unless (subset? (car c) (car best-candidate)) 64 (raise-syntax-error 'type-expander 65 (format "Ambiguous bindings: ~a" 66 (map (λ (c) (list (cadr c) (car c))) 67 candidates))))) 68 (caddr best-candidate))))) 69 70 (define-syntax-rule (start-tl-redirections . rest) 71 (parameterize ([tl-redirections (or (tl-redirections) 72 (make-binding-table))]) 73 . rest)) 74 75 (define-syntax-rule (f-start-tl-redirections f) 76 (λ l (start-tl-redirections (apply f l)))) 77 78 79 (define-syntax with-bindings 80 (syntax-parser 81 [(_ [{~or v1:id (v* {~and ooo {~literal ...}})} e/es] x code ...+) 82 #:with vs (if (attribute ooo) #'(v* ooo) #'(v1)) 83 #:with es (if (attribute ooo) #'e/es #'(list e/es)) 84 (template 85 (let () 86 (define ctx (make-syntax-introducer)) 87 (invariant-assertion (λ (ll) (and (list? ll) 88 (andmap identifier? ll))) 89 (syntax->list #'vs)) 90 (for ([binding (in-syntax #'vs)] 91 [value es]) 92 (binding-table-set! (tl-redirections) (ctx binding) value)) 93 (with-syntax ([(vs x) 94 (ctx #'(vs x))]) 95 code ...)))])) 96 97 (define-syntax with-rec-bindings 98 (syntax-parser 99 [(_ [{~or v1:id (v* {~and ooo {~literal ...}})} func e/es] x code ...+) 100 #:with vs (if (attribute ooo) #'(v* ooo) #'(v1)) 101 #:with es (if (attribute ooo) #'(e/es ooo) #'(e/es)) 102 (template 103 (let () 104 (define ctx (make-syntax-introducer)) 105 (define ctx2 (make-syntax-introducer #t)) 106 (invariant-assertion (λ (ll) (and (list? ll) 107 (andmap identifier? ll))) 108 (syntax->list #'vs)) 109 (for ([binding (in-syntax #'vs)] 110 [stx-value (in-syntax #'es)]) 111 (let ([vvv (func (ctx stx-value))]) 112 (binding-table-set! (tl-redirections) 113 (ctx binding) 114 vvv))) 115 (with-syntax ([(vs x) 116 (ctx2 (ctx #'(vs x)))]) 117 code ...)))])) 118 119 (provide trampoline-eval) 120 (define trampoline-result (make-parameter #f)) 121 (define (trampoline-eval code) 122 (define result 'not-yet-result) 123 (parameterize ([trampoline-result (λ (v) (set! result v))]) 124 (local-expand (syntax-local-introduce 125 #`(let-syntax ([tr ((trampoline-result) #,code)]) 126 (void))) 127 'expression 128 '())) 129 result) 130 131 132 (module+ test 133 (require rackunit) 134 (check-equal? (let () 135 (define tbl (make-binding-table)) 136 (define id #'id) 137 (binding-table-set! tbl id 123) 138 (define ctx (make-syntax-introducer)) 139 (binding-table-set! tbl (ctx id) 456) 140 (define ctx2 (make-syntax-introducer)) 141 (list (binding-table-find-best tbl id #f) 142 (binding-table-find-best tbl (ctx id) #f) 143 (binding-table-find-best tbl (ctx2 id) #f) 144 (binding-table-find-best tbl (ctx2 (ctx id)) #f) 145 (binding-table-find-best tbl (ctx (ctx2 id)) #f))) 146 '(123 456 123 456 456)))