diff options
author | Andy Wingo <wingo@pobox.com> | 2010-02-25 00:41:03 +0100 |
---|---|---|
committer | Andy Wingo <wingo@pobox.com> | 2010-02-25 00:43:52 +0100 |
commit | da7fa082e80b2c3989c90031ee5356e5b65bd00b (patch) | |
tree | bd389da4f7764711c755ced9e5f3603e231fa144 | |
parent | 1371fe9b149da699320567e5160160169ecdb0be (diff) | |
download | guile-da7fa082e80b2c3989c90031ee5356e5b65bd00b.tar.gz |
more substance to control.test
* test-suite/tests/control.test ("suspend/resume with fluids"):
("restarting partial continuations"):
("reified continuations", "escape-only continuations"): More tests.
eval.scm's handling of with-fluids doesn't leave the VM
* module/ice-9/eval.scm (primitive-eval): Implement with-fluids in terms
of with-fluids, to avoid recursively calling the VM via with-fluids*.
-rw-r--r-- | test-suite/tests/control.test | 162 |
1 files changed, 161 insertions, 1 deletions
diff --git a/test-suite/tests/control.test b/test-suite/tests/control.test index fab2f6092..650f25552 100644 --- a/test-suite/tests/control.test +++ b/test-suite/tests/control.test @@ -25,6 +25,9 @@ (define default-tag (fluid-ref %default-prompt-tag)) +;; 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 "escape-only continuations" (pass-if "no values, normal exit" (equal? '() @@ -35,12 +38,169 @@ (lambda (k . args) (error "unexpected exit" args)))) list))) - (pass-if "no values, normal exit" + + (pass-if "no values, abnormal exit" (equal? '() (% default-tag (begin (abort default-tag) (error "unexpected exit")) (lambda (k . args) + args)))) + + (pass-if "single value, normal exit" + (equal? '(foo) + (call-with-values + (lambda () + (% default-tag + 'foo + (lambda (k . args) + (error "unexpected exit" args)))) + list))) + + (pass-if "single value, abnormal exit" + (equal? '(foo) + (% default-tag + (begin + (abort default-tag 'foo) + (error "unexpected exit")) + (lambda (k . args) + args)))) + + (pass-if "multiple values, normal exit" + (equal? '(foo bar baz) + (call-with-values + (lambda () + (% default-tag + (values 'foo 'bar 'baz) + (lambda (k . args) + (error "unexpected exit" args)))) + list))) + + (pass-if "multiple values, abnormal exit" + (equal? '(foo bar baz) + (% default-tag + (begin + (abort default-tag 'foo 'bar 'baz) + (error "unexpected exit")) + (lambda (k . args) args))))) +;;; And the case in which the compiler has to reify the continuation. +(with-test-prefix "reified continuations" + (pass-if "no values, normal exit" + (equal? '() + (call-with-values + (lambda () + (% default-tag + (values) + (lambda (k . args) + (error "unexpected exit" k args)))) + list))) + + (pass-if "no values, abnormal exit" + (equal? '() + (cdr + (% default-tag + (begin + (abort default-tag) + (error "unexpected exit")) + (lambda args + args))))) + + (pass-if "single value, normal exit" + (equal? '(foo) + (call-with-values + (lambda () + (% default-tag + 'foo + (lambda (k . args) + (error "unexpected exit" k args)))) + list))) + + (pass-if "single value, abnormal exit" + (equal? '(foo) + (cdr + (% default-tag + (begin + (abort default-tag 'foo) + (error "unexpected exit")) + (lambda args + args))))) + + (pass-if "multiple values, normal exit" + (equal? '(foo bar baz) + (call-with-values + (lambda () + (% default-tag + (values 'foo 'bar 'baz) + (lambda (k . args) + (error "unexpected exit" k args)))) + list))) + + (pass-if "multiple values, abnormal exit" + (equal? '(foo bar baz) + (cdr + (% default-tag + (begin + (abort default-tag 'foo 'bar 'baz) + (error "unexpected exit")) + (lambda args + args)))))) + +;;; Here we test that instantiation works +(with-test-prefix "restarting partial continuations" + (pass-if "simple" + (let ((k (% default-tag + (begin (abort default-tag) 'foo) + (lambda (k) k)))) + (eq? (k) + 'foo)))) + +(define fl (make-fluid)) +(fluid-set! fl 0) + +(with-test-prefix "suspend/resume with fluids" + (pass-if "normal" + (zero? (% default-tag + (fluid-ref fl) + error))) + (pass-if "with-fluids normal" + (equal? (% default-tag + (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? (% default-tag + (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 (% default-tag + (with-fluids ((fl (1+ (fluid-ref fl)))) + (abort default-tag) + (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)))) |