Mercurial > hg > xemacs-beta

comparison src/print.c @ 1957:59e1bbea04fe

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
[xemacs-hg @ 2004-03-19 02:59:08 by james] Break infinite loop that made debug-allocation unusable.
author james
date Fri, 19 Mar 2004 02:59:10 +0000
parents 01c57eb70ae9
children cc5b615380f8
comparison
equal deleted inserted replaced
1956:2aa9359b1615 1957:59e1bbea04fe
117 FILE *termscript; /* Stdio stream being used for copy of all output. */ 117 FILE *termscript; /* Stdio stream being used for copy of all output. */
118 118
119 static void write_string_to_alternate_debugging_output (const Ibyte *str, 119 static void write_string_to_alternate_debugging_output (const Ibyte *str,
120 Bytecount len); 120 Bytecount len);
121 121
122 /* To avoid consing in debug_prin1, we package up variables we need to bind
123 into an opaque object. */
124 struct debug_bindings
125 {
126 int inhibit_non_essential_printing_operations;
127 int print_depth;
128 int print_readably;
129 int print_unbuffered;
130 int gc_currently_forbidden;
131 Lisp_Object Vprint_length;
132 Lisp_Object Vprint_level;
133 Lisp_Object Vinhibit_quit;
134 };
135
136 static Lisp_Object debug_prin1_bindings;
122 137
123 138
124 int stdout_needs_newline; 139 int stdout_needs_newline;
125 int stdout_clear_before_next_output; 140 int stdout_clear_before_next_output;
126 141
410 if (len < 65536) 425 if (len < 65536)
411 { 426 {
412 Ibyte *copied = alloca_array (Ibyte, len); 427 Ibyte *copied = alloca_array (Ibyte, len);
413 memcpy (copied, newnonreloc + offset, len); 428 memcpy (copied, newnonreloc + offset, len);
414 Lstream_write (XLSTREAM (function), copied, len); 429 Lstream_write (XLSTREAM (function), copied, len);
430 }
431 else if (gc_currently_forbidden)
432 {
433 /* Avoid calling begin_gc_forbidden, which conses. We can reach
434 this point from the cons debug code, which will get us into
435 an infinite loop if we cons again. */
436 Lstream_write (XLSTREAM (function), newnonreloc + offset, len);
415 } 437 }
416 else 438 else
417 { 439 {
418 int speccount = begin_gc_forbidden (); 440 int speccount = begin_gc_forbidden ();
419 Lstream_write (XLSTREAM (function), newnonreloc + offset, len); 441 Lstream_write (XLSTREAM (function), newnonreloc + offset, len);
1533 return; 1555 return;
1534 } 1556 }
1535 } 1557 }
1536 1558
1537 being_printed[print_depth] = obj; 1559 being_printed[print_depth] = obj;
1538 specdepth = internal_bind_int (&print_depth, print_depth + 1); 1560
1539 1561 /* Avoid calling internal_bind_int, which conses, when called from
1540 if (print_depth > PRINT_CIRCLE) 1562 debug_prin1. In that case, we have bound print_depth to 0 anyway. */
1541 signal_error (Qstack_overflow, "Apparently circular structure being printed", Qunbound); 1563 if (!inhibit_non_essential_printing_operations)
1564 {
1565 specdepth = internal_bind_int (&print_depth, print_depth + 1);
1566
1567 if (print_depth > PRINT_CIRCLE)
1568 signal_error (Qstack_overflow, "Apparently circular structure being printed", Qunbound);
1569 }
1542 1570
1543 switch (XTYPE (obj)) 1571 switch (XTYPE (obj))
1544 { 1572 {
1545 case Lisp_Type_Int_Even: 1573 case Lisp_Type_Int_Even:
1546 case Lisp_Type_Int_Odd: 1574 case Lisp_Type_Int_Odd:
1710 LISP_TO_VOID (obj), BADNESS_INTEGER_OBJECT); 1738 LISP_TO_VOID (obj), BADNESS_INTEGER_OBJECT);
1711 break; 1739 break;
1712 } 1740 }
1713 } 1741 }
1714 1742
1715 unbind_to (specdepth); 1743 if (!inhibit_non_essential_printing_operations)
1744 unbind_to (specdepth);
1716 UNGCPRO; 1745 UNGCPRO;
1717 } 1746 }
1718 1747
1719 void 1748 void
1720 print_float (Lisp_Object obj, Lisp_Object printcharfun, int escapeflag) 1749 print_float (Lisp_Object obj, Lisp_Object printcharfun, int escapeflag)
1855 1884
1856 /* Useful on systems or in places where writing to stdout is unavailable or 1885 /* Useful on systems or in places where writing to stdout is unavailable or
1857 not working. */ 1886 not working. */
1858 1887
1859 static int alternate_do_pointer; 1888 static int alternate_do_pointer;
1860 static char alternate_do_string[5000]; 1889 static int alternate_do_size;
1890 static char *alternate_do_string;
1861 1891
1862 DEFUN ("alternate-debugging-output", Falternate_debugging_output, 1, 1, 0, /* 1892 DEFUN ("alternate-debugging-output", Falternate_debugging_output, 1, 1, 0, /*
1863 Append CHARACTER to the array `alternate_do_string'. 1893 Append CHARACTER to the array `alternate_do_string'.
1864 This can be used in place of `external-debugging-output' as a function 1894 This can be used in place of `external-debugging-output' as a function
1865 to be passed to `print'. Before calling `print', set `alternate_do_pointer' 1895 to be passed to `print'. Before calling `print', set `alternate_do_pointer'
1890 else 1920 else
1891 #endif /* 0 */ 1921 #endif /* 0 */
1892 { 1922 {
1893 extlen = len; 1923 extlen = len;
1894 extptr = (Extbyte *) str; 1924 extptr = (Extbyte *) str;
1925 }
1926
1927 /* If not yet initialized, just skip it. */
1928 if (alternate_do_string == NULL)
1929 return;
1930
1931 if (alternate_do_pointer + extlen >= alternate_do_size)
1932 {
1933 alternate_do_size =
1934 max(alternate_do_size * 2, alternate_do_pointer + extlen + 1);
1935 XREALLOC_ARRAY (alternate_do_string, char, alternate_do_size);
1895 } 1936 }
1896 memcpy (alternate_do_string + alternate_do_pointer, extptr, extlen); 1937 memcpy (alternate_do_string + alternate_do_pointer, extptr, extlen);
1897 alternate_do_pointer += extlen; 1938 alternate_do_pointer += extlen;
1898 alternate_do_string[alternate_do_pointer] = 0; 1939 alternate_do_string[alternate_do_pointer] = 0;
1899 } 1940 }
2010 2051
2011 static int debug_print_length = 50; 2052 static int debug_print_length = 50;
2012 static int debug_print_level = 15; 2053 static int debug_print_level = 15;
2013 static int debug_print_readably = -1; 2054 static int debug_print_readably = -1;
2014 2055
2056 /* Restore values temporarily bound by debug_prin1. We use this approach to
2057 avoid consing in debug_prin1. That is verboten, since debug_prin1 can be
2058 called by cons debugging code. */
2059 static Lisp_Object
2060 debug_prin1_exit (Lisp_Object ignored UNUSED_ARG)
2061 {
2062 struct debug_bindings *bindings =
2063 (struct debug_bindings *) XOPAQUE (debug_prin1_bindings)->data;
2064 inhibit_non_essential_printing_operations =
2065 bindings->inhibit_non_essential_printing_operations;
2066 print_depth = bindings->print_depth;
2067 print_readably = bindings->print_readably;
2068 print_unbuffered = bindings->print_unbuffered;
2069 gc_currently_forbidden = bindings->gc_currently_forbidden;
2070 Vprint_length = bindings->Vprint_length;
2071 Vprint_level = bindings->Vprint_level;
2072 Vinhibit_quit = bindings->Vinhibit_quit;
2073 return Qnil;
2074 }
2075
2015 /* Print an object, `prin1'-style, to various possible debugging outputs. 2076 /* Print an object, `prin1'-style, to various possible debugging outputs.
2016 Make sure it's completely unbuffered so that, in the event of a crash 2077 Make sure it's completely unbuffered so that, in the event of a crash
2017 somewhere, we see as much as possible that happened before it. 2078 somewhere, we see as much as possible that happened before it.
2018
2019
2020 */ 2079 */
2021 static void 2080 static void
2022 debug_prin1 (Lisp_Object debug_print_obj, int flags) 2081 debug_prin1 (Lisp_Object debug_print_obj, int flags)
2023 { 2082 {
2024 /* This function can GC */ 2083 /* This function can GC */
2025 2084
2026 /* by doing this, we trick various things that are non-essential 2085 /* by doing this, we trick various things that are non-essential
2027 but might cause crashes into not getting executed. */ 2086 but might cause crashes into not getting executed. */
2028 int specdepth = 2087 int specdepth;
2029 internal_bind_int (&inhibit_non_essential_printing_operations, 1); 2088 struct debug_bindings *bindings =
2030 2089 (struct debug_bindings *) XOPAQUE (debug_prin1_bindings)->data;
2031 internal_bind_int (&print_depth, 0); 2090
2032 internal_bind_int (&print_readably, 2091 bindings->inhibit_non_essential_printing_operations =
2033 debug_print_readably != -1 ? debug_print_readably : 0); 2092 inhibit_non_essential_printing_operations;
2034 internal_bind_int (&print_unbuffered, print_unbuffered + 1); 2093 bindings->print_depth = print_depth;
2094 bindings->print_readably = print_readably;
2095 bindings->print_unbuffered = print_unbuffered;
2096 bindings->gc_currently_forbidden = gc_currently_forbidden;
2097 bindings->Vprint_length = Vprint_length;
2098 bindings->Vprint_level = Vprint_level;
2099 bindings->Vinhibit_quit = Vinhibit_quit;
2100 specdepth = record_unwind_protect (debug_prin1_exit, Qnil);
2101
2102 inhibit_non_essential_printing_operations = 1;
2103 print_depth = 0;
2104 print_readably = debug_print_readably != -1 ? debug_print_readably : 0;
2105 print_unbuffered++;
2035 if (debug_print_length > 0) 2106 if (debug_print_length > 0)
2036 internal_bind_lisp_object (&Vprint_length, make_int (debug_print_length)); 2107 Vprint_length = make_int (debug_print_length);
2037 if (debug_print_level > 0) 2108 if (debug_print_level > 0)
2038 internal_bind_lisp_object (&Vprint_level, make_int (debug_print_level)); 2109 Vprint_level = make_int (debug_print_level);
2039 /* #### Do we need this? It was in the old code. */ 2110 Vinhibit_quit = Qt;
2040 internal_bind_lisp_object (&Vinhibit_quit, Vinhibit_quit);
2041 2111
2042 if ((flags & EXT_PRINT_STDOUT) || (flags & EXT_PRINT_STDERR)) 2112 if ((flags & EXT_PRINT_STDOUT) || (flags & EXT_PRINT_STDERR))
2043 print_internal (debug_print_obj, Qexternal_debugging_output, 1); 2113 print_internal (debug_print_obj, Qexternal_debugging_output, 1);
2044 if (flags & EXT_PRINT_ALTERNATE) 2114 if (flags & EXT_PRINT_ALTERNATE)
2045 print_internal (debug_print_obj, Qalternate_debugging_output, 1); 2115 print_internal (debug_print_obj, Qalternate_debugging_output, 1);
2404 DEFVAR_LISP ("print-message-label", &Vprint_message_label /* 2474 DEFVAR_LISP ("print-message-label", &Vprint_message_label /*
2405 Label for minibuffer messages created with `print'. This should 2475 Label for minibuffer messages created with `print'. This should
2406 generally be bound with `let' rather than set. (See `display-message'.) 2476 generally be bound with `let' rather than set. (See `display-message'.)
2407 */ ); 2477 */ );
2408 Vprint_message_label = Qprint; 2478 Vprint_message_label = Qprint;
2409 } 2479
2480 debug_prin1_bindings =
2481 make_opaque (OPAQUE_UNINIT, sizeof (struct debug_bindings));
2482 staticpro (&debug_prin1_bindings);
2483
2484 alternate_do_size = 5000;
2485 alternate_do_string = xnew_array(char, 5000);
2486 }