Skip to content

Commit 151538d

Browse files
committed
Fix error discovered by Philip McGrath
1 parent 9f19018 commit 151538d

File tree

3 files changed

+211
-4
lines changed

3 files changed

+211
-4
lines changed

web-server-lib/web-server/lang/anormal.rkt

Lines changed: 165 additions & 2 deletions
Original file line numberDiff line numberDiff line change
@@ -1,6 +1,7 @@
11
#lang racket/base
22
(require (for-template racket/base)
33
syntax/kerncase
4+
syntax/id-table
45
racket/list
56
racket/contract
67
racket/match
@@ -31,6 +32,147 @@
3132
(define (make-anormal-term elim-letrec-term)
3233
(define (anormal-term stx)
3334
(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)])))
34176

35177
(define (anormal ctxt stx)
36178
(rearm
@@ -92,9 +234,30 @@
92234
[(letrec-values ([(v ...) ve] ...) be ...)
93235
(anormal ctxt
94236
(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)))))]
95257
[(#%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 ...))))]
98261
[(case-lambda [formals be] ...)
99262
(with-syntax ([(be ...) (map anormal-term (syntax->list #'(be ...)))])
100263
(ctxt (syntax/loc stx (case-lambda [formals be] ...))))]

web-server-lib/web-server/lang/util.rkt

Lines changed: 3 additions & 2 deletions
Original file line numberDiff line numberDiff line change
@@ -34,8 +34,9 @@
3434
(let ([name (datum->syntax (and stx-base (disarm stx-base)) (gensym sym-name))])
3535
(with-syntax ([(#%plain-lambda (formal) ref-to-formal)
3636
(if (syntax-transforming?)
37-
(local-expand #`(#%plain-lambda (#,name) #,name) 'expression empty)
38-
#`(#%plain-lambda (#,name) #,name))])
37+
(local-expand
38+
#`(#%plain-lambda (#,name) #,name) 'expression empty)
39+
#`(#%plain-lambda (#,name) #,name))])
3940
(values #'formal #'ref-to-formal))))
4041

4142
(define (formals-list stx)
Lines changed: 43 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,43 @@
1+
#lang web-server/base
2+
(module+ test
3+
(define (test x a b)
4+
((if (= a b) printf eprintf)
5+
"~a: ~a: ~a should be ~a\n"
6+
(if (= a b) " OK" "BAD")
7+
x
8+
a b))
9+
10+
;; Works at the top-level
11+
(define x 0)
12+
(set! x (add1 x))
13+
(test 'top-level x 1)
14+
15+
;; Works on let
16+
(let ([y 0])
17+
(set! y (add1 y))
18+
(test 'let y 1))
19+
20+
;; Works on letrec
21+
(letrec ([y 0])
22+
(set! y (add1 y))
23+
(test 'letrec y 1))
24+
25+
;; Works on define that turns into letrec
26+
(let ()
27+
(define (f x) (g y))
28+
(define y 0)
29+
(define (g x) y)
30+
(set! y (add1 y))
31+
(test 'define->letrec y 1))
32+
33+
;; Works on lambda arg
34+
((λ (y)
35+
(set! y (add1 y))
36+
(test 'lambda y 1))
37+
0)
38+
39+
;; Works on define that turns into let
40+
(let ()
41+
(define y 0)
42+
(set! y (add1 y))
43+
(test 'define->let y 1)))

0 commit comments

Comments
 (0)