suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

Fixes a bug in the elimination of continuation values

Browse Source
This commit is contained in:
Casey Klein 2010-12-30 14:42:17 -06:00
parent a6e40bfb03
commit 8b50aeb346
2 changed files with 27 additions and 14 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

11
collects/redex/examples/delim-cont/randomized-tests-test.rkt
View File

@ -124,6 +124,17 @@
5)) 5))
"134" 5) "134" 5)
(test-transformation
(<>
()
()
(cont 0
(dw x
#f
(cons (cont 1 hole) hole)
(print 2))))
"" procedure)
(define (transformation-preserves-meaning? p) (define (transformation-preserves-meaning? p)
(let ([original-result (parameterize ([model-eval-steps 1000]) (model-eval p))] (let ([original-result (parameterize ([model-eval-steps 1000]) (model-eval p))]
[transformed (transform-intermediate p)] [transformed (transform-intermediate p)]

30
collects/redex/examples/delim-cont/randomized-tests.rkt
View File

@ -278,7 +278,7 @@
(define cell (fresh prefix)) (define cell (fresh prefix))
(set! allocated (cons cell allocated)) (set! allocated (cons cell allocated))
cell) cell)
(define no-dw? (alloc-cell "handlers-disabled?")) (define capts (alloc-cell "active-cont-capts"))
(define dw-frame-locs (define dw-frame-locs
(let ([locs (make-hash)]) (let ([locs (make-hash)])
(λ (x) (λ (x)
@ -301,15 +301,15 @@
[t (fresh "t")]) [t (fresh "t")])
`((λ (,t) `((λ (,t)
(if ,a? (if ,a?
(begin (if ,no-dw? #f (set! ,s? #t)) (,c ,t)) (begin (if (zero? ,capts) (set! ,s? #t) #f) (,c ,t))
(% 1 (% 1
(dynamic-wind (dynamic-wind
(λ () (λ ()
(if ,no-dw? (if (zero? ,capts)
#f
(if ,a? (if ,a?
(if ,s? (set! ,s? #f) ,(transform e1)) (if ,s? (set! ,s? #f) ,(transform e1))
#f))) #f)
#f))
(λ () (λ ()
((call/comp ((call/comp
(λ (k) (λ (k)
@ -318,22 +318,22 @@
(abort 1 k))) (abort 1 k)))
1))) 1)))
(λ () (λ ()
(if ,no-dw? (if (zero? ,capts)
(set! ,a? #t)
(if ,a? (if ,a?
,(transform e3) ,(transform e3)
(set! ,a? #t))))) (set! ,a? #t))
(λ (k) (begin (if ,no-dw? #f (set! ,s? #t)) (k ,t)))))) (set! ,a? #t))))
(λ (k) (begin (if (zero? ,capts) (set! ,s? #t) #f) (k ,t))))))
(λ () ,(transform e2))))] (λ () ,(transform e2))))]
[`(cont ,v ,E) [`(cont ,v ,E)
(let ([x (fresh "v")]) (let ([x (fresh "v")])
`(begin `(begin
(set! ,no-dw? #t) (set! ,capts (+ ,capts 1))
((λ (,x) ((λ (,x)
(% ,x (% ,x
,(transform ,(transform
(term (plug ,E (call/cc (λ (k) (abort ,x k)) ,x)))) (term (plug ,E (call/cc (λ (k) (abort ,x k)) ,x))))
(λ (x) (begin (set! ,no-dw? #f) x)))) (λ (x) (begin (set! ,capts (+ ,capts -1)) x))))
,(transform v))))] ,(transform v))))]
[`(comp ,E) [`(comp ,E)
(define numbers (define numbers
@ -343,11 +343,11 @@
[_ (list)])) [_ (list)]))
(define t (add1 (apply max 0 (numbers E)))) (define t (add1 (apply max 0 (numbers E))))
`(begin `(begin
(set! ,no-dw? #t) (set! ,capts (+ ,capts 1))
(% ,t (% ,t
,(transform ,(transform
(term (plug ,E (call/comp (λ (k) (abort ,t k)) ,t)))) (term (plug ,E (call/comp (λ (k) (abort ,t k)) ,t))))
(λ (x) (begin (set! ,no-dw? #f) x))))] (λ (x) (begin (set! ,capts (+ ,capts -1)) x))))]
[`(list ,vs ...) [`(list ,vs ...)
`(list ,@(map transform-value vs))] `(list ,@(map transform-value vs))]
[(? list? xs) [(? list? xs)
@ -365,7 +365,9 @@
[(list _ v’) (list x v’)])) [(list _ v’) (list x v’)]))
allocated) allocated)
,o ,o
,e’)])) (begin
(set! ,capts 0)
,e’))]))
;; The built-in `plug' sometimes chooses the wrong hole. ;; The built-in `plug' sometimes chooses the wrong hole.
(define-metafunction grammar (define-metafunction grammar