diff options
Diffstat (limited to 'test-suite/tests/control.test')
-rw-r--r-- | test-suite/tests/control.test | 449 |
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)))))) |