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

Copyright (C) 1985-1986, 1988, 1993-1995, 1997-2011
  Free Software 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>
Jim Blandy's avatar
Jim Blandy committed
23
#include <stdio.h>
24
#include <setjmp.h>
Jim Blandy's avatar
Jim Blandy committed
25 26
#include "lisp.h"
#include "buffer.h"
27
#include "character.h"
Kenichi Handa's avatar
Kenichi Handa committed
28
#include "charset.h"
29
#include "keyboard.h"
Jim Blandy's avatar
Jim Blandy committed
30
#include "frame.h"
Jim Blandy's avatar
Jim Blandy committed
31 32 33 34
#include "window.h"
#include "process.h"
#include "dispextern.h"
#include "termchar.h"
Richard M. Stallman's avatar
Richard M. Stallman committed
35
#include "intervals.h"
YAMAMOTO Mitsuharu's avatar
YAMAMOTO Mitsuharu committed
36
#include "blockinput.h"
37
#include "termhooks.h"		/* For struct terminal.  */
Kenichi Handa's avatar
Kenichi Handa committed
38
#include "font.h"
Richard M. Stallman's avatar
Richard M. Stallman committed
39

40
Lisp_Object Qstandard_output;
Jim Blandy's avatar
Jim Blandy committed
41

42 43
Lisp_Object Qtemp_buffer_setup_hook;

Erik Naggum's avatar
Erik Naggum committed
44 45
/* These are used to print like we read.  */

46
Lisp_Object Qfloat_output_format;
Paul Eggert's avatar
Paul Eggert committed
47 48 49 50 51 52

#include <math.h>

#if STDC_HEADERS
#include <float.h>
#endif
Paul Eggert's avatar
Paul Eggert committed
53
#include <ftoastr.h>
Paul Eggert's avatar
Paul Eggert committed
54 55 56 57 58 59

/* Default to values appropriate for IEEE floating point.  */
#ifndef DBL_DIG
#define DBL_DIG 15
#endif

Jim Blandy's avatar
Jim Blandy committed
60 61 62
/* Avoid actual stack overflow in print.  */
int print_depth;

63 64
/* Level of nesting inside outputting backquote in new style.  */
int new_backquote_output;
65

66 67 68 69
/* Detect most circularities to print finite output.  */
#define PRINT_CIRCLE 200
Lisp_Object being_printed[PRINT_CIRCLE];

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

/* Size allocated in print_buffer.  */
75
EMACS_INT print_buffer_size;
76
/* Chars stored in print_buffer.  */
77
EMACS_INT print_buffer_pos;
78
/* Bytes stored in print_buffer.  */
79
EMACS_INT print_buffer_pos_byte;
80

81 82 83
Lisp_Object Qprint_escape_newlines;
Lisp_Object Qprint_escape_multibyte, Qprint_escape_nonascii;

84 85 86 87 88 89 90 91
/* 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.  */
92
int print_number_index;
93
void print_interval (INTERVAL interval, Lisp_Object printcharfun);
Jim Blandy's avatar
Jim Blandy committed
94

95
/* GDB resets this to zero on W32 to disable OutputDebugString calls.  */
96
int print_output_debug_flag EXTERNALLY_VISIBLE = 1;
97

Jim Blandy's avatar
Jim Blandy committed
98

99
/* Low level output routines for characters and strings */
Jim Blandy's avatar
Jim Blandy committed
100 101

/* Lisp functions to do output using a stream
102 103 104 105
   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,
106
   or call strout to output a block of characters. */
107 108 109

#define PRINTDECLARE							\
   struct buffer *old = current_buffer;					\
110 111
   EMACS_INT old_point = -1, start_point = -1;				\
   EMACS_INT old_point_byte = -1, start_point_byte = -1;		\
Juanma Barranquero's avatar
Juanma Barranquero committed
112
   int specpdl_count = SPECPDL_INDEX ();				\
113 114
   int free_print_buffer = 0;						\
   int multibyte = !NILP (current_buffer->enable_multibyte_characters);	\
115 116
   Lisp_Object original

