update.
[chise/xemacs-chise.git.1] / src / print.c
index 98d4a84..3adf779 100644 (file)
@@ -1,6 +1,6 @@
 /* Lisp object printing and output streams.
    Copyright (C) 1985, 1986, 1988, 1992-1995 Free Software Foundation, Inc.
 /* Lisp object printing and output streams.
    Copyright (C) 1985, 1986, 1988, 1992-1995 Free Software Foundation, Inc.
-   Copyright (C) 1995, 1996 Ben Wing.
+   Copyright (C) 1995, 1996, 2000, 2002 Ben Wing.
 
 This file is part of XEmacs.
 
 
 This file is part of XEmacs.
 
@@ -38,8 +38,10 @@ Boston, MA 02111-1307, USA.  */
 #include "insdel.h"
 #include "lstream.h"
 #include "sysfile.h"
 #include "insdel.h"
 #include "lstream.h"
 #include "sysfile.h"
+#ifdef WIN32_NATIVE
+#include "console-msw.h"
+#endif
 
 
-#include <limits.h>
 #include <float.h>
 /* Define if not in float.h */
 #ifndef DBL_DIG
 #include <float.h>
 /* Define if not in float.h */
 #ifndef DBL_DIG
@@ -50,15 +52,18 @@ Lisp_Object Vstandard_output, Qstandard_output;
 
 /* The subroutine object for external-debugging-output is kept here
    for the convenience of the debugger.  */
 
 /* 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;
+Lisp_Object Qexternal_debugging_output, Qalternate_debugging_output;
+
+#ifdef HAVE_MS_WINDOWS
+Lisp_Object Qmswindows_debugging_output;
+#endif
 
 /* Avoid actual stack overflow in print.  */
 static int print_depth;
 
 /* Detect most circularities to print finite output.  */
 #define PRINT_CIRCLE 200
 
 /* Avoid actual stack overflow in print.  */
 static int print_depth;
 
 /* Detect most circularities to print finite output.  */
 #define PRINT_CIRCLE 200
-Lisp_Object being_printed[PRINT_CIRCLE];
+static Lisp_Object being_printed[PRINT_CIRCLE];
 
 /* Maximum length of list or vector to print in full; noninteger means
    effectively infinity */
 
 /* Maximum length of list or vector to print in full; noninteger means
    effectively infinity */
@@ -92,9 +97,6 @@ int print_readably;
 Lisp_Object Vprint_gensym;
 Lisp_Object Vprint_gensym_alist;
 
 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;
 
 Lisp_Object Qdisplay_error;
 Lisp_Object Qprint_message_label;
 
@@ -107,38 +109,45 @@ FILE *termscript; /* Stdio stream being used for copy of all output.  */
 
 int stdout_needs_newline;
 
 
 int stdout_needs_newline;
 
-/* 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,
-                             enum external_data_format fmt)
+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)
 {
 {
-  int extlen;
-  CONST Extbyte *extptr;
-
-  GET_CHARPTR_EXT_DATA_ALLOCA (str + offset, len, fmt, extptr, extlen);
   if (stream)
     {
   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);
+#ifdef WIN32_NATIVE
+      HANDLE errhand = GetStdHandle (STD_INPUT_HANDLE);
+      int no_useful_stderr = errhand == 0 || errhand == INVALID_HANDLE_VALUE;
+
+      if (!no_useful_stderr)
+       no_useful_stderr = !PeekNamedPipe (errhand, 0, 0, 0, 0, 0);
+      /* we typically have no useful stdout/stderr under windows if we're
+        being invoked graphically. */
+      if (no_useful_stderr)
+       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
 #endif
+         if (must_flush)
+           fflush (stream);
+       }
     }
   else
     }
   else
