1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
|
; Part of Scheme 48 1.9. See file COPYING for notices and license.
; Authors: Richard Kelsey, Jonathan Rees
; A state space is a tree with the state at the root. Each node other
; than the root is a triple <before, after, parent>, represented in
; this implementation as a structure ((before . after) . parent).
; Moving from one state to another means re-rooting the tree by pointer
; reversal.
(define *here* (list #f))
(define original-cwcc call-with-current-continuation)
(define (call-with-current-continuation proc)
(let ((here *here*))
(original-cwcc (lambda (cont)
(proc (lambda results
(reroot! here)
(apply cont results)))))))
(define (dynamic-wind before during after)
(let ((here *here*))
(reroot! (cons (cons before after) here))
(call-with-values during
(lambda results
(reroot! here)
(apply values results)))))
(define (reroot! there)
(if (not (eq? *here* there))
(begin (reroot! (cdr there))
(let ((before (caar there))
(after (cdar there)))
(set-car! *here* (cons after before))
(set-cdr! *here* there)
(set-car! there #f)
(set-cdr! there '())
(set! *here* there)
(before)))))
; -----
;
;(define r #f) (define s #f) (define (p x) (write x) (newline))
;(define (tst)
; (set! r *here*)
; (set! s (cons (cons (lambda () (p 'in)) (lambda () (p 'out))) *here*))
; (reroot! s))
;
;
;(define (check) ;Algorithm invariants
; (if (not (null? (cdr *here*)))
; (assertion-violation 'check "confusion #1"))
; (if (car *here*)
; (assertion-violation 'check "confusion #2")))
|