117 118 119 120 121 122 123 124 125 126 127
#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))						\
     {									\
128
       EMACS_INT marker_pos;						\
Andreas Schwab's avatar
Andreas Schwab committed
129
       if (! XMARKER (printcharfun)->buffer)				\
130
         error ("Marker does not point anywhere");			\
131 132 133 134 135
       if (XMARKER (printcharfun)->buffer != current_buffer)		\
         set_buffer_internal (XMARKER (printcharfun)->buffer);		\
       marker_pos = marker_position (printcharfun);			\
       if (marker_pos < BEGV || marker_pos > ZV)			\
	 error ("Marker is outside the accessible part of the buffer"); \
136 137
       old_point = PT;							\
       old_point_byte = PT_BYTE;					\
138
       SET_PT_BOTH (marker_pos,						\
139 140 141 142 143 144 145 146 147 148 149
		    marker_byte_position (printcharfun));		\
       start_point = PT;						\
       start_point_byte = PT_BYTE;					\
       printcharfun = Qnil;						\
     }									\
   if (NILP (printcharfun))						\
     {									\
       Lisp_Object string;						\
       if (NILP (current_buffer->enable_multibyte_characters)		\
	   && ! print_escape_multibyte)					\
         specbind (Qprint_escape_multibyte, Qt);			\
150 151 152
       if (! NILP (current_buffer->enable_multibyte_characters)		\
	   && ! print_escape_nonascii)					\
         specbind (Qprint_escape_nonascii, Qt);				\
153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168
       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								\
	 {								\
           print_buffer_size = 1000;					\
           print_buffer = (char *) xmalloc (print_buffer_size);		\
	   free_print_buffer = 1;					\
	 }								\
       print_buffer_pos = 0;						\
       print_buffer_pos_byte = 0;					\
     }									\
169
   if (EQ (printcharfun, Qt) && ! noninteractive)			\
170
     setup_echo_area_for_printing (multibyte);
Jim Blandy's avatar
Jim Blandy committed
171

172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187
#define PRINTFINISH							\
   if (NILP (printcharfun))						\
     {									\
       if (print_buffer_pos != print_buffer_pos_byte			\
	   && NILP (current_buffer->enable_multibyte_characters))	\
	 {								\
	   unsigned char *temp						\
	     = (unsigned char *) alloca (print_buffer_pos + 1);		\
	   copy_text (print_buffer, temp, print_buffer_pos_byte,	\
		      1, 0);						\
	   insert_1_both (temp, print_buffer_pos,			\
			  print_buffer_pos, 0, 1, 0);			\
	 }								\
       else								\
	 insert_1_both (print_buffer, print_buffer_pos,			\
			print_buffer_pos_byte, 0, 1, 0);		\
188
       signal_after_change (PT - print_buffer_pos, 0, print_buffer_pos);\
189 190 191 192 193 194 195 196 197 198 199 200
     }									\
   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),			\
201
		  old_point_byte + (old_point_byte >= start_point_byte	\
Andreas Schwab's avatar
Andreas Schwab committed
202
				    ? PT_BYTE - start_point_byte : 0));	\
203
   if (old != current_buffer)						\
204
     set_buffer_internal (old);
Jim Blandy's avatar
Jim Blandy committed
205 206 207

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

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

211
static Lisp_Object
212
print_unwind (Lisp_Object saved_text)
213
{
214
  memcpy (print_buffer, SDATA (saved_text), SCHARS (saved_text));
Gerd Moellmann's avatar
Gerd Moellmann committed
215
  return Qnil;
216 217
}

218 219 220 221 222

/* 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
223 224

static void
225
printchar (unsigned int ch, Lisp_Object fun)
Jim Blandy's avatar
Jim Blandy committed
226
{
227 228 229
  if (!NILP (fun) && !EQ (fun, Qt))
    call1 (fun, make_number (ch));
  else
Jim Blandy's avatar
Jim Blandy committed
230
    {
231 232 233
      unsigned char str[MAX_MULTIBYTE_LENGTH];
      int len = CHAR_STRING (ch, str);

234
      QUIT;
235

236
      if (NILP (fun))
237
	{
238 239 240
	  if (print_buffer_pos_byte + len >= print_buffer_size)
	    print_buffer = (char *) xrealloc (print_buffer,
					      print_buffer_size *= 2);
241
	  memcpy (print_buffer + print_buffer_pos_byte, str, len);
242 243
	  print_buffer_pos += 1;
	  print_buffer_pos_byte += len;
244
	}
245
      else if (noninteractive)
246
	{
247 248
	  fwrite (str, 1, len, stdout);
	  noninteractive_need_newline = 1;
249
	}
250
      else
251
	{
252 253
	  int multibyte_p
	    = !NILP (current_buffer->enable_multibyte_characters);
254

255
	  setup_echo_area_for_printing (multibyte_p);
256 257
	  insert_char (ch);
	  message_dolog (str, len, 0, multibyte_p);
258
	}
Jim Blandy's avatar
Jim Blandy committed
259 260 261
    }
}

262 263 264 265 266 267 268

/* 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
269 270 271 272
   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.  */
