print.c 68.4 KB
Newer Older
Jim Blandy's avatar
Jim Blandy committed
1
/* Lisp object printing and output streams.
2

Paul Eggert's avatar
Paul Eggert committed
3
Copyright (C) 1985-1986, 1988, 1993-1995, 1997-2016 Free Software
4
Foundation, Inc.
Jim Blandy's avatar
Jim Blandy committed
5 6 7

This file is part of GNU Emacs.

8
GNU Emacs is free software: you can redistribute it and/or modify
Jim Blandy's avatar
Jim Blandy committed
9
it under the terms of the GNU General Public License as published by
10 11
the Free Software Foundation, either version 3 of the License, or (at
your option) any later version.
Jim Blandy's avatar
Jim Blandy committed
12 13 14 15 16 17 18

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
19
along with GNU Emacs.  If not, see <http://www.gnu.org/licenses/>.  */
Jim Blandy's avatar
Jim Blandy committed
20 21


22
#include <config.h>
23
#include "sysstdio.h"
24

Jim Blandy's avatar
Jim Blandy committed
25
#include "lisp.h"
26
#include "character.h"
27
#include "coding.h"
28
#include "buffer.h"
Kenichi Handa's avatar
Kenichi Handa committed
29
#include "charset.h"
Jim Blandy's avatar
Jim Blandy committed
30
#include "frame.h"
Jim Blandy's avatar
Jim Blandy committed
31
#include "process.h"
32
#include "disptab.h"
Richard M. Stallman's avatar
Richard M. Stallman committed
33
#include "intervals.h"
YAMAMOTO Mitsuharu's avatar
YAMAMOTO Mitsuharu committed
34
#include "blockinput.h"
Paul Eggert's avatar
Paul Eggert committed
35
#include "xwidget.h"
36

37
#include <c-ctype.h>
Paul Eggert's avatar
Paul Eggert committed
38
#include <float.h>
Paul Eggert's avatar
Paul Eggert committed
39
#include <ftoastr.h>
Paul Eggert's avatar
Paul Eggert committed
40

41 42 43 44
#ifdef WINDOWSNT
# include <sys/socket.h> /* for F_DUPFD_CLOEXEC */
#endif

45 46
struct terminal;

Jim Blandy's avatar
Jim Blandy committed
47
/* Avoid actual stack overflow in print.  */
48
static ptrdiff_t print_depth;
Jim Blandy's avatar
Jim Blandy committed
49

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

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

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

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

/* Size allocated in print_buffer.  */
65
static ptrdiff_t print_buffer_size;
66
/* Chars stored in print_buffer.  */
67
static ptrdiff_t print_buffer_pos;
68
/* Bytes stored in print_buffer.  */
69
static ptrdiff_t print_buffer_pos_byte;
70

71 72 73 74 75 76 77 78
/* 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.  */
79
static ptrdiff_t print_number_index;
80
static void print_interval (INTERVAL interval, Lisp_Object printcharfun);
Jim Blandy's avatar
Jim Blandy committed
81

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

Jim Blandy's avatar
Jim Blandy committed
85

86
/* Low level output routines for characters and strings.  */
Jim Blandy's avatar
Jim Blandy committed
87 88

/* Lisp functions to do output using a stream
89
   must have the stream in a variable called printcharfun
90 91
   and must start with PRINTPREPARE, end with PRINTFINISH.
   Use printchar to output one character,
92
   or call strout to output a block of characters.  */
93

94
#define PRINTPREPARE							\
95
   struct buffer *old = current_buffer;					\
96 97 98
   ptrdiff_t old_point = -1, start_point = -1;				\
   ptrdiff_t old_point_byte = -1, start_point_byte = -1;		\
   ptrdiff_t specpdl_count = SPECPDL_INDEX ();				\
99
   bool free_print_buffer = 0;						\
100 101
   bool multibyte							\
     = !NILP (BVAR (current_buffer, enable_multibyte_characters));	\
102
   Lisp_Object original = printcharfun;					\
