From 42906d7406913a724aea52e4d8f087e6819ab4c6 Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Sat, 1 Nov 2008 18:19:19 +0100 Subject: [PATCH] fix multiple values coming from interpreted or C procedures * libguile/vm-i-system.c (call, goto/args): Handle the case in which a non-program (i.e. interpreted program or a subr) returns multiple values. * testsuite/t-values.scm: Add test case that exhibited this problem. --- libguile/vm-i-system.c | 22 ++++++++++++++++++++-- testsuite/t-values.scm | 15 ++++++++------- 2 files changed, 28 insertions(+), 9 deletions(-) diff --git a/libguile/vm-i-system.c b/libguile/vm-i-system.c index ca1dbcaf8..313a577eb 100644 --- a/libguile/vm-i-system.c +++ b/libguile/vm-i-system.c @@ -573,8 +573,17 @@ VM_DEFINE_INSTRUCTION (call, "call", 1, -1, 1) /* keep args on stack so they are marked */ sp[-1] = scm_apply (x, sp[0], SCM_EOL); NULLSTACK_FOR_NONLOCAL_EXIT (); - /* FIXME what if SCM_VALUESP(*sp) */ DROP (); + if (SCM_UNLIKELY (SCM_VALUESP (*sp))) + { + /* truncate values */ + SCM values; + POP (values); + values = scm_struct_ref (values, SCM_INUM0); + if (scm_is_null (values)) + goto vm_error_not_enough_values; + PUSH (SCM_CAR (values)); + } NEXT; } /* @@ -769,7 +778,16 @@ VM_DEFINE_INSTRUCTION (goto_args, "goto/args", 1, -1, 1) sp[-1] = scm_apply (x, sp[0], SCM_EOL); NULLSTACK_FOR_NONLOCAL_EXIT (); DROP (); - /* FIXME what if SCM_VALUESP(*sp) */ + if (SCM_UNLIKELY (SCM_VALUESP (*sp))) + { + /* multiple values returned to continuation */ + SCM values; + POP (values); + values = scm_struct_ref (values, SCM_INUM0); + nvalues = scm_ilength (values); + PUSH_LIST (values); + goto vm_return_values; + } goto vm_return; } diff --git a/testsuite/t-values.scm b/testsuite/t-values.scm index e741ae423..565f64e07 100644 --- a/testsuite/t-values.scm +++ b/testsuite/t-values.scm @@ -1,8 +1,9 @@ -(use-modules (ice-9 receive)) - -(define (do-stuff x y) - (values x y)) - -(call-with-values (lambda () (values 1 2)) - (lambda (x y) (cons x y))) +(list (call-with-values + (lambda () (values 1 2)) + (lambda (x y) (cons x y))) + + ;; the start-stack forces a bounce through the interpreter + (call-with-values + (lambda () (start-stack 'foo (values 1 2))) + list)) -- 2.20.1