273

Jim Blandy's avatar
Jim Blandy committed
274
static void
275 276
strout (const char *ptr, EMACS_INT size, EMACS_INT size_byte,
	Lisp_Object printcharfun, int multibyte)
Jim Blandy's avatar
Jim Blandy committed
277
{
Karl Heuer's avatar
Karl Heuer committed
278
  if (size < 0)
279
    size_byte = size = strlen (ptr);
Karl Heuer's avatar
Karl Heuer committed
280

281
  if (NILP (printcharfun))
Jim Blandy's avatar
Jim Blandy committed
282
    {
283
      if (print_buffer_pos_byte + size_byte > print_buffer_size)
284
	{
285
	  print_buffer_size = print_buffer_size * 2 + size_byte;
286 287 288
	  print_buffer = (char *) xrealloc (print_buffer,
					    print_buffer_size);
	}
289
      memcpy (print_buffer + print_buffer_pos_byte, ptr, size_byte);
290
      print_buffer_pos += size;
291
      print_buffer_pos_byte += size_byte;
Jim Blandy's avatar
Jim Blandy committed
292
    }
293
  else if (noninteractive && EQ (printcharfun, Qt))
Jim Blandy's avatar
Jim Blandy committed
294
    {
295 296 297 298 299 300 301 302 303 304 305
      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;
      int multibyte_p
	= !NILP (current_buffer->enable_multibyte_characters);
306

307
      setup_echo_area_for_printing (multibyte_p);
308
      message_dolog (ptr, size_byte, 0, multibyte_p);
309

310
      if (size == size_byte)
Jim Blandy's avatar
Jim Blandy committed
311
	{
312
	  for (i = 0; i < size; ++i)
Andreas Schwab's avatar
Andreas Schwab committed
313
	    insert_char ((unsigned char) *ptr++);
Jim Blandy's avatar
Jim Blandy committed
314
	}
315
      else
Jim Blandy's avatar
Jim Blandy committed
316
	{
317 318
	  int len;
	  for (i = 0; i < size_byte; i += len)
319
	    {
320
	      int ch = STRING_CHAR_AND_LENGTH (ptr + i, len);
321
	      insert_char (ch);
322
	    }
Jim Blandy's avatar
Jim Blandy committed
323
	}
324 325 326 327
    }
  else
    {
      /* PRINTCHARFUN is a Lisp function.  */
328
      EMACS_INT i = 0;
Jim Blandy's avatar
Jim Blandy committed
329

330
      if (size == size_byte)
331
	{
332
	  while (i < size_byte)
333
	    {
334 335
	      int ch = ptr[i++];
	      PRINTCHAR (ch);
336 337
	    }
	}
338
      else
Karl Heuer's avatar
Karl Heuer committed
339
	{
340 341 342 343 344 345
	  while (i < size_byte)
	    {
	      /* Here, we must convert each multi-byte form to the
		 corresponding character code before handing it to
		 PRINTCHAR.  */
	      int len;
346
	      int ch = STRING_CHAR_AND_LENGTH (ptr + i, len);
347 348 349
	      PRINTCHAR (ch);
	      i += len;
	    }
Karl Heuer's avatar
Karl Heuer committed
350
	}
Jim Blandy's avatar
Jim Blandy committed
351 352 353 354
    }
}

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

