source: project/release/4/F-operator/tags/3.0.0/shift-reset.scm @ 33417

Last change on this file since 33417 was 33417, checked in by Kon Lovett, 4 years ago

use setup-helper-mode. remove % forms (segfault).

File size: 4.6 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#; ;REMOVED
32(define-syntax %reset
33  (syntax-rules ()
34    ((_ BODY ...) (*%reset (lambda () BODY ...)) ) ) )
35
36#; ;REMOVED
37(define-syntax %shift
38  (syntax-rules ()
39    ((_ SP BODY ...) (*%shift (lambda (SP) BODY ...)) ) ) )
40
41(define-syntax reset
42  (syntax-rules ()
43    ((_ BODY ...) (*reset (lambda () BODY ...)) ) ) )
44
45(define-syntax shift
46  (syntax-rules ()
47    ((_ SP BODY ...) (*shift (lambda (SP) BODY ...)) ) ) )
48
49#; ;REMOVED
50(define-syntax %reset-values
51  (syntax-rules ()
52    ((_ BODY ...) (*%reset-values (lambda () BODY ...)) ) ) )
53
54#; ;REMOVED
55(define-syntax %shift-values
56  (syntax-rules ()
57    ((_ SP BODY ...) (*%shift-values (lambda (SP) BODY ...)) ) ) )
58
59(define-syntax reset-values
60  (syntax-rules ()
61    ((_ BODY ...) (*reset-values (lambda () BODY ...)) ) ) )
62
63(define-syntax shift-values
64  (syntax-rules ()
65    ((_ SP BODY ...) (*shift-values (lambda (SP) BODY ...)) ) ) )
66
67;;
68;; Local impl of continuation binding
69;;
70
71#; ;REMOVED
72(define-syntax let/scc
73  (syntax-rules ()
74    ((_ K BODY ...) (##sys#call-with-current-continuation (lambda (K) BODY ...)) ) ) )
75
76#; ;REMOVED
77(define-syntax let/cdc
78  (syntax-rules ()
79    ((_ K BODY ...) (##sys#call-with-direct-continuation (lambda (K) BODY ...)) ) ) )
80
81(define-syntax let/ccp
82  (syntax-rules ()
83    ((_ K BODY ...) (continuation-capture (lambda (K) BODY ...)) ) ) )
84
85;;
86;; Common error
87;;
88
89(define (bad-k s r) (error s "no toplevel in scope" r))
90
91;;
92;; Single Valued - Without Dynamic-Wind
93;;
94
95#; ;REMOVED
96(define *meta-dk* (lambda (val) (bad-k '%shift '%reset)))
97
98#; ;REMOVED
99(define (*%return EXPR) (##sys#direct-return *meta-dk* EXPR))
100
101#; ;REMOVED
102(define (*%reset thunk)
103  (let ((meta-dk *meta-dk*))
104    (let ((val (let/cdc k
105                 (set! *meta-dk* k)
106                 (*%return (thunk)))))
107      (set! *meta-dk* meta-dk)
108      val) ) )
109
110#; ;REMOVED
111(define (*%shift proc)
112  (let/cdc k
113    (*%return
114      (proc
115        (lambda (val)
116          (*%reset
117            (lambda ()
118              (##sys#direct-return k val)))))) ) )
119
120;;
121;; Single Valued - With Dynamic-Wind
122;;
123
124(define *meta-k* (lambda (val) (bad-k 'shift 'reset)))
125
126(define-syntax *return
127  (syntax-rules ()
128    ((_ EXPR) (*meta-k* EXPR)) ) )
129
130(define (*reset thunk)
131  (let ((meta-k *meta-k*))
132    (let/cc k
133      (set! *meta-k*
134        (lambda (val)
135          (set! *meta-k* meta-k)
136          (k val)))
137      (*return (thunk)) ) ) )
138
139(define (*shift proc)
140  (let/cc k
141    (*return (proc (lambda (val) (*reset (lambda () (k val)))))) ) )
142
143;;
144;; Multi-Valued - Without Dynamic-Wind
145;;
146
147#; ;REMOVED
148(define *meta-dkv* (lambda vals (bad-k '%shift-values '%reset-values)))
149
150#; ;REMOVED
151(define-syntax *%return-values
152  (syntax-rules ()
153    ((_ EXPR)
154      (call-with-values
155        (lambda () EXPR)
156        (lambda vals (apply *meta-dkv* vals))) ) ) )
157
158#; ;REMOVED
159(define (*%reset-values thunk)
160  (let ((meta-dkv *meta-dkv*))
161    (call-with-values
162      (lambda ()
163        (let/scc k
164          (set! *meta-dkv* k)
165          (*%return-values (thunk))))
166      (lambda vals
167        (set! *meta-dkv* meta-dkv)
168        (apply values vals))) ) )
169
170#; ;REMOVED
171(define (*%shift-values proc)
172  (let/scc k
173    (*%return-values (proc (lambda vals (*%reset-values (lambda () (apply k vals)))))) ) )
174
175;;
176;; Multi-Valued - With Dynamic-Wind
177;;
178
179(define *meta-kv* (void))
180
181(define-syntax *return-values
182  (syntax-rules ()
183    ((_ EXPR CALLER)
184      (if (continuation? *meta-kv*) (continuation-graft *meta-kv* (lambda () EXPR))
185          (bad-k CALLER 'reset-values) ) ) ) )
186
187(define (*reset-values thunk)
188  (let ((meta-kv *meta-kv*))
189    (call-with-values
190      (lambda ()
191        (let/ccp k
192          (set! *meta-kv* k)
193          (call-with-values
194            thunk
195            (lambda vals
196              (*return-values (apply values vals) 'reset-values)))))
197      (lambda vals
198        (set! *meta-kv* meta-kv)
199        (apply values vals))) ) )
200
201(define (*shift-values proc)
202  (let/ccp k
203    (*return-values
204      (proc (lambda vals (*reset-values (lambda () (apply continuation-return k vals)))))
205      'shift-values) ) )
206
207) ;module shift-reset
Note: See TracBrowser for help on using the repository browser.