summaryrefslogtreecommitdiff
path: root/test-suite/tests/control.test
diff options
context:
space:
mode:
Diffstat (limited to 'test-suite/tests/control.test')
-rw-r--r--test-suite/tests/control.test449
1 files changed, 449 insertions, 0 deletions
diff --git a/test-suite/tests/control.test b/test-suite/tests/control.test
new file mode 100644
index 000000000..213917fc1
--- /dev/null
+++ b/test-suite/tests/control.test
@@ -0,0 +1,449 @@
+;;;; -*- scheme -*-
+;;;; control.test --- test suite for delimited continuations
+;;;;
+;;;; Copyright (C) 2010, 2011, 2013 Free Software Foundation, Inc.
+;;;;
+;;;; This library is free software; you can redistribute it and/or
+;;;; modify it under the terms of the GNU Lesser General Public
+;;;; License as published by the Free Software Foundation; either
+;;;; version 3 of the License, or (at your option) any later version.
+;;;;
+;;;; This library is distributed in the hope that it will be useful,
+;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+;;;; Lesser General Public License for more details.
+;;;;
+;;;; You should have received a copy of the GNU Lesser General Public
+;;;; License along with this library; if not, write to the Free Software
+;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
+
+(define-module (test-suite test-control)
+ #:use-module (ice-9 control)
+ #:use-module (system vm vm)
+ #:use-module (srfi srfi-1)
+ #:use-module (srfi srfi-11)
+ #:use-module (test-suite lib))
+
+
+;; For these, the compiler should be able to prove that "k" is not referenced,
+;; so it avoids reifying the continuation. Since that's a slightly different
+;; codepath, we test them both.
+(with-test-prefix/c&e "escape-only continuations"
+ (pass-if "no values, normal exit"
+ (equal? '()
+ (call-with-values
+ (lambda ()
+ (% (values)
+ (lambda (k . args)
+ (error "unexpected exit" args))))
+ list)))
+
+ (pass-if "no values, abnormal exit"
+ (equal? '()
+ (% (begin
+ (abort)
+ (error "unexpected exit"))
+ (lambda (k . args)
+ args))))
+
+ (pass-if "single value, normal exit"
+ (equal? '(foo)
+ (call-with-values
+ (lambda ()
+ (% 'foo
+ (lambda (k . args)
+ (error "unexpected exit" args))))
+ list)))
+
+ (pass-if "single value, abnormal exit"
+ (equal? '(foo)
+ (% (begin
+ (abort 'foo)
+ (error "unexpected exit"))
+ (lambda (k . args)
+ args))))
+
+ (pass-if "multiple values, normal exit"
+ (equal? '(foo bar baz)
+ (call-with-values
+ (lambda ()
+ (% (values 'foo 'bar 'baz)
+ (lambda (k . args)
+ (error "unexpected exit" args))))
+ list)))
+
+ (pass-if "multiple values, abnormal exit"
+ (equal? '(foo bar baz)
+ (% (begin
+ (abort 'foo 'bar 'baz)
+ (error "unexpected exit"))
+ (lambda (k . args)
+ args))))
+
+ (pass-if-equal "call/ec" '(0 1 2) ; example from the manual
+ (let ((prefix
+ (lambda (x lst)
+ (call/ec
+ (lambda (return)
+ (fold (lambda (element prefix)
+ (if (equal? element x)
+ (return (reverse prefix))
+ (cons element prefix)))
+ '()
+ lst))))))
+ (prefix 'a '(0 1 2 a 3 4 5))))
+
+ (pass-if-equal "let/ec" '(0 1 2)
+ (let ((prefix
+ (lambda (x lst)
+ (let/ec return
+ (fold (lambda (element prefix)
+ (if (equal? element x)
+ (return (reverse prefix))
+ (cons element prefix)))
+ '()
+ lst)))))
+ (prefix 'a '(0 1 2 a 3 4 5))))
+
+ (pass-if "loop only in handler"
+ (let ((n #f))
+ (let lp ()
+ (or n
+ (call-with-prompt 'foo
+ (lambda ()
+ (set! n #t)
+ (abort-to-prompt 'foo))
+ (lambda (k) (lp))))))))
+
+;;; And the case in which the compiler has to reify the continuation.
+(with-test-prefix/c&e "reified continuations"
+ (pass-if "no values, normal exit"
+ (equal? '()
+ (call-with-values
+ (lambda ()
+ (% (values)
+ (lambda (k . args)
+ (error "unexpected exit" k args))))
+ list)))
+
+ (pass-if "no values, abnormal exit"
+ (equal? '()
+ (cdr
+ (% (begin
+ (abort)
+ (error "unexpected exit"))
+ (lambda args
+ args)))))
+
+ (pass-if "single value, normal exit"
+ (equal? '(foo)
+ (call-with-values
+ (lambda ()
+ (% 'foo
+ (lambda (k . args)
+ (error "unexpected exit" k args))))
+ list)))
+
+ (pass-if "single value, abnormal exit"
+ (equal? '(foo)
+ (cdr
+ (% (begin
+ (abort 'foo)
+ (error "unexpected exit"))
+ (lambda args
+ args)))))
+
+ (pass-if "multiple values, normal exit"
+ (equal? '(foo bar baz)
+ (call-with-values
+ (lambda ()
+ (% (values 'foo 'bar 'baz)
+ (lambda (k . args)
+ (error "unexpected exit" k args))))
+ list)))
+
+ (pass-if "multiple values, abnormal exit"
+ (equal? '(foo bar baz)
+ (cdr
+ (% (begin
+ (abort 'foo 'bar 'baz)
+ (error "unexpected exit"))
+ (lambda args
+ args)))))
+
+ (pass-if "reified pending call frames, instantiated elsewhere on the stack"
+ (equal? 'foo
+ ((call-with-prompt
+ 'p0
+ (lambda ()
+ (identity ((abort-to-prompt 'p0) 'foo)))
+ (lambda (c) c))
+ (lambda (x) x)))))
+
+
+;; The variants check different cases in the compiler.
+(with-test-prefix/c&e "restarting partial continuations"
+ (pass-if "in side-effect position"
+ (let ((k (% (begin (abort) 'foo)
+ (lambda (k) k))))
+ (eq? (k)
+ 'foo)))
+
+ (pass-if "passing values to side-effect abort"
+ (let ((k (% (begin (abort) 'foo)
+ (lambda (k) k))))
+ (eq? (k 'qux 'baz 'hello)
+ 'foo)))
+
+ (pass-if "called for one value"
+ (let ((k (% (+ (abort) 3)
+ (lambda (k) k))))
+ (eqv? (k 39)
+ 42)))
+
+ (pass-if "called for multiple values"
+ (let ((k (% (let-values (((a b . c) (abort)))
+ (list a b c))
+ (lambda (k) k))))
+ (equal? (k 1 2 3 4)
+ '(1 2 (3 4)))))
+
+ (pass-if "in tail position"
+ (let ((k (% (abort)
+ (lambda (k) k))))
+ (eq? (k 'xyzzy)
+ 'xyzzy))))
+
+;; Here we test different cases for the `prompt'.
+(with-test-prefix/c&e "prompt in different contexts"
+ (pass-if "push, normal exit"
+ (car (call-with-prompt
+ 'foo
+ (lambda () '(#t))
+ (lambda (k) '(#f)))))
+
+ (pass-if "push, nonlocal exit"
+ (car (call-with-prompt
+ 'foo
+ (lambda () (abort-to-prompt 'foo) '(#f))
+ (lambda (k) '(#t)))))
+
+ (pass-if "push with RA, normal exit"
+ (car (letrec ((test (lambda ()
+ (call-with-prompt
+ 'foo
+ (lambda () '(#t))
+ (lambda (k) '(#f))))))
+ (test))))
+
+ (pass-if "push with RA, nonlocal exit"
+ (car (letrec ((test (lambda ()
+ (call-with-prompt
+ 'foo
+ (lambda () (abort-to-prompt 'foo) '(#f))
+ (lambda (k) '(#t))))))
+ (test))))
+
+ (pass-if "tail, normal exit"
+ (call-with-prompt
+ 'foo
+ (lambda () #t)
+ (lambda (k) #f)))
+
+ (pass-if "tail, nonlocal exit"
+ (call-with-prompt
+ 'foo
+ (lambda () (abort-to-prompt 'foo) #f)
+ (lambda (k) #t)))
+
+ (pass-if "tail with RA, normal exit"
+ (letrec ((test (lambda ()
+ (call-with-prompt
+ 'foo
+ (lambda () #t)
+ (lambda (k) #f)))))
+ (test)))
+
+ (pass-if "tail with RA, nonlocal exit"
+ (letrec ((test (lambda ()
+ (call-with-prompt
+ 'foo
+ (lambda () (abort-to-prompt 'foo) #f)
+ (lambda (k) #t)))))
+ (test)))
+
+ (pass-if "drop, normal exit"
+ (begin
+ (call-with-prompt
+ 'foo
+ (lambda () #f)
+ (lambda (k) #f))
+ #t))
+
+ (pass-if "drop, nonlocal exit"
+ (begin
+ (call-with-prompt
+ 'foo
+ (lambda () (abort-to-prompt 'foo))
+ (lambda (k) #f))
+ #t))
+
+ (pass-if "drop with RA, normal exit"
+ (begin
+ (letrec ((test (lambda ()
+ (call-with-prompt
+ 'foo
+ (lambda () #f)
+ (lambda (k) #f)))))
+ (test))
+ #t))
+
+ (pass-if "drop with RA, nonlocal exit"
+ (begin
+ (letrec ((test (lambda ()
+ (call-with-prompt
+ 'foo
+ (lambda () (abort-to-prompt 'foo) #f)
+ (lambda (k) #f)))))
+ (test))
+ #t)))
+
+
+(define fl (make-fluid))
+(fluid-set! fl 0)
+
+;; Not c&e as it assumes this block executes once.
+;;
+(with-test-prefix "suspend/resume with fluids"
+ (pass-if "normal"
+ (zero? (% (fluid-ref fl)
+ error)))
+ (pass-if "with-fluids normal"
+ (equal? (% (with-fluids ((fl (1+ (fluid-ref fl))))
+ (fluid-ref fl))
+ error)
+ 1))
+ (pass-if "normal (post)"
+ (zero? (fluid-ref fl)))
+ (pass-if "with-fluids and fluid-set!"
+ (equal? (% (with-fluids ((fl (1+ (fluid-ref fl))))
+ (fluid-set! fl (1+ (fluid-ref fl)))
+ (fluid-ref fl))
+ error)
+ 2))
+ (pass-if "normal (post2)"
+ (zero? (fluid-ref fl)))
+ (pass-if "normal fluid-set!"
+ (equal? (begin
+ (fluid-set! fl (1+ (fluid-ref fl)))
+ (fluid-ref fl))
+ 1))
+ (pass-if "reset fluid-set!"
+ (equal? (begin
+ (fluid-set! fl (1- (fluid-ref fl)))
+ (fluid-ref fl))
+ 0))
+
+ (let ((k (% (with-fluids ((fl (1+ (fluid-ref fl))))
+ (abort)
+ (fluid-ref fl))
+ (lambda (k) k))))
+ (pass-if "pre"
+ (equal? (fluid-ref fl) 0))
+ (pass-if "res"
+ (equal? (k) 1))
+ (pass-if "post"
+ (equal? (fluid-ref fl) 0))))
+
+(with-test-prefix/c&e "rewinding prompts"
+ (pass-if "nested prompts"
+ (let ((k (% 'a
+ (% 'b
+ (begin
+ (abort-to-prompt 'a)
+ (abort-to-prompt 'b #t))
+ (lambda (k x) x))
+ (lambda (k) k))))
+ (k))))
+
+(with-test-prefix/c&e "abort to unknown prompt"
+ (pass-if-exception "foo" '(misc-error . "^Abort to unknown prompt")
+ (abort-to-prompt 'does-not-exist)))
+
+(with-test-prefix/c&e "unwind"
+
+ (pass-if "unwind through call-with-vm"
+ (let ((proc (lambda (x y)
+ (expt x y)))
+ (call (lambda (p x y)
+ (p x y))))
+ (catch 'foo
+ (lambda ()
+ (call-with-vm (lambda () (throw 'foo))))
+ (lambda (key)
+ (eq? key 'foo))))))
+
+;; These tests from Oleg Kiselyov's delim-control-n.scm, available at
+;; http://okmij.org/ftp/Scheme/delim-control-n.scm. Public domain.
+;;
+(with-test-prefix "shift and reset"
+ (pass-if (equal?
+ 117
+ (+ 10 (reset (+ 2 (shift k (+ 100 (k (k 3)))))))))
+
+ (pass-if (equal?
+ 60
+ (* 10 (reset (* 2 (shift g (* 5 (shift f (+ (f 1) 1)))))))))
+
+ (pass-if (equal?
+ 121
+ (let ((f (lambda (x) (shift k (k (k x))))))
+ (+ 1 (reset (+ 10 (f 100)))))))
+
+ (pass-if (equal?
+ 'a
+ (car (reset
+ (let ((x (shift f
+ (shift f1 (f1 (cons 'a (f '())))))))
+ (shift g x))))))
+
+ ;; Example by Olivier Danvy
+ (pass-if (equal?
+ '(1 2 3 4 5)
+ (let ()
+ (define (traverse xs)
+ (define (visit xs)
+ (if (null? xs)
+ '()
+ (visit (shift*
+ (lambda (k)
+ (cons (car xs) (k (cdr xs))))))))
+ (reset* (lambda () (visit xs))))
+ (traverse '(1 2 3 4 5))))))
+
+(with-test-prefix "suspendable-continuation?"
+ (let ((tag (make-prompt-tag)))
+ (pass-if "escape-only"
+ (call-with-prompt tag
+ (lambda ()
+ (suspendable-continuation? tag))
+ (lambda _ (error "unreachable"))))
+ (pass-if "full"
+ (call-with-prompt tag
+ (lambda ()
+ (suspendable-continuation? tag))
+ (lambda (k) (error "unreachable" k))))
+ (pass-if "escape-only with barrier"
+ (call-with-prompt tag
+ (lambda ()
+ (with-continuation-barrier
+ (lambda ()
+ (not (suspendable-continuation? tag)))))
+ (lambda _ (error "unreachable"))))
+ (pass-if "full with barrier"
+ (call-with-prompt tag
+ (lambda ()
+ (with-continuation-barrier
+ (lambda ()
+ (not (suspendable-continuation? tag)))))
+ (lambda (k) (error "unreachable" k))))))