358
static void
359
print_string (Lisp_Object string, Lisp_Object printcharfun)
Jim Blandy's avatar
Jim Blandy committed
360
{
361
  if (EQ (printcharfun, Qt) || NILP (printcharfun))
362
    {
363
      EMACS_INT chars;
364

365 366 367
      if (print_escape_nonascii)
	string = string_escape_byte8 (string);

368
      if (STRING_MULTIBYTE (string))
369
	chars = SCHARS (string);
370 371 372 373
      else if (! print_escape_nonascii
	       && (EQ (printcharfun, Qt)
		   ? ! NILP (buffer_defaults.enable_multibyte_characters)
		   : ! NILP (current_buffer->enable_multibyte_characters)))
374 375 376 377 378
	{
	  /* If unibyte string STRING contains 8-bit codes, we must
	     convert STRING to a multibyte string containing the same
	     character codes.  */
	  Lisp_Object newstr;
379
	  EMACS_INT bytes;
380

381 382
	  chars = SBYTES (string);
	  bytes = parse_str_to_multibyte (SDATA (string), chars);
383 384 385
	  if (chars < bytes)
	    {
	      newstr = make_uninit_multibyte_string (chars, bytes);
386
	      memcpy (SDATA (newstr), SDATA (string), chars);
387
	      str_to_multibyte (SDATA (newstr), bytes, chars);
388 389 390
	      string = newstr;
	    }
	}
391
      else
392
	chars = SBYTES (string);
393

394 395 396
      if (EQ (printcharfun, Qt))
	{
	  /* Output to echo area.  */
397
	  EMACS_INT nbytes = SBYTES (string);
398 399 400 401 402 403 404
	  char *buffer;

	  /* Copy the string contents so that relocation of STRING by
	     GC does not cause trouble.  */
	  USE_SAFE_ALLOCA;

	  SAFE_ALLOCA (buffer, char *, nbytes);
405
	  memcpy (buffer, SDATA (string), nbytes);
406 407 408 409 410 411 412 413

	  strout (buffer, chars, SBYTES (string),
		  printcharfun, STRING_MULTIBYTE (string));

	  SAFE_FREE ();
	}
      else
	/* No need to copy, since output to print_buffer can't GC.  */
414
	strout (SSDATA (string),
415 416
		chars, SBYTES (string),
		printcharfun, STRING_MULTIBYTE (string));
417
    }
Jim Blandy's avatar
Jim Blandy committed
418 419
  else
    {
420 421
      /* Otherwise, string may be relocated by printing one char.
	 So re-fetch the string address for each character.  */
422
      EMACS_INT i;
423 424
      EMACS_INT size = SCHARS (string);
      EMACS_INT size_byte = SBYTES (string);
Jim Blandy's avatar
Jim Blandy committed
425 426
      struct gcpro gcpro1;
      GCPRO1 (string);
427 428
      if (size == size_byte)
	for (i = 0; i < size; i++)
429
	  PRINTCHAR (SREF (string, i));
430
      else
Kenichi Handa's avatar
Kenichi Handa committed
431
	for (i = 0; i < size_byte; )
432 433 434 435
	  {
	    /* Here, we must convert each multi-byte form to the
	       corresponding character code before handing it to PRINTCHAR.  */
	    int len;
436
	    int ch = STRING_CHAR_AND_LENGTH (SDATA (string) + i, len);
437 438 439
	    PRINTCHAR (ch);
	    i += len;
	  }
Jim Blandy's avatar
Jim Blandy committed
440 441 442 443 444
      UNGCPRO;
    }
}

DEFUN ("write-char", Fwrite_char, Swrite_char, 1, 2, 0,
445 446
       doc: /* Output character CHARACTER to stream PRINTCHARFUN.
PRINTCHARFUN defaults to the value of `standard-output' (which see).  */)
Dan Nicolaescu's avatar
Dan Nicolaescu committed
447
  (Lisp_Object character, Lisp_Object printcharfun)
Jim Blandy's avatar
Jim Blandy committed
448
{
449
  PRINTDECLARE;
Jim Blandy's avatar
Jim Blandy committed
450

Jim Blandy's avatar
Jim Blandy committed
451
  if (NILP (printcharfun))
Jim Blandy's avatar
Jim Blandy committed
452
    printcharfun = Vstandard_output;
453
  CHECK_NUMBER (character);
Jim Blandy's avatar
Jim Blandy committed
454
  PRINTPREPARE;
455
  PRINTCHAR (XINT (character));
Jim Blandy's avatar
Jim Blandy committed
456
  PRINTFINISH;
457
  return character;
Jim Blandy's avatar
Jim Blandy committed
458 459
}

460 461
/* Used from outside of print.c to print a block of SIZE
   single-byte chars at DATA on the default output stream.
Jim Blandy's avatar
Jim Blandy committed
462 463
   Do not use this on the contents of a Lisp string.  */

