wingo pushed a commit to branch main
in repository guile.
commit 38e9bd7a2f9d84442bc26ec4b2d91f515aedfeb1
Author: Andy Wingo <wi...@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)))
