xemacs-beta: src/print.c comparison

comparison src/print.c @ 412:697ef44129c6 r21-2-14

Import from CVS: tag r21-2-14

author	cvs
date	Mon, 13 Aug 2007 11:20:41 +0200
parents	de805c49cfc1
children	da8ed4261e83

comparison

equal deleted inserted replaced

-:12e008d41344
+:697ef44129c6
 /* Lisp object printing and output streams.
 Copyright (C) 1985, 1986, 1988, 1992-1995 Free Software Foundation, Inc.
-Copyright (C) 1995, 1996, 2000 Ben Wing.
+Copyright (C) 1995, 1996 Ben Wing.
 This file is part of XEmacs.
 XEmacs is free software; you can redistribute it and/or modify it
 under the terms of the GNU General Public License as published by the
 #include "extents.h"
 #include "frame.h"
 #include "insdel.h"
 #include "lstream.h"
 #include "sysfile.h"
-#ifdef WIN32_NATIVE
-#include "console-msw.h"
+#include <limits.h>
-#endif
 #include <float.h>
 /* Define if not in float.h */
 #ifndef DBL_DIG
 #define DBL_DIG 16
 #endif
 Lisp_Object Vstandard_output, Qstandard_output;
 /* The subroutine object for external-debugging-output is kept here
 for the convenience of the debugger.  */
 Lisp_Object Qexternal_debugging_output;
+Lisp_Object Qalternate_debugging_output;
 /* Avoid actual stack overflow in print.  */
 static int print_depth;
 /* Detect most circularities to print finite output.  */
 #define PRINT_CIRCLE 200
-static Lisp_Object being_printed[PRINT_CIRCLE];
+Lisp_Object being_printed[PRINT_CIRCLE];
 /* Maximum length of list or vector to print in full; noninteger means
 effectively infinity */
 Lisp_Object Vprint_length;
 Neither t nor nil means so that and don't clear Vprint_gensym_alist
 on entry to and exit from print functions.  */
 Lisp_Object Vprint_gensym;
 Lisp_Object Vprint_gensym_alist;
+Lisp_Object Qprint_escape_newlines;
+Lisp_Object Qprint_readably;
 Lisp_Object Qdisplay_error;
 Lisp_Object Qprint_message_label;
 /* Force immediate output of all printed data.  Used for debugging. */
 int print_unbuffered;
 int stdout_needs_newline;