464
void
465
write_string (const char *data, int size)
Jim Blandy's avatar
Jim Blandy committed
466
{
467
  PRINTDECLARE;
Jim Blandy's avatar
Jim Blandy committed
468 469 470 471 472
  Lisp_Object printcharfun;

  printcharfun = Vstandard_output;

  PRINTPREPARE;
473
  strout (data, size, size, printcharfun, 0);
Jim Blandy's avatar
Jim Blandy committed
474 475 476
  PRINTFINISH;
}

Andreas Schwab's avatar
Andreas Schwab committed
477 478
/* Used to print a block of SIZE single-byte chars at DATA on a
   specified stream PRINTCHARFUN.
Jim Blandy's avatar
Jim Blandy committed
479 480
   Do not use this on the contents of a Lisp string.  */

Andreas Schwab's avatar
Andreas Schwab committed
481
static void
482
write_string_1 (const char *data, int size, Lisp_Object printcharfun)
Jim Blandy's avatar
Jim Blandy committed
483
{
484
  PRINTDECLARE;
Jim Blandy's avatar
Jim Blandy committed
485 486

  PRINTPREPARE;
487
  strout (data, size, size, printcharfun, 0);
Jim Blandy's avatar
Jim Blandy committed
488 489 490 491 492
  PRINTFINISH;
}


void
493
temp_output_buffer_setup (const char *bufname)
Jim Blandy's avatar
Jim Blandy committed
494
{
Juanma Barranquero's avatar
Juanma Barranquero committed
495
  int count = SPECPDL_INDEX ();
Jim Blandy's avatar
Jim Blandy committed
496 497 498
  register struct buffer *old = current_buffer;
  register Lisp_Object buf;

499 500
  record_unwind_protect (set_buffer_if_live, Fcurrent_buffer ());

Jim Blandy's avatar
Jim Blandy committed
501 502
  Fset_buffer (Fget_buffer_create (build_string (bufname)));

503
  Fkill_all_local_variables ();
504
  delete_all_overlays (current_buffer);
505
  current_buffer->directory = old->directory;
Jim Blandy's avatar
Jim Blandy committed
506
  current_buffer->read_only = Qnil;
507 508
  current_buffer->filename = Qnil;
  current_buffer->undo_list = Qt;
509 510
  eassert (current_buffer->overlays_before == NULL);
  eassert (current_buffer->overlays_after == NULL);
511 512
  current_buffer->enable_multibyte_characters
    = buffer_defaults.enable_multibyte_characters;
513 514
  specbind (Qinhibit_read_only, Qt);
  specbind (Qinhibit_modification_hooks, Qt);
Jim Blandy's avatar
Jim Blandy committed
515
  Ferase_buffer ();
516
  XSETBUFFER (buf, current_buffer);
Jim Blandy's avatar
Jim Blandy committed
517

518
  Frun_hooks (1, &Qtemp_buffer_setup_hook);
519 520 521 522

  unbind_to (count, Qnil);

  specbind (Qstandard_output, buf);
Jim Blandy's avatar
Jim Blandy committed
523 524 525
}

Lisp_Object
526
internal_with_output_to_temp_buffer (const char *bufname, Lisp_Object (*function) (Lisp_Object), Lisp_Object args)
Jim Blandy's avatar
Jim Blandy committed
527
{
Juanma Barranquero's avatar
Juanma Barranquero committed
528
  int count = SPECPDL_INDEX ();
Jim Blandy's avatar
Jim Blandy committed
529
  Lisp_Object buf, val;
530
  struct gcpro gcpro1;
Jim Blandy's avatar
Jim Blandy committed
531

532
  GCPRO1 (args);
Jim Blandy's avatar
Jim Blandy committed
533 534 535
  record_unwind_protect (Fset_buffer, Fcurrent_buffer ());
  temp_output_buffer_setup (bufname);
  buf = Vstandard_output;
536
  UNGCPRO;
Jim Blandy's avatar
Jim Blandy committed
537 538 539

  val = (*function) (args);

540
  GCPRO1 (val);
Jim Blandy's avatar
Jim Blandy committed
541
  temp_output_buffer_show (buf);
542
  UNGCPRO;
Jim Blandy's avatar
Jim Blandy committed
543 544 545 546

  return unbind_to (count, val);
}

