diff src/eval.c @ 5178:97eb4942aec8

merge
author Ben Wing <ben@xemacs.org>
date Mon, 29 Mar 2010 21:28:13 -0500
parents 88bd4f3ef8e4
children 1096ef427b56
line wrap: on
line diff
--- a/src/eval.c	Tue Feb 23 07:28:35 2010 -0600
+++ b/src/eval.c	Mon Mar 29 21:28:13 2010 -0500
@@ -418,6 +418,29 @@
 static Lisp_Object maybe_get_trapping_problems_backtrace (void);
 
 
+
+/* When parsing keyword arguments; is some element of NARGS
+   :allow-other-keys, and is that element followed by a non-nil Lisp
+   object? */
+
+Boolint
+non_nil_allow_other_keys_p (Elemcount offset, int nargs, Lisp_Object *args)
+{
+  Lisp_Object key, value;
+  while (offset + 1 < nargs)
+    {
+      key = args[offset++];
+      value = args[offset++];
+      if (EQ (key, Q_allow_other_keys)) 
+	{
+          /* The ANSI Common Lisp standard says the first value for a given
+             keyword overrides. */
+          return !NILP (value);
+	}
+    }
+  return 0;
+}
+
 /************************************************************************/
 /*			The subr object type				*/
 /************************************************************************/
@@ -432,7 +455,7 @@
   const Ascbyte *trailer = subr->prompt ? " (interactive)>" : ">";
 
   if (print_readably)
-    printing_unreadable_object ("%s%s%s", header, name, trailer);
+    printing_unreadable_object_fmt ("%s%s%s", header, name, trailer);
 
   write_ascstring (printcharfun, header);
   write_ascstring (printcharfun, name);
@@ -444,11 +467,10 @@
   { XD_END }
 };
 
-DEFINE_BASIC_LRECORD_IMPLEMENTATION ("subr", subr,
-				     1, /*dumpable-flag*/
-				     0, print_subr, 0, 0, 0,
-				     subr_description,
-				     Lisp_Subr);
+DEFINE_DUMPABLE_FROB_BLOCK_LISP_OBJECT ("subr", subr,
+					0, print_subr, 0, 0, 0,
+					subr_description,
+					Lisp_Subr);
 
 /************************************************************************/
 /*			 Entering the debugger				*/
@@ -3050,6 +3072,12 @@
 }
 
 DOESNT_RETURN
+invalid_keyword_argument (Lisp_Object function, Lisp_Object keyword)
+{
+  signal_error_1 (Qinvalid_keyword_argument, list2 (function, keyword));
+}
+
+DOESNT_RETURN
 invalid_constant (const Ascbyte *reason, Lisp_Object frob)
 {
   signal_error (Qinvalid_constant, reason, frob);
@@ -4491,6 +4519,7 @@
   Bytecount sizem;
   struct multiple_value *mv;
   Elemcount i, allocated_count;
+  Lisp_Object mvobj;
 
   assert (count != 1);
 
@@ -4516,8 +4545,8 @@
   sizem = FLEXIBLE_ARRAY_STRUCT_SIZEOF (multiple_value,
                                         Lisp_Object,
                                         contents, allocated_count);
-  mv = (multiple_value *) BASIC_ALLOC_LCRECORD (sizem,
-                                                &lrecord_multiple_value);
+  mvobj = ALLOC_SIZED_LISP_OBJECT (sizem, multiple_value);
+  mv = XMULTIPLE_VALUE (mvobj);
 
   mv->count = count;
   mv->first_desired = first_desired;
@@ -4529,7 +4558,7 @@
       mv->contents[1 + (i - first_desired)] = Qunbound;
     }
 
-  return wrap_multiple_value (mv);
+  return mvobj;
 }
 
 void
@@ -4576,13 +4605,13 @@
 
   if (print_readably)
     {
-      printing_unreadable_object ("multiple values");
+      printing_unreadable_object_fmt ("#<multiple values 0x%x>",
+				      LISP_OBJECT_UID (obj));
     }
 
-  if (0 == count)
-    {
-      write_msg_string (printcharfun, "#<zero-length multiple value>");
-    }
+  write_fmt_string (printcharfun,
+                    "#<INTERNAL OBJECT (XEmacs bug?) %d multiple values,"
+                    " data (", count);
 
   for (index = 0; index < count;)
     {
@@ -4603,9 +4632,11 @@
 
       if (count > 1 && index < count)
         {
-          write_ascstring (printcharfun, " ;\n");
+          write_ascstring (printcharfun, " ");
         }
     }
+
+  write_fmt_string (printcharfun, ") 0x%x>", LISP_OBJECT_UID (obj));
 }
 
 static Lisp_Object
@@ -4623,12 +4654,11 @@
 }
 
 static Bytecount
-size_multiple_value (const void *lheader)
+size_multiple_value (Lisp_Object obj)
 {
   return FLEXIBLE_ARRAY_STRUCT_SIZEOF (struct multiple_value,
                                        Lisp_Object, contents,
-                                       ((struct multiple_value *) lheader)->
-                                       allocated_count);
+                                       XMULTIPLE_VALUE (obj)->allocated_count);
 }
 
 static const struct memory_description multiple_value_description[] = {
@@ -4640,15 +4670,14 @@
   { XD_END }
 };
 
-DEFINE_LRECORD_SEQUENCE_IMPLEMENTATION ("multiple-value", multiple_value,
-					1, /*dumpable-flag*/
-					mark_multiple_value,
-                                        print_multiple_value, 0,
-					0, /* No equal method. */
-					0, /* No hash method. */
-					multiple_value_description,
-					size_multiple_value,
-                                        struct multiple_value);
+DEFINE_DUMPABLE_SIZABLE_LISP_OBJECT ("multiple-value", multiple_value,
+				     mark_multiple_value,
+				     print_multiple_value, 0,
+				     0, /* No equal method. */
+				     0, /* No hash method. */
+				     multiple_value_description,
+				     size_multiple_value,
+				     struct multiple_value);
 
 /* Given that FIRST and UPPER are the inclusive lower and exclusive upper
    bounds for the multiple values we're interested in, modify (or don't) the
@@ -7236,8 +7265,8 @@
 void
 syms_of_eval (void)
 {
-  INIT_LRECORD_IMPLEMENTATION (subr);
-  INIT_LRECORD_IMPLEMENTATION (multiple_value);
+  INIT_LISP_OBJECT (subr);
+  INIT_LISP_OBJECT (multiple_value);
 
   DEFSYMBOL (Qinhibit_quit);
   DEFSYMBOL (Qautoload);