1/* Lisp object printing and output streams. 2 Copyright (C) 1985, 1986, 1988, 1993, 1994, 1995, 1997, 3 1998, 1999, 2000, 2001, 2002, 2003, 2004, 4 2005, 2006, 2007 Free Software Foundation, Inc. 5 6This file is part of GNU Emacs. 7 8GNU Emacs is free software; you can redistribute it and/or modify 9it under the terms of the GNU General Public License as published by 10the Free Software Foundation; either version 2, or (at your option) 11any later version. 12 13GNU Emacs is distributed in the hope that it will be useful, 14but WITHOUT ANY WARRANTY; without even the implied warranty of 15MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 16GNU General Public License for more details. 17 18You should have received a copy of the GNU General Public License 19along with GNU Emacs; see the file COPYING. If not, write to 20the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, 21Boston, MA 02110-1301, USA. */ 22 23 24#include <config.h> 25#include <stdio.h> 26#include "lisp.h" 27#include "buffer.h" 28#include "charset.h" 29#include "keyboard.h" 30#include "frame.h" 31#include "window.h" 32#include "process.h" 33#include "dispextern.h" 34#include "termchar.h" 35#include "intervals.h" 36#include "blockinput.h" 37 38Lisp_Object Vstandard_output, Qstandard_output; 39 40Lisp_Object Qtemp_buffer_setup_hook; 41 42/* These are used to print like we read. */ 43extern Lisp_Object Qbackquote, Qcomma, Qcomma_at, Qcomma_dot, Qfunction; 44 45Lisp_Object Vfloat_output_format, Qfloat_output_format; 46 47/* Work around a problem that happens because math.h on hpux 7 48 defines two static variables--which, in Emacs, are not really static, 49 because `static' is defined as nothing. The problem is that they are 50 defined both here and in lread.c. 51 These macros prevent the name conflict. */ 52#if defined (HPUX) && !defined (HPUX8) 53#define _MAXLDBL print_maxldbl 54#define _NMAXLDBL print_nmaxldbl 55#endif 56 57#include <math.h> 58 59#if STDC_HEADERS 60#include <float.h> 61#endif 62 63/* Default to values appropriate for IEEE floating point. */ 64#ifndef FLT_RADIX 65#define FLT_RADIX 2 66#endif 67#ifndef DBL_MANT_DIG 68#define DBL_MANT_DIG 53 69#endif 70#ifndef DBL_DIG 71#define DBL_DIG 15 72#endif 73#ifndef DBL_MIN 74#define DBL_MIN 2.2250738585072014e-308 75#endif 76 77#ifdef DBL_MIN_REPLACEMENT 78#undef DBL_MIN 79#define DBL_MIN DBL_MIN_REPLACEMENT 80#endif 81 82/* Define DOUBLE_DIGITS_BOUND, an upper bound on the number of decimal digits 83 needed to express a float without losing information. 84 The general-case formula is valid for the usual case, IEEE floating point, 85 but many compilers can't optimize the formula to an integer constant, 86 so make a special case for it. */ 87#if FLT_RADIX == 2 && DBL_MANT_DIG == 53 88#define DOUBLE_DIGITS_BOUND 17 /* IEEE floating point */ 89#else 90#define DOUBLE_DIGITS_BOUND ((int) ceil (log10 (pow (FLT_RADIX, DBL_MANT_DIG)))) 91#endif 92 93/* Avoid actual stack overflow in print. */ 94int print_depth; 95 96/* Nonzero if inside outputting backquote in old style. */ 97int old_backquote_output; 98 99/* Detect most circularities to print finite output. */ 100#define PRINT_CIRCLE 200 101Lisp_Object being_printed[PRINT_CIRCLE]; 102 103/* When printing into a buffer, first we put the text in this 104 block, then insert it all at once. */ 105char *print_buffer; 106 107/* Size allocated in print_buffer. */ 108int print_buffer_size; 109/* Chars stored in print_buffer. */ 110int print_buffer_pos; 111/* Bytes stored in print_buffer. */ 112int print_buffer_pos_byte; 113 114/* Maximum length of list to print in full; noninteger means 115 effectively infinity */ 116 117Lisp_Object Vprint_length; 118 119/* Maximum depth of list to print in full; noninteger means 120 effectively infinity. */ 121 122Lisp_Object Vprint_level; 123 124/* Nonzero means print newlines in strings as \n. */ 125 126int print_escape_newlines; 127 128/* Nonzero means to print single-byte non-ascii characters in strings as 129 octal escapes. */ 130 131int print_escape_nonascii; 132 133/* Nonzero means to print multibyte characters in strings as hex escapes. */ 134 135int print_escape_multibyte; 136 137Lisp_Object Qprint_escape_newlines; 138Lisp_Object Qprint_escape_multibyte, Qprint_escape_nonascii; 139 140/* Nonzero means print (quote foo) forms as 'foo, etc. */ 141 142int print_quoted; 143 144/* Non-nil means print #: before uninterned symbols. */ 145 146Lisp_Object Vprint_gensym; 147 148/* Non-nil means print recursive structures using #n= and #n# syntax. */ 149 150Lisp_Object Vprint_circle; 151 152/* Non-nil means keep continuous number for #n= and #n# syntax 153 between several print functions. */ 154 155Lisp_Object Vprint_continuous_numbering; 156 157/* Vprint_number_table is a vector like [OBJ1 STAT1 OBJ2 STAT2 ...], 158 where OBJn are objects going to be printed, and STATn are their status, 159 which may be different meanings during process. See the comments of 160 the functions print and print_preprocess for details. 161 print_number_index keeps the last position the next object should be added, 162 twice of which is the actual vector position in Vprint_number_table. */ 163int print_number_index; 164Lisp_Object Vprint_number_table; 165 166/* PRINT_NUMBER_OBJECT returns the I'th object in Vprint_number_table TABLE. 167 PRINT_NUMBER_STATUS returns the status of the I'th object in TABLE. 168 See the comment of the variable Vprint_number_table. */ 169#define PRINT_NUMBER_OBJECT(table,i) XVECTOR ((table))->contents[(i) * 2] 170#define PRINT_NUMBER_STATUS(table,i) XVECTOR ((table))->contents[(i) * 2 + 1] 171 172/* Nonzero means print newline to stdout before next minibuffer message. 173 Defined in xdisp.c */ 174 175extern int noninteractive_need_newline; 176 177extern int minibuffer_auto_raise; 178 179#ifdef MAX_PRINT_CHARS 180static int print_chars; 181static int max_print; 182#endif /* MAX_PRINT_CHARS */ 183 184void print_interval (); 185 186/* GDB resets this to zero on W32 to disable OutputDebugString calls. */ 187int print_output_debug_flag = 1; 188 189 190/* Low level output routines for characters and strings */ 191 192/* Lisp functions to do output using a stream 193 must have the stream in a variable called printcharfun 194 and must start with PRINTPREPARE, end with PRINTFINISH, 195 and use PRINTDECLARE to declare common variables. 196 Use PRINTCHAR to output one character, 197 or call strout to output a block of characters. */ 198 199#define PRINTDECLARE \ 200 struct buffer *old = current_buffer; \ 201 int old_point = -1, start_point = -1; \ 202 int old_point_byte = -1, start_point_byte = -1; \ 203 int specpdl_count = SPECPDL_INDEX (); \ 204 int free_print_buffer = 0; \ 205 int multibyte = !NILP (current_buffer->enable_multibyte_characters); \ 206 Lisp_Object original 207 208#define PRINTPREPARE \ 209 original = printcharfun; \ 210 if (NILP (printcharfun)) printcharfun = Qt; \ 211 if (BUFFERP (printcharfun)) \ 212 { \ 213 if (XBUFFER (printcharfun) != current_buffer) \ 214 Fset_buffer (printcharfun); \ 215 printcharfun = Qnil; \ 216 } \ 217 if (MARKERP (printcharfun)) \ 218 { \ 219 EMACS_INT marker_pos; \ 220 if (! XMARKER (printcharfun)->buffer) \ 221 error ("Marker does not point anywhere"); \ 222 if (XMARKER (printcharfun)->buffer != current_buffer) \ 223 set_buffer_internal (XMARKER (printcharfun)->buffer); \ 224 marker_pos = marker_position (printcharfun); \ 225 if (marker_pos < BEGV || marker_pos > ZV) \ 226 error ("Marker is outside the accessible part of the buffer"); \ 227 old_point = PT; \ 228 old_point_byte = PT_BYTE; \ 229 SET_PT_BOTH (marker_pos, \ 230 marker_byte_position (printcharfun)); \ 231 start_point = PT; \ 232 start_point_byte = PT_BYTE; \ 233 printcharfun = Qnil; \ 234 } \ 235 if (NILP (printcharfun)) \ 236 { \ 237 Lisp_Object string; \ 238 if (NILP (current_buffer->enable_multibyte_characters) \ 239 && ! print_escape_multibyte) \ 240 specbind (Qprint_escape_multibyte, Qt); \ 241 if (! NILP (current_buffer->enable_multibyte_characters) \ 242 && ! print_escape_nonascii) \ 243 specbind (Qprint_escape_nonascii, Qt); \ 244 if (print_buffer != 0) \ 245 { \ 246 string = make_string_from_bytes (print_buffer, \ 247 print_buffer_pos, \ 248 print_buffer_pos_byte); \ 249 record_unwind_protect (print_unwind, string); \ 250 } \ 251 else \ 252 { \ 253 print_buffer_size = 1000; \ 254 print_buffer = (char *) xmalloc (print_buffer_size); \ 255 free_print_buffer = 1; \ 256 } \ 257 print_buffer_pos = 0; \ 258 print_buffer_pos_byte = 0; \ 259 } \ 260 if (EQ (printcharfun, Qt) && ! noninteractive) \ 261 setup_echo_area_for_printing (multibyte); 262 263#define PRINTFINISH \ 264 if (NILP (printcharfun)) \ 265 { \ 266 if (print_buffer_pos != print_buffer_pos_byte \ 267 && NILP (current_buffer->enable_multibyte_characters)) \ 268 { \ 269 unsigned char *temp \ 270 = (unsigned char *) alloca (print_buffer_pos + 1); \ 271 copy_text (print_buffer, temp, print_buffer_pos_byte, \ 272 1, 0); \ 273 insert_1_both (temp, print_buffer_pos, \ 274 print_buffer_pos, 0, 1, 0); \ 275 } \ 276 else \ 277 insert_1_both (print_buffer, print_buffer_pos, \ 278 print_buffer_pos_byte, 0, 1, 0); \ 279 signal_after_change (PT - print_buffer_pos, 0, print_buffer_pos);\ 280 } \ 281 if (free_print_buffer) \ 282 { \ 283 xfree (print_buffer); \ 284 print_buffer = 0; \ 285 } \ 286 unbind_to (specpdl_count, Qnil); \ 287 if (MARKERP (original)) \ 288 set_marker_both (original, Qnil, PT, PT_BYTE); \ 289 if (old_point >= 0) \ 290 SET_PT_BOTH (old_point + (old_point >= start_point \ 291 ? PT - start_point : 0), \ 292 old_point_byte + (old_point_byte >= start_point_byte \ 293 ? PT_BYTE - start_point_byte : 0)); \ 294 if (old != current_buffer) \ 295 set_buffer_internal (old); 296 297#define PRINTCHAR(ch) printchar (ch, printcharfun) 298 299/* This is used to restore the saved contents of print_buffer 300 when there is a recursive call to print. */ 301 302static Lisp_Object 303print_unwind (saved_text) 304 Lisp_Object saved_text; 305{ 306 bcopy (SDATA (saved_text), print_buffer, SCHARS (saved_text)); 307 return Qnil; 308} 309 310 311/* Print character CH using method FUN. FUN nil means print to 312 print_buffer. FUN t means print to echo area or stdout if 313 non-interactive. If FUN is neither nil nor t, call FUN with CH as 314 argument. */ 315 316static void 317printchar (ch, fun) 318 unsigned int ch; 319 Lisp_Object fun; 320{ 321#ifdef MAX_PRINT_CHARS 322 if (max_print) 323 print_chars++; 324#endif /* MAX_PRINT_CHARS */ 325 326 if (!NILP (fun) && !EQ (fun, Qt)) 327 call1 (fun, make_number (ch)); 328 else 329 { 330 unsigned char str[MAX_MULTIBYTE_LENGTH]; 331 int len = CHAR_STRING (ch, str); 332 333 QUIT; 334 335 if (NILP (fun)) 336 { 337 if (print_buffer_pos_byte + len >= print_buffer_size) 338 print_buffer = (char *) xrealloc (print_buffer, 339 print_buffer_size *= 2); 340 bcopy (str, print_buffer + print_buffer_pos_byte, len); 341 print_buffer_pos += 1; 342 print_buffer_pos_byte += len; 343 } 344 else if (noninteractive) 345 { 346 fwrite (str, 1, len, stdout); 347 noninteractive_need_newline = 1; 348 } 349 else 350 { 351 int multibyte_p 352 = !NILP (current_buffer->enable_multibyte_characters); 353 354 setup_echo_area_for_printing (multibyte_p); 355 insert_char (ch); 356 message_dolog (str, len, 0, multibyte_p); 357 } 358 } 359} 360 361 362/* Output SIZE characters, SIZE_BYTE bytes from string PTR using 363 method PRINTCHARFUN. If SIZE < 0, use the string length of PTR for 364 both SIZE and SIZE_BYTE. PRINTCHARFUN nil means output to 365 print_buffer. PRINTCHARFUN t means output to the echo area or to 366 stdout if non-interactive. If neither nil nor t, call Lisp 367 function PRINTCHARFUN for each character printed. MULTIBYTE 368 non-zero means PTR contains multibyte characters. 369 370 In the case where PRINTCHARFUN is nil, it is safe for PTR to point 371 to data in a Lisp string. Otherwise that is not safe. */ 372 373static void 374strout (ptr, size, size_byte, printcharfun, multibyte) 375 char *ptr; 376 int size, size_byte; 377 Lisp_Object printcharfun; 378 int multibyte; 379{ 380 if (size < 0) 381 size_byte = size = strlen (ptr); 382 383 if (NILP (printcharfun)) 384 { 385 if (print_buffer_pos_byte + size_byte > print_buffer_size) 386 { 387 print_buffer_size = print_buffer_size * 2 + size_byte; 388 print_buffer = (char *) xrealloc (print_buffer, 389 print_buffer_size); 390 } 391 bcopy (ptr, print_buffer + print_buffer_pos_byte, size_byte); 392 print_buffer_pos += size; 393 print_buffer_pos_byte += size_byte; 394 395#ifdef MAX_PRINT_CHARS 396 if (max_print) 397 print_chars += size; 398#endif /* MAX_PRINT_CHARS */ 399 } 400 else if (noninteractive && EQ (printcharfun, Qt)) 401 { 402 fwrite (ptr, 1, size_byte, stdout); 403 noninteractive_need_newline = 1; 404 } 405 else if (EQ (printcharfun, Qt)) 406 { 407 /* Output to echo area. We're trying to avoid a little overhead 408 here, that's the reason we don't call printchar to do the 409 job. */ 410 int i; 411 int multibyte_p 412 = !NILP (current_buffer->enable_multibyte_characters); 413 414 setup_echo_area_for_printing (multibyte_p); 415 message_dolog (ptr, size_byte, 0, multibyte_p); 416 417 if (size == size_byte) 418 { 419 for (i = 0; i < size; ++i) 420 insert_char ((unsigned char) *ptr++); 421 } 422 else 423 { 424 int len; 425 for (i = 0; i < size_byte; i += len) 426 { 427 int ch = STRING_CHAR_AND_LENGTH (ptr + i, size_byte - i, len); 428 insert_char (ch); 429 } 430 } 431 432#ifdef MAX_PRINT_CHARS 433 if (max_print) 434 print_chars += size; 435#endif /* MAX_PRINT_CHARS */ 436 } 437 else 438 { 439 /* PRINTCHARFUN is a Lisp function. */ 440 int i = 0; 441 442 if (size == size_byte) 443 { 444 while (i < size_byte) 445 { 446 int ch = ptr[i++]; 447 PRINTCHAR (ch); 448 } 449 } 450 else 451 { 452 while (i < size_byte) 453 { 454 /* Here, we must convert each multi-byte form to the 455 corresponding character code before handing it to 456 PRINTCHAR. */ 457 int len; 458 int ch = STRING_CHAR_AND_LENGTH (ptr + i, size_byte - i, len); 459 PRINTCHAR (ch); 460 i += len; 461 } 462 } 463 } 464} 465 466/* Print the contents of a string STRING using PRINTCHARFUN. 467 It isn't safe to use strout in many cases, 468 because printing one char can relocate. */ 469 470static void 471print_string (string, printcharfun) 472 Lisp_Object string; 473 Lisp_Object printcharfun; 474{ 475 if (EQ (printcharfun, Qt) || NILP (printcharfun)) 476 { 477 int chars; 478 479 if (STRING_MULTIBYTE (string)) 480 chars = SCHARS (string); 481 else if (EQ (printcharfun, Qt) 482 ? ! NILP (buffer_defaults.enable_multibyte_characters) 483 : ! NILP (current_buffer->enable_multibyte_characters)) 484 { 485 /* If unibyte string STRING contains 8-bit codes, we must 486 convert STRING to a multibyte string containing the same 487 character codes. */ 488 Lisp_Object newstr; 489 int bytes; 490 491 chars = SBYTES (string); 492 bytes = parse_str_to_multibyte (SDATA (string), chars); 493 if (chars < bytes) 494 { 495 newstr = make_uninit_multibyte_string (chars, bytes); 496 bcopy (SDATA (string), SDATA (newstr), chars); 497 str_to_multibyte (SDATA (newstr), bytes, chars); 498 string = newstr; 499 } 500 } 501 else 502 chars = SBYTES (string); 503 504 if (EQ (printcharfun, Qt)) 505 { 506 /* Output to echo area. */ 507 int nbytes = SBYTES (string); 508 char *buffer; 509 510 /* Copy the string contents so that relocation of STRING by 511 GC does not cause trouble. */ 512 USE_SAFE_ALLOCA; 513 514 SAFE_ALLOCA (buffer, char *, nbytes); 515 bcopy (SDATA (string), buffer, nbytes); 516 517 strout (buffer, chars, SBYTES (string), 518 printcharfun, STRING_MULTIBYTE (string)); 519 520 SAFE_FREE (); 521 } 522 else 523 /* No need to copy, since output to print_buffer can't GC. */ 524 strout (SDATA (string), 525 chars, SBYTES (string), 526 printcharfun, STRING_MULTIBYTE (string)); 527 } 528 else 529 { 530 /* Otherwise, string may be relocated by printing one char. 531 So re-fetch the string address for each character. */ 532 int i; 533 int size = SCHARS (string); 534 int size_byte = SBYTES (string); 535 struct gcpro gcpro1; 536 GCPRO1 (string); 537 if (size == size_byte) 538 for (i = 0; i < size; i++) 539 PRINTCHAR (SREF (string, i)); 540 else 541 for (i = 0; i < size_byte; ) 542 { 543 /* Here, we must convert each multi-byte form to the 544 corresponding character code before handing it to PRINTCHAR. */ 545 int len; 546 int ch = STRING_CHAR_AND_LENGTH (SDATA (string) + i, 547 size_byte - i, len); 548 if (!CHAR_VALID_P (ch, 0)) 549 { 550 ch = SREF (string, i); 551 len = 1; 552 } 553 PRINTCHAR (ch); 554 i += len; 555 } 556 UNGCPRO; 557 } 558} 559 560DEFUN ("write-char", Fwrite_char, Swrite_char, 1, 2, 0, 561 doc: /* Output character CHARACTER to stream PRINTCHARFUN. 562PRINTCHARFUN defaults to the value of `standard-output' (which see). */) 563 (character, printcharfun) 564 Lisp_Object character, printcharfun; 565{ 566 PRINTDECLARE; 567 568 if (NILP (printcharfun)) 569 printcharfun = Vstandard_output; 570 CHECK_NUMBER (character); 571 PRINTPREPARE; 572 PRINTCHAR (XINT (character)); 573 PRINTFINISH; 574 return character; 575} 576 577/* Used from outside of print.c to print a block of SIZE 578 single-byte chars at DATA on the default output stream. 579 Do not use this on the contents of a Lisp string. */ 580 581void 582write_string (data, size) 583 char *data; 584 int size; 585{ 586 PRINTDECLARE; 587 Lisp_Object printcharfun; 588 589 printcharfun = Vstandard_output; 590 591 PRINTPREPARE; 592 strout (data, size, size, printcharfun, 0); 593 PRINTFINISH; 594} 595 596/* Used from outside of print.c to print a block of SIZE 597 single-byte chars at DATA on a specified stream PRINTCHARFUN. 598 Do not use this on the contents of a Lisp string. */ 599 600void 601write_string_1 (data, size, printcharfun) 602 char *data; 603 int size; 604 Lisp_Object printcharfun; 605{ 606 PRINTDECLARE; 607 608 PRINTPREPARE; 609 strout (data, size, size, printcharfun, 0); 610 PRINTFINISH; 611} 612 613 614void 615temp_output_buffer_setup (bufname) 616 const char *bufname; 617{ 618 int count = SPECPDL_INDEX (); 619 register struct buffer *old = current_buffer; 620 register Lisp_Object buf; 621 622 record_unwind_protect (set_buffer_if_live, Fcurrent_buffer ()); 623 624 Fset_buffer (Fget_buffer_create (build_string (bufname))); 625 626 Fkill_all_local_variables (); 627 delete_all_overlays (current_buffer); 628 current_buffer->directory = old->directory; 629 current_buffer->read_only = Qnil; 630 current_buffer->filename = Qnil; 631 current_buffer->undo_list = Qt; 632 eassert (current_buffer->overlays_before == NULL); 633 eassert (current_buffer->overlays_after == NULL); 634 current_buffer->enable_multibyte_characters 635 = buffer_defaults.enable_multibyte_characters; 636 specbind (Qinhibit_read_only, Qt); 637 specbind (Qinhibit_modification_hooks, Qt); 638 Ferase_buffer (); 639 XSETBUFFER (buf, current_buffer); 640 641 Frun_hooks (1, &Qtemp_buffer_setup_hook); 642 643 unbind_to (count, Qnil); 644 645 specbind (Qstandard_output, buf); 646} 647 648Lisp_Object 649internal_with_output_to_temp_buffer (bufname, function, args) 650 const char *bufname; 651 Lisp_Object (*function) P_ ((Lisp_Object)); 652 Lisp_Object args; 653{ 654 int count = SPECPDL_INDEX (); 655 Lisp_Object buf, val; 656 struct gcpro gcpro1; 657 658 GCPRO1 (args); 659 record_unwind_protect (Fset_buffer, Fcurrent_buffer ()); 660 temp_output_buffer_setup (bufname); 661 buf = Vstandard_output; 662 UNGCPRO; 663 664 val = (*function) (args); 665 666 GCPRO1 (val); 667 temp_output_buffer_show (buf); 668 UNGCPRO; 669 670 return unbind_to (count, val); 671} 672 673DEFUN ("with-output-to-temp-buffer", 674 Fwith_output_to_temp_buffer, Swith_output_to_temp_buffer, 675 1, UNEVALLED, 0, 676 doc: /* Bind `standard-output' to buffer BUFNAME, eval BODY, then show that buffer. 677The buffer is cleared out initially, and marked as unmodified when done. 678All output done by BODY is inserted in that buffer by default. 679The buffer is displayed in another window, but not selected. 680The value of the last form in BODY is returned. 681If BODY does not finish normally, the buffer BUFNAME is not displayed. 682 683The hook `temp-buffer-setup-hook' is run before BODY, 684with the buffer BUFNAME temporarily current. 685The hook `temp-buffer-show-hook' is run after the buffer is displayed, 686with the buffer temporarily current, and the window that was used 687to display it temporarily selected. 688 689If variable `temp-buffer-show-function' is non-nil, call it at the end 690to get the buffer displayed instead of just displaying the non-selected 691buffer and calling the hook. It gets one argument, the buffer to display. 692 693usage: (with-output-to-temp-buffer BUFNAME BODY ...) */) 694 (args) 695 Lisp_Object args; 696{ 697 struct gcpro gcpro1; 698 Lisp_Object name; 699 int count = SPECPDL_INDEX (); 700 Lisp_Object buf, val; 701 702 GCPRO1(args); 703 name = Feval (Fcar (args)); 704 CHECK_STRING (name); 705 temp_output_buffer_setup (SDATA (name)); 706 buf = Vstandard_output; 707 UNGCPRO; 708 709 val = Fprogn (XCDR (args)); 710 711 GCPRO1 (val); 712 temp_output_buffer_show (buf); 713 UNGCPRO; 714 715 return unbind_to (count, val); 716} 717 718 719static void print (); 720static void print_preprocess (); 721static void print_preprocess_string (); 722static void print_object (); 723 724DEFUN ("terpri", Fterpri, Sterpri, 0, 1, 0, 725 doc: /* Output a newline to stream PRINTCHARFUN. 726If PRINTCHARFUN is omitted or nil, the value of `standard-output' is used. */) 727 (printcharfun) 728 Lisp_Object printcharfun; 729{ 730 PRINTDECLARE; 731 732 if (NILP (printcharfun)) 733 printcharfun = Vstandard_output; 734 PRINTPREPARE; 735 PRINTCHAR ('\n'); 736 PRINTFINISH; 737 return Qt; 738} 739 740DEFUN ("prin1", Fprin1, Sprin1, 1, 2, 0, 741 doc: /* Output the printed representation of OBJECT, any Lisp object. 742Quoting characters are printed when needed to make output that `read' 743can handle, whenever this is possible. For complex objects, the behavior 744is controlled by `print-level' and `print-length', which see. 745 746OBJECT is any of the Lisp data types: a number, a string, a symbol, 747a list, a buffer, a window, a frame, etc. 748 749A printed representation of an object is text which describes that object. 750 751Optional argument PRINTCHARFUN is the output stream, which can be one 752of these: 753 754 - a buffer, in which case output is inserted into that buffer at point; 755 - a marker, in which case output is inserted at marker's position; 756 - a function, in which case that function is called once for each 757 character of OBJECT's printed representation; 758 - a symbol, in which case that symbol's function definition is called; or 759 - t, in which case the output is displayed in the echo area. 760 761If PRINTCHARFUN is omitted, the value of `standard-output' (which see) 762is used instead. */) 763 (object, printcharfun) 764 Lisp_Object object, printcharfun; 765{ 766 PRINTDECLARE; 767 768#ifdef MAX_PRINT_CHARS 769 max_print = 0; 770#endif /* MAX_PRINT_CHARS */ 771 if (NILP (printcharfun)) 772 printcharfun = Vstandard_output; 773 PRINTPREPARE; 774 print (object, printcharfun, 1); 775 PRINTFINISH; 776 return object; 777} 778 779/* a buffer which is used to hold output being built by prin1-to-string */ 780Lisp_Object Vprin1_to_string_buffer; 781 782DEFUN ("prin1-to-string", Fprin1_to_string, Sprin1_to_string, 1, 2, 0, 783 doc: /* Return a string containing the printed representation of OBJECT. 784OBJECT can be any Lisp object. This function outputs quoting characters 785when necessary to make output that `read' can handle, whenever possible, 786unless the optional second argument NOESCAPE is non-nil. For complex objects, 787the behavior is controlled by `print-level' and `print-length', which see. 788 789OBJECT is any of the Lisp data types: a number, a string, a symbol, 790a list, a buffer, a window, a frame, etc. 791 792A printed representation of an object is text which describes that object. */) 793 (object, noescape) 794 Lisp_Object object, noescape; 795{ 796 Lisp_Object printcharfun; 797 /* struct gcpro gcpro1, gcpro2; */ 798 Lisp_Object save_deactivate_mark; 799 int count = SPECPDL_INDEX (); 800 struct buffer *previous; 801 802 specbind (Qinhibit_modification_hooks, Qt); 803 804 { 805 PRINTDECLARE; 806 807 /* Save and restore this--we are altering a buffer 808 but we don't want to deactivate the mark just for that. 809 No need for specbind, since errors deactivate the mark. */ 810 save_deactivate_mark = Vdeactivate_mark; 811 /* GCPRO2 (object, save_deactivate_mark); */ 812 abort_on_gc++; 813 814 printcharfun = Vprin1_to_string_buffer; 815 PRINTPREPARE; 816 print (object, printcharfun, NILP (noescape)); 817 /* Make Vprin1_to_string_buffer be the default buffer after PRINTFINSH */ 818 PRINTFINISH; 819 } 820 821 previous = current_buffer; 822 set_buffer_internal (XBUFFER (Vprin1_to_string_buffer)); 823 object = Fbuffer_string (); 824 if (SBYTES (object) == SCHARS (object)) 825 STRING_SET_UNIBYTE (object); 826 827 /* Note that this won't make prepare_to_modify_buffer call 828 ask-user-about-supersession-threat because this buffer 829 does not visit a file. */ 830 Ferase_buffer (); 831 set_buffer_internal (previous); 832 833 Vdeactivate_mark = save_deactivate_mark; 834 /* UNGCPRO; */ 835 836 abort_on_gc--; 837 return unbind_to (count, object); 838} 839 840DEFUN ("princ", Fprinc, Sprinc, 1, 2, 0, 841 doc: /* Output the printed representation of OBJECT, any Lisp object. 842No quoting characters are used; no delimiters are printed around 843the contents of strings. 844 845OBJECT is any of the Lisp data types: a number, a string, a symbol, 846a list, a buffer, a window, a frame, etc. 847 848A printed representation of an object is text which describes that object. 849 850Optional argument PRINTCHARFUN is the output stream, which can be one 851of these: 852 853 - a buffer, in which case output is inserted into that buffer at point; 854 - a marker, in which case output is inserted at marker's position; 855 - a function, in which case that function is called once for each 856 character of OBJECT's printed representation; 857 - a symbol, in which case that symbol's function definition is called; or 858 - t, in which case the output is displayed in the echo area. 859 860If PRINTCHARFUN is omitted, the value of `standard-output' (which see) 861is used instead. */) 862 (object, printcharfun) 863 Lisp_Object object, printcharfun; 864{ 865 PRINTDECLARE; 866 867 if (NILP (printcharfun)) 868 printcharfun = Vstandard_output; 869 PRINTPREPARE; 870 print (object, printcharfun, 0); 871 PRINTFINISH; 872 return object; 873} 874 875DEFUN ("print", Fprint, Sprint, 1, 2, 0, 876 doc: /* Output the printed representation of OBJECT, with newlines around it. 877Quoting characters are printed when needed to make output that `read' 878can handle, whenever this is possible. For complex objects, the behavior 879is controlled by `print-level' and `print-length', which see. 880 881OBJECT is any of the Lisp data types: a number, a string, a symbol, 882a list, a buffer, a window, a frame, etc. 883 884A printed representation of an object is text which describes that object. 885 886Optional argument PRINTCHARFUN is the output stream, which can be one 887of these: 888 889 - a buffer, in which case output is inserted into that buffer at point; 890 - a marker, in which case output is inserted at marker's position; 891 - a function, in which case that function is called once for each 892 character of OBJECT's printed representation; 893 - a symbol, in which case that symbol's function definition is called; or 894 - t, in which case the output is displayed in the echo area. 895 896If PRINTCHARFUN is omitted, the value of `standard-output' (which see) 897is used instead. */) 898 (object, printcharfun) 899 Lisp_Object object, printcharfun; 900{ 901 PRINTDECLARE; 902 struct gcpro gcpro1; 903 904#ifdef MAX_PRINT_CHARS 905 print_chars = 0; 906 max_print = MAX_PRINT_CHARS; 907#endif /* MAX_PRINT_CHARS */ 908 if (NILP (printcharfun)) 909 printcharfun = Vstandard_output; 910 GCPRO1 (object); 911 PRINTPREPARE; 912 PRINTCHAR ('\n'); 913 print (object, printcharfun, 1); 914 PRINTCHAR ('\n'); 915 PRINTFINISH; 916#ifdef MAX_PRINT_CHARS 917 max_print = 0; 918 print_chars = 0; 919#endif /* MAX_PRINT_CHARS */ 920 UNGCPRO; 921 return object; 922} 923 924/* The subroutine object for external-debugging-output is kept here 925 for the convenience of the debugger. */ 926Lisp_Object Qexternal_debugging_output; 927 928DEFUN ("external-debugging-output", Fexternal_debugging_output, Sexternal_debugging_output, 1, 1, 0, 929 doc: /* Write CHARACTER to stderr. 930You can call print while debugging emacs, and pass it this function 931to make it write to the debugging output. */) 932 (character) 933 Lisp_Object character; 934{ 935 CHECK_NUMBER (character); 936 putc (XINT (character), stderr); 937 938#ifdef WINDOWSNT 939 /* Send the output to a debugger (nothing happens if there isn't one). */ 940 if (print_output_debug_flag) 941 { 942 char buf[2] = {(char) XINT (character), '\0'}; 943 OutputDebugString (buf); 944 } 945#endif 946 947 return character; 948} 949 950/* This function is never called. Its purpose is to prevent 951 print_output_debug_flag from being optimized away. */ 952 953void 954debug_output_compilation_hack (x) 955 int x; 956{ 957 print_output_debug_flag = x; 958} 959 960#if defined (GNU_LINUX) 961 962/* This functionality is not vitally important in general, so we rely on 963 non-portable ability to use stderr as lvalue. */ 964 965#define WITH_REDIRECT_DEBUGGING_OUTPUT 1 966 967FILE *initial_stderr_stream = NULL; 968 969DEFUN ("redirect-debugging-output", Fredirect_debugging_output, Sredirect_debugging_output, 970 1, 2, 971 "FDebug output file: \nP", 972 doc: /* Redirect debugging output (stderr stream) to file FILE. 973If FILE is nil, reset target to the initial stderr stream. 974Optional arg APPEND non-nil (interactively, with prefix arg) means 975append to existing target file. */) 976 (file, append) 977 Lisp_Object file, append; 978{ 979 if (initial_stderr_stream != NULL) 980 { 981 BLOCK_INPUT; 982 fclose (stderr); 983 UNBLOCK_INPUT; 984 } 985 stderr = initial_stderr_stream; 986 initial_stderr_stream = NULL; 987 988 if (STRINGP (file)) 989 { 990 file = Fexpand_file_name (file, Qnil); 991 initial_stderr_stream = stderr; 992 stderr = fopen (SDATA (file), NILP (append) ? "w" : "a"); 993 if (stderr == NULL) 994 { 995 stderr = initial_stderr_stream; 996 initial_stderr_stream = NULL; 997 report_file_error ("Cannot open debugging output stream", 998 Fcons (file, Qnil)); 999 } 1000 } 1001 return Qnil; 1002} 1003#endif /* GNU_LINUX */ 1004 1005 1006/* This is the interface for debugging printing. */ 1007 1008void 1009debug_print (arg) 1010 Lisp_Object arg; 1011{ 1012 Fprin1 (arg, Qexternal_debugging_output); 1013 fprintf (stderr, "\r\n"); 1014} 1015 1016void 1017safe_debug_print (arg) 1018 Lisp_Object arg; 1019{ 1020 int valid = valid_lisp_object_p (arg); 1021 1022 if (valid > 0) 1023 debug_print (arg); 1024 else 1025 fprintf (stderr, "#<%s_LISP_OBJECT 0x%08lx>\r\n", 1026 !valid ? "INVALID" : "SOME", 1027#ifdef NO_UNION_TYPE 1028 (unsigned long) arg 1029#else 1030 (unsigned long) arg.i 1031#endif 1032 ); 1033} 1034 1035 1036DEFUN ("error-message-string", Ferror_message_string, Serror_message_string, 1037 1, 1, 0, 1038 doc: /* Convert an error value (ERROR-SYMBOL . DATA) to an error message. 1039See Info anchor `(elisp)Definition of signal' for some details on how this 1040error message is constructed. */) 1041 (obj) 1042 Lisp_Object obj; 1043{ 1044 struct buffer *old = current_buffer; 1045 Lisp_Object value; 1046 struct gcpro gcpro1; 1047 1048 /* If OBJ is (error STRING), just return STRING. 1049 That is not only faster, it also avoids the need to allocate 1050 space here when the error is due to memory full. */ 1051 if (CONSP (obj) && EQ (XCAR (obj), Qerror) 1052 && CONSP (XCDR (obj)) 1053 && STRINGP (XCAR (XCDR (obj))) 1054 && NILP (XCDR (XCDR (obj)))) 1055 return XCAR (XCDR (obj)); 1056 1057 print_error_message (obj, Vprin1_to_string_buffer, 0, Qnil); 1058 1059 set_buffer_internal (XBUFFER (Vprin1_to_string_buffer)); 1060 value = Fbuffer_string (); 1061 1062 GCPRO1 (value); 1063 Ferase_buffer (); 1064 set_buffer_internal (old); 1065 UNGCPRO; 1066 1067 return value; 1068} 1069 1070/* Print an error message for the error DATA onto Lisp output stream 1071 STREAM (suitable for the print functions). 1072 CONTEXT is a C string describing the context of the error. 1073 CALLER is the Lisp function inside which the error was signaled. */ 1074 1075void 1076print_error_message (data, stream, context, caller) 1077 Lisp_Object data, stream; 1078 char *context; 1079 Lisp_Object caller; 1080{ 1081 Lisp_Object errname, errmsg, file_error, tail; 1082 struct gcpro gcpro1; 1083 int i; 1084 1085 if (context != 0) 1086 write_string_1 (context, -1, stream); 1087 1088 /* If we know from where the error was signaled, show it in 1089 *Messages*. */ 1090 if (!NILP (caller) && SYMBOLP (caller)) 1091 { 1092 Lisp_Object cname = SYMBOL_NAME (caller); 1093 char *name = alloca (SBYTES (cname)); 1094 bcopy (SDATA (cname), name, SBYTES (cname)); 1095 message_dolog (name, SBYTES (cname), 0, 0); 1096 message_dolog (": ", 2, 0, 0); 1097 } 1098 1099 errname = Fcar (data); 1100 1101 if (EQ (errname, Qerror)) 1102 { 1103 data = Fcdr (data); 1104 if (!CONSP (data)) 1105 data = Qnil; 1106 errmsg = Fcar (data); 1107 file_error = Qnil; 1108 } 1109 else 1110 { 1111 Lisp_Object error_conditions; 1112 errmsg = Fget (errname, Qerror_message); 1113 error_conditions = Fget (errname, Qerror_conditions); 1114 file_error = Fmemq (Qfile_error, error_conditions); 1115 } 1116 1117 /* Print an error message including the data items. */ 1118 1119 tail = Fcdr_safe (data); 1120 GCPRO1 (tail); 1121 1122 /* For file-error, make error message by concatenating 1123 all the data items. They are all strings. */ 1124 if (!NILP (file_error) && CONSP (tail)) 1125 errmsg = XCAR (tail), tail = XCDR (tail); 1126 1127 if (STRINGP (errmsg)) 1128 Fprinc (errmsg, stream); 1129 else 1130 write_string_1 ("peculiar error", -1, stream); 1131 1132 for (i = 0; CONSP (tail); tail = XCDR (tail), i++) 1133 { 1134 Lisp_Object obj; 1135 1136 write_string_1 (i ? ", " : ": ", 2, stream); 1137 obj = XCAR (tail); 1138 if (!NILP (file_error) || EQ (errname, Qend_of_file)) 1139 Fprinc (obj, stream); 1140 else 1141 Fprin1 (obj, stream); 1142 } 1143 1144 UNGCPRO; 1145} 1146 1147 1148 1149/* 1150 * The buffer should be at least as large as the max string size of the 1151 * largest float, printed in the biggest notation. This is undoubtedly 1152 * 20d float_output_format, with the negative of the C-constant "HUGE" 1153 * from <math.h>. 1154 * 1155 * On the vax the worst case is -1e38 in 20d format which takes 61 bytes. 1156 * 1157 * I assume that IEEE-754 format numbers can take 329 bytes for the worst 1158 * case of -1e307 in 20d float_output_format. What is one to do (short of 1159 * re-writing _doprnt to be more sane)? 1160 * -wsr 1161 */ 1162 1163void 1164float_to_string (buf, data) 1165 unsigned char *buf; 1166 double data; 1167{ 1168 unsigned char *cp; 1169 int width; 1170 1171 /* Check for plus infinity in a way that won't lose 1172 if there is no plus infinity. */ 1173 if (data == data / 2 && data > 1.0) 1174 { 1175 strcpy (buf, "1.0e+INF"); 1176 return; 1177 } 1178 /* Likewise for minus infinity. */ 1179 if (data == data / 2 && data < -1.0) 1180 { 1181 strcpy (buf, "-1.0e+INF"); 1182 return; 1183 } 1184 /* Check for NaN in a way that won't fail if there are no NaNs. */ 1185 if (! (data * 0.0 >= 0.0)) 1186 { 1187 /* Prepend "-" if the NaN's sign bit is negative. 1188 The sign bit of a double is the bit that is 1 in -0.0. */ 1189 int i; 1190 union { double d; char c[sizeof (double)]; } u_data, u_minus_zero; 1191 u_data.d = data; 1192 u_minus_zero.d = - 0.0; 1193 for (i = 0; i < sizeof (double); i++) 1194 if (u_data.c[i] & u_minus_zero.c[i]) 1195 { 1196 *buf++ = '-'; 1197 break; 1198 } 1199 1200 strcpy (buf, "0.0e+NaN"); 1201 return; 1202 } 1203 1204 if (NILP (Vfloat_output_format) 1205 || !STRINGP (Vfloat_output_format)) 1206 lose: 1207 { 1208 /* Generate the fewest number of digits that represent the 1209 floating point value without losing information. 1210 The following method is simple but a bit slow. 1211 For ideas about speeding things up, please see: 1212 1213 Guy L Steele Jr & Jon L White, How to print floating-point numbers 1214 accurately. SIGPLAN notices 25, 6 (June 1990), 112-126. 1215 1216 Robert G Burger & R Kent Dybvig, Printing floating point numbers 1217 quickly and accurately, SIGPLAN notices 31, 5 (May 1996), 108-116. */ 1218 1219 width = fabs (data) < DBL_MIN ? 1 : DBL_DIG; 1220 do 1221 sprintf (buf, "%.*g", width, data); 1222 while (width++ < DOUBLE_DIGITS_BOUND && atof (buf) != data); 1223 } 1224 else /* oink oink */ 1225 { 1226 /* Check that the spec we have is fully valid. 1227 This means not only valid for printf, 1228 but meant for floats, and reasonable. */ 1229 cp = SDATA (Vfloat_output_format); 1230 1231 if (cp[0] != '%') 1232 goto lose; 1233 if (cp[1] != '.') 1234 goto lose; 1235 1236 cp += 2; 1237 1238 /* Check the width specification. */ 1239 width = -1; 1240 if ('0' <= *cp && *cp <= '9') 1241 { 1242 width = 0; 1243 do 1244 width = (width * 10) + (*cp++ - '0'); 1245 while (*cp >= '0' && *cp <= '9'); 1246 1247 /* A precision of zero is valid only for %f. */ 1248 if (width > DBL_DIG 1249 || (width == 0 && *cp != 'f')) 1250 goto lose; 1251 } 1252 1253 if (*cp != 'e' && *cp != 'f' && *cp != 'g') 1254 goto lose; 1255 1256 if (cp[1] != 0) 1257 goto lose; 1258 1259 sprintf (buf, SDATA (Vfloat_output_format), data); 1260 } 1261 1262 /* Make sure there is a decimal point with digit after, or an 1263 exponent, so that the value is readable as a float. But don't do 1264 this with "%.0f"; it's valid for that not to produce a decimal 1265 point. Note that width can be 0 only for %.0f. */ 1266 if (width != 0) 1267 { 1268 for (cp = buf; *cp; cp++) 1269 if ((*cp < '0' || *cp > '9') && *cp != '-') 1270 break; 1271 1272 if (*cp == '.' && cp[1] == 0) 1273 { 1274 cp[1] = '0'; 1275 cp[2] = 0; 1276 } 1277 1278 if (*cp == 0) 1279 { 1280 *cp++ = '.'; 1281 *cp++ = '0'; 1282 *cp++ = 0; 1283 } 1284 } 1285} 1286 1287 1288static void 1289print (obj, printcharfun, escapeflag) 1290 Lisp_Object obj; 1291 register Lisp_Object printcharfun; 1292 int escapeflag; 1293{ 1294 old_backquote_output = 0; 1295 1296 /* Reset print_number_index and Vprint_number_table only when 1297 the variable Vprint_continuous_numbering is nil. Otherwise, 1298 the values of these variables will be kept between several 1299 print functions. */ 1300 if (NILP (Vprint_continuous_numbering) 1301 || NILP (Vprint_number_table)) 1302 { 1303 print_number_index = 0; 1304 Vprint_number_table = Qnil; 1305 } 1306 1307 /* Construct Vprint_number_table for print-gensym and print-circle. */ 1308 if (!NILP (Vprint_gensym) || !NILP (Vprint_circle)) 1309 { 1310 int i, start, index; 1311 start = index = print_number_index; 1312 /* Construct Vprint_number_table. 1313 This increments print_number_index for the objects added. */ 1314 print_depth = 0; 1315 print_preprocess (obj); 1316 1317 /* Remove unnecessary objects, which appear only once in OBJ; 1318 that is, whose status is Qnil. Compactify the necessary objects. */ 1319 for (i = start; i < print_number_index; i++) 1320 if (!NILP (PRINT_NUMBER_STATUS (Vprint_number_table, i))) 1321 { 1322 PRINT_NUMBER_OBJECT (Vprint_number_table, index) 1323 = PRINT_NUMBER_OBJECT (Vprint_number_table, i); 1324 index++; 1325 } 1326 1327 /* Clear out objects outside the active part of the table. */ 1328 for (i = index; i < print_number_index; i++) 1329 PRINT_NUMBER_OBJECT (Vprint_number_table, i) = Qnil; 1330 1331 /* Reset the status field for the next print step. Now this 1332 field means whether the object has already been printed. */ 1333 for (i = start; i < print_number_index; i++) 1334 PRINT_NUMBER_STATUS (Vprint_number_table, i) = Qnil; 1335 1336 print_number_index = index; 1337 } 1338 1339 print_depth = 0; 1340 print_object (obj, printcharfun, escapeflag); 1341} 1342 1343/* Construct Vprint_number_table according to the structure of OBJ. 1344 OBJ itself and all its elements will be added to Vprint_number_table 1345 recursively if it is a list, vector, compiled function, char-table, 1346 string (its text properties will be traced), or a symbol that has 1347 no obarray (this is for the print-gensym feature). 1348 The status fields of Vprint_number_table mean whether each object appears 1349 more than once in OBJ: Qnil at the first time, and Qt after that . */ 1350static void 1351print_preprocess (obj) 1352 Lisp_Object obj; 1353{ 1354 int i; 1355 EMACS_INT size; 1356 int loop_count = 0; 1357 Lisp_Object halftail; 1358 1359 /* Give up if we go so deep that print_object will get an error. */ 1360 /* See similar code in print_object. */ 1361 if (print_depth >= PRINT_CIRCLE) 1362 error ("Apparently circular structure being printed"); 1363 1364 /* Avoid infinite recursion for circular nested structure 1365 in the case where Vprint_circle is nil. */ 1366 if (NILP (Vprint_circle)) 1367 { 1368 for (i = 0; i < print_depth; i++) 1369 if (EQ (obj, being_printed[i])) 1370 return; 1371 being_printed[print_depth] = obj; 1372 } 1373 1374 print_depth++; 1375 halftail = obj; 1376 1377 loop: 1378 if (STRINGP (obj) || CONSP (obj) || VECTORP (obj) 1379 || COMPILEDP (obj) || CHAR_TABLE_P (obj) 1380 || (! NILP (Vprint_gensym) 1381 && SYMBOLP (obj) 1382 && !SYMBOL_INTERNED_P (obj))) 1383 { 1384 /* In case print-circle is nil and print-gensym is t, 1385 add OBJ to Vprint_number_table only when OBJ is a symbol. */ 1386 if (! NILP (Vprint_circle) || SYMBOLP (obj)) 1387 { 1388 for (i = 0; i < print_number_index; i++) 1389 if (EQ (PRINT_NUMBER_OBJECT (Vprint_number_table, i), obj)) 1390 { 1391 /* OBJ appears more than once. Let's remember that. */ 1392 PRINT_NUMBER_STATUS (Vprint_number_table, i) = Qt; 1393 print_depth--; 1394 return; 1395 } 1396 1397 /* OBJ is not yet recorded. Let's add to the table. */ 1398 if (print_number_index == 0) 1399 { 1400 /* Initialize the table. */ 1401 Vprint_number_table = Fmake_vector (make_number (40), Qnil); 1402 } 1403 else if (XVECTOR (Vprint_number_table)->size == print_number_index * 2) 1404 { 1405 /* Reallocate the table. */ 1406 int i = print_number_index * 4; 1407 Lisp_Object old_table = Vprint_number_table; 1408 Vprint_number_table = Fmake_vector (make_number (i), Qnil); 1409 for (i = 0; i < print_number_index; i++) 1410 { 1411 PRINT_NUMBER_OBJECT (Vprint_number_table, i) 1412 = PRINT_NUMBER_OBJECT (old_table, i); 1413 PRINT_NUMBER_STATUS (Vprint_number_table, i) 1414 = PRINT_NUMBER_STATUS (old_table, i); 1415 } 1416 } 1417 PRINT_NUMBER_OBJECT (Vprint_number_table, print_number_index) = obj; 1418 /* If Vprint_continuous_numbering is non-nil and OBJ is a gensym, 1419 always print the gensym with a number. This is a special for 1420 the lisp function byte-compile-output-docform. */ 1421 if (!NILP (Vprint_continuous_numbering) 1422 && SYMBOLP (obj) 1423 && !SYMBOL_INTERNED_P (obj)) 1424 PRINT_NUMBER_STATUS (Vprint_number_table, print_number_index) = Qt; 1425 print_number_index++; 1426 } 1427 1428 switch (XGCTYPE (obj)) 1429 { 1430 case Lisp_String: 1431 /* A string may have text properties, which can be circular. */ 1432 traverse_intervals_noorder (STRING_INTERVALS (obj), 1433 print_preprocess_string, Qnil); 1434 break; 1435 1436 case Lisp_Cons: 1437 /* Use HALFTAIL and LOOP_COUNT to detect circular lists, 1438 just as in print_object. */ 1439 if (loop_count && EQ (obj, halftail)) 1440 break; 1441 print_preprocess (XCAR (obj)); 1442 obj = XCDR (obj); 1443 loop_count++; 1444 if (!(loop_count & 1)) 1445 halftail = XCDR (halftail); 1446 goto loop; 1447 1448 case Lisp_Vectorlike: 1449 size = XVECTOR (obj)->size; 1450 if (size & PSEUDOVECTOR_FLAG) 1451 size &= PSEUDOVECTOR_SIZE_MASK; 1452 for (i = 0; i < size; i++) 1453 print_preprocess (XVECTOR (obj)->contents[i]); 1454 break; 1455 1456 default: 1457 break; 1458 } 1459 } 1460 print_depth--; 1461} 1462 1463static void 1464print_preprocess_string (interval, arg) 1465 INTERVAL interval; 1466 Lisp_Object arg; 1467{ 1468 print_preprocess (interval->plist); 1469} 1470 1471static void 1472print_object (obj, printcharfun, escapeflag) 1473 Lisp_Object obj; 1474 register Lisp_Object printcharfun; 1475 int escapeflag; 1476{ 1477 char buf[40]; 1478 1479 QUIT; 1480 1481 /* Detect circularities and truncate them. */ 1482 if (STRINGP (obj) || CONSP (obj) || VECTORP (obj) 1483 || COMPILEDP (obj) || CHAR_TABLE_P (obj) 1484 || (! NILP (Vprint_gensym) 1485 && SYMBOLP (obj) 1486 && !SYMBOL_INTERNED_P (obj))) 1487 { 1488 if (NILP (Vprint_circle) && NILP (Vprint_gensym)) 1489 { 1490 /* Simple but incomplete way. */ 1491 int i; 1492 for (i = 0; i < print_depth; i++) 1493 if (EQ (obj, being_printed[i])) 1494 { 1495 sprintf (buf, "#%d", i); 1496 strout (buf, -1, -1, printcharfun, 0); 1497 return; 1498 } 1499 being_printed[print_depth] = obj; 1500 } 1501 else 1502 { 1503 /* With the print-circle feature. */ 1504 int i; 1505 for (i = 0; i < print_number_index; i++) 1506 if (EQ (PRINT_NUMBER_OBJECT (Vprint_number_table, i), obj)) 1507 { 1508 if (NILP (PRINT_NUMBER_STATUS (Vprint_number_table, i))) 1509 { 1510 /* Add a prefix #n= if OBJ has not yet been printed; 1511 that is, its status field is nil. */ 1512 sprintf (buf, "#%d=", i + 1); 1513 strout (buf, -1, -1, printcharfun, 0); 1514 /* OBJ is going to be printed. Set the status to t. */ 1515 PRINT_NUMBER_STATUS (Vprint_number_table, i) = Qt; 1516 break; 1517 } 1518 else 1519 { 1520 /* Just print #n# if OBJ has already been printed. */ 1521 sprintf (buf, "#%d#", i + 1); 1522 strout (buf, -1, -1, printcharfun, 0); 1523 return; 1524 } 1525 } 1526 } 1527 } 1528 1529 print_depth++; 1530 1531 /* See similar code in print_preprocess. */ 1532 if (print_depth > PRINT_CIRCLE) 1533 error ("Apparently circular structure being printed"); 1534#ifdef MAX_PRINT_CHARS 1535 if (max_print && print_chars > max_print) 1536 { 1537 PRINTCHAR ('\n'); 1538 print_chars = 0; 1539 } 1540#endif /* MAX_PRINT_CHARS */ 1541 1542 switch (XGCTYPE (obj)) 1543 { 1544 case Lisp_Int: 1545 if (sizeof (int) == sizeof (EMACS_INT)) 1546 sprintf (buf, "%d", XINT (obj)); 1547 else if (sizeof (long) == sizeof (EMACS_INT)) 1548 sprintf (buf, "%ld", (long) XINT (obj)); 1549 else 1550 abort (); 1551 strout (buf, -1, -1, printcharfun, 0); 1552 break; 1553 1554 case Lisp_Float: 1555 { 1556 char pigbuf[350]; /* see comments in float_to_string */ 1557 1558 float_to_string (pigbuf, XFLOAT_DATA (obj)); 1559 strout (pigbuf, -1, -1, printcharfun, 0); 1560 } 1561 break; 1562 1563 case Lisp_String: 1564 if (!escapeflag) 1565 print_string (obj, printcharfun); 1566 else 1567 { 1568 register int i, i_byte; 1569 struct gcpro gcpro1; 1570 unsigned char *str; 1571 int size_byte; 1572 /* 1 means we must ensure that the next character we output 1573 cannot be taken as part of a hex character escape. */ 1574 int need_nonhex = 0; 1575 int multibyte = STRING_MULTIBYTE (obj); 1576 1577 GCPRO1 (obj); 1578 1579 if (!NULL_INTERVAL_P (STRING_INTERVALS (obj))) 1580 { 1581 PRINTCHAR ('#'); 1582 PRINTCHAR ('('); 1583 } 1584 1585 PRINTCHAR ('\"'); 1586 str = SDATA (obj); 1587 size_byte = SBYTES (obj); 1588 1589 for (i = 0, i_byte = 0; i_byte < size_byte;) 1590 { 1591 /* Here, we must convert each multi-byte form to the 1592 corresponding character code before handing it to PRINTCHAR. */ 1593 int len; 1594 int c; 1595 1596 if (multibyte) 1597 { 1598 c = STRING_CHAR_AND_LENGTH (str + i_byte, 1599 size_byte - i_byte, len); 1600 if (CHAR_VALID_P (c, 0)) 1601 i_byte += len; 1602 else 1603 c = str[i_byte++]; 1604 } 1605 else 1606 c = str[i_byte++]; 1607 1608 QUIT; 1609 1610 if (c == '\n' && print_escape_newlines) 1611 { 1612 PRINTCHAR ('\\'); 1613 PRINTCHAR ('n'); 1614 } 1615 else if (c == '\f' && print_escape_newlines) 1616 { 1617 PRINTCHAR ('\\'); 1618 PRINTCHAR ('f'); 1619 } 1620 else if (multibyte 1621 && ! ASCII_BYTE_P (c) 1622 && (SINGLE_BYTE_CHAR_P (c) || print_escape_multibyte)) 1623 { 1624 /* When multibyte is disabled, 1625 print multibyte string chars using hex escapes. 1626 For a char code that could be in a unibyte string, 1627 when found in a multibyte string, always use a hex escape 1628 so it reads back as multibyte. */ 1629 unsigned char outbuf[50]; 1630 sprintf (outbuf, "\\x%x", c); 1631 strout (outbuf, -1, -1, printcharfun, 0); 1632 need_nonhex = 1; 1633 } 1634 else if (! multibyte 1635 && SINGLE_BYTE_CHAR_P (c) && ! ASCII_BYTE_P (c) 1636 && print_escape_nonascii) 1637 { 1638 /* When printing in a multibyte buffer 1639 or when explicitly requested, 1640 print single-byte non-ASCII string chars 1641 using octal escapes. */ 1642 unsigned char outbuf[5]; 1643 sprintf (outbuf, "\\%03o", c); 1644 strout (outbuf, -1, -1, printcharfun, 0); 1645 } 1646 else 1647 { 1648 /* If we just had a hex escape, and this character 1649 could be taken as part of it, 1650 output `\ ' to prevent that. */ 1651 if (need_nonhex) 1652 { 1653 need_nonhex = 0; 1654 if ((c >= 'a' && c <= 'f') 1655 || (c >= 'A' && c <= 'F') 1656 || (c >= '0' && c <= '9')) 1657 strout ("\\ ", -1, -1, printcharfun, 0); 1658 } 1659 1660 if (c == '\"' || c == '\\') 1661 PRINTCHAR ('\\'); 1662 PRINTCHAR (c); 1663 } 1664 } 1665 PRINTCHAR ('\"'); 1666 1667 if (!NULL_INTERVAL_P (STRING_INTERVALS (obj))) 1668 { 1669 traverse_intervals (STRING_INTERVALS (obj), 1670 0, print_interval, printcharfun); 1671 PRINTCHAR (')'); 1672 } 1673 1674 UNGCPRO; 1675 } 1676 break; 1677 1678 case Lisp_Symbol: 1679 { 1680 register int confusing; 1681 register unsigned char *p = SDATA (SYMBOL_NAME (obj)); 1682 register unsigned char *end = p + SBYTES (SYMBOL_NAME (obj)); 1683 register int c; 1684 int i, i_byte, size_byte; 1685 Lisp_Object name; 1686 1687 name = SYMBOL_NAME (obj); 1688 1689 if (p != end && (*p == '-' || *p == '+')) p++; 1690 if (p == end) 1691 confusing = 0; 1692 /* If symbol name begins with a digit, and ends with a digit, 1693 and contains nothing but digits and `e', it could be treated 1694 as a number. So set CONFUSING. 1695 1696 Symbols that contain periods could also be taken as numbers, 1697 but periods are always escaped, so we don't have to worry 1698 about them here. */ 1699 else if (*p >= '0' && *p <= '9' 1700 && end[-1] >= '0' && end[-1] <= '9') 1701 { 1702 while (p != end && ((*p >= '0' && *p <= '9') 1703 /* Needed for \2e10. */ 1704 || *p == 'e')) 1705 p++; 1706 confusing = (end == p); 1707 } 1708 else 1709 confusing = 0; 1710 1711 if (! NILP (Vprint_gensym) && !SYMBOL_INTERNED_P (obj)) 1712 { 1713 PRINTCHAR ('#'); 1714 PRINTCHAR (':'); 1715 } 1716 1717 size_byte = SBYTES (name); 1718 1719 for (i = 0, i_byte = 0; i_byte < size_byte;) 1720 { 1721 /* Here, we must convert each multi-byte form to the 1722 corresponding character code before handing it to PRINTCHAR. */ 1723 FETCH_STRING_CHAR_ADVANCE (c, name, i, i_byte); 1724 QUIT; 1725 1726 if (escapeflag) 1727 { 1728 if (c == '\"' || c == '\\' || c == '\'' 1729 || c == ';' || c == '#' || c == '(' || c == ')' 1730 || c == ',' || c =='.' || c == '`' 1731 || c == '[' || c == ']' || c == '?' || c <= 040 1732 || confusing) 1733 PRINTCHAR ('\\'), confusing = 0; 1734 } 1735 PRINTCHAR (c); 1736 } 1737 } 1738 break; 1739 1740 case Lisp_Cons: 1741 /* If deeper than spec'd depth, print placeholder. */ 1742 if (INTEGERP (Vprint_level) 1743 && print_depth > XINT (Vprint_level)) 1744 strout ("...", -1, -1, printcharfun, 0); 1745 else if (print_quoted && CONSP (XCDR (obj)) && NILP (XCDR (XCDR (obj))) 1746 && (EQ (XCAR (obj), Qquote))) 1747 { 1748 PRINTCHAR ('\''); 1749 print_object (XCAR (XCDR (obj)), printcharfun, escapeflag); 1750 } 1751 else if (print_quoted && CONSP (XCDR (obj)) && NILP (XCDR (XCDR (obj))) 1752 && (EQ (XCAR (obj), Qfunction))) 1753 { 1754 PRINTCHAR ('#'); 1755 PRINTCHAR ('\''); 1756 print_object (XCAR (XCDR (obj)), printcharfun, escapeflag); 1757 } 1758 else if (print_quoted && CONSP (XCDR (obj)) && NILP (XCDR (XCDR (obj))) 1759 && ! old_backquote_output 1760 && ((EQ (XCAR (obj), Qbackquote) 1761 || EQ (XCAR (obj), Qcomma) 1762 || EQ (XCAR (obj), Qcomma_at) 1763 || EQ (XCAR (obj), Qcomma_dot)))) 1764 { 1765 print_object (XCAR (obj), printcharfun, 0); 1766 print_object (XCAR (XCDR (obj)), printcharfun, escapeflag); 1767 } 1768 else 1769 { 1770 PRINTCHAR ('('); 1771 1772 /* If the first element is a backquote form, 1773 print it old-style so it won't be misunderstood. */ 1774 if (print_quoted && CONSP (XCAR (obj)) 1775 && CONSP (XCDR (XCAR (obj))) 1776 && NILP (XCDR (XCDR (XCAR (obj)))) 1777 && EQ (XCAR (XCAR (obj)), Qbackquote)) 1778 { 1779 Lisp_Object tem; 1780 tem = XCAR (obj); 1781 PRINTCHAR ('('); 1782 1783 print_object (Qbackquote, printcharfun, 0); 1784 PRINTCHAR (' '); 1785 1786 ++old_backquote_output; 1787 print_object (XCAR (XCDR (tem)), printcharfun, 0); 1788 --old_backquote_output; 1789 PRINTCHAR (')'); 1790 1791 obj = XCDR (obj); 1792 } 1793 1794 { 1795 int print_length, i; 1796 Lisp_Object halftail = obj; 1797 1798 /* Negative values of print-length are invalid in CL. 1799 Treat them like nil, as CMUCL does. */ 1800 if (NATNUMP (Vprint_length)) 1801 print_length = XFASTINT (Vprint_length); 1802 else 1803 print_length = 0; 1804 1805 i = 0; 1806 while (CONSP (obj)) 1807 { 1808 /* Detect circular list. */ 1809 if (NILP (Vprint_circle)) 1810 { 1811 /* Simple but imcomplete way. */ 1812 if (i != 0 && EQ (obj, halftail)) 1813 { 1814 sprintf (buf, " . #%d", i / 2); 1815 strout (buf, -1, -1, printcharfun, 0); 1816 goto end_of_list; 1817 } 1818 } 1819 else 1820 { 1821 /* With the print-circle feature. */ 1822 if (i != 0) 1823 { 1824 int i; 1825 for (i = 0; i < print_number_index; i++) 1826 if (EQ (PRINT_NUMBER_OBJECT (Vprint_number_table, i), 1827 obj)) 1828 { 1829 if (NILP (PRINT_NUMBER_STATUS (Vprint_number_table, i))) 1830 { 1831 strout (" . ", 3, 3, printcharfun, 0); 1832 print_object (obj, printcharfun, escapeflag); 1833 } 1834 else 1835 { 1836 sprintf (buf, " . #%d#", i + 1); 1837 strout (buf, -1, -1, printcharfun, 0); 1838 } 1839 goto end_of_list; 1840 } 1841 } 1842 } 1843 1844 if (i++) 1845 PRINTCHAR (' '); 1846 1847 if (print_length && i > print_length) 1848 { 1849 strout ("...", 3, 3, printcharfun, 0); 1850 goto end_of_list; 1851 } 1852 1853 print_object (XCAR (obj), printcharfun, escapeflag); 1854 1855 obj = XCDR (obj); 1856 if (!(i & 1)) 1857 halftail = XCDR (halftail); 1858 } 1859 } 1860 1861 /* OBJ non-nil here means it's the end of a dotted list. */ 1862 if (!NILP (obj)) 1863 { 1864 strout (" . ", 3, 3, printcharfun, 0); 1865 print_object (obj, printcharfun, escapeflag); 1866 } 1867 1868 end_of_list: 1869 PRINTCHAR (')'); 1870 } 1871 break; 1872 1873 case Lisp_Vectorlike: 1874 if (PROCESSP (obj)) 1875 { 1876 if (escapeflag) 1877 { 1878 strout ("#<process ", -1, -1, printcharfun, 0); 1879 print_string (XPROCESS (obj)->name, printcharfun); 1880 PRINTCHAR ('>'); 1881 } 1882 else 1883 print_string (XPROCESS (obj)->name, printcharfun); 1884 } 1885 else if (BOOL_VECTOR_P (obj)) 1886 { 1887 register int i; 1888 register unsigned char c; 1889 struct gcpro gcpro1; 1890 int size_in_chars 1891 = ((XBOOL_VECTOR (obj)->size + BOOL_VECTOR_BITS_PER_CHAR - 1) 1892 / BOOL_VECTOR_BITS_PER_CHAR); 1893 1894 GCPRO1 (obj); 1895 1896 PRINTCHAR ('#'); 1897 PRINTCHAR ('&'); 1898 sprintf (buf, "%ld", (long) XBOOL_VECTOR (obj)->size); 1899 strout (buf, -1, -1, printcharfun, 0); 1900 PRINTCHAR ('\"'); 1901 1902 /* Don't print more characters than the specified maximum. 1903 Negative values of print-length are invalid. Treat them 1904 like a print-length of nil. */ 1905 if (NATNUMP (Vprint_length) 1906 && XFASTINT (Vprint_length) < size_in_chars) 1907 size_in_chars = XFASTINT (Vprint_length); 1908 1909 for (i = 0; i < size_in_chars; i++) 1910 { 1911 QUIT; 1912 c = XBOOL_VECTOR (obj)->data[i]; 1913 if (c == '\n' && print_escape_newlines) 1914 { 1915 PRINTCHAR ('\\'); 1916 PRINTCHAR ('n'); 1917 } 1918 else if (c == '\f' && print_escape_newlines) 1919 { 1920 PRINTCHAR ('\\'); 1921 PRINTCHAR ('f'); 1922 } 1923 else if (c > '\177') 1924 { 1925 /* Use octal escapes to avoid encoding issues. */ 1926 PRINTCHAR ('\\'); 1927 PRINTCHAR ('0' + ((c >> 6) & 3)); 1928 PRINTCHAR ('0' + ((c >> 3) & 7)); 1929 PRINTCHAR ('0' + (c & 7)); 1930 } 1931 else 1932 { 1933 if (c == '\"' || c == '\\') 1934 PRINTCHAR ('\\'); 1935 PRINTCHAR (c); 1936 } 1937 } 1938 PRINTCHAR ('\"'); 1939 1940 UNGCPRO; 1941 } 1942 else if (SUBRP (obj)) 1943 { 1944 strout ("#<subr ", -1, -1, printcharfun, 0); 1945 strout (XSUBR (obj)->symbol_name, -1, -1, printcharfun, 0); 1946 PRINTCHAR ('>'); 1947 } 1948 else if (WINDOWP (obj)) 1949 { 1950 strout ("#<window ", -1, -1, printcharfun, 0); 1951 sprintf (buf, "%ld", (long) XFASTINT (XWINDOW (obj)->sequence_number)); 1952 strout (buf, -1, -1, printcharfun, 0); 1953 if (!NILP (XWINDOW (obj)->buffer)) 1954 { 1955 strout (" on ", -1, -1, printcharfun, 0); 1956 print_string (XBUFFER (XWINDOW (obj)->buffer)->name, printcharfun); 1957 } 1958 PRINTCHAR ('>'); 1959 } 1960 else if (HASH_TABLE_P (obj)) 1961 { 1962 struct Lisp_Hash_Table *h = XHASH_TABLE (obj); 1963 strout ("#<hash-table", -1, -1, printcharfun, 0); 1964 if (SYMBOLP (h->test)) 1965 { 1966 PRINTCHAR (' '); 1967 PRINTCHAR ('\''); 1968 strout (SDATA (SYMBOL_NAME (h->test)), -1, -1, printcharfun, 0); 1969 PRINTCHAR (' '); 1970 strout (SDATA (SYMBOL_NAME (h->weak)), -1, -1, printcharfun, 0); 1971 PRINTCHAR (' '); 1972 sprintf (buf, "%ld/%ld", (long) XFASTINT (h->count), 1973 (long) XVECTOR (h->next)->size); 1974 strout (buf, -1, -1, printcharfun, 0); 1975 } 1976 sprintf (buf, " 0x%lx", (unsigned long) h); 1977 strout (buf, -1, -1, printcharfun, 0); 1978 PRINTCHAR ('>'); 1979 } 1980 else if (BUFFERP (obj)) 1981 { 1982 if (NILP (XBUFFER (obj)->name)) 1983 strout ("#<killed buffer>", -1, -1, printcharfun, 0); 1984 else if (escapeflag) 1985 { 1986 strout ("#<buffer ", -1, -1, printcharfun, 0); 1987 print_string (XBUFFER (obj)->name, printcharfun); 1988 PRINTCHAR ('>'); 1989 } 1990 else 1991 print_string (XBUFFER (obj)->name, printcharfun); 1992 } 1993 else if (WINDOW_CONFIGURATIONP (obj)) 1994 { 1995 strout ("#<window-configuration>", -1, -1, printcharfun, 0); 1996 } 1997 else if (FRAMEP (obj)) 1998 { 1999 strout ((FRAME_LIVE_P (XFRAME (obj)) 2000 ? "#<frame " : "#<dead frame "), 2001 -1, -1, printcharfun, 0); 2002 print_string (XFRAME (obj)->name, printcharfun); 2003 sprintf (buf, " 0x%lx", (unsigned long) (XFRAME (obj))); 2004 strout (buf, -1, -1, printcharfun, 0); 2005 PRINTCHAR ('>'); 2006 } 2007 else 2008 { 2009 EMACS_INT size = XVECTOR (obj)->size; 2010 if (COMPILEDP (obj)) 2011 { 2012 PRINTCHAR ('#'); 2013 size &= PSEUDOVECTOR_SIZE_MASK; 2014 } 2015 if (CHAR_TABLE_P (obj)) 2016 { 2017 /* We print a char-table as if it were a vector, 2018 lumping the parent and default slots in with the 2019 character slots. But we add #^ as a prefix. */ 2020 PRINTCHAR ('#'); 2021 PRINTCHAR ('^'); 2022 if (SUB_CHAR_TABLE_P (obj)) 2023 PRINTCHAR ('^'); 2024 size &= PSEUDOVECTOR_SIZE_MASK; 2025 } 2026 if (size & PSEUDOVECTOR_FLAG) 2027 goto badtype; 2028 2029 PRINTCHAR ('['); 2030 { 2031 register int i; 2032 register Lisp_Object tem; 2033 int real_size = size; 2034 2035 /* Don't print more elements than the specified maximum. */ 2036 if (NATNUMP (Vprint_length) 2037 && XFASTINT (Vprint_length) < size) 2038 size = XFASTINT (Vprint_length); 2039 2040 for (i = 0; i < size; i++) 2041 { 2042 if (i) PRINTCHAR (' '); 2043 tem = XVECTOR (obj)->contents[i]; 2044 print_object (tem, printcharfun, escapeflag); 2045 } 2046 if (size < real_size) 2047 strout (" ...", 4, 4, printcharfun, 0); 2048 } 2049 PRINTCHAR (']'); 2050 } 2051 break; 2052 2053 case Lisp_Misc: 2054 switch (XMISCTYPE (obj)) 2055 { 2056 case Lisp_Misc_Marker: 2057 strout ("#<marker ", -1, -1, printcharfun, 0); 2058 /* Do you think this is necessary? */ 2059 if (XMARKER (obj)->insertion_type != 0) 2060 strout ("(moves after insertion) ", -1, -1, printcharfun, 0); 2061 if (! XMARKER (obj)->buffer) 2062 strout ("in no buffer", -1, -1, printcharfun, 0); 2063 else 2064 { 2065 sprintf (buf, "at %d", marker_position (obj)); 2066 strout (buf, -1, -1, printcharfun, 0); 2067 strout (" in ", -1, -1, printcharfun, 0); 2068 print_string (XMARKER (obj)->buffer->name, printcharfun); 2069 } 2070 PRINTCHAR ('>'); 2071 break; 2072 2073 case Lisp_Misc_Overlay: 2074 strout ("#<overlay ", -1, -1, printcharfun, 0); 2075 if (! XMARKER (OVERLAY_START (obj))->buffer) 2076 strout ("in no buffer", -1, -1, printcharfun, 0); 2077 else 2078 { 2079 sprintf (buf, "from %d to %d in ", 2080 marker_position (OVERLAY_START (obj)), 2081 marker_position (OVERLAY_END (obj))); 2082 strout (buf, -1, -1, printcharfun, 0); 2083 print_string (XMARKER (OVERLAY_START (obj))->buffer->name, 2084 printcharfun); 2085 } 2086 PRINTCHAR ('>'); 2087 break; 2088 2089 /* Remaining cases shouldn't happen in normal usage, but let's print 2090 them anyway for the benefit of the debugger. */ 2091 case Lisp_Misc_Free: 2092 strout ("#<misc free cell>", -1, -1, printcharfun, 0); 2093 break; 2094 2095 case Lisp_Misc_Intfwd: 2096 sprintf (buf, "#<intfwd to %ld>", (long) *XINTFWD (obj)->intvar); 2097 strout (buf, -1, -1, printcharfun, 0); 2098 break; 2099 2100 case Lisp_Misc_Boolfwd: 2101 sprintf (buf, "#<boolfwd to %s>", 2102 (*XBOOLFWD (obj)->boolvar ? "t" : "nil")); 2103 strout (buf, -1, -1, printcharfun, 0); 2104 break; 2105 2106 case Lisp_Misc_Objfwd: 2107 strout ("#<objfwd to ", -1, -1, printcharfun, 0); 2108 print_object (*XOBJFWD (obj)->objvar, printcharfun, escapeflag); 2109 PRINTCHAR ('>'); 2110 break; 2111 2112 case Lisp_Misc_Buffer_Objfwd: 2113 strout ("#<buffer_objfwd to ", -1, -1, printcharfun, 0); 2114 print_object (PER_BUFFER_VALUE (current_buffer, 2115 XBUFFER_OBJFWD (obj)->offset), 2116 printcharfun, escapeflag); 2117 PRINTCHAR ('>'); 2118 break; 2119 2120 case Lisp_Misc_Kboard_Objfwd: 2121 strout ("#<kboard_objfwd to ", -1, -1, printcharfun, 0); 2122 print_object (*(Lisp_Object *) ((char *) current_kboard 2123 + XKBOARD_OBJFWD (obj)->offset), 2124 printcharfun, escapeflag); 2125 PRINTCHAR ('>'); 2126 break; 2127 2128 case Lisp_Misc_Buffer_Local_Value: 2129 strout ("#<buffer_local_value ", -1, -1, printcharfun, 0); 2130 goto do_buffer_local; 2131 case Lisp_Misc_Some_Buffer_Local_Value: 2132 strout ("#<some_buffer_local_value ", -1, -1, printcharfun, 0); 2133 do_buffer_local: 2134 strout ("[realvalue] ", -1, -1, printcharfun, 0); 2135 print_object (XBUFFER_LOCAL_VALUE (obj)->realvalue, 2136 printcharfun, escapeflag); 2137 if (XBUFFER_LOCAL_VALUE (obj)->found_for_buffer) 2138 strout ("[local in buffer] ", -1, -1, printcharfun, 0); 2139 else 2140 strout ("[buffer] ", -1, -1, printcharfun, 0); 2141 print_object (XBUFFER_LOCAL_VALUE (obj)->buffer, 2142 printcharfun, escapeflag); 2143 if (XBUFFER_LOCAL_VALUE (obj)->check_frame) 2144 { 2145 if (XBUFFER_LOCAL_VALUE (obj)->found_for_frame) 2146 strout ("[local in frame] ", -1, -1, printcharfun, 0); 2147 else 2148 strout ("[frame] ", -1, -1, printcharfun, 0); 2149 print_object (XBUFFER_LOCAL_VALUE (obj)->frame, 2150 printcharfun, escapeflag); 2151 } 2152 strout ("[alist-elt] ", -1, -1, printcharfun, 0); 2153 print_object (XCAR (XBUFFER_LOCAL_VALUE (obj)->cdr), 2154 printcharfun, escapeflag); 2155 strout ("[default-value] ", -1, -1, printcharfun, 0); 2156 print_object (XCDR (XBUFFER_LOCAL_VALUE (obj)->cdr), 2157 printcharfun, escapeflag); 2158 PRINTCHAR ('>'); 2159 break; 2160 2161 case Lisp_Misc_Save_Value: 2162 strout ("#<save_value ", -1, -1, printcharfun, 0); 2163 sprintf(buf, "ptr=0x%08lx int=%d", 2164 (unsigned long) XSAVE_VALUE (obj)->pointer, 2165 XSAVE_VALUE (obj)->integer); 2166 strout (buf, -1, -1, printcharfun, 0); 2167 PRINTCHAR ('>'); 2168 break; 2169 2170 default: 2171 goto badtype; 2172 } 2173 break; 2174 2175 default: 2176 badtype: 2177 { 2178 /* We're in trouble if this happens! 2179 Probably should just abort () */ 2180 strout ("#<EMACS BUG: INVALID DATATYPE ", -1, -1, printcharfun, 0); 2181 if (MISCP (obj)) 2182 sprintf (buf, "(MISC 0x%04x)", (int) XMISCTYPE (obj)); 2183 else if (VECTORLIKEP (obj)) 2184 sprintf (buf, "(PVEC 0x%08x)", (int) XVECTOR (obj)->size); 2185 else 2186 sprintf (buf, "(0x%02x)", (int) XTYPE (obj)); 2187 strout (buf, -1, -1, printcharfun, 0); 2188 strout (" Save your buffers immediately and please report this bug>", 2189 -1, -1, printcharfun, 0); 2190 } 2191 } 2192 2193 print_depth--; 2194} 2195 2196 2197/* Print a description of INTERVAL using PRINTCHARFUN. 2198 This is part of printing a string that has text properties. */ 2199 2200void 2201print_interval (interval, printcharfun) 2202 INTERVAL interval; 2203 Lisp_Object printcharfun; 2204{ 2205 PRINTCHAR (' '); 2206 print_object (make_number (interval->position), printcharfun, 1); 2207 PRINTCHAR (' '); 2208 print_object (make_number (interval->position + LENGTH (interval)), 2209 printcharfun, 1); 2210 PRINTCHAR (' '); 2211 print_object (interval->plist, printcharfun, 1); 2212} 2213 2214 2215void 2216syms_of_print () 2217{ 2218 Qtemp_buffer_setup_hook = intern ("temp-buffer-setup-hook"); 2219 staticpro (&Qtemp_buffer_setup_hook); 2220 2221 DEFVAR_LISP ("standard-output", &Vstandard_output, 2222 doc: /* Output stream `print' uses by default for outputting a character. 2223This may be any function of one argument. 2224It may also be a buffer (output is inserted before point) 2225or a marker (output is inserted and the marker is advanced) 2226or the symbol t (output appears in the echo area). */); 2227 Vstandard_output = Qt; 2228 Qstandard_output = intern ("standard-output"); 2229 staticpro (&Qstandard_output); 2230 2231 DEFVAR_LISP ("float-output-format", &Vfloat_output_format, 2232 doc: /* The format descriptor string used to print floats. 2233This is a %-spec like those accepted by `printf' in C, 2234but with some restrictions. It must start with the two characters `%.'. 2235After that comes an integer precision specification, 2236and then a letter which controls the format. 2237The letters allowed are `e', `f' and `g'. 2238Use `e' for exponential notation \"DIG.DIGITSeEXPT\" 2239Use `f' for decimal point notation \"DIGITS.DIGITS\". 2240Use `g' to choose the shorter of those two formats for the number at hand. 2241The precision in any of these cases is the number of digits following 2242the decimal point. With `f', a precision of 0 means to omit the 2243decimal point. 0 is not allowed with `e' or `g'. 2244 2245A value of nil means to use the shortest notation 2246that represents the number without losing information. */); 2247 Vfloat_output_format = Qnil; 2248 Qfloat_output_format = intern ("float-output-format"); 2249 staticpro (&Qfloat_output_format); 2250 2251 DEFVAR_LISP ("print-length", &Vprint_length, 2252 doc: /* Maximum length of list to print before abbreviating. 2253A value of nil means no limit. See also `eval-expression-print-length'. */); 2254 Vprint_length = Qnil; 2255 2256 DEFVAR_LISP ("print-level", &Vprint_level, 2257 doc: /* Maximum depth of list nesting to print before abbreviating. 2258A value of nil means no limit. See also `eval-expression-print-level'. */); 2259 Vprint_level = Qnil; 2260 2261 DEFVAR_BOOL ("print-escape-newlines", &print_escape_newlines, 2262 doc: /* Non-nil means print newlines in strings as `\\n'. 2263Also print formfeeds as `\\f'. */); 2264 print_escape_newlines = 0; 2265 2266 DEFVAR_BOOL ("print-escape-nonascii", &print_escape_nonascii, 2267 doc: /* Non-nil means print unibyte non-ASCII chars in strings as \\OOO. 2268\(OOO is the octal representation of the character code.) 2269Only single-byte characters are affected, and only in `prin1'. 2270When the output goes in a multibyte buffer, this feature is 2271enabled regardless of the value of the variable. */); 2272 print_escape_nonascii = 0; 2273 2274 DEFVAR_BOOL ("print-escape-multibyte", &print_escape_multibyte, 2275 doc: /* Non-nil means print multibyte characters in strings as \\xXXXX. 2276\(XXXX is the hex representation of the character code.) 2277This affects only `prin1'. */); 2278 print_escape_multibyte = 0; 2279 2280 DEFVAR_BOOL ("print-quoted", &print_quoted, 2281 doc: /* Non-nil means print quoted forms with reader syntax. 2282I.e., (quote foo) prints as 'foo, (function foo) as #'foo, and backquoted 2283forms print as in the new syntax. */); 2284 print_quoted = 0; 2285 2286 DEFVAR_LISP ("print-gensym", &Vprint_gensym, 2287 doc: /* Non-nil means print uninterned symbols so they will read as uninterned. 2288I.e., the value of (make-symbol \"foobar\") prints as #:foobar. 2289When the uninterned symbol appears within a recursive data structure, 2290and the symbol appears more than once, in addition use the #N# and #N= 2291constructs as needed, so that multiple references to the same symbol are 2292shared once again when the text is read back. */); 2293 Vprint_gensym = Qnil; 2294 2295 DEFVAR_LISP ("print-circle", &Vprint_circle, 2296 doc: /* *Non-nil means print recursive structures using #N= and #N# syntax. 2297If nil, printing proceeds recursively and may lead to 2298`max-lisp-eval-depth' being exceeded or an error may occur: 2299\"Apparently circular structure being printed.\" Also see 2300`print-length' and `print-level'. 2301If non-nil, shared substructures anywhere in the structure are printed 2302with `#N=' before the first occurrence (in the order of the print 2303representation) and `#N#' in place of each subsequent occurrence, 2304where N is a positive decimal integer. */); 2305 Vprint_circle = Qnil; 2306 2307 DEFVAR_LISP ("print-continuous-numbering", &Vprint_continuous_numbering, 2308 doc: /* *Non-nil means number continuously across print calls. 2309This affects the numbers printed for #N= labels and #M# references. 2310See also `print-circle', `print-gensym', and `print-number-table'. 2311This variable should not be set with `setq'; bind it with a `let' instead. */); 2312 Vprint_continuous_numbering = Qnil; 2313 2314 DEFVAR_LISP ("print-number-table", &Vprint_number_table, 2315 doc: /* A vector used internally to produce `#N=' labels and `#N#' references. 2316The Lisp printer uses this vector to detect Lisp objects referenced more 2317than once. 2318 2319When you bind `print-continuous-numbering' to t, you should probably 2320also bind `print-number-table' to nil. This ensures that the value of 2321`print-number-table' can be garbage-collected once the printing is 2322done. If all elements of `print-number-table' are nil, it means that 2323the printing done so far has not found any shared structure or objects 2324that need to be recorded in the table. */); 2325 Vprint_number_table = Qnil; 2326 2327 /* prin1_to_string_buffer initialized in init_buffer_once in buffer.c */ 2328 staticpro (&Vprin1_to_string_buffer); 2329 2330 defsubr (&Sprin1); 2331 defsubr (&Sprin1_to_string); 2332 defsubr (&Serror_message_string); 2333 defsubr (&Sprinc); 2334 defsubr (&Sprint); 2335 defsubr (&Sterpri); 2336 defsubr (&Swrite_char); 2337 defsubr (&Sexternal_debugging_output); 2338#ifdef WITH_REDIRECT_DEBUGGING_OUTPUT 2339 defsubr (&Sredirect_debugging_output); 2340#endif 2341 2342 Qexternal_debugging_output = intern ("external-debugging-output"); 2343 staticpro (&Qexternal_debugging_output); 2344 2345 Qprint_escape_newlines = intern ("print-escape-newlines"); 2346 staticpro (&Qprint_escape_newlines); 2347 2348 Qprint_escape_multibyte = intern ("print-escape-multibyte"); 2349 staticpro (&Qprint_escape_multibyte); 2350 2351 Qprint_escape_nonascii = intern ("print-escape-nonascii"); 2352 staticpro (&Qprint_escape_nonascii); 2353 2354 defsubr (&Swith_output_to_temp_buffer); 2355} 2356 2357/* arch-tag: bc797170-94ae-41de-86e3-75e20f8f7a39 2358 (do not change this comment) */ 2359