|
1 | 1 | #lang racket/base
|
2 | 2 | (require (for-template racket/base)
|
3 | 3 | syntax/kerncase
|
| 4 | + syntax/id-table |
4 | 5 | racket/list
|
5 | 6 | racket/contract
|
6 | 7 | racket/match
|
|
31 | 32 | (define (make-anormal-term elim-letrec-term)
|
32 | 33 | (define (anormal-term stx)
|
33 | 34 | (anormal id stx))
|
| 35 | + |
| 36 | + (define (detect-set!-ids* bm-map stx-l) |
| 37 | + (for ([x (in-list (syntax->list stx-l))]) |
| 38 | + (detect-set!-ids bm-map x))) |
| 39 | + |
| 40 | + (define (detect-set!-ids bm-map stx) |
| 41 | + (kernel-syntax-case |
| 42 | + (disarm stx) (transformer?) |
| 43 | + [(begin fbe be ...) |
| 44 | + (detect-set!-ids* bm-map #'(fbe be ...))] |
| 45 | + [(begin0 fbe be ...) |
| 46 | + (detect-set!-ids* bm-map #'(fbe be ...))] |
| 47 | + [(set! v ve) |
| 48 | + (unless (bound-id-table-ref bm-map #'v 'none) |
| 49 | + (bound-id-table-set! bm-map #'v #t)) |
| 50 | + (detect-set!-ids* bm-map #'(ve))] |
| 51 | + [(let-values ([(v ...) ve] ...) be ...) |
| 52 | + (detect-set!-ids* bm-map #'(ve ... be ...))] |
| 53 | + [(letrec-values ([(v ...) ve] ...) be ...) |
| 54 | + (detect-set!-ids* bm-map #'(ve ... be ...))] |
| 55 | + [(#%plain-lambda formals be ...) |
| 56 | + (detect-set!-ids* bm-map #'(be ...))] |
| 57 | + [(case-lambda [formals be ...] ...) |
| 58 | + (detect-set!-ids* bm-map #'(be ... ...))] |
| 59 | + [(if te ce ae) |
| 60 | + (detect-set!-ids* bm-map #'(te ce ae))] |
| 61 | + [(quote datum) |
| 62 | + (void)] |
| 63 | + [(quote-syntax datum) |
| 64 | + (void)] |
| 65 | + [(with-continuation-mark ke me be) |
| 66 | + (detect-set!-ids* bm-map #'(ke me be))] |
| 67 | + [(#%plain-app fe e ...) |
| 68 | + (detect-set!-ids* bm-map #'(fe e ...))] |
| 69 | + [(#%top . v) |
| 70 | + (void)] |
| 71 | + [(#%variable-reference . v) |
| 72 | + (void)] |
| 73 | + [id (identifier? #'id) |
| 74 | + (void)] |
| 75 | + [(letrec-syntaxes+values ([(sv ...) se] ...) |
| 76 | + ([(vv ...) ve] ...) |
| 77 | + be ...) |
| 78 | + (detect-set!-ids* bm-map #'(se ... ve ... be ...))] |
| 79 | + [(#%expression d) |
| 80 | + (detect-set!-ids* bm-map #'(d))] |
| 81 | + [_ |
| 82 | + (raise-syntax-error 'detect-set!-ids "Dropped through:" stx)])) |
| 83 | + |
| 84 | + (define (remove-set!-ids* bm-map stx-l) |
| 85 | + (for/list ([x (in-list (syntax->list stx-l))]) |
| 86 | + (remove-set!-ids bm-map x))) |
| 87 | + |
| 88 | + (define (remove-set!-ids** bm-map stx-l) |
| 89 | + (for/list ([x (in-list (syntax->list stx-l))]) |
| 90 | + (remove-set!-ids* bm-map x))) |
| 91 | + |
| 92 | + (define (remove-set!-ids bm-map stx) |
| 93 | + (rearm |
| 94 | + stx |
| 95 | + (kernel-syntax-case |
| 96 | + (disarm stx) (transformer?) |
| 97 | + [(begin fbe be ...) |
| 98 | + (with-syntax ([(nfbe nbe ...) |
| 99 | + (remove-set!-ids* bm-map #'(fbe be ...))]) |
| 100 | + (syntax/loc stx |
| 101 | + (begin nfbe nbe ...)))] |
| 102 | + [(begin0 fbe be ...) |
| 103 | + (with-syntax ([(nfbe nbe ...) |
| 104 | + (remove-set!-ids* bm-map #'(fbe be ...))]) |
| 105 | + (syntax/loc stx |
| 106 | + (begin0 nfbe nbe ...)))] |
| 107 | + [(set! v ve) |
| 108 | + (with-syntax ([nve (remove-set!-ids bm-map #'ve)]) |
| 109 | + (if (bound-id-table-ref bm-map #'v #f) |
| 110 | + (syntax/loc stx |
| 111 | + (#%plain-app set-box! v nve)) |
| 112 | + (syntax/loc stx |
| 113 | + (set! v nve))))] |
| 114 | + [(let-values ([(v ...) ve] ...) be ...) |
| 115 | + (with-syntax ([(nve ...) (remove-set!-ids* bm-map #'(ve ...))] |
| 116 | + [(nbe ...) (remove-set!-ids* bm-map #'(be ...))]) |
| 117 | + (syntax/loc stx |
| 118 | + (let-values ([(v ...) nve] ...) nbe ...)))] |
| 119 | + [(letrec-values ([(v ...) ve] ...) be ...) |
| 120 | + (with-syntax ([(nve ...) (remove-set!-ids* bm-map #'(ve ...))] |
| 121 | + [(nbe ...) (remove-set!-ids* bm-map #'(be ...))]) |
| 122 | + (syntax/loc stx |
| 123 | + (letrec-values ([(v ...) nve] ...) nbe ...)))] |
| 124 | + [(#%plain-lambda formals be ...) |
| 125 | + (with-syntax ([(nbe ...) (remove-set!-ids* bm-map #'(be ...))]) |
| 126 | + (syntax/loc stx |
| 127 | + (#%plain-lambda formals nbe ...)))] |
| 128 | + [(case-lambda [formals be ...] ...) |
| 129 | + (with-syntax ([((nbe ...) ...) (remove-set!-ids** bm-map #'((be ...) ...))]) |
| 130 | + (syntax/loc stx |
| 131 | + (case-lambda [formals nbe ...] ...)))] |
| 132 | + [(if te ce ae) |
| 133 | + (with-syntax ([(nte nce nae) (remove-set!-ids* bm-map #'(te ce ae))]) |
| 134 | + (syntax/loc stx |
| 135 | + (if nte nce nae)))] |
| 136 | + [(quote datum) |
| 137 | + stx] |
| 138 | + [(quote-syntax datum) |
| 139 | + stx] |
| 140 | + [(with-continuation-mark ke me be) |
| 141 | + (with-syntax ([(nke nme nbe) (remove-set!-ids* bm-map #'(ke me be))]) |
| 142 | + (syntax/loc stx |
| 143 | + (with-continuation-mark nke nme nbe)))] |
| 144 | + [(#%plain-app fe e ...) |
| 145 | + (with-syntax ([(nfe ne ...) (remove-set!-ids* bm-map #'(fe e ...))]) |
| 146 | + (syntax/loc stx |
| 147 | + (#%plain-app nfe ne ...)))] |
| 148 | + [(#%top . v) |
| 149 | + stx] |
| 150 | + [(#%variable-reference . v) |
| 151 | + stx] |
| 152 | + [id (identifier? #'id) |
| 153 | + (if (bound-id-table-ref bm-map #'id #f) |
| 154 | + (syntax/loc stx |
| 155 | + (#%plain-app unbox id)) |
| 156 | + stx)] |
| 157 | + [(letrec-syntaxes+values ([(sv ...) se] ...) |
| 158 | + ([(vv ...) ve] ...) |
| 159 | + be ...) |
| 160 | + (with-syntax ([((nse ...) |
| 161 | + (nve ...) |
| 162 | + (nbe ...)) |
| 163 | + (remove-set!-ids** bm-map #'((se ...) |
| 164 | + (ve ...) |
| 165 | + (be ...)))]) |
| 166 | + (syntax/loc stx |
| 167 | + (letrec-syntaxes+values ([(sv ...) nse] ...) |
| 168 | + ([(vv ...) nve] ...) |
| 169 | + nbe ...)))] |
| 170 | + [(#%expression d) |
| 171 | + (with-syntax ([nd (remove-set!-ids bm-map #'d)]) |
| 172 | + (syntax/loc stx |
| 173 | + (#%expression nd)))] |
| 174 | + [_ |
| 175 | + (raise-syntax-error 'remove-set!-ids "Dropped through:" stx)]))) |
34 | 176 |
|
35 | 177 | (define (anormal ctxt stx)
|
36 | 178 | (rearm
|
|
92 | 234 | [(letrec-values ([(v ...) ve] ...) be ...)
|
93 | 235 | (anormal ctxt
|
94 | 236 | (elim-letrec-term stx))]
|
| 237 | + [(#%plain-lambda formals be) |
| 238 | + (let () |
| 239 | + (define the-formals (formals-list #'formals)) |
| 240 | + (define bm-map (make-bound-id-table)) |
| 241 | + (for ([f (in-list the-formals)]) |
| 242 | + (bound-id-table-set! bm-map f #f)) |
| 243 | + (detect-set!-ids bm-map #'be) |
| 244 | + (define set!less-be (remove-set!-ids bm-map #'be)) |
| 245 | + (define set!-ids |
| 246 | + (filter (λ (f) |
| 247 | + (bound-id-table-ref bm-map f #f)) |
| 248 | + the-formals)) |
| 249 | + (define set!less+boxed-be |
| 250 | + (with-syntax ([(f ...) set!-ids]) |
| 251 | + (quasisyntax/loc stx |
| 252 | + (let-values ([(f) (#%plain-app box f)] |
| 253 | + ...) |
| 254 | + #,set!less-be)))) |
| 255 | + (with-syntax ([nbe (anormal-term set!less+boxed-be)]) |
| 256 | + (ctxt (syntax/loc stx (#%plain-lambda formals nbe)))))] |
95 | 257 | [(#%plain-lambda formals be ...)
|
96 |
| - (with-syntax ([nbe (anormal-term (syntax/loc stx (begin be ...)))]) |
97 |
| - (ctxt (syntax/loc stx (#%plain-lambda formals nbe))))] |
| 258 | + (anormal ctxt |
| 259 | + (syntax/loc stx |
| 260 | + (#%plain-lambda formals (begin be ...))))] |
98 | 261 | [(case-lambda [formals be] ...)
|
99 | 262 | (with-syntax ([(be ...) (map anormal-term (syntax->list #'(be ...)))])
|
100 | 263 | (ctxt (syntax/loc stx (case-lambda [formals be] ...))))]
|
|
0 commit comments