From fb10a0084e0e670cf6ecad1e62e6f22e315672b9 Mon Sep 17 00:00:00 2001
From: Andy Wingo <wingo@pobox.com>
Date: Sun, 4 Jan 2009 14:06:52 +0100
Subject: [PATCH] allow `apply' on %nil-terminated lists

* 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.
---
 libguile/vm-engine.h        |  4 ++--
 libguile/vm-i-system.c      | 16 ++++++++++------
 libguile/vm.c               |  1 +
 test-suite/tests/elisp.test |  8 ++------
 4 files changed, 15 insertions(+), 14 deletions(-)

diff --git a/libguile/vm-engine.h b/libguile/vm-engine.h
index 217ad2e66..d0ceaf492 100644
--- a/libguile/vm-engine.h
+++ b/libguile/vm-engine.h
@@ -299,12 +299,12 @@ do						\
 } while (0)
 
 /* The opposite: push all of the elements in L onto the list. */
-#define PUSH_LIST(l)				\
+#define PUSH_LIST(l, NILP)			\
 do						\
 {						\
   for (; scm_is_pair (l); l = SCM_CDR (l))      \
     PUSH (SCM_CAR (l));                         \
-  if (SCM_UNLIKELY (!SCM_NULLP (l))) {          \
+  if (SCM_UNLIKELY (!NILP (l))) {               \
     err_args = scm_list_1 (l);                  \
     goto vm_error_improper_list;                \
   }                                             \
diff --git a/libguile/vm-i-system.c b/libguile/vm-i-system.c
index 831819db8..60182c75a 100644
--- a/libguile/vm-i-system.c
+++ b/libguile/vm-i-system.c
@@ -214,7 +214,7 @@ VM_DEFINE_INSTRUCTION (list_break, "list-break", 0, 0, 0)
 {
   SCM l;
   POP (l);
-  PUSH_LIST (l);
+  PUSH_LIST (l, SCM_NULLP);
   NEXT;
 }
 
@@ -784,7 +784,7 @@ VM_DEFINE_INSTRUCTION (goto_args, "goto/args", 1, -1, 1)
           POP (values);
           values = scm_struct_ref (values, SCM_INUM0);
           nvalues = scm_ilength (values);
-          PUSH_LIST (values);
+          PUSH_LIST (values, SCM_NULLP);
           goto vm_return_values;
         }
       goto vm_return;
@@ -861,7 +861,7 @@ VM_DEFINE_INSTRUCTION (mv_call, "mv-call", 3, -1, 1)
           POP (values);
           values = scm_struct_ref (values, SCM_INUM0);
           len = scm_length (values);
-          PUSH_LIST (values);
+          PUSH_LIST (values, SCM_NULLP);
           PUSH (len);
           ip += offset;
         }
@@ -893,7 +893,7 @@ VM_DEFINE_INSTRUCTION (apply, "apply", 1, -1, 1)
   if (len < 0)
     goto vm_error_wrong_type_arg;
 
-  PUSH_LIST (ls);
+  PUSH_LIST (ls, SCM_NULL_OR_NIL_P);
 
   nargs += len - 2;
   goto vm_call;
@@ -912,7 +912,7 @@ VM_DEFINE_INSTRUCTION (goto_apply, "goto/apply", 1, -1, 1)
   if (len < 0)
     goto vm_error_wrong_type_arg;
 
-  PUSH_LIST (ls);
+  PUSH_LIST (ls, SCM_NULL_OR_NIL_P);
 
   nargs += len - 2;
   goto vm_goto_args;
@@ -974,7 +974,7 @@ VM_DEFINE_INSTRUCTION (goto_cc, "goto/cc", 0, 1, 1)
       SCM values;
       values = scm_struct_ref (cont, SCM_INUM0);
       nvalues = scm_ilength (values);
-      PUSH_LIST (values);
+      PUSH_LIST (values, SCM_NULLP);
       goto vm_return_values;
     }
   else
@@ -1097,6 +1097,10 @@ VM_DEFINE_INSTRUCTION (return_values_star, "return/values*", 1, -1, -1)
       l = SCM_CDR (l);
       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;
 }
diff --git a/libguile/vm.c b/libguile/vm.c
index 32fde6150..ed69bd995 100644
--- a/libguile/vm.c
+++ b/libguile/vm.c
@@ -49,6 +49,7 @@
 #include "instructions.h"
 #include "objcodes.h"
 #include "programs.h"
+#include "lang.h" /* NULL_OR_NIL_P */
 #include "vm.h"
 
 /* I sometimes use this for debugging. */
diff --git a/test-suite/tests/elisp.test b/test-suite/tests/elisp.test
index 06378f885..eaf6dbbff 100644
--- a/test-suite/tests/elisp.test
+++ b/test-suite/tests/elisp.test
@@ -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 '(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
-      ;; lists.
-      (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 '(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 '(defvar x 4) "x")