source: project/release/4/F-operator/trunk/bshift-breset.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: 6.4 KB
Line 
1;;;; bshift-breset.scm
2;;;; Kon Lovett, Apr 6 '06
3
4;; Statically scoped shift/reset (Oleg Kiselyov)
5
6(module bshift-breset (;export
7  ;;
8  (%breset *%breset) (%bshift *%bshift)
9  (breset *breset) (bshift *bshift)
10  (%breset-values *%breset-values) (%bshift-values *%bshift-values)
11  (breset-values *breset-values) (bshift-values *bshift-values)
12  ;;
13  *%breset *%bshift
14  *breset *bshift
15  *%breset-values *%bshift-values
16  *breset-values *bshift-values
17  ;;
18  $range-empty-tag)
19
20  (import scheme chicken
21          (only miscmacros let/cc)
22          (only box make-box *box-structure? *box-structure-ref *box-structure-set!))
23
24  (require-library miscmacros box)
25
26(define-syntax %breset
27  (syntax-rules ()
28    ((_ RC BODY ...) (*%breset (lambda (RC) BODY ...) 'RC) ) ) )
29
30(define-syntax %bshift
31  (syntax-rules ()
32    ((_ RC SP BODY ...) (*%bshift RC (lambda (SP) BODY ...) 'RC) ) ) )
33
34(define-syntax breset
35  (syntax-rules ()
36    ((_ RC BODY ...) (*breset (lambda (RC) BODY ...) 'RC) ) ) )
37
38(define-syntax bshift
39  (syntax-rules ()
40    ((_ RC SP BODY ...) (*bshift RC (lambda (SP) BODY ...) 'RC) ) ) )
41
42(define-syntax %breset-values
43  (syntax-rules ()
44    ((_ RC BODY ...) (*%breset-values (lambda (RC) BODY ...) 'RC) ) ) )
45
46(define-syntax %bshift-values
47  (syntax-rules ()
48    ((_ RC SP BODY ...) (*%bshift-values RC (lambda (SP) BODY ...) 'RC) ) ) )
49
50(define-syntax breset-values
51  (syntax-rules ()
52    ((_ RC BODY ...) (*breset-values (lambda (RC) BODY ...) 'RC) ) ) )
53
54(define-syntax bshift-values
55  (syntax-rules ()
56    ((_ RC SP BODY ...) (*bshift-values RC (lambda (SP) BODY ...) 'RC) ) ) )
57
58;;
59;; Local impl of continuation binding
60;;
61
62(define-syntax let/scc
63  (syntax-rules ()
64    ((_ K BODY ...) (##sys#call-with-current-continuation (lambda (K) BODY ...)) ) ) )
65
66(define-syntax let/cdc
67  (syntax-rules ()
68    ((_ K BODY ...) (##sys#call-with-direct-continuation (lambda (K) BODY ...)) ) ) )
69
70(define-syntax let/ccp
71  (syntax-rules ()
72    ((_ K BODY ...) (continuation-capture (lambda (K) BODY ...)) ) ) )
73
74;;
75;; Common error
76;;
77
78(define (bad-dk s r) (error s "no toplevel in scope" r))
79
80;;
81;; Unique value for range macro
82;;
83
84(define ($range-empty-tag) $range-empty-tag)
85
86;;
87;; Single valued - Without Dynamic-Wind
88;;
89
90(define-syntax *%breturn
91        (syntax-rules ()
92                ((_ RC EXPR RC-SYM CALLER)
93      (let ((val EXPR) (rc RC))
94        (if (not (*box-structure? rc)) (bad-dk CALLER RC-SYM)
95            (let ((rc-k (*box-structure-ref rc)))
96              (when (procedure? rc-k)
97                (##sys#direct-return rc-k val) ) ) ) ) ) ) )
98
99(define (*%breset proc rc-sym)
100  (let/cdc rc-k
101    (let ((rc (make-box rc-k)))
102      (*%breturn rc (proc rc) rc-sym '%breset) ) ) ) 
103
104(define (*%bshift rc proc rc-sym)
105  (let/cdc s-k
106    (*%breturn rc
107      (proc
108        (lambda (val)
109          (if (not (*box-structure? rc)) (bad-dk '%bshift rc-sym)
110              (let ((old-rc (*box-structure-ref rc)))
111                (let ((s-val
112                        (let/cdc rc-k
113                          (*box-structure-set! rc rc-k)
114                          (##sys#direct-return s-k val))))
115                  (*box-structure-set! rc old-rc)
116                  s-val)))))
117      rc-sym '%bshift) ) )
118
119;;
120;; Single valued - With Dynamic-Wind
121;;
122
123(define-syntax *breturn
124        (syntax-rules ()
125                ((_ RC EXPR RC-SYM CALLER)
126      (let ((val EXPR) (rc RC))
127        (if (not (*box-structure? rc)) (bad-dk CALLER RC-SYM)
128            (let ((rc-proc (*box-structure-ref rc)))
129              (when (procedure? rc-proc)
130                (rc-proc val) ) ) ) ) ) ) )
131
132(define (*breset proc rc-sym)
133  (let/cc rc-k
134    (let ((rc (make-box rc-k)))
135      (*breturn rc (proc rc) rc-sym 'breset) ) ) )
136
137(define (*bshift rc proc rc-sym)
138  (let/cc s-k
139    (*breturn rc
140      (proc
141        (lambda (val)
142          (if (not (*box-structure? rc)) (bad-dk 'bshift rc-sym)
143              (let ((old-rc (*box-structure-ref rc)))
144                (let ((s-val
145                        (let/cc rc-k
146                          (*box-structure-set! rc rc-k)
147                          (s-k val))))
148                  (*box-structure-set! rc old-rc)
149                  s-val)))))
150      rc-sym 'bshift) ) )
151
152;;
153;; Multiple valued - Without Dynamic-Wind
154;;
155
156(define-syntax *%breturn-values
157        (syntax-rules ()
158                ((_ RC EXPR RC-SYM CALLER)
159      (let ((rc RC))
160        (call-with-values
161          (lambda () EXPR)
162          (lambda vals
163            (if (not (*box-structure? rc)) (bad-dk CALLER RC-SYM)
164                (let ((rc-k (*box-structure-ref rc)))
165                  (when (procedure? rc-k)
166                    (apply rc-k vals)))))) ) ) ) )
167
168(define (*%breset-values proc rc-sym)
169  (let/scc rc-k
170    (let ((rc (make-box rc-k)))
171      (*%breturn-values rc (proc rc) rc-sym '%breset-values) ) ) )
172
173(define (*%bshift-values rc proc rc-sym)
174  (let/scc s-k
175    (*%breturn-values rc
176      (proc
177        (lambda vals
178          (if (not (*box-structure? rc)) (bad-dk '%bshift-values rc-sym)
179              (let ((old-rc (*box-structure-ref rc)))
180                (call-with-values
181                  (lambda ()
182                    (let/scc rc-k
183                      (*box-structure-set! rc rc-k)
184                      (apply s-k vals)))
185                  (lambda s-vals
186                    (*box-structure-set! rc old-rc)
187                    (apply values s-vals)))))))
188      rc-sym '%bshift-values) ) )
189
190;;
191;; Multiple valued - With Dynamic-Wind
192;;
193
194(define-syntax *breturn-values
195        (syntax-rules ()
196                ((_ RC EXPR RC-SYM CALLER)
197      (let ((rc RC))
198        (call-with-values
199          (lambda () EXPR)
200          (lambda vals
201            (if (not (*box-structure? rc)) (bad-dk CALLER RC-SYM)
202                (let ((rc-k (*box-structure-ref rc)))
203                  (when (continuation? rc-k)
204                    (apply continuation-return rc-k vals)))))) ) ) ) )
205
206(define (*breset-values proc rc-sym)
207  (let/ccp rc-k
208    (let ((rc (make-box rc-k)))
209      (*breturn-values rc (proc rc) rc-sym 'breset-values) ) ) )
210
211(define (*bshift-values rc proc rc-sym)
212  (let/ccp s-k
213    (*breturn-values rc
214      (proc
215        (lambda vals
216          (if (not (*box-structure? rc)) (bad-dk 'bshift-values rc-sym)
217              (let ((old-rc (*box-structure-ref rc)))
218                (call-with-values
219                  (lambda ()
220                    (let/ccp rc-k
221                      (*box-structure-set! rc rc-k)
222                      (apply continuation-return s-k vals)))
223                  (lambda s-vals
224                    (*box-structure-set! rc old-rc)
225                    (apply values s-vals)))))))
226      rc-sym 'bshift-values) ) )
227
228) ;module bshift-breset
Note: See TracBrowser for help on using the repository browser.