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

3
Copyright (C) 1985-1986, 1988, 1993-1995, 1997-2012
4
  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
static Lisp_Object Qtemp_buffer_setup_hook;
43

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

46
static Lisp_Object Qfloat_output_format;
Paul Eggert's avatar
Paul Eggert committed
47 48 49

#include <math.h>
#include <float.h>
Paul Eggert's avatar
Paul Eggert committed
50
#include <ftoastr.h>
Paul Eggert's avatar
Paul Eggert committed
51 52 53 54 55 56

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

Jim Blandy's avatar
Jim Blandy committed
57
/* Avoid actual stack overflow in print.  */
58
static int print_depth;
Jim Blandy's avatar
Jim Blandy committed
59

60
/* Level of nesting inside outputting backquote in new style.  */
61
static int new_backquote_output;
62

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

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

/* Size allocated in print_buffer.  */
72
static EMACS_INT print_buffer_size;
73
/* Chars stored in print_buffer.  */
74
static EMACS_INT print_buffer_pos;
75
/* Bytes stored in print_buffer.  */
76
static EMACS_INT print_buffer_pos_byte;
77

78
Lisp_Object Qprint_escape_newlines;
79
static Lisp_Object Qprint_escape_multibyte, Qprint_escape_nonascii;
80

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

92
/* GDB resets this to zero on W32 to disable OutputDebugString calls.  */
93
int print_output_debug_flag EXTERNALLY_VISIBLE = 1;
94

Jim Blandy's avatar
Jim Blandy committed
95

96
/* Low level output routines for characters and strings */
Jim Blandy's avatar
Jim Blandy committed
97 98

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

#define PRINTDECLARE							\
   struct buffer *old = current_buffer;					\
107 108
   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
109
   int specpdl_count = SPECPDL_INDEX ();				\
110
   int free_print_buffer = 0;						\
Tom Tromey's avatar
Tom Tromey committed
111
   int multibyte = !NILP (BVAR (current_buffer, enable_multibyte_characters));	\
112 113
   Lisp_Object original

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

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

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

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

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

216 217 218 219 220

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

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

232
      QUIT;
233

234
      if (NILP (fun))
235
	{
236 237 238 239 240 241 242 243 244
	  if (print_buffer_size - len <= print_buffer_pos_byte)
	    {
	      ptrdiff_t new_size;
	      if (STRING_BYTES_BOUND / 2 < print_buffer_size)
		string_overflow ();
	      new_size = print_buffer_size * 2;
	      print_buffer = (char *) xrealloc (print_buffer, new_size);
	      print_buffer_size = new_size;
	    }
245
	  memcpy (print_buffer + print_buffer_pos_byte, str, len);
246 247
	  print_buffer_pos += 1;
	  print_buffer_pos_byte += len;
248
	}
249
      else if (noninteractive)
250
	{
251 252
	  fwrite (str, 1, len, stdout);
	  noninteractive_need_newline = 1;
253
	}
254
      else
255
	{
256
	  int multibyte_p
Tom Tromey's avatar
Tom Tromey committed
257
	    = !NILP (BVAR (current_buffer, enable_multibyte_characters));
258

259
	  setup_echo_area_for_printing (multibyte_p);
260
	  insert_char (ch);
261
	  message_dolog ((char *) str, len, 0, multibyte_p);
262
	}
Jim Blandy's avatar
Jim Blandy committed
263 264 265
    }
}

266 267 268 269 270 271 272

/* 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
273 274 275 276
   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.  */
277

Jim Blandy's avatar
Jim Blandy committed
278
static void
279
strout (const char *ptr, EMACS_INT size, EMACS_INT size_byte,
280
	Lisp_Object printcharfun)