103 104 105 106 107 108 109 110 111
   if (NILP (printcharfun)) printcharfun = Qt;				\
   if (BUFFERP (printcharfun))						\
     {									\
       if (XBUFFER (printcharfun) != current_buffer)			\
	 Fset_buffer (printcharfun);					\
       printcharfun = Qnil;						\
     }									\
   if (MARKERP (printcharfun))						\
     {									\
112
       ptrdiff_t marker_pos;						\
Andreas Schwab's avatar
Andreas Schwab committed
113
       if (! XMARKER (printcharfun)->buffer)				\
114
         error ("Marker does not point anywhere");			\
115 116 117 118
       if (XMARKER (printcharfun)->buffer != current_buffer)		\
         set_buffer_internal (XMARKER (printcharfun)->buffer);		\
       marker_pos = marker_position (printcharfun);			\
       if (marker_pos < BEGV || marker_pos > ZV)			\
Joakim Verona's avatar
Joakim Verona committed
119 120
	 signal_error ("Marker is outside the accessible "		\
		       "part of the buffer", printcharfun);		\
121 122
       old_point = PT;							\
       old_point_byte = PT_BYTE;					\
123
       SET_PT_BOTH (marker_pos,						\
124 125 126 127 128 129 130 131
		    marker_byte_position (printcharfun));		\
       start_point = PT;						\
       start_point_byte = PT_BYTE;					\
       printcharfun = Qnil;						\
     }									\
   if (NILP (printcharfun))						\
     {									\
       Lisp_Object string;						\
Joakim Verona's avatar
Joakim Verona committed
132
       if (NILP (BVAR (current_buffer, enable_multibyte_characters))	\
133 134
	   && ! print_escape_multibyte)					\
         specbind (Qprint_escape_multibyte, Qt);			\
Joakim Verona's avatar
Joakim Verona committed
135
       if (! NILP (BVAR (current_buffer, enable_multibyte_characters))	\
136 137
	   && ! print_escape_nonascii)					\
         specbind (Qprint_escape_nonascii, Qt);				\
138 139 140 141 142 143 144 145 146
       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								\
	 {								\
147
	   int new_size = 1000;						\
Dmitry Antipov's avatar
Dmitry Antipov committed
148
	   print_buffer = xmalloc (new_size);				\
149
	   print_buffer_size = new_size;				\
150 151 152 153 154
	   free_print_buffer = 1;					\
	 }								\
       print_buffer_pos = 0;						\
       print_buffer_pos_byte = 0;					\
     }									\
155
   if (EQ (printcharfun, Qt) && ! noninteractive)			\
156
     setup_echo_area_for_printing (multibyte);
Jim Blandy's avatar
Jim Blandy committed
157

158 159 160 161
#define PRINTFINISH							\
   if (NILP (printcharfun))						\
     {									\
       if (print_buffer_pos != print_buffer_pos_byte			\
Joakim Verona's avatar
Joakim Verona committed
162
	   && NILP (BVAR (current_buffer, enable_multibyte_characters)))\
163
	 {								\
164 165
	   USE_SAFE_ALLOCA;						\
	   unsigned char *temp = SAFE_ALLOCA (print_buffer_pos + 1);	\
166 167
	   copy_text ((unsigned char *) print_buffer, temp,		\
		      print_buffer_pos_byte, 1, 0);			\
168
	   insert_1_both ((char *) temp, print_buffer_pos,		\
169
			  print_buffer_pos, 0, 1, 0);			\
170
	   SAFE_FREE ();						\
171 172 173 174
	 }								\
       else								\
	 insert_1_both (print_buffer, print_buffer_pos,			\
			print_buffer_pos_byte, 0, 1, 0);		\
175
       signal_after_change (PT - print_buffer_pos, 0, print_buffer_pos);\
176 177 178 179 180 181 182 183 184 185 186 187
     }									\
   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),			\
188
		  old_point_byte + (old_point_byte >= start_point_byte	\
Andreas Schwab's avatar
Andreas Schwab committed
189
				    ? PT_BYTE - start_point_byte : 0));	\
190
   set_buffer_internal (old);
Jim Blandy's avatar
Jim Blandy committed
191

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

195
static void
196
print_unwind (Lisp_Object saved_text)
197
{
198
  memcpy (print_buffer, SDATA (saved_text), SCHARS (saved_text));
199 200
}

201 202 203 204 205
/* Print character CH to the stdio stream STREAM.  */

