source: project/release/4/F-operator/trunk/shift-reset.scm @ 15941

Last change on this file since 15941 was 15941, checked in by Kon Lovett, 10 years ago

Rel 2.0.0 for Chicken 4

File size: 4.4 KB
Line 
1;;;; shift-reset.scm
2;;;; Kon Lovett, Apr 6 '06
3
4;; Dynamically scoped shift/reset (Olivier Danvy & Andrzej Filinski)
5
6(module shift-reset (;export
7  ;;
8  (%reset *%reset) (%shift *%shift)
9  (reset *reset) (shift *shift)
10  (%reset-values *%reset-values) (%shift-values *%shift-values)
11  (reset-values *reset-values) (shift-values *shift-values)
12  ;;
13  *%reset *%shift
14  *reset *shift
15  *%reset-values *%shift-values
16  *reset-values *shift-values)
17
18  (import scheme
19          (except chicken reset)
20          (only miscmacros let/cc))
21
22  (require-library miscmacros)
23
24  (declare
25                (always-bound
26                        *meta-dk*
27                        *meta-k*
28                        *meta-dkv*
29                        *meta-kv*))
30
31(define-syntax %reset
32  (syntax-rules ()
33    ((_ BODY ...) (*%reset (lambda () BODY ...)) ) ) )
34
35(define-syntax %shift
36  (syntax-rules ()
37    ((_ SP BODY ...) (*%shift (lambda (SP) BODY ...)) ) ) )
38
39(define-syntax reset
40  (syntax-rules ()
41    ((_ BODY ...) (*reset (lambda () BODY ...)) ) ) )
42
43(define-syntax shift
44  (syntax-rules ()
45    ((_ SP BODY ...) (*shift (lambda (SP) BODY ...)) ) ) )
46
47(define-syntax %reset-values
48  (syntax-rules ()
49    ((_ BODY ...) (*%reset-values (lambda () BODY ...)) ) ) )
50
51(define-syntax %shift-values
52  (syntax-rules ()
53    ((_ SP BODY ...) (*%shift-values (lambda (SP) BODY ...)) ) ) )
54
55(define-syntax reset-values
56  (syntax-rules ()
57    ((_ BODY ...) (*reset-values (lambda () BODY ...)) ) ) )
58
59(define-syntax shift-values
60  (syntax-rules ()
61    ((_ SP BODY ...) (*shift-values (lambda (SP) BODY ...)) ) ) )
62
63;;
64;; Local impl of continuation binding
65;;
66
67(define-syntax let/scc
68  (syntax-rules ()
69    ((_ K BODY ...) (##sys#call-with-current-continuation (lambda (K) BODY ...)) ) ) )
70
71(define-syntax let/cdc
72  (syntax-rules ()
73    ((_ K BODY ...) (##sys#call-with-direct-continuation (lambda (K) BODY ...)) ) ) )
74
75(define-syntax let/ccp
76  (syntax-rules ()
77    ((_ K BODY ...) (continuation-capture (lambda (K) BODY ...)) ) ) )
78
79;;
80;; Common error
81;;
82
83(define (bad-k s r) (error s "no toplevel in scope" r))
84
85;;
86;; Single Valued - Without Dynamic-Wind
87;;
88
89(define *meta-dk* (lambda (val) (bad-k '%shift '%reset)))
90
91(define (*%return EXPR) (##sys#direct-return *meta-dk* EXPR))
92
93(define (*%reset thunk)
94  (let ((meta-dk *meta-dk*))
95    (let ((val (let/cdc k
96                 (set! *meta-dk* k)
97                 (*%return (thunk)))))
98      (set! *meta-dk* meta-dk)
99      val) ) )
100
101(define (*%shift proc)
102  (let/cdc k
103    (*%return
104      (proc
105        (lambda (val)
106          (*%reset
107            (lambda ()
108              (##sys#direct-return k val)))))) ) )
109
110;;
111;; Single Valued - With Dynamic-Wind
112;;
113
114(define *meta-k* (lambda (val) (bad-k 'shift 'reset)))
115
116(define-syntax *return
117  (syntax-rules ()
118    ((_ EXPR) (*meta-k* EXPR)) ) )
119
120(define (*reset thunk)
121  (let ((meta-k *meta-k*))
122    (let/cc k
123      (set! *meta-k*
124        (lambda (val)
125          (set! *meta-k* meta-k)
126          (k val)))
127      (*return (thunk)) ) ) )
128
129(define (*shift proc)
130  (let/cc k
131    (*return (proc (lambda (val) (*reset (lambda () (k val)))))) ) )
132
133;;
134;; Multi-Valued - Without Dynamic-Wind
135;;
136
137(define *meta-dkv* (lambda vals (bad-k '%shift-values '%reset-values)))
138
139(define-syntax *%return-values
140  (syntax-rules ()
141    ((_ EXPR)
142      (call-with-values
143        (lambda () EXPR)
144        (lambda vals (apply *meta-dkv* vals))) ) ) )
145
146(define (*%reset-values thunk)
147  (let ((meta-dkv *meta-dkv*))
148    (call-with-values
149      (lambda ()
150        (let/scc k
151          (set! *meta-dkv* k)
152          (*%return-values (thunk))))
153      (lambda vals
154        (set! *meta-dkv* meta-dkv)
155        (apply values vals))) ) )
156
157(define (*%shift-values proc)
158  (let/scc k
159    (*%return-values (proc (lambda vals (*%reset-values (lambda () (apply k vals)))))) ) )
160
161;;
162;; Multi-Valued - With Dynamic-Wind
163;;
164
165(define *meta-kv* (void))
166
167(define-syntax *return-values
168  (syntax-rules ()
169    ((_ EXPR CALLER)
170      (if (continuation? *meta-kv*) (continuation-graft *meta-kv* (lambda () EXPR))
171          (bad-k CALLER 'reset-values) ) ) ) )
172
173(define (*reset-values thunk)
174  (let ((meta-kv *meta-kv*))
175    (call-with-values
176      (lambda ()
177        (let/ccp k
178          (set! *meta-kv* k)
179          (call-with-values
180            thunk
181            (lambda vals
182              (*return-values (apply values vals) 'reset-values)))))
183      (lambda vals
184        (set! *meta-kv* meta-kv)
185        (apply values vals))) ) )
186
187(define (*shift-values proc)
188  (let/ccp k
189    (*return-values
190      (proc (lambda vals (*reset-values (lambda () (apply continuation-return k vals)))))
191      'shift-values) ) )
192
193) ;module shift-reset
Note: See TracBrowser for help on using the repository browser.