print.c

/* Lisp object printing and output streams.

Copyright (C) 1985-1986, 1988, 1993-1995, 1997-2015 Free Software
Foundation, Inc.

This file is part of GNU Emacs.

GNU Emacs is free software: you can redistribute it and/or modify
it under the terms of the GNU General Public License as published by
the Free Software Foundation, either version 3 of the License, or
(at your option) any later version.

GNU Emacs is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
GNU General Public License for more details.

You should have received a copy of the GNU General Public License
along with GNU Emacs.  If not, see <http://www.gnu.org/licenses/>.  */


#include <config.h>
#include "sysstdio.h"

#include "lisp.h"
#include "character.h"
#include "buffer.h"
#include "charset.h"
#include "keyboard.h"
#include "frame.h"
#include "window.h"
#include "process.h"
#include "dispextern.h"
#include "termchar.h"
#include "intervals.h"
#include "blockinput.h"
#include "termhooks.h"		/* For struct terminal.  */
#include "font.h"

#include <float.h>
#include <ftoastr.h>

/* Avoid actual stack overflow in print.  */
static ptrdiff_t print_depth;

/* Level of nesting inside outputting backquote in new style.  */
static ptrdiff_t new_backquote_output;

/* Detect most circularities to print finite output.  */
#define PRINT_CIRCLE 200
static Lisp_Object being_printed[PRINT_CIRCLE];

/* Last char printed to stdout by printchar.  */
static unsigned int printchar_stdout_last;

/* When printing into a buffer, first we put the text in this
   block, then insert it all at once.  */
static char *print_buffer;

/* Size allocated in print_buffer.  */
static ptrdiff_t print_buffer_size;
/* Chars stored in print_buffer.  */
static ptrdiff_t print_buffer_pos;
/* Bytes stored in print_buffer.  */
static ptrdiff_t print_buffer_pos_byte;

/* Vprint_number_table is a table, that keeps objects that are going to
   be printed, to allow use of #n= and #n# to express sharing.
   For any given object, the table can give the following values:
     t    the object will be printed only once.
     -N   the object will be printed several times and will take number N.
     N    the object has been printed so we can refer to it as #N#.
   print_number_index holds the largest N already used.
   N has to be striclty larger than 0 since we need to distinguish -N.  */
static ptrdiff_t print_number_index;
static void print_interval (INTERVAL interval, Lisp_Object printcharfun);

/* GDB resets this to zero on W32 to disable OutputDebugString calls.  */
bool print_output_debug_flag EXTERNALLY_VISIBLE = 1;


/* Low level output routines for characters and strings.  */

/* Lisp functions to do output using a stream
   must have the stream in a variable called printcharfun
   and must start with PRINTPREPARE, end with PRINTFINISH,
   and use PRINTDECLARE to declare common variables.
   Use PRINTCHAR to output one character,
   or call strout to output a block of characters.  */

#define PRINTDECLARE							\
   struct buffer *old = current_buffer;					\
   ptrdiff_t old_point = -1, start_point = -1;				\
   ptrdiff_t old_point_byte = -1, start_point_byte = -1;		\
   ptrdiff_t specpdl_count = SPECPDL_INDEX ();				\
   bool free_print_buffer = 0;						\
   bool multibyte							\
     = !NILP (BVAR (current_buffer, enable_multibyte_characters));	\
   Lisp_Object original