static void
printchar_to_stream (unsigned int ch, FILE *stream)
{
206
  Lisp_Object dv UNINIT;
207
  ptrdiff_t i = 0, n = 1;
208 209 210 211 212 213 214
  Lisp_Object coding_system = Vlocale_coding_system;
  bool encode_p = false;

  if (!NILP (Vcoding_system_for_write))
    coding_system = Vcoding_system_for_write;
  if (!NILP (coding_system))
    encode_p = true;
215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242

  if (CHAR_VALID_P (ch) && DISP_TABLE_P (Vstandard_display_table))
    {
      dv = DISP_CHAR_VECTOR (XCHAR_TABLE (Vstandard_display_table), ch);
      if (VECTORP (dv))
	{
	  n = ASIZE (dv);
	  goto next_char;
	}
    }

  while (true)
    {
      if (ASCII_CHAR_P (ch))
	{
	  putc (ch, stream);
#ifdef WINDOWSNT
	  /* Send the output to a debugger (nothing happens if there
	     isn't one).  */
	  if (print_output_debug_flag && stream == stderr)
	    OutputDebugString ((char []) {ch, '\0'});
#endif
	}
      else
	{
	  unsigned char mbstr[MAX_MULTIBYTE_LENGTH];
	  int len = CHAR_STRING (ch, mbstr);
	  Lisp_Object encoded_ch =
243
	    make_multibyte_string ((char *) mbstr, 1, len);
244

245 246 247
	  if (encode_p)
	    encoded_ch = code_convert_string_norecord (encoded_ch,
						       coding_system, true);
248 249 250 251 252 253 254 255 256 257 258 259 260 261 262 263 264 265
	  fwrite (SSDATA (encoded_ch), 1, SBYTES (encoded_ch), stream);
#ifdef WINDOWSNT
	  if (print_output_debug_flag && stream == stderr)
	    OutputDebugString (SSDATA (encoded_ch));
#endif
	}

      i++;

    next_char:
      for (; i < n; i++)
	if (CHARACTERP (AREF (dv, i)))
	  break;
      if (! (i < n))
	break;
      ch = XFASTINT (AREF (dv, i));
    }
}
266 267 268 269 270

/* 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.  */
Jim Blandy's avatar
Jim Blandy committed
271 272

static void
273
printchar (unsigned int ch, Lisp_Object fun)
Jim Blandy's avatar
Jim Blandy committed
274
{
275 276 277
  if (!NILP (fun) && !EQ (fun, Qt))
    call1 (fun, make_number (ch));
  else
Jim Blandy's avatar
Jim Blandy committed
278
    {
279 280 281
      unsigned char str[MAX_MULTIBYTE_LENGTH];
      int len = CHAR_STRING (ch, str);

282
      QUIT;
283

284
      if (NILP (fun))
285
	{
286
	  ptrdiff_t incr = len - (print_buffer_size - print_buffer_pos_byte);
287 288 289
	  if (incr > 0)
	    print_buffer = xpalloc (print_buffer, &print_buffer_size,
				    incr, -1, 1);
290
	  memcpy (print_buffer + print_buffer_pos_byte, str, len);
291 292
	  print_buffer_pos += 1;
	  print_buffer_pos_byte += len;
293
	}
294
      else if (noninteractive)
295
	{
296
	  printchar_stdout_last = ch;
297 298 299 300
	  if (DISP_TABLE_P (Vstandard_display_table))
	    printchar_to_stream (ch, stdout);
	  else
	    fwrite (str, 1, len, stdout);
301
	  noninteractive_need_newline = 1;
302
	}
303
      else
304
	{
305
	  bool multibyte_p
Tom Tromey's avatar
Tom Tromey committed
306
	    = !NILP (BVAR (current_buffer, enable_multibyte_characters));
307

308
	  setup_echo_area_for_printing (multibyte_p);
309
	  insert_char (ch);
310
	  message_dolog ((char *) str, len, 0, multibyte_p);
311
	}
Jim Blandy's avatar
Jim Blandy committed
312 313 314
    }
}

315 316

/* Output SIZE characters, SIZE_BYTE bytes from string PTR using
317
   method PRINTCHARFUN.  PRINTCHARFUN nil means output to
318 319 320
   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
321 322 323 324
   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.  */
325

Jim Blandy's avatar
Jim Blandy committed
326
static void
327
strout (const char *ptr, ptrdiff_t size, ptrdiff_t size_byte,
328
	Lisp_Object printcharfun)