Jim Blandy's avatar
Jim Blandy committed
281
{
Karl Heuer's avatar
Karl Heuer committed
282
  if (size < 0)
283
    size_byte = size = strlen (ptr);
Karl Heuer's avatar
Karl Heuer committed
284

285
  if (NILP (printcharfun))
Jim Blandy's avatar
Jim Blandy committed
286
    {
287
      if (print_buffer_size - size_byte < print_buffer_pos_byte)
288
	{
289 290 291 292 293 294
	  ptrdiff_t new_size;
	  if (STRING_BYTES_BOUND / 2 - size_byte < print_buffer_size)
	    string_overflow ();
	  new_size = print_buffer_size * 2 + size_byte;
	  print_buffer = (char *) xrealloc (print_buffer, new_size);
	  print_buffer_size = new_size;
295
	}
296
      memcpy (print_buffer + print_buffer_pos_byte, ptr, size_byte);
297
      print_buffer_pos += size;
298
      print_buffer_pos_byte += size_byte;
Jim Blandy's avatar
Jim Blandy committed
299
    }
300
  else if (noninteractive && EQ (printcharfun, Qt))
Jim Blandy's avatar
Jim Blandy committed
301
    {
302 303 304 305 306 307 308 309 310 311
      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
Tom Tromey's avatar
Tom Tromey committed
312
	= !NILP (BVAR (current_buffer, enable_multibyte_characters));
313

314
      setup_echo_area_for_printing (multibyte_p);
315
      message_dolog (ptr, size_byte, 0, multibyte_p);
316

317
      if (size == size_byte)
Jim Blandy's avatar
Jim Blandy committed
318
	{
319
	  for (i = 0; i < size; ++i)
Andreas Schwab's avatar
Andreas Schwab committed
320
	    insert_char ((unsigned char) *ptr++);
Jim Blandy's avatar
Jim Blandy committed
321
	}
322
      else
Jim Blandy's avatar
Jim Blandy committed
323
	{
324 325
	  int len;
	  for (i = 0; i < size_byte; i += len)
326
	    {
327 328
	      int ch = STRING_CHAR_AND_LENGTH ((const unsigned char *) ptr + i,
					       len);
329
	      insert_char (ch);
330
	    }
Jim Blandy's avatar
Jim Blandy committed
331
	}
332 333 334 335
    }
  else
    {
      /* PRINTCHARFUN is a Lisp function.  */
336
      EMACS_INT i = 0;
Jim Blandy's avatar
Jim Blandy committed
337

338
      if (size == size_byte)
339
	{
340
	  while (i < size_byte)
341
	    {
342 343
	      int ch = ptr[i++];
	      PRINTCHAR (ch);
344 345
	    }
	}
346
      else
Karl Heuer's avatar
Karl Heuer committed
347
	{
348 349 350 351 352 353
	  while (i < size_byte)
	    {
	      /* Here, we must convert each multi-byte form to the
		 corresponding character code before handing it to
		 PRINTCHAR.  */
	      int len;
354 355
	      int ch = STRING_CHAR_AND_LENGTH ((const unsigned char *) ptr + i,
					       len);
356 357 358
	      PRINTCHAR (ch);
	      i += len;
	    }
Karl Heuer's avatar
Karl Heuer committed
359
	}
Jim Blandy's avatar
Jim Blandy committed
360 361 362 363
    }
}

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

