2 ;;;; control.test --- test suite for delimited continuations
4 ;;;; Copyright (C) 2010, 2011, 2013 Free Software Foundation, Inc.
6 ;;;; This library is free software; you can redistribute it and/or
7 ;;;; modify it under the terms of the GNU Lesser General Public
8 ;;;; License as published by the Free Software Foundation; either
9 ;;;; version 3 of the License, or (at your option) any later version.
11 ;;;; This library is distributed in the hope that it will be useful,
12 ;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
13 ;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
14 ;;;; Lesser General Public License for more details.
16 ;;;; You should have received a copy of the GNU Lesser General Public
17 ;;;; License along with this library; if not, write to the Free Software
18 ;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
20 (define-module (test-suite test-control)
21 #:use-module (ice-9 control)
22 #:use-module (system vm vm)
23 #:use-module (srfi srfi-1)
24 #:use-module (srfi srfi-11)
25 #:use-module (test-suite lib))
28 ;; For these, the compiler should be able to prove that "k" is not referenced,
29 ;; so it avoids reifying the continuation. Since that's a slightly different
30 ;; codepath, we test them both.
31 (with-test-prefix/c&e "escape-only continuations"
32 (pass-if "no values, normal exit"
38 (error "unexpected exit" args))))
41 (pass-if "no values, abnormal exit"
45 (error "unexpected exit"))
49 (pass-if "single value, normal exit"
55 (error "unexpected exit" args))))
58 (pass-if "single value, abnormal exit"
62 (error "unexpected exit"))
66 (pass-if "multiple values, normal exit"
67 (equal? '(foo bar baz)
70 (% (values 'foo 'bar 'baz)
72 (error "unexpected exit" args))))
75 (pass-if "multiple values, abnormal exit"
76 (equal? '(foo bar baz)
78 (abort 'foo 'bar 'baz)
79 (error "unexpected exit"))
83 (pass-if-equal "call/ec" '(0 1 2) ; example from the manual
88 (fold (lambda (element prefix)
89 (if (equal? element x)
90 (return (reverse prefix))
91 (cons element prefix)))
94 (prefix 'a '(0 1 2 a 3 4 5))))
96 (pass-if-equal "let/ec" '(0 1 2)
100 (fold (lambda (element prefix)
101 (if (equal? element x)
102 (return (reverse prefix))
103 (cons element prefix)))
106 (prefix 'a '(0 1 2 a 3 4 5)))))
108 ;;; And the case in which the compiler has to reify the continuation.
109 (with-test-prefix/c&e "reified continuations"
110 (pass-if "no values, normal exit"
116 (error "unexpected exit" k args))))
119 (pass-if "no values, abnormal exit"
124 (error "unexpected exit"))
128 (pass-if "single value, normal exit"
134 (error "unexpected exit" k args))))
137 (pass-if "single value, abnormal exit"
142 (error "unexpected exit"))
146 (pass-if "multiple values, normal exit"
147 (equal? '(foo bar baz)
150 (% (values 'foo 'bar 'baz)
152 (error "unexpected exit" k args))))
155 (pass-if "multiple values, abnormal exit"
156 (equal? '(foo bar baz)
159 (abort 'foo 'bar 'baz)
160 (error "unexpected exit"))
164 (pass-if "reified pending call frames, instantiated elsewhere on the stack"
169 (identity ((abort-to-prompt 'p0) 'foo)))
174 ;; The variants check different cases in the compiler.
175 (with-test-prefix/c&e "restarting partial continuations"
176 (pass-if "in side-effect position"
177 (let ((k (% (begin (abort) 'foo)
182 (pass-if "passing values to side-effect abort"
183 (let ((k (% (begin (abort) 'foo)
185 (eq? (k 'qux 'baz 'hello)
188 (pass-if "called for one value"
189 (let ((k (% (+ (abort) 3)
194 (pass-if "called for multiple values"
195 (let ((k (% (let-values (((a b . c) (abort)))
201 (pass-if "in tail position"
207 ;; Here we test different cases for the `prompt'.
208 (with-test-prefix/c&e "prompt in different contexts"
209 (pass-if "push, normal exit"
210 (car (call-with-prompt
213 (lambda (k) '(#f)))))
215 (pass-if "push, nonlocal exit"
216 (car (call-with-prompt
218 (lambda () (abort-to-prompt 'foo) '(#f))
219 (lambda (k) '(#t)))))
221 (pass-if "push with RA, normal exit"
222 (car (letrec ((test (lambda ()
226 (lambda (k) '(#f))))))
229 (pass-if "push with RA, nonlocal exit"
230 (car (letrec ((test (lambda ()
233 (lambda () (abort-to-prompt 'foo) '(#f))
234 (lambda (k) '(#t))))))
237 (pass-if "tail, normal exit"
243 (pass-if "tail, nonlocal exit"
246 (lambda () (abort-to-prompt 'foo) #f)
249 (pass-if "tail with RA, normal exit"
250 (letrec ((test (lambda ()
257 (pass-if "tail with RA, nonlocal exit"
258 (letrec ((test (lambda ()
261 (lambda () (abort-to-prompt 'foo) #f)
265 (pass-if "drop, normal exit"
273 (pass-if "drop, nonlocal exit"
277 (lambda () (abort-to-prompt 'foo))
281 (pass-if "drop with RA, normal exit"
283 (letrec ((test (lambda ()
291 (pass-if "drop with RA, nonlocal exit"
293 (letrec ((test (lambda ()
296 (lambda () (abort-to-prompt 'foo) #f)
302 (define fl (make-fluid))
305 ;; Not c&e as it assumes this block executes once.
307 (with-test-prefix "suspend/resume with fluids"
309 (zero? (% (fluid-ref fl)
311 (pass-if "with-fluids normal"
312 (equal? (% (with-fluids ((fl (1+ (fluid-ref fl))))
316 (pass-if "normal (post)"
317 (zero? (fluid-ref fl)))
318 (pass-if "with-fluids and fluid-set!"
319 (equal? (% (with-fluids ((fl (1+ (fluid-ref fl))))
320 (fluid-set! fl (1+ (fluid-ref fl)))
324 (pass-if "normal (post2)"
325 (zero? (fluid-ref fl)))
326 (pass-if "normal fluid-set!"
328 (fluid-set! fl (1+ (fluid-ref fl)))
331 (pass-if "reset fluid-set!"
333 (fluid-set! fl (1- (fluid-ref fl)))
337 (let ((k (% (with-fluids ((fl (1+ (fluid-ref fl))))
342 (equal? (fluid-ref fl) 0))
346 (equal? (fluid-ref fl) 0))))
348 (with-test-prefix/c&e "rewinding prompts"
349 (pass-if "nested prompts"
354 (abort-to-prompt 'b #t))
359 (with-test-prefix/c&e "abort to unknown prompt"
360 (pass-if-exception "foo" '(misc-error . "^Abort to unknown prompt")
361 (abort-to-prompt 'does-not-exist)))
363 (with-test-prefix/c&e "unwind"
365 (pass-if "unwind through call-with-vm"
366 (let ((proc (lambda (x y)
368 (call (lambda (p x y)
372 (call-with-vm (lambda () (throw 'foo))))
376 ;; These tests from Oleg Kiselyov's delim-control-n.scm, available at
377 ;; http://okmij.org/ftp/Scheme/delim-control-n.scm. Public domain.
379 (with-test-prefix "shift and reset"
382 (+ 10 (reset (+ 2 (shift k (+ 100 (k (k 3)))))))))
386 (* 10 (reset (* 2 (shift g (* 5 (shift f (+ (f 1) 1)))))))))
390 (let ((f (lambda (x) (shift k (k (k x))))))
391 (+ 1 (reset (+ 10 (f 100)))))))
397 (shift f1 (f1 (cons 'a (f '())))))))
400 ;; Example by Olivier Danvy
404 (define (traverse xs)
410 (cons (car xs) (k (cdr xs))))))))
411 (reset* (lambda () (visit xs))))
412 (traverse '(1 2 3 4 5))))))