mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-04-30 20:00:19 +02:00
Code Activity

Avoid swallowing errors for (values) operands of elided primcalls

Browse source 
* 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.
This commit is contained in:
Andy Wingo 2023-11-27 14:02:03 +01:00
parent 3b7c78cc83
commit 38e9bd7a2f
2 changed files with 19 additions and 9 deletions
Download patch file Download diff file Expand all files Collapse all files

21
module/language/tree-il/peval.scm
View file

@ -1306,12 +1306,16 @@ top-level bindings from ENV and return the resulting expression."
'())))))))) '()))))))))
(($ <primcall> src 'values exps) (($ <primcall> src 'values exps)
(cond (match exps
((null? exps) (()
(if (eq? ctx 'effect) (case ctx
(make-void #f) ((effect) (make-void #f))
exp)) ((values) exp)
(else ;; 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))) (let ((vals (map for-value exps)))
(if (and (case ctx (if (and (case ctx
((value test effect) #t) ((value test effect) #t)
@ -1357,12 +1361,11 @@ top-level bindings from ENV and return the resulting expression."
('make-prompt-tag ($ <const> _ (? string?)))) ('make-prompt-tag ($ <const> _ (? string?))))
#t) #t)
(_ #f))) (_ #f)))
;; Some expressions can be folded without visiting the
;; arguments for value.
(let ((res (if (eq? ctx 'effect) (let ((res (if (eq? ctx 'effect)
(make-void #f) (make-void #f)
(make-const #f #t)))) (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 (else
(match (cons name (map for-value args)) (match (cons name (map for-value args))
(('cons x ($ <const> _ (? (cut eq? <> '())))) (('cons x ($ <const> _ (? (cut eq? <> '()))))

7
test-suite/tests/peval.test
View file

@ -1583,3 +1583,10 @@
(pass-if-peval (equal? x '(a . b)) (pass-if-peval (equal? x '(a . b))
(primcall equal? (toplevel x) (const (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)))