xemacs-beta: src/print.c comparison

comparison src/print.c @ 5027:22179cd0fe15

merge

author	Ben Wing <ben@xemacs.org>
date	Wed, 10 Feb 2010 07:25:19 -0600
parents	c2e0c3af5fe3
children	b5df3737028a

comparison

equal deleted inserted replaced

-:46cf825f6158
+:22179cd0fe15
 Lisp_Object Vprint_length;
 Lisp_Object Vprint_level;
 Lisp_Object Vinhibit_quit;
 };
-static Lisp_Object debug_prin1_bindings;
+static int begin_inhibit_non_essential_conversion_operations (void);
 int stdout_needs_newline;
 int stdout_clear_before_next_output;
 Works like stderr_out(). */
 void
 debug_out (const CIbyte *fmt, ...)
 {
+int depth =  begin_inhibit_non_essential_conversion_operations ();
 va_list args;
 va_start (args, fmt);
 write_string_to_external_output_va (fmt, args, EXT_PRINT_ALL);
 va_end (args);
+unbind_to (depth);
 }
 DOESNT_RETURN
 fatal (const CIbyte *fmt, ...)
 {
 default:
 {
 	/* We're in trouble if this happens! */
 	printing_major_badness (printcharfun, "ILLEGAL LISP OBJECT TAG TYPE",
-				XTYPE (obj), LISP_TO_VOID (obj), 0,
+				XTYPE (obj), STORE_LISP_IN_VOID (obj), 0,
 				BADNESS_INTEGER_OBJECT);
 	break;
 }
 }
 return;
 if (alternate_do_pointer + extlen >= alternate_do_size)
 {
 alternate_do_size =
-	max(alternate_do_size * 2, alternate_do_pointer + extlen + 1);
+	max (alternate_do_size * 2, alternate_do_pointer + extlen + 1);
-XREALLOC_ARRAY (alternate_do_string, char, alternate_do_size);
+XREALLOC_ARRAY (alternate_do_string, CIbyte, alternate_do_size);
 }
 memcpy (alternate_do_string + alternate_do_pointer, extptr, extlen);
 alternate_do_pointer += extlen;
 alternate_do_string[alternate_do_pointer] = 0;
 }
 	report_file_error ("Opening termscript", filename);
 }
 return Qnil;
 }
+static Lisp_Object
+restore_inhibit_non_essential_conversion_operations (Lisp_Object obj)
+{
+inhibit_non_essential_conversion_operations = XINT (obj);
+return Qnil;
+}
+/* Bind the value of inhibit_non_essential_conversion_operations to 1
+in a way that involves no consing. */
+static int
+begin_inhibit_non_essential_conversion_operations (void)
+{
+int depth =
+record_unwind_protect
+(restore_inhibit_non_essential_conversion_operations,
+make_int (inhibit_non_essential_conversion_operations));
+inhibit_non_essential_conversion_operations = 1;
+return depth;
+}
 static int debug_print_length   = 50;
 static int debug_print_level    = 15;
 static int debug_print_readably = -1;
 /* Restore values temporarily bound by debug_prin1.  We use this approach to
-avoid consing in debug_prin1.  That is verboten, since debug_prin1 can be
+avoid consing in debug_prin1.  That is verboten, since debug_print can be
 called by cons debugging code. */
 static Lisp_Object
-debug_prin1_exit (Lisp_Object UNUSED (ignored))
+debug_print_exit (Lisp_Object val)
 {
 struct debug_bindings *bindings =
-(struct debug_bindings *) XOPAQUE (debug_prin1_bindings)->data;
+(struct debug_bindings *) GET_VOID_FROM_LISP (val);
 inhibit_non_essential_conversion_operations =
 bindings->inhibit_non_essential_conversion_operations;
 print_depth = bindings->print_depth;
 print_readably = bindings->print_readably;
 print_unbuffered = bindings->print_unbuffered;
 Vprint_level = bindings->Vprint_level;
 Vinhibit_quit = bindings->Vinhibit_quit;
 return Qnil;
 }
