xemacs-beta: src/eval.c comparison

comparison src/eval.c @ 1333:1b0339b048ce

[xemacs-hg @ 2003-03-02 09:38:37 by ben] To: xemacs-patches@xemacs.org PROBLEMS: Include nt/PROBLEMS and update. Add note about incremental linking badness. cmdloop.el, custom.el, dumped-lisp.el, files.el, keydefs.el, keymap.el, lisp-mode.el, make-docfile.el, replace.el, simple.el, subr.el, view-less.el, wid-edit.el: Lots of syncing with FSF 21.2. Use if-fboundp in wid-edit.el. New file newcomment.el from FSF. internals/internals.texi: Fix typo. (Build-Time Dependencies): New node. PROBLEMS: Delete. config.inc.samp, xemacs.mak: Eliminate HAVE_VC6, use SUPPORT_EDIT_AND_CONTINUE in its place. No incremental linking unless SUPPORT_EDIT_AND_CONTINUE, since it can cause nasty crashes in pdump. Put warnings about this in config.inc.samp. Report the full compile flags used for src and lib-src in the Installation output. alloc.c, lisp.h, ralloc.c, regex.c: Use ALLOCA() in regex.c to avoid excessive stack allocation. Also fix subtle problem with REL_ALLOC() -- any call to malloc() (direct or indirect) may relocate rel-alloced data, causing buffer text to shift. After any such call, regex must update all its pointers to such data. Add a system, when ERROR_CHECK_MALLOC, whereby regex.c indicates all the places it is prepared to handle malloc()/realloc()/free(), and any calls anywhere in XEmacs outside of this will trigger an abort. alloc.c, dialog-msw.c, eval.c, event-stream.c, general-slots.h, insdel.c, lisp.h, menubar-msw.c, menubar-x.c: Change *run_hook*_trapping_problems to take a warning class, not a string. Factor out code to issue warnings, add flag to call_trapping_problems() to postpone warning issue, and make *run_hook*_trapping_problems issue their own warnings tailored to the hook, postponed in the case of safe_run_hook_trapping_problems() so that the appropriate message can be issued about resetting to nil only when not `quit'. Make record_unwind_protect_restoring_int() non-static. dumper.c: Issue notes about incremental linking problems under Windows. fileio.c: Mule-ize encrypt/decrypt-string code. text.h: Spacing changes.

author	ben
date	Sun, 02 Mar 2003 09:38:54 +0000
parents	0e48d8b45bdb
children	ac1be85b4a5f

comparison

equal deleted inserted replaced

-:6aa23bb3da6b
+:1b0339b048ce
 args[0] = Qpost_gc_hook;
 args[1] = Fcons (Fcons (Qfinalize_list, zap_finalize_list ()), Qnil);
 run_hook_with_args_trapping_problems
-("Error in post-gc-hook",
+(Qgarbage_collecting, 2, args, RUN_HOOKS_TO_COMPLETION,
-2, args,
-RUN_HOOKS_TO_COMPLETION,
 INHIBIT_QUIT | NO_INHIBIT_ERRORS);
 }
 DEFUN ("funcall", Ffuncall, 1, MANY, 0, /*
 Call first argument as a function, passing the remaining arguments to it.
 flagged_a_squirmer (Lisp_Object error_conditions, Lisp_Object data,
 		    Lisp_Object opaque)
 {
 struct call_trapping_problems *p =
 (struct call_trapping_problems *) get_opaque_ptr (opaque);
-struct gcpro gcpro1;
-Lisp_Object lstream = Qnil;
-Lisp_Object errstr;
-int speccount = specpdl_depth ();
 if (!(inhibit_flags & INHIBIT_WARNING_ISSUE)
 && !warning_will_be_discarded (current_warning_level ()))
 {
+struct gcpro gcpro1;
+Lisp_Object lstream = Qnil;
+int speccount = specpdl_depth ();
 /* We're no longer protected against errors or quit here, so at
 	 least let's temporarily inhibit quit.  We definitely do not
 	 want to inhibit quit during the calling of the function
 	 itself!!!!!!!!!!! */
 Lstream_flush (XLSTREAM (lstream));
 p->backtrace = resizing_buffer_to_lisp_string (XLSTREAM (lstream));
 Lstream_delete (XLSTREAM (lstream));
 UNGCPRO;
-/* #### This should call
-	 (with-output-to-string (display-error (cons error_conditions data))
-	 but that stuff is all in Lisp currently. */
-errstr =
-	emacs_sprintf_string_lisp
-	("%s: (%s %s)\n\nBacktrace follows:\n\n%s",
-	 Qnil, 4,
-	 build_msg_string (p->warning_string ? p->warning_string : "error"),
-	 error_conditions, data, p->backtrace);
-warn_when_safe_lispobj (p->warning_class, current_warning_level (),
-			      errstr);
 unbind_to (speccount);
 }
 else
 p->backtrace = Qnil;
 static Lisp_Object
 call_trapping_problems_1 (Lisp_Object opaque)
 {
 return call_with_condition_handler (flagged_a_squirmer, opaque,
 				      call_trapping_problems_2, opaque);
+}
+static void
+issue_call_trapping_problems_warning (Lisp_Object warning_class,
+				      const CIbyte *warning_string,
+				      struct call_trapping_problems_result *p)
+{
+if (!warning_will_be_discarded (current_warning_level ()))
+{
+int depth = specpdl_depth ();
+/* We're no longer protected against errors or quit here, so at
+	 least let's temporarily inhibit quit. */
+specbind (Qinhibit_quit, Qt);
+if (p->caught_throw)
+	{
+	  Lisp_Object errstr =
+	    emacs_sprintf_string_lisp
+	    ("%s: Attempt to throw outside of function "
+	     "to catch `%s' with value `%s'",
+	     Qnil, 3,
+	     build_msg_string (warning_string ? warning_string : "error"),
+	     p->thrown_tag, p->thrown_value);
+	  warn_when_safe_lispobj (Qerror, current_warning_level (), errstr);
+	}
+else if (p->caught_error)
+	{
+	  Lisp_Object errstr;
+	  /* #### This should call
+	     (with-output-to-string (display-error (cons error_conditions
+	                                                 data))
+	     but that stuff is all in Lisp currently. */
+	  errstr =
+	    emacs_sprintf_string_lisp
+	    ("%s: (%s %s)\n\nBacktrace follows:\n\n%s",
+	     Qnil, 4,
+	     build_msg_string (warning_string ? warning_string : "error"),
+	     p->error_conditions, p->data, p->backtrace);
+	  warn_when_safe_lispobj (warning_class, current_warning_level (),
+				  errstr);
+	}
+unbind_to (depth);
+}
 }
 /* Turn on the trapping flags in FLAGS -- see call_trapping_problems().
 This cannot handle INTERNAL_INHIBIT_THROWS() or INTERNAL_INHIBIT_ERRORS
 (because they ultimately boil down to a setjmp()!) -- you must directly
 `throw' out of the function being called are trapped, and a warning
 issued. (Again, WARNING_STRING should be given.)
 (If FLAGS contains INHIBIT_WARNING_ISSUE, no warnings are issued;
 this applies to recursive invocations of call_trapping_problems, too.
+If FLAGS contains POSTPONE_WARNING_ISSUE, no warnings are issued;
+but values useful for generating a warning are still computed (in
+particular, the backtrace), so that the calling function can issue
+a warning.
 If FLAGS contains ISSUE_WARNINGS_AT_DEBUG_LEVEL, warnings will be
 issued, but at level `debug', which normally is below the minimum
 specified by `log-warning-minimum-level', meaning such warnings will
 be ignored entirely.  The user can change this variable, however,
 			void *arg)
 {
 int speccount = specpdl_depth ();
 struct gcpro gcpro1, gcpro2, gcpro3, gcpro4, gcpro5;
 struct call_trapping_problems package;
+struct call_trapping_problems_result real_problem;
 Lisp_Object opaque, thrown_tag, tem;
 int thrown = 0;
 assert (SYMBOLP (warning_class)); /* sanity-check */
 assert (!NILP (warning_class));
 			  &thrown, &thrown_tag);
 else
 /* Nothing special. */
 tem = (fun) (arg);
