mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-05-21 20:20:24 +02:00
Code Activity

fix multiple values coming from interpreted or C procedures

Browse source 
* 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.
This commit is contained in:
Andy Wingo 2008-11-01 18:19:19 +01:00
parent 3fd8807eab
commit 42906d7406
2 changed files with 28 additions and 9 deletions
Download patch file Download diff file Expand all files Collapse all files

22
libguile/vm-i-system.c
View file

@ -573,8 +573,17 @@ VM_DEFINE_INSTRUCTION (call, "call", 1, -1, 1)
/* keep args on stack so they are marked */ /* keep args on stack so they are marked */
sp[-1] = scm_apply (x, sp[0], SCM_EOL); sp[-1] = scm_apply (x, sp[0], SCM_EOL);
NULLSTACK_FOR_NONLOCAL_EXIT (); NULLSTACK_FOR_NONLOCAL_EXIT ();
/* FIXME what if SCM_VALUESP(*sp) */
DROP (); 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; NEXT;
} }
/* /*
@ -769,7 +778,16 @@ VM_DEFINE_INSTRUCTION (goto_args, "goto/args", 1, -1, 1)
sp[-1] = scm_apply (x, sp[0], SCM_EOL); sp[-1] = scm_apply (x, sp[0], SCM_EOL);
NULLSTACK_FOR_NONLOCAL_EXIT (); NULLSTACK_FOR_NONLOCAL_EXIT ();
DROP (); 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; goto vm_return;
} }

15
testsuite/t-values.scm
View file

@ -1,8 +1,9 @@
(use-modules (ice-9 receive)) (list (call-with-values
(lambda () (values 1 2))
(define (do-stuff x y) (lambda (x y) (cons x y)))
(values x y))
;; the start-stack forces a bounce through the interpreter
(call-with-values (lambda () (values 1 2)) (call-with-values
(lambda (x y) (cons x y))) (lambda () (start-stack 'foo (values 1 2)))
list))