-#ifdef WIN32_NATIVE
+/* Write a string (in internal format) to stdio stream STREAM. */
-static int no_useful_stderr;
+void
+write_string_to_stdio_stream (FILE *stream, struct console *con,
+			      CONST Bufbyte *str,
+			      Bytecount offset, Bytecount len,
+			      enum external_data_format fmt)
+{
+int extlen;
+CONST Extbyte *extptr;
+GET_CHARPTR_EXT_DATA_ALLOCA (str + offset, len, fmt, extptr, extlen);
+if (stream)
+{
+fwrite (extptr, 1, extlen, stream);
+#ifdef WINDOWSNT
+/* Q122442 says that pipes are "treated as files, not as
+	 devices", and that this is a feature. Before I found that
+	 article, I thought it was a bug. Thanks MS, I feel much
+	 better now. - kkm */
+if (stream == stdout || stream == stderr)
+	fflush (stream);
 #endif
-static void
-std_handle_out_external (FILE *stream, Lisp_Object lstream,
-			 const Extbyte *extptr, Extcount extlen,
-			 /* is this really stdout/stderr?
-			    (controls termscript writing) */
-			 int output_is_std_handle,
-			 int must_flush)
-{
-if (stream)
-{
-#ifdef WIN32_NATIVE
-if (!no_useful_stderr)
-	no_useful_stderr = GetStdHandle (STD_ERROR_HANDLE) == 0 ? 1 : -1;
-/* we typically have no useful stdout/stderr under windows if we're
-	 being invoked graphically. */
-if (!noninteractive || no_useful_stderr > 0)
-	mswindows_output_console_string (extptr, extlen);
-else
-#endif
-	{
-	  fwrite (extptr, 1, extlen, stream);
-#ifdef WIN32_NATIVE
-	  /* Q122442 says that pipes are "treated as files, not as
-	     devices", and that this is a feature. Before I found that
-	     article, I thought it was a bug. Thanks MS, I feel much
-	     better now. - kkm */
-	  must_flush = 1;
-#endif
-	  if (must_flush)
-	    fflush (stream);
-	}
 }
 else
-Lstream_write (XLSTREAM (lstream), extptr, extlen);
+{
+assert (CONSOLE_TTY_P (con));
-if (output_is_std_handle)
+Lstream_write (XLSTREAM (CONSOLE_TTY_DATA (con)->outstream),
+		     extptr, extlen);
+}
+if (stream == stdout || stream == stderr ||
+(!stream && CONSOLE_TTY_DATA (con)->is_stdio))
 {
 if (termscript)
 	{
 	  fwrite (extptr, 1, extlen, termscript);
 	  fflush (termscript);
 	}
 stdout_needs_newline = (extptr[extlen - 1] != '\n');
 }
 }
-/* #### The following function should be replaced a call to the
-emacs_doprnt_*() functions.  This is the only way to ensure that
-I18N3 works properly (many implementations of the *printf()
-functions, including the ones included in glibc, do not implement
-the %###$ argument-positioning syntax).
-Note, however, that to do this, we'd have to
-1) pre-allocate all the lstreams and do whatever else was necessary
-to make sure that no allocation occurs, since these functions may be
-called from fatal_error_signal().
-2) (to be really correct) make a new lstream that outputs using
-mswindows_output_console_string().  */
-static int
-std_handle_out_va (FILE *stream, const char *fmt, va_list args)
-{
-Bufbyte kludge[8192];
-Extbyte *extptr;
-Extcount extlen;
-int retval;
-retval = vsprintf ((char *) kludge, fmt, args);
-if (initialized && !fatal_error_in_progress)
-TO_EXTERNAL_FORMAT (DATA, (kludge, strlen ((char *) kludge)),
-			ALLOCA, (extptr, extlen),
-			Qnative);
-else
-{
-extptr = (Extbyte *) kludge;
-extlen = (Extcount) strlen ((char *) kludge);
-}
-std_handle_out_external (stream, Qnil, extptr, extlen, 1, 1);
-return retval;
-}
-/* Output portably to stderr or its equivalent; call GETTEXT on the
-format string.  Automatically flush when done. */
-int
-stderr_out (const char *fmt, ...)
-{
-int retval;
-va_list args;
-va_start (args, fmt);
-retval =
-std_handle_out_va
-(stderr, initialized && !fatal_error_in_progress ? GETTEXT (fmt) : fmt,
-args);
-va_end (args);
-return retval;
-}
-/* Output portably to stdout or its equivalent; call GETTEXT on the
-format string.  Automatically flush when done. */
-int
-stdout_out (const char *fmt, ...)
-{
-int retval;
-va_list args;
-va_start (args, fmt);
-retval =
-std_handle_out_va
-(stdout, initialized && !fatal_error_in_progress ? GETTEXT (fmt) : fmt,
-args);
-va_end (args);
-return retval;
-}
-DOESNT_RETURN
-fatal (const char *fmt, ...)
-{
-va_list args;
-va_start (args, fmt);
-stderr_out ("\nXEmacs: ");
-std_handle_out_va (stderr, GETTEXT (fmt), args);
-stderr_out ("\n");
-va_end (args);
-exit (1);
-}
-/* Write a string (in internal format) to stdio stream STREAM. */
-void
-write_string_to_stdio_stream (FILE *stream, struct console *con,
-			      const Bufbyte *str,
-			      Bytecount offset, Bytecount len,
-			      Lisp_Object coding_system,
-			      int must_flush)
-{
-Extcount extlen;
-const Extbyte *extptr;
-/* #### yuck! sometimes this function is called with string data,
-and the following call may gc. */
-{
-Bufbyte *puta = (Bufbyte *) alloca (len);
-memcpy (puta, str + offset, len);
-TO_EXTERNAL_FORMAT (DATA, (puta, len),
-			ALLOCA, (extptr, extlen),
-			coding_system);
-}
-if (stream)
-std_handle_out_external (stream, Qnil, extptr, extlen,
-			     stream == stdout || stream == stderr, must_flush);
-else
-{
-assert (CONSOLE_TTY_P (con));
-std_handle_out_external (0, CONSOLE_TTY_DATA (con)->outstream,
-			       extptr, extlen,
-			       CONSOLE_TTY_DATA (con)->is_stdio, must_flush);
-}
-}
 /* Write a string to the output location specified in FUNCTION.
 Arguments NONRELOC, RELOC, OFFSET, and LEN are as in
 buffer_insert_string_1() in insdel.c. */
 static void
-output_string (Lisp_Object function, const Bufbyte *nonreloc,
+output_string (Lisp_Object function, CONST Bufbyte *nonreloc,
 	       Lisp_Object reloc, Bytecount offset, Bytecount len)
 {
 /* This function can GC */
 Charcount cclen;
 /* We change the value of nonreloc (fetching it from reloc as
 necessary), but we don't want to pass this changed value on to
 other functions that take both a nonreloc and a reloc, or things
 may get confused and an assertion failure in
 fixup_internal_substring() may get triggered. */
-const Bufbyte *newnonreloc = nonreloc;
+CONST Bufbyte *newnonreloc = nonreloc;
 struct gcpro gcpro1, gcpro2;
 /* Emacs won't print while GCing, but an external debugger might */
 if (gc_in_progress) return;
 echo_area_append (f, nonreloc, reloc, offset, len, Vprint_message_label);
 }
 else if (EQ (function, Qt) || EQ (function, Qnil))
 {
 write_string_to_stdio_stream (stdout, 0, newnonreloc, offset, len,
-				    Qterminal, print_unbuffered);
+				    FORMAT_TERMINAL);
 }
 else
 {
 Charcount ccoff = bytecount_to_charcount (newnonreloc, offset);
 Charcount iii;
 }
 }
 /* Used for printing a single-byte character (*not* any Emchar).  */
 #define write_char_internal(string_of_length_1, stream)			\
-output_string (stream, (const Bufbyte *) (string_of_length_1),	\
+output_string (stream, (CONST Bufbyte *) (string_of_length_1),	\
 		 Qnil, 0, 1)
 /* NOTE: Do not call this with the data of a Lisp_String, as
 printcharfun might cause a GC, which might cause the string's data
 to be relocated.  To princ a Lisp string, use:
 Also note that STREAM should be the result of
 canonicalize_printcharfun() (i.e. Qnil means stdout, not
 Vstandard_output, etc.)  */
 void
-write_string_1 (const Bufbyte *str, Bytecount size, Lisp_Object stream)
+write_string_1 (CONST Bufbyte *str, Bytecount size, Lisp_Object stream)
 {
 /* This function can GC */
 #ifdef ERROR_CHECK_BUFPOS
 assert (size >= 0);
 #endif
 output_string (stream, str, Qnil, 0, size);
 }
 void
-write_c_string (const char *str, Lisp_Object stream)
+write_c_string (CONST char *str, Lisp_Object stream)
 {
 /* This function can GC */
-write_string_1 ((const Bufbyte *) str, strlen (str), stream);
+write_string_1 ((CONST Bufbyte *) str, strlen (str), stream);
 }
 DEFUN ("write-char", Fwrite_char, 1, 2, 0, /*
 Output character CH to stream STREAM.
 }
 /* Default method */
 {
 int first = 1;
 int speccount = specpdl_depth ();
-Lisp_Object frame = Qnil;
-struct gcpro gcpro1;
-GCPRO1 (stream);
 specbind (Qprint_message_label, Qerror);
-stream = print_prepare (stream, &frame);
 tail = Fcdr (error_object);
 if (EQ (type, Qerror))
 {
 	print_internal (Fcar (tail), stream, 0);
 	tail = Fcdr (tail);
 	write_c_string (first ? ": " : ", ", stream);
 	print_internal (Fcar (tail), stream, 1);
 	tail = Fcdr (tail);
 	first = 0;
 }
-print_finish (stream, frame);
-UNGCPRO;
 unbind_to (speccount, Qnil);
 return;
 /* not reached */
 }
 #ifdef LISP_FLOAT_TYPE
 Lisp_Object Vfloat_output_format;
+Lisp_Object Qfloat_output_format;
 /*
 * This buffer should be at least as large as the max string size of the
-* largest float, printed in the biggest notation.  This is undoubtedly
+* largest float, printed in the biggest notation.  This is undoubtably
 * 20d float_output_format, with the negative of the C-constant "HUGE"
 * from <math.h>.
 *
 * On the vax the worst case is -1e38 in 20d format which takes 61 bytes.
 *
 buf [(buf [0] == '-' ? 1 : 0)] = '0';
 }
 }
 #endif /* LISP_FLOAT_TYPE */
-/* Print NUMBER to BUFFER.  This is equivalent to sprintf(buffer,
+/* Print NUMBER to BUFFER.  The digits are first written in reverse
-"%ld", number), only much faster.
+order (the least significant digit first), and are then reversed.
+This is equivalent to sprintf(buffer, "%ld", number), only much
+faster.
 BUFFER should accept 24 bytes.  This should suffice for the longest
-numbers on 64-bit machines, including the `-' sign and the trailing
+numbers on 64-bit machines.  */
-\0.  */
 void
 long_to_string (char *buffer, long number)
 {
-#if (SIZEOF_LONG != 4) && (SIZEOF_LONG != 8)
+char *p;
-/* Huh? */
+int i, len;
-sprintf (buffer, "%ld", number);
-#else /* (SIZEOF_LONG == 4) || (SIZEOF_LONG == 8) */
-char *p = buffer;
-int force = 0;
 if (number < 0)
 {
-*p++ = '-';
+*buffer++ = '-';
 number = -number;
 }
+p = buffer;
-#define FROB(figure) do {						\
-if (force || number >= figure)					\
+/* Print the digits to the string.  */
-*p++ = number / figure + '0', number %= figure, force = 1;	\
+do
-} while (0)
+{
-#if SIZEOF_LONG == 8
+*p++ = number % 10 + '0';
-FROB (1000000000000000000L);
+number /= 10;
-FROB (100000000000000000L);
+}
-FROB (10000000000000000L);
+while (number);
-FROB (1000000000000000L);
-FROB (100000000000000L);
+/* And reverse them.  */
-FROB (10000000000000L);
+len = p - buffer - 1;
-FROB (1000000000000L);
+for (i = len / 2; i >= 0; i--)
-FROB (100000000000L);
+{
-FROB (10000000000L);
+char c = buffer[i];
-#endif /* SIZEOF_LONG == 8 */
+buffer[i] = buffer[len - i];
-FROB (1000000000);
+buffer[len - i] = c;
-FROB (100000000);
+}
-FROB (10000000);
+buffer[len + 1] = '\0';
-FROB (1000000);
-FROB (100000);
-FROB (10000);
-FROB (1000);
-FROB (100);
-FROB (10);
-#undef FROB
-*p++ = number + '0';
-*p = '\0';
-#endif /* (SIZEOF_LONG == 4) || (SIZEOF_LONG == 8) */
 }
 static void
-print_vector_internal (const char *start, const char *end,
+print_vector_internal (CONST char *start, CONST char *end,
 Lisp_Object obj,
 Lisp_Object printcharfun, int escapeflag)
 {
 /* This function can GC */
 int i;
 }
 void
 print_string (Lisp_Object obj, Lisp_Object printcharfun, int escapeflag)
 {
-Lisp_String *s = XSTRING (obj);
+struct Lisp_String *s = XSTRING (obj);
 /* We distinguish between Bytecounts and Charcounts, to make
 Vprint_string_length work correctly under Mule.  */
 Charcount size = string_char_length (s);
 Charcount max = size;
 Bytecount bcmax = string_length (s);
 switch (XTYPE (obj))
 {
 case Lisp_Type_Int_Even:
 case Lisp_Type_Int_Odd:
 {
-	/* ASCII Decimal representation uses 2.4 times as many bits as
+	char buf[24];
-	   machine binary.  */
-	char buf[3 * sizeof (EMACS_INT) + 5];
 	long_to_string (buf, XINT (obj));
 	write_c_string (buf, printcharfun);
 	break;
 }
 	/* God intended that this be #\..., you know. */
 	char buf[16];
 	Emchar ch = XCHAR (obj);
 	char *p = buf;
 	*p++ = '?';
-	if (ch < 32)
+	if (ch == '\n')
+	  *p++ = '\\', *p++ = 'n';
+	else if (ch == '\r')
+	  *p++ = '\\', *p++ = 'r';
+	else if (ch == '\t')
+	  *p++ = '\\', *p++ = 't';
+	else if (ch < 32)
 	  {
-	    *p++ = '\\';
+	    *p++ = '\\', *p++ = '^';
-	    switch (ch)
+	    *p++ = ch + 64;
-	      {
+	    if ((ch + 64) == '\\')
-	      case '\t': *p++ = 't'; break;
+	      *p++ = '\\';
-	      case '\n': *p++ = 'n'; break;
-	      case '\r': *p++ = 'r'; break;
-	      default:
-		*p++ = '^';
-		*p++ = ch + 64;
-		if ((ch + 64) == '\\')
-		  *p++ = '\\';
-		break;
-	      }
-	  }
-	else if (ch < 127)
-	  {
-	    /* syntactically special characters should be escaped. */
-	    switch (ch)
-	      {
-	      case ' ':
-	      case '"':
-	      case '#':
-	      case '\'':
-	      case '(':
-	      case ')':
-	      case ',':
-	      case '.':
-	      case ';':
-	      case '?':
-	      case '[':
-	      case '\\':
-	      case ']':
-	      case '`':
-		*p++ = '\\';
-	      }
-	    *p++ = ch;
 	  }
 	else if (ch == 127)
-	  {
+	  *p++ = '\\', *p++ = '^', *p++ = '?';
-	    *p++ = '\\', *p++ = '^', *p++ = '?';
+	else if (ch >= 128 && ch < 160)
-	  }
-	else if (ch < 160)
 	  {
 	    *p++ = '\\', *p++ = '^';
-	    p += set_charptr_emchar ((Bufbyte *) p, ch + 64);
+	    p += set_charptr_emchar ((Bufbyte *)p, ch + 64);
 	  }
+	else if (ch < 127
+		 && !isdigit (ch)
+		 && !isalpha (ch)
+		 && ch != '^') /* must not backslash this or it will
+				  be interpreted as the start of a
+				  control char */
+	  *p++ = '\\', *p++ = ch;
 	else
-	  {
+	  p += set_charptr_emchar ((Bufbyte *)p, ch);
-	    p += set_charptr_emchar ((Bufbyte *) p, ch);
+	output_string (printcharfun, (Bufbyte *)buf, Qnil, 0, p - buf);
-	  }
-	output_string (printcharfun, (Bufbyte *) buf, Qnil, 0, p - buf);
 	break;
 }
 case Lisp_Type_Record:
 {
 print_symbol (Lisp_Object obj, Lisp_Object printcharfun, int escapeflag)
 {
 /* This function can GC */
 /* #### Bug!! (intern "") isn't printed in some distinguished way */
 /* ####  (the reader also loses on it) */
-Lisp_String *name = symbol_name (XSYMBOL (obj));
+struct Lisp_String *name = symbol_name (XSYMBOL (obj));
 Bytecount size = string_length (name);
 struct gcpro gcpro1, gcpro2;
 if (!escapeflag)
 {
 alternate-debugging-output @ 429542' -slb */
 /* #### Eek!  Any clue how to get rid of it?  In fact, how about
 getting rid of this function altogether?  Does anything actually
 *use* it?  --hniksic */
-static int alternate_do_pointer;
+int alternate_do_pointer;
-static char alternate_do_string[5000];
+char alternate_do_string[5000];
 DEFUN ("alternate-debugging-output", Falternate_debugging_output, 1, 1, 0, /*
 Append CHARACTER to the array `alternate_do_string'.
 This can be used in place of `external-debugging-output' as a function
 to be passed to `print'.  Before calling `print', set `alternate_do_pointer'
 (character))
 {
 Bufbyte str[MAX_EMCHAR_LEN];
 Bytecount len;
 int extlen;
-const Extbyte *extptr;
+CONST Extbyte *extptr;
 CHECK_CHAR_COERCE_INT (character);
 len = set_charptr_emchar (str, XCHAR (character));
-TO_EXTERNAL_FORMAT (DATA, (str, len),
+GET_CHARPTR_EXT_DATA_ALLOCA (str, len, FORMAT_TERMINAL, extptr, extlen);
-		      ALLOCA, (extptr, extlen),
-		      Qterminal);
 memcpy (alternate_do_string + alternate_do_pointer, extptr, extlen);
 alternate_do_pointer += extlen;
 alternate_do_string[alternate_do_pointer] = 0;
 return character;
 }
 DEFUN ("external-debugging-output", Fexternal_debugging_output, 1, 3, 0, /*
 Write CHAR-OR-STRING to stderr or stdout.
 If optional arg STDOUT-P is non-nil, write to stdout; otherwise, write
 to stderr.  You can use this function to write directly to the terminal.
 This function can be used as the STREAM argument of Fprint() or the like.
-Under MS Windows, this writes output to the console window (which is
-created, if necessary), unless XEmacs is being run noninteractively
-\(i.e. using the `-batch' argument).
 If you have opened a termscript file (using `open-termscript'), then
 the output also will be logged to this file.
 */
 (char_or_string, stdout_p, device))
 if (STRINGP (char_or_string))
 write_string_to_stdio_stream (file, con,
 				  XSTRING_DATA (char_or_string),
 				  0, XSTRING_LENGTH (char_or_string),
-				  Qterminal, 1);
+				  FORMAT_TERMINAL);
 else
 {
 Bufbyte str[MAX_EMCHAR_LEN];
 Bytecount len;
 CHECK_CHAR_COERCE_INT (char_or_string);
 len = set_charptr_emchar (str, XCHAR (char_or_string));
-write_string_to_stdio_stream (file, con, str, 0, len, Qterminal, 1);
+write_string_to_stdio_stream (file, con, str, 0, len, FORMAT_TERMINAL);
 }
 return char_or_string;
 }
 return Qnil;
 }
 #if 1
 /* Debugging kludge -- unbuffered */
-static int debug_print_length   = 50;
+static int debug_print_length = 50;
-static int debug_print_level    = 15;
+static int debug_print_level = 15;
-static int debug_print_readably = -1;
+Lisp_Object debug_temp;
 static void
 debug_print_no_newline (Lisp_Object debug_print_obj)
 {
 /* This function can GC */
-int save_print_readably = print_readably;
+int old_print_readably = print_readably;
-int save_print_depth    = print_depth;
+int old_print_depth = print_depth;
-Lisp_Object save_Vprint_length = Vprint_length;
+Lisp_Object old_print_length = Vprint_length;
-Lisp_Object save_Vprint_level  = Vprint_level;
+Lisp_Object old_print_level = Vprint_level;
-Lisp_Object save_Vinhibit_quit = Vinhibit_quit;
+Lisp_Object old_inhibit_quit = Vinhibit_quit;
-struct gcpro gcpro1, gcpro2, gcpro3;
-GCPRO3 (save_Vprint_level, save_Vprint_length, save_Vinhibit_quit);
-if (gc_in_progress)
-stderr_out ("** gc-in-progress!  Bad idea to print anything! **\n");
-print_depth = 0;
-print_readably = debug_print_readably != -1 ? debug_print_readably : 0;
-print_unbuffered++;
-/* Could use unwind-protect, but why bother? */
-if (debug_print_length > 0)
-Vprint_length = make_int (debug_print_length);
-if (debug_print_level > 0)
-Vprint_level = make_int (debug_print_level);
-print_internal (debug_print_obj, Qexternal_debugging_output, 1);
-Vinhibit_quit  = save_Vinhibit_quit;
-Vprint_level   = save_Vprint_level;
-Vprint_length  = save_Vprint_length;
-print_depth    = save_print_depth;
-print_readably = save_print_readably;
-print_unbuffered--;
-UNGCPRO;
-}
-void
-debug_print (Lisp_Object debug_print_obj)
-{
-debug_print_no_newline (debug_print_obj);
-stderr_out ("\n");
-}
-/* Debugging kludge -- unbuffered */
-/* This function provided for the benefit of the debugger.  */
-void debug_backtrace (void);
-void
-debug_backtrace (void)
-{
-/* This function can GC */
-int         old_print_readably = print_readably;
-int         old_print_depth    = print_depth;
-Lisp_Object old_print_length   = Vprint_length;
-Lisp_Object old_print_level    = Vprint_level;
-Lisp_Object old_inhibit_quit   = Vinhibit_quit;
 struct gcpro gcpro1, gcpro2, gcpro3;
 GCPRO3 (old_print_level, old_print_length, old_inhibit_quit);
 if (gc_in_progress)
 stderr_out ("** gc-in-progress!  Bad idea to print anything! **\n");
 /* Could use unwind-protect, but why bother? */
 if (debug_print_length > 0)
 Vprint_length = make_int (debug_print_length);
 if (debug_print_level > 0)
 Vprint_level = make_int (debug_print_level);
+print_internal (debug_print_obj, Qexternal_debugging_output, 1);
+Vinhibit_quit = old_inhibit_quit;
+Vprint_level = old_print_level;
+Vprint_length = old_print_length;
+print_depth = old_print_depth;
+print_readably = old_print_readably;
+print_unbuffered--;
+UNGCPRO;
+}
+void
+debug_print (Lisp_Object debug_print_obj)
+{
+debug_print_no_newline (debug_print_obj);
+stderr_out ("\n");
+fflush (stderr);
+}
+/* Debugging kludge -- unbuffered */
+/* This function provided for the benefit of the debugger.  */
+void debug_backtrace (void);
+void
+debug_backtrace (void)
+{
+/* This function can GC */
+int         old_print_readably = print_readably;
+int         old_print_depth    = print_depth;
+Lisp_Object old_print_length   = Vprint_length;
+Lisp_Object old_print_level    = Vprint_level;
+Lisp_Object old_inhibit_quit   = Vinhibit_quit;
+struct gcpro gcpro1, gcpro2, gcpro3;
+GCPRO3 (old_print_level, old_print_length, old_inhibit_quit);
+if (gc_in_progress)
+stderr_out ("** gc-in-progress!  Bad idea to print anything! **\n");
+print_depth = 0;
+print_readably = 0;
+print_unbuffered++;
+/* Could use unwind-protect, but why bother? */
+if (debug_print_length > 0)
+Vprint_length = make_int (debug_print_length);
+if (debug_print_level > 0)
+Vprint_level = make_int (debug_print_level);
 Fbacktrace (Qexternal_debugging_output, Qt);
 stderr_out ("\n");
+fflush (stderr);
 Vinhibit_quit  = old_inhibit_quit;
 Vprint_level   = old_print_level;
 Vprint_length  = old_print_length;
 print_depth    = old_print_depth;
 debug_short_backtrace (int length)
 {
 int first = 1;
 struct backtrace *bt = backtrace_list;
 stderr_out ("   [");
+fflush (stderr);
 while (length > 0 && bt)
 {
 if (!first)
 	{
 	  stderr_out (", ");
+	  fflush (stderr);
 	}
 if (COMPILED_FUNCTIONP (*bt->function))
 	{
 #if defined(COMPILED_FUNCTION_ANNOTATION_HACK)
 	  Lisp_Object ann =
 	  Lisp_Object ann = Qnil;
 #endif
 	  if (!NILP (ann))
 	    {
 	      stderr_out ("<compiled-function from ");
+	      fflush (stderr);
 	      debug_print_no_newline (ann);
 	      stderr_out (">");
+	      fflush (stderr);
 	    }
 	  else
 	    {
 	      stderr_out ("<compiled-function of unknown origin>");
+	      fflush (stderr);
 	    }
 	}
 else
 	debug_print_no_newline (*bt->function);
 first = 0;
 length--;
 bt = bt->next;
 }
 stderr_out ("]\n");
+fflush (stderr);
 }
 #endif /* debugging kludge */
 void
 syms_of_print (void)
 {
+defsymbol (&Qprint_escape_newlines, "print-escape-newlines");
+defsymbol (&Qprint_readably, "print-readably");
 defsymbol (&Qstandard_output, "standard-output");
+#ifdef LISP_FLOAT_TYPE
+defsymbol (&Qfloat_output_format, "float-output-format");
+#endif
 defsymbol (&Qprint_length, "print-length");
 defsymbol (&Qprint_string_length, "print-string-length");
 DEFSUBR (Ferror_message_string);
 DEFSUBR (Fdisplay_error);
 DEFSUBR (Fterpri);
 DEFSUBR (Fwrite_char);
 DEFSUBR (Falternate_debugging_output);
+defsymbol (&Qalternate_debugging_output, "alternate-debugging-output");
 DEFSUBR (Fexternal_debugging_output);
 DEFSUBR (Fopen_termscript);
 defsymbol (&Qexternal_debugging_output, "external-debugging-output");
 DEFSUBR (Fwith_output_to_temp_buffer);
 }
 void
-reinit_vars_of_print (void)
+vars_of_print (void)
 {
 alternate_do_pointer = 0;
-}
-void
-vars_of_print (void)
-{
-reinit_vars_of_print ();
 DEFVAR_LISP ("standard-output", &Vstandard_output /*
 Output stream `print' uses by default for outputting a character.
 This may be any function of one argument.
 It may also be a buffer (output is inserted before point)

Mercurial > hg > xemacs-beta

comparison src/print.c @ 412:697ef44129c6 r21-2-14