-if (thrown && !EQ (thrown_tag, package.catchtag)
+if (!problem)
-&& !(flags & INHIBIT_WARNING_ISSUE)
+problem = &real_problem;
-&& !warning_will_be_discarded (current_warning_level ()))
-{
+if (!thrown)
-Lisp_Object errstr;
+{
+problem->caught_error = 0;
-if (!(flags & INHIBIT_QUIT))
+problem->caught_throw = 0;
-	/* We're no longer protected against errors or quit here, so at
+problem->error_conditions = Qnil;
-	   least let's temporarily inhibit quit. */
+problem->data = Qnil;
-	specbind (Qinhibit_quit, Qt);
+problem->backtrace = Qnil;
-errstr =
+problem->thrown_tag = Qnil;
-	emacs_sprintf_string_lisp
+problem->thrown_value = Qnil;
-	("%s: Attempt to throw outside of function "
+}
-	 "to catch `%s' with value `%s'",
+else if (EQ (thrown_tag, package.catchtag))
-	 Qnil, 3, build_msg_string (warning_string ? warning_string : "error"),
+{
-	 thrown_tag, tem);
+problem->caught_error = 1;
+problem->caught_throw = 0;
-warn_when_safe_lispobj (Qerror, current_warning_level (), errstr);
+problem->error_conditions = package.error_conditions;
-}
+problem->data = package.data;
+problem->backtrace = package.backtrace;
-if (problem)
+problem->thrown_tag = Qnil;
-{
+problem->thrown_value = Qnil;
-if (!thrown)
+}
-	{
+else
-	  problem->caught_error = 0;
+{
-	  problem->caught_throw = 0;
+problem->caught_error = 0;
-	  problem->error_conditions = Qnil;
+problem->caught_throw = 1;
-	  problem->data = Qnil;
+problem->error_conditions = Qnil;
-	  problem->backtrace = Qnil;
+problem->data = Qnil;
-	  problem->thrown_tag = Qnil;
+problem->backtrace = Qnil;
-	  problem->thrown_value = Qnil;
+problem->thrown_tag = thrown_tag;
-	}
+problem->thrown_value = tem;
-else if (EQ (thrown_tag, package.catchtag))
+}
-	{
-	  problem->caught_error = 1;
+if (!(flags & INHIBIT_WARNING_ISSUE) && !(flags & POSTPONE_WARNING_ISSUE))
-	  problem->caught_throw = 0;
+issue_call_trapping_problems_warning (warning_class, warning_string,
-	  problem->error_conditions = package.error_conditions;
+					  problem);
-	  problem->data = package.data;
-	  problem->backtrace = package.backtrace;
-	  problem->thrown_tag = Qnil;
-	  problem->thrown_value = Qnil;
-	}
-else
-	{
-	  problem->caught_error = 0;
-	  problem->caught_throw = 1;
-	  problem->error_conditions = Qnil;
-	  problem->data = Qnil;
-	  problem->backtrace = Qnil;
-	  problem->thrown_tag = thrown_tag;
-	  problem->thrown_value = tem;
-	}
-}
 if (!NILP (package.catchtag) &&
 !EQ (package.catchtag, Vcatch_everything_tag))
 free_opaque_ptr (package.catchtag);
 					  eval_in_buffer_trapping_problems_1,
 					  &p));
 }
 Lisp_Object