Jim Blandy's avatar
Jim Blandy committed
329
{
330
  if (NILP (printcharfun))
Jim Blandy's avatar
Jim Blandy committed
331
    {
332
      ptrdiff_t incr = size_byte - (print_buffer_size - print_buffer_pos_byte);
333
      if (incr > 0)
334
	print_buffer = xpalloc (print_buffer, &print_buffer_size, incr, -1, 1);
335
      memcpy (print_buffer + print_buffer_pos_byte, ptr, size_byte);
336
      print_buffer_pos += size;
337
      print_buffer_pos_byte += size_byte;
Jim Blandy's avatar
Jim Blandy committed
338
    }
339
  else if (noninteractive && EQ (printcharfun, Qt))
Jim Blandy's avatar
Jim Blandy committed
340
    {
341 342 343 344 345 346 347 348 349 350 351 352 353
      if (DISP_TABLE_P (Vstandard_display_table))
	{
	  int len;
	  for (ptrdiff_t i = 0; i < size_byte; i += len)
	    {
	      int ch = STRING_CHAR_AND_LENGTH ((const unsigned char *) ptr + i,
					       len);
	      printchar_to_stream (ch, stdout);
	    }
	}
      else
	fwrite (ptr, 1, size_byte, stdout);

354 355 356 357 358 359 360 361
      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;
362
      bool multibyte_p
Tom Tromey's avatar
Tom Tromey committed
363
	= !NILP (BVAR (current_buffer, enable_multibyte_characters));
364

365
      setup_echo_area_for_printing (multibyte_p);
366
      message_dolog (ptr, size_byte, 0, multibyte_p);
367

368
      if (size == size_byte)
Jim Blandy's avatar
Jim Blandy committed
369
	{
370
	  for (i = 0; i < size; ++i)
Andreas Schwab's avatar
Andreas Schwab committed
371
	    insert_char ((unsigned char) *ptr++);
Jim Blandy's avatar
Jim Blandy committed
372
	}
373
      else
Jim Blandy's avatar
Jim Blandy committed
374
	{
375 376
	  int len;
	  for (i = 0; i < size_byte; i += len)
377
	    {
378 379
	      int ch = STRING_CHAR_AND_LENGTH ((const unsigned char *) ptr + i,
					       len);
380
	      insert_char (ch);
381
	    }
Jim Blandy's avatar
Jim Blandy committed
382
	}
383 384 385 386
    }
  else
    {
      /* PRINTCHARFUN is a Lisp function.  */
387
      ptrdiff_t i = 0;
Jim Blandy's avatar
Jim Blandy committed
388

389
      if (size == size_byte)
390
	{
391
	  while (i < size_byte)
392
	    {
393
	      int ch = ptr[i++];
394
	      printchar (ch, printcharfun);
395 396
	    }
	}
397
      else
Karl Heuer's avatar
Karl Heuer committed
398
	{
399 400 401 402 403 404
	  while (i < size_byte)
	    {
	      /* Here, we must convert each multi-byte form to the
		 corresponding character code before handing it to
		 PRINTCHAR.  */
	      int len;
405 406
	      int ch = STRING_CHAR_AND_LENGTH ((const unsigned char *) ptr + i,
					       len);
407
	      printchar (ch, printcharfun);
408 409
	      i += len;
	    }
Karl Heuer's avatar
Karl Heuer committed
410
	}
Jim Blandy's avatar
Jim Blandy committed
411 412 413 414
    }
}

/* Print the contents of a string STRING using PRINTCHARFUN.
415 416
   It isn't safe to use strout in many cases,
   because printing one char can relocate.  */
Jim Blandy's avatar
Jim Blandy committed
417