-    {
-      assert (CONSOLE_TTY_P (con));
-      Lstream_write (XLSTREAM (CONSOLE_TTY_DATA (con)->outstream),
-                    extptr, extlen);
-    }
-  if (stream == stdout || stream == stderr ||
-      (!stream && CONSOLE_TTY_DATA (con)->is_stdio))
+    Lstream_write (XLSTREAM (lstream), extptr, extlen);
+
+  if (output_is_std_handle)
     {
       if (termscript)
        {
     {
       if (termscript)
        {
@@ -149,12 +158,139 @@ write_string_to_stdio_stream (FILE *stream, struct console *con,
     }
 }
 
     }
 }
 
+/* #### 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 && !inhibit_non_essential_printing_operations)
+    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);
+
+    if (initialized && !inhibit_non_essential_printing_operations)
+    TO_EXTERNAL_FORMAT (DATA, (puta, len),
+                       ALLOCA, (extptr, extlen),
+                       coding_system);
+    else
+      {
+       extptr = (Extbyte *) puta;
+       extlen = (Bytecount) len;
+      }
+  }
+
+  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
 /* 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 */
               Lisp_Object reloc, Bytecount offset, Bytecount len)
 {
   /* This function can GC */
@@ -164,7 +300,7 @@ output_string (Lisp_Object function, CONST Bufbyte *nonreloc,
      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. */
      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 */
   struct gcpro gcpro1, gcpro2;
 
   /* Emacs won't print while GCing, but an external debugger might */
@@ -240,7 +376,7 @@ output_string (Lisp_Object function, CONST Bufbyte *nonreloc,
   else if (EQ (function, Qt) || EQ (function, Qnil))
     {
       write_string_to_stdio_stream (stdout, 0, newnonreloc, offset, len,
   else if (EQ (function, Qt) || EQ (function, Qnil))
     {
       write_string_to_stdio_stream (stdout, 0, newnonreloc, offset, len,
-                                   FORMAT_TERMINAL);
+                                   Qterminal, print_unbuffered);
     }
   else
     {
     }
   else
     {
@@ -349,7 +485,7 @@ print_finish (Lisp_Object stream, Lisp_Object frame_kludge)
 \f
 /* Used for printing a single-byte character (*not* any Emchar).  */
 #define write_char_internal(string_of_length_1, stream)                        \
 \f
 /* 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
                 Qnil, 0, 1)
 
 /* NOTE: Do not call this with the data of a Lisp_String, as
@@ -362,7 +498,7 @@ print_finish (Lisp_Object stream, Lisp_Object frame_kludge)
    canonicalize_printcharfun() (i.e. Qnil means stdout, not
    Vstandard_output, etc.)  */
 void
    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
 {
   /* This function can GC */
 #ifdef ERROR_CHECK_BUFPOS
@@ -372,27 +508,39 @@ write_string_1 (CONST Bufbyte *str, Bytecount size, Lisp_Object stream)
 }
 
 void
 }
 
 void
-write_c_string (CONST char *str, Lisp_Object stream)
+write_c_string (const char *str, Lisp_Object stream)
 {
   /* This function can GC */
 {
   /* This function can GC */
-  write_string_1 ((CONST Bufbyte *) str, strlen (str), stream);
+  write_string_1 ((const Bufbyte *) str, strlen (str), stream);
+}
+
+static void
+write_fmt_string (Lisp_Object stream, const char *fmt, ...)
+{
+  va_list va;
+  char bigbuf[666];
+
+  va_start (va, fmt);
+  vsprintf (bigbuf, fmt, va);
+  va_end (va);
+  write_c_string (bigbuf, stream);
 }
 
 \f
 DEFUN ("write-char", Fwrite_char, 1, 2, 0, /*
 }
 
 \f
 DEFUN ("write-char", Fwrite_char, 1, 2, 0, /*
-Output character CH to stream STREAM.
+Output character CHARACTER to stream STREAM.
 STREAM defaults to the value of `standard-output' (which see).
 */
 STREAM defaults to the value of `standard-output' (which see).
 */
-       (ch, stream))
+       (character, stream))
 {
   /* This function can GC */
   Bufbyte str[MAX_EMCHAR_LEN];
   Bytecount len;
 
 {
   /* This function can GC */
   Bufbyte str[MAX_EMCHAR_LEN];
   Bytecount len;
 
-  CHECK_CHAR_COERCE_INT (ch);
-  len = set_charptr_emchar (str, XCHAR (ch));
+  CHECK_CHAR_COERCE_INT (character);
+  len = set_charptr_emchar (str, XCHAR (character));
   output_string (canonicalize_printcharfun (stream), str, Qnil, 0, len);
   output_string (canonicalize_printcharfun (stream), str, Qnil, 0, len);
-  return ch;
+  return character;
 }
 
 void
 }
 
 void
@@ -544,7 +692,7 @@ DEFUN ("princ", Fprinc, 1, 2, 0, /*
 Output the printed representation of OBJECT, any Lisp object.
 No quoting characters are used; no delimiters are printed around
 the contents of strings.
 Output the printed representation of OBJECT, any Lisp object.
 No quoting characters are used; no delimiters are printed around
 the contents of strings.
-Output stream is STREAM, or value of standard-output (which see).
+Output stream is STREAM, or value of `standard-output' (which see).
 */
        (object, stream))
 {
 */
        (object, stream))
 {
@@ -631,8 +779,13 @@ print_error_message (Lisp_Object error_object, Lisp_Object stream)
   {
     int first = 1;
     int speccount = specpdl_depth ();
   {
     int first = 1;
     int speccount = specpdl_depth ();
+    Lisp_Object frame = Qnil;
+    struct gcpro gcpro1;
+    GCPRO1 (stream);
 
     specbind (Qprint_message_label, Qerror);
 
     specbind (Qprint_message_label, Qerror);
+    stream = print_prepare (stream, &frame);
+
     tail = Fcdr (error_object);
     if (EQ (type, Qerror))
       {
     tail = Fcdr (error_object);
     if (EQ (type, Qerror))
       {
@@ -654,6 +807,8 @@ print_error_message (Lisp_Object error_object, Lisp_Object stream)
        tail = Fcdr (tail);
        first = 0;
       }
        tail = Fcdr (tail);
        first = 0;
       }
+    print_finish (stream, frame);
+    UNGCPRO;
     unbind_to (speccount, Qnil);
     return;
     /* not reached */
     unbind_to (speccount, Qnil);
     return;
     /* not reached */
@@ -711,11 +866,10 @@ Display ERROR-OBJECT on STREAM in a user-friendly way.
 #ifdef LISP_FLOAT_TYPE
 
 Lisp_Object Vfloat_output_format;
 #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
 
 /*
  * This buffer should be at least as large as the max string size of the
- * largest float, printed in the biggest notation.  This is undoubtably
+ * largest float, printed in the biggest notation.  This is undoubtedly
  * 20d float_output_format, with the negative of the C-constant "HUGE"
  * from <math.h>.
  *
  * 20d float_output_format, with the negative of the C-constant "HUGE"
  * from <math.h>.
  *
@@ -800,47 +954,62 @@ float_to_string (char *buf, double data)
 }
 #endif /* LISP_FLOAT_TYPE */
 
 }
 #endif /* LISP_FLOAT_TYPE */
 
-/* Print NUMBER to BUFFER.  The digits are first written in reverse
-   order (the least significant digit first), and are then reversed.
-   This is equivalent to sprintf(buffer, "%ld", number), only much
-   faster.
+/* Print NUMBER to BUFFER.
+   This is equivalent to sprintf (buffer, "%ld", number), only much faster.
 
    BUFFER should accept 24 bytes.  This should suffice for the longest
 
    BUFFER should accept 24 bytes.  This should suffice for the longest
-   numbers on 64-bit machines.  */
-void
+   numbers on 64-bit machines, including the `-' sign and the trailing
+   '\0'.  Returns a pointer to the trailing '\0'. */
+char *
 long_to_string (char *buffer, long number)
 {
 long_to_string (char *buffer, long number)
 {
-  char *p;
-  int i, len;
+#if (SIZEOF_LONG != 4) && (SIZEOF_LONG != 8)
+  /* Huh? */
+  sprintf (buffer, "%ld", number);
+  return buffer + strlen (buffer);
+#else /* (SIZEOF_LONG == 4) || (SIZEOF_LONG == 8) */
+  char *p = buffer;
+  int force = 0;
 
   if (number < 0)
     {
 
   if (number < 0)
     {
-      *buffer++ = '-';
+      *p++ = '-';
       number = -number;
     }
       number = -number;
     }
-  p = buffer;
 
 
-  /* Print the digits to the string.  */
-  do
-    {
-      *p++ = number % 10 + '0';
-      number /= 10;
-    }
-  while (number);
-
-  /* And reverse them.  */
-  len = p - buffer - 1;
-  for (i = len / 2; i >= 0; i--)
-    {
-      char c = buffer[i];
-      buffer[i] = buffer[len - i];
-      buffer[len - i] = c;
-    }
-  buffer[len + 1] = '\0';
+#define FROB(figure) do {                                                  \
+    if (force || number >= figure)                                         \
+      *p++ = (char) (number / figure + '0'), number %= figure, force = 1;   \
+    } while (0)
+#if SIZEOF_LONG == 8
+  FROB (1000000000000000000L);
+  FROB (100000000000000000L);
+  FROB (10000000000000000L);
+  FROB (1000000000000000L);
+  FROB (100000000000000L);
+  FROB (10000000000000L);
+  FROB (1000000000000L);
+  FROB (100000000000L);
+  FROB (10000000000L);
+#endif /* SIZEOF_LONG == 8 */
+  FROB (1000000000);
+  FROB (100000000);
+  FROB (10000000);
+  FROB (1000000);
+  FROB (100000);
+  FROB (10000);
+  FROB (1000);
+  FROB (100);
+  FROB (10);
+#undef FROB
+  *p++ = (char) (number + '0');
+  *p = '\0';
+  return p;
+#endif /* (SIZEOF_LONG == 4) || (SIZEOF_LONG == 8) */
 }
 \f
 static void
 }
 \f
 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)
 {
                        Lisp_Object obj,
                        Lisp_Object printcharfun, int escapeflag)
 {
@@ -947,7 +1116,7 @@ print_vector (Lisp_Object obj, Lisp_Object printcharfun, int escapeflag)
 void
 print_string (Lisp_Object obj, Lisp_Object printcharfun, int escapeflag)
 {
 void
 print_string (Lisp_Object obj, Lisp_Object printcharfun, int escapeflag)
 {
-  struct Lisp_String *s = XSTRING (obj);
+  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);
   /* We distinguish between Bytecounts and Charcounts, to make
      Vprint_string_length work correctly under Mule.  */
   Charcount size = string_char_length (s);
@@ -1047,6 +1216,52 @@ internal_object_printer (Lisp_Object obj, Lisp_Object printcharfun,
   write_c_string (buf, printcharfun);
 }
 
   write_c_string (buf, printcharfun);
 }
 
+enum printing_badness
+{
+  BADNESS_INTEGER_OBJECT,
+  BADNESS_POINTER_OBJECT,
+  BADNESS_NO_TYPE
+};
+
+static void
+printing_major_badness (Lisp_Object printcharfun,
+                       Char_ASCII *badness_string, int type, void *val,
+                       enum printing_badness badness)
+{
+  char buf[666];
+
+  switch (badness)
+    {
+    case BADNESS_INTEGER_OBJECT:
+      sprintf (buf, "%s %d object %ld", badness_string, type,
+                 (EMACS_INT) val);
+      break;
+
+    case BADNESS_POINTER_OBJECT:
+      sprintf (buf, "%s %d object %p", badness_string, type, val);
+      break;
+
+    case BADNESS_NO_TYPE:
+      sprintf (buf, "%s object %p", badness_string, val);
+      break;
+    }
+
+  /* Don't ABORT or signal if called from debug_print() or already
+     crashing */
+  if (!inhibit_non_essential_printing_operations)
+    {
+#ifdef ERROR_CHECK_TYPES
+      ABORT ();
+#else  /* not ERROR_CHECK_TYPES */
+      if (print_readably)
+       type_error (Qinternal_error, "printing %s", buf);
+#endif /* not ERROR_CHECK_TYPES */
+    }
+  write_fmt_string (printcharfun,
+                   "#<EMACS BUG: %s Save your buffers immediately and "
+                   "please report this bug>", buf);
+}
+
 void
 print_internal (Lisp_Object obj, Lisp_Object printcharfun, int escapeflag)
 {
 void
 print_internal (Lisp_Object obj, Lisp_Object printcharfun, int escapeflag)
 {
@@ -1096,7 +1311,9 @@ print_internal (Lisp_Object obj, Lisp_Object printcharfun, int escapeflag)
     case Lisp_Type_Int_Even:
     case Lisp_Type_Int_Odd:
       {
     case Lisp_Type_Int_Even:
     case Lisp_Type_Int_Odd:
       {
-       char buf[24];
+       /* ASCII Decimal representation uses 2.4 times as many bits as
+          machine binary.  */
+       char buf[3 * sizeof (EMACS_INT) + 5];
        long_to_string (buf, XINT (obj));
        write_c_string (buf, printcharfun);
        break;
        long_to_string (buf, XINT (obj));
        write_c_string (buf, printcharfun);
        break;
@@ -1109,85 +1326,162 @@ print_internal (Lisp_Object obj, Lisp_Object printcharfun, int escapeflag)
        Emchar ch = XCHAR (obj);
        char *p = buf;
        *p++ = '?';
        Emchar ch = XCHAR (obj);
        char *p = buf;
        *p++ = '?';
-       if (ch == '\n')
-         *p++ = '\\', *p++ = 'n';
-       else if (ch == '\r')
-         *p++ = '\\', *p++ = 'r';
-       else if (ch == '\t')
-         *p++ = '\\', *p++ = 't';
-       else if (ch < 32)
+       if (ch < 32)
          {
          {
-           *p++ = '\\', *p++ = '^';
-           *p++ = ch + 64;
-           if ((ch + 64) == '\\')
-             *p++ = '\\';
+           *p++ = '\\';
+           switch (ch)
+             {
+             case '\t': *p++ = 't'; break;
+             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)
          }
        else if (ch == 127)
-         *p++ = '\\', *p++ = '^', *p++ = '?';
-       else if (ch >= 128 && ch < 160)
+         {
+           *p++ = '\\', *p++ = '^', *p++ = '?';
+         }
+       else if (ch < 160)
          {
            *p++ = '\\', *p++ = '^';
          {
            *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
        else
-         p += set_charptr_emchar ((Bufbyte *)p, ch);
-       output_string (printcharfun, (Bufbyte *)buf, Qnil, 0, p - buf);
+         {
+           p += set_charptr_emchar ((Bufbyte *) p, ch);
+         }
+
+       output_string (printcharfun, (Bufbyte *) buf, Qnil, 0, p - buf);
+
        break;
       }
 
     case Lisp_Type_Record:
       {
        struct lrecord_header *lheader = XRECORD_LHEADER (obj);
        break;
       }
 
     case Lisp_Type_Record:
       {
        struct lrecord_header *lheader = XRECORD_LHEADER (obj);
-       struct gcpro gcpro1, gcpro2;
 
 
-       if (CONSP (obj) || VECTORP(obj))
+       /* Try to check for various sorts of bogus pointers if we're in a
+          situation where it may be likely -- i.e. called from
+          debug_print() or we're already crashing.  In such cases,
+          (further) crashing is counterproductive. */
+
+       if (inhibit_non_essential_printing_operations &&
+           !debug_can_access_memory (lheader, sizeof (*lheader)))
+           {
+             write_fmt_string (printcharfun,
+                               "#<EMACS BUG: BAD MEMORY ACCESS %p>",
+                               lheader);
+             break;
+           }
+
+       if (CONSP (obj) || VECTORP (obj))
          {
            /* If deeper than spec'd depth, print placeholder.  */
            if (INTP (Vprint_level)
                && print_depth > XINT (Vprint_level))
              {
          {
            /* If deeper than spec'd depth, print placeholder.  */
            if (INTP (Vprint_level)
                && print_depth > XINT (Vprint_level))
              {
-               GCPRO2 (obj, printcharfun);
                write_c_string ("...", printcharfun);
                write_c_string ("...", printcharfun);
-               UNGCPRO;
                break;
              }
          }
 
                break;
              }
          }
 
-       GCPRO2 (obj, printcharfun);
+       if (lheader->type == lrecord_type_free)
+         {
+           printing_major_badness (printcharfun, "freed lrecord", 0,
+                                   lheader, BADNESS_NO_TYPE);
+           break;
+         }
+       else if (lheader->type == lrecord_type_undefined)
+         {
+           printing_major_badness (printcharfun, "lrecord_type_undefined", 0,
+                                   lheader, BADNESS_NO_TYPE);
+           break;
+         }
+       else if (lheader->type >= lrecord_type_count)
+         {
+           printing_major_badness (printcharfun, "illegal lrecord type",
+                                   (int) (lheader->type),
+                                   lheader, BADNESS_POINTER_OBJECT);
+           break;
+         }
+
+       /* Further checks for bad memory in critical situations.  We don't
+          normally do these because they may be expensive or weird
+          (e.g. under Unix we typically have to set a SIGSEGV handler and
+          try to trigger a seg fault). */
+
+       if (inhibit_non_essential_printing_operations)
+         {
+           const struct lrecord_implementation *imp =
+             LHEADER_IMPLEMENTATION (lheader);
+
+         if (!debug_can_access_memory
+               (lheader, imp->size_in_bytes_method ?
+                imp->size_in_bytes_method (lheader) :
+                imp->static_size))
+             {
+               write_fmt_string (printcharfun,
+                                 "#<EMACS BUG: type %s BAD MEMORY ACCESS %p>",
+                                 LHEADER_IMPLEMENTATION (lheader)->name,
+                                 lheader);
+               break;
+             }
+
+           if (STRINGP (obj))
+             {
+               Lisp_String *l = (Lisp_String *) lheader;
+               if (!debug_can_access_memory (l->data, l->size))
+                 {
+                   write_fmt_string
+                     (printcharfun,
+                      "#<EMACS BUG: %p (CAN'T ACCESS STRING DATA %p)>",
+                      lheader, l->data);
+                   break;
+                 }
+             }
+         }
+
        if (LHEADER_IMPLEMENTATION (lheader)->printer)
          ((LHEADER_IMPLEMENTATION (lheader)->printer)
           (obj, printcharfun, escapeflag));
        else
          default_object_printer (obj, printcharfun, escapeflag);
        if (LHEADER_IMPLEMENTATION (lheader)->printer)
          ((LHEADER_IMPLEMENTATION (lheader)->printer)
           (obj, printcharfun, escapeflag));
        else
          default_object_printer (obj, printcharfun, escapeflag);
-       UNGCPRO;
        break;
       }
 
     default:
       {
        break;
       }
 
     default:
       {
-#ifdef ERROR_CHECK_TYPECHECK
-       abort ();
-#else  /* not ERROR_CHECK_TYPECHECK */
-       char buf[128];
        /* We're in trouble if this happens! */
        /* We're in trouble if this happens! */
-       if (print_readably)
-         error ("printing illegal data type #o%03o",
-                (int) XTYPE (obj));
-       write_c_string ("#<EMACS BUG: ILLEGAL DATATYPE ",
-                       printcharfun);
-       sprintf (buf, "(#o%3o)", (int) XTYPE (obj));
-       write_c_string (buf, printcharfun);
-       write_c_string
-         (" Save your buffers immediately and please report this bug>",
-          printcharfun);
-#endif /* not ERROR_CHECK_TYPECHECK */
+       printing_major_badness (printcharfun, "illegal data type", XTYPE (obj),
+                               LISP_TO_VOID (obj), BADNESS_INTEGER_OBJECT);
        break;
       }
     }
        break;
       }
     }
@@ -1213,7 +1507,7 @@ 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) */
   /* This function can GC */
   /* #### Bug!! (intern "") isn't printed in some distinguished way */
   /* ####  (the reader also loses on it) */
-  struct Lisp_String *name = symbol_name (XSYMBOL (obj));
+  Lisp_String *name = symbol_name (XSYMBOL (obj));
   Bytecount size = string_length (name);
   struct gcpro gcpro1, gcpro2;
 
   Bytecount size = string_length (name);
   struct gcpro gcpro1, gcpro2;
 
@@ -1231,7 +1525,7 @@ print_symbol (Lisp_Object obj, Lisp_Object printcharfun, int escapeflag)
      the flag print-gensym is non-nil, prefix it with #n= to read the
      object back with the #n# reader syntax later if needed.  */
   if (!NILP (Vprint_gensym)
      the flag print-gensym is non-nil, prefix it with #n= to read the
      object back with the #n# reader syntax later if needed.  */
   if (!NILP (Vprint_gensym)
-      /* #### Test whether this produces a noticable slow-down for
+      /* #### Test whether this produces a noticeable slow-down for
          printing when print-gensym is non-nil.  */
       && !EQ (obj, oblookup (Vobarray,
                             string_data (symbol_name (XSYMBOL (obj))),
          printing when print-gensym is non-nil.  */
       && !EQ (obj, oblookup (Vobarray,
                             string_data (symbol_name (XSYMBOL (obj))),
@@ -1245,6 +1539,7 @@ print_symbol (Lisp_Object obj, Lisp_Object printcharfun, int escapeflag)
              write_char_internal ("#", printcharfun);
              print_internal (XCDR (tem), printcharfun, escapeflag);
              write_char_internal ("#", printcharfun);
              write_char_internal ("#", printcharfun);
              print_internal (XCDR (tem), printcharfun, escapeflag);
              write_char_internal ("#", printcharfun);
+             UNGCPRO;
              return;
            }
          else
              return;
            }
          else
@@ -1339,16 +1634,12 @@ print_symbol (Lisp_Object obj, Lisp_Object printcharfun, int escapeflag)
   UNGCPRO;
 }
 \f
   UNGCPRO;
 }
 \f
-/* #ifdef DEBUG_XEMACS */
 
 
-/* I don't like seeing `Note: Strange doc (not fboundp) for function
-   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 */
+/* Useful on systems or in places where writing to stdout is unavailable or
+   not working. */
 
 
-int alternate_do_pointer;
-char alternate_do_string[5000];
+static int alternate_do_pointer;
+static char alternate_do_string[5000];
 
 DEFUN ("alternate-debugging-output", Falternate_debugging_output, 1, 1, 0, /*
 Append CHARACTER to the array `alternate_do_string'.
 
 DEFUN ("alternate-debugging-output", Falternate_debugging_output, 1, 1, 0, /*
 Append CHARACTER to the array `alternate_do_string'.
@@ -1361,17 +1652,18 @@ to 0.
   Bufbyte str[MAX_EMCHAR_LEN];
   Bytecount len;
   int extlen;
   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));
 
   CHECK_CHAR_COERCE_INT (character);
   len = set_charptr_emchar (str, XCHAR (character));
-  GET_CHARPTR_EXT_DATA_ALLOCA (str, len, FORMAT_TERMINAL, extptr, extlen);
+  TO_EXTERNAL_FORMAT (DATA, (str, len),
+                     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;
 }
   memcpy (alternate_do_string + alternate_do_pointer, extptr, extlen);
   alternate_do_pointer += extlen;
   alternate_do_string[alternate_do_pointer] = 0;
   return character;
 }
-/* #endif / * DEBUG_XEMACS */
 
 DEFUN ("external-debugging-output", Fexternal_debugging_output, 1, 3, 0, /*
 Write CHAR-OR-STRING to stderr or stdout.
 
 DEFUN ("external-debugging-output", Fexternal_debugging_output, 1, 3, 0, /*
 Write CHAR-OR-STRING to stderr or stdout.
@@ -1379,6 +1671,10 @@ 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.
 
 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.
 */
 If you have opened a termscript file (using `open-termscript'), then
 the output also will be logged to this file.
 */
@@ -1413,7 +1709,7 @@ the output also will be logged to this file.
     write_string_to_stdio_stream (file, con,
                                  XSTRING_DATA (char_or_string),
                                  0, XSTRING_LENGTH (char_or_string),
     write_string_to_stdio_stream (file, con,
                                  XSTRING_DATA (char_or_string),
                                  0, XSTRING_LENGTH (char_or_string),
-                                 FORMAT_TERMINAL);
+                                 Qterminal, 1);
   else
     {
       Bufbyte str[MAX_EMCHAR_LEN];
   else
     {
       Bufbyte str[MAX_EMCHAR_LEN];
@@ -1421,68 +1717,80 @@ the output also will be logged to this file.
 
       CHECK_CHAR_COERCE_INT (char_or_string);
       len = set_charptr_emchar (str, XCHAR (char_or_string));
 
       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, FORMAT_TERMINAL);
+      write_string_to_stdio_stream (file, con, str, 0, len, Qterminal, 1);
     }
 
   return char_or_string;
 }
 
 DEFUN ("open-termscript", Fopen_termscript, 1, 1, "FOpen termscript file: ", /*
     }
 
   return char_or_string;
 }
 
 DEFUN ("open-termscript", Fopen_termscript, 1, 1, "FOpen termscript file: ", /*
-Start writing all terminal output to FILE as well as the terminal.
-FILE = nil means just close any termscript file currently open.
+Start writing all terminal output to FILENAME as well as the terminal.
+FILENAME = nil means just close any termscript file currently open.
 */
 */
-       (file))
+       (filename))
 {
   /* This function can GC */
   if (termscript != 0)
 {
   /* This function can GC */
   if (termscript != 0)
-    fclose (termscript);
-  termscript = 0;
+    {
+      fclose (termscript);
+      termscript = 0;
+    }
 
 
-  if (! NILP (file))
+  if (! NILP (filename))
     {
     {
-      file = Fexpand_file_name (file, Qnil);
-      termscript = fopen ((char *) XSTRING_DATA (file), "w");
+      filename = Fexpand_file_name (filename, Qnil);
+      termscript = fopen ((char *) XSTRING_DATA (filename), "w");
       if (termscript == NULL)
       if (termscript == NULL)
-       report_file_error ("Opening termscript", list1 (file));
+       report_file_error ("Opening termscript", list1 (filename));
     }
   return Qnil;
 }
 
 #if 1
 /* Debugging kludge -- unbuffered */
     }
   return Qnil;
 }
 
 #if 1
 /* Debugging kludge -- unbuffered */
-static int debug_print_length = 50;
-static int debug_print_level = 15;
-Lisp_Object debug_temp;
+static int debug_print_length   = 50;
+static int debug_print_level    = 15;
+static int debug_print_readably = -1;
 
 static void
 debug_print_no_newline (Lisp_Object debug_print_obj)
 {
   /* This function can GC */
 
 static void
 debug_print_no_newline (Lisp_Object debug_print_obj)
 {
   /* 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;
+  int save_print_readably = print_readably;
+  int save_print_depth    = print_depth;
+  Lisp_Object save_Vprint_length = Vprint_length;
+  Lisp_Object save_Vprint_level  = Vprint_level;
+  Lisp_Object save_Vinhibit_quit = Vinhibit_quit;
   struct gcpro gcpro1, gcpro2, gcpro3;
   struct gcpro gcpro1, gcpro2, gcpro3;
-  GCPRO3 (old_print_level, old_print_length, old_inhibit_quit);
+  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;
 
   if (gc_in_progress)
     stderr_out ("** gc-in-progress!  Bad idea to print anything! **\n");
 
   print_depth = 0;
-  print_readably = 0;
+  print_readably = debug_print_readably != -1 ? debug_print_readably : 0;
   print_unbuffered++;
   print_unbuffered++;
+  inhibit_non_essential_printing_operations = 1;
   /* 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);
   /* 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);
   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;
+  alternate_do_pointer = 0;
+  print_internal (debug_print_obj, Qalternate_debugging_output, 1);
+#ifdef WIN32_NATIVE
+  /* Write out to the debugger, as well */
+  print_internal (debug_print_obj, Qmswindows_debugging_output, 1);
+#endif
+
+  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;
+  inhibit_non_essential_printing_operations = 0;
   print_unbuffered--;
   UNGCPRO;
 }
   print_unbuffered--;
   UNGCPRO;
 }
@@ -1492,7 +1800,6 @@ debug_print (Lisp_Object debug_print_obj)
 {
   debug_print_no_newline (debug_print_obj);
   stderr_out ("\n");
 {
   debug_print_no_newline (debug_print_obj);
   stderr_out ("\n");
-  fflush (stderr);
 }
 
 /* Debugging kludge -- unbuffered */
 }
 
 /* Debugging kludge -- unbuffered */
@@ -1517,6 +1824,7 @@ debug_backtrace (void)
   print_depth = 0;
   print_readably = 0;
   print_unbuffered++;
   print_depth = 0;
   print_readably = 0;
   print_unbuffered++;
+  inhibit_non_essential_printing_operations = 1;
   /* Could use unwind-protect, but why bother? */
   if (debug_print_length > 0)
     Vprint_length = make_int (debug_print_length);
   /* Could use unwind-protect, but why bother? */
   if (debug_print_length > 0)
     Vprint_length = make_int (debug_print_length);
@@ -1525,13 +1833,13 @@ debug_backtrace (void)
 
   Fbacktrace (Qexternal_debugging_output, Qt);
   stderr_out ("\n");
 
   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;
   print_readably = old_print_readably;
 
   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;
+  inhibit_non_essential_printing_operations = 0;
   print_unbuffered--;
 
   UNGCPRO;
   print_unbuffered--;
 
   UNGCPRO;
@@ -1543,13 +1851,11 @@ debug_short_backtrace (int length)
   int first = 1;
   struct backtrace *bt = backtrace_list;
   stderr_out ("   [");
   int first = 1;
   struct backtrace *bt = backtrace_list;
   stderr_out ("   [");
-  fflush (stderr);
   while (length > 0 && bt)
     {
       if (!first)
        {
          stderr_out (", ");
   while (length > 0 && bt)
     {
       if (!first)
        {
          stderr_out (", ");
-         fflush (stderr);
        }
       if (COMPILED_FUNCTIONP (*bt->function))
        {
        }
       if (COMPILED_FUNCTIONP (*bt->function))
        {
@@ -1562,15 +1868,12 @@ debug_short_backtrace (int length)
          if (!NILP (ann))
            {
              stderr_out ("<compiled-function from ");
          if (!NILP (ann))
            {
              stderr_out ("<compiled-function from ");
-             fflush (stderr);
              debug_print_no_newline (ann);
              stderr_out (">");
              debug_print_no_newline (ann);
              stderr_out (">");
-             fflush (stderr);
            }
          else
            {
              stderr_out ("<compiled-function of unknown origin>");
            }
          else
            {
              stderr_out ("<compiled-function of unknown origin>");
-             fflush (stderr);
            }
        }
       else
            }
        }
       else
@@ -1580,7 +1883,6 @@ debug_short_backtrace (int length)
       bt = bt->next;
     }
   stderr_out ("]\n");
       bt = bt->next;
     }
   stderr_out ("]\n");
-  fflush (stderr);
 }
 
 #endif /* debugging kludge */
 }
 
 #endif /* debugging kludge */
@@ -1589,15 +1891,8 @@ debug_short_backtrace (int length)
 void
 syms_of_print (void)
 {
 void
 syms_of_print (void)
 {
-  defsymbol (&Qprint_escape_newlines, "print-escape-newlines");
-  defsymbol (&Qprint_readably, "print-readably");
-
   defsymbol (&Qstandard_output, "standard-output");
 
   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");
   defsymbol (&Qprint_length, "print-length");
 
   defsymbol (&Qprint_string_length, "print-string-length");
@@ -1614,17 +1909,26 @@ syms_of_print (void)
   DEFSUBR (Fterpri);
   DEFSUBR (Fwrite_char);
   DEFSUBR (Falternate_debugging_output);
   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 (Fexternal_debugging_output);
   DEFSUBR (Fopen_termscript);
   defsymbol (&Qexternal_debugging_output, "external-debugging-output");
+  defsymbol (&Qalternate_debugging_output, "alternate-debugging-output");
+#ifdef HAVE_MS_WINDOWS
+  defsymbol (&Qmswindows_debugging_output, "mswindows-debugging-output");
+#endif
   DEFSUBR (Fwith_output_to_temp_buffer);
 }
 
 void
   DEFSUBR (Fwith_output_to_temp_buffer);
 }
 
 void
-vars_of_print (void)
+reinit_vars_of_print (void)
 {
   alternate_do_pointer = 0;
 {
   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.
 
   DEFVAR_LISP ("standard-output", &Vstandard_output /*
 Output stream `print' uses by default for outputting a character.