#define PRINTPREPARE							\
   original = printcharfun;						\
   if (NILP (printcharfun)) printcharfun = Qt;				\
   if (BUFFERP (printcharfun))						\
     {									\
       if (XBUFFER (printcharfun) != current_buffer)			\
	 Fset_buffer (printcharfun);					\
       printcharfun = Qnil;						\
     }									\
   if (MARKERP (printcharfun))						\
     {									\
       ptrdiff_t marker_pos;						\
       if (! XMARKER (printcharfun)->buffer)				\
         error ("Marker does not point anywhere");			\
       if (XMARKER (printcharfun)->buffer != current_buffer)		\
         set_buffer_internal (XMARKER (printcharfun)->buffer);		\
       marker_pos = marker_position (printcharfun);			\
       if (marker_pos < BEGV || marker_pos > ZV)			\
	 signal_error ("Marker is outside the accessible "		\
		       "part of the buffer", printcharfun);		\
       old_point = PT;							\
       old_point_byte = PT_BYTE;					\
       SET_PT_BOTH (marker_pos,						\
		    marker_byte_position (printcharfun));		\
       start_point = PT;						\
       start_point_byte = PT_BYTE;					\
       printcharfun = Qnil;						\
     }									\
   if (NILP (printcharfun))						\
     {									\
       Lisp_Object string;						\
       if (NILP (BVAR (current_buffer, enable_multibyte_characters))	\
	   && ! print_escape_multibyte)					\
         specbind (Qprint_escape_multibyte, Qt);			\
       if (! NILP (BVAR (current_buffer, enable_multibyte_characters))	\
	   && ! print_escape_nonascii)					\
         specbind (Qprint_escape_nonascii, Qt);				\
       if (print_buffer != 0)						\
	 {								\
	   string = make_string_from_bytes (print_buffer,		\
					    print_buffer_pos,		\
					    print_buffer_pos_byte);	\
	   record_unwind_protect (print_unwind, string);		\
	 }								\
       else								\
	 {								\
	   int new_size = 1000;						\
	   print_buffer = xmalloc (new_size);				\
	   print_buffer_size = new_size;				\
	   free_print_buffer = 1;					\
	 }								\
       print_buffer_pos = 0;						\
       print_buffer_pos_byte = 0;					\
     }									\
   if (EQ (printcharfun, Qt) && ! noninteractive)			\
     setup_echo_area_for_printing (multibyte);

#define PRINTFINISH							\
   if (NILP (printcharfun))						\
     {									\
       if (print_buffer_pos != print_buffer_pos_byte			\
	   && NILP (BVAR (current_buffer, enable_multibyte_characters)))\
	 {								\
	   USE_SAFE_ALLOCA;						\
	   unsigned char *temp = SAFE_ALLOCA (print_buffer_pos + 1);	\
	   copy_text ((unsigned char *) print_buffer, temp,		\
		      print_buffer_pos_byte, 1, 0);			\
	   insert_1_both ((char *) temp, print_buffer_pos,		\
			  print_buffer_pos, 0, 1, 0);			\
	   SAFE_FREE ();						\
	 }								\
       else								\
	 insert_1_both (print_buffer, print_buffer_pos,			\
			print_buffer_pos_byte, 0, 1, 0);		\
       signal_after_change (PT - print_buffer_pos, 0, print_buffer_pos);\
     }									\
   if (free_print_buffer)						\
     {									\
       xfree (print_buffer);						\
       print_buffer = 0;						\
     }									\
   unbind_to (specpdl_count, Qnil);					\
   if (MARKERP (original))						\
     set_marker_both (original, Qnil, PT, PT_BYTE);			\
   if (old_point >= 0)							\
     SET_PT_BOTH (old_point + (old_point >= start_point			\
			       ? PT - start_point : 0),			\
		  old_point_byte + (old_point_byte >= start_point_byte	\
				    ? PT_BYTE - start_point_byte : 0));	\
   set_buffer_internal (old);

#define PRINTCHAR(ch) printchar (ch, printcharfun)

/* This is used to restore the saved contents of print_buffer
   when there is a recursive call to print.  */

static void
print_unwind (Lisp_Object saved_text)
{
  memcpy (print_buffer, SDATA (saved_text), SCHARS (saved_text));
}


/* Print character CH using method FUN.  FUN nil means print to
   print_buffer.  FUN t means print to echo area or stdout if
   non-interactive.  If FUN is neither nil nor t, call FUN with CH as
   argument.  */