367
static void
368
print_string (Lisp_Object string, Lisp_Object printcharfun)
Jim Blandy's avatar
Jim Blandy committed
369
{
370
  if (EQ (printcharfun, Qt) || NILP (printcharfun))
371
    {
372
      EMACS_INT chars;
373

374 375 376
      if (print_escape_nonascii)
	string = string_escape_byte8 (string);

377
      if (STRING_MULTIBYTE (string))
378
	chars = SCHARS (string);
379 380
      else if (! print_escape_nonascii
	       && (EQ (printcharfun, Qt)
Tom Tromey's avatar
Tom Tromey committed
381 382
		   ? ! NILP (BVAR (&buffer_defaults, enable_multibyte_characters))
		   : ! NILP (BVAR (current_buffer, enable_multibyte_characters))))
383 384 385 386 387
	{
	  /* If unibyte string STRING contains 8-bit codes, we must
	     convert STRING to a multibyte string containing the same
	     character codes.  */
	  Lisp_Object newstr;
388
	  EMACS_INT bytes;
389

390
	  chars = SBYTES (string);
391
	  bytes = count_size_as_multibyte (SDATA (string), chars);
392 393 394
	  if (chars < bytes)
	    {
	      newstr = make_uninit_multibyte_string (chars, bytes);
395
	      memcpy (SDATA (newstr), SDATA (string), chars);
396
	      str_to_multibyte (SDATA (newstr), bytes, chars);
397 398 399
	      string = newstr;
	    }
	}
400
      else
401
	chars = SBYTES (string);
402

403 404 405
      if (EQ (printcharfun, Qt))
	{
	  /* Output to echo area.  */
406
	  EMACS_INT nbytes = SBYTES (string);
407 408 409 410 411 412 413
	  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);
414
	  memcpy (buffer, SDATA (string), nbytes);
415

416
	  strout (buffer, chars, SBYTES (string), printcharfun);
417 418 419 420 421

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

Jim Blandy's avatar
Jim Blandy committed
457
  if (NILP (printcharfun))
Jim Blandy's avatar
Jim Blandy committed
458
    printcharfun = Vstandard_output;
459
  CHECK_NUMBER (character);
Jim Blandy's avatar
Jim Blandy committed
460
  PRINTPREPARE;
461
  PRINTCHAR (XINT (character));
Jim Blandy's avatar
Jim Blandy committed
462
  PRINTFINISH;
463
  return character;
Jim Blandy's avatar
Jim Blandy committed
464 465
}

466 467
/* 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
468 469
   Do not use this on the contents of a Lisp string.  */

470
void
471
write_string (const char *data, int size)
Jim Blandy's avatar
Jim Blandy committed
472
{
473
  PRINTDECLARE;
Jim Blandy's avatar
Jim Blandy committed
474 475 476 477 478
  Lisp_Object printcharfun;

  printcharfun = Vstandard_output;

  PRINTPREPARE;
479
  strout (data, size, size, printcharfun);
Jim Blandy's avatar
Jim Blandy committed
480 481 482
  PRINTFINISH;
}

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

Andreas Schwab's avatar
Andreas Schwab committed
487
static void
488
write_string_1 (const char *data, int size, Lisp_Object printcharfun)
Jim Blandy's avatar
Jim Blandy committed
489
{
490
  PRINTDECLARE;
Jim Blandy's avatar
Jim Blandy committed
491 492

  PRINTPREPARE;
493
  strout (data, size, size, printcharfun);
Jim Blandy's avatar
Jim Blandy committed
494 495 496 497 498
  PRINTFINISH;
}


void
499
temp_output_buffer_setup (const char *bufname)
Jim Blandy's avatar
Jim Blandy committed
500
{
Juanma Barranquero's avatar
Juanma Barranquero committed
501
  int count = SPECPDL_INDEX ();
Jim Blandy's avatar
Jim Blandy committed
502 503 504
  register struct buffer *old = current_buffer;
  register Lisp_Object buf;

505 506
  record_unwind_protect (set_buffer_if_live, Fcurrent_buffer ());

Jim Blandy's avatar
Jim Blandy committed
507 508
  Fset_buffer (Fget_buffer_create (build_string (bufname)));

509
  Fkill_all_local_variables ();
510
  delete_all_overlays (current_buffer);
Tom Tromey's avatar
Tom Tromey committed
511 512 513 514
  BVAR (current_buffer, directory) = BVAR (old, directory);
  BVAR (current_buffer, read_only) = Qnil;
  BVAR (current_buffer, filename) = Qnil;
  BVAR (current_buffer, undo_list) = Qt;
515 516
  eassert (current_buffer->overlays_before == NULL);
  eassert (current_buffer->overlays_after == NULL);
Tom Tromey's avatar
Tom Tromey committed
517 518
  BVAR (current_buffer, enable_multibyte_characters)
    = BVAR (&buffer_defaults, enable_multibyte_characters);
519 520
  specbind (Qinhibit_read_only, Qt);
  specbind (Qinhibit_modification_hooks, Qt);
Jim Blandy's avatar
Jim Blandy committed
521
  Ferase_buffer ();
522
  XSETBUFFER (buf, current_buffer);
Jim Blandy's avatar
Jim Blandy committed
523

524
  Frun_hooks (1, &Qtemp_buffer_setup_hook);
525 526 527 528

  unbind_to (count, Qnil);

  specbind (Qstandard_output, buf);
Jim Blandy's avatar
Jim Blandy committed
529 530
}

531 532 533 534
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
535

Paul Eggert's avatar
Paul Eggert committed
536
DEFUN ("terpri", Fterpri, Sterpri, 0, 1, 0,
537 538
       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
539
  (Lisp_Object printcharfun)
Jim Blandy's avatar
Jim Blandy committed
540
{
541
  PRINTDECLARE;
Jim Blandy's avatar
Jim Blandy committed
542

Jim Blandy's avatar
Jim Blandy committed
543
  if (NILP (printcharfun))
Jim Blandy's avatar
Jim Blandy committed
544 545 546 547 548 549 550
    printcharfun = Vstandard_output;
  PRINTPREPARE;
  PRINTCHAR ('\n');
  PRINTFINISH;
  return Qt;
}

Paul Eggert's avatar
Paul Eggert committed
551
DEFUN ("prin1", Fprin1, Sprin1, 1, 2, 0,
552 553
       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
554
can handle, whenever this is possible.  For complex objects, the behavior
Pavel Janík's avatar
Pavel Janík committed
555
is controlled by `print-level' and `print-length', which see.
556 557 558 559 560 561 562 563 564 565 566 567 568 569 570 571 572 573

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
574
  (Lisp_Object object, Lisp_Object printcharfun)
Jim Blandy's avatar
Jim Blandy committed
575
{
576
  PRINTDECLARE;
Jim Blandy's avatar
Jim Blandy committed
577

Jim Blandy's avatar
Jim Blandy committed
578
  if (NILP (printcharfun))
Jim Blandy's avatar
Jim Blandy committed
579 580
    printcharfun = Vstandard_output;
  PRINTPREPARE;
581
  print (object, printcharfun, 1);
Jim Blandy's avatar
Jim Blandy committed
582
  PRINTFINISH;
583
  return object;
Jim Blandy's avatar
Jim Blandy committed
584 585 586 587 588
}

/* 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
589
DEFUN ("prin1-to-string", Fprin1_to_string, Sprin1_to_string, 1, 2, 0,
590 591
       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
592
when necessary to make output that `read' can handle, whenever possible,
593 594
unless the optional second argument NOESCAPE is non-nil.  For complex objects,
the behavior is controlled by `print-level' and `print-length', which see.
595 596 597 598 599

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
600
  (Lisp_Object object, Lisp_Object noescape)
Jim Blandy's avatar
Jim Blandy committed
601
{
602
  Lisp_Object printcharfun;
603 604
  /* struct gcpro gcpro1, gcpro2; */
  Lisp_Object save_deactivate_mark;
605
  int count = SPECPDL_INDEX ();
Kenichi Handa's avatar
Kenichi Handa committed
606
  struct buffer *previous;
607 608

  specbind (Qinhibit_modification_hooks, Qt);
609

Kenichi Handa's avatar
Kenichi Handa committed
610 611 612 613 614 615 616 617 618 619 620 621 622
  {
    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));
Paul Eggert's avatar
Paul Eggert committed
623
    /* Make Vprin1_to_string_buffer be the default buffer after PRINTFINISH */
Kenichi Handa's avatar
Kenichi Handa committed
624 625
    PRINTFINISH;
  }
Jim Blandy's avatar
Jim Blandy committed
626

Kenichi Handa's avatar
Kenichi Handa committed
627
  previous = current_buffer;
Jim Blandy's avatar
Jim Blandy committed
628
  set_buffer_internal (XBUFFER (Vprin1_to_string_buffer));
629
  object = Fbuffer_string ();
630 631
  if (SBYTES (object) == SCHARS (object))
    STRING_SET_UNIBYTE (object);
Jim Blandy's avatar
Jim Blandy committed
632

633
  /* Note that this won't make prepare_to_modify_buffer call
Kenichi Handa's avatar
Kenichi Handa committed
634 635
     ask-user-about-supersession-threat because this buffer
     does not visit a file.  */
Jim Blandy's avatar
Jim Blandy committed
636
  Ferase_buffer ();
Kenichi Handa's avatar
Kenichi Handa committed
637
  set_buffer_internal (previous);
638

639 640
  Vdeactivate_mark = save_deactivate_mark;
  /* UNGCPRO; */
Jim Blandy's avatar
Jim Blandy committed
641

642 643
  abort_on_gc--;
  return unbind_to (count, object);
Jim Blandy's avatar
Jim Blandy committed
644 645
}