418
static void
419
print_string (Lisp_Object string, Lisp_Object printcharfun)
Jim Blandy's avatar
Jim Blandy committed
420
{
421
  if (EQ (printcharfun, Qt) || NILP (printcharfun))
422
    {
423
      ptrdiff_t chars;
424

425 426 427
      if (print_escape_nonascii)
	string = string_escape_byte8 (string);

428
      if (STRING_MULTIBYTE (string))
429
	chars = SCHARS (string);
430 431
      else if (! print_escape_nonascii
	       && (EQ (printcharfun, Qt)
Tom Tromey's avatar
Tom Tromey committed
432 433
		   ? ! NILP (BVAR (&buffer_defaults, enable_multibyte_characters))
		   : ! NILP (BVAR (current_buffer, enable_multibyte_characters))))
434 435 436 437 438
	{
	  /* If unibyte string STRING contains 8-bit codes, we must
	     convert STRING to a multibyte string containing the same
	     character codes.  */
	  Lisp_Object newstr;
439
	  ptrdiff_t bytes;
440

441
	  chars = SBYTES (string);
442
	  bytes = count_size_as_multibyte (SDATA (string), chars);
443 444 445
	  if (chars < bytes)
	    {
	      newstr = make_uninit_multibyte_string (chars, bytes);
446
	      memcpy (SDATA (newstr), SDATA (string), chars);
447
	      str_to_multibyte (SDATA (newstr), bytes, chars);
448 449 450
	      string = newstr;
	    }
	}
451
      else
452
	chars = SBYTES (string);
453

454 455 456
      if (EQ (printcharfun, Qt))
	{
	  /* Output to echo area.  */
457
	  ptrdiff_t nbytes = SBYTES (string);
458 459 460 461

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

465
	  strout (buffer, chars, nbytes, printcharfun);
466 467 468 469 470

	  SAFE_FREE ();
	}
      else
	/* No need to copy, since output to print_buffer can't GC.  */
471
	strout (SSDATA (string), chars, SBYTES (string), printcharfun);
472
    }
Jim Blandy's avatar
Jim Blandy committed
473 474
  else
    {
475 476
      /* Otherwise, string may be relocated by printing one char.
	 So re-fetch the string address for each character.  */
477 478 479
      ptrdiff_t i;
      ptrdiff_t size = SCHARS (string);
      ptrdiff_t size_byte = SBYTES (string);
480 481
      if (size == size_byte)
	for (i = 0; i < size; i++)
482
	  printchar (SREF (string, i), printcharfun);
483
      else
Kenichi Handa's avatar
Kenichi Handa committed
484
	for (i = 0; i < size_byte; )
485 486 487 488
	  {
	    /* Here, we must convert each multi-byte form to the
	       corresponding character code before handing it to PRINTCHAR.  */
	    int len;
489
	    int ch = STRING_CHAR_AND_LENGTH (SDATA (string) + i, len);
490
	    printchar (ch, printcharfun);
491 492
	    i += len;
	  }
Jim Blandy's avatar
Jim Blandy committed
493 494 495 496
    }
}

DEFUN ("write-char", Fwrite_char, Swrite_char, 1, 2, 0,
497 498
       doc: /* Output character CHARACTER to stream PRINTCHARFUN.
PRINTCHARFUN defaults to the value of `standard-output' (which see).  */)
Dan Nicolaescu's avatar
Dan Nicolaescu committed
499
  (Lisp_Object character, Lisp_Object printcharfun)
Jim Blandy's avatar
Jim Blandy committed
500
{
Jim Blandy's avatar
Jim Blandy committed
501
  if (NILP (printcharfun))
Jim Blandy's avatar
Jim Blandy committed
502
    printcharfun = Vstandard_output;
503
  CHECK_NUMBER (character);
Jim Blandy's avatar
Jim Blandy committed
504
  PRINTPREPARE;
505
  printchar (XINT (character), printcharfun);
Jim Blandy's avatar
Jim Blandy committed
506
  PRINTFINISH;
507
  return character;
Jim Blandy's avatar
Jim Blandy committed
508 509
}

510 511
/* Print the contents of a unibyte C string STRING using PRINTCHARFUN.
   The caller should arrange to put this inside PRINTPREPARE and PRINTFINISH.
Jim Blandy's avatar
Jim Blandy committed
512 513
   Do not use this on the contents of a Lisp string.  */

514 515
static void
print_c_string (char const *string, Lisp_Object printcharfun)
Jim Blandy's avatar
Jim Blandy committed
516
{
517 518 519
  ptrdiff_t len = strlen (string);
  strout (string, len, len, printcharfun);
}
Jim Blandy's avatar
Jim Blandy committed
520

521 522
/* Print unibyte C string at DATA on a specified stream PRINTCHARFUN.
   Do not use this on the contents of a Lisp string.  */