-run_hook_trapping_problems (const CIbyte *warning_string,
+run_hook_trapping_problems (Lisp_Object warning_class,
 			    Lisp_Object hook_symbol,
 			    int flags)
 {
-return run_hook_with_args_trapping_problems (warning_string, 1, &hook_symbol,
+return run_hook_with_args_trapping_problems (warning_class, 1, &hook_symbol,
 					       RUN_HOOKS_TO_COMPLETION,
 					       flags);
 }
 static Lisp_Object
 /* Same as run_hook_trapping_problems() but also set the hook to nil
 if an error occurs (but not a quit). */
 Lisp_Object
-safe_run_hook_trapping_problems (const CIbyte *warning_string,
+safe_run_hook_trapping_problems (Lisp_Object warning_class,
-				 Lisp_Object hook_symbol,
+				 Lisp_Object hook_symbol, int flags)
-				 int flags)
 {
 Lisp_Object tem;
 struct gcpro gcpro1, gcpro2;
 struct call_trapping_problems_result prob;
 tem = find_symbol_value (hook_symbol);
 if (NILP (tem) || UNBOUNDP (tem))
 return Qnil;
 GCPRO2 (hook_symbol, tem);
-tem = call_trapping_problems (Qerror, warning_string, flags,
+tem = call_trapping_problems (Qerror, NULL,
+				flags | POSTPONE_WARNING_ISSUE,
 				&prob,
 				safe_run_hook_trapping_problems_1,
 				LISP_TO_VOID (hook_symbol));
-if (prob.caught_throw || (prob.caught_error && !EQ (prob.error_conditions,
+{
-						      Qquit)))
+Lisp_Object hook_name = XSYMBOL_NAME (hook_symbol);
-Fset (hook_symbol, Qnil);
+Ibyte *hook_str = XSTRING_DATA (hook_name);
-RETURN_UNGCPRO (tem);
+Ibyte *err = alloca_ibytes (XSTRING_LENGTH (hook_name) + 100);
+if (prob.caught_throw || (prob.caught_error && !EQ (prob.error_conditions,
+							Qquit)))
+{
+	Fset (hook_symbol, Qnil);
+	qxesprintf (err, "Error in `%s' (resetting to nil)", hook_str);
+}
+else
+qxesprintf (err, "Quit in `%s'", hook_str);
+issue_call_trapping_problems_warning (warning_class, (CIbyte *) err,
+					  &prob);
+}
+UNGCPRO;
+return tem;
 }
 struct run_hook_with_args_in_buffer_trapping_problems
 {
 struct buffer *buf;
 /* #### fix these functions to follow the calling convention of
 call_trapping_problems! */
 Lisp_Object
-run_hook_with_args_in_buffer_trapping_problems (const CIbyte *warning_string,
+run_hook_with_args_in_buffer_trapping_problems (Lisp_Object warning_class,
 						struct buffer *buf, int nargs,
 						Lisp_Object *args,
 						enum run_hooks_condition cond,
 						int flags)
 {
 Lisp_Object sym, val, ret;
 struct run_hook_with_args_in_buffer_trapping_problems diversity_and_distrust;
 struct gcpro gcpro1;
+Lisp_Object hook_name;
+Ibyte *hook_str;
+Ibyte *err;
 if (!initialized || preparing_for_armageddon)
 /* We need to bail out of here pronto. */
 return Qnil;
 diversity_and_distrust.buf = buf;
 diversity_and_distrust.nargs = nargs;
 diversity_and_distrust.args = args;
 diversity_and_distrust.cond = cond;
+hook_name = XSYMBOL_NAME (args[0]);
+hook_str = XSTRING_DATA (hook_name);
+err = alloca_ibytes (XSTRING_LENGTH (hook_name) + 100);
+qxesprintf (err, "Error in `%s'", hook_str);
 RETURN_UNGCPRO
 (call_trapping_problems
-(Qerror, warning_string,
+(warning_class, (CIbyte *) err, flags, 0,
-flags, 0,
 run_hook_with_args_in_buffer_trapping_problems_1,
 &diversity_and_distrust));
 }
 Lisp_Object
-run_hook_with_args_trapping_problems (const CIbyte *warning_string,
+run_hook_with_args_trapping_problems (Lisp_Object warning_class,
 				      int nargs,
 				      Lisp_Object *args,
 				      enum run_hooks_condition cond,
 				      int flags)
 {
 return run_hook_with_args_in_buffer_trapping_problems
-(warning_string, current_buffer, nargs, args, cond, flags);
+(warning_class, current_buffer, nargs, args, cond, flags);
 }
 Lisp_Object
-va_run_hook_with_args_trapping_problems (const CIbyte *warning_string,
+va_run_hook_with_args_trapping_problems (Lisp_Object warning_class,
 					 Lisp_Object hook_var,
 					 int nargs, ...)
 {
 /* This function can GC */
 struct gcpro gcpro1;
 flags = va_arg (vargs, int);
 va_end (vargs);
 GCPRO1_ARRAY (funcall_args, nargs + 1);
 RETURN_UNGCPRO (run_hook_with_args_in_buffer_trapping_problems
-		  (warning_string, current_buffer, nargs + 1, funcall_args,
+		  (warning_class, current_buffer, nargs + 1, funcall_args,
 		   RUN_HOOKS_TO_COMPLETION, flags));
 }
 Lisp_Object
-va_run_hook_with_args_in_buffer_trapping_problems (const CIbyte *
+va_run_hook_with_args_in_buffer_trapping_problems (Lisp_Object warning_class,
-						   warning_string,
 						   struct buffer *buf,
 						   Lisp_Object hook_var,
 						   int nargs, ...)
 {
 /* This function can GC */
 flags = va_arg (vargs, int);
 va_end (vargs);
 GCPRO1_ARRAY (funcall_args, nargs + 1);
 RETURN_UNGCPRO (run_hook_with_args_in_buffer_trapping_problems
-		  (warning_string, buf, nargs + 1, funcall_args,
+		  (warning_class, buf, nargs + 1, funcall_args,
 		   RUN_HOOKS_TO_COMPLETION, flags));
 }
 /************************************************************************/
 }
 /* Establish an unwind-protect which will restore the int pointed to
 by ADDR with the value VAL.  This function works correctly with
 all ints, even those that don't fit into a Lisp integer. */
-static int
+int
 record_unwind_protect_restoring_int (int *addr, int val)
 {
 Lisp_Object opaque = make_opaque_ptr (addr);
 Lisp_Object lval;

Mercurial > hg > xemacs-beta

comparison src/eval.c @ 1333:1b0339b048ce