mirror of
https://git.savannah.gnu.org/git/guile.git
synced 2025-04-29 19:30:36 +02:00
0543ec96b2
* module/language/cps/effects-analysis.scm (expression-effects): Prompts
cause &all-effects. I tried to limit this change to CSE but it was
actually LICM that was borked, so better to be conservative
* test-suite/tests/control.test ("escape-only continuations"): Add
test.
449 lines
13 KiB
Scheme
449 lines
13 KiB
Scheme
;;;; -*- 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))))))
|