547 548
DEFUN ("with-output-to-temp-buffer",
       Fwith_output_to_temp_buffer, Swith_output_to_temp_buffer,
Jim Blandy's avatar
Jim Blandy committed
549
       1, UNEVALLED, 0,
550
       doc: /* Bind `standard-output' to buffer BUFNAME, eval BODY, then show that buffer.
551 552 553 554 555 556 557 558 559 560 561 562 563 564 565 566 567 568 569 570 571 572 573 574

This construct makes buffer BUFNAME empty before running BODY.
It does not make the buffer current for BODY.
Instead it binds `standard-output' to that buffer, so that output
generated with `prin1' and similar functions in BODY goes into
the buffer.

At the end of BODY, this marks buffer BUFNAME unmodifed and displays
it in a window, but does not select it.  The normal way to do this is
by calling `display-buffer', then running `temp-buffer-show-hook'.
However, if `temp-buffer-show-function' is non-nil, it calls that
function instead (and does not run `temp-buffer-show-hook').  The
function gets one argument, the buffer to display.

The return value of `with-output-to-temp-buffer' is the value of the
last form in BODY.  If BODY does not finish normally, the buffer
BUFNAME is not displayed.

This runs the hook `temp-buffer-setup-hook' before BODY,
with the buffer BUFNAME temporarily current.  It runs the hook
`temp-buffer-show-hook' after displaying buffer BUFNAME, with that
buffer temporarily current, and the window that was used to display it
temporarily selected.  But it doesn't run `temp-buffer-show-hook'
if it uses `temp-buffer-show-function'.
575

576
usage: (with-output-to-temp-buffer BUFNAME BODY...)  */)
Dan Nicolaescu's avatar
Dan Nicolaescu committed
577
  (Lisp_Object args)
Jim Blandy's avatar
Jim Blandy committed
578 579 580
{
  struct gcpro gcpro1;
  Lisp_Object name;
Juanma Barranquero's avatar
Juanma Barranquero committed
581
  int count = SPECPDL_INDEX ();
Jim Blandy's avatar
Jim Blandy committed
582 583 584 585
  Lisp_Object buf, val;

  GCPRO1(args);
  name = Feval (Fcar (args));
586
  CHECK_STRING (name);
587
  temp_output_buffer_setup (SSDATA (name));
Jim Blandy's avatar
Jim Blandy committed
588
  buf = Vstandard_output;
589
  UNGCPRO;
Jim Blandy's avatar
Jim Blandy committed
590

591
  val = Fprogn (XCDR (args));
Jim Blandy's avatar
Jim Blandy committed
592

593
  GCPRO1 (val);
Jim Blandy's avatar
Jim Blandy committed
594
  temp_output_buffer_show (buf);
595
  UNGCPRO;
Jim Blandy's avatar
Jim Blandy committed
596 597 598

  return unbind_to (count, val);
}
599

Jim Blandy's avatar
Jim Blandy committed
600

601 602 603 604
static void print (Lisp_Object obj, register Lisp_Object printcharfun, int escapeflag);
static void print_preprocess (Lisp_Object obj);
static void print_preprocess_string (INTERVAL interval, Lisp_Object arg);
static void print_object (Lisp_Object obj, register Lisp_Object printcharfun, int escapeflag);
Jim Blandy's avatar
Jim Blandy committed
605 606

DEFUN ("terpri", Fterpri, Sterpri, 0, 1, 0,
607 608
       doc: /* Output a newline to stream PRINTCHARFUN.
If PRINTCHARFUN is omitted or nil, the value of `standard-output' is used.  */)
Dan Nicolaescu's avatar
Dan Nicolaescu committed
609
  (Lisp_Object printcharfun)
Jim Blandy's avatar
Jim Blandy committed
610
{
611
  PRINTDECLARE;
Jim Blandy's avatar
Jim Blandy committed
612

Jim Blandy's avatar
Jim Blandy committed
613
  if (NILP (printcharfun))
Jim Blandy's avatar
Jim Blandy committed
614 615 616 617 618 619 620 621
    printcharfun = Vstandard_output;
  PRINTPREPARE;
  PRINTCHAR ('\n');
  PRINTFINISH;
  return Qt;
}

