From da7fa082e80b2c3989c90031ee5356e5b65bd00b Mon Sep 17 00:00:00 2001
From: Andy Wingo <wingo@pobox.com>
Date: Thu, 25 Feb 2010 00:41:03 +0100
Subject: [PATCH] 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*.
---
 test-suite/tests/control.test | 162 +++++++++++++++++++++++++++++++++-
 1 file changed, 161 insertions(+), 1 deletion(-)

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))))