static void
printchar (unsigned int ch, Lisp_Object fun)
{
  if (!NILP (fun) && !EQ (fun, Qt))
    call1 (fun, make_number (ch));
  else
    {
      unsigned char str[MAX_MULTIBYTE_LENGTH];
      int len = CHAR_STRING (ch, str);

      QUIT;

      if (NILP (fun))
	{
	  ptrdiff_t incr = len - (print_buffer_size - print_buffer_pos_byte);
	  if (incr > 0)
	    print_buffer = xpalloc (print_buffer, &print_buffer_size,
				    incr, -1, 1);
	  memcpy (print_buffer + print_buffer_pos_byte, str, len);
	  print_buffer_pos += 1;
	  print_buffer_pos_byte += len;
	}
      else if (noninteractive)
	{
	  printchar_stdout_last = ch;
	  fwrite (str, 1, len, stdout);
	  noninteractive_need_newline = 1;
	}
      else
	{
	  bool multibyte_p
	    = !NILP (BVAR (current_buffer, enable_multibyte_characters));

	  setup_echo_area_for_printing (multibyte_p);
	  insert_char (ch);
	  message_dolog ((char *) str, len, 0, multibyte_p);
	}
    }
}


/* Output SIZE characters, SIZE_BYTE bytes from string PTR using
   method PRINTCHARFUN.  If SIZE < 0, use the string length of PTR for
   both SIZE and SIZE_BYTE.  PRINTCHARFUN nil means output to
   print_buffer.  PRINTCHARFUN t means output to the echo area or to
   stdout if non-interactive.  If neither nil nor t, call Lisp
   function PRINTCHARFUN for each character printed.  MULTIBYTE
   non-zero means PTR contains multibyte characters.

   In the case where PRINTCHARFUN is nil, it is safe for PTR to point
   to data in a Lisp string.  Otherwise that is not safe.  */

static void
strout (const char *ptr, ptrdiff_t size, ptrdiff_t size_byte,
	Lisp_Object printcharfun)
{
  if (size < 0)
    size_byte = size = strlen (ptr);

  if (NILP (printcharfun))
    {
      ptrdiff_t incr = size_byte - (print_buffer_size - print_buffer_pos_byte);
      if (incr > 0)
	print_buffer = xpalloc (print_buffer, &print_buffer_size, incr, -1, 1);
      memcpy (print_buffer + print_buffer_pos_byte, ptr, size_byte);
      print_buffer_pos += size;
      print_buffer_pos_byte += size_byte;
    }
  else if (noninteractive && EQ (printcharfun, Qt))
    {
      fwrite (ptr, 1, size_byte, stdout);
      noninteractive_need_newline = 1;
    }
  else if (EQ (printcharfun, Qt))
    {
      /* Output to echo area.  We're trying to avoid a little overhead
	 here, that's the reason we don't call printchar to do the
	 job.  */
      int i;
      bool multibyte_p
	= !NILP (BVAR (current_buffer, enable_multibyte_characters));

      setup_echo_area_for_printing (multibyte_p);
      message_dolog (ptr, size_byte, 0, multibyte_p);

      if (size == size_byte)
	{
	  for (i = 0; i < size; ++i)
	    insert_char ((unsigned char) *ptr++);
	}
      else
	{
	  int len;
	  for (i = 0; i < size_byte; i += len)
	    {
	      int ch = STRING_CHAR_AND_LENGTH ((const unsigned char *) ptr + i,
					       len);
	      insert_char (ch);
	    }
	}
    }
  else
    {
      /* PRINTCHARFUN is a Lisp function.  */
      ptrdiff_t i = 0;

      if (size == size_byte)
	{
	  while (i < size_byte)
	    {
	      int ch = ptr[i++];
	      PRINTCHAR (ch);
	    }
	}
      else
	{
	  while (i < size_byte)
	    {
	      /* Here, we must convert each multi-byte form to the
		 corresponding character code before handing it to
		 PRINTCHAR.  */
	      int len;
	      int ch = STRING_CHAR_AND_LENGTH ((const unsigned char *) ptr + i,
					       len);
	      PRINTCHAR (ch);
	      i += len;
	    }
	}
    }
}

