mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-06-12 23:00:22 +02:00
Code Activity

ensure that lists pushed onto the stack are proper

Browse source 
I saw this problem when running elisp.test -- it tries to apply a
function to an arglist ending in nil, which obviously is not null.

* libguile/vm-engine.h (PUSH_LIST): New helper macro, pushes the elements
  of a list onto the stack. Checks to make sure that the list is proper.

* libguile/vm-i-system.c (list-break, mv-call, apply, goto/apply)
  (goto/cc): Use LIST_BREAK.

* libguile/vm-engine.c (vm_error_improper_list): New error case.
This commit is contained in:
Andy Wingo 2008-10-16 13:24:39 +02:00
parent 28a2f57bde
commit 1f40459f5c
3 changed files with 21 additions and 10 deletions
Download patch file Download diff file Expand all files Collapse all files

4
libguile/vm-engine.c
View file

@ -176,6 +176,10 @@ vm_run (SCM vm, SCM program, SCM args)
err_args = SCM_EOL; err_args = SCM_EOL;
goto vm_error; goto vm_error;
vm_error_improper_list:
err_msg = scm_from_locale_string ("VM: Attempt to unroll an improper list: tail is ~A");
goto vm_error;
vm_error_no_values: vm_error_no_values:
err_msg = scm_from_locale_string ("VM: 0-valued return"); err_msg = scm_from_locale_string ("VM: 0-valued return");
err_args = SCM_EOL; err_args = SCM_EOL;

12
libguile/vm-engine.h
View file

@ -299,6 +299,18 @@ do \
PUSH (l); \ PUSH (l); \
} while (0) } while (0)
/* The opposite: push all of the elements in L onto the list. */
#define PUSH_LIST(l) \
do \
{ \
for (; scm_is_pair (l); l = SCM_CDR (l)) \
PUSH (SCM_CAR (l)); \
if (SCM_UNLIKELY (!SCM_NULLP (l))) { \
err_args = scm_list_1 (l); \
goto vm_error_improper_list; \
} \
} while (0)
/* Below is a (slightly broken) experiment to avoid calling `scm_cell' and to /* Below is a (slightly broken) experiment to avoid calling `scm_cell' and to
allocate cells on the stack. This is a significant improvement for allocate cells on the stack. This is a significant improvement for

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

@ -214,8 +214,7 @@ VM_DEFINE_INSTRUCTION (list_break, "list-break", 0, 0, 0)
{ {
SCM l; SCM l;
POP (l); POP (l);
for (; !SCM_NULLP (l); l = SCM_CDR (l)) PUSH_LIST (l);
PUSH (SCM_CAR (l));
NEXT; NEXT;
} }
@ -833,8 +832,7 @@ VM_DEFINE_INSTRUCTION (mv_call, "mv-call", 3, -1, 1)
POP (values); POP (values);
values = scm_struct_ref (values, SCM_INUM0); values = scm_struct_ref (values, SCM_INUM0);
len = scm_length (values); len = scm_length (values);
for (; !SCM_NULLP (values); values = SCM_CDR (values)) PUSH_LIST (values);
PUSH (SCM_CAR (values));
PUSH (len); PUSH (len);
ip += offset; ip += offset;
} }
@ -866,8 +864,7 @@ VM_DEFINE_INSTRUCTION (apply, "apply", 1, -1, 1)
if (len < 0) if (len < 0)
goto vm_error_wrong_type_arg; goto vm_error_wrong_type_arg;
for (; !SCM_NULLP (ls); ls = SCM_CDR (ls)) PUSH_LIST (ls);
PUSH (SCM_CAR (ls));
nargs += len - 2; nargs += len - 2;
goto vm_call; goto vm_call;
@ -886,8 +883,7 @@ VM_DEFINE_INSTRUCTION (goto_apply, "goto/apply", 1, -1, 1)
if (len < 0) if (len < 0)
goto vm_error_wrong_type_arg; goto vm_error_wrong_type_arg;
for (; !SCM_NULLP (ls); ls = SCM_CDR (ls)) PUSH_LIST (ls);
PUSH (SCM_CAR (ls));
nargs += len - 2; nargs += len - 2;
goto vm_goto_args; goto vm_goto_args;
@ -949,8 +945,7 @@ VM_DEFINE_INSTRUCTION (goto_cc, "goto/cc", 0, 1, 1)
SCM values; SCM values;
values = scm_struct_ref (cont, SCM_INUM0); values = scm_struct_ref (cont, SCM_INUM0);
nvalues = scm_ilength (values); nvalues = scm_ilength (values);
for (; !SCM_NULLP (values); values = SCM_CDR (values)) PUSH_LIST (values);
PUSH (SCM_CAR (values));
goto vm_return_values; goto vm_return_values;
} }
else else