;;;; -*- 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))))) ;;; 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 "the-vm" (pass-if "unwind changes VMs" (let ((new-vm (make-vm)) (prev-vm (the-vm)) (proc (lambda (x y) (expt x y))) (call (lambda (p x y) (p x y)))) (catch 'foo (lambda () (call-with-vm new-vm (lambda () (throw 'foo (the-vm))))) (lambda (key vm) (and (eq? key 'foo) (eq? vm new-vm) (eq? (the-vm) prev-vm)))))) (pass-if "stack overflow reinstates stack reserve" ;; In Guile <= 2.0.9, only the first overflow would be gracefully ;; handle; subsequent overflows would lead to an abort. See ;; . (letrec ((foo (lambda () (+ 1 (foo))))) (define (overflows?) (catch 'vm-error foo (lambda (key proc msg . rest) (and (eq? 'vm-run proc) (->bool (string-contains msg "overflow")))))) (and (overflows?) (overflows?) (overflows?))))) ;; 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))))))