xemacs-beta: src/eval.c comparison

comparison src/eval.c @ 404:2f8bb876ab1d r21-2-32

Import from CVS: tag r21-2-32

author	cvs
date	Mon, 13 Aug 2007 11:16:07 +0200
parents	a86b2b5e0111
children	b8cc9ab3f761

comparison

equal deleted inserted replaced

-:9f011ab08d48
+:2f8bb876ab1d
 in.
 */
 static Lisp_Object Vcondition_handlers;
-#if 0 /* no longer used */
+#define DEFEND_AGAINST_THROW_RECURSION
+#ifdef DEFEND_AGAINST_THROW_RECURSION
 /* Used for error catching purposes by throw_or_bomb_out */
 static int throw_level;
-#endif /* unused */
+#endif
+#ifdef ERROR_CHECK_TYPECHECK
+void check_error_state_sanity (void);
+#endif
 /************************************************************************/
 /*			The subr object type				*/
 /************************************************************************/
 return c.val;
 }
 c.val = (*func) (arg);
 if (threw) *threw = 0;
 catchlist = c.next;
+#ifdef ERROR_CHECK_TYPECHECK
+check_error_state_sanity ();
+#endif
 return c.val;
 }
 /* Unwind the specbind, catch, and handler stacks back to CATCH, and
 /* Unwind the specpdl stack, and then restore the proper set of
 handlers.  */
 unbind_to (catchlist->pdlcount, Qnil);
 handlerlist = catchlist->handlerlist;
 catchlist = catchlist->next;
+#ifdef ERROR_CHECK_TYPECHECK
+check_error_state_sanity ();
+#endif
 }
 while (! last_time);
 #else /* Actual XEmacs code */
 /* Unwind the specpdl stack */
 unbind_to (c->pdlcount, Qnil);
 catchlist = c->next;
+#ifdef ERROR_CHECK_TYPECHECK
+check_error_state_sanity ();
+#endif
 #endif
 gcprolist = c->gcpro;
 backtrace_list = c->backlist;
 lisp_eval_depth = c->lisp_eval_depth;
-#if 0 /* no longer used */
+#ifdef DEFEND_AGAINST_THROW_RECURSION
 throw_level = 0;
 #endif
 LONGJMP (c->jmp, 1);
 }
 static DOESNT_RETURN
 throw_or_bomb_out (Lisp_Object tag, Lisp_Object val, int bomb_out_p,
 		   Lisp_Object sig, Lisp_Object data)
 {
-#if 0
+#ifdef DEFEND_AGAINST_THROW_RECURSION
 /* die if we recurse more than is reasonable */
 if (++throw_level > 20)
 abort();
 #endif
 ungcpro, restoring catchlist and condition_handlers are actually
 redundant since unbind_to now restores them.  But it looks funny not to
 have this code here, and it doesn't cost anything, so I'm leaving it.*/
 UNGCPRO;
 catchlist = c.next;
+#ifdef ERROR_CHECK_TYPECHECK
+check_error_state_sanity ();
+#endif
 Vcondition_handlers = XCDR (c.tag);
 return unbind_to (speccount, c.val);
 }
 if (!initialized)
 {
 /* who knows how much has been initialized?  Safest bet is
 just to bomb out immediately. */
+/* let's not use stderr_out() here, because that does a bunch of
+	 things that might not be safe yet. */
 fprintf (stderr, "Error before initialization is complete!\n");
 abort ();
 }
 if (gc_in_progress || in_display)
 signal_error (Lisp_Object sig, Lisp_Object data)
 {
 for (;;)
 Fsignal (sig, data);
 }