DEFUN ("prin1", Fprin1, Sprin1, 1, 2, 0,
622 623
       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
624
can handle, whenever this is possible.  For complex objects, the behavior
Pavel Janík's avatar
Pavel Janík committed
625
is controlled by `print-level' and `print-length', which see.
626 627 628 629 630 631 632 633 634 635 636 637 638 639 640 641 642 643

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
644
  (Lisp_Object object, Lisp_Object printcharfun)
Jim Blandy's avatar
Jim Blandy committed
645
{
646
  PRINTDECLARE;
Jim Blandy's avatar
Jim Blandy committed
647

Jim Blandy's avatar
Jim Blandy committed
648
  if (NILP (printcharfun))
Jim Blandy's avatar
Jim Blandy committed
649 650
    printcharfun = Vstandard_output;
  PRINTPREPARE;
651
  print (object, printcharfun, 1);
Jim Blandy's avatar
Jim Blandy committed
652
  PRINTFINISH;
653
  return object;
Jim Blandy's avatar
Jim Blandy committed
654 655 656 657 658 659
}

/* 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,
660 661
       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
662
when necessary to make output that `read' can handle, whenever possible,
663 664
unless the optional second argument NOESCAPE is non-nil.  For complex objects,
the behavior is controlled by `print-level' and `print-length', which see.
665 666 667 668 669

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
670
  (Lisp_Object object, Lisp_Object noescape)
Jim Blandy's avatar
Jim Blandy committed
671
{
672
  Lisp_Object printcharfun;
673 674
  /* struct gcpro gcpro1, gcpro2; */
  Lisp_Object save_deactivate_mark;
675
  int count = SPECPDL_INDEX ();
Kenichi Handa's avatar
Kenichi Handa committed
676
  struct buffer *previous;
677 678

  specbind (Qinhibit_modification_hooks, Qt);
679

Kenichi Handa's avatar
Kenichi Handa committed
680 681 682 683 684 685 686 687 688 689 690 691 692 693 694 695
  {
    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;
    /* GCPRO2 (object, save_deactivate_mark); */
    abort_on_gc++;

    printcharfun = Vprin1_to_string_buffer;
    PRINTPREPARE;
    print (object, printcharfun, NILP (noescape));
    /* Make Vprin1_to_string_buffer be the default buffer after PRINTFINSH */
    PRINTFINISH;
  }
Jim Blandy's avatar
Jim Blandy committed
696

Kenichi Handa's avatar
Kenichi Handa committed
697
  previous = current_buffer;
Jim Blandy's avatar
Jim Blandy committed
698
  set_buffer_internal (XBUFFER (Vprin1_to_string_buffer));
699
  object = Fbuffer_string ();
700 701
  if (SBYTES (object) == SCHARS (object))
    STRING_SET_UNIBYTE (object);
Jim Blandy's avatar
Jim Blandy committed
702

703
  /* Note that this won't make prepare_to_modify_buffer call
Kenichi Handa's avatar
Kenichi Handa committed
704 705
     ask-user-about-supersession-threat because this buffer
     does not visit a file.  */
Jim Blandy's avatar
Jim Blandy committed
706
  Ferase_buffer ();
Kenichi Handa's avatar
Kenichi Handa committed
707
  set_buffer_internal (previous);
708

709 710
  Vdeactivate_mark = save_deactivate_mark;
  /* UNGCPRO; */
Jim Blandy's avatar
Jim Blandy committed
711

712 713
  abort_on_gc--;
  return unbind_to (count, object);
Jim Blandy's avatar
Jim Blandy committed
714 715 716
}