/* Print the contents of a string STRING using PRINTCHARFUN.
   It isn't safe to use strout in many cases,
   because printing one char can relocate.  */

static void
print_string (Lisp_Object string, Lisp_Object printcharfun)
{
  if (EQ (printcharfun, Qt) || NILP (printcharfun))
    {
      ptrdiff_t chars;

      if (print_escape_nonascii)
	string = string_escape_byte8 (string);

      if (STRING_MULTIBYTE (string))
	chars = SCHARS (string);
      else if (! print_escape_nonascii
	       && (EQ (printcharfun, Qt)
		   ? ! NILP (BVAR (&buffer_defaults, enable_multibyte_characters))
		   : ! NILP (BVAR (current_buffer, enable_multibyte_characters))))
	{
	  /* If unibyte string STRING contains 8-bit codes, we must
	     convert STRING to a multibyte string containing the same
	     character codes.  */
	  Lisp_Object newstr;
	  ptrdiff_t bytes;

	  chars = SBYTES (string);
	  bytes = count_size_as_multibyte (SDATA (string), chars);
	  if (chars < bytes)
	    {
	      newstr = make_uninit_multibyte_string (chars, bytes);
	      memcpy (SDATA (newstr), SDATA (string), chars);
	      str_to_multibyte (SDATA (newstr), bytes, chars);
	      string = newstr;
	    }
	}
      else
	chars = SBYTES (string);

      if (EQ (printcharfun, Qt))
	{
	  /* Output to echo area.  */
	  ptrdiff_t nbytes = SBYTES (string);

	  /* Copy the string contents so that relocation of STRING by
	     GC does not cause trouble.  */
	  USE_SAFE_ALLOCA;
	  char *buffer = SAFE_ALLOCA (nbytes);
	  memcpy (buffer, SDATA (string), nbytes);

	  strout (buffer, chars, nbytes, printcharfun);

	  SAFE_FREE ();
	}
      else
	/* No need to copy, since output to print_buffer can't GC.  */
	strout (SSDATA (string), chars, SBYTES (string), printcharfun);
    }
  else
    {
      /* Otherwise, string may be relocated by printing one char.
	 So re-fetch the string address for each character.  */
      ptrdiff_t i;
      ptrdiff_t size = SCHARS (string);
      ptrdiff_t size_byte = SBYTES (string);
      struct gcpro gcpro1;
      GCPRO1 (string);
      if (size == size_byte)
	for (i = 0; i < size; i++)
	  PRINTCHAR (SREF (string, i));
      else
	for (i = 0; i < size_byte; )
	  {
	    /* Here, we must convert each multi-byte form to the
	       corresponding character code before handing it to PRINTCHAR.  */
	    int len;
	    int ch = STRING_CHAR_AND_LENGTH (SDATA (string) + i, len);
	    PRINTCHAR (ch);
	    i += len;
	  }
      UNGCPRO;
    }
}

DEFUN ("write-char", Fwrite_char, Swrite_char, 1, 2, 0,
       doc: /* Output character CHARACTER to stream PRINTCHARFUN.
PRINTCHARFUN defaults to the value of `standard-output' (which see).  */)
  (Lisp_Object character, Lisp_Object printcharfun)
{
  PRINTDECLARE;

  if (NILP (printcharfun))
    printcharfun = Vstandard_output;
  CHECK_NUMBER (character);
  PRINTPREPARE;
  PRINTCHAR (XINT (character));
  PRINTFINISH;
  return character;
}

/* Used from outside of print.c to print a block of SIZE
   single-byte chars at DATA on the default output stream.
   Do not use this on the contents of a Lisp string.  */

void
write_string (const char *data, int size)
{
  PRINTDECLARE;
  Lisp_Object printcharfun;

  printcharfun = Vstandard_output;

  PRINTPREPARE;
  strout (data, size, size, printcharfun);
  PRINTFINISH;
}

/* Used to print a block of SIZE single-byte chars at DATA on a
   specified stream PRINTCHARFUN.
   Do not use this on the contents of a Lisp string.  */

