diff options
author | Andy Wingo <wingo@pobox.com> | 2023-11-27 14:02:03 +0100 |
---|---|---|
committer | Andy Wingo <wingo@pobox.com> | 2023-11-27 14:24:50 +0100 |
commit | 38e9bd7a2f9d84442bc26ec4b2d91f515aedfeb1 (patch) | |
tree | 8c632d9c2dc3af2e6ee64804ce9139a8ef8e4333 /module/language | |
parent | 3b7c78cc83995992af0ce033e7f0229921b92ca4 (diff) | |
download | guile-38e9bd7a2f9d84442bc26ec4b2d91f515aedfeb1.tar.gz |
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.
Diffstat (limited to 'module/language')
-rw-r--r-- | module/language/tree-il/peval.scm | 21 |
1 files changed, 12 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? <> '())))) |