diff src/eval.c @ 70:131b0175ea99 r20-0b30

Import from CVS: tag r20-0b30
author cvs
date Mon, 13 Aug 2007 09:02:59 +0200
parents 8d2a9b52c682
children 54cc21c15cbb
line wrap: on
line diff
--- a/src/eval.c	Mon Aug 13 09:00:04 2007 +0200
+++ b/src/eval.c	Mon Aug 13 09:02:59 2007 +0200
@@ -41,16 +41,6 @@
 
 struct backtrace *backtrace_list;
 
-/* Note you must always fill all of the fields in a backtrace structure
-   before pushing them on the backtrace_list.  The profiling code depends
-   on this. */
-
-#define PUSH_BACKTRACE(bt) \
-  do { (bt).next = backtrace_list; backtrace_list = &(bt); } while (0)
-
-#define POP_BACKTRACE(bt) \
-  do { backtrace_list = (bt).next; } while (0)
-
 /* This is the list of current catches (and also condition-cases).
    This is a stack: the most recent catch is at the head of the
    list.  Catches are created by declaring a 'struct catchtag'
@@ -228,7 +218,7 @@
 /* Used for error catching purposes by throw_or_bomb_out */
 static int throw_level;
 
-static Lisp_Object primitive_funcall (lisp_fn_t fn, int nargs,
+static Lisp_Object primitive_funcall (Lisp_Object (*fn) (), int nargs,
 				      Lisp_Object args[]);
 
 
@@ -413,8 +403,9 @@
 do_debug_on_exit (Lisp_Object val)
 {
   /* This is falsified by call_debugger */
+  int old_debug_on_next_call = debug_on_next_call;
   Lisp_Object v = call_debugger (list2 (Qexit, val));
-
+  debug_on_next_call = old_debug_on_next_call;
   return ((!UNBOUNDP (v)) ? v : val);
 }
 
@@ -664,7 +655,7 @@
 THEN must be one expression, but ELSE... can be zero or more expressions.
 If COND yields nil, and there are no ELSE's, the value is nil.
 */
-       (args))
+  (args))
 {
   /* This function can GC */
   Lisp_Object cond;
@@ -926,7 +917,7 @@
 The order of execution is thus TEST, BODY, TEST, BODY and so on
 until TEST returns nil.
 */
-       (args))
+(args))
 {
   /* This function can GC */
   Lisp_Object test, body, tem;
@@ -1757,7 +1748,7 @@
 Lisp stack, bindings, etc. as they were when `signal' was called,
 rather than when the handler was set, use `call-with-condition-handler'.
 */
-       (args))
+     (args))
 {
   /* This function can GC */
   return Fcondition_case_3 (Fcar (Fcdr (args)),
@@ -1781,7 +1772,7 @@
 (It continues to look for handlers established earlier than this one,
 and invokes the standard error-handler if none is found.)
 */
-       (int nargs, Lisp_Object *args))  /* Note!  Args side-effected! */
+(int nargs, Lisp_Object *args)) /* Note!  Args side-effected! */
 {
   /* This function can GC */
   int speccount = specpdl_depth_counter;
@@ -2063,8 +2054,9 @@
 call_with_suspended_errors_1 (Lisp_Object opaque_arg)
 {
   Lisp_Object *kludgy_args = (Lisp_Object *) get_opaque_ptr (opaque_arg);
-  return (primitive_funcall ((lisp_fn_t) get_opaque_ptr (kludgy_args[0]),
-			     XINT (kludgy_args[1]), kludgy_args + 2));
+  return (primitive_funcall
+	  ((Lisp_Object (*)()) get_opaque_ptr (kludgy_args[0]),
+	   XINT (kludgy_args[1]), kludgy_args + 2));
 }
 
 static Lisp_Object
@@ -2097,7 +2089,7 @@
 */
 
 Lisp_Object
-call_with_suspended_errors (lisp_fn_t fun, Lisp_Object retval,
+call_with_suspended_errors (Lisp_Object (*fun)(), Lisp_Object retval,
 			    Lisp_Object class, Error_behavior errb,
 			    int nargs, ...)
 {
@@ -2592,17 +2584,18 @@
 #ifdef EMACS_BTL
       backtrace.id_number = 0;
 #endif
+      backtrace.next = backtrace_list;
+      backtrace_list = &backtrace;
       backtrace.function = &Qcall_interactively;
       backtrace.args = &cmd;
       backtrace.nargs = 1;
       backtrace.evalargs = 0;
       backtrace.pdlcount = specpdl_depth ();
       backtrace.debug_on_exit = 0;
-      PUSH_BACKTRACE (backtrace);
 
       final = Fcall_interactively (cmd, record, keys);
 
-      POP_BACKTRACE (backtrace);
+      backtrace_list = backtrace.next;
       return (final);
     }
   else if (STRINGP (final) || VECTORP (final))
@@ -2926,12 +2919,13 @@
   backtrace.id_number = 0;
 #endif
   backtrace.pdlcount = specpdl_depth_counter;
+  backtrace.next = backtrace_list;
+  backtrace_list = &backtrace;
   backtrace.function = &original_fun; /* This also protects them from gc */
   backtrace.args = &original_args;
   backtrace.nargs = UNEVALLED;
   backtrace.evalargs = 1;
   backtrace.debug_on_exit = 0;
-  PUSH_BACKTRACE (backtrace);
 
   if (debug_on_next_call)
     do_debug_on_call (Qt);
@@ -2987,8 +2981,7 @@
 	  backtrace.args = vals;
 	  backtrace.nargs = nargs;
 
-	  val = ((Lisp_Object (*) (int, Lisp_Object *)) (subr_function (subr)))
-	    (nargs, vals);
+	  val = ((subr_function (subr)) (nargs, vals));
 
           /* Have to duplicate this code because if the
            *  debugger is called it must be in a scope in
@@ -3007,7 +3000,7 @@
 #endif
           if (backtrace.debug_on_exit)
             val = do_debug_on_exit (val);
-	  POP_BACKTRACE (backtrace);
+          backtrace_list = backtrace.next;
 	  UNGCPRO;
           return (val);
 	}
@@ -3080,7 +3073,7 @@
 #endif
   if (backtrace.debug_on_exit)
     val = do_debug_on_exit (val);
-  POP_BACKTRACE (backtrace);
+  backtrace_list = backtrace.next;
   return (val);
 }
 
@@ -3115,12 +3108,15 @@
   backtrace.id_number = 0;
 #endif
   backtrace.pdlcount = specpdl_depth_counter;
+  backtrace.next = backtrace_list;
   backtrace.function = &args[0];
   backtrace.args = &args[1];
   backtrace.nargs = nargs;
   backtrace.evalargs = 0;
   backtrace.debug_on_exit = 0;
-  PUSH_BACKTRACE (backtrace);
+  /* XEmacs: make sure this is done last so we don't get race
+     conditions in the profiling code. */
+  backtrace_list = &backtrace;
 
   if (debug_on_next_call)
     do_debug_on_call (Qlambda);
@@ -3158,8 +3154,7 @@
 
       if (max_args == MANY)
 	{
-	  val = ((Lisp_Object (*) (int, Lisp_Object *)) (subr_function (subr)))
-	    (nargs, args + 1);
+	  val = ((subr_function (subr)) (nargs, args + 1));
 	}
 
       else if (max_args > nargs)
@@ -3209,7 +3204,7 @@
   lisp_eval_depth--;
   if (backtrace.debug_on_exit)
     val = do_debug_on_exit (val);
-  POP_BACKTRACE (backtrace);
+  backtrace_list = backtrace.next;
   return val;
 }
 
@@ -3436,47 +3431,50 @@
 }
 
 