static void
write_string_1 (const char *data, int size, Lisp_Object printcharfun)
{
  PRINTDECLARE;

  PRINTPREPARE;
  strout (data, size, size, printcharfun);
  PRINTFINISH;
}


void
temp_output_buffer_setup (const char *bufname)
{
  ptrdiff_t count = SPECPDL_INDEX ();
  register struct buffer *old = current_buffer;
  register Lisp_Object buf;

  record_unwind_current_buffer ();

  Fset_buffer (Fget_buffer_create (build_string (bufname)));

  Fkill_all_local_variables ();
  delete_all_overlays (current_buffer);
  bset_directory (current_buffer, BVAR (old, directory));
  bset_read_only (current_buffer, Qnil);
  bset_filename (current_buffer, Qnil);
  bset_undo_list (current_buffer, Qt);
  eassert (current_buffer->overlays_before == NULL);
  eassert (current_buffer->overlays_after == NULL);
  bset_enable_multibyte_characters
    (current_buffer, BVAR (&buffer_defaults, enable_multibyte_characters));
  specbind (Qinhibit_read_only, Qt);
  specbind (Qinhibit_modification_hooks, Qt);
  Ferase_buffer ();
  XSETBUFFER (buf, current_buffer);

  run_hook (Qtemp_buffer_setup_hook);

  unbind_to (count, Qnil);

  specbind (Qstandard_output, buf);
}

static void print (Lisp_Object, Lisp_Object, bool);
static void print_preprocess (Lisp_Object);
static void print_preprocess_string (INTERVAL, Lisp_Object);
static void print_object (Lisp_Object, Lisp_Object, bool);

DEFUN ("terpri", Fterpri, Sterpri, 0, 2, 0,
       doc: /* Output a newline to stream PRINTCHARFUN.
If ENSURE is non-nil only output a newline if not already at the
beginning of a line.  Value is non-nil if a newline is printed.
If PRINTCHARFUN is omitted or nil, the value of `standard-output' is used.  */)
  (Lisp_Object printcharfun, Lisp_Object ensure)
{
  Lisp_Object val = Qnil;

  PRINTDECLARE;
  if (NILP (printcharfun))
    printcharfun = Vstandard_output;
  PRINTPREPARE;

  if (NILP (ensure))
    val = Qt;
  /* Difficult to check if at line beginning so abort.  */
  else if (FUNCTIONP (printcharfun))
    signal_error ("Unsupported function argument", printcharfun);
  else if (noninteractive && !NILP (printcharfun))
    val = printchar_stdout_last == 10 ? Qnil : Qt;
  else if (NILP (Fbolp ()))
    val = Qt;

  if (!NILP (val)) PRINTCHAR ('\n');
  PRINTFINISH;
  return val;
}

DEFUN ("prin1", Fprin1, Sprin1, 1, 2, 0,
       doc: /* Output the printed representation of OBJECT, any Lisp object.
Quoting characters are printed when needed to make output that `read'
can handle, whenever this is possible.  For complex objects, the behavior
is controlled by `print-level' and `print-length', which see.

OBJECT is any of the Lisp data types: a number, a string, a symbol,
a list, a buffer, a window, a frame, etc.

A printed representation of an object is text which describes that object.

Optional argument PRINTCHARFUN is the output stream, which can be one
of these:

   - a buffer, in which case output is inserted into that buffer at point;
   - a marker, in which case output is inserted at marker's position;
   - a function, in which case that function is called once for each
     character of OBJECT's printed representation;
   - a symbol, in which case that symbol's function definition is called; or
   - t, in which case the output is displayed in the echo area.

If PRINTCHARFUN is omitted, the value of `standard-output' (which see)
is used instead.  */)
  (Lisp_Object object, Lisp_Object printcharfun)
{
  PRINTDECLARE;

  if (NILP (printcharfun))
    printcharfun = Vstandard_output;
  PRINTPREPARE;
  print (object, printcharfun, 1);
  PRINTFINISH;
  return object;
}

