(CHAR_TO_CHARC): New inline function.
[chise/xemacs-chise.git-] / src / print.c
index 5b828ca..4d1664f 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 Ben Wing.
 
 This file is part of XEmacs.
 
 
 This file is part of XEmacs.
 
@@ -38,6 +38,9 @@ Boston, MA 02111-1307, USA.  */
 #include "insdel.h"
 #include "lstream.h"
 #include "sysfile.h"
 #include "insdel.h"
 #include "lstream.h"
 #include "sysfile.h"
+#ifdef WINDOWSNT
+#include "console-msw.h"
+#endif
 
 #include <limits.h>
 #include <float.h>
 
 #include <limits.h>
 #include <float.h>
@@ -103,38 +106,47 @@ 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. */
+#ifdef WINDOWSNT
+static int no_useful_stderr;
+#endif
 
 
-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
 #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);
+      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)
+       msw_output_console_string (extptr, extlen);
+      else
 #endif
 #endif
+       {
+         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 */
+         must_flush = 1;
+#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)
        {
@@ -145,12 +157,132 @@ 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
+   msw_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
 /* 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 */
@@ -160,7 +292,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 */
@@ -236,7 +368,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
     {
@@ -345,7 +477,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
@@ -358,7 +490,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
@@ -368,10 +500,10 @@ 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);
 }
 
 \f
 }
 
 \f
@@ -627,8 +759,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))
       {
@@ -650,6 +787,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 */
@@ -710,7 +849,7 @@ Lisp_Object Vfloat_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>.
  *
@@ -850,7 +989,7 @@ long_to_string (char *buffer, long number)
 }
 \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)
 {
@@ -957,7 +1096,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);
@@ -1173,7 +1312,7 @@ print_internal (Lisp_Object obj, Lisp_Object printcharfun, int escapeflag)
          {
            p += set_charptr_emchar ((Bufbyte *) p, ch);
          }
          {
            p += set_charptr_emchar ((Bufbyte *) p, ch);
          }
-         
+
        output_string (printcharfun, (Bufbyte *) buf, Qnil, 0, p - buf);
 
        break;
        output_string (printcharfun, (Bufbyte *) buf, Qnil, 0, p - buf);
 
        break;
@@ -1250,7 +1389,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;
 
@@ -1398,11 +1537,13 @@ 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;
   memcpy (alternate_do_string + alternate_do_pointer, extptr, extlen);
   alternate_do_pointer += extlen;
   alternate_do_string[alternate_do_pointer] = 0;
@@ -1416,6 +1557,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.
 */
@@ -1450,7 +1595,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];
@@ -1458,7 +1603,7 @@ 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;
     }
 
   return char_or_string;
@@ -1487,38 +1632,41 @@ FILE = nil means just close any termscript file currently open.
 
 #if 1
 /* Debugging kludge -- unbuffered */
 
 #if 1
 /* Debugging kludge -- unbuffered */
-static int debug_print_length = 50;
-static int debug_print_level = 15;
+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++;
   /* 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_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);
   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;
+
+  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;
 }
   print_unbuffered--;
   UNGCPRO;
 }
@@ -1528,7 +1676,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 */
@@ -1561,7 +1708,6 @@ 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;
 
   Vinhibit_quit  = old_inhibit_quit;
   Vprint_level   = old_print_level;
@@ -1579,13 +1725,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))
        {
@@ -1598,15 +1742,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
@@ -1616,7 +1757,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 */