-/* Define proper types and argument lists simultaneously */
-#define PRIMITIVE_FUNCALL(n) ((Lisp_Object (*) (PRIMITIVE_FUNCALL_##n)
-#define PRIMITIVE_FUNCALL_0  void)) (fn)) (
-#define PRIMITIVE_FUNCALL_1  Lisp_Object)) (fn)) (args[0]
-#define PRIMITIVE_FUNCALL_2  Lisp_Object, PRIMITIVE_FUNCALL_1,  args[1]
-#define PRIMITIVE_FUNCALL_3  Lisp_Object, PRIMITIVE_FUNCALL_2,  args[2]
-#define PRIMITIVE_FUNCALL_4  Lisp_Object, PRIMITIVE_FUNCALL_3,  args[3]
-#define PRIMITIVE_FUNCALL_5  Lisp_Object, PRIMITIVE_FUNCALL_4,  args[4]
-#define PRIMITIVE_FUNCALL_6  Lisp_Object, PRIMITIVE_FUNCALL_5,  args[5]
-#define PRIMITIVE_FUNCALL_7  Lisp_Object, PRIMITIVE_FUNCALL_6,  args[6]
-#define PRIMITIVE_FUNCALL_8  Lisp_Object, PRIMITIVE_FUNCALL_7,  args[7]
-#define PRIMITIVE_FUNCALL_9  Lisp_Object, PRIMITIVE_FUNCALL_8,  args[8]
-#define PRIMITIVE_FUNCALL_10 Lisp_Object, PRIMITIVE_FUNCALL_9,  args[9]
-#define PRIMITIVE_FUNCALL_11 Lisp_Object, PRIMITIVE_FUNCALL_10, args[10]
-#define PRIMITIVE_FUNCALL_12 Lisp_Object, PRIMITIVE_FUNCALL_11, args[11]
-
 static Lisp_Object