/* a buffer which is used to hold output being built by prin1-to-string */
Lisp_Object Vprin1_to_string_buffer;

DEFUN ("prin1-to-string", Fprin1_to_string, Sprin1_to_string, 1, 2, 0,
       doc: /* Return a string containing the printed representation of OBJECT.
OBJECT can be any Lisp object.  This function outputs quoting characters
when necessary to make output that `read' can handle, whenever possible,
unless the optional second argument NOESCAPE is non-nil.  For complex objects,
the behavior is controlled by `print-level' and `print-length', which see.

OBJECT is any of the Lisp data types: a number, a string, a symbol,
a list, a buffer, a window, a frame, etc.

A printed representation of an object is text which describes that object.  */)
  (Lisp_Object object, Lisp_Object noescape)
{
  Lisp_Object printcharfun;
  bool prev_abort_on_gc;
  Lisp_Object save_deactivate_mark;
  ptrdiff_t count = SPECPDL_INDEX ();
  struct buffer *previous;

  specbind (Qinhibit_modification_hooks, Qt);

  {
    PRINTDECLARE;

    /* Save and restore this--we are altering a buffer
       but we don't want to deactivate the mark just for that.
       No need for specbind, since errors deactivate the mark.  */
    save_deactivate_mark = Vdeactivate_mark;
    prev_abort_on_gc = abort_on_gc;
    abort_on_gc = 1;

    printcharfun = Vprin1_to_string_buffer;
    PRINTPREPARE;
    print (object, printcharfun, NILP (noescape));
    /* Make Vprin1_to_string_buffer be the default buffer after PRINTFINISH */
    PRINTFINISH;
  }

  previous = current_buffer;
  set_buffer_internal (XBUFFER (Vprin1_to_string_buffer));
  object = Fbuffer_string ();
  if (SBYTES (object) == SCHARS (object))
    STRING_SET_UNIBYTE (object);

  /* Note that this won't make prepare_to_modify_buffer call
     ask-user-about-supersession-threat because this buffer
     does not visit a file.  */
  Ferase_buffer ();
  set_buffer_internal (previous);

  Vdeactivate_mark = save_deactivate_mark;

  abort_on_gc = prev_abort_on_gc;
  return unbind_to (count, object);
}

DEFUN ("princ", Fprinc, Sprinc, 1, 2, 0,
       doc: /* Output the printed representation of OBJECT, any Lisp object.
No quoting characters are used; no delimiters are printed around
the contents of strings.

OBJECT is any of the Lisp data types: a number, a string, a symbol,
a list, a buffer, a window, a frame, etc.

A printed representation of an object is text which describes that object.

Optional argument PRINTCHARFUN is the output stream, which can be one
of these:

   - a buffer, in which case output is inserted into that buffer at point;
   - a marker, in which case output is inserted at marker's position;
   - a function, in which case that function is called once for each
     character of OBJECT's printed representation;
   - a symbol, in which case that symbol's function definition is called; or
   - t, in which case the output is displayed in the echo area.

If PRINTCHARFUN is omitted, the value of `standard-output' (which see)
is used instead.  */)
  (Lisp_Object object, Lisp_Object printcharfun)
{
  PRINTDECLARE;

  if (NILP (printcharfun))
    printcharfun = Vstandard_output;
  PRINTPREPARE;
  print (object, printcharfun, 0);
  PRINTFINISH;
  return object;
}