-/* Print an object, `prin1'-style, to various possible debugging outputs.
+/* Save values and bind them to new values suitable for debug output.  We
-Make sure it's completely unbuffered so that, in the event of a crash
+try very hard to avoid any Lisp allocation (i.e. consing) during the
-somewhere, we see as much as possible that happened before it.
+operation of debug printing, since we might be calling it from inside GC
-*/
+or other sensitive places.  This means we have to be a bit careful with
-static void
+record_unwind_protect to not create any temporary Lisp objects. */
-debug_prin1 (Lisp_Object debug_print_obj, int flags)
-{
+static int
-/* This function can GC */
+debug_print_enter (struct debug_bindings *bindings)
+{
 /* by doing this, we trick various things that are non-essential
 but might cause crashes into not getting executed. */
 int specdepth;
-struct debug_bindings *bindings =
-(struct debug_bindings *) XOPAQUE (debug_prin1_bindings)->data;
 bindings->inhibit_non_essential_conversion_operations =
 inhibit_non_essential_conversion_operations;
 bindings->print_depth = print_depth;
 bindings->print_readably = print_readably;
 bindings->in_debug_print = in_debug_print;
 bindings->gc_currently_forbidden = gc_currently_forbidden;
 bindings->Vprint_length = Vprint_length;
 bindings->Vprint_level = Vprint_level;
 bindings->Vinhibit_quit = Vinhibit_quit;
-specdepth = record_unwind_protect (debug_prin1_exit, Qnil);
+specdepth = record_unwind_protect (debug_print_exit,
+				     STORE_VOID_IN_LISP (bindings));
 inhibit_non_essential_conversion_operations = 1;
 print_depth = 0;
 print_readably = debug_print_readably != -1 ? debug_print_readably : 0;
 print_unbuffered++;
 Vprint_length = make_int (debug_print_length);
 if (debug_print_level > 0)
 Vprint_level = make_int (debug_print_level);
 Vinhibit_quit = Qt;
+return specdepth;
+}
+/* Print an object, `prin1'-style, to various possible debugging outputs.
+Make sure it's completely unbuffered so that, in the event of a crash
+somewhere, we see as much as possible that happened before it.
+*/
+static void
+debug_prin1 (Lisp_Object debug_print_obj, int flags)
+{
+/* This function cannot GC, since GC is forbidden */
+struct debug_bindings bindings;
+int specdepth = debug_print_enter (&bindings);
 if ((flags & EXT_PRINT_STDOUT) || (flags & EXT_PRINT_STDERR))
 print_internal (debug_print_obj, Qexternal_debugging_output, 1);
 if (flags & EXT_PRINT_ALTERNATE)
 print_internal (debug_print_obj, Qalternate_debugging_output, 1);
 #ifdef WIN32_NATIVE
 }
 void
 debug_p4 (Lisp_Object obj)
 {
-inhibit_non_essential_conversion_operations = 1;
 if (STRINGP (obj))
 debug_out ("\"%s\"", XSTRING_DATA (obj));
 else if (CONSP (obj))
 {
 int first = 1;
 		   (EMACS_INT) (LHEADER_IMPLEMENTATION (header)->basic_p ?
 				((struct lrecord_header *) header)->uid :
 				((struct old_lcrecord_header *) header)->uid));
 #endif /* not NEW_GC */
 }
+}
-inhibit_non_essential_conversion_operations = 0;
-}
+static int
-static void
 ext_print_begin (int dest)
 {
+int depth = begin_inhibit_non_essential_conversion_operations ();
 if (dest & EXT_PRINT_ALTERNATE)
 alternate_do_pointer = 0;
 if (dest & (EXT_PRINT_STDERR | EXT_PRINT_STDOUT))
 stdout_clear_before_next_output = 1;
+return depth;
 }
 static void
-ext_print_end (int dest)
+ext_print_end (int dest, int depth)
 {
 if (dest & (EXT_PRINT_MSWINDOWS | EXT_PRINT_STDERR | EXT_PRINT_STDOUT))
 external_out (dest & (EXT_PRINT_MSWINDOWS | EXT_PRINT_STDERR |
 			  EXT_PRINT_STDOUT), "\n");
+unbind_to (depth);
 }
 static void
 external_debug_print (Lisp_Object object, int dest)
 {
-ext_print_begin (dest);
+int depth = ext_print_begin (dest);
 debug_prin1 (object, dest);
-ext_print_end (dest);
+ext_print_end (dest, depth);
 }
 void
 debug_p3 (Lisp_Object obj)
 {
 debug_p4 (obj);
-inhibit_non_essential_conversion_operations = 1;
 debug_out ("\n");
-inhibit_non_essential_conversion_operations = 0;
 }
 void
 debug_print (Lisp_Object debug_print_obj)
 {
 /* Debugging kludge -- unbuffered */
 /* This function provided for the benefit of the debugger.  */
 void
 debug_backtrace (void)
 {
-/* This function can GC */
+/* This function cannot GC, since GC is forbidden */
+struct debug_bindings bindings;
-/* by doing this, we trick various things that are non-essential
+int specdepth = debug_print_enter (&bindings);
-but might cause crashes into not getting executed. */
-int specdepth =
-internal_bind_int (&inhibit_non_essential_conversion_operations, 1);
-internal_bind_int (&print_depth, 0);
-internal_bind_int (&print_readably, 0);
-internal_bind_int (&print_unbuffered, print_unbuffered + 1);
-if (debug_print_length > 0)
-internal_bind_lisp_object (&Vprint_length, make_int (debug_print_length));
-if (debug_print_level > 0)
-internal_bind_lisp_object (&Vprint_level, make_int (debug_print_level));
-/* #### Do we need this?  It was in the old code. */
-internal_bind_lisp_object (&Vinhibit_quit, Vinhibit_quit);
 Fbacktrace (Qexternal_debugging_output, Qt);
 stderr_out ("\n");
 unbind_to (specdepth);
 void
 debug_short_backtrace (int length)
 {
 int first = 1;
 struct backtrace *bt = backtrace_list;
 debug_out ("   [");
 while (length > 0 && bt)
 {
 if (!first)
 	{
 Label for minibuffer messages created with `print'.  This should
 generally be bound with `let' rather than set.  (See `display-message'.)
 */ );
 Vprint_message_label = Qprint;
-debug_prin1_bindings =
+/* The exact size doesn't matter since we realloc when necessary.
-make_opaque (OPAQUE_UNINIT, sizeof (struct debug_bindings));
+Use CIbyte instead of Ibyte so that debuggers show the associated
-staticpro (&debug_prin1_bindings);
+string automatically. */
 alternate_do_size = 5000;
-alternate_do_string = xnew_array(char, 5000);
+alternate_do_string = xnew_array (CIbyte, 5000);
 }

Mercurial > hg > xemacs-beta

comparison src/print.c @ 5027:22179cd0fe15