-primitive_funcall (lisp_fn_t fn, int nargs, Lisp_Object args[])
+primitive_funcall (Lisp_Object (*fn) (), int nargs, Lisp_Object args[])
 {
   switch (nargs)
     {
-    case 0:  return PRIMITIVE_FUNCALL(0);
-    case 1:  return PRIMITIVE_FUNCALL(1);
-    case 2:  return PRIMITIVE_FUNCALL(2);
-    case 3:  return PRIMITIVE_FUNCALL(3);
-    case 4:  return PRIMITIVE_FUNCALL(4);
-    case 5:  return PRIMITIVE_FUNCALL(5);
-    case 6:  return PRIMITIVE_FUNCALL(6);
-    case 7:  return PRIMITIVE_FUNCALL(7);
-    case 8:  return PRIMITIVE_FUNCALL(8);
-    case 9:  return PRIMITIVE_FUNCALL(9);
-    case 10: return PRIMITIVE_FUNCALL(10);
-    case 11: return PRIMITIVE_FUNCALL(11);
-    case 12: return PRIMITIVE_FUNCALL(12);
+    case 0:
+      return ((*fn) ());
+    case 1:
+      return ((*fn) (args[0]));
+    case 2:
+      return ((*fn) (args[0], args[1]));
+    case 3:
+      return ((*fn) (args[0], args[1], args[2]));
+    case 4:
+      return ((*fn) (args[0], args[1], args[2], args[3]));
+    case 5:
+      return ((*fn) (args[0], args[1], args[2], args[3], args[4]));
+    case 6:
+      return ((*fn) (args[0], args[1], args[2], args[3], args[4], args[5]));
+    case 7:
+      return ((*fn) (args[0], args[1], args[2], args[3], args[4], args[5],
+		     args[6]));
+    case 8:
+      return ((*fn) (args[0], args[1], args[2], args[3], args[4], args[5],
+		     args[6], args[7]));
+    case 9:
+      return ((*fn) (args[0], args[1], args[2], args[3], args[4], args[5],
+		     args[6], args[7], args[8]));
+    case 10:
+      return ((*fn) (args[0], args[1], args[2], args[3], args[4], args[5],
+		     args[6], args[7], args[8], args[9]));
+    case 11:
+      return ((*fn) (args[0], args[1], args[2], args[3], args[4], args[5],
+		     args[6], args[7], args[8], args[9], args[10]));
+    case 12:
+      return ((*fn) (args[0], args[1], args[2], args[3], args[4], args[5],
+		     args[6], args[7], args[8], args[9], args[10], args[11]));
+    default:
+      /* Someone has created a subr that takes more arguments than
+	 is supported by this code.  We need to either rewrite the
+	 subr to use a different argument protocol, or add more
+	 cases to this switch.  */
+      abort ();
     }
-
-  /* Someone has created a subr that takes more arguments than is
-     supported by this code.  We need to either rewrite the subr to
-     use a different argument protocol, or add more cases to this
-     switch.  */
-  abort ();
   return Qnil;	/* suppress compiler warning */
 }
 
@@ -3613,6 +3611,10 @@
       tem = read_doc_string (XCOMPILED_FUNCTION (object)->bytecodes);
       if (!CONSP (tem))
 	signal_simple_error ("invalid lazy-loaded byte code", tem);
+      /* v18 or v19 bytecode file.  Need to Ebolify. */
+      if (XCOMPILED_FUNCTION (object)->flags.ebolified
+	  && VECTORP (XCDR (tem)))
+	ebolify_bytecode_constants (XCDR (tem));
       /* VERY IMPORTANT to purecopy here!!!!!
 	 See load_force_doc_string_unwind. */
       XCOMPILED_FUNCTION (object)->bytecodes = Fpurecopy (XCAR (tem));