[Guile-commits] 01/01: peval: Always visit prompt bodies in values context

[Andy Wingo]

wingo pushed a commit to branch stable-2.0
in repository guile.

commit a192c336a22b8c9ac354e88c2f2b317dff22b8c9
Author: Andy Wingo <address@hidden>
Date:   Mon Jun 20 22:59:38 2016 +0200

    peval: Always visit prompt bodies in values context
    
    * module/language/tree-il/peval.scm (peval): Always evaluate the body in
      values context, as a captured continuation could continue to a
      continuation of any arity.  However the handler, if it returns, does
      return to the prompt's continuation.  Fixes #14347.  Thanks to Jussi
      Piitulainen for the report.
    * test-suite/tests/control.test ("shift and reset"): Add a test.
---
 module/language/tree-il/peval.scm |    6 +++---
 test-suite/tests/control.test     |   10 ++++++++++
 2 files changed, 13 insertions(+), 3 deletions(-)

diff --git a/module/language/tree-il/peval.scm 
b/module/language/tree-il/peval.scm
index 7dfbf6f..062d2ee 100644
--- a/module/language/tree-il/peval.scm
+++ b/module/language/tree-il/peval.scm
@@ -1550,7 +1550,7 @@ top-level bindings from ENV and return the resulting 
expression."
            (_ #f)))
 
        (let ((tag (for-value tag))
-             (body (for-tail body)))
+             (body (for-values body)))
          (cond
           ((find-definition tag 1)
            (lambda (val op)
@@ -1582,9 +1582,9 @@ top-level bindings from ENV and return the resulting 
expression."
                                       ,(make-primitive-ref #f 'values)
                                       ,@(abort-args body)
                                       ,(abort-tail body)))
-                  (for-value handler)))))
+                  (for-tail handler)))))
           (else
-           (make-prompt src tag body (for-value handler))))))
+           (make-prompt src tag body (for-tail handler))))))
       (($ <abort> src tag args tail)
        (make-abort src (for-value tag) (map for-value args)
                    (for-value tail))))))
diff --git a/test-suite/tests/control.test b/test-suite/tests/control.test
index 0d95dba..e5da24d 100644
--- a/test-suite/tests/control.test
+++ b/test-suite/tests/control.test
@@ -427,3 +427,13 @@
                                 (cons (car xs) (k (cdr xs))))))))
                 (reset* (lambda () (visit xs))))
               (traverse '(1 2 3 4 5))))))
+
+(with-test-prefix/c&e "shift/reset optimization"
+  ;; Although a call-with-prompt continuation might accept only a single
+  ;; value, it doesn't mean that the body can't provide a possibly
+  ;; different number of values to other continuations.
+  (pass-if-equal "bug #14347"
+      '(3.1 2 3)
+    (call-with-values
+        (lambda () (let ((k (reset (shift k k) (values 3.1 2 3)))) (k)))
+      list)))