646
DEFUN ("princ", Fprinc, Sprinc, 1, 2, 0,
647 648 649 650 651 652 653 654 655 656 657 658 659 660 661 662 663 664 665 666 667
       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
668
  (Lisp_Object object, Lisp_Object printcharfun)
Jim Blandy's avatar
Jim Blandy committed
669
{
670
  PRINTDECLARE;
Jim Blandy's avatar
Jim Blandy committed
671

Jim Blandy's avatar
Jim Blandy committed
672
  if (NILP (printcharfun))
Jim Blandy's avatar
Jim Blandy committed
673 674
    printcharfun = Vstandard_output;
  PRINTPREPARE;
675
  print (object, printcharfun, 0);
Jim Blandy's avatar
Jim Blandy committed
676
  PRINTFINISH;
677
  return object;
Jim Blandy's avatar
Jim Blandy committed
678 679
}

Paul Eggert's avatar
Paul Eggert committed
680
DEFUN ("print", Fprint, Sprint, 1, 2, 0,
681 682
       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
683
can handle, whenever this is possible.  For complex objects, the behavior
Pavel Janík's avatar
Pavel Janík committed
684
is controlled by `print-level' and `print-length', which see.
685 686 687 688 689 690 691 692 693 694 695 696 697 698 699 700 701 702

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
703
  (Lisp_Object object, Lisp_Object printcharfun)
Jim Blandy's avatar
Jim Blandy committed
704
{
705
  PRINTDECLARE;
Jim Blandy's avatar
Jim Blandy committed
706 707
  struct gcpro gcpro1;

Jim Blandy's avatar
Jim Blandy committed
708
  if (NILP (printcharfun))
Jim Blandy's avatar
Jim Blandy committed
709
    printcharfun = Vstandard_output;
710
  GCPRO1 (object);
Jim Blandy's avatar
Jim Blandy committed
711 712
  PRINTPREPARE;
  PRINTCHAR ('\n');
713
  print (object, printcharfun, 1);
Jim Blandy's avatar
Jim Blandy committed
714 715 716
  PRINTCHAR ('\n');
  PRINTFINISH;
  UNGCPRO;
717
  return object;
Jim Blandy's avatar
Jim Blandy committed
718 719 720 721 722 723
}

/* 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
724
DEFUN ("external-debugging-output", Fexternal_debugging_output, Sexternal_debugging_output, 1, 1, 0,
725 726 727
       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
728
  (Lisp_Object character)
Jim Blandy's avatar
Jim Blandy committed
729
{
730
  CHECK_NUMBER (character);
731
  putc ((int) XINT (character), stderr);
732 733 734

#ifdef WINDOWSNT
  /* Send the output to a debugger (nothing happens if there isn't one).  */
735 736 737 738 739
  if (print_output_debug_flag)
    {
      char buf[2] = {(char) XINT (character), '\0'};
      OutputDebugString (buf);
    }
740 741
#endif

Jim Blandy's avatar
Jim Blandy committed
742 743
  return character;
}
744

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

Paul Eggert's avatar
Paul Eggert committed
748
extern void debug_output_compilation_hack (int) EXTERNALLY_VISIBLE;
749
void
750
debug_output_compilation_hack (int x)
751 752 753
{
  print_output_debug_flag = x;
}
Kenichi Handa's avatar
Kenichi Handa committed
754

Andreas Schwab's avatar
Andreas Schwab committed
755
#if defined (GNU_LINUX)
Kenichi Handa's avatar
Kenichi Handa committed
756 757 758 759 760 761

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

762
static FILE *initial_stderr_stream = NULL;
Kenichi Handa's avatar
Kenichi Handa committed
763 764 765 766 767 768 769

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
770
append to existing target file.  */)
Dan Nicolaescu's avatar
Dan Nicolaescu committed
771
  (Lisp_Object file, Lisp_Object append)