Jim Blandy's avatar
Jim Blandy committed
523

524 525 526
static void
write_string_1 (const char *data, Lisp_Object printcharfun)
{
Jim Blandy's avatar
Jim Blandy committed
527
  PRINTPREPARE;
528
  print_c_string (data, printcharfun);
Jim Blandy's avatar
Jim Blandy committed
529 530 531
  PRINTFINISH;
}

532 533
/* Used from outside of print.c to print a C unibyte
   string at DATA on the default output stream.
Jim Blandy's avatar
Jim Blandy committed
534 535
   Do not use this on the contents of a Lisp string.  */

536 537
void
write_string (const char *data)
Jim Blandy's avatar
Jim Blandy committed
538
{
539
  write_string_1 (data, Vstandard_output);
Jim Blandy's avatar
Jim Blandy committed
540 541 542 543
}


void
544
temp_output_buffer_setup (const char *bufname)
Jim Blandy's avatar
Jim Blandy committed
545
{
546
  ptrdiff_t count = SPECPDL_INDEX ();
Jim Blandy's avatar
Jim Blandy committed
547 548 549
  register struct buffer *old = current_buffer;
  register Lisp_Object buf;

550
  record_unwind_current_buffer ();
551

Jim Blandy's avatar
Jim Blandy committed
552 553
  Fset_buffer (Fget_buffer_create (build_string (bufname)));

554
  Fkill_all_local_variables ();
555
  delete_all_overlays (current_buffer);
Paul Eggert's avatar
Paul Eggert committed
556 557 558 559
  bset_directory (current_buffer, BVAR (old, directory));
  bset_read_only (current_buffer, Qnil);
  bset_filename (current_buffer, Qnil);
  bset_undo_list (current_buffer, Qt);
560 561
  eassert (current_buffer->overlays_before == NULL);
  eassert (current_buffer->overlays_after == NULL);
Paul Eggert's avatar
Paul Eggert committed
562 563
  bset_enable_multibyte_characters
    (current_buffer, BVAR (&buffer_defaults, enable_multibyte_characters));
564 565
  specbind (Qinhibit_read_only, Qt);
  specbind (Qinhibit_modification_hooks, Qt);
Jim Blandy's avatar
Jim Blandy committed
566
  Ferase_buffer ();
567
  XSETBUFFER (buf, current_buffer);
Jim Blandy's avatar
Jim Blandy committed
568

569
  run_hook (Qtemp_buffer_setup_hook);
570 571 572 573

  unbind_to (count, Qnil);

  specbind (Qstandard_output, buf);
Jim Blandy's avatar
Jim Blandy committed
574 575
}

576 577 578 579
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);
Jim Blandy's avatar
Jim Blandy committed
580

581
DEFUN ("terpri", Fterpri, Sterpri, 0, 2, 0,
582
       doc: /* Output a newline to stream PRINTCHARFUN.
583 584
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.
585
If PRINTCHARFUN is omitted or nil, the value of `standard-output' is used.  */)
586
  (Lisp_Object printcharfun, Lisp_Object ensure)
Jim Blandy's avatar
Jim Blandy committed
587
{
588
  Lisp_Object val;
Jim Blandy's avatar
Jim Blandy committed
589

Jim Blandy's avatar
Jim Blandy committed
590
  if (NILP (printcharfun))
Jim Blandy's avatar
Jim Blandy committed
591 592
    printcharfun = Vstandard_output;
  PRINTPREPARE;
593 594 595 596 597 598 599 600

  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;
601 602
  else
    val = NILP (Fbolp ()) ? Qt : Qnil;
603

604 605
  if (!NILP (val))
    printchar ('\n', printcharfun);
Jim Blandy's avatar
Jim Blandy committed
606
  PRINTFINISH;
607
  return val;
Jim Blandy's avatar
Jim Blandy committed
608 609
}

Paul Eggert's avatar
Paul Eggert committed
610
DEFUN ("prin1", Fprin1, Sprin1, 1, 2, 0,
611 612
       doc: /* Output the printed representation of OBJECT, any Lisp object.
Quoting characters are printed when needed to make output that `read'
Eli Zaretskii's avatar
Eli Zaretskii committed
613
can handle, whenever this is possible.  For complex objects, the behavior
Pavel Janík's avatar
Pavel Janík committed
614
is controlled by `print-level' and `print-length', which see.
615 616 617 618 619 620 621 622 623 624 625 626 627 628 629 630 631 632

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.  */)
Dan Nicolaescu's avatar
Dan Nicolaescu committed
633
  (Lisp_Object object, Lisp_Object printcharfun)
