[Guile-commits] 01/02: Avoid swallowing errors for (values) operands of elided primcalls

[Andy Wingo]

wingo pushed a commit to branch main
in repository guile.

commit 38e9bd7a2f9d84442bc26ec4b2d91f515aedfeb1
Author: Andy Wingo <wingo@pobox.com>
AuthorDate: Mon Nov 27 14:02:03 2023 +0100

    Avoid swallowing errors for (values) operands of elided primcalls
    
    * module/language/tree-il/peval.scm (peval): When visiting (values) in
    anything other than an effect or values context,
    residualize (values (values)), which will cause a run-time error.
    * test-suite/tests/peval.test ("values"): Add test.
---
 module/language/tree-il/peval.scm | 21 ++++++++++++---------
 test-suite/tests/peval.test       |  7 +++++++
 2 files changed, 19 insertions(+), 9 deletions(-)

diff --git a/module/language/tree-il/peval.scm 
b/module/language/tree-il/peval.scm
index c39069f69..937a797f0 100644
--- a/module/language/tree-il/peval.scm
+++ b/module/language/tree-il/peval.scm
@@ -1306,12 +1306,16 @@ top-level bindings from ENV and return the resulting 
expression."
                                                   '()))))))))
 
       (($ <primcall> src 'values exps)
-       (cond
-        ((null? exps)
-         (if (eq? ctx 'effect)
-             (make-void #f)
-             exp))
-        (else
+       (match exps
+        (()
+         (case ctx
+           ((effect) (make-void #f))
+           ((values) exp)
+           ;; Zero values returned to continuation expecting a value:
+           ;; ensure that we raise an error.
+           (else (make-primcall src 'values (list exp)))))
+        ((($ <primcall> _ 'values ())) exp)
+        (_
          (let ((vals (map for-value exps)))
            (if (and (case ctx
                       ((value test effect) #t)
@@ -1357,12 +1361,11 @@ top-level bindings from ENV and return the resulting 
expression."
                      ('make-prompt-tag ($ <const> _ (? string?))))
                  #t)
                 (_ #f)))
-         ;; Some expressions can be folded without visiting the
-         ;; arguments for value.
          (let ((res (if (eq? ctx 'effect)
                         (make-void #f)
                         (make-const #f #t))))
-           (for-tail (list->seq src (append args (list res))))))
+           (for-tail (list->seq src (append (map for-value args)
+                                            (list res))))))
         (else
          (match (cons name (map for-value args))
            (('cons x ($ <const> _ (? (cut eq? <> '()))))
diff --git a/test-suite/tests/peval.test b/test-suite/tests/peval.test
index 4b03c9ea0..bed2e2dc4 100644
--- a/test-suite/tests/peval.test
+++ b/test-suite/tests/peval.test
@@ -1583,3 +1583,10 @@
 
   (pass-if-peval (equal? x '(a . b))
     (primcall equal? (toplevel x) (const (a . b)))))
+
+(with-test-prefix "values"
+  (pass-if-peval (begin (cons 1 (values)) #f)
+    (seq (primcall values (primcall values))
+         (const #f)))
+  (pass-if-peval (begin 1 (values) #f)
+    (const #f)))