DEFUN ("print", Fprint, Sprint, 1, 2, 0,
       doc: /* Output the printed representation of OBJECT, with newlines around it.
Quoting characters are printed when needed to make output that `read'
can handle, whenever this is possible.  For complex objects, the behavior
is controlled by `print-level' and `print-length', which see.

OBJECT is any of the Lisp data types: a number, a string, a symbol,
a list, a buffer, a window, a frame, etc.

A printed representation of an object is text which describes that object.

Optional argument PRINTCHARFUN is the output stream, which can be one
of these:

   - a buffer, in which case output is inserted into that buffer at point;
   - a marker, in which case output is inserted at marker's position;
   - a function, in which case that function is called once for each
     character of OBJECT's printed representation;
   - a symbol, in which case that symbol's function definition is called; or
   - t, in which case the output is displayed in the echo area.

If PRINTCHARFUN is omitted, the value of `standard-output' (which see)
is used instead.  */)
  (Lisp_Object object, Lisp_Object printcharfun)
{
  PRINTDECLARE;
  struct gcpro gcpro1;

  if (NILP (printcharfun))
    printcharfun = Vstandard_output;
  GCPRO1 (object);
  PRINTPREPARE;
  PRINTCHAR ('\n');
  print (object, printcharfun, 1);
  PRINTCHAR ('\n');
  PRINTFINISH;
  UNGCPRO;
  return object;
}

DEFUN ("external-debugging-output", Fexternal_debugging_output, Sexternal_debugging_output, 1, 1, 0,
       doc: /* Write CHARACTER to stderr.
You can call print while debugging emacs, and pass it this function
to make it write to the debugging output.  */)
  (Lisp_Object character)
{
  unsigned int ch;

  CHECK_NUMBER (character);
  ch = XINT (character);
  if (ASCII_CHAR_P (ch))
    {
      putc (ch, stderr);
#ifdef WINDOWSNT
      /* Send the output to a debugger (nothing happens if there isn't
	 one).  */
      if (print_output_debug_flag)
	{
	  char buf[2] = {(char) XINT (character), '\0'};
	  OutputDebugString (buf);
	}
#endif
    }
  else
    {
      unsigned char mbstr[MAX_MULTIBYTE_LENGTH];
      ptrdiff_t len = CHAR_STRING (ch, mbstr);
      Lisp_Object encoded_ch =
	ENCODE_SYSTEM (make_multibyte_string ((char *) mbstr, 1, len));

      fwrite (SSDATA (encoded_ch), SBYTES (encoded_ch), 1, stderr);
#ifdef WINDOWSNT
      if (print_output_debug_flag)
	OutputDebugString (SSDATA (encoded_ch));
#endif
    }

  return character;
}

/* This function is never called.  Its purpose is to prevent
   print_output_debug_flag from being optimized away.  */

extern void debug_output_compilation_hack (bool) EXTERNALLY_VISIBLE;
void
debug_output_compilation_hack (bool x)
{
  print_output_debug_flag = x;
}

#if defined (GNU_LINUX)

/* This functionality is not vitally important in general, so we rely on
   non-portable ability to use stderr as lvalue.  */

#define WITH_REDIRECT_DEBUGGING_OUTPUT 1

static FILE *initial_stderr_stream = NULL;

DEFUN ("redirect-debugging-output", Fredirect_debugging_output, Sredirect_debugging_output,
       1, 2,
       "FDebug output file: \nP",
       doc: /* Redirect debugging output (stderr stream) to file FILE.
If FILE is nil, reset target to the initial stderr stream.
Optional arg APPEND non-nil (interactively, with prefix arg) means
append to existing target file.  */)
  (Lisp_Object file, Lisp_Object append)
{
  if (initial_stderr_stream != NULL)
    {
      block_input ();
      fclose (stderr);
      unblock_input ();
    }
  stderr = initial_stderr_stream;
  initial_stderr_stream = NULL;

  if (STRINGP (file))
    {
      file = Fexpand_file_name (file, Qnil);
      initial_stderr_stream = stderr;
      stderr = emacs_fopen (SSDATA (file), NILP (append) ? "w" : "a");
      if (stderr == NULL)
	{
	  stderr = initial_stderr_stream;
	  initial_stderr_stream = NULL;
	  report_file_error ("Cannot open debugging output stream", file);
	}
    }
  return Qnil;
}
#endif /* GNU_LINUX */


/* This is the interface for debugging printing.  */

void
debug_print (Lisp_Object arg)
{
  Fprin1 (arg, Qexternal_debugging_output);
  fprintf (stderr, "\r\n");
}