1;;  Filename : test-dyn-extent.scm
2;;  About    : unit test for dynamic extent
3;;
4;;  Copyright (C) 2005-2006 YAMAMOTO Kengo <yamaken AT bp.iij4u.or.jp>
5;;  Copyright (c) 2007-2008 SigScheme Project <uim-en AT googlegroups.com>
6;;
7;;  All rights reserved.
8;;
9;;  Redistribution and use in source and binary forms, with or without
10;;  modification, are permitted provided that the following conditions
11;;  are met:
12;;
13;;  1. Redistributions of source code must retain the above copyright
14;;     notice, this list of conditions and the following disclaimer.
15;;  2. Redistributions in binary form must reproduce the above copyright
16;;     notice, this list of conditions and the following disclaimer in the
17;;     documentation and/or other materials provided with the distribution.
18;;  3. Neither the name of authors nor the names of its contributors
19;;     may be used to endorse or promote products derived from this software
20;;     without specific prior written permission.
21;;
22;;  THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ``AS
23;;  IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,
24;;  THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
25;;  PURPOSE ARE DISCLAIMED.  IN NO EVENT SHALL THE COPYRIGHT HOLDERS OR
26;;  CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL,
27;;  EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO,
28;;  PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR
29;;  PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF
30;;  LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
31;;  NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
32;;  SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
33
34(require-extension (unittest))
35
36(if (not (symbol-bound? 'dynamic-wind))
37    (test-skip "R5RS dynamic-wind is not enabled"))
38
39(define *test-track-progress* #f)
40(define tn test-name)
41
42;;
43;; dynamic-wind
44;;
45
46(define dynwind-res '())
47(define append-sym!
48  (lambda (sym)
49    (set! dynwind-res (append dynwind-res (list sym)))))
50
51(tn "dynamic-wind: without escape")
52;; no escape with depth 1
53(set! dynwind-res '())
54(assert-equal? (tn)
55               '(before thunk after)
56               (begin
57                 (dynamic-wind
58                     (lambda ()
59                       (append-sym! 'before))
60                     (lambda ()
61                       (append-sym! 'thunk))
62                     (lambda ()
63                       (append-sym! 'after)))
64                 dynwind-res))
65
66;; no escape with depth 2
67(set! dynwind-res '())
68(assert-equal? (tn)
69               '(before1 thunk1 before2 thunk2 after2 after1)
70               (begin
71                 (dynamic-wind
72                     (lambda ()
73                       (append-sym! 'before1))
74                     (lambda ()
75                       (append-sym! 'thunk1)
76                       (dynamic-wind
77                           (lambda ()
78                             (append-sym! 'before2))
79                           (lambda ()
80                             (append-sym! 'thunk2))
81                           (lambda ()
82                             (append-sym! 'after2))))
83                     (lambda ()
84                       (append-sym! 'after1)))
85                 dynwind-res))
86
87;; no escape with depth 3
88(set! dynwind-res '())
89(assert-equal? (tn)
90               '(before1 thunk1 before2 thunk2 before3 thunk3
91                 after3 after2 after1)
92               (begin
93                 (dynamic-wind
94                     (lambda ()
95                       (append-sym! 'before1))
96                     (lambda ()
97                       (append-sym! 'thunk1)
98                       (dynamic-wind
99                           (lambda ()
100                             (append-sym! 'before2))
101                           (lambda ()
102                             (append-sym! 'thunk2)
103                             (dynamic-wind
104                                 (lambda ()
105                                   (append-sym! 'before3))
106                                 (lambda ()
107                                   (append-sym! 'thunk3))
108                                 (lambda ()
109                                   (append-sym! 'after3))))
110                           (lambda ()
111                             (append-sym! 'after2))))
112                     (lambda ()
113                       (append-sym! 'after1)))
114                 dynwind-res))
115
116(tn "dynamic-wind: escape from deeper thunk")
117;; escape from thunk1
118(set! dynwind-res '())
119(assert-equal? (tn)
120               '(before thunk after)
121               (begin
122                 (call/cc
123                  (lambda (k)
124                    (dynamic-wind
125                        (lambda ()
126                          (append-sym! 'before))
127                        (lambda ()
128                          (append-sym! 'thunk)
129                          (k #f))
130                        (lambda ()
131                          (append-sym! 'after)))))
132                 dynwind-res))
133
134;; escape from thunk2
135(set! dynwind-res '())
136(assert-equal? (tn)
137               '(before1 thunk1 before2 thunk2 after2 after1)
138               (begin
139                 (call/cc
140                  (lambda (k)
141                    (dynamic-wind
142                        (lambda ()
143                          (append-sym! 'before1))
144                        (lambda ()
145                          (append-sym! 'thunk1)
146                          (dynamic-wind
147                              (lambda ()
148                                (append-sym! 'before2))
149                              (lambda ()
150                                (append-sym! 'thunk2)
151                                (k #f))
152                              (lambda ()
153                                (append-sym! 'after2))))
154                        (lambda ()
155                          (append-sym! 'after1)))))
156                 dynwind-res))
157
158;; escape from thunk3
159(set! dynwind-res '())
160(assert-equal? (tn)
161               '(before1 thunk1 before2 thunk2 before3 thunk3
162                         after3 after2 after1)
163               (begin
164                 (call/cc
165                  (lambda (k)
166                    (dynamic-wind
167                        (lambda ()
168                          (append-sym! 'before1))
169                        (lambda ()
170                          (append-sym! 'thunk1)
171                          (dynamic-wind
172                              (lambda ()
173                                (append-sym! 'before2))
174                              (lambda ()
175                                (append-sym! 'thunk2)
176                                (dynamic-wind
177                                    (lambda ()
178                                      (append-sym! 'before3))
179                                    (lambda ()
180                                      (append-sym! 'thunk3)
181                                      (k #f))
182                                    (lambda ()
183                                      (append-sym! 'after3))))
184                              (lambda ()
185                                (append-sym! 'after2))))
186                        (lambda ()
187                          (append-sym! 'after1)))))
188                 dynwind-res))
189
190;; escape from thunk3 to thunk1
191(set! dynwind-res '())
192(assert-equal? (tn)
193               '(before1 thunk1 before2 thunk2 before3 thunk3
194                         after3 after2 after1)
195               (begin
196                 (dynamic-wind
197                     (lambda ()
198                       (append-sym! 'before1))
199                     (lambda ()
200                       (append-sym! 'thunk1)
201                       (call/cc
202                        (lambda (k)
203                          (dynamic-wind
204                              (lambda ()
205                                (append-sym! 'before2))
206                              (lambda ()
207                                (append-sym! 'thunk2)
208                                (dynamic-wind
209                                    (lambda ()
210                                      (append-sym! 'before3))
211                                    (lambda ()
212                                      (append-sym! 'thunk3)
213                                      (k #f))
214                                    (lambda ()
215                                      (append-sym! 'after3))))
216                              (lambda ()
217                                (append-sym! 'after2))))))
218                     (lambda ()
219                       (append-sym! 'after1)))
220                 dynwind-res))
221
222;; escape from thunk3 to thunk2
223(set! dynwind-res '())
224(assert-equal? (tn)
225               '(before1 thunk1 before2 thunk2 before3 thunk3
226                         after3 after2 after1)
227               (begin
228                 (dynamic-wind
229                     (lambda ()
230                       (append-sym! 'before1))
231                     (lambda ()
232                       (append-sym! 'thunk1)
233                       (dynamic-wind
234                           (lambda ()
235                             (append-sym! 'before2))
236                           (lambda ()
237                             (append-sym! 'thunk2)
238                             (call/cc
239                              (lambda (k)
240                                (dynamic-wind
241                                    (lambda ()
242                                      (append-sym! 'before3))
243                                    (lambda ()
244                                      (append-sym! 'thunk3)
245                                      (k #f))
246                                    (lambda ()
247                                      (append-sym! 'after3))))))
248                           (lambda ()
249                             (append-sym! 'after2))))
250                     (lambda ()
251                       (append-sym! 'after1)))
252                 dynwind-res))
253
254;; escape from thunk3 to thunk3
255(set! dynwind-res '())
256(assert-equal? (tn)
257               '(before1 thunk1 before2 thunk2 before3 thunk3
258                         after3 after2 after1)
259               (begin
260                 (dynamic-wind
261                     (lambda ()
262                       (append-sym! 'before1))
263                     (lambda ()
264                       (append-sym! 'thunk1)
265                       (dynamic-wind
266                           (lambda ()
267                             (append-sym! 'before2))
268                           (lambda ()
269                             (append-sym! 'thunk2)
270                                (dynamic-wind
271                                    (lambda ()
272                                      (append-sym! 'before3))
273                                    (lambda ()
274                                      (call/cc
275                                       (lambda (k)
276                                         (append-sym! 'thunk3)
277                                         (k #f))))
278                                    (lambda ()
279                                      (append-sym! 'after3))))
280                           (lambda ()
281                             (append-sym! 'after2))))
282                     (lambda ()
283                       (append-sym! 'after1)))
284                 dynwind-res))
285
286(tn "dynamic-wind: SigScheme-specific escape behavior")
287;; R5RS: 6.4 Control features
288;; > The effect of using a captured continuation to enter or exit the dynamic
289;; > extent of a call to before or after is undefined.
290
291;; escape from before3 to thunk1
292(set! dynwind-res '())
293(if (provided? "sigscheme")
294    (assert-equal? (tn)
295                   '(before1 thunk1 before2 thunk2 before3 after2 after1)
296                   (begin
297                     (dynamic-wind
298                         (lambda ()
299                           (append-sym! 'before1))
300                         (lambda ()
301                           (append-sym! 'thunk1)
302                           (call/cc
303                            (lambda (k)
304                              (dynamic-wind
305                                  (lambda ()
306                                    (append-sym! 'before2))
307                                  (lambda ()
308                                    (append-sym! 'thunk2)
309                                    (dynamic-wind
310                                        (lambda ()
311                                          (append-sym! 'before3)
312                                          (k #f))
313                                        (lambda ()
314                                          (append-sym! 'thunk3))
315                                        (lambda ()
316                                          (append-sym! 'after3))))
317                                  (lambda ()
318                                    (append-sym! 'after2))))))
319                         (lambda ()
320                           (append-sym! 'after1)))
321                     dynwind-res)))
322
323;; escape from after3 to thunk1
324(set! dynwind-res '())
325(if (provided? "sigscheme")
326    (assert-equal? (tn)
327                   '(before1 thunk1 before2 thunk2 before3 thunk3
328                             after3 after2 after1)
329                   (begin
330                     (dynamic-wind
331                         (lambda ()
332                           (append-sym! 'before1))
333                         (lambda ()
334                           (append-sym! 'thunk1)
335                           (call/cc
336                            (lambda (k)
337                              (dynamic-wind
338                                  (lambda ()
339                                    (append-sym! 'before2))
340                                  (lambda ()
341                                    (append-sym! 'thunk2)
342                                    (dynamic-wind
343                                        (lambda ()
344                                          (append-sym! 'before3))
345                                        (lambda ()
346                                          (append-sym! 'thunk3))
347                                        (lambda ()
348                                          (append-sym! 'after3)
349                                          (k #f))))
350                                  (lambda ()
351                                    (append-sym! 'after2))))))
352                         (lambda ()
353                           (append-sym! 'after1)))
354                     dynwind-res)))
355
356;; thunk3 -> after3 -> thunk1
357(set! dynwind-res '())
358(if (provided? "sigscheme")
359    (assert-equal? (tn)
360                   '(before1 thunk1 before2 thunk2 before3 thunk3
361                             after3 after2 after1)
362                   (begin
363                     (dynamic-wind
364                         (lambda ()
365                           (append-sym! 'before1))
366                         (lambda ()
367                           (append-sym! 'thunk1)
368                           (call/cc
369                            (lambda (k)
370                              (dynamic-wind
371                                  (lambda ()
372                                    (append-sym! 'before2))
373                                  (lambda ()
374                                    (append-sym! 'thunk2)
375                                    (call/cc
376                                     (lambda (j)
377                                       (dynamic-wind
378                                           (lambda ()
379                                             (append-sym! 'before3))
380                                           (lambda ()
381                                             (append-sym! 'thunk3)
382                                             (j #f))
383                                           (lambda ()
384                                             (append-sym! 'after3)
385                                             (k #f))))))
386                                  (lambda ()
387                                    (append-sym! 'after2))))))
388                         (lambda ()
389                           (append-sym! 'after1)))
390                     dynwind-res)))
391
392
393(total-report)
394