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