Jim Blandy's avatar
Jim Blandy committed
634
{
Jim Blandy's avatar
Jim Blandy committed
635
  if (NILP (printcharfun))
Jim Blandy's avatar
Jim Blandy committed
636 637
    printcharfun = Vstandard_output;
  PRINTPREPARE;
638
  print (object, printcharfun, 1);
Jim Blandy's avatar
Jim Blandy committed
639
  PRINTFINISH;
640
  return object;
Jim Blandy's avatar
Jim Blandy committed
641 642 643 644 645
}

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

Paul Eggert's avatar
Paul Eggert committed
646
DEFUN ("prin1-to-string", Fprin1_to_string, Sprin1_to_string, 1, 2, 0,
647 648
       doc: /* Return a string containing the printed representation of OBJECT.
OBJECT can be any Lisp object.  This function outputs quoting characters
Pavel Janík's avatar
Pavel Janík committed
649
when necessary to make output that `read' can handle, whenever possible,
650 651
unless the optional second argument NOESCAPE is non-nil.  For complex objects,
the behavior is controlled by `print-level' and `print-length', which see.
652 653 654 655 656

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.  */)
Dan Nicolaescu's avatar
Dan Nicolaescu committed
657
  (Lisp_Object object, Lisp_Object noescape)
Jim Blandy's avatar
Jim Blandy committed
658
{
659
  ptrdiff_t count = SPECPDL_INDEX ();
660 661

  specbind (Qinhibit_modification_hooks, Qt);
662

663 664 665 666
  /* 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.  */
  Lisp_Object save_deactivate_mark = Vdeactivate_mark;
Jim Blandy's avatar
Jim Blandy committed
667

668 669 670 671 672 673 674
  Lisp_Object printcharfun = Vprin1_to_string_buffer;
  PRINTPREPARE;
  print (object, printcharfun, NILP (noescape));
  /* Make Vprin1_to_string_buffer be the default buffer after PRINTFINISH */
  PRINTFINISH;

  struct buffer *previous = current_buffer;
Jim Blandy's avatar
Jim Blandy committed
675
  set_buffer_internal (XBUFFER (Vprin1_to_string_buffer));
676
  object = Fbuffer_string ();
677 678
  if (SBYTES (object) == SCHARS (object))
    STRING_SET_UNIBYTE (object);
Jim Blandy's avatar
Jim Blandy committed
679

680
  /* Note that this won't make prepare_to_modify_buffer call
Kenichi Handa's avatar
Kenichi Handa committed
681 682
     ask-user-about-supersession-threat because this buffer
     does not visit a file.  */
Jim Blandy's avatar
Jim Blandy committed
683
  Ferase_buffer ();
Kenichi Handa's avatar
Kenichi Handa committed
684
  set_buffer_internal (previous);
685

686
  Vdeactivate_mark = save_deactivate_mark;
Jim Blandy's avatar
Jim Blandy committed
687

688
  return unbind_to (count, object);
Jim Blandy's avatar
Jim Blandy committed
689 690
}

691
DEFUN ("princ", Fprinc, Sprinc, 1, 2, 0,
692 693 694 695 696 697 698 699 700 701 702 703 704 705 706 707 708 709 710 711 712
       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.  */)
Dan Nicolaescu's avatar
Dan Nicolaescu committed
713
  (Lisp_Object object, Lisp_Object printcharfun)
Jim Blandy's avatar
Jim Blandy committed
714
{
Jim Blandy's avatar
Jim Blandy committed
715
  if (NILP (printcharfun))
Jim Blandy's avatar
Jim Blandy committed
716 717
    printcharfun = Vstandard_output;
  PRINTPREPARE;
718
  print (object, printcharfun, 0);
Jim Blandy's avatar
Jim Blandy committed
719
  PRINTFINISH;
720
  return object;
Jim Blandy's avatar
Jim Blandy committed
721 722
}