Kenichi Handa's avatar
Kenichi Handa committed
772 773
{
  if (initial_stderr_stream != NULL)
YAMAMOTO Mitsuharu's avatar
YAMAMOTO Mitsuharu committed
774 775 776 777 778
    {
      BLOCK_INPUT;
      fclose (stderr);
      UNBLOCK_INPUT;
    }
Kenichi Handa's avatar
Kenichi Handa committed
779 780 781 782 783 784 785
  stderr = initial_stderr_stream;
  initial_stderr_stream = NULL;

  if (STRINGP (file))
    {
      file = Fexpand_file_name (file, Qnil);
      initial_stderr_stream = stderr;
786
      stderr = fopen (SSDATA (file), NILP (append) ? "w" : "a");
Kenichi Handa's avatar
Kenichi Handa committed
787 788 789 790 791 792 793 794 795 796 797 798 799
      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 */


800 801 802
/* This is the interface for debugging printing.  */

void
803
debug_print (Lisp_Object arg)
804 805
{
  Fprin1 (arg, Qexternal_debugging_output);
806
  fprintf (stderr, "\r\n");
807
}
808

809
void safe_debug_print (Lisp_Object) EXTERNALLY_VISIBLE;
810
void
811
safe_debug_print (Lisp_Object arg)
812 813 814 815 816 817
{
  int valid = valid_lisp_object_p (arg);

  if (valid > 0)
    debug_print (arg);
  else
818
    fprintf (stderr, "#<%s_LISP_OBJECT 0x%08"pI"x>\r\n",
819
	     !valid ? "INVALID" : "SOME",
820
	     XHASH (arg));
821 822
}

Jim Blandy's avatar
Jim Blandy committed
823

Paul Eggert's avatar
Paul Eggert committed
824
DEFUN ("error-message-string", Ferror_message_string, Serror_message_string,
825
       1, 1, 0,
Kenichi Handa's avatar
Kenichi Handa committed
826 827 828
       doc: /* Convert an error value (ERROR-SYMBOL . DATA) to an error message.
See Info anchor `(elisp)Definition of signal' for some details on how this
error message is constructed.  */)
Dan Nicolaescu's avatar
Dan Nicolaescu committed
829
  (Lisp_Object obj)
830 831
{
  struct buffer *old = current_buffer;
832
  Lisp_Object value;
833 834
  struct gcpro gcpro1;

835 836