+#ifdef ERROR_CHECK_TYPECHECK
+void
+check_error_state_sanity (void)
+{
+struct catchtag *c;
+int found_error_tag = 0;
+for (c = catchlist; c; c = c->next)
+{
+if (EQ (c->tag, Qunbound_suspended_errors_tag))
+	{
+	  found_error_tag = 1;
+	  break;
+	}
+}
+assert (found_error_tag || NILP (Vcurrent_error_state));
+}
+#endif
+static Lisp_Object
+restore_current_warning_class (Lisp_Object warning_class)
+{
+Vcurrent_warning_class = warning_class;
+return Qnil;
+}
+static Lisp_Object
+restore_current_error_state (Lisp_Object error_state)
+{
+Vcurrent_error_state = error_state;
+return Qnil;
+}
 static Lisp_Object
 call_with_suspended_errors_1 (Lisp_Object opaque_arg)
 {
 Lisp_Object val;
 Lisp_Object *kludgy_args = (Lisp_Object *) get_opaque_ptr (opaque_arg);
+Lisp_Object no_error = kludgy_args[2];
+int speccount = specpdl_depth ();
+if (!EQ (Vcurrent_error_state, no_error))
+{
+record_unwind_protect (restore_current_error_state,
+			     Vcurrent_error_state);
+Vcurrent_error_state = no_error;
+}
 PRIMITIVE_FUNCALL (val, get_opaque_ptr (kludgy_args[0]),
-		     kludgy_args + 2, XINT (kludgy_args[1]));
+		     kludgy_args + 3, XINT (kludgy_args[1]));
-return val;
+return unbind_to (speccount, val);
-}
-static Lisp_Object
-restore_current_warning_class (Lisp_Object warning_class)
-{
-Vcurrent_warning_class = warning_class;
-return Qnil;
-}
-static Lisp_Object
-restore_current_error_state (Lisp_Object error_state)
-{
-Vcurrent_error_state = error_state;
-return Qnil;
 }
 /* Many functions would like to do one of three things if an error
 occurs:
 			    Lisp_Object class, Error_behavior errb,
 			    int nargs, ...)
 {
 va_list vargs;
 int speccount;
-Lisp_Object kludgy_args[22];
+Lisp_Object kludgy_args[23];
-Lisp_Object *args = kludgy_args + 2;
+Lisp_Object *args = kludgy_args + 3;
 int i;
 Lisp_Object no_error;
 assert (SYMBOLP (class)); /* sanity-check */
 assert (!NILP (class));
 Lisp_Object val;
 PRIMITIVE_FUNCALL (val, fun, args, nargs);
 return val;
 }
-speccount = specpdl_depth();
+speccount = specpdl_depth ();
 if (NILP (class) || NILP (Vcurrent_warning_class))
 {
 /* If we're currently calling for no warnings, then make it so.
 	 If we're currently calling for warnings and we weren't
 	 previously, then set our warning class; otherwise, leave
 	 the existing one alone. */
 record_unwind_protect (restore_current_warning_class,
 			     Vcurrent_warning_class);
 Vcurrent_warning_class = class;
 }
-if (!EQ (Vcurrent_error_state, no_error))
-{
-record_unwind_protect (restore_current_error_state,
-			     Vcurrent_error_state);
-Vcurrent_error_state = no_error;
-}
 {
 int threw;
 Lisp_Object the_retval;
 Lisp_Object opaque1 = make_opaque_ptr (kludgy_args);
 struct gcpro gcpro1, gcpro2;
 GCPRO2 (opaque1, opaque2);
 kludgy_args[0] = opaque2;
 kludgy_args[1] = make_int (nargs);
+kludgy_args[2] = no_error;
 the_retval = internal_catch (Qunbound_suspended_errors_tag,
 				 call_with_suspended_errors_1,
 				 opaque1, &threw);
 free_opaque_ptr (opaque1);
 free_opaque_ptr (opaque2);
 specpdl_size = 50;
 specpdl = xnew_array (struct specbinding, specpdl_size);
 /* XEmacs change: increase these values. */
 max_specpdl_size = 3000;
 max_lisp_eval_depth = 500;
-#if 0 /* no longer used */
+#ifdef DEFEND_AGAINST_THROW_RECURSION
 throw_level = 0;
 #endif
 }
 void

Mercurial > hg > xemacs-beta

comparison src/eval.c @ 404:2f8bb876ab1d r21-2-32