Paul Eggert's avatar
Paul Eggert committed
723
DEFUN ("print", Fprint, Sprint, 1, 2, 0,
724 725
       doc: /* Output the printed representation of OBJECT, with newlines around it.
Quoting characters are printed when needed to make output that `read'
Eli Zaretskii's avatar
Eli Zaretskii committed
726
can handle, whenever this is possible.  For complex objects, the behavior
Pavel Janík's avatar
Pavel Janík committed
727
is controlled by `print-level' and `print-length', which see.
728 729 730 731 732 733 734 735 736 737 738 739 740 741 742 743 744 745

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.  */)
Dan Nicolaescu's avatar
Dan Nicolaescu committed
746
  (Lisp_Object object, Lisp_Object printcharfun)
Jim Blandy's avatar
Jim Blandy committed
747
{
Jim Blandy's avatar
Jim Blandy committed
748
  if (NILP (printcharfun))
Jim Blandy's avatar
Jim Blandy committed
749 750
    printcharfun = Vstandard_output;
  PRINTPREPARE;
751
  printchar ('\n', printcharfun);
752
  print (object, printcharfun, 1);
753
  printchar ('\n', printcharfun);
Jim Blandy's avatar
Jim Blandy committed
754
  PRINTFINISH;
755
  return object;
Jim Blandy's avatar
Jim Blandy committed
756 757
}

Jim Blandy's avatar
Jim Blandy committed
758
DEFUN ("external-debugging-output", Fexternal_debugging_output, Sexternal_debugging_output, 1, 1, 0,
759 760 761
       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.  */)
Dan Nicolaescu's avatar
Dan Nicolaescu committed
762
  (Lisp_Object character)
Jim Blandy's avatar
Jim Blandy committed
763
{
764
  CHECK_NUMBER (character);
765
  printchar_to_stream (XINT (character), stderr);
Jim Blandy's avatar
Jim Blandy committed
766 767
  return character;
}
768

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

772
extern void debug_output_compilation_hack (bool) EXTERNALLY_VISIBLE;
773
void
774
debug_output_compilation_hack (bool x)
775 776 777
{
  print_output_debug_flag = x;
}
Kenichi Handa's avatar
Kenichi Handa committed
778 779 780 781 782 783 784

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
785
append to existing target file.  */)
Dan Nicolaescu's avatar
Dan Nicolaescu committed
786
  (Lisp_Object file, Lisp_Object append)
Kenichi Handa's avatar
Kenichi Handa committed
787
{
788 789 790 791
  /* If equal to STDERR_FILENO, stderr has not been duplicated and is OK as-is.
     Otherwise, this is a close-on-exec duplicate of the original stderr. */
  static int stderr_dup = STDERR_FILENO;
  int fd = stderr_dup;
Kenichi Handa's avatar
Kenichi Handa committed
792

793
  if (! NILP (file))
Kenichi Handa's avatar
Kenichi Handa committed
794 795
    {
      file = Fexpand_file_name (file, Qnil);
796 797

      if (stderr_dup == STDERR_FILENO)
Kenichi Handa's avatar
Kenichi Handa committed
798
	{
799 800 801 802
	  int n = fcntl (STDERR_FILENO, F_DUPFD_CLOEXEC, STDERR_FILENO + 1);
	  if (n < 0)
	    report_file_error ("dup", file);
	  stderr_dup = n;
Kenichi Handa's avatar
Kenichi Handa committed
803
	}
804 805 806 807 808 809 810

      fd = emacs_open (SSDATA (ENCODE_FILE (file)),
		       (O_WRONLY | O_CREAT
			| (! NILP (append) ? O_APPEND : O_TRUNC)),
		       0666);
      if (fd < 0)
	report_file_error ("Cannot open debugging output stream", file);
Kenichi Handa's avatar
Kenichi Handa committed
811
    }
812 813 814 815 816 817

  fflush (stderr);
  if (dup2 (fd, STDERR_FILENO) < 0)
    report_file_error ("dup2", file);
  if (fd != stderr_dup)
    emacs_close (fd);
Kenichi Handa's avatar
Kenichi Handa committed
818 819 820 821
  return Qnil;
}


822 823 824
/* This is the interface for debugging printing.  */

void
825
debug_print (Lisp_Object arg)
826 827
{
  Fprin1 (arg, Qexternal_debugging_output);
828
  fprintf (stderr, "\r\n");
829
}
830