mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-06-15 16:20:17 +02:00
Code Activity

allow `apply' on %nil-terminated lists

Browse source 
* libguile/vm-engine.h (PUSH_LIST): Add a parameter to check that the
  list was proper.

* libguile/vm-i-system.c: Adapt PUSH_LIST callsites to pass SCM_NULLP or
  SCM_NULL_OR_NIL_P, as appropriate. Add a check to return/values*.

* libguile/vm.c: Add lang.h header for SCM_NULL_OR_NIL_P.

* test-suite/tests/elisp.test: Fix XFAIL for elisp + apply.
This commit is contained in:
Andy Wingo 2009-01-04 14:06:52 +01:00
parent b1b942b74c
commit fb10a0084e
4 changed files with 15 additions and 14 deletions
Download patch file Download diff file Expand all files Collapse all files

4
libguile/vm-engine.h
View file

@ -299,12 +299,12 @@ do \
} while (0) } while (0)
/* The opposite: push all of the elements in L onto the list. */ /* The opposite: push all of the elements in L onto the list. */
#define PUSH_LIST(l) \ #define PUSH_LIST(l, NILP) \
do \ do \
{ \ { \
for (; scm_is_pair (l); l = SCM_CDR (l)) \ for (; scm_is_pair (l); l = SCM_CDR (l)) \
PUSH (SCM_CAR (l)); \ PUSH (SCM_CAR (l)); \
if (SCM_UNLIKELY (!SCM_NULLP (l))) { \ if (SCM_UNLIKELY (!NILP (l))) { \
err_args = scm_list_1 (l); \ err_args = scm_list_1 (l); \
goto vm_error_improper_list; \ goto vm_error_improper_list; \
} \ } \

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

@ -214,7 +214,7 @@ VM_DEFINE_INSTRUCTION (list_break, "list-break", 0, 0, 0)
{ {
SCM l; SCM l;
POP (l); POP (l);
PUSH_LIST (l); PUSH_LIST (l, SCM_NULLP);
NEXT; NEXT;
} }
@ -784,7 +784,7 @@ VM_DEFINE_INSTRUCTION (goto_args, "goto/args", 1, -1, 1)
POP (values); POP (values);
values = scm_struct_ref (values, SCM_INUM0); values = scm_struct_ref (values, SCM_INUM0);
nvalues = scm_ilength (values); nvalues = scm_ilength (values);
PUSH_LIST (values); PUSH_LIST (values, SCM_NULLP);
goto vm_return_values; goto vm_return_values;
} }
goto vm_return; goto vm_return;
@ -861,7 +861,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);
PUSH_LIST (values); PUSH_LIST (values, SCM_NULLP);
PUSH (len); PUSH (len);
ip += offset; ip += offset;
} }
@ -893,7 +893,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;
PUSH_LIST (ls); PUSH_LIST (ls, SCM_NULL_OR_NIL_P);
nargs += len - 2; nargs += len - 2;
goto vm_call; goto vm_call;
@ -912,7 +912,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;
PUSH_LIST (ls); PUSH_LIST (ls, SCM_NULL_OR_NIL_P);
nargs += len - 2; nargs += len - 2;
goto vm_goto_args; goto vm_goto_args;
@ -974,7 +974,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);
PUSH_LIST (values); PUSH_LIST (values, SCM_NULLP);
goto vm_return_values; goto vm_return_values;
} }
else else
@ -1097,6 +1097,10 @@ VM_DEFINE_INSTRUCTION (return_values_star, "return/values*", 1, -1, -1)
l = SCM_CDR (l); l = SCM_CDR (l);
nvalues++; nvalues++;
} }
if (SCM_UNLIKELY (!SCM_NULL_OR_NIL_P (l))) {
err_args = scm_list_1 (l);
goto vm_error_improper_list;
}
goto vm_return_values; goto vm_return_values;
} }

1
libguile/vm.c
View file

@ -49,6 +49,7 @@
#include "instructions.h" #include "instructions.h"
#include "objcodes.h" #include "objcodes.h"
#include "programs.h" #include "programs.h"
#include "lang.h" /* NULL_OR_NIL_P */
#include "vm.h" #include "vm.h"
/* I sometimes use this for debugging. */ /* I sometimes use this for debugging. */

8
test-suite/tests/elisp.test
View file

@ -341,12 +341,8 @@
(elisp-pass-if '(function (lambda (x y &optional o &rest r) (list x y o r))) "(lambda (x y &optional o &rest r) (list x y o r))") (elisp-pass-if '(function (lambda (x y &optional o &rest r) (list x y o r))) "(lambda (x y &optional o &rest r) (list x y o r))")
(elisp-pass-if '(funcall (lambda (x y &optional o &rest r) (list x y o r)) 1 2 3 4) "(1 2 3 (4))") (elisp-pass-if '(funcall (lambda (x y &optional o &rest r) (list x y o r)) 1 2 3 4) "(1 2 3 (4))")
;; If r4rs.scm is compiled, `apply' will only unroll true scheme (elisp-pass-if '(apply (lambda (x y &optional o &rest r) (list x y o r)) 1 2 3 nil)
;; lists. "(1 2 3 #nil)")
(elisp-pass-if/maybe-error
'vm-error
'(apply (lambda (x y &optional o &rest r) (list x y o r)) 1 2 3 nil)
"(1 2 3 #nil)")
(elisp-pass-if '(setq x 3) "3") (elisp-pass-if '(setq x 3) "3")
(elisp-pass-if '(defvar x 4) "x") (elisp-pass-if '(defvar x 4) "x")