DEFUN ("princ", Fprinc, Sprinc, 1, 2, 0,
717 718 719 720 721 722 723 724 725 726 727 728 729 730 731 732 733 734 735 736 737
       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
738
  (Lisp_Object object, Lisp_Object printcharfun)
Jim Blandy's avatar
Jim Blandy committed
739
{
740
  PRINTDECLARE;
Jim Blandy's avatar
Jim Blandy committed
741

Jim Blandy's avatar
Jim Blandy committed
742
  if (NILP (printcharfun))
Jim Blandy's avatar
Jim Blandy committed
743 744
    printcharfun = Vstandard_output;
  PRINTPREPARE;
745
  print (object, printcharfun, 0);
Jim Blandy's avatar
Jim Blandy committed
746
  PRINTFINISH;
747
  return object;
Jim Blandy's avatar
Jim Blandy committed
748 749 750
}

DEFUN ("print", Fprint, Sprint, 1, 2, 0,
751 752
       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
753
can handle, whenever this is possible.  For complex objects, the behavior
Pavel Janík's avatar
Pavel Janík committed
754
is controlled by `print-level' and `print-length', which see.
755 756 757 758 759 760 761 762 763 764 765 766 767 768 769 770 771 772

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
773
  (Lisp_Object object, Lisp_Object printcharfun)
Jim Blandy's avatar
Jim Blandy committed
774
{
775
  PRINTDECLARE;
Jim Blandy's avatar
Jim Blandy committed
776 777
  struct gcpro gcpro1;

Jim Blandy's avatar
Jim Blandy committed
778
  if (NILP (printcharfun))
Jim Blandy's avatar
Jim Blandy committed
779
    printcharfun = Vstandard_output;
780
  GCPRO1 (object);
Jim Blandy's avatar
Jim Blandy committed
781 782
  PRINTPREPARE;
  PRINTCHAR ('\n');
783
  print (object, printcharfun, 1);
Jim Blandy's avatar
Jim Blandy committed
784 785 786
  PRINTCHAR ('\n');
  PRINTFINISH;
  UNGCPRO;
787
  return object;
Jim Blandy's avatar
Jim Blandy committed
788 789 790 791 792 793
}

/* The subroutine object for external-debugging-output is kept here
   for the convenience of the debugger.  */
Lisp_Object Qexternal_debugging_output;

Jim Blandy's avatar
Jim Blandy committed
794
DEFUN ("external-debugging-output", Fexternal_debugging_output, Sexternal_debugging_output, 1, 1, 0,
795 796 797
       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
798
  (Lisp_Object character)
Jim Blandy's avatar
Jim Blandy committed
799
{
800
  CHECK_NUMBER (character);
801
  putc ((int) XINT (character), stderr);
802 803 804

#ifdef WINDOWSNT
  /* Send the output to a debugger (nothing happens if there isn't one).  */
805 806 807 808 809
  if (print_output_debug_flag)
    {
      char buf[2] = {(char) XINT (character), '\0'};
      OutputDebugString (buf);
    }
810 811
#endif

Jim Blandy's avatar
Jim Blandy committed
812 813
  return character;
}
814

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

818
void
819
debug_output_compilation_hack (int x)
820 821 822
{
  print_output_debug_flag = x;
}
Kenichi Handa's avatar
Kenichi Handa committed
823

Andreas Schwab's avatar
Andreas Schwab committed
824
#if defined (GNU_LINUX)
Kenichi Handa's avatar
Kenichi Handa committed
825 826 827 828 829 830 831 832 833 834 835 836 837 838

/* 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

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
839
append to existing target file.  */)
Dan Nicolaescu's avatar
Dan Nicolaescu committed
840
  (Lisp_Object file, Lisp_Object append)
Kenichi Handa's avatar
Kenichi Handa committed
841 842
{
  if (initial_stderr_stream != NULL)
YAMAMOTO Mitsuharu's avatar
YAMAMOTO Mitsuharu committed
843 844 845 846 847
    {
      BLOCK_INPUT;
      fclose (stderr);
      UNBLOCK_INPUT;
    }
Kenichi Handa's avatar
Kenichi Handa committed
848 849 850 851 852 853 854
  stderr = initial_stderr_stream;
  initial_stderr_stream = NULL;

  if (STRINGP (file))
    {
      file = Fexpand_file_name (file, Qnil);
      initial_stderr_stream = stderr;
Andreas Schwab's avatar
Andreas Schwab committed
855
      stderr = fopen (SDATA (file), NILP (append) ? "w" : "a");
Kenichi Handa's avatar
Kenichi Handa committed
856 857 858 859 860 861 862 863 864 865 866 867 868
      if (stderr == NULL)
	{
	  stderr = initial_stderr_stream;
	  initial_stderr_stream = NULL;
	  report_file_error ("Cannot open debugging output stream",
			     Fcons (file, Qnil));
	}
    }
  return Qnil;
}
#endif /* GNU_LINUX */


869 870 871
/* This is the interface for debugging printing.  */

void
872
debug_print (Lisp_Object arg)
873 874
{
  Fprin1 (arg, Qexternal_debugging_output);
875
  fprintf (stderr, "\r\n");
876
}
877 878

void
879
safe_debug_print (Lisp_Object arg)
880 881 882 883 884 885 886 887
{
  int valid = valid_lisp_object_p (arg);

  if (valid > 0)
    debug_print (arg);
  else
    fprintf (stderr, "#<%s_LISP_OBJECT 0x%08lx>\r\n",
	     !valid ? "INVALID" : "SOME",
888
	     (unsigned long) XHASH (arg)