Mercurial > hg > xemacs-beta
annotate src/print.c @ 4407:4ee73bbe4f8e
Always use boyer_moore in ASCII or Latin-1 buffers with ASCII search strings.
2007-12-26 Aidan Kehoe <kehoea@parhasard.net>
* casetab.c:
Extend and correct some case table documentation.
* search.c (search_buffer):
Correct a bug where only the first entry for a character in the
case equivalence table was examined in determining if the
Boyer-Moore search algorithm is appropriate.
If there are case mappings outside of the charset and row of the
characters specified in the search string, those case mappings can
be safely ignored (and Boyer-Moore search can be used) if we know
from the buffer statistics that the corresponding characters cannot
occur.
* search.c (boyer_moore):
Assert that we haven't been passed a string with varying
characters sets or rows within character sets. That's what
simple_search is for.
In the very rare event that a character in the search string has a
canonical case mapping that is not in the same character set and
row, don't try to search for the canonical character, search for
some other character that is in the the desired character set and
row. Assert that the case table isn't corrupt.
Do not search for any character case mappings that cannot possibly
occur in the buffer, given the buffer metadata about its
contents.
| author | Aidan Kehoe <kehoea@parhasard.net> |
|---|---|
| date | Wed, 26 Dec 2007 17:30:16 +0100 |
| parents | d9eb5ea14f65 |
| children | cacc942c0d0f |
| rev | line source |
|---|---|
| 428 | 1 /* Lisp object printing and output streams. |
| 2 Copyright (C) 1985, 1986, 1988, 1992-1995 Free Software Foundation, Inc. | |
| 3063 | 3 Copyright (C) 1995, 1996, 2000, 2001, 2002, 2003, 2005 Ben Wing. |
| 428 | 4 |
| 5 This file is part of XEmacs. | |
| 6 | |
| 7 XEmacs is free software; you can redistribute it and/or modify it | |
| 8 under the terms of the GNU General Public License as published by the | |
| 9 Free Software Foundation; either version 2, or (at your option) any | |
| 10 later version. | |
| 11 | |
| 12 XEmacs is distributed in the hope that it will be useful, but WITHOUT | |
| 13 ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or | |
| 14 FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License | |
| 15 for more details. | |
| 16 | |
| 17 You should have received a copy of the GNU General Public License | |
| 18 along with XEmacs; see the file COPYING. If not, write to | |
| 19 the Free Software Foundation, Inc., 59 Temple Place - Suite 330, | |
| 20 Boston, MA 02111-1307, USA. */ | |
| 21 | |
| 22 /* Synched up with: Not synched with FSF. */ | |
| 23 | |
| 24 /* This file has been Mule-ized. */ | |
| 25 | |
| 771 | 26 /* Seriously divergent from FSF by this point. |
| 27 | |
| 28 Seriously hacked on by Ben Wing for Mule. All stdio code also by Ben, | |
| 29 as well as the debugging code (initial version of debug_print(), though, | |
| 30 by Jamie Zawinski) and the _fmt interfaces. Also a fair amount of work | |
| 31 by Hrvoje, e.g. floating-point code and rewriting to avoid O(N^2) | |
| 32 consing when outputting to the echo area. Print-circularity code by | |
| 33 Martin? */ | |
| 428 | 34 |
| 35 #include <config.h> | |
| 36 #include "lisp.h" | |
| 37 | |
| 38 #include "backtrace.h" | |
| 39 #include "buffer.h" | |
| 40 #include "bytecode.h" | |
| 872 | 41 #include "device-impl.h" |
| 428 | 42 #include "extents.h" |
| 43 #include "frame.h" | |
| 44 #include "insdel.h" | |
| 45 #include "lstream.h" | |
| 771 | 46 #include "opaque.h" |
| 800 | 47 |
| 872 | 48 #include "console-tty-impl.h" |
| 49 #include "console-stream-impl.h" | |
| 442 | 50 #ifdef WIN32_NATIVE |
| 51 #include "console-msw.h" | |
| 52 #endif | |
| 428 | 53 |
| 800 | 54 #include "sysfile.h" |
| 55 | |
| 428 | 56 #include <float.h> |
| 57 /* Define if not in float.h */ | |
| 58 #ifndef DBL_DIG | |
| 59 #define DBL_DIG 16 | |
| 60 #endif | |
| 61 | |
| 62 Lisp_Object Vstandard_output, Qstandard_output; | |
| 63 | |
| 64 /* The subroutine object for external-debugging-output is kept here | |
| 65 for the convenience of the debugger. */ | |
| 442 | 66 Lisp_Object Qexternal_debugging_output, Qalternate_debugging_output; |
| 67 | |
| 68 #ifdef HAVE_MS_WINDOWS | |
| 69 Lisp_Object Qmswindows_debugging_output; | |
| 70 #endif | |
| 428 | 71 |
| 72 /* Avoid actual stack overflow in print. */ | |
| 73 static int print_depth; | |
| 74 | |
| 75 /* Detect most circularities to print finite output. */ | |
| 76 #define PRINT_CIRCLE 200 | |
| 77 static Lisp_Object being_printed[PRINT_CIRCLE]; | |
| 78 | |
| 79 /* Maximum length of list or vector to print in full; noninteger means | |
| 80 effectively infinity */ | |
| 81 | |
| 82 Lisp_Object Vprint_length; | |
| 83 Lisp_Object Qprint_length; | |
| 84 | |
| 85 /* Maximum length of string to print in full; noninteger means | |
| 86 effectively infinity */ | |
| 87 | |
| 88 Lisp_Object Vprint_string_length; | |
| 89 Lisp_Object Qprint_string_length; | |
| 90 | |
| 91 /* Maximum depth of list to print in full; noninteger means | |
| 92 effectively infinity. */ | |
| 93 | |
| 94 Lisp_Object Vprint_level; | |
| 95 | |
| 96 /* Label to use when making echo-area messages. */ | |
| 97 | |
| 98 Lisp_Object Vprint_message_label; | |
| 99 | |
| 100 /* Nonzero means print newlines in strings as \n. */ | |
| 101 | |
| 102 int print_escape_newlines; | |
| 103 int print_readably; | |
| 104 | |
| 105 /* Non-nil means print #: before uninterned symbols. | |
| 106 Neither t nor nil means so that and don't clear Vprint_gensym_alist | |
| 107 on entry to and exit from print functions. */ | |
| 108 Lisp_Object Vprint_gensym; | |
| 109 Lisp_Object Vprint_gensym_alist; | |
| 110 | |
| 111 Lisp_Object Qdisplay_error; | |
| 112 Lisp_Object Qprint_message_label; | |
| 113 | |
| 114 /* Force immediate output of all printed data. Used for debugging. */ | |
| 115 int print_unbuffered; | |
| 116 | |
| 117 FILE *termscript; /* Stdio stream being used for copy of all output. */ | |
| 118 | |
| 1346 | 119 static void write_string_to_alternate_debugging_output (const Ibyte *str, |
| 771 | 120 Bytecount len); |
| 121 | |
| 1957 | 122 /* To avoid consing in debug_prin1, we package up variables we need to bind |
| 123 into an opaque object. */ | |
| 124 struct debug_bindings | |
| 125 { | |
| 2367 | 126 int inhibit_non_essential_conversion_operations; |
| 1957 | 127 int print_depth; |
| 128 int print_readably; | |
| 129 int print_unbuffered; | |
| 130 int gc_currently_forbidden; | |
| 131 Lisp_Object Vprint_length; | |
| 132 Lisp_Object Vprint_level; | |
| 133 Lisp_Object Vinhibit_quit; | |
| 134 }; | |
| 135 | |
| 136 static Lisp_Object debug_prin1_bindings; | |
| 428 | 137 |
| 138 | |
| 139 int stdout_needs_newline; | |
| 1346 | 140 int stdout_clear_before_next_output; |
| 428 | 141 |
| 771 | 142 /* Basic function to actually write to a stdio stream or TTY console. */ |
| 143 | |
| 442 | 144 static void |
| 1346 | 145 write_string_to_stdio_stream_1 (FILE *stream, struct console *con, |
| 146 const Ibyte *ptr, Bytecount len, | |
| 147 int must_flush) | |
| 428 | 148 { |
| 771 | 149 Extbyte *extptr = 0; |
| 150 Bytecount extlen = 0; | |
| 151 int output_is_std_handle = | |
| 152 stream ? stream == stdout || stream == stderr : | |
| 153 CONSOLE_TTY_DATA (con)->is_stdio; | |
| 154 | |
| 155 if (stream || output_is_std_handle) | |
| 156 { | |
| 2367 | 157 if (initialized && !inhibit_non_essential_conversion_operations) |
| 771 | 158 TO_EXTERNAL_FORMAT (DATA, (ptr, len), |
| 159 ALLOCA, (extptr, extlen), | |
| 160 Qterminal); | |
| 161 else | |
| 162 { | |
| 2367 | 163 #ifdef NON_ASCII_INTERNAL_FORMAT |
| 164 #error Do something here | |
| 165 #else | |
| 771 | 166 extptr = (Extbyte *) ptr; |
| 167 extlen = (Bytecount) len; | |
| 2367 | 168 #endif |
| 771 | 169 } |
| 170 } | |
| 171 | |
| 428 | 172 if (stream) |
| 173 { | |
| 442 | 174 #ifdef WIN32_NATIVE |
| 175 HANDLE errhand = GetStdHandle (STD_INPUT_HANDLE); | |
| 176 int no_useful_stderr = errhand == 0 || errhand == INVALID_HANDLE_VALUE; | |
| 177 | |
| 178 if (!no_useful_stderr) | |
| 179 no_useful_stderr = !PeekNamedPipe (errhand, 0, 0, 0, 0, 0); | |
| 180 /* we typically have no useful stdout/stderr under windows if we're | |
| 181 being invoked graphically. */ | |
| 182 if (no_useful_stderr) | |
| 771 | 183 mswindows_output_console_string (ptr, len); |
| 442 | 184 else |
| 428 | 185 #endif |
| 442 | 186 { |
| 771 | 187 retry_fwrite (extptr, 1, extlen, stream); |
| 442 | 188 #ifdef WIN32_NATIVE |
| 189 /* Q122442 says that pipes are "treated as files, not as | |
| 190 devices", and that this is a feature. Before I found that | |
| 191 article, I thought it was a bug. Thanks MS, I feel much | |
| 192 better now. - kkm */ | |
| 193 must_flush = 1; | |
| 194 #endif | |
| 195 if (must_flush) | |
| 196 fflush (stream); | |
| 197 } | |
| 428 | 198 } |
| 199 else | |
| 771 | 200 /* The stream itself does conversion to external format */ |
| 201 Lstream_write (XLSTREAM (CONSOLE_TTY_DATA (con)->outstream), ptr, len); | |
| 442 | 202 |
| 203 if (output_is_std_handle) | |
| 428 | 204 { |
| 205 if (termscript) | |
| 206 { | |
| 771 | 207 retry_fwrite (extptr, 1, extlen, termscript); |
| 428 | 208 fflush (termscript); |
| 209 } | |
| 1346 | 210 stdout_needs_newline = (ptr[len - 1] != '\n'); |
| 428 | 211 } |
| 212 } | |
| 213 | |
| 1346 | 214 /* Write to a stdio stream or TTY console, first clearing the left side |
| 215 if necessary. */ | |
| 216 | |
| 217 static void | |
| 218 write_string_to_stdio_stream (FILE *stream, struct console *con, | |
| 219 const Ibyte *ptr, Bytecount len, | |
| 220 int must_flush) | |
| 221 { | |
| 222 if (stdout_clear_before_next_output && | |
| 223 (stream ? stream == stdout || stream == stderr : | |
| 224 CONSOLE_TTY_DATA (con)->is_stdio)) | |
| 225 { | |
| 226 if (stdout_needs_newline) | |
| 227 write_string_to_stdio_stream_1 (stream, con, (Ibyte *) "\n", 1, | |
| 228 must_flush); | |
| 229 stdout_clear_before_next_output = 0; | |
| 230 } | |
| 231 | |
| 232 write_string_to_stdio_stream_1 (stream, con, ptr, len, must_flush); | |
| 233 } | |
| 234 | |
| 235 /* | |
| 236 EXT_PRINT_STDOUT = stdout or its equivalent (may be a | |
| 237 console window under MS Windows) | |
| 238 EXT_PRINT_STDERR = stderr or its equivalent (may be a | |
| 239 console window under MS Windows) | |
| 240 EXT_PRINT_ALTERNATE = an internal character array; see | |
| 241 `alternate-debugging-output' | |
| 242 EXT_PRINT_MSWINDOWS = Under MS Windows, the "debugging output" that | |
| 243 debuggers can hook into; uses OutputDebugString() | |
| 244 system call | |
| 245 EXT_PRINT_ALL = all of the above except stdout | |
| 246 */ | |
| 247 | |
| 248 enum ext_print | |
| 249 { | |
| 250 EXT_PRINT_STDOUT = 1, | |
| 251 EXT_PRINT_STDERR = 2, | |
| 252 EXT_PRINT_ALTERNATE = 4, | |
| 253 EXT_PRINT_MSWINDOWS = 8, | |
| 254 EXT_PRINT_ALL = 14 | |
| 255 }; | |
| 256 | |
| 257 static void | |
| 258 write_string_to_external_output (const Ibyte *ptr, Bytecount len, | |
| 259 int dest) | |
| 260 { | |
| 261 if (dest & EXT_PRINT_STDOUT) | |
| 262 write_string_to_stdio_stream (stdout, 0, ptr, len, 1); | |
| 263 if (dest & EXT_PRINT_STDERR) | |
| 264 write_string_to_stdio_stream (stderr, 0, ptr, len, 1); | |
| 265 if (dest & EXT_PRINT_ALTERNATE) | |
| 266 write_string_to_alternate_debugging_output (ptr, len); | |
| 267 #ifdef WIN32_NATIVE | |
| 268 if (dest & EXT_PRINT_MSWINDOWS) | |
| 269 write_string_to_mswindows_debugging_output (ptr, len); | |
| 270 #endif | |
| 271 } | |
| 272 | |
| 273 /* #### The following function should make use of a call to the | |
| 274 emacs_vsprintf_*() functions rather than just using vsprintf. This is | |
| 275 the only way to ensure that I18N3 works properly (many implementations | |
| 276 of the *printf() functions, including the ones included in glibc, do not | |
| 277 implement the %###$ argument-positioning syntax). | |
| 442 | 278 |
| 279 Note, however, that to do this, we'd have to | |
| 280 | |
| 281 1) pre-allocate all the lstreams and do whatever else was necessary | |
| 282 to make sure that no allocation occurs, since these functions may be | |
| 283 called from fatal_error_signal(). | |
| 284 | |
| 285 2) (to be really correct) make a new lstream that outputs using | |
| 1346 | 286 mswindows_output_console_string(). |
| 287 | |
| 288 3) A reasonable compromise might be to use emacs_vsprintf() when we're | |
| 289 in a safe state, and when not, use plain vsprintf(). */ | |
| 442 | 290 |
| 771 | 291 static void |
| 1346 | 292 write_string_to_external_output_va (const CIbyte *fmt, va_list args, |
| 293 int dest) | |
| 442 | 294 { |
| 867 | 295 Ibyte kludge[8192]; |
| 771 | 296 Bytecount kludgelen; |
| 297 | |
| 2367 | 298 if (initialized && !inhibit_non_essential_conversion_operations) |
| 771 | 299 fmt = GETTEXT (fmt); |
| 867 | 300 vsprintf ((CIbyte *) kludge, fmt, args); |
| 771 | 301 kludgelen = qxestrlen (kludge); |
| 1346 | 302 write_string_to_external_output (kludge, kludgelen, dest); |
| 442 | 303 } |
| 304 | |
| 771 | 305 /* Output portably to stderr or its equivalent (i.e. may be a console |
| 306 window under MS Windows); do external-format conversion and call GETTEXT | |
| 307 on the format string. Automatically flush when done. | |
| 442 | 308 |
| 2731 | 309 NOTE: CIbyte means "internal format" data. This includes the "..." |
| 310 arguments. For numerical arguments, we have to assume that vsprintf | |
| 311 will be a good boy and format them as ASCII. For Mule internal coding | |
| 312 (and UTF-8 internal coding, if/when we get it), it is safe to pass | |
| 313 string values in internal format to be formatted, because zero octets | |
| 314 only occur in the NUL character itself. Similarly, it is safe to pass | |
| 315 pure ASCII literal strings for these functions. *Everything else must | |
| 316 be converted, including all external data.* | |
| 317 | |
| 318 This function is safe to use even when not initialized or when dying -- | |
| 319 we don't do conversion in such cases. */ | |
| 771 | 320 |
| 321 void | |
| 867 | 322 stderr_out (const CIbyte *fmt, ...) |
| 442 | 323 { |
| 324 va_list args; | |
| 325 va_start (args, fmt); | |
| 1346 | 326 write_string_to_external_output_va (fmt, args, EXT_PRINT_STDERR); |
| 442 | 327 va_end (args); |
| 328 } | |
| 329 | |
| 771 | 330 /* Output portably to stdout or its equivalent (i.e. may be a console |
| 331 window under MS Windows). Works like stderr_out(). */ | |
| 442 | 332 |
| 771 | 333 void |
| 867 | 334 stdout_out (const CIbyte *fmt, ...) |
| 442 | 335 { |
| 336 va_list args; | |
| 337 va_start (args, fmt); | |
| 1346 | 338 write_string_to_external_output_va (fmt, args, EXT_PRINT_STDOUT); |
| 339 va_end (args); | |
| 340 } | |
| 341 | |
| 342 /* Output portably to print destination as specified by DEST. */ | |
| 343 | |
| 344 void | |
| 345 external_out (int dest, const CIbyte *fmt, ...) | |
| 346 { | |
| 347 va_list args; | |
| 348 va_start (args, fmt); | |
| 349 write_string_to_external_output_va (fmt, args, dest); | |
| 442 | 350 va_end (args); |
| 771 | 351 } |
| 352 | |
| 353 /* Output portably to stderr or its equivalent (i.e. may be a console | |
| 354 window under MS Windows), as well as alternate-debugging-output and | |
| 355 (under MS Windows) the C debugging output, i.e. OutputDebugString(). | |
| 356 Works like stderr_out(). */ | |
| 357 | |
| 358 void | |
| 867 | 359 debug_out (const CIbyte *fmt, ...) |
| 771 | 360 { |
| 361 va_list args; | |
| 362 va_start (args, fmt); | |
| 1346 | 363 write_string_to_external_output_va (fmt, args, EXT_PRINT_ALL); |
| 771 | 364 va_end (args); |
| 442 | 365 } |
| 366 | |
| 367 DOESNT_RETURN | |
| 867 | 368 fatal (const CIbyte *fmt, ...) |
| 442 | 369 { |
| 370 va_list args; | |
| 371 va_start (args, fmt); | |
| 372 | |
| 771 | 373 stderr_out ("\nXEmacs: fatal error: "); |
| 1346 | 374 write_string_to_external_output_va (fmt, args, EXT_PRINT_STDERR); |
| 442 | 375 stderr_out ("\n"); |
| 376 | |
| 377 va_end (args); | |
| 378 exit (1); | |
| 379 } | |
| 380 | |
| 428 | 381 /* Write a string to the output location specified in FUNCTION. |
| 382 Arguments NONRELOC, RELOC, OFFSET, and LEN are as in | |
| 771 | 383 buffer_insert_string_1() in insdel.c. |
| 384 | |
| 385 FUNCTION is one of | |
| 386 | |
| 387 -- an lstream | |
| 388 -- a buffer (insert at point and advance point) | |
| 389 -- a marker (insert at marker and advance marker) | |
| 390 -- a frame (append to echo area; clear echo area first if | |
| 391 `print-message-label' has changed since the last time) | |
| 392 -- t or nil (send to stdout) | |
| 393 -- a Lisp function of one argument (call to get data output) | |
| 394 | |
| 395 Use Qexternal_debugging_output to get output to stderr. | |
| 396 */ | |
| 428 | 397 |
| 398 static void | |
| 867 | 399 output_string (Lisp_Object function, const Ibyte *nonreloc, |
| 428 | 400 Lisp_Object reloc, Bytecount offset, Bytecount len) |
| 401 { | |
| 402 /* This function can GC */ | |
| 403 Charcount cclen; | |
| 404 /* We change the value of nonreloc (fetching it from reloc as | |
| 405 necessary), but we don't want to pass this changed value on to | |
| 406 other functions that take both a nonreloc and a reloc, or things | |
| 407 may get confused and an assertion failure in | |
| 408 fixup_internal_substring() may get triggered. */ | |
| 867 | 409 const Ibyte *newnonreloc = nonreloc; |
| 428 | 410 struct gcpro gcpro1, gcpro2; |
| 411 | |
| 412 /* Emacs won't print while GCing, but an external debugger might */ | |
| 771 | 413 #ifdef NO_PRINT_DURING_GC |
| 428 | 414 if (gc_in_progress) return; |
| 771 | 415 #endif |
| 428 | 416 |
| 417 /* Perhaps not necessary but probably safer. */ | |
| 418 GCPRO2 (function, reloc); | |
| 419 | |
| 420 fixup_internal_substring (newnonreloc, reloc, offset, &len); | |
| 421 | |
| 422 if (STRINGP (reloc)) | |
| 771 | 423 { |
| 793 | 424 cclen = string_offset_byte_to_char_len (reloc, offset, len); |
| 771 | 425 newnonreloc = XSTRING_DATA (reloc); |
| 426 } | |
| 427 else | |
| 428 cclen = bytecount_to_charcount (newnonreloc + offset, len); | |
| 428 | 429 |
| 430 if (LSTREAMP (function)) | |
| 431 { | |
| 432 if (STRINGP (reloc)) | |
| 433 { | |
| 434 /* Protect against Lstream_write() causing a GC and | |
| 435 relocating the string. For small strings, we do it by | |
| 436 alloc'ing the string and using a copy; for large strings, | |
| 437 we inhibit GC. */ | |
| 438 if (len < 65536) | |
| 439 { | |
| 2367 | 440 Ibyte *copied = alloca_ibytes (len); |
| 428 | 441 memcpy (copied, newnonreloc + offset, len); |
| 442 Lstream_write (XLSTREAM (function), copied, len); | |
| 443 } | |
| 1957 | 444 else if (gc_currently_forbidden) |
| 445 { | |
| 446 /* Avoid calling begin_gc_forbidden, which conses. We can reach | |
| 447 this point from the cons debug code, which will get us into | |
| 448 an infinite loop if we cons again. */ | |
| 449 Lstream_write (XLSTREAM (function), newnonreloc + offset, len); | |
| 450 } | |
| 428 | 451 else |
| 452 { | |
| 771 | 453 int speccount = begin_gc_forbidden (); |
| 428 | 454 Lstream_write (XLSTREAM (function), newnonreloc + offset, len); |
| 771 | 455 unbind_to (speccount); |
| 428 | 456 } |
| 457 } | |
| 458 else | |
| 459 Lstream_write (XLSTREAM (function), newnonreloc + offset, len); | |
| 460 | |
| 461 if (print_unbuffered) | |
| 462 Lstream_flush (XLSTREAM (function)); | |
| 463 } | |
| 464 else if (BUFFERP (function)) | |
| 465 { | |
| 466 CHECK_LIVE_BUFFER (function); | |
| 467 buffer_insert_string (XBUFFER (function), nonreloc, reloc, offset, len); | |
| 468 } | |
| 469 else if (MARKERP (function)) | |
| 470 { | |
| 471 /* marker_position() will err if marker doesn't point anywhere. */ | |
| 665 | 472 Charbpos spoint = marker_position (function); |
| 428 | 473 |
| 474 buffer_insert_string_1 (XMARKER (function)->buffer, | |
| 475 spoint, nonreloc, reloc, offset, len, | |
| 476 0); | |
| 477 Fset_marker (function, make_int (spoint + cclen), | |
| 478 Fmarker_buffer (function)); | |
| 479 } | |
| 480 else if (FRAMEP (function)) | |
| 481 { | |
| 482 /* This gets used by functions not invoking print_prepare(), | |
| 483 such as Fwrite_char, Fterpri, etc.. */ | |
| 484 struct frame *f = XFRAME (function); | |
| 485 CHECK_LIVE_FRAME (function); | |
| 486 | |
| 487 if (!EQ (Vprint_message_label, echo_area_status (f))) | |
| 488 clear_echo_area_from_print (f, Qnil, 1); | |
| 489 echo_area_append (f, nonreloc, reloc, offset, len, Vprint_message_label); | |
| 490 } | |
| 491 else if (EQ (function, Qt) || EQ (function, Qnil)) | |
| 492 { | |
| 771 | 493 write_string_to_stdio_stream (stdout, 0, newnonreloc + offset, len, |
| 494 print_unbuffered); | |
| 495 } | |
| 496 else if (EQ (function, Qexternal_debugging_output)) | |
| 497 { | |
| 498 /* This is not strictly necessary, and somewhat of a hack, but it | |
| 499 avoids having each character passed separately to | |
| 500 `external-debugging-output'. #### Why do we pass each character | |
| 501 separately, anyway? | |
| 502 */ | |
| 503 write_string_to_stdio_stream (stderr, 0, newnonreloc + offset, len, | |
| 504 print_unbuffered); | |
| 428 | 505 } |
| 506 else | |
| 507 { | |
| 771 | 508 Charcount ccoff; |
| 428 | 509 Charcount iii; |
| 510 | |
| 771 | 511 if (STRINGP (reloc)) |
| 793 | 512 ccoff = string_index_byte_to_char (reloc, offset); |
| 771 | 513 else |
| 514 ccoff = bytecount_to_charcount (newnonreloc, offset); | |
| 515 | |
| 516 if (STRINGP (reloc)) | |
| 428 | 517 { |
| 771 | 518 for (iii = ccoff; iii < cclen + ccoff; iii++) |
| 519 { | |
| 867 | 520 call1 (function, make_char (string_ichar (reloc, iii))); |
| 771 | 521 if (STRINGP (reloc)) |
| 522 newnonreloc = XSTRING_DATA (reloc); | |
| 523 } | |
| 524 } | |
| 525 else | |
| 526 { | |
| 527 for (iii = ccoff; iii < cclen + ccoff; iii++) | |
| 528 { | |
| 529 call1 (function, | |
| 867 | 530 make_char (itext_ichar_n (newnonreloc, iii))); |
| 771 | 531 } |
| 428 | 532 } |
| 533 } | |
| 534 | |
| 535 UNGCPRO; | |
| 536 } | |
| 537 | |
| 538 #define RESET_PRINT_GENSYM do { \ | |
| 539 if (!CONSP (Vprint_gensym)) \ | |
| 540 Vprint_gensym_alist = Qnil; \ | |
| 541 } while (0) | |
| 542 | |
| 1261 | 543 Lisp_Object |
| 428 | 544 canonicalize_printcharfun (Lisp_Object printcharfun) |
| 545 { | |
| 546 if (NILP (printcharfun)) | |
| 547 printcharfun = Vstandard_output; | |
| 548 | |
| 1261 | 549 if (!noninteractive && (EQ (printcharfun, Qt) || NILP (printcharfun))) |
| 428 | 550 printcharfun = Fselected_frame (Qnil); /* print to minibuffer */ |
| 551 | |
| 552 return printcharfun; | |
| 553 } | |
| 554 | |
| 555 static Lisp_Object | |
| 556 print_prepare (Lisp_Object printcharfun, Lisp_Object *frame_kludge) | |
| 557 { | |
| 558 /* Emacs won't print while GCing, but an external debugger might */ | |
| 771 | 559 #ifdef NO_PRINT_DURING_GC |
| 428 | 560 if (gc_in_progress) |
| 561 return Qnil; | |
| 771 | 562 #endif |
| 563 | |
| 428 | 564 RESET_PRINT_GENSYM; |
| 565 | |
| 566 printcharfun = canonicalize_printcharfun (printcharfun); | |
| 567 | |
| 568 /* Here we could safely return the canonicalized PRINTCHARFUN. | |
| 569 However, if PRINTCHARFUN is a frame, printing of complex | |
| 570 structures becomes very expensive, because `append-message' | |
| 571 (called by echo_area_append) gets called as many times as | |
| 572 output_string() is called (and that's a *lot*). append-message | |
| 573 tries to keep top of the message-stack in sync with the contents | |
| 574 of " *Echo Area" buffer, consing a new string for each component | |
| 575 of the printed structure. For instance, if you print (a a), | |
| 576 append-message will cons up the following strings: | |
| 577 | |
| 578 "(" | |
| 579 "(a" | |
| 580 "(a " | |
| 581 "(a a" | |
| 582 "(a a)" | |
| 583 | |
| 584 and will use only the last one. With larger objects, this turns | |
| 585 into an O(n^2) consing frenzy that locks up XEmacs in incessant | |
| 586 garbage collection. | |
| 587 | |
| 588 We prevent this by creating a resizing_buffer stream and letting | |
| 589 the printer write into it. print_finish() will notice this | |
| 590 stream, and invoke echo_area_append() with the stream's buffer, | |
| 591 only once. */ | |
| 592 if (FRAMEP (printcharfun)) | |
| 593 { | |
| 594 CHECK_LIVE_FRAME (printcharfun); | |
| 595 *frame_kludge = printcharfun; | |
| 596 printcharfun = make_resizing_buffer_output_stream (); | |
| 597 } | |
| 598 | |
| 599 return printcharfun; | |
| 600 } | |
| 601 | |
| 602 static void | |
| 603 print_finish (Lisp_Object stream, Lisp_Object frame_kludge) | |
| 604 { | |
| 605 /* Emacs won't print while GCing, but an external debugger might */ | |
| 771 | 606 #ifdef NO_PRINT_DURING_GC |
| 428 | 607 if (gc_in_progress) |
| 608 return; | |
| 771 | 609 #endif |
| 610 | |
| 428 | 611 RESET_PRINT_GENSYM; |
| 612 | |
| 613 /* See the comment in print_prepare(). */ | |
| 614 if (FRAMEP (frame_kludge)) | |
| 615 { | |
| 616 struct frame *f = XFRAME (frame_kludge); | |
| 617 Lstream *str = XLSTREAM (stream); | |
| 618 CHECK_LIVE_FRAME (frame_kludge); | |
| 619 | |
| 620 Lstream_flush (str); | |
| 621 if (!EQ (Vprint_message_label, echo_area_status (f))) | |
| 622 clear_echo_area_from_print (f, Qnil, 1); | |
| 623 echo_area_append (f, resizing_buffer_stream_ptr (str), | |
| 624 Qnil, 0, Lstream_byte_count (str), | |
| 625 Vprint_message_label); | |
| 626 Lstream_delete (str); | |
| 627 } | |
| 628 } | |
| 629 | |
| 630 | |
| 771 | 631 /* Write internal-format data to STREAM. See output_string() for |
| 632 interpretation of STREAM. | |
| 633 | |
| 634 NOTE: Do not call this with the data of a Lisp_String, as | |
| 428 | 635 printcharfun might cause a GC, which might cause the string's data |
| 636 to be relocated. To princ a Lisp string, use: | |
| 637 | |
| 638 print_internal (string, printcharfun, 0); | |
| 639 | |
| 640 Also note that STREAM should be the result of | |
| 641 canonicalize_printcharfun() (i.e. Qnil means stdout, not | |
| 642 Vstandard_output, etc.) */ | |
| 643 void | |
| 867 | 644 write_string_1 (Lisp_Object stream, const Ibyte *str, Bytecount size) |
| 428 | 645 { |
| 646 /* This function can GC */ | |
| 800 | 647 #ifdef ERROR_CHECK_TEXT |
| 428 | 648 assert (size >= 0); |
| 649 #endif | |
| 650 output_string (stream, str, Qnil, 0, size); | |
| 651 } | |
| 652 | |
| 653 void | |
| 867 | 654 write_string (Lisp_Object stream, const Ibyte *str) |
| 771 | 655 { |
| 656 /* This function can GC */ | |
| 826 | 657 write_string_1 (stream, str, qxestrlen (str)); |
| 771 | 658 } |
| 659 | |
| 660 void | |
| 867 | 661 write_c_string (Lisp_Object stream, const CIbyte *str) |
| 428 | 662 { |
| 663 /* This function can GC */ | |
| 867 | 664 write_string_1 (stream, (const Ibyte *) str, strlen (str)); |
| 428 | 665 } |
| 666 | |
| 793 | 667 void |
| 826 | 668 write_eistring (Lisp_Object stream, const Eistring *ei) |
| 793 | 669 { |
| 826 | 670 write_string_1 (stream, eidata (ei), eilen (ei)); |
| 793 | 671 } |
| 672 | |
| 771 | 673 /* Write a printf-style string to STREAM; see output_string(). */ |
| 674 | |
| 675 void | |
| 867 | 676 write_fmt_string (Lisp_Object stream, const CIbyte *fmt, ...) |
| 771 | 677 { |
| 678 va_list va; | |
| 867 | 679 Ibyte *str; |
| 771 | 680 Bytecount len; |
| 681 int count; | |
| 682 | |
| 683 va_start (va, fmt); | |
| 684 str = emacs_vsprintf_malloc (fmt, va, &len); | |
| 685 va_end (va); | |
| 686 count = record_unwind_protect_freeing (str); | |
| 826 | 687 write_string_1 (stream, str, len); |
| 771 | 688 unbind_to (count); |
| 689 } | |
| 690 | |
| 691 /* Write a printf-style string to STREAM, where the arguments are | |
| 692 Lisp objects and not C strings or integers; see output_string(). | |
| 693 | |
| 694 #### It shouldn't be necessary to specify the number of arguments. | |
| 695 This would require some rewriting of the doprnt() functions, though. */ | |
| 696 | |
| 697 void | |
| 867 | 698 write_fmt_string_lisp (Lisp_Object stream, const CIbyte *fmt, int nargs, ...) |
| 771 | 699 { |
| 700 Lisp_Object *args = alloca_array (Lisp_Object, nargs); | |
| 701 va_list va; | |
| 702 int i; | |
| 867 | 703 Ibyte *str; |
| 771 | 704 Bytecount len; |
| 705 int count; | |
| 706 | |
| 707 va_start (va, nargs); | |
| 708 for (i = 0; i < nargs; i++) | |
| 709 args[i] = va_arg (va, Lisp_Object); | |
| 710 va_end (va); | |
| 711 str = emacs_vsprintf_malloc_lisp (fmt, Qnil, nargs, args, &len); | |
| 712 count = record_unwind_protect_freeing (str); | |
| 826 | 713 write_string_1 (stream, str, len); |
| 771 | 714 unbind_to (count); |
| 715 } | |
| 716 | |
| 717 void | |
| 867 | 718 stderr_out_lisp (const CIbyte *fmt, int nargs, ...) |
| 771 | 719 { |
| 720 Lisp_Object *args = alloca_array (Lisp_Object, nargs); | |
| 721 va_list va; | |
| 722 int i; | |
| 867 | 723 Ibyte *str; |
| 771 | 724 Bytecount len; |
| 725 int count; | |
| 726 | |
| 727 va_start (va, nargs); | |
| 728 for (i = 0; i < nargs; i++) | |
| 729 args[i] = va_arg (va, Lisp_Object); | |
| 730 va_end (va); | |
| 731 str = emacs_vsprintf_malloc_lisp (fmt, Qnil, nargs, args, &len); | |
| 732 count = record_unwind_protect_freeing (str); | |
| 826 | 733 write_string_1 (Qexternal_debugging_output, str, len); |
| 771 | 734 unbind_to (count); |
| 735 } | |
| 736 | |
| 428 | 737 |
| 738 DEFUN ("write-char", Fwrite_char, 1, 2, 0, /* | |
| 444 | 739 Output character CHARACTER to stream STREAM. |
| 428 | 740 STREAM defaults to the value of `standard-output' (which see). |
| 741 */ | |
| 444 | 742 (character, stream)) |
| 428 | 743 { |
| 744 /* This function can GC */ | |
| 867 | 745 Ibyte str[MAX_ICHAR_LEN]; |
| 428 | 746 Bytecount len; |
| 747 | |
| 444 | 748 CHECK_CHAR_COERCE_INT (character); |
| 867 | 749 len = set_itext_ichar (str, XCHAR (character)); |
| 428 | 750 output_string (canonicalize_printcharfun (stream), str, Qnil, 0, len); |
| 444 | 751 return character; |
| 428 | 752 } |
| 753 | |
| 754 void | |
| 755 temp_output_buffer_setup (Lisp_Object bufname) | |
| 756 { | |
| 757 /* This function can GC */ | |
| 758 struct buffer *old = current_buffer; | |
| 759 Lisp_Object buf; | |
| 760 | |
| 761 #ifdef I18N3 | |
| 762 /* #### This function should accept a Lisp_Object instead of a char *, | |
| 763 so that proper translation on the buffer name can occur. */ | |
| 764 #endif | |
| 765 | |
| 766 Fset_buffer (Fget_buffer_create (bufname)); | |
| 767 | |
| 768 current_buffer->read_only = Qnil; | |
| 769 Ferase_buffer (Qnil); | |
| 770 | |
| 793 | 771 buf = wrap_buffer (current_buffer); |
| 428 | 772 specbind (Qstandard_output, buf); |
| 773 | |
| 774 set_buffer_internal (old); | |
| 775 } | |
| 776 | |
| 777 Lisp_Object | |
| 778 internal_with_output_to_temp_buffer (Lisp_Object bufname, | |
| 779 Lisp_Object (*function) (Lisp_Object arg), | |
| 780 Lisp_Object arg, | |
| 781 Lisp_Object same_frame) | |
| 782 { | |
| 783 int speccount = specpdl_depth (); | |
| 784 struct gcpro gcpro1, gcpro2, gcpro3; | |
| 785 Lisp_Object buf = Qnil; | |
| 786 | |
| 787 GCPRO3 (buf, arg, same_frame); | |
| 788 | |
| 789 temp_output_buffer_setup (bufname); | |
| 790 buf = Vstandard_output; | |
| 791 | |
| 792 arg = (*function) (arg); | |
| 793 | |
| 794 temp_output_buffer_show (buf, same_frame); | |
| 795 UNGCPRO; | |
| 796 | |
| 771 | 797 return unbind_to_1 (speccount, arg); |
| 428 | 798 } |
| 799 | |
| 800 DEFUN ("with-output-to-temp-buffer", Fwith_output_to_temp_buffer, 1, UNEVALLED, 0, /* | |
| 801 Bind `standard-output' to buffer BUFNAME, eval BODY, then show that buffer. | |
| 802 The buffer is cleared out initially, and marked as unmodified when done. | |
| 803 All output done by BODY is inserted in that buffer by default. | |
| 804 The buffer is displayed in another window, but not selected. | |
| 805 The value of the last form in BODY is returned. | |
| 806 If BODY does not finish normally, the buffer BUFNAME is not displayed. | |
| 807 | |
| 808 If variable `temp-buffer-show-function' is non-nil, call it at the end | |
| 809 to get the buffer displayed. It gets one argument, the buffer to display. | |
| 810 */ | |
| 811 (args)) | |
| 812 { | |
| 813 /* This function can GC */ | |
| 814 Lisp_Object name = Qnil; | |
| 815 int speccount = specpdl_depth (); | |
| 816 struct gcpro gcpro1, gcpro2; | |
| 817 Lisp_Object val = Qnil; | |
| 818 | |
| 819 #ifdef I18N3 | |
| 820 /* #### should set the buffer to be translating. See print_internal(). */ | |
| 821 #endif | |
| 822 | |
| 823 GCPRO2 (name, val); | |
| 824 name = Feval (XCAR (args)); | |
| 825 | |
| 826 CHECK_STRING (name); | |
| 827 | |
| 828 temp_output_buffer_setup (name); | |
| 829 UNGCPRO; | |
| 830 | |
| 831 val = Fprogn (XCDR (args)); | |
| 832 | |
| 833 temp_output_buffer_show (Vstandard_output, Qnil); | |
| 834 | |
| 771 | 835 return unbind_to_1 (speccount, val); |
| 428 | 836 } |
| 837 | |
| 838 DEFUN ("terpri", Fterpri, 0, 1, 0, /* | |
| 839 Output a newline to STREAM. | |
| 840 If STREAM is omitted or nil, the value of `standard-output' is used. | |
| 841 */ | |
| 842 (stream)) | |
| 843 { | |
| 844 /* This function can GC */ | |
| 826 | 845 write_c_string (canonicalize_printcharfun (stream), "\n"); |
| 428 | 846 return Qt; |
| 847 } | |
| 848 | |
| 849 DEFUN ("prin1", Fprin1, 1, 2, 0, /* | |
| 850 Output the printed representation of OBJECT, any Lisp object. | |
| 851 Quoting characters are printed when needed to make output that `read' | |
| 852 can handle, whenever this is possible. | |
| 853 Output stream is STREAM, or value of `standard-output' (which see). | |
| 854 */ | |
| 855 (object, stream)) | |
| 856 { | |
| 857 /* This function can GC */ | |
| 858 Lisp_Object frame = Qnil; | |
| 859 struct gcpro gcpro1, gcpro2; | |
| 860 GCPRO2 (object, stream); | |
| 861 | |
| 862 stream = print_prepare (stream, &frame); | |
| 863 print_internal (object, stream, 1); | |
| 864 print_finish (stream, frame); | |
| 865 | |
| 866 UNGCPRO; | |
| 867 return object; | |
| 868 } | |
| 869 | |
| 870 DEFUN ("prin1-to-string", Fprin1_to_string, 1, 2, 0, /* | |
| 871 Return a string containing the printed representation of OBJECT, | |
| 872 any Lisp object. Quoting characters are used when needed to make output | |
| 873 that `read' can handle, whenever this is possible, unless the optional | |
| 874 second argument NOESCAPE is non-nil. | |
| 875 */ | |
| 876 (object, noescape)) | |
| 877 { | |
| 878 /* This function can GC */ | |
| 879 Lisp_Object result = Qnil; | |
| 880 Lisp_Object stream = make_resizing_buffer_output_stream (); | |
| 881 Lstream *str = XLSTREAM (stream); | |
| 882 /* gcpro OBJECT in case a caller forgot to do so */ | |
| 883 struct gcpro gcpro1, gcpro2, gcpro3; | |
| 884 GCPRO3 (object, stream, result); | |
| 885 | |
| 886 RESET_PRINT_GENSYM; | |
| 887 print_internal (object, stream, NILP (noescape)); | |
| 888 RESET_PRINT_GENSYM; | |
| 889 Lstream_flush (str); | |
| 890 UNGCPRO; | |
| 891 result = make_string (resizing_buffer_stream_ptr (str), | |
| 892 Lstream_byte_count (str)); | |
| 893 Lstream_delete (str); | |
| 894 return result; | |
| 895 } | |
| 896 | |
| 897 DEFUN ("princ", Fprinc, 1, 2, 0, /* | |
| 898 Output the printed representation of OBJECT, any Lisp object. | |
| 899 No quoting characters are used; no delimiters are printed around | |
| 900 the contents of strings. | |
| 444 | 901 Output stream is STREAM, or value of `standard-output' (which see). |
| 428 | 902 */ |
| 903 (object, stream)) | |
| 904 { | |
| 905 /* This function can GC */ | |
| 906 Lisp_Object frame = Qnil; | |
| 907 struct gcpro gcpro1, gcpro2; | |
| 908 | |
| 909 GCPRO2 (object, stream); | |
| 910 stream = print_prepare (stream, &frame); | |
| 911 print_internal (object, stream, 0); | |
| 912 print_finish (stream, frame); | |
| 913 UNGCPRO; | |
| 914 return object; | |
| 915 } | |
| 916 | |
| 917 DEFUN ("print", Fprint, 1, 2, 0, /* | |
| 918 Output the printed representation of OBJECT, with newlines around it. | |
| 919 Quoting characters are printed when needed to make output that `read' | |
| 920 can handle, whenever this is possible. | |
| 921 Output stream is STREAM, or value of `standard-output' (which see). | |
| 922 */ | |
| 923 (object, stream)) | |
| 924 { | |
| 925 /* This function can GC */ | |
| 926 Lisp_Object frame = Qnil; | |
| 927 struct gcpro gcpro1, gcpro2; | |
| 928 | |
| 929 GCPRO2 (object, stream); | |
| 930 stream = print_prepare (stream, &frame); | |
| 826 | 931 write_c_string (stream, "\n"); |
| 428 | 932 print_internal (object, stream, 1); |
| 826 | 933 write_c_string (stream, "\n"); |
| 428 | 934 print_finish (stream, frame); |
| 935 UNGCPRO; | |
| 936 return object; | |
| 937 } | |
| 938 | |
| 939 /* Print an error message for the error DATA to STREAM. This is a | |
| 940 complete implementation of `display-error', which used to be in | |
| 941 Lisp (see prim/cmdloop.el). It was ported to C so it can be used | |
| 942 efficiently by Ferror_message_string. Fdisplay_error and | |
| 943 Ferror_message_string are trivial wrappers around this function. | |
| 944 | |
| 945 STREAM should be the result of canonicalize_printcharfun(). */ | |
| 946 static void | |
| 947 print_error_message (Lisp_Object error_object, Lisp_Object stream) | |
| 948 { | |
| 949 /* This function can GC */ | |
| 950 Lisp_Object type = Fcar_safe (error_object); | |
| 951 Lisp_Object method = Qnil; | |
| 952 Lisp_Object tail; | |
| 953 | |
| 954 /* No need to GCPRO anything under the assumption that ERROR_OBJECT | |
| 955 is GCPRO'd. */ | |
| 956 | |
| 957 if (! (CONSP (error_object) && SYMBOLP (type) | |
| 958 && CONSP (Fget (type, Qerror_conditions, Qnil)))) | |
| 959 goto error_throw; | |
| 960 | |
| 961 tail = XCDR (error_object); | |
| 962 while (!NILP (tail)) | |
| 963 { | |
| 964 if (CONSP (tail)) | |
| 965 tail = XCDR (tail); | |
| 966 else | |
| 967 goto error_throw; | |
| 968 } | |
| 969 tail = Fget (type, Qerror_conditions, Qnil); | |
| 970 while (!NILP (tail)) | |
| 971 { | |
| 972 if (!(CONSP (tail) && SYMBOLP (XCAR (tail)))) | |
| 973 goto error_throw; | |
| 974 else if (!NILP (Fget (XCAR (tail), Qdisplay_error, Qnil))) | |
| 975 { | |
| 976 method = Fget (XCAR (tail), Qdisplay_error, Qnil); | |
| 977 goto error_throw; | |
| 978 } | |
| 979 else | |
| 980 tail = XCDR (tail); | |
| 981 } | |
| 982 /* Default method */ | |
| 983 { | |
| 984 int first = 1; | |
| 985 int speccount = specpdl_depth (); | |
| 438 | 986 Lisp_Object frame = Qnil; |
| 987 struct gcpro gcpro1; | |
| 988 GCPRO1 (stream); | |
| 428 | 989 |
| 990 specbind (Qprint_message_label, Qerror); | |
| 438 | 991 stream = print_prepare (stream, &frame); |
| 992 | |
| 428 | 993 tail = Fcdr (error_object); |
| 994 if (EQ (type, Qerror)) | |
| 995 { | |
| 996 print_internal (Fcar (tail), stream, 0); | |
| 997 tail = Fcdr (tail); | |
| 998 } | |
| 999 else | |
| 1000 { | |
| 1001 Lisp_Object errmsg = Fget (type, Qerror_message, Qnil); | |
| 1002 if (NILP (errmsg)) | |
| 1003 print_internal (type, stream, 0); | |
| 1004 else | |
| 1005 print_internal (LISP_GETTEXT (errmsg), stream, 0); | |
| 1006 } | |
| 1007 while (!NILP (tail)) | |
| 1008 { | |
| 826 | 1009 write_c_string (stream, first ? ": " : ", "); |
| 563 | 1010 /* Most errors have an explanatory string as their first argument, |
| 1011 and it looks better not to put the quotes around it. */ | |
| 1012 print_internal (Fcar (tail), stream, | |
| 1013 !(first && STRINGP (Fcar (tail))) || | |
| 1014 !NILP (Fget (type, Qerror_lacks_explanatory_string, | |
| 1015 Qnil))); | |
| 428 | 1016 tail = Fcdr (tail); |
| 1017 first = 0; | |
| 1018 } | |
| 438 | 1019 print_finish (stream, frame); |
| 1020 UNGCPRO; | |
| 771 | 1021 unbind_to (speccount); |
| 428 | 1022 return; |
| 1023 /* not reached */ | |
| 1024 } | |
| 1025 | |
| 1026 error_throw: | |
| 1027 if (NILP (method)) | |
| 1028 { | |
| 826 | 1029 write_c_string (stream, GETTEXT ("Peculiar error ")); |
| 428 | 1030 print_internal (error_object, stream, 1); |
| 1031 return; | |
| 1032 } | |
| 1033 else | |
| 1034 { | |
| 1035 call2 (method, error_object, stream); | |
| 1036 } | |
| 1037 } | |
| 1038 | |
| 1039 DEFUN ("error-message-string", Ferror_message_string, 1, 1, 0, /* | |
| 1040 Convert ERROR-OBJECT to an error message, and return it. | |
| 1041 | |
| 1042 The format of ERROR-OBJECT should be (ERROR-SYMBOL . DATA). The | |
| 1043 message is equivalent to the one that would be issued by | |
| 1044 `display-error' with the same argument. | |
| 1045 */ | |
| 1046 (error_object)) | |
| 1047 { | |
| 1048 /* This function can GC */ | |
| 1049 Lisp_Object result = Qnil; | |
| 1050 Lisp_Object stream = make_resizing_buffer_output_stream (); | |
| 1051 struct gcpro gcpro1; | |
| 1052 GCPRO1 (stream); | |
| 1053 | |
| 1054 print_error_message (error_object, stream); | |
| 1055 Lstream_flush (XLSTREAM (stream)); | |
| 1056 result = make_string (resizing_buffer_stream_ptr (XLSTREAM (stream)), | |
| 1057 Lstream_byte_count (XLSTREAM (stream))); | |
| 1058 Lstream_delete (XLSTREAM (stream)); | |
| 1059 | |
| 1060 UNGCPRO; | |
| 1061 return result; | |
| 1062 } | |
| 1063 | |
| 1064 DEFUN ("display-error", Fdisplay_error, 2, 2, 0, /* | |
| 1065 Display ERROR-OBJECT on STREAM in a user-friendly way. | |
| 1066 */ | |
| 1067 (error_object, stream)) | |
| 1068 { | |
| 1069 /* This function can GC */ | |
| 1070 print_error_message (error_object, canonicalize_printcharfun (stream)); | |
| 1071 return Qnil; | |
| 1072 } | |
| 1073 | |
| 1074 | |
| 1075 Lisp_Object Vfloat_output_format; | |
| 1076 | |
| 1077 /* | |
| 1078 * This buffer should be at least as large as the max string size of the | |
| 440 | 1079 * largest float, printed in the biggest notation. This is undoubtedly |
| 428 | 1080 * 20d float_output_format, with the negative of the C-constant "HUGE" |
| 1081 * from <math.h>. | |
| 1082 * | |
| 1083 * On the vax the worst case is -1e38 in 20d format which takes 61 bytes. | |
| 1084 * | |
| 1085 * I assume that IEEE-754 format numbers can take 329 bytes for the worst | |
| 1086 * case of -1e307 in 20d float_output_format. What is one to do (short of | |
| 1087 * re-writing _doprnt to be more sane)? | |
| 1088 * -wsr | |
| 1089 */ | |
| 1090 void | |
| 1091 float_to_string (char *buf, double data) | |
| 1092 { | |
| 867 | 1093 Ibyte *cp, c; |
| 428 | 1094 int width; |
| 1095 | |
| 1096 if (NILP (Vfloat_output_format) | |
| 1097 || !STRINGP (Vfloat_output_format)) | |
| 1098 lose: | |
| 1099 sprintf (buf, "%.16g", data); | |
| 1100 else /* oink oink */ | |
| 1101 { | |
| 1102 /* Check that the spec we have is fully valid. | |
| 1103 This means not only valid for printf, | |
| 1104 but meant for floats, and reasonable. */ | |
| 1105 cp = XSTRING_DATA (Vfloat_output_format); | |
| 1106 | |
| 1107 if (cp[0] != '%') | |
| 1108 goto lose; | |
| 1109 if (cp[1] != '.') | |
| 1110 goto lose; | |
| 1111 | |
| 1112 cp += 2; | |
| 1113 for (width = 0; (c = *cp, isdigit (c)); cp++) | |
| 1114 { | |
| 1115 width *= 10; | |
| 1116 width += c - '0'; | |
| 1117 } | |
| 1118 | |
| 1119 if (*cp != 'e' && *cp != 'f' && *cp != 'g' && *cp != 'E' && *cp != 'G') | |
| 1120 goto lose; | |
| 1121 | |
| 1122 if (width < (int) (*cp != 'e' && *cp != 'E') || width > DBL_DIG) | |
| 1123 goto lose; | |
| 1124 | |
| 1125 if (cp[1] != 0) | |
| 1126 goto lose; | |
| 1127 | |
| 1128 sprintf (buf, (char *) XSTRING_DATA (Vfloat_output_format), | |
| 1129 data); | |
| 1130 } | |
| 1131 | |
| 1132 /* added by jwz: don't allow "1.0" to print as "1"; that destroys | |
| 1133 the read-equivalence of lisp objects. (* x 1) and (* x 1.0) do | |
| 1134 not do the same thing, so it's important that the printed | |
| 1135 representation of that form not be corrupted by the printer. | |
| 1136 */ | |
| 1137 { | |
| 867 | 1138 Ibyte *s = (Ibyte *) buf; /* don't use signed chars here! |
| 428 | 1139 isdigit() can't hack them! */ |
| 1140 if (*s == '-') s++; | |
| 1141 for (; *s; s++) | |
| 1142 /* if there's a non-digit, then there is a decimal point, or | |
| 1143 it's in exponential notation, both of which are ok. */ | |
| 1144 if (!isdigit (*s)) | |
| 1145 goto DONE_LABEL; | |
| 1146 /* otherwise, we need to hack it. */ | |
| 1147 *s++ = '.'; | |
| 1148 *s++ = '0'; | |
| 1149 *s = 0; | |
| 1150 } | |
| 1151 DONE_LABEL: | |
| 1152 | |
| 1153 /* Some machines print "0.4" as ".4". I don't like that. */ | |
| 1154 if (buf [0] == '.' || (buf [0] == '-' && buf [1] == '.')) | |
| 1155 { | |
| 1156 int i; | |
| 1157 for (i = strlen (buf) + 1; i >= 0; i--) | |
| 1158 buf [i+1] = buf [i]; | |
| 1159 buf [(buf [0] == '-' ? 1 : 0)] = '0'; | |
| 1160 } | |
| 1161 } | |
| 1162 | |
| 2500 | 1163 #define ONE_DIGIT(figure) *p++ = (char) (n / (figure) + '0') |
| 577 | 1164 #define ONE_DIGIT_ADVANCE(figure) (ONE_DIGIT (figure), n %= (figure)) |
| 1165 | |
| 1166 #define DIGITS_1(figure) ONE_DIGIT (figure) | |
| 1167 #define DIGITS_2(figure) ONE_DIGIT_ADVANCE (figure); DIGITS_1 ((figure) / 10) | |
| 1168 #define DIGITS_3(figure) ONE_DIGIT_ADVANCE (figure); DIGITS_2 ((figure) / 10) | |
| 1169 #define DIGITS_4(figure) ONE_DIGIT_ADVANCE (figure); DIGITS_3 ((figure) / 10) | |
| 1170 #define DIGITS_5(figure) ONE_DIGIT_ADVANCE (figure); DIGITS_4 ((figure) / 10) | |
| 1171 #define DIGITS_6(figure) ONE_DIGIT_ADVANCE (figure); DIGITS_5 ((figure) / 10) | |
| 1172 #define DIGITS_7(figure) ONE_DIGIT_ADVANCE (figure); DIGITS_6 ((figure) / 10) | |
| 1173 #define DIGITS_8(figure) ONE_DIGIT_ADVANCE (figure); DIGITS_7 ((figure) / 10) | |
| 1174 #define DIGITS_9(figure) ONE_DIGIT_ADVANCE (figure); DIGITS_8 ((figure) / 10) | |
| 1175 #define DIGITS_10(figure) ONE_DIGIT_ADVANCE (figure); DIGITS_9 ((figure) / 10) | |
| 1176 | |
| 1177 /* DIGITS_<11-20> are only used on machines with 64-bit longs. */ | |
| 428 | 1178 |
| 577 | 1179 #define DIGITS_11(figure) ONE_DIGIT_ADVANCE (figure); DIGITS_10 ((figure) / 10) |
| 1180 #define DIGITS_12(figure) ONE_DIGIT_ADVANCE (figure); DIGITS_11 ((figure) / 10) | |
| 1181 #define DIGITS_13(figure) ONE_DIGIT_ADVANCE (figure); DIGITS_12 ((figure) / 10) | |
| 1182 #define DIGITS_14(figure) ONE_DIGIT_ADVANCE (figure); DIGITS_13 ((figure) / 10) | |
| 1183 #define DIGITS_15(figure) ONE_DIGIT_ADVANCE (figure); DIGITS_14 ((figure) / 10) | |
| 1184 #define DIGITS_16(figure) ONE_DIGIT_ADVANCE (figure); DIGITS_15 ((figure) / 10) | |
| 1185 #define DIGITS_17(figure) ONE_DIGIT_ADVANCE (figure); DIGITS_16 ((figure) / 10) | |
| 1186 #define DIGITS_18(figure) ONE_DIGIT_ADVANCE (figure); DIGITS_17 ((figure) / 10) | |
| 1187 #define DIGITS_19(figure) ONE_DIGIT_ADVANCE (figure); DIGITS_18 ((figure) / 10) | |
| 1188 | |
| 1189 /* Print NUMBER to BUFFER in base 10. This is completely equivalent | |
| 1190 to `sprintf(buffer, "%ld", number)', only much faster. | |
| 1191 | |
| 1192 The speedup may make a difference in programs that frequently | |
| 1193 convert numbers to strings. Some implementations of sprintf, | |
| 1194 particularly the one in GNU libc, have been known to be extremely | |
| 1195 slow compared to this function. | |
| 1196 | |
| 1197 BUFFER should accept as many bytes as you expect the number to take | |
| 1198 up. On machines with 64-bit longs the maximum needed size is 24 | |
| 1199 bytes. That includes the worst-case digits, the optional `-' sign, | |
| 1200 and the trailing \0. */ | |
| 1201 | |
| 1202 void | |
| 428 | 1203 long_to_string (char *buffer, long number) |
| 1204 { | |
| 577 | 1205 char *p = buffer; |
| 1206 long n = number; | |
| 1207 | |
| 428 | 1208 #if (SIZEOF_LONG != 4) && (SIZEOF_LONG != 8) |
| 577 | 1209 /* We are running in a strange or misconfigured environment. Let |
| 1210 sprintf cope with it. */ | |
| 1211 sprintf (buffer, "%ld", n); | |
| 1212 #else /* (SIZEOF_LONG == 4) || (SIZEOF_LONG == 8) */ | |
| 428 | 1213 |
| 577 | 1214 if (n < 0) |
| 428 | 1215 { |
| 1216 *p++ = '-'; | |
| 577 | 1217 n = -n; |
| 428 | 1218 } |
| 1219 | |
| 577 | 1220 if (n < 10) { DIGITS_1 (1); } |
| 1221 else if (n < 100) { DIGITS_2 (10); } | |
| 1222 else if (n < 1000) { DIGITS_3 (100); } | |
| 1223 else if (n < 10000) { DIGITS_4 (1000); } | |
| 1224 else if (n < 100000) { DIGITS_5 (10000); } | |
| 1225 else if (n < 1000000) { DIGITS_6 (100000); } | |
| 1226 else if (n < 10000000) { DIGITS_7 (1000000); } | |
| 1227 else if (n < 100000000) { DIGITS_8 (10000000); } | |
| 1228 else if (n < 1000000000) { DIGITS_9 (100000000); } | |
| 1229 #if SIZEOF_LONG == 4 | |
| 1230 /* ``if (1)'' serves only to preserve editor indentation. */ | |
| 1231 else if (1) { DIGITS_10 (1000000000); } | |
| 1232 #else /* SIZEOF_LONG != 4 */ | |
| 1233 else if (n < 10000000000L) { DIGITS_10 (1000000000L); } | |
| 1234 else if (n < 100000000000L) { DIGITS_11 (10000000000L); } | |
| 1235 else if (n < 1000000000000L) { DIGITS_12 (100000000000L); } | |
| 1236 else if (n < 10000000000000L) { DIGITS_13 (1000000000000L); } | |
| 1237 else if (n < 100000000000000L) { DIGITS_14 (10000000000000L); } | |
| 1238 else if (n < 1000000000000000L) { DIGITS_15 (100000000000000L); } | |
| 1239 else if (n < 10000000000000000L) { DIGITS_16 (1000000000000000L); } | |
| 1240 else if (n < 100000000000000000L) { DIGITS_17 (10000000000000000L); } | |
| 1241 else if (n < 1000000000000000000L) { DIGITS_18 (100000000000000000L); } | |
| 1242 else { DIGITS_19 (1000000000000000000L); } | |
| 1243 #endif /* SIZEOF_LONG != 4 */ | |
| 1244 | |
| 428 | 1245 *p = '\0'; |
| 1246 #endif /* (SIZEOF_LONG == 4) || (SIZEOF_LONG == 8) */ | |
| 1247 } | |
| 577 | 1248 |
| 1249 #undef ONE_DIGIT | |
| 1250 #undef ONE_DIGIT_ADVANCE | |
| 1251 | |
| 1252 #undef DIGITS_1 | |
| 1253 #undef DIGITS_2 | |
| 1254 #undef DIGITS_3 | |
| 1255 #undef DIGITS_4 | |
| 1256 #undef DIGITS_5 | |
| 1257 #undef DIGITS_6 | |
| 1258 #undef DIGITS_7 | |
| 1259 #undef DIGITS_8 | |
| 1260 #undef DIGITS_9 | |
| 1261 #undef DIGITS_10 | |
| 1262 #undef DIGITS_11 | |
| 1263 #undef DIGITS_12 | |
| 1264 #undef DIGITS_13 | |
| 1265 #undef DIGITS_14 | |
| 1266 #undef DIGITS_15 | |
| 1267 #undef DIGITS_16 | |
| 1268 #undef DIGITS_17 | |
| 1269 #undef DIGITS_18 | |
| 1270 #undef DIGITS_19 | |
| 428 | 1271 |
|
4329
d9eb5ea14f65
Provide %b in #'format; use it for converting between ints and bit vectors.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3263
diff
changeset
|
1272 void |
|
d9eb5ea14f65
Provide %b in #'format; use it for converting between ints and bit vectors.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3263
diff
changeset
|
1273 ulong_to_bit_string (char *p, unsigned long number) |
|
d9eb5ea14f65
Provide %b in #'format; use it for converting between ints and bit vectors.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3263
diff
changeset
|
1274 { |
|
d9eb5ea14f65
Provide %b in #'format; use it for converting between ints and bit vectors.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3263
diff
changeset
|
1275 int i, seen_high_order = 0;; |
|
d9eb5ea14f65
Provide %b in #'format; use it for converting between ints and bit vectors.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3263
diff
changeset
|
1276 |
|
d9eb5ea14f65
Provide %b in #'format; use it for converting between ints and bit vectors.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3263
diff
changeset
|
1277 for (i = ((SIZEOF_LONG * 8) - 1); i >= 0; --i) |
|
d9eb5ea14f65
Provide %b in #'format; use it for converting between ints and bit vectors.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3263
diff
changeset
|
1278 { |
|
d9eb5ea14f65
Provide %b in #'format; use it for converting between ints and bit vectors.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3263
diff
changeset
|
1279 if (number & (unsigned long)1 << i) |
|
d9eb5ea14f65
Provide %b in #'format; use it for converting between ints and bit vectors.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3263
diff
changeset
|
1280 { |
|
d9eb5ea14f65
Provide %b in #'format; use it for converting between ints and bit vectors.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3263
diff
changeset
|
1281 seen_high_order = 1; |
|
d9eb5ea14f65
Provide %b in #'format; use it for converting between ints and bit vectors.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3263
diff
changeset
|
1282 *p++ = '1'; |
|
d9eb5ea14f65
Provide %b in #'format; use it for converting between ints and bit vectors.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3263
diff
changeset
|
1283 } |
|
d9eb5ea14f65
Provide %b in #'format; use it for converting between ints and bit vectors.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3263
diff
changeset
|
1284 else |
|
d9eb5ea14f65
Provide %b in #'format; use it for converting between ints and bit vectors.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3263
diff
changeset
|
1285 { |
|
d9eb5ea14f65
Provide %b in #'format; use it for converting between ints and bit vectors.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3263
diff
changeset
|
1286 if (seen_high_order) |
|
d9eb5ea14f65
Provide %b in #'format; use it for converting between ints and bit vectors.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3263
diff
changeset
|
1287 { |
|
d9eb5ea14f65
Provide %b in #'format; use it for converting between ints and bit vectors.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3263
diff
changeset
|
1288 *p++ = '0'; |
|
d9eb5ea14f65
Provide %b in #'format; use it for converting between ints and bit vectors.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3263
diff
changeset
|
1289 } |
|
d9eb5ea14f65
Provide %b in #'format; use it for converting between ints and bit vectors.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3263
diff
changeset
|
1290 } |
|
d9eb5ea14f65
Provide %b in #'format; use it for converting between ints and bit vectors.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3263
diff
changeset
|
1291 } |
|
d9eb5ea14f65
Provide %b in #'format; use it for converting between ints and bit vectors.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3263
diff
changeset
|
1292 *p = '\0'; |
|
d9eb5ea14f65
Provide %b in #'format; use it for converting between ints and bit vectors.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3263
diff
changeset
|
1293 } |
|
d9eb5ea14f65
Provide %b in #'format; use it for converting between ints and bit vectors.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3263
diff
changeset
|
1294 |
| 428 | 1295 static void |
| 442 | 1296 print_vector_internal (const char *start, const char *end, |
| 428 | 1297 Lisp_Object obj, |
| 1298 Lisp_Object printcharfun, int escapeflag) | |
| 1299 { | |
| 1300 /* This function can GC */ | |
| 1301 int i; | |
| 1302 int len = XVECTOR_LENGTH (obj); | |
| 1303 int last = len; | |
| 1304 struct gcpro gcpro1, gcpro2; | |
| 1305 GCPRO2 (obj, printcharfun); | |
| 1306 | |
| 1307 if (INTP (Vprint_length)) | |
| 1308 { | |
| 1309 int max = XINT (Vprint_length); | |
| 1310 if (max < len) last = max; | |
| 1311 } | |
| 1312 | |
| 826 | 1313 write_c_string (printcharfun, start); |
| 428 | 1314 for (i = 0; i < last; i++) |
| 1315 { | |
| 1316 Lisp_Object elt = XVECTOR_DATA (obj)[i]; | |
| 826 | 1317 if (i != 0) write_c_string (printcharfun, " "); |
| 428 | 1318 print_internal (elt, printcharfun, escapeflag); |
| 1319 } | |
| 1320 UNGCPRO; | |
| 1321 if (last != len) | |
| 826 | 1322 write_c_string (printcharfun, " ..."); |
| 1323 write_c_string (printcharfun, end); | |
| 428 | 1324 } |
| 1325 | |
| 1326 void | |
| 1327 print_cons (Lisp_Object obj, Lisp_Object printcharfun, int escapeflag) | |
| 1328 { | |
| 1329 /* This function can GC */ | |
| 1330 struct gcpro gcpro1, gcpro2; | |
| 1331 | |
| 1332 /* If print_readably is on, print (quote -foo-) as '-foo- | |
| 1333 (Yeah, this should really be what print-pretty does, but we | |
| 1334 don't have the rest of a pretty printer, and this actually | |
| 1335 has non-negligible impact on size/speed of .elc files.) | |
| 1336 */ | |
| 1337 if (print_readably && | |
| 1338 EQ (XCAR (obj), Qquote) && | |
| 1339 CONSP (XCDR (obj)) && | |
| 1340 NILP (XCDR (XCDR (obj)))) | |
| 1341 { | |
| 1342 obj = XCAR (XCDR (obj)); | |
| 1343 GCPRO2 (obj, printcharfun); | |
| 826 | 1344 write_c_string (printcharfun, "\'"); |
| 428 | 1345 UNGCPRO; |
| 1346 print_internal (obj, printcharfun, escapeflag); | |
| 1347 return; | |
| 1348 } | |
| 1349 | |
| 1350 GCPRO2 (obj, printcharfun); | |
| 826 | 1351 write_c_string (printcharfun, "("); |
| 428 | 1352 |
| 1353 { | |
| 1354 int len; | |
| 1355 int max = INTP (Vprint_length) ? XINT (Vprint_length) : INT_MAX; | |
| 1356 Lisp_Object tortoise; | |
| 1357 /* Use tortoise/hare to make sure circular lists don't infloop */ | |
| 1358 | |
| 1359 for (tortoise = obj, len = 0; | |
| 1360 CONSP (obj); | |
| 1361 obj = XCDR (obj), len++) | |
| 1362 { | |
| 1363 if (len > 0) | |
| 826 | 1364 write_c_string (printcharfun, " "); |
| 428 | 1365 if (EQ (obj, tortoise) && len > 0) |
| 1366 { | |
| 1367 if (print_readably) | |
| 563 | 1368 printing_unreadable_object ("circular list"); |
| 428 | 1369 else |
| 826 | 1370 write_c_string (printcharfun, "... <circular list>"); |
| 428 | 1371 break; |
| 1372 } | |
| 1373 if (len & 1) | |
| 1374 tortoise = XCDR (tortoise); | |
| 1375 if (len > max) | |
| 1376 { | |
| 826 | 1377 write_c_string (printcharfun, "..."); |
| 428 | 1378 break; |
| 1379 } | |
| 1380 print_internal (XCAR (obj), printcharfun, escapeflag); | |
| 1381 } | |
| 1382 } | |
| 1383 if (!LISTP (obj)) | |
| 1384 { | |
| 826 | 1385 write_c_string (printcharfun, " . "); |
| 428 | 1386 print_internal (obj, printcharfun, escapeflag); |
| 1387 } | |
| 1388 UNGCPRO; | |
| 1389 | |
| 826 | 1390 write_c_string (printcharfun, ")"); |
| 428 | 1391 return; |
| 1392 } | |
| 1393 | |
| 1394 void | |
| 1395 print_vector (Lisp_Object obj, Lisp_Object printcharfun, int escapeflag) | |
| 1396 { | |
| 1397 print_vector_internal ("[", "]", obj, printcharfun, escapeflag); | |
| 1398 } | |
| 1399 | |
| 1400 void | |
| 1401 print_string (Lisp_Object obj, Lisp_Object printcharfun, int escapeflag) | |
| 1402 { | |
| 1403 /* We distinguish between Bytecounts and Charcounts, to make | |
| 1404 Vprint_string_length work correctly under Mule. */ | |
| 826 | 1405 Charcount size = string_char_length (obj); |
| 428 | 1406 Charcount max = size; |
| 793 | 1407 Bytecount bcmax = XSTRING_LENGTH (obj); |
| 428 | 1408 struct gcpro gcpro1, gcpro2; |
| 1409 GCPRO2 (obj, printcharfun); | |
| 1410 | |
| 1411 if (INTP (Vprint_string_length) && | |
| 1412 XINT (Vprint_string_length) < max) | |
| 1413 { | |
| 1414 max = XINT (Vprint_string_length); | |
| 793 | 1415 bcmax = string_index_char_to_byte (obj, max); |
| 428 | 1416 } |
| 1417 if (max < 0) | |
| 1418 { | |
| 1419 max = 0; | |
| 1420 bcmax = 0; | |
| 1421 } | |
| 1422 | |
| 1423 if (!escapeflag) | |
| 1424 { | |
| 1425 /* This deals with GC-relocation and Mule. */ | |
| 1426 output_string (printcharfun, 0, obj, 0, bcmax); | |
| 1427 if (max < size) | |
| 826 | 1428 write_c_string (printcharfun, " ..."); |
| 428 | 1429 } |
| 1430 else | |
| 1431 { | |
| 1432 Bytecount i, last = 0; | |
| 1433 | |
| 826 | 1434 write_c_string (printcharfun, "\""); |
| 428 | 1435 for (i = 0; i < bcmax; i++) |
| 1436 { | |
| 867 | 1437 Ibyte ch = string_byte (obj, i); |
| 428 | 1438 if (ch == '\"' || ch == '\\' |
| 1439 || (ch == '\n' && print_escape_newlines)) | |
| 1440 { | |
| 1441 if (i > last) | |
| 1442 { | |
| 1443 output_string (printcharfun, 0, obj, last, | |
| 1444 i - last); | |
| 1445 } | |
| 1446 if (ch == '\n') | |
| 1447 { | |
| 826 | 1448 write_c_string (printcharfun, "\\n"); |
| 428 | 1449 } |
| 1450 else | |
| 1451 { | |
| 867 | 1452 Ibyte temp[2]; |
| 826 | 1453 write_c_string (printcharfun, "\\"); |
| 428 | 1454 /* This is correct for Mule because the |
| 1455 character is either \ or " */ | |
| 826 | 1456 temp[0] = string_byte (obj, i); |
| 1457 temp[1] = '\0'; | |
| 1458 write_string (printcharfun, temp); | |
| 428 | 1459 } |
| 1460 last = i + 1; | |
| 1461 } | |
| 1462 } | |
| 1463 if (bcmax > last) | |
| 1464 { | |
| 1465 output_string (printcharfun, 0, obj, last, | |
| 1466 bcmax - last); | |
| 1467 } | |
| 1468 if (max < size) | |
| 826 | 1469 write_c_string (printcharfun, " ..."); |
| 1470 write_c_string (printcharfun, "\""); | |
| 428 | 1471 } |
| 1472 UNGCPRO; | |
| 1473 } | |
| 1474 | |
| 3085 | 1475 void |
| 428 | 1476 default_object_printer (Lisp_Object obj, Lisp_Object printcharfun, |
| 2286 | 1477 int UNUSED (escapeflag)) |
| 428 | 1478 { |
| 3017 | 1479 struct LCRECORD_HEADER *header = (struct LCRECORD_HEADER *) XPNTR (obj); |
| 428 | 1480 |
| 1481 if (print_readably) | |
| 563 | 1482 printing_unreadable_object |
| 1483 ("#<%s 0x%x>", | |
| 3263 | 1484 #ifdef NEW_GC |
| 2720 | 1485 LHEADER_IMPLEMENTATION (header)->name, |
| 3263 | 1486 #else /* not NEW_GC */ |
| 563 | 1487 LHEADER_IMPLEMENTATION (&header->lheader)->name, |
| 3263 | 1488 #endif /* not NEW_GC */ |
| 563 | 1489 header->uid); |
| 428 | 1490 |
| 800 | 1491 write_fmt_string (printcharfun, "#<%s 0x%x>", |
| 3263 | 1492 #ifdef NEW_GC |
| 2720 | 1493 LHEADER_IMPLEMENTATION (header)->name, |
| 3263 | 1494 #else /* not NEW_GC */ |
| 800 | 1495 LHEADER_IMPLEMENTATION (&header->lheader)->name, |
| 3263 | 1496 #endif /* not NEW_GC */ |
| 800 | 1497 header->uid); |
| 428 | 1498 } |
| 1499 | |
| 1500 void | |
| 1501 internal_object_printer (Lisp_Object obj, Lisp_Object printcharfun, | |
| 2286 | 1502 int UNUSED (escapeflag)) |
| 428 | 1503 { |
| 800 | 1504 write_fmt_string (printcharfun, |
| 1505 "#<INTERNAL OBJECT (XEmacs bug?) (%s) 0x%lx>", | |
| 1506 XRECORD_LHEADER_IMPLEMENTATION (obj)->name, | |
| 1507 (unsigned long) XPNTR (obj)); | |
| 428 | 1508 } |
| 1509 | |
| 1204 | 1510 enum printing_badness |
| 1511 { | |
| 1512 BADNESS_INTEGER_OBJECT, | |
| 1513 BADNESS_POINTER_OBJECT, | |
| 1514 BADNESS_NO_TYPE | |
| 1515 }; | |
| 1516 | |
| 1517 static void | |
| 1518 printing_major_badness (Lisp_Object printcharfun, | |
| 2367 | 1519 Ascbyte *badness_string, int type, void *val, |
| 1204 | 1520 enum printing_badness badness) |
| 1521 { | |
| 1522 Ibyte buf[666]; | |
| 1523 | |
| 1524 switch (badness) | |
| 1525 { | |
| 1526 case BADNESS_INTEGER_OBJECT: | |
| 1527 qxesprintf (buf, "%s %d object %ld", badness_string, type, | |
| 1528 (EMACS_INT) val); | |
| 1529 break; | |
| 1530 | |
| 1531 case BADNESS_POINTER_OBJECT: | |
| 1532 qxesprintf (buf, "%s %d object %p", badness_string, type, val); | |
| 1533 break; | |
| 1534 | |
| 1535 case BADNESS_NO_TYPE: | |
| 1536 qxesprintf (buf, "%s object %p", badness_string, val); | |
| 1537 break; | |
| 1538 } | |
| 1539 | |
| 1540 /* Don't abort or signal if called from debug_print() or already | |
| 1541 crashing */ | |
| 2367 | 1542 if (!inhibit_non_essential_conversion_operations) |
| 1204 | 1543 { |
| 1544 #ifdef ERROR_CHECK_TYPES | |
| 2500 | 1545 ABORT (); |
| 1204 | 1546 #else /* not ERROR_CHECK_TYPES */ |
| 1547 if (print_readably) | |
| 1548 signal_ferror (Qinternal_error, "printing %s", buf); | |
| 1549 #endif /* not ERROR_CHECK_TYPES */ | |
| 1550 } | |
| 1551 write_fmt_string (printcharfun, | |
| 1552 "#<EMACS BUG: %s Save your buffers immediately and " | |
| 1553 "please report this bug>", buf); | |
| 1554 } | |
| 1555 | |
| 428 | 1556 void |
| 1557 print_internal (Lisp_Object obj, Lisp_Object printcharfun, int escapeflag) | |
| 1558 { | |
| 1559 /* This function can GC */ | |
| 2001 | 1560 int specdepth = 0; |
| 1204 | 1561 struct gcpro gcpro1, gcpro2; |
| 428 | 1562 |
| 1563 QUIT; | |
| 1564 | |
| 771 | 1565 #ifdef NO_PRINT_DURING_GC |
| 428 | 1566 /* Emacs won't print while GCing, but an external debugger might */ |
| 1567 if (gc_in_progress) return; | |
| 771 | 1568 #endif |
| 1569 | |
| 1204 | 1570 /* Just to be safe ... */ |
| 1571 GCPRO2 (obj, printcharfun); | |
| 428 | 1572 |
| 1573 #ifdef I18N3 | |
| 1574 /* #### Both input and output streams should have a flag associated | |
| 1575 with them indicating whether output to that stream, or strings | |
| 1576 read from the stream, get translated using Fgettext(). Such a | |
| 1577 stream is called a "translating stream". For the minibuffer and | |
| 1578 external-debugging-output this is always true on output, and | |
| 1579 with-output-to-temp-buffer sets the flag to true for the buffer | |
| 1580 it creates. This flag should also be user-settable. Perhaps it | |
| 1581 should be split up into two flags, one for input and one for | |
| 1582 output. */ | |
| 1583 #endif | |
| 1584 | |
| 1585 /* Detect circularities and truncate them. | |
| 1586 No need to offer any alternative--this is better than an error. */ | |
| 1587 if (CONSP (obj) || VECTORP (obj) || COMPILED_FUNCTIONP (obj)) | |
| 1588 { | |
| 1589 int i; | |
| 1590 for (i = 0; i < print_depth; i++) | |
| 1591 if (EQ (obj, being_printed[i])) | |
| 1592 { | |
| 603 | 1593 char buf[DECIMAL_PRINT_SIZE (long) + 1]; |
| 428 | 1594 *buf = '#'; |
| 1595 long_to_string (buf + 1, i); | |
| 826 | 1596 write_c_string (printcharfun, buf); |
| 1204 | 1597 UNGCPRO; |
| 428 | 1598 return; |
| 1599 } | |
| 1600 } | |
| 1601 | |
| 1602 being_printed[print_depth] = obj; | |
| 1603 | |
| 1957 | 1604 /* Avoid calling internal_bind_int, which conses, when called from |
| 1605 debug_prin1. In that case, we have bound print_depth to 0 anyway. */ | |
| 2367 | 1606 if (!inhibit_non_essential_conversion_operations) |
| 1957 | 1607 { |
| 1608 specdepth = internal_bind_int (&print_depth, print_depth + 1); | |
| 1609 | |
| 1610 if (print_depth > PRINT_CIRCLE) | |
| 1611 signal_error (Qstack_overflow, "Apparently circular structure being printed", Qunbound); | |
| 1612 } | |
| 428 | 1613 |
| 1614 switch (XTYPE (obj)) | |
| 1615 { | |
| 1616 case Lisp_Type_Int_Even: | |
| 1617 case Lisp_Type_Int_Odd: | |
| 1618 { | |
| 603 | 1619 char buf[DECIMAL_PRINT_SIZE (EMACS_INT)]; |
| 428 | 1620 long_to_string (buf, XINT (obj)); |
| 826 | 1621 write_c_string (printcharfun, buf); |
| 428 | 1622 break; |
| 1623 } | |
| 1624 | |
| 1625 case Lisp_Type_Char: | |
| 1626 { | |
| 1627 /* God intended that this be #\..., you know. */ | |
| 1628 char buf[16]; | |
| 867 | 1629 Ichar ch = XCHAR (obj); |
| 428 | 1630 char *p = buf; |
| 1631 *p++ = '?'; | |
| 434 | 1632 if (ch < 32) |
| 1633 { | |
| 1634 *p++ = '\\'; | |
| 1635 switch (ch) | |
| 1636 { | |
| 1637 case '\t': *p++ = 't'; break; | |
| 1638 case '\n': *p++ = 'n'; break; | |
| 1639 case '\r': *p++ = 'r'; break; | |
| 1640 default: | |
| 1641 *p++ = '^'; | |
| 1642 *p++ = ch + 64; | |
| 1643 if ((ch + 64) == '\\') | |
| 1644 *p++ = '\\'; | |
| 1645 break; | |
| 1646 } | |
| 1647 } | |
| 1648 else if (ch < 127) | |
| 428 | 1649 { |
| 434 | 1650 /* syntactically special characters should be escaped. */ |
| 1651 switch (ch) | |
| 1652 { | |
| 1653 case ' ': | |
| 1654 case '"': | |
| 1655 case '#': | |
| 1656 case '\'': | |
| 1657 case '(': | |
| 1658 case ')': | |
| 1659 case ',': | |
| 1660 case '.': | |
| 1661 case ';': | |
| 1662 case '?': | |
| 1663 case '[': | |
| 1664 case '\\': | |
| 1665 case ']': | |
| 1666 case '`': | |
| 1667 *p++ = '\\'; | |
| 1668 } | |
| 1669 *p++ = ch; | |
| 428 | 1670 } |
| 1671 else if (ch == 127) | |
| 434 | 1672 { |
| 1673 *p++ = '\\', *p++ = '^', *p++ = '?'; | |
| 1674 } | |
| 1675 else if (ch < 160) | |
| 428 | 1676 { |
| 1677 *p++ = '\\', *p++ = '^'; | |
| 867 | 1678 p += set_itext_ichar ((Ibyte *) p, ch + 64); |
| 428 | 1679 } |
| 1680 else | |
| 434 | 1681 { |
| 867 | 1682 p += set_itext_ichar ((Ibyte *) p, ch); |
| 434 | 1683 } |
| 440 | 1684 |
| 867 | 1685 output_string (printcharfun, (Ibyte *) buf, Qnil, 0, p - buf); |
| 434 | 1686 |
| 428 | 1687 break; |
| 1688 } | |
| 1689 | |
| 1690 case Lisp_Type_Record: | |
| 1691 { | |
| 1692 struct lrecord_header *lheader = XRECORD_LHEADER (obj); | |
| 1204 | 1693 |
| 1694 /* Try to check for various sorts of bogus pointers if we're in a | |
| 1695 situation where it may be likely -- i.e. called from | |
| 1696 debug_print() or we're already crashing. In such cases, | |
| 1697 (further) crashing is counterproductive. */ | |
| 428 | 1698 |
| 2367 | 1699 if (inhibit_non_essential_conversion_operations && |
| 1204 | 1700 !debug_can_access_memory (lheader, sizeof (*lheader))) |
| 1701 { | |
| 1702 write_fmt_string (printcharfun, "#<EMACS BUG: BAD MEMORY %p>", | |
| 1703 lheader); | |
| 1704 break; | |
| 1705 } | |
| 1706 | |
| 1707 if (CONSP (obj) || VECTORP (obj)) | |
| 428 | 1708 { |
| 1709 /* If deeper than spec'd depth, print placeholder. */ | |
| 1710 if (INTP (Vprint_level) | |
| 1711 && print_depth > XINT (Vprint_level)) | |
| 1712 { | |
| 826 | 1713 write_c_string (printcharfun, "..."); |
| 428 | 1714 break; |
| 1715 } | |
| 1716 } | |
| 1717 | |
| 3263 | 1718 #ifndef NEW_GC |
| 1204 | 1719 if (lheader->type == lrecord_type_free) |
| 1720 { | |
| 1721 printing_major_badness (printcharfun, "freed lrecord", 0, | |
| 1722 lheader, BADNESS_NO_TYPE); | |
| 1723 break; | |
| 1724 } | |
| 1725 else if (lheader->type == lrecord_type_undefined) | |
| 1726 { | |
| 1727 printing_major_badness (printcharfun, "lrecord_type_undefined", 0, | |
| 1728 lheader, BADNESS_NO_TYPE); | |
| 1729 break; | |
| 1730 } | |
| 3263 | 1731 #endif /* not NEW_GC */ |
| 1204 | 1732 else if ((int) (lheader->type) >= lrecord_type_count) |
| 1733 { | |
| 1734 printing_major_badness (printcharfun, "illegal lrecord type", | |
| 1735 (int) (lheader->type), | |
| 1736 lheader, BADNESS_POINTER_OBJECT); | |
| 1737 break; | |
| 1738 } | |
| 1739 | |
| 1740 /* Further checks for bad memory in critical situations. We don't | |
| 1741 normally do these because they may be expensive or weird | |
| 1742 (e.g. under Unix we typically have to set a SIGSEGV handler and | |
| 1743 try to trigger a seg fault). */ | |
| 1744 | |
| 2367 | 1745 if (inhibit_non_essential_conversion_operations) |
| 1204 | 1746 { |
| 1747 if (!debug_can_access_memory | |
| 1748 (lheader, detagged_lisp_object_size (lheader))) | |
| 1749 { | |
| 1750 write_fmt_string (printcharfun, | |
| 1751 "#<EMACS BUG: type %s BAD MEMORY %p>", | |
| 1752 LHEADER_IMPLEMENTATION (lheader)->name, | |
| 1753 lheader); | |
| 1754 break; | |
| 1755 } | |
| 1756 | |
| 1757 if (STRINGP (obj)) | |
| 1758 { | |
| 3092 | 1759 #ifdef NEW_GC |
| 1760 if (!debug_can_access_memory (XSTRING_DATA (obj), | |
| 1761 XSTRING_LENGTH (obj))) | |
| 1762 { | |
| 1763 write_fmt_string | |
| 1764 (printcharfun, | |
| 1765 "#<EMACS BUG: %p (BAD STRING DATA %p)>", | |
| 1766 lheader, XSTRING_DATA (obj)); | |
| 1767 break; | |
| 1768 } | |
| 1769 #else /* not NEW_GC */ | |
| 1204 | 1770 Lisp_String *l = (Lisp_String *) lheader; |
| 1771 if (!debug_can_access_memory (l->data_, l->size_)) | |
| 1772 { | |
| 1773 write_fmt_string | |
| 1774 (printcharfun, | |
| 1775 "#<EMACS BUG: %p (BAD STRING DATA %p)>", | |
| 1776 lheader, l->data_); | |
| 1777 break; | |
| 1778 } | |
| 3092 | 1779 #endif /* not NEW_GC */ |
| 1204 | 1780 } |
| 1781 } | |
| 1782 | |
| 428 | 1783 if (LHEADER_IMPLEMENTATION (lheader)->printer) |
| 1784 ((LHEADER_IMPLEMENTATION (lheader)->printer) | |
| 1785 (obj, printcharfun, escapeflag)); | |
| 1786 else | |
| 3085 | 1787 internal_object_printer (obj, printcharfun, escapeflag); |
| 428 | 1788 break; |
| 1789 } | |
| 1790 | |
| 1791 default: | |
| 1792 { | |
| 1793 /* We're in trouble if this happens! */ | |
| 1204 | 1794 printing_major_badness (printcharfun, "illegal data type", XTYPE (obj), |
| 1795 LISP_TO_VOID (obj), BADNESS_INTEGER_OBJECT); | |
| 428 | 1796 break; |
| 1797 } | |
| 1798 } | |
| 1799 | |
| 2367 | 1800 if (!inhibit_non_essential_conversion_operations) |
| 1957 | 1801 unbind_to (specdepth); |
| 1204 | 1802 UNGCPRO; |
| 428 | 1803 } |
| 1804 | |
| 1805 void | |
| 2286 | 1806 print_float (Lisp_Object obj, Lisp_Object printcharfun, |
| 1807 int UNUSED (escapeflag)) | |
| 428 | 1808 { |
| 1809 char pigbuf[350]; /* see comments in float_to_string */ | |
| 1810 | |
| 1811 float_to_string (pigbuf, XFLOAT_DATA (obj)); | |
| 826 | 1812 write_c_string (printcharfun, pigbuf); |
| 428 | 1813 } |
| 1814 | |
| 1815 void | |
| 1816 print_symbol (Lisp_Object obj, Lisp_Object printcharfun, int escapeflag) | |
| 1817 { | |
| 1818 /* This function can GC */ | |
| 1819 /* #### Bug!! (intern "") isn't printed in some distinguished way */ | |
| 1820 /* #### (the reader also loses on it) */ | |
| 793 | 1821 Lisp_Object name = symbol_name (XSYMBOL (obj)); |
| 1822 Bytecount size = XSTRING_LENGTH (name); | |
| 428 | 1823 struct gcpro gcpro1, gcpro2; |
| 1824 | |
| 1825 if (!escapeflag) | |
| 1826 { | |
| 1827 /* This deals with GC-relocation */ | |
| 793 | 1828 output_string (printcharfun, 0, name, 0, size); |
| 428 | 1829 return; |
| 1830 } | |
| 1831 GCPRO2 (obj, printcharfun); | |
| 1832 | |
| 1833 /* If we print an uninterned symbol as part of a complex object and | |
| 1834 the flag print-gensym is non-nil, prefix it with #n= to read the | |
| 1835 object back with the #n# reader syntax later if needed. */ | |
| 1836 if (!NILP (Vprint_gensym) | |
| 442 | 1837 /* #### Test whether this produces a noticeable slow-down for |
| 428 | 1838 printing when print-gensym is non-nil. */ |
| 1839 && !EQ (obj, oblookup (Vobarray, | |
| 793 | 1840 XSTRING_DATA (symbol_name (XSYMBOL (obj))), |
| 1841 XSTRING_LENGTH (symbol_name (XSYMBOL (obj)))))) | |
| 428 | 1842 { |
| 1843 if (print_depth > 1) | |
| 1844 { | |
| 1845 Lisp_Object tem = Fassq (obj, Vprint_gensym_alist); | |
| 1846 if (CONSP (tem)) | |
| 1847 { | |
| 826 | 1848 write_c_string (printcharfun, "#"); |
| 428 | 1849 print_internal (XCDR (tem), printcharfun, escapeflag); |
| 826 | 1850 write_c_string (printcharfun, "#"); |
| 446 | 1851 UNGCPRO; |
| 428 | 1852 return; |
| 1853 } | |
| 1854 else | |
| 1855 { | |
| 1856 if (CONSP (Vprint_gensym_alist)) | |
| 1857 { | |
| 1858 /* Vprint_gensym_alist is exposed to Lisp, so we | |
| 1859 have to be careful. */ | |
| 1860 CHECK_CONS (XCAR (Vprint_gensym_alist)); | |
| 1861 CHECK_INT (XCDR (XCAR (Vprint_gensym_alist))); | |
| 793 | 1862 tem = make_int (XINT (XCDR (XCAR (Vprint_gensym_alist))) + 1); |
| 428 | 1863 } |
| 1864 else | |
| 793 | 1865 tem = make_int (1); |
| 428 | 1866 Vprint_gensym_alist = Fcons (Fcons (obj, tem), Vprint_gensym_alist); |
| 1867 | |
| 826 | 1868 write_c_string (printcharfun, "#"); |
| 428 | 1869 print_internal (tem, printcharfun, escapeflag); |
| 826 | 1870 write_c_string (printcharfun, "="); |
| 428 | 1871 } |
| 1872 } | |
| 826 | 1873 write_c_string (printcharfun, "#:"); |
| 428 | 1874 } |
| 1875 | |
| 1876 /* Does it look like an integer or a float? */ | |
| 1877 { | |
| 867 | 1878 Ibyte *data = XSTRING_DATA (name); |
| 428 | 1879 Bytecount confusing = 0; |
| 1880 | |
| 1881 if (size == 0) | |
| 1882 goto not_yet_confused; /* Really confusing */ | |
| 1883 else if (isdigit (data[0])) | |
| 1884 confusing = 0; | |
| 1885 else if (size == 1) | |
| 1886 goto not_yet_confused; | |
| 1887 else if (data[0] == '-' || data[0] == '+') | |
| 1888 confusing = 1; | |
| 1889 else | |
| 1890 goto not_yet_confused; | |
| 1891 | |
| 1892 for (; confusing < size; confusing++) | |
| 1893 { | |
| 1894 if (!isdigit (data[confusing])) | |
| 1895 { | |
| 1896 confusing = 0; | |
| 1897 break; | |
| 1898 } | |
| 1899 } | |
| 1900 not_yet_confused: | |
| 1901 | |
| 1902 if (!confusing) | |
| 1903 /* #### Ugh, this is needlessly complex and slow for what we | |
| 1904 need here. It might be a good idea to copy equivalent code | |
| 1905 from FSF. --hniksic */ | |
| 1906 confusing = isfloat_string ((char *) data); | |
| 1907 if (confusing) | |
| 826 | 1908 write_c_string (printcharfun, "\\"); |
| 428 | 1909 } |
| 1910 | |
| 1911 { | |
| 1912 Bytecount i; | |
| 1913 Bytecount last = 0; | |
| 1914 | |
| 1915 for (i = 0; i < size; i++) | |
| 1916 { | |
| 826 | 1917 switch (string_byte (name, i)) |
| 428 | 1918 { |
| 1919 case 0: case 1: case 2: case 3: | |
| 1920 case 4: case 5: case 6: case 7: | |
| 1921 case 8: case 9: case 10: case 11: | |
| 1922 case 12: case 13: case 14: case 15: | |
| 1923 case 16: case 17: case 18: case 19: | |
| 1924 case 20: case 21: case 22: case 23: | |
| 1925 case 24: case 25: case 26: case 27: | |
| 1926 case 28: case 29: case 30: case 31: | |
| 1927 case ' ': case '\"': case '\\': case '\'': | |
| 1928 case ';': case '#' : case '(' : case ')': | |
| 1929 case ',': case '.' : case '`' : | |
| 1930 case '[': case ']' : case '?' : | |
| 1931 if (i > last) | |
| 793 | 1932 output_string (printcharfun, 0, name, last, i - last); |
| 826 | 1933 write_c_string (printcharfun, "\\"); |
| 428 | 1934 last = i; |
| 1935 } | |
| 1936 } | |
| 793 | 1937 output_string (printcharfun, 0, name, last, size - last); |
| 428 | 1938 } |
| 1939 UNGCPRO; | |
| 1940 } | |
| 1941 | |
| 1942 | |
| 442 | 1943 /* Useful on systems or in places where writing to stdout is unavailable or |
| 1944 not working. */ | |
| 428 | 1945 |
| 1946 static int alternate_do_pointer; | |
| 1957 | 1947 static int alternate_do_size; |
| 1948 static char *alternate_do_string; | |
| 428 | 1949 |
| 1950 DEFUN ("alternate-debugging-output", Falternate_debugging_output, 1, 1, 0, /* | |
| 1951 Append CHARACTER to the array `alternate_do_string'. | |
| 1952 This can be used in place of `external-debugging-output' as a function | |
| 1953 to be passed to `print'. Before calling `print', set `alternate_do_pointer' | |
| 1954 to 0. | |
| 1955 */ | |
| 1956 (character)) | |
| 1957 { | |
| 867 | 1958 Ibyte str[MAX_ICHAR_LEN]; |
| 428 | 1959 Bytecount len; |
| 1960 | |
| 1961 CHECK_CHAR_COERCE_INT (character); | |
| 867 | 1962 len = set_itext_ichar (str, XCHAR (character)); |
| 771 | 1963 write_string_to_alternate_debugging_output (str, len); |
| 1964 | |
| 1965 return character; | |
| 1966 } | |
| 1967 | |
| 1968 static void | |
| 1346 | 1969 write_string_to_alternate_debugging_output (const Ibyte *str, Bytecount len) |
| 771 | 1970 { |
| 1971 int extlen; | |
| 1972 const Extbyte *extptr; | |
| 1973 #if 0 /* We want to see the internal representation, don't we? */ | |
| 2367 | 1974 if (initialized && !inhibit_non_essential_conversion_operations) |
| 771 | 1975 TO_EXTERNAL_FORMAT (DATA, (str, len), |
| 1976 ALLOCA, (extptr, extlen), | |
| 1977 Qterminal); | |
| 1978 else | |
| 1979 #endif /* 0 */ | |
| 1980 { | |
| 1981 extlen = len; | |
| 1982 extptr = (Extbyte *) str; | |
| 1983 } | |
| 1957 | 1984 |
| 1985 /* If not yet initialized, just skip it. */ | |
| 1986 if (alternate_do_string == NULL) | |
| 1987 return; | |
| 1988 | |
| 1989 if (alternate_do_pointer + extlen >= alternate_do_size) | |
| 1990 { | |
| 1991 alternate_do_size = | |
| 1992 max(alternate_do_size * 2, alternate_do_pointer + extlen + 1); | |
| 1993 XREALLOC_ARRAY (alternate_do_string, char, alternate_do_size); | |
| 1994 } | |
| 428 | 1995 memcpy (alternate_do_string + alternate_do_pointer, extptr, extlen); |
| 1996 alternate_do_pointer += extlen; | |
| 1997 alternate_do_string[alternate_do_pointer] = 0; | |
| 1998 } | |
| 1999 | |
| 1346 | 2000 |
| 2001 DEFUN ("set-device-clear-left-side", Fset_device_clear_left_side, 2, 2, 0, /* | |
| 2002 Set whether to output a newline before the next output to a stream device. | |
| 2003 This will happen only if the most recently-outputted character was not | |
| 2004 a newline -- i.e. it will make sure the left side is "clear" of text. | |
| 2005 */ | |
| 2006 (device, value)) | |
| 2007 { | |
| 2008 if (!NILP (device)) | |
| 2009 CHECK_LIVE_DEVICE (device); | |
| 2010 if (NILP (device) || DEVICE_STREAM_P (XDEVICE (device))) | |
| 2011 /* #### This should be per-device */ | |
| 2012 stdout_clear_before_next_output = !NILP (value); | |
| 2013 return Qnil; | |
| 2014 } | |
| 2015 | |
| 2016 DEFUN ("device-left-side-clear-p", Fdevice_left_side_clear_p, 0, 1, 0, /* | |
| 2017 For stream devices, true if the most recent-outputted character was a newline. | |
| 2018 */ | |
| 2019 (device)) | |
| 2020 { | |
| 2021 if (!NILP (device)) | |
| 2022 CHECK_LIVE_DEVICE (device); | |
| 2023 if (NILP (device) || DEVICE_STREAM_P (XDEVICE (device))) | |
| 2024 /* #### This should be per-device */ | |
| 2025 return stdout_needs_newline ? Qt : Qnil; | |
| 2026 return Qnil; | |
| 2027 } | |
| 2028 | |
| 428 | 2029 DEFUN ("external-debugging-output", Fexternal_debugging_output, 1, 3, 0, /* |
| 2030 Write CHAR-OR-STRING to stderr or stdout. | |
| 2031 If optional arg STDOUT-P is non-nil, write to stdout; otherwise, write | |
| 2032 to stderr. You can use this function to write directly to the terminal. | |
| 2033 This function can be used as the STREAM argument of Fprint() or the like. | |
| 2034 | |
| 442 | 2035 Under MS Windows, this writes output to the console window (which is |
| 2036 created, if necessary), unless XEmacs is being run noninteractively | |
| 2037 \(i.e. using the `-batch' argument). | |
| 2038 | |
| 428 | 2039 If you have opened a termscript file (using `open-termscript'), then |
| 2040 the output also will be logged to this file. | |
| 2041 */ | |
| 2042 (char_or_string, stdout_p, device)) | |
| 2043 { | |
| 2044 FILE *file = 0; | |
| 2045 struct console *con = 0; | |
| 2046 | |
| 2047 if (NILP (device)) | |
| 2048 { | |
| 2049 if (!NILP (stdout_p)) | |
| 2050 file = stdout; | |
| 2051 else | |
| 2052 file = stderr; | |
| 2053 } | |
| 2054 else | |
| 2055 { | |
| 2056 CHECK_LIVE_DEVICE (device); | |
| 2057 if (!DEVICE_TTY_P (XDEVICE (device)) && | |
| 2058 !DEVICE_STREAM_P (XDEVICE (device))) | |
| 563 | 2059 wtaerror ("Must be tty or stream device", device); |
| 428 | 2060 con = XCONSOLE (DEVICE_CONSOLE (XDEVICE (device))); |
| 2061 if (DEVICE_TTY_P (XDEVICE (device))) | |
| 2062 file = 0; | |
| 2063 else if (!NILP (stdout_p)) | |
| 2064 file = CONSOLE_STREAM_DATA (con)->out; | |
| 2065 else | |
| 2066 file = CONSOLE_STREAM_DATA (con)->err; | |
| 2067 } | |
| 2068 | |
| 2069 if (STRINGP (char_or_string)) | |
| 2070 write_string_to_stdio_stream (file, con, | |
| 2071 XSTRING_DATA (char_or_string), | |
| 771 | 2072 XSTRING_LENGTH (char_or_string), |
| 2073 print_unbuffered); | |
| 428 | 2074 else |
| 2075 { | |
| 867 | 2076 Ibyte str[MAX_ICHAR_LEN]; |
| 428 | 2077 Bytecount len; |
| 2078 | |
| 2079 CHECK_CHAR_COERCE_INT (char_or_string); | |
| 867 | 2080 len = set_itext_ichar (str, XCHAR (char_or_string)); |
| 771 | 2081 write_string_to_stdio_stream (file, con, str, len, print_unbuffered); |
| 428 | 2082 } |
| 2083 | |
| 2084 return char_or_string; | |
| 2085 } | |
| 2086 | |
| 2087 DEFUN ("open-termscript", Fopen_termscript, 1, 1, "FOpen termscript file: ", /* | |
| 444 | 2088 Start writing all terminal output to FILENAME as well as the terminal. |
| 2089 FILENAME = nil means just close any termscript file currently open. | |
| 428 | 2090 */ |
| 444 | 2091 (filename)) |
| 428 | 2092 { |
| 2093 /* This function can GC */ | |
| 2094 if (termscript != 0) | |
| 2095 { | |
| 771 | 2096 retry_fclose (termscript); |
| 444 | 2097 termscript = 0; |
| 2098 } | |
| 2099 | |
| 2100 if (! NILP (filename)) | |
| 2101 { | |
| 2102 filename = Fexpand_file_name (filename, Qnil); | |
| 771 | 2103 termscript = qxe_fopen (XSTRING_DATA (filename), "w"); |
| 428 | 2104 if (termscript == NULL) |
| 563 | 2105 report_file_error ("Opening termscript", filename); |
| 428 | 2106 } |
| 2107 return Qnil; | |
| 2108 } | |
| 2109 | |
| 440 | 2110 static int debug_print_length = 50; |
| 2111 static int debug_print_level = 15; | |
| 2112 static int debug_print_readably = -1; | |
| 428 | 2113 |
| 1957 | 2114 /* Restore values temporarily bound by debug_prin1. We use this approach to |
| 2115 avoid consing in debug_prin1. That is verboten, since debug_prin1 can be | |
| 2116 called by cons debugging code. */ | |
| 2117 static Lisp_Object | |
| 2286 | 2118 debug_prin1_exit (Lisp_Object UNUSED (ignored)) |
| 1957 | 2119 { |
| 2120 struct debug_bindings *bindings = | |
| 2121 (struct debug_bindings *) XOPAQUE (debug_prin1_bindings)->data; | |
| 2367 | 2122 inhibit_non_essential_conversion_operations = |
| 2123 bindings->inhibit_non_essential_conversion_operations; | |
| 1957 | 2124 print_depth = bindings->print_depth; |
| 2125 print_readably = bindings->print_readably; | |
| 2126 print_unbuffered = bindings->print_unbuffered; | |
| 2127 gc_currently_forbidden = bindings->gc_currently_forbidden; | |
| 2128 Vprint_length = bindings->Vprint_length; | |
| 2129 Vprint_level = bindings->Vprint_level; | |
| 2130 Vinhibit_quit = bindings->Vinhibit_quit; | |
| 2131 return Qnil; | |
| 2132 } | |
| 2133 | |
| 1346 | 2134 /* Print an object, `prin1'-style, to various possible debugging outputs. |
| 2135 Make sure it's completely unbuffered so that, in the event of a crash | |
| 2136 somewhere, we see as much as possible that happened before it. | |
| 2137 */ | |
| 428 | 2138 static void |
| 1346 | 2139 debug_prin1 (Lisp_Object debug_print_obj, int flags) |
| 428 | 2140 { |
| 2141 /* This function can GC */ | |
| 853 | 2142 |
| 2143 /* by doing this, we trick various things that are non-essential | |
| 2144 but might cause crashes into not getting executed. */ | |
| 1957 | 2145 int specdepth; |
| 2146 struct debug_bindings *bindings = | |
| 2147 (struct debug_bindings *) XOPAQUE (debug_prin1_bindings)->data; | |
| 853 | 2148 |
| 2367 | 2149 bindings->inhibit_non_essential_conversion_operations = |
| 2150 inhibit_non_essential_conversion_operations; | |
| 1957 | 2151 bindings->print_depth = print_depth; |
| 2152 bindings->print_readably = print_readably; | |
| 2153 bindings->print_unbuffered = print_unbuffered; | |
| 2154 bindings->gc_currently_forbidden = gc_currently_forbidden; | |
| 2155 bindings->Vprint_length = Vprint_length; | |
| 2156 bindings->Vprint_level = Vprint_level; | |
| 2157 bindings->Vinhibit_quit = Vinhibit_quit; | |
| 2158 specdepth = record_unwind_protect (debug_prin1_exit, Qnil); | |
| 2159 | |
| 2367 | 2160 inhibit_non_essential_conversion_operations = 1; |
| 1957 | 2161 print_depth = 0; |
| 2162 print_readably = debug_print_readably != -1 ? debug_print_readably : 0; | |
| 2163 print_unbuffered++; | |
| 428 | 2164 if (debug_print_length > 0) |
| 1957 | 2165 Vprint_length = make_int (debug_print_length); |
| 428 | 2166 if (debug_print_level > 0) |
| 1957 | 2167 Vprint_level = make_int (debug_print_level); |
| 2168 Vinhibit_quit = Qt; | |
| 1346 | 2169 |
| 2170 if ((flags & EXT_PRINT_STDOUT) || (flags & EXT_PRINT_STDERR)) | |
| 2171 print_internal (debug_print_obj, Qexternal_debugging_output, 1); | |
| 2172 if (flags & EXT_PRINT_ALTERNATE) | |
| 2173 print_internal (debug_print_obj, Qalternate_debugging_output, 1); | |
| 442 | 2174 #ifdef WIN32_NATIVE |
| 1346 | 2175 if (flags & EXT_PRINT_MSWINDOWS) |
| 2176 { | |
| 2177 /* Write out to the debugger, as well */ | |
| 2178 print_internal (debug_print_obj, Qmswindows_debugging_output, 1); | |
| 2179 } | |
| 442 | 2180 #endif |
| 440 | 2181 |
| 802 | 2182 unbind_to (specdepth); |
| 428 | 2183 } |
| 2184 | |
| 2185 void | |
| 1204 | 2186 debug_p4 (Lisp_Object obj) |
| 2187 { | |
| 2367 | 2188 inhibit_non_essential_conversion_operations = 1; |
| 1204 | 2189 if (STRINGP (obj)) |
| 2190 debug_out ("\"%s\"", XSTRING_DATA (obj)); | |
| 2191 else if (CONSP (obj)) | |
| 2192 { | |
| 2193 int first = 1; | |
| 2194 do { | |
| 2195 debug_out (first ? "(" : " "); | |
| 2196 first = 0; | |
| 2197 debug_p4 (XCAR (obj)); | |
| 2198 obj = XCDR (obj); | |
| 2199 } while (CONSP (obj)); | |
| 2200 if (NILP (obj)) | |
| 2201 debug_out (")"); | |
| 2202 else | |
| 2203 { | |
| 2204 debug_out (" . "); | |
| 2205 debug_p4 (obj); | |
| 2206 debug_out (")"); | |
| 2207 } | |
| 2208 } | |
| 2209 else if (VECTORP (obj)) | |
| 2210 { | |
| 2211 int size = XVECTOR_LENGTH (obj); | |
| 2212 int i; | |
| 2213 int first = 1; | |
| 2214 | |
| 2215 for (i = 0; i < size; i++) | |
| 2216 { | |
| 2217 debug_out (first ? "[" : " "); | |
| 2218 first = 0; | |
| 2219 debug_p4 (XVECTOR_DATA (obj)[i]); | |
| 2220 debug_out ("]"); | |
| 2221 } | |
| 2222 } | |
| 2223 else if (SYMBOLP (obj)) | |
| 2224 { | |
| 2225 Lisp_Object name = XSYMBOL_NAME (obj); | |
| 2226 if (!STRINGP (name)) | |
| 2227 debug_out ("<<bad symbol>>"); | |
| 2228 else | |
| 2229 debug_out ("%s", XSTRING_DATA (name)); | |
| 2230 } | |
| 2231 else if (INTP (obj)) | |
| 2232 { | |
| 2233 debug_out ("%ld", XINT (obj)); | |
| 2234 } | |
| 2235 else if (FLOATP (obj)) | |
| 2236 { | |
| 2237 debug_out ("%g", XFLOAT_DATA (obj)); | |
| 2238 } | |
| 2239 else | |
| 2240 { | |
| 2241 struct lrecord_header *header = | |
| 2242 (struct lrecord_header *) XPNTR (obj); | |
| 2243 | |
| 2244 if (header->type >= lrecord_type_last_built_in_type) | |
| 2245 debug_out ("<< bad object type=%d 0x%lx>>", header->type, | |
| 2246 (EMACS_INT) header); | |
| 2247 else | |
| 3263 | 2248 #ifdef NEW_GC |
| 3063 | 2249 debug_out ("#<%s addr=0x%lx uid=0x%lx>", |
| 2720 | 2250 LHEADER_IMPLEMENTATION (header)->name, |
| 3063 | 2251 (EMACS_INT) header, |
| 2720 | 2252 (EMACS_INT) ((struct lrecord_header *) header)->uid); |
| 3263 | 2253 #else /* not NEW_GC */ |
| 3063 | 2254 debug_out ("#<%s addr=0x%lx uid=0x%lx>", |
| 1204 | 2255 LHEADER_IMPLEMENTATION (header)->name, |
| 3063 | 2256 (EMACS_INT) header, |
| 3092 | 2257 (EMACS_INT) (LHEADER_IMPLEMENTATION (header)->basic_p ? |
| 2258 ((struct lrecord_header *) header)->uid : | |
| 2259 ((struct old_lcrecord_header *) header)->uid)); | |
| 3263 | 2260 #endif /* not NEW_GC */ |
| 1204 | 2261 } |
| 2262 | |
| 2367 | 2263 inhibit_non_essential_conversion_operations = 0; |
| 1204 | 2264 } |
| 2265 | |
| 1346 | 2266 static void |
| 2267 ext_print_begin (int dest) | |
| 2268 { | |
| 2269 if (dest & EXT_PRINT_ALTERNATE) | |
| 2270 alternate_do_pointer = 0; | |
| 2271 if (dest & (EXT_PRINT_STDERR | EXT_PRINT_STDOUT)) | |
| 2272 stdout_clear_before_next_output = 1; | |
| 2273 } | |
| 2274 | |
| 2275 static void | |
| 2276 ext_print_end (int dest) | |
| 2277 { | |
| 2278 if (dest & (EXT_PRINT_MSWINDOWS | EXT_PRINT_STDERR | EXT_PRINT_STDOUT)) | |
| 2279 external_out (dest & (EXT_PRINT_MSWINDOWS | EXT_PRINT_STDERR | | |
| 2280 EXT_PRINT_STDOUT), "\n"); | |
| 2281 } | |
| 2282 | |
| 2283 static void | |
| 2284 external_debug_print (Lisp_Object object, int dest) | |
| 2285 { | |
| 2286 ext_print_begin (dest); | |
| 2287 debug_prin1 (object, dest); | |
| 2288 ext_print_end (dest); | |
| 2289 } | |
| 2290 | |
| 1204 | 2291 void |
| 2292 debug_p3 (Lisp_Object obj) | |
| 2293 { | |
| 2294 debug_p4 (obj); | |
| 2367 | 2295 inhibit_non_essential_conversion_operations = 1; |
| 1204 | 2296 debug_out ("\n"); |
| 2367 | 2297 inhibit_non_essential_conversion_operations = 0; |
| 1204 | 2298 } |
| 2299 | |
| 2300 void | |
| 428 | 2301 debug_print (Lisp_Object debug_print_obj) |
| 2302 { | |
| 1346 | 2303 external_debug_print (debug_print_obj, EXT_PRINT_ALL); |
| 428 | 2304 } |
| 2305 | |
| 1204 | 2306 /* Getting tired of typing debug_print() ... */ |
| 2307 void dp (Lisp_Object debug_print_obj); | |
| 2308 void | |
| 2309 dp (Lisp_Object debug_print_obj) | |
| 2310 { | |
| 2311 debug_print (debug_print_obj); | |
| 2312 } | |
| 2313 | |
| 1346 | 2314 /* Alternate debug printer: Return a char * pointer to the output */ |
| 2315 char *dpa (Lisp_Object debug_print_obj); | |
| 2316 char * | |
| 2317 dpa (Lisp_Object debug_print_obj) | |
| 2318 { | |
| 2319 external_debug_print (debug_print_obj, EXT_PRINT_ALTERNATE); | |
| 2320 | |
| 2321 return alternate_do_string; | |
| 2322 } | |
| 2323 | |
| 428 | 2324 /* Debugging kludge -- unbuffered */ |
| 2325 /* This function provided for the benefit of the debugger. */ | |
| 2326 void | |
| 2327 debug_backtrace (void) | |
| 2328 { | |
| 2329 /* This function can GC */ | |
| 853 | 2330 |
| 2331 /* by doing this, we trick various things that are non-essential | |
| 2332 but might cause crashes into not getting executed. */ | |
| 2333 int specdepth = | |
| 2367 | 2334 internal_bind_int (&inhibit_non_essential_conversion_operations, 1); |
| 853 | 2335 |
| 2336 internal_bind_int (&print_depth, 0); | |
| 802 | 2337 internal_bind_int (&print_readably, 0); |
| 2338 internal_bind_int (&print_unbuffered, print_unbuffered + 1); | |
| 428 | 2339 if (debug_print_length > 0) |
| 802 | 2340 internal_bind_lisp_object (&Vprint_length, make_int (debug_print_length)); |
| 428 | 2341 if (debug_print_level > 0) |
| 802 | 2342 internal_bind_lisp_object (&Vprint_level, make_int (debug_print_level)); |
| 2343 /* #### Do we need this? It was in the old code. */ | |
| 2344 internal_bind_lisp_object (&Vinhibit_quit, Vinhibit_quit); | |
| 428 | 2345 |
| 2346 Fbacktrace (Qexternal_debugging_output, Qt); | |
| 2347 stderr_out ("\n"); | |
| 2348 | |
| 802 | 2349 unbind_to (specdepth); |
| 428 | 2350 } |
| 2351 | |
| 1204 | 2352 /* Getting tired of typing debug_backtrace() ... */ |
| 2353 void db (void); | |
| 2354 void | |
| 2355 db (void) | |
| 2356 { | |
| 2357 debug_backtrace (); | |
| 2358 } | |
| 2359 | |
| 428 | 2360 void |
| 2361 debug_short_backtrace (int length) | |
| 2362 { | |
| 2363 int first = 1; | |
| 2364 struct backtrace *bt = backtrace_list; | |
| 771 | 2365 debug_out (" ["); |
| 428 | 2366 while (length > 0 && bt) |
| 2367 { | |
| 2368 if (!first) | |
| 2369 { | |
| 771 | 2370 debug_out (", "); |
| 428 | 2371 } |
| 2372 if (COMPILED_FUNCTIONP (*bt->function)) | |
| 2373 { | |
| 1346 | 2374 #if defined (COMPILED_FUNCTION_ANNOTATION_HACK) |
| 428 | 2375 Lisp_Object ann = |
| 2376 compiled_function_annotation (XCOMPILED_FUNCTION (*bt->function)); | |
| 2377 #else | |
| 2378 Lisp_Object ann = Qnil; | |
| 2379 #endif | |
| 2380 if (!NILP (ann)) | |
| 2381 { | |
| 771 | 2382 debug_out ("<compiled-function from "); |
| 1346 | 2383 debug_prin1 (ann, EXT_PRINT_ALL); |
| 771 | 2384 debug_out (">"); |
| 428 | 2385 } |
| 2386 else | |
| 2387 { | |
| 771 | 2388 debug_out ("<compiled-function of unknown origin>"); |
| 428 | 2389 } |
| 2390 } | |
| 2391 else | |
| 1346 | 2392 debug_prin1 (*bt->function, EXT_PRINT_ALL); |
| 428 | 2393 first = 0; |
| 2394 length--; | |
| 2395 bt = bt->next; | |
| 2396 } | |
| 771 | 2397 debug_out ("]\n"); |
| 428 | 2398 } |
| 2399 | |
| 2400 | |
| 2401 void | |
| 2402 syms_of_print (void) | |
| 2403 { | |
| 563 | 2404 DEFSYMBOL (Qstandard_output); |
| 428 | 2405 |
| 563 | 2406 DEFSYMBOL (Qprint_length); |
| 428 | 2407 |
| 563 | 2408 DEFSYMBOL (Qprint_string_length); |
| 428 | 2409 |
| 563 | 2410 DEFSYMBOL (Qdisplay_error); |
| 2411 DEFSYMBOL (Qprint_message_label); | |
| 428 | 2412 |
| 2413 DEFSUBR (Fprin1); | |
| 2414 DEFSUBR (Fprin1_to_string); | |
| 2415 DEFSUBR (Fprinc); | |
| 2416 DEFSUBR (Fprint); | |
| 2417 DEFSUBR (Ferror_message_string); | |
| 2418 DEFSUBR (Fdisplay_error); | |
| 2419 DEFSUBR (Fterpri); | |
| 2420 DEFSUBR (Fwrite_char); | |
| 2421 DEFSUBR (Falternate_debugging_output); | |
| 1346 | 2422 DEFSUBR (Fset_device_clear_left_side); |
| 2423 DEFSUBR (Fdevice_left_side_clear_p); | |
| 428 | 2424 DEFSUBR (Fexternal_debugging_output); |
| 2425 DEFSUBR (Fopen_termscript); | |
| 563 | 2426 DEFSYMBOL (Qexternal_debugging_output); |
| 2427 DEFSYMBOL (Qalternate_debugging_output); | |
| 442 | 2428 #ifdef HAVE_MS_WINDOWS |
| 563 | 2429 DEFSYMBOL (Qmswindows_debugging_output); |
| 442 | 2430 #endif |
| 428 | 2431 DEFSUBR (Fwith_output_to_temp_buffer); |
| 2432 } | |
| 2433 | |
| 2434 void | |
| 2435 reinit_vars_of_print (void) | |
| 2436 { | |
| 2437 alternate_do_pointer = 0; | |
| 2438 } | |
| 2439 | |
| 2440 void | |
| 2441 vars_of_print (void) | |
| 2442 { | |
| 2443 DEFVAR_LISP ("standard-output", &Vstandard_output /* | |
| 2444 Output stream `print' uses by default for outputting a character. | |
| 2445 This may be any function of one argument. | |
| 2446 It may also be a buffer (output is inserted before point) | |
| 2447 or a marker (output is inserted and the marker is advanced) | |
| 2448 or the symbol t (output appears in the minibuffer line). | |
| 2449 */ ); | |
| 2450 Vstandard_output = Qt; | |
| 2451 | |
| 2452 DEFVAR_LISP ("float-output-format", &Vfloat_output_format /* | |
| 2453 The format descriptor string that lisp uses to print floats. | |
| 2454 This is a %-spec like those accepted by `printf' in C, | |
| 2455 but with some restrictions. It must start with the two characters `%.'. | |
| 2456 After that comes an integer precision specification, | |
| 2457 and then a letter which controls the format. | |
| 2458 The letters allowed are `e', `f' and `g'. | |
| 2459 Use `e' for exponential notation "DIG.DIGITSeEXPT" | |
| 2460 Use `f' for decimal point notation "DIGITS.DIGITS". | |
| 2461 Use `g' to choose the shorter of those two formats for the number at hand. | |
| 2462 The precision in any of these cases is the number of digits following | |
| 2463 the decimal point. With `f', a precision of 0 means to omit the | |
| 2464 decimal point. 0 is not allowed with `f' or `g'. | |
| 2465 | |
| 2466 A value of nil means to use `%.16g'. | |
| 2467 | |
| 2468 Regardless of the value of `float-output-format', a floating point number | |
| 2469 will never be printed in such a way that it is ambiguous with an integer; | |
| 2470 that is, a floating-point number will always be printed with a decimal | |
| 2471 point and/or an exponent, even if the digits following the decimal point | |
| 2472 are all zero. This is to preserve read-equivalence. | |
| 2473 */ ); | |
| 2474 Vfloat_output_format = Qnil; | |
| 2475 | |
| 2476 DEFVAR_LISP ("print-length", &Vprint_length /* | |
| 2477 Maximum length of list or vector to print before abbreviating. | |
| 2478 A value of nil means no limit. | |
| 2479 */ ); | |
| 2480 Vprint_length = Qnil; | |
| 2481 | |
| 2482 DEFVAR_LISP ("print-string-length", &Vprint_string_length /* | |
| 2483 Maximum length of string to print before abbreviating. | |
| 2484 A value of nil means no limit. | |
| 2485 */ ); | |
| 2486 Vprint_string_length = Qnil; | |
| 2487 | |
| 2488 DEFVAR_LISP ("print-level", &Vprint_level /* | |
| 2489 Maximum depth of list nesting to print before abbreviating. | |
| 2490 A value of nil means no limit. | |
| 2491 */ ); | |
| 2492 Vprint_level = Qnil; | |
| 2493 | |
| 2494 DEFVAR_BOOL ("print-escape-newlines", &print_escape_newlines /* | |
| 2495 Non-nil means print newlines in strings as backslash-n. | |
| 2496 */ ); | |
| 2497 print_escape_newlines = 0; | |
| 2498 | |
| 2499 DEFVAR_BOOL ("print-readably", &print_readably /* | |
| 2500 If non-nil, then all objects will be printed in a readable form. | |
| 2501 If an object has no readable representation, then an error is signalled. | |
| 2502 When print-readably is true, compiled-function objects will be written in | |
| 2503 #[...] form instead of in #<compiled-function [...]> form, and two-element | |
| 2504 lists of the form (quote object) will be written as the equivalent 'object. | |
| 2505 Do not SET this variable; bind it instead. | |
| 2506 */ ); | |
| 2507 print_readably = 0; | |
| 2508 | |
| 2509 /* #### I think this should default to t. But we'd better wait | |
| 2510 until we see that it works out. */ | |
| 2511 DEFVAR_LISP ("print-gensym", &Vprint_gensym /* | |
| 2512 If non-nil, then uninterned symbols will be printed specially. | |
| 2513 Uninterned symbols are those which are not present in `obarray', that is, | |
| 2514 those which were made with `make-symbol' or by calling `intern' with a | |
| 2515 second argument. | |
| 2516 | |
| 2517 When print-gensym is true, such symbols will be preceded by "#:", | |
| 2518 which causes the reader to create a new symbol instead of interning | |
| 2519 and returning an existing one. Beware: the #: syntax creates a new | |
| 2520 symbol each time it is seen, so if you print an object which contains | |
| 2521 two pointers to the same uninterned symbol, `read' will not duplicate | |
| 2522 that structure. | |
| 2523 | |
| 2524 If the value of `print-gensym' is a cons cell, then in addition | |
| 2525 refrain from clearing `print-gensym-alist' on entry to and exit from | |
| 2526 printing functions, so that the use of #...# and #...= can carry over | |
| 2527 for several separately printed objects. | |
| 2528 */ ); | |
| 2529 Vprint_gensym = Qnil; | |
| 2530 | |
| 2531 DEFVAR_LISP ("print-gensym-alist", &Vprint_gensym_alist /* | |
| 2532 Association list of elements (GENSYM . N) to guide use of #N# and #N=. | |
| 2533 In each element, GENSYM is an uninterned symbol that has been associated | |
| 2534 with #N= for the specified value of N. | |
| 2535 */ ); | |
| 2536 Vprint_gensym_alist = Qnil; | |
| 2537 | |
| 2538 DEFVAR_LISP ("print-message-label", &Vprint_message_label /* | |
| 2539 Label for minibuffer messages created with `print'. This should | |
| 2540 generally be bound with `let' rather than set. (See `display-message'.) | |
| 2541 */ ); | |
| 2542 Vprint_message_label = Qprint; | |
| 1957 | 2543 |
| 2544 debug_prin1_bindings = | |
| 2545 make_opaque (OPAQUE_UNINIT, sizeof (struct debug_bindings)); | |
| 2546 staticpro (&debug_prin1_bindings); | |
| 2547 | |
| 2548 alternate_do_size = 5000; | |
| 2549 alternate_do_string = xnew_array(char, 5000); | |
| 428 | 2550 } |