Mercurial > hg > xemacs-beta
annotate src/print.c @ 4614:afbfad080ddd
The URLs in our current config.guess and config.sub files are obsolete.
Update to the latest upstream release to get correct URLs, as well as fixes
and enhancements to those scripts.
| author | Jerry James <james@xemacs.org> |
|---|---|
| date | Wed, 11 Feb 2009 11:09:35 -0700 |
| parents | 726060ee587c |
| children | 8f1ee2d15784 |
| 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 | |
|
4394
cacc942c0d0f
Avoid clearing print-gensym-alist inappropriately when printing hash tables.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4329
diff
changeset
|
870 Lisp_Object |
|
cacc942c0d0f
Avoid clearing print-gensym-alist inappropriately when printing hash tables.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4329
diff
changeset
|
871 prin1_to_string (Lisp_Object object, int noescape) |
|
cacc942c0d0f
Avoid clearing print-gensym-alist inappropriately when printing hash tables.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4329
diff
changeset
|
872 { |
|
cacc942c0d0f
Avoid clearing print-gensym-alist inappropriately when printing hash tables.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4329
diff
changeset
|
873 /* This function can GC */ |
|
cacc942c0d0f
Avoid clearing print-gensym-alist inappropriately when printing hash tables.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4329
diff
changeset
|
874 Lisp_Object result = Qnil; |
|
cacc942c0d0f
Avoid clearing print-gensym-alist inappropriately when printing hash tables.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4329
diff
changeset
|
875 Lisp_Object stream = make_resizing_buffer_output_stream (); |
|
cacc942c0d0f
Avoid clearing print-gensym-alist inappropriately when printing hash tables.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4329
diff
changeset
|
876 Lstream *str = XLSTREAM (stream); |
|
cacc942c0d0f
Avoid clearing print-gensym-alist inappropriately when printing hash tables.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4329
diff
changeset
|
877 /* gcpro OBJECT in case a caller forgot to do so */ |
|
cacc942c0d0f
Avoid clearing print-gensym-alist inappropriately when printing hash tables.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4329
diff
changeset
|
878 struct gcpro gcpro1, gcpro2, gcpro3; |
|
cacc942c0d0f
Avoid clearing print-gensym-alist inappropriately when printing hash tables.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4329
diff
changeset
|
879 GCPRO3 (object, stream, result); |
|
cacc942c0d0f
Avoid clearing print-gensym-alist inappropriately when printing hash tables.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4329
diff
changeset
|
880 |
|
cacc942c0d0f
Avoid clearing print-gensym-alist inappropriately when printing hash tables.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4329
diff
changeset
|
881 print_internal (object, stream, !noescape); |
|
cacc942c0d0f
Avoid clearing print-gensym-alist inappropriately when printing hash tables.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4329
diff
changeset
|
882 Lstream_flush (str); |
|
cacc942c0d0f
Avoid clearing print-gensym-alist inappropriately when printing hash tables.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4329
diff
changeset
|
883 UNGCPRO; |
|
cacc942c0d0f
Avoid clearing print-gensym-alist inappropriately when printing hash tables.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4329
diff
changeset
|
884 result = make_string (resizing_buffer_stream_ptr (str), |
|
cacc942c0d0f
Avoid clearing print-gensym-alist inappropriately when printing hash tables.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4329
diff
changeset
|
885 Lstream_byte_count (str)); |
|
cacc942c0d0f
Avoid clearing print-gensym-alist inappropriately when printing hash tables.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4329
diff
changeset
|
886 Lstream_delete (str); |
|
cacc942c0d0f
Avoid clearing print-gensym-alist inappropriately when printing hash tables.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4329
diff
changeset
|
887 return result; |
|
cacc942c0d0f
Avoid clearing print-gensym-alist inappropriately when printing hash tables.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4329
diff
changeset
|
888 } |
|
cacc942c0d0f
Avoid clearing print-gensym-alist inappropriately when printing hash tables.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4329
diff
changeset
|
889 |
| 428 | 890 DEFUN ("prin1-to-string", Fprin1_to_string, 1, 2, 0, /* |
| 891 Return a string containing the printed representation of OBJECT, | |
| 892 any Lisp object. Quoting characters are used when needed to make output | |
| 893 that `read' can handle, whenever this is possible, unless the optional | |
| 894 second argument NOESCAPE is non-nil. | |
| 895 */ | |
| 896 (object, noescape)) | |
| 897 { | |
| 898 /* This function can GC */ | |
| 899 Lisp_Object result = Qnil; | |
| 900 | |
| 901 RESET_PRINT_GENSYM; | |
|
4394
cacc942c0d0f
Avoid clearing print-gensym-alist inappropriately when printing hash tables.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4329
diff
changeset
|
902 result = prin1_to_string (object, !(EQ(noescape, Qnil))); |
| 428 | 903 RESET_PRINT_GENSYM; |
|
4394
cacc942c0d0f
Avoid clearing print-gensym-alist inappropriately when printing hash tables.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4329
diff
changeset
|
904 |
| 428 | 905 return result; |
| 906 } | |
| 907 | |
| 908 DEFUN ("princ", Fprinc, 1, 2, 0, /* | |
| 909 Output the printed representation of OBJECT, any Lisp object. | |
| 910 No quoting characters are used; no delimiters are printed around | |
| 911 the contents of strings. | |
| 444 | 912 Output stream is STREAM, or value of `standard-output' (which see). |
| 428 | 913 */ |
| 914 (object, stream)) | |
| 915 { | |
| 916 /* This function can GC */ | |
| 917 Lisp_Object frame = Qnil; | |
| 918 struct gcpro gcpro1, gcpro2; | |
| 919 | |
| 920 GCPRO2 (object, stream); | |
| 921 stream = print_prepare (stream, &frame); | |
| 922 print_internal (object, stream, 0); | |
| 923 print_finish (stream, frame); | |
| 924 UNGCPRO; | |
| 925 return object; | |
| 926 } | |
| 927 | |
| 928 DEFUN ("print", Fprint, 1, 2, 0, /* | |
| 929 Output the printed representation of OBJECT, with newlines around it. | |
| 930 Quoting characters are printed when needed to make output that `read' | |
| 931 can handle, whenever this is possible. | |
| 932 Output stream is STREAM, or value of `standard-output' (which see). | |
| 933 */ | |
| 934 (object, stream)) | |
| 935 { | |
| 936 /* This function can GC */ | |
| 937 Lisp_Object frame = Qnil; | |
| 938 struct gcpro gcpro1, gcpro2; | |
| 939 | |
| 940 GCPRO2 (object, stream); | |
| 941 stream = print_prepare (stream, &frame); | |
| 826 | 942 write_c_string (stream, "\n"); |
| 428 | 943 print_internal (object, stream, 1); |
| 826 | 944 write_c_string (stream, "\n"); |
| 428 | 945 print_finish (stream, frame); |
| 946 UNGCPRO; | |
| 947 return object; | |
| 948 } | |
| 949 | |
| 950 /* Print an error message for the error DATA to STREAM. This is a | |
| 951 complete implementation of `display-error', which used to be in | |
| 952 Lisp (see prim/cmdloop.el). It was ported to C so it can be used | |
| 953 efficiently by Ferror_message_string. Fdisplay_error and | |
| 954 Ferror_message_string are trivial wrappers around this function. | |
| 955 | |
| 956 STREAM should be the result of canonicalize_printcharfun(). */ | |
| 957 static void | |
| 958 print_error_message (Lisp_Object error_object, Lisp_Object stream) | |
| 959 { | |
| 960 /* This function can GC */ | |
| 961 Lisp_Object type = Fcar_safe (error_object); | |
| 962 Lisp_Object method = Qnil; | |
| 963 Lisp_Object tail; | |
| 964 | |
| 965 /* No need to GCPRO anything under the assumption that ERROR_OBJECT | |
| 966 is GCPRO'd. */ | |
| 967 | |
| 968 if (! (CONSP (error_object) && SYMBOLP (type) | |
| 969 && CONSP (Fget (type, Qerror_conditions, Qnil)))) | |
| 970 goto error_throw; | |
| 971 | |
| 972 tail = XCDR (error_object); | |
| 973 while (!NILP (tail)) | |
| 974 { | |
| 975 if (CONSP (tail)) | |
| 976 tail = XCDR (tail); | |
| 977 else | |
| 978 goto error_throw; | |
| 979 } | |
| 980 tail = Fget (type, Qerror_conditions, Qnil); | |
| 981 while (!NILP (tail)) | |
| 982 { | |
| 983 if (!(CONSP (tail) && SYMBOLP (XCAR (tail)))) | |
| 984 goto error_throw; | |
| 985 else if (!NILP (Fget (XCAR (tail), Qdisplay_error, Qnil))) | |
| 986 { | |
| 987 method = Fget (XCAR (tail), Qdisplay_error, Qnil); | |
| 988 goto error_throw; | |
| 989 } | |
| 990 else | |
| 991 tail = XCDR (tail); | |
| 992 } | |
| 993 /* Default method */ | |
| 994 { | |
| 995 int first = 1; | |
| 996 int speccount = specpdl_depth (); | |
| 438 | 997 Lisp_Object frame = Qnil; |
| 998 struct gcpro gcpro1; | |
| 999 GCPRO1 (stream); | |
| 428 | 1000 |
| 1001 specbind (Qprint_message_label, Qerror); | |
| 438 | 1002 stream = print_prepare (stream, &frame); |
| 1003 | |
| 428 | 1004 tail = Fcdr (error_object); |
| 1005 if (EQ (type, Qerror)) | |
| 1006 { | |
| 1007 print_internal (Fcar (tail), stream, 0); | |
| 1008 tail = Fcdr (tail); | |
| 1009 } | |
| 1010 else | |
| 1011 { | |
| 1012 Lisp_Object errmsg = Fget (type, Qerror_message, Qnil); | |
| 1013 if (NILP (errmsg)) | |
| 1014 print_internal (type, stream, 0); | |
| 1015 else | |
| 1016 print_internal (LISP_GETTEXT (errmsg), stream, 0); | |
| 1017 } | |
| 1018 while (!NILP (tail)) | |
| 1019 { | |
| 826 | 1020 write_c_string (stream, first ? ": " : ", "); |
| 563 | 1021 /* Most errors have an explanatory string as their first argument, |
| 1022 and it looks better not to put the quotes around it. */ | |
| 1023 print_internal (Fcar (tail), stream, | |
| 1024 !(first && STRINGP (Fcar (tail))) || | |
| 1025 !NILP (Fget (type, Qerror_lacks_explanatory_string, | |
| 1026 Qnil))); | |
| 428 | 1027 tail = Fcdr (tail); |
| 1028 first = 0; | |
| 1029 } | |
| 438 | 1030 print_finish (stream, frame); |
| 1031 UNGCPRO; | |
| 771 | 1032 unbind_to (speccount); |
| 428 | 1033 return; |
| 1034 /* not reached */ | |
| 1035 } | |
| 1036 | |
| 1037 error_throw: | |
| 1038 if (NILP (method)) | |
| 1039 { | |
| 826 | 1040 write_c_string (stream, GETTEXT ("Peculiar error ")); |
| 428 | 1041 print_internal (error_object, stream, 1); |
| 1042 return; | |
| 1043 } | |
| 1044 else | |
| 1045 { | |
| 1046 call2 (method, error_object, stream); | |
| 1047 } | |
| 1048 } | |
| 1049 | |
| 1050 DEFUN ("error-message-string", Ferror_message_string, 1, 1, 0, /* | |
| 1051 Convert ERROR-OBJECT to an error message, and return it. | |
| 1052 | |
| 1053 The format of ERROR-OBJECT should be (ERROR-SYMBOL . DATA). The | |
| 1054 message is equivalent to the one that would be issued by | |
| 1055 `display-error' with the same argument. | |
| 1056 */ | |
| 1057 (error_object)) | |
| 1058 { | |
| 1059 /* This function can GC */ | |
| 1060 Lisp_Object result = Qnil; | |
| 1061 Lisp_Object stream = make_resizing_buffer_output_stream (); | |
| 1062 struct gcpro gcpro1; | |
| 1063 GCPRO1 (stream); | |
| 1064 | |
| 1065 print_error_message (error_object, stream); | |
| 1066 Lstream_flush (XLSTREAM (stream)); | |
| 1067 result = make_string (resizing_buffer_stream_ptr (XLSTREAM (stream)), | |
| 1068 Lstream_byte_count (XLSTREAM (stream))); | |
| 1069 Lstream_delete (XLSTREAM (stream)); | |
| 1070 | |
| 1071 UNGCPRO; | |
| 1072 return result; | |
| 1073 } | |
| 1074 | |
| 1075 DEFUN ("display-error", Fdisplay_error, 2, 2, 0, /* | |
| 1076 Display ERROR-OBJECT on STREAM in a user-friendly way. | |
| 1077 */ | |
| 1078 (error_object, stream)) | |
| 1079 { | |
| 1080 /* This function can GC */ | |
| 1081 print_error_message (error_object, canonicalize_printcharfun (stream)); | |
| 1082 return Qnil; | |
| 1083 } | |
| 1084 | |
| 1085 | |
| 1086 Lisp_Object Vfloat_output_format; | |
| 1087 | |
| 1088 /* | |
| 1089 * This buffer should be at least as large as the max string size of the | |
| 440 | 1090 * largest float, printed in the biggest notation. This is undoubtedly |
| 428 | 1091 * 20d float_output_format, with the negative of the C-constant "HUGE" |
| 1092 * from <math.h>. | |
| 1093 * | |
| 1094 * On the vax the worst case is -1e38 in 20d format which takes 61 bytes. | |
| 1095 * | |
| 1096 * I assume that IEEE-754 format numbers can take 329 bytes for the worst | |
| 1097 * case of -1e307 in 20d float_output_format. What is one to do (short of | |
| 1098 * re-writing _doprnt to be more sane)? | |
| 1099 * -wsr | |
| 1100 */ | |
| 1101 void | |
| 1102 float_to_string (char *buf, double data) | |
| 1103 { | |
| 867 | 1104 Ibyte *cp, c; |
| 428 | 1105 int width; |
| 1106 | |
| 1107 if (NILP (Vfloat_output_format) | |
| 1108 || !STRINGP (Vfloat_output_format)) | |
| 1109 lose: | |
| 1110 sprintf (buf, "%.16g", data); | |
| 1111 else /* oink oink */ | |
| 1112 { | |
| 1113 /* Check that the spec we have is fully valid. | |
| 1114 This means not only valid for printf, | |
| 1115 but meant for floats, and reasonable. */ | |
| 1116 cp = XSTRING_DATA (Vfloat_output_format); | |
| 1117 | |
| 1118 if (cp[0] != '%') | |
| 1119 goto lose; | |
| 1120 if (cp[1] != '.') | |
| 1121 goto lose; | |
| 1122 | |
| 1123 cp += 2; | |
| 1124 for (width = 0; (c = *cp, isdigit (c)); cp++) | |
| 1125 { | |
| 1126 width *= 10; | |
| 1127 width += c - '0'; | |
| 1128 } | |
| 1129 | |
| 1130 if (*cp != 'e' && *cp != 'f' && *cp != 'g' && *cp != 'E' && *cp != 'G') | |
| 1131 goto lose; | |
| 1132 | |
| 1133 if (width < (int) (*cp != 'e' && *cp != 'E') || width > DBL_DIG) | |
| 1134 goto lose; | |
| 1135 | |
| 1136 if (cp[1] != 0) | |
| 1137 goto lose; | |
| 1138 | |
| 1139 sprintf (buf, (char *) XSTRING_DATA (Vfloat_output_format), | |
| 1140 data); | |
| 1141 } | |
| 1142 | |
| 1143 /* added by jwz: don't allow "1.0" to print as "1"; that destroys | |
| 1144 the read-equivalence of lisp objects. (* x 1) and (* x 1.0) do | |
| 1145 not do the same thing, so it's important that the printed | |
| 1146 representation of that form not be corrupted by the printer. | |
| 1147 */ | |
| 1148 { | |
| 867 | 1149 Ibyte *s = (Ibyte *) buf; /* don't use signed chars here! |
| 428 | 1150 isdigit() can't hack them! */ |
| 1151 if (*s == '-') s++; | |
| 1152 for (; *s; s++) | |
| 1153 /* if there's a non-digit, then there is a decimal point, or | |
| 1154 it's in exponential notation, both of which are ok. */ | |
| 1155 if (!isdigit (*s)) | |
| 1156 goto DONE_LABEL; | |
| 1157 /* otherwise, we need to hack it. */ | |
| 1158 *s++ = '.'; | |
| 1159 *s++ = '0'; | |
| 1160 *s = 0; | |
| 1161 } | |
| 1162 DONE_LABEL: | |
| 1163 | |
| 1164 /* Some machines print "0.4" as ".4". I don't like that. */ | |
| 1165 if (buf [0] == '.' || (buf [0] == '-' && buf [1] == '.')) | |
| 1166 { | |
| 1167 int i; | |
| 1168 for (i = strlen (buf) + 1; i >= 0; i--) | |
| 1169 buf [i+1] = buf [i]; | |
| 1170 buf [(buf [0] == '-' ? 1 : 0)] = '0'; | |
| 1171 } | |
| 1172 } | |
| 1173 | |
| 2500 | 1174 #define ONE_DIGIT(figure) *p++ = (char) (n / (figure) + '0') |
| 577 | 1175 #define ONE_DIGIT_ADVANCE(figure) (ONE_DIGIT (figure), n %= (figure)) |
| 1176 | |
| 1177 #define DIGITS_1(figure) ONE_DIGIT (figure) | |
| 1178 #define DIGITS_2(figure) ONE_DIGIT_ADVANCE (figure); DIGITS_1 ((figure) / 10) | |
| 1179 #define DIGITS_3(figure) ONE_DIGIT_ADVANCE (figure); DIGITS_2 ((figure) / 10) | |
| 1180 #define DIGITS_4(figure) ONE_DIGIT_ADVANCE (figure); DIGITS_3 ((figure) / 10) | |
| 1181 #define DIGITS_5(figure) ONE_DIGIT_ADVANCE (figure); DIGITS_4 ((figure) / 10) | |
| 1182 #define DIGITS_6(figure) ONE_DIGIT_ADVANCE (figure); DIGITS_5 ((figure) / 10) | |
| 1183 #define DIGITS_7(figure) ONE_DIGIT_ADVANCE (figure); DIGITS_6 ((figure) / 10) | |
| 1184 #define DIGITS_8(figure) ONE_DIGIT_ADVANCE (figure); DIGITS_7 ((figure) / 10) | |
| 1185 #define DIGITS_9(figure) ONE_DIGIT_ADVANCE (figure); DIGITS_8 ((figure) / 10) | |
| 1186 #define DIGITS_10(figure) ONE_DIGIT_ADVANCE (figure); DIGITS_9 ((figure) / 10) | |
| 1187 | |
| 1188 /* DIGITS_<11-20> are only used on machines with 64-bit longs. */ | |
| 428 | 1189 |
| 577 | 1190 #define DIGITS_11(figure) ONE_DIGIT_ADVANCE (figure); DIGITS_10 ((figure) / 10) |
| 1191 #define DIGITS_12(figure) ONE_DIGIT_ADVANCE (figure); DIGITS_11 ((figure) / 10) | |
| 1192 #define DIGITS_13(figure) ONE_DIGIT_ADVANCE (figure); DIGITS_12 ((figure) / 10) | |
| 1193 #define DIGITS_14(figure) ONE_DIGIT_ADVANCE (figure); DIGITS_13 ((figure) / 10) | |
| 1194 #define DIGITS_15(figure) ONE_DIGIT_ADVANCE (figure); DIGITS_14 ((figure) / 10) | |
| 1195 #define DIGITS_16(figure) ONE_DIGIT_ADVANCE (figure); DIGITS_15 ((figure) / 10) | |
| 1196 #define DIGITS_17(figure) ONE_DIGIT_ADVANCE (figure); DIGITS_16 ((figure) / 10) | |
| 1197 #define DIGITS_18(figure) ONE_DIGIT_ADVANCE (figure); DIGITS_17 ((figure) / 10) | |
| 1198 #define DIGITS_19(figure) ONE_DIGIT_ADVANCE (figure); DIGITS_18 ((figure) / 10) | |
| 1199 | |
| 1200 /* Print NUMBER to BUFFER in base 10. This is completely equivalent | |
| 1201 to `sprintf(buffer, "%ld", number)', only much faster. | |
| 1202 | |
| 1203 The speedup may make a difference in programs that frequently | |
| 1204 convert numbers to strings. Some implementations of sprintf, | |
| 1205 particularly the one in GNU libc, have been known to be extremely | |
| 1206 slow compared to this function. | |
| 1207 | |
| 1208 BUFFER should accept as many bytes as you expect the number to take | |
| 1209 up. On machines with 64-bit longs the maximum needed size is 24 | |
| 1210 bytes. That includes the worst-case digits, the optional `-' sign, | |
| 1211 and the trailing \0. */ | |
| 1212 | |
| 1213 void | |
| 428 | 1214 long_to_string (char *buffer, long number) |
| 1215 { | |
| 577 | 1216 char *p = buffer; |
| 1217 long n = number; | |
| 1218 | |
| 428 | 1219 #if (SIZEOF_LONG != 4) && (SIZEOF_LONG != 8) |
| 577 | 1220 /* We are running in a strange or misconfigured environment. Let |
| 1221 sprintf cope with it. */ | |
| 1222 sprintf (buffer, "%ld", n); | |
| 1223 #else /* (SIZEOF_LONG == 4) || (SIZEOF_LONG == 8) */ | |
| 428 | 1224 |
| 577 | 1225 if (n < 0) |
| 428 | 1226 { |
| 1227 *p++ = '-'; | |
| 577 | 1228 n = -n; |
| 428 | 1229 } |
| 1230 | |
| 577 | 1231 if (n < 10) { DIGITS_1 (1); } |
| 1232 else if (n < 100) { DIGITS_2 (10); } | |
| 1233 else if (n < 1000) { DIGITS_3 (100); } | |
| 1234 else if (n < 10000) { DIGITS_4 (1000); } | |
| 1235 else if (n < 100000) { DIGITS_5 (10000); } | |
| 1236 else if (n < 1000000) { DIGITS_6 (100000); } | |
| 1237 else if (n < 10000000) { DIGITS_7 (1000000); } | |
| 1238 else if (n < 100000000) { DIGITS_8 (10000000); } | |
| 1239 else if (n < 1000000000) { DIGITS_9 (100000000); } | |
| 1240 #if SIZEOF_LONG == 4 | |
| 1241 /* ``if (1)'' serves only to preserve editor indentation. */ | |
| 1242 else if (1) { DIGITS_10 (1000000000); } | |
| 1243 #else /* SIZEOF_LONG != 4 */ | |
| 1244 else if (n < 10000000000L) { DIGITS_10 (1000000000L); } | |
| 1245 else if (n < 100000000000L) { DIGITS_11 (10000000000L); } | |
| 1246 else if (n < 1000000000000L) { DIGITS_12 (100000000000L); } | |
| 1247 else if (n < 10000000000000L) { DIGITS_13 (1000000000000L); } | |
| 1248 else if (n < 100000000000000L) { DIGITS_14 (10000000000000L); } | |
| 1249 else if (n < 1000000000000000L) { DIGITS_15 (100000000000000L); } | |
| 1250 else if (n < 10000000000000000L) { DIGITS_16 (1000000000000000L); } | |
| 1251 else if (n < 100000000000000000L) { DIGITS_17 (10000000000000000L); } | |
| 1252 else if (n < 1000000000000000000L) { DIGITS_18 (100000000000000000L); } | |
| 1253 else { DIGITS_19 (1000000000000000000L); } | |
| 1254 #endif /* SIZEOF_LONG != 4 */ | |
| 1255 | |
| 428 | 1256 *p = '\0'; |
| 1257 #endif /* (SIZEOF_LONG == 4) || (SIZEOF_LONG == 8) */ | |
| 1258 } | |
| 577 | 1259 |
| 1260 #undef ONE_DIGIT | |
| 1261 #undef ONE_DIGIT_ADVANCE | |
| 1262 | |
| 1263 #undef DIGITS_1 | |
| 1264 #undef DIGITS_2 | |
| 1265 #undef DIGITS_3 | |
| 1266 #undef DIGITS_4 | |
| 1267 #undef DIGITS_5 | |
| 1268 #undef DIGITS_6 | |
| 1269 #undef DIGITS_7 | |
| 1270 #undef DIGITS_8 | |
| 1271 #undef DIGITS_9 | |
| 1272 #undef DIGITS_10 | |
| 1273 #undef DIGITS_11 | |
| 1274 #undef DIGITS_12 | |
| 1275 #undef DIGITS_13 | |
| 1276 #undef DIGITS_14 | |
| 1277 #undef DIGITS_15 | |
| 1278 #undef DIGITS_16 | |
| 1279 #undef DIGITS_17 | |
| 1280 #undef DIGITS_18 | |
| 1281 #undef DIGITS_19 | |
| 428 | 1282 |
|
4329
d9eb5ea14f65
Provide %b in #'format; use it for converting between ints and bit vectors.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3263
diff
changeset
|
1283 void |
|
d9eb5ea14f65
Provide %b in #'format; use it for converting between ints and bit vectors.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3263
diff
changeset
|
1284 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
|
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 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
|
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 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
|
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 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
|
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 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
|
1293 *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
|
1294 } |
|
d9eb5ea14f65
Provide %b in #'format; use it for converting between ints and bit vectors.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3263
diff
changeset
|
1295 else |
|
d9eb5ea14f65
Provide %b in #'format; use it for converting between ints and bit vectors.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3263
diff
changeset
|
1296 { |
|
d9eb5ea14f65
Provide %b in #'format; use it for converting between ints and bit vectors.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3263
diff
changeset
|
1297 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
|
1298 { |
|
d9eb5ea14f65
Provide %b in #'format; use it for converting between ints and bit vectors.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3263
diff
changeset
|
1299 *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
|
1300 } |
|
d9eb5ea14f65
Provide %b in #'format; use it for converting between ints and bit vectors.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3263
diff
changeset
|
1301 } |
|
d9eb5ea14f65
Provide %b in #'format; use it for converting between ints and bit vectors.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3263
diff
changeset
|
1302 } |
|
d9eb5ea14f65
Provide %b in #'format; use it for converting between ints and bit vectors.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3263
diff
changeset
|
1303 *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
|
1304 } |
|
d9eb5ea14f65
Provide %b in #'format; use it for converting between ints and bit vectors.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3263
diff
changeset
|
1305 |
| 428 | 1306 static void |
| 442 | 1307 print_vector_internal (const char *start, const char *end, |
| 428 | 1308 Lisp_Object obj, |
| 1309 Lisp_Object printcharfun, int escapeflag) | |
| 1310 { | |
| 1311 /* This function can GC */ | |
| 1312 int i; | |
| 1313 int len = XVECTOR_LENGTH (obj); | |
| 1314 int last = len; | |
| 1315 struct gcpro gcpro1, gcpro2; | |
| 1316 GCPRO2 (obj, printcharfun); | |
| 1317 | |
| 1318 if (INTP (Vprint_length)) | |
| 1319 { | |
| 1320 int max = XINT (Vprint_length); | |
| 1321 if (max < len) last = max; | |
| 1322 } | |
| 1323 | |
| 826 | 1324 write_c_string (printcharfun, start); |
| 428 | 1325 for (i = 0; i < last; i++) |
| 1326 { | |
| 1327 Lisp_Object elt = XVECTOR_DATA (obj)[i]; | |
| 826 | 1328 if (i != 0) write_c_string (printcharfun, " "); |
| 428 | 1329 print_internal (elt, printcharfun, escapeflag); |
| 1330 } | |
| 1331 UNGCPRO; | |
| 1332 if (last != len) | |
| 826 | 1333 write_c_string (printcharfun, " ..."); |
| 1334 write_c_string (printcharfun, end); | |
| 428 | 1335 } |
| 1336 | |
| 1337 void | |
| 1338 print_cons (Lisp_Object obj, Lisp_Object printcharfun, int escapeflag) | |
| 1339 { | |
| 1340 /* This function can GC */ | |
| 1341 struct gcpro gcpro1, gcpro2; | |
| 1342 | |
| 1343 /* If print_readably is on, print (quote -foo-) as '-foo- | |
| 1344 (Yeah, this should really be what print-pretty does, but we | |
| 1345 don't have the rest of a pretty printer, and this actually | |
| 1346 has non-negligible impact on size/speed of .elc files.) | |
| 1347 */ | |
| 1348 if (print_readably && | |
| 1349 EQ (XCAR (obj), Qquote) && | |
| 1350 CONSP (XCDR (obj)) && | |
| 1351 NILP (XCDR (XCDR (obj)))) | |
| 1352 { | |
| 1353 obj = XCAR (XCDR (obj)); | |
| 1354 GCPRO2 (obj, printcharfun); | |
| 826 | 1355 write_c_string (printcharfun, "\'"); |
| 428 | 1356 UNGCPRO; |
| 1357 print_internal (obj, printcharfun, escapeflag); | |
| 1358 return; | |
| 1359 } | |
| 1360 | |
| 1361 GCPRO2 (obj, printcharfun); | |
| 826 | 1362 write_c_string (printcharfun, "("); |
| 428 | 1363 |
| 1364 { | |
| 1365 int len; | |
| 1366 int max = INTP (Vprint_length) ? XINT (Vprint_length) : INT_MAX; | |
| 1367 Lisp_Object tortoise; | |
| 1368 /* Use tortoise/hare to make sure circular lists don't infloop */ | |
| 1369 | |
| 1370 for (tortoise = obj, len = 0; | |
| 1371 CONSP (obj); | |
| 1372 obj = XCDR (obj), len++) | |
| 1373 { | |
| 1374 if (len > 0) | |
| 826 | 1375 write_c_string (printcharfun, " "); |
| 428 | 1376 if (EQ (obj, tortoise) && len > 0) |
| 1377 { | |
| 1378 if (print_readably) | |
| 563 | 1379 printing_unreadable_object ("circular list"); |
| 428 | 1380 else |
| 826 | 1381 write_c_string (printcharfun, "... <circular list>"); |
| 428 | 1382 break; |
| 1383 } | |
| 1384 if (len & 1) | |
| 1385 tortoise = XCDR (tortoise); | |
| 1386 if (len > max) | |
| 1387 { | |
| 826 | 1388 write_c_string (printcharfun, "..."); |
| 428 | 1389 break; |
| 1390 } | |
| 1391 print_internal (XCAR (obj), printcharfun, escapeflag); | |
| 1392 } | |
| 1393 } | |
| 1394 if (!LISTP (obj)) | |
| 1395 { | |
| 826 | 1396 write_c_string (printcharfun, " . "); |
| 428 | 1397 print_internal (obj, printcharfun, escapeflag); |
| 1398 } | |
| 1399 UNGCPRO; | |
| 1400 | |
| 826 | 1401 write_c_string (printcharfun, ")"); |
| 428 | 1402 return; |
| 1403 } | |
| 1404 | |
| 1405 void | |
| 1406 print_vector (Lisp_Object obj, Lisp_Object printcharfun, int escapeflag) | |
| 1407 { | |
| 1408 print_vector_internal ("[", "]", obj, printcharfun, escapeflag); | |
| 1409 } | |
| 1410 | |
| 1411 void | |
| 1412 print_string (Lisp_Object obj, Lisp_Object printcharfun, int escapeflag) | |
| 1413 { | |
| 1414 /* We distinguish between Bytecounts and Charcounts, to make | |
| 1415 Vprint_string_length work correctly under Mule. */ | |
| 826 | 1416 Charcount size = string_char_length (obj); |
| 428 | 1417 Charcount max = size; |
| 793 | 1418 Bytecount bcmax = XSTRING_LENGTH (obj); |
| 428 | 1419 struct gcpro gcpro1, gcpro2; |
| 1420 GCPRO2 (obj, printcharfun); | |
| 1421 | |
| 1422 if (INTP (Vprint_string_length) && | |
| 1423 XINT (Vprint_string_length) < max) | |
| 1424 { | |
| 1425 max = XINT (Vprint_string_length); | |
| 793 | 1426 bcmax = string_index_char_to_byte (obj, max); |
| 428 | 1427 } |
| 1428 if (max < 0) | |
| 1429 { | |
| 1430 max = 0; | |
| 1431 bcmax = 0; | |
| 1432 } | |
| 1433 | |
| 1434 if (!escapeflag) | |
| 1435 { | |
| 1436 /* This deals with GC-relocation and Mule. */ | |
| 1437 output_string (printcharfun, 0, obj, 0, bcmax); | |
| 1438 if (max < size) | |
| 826 | 1439 write_c_string (printcharfun, " ..."); |
| 428 | 1440 } |
| 1441 else | |
| 1442 { | |
| 1443 Bytecount i, last = 0; | |
| 1444 | |
| 826 | 1445 write_c_string (printcharfun, "\""); |
| 428 | 1446 for (i = 0; i < bcmax; i++) |
| 1447 { | |
| 867 | 1448 Ibyte ch = string_byte (obj, i); |
| 428 | 1449 if (ch == '\"' || ch == '\\' |
| 1450 || (ch == '\n' && print_escape_newlines)) | |
| 1451 { | |
| 1452 if (i > last) | |
| 1453 { | |
| 1454 output_string (printcharfun, 0, obj, last, | |
| 1455 i - last); | |
| 1456 } | |
| 1457 if (ch == '\n') | |
| 1458 { | |
| 826 | 1459 write_c_string (printcharfun, "\\n"); |
| 428 | 1460 } |
| 1461 else | |
| 1462 { | |
| 867 | 1463 Ibyte temp[2]; |
| 826 | 1464 write_c_string (printcharfun, "\\"); |
| 428 | 1465 /* This is correct for Mule because the |
| 1466 character is either \ or " */ | |
| 826 | 1467 temp[0] = string_byte (obj, i); |
| 1468 temp[1] = '\0'; | |
| 1469 write_string (printcharfun, temp); | |
| 428 | 1470 } |
| 1471 last = i + 1; | |
| 1472 } | |
| 1473 } | |
| 1474 if (bcmax > last) | |
| 1475 { | |
| 1476 output_string (printcharfun, 0, obj, last, | |
| 1477 bcmax - last); | |
| 1478 } | |
| 1479 if (max < size) | |
| 826 | 1480 write_c_string (printcharfun, " ..."); |
| 1481 write_c_string (printcharfun, "\""); | |
| 428 | 1482 } |
| 1483 UNGCPRO; | |
| 1484 } | |
| 1485 | |
| 3085 | 1486 void |
| 428 | 1487 default_object_printer (Lisp_Object obj, Lisp_Object printcharfun, |
| 2286 | 1488 int UNUSED (escapeflag)) |
| 428 | 1489 { |
| 3017 | 1490 struct LCRECORD_HEADER *header = (struct LCRECORD_HEADER *) XPNTR (obj); |
| 428 | 1491 |
| 1492 if (print_readably) | |
| 563 | 1493 printing_unreadable_object |
| 1494 ("#<%s 0x%x>", | |
| 3263 | 1495 #ifdef NEW_GC |
| 2720 | 1496 LHEADER_IMPLEMENTATION (header)->name, |
| 3263 | 1497 #else /* not NEW_GC */ |
| 563 | 1498 LHEADER_IMPLEMENTATION (&header->lheader)->name, |
| 3263 | 1499 #endif /* not NEW_GC */ |
| 563 | 1500 header->uid); |
| 428 | 1501 |
| 800 | 1502 write_fmt_string (printcharfun, "#<%s 0x%x>", |
| 3263 | 1503 #ifdef NEW_GC |
| 2720 | 1504 LHEADER_IMPLEMENTATION (header)->name, |
| 3263 | 1505 #else /* not NEW_GC */ |
| 800 | 1506 LHEADER_IMPLEMENTATION (&header->lheader)->name, |
| 3263 | 1507 #endif /* not NEW_GC */ |
| 800 | 1508 header->uid); |
| 428 | 1509 } |
| 1510 | |
| 1511 void | |
| 1512 internal_object_printer (Lisp_Object obj, Lisp_Object printcharfun, | |
| 2286 | 1513 int UNUSED (escapeflag)) |
| 428 | 1514 { |
| 800 | 1515 write_fmt_string (printcharfun, |
| 1516 "#<INTERNAL OBJECT (XEmacs bug?) (%s) 0x%lx>", | |
| 1517 XRECORD_LHEADER_IMPLEMENTATION (obj)->name, | |
| 1518 (unsigned long) XPNTR (obj)); | |
| 428 | 1519 } |
| 1520 | |
| 1204 | 1521 enum printing_badness |
| 1522 { | |
| 1523 BADNESS_INTEGER_OBJECT, | |
| 1524 BADNESS_POINTER_OBJECT, | |
| 1525 BADNESS_NO_TYPE | |
| 1526 }; | |
| 1527 | |
| 1528 static void | |
| 1529 printing_major_badness (Lisp_Object printcharfun, | |
|
4528
726060ee587c
First draft of g++ 4.3 warning removal patch. Builds. *Needs ChangeLogs.*
Stephen J. Turnbull <stephen@xemacs.org>
parents:
4522
diff
changeset
|
1530 const Ascbyte *badness_string, int type, void *val, |
| 1204 | 1531 enum printing_badness badness) |
| 1532 { | |
| 1533 Ibyte buf[666]; | |
| 1534 | |
| 1535 switch (badness) | |
| 1536 { | |
| 1537 case BADNESS_INTEGER_OBJECT: | |
| 1538 qxesprintf (buf, "%s %d object %ld", badness_string, type, | |
| 1539 (EMACS_INT) val); | |
| 1540 break; | |
| 1541 | |
| 1542 case BADNESS_POINTER_OBJECT: | |
| 1543 qxesprintf (buf, "%s %d object %p", badness_string, type, val); | |
| 1544 break; | |
| 1545 | |
| 1546 case BADNESS_NO_TYPE: | |
| 1547 qxesprintf (buf, "%s object %p", badness_string, val); | |
| 1548 break; | |
| 1549 } | |
| 1550 | |
| 1551 /* Don't abort or signal if called from debug_print() or already | |
| 1552 crashing */ | |
| 2367 | 1553 if (!inhibit_non_essential_conversion_operations) |
| 1204 | 1554 { |
| 1555 #ifdef ERROR_CHECK_TYPES | |
| 2500 | 1556 ABORT (); |
| 1204 | 1557 #else /* not ERROR_CHECK_TYPES */ |
| 1558 if (print_readably) | |
| 1559 signal_ferror (Qinternal_error, "printing %s", buf); | |
| 1560 #endif /* not ERROR_CHECK_TYPES */ | |
| 1561 } | |
| 1562 write_fmt_string (printcharfun, | |
| 1563 "#<EMACS BUG: %s Save your buffers immediately and " | |
| 1564 "please report this bug>", buf); | |
| 1565 } | |
| 1566 | |
| 428 | 1567 void |
| 1568 print_internal (Lisp_Object obj, Lisp_Object printcharfun, int escapeflag) | |
| 1569 { | |
| 1570 /* This function can GC */ | |
| 2001 | 1571 int specdepth = 0; |
| 1204 | 1572 struct gcpro gcpro1, gcpro2; |
| 428 | 1573 |
| 1574 QUIT; | |
| 1575 | |
| 771 | 1576 #ifdef NO_PRINT_DURING_GC |
| 428 | 1577 /* Emacs won't print while GCing, but an external debugger might */ |
| 1578 if (gc_in_progress) return; | |
| 771 | 1579 #endif |
| 1580 | |
| 1204 | 1581 /* Just to be safe ... */ |
| 1582 GCPRO2 (obj, printcharfun); | |
| 428 | 1583 |
| 1584 #ifdef I18N3 | |
| 1585 /* #### Both input and output streams should have a flag associated | |
| 1586 with them indicating whether output to that stream, or strings | |
| 1587 read from the stream, get translated using Fgettext(). Such a | |
| 1588 stream is called a "translating stream". For the minibuffer and | |
| 1589 external-debugging-output this is always true on output, and | |
| 1590 with-output-to-temp-buffer sets the flag to true for the buffer | |
| 1591 it creates. This flag should also be user-settable. Perhaps it | |
| 1592 should be split up into two flags, one for input and one for | |
| 1593 output. */ | |
| 1594 #endif | |
| 1595 | |
| 1596 /* Detect circularities and truncate them. | |
| 1597 No need to offer any alternative--this is better than an error. */ | |
| 1598 if (CONSP (obj) || VECTORP (obj) || COMPILED_FUNCTIONP (obj)) | |
| 1599 { | |
| 1600 int i; | |
| 1601 for (i = 0; i < print_depth; i++) | |
| 1602 if (EQ (obj, being_printed[i])) | |
| 1603 { | |
| 603 | 1604 char buf[DECIMAL_PRINT_SIZE (long) + 1]; |
| 428 | 1605 *buf = '#'; |
| 1606 long_to_string (buf + 1, i); | |
| 826 | 1607 write_c_string (printcharfun, buf); |
| 1204 | 1608 UNGCPRO; |
| 428 | 1609 return; |
| 1610 } | |
| 1611 } | |
| 1612 | |
| 1613 being_printed[print_depth] = obj; | |
| 1614 | |
| 1957 | 1615 /* Avoid calling internal_bind_int, which conses, when called from |
| 1616 debug_prin1. In that case, we have bound print_depth to 0 anyway. */ | |
| 2367 | 1617 if (!inhibit_non_essential_conversion_operations) |
| 1957 | 1618 { |
| 1619 specdepth = internal_bind_int (&print_depth, print_depth + 1); | |
| 1620 | |
| 1621 if (print_depth > PRINT_CIRCLE) | |
| 1622 signal_error (Qstack_overflow, "Apparently circular structure being printed", Qunbound); | |
| 1623 } | |
| 428 | 1624 |
| 1625 switch (XTYPE (obj)) | |
| 1626 { | |
| 1627 case Lisp_Type_Int_Even: | |
| 1628 case Lisp_Type_Int_Odd: | |
| 1629 { | |
| 603 | 1630 char buf[DECIMAL_PRINT_SIZE (EMACS_INT)]; |
| 428 | 1631 long_to_string (buf, XINT (obj)); |
| 826 | 1632 write_c_string (printcharfun, buf); |
| 428 | 1633 break; |
| 1634 } | |
| 1635 | |
| 1636 case Lisp_Type_Char: | |
| 1637 { | |
| 1638 /* God intended that this be #\..., you know. */ | |
| 1639 char buf[16]; | |
| 867 | 1640 Ichar ch = XCHAR (obj); |
| 428 | 1641 char *p = buf; |
| 1642 *p++ = '?'; | |
| 434 | 1643 if (ch < 32) |
| 1644 { | |
| 1645 *p++ = '\\'; | |
| 1646 switch (ch) | |
| 1647 { | |
| 1648 case '\t': *p++ = 't'; break; | |
| 1649 case '\n': *p++ = 'n'; break; | |
| 1650 case '\r': *p++ = 'r'; break; | |
| 1651 default: | |
| 1652 *p++ = '^'; | |
| 1653 *p++ = ch + 64; | |
| 1654 if ((ch + 64) == '\\') | |
| 1655 *p++ = '\\'; | |
| 1656 break; | |
| 1657 } | |
| 1658 } | |
| 1659 else if (ch < 127) | |
| 428 | 1660 { |
| 434 | 1661 /* syntactically special characters should be escaped. */ |
| 1662 switch (ch) | |
| 1663 { | |
| 1664 case ' ': | |
| 1665 case '"': | |
| 1666 case '#': | |
| 1667 case '\'': | |
| 1668 case '(': | |
| 1669 case ')': | |
| 1670 case ',': | |
| 1671 case '.': | |
| 1672 case ';': | |
| 1673 case '?': | |
| 1674 case '[': | |
| 1675 case '\\': | |
| 1676 case ']': | |
| 1677 case '`': | |
| 1678 *p++ = '\\'; | |
| 1679 } | |
| 1680 *p++ = ch; | |
| 428 | 1681 } |
| 1682 else if (ch == 127) | |
| 434 | 1683 { |
| 1684 *p++ = '\\', *p++ = '^', *p++ = '?'; | |
| 1685 } | |
| 1686 else if (ch < 160) | |
| 428 | 1687 { |
| 1688 *p++ = '\\', *p++ = '^'; | |
| 867 | 1689 p += set_itext_ichar ((Ibyte *) p, ch + 64); |
| 428 | 1690 } |
| 1691 else | |
| 434 | 1692 { |
| 867 | 1693 p += set_itext_ichar ((Ibyte *) p, ch); |
| 434 | 1694 } |
| 440 | 1695 |
| 867 | 1696 output_string (printcharfun, (Ibyte *) buf, Qnil, 0, p - buf); |
| 434 | 1697 |
| 428 | 1698 break; |
| 1699 } | |
| 1700 | |
| 1701 case Lisp_Type_Record: | |
| 1702 { | |
| 1703 struct lrecord_header *lheader = XRECORD_LHEADER (obj); | |
| 1204 | 1704 |
| 1705 /* Try to check for various sorts of bogus pointers if we're in a | |
| 1706 situation where it may be likely -- i.e. called from | |
| 1707 debug_print() or we're already crashing. In such cases, | |
| 1708 (further) crashing is counterproductive. */ | |
| 428 | 1709 |
| 2367 | 1710 if (inhibit_non_essential_conversion_operations && |
| 1204 | 1711 !debug_can_access_memory (lheader, sizeof (*lheader))) |
| 1712 { | |
| 1713 write_fmt_string (printcharfun, "#<EMACS BUG: BAD MEMORY %p>", | |
| 1714 lheader); | |
| 1715 break; | |
| 1716 } | |
| 1717 | |
| 1718 if (CONSP (obj) || VECTORP (obj)) | |
| 428 | 1719 { |
| 1720 /* If deeper than spec'd depth, print placeholder. */ | |
| 1721 if (INTP (Vprint_level) | |
| 1722 && print_depth > XINT (Vprint_level)) | |
| 1723 { | |
| 826 | 1724 write_c_string (printcharfun, "..."); |
| 428 | 1725 break; |
| 1726 } | |
| 1727 } | |
| 1728 | |
| 3263 | 1729 #ifndef NEW_GC |
| 1204 | 1730 if (lheader->type == lrecord_type_free) |
| 1731 { | |
| 1732 printing_major_badness (printcharfun, "freed lrecord", 0, | |
| 1733 lheader, BADNESS_NO_TYPE); | |
| 1734 break; | |
| 1735 } | |
| 1736 else if (lheader->type == lrecord_type_undefined) | |
| 1737 { | |
| 1738 printing_major_badness (printcharfun, "lrecord_type_undefined", 0, | |
| 1739 lheader, BADNESS_NO_TYPE); | |
| 1740 break; | |
| 1741 } | |
| 3263 | 1742 #endif /* not NEW_GC */ |
| 1204 | 1743 else if ((int) (lheader->type) >= lrecord_type_count) |
| 1744 { | |
| 1745 printing_major_badness (printcharfun, "illegal lrecord type", | |
| 1746 (int) (lheader->type), | |
| 1747 lheader, BADNESS_POINTER_OBJECT); | |
| 1748 break; | |
| 1749 } | |
| 1750 | |
| 1751 /* Further checks for bad memory in critical situations. We don't | |
| 1752 normally do these because they may be expensive or weird | |
| 1753 (e.g. under Unix we typically have to set a SIGSEGV handler and | |
| 1754 try to trigger a seg fault). */ | |
| 1755 | |
| 2367 | 1756 if (inhibit_non_essential_conversion_operations) |
| 1204 | 1757 { |
| 1758 if (!debug_can_access_memory | |
| 1759 (lheader, detagged_lisp_object_size (lheader))) | |
| 1760 { | |
| 1761 write_fmt_string (printcharfun, | |
| 1762 "#<EMACS BUG: type %s BAD MEMORY %p>", | |
| 1763 LHEADER_IMPLEMENTATION (lheader)->name, | |
| 1764 lheader); | |
| 1765 break; | |
| 1766 } | |
| 1767 | |
| 1768 if (STRINGP (obj)) | |
| 1769 { | |
| 3092 | 1770 #ifdef NEW_GC |
| 1771 if (!debug_can_access_memory (XSTRING_DATA (obj), | |
| 1772 XSTRING_LENGTH (obj))) | |
| 1773 { | |
| 1774 write_fmt_string | |
| 1775 (printcharfun, | |
| 1776 "#<EMACS BUG: %p (BAD STRING DATA %p)>", | |
| 1777 lheader, XSTRING_DATA (obj)); | |
| 1778 break; | |
| 1779 } | |
| 1780 #else /* not NEW_GC */ | |
| 1204 | 1781 Lisp_String *l = (Lisp_String *) lheader; |
| 1782 if (!debug_can_access_memory (l->data_, l->size_)) | |
| 1783 { | |
| 1784 write_fmt_string | |
| 1785 (printcharfun, | |
| 1786 "#<EMACS BUG: %p (BAD STRING DATA %p)>", | |
| 1787 lheader, l->data_); | |
| 1788 break; | |
| 1789 } | |
| 3092 | 1790 #endif /* not NEW_GC */ |
| 1204 | 1791 } |
| 1792 } | |
| 1793 | |
| 428 | 1794 if (LHEADER_IMPLEMENTATION (lheader)->printer) |
| 1795 ((LHEADER_IMPLEMENTATION (lheader)->printer) | |
| 1796 (obj, printcharfun, escapeflag)); | |
| 1797 else | |
| 3085 | 1798 internal_object_printer (obj, printcharfun, escapeflag); |
| 428 | 1799 break; |
| 1800 } | |
| 1801 | |
| 1802 default: | |
| 1803 { | |
| 1804 /* We're in trouble if this happens! */ | |
| 1204 | 1805 printing_major_badness (printcharfun, "illegal data type", XTYPE (obj), |
| 1806 LISP_TO_VOID (obj), BADNESS_INTEGER_OBJECT); | |
| 428 | 1807 break; |
| 1808 } | |
| 1809 } | |
| 1810 | |
| 2367 | 1811 if (!inhibit_non_essential_conversion_operations) |
| 1957 | 1812 unbind_to (specdepth); |
| 1204 | 1813 UNGCPRO; |
| 428 | 1814 } |
| 1815 | |
| 1816 void | |
| 2286 | 1817 print_float (Lisp_Object obj, Lisp_Object printcharfun, |
| 1818 int UNUSED (escapeflag)) | |
| 428 | 1819 { |
| 1820 char pigbuf[350]; /* see comments in float_to_string */ | |
| 1821 | |
| 1822 float_to_string (pigbuf, XFLOAT_DATA (obj)); | |
| 826 | 1823 write_c_string (printcharfun, pigbuf); |
| 428 | 1824 } |
| 1825 | |
| 1826 void | |
| 1827 print_symbol (Lisp_Object obj, Lisp_Object printcharfun, int escapeflag) | |
| 1828 { | |
| 1829 /* This function can GC */ | |
| 1830 /* #### Bug!! (intern "") isn't printed in some distinguished way */ | |
| 1831 /* #### (the reader also loses on it) */ | |
| 793 | 1832 Lisp_Object name = symbol_name (XSYMBOL (obj)); |
| 1833 Bytecount size = XSTRING_LENGTH (name); | |
| 428 | 1834 struct gcpro gcpro1, gcpro2; |
| 1835 | |
| 1836 if (!escapeflag) | |
| 1837 { | |
| 1838 /* This deals with GC-relocation */ | |
| 793 | 1839 output_string (printcharfun, 0, name, 0, size); |
| 428 | 1840 return; |
| 1841 } | |
| 1842 GCPRO2 (obj, printcharfun); | |
| 1843 | |
| 1844 /* If we print an uninterned symbol as part of a complex object and | |
| 1845 the flag print-gensym is non-nil, prefix it with #n= to read the | |
| 1846 object back with the #n# reader syntax later if needed. */ | |
| 1847 if (!NILP (Vprint_gensym) | |
| 442 | 1848 /* #### Test whether this produces a noticeable slow-down for |
| 428 | 1849 printing when print-gensym is non-nil. */ |
| 1850 && !EQ (obj, oblookup (Vobarray, | |
| 793 | 1851 XSTRING_DATA (symbol_name (XSYMBOL (obj))), |
| 1852 XSTRING_LENGTH (symbol_name (XSYMBOL (obj)))))) | |
| 428 | 1853 { |
| 1854 if (print_depth > 1) | |
| 1855 { | |
| 1856 Lisp_Object tem = Fassq (obj, Vprint_gensym_alist); | |
| 1857 if (CONSP (tem)) | |
| 1858 { | |
| 826 | 1859 write_c_string (printcharfun, "#"); |
| 428 | 1860 print_internal (XCDR (tem), printcharfun, escapeflag); |
| 826 | 1861 write_c_string (printcharfun, "#"); |
| 446 | 1862 UNGCPRO; |
| 428 | 1863 return; |
| 1864 } | |
| 1865 else | |
| 1866 { | |
| 1867 if (CONSP (Vprint_gensym_alist)) | |
| 1868 { | |
| 1869 /* Vprint_gensym_alist is exposed to Lisp, so we | |
| 1870 have to be careful. */ | |
| 1871 CHECK_CONS (XCAR (Vprint_gensym_alist)); | |
| 1872 CHECK_INT (XCDR (XCAR (Vprint_gensym_alist))); | |
| 793 | 1873 tem = make_int (XINT (XCDR (XCAR (Vprint_gensym_alist))) + 1); |
| 428 | 1874 } |
| 1875 else | |
| 793 | 1876 tem = make_int (1); |
| 428 | 1877 Vprint_gensym_alist = Fcons (Fcons (obj, tem), Vprint_gensym_alist); |
| 1878 | |
| 826 | 1879 write_c_string (printcharfun, "#"); |
| 428 | 1880 print_internal (tem, printcharfun, escapeflag); |
| 826 | 1881 write_c_string (printcharfun, "="); |
| 428 | 1882 } |
| 1883 } | |
| 826 | 1884 write_c_string (printcharfun, "#:"); |
| 428 | 1885 } |
| 1886 | |
| 1887 /* Does it look like an integer or a float? */ | |
| 1888 { | |
| 867 | 1889 Ibyte *data = XSTRING_DATA (name); |
| 428 | 1890 Bytecount confusing = 0; |
| 1891 | |
| 1892 if (size == 0) | |
| 1893 goto not_yet_confused; /* Really confusing */ | |
| 1894 else if (isdigit (data[0])) | |
| 1895 confusing = 0; | |
| 1896 else if (size == 1) | |
| 1897 goto not_yet_confused; | |
| 1898 else if (data[0] == '-' || data[0] == '+') | |
| 1899 confusing = 1; | |
| 1900 else | |
| 1901 goto not_yet_confused; | |
| 1902 | |
| 1903 for (; confusing < size; confusing++) | |
| 1904 { | |
| 1905 if (!isdigit (data[confusing])) | |
| 1906 { | |
| 1907 confusing = 0; | |
| 1908 break; | |
| 1909 } | |
| 1910 } | |
| 1911 not_yet_confused: | |
| 1912 | |
| 1913 if (!confusing) | |
| 1914 /* #### Ugh, this is needlessly complex and slow for what we | |
| 1915 need here. It might be a good idea to copy equivalent code | |
| 1916 from FSF. --hniksic */ | |
| 1917 confusing = isfloat_string ((char *) data); | |
| 1918 if (confusing) | |
| 826 | 1919 write_c_string (printcharfun, "\\"); |
| 428 | 1920 } |
| 1921 | |
| 1922 { | |
| 1923 Bytecount i; | |
| 1924 Bytecount last = 0; | |
| 1925 | |
| 1926 for (i = 0; i < size; i++) | |
| 1927 { | |
| 826 | 1928 switch (string_byte (name, i)) |
| 428 | 1929 { |
| 1930 case 0: case 1: case 2: case 3: | |
| 1931 case 4: case 5: case 6: case 7: | |
| 1932 case 8: case 9: case 10: case 11: | |
| 1933 case 12: case 13: case 14: case 15: | |
| 1934 case 16: case 17: case 18: case 19: | |
| 1935 case 20: case 21: case 22: case 23: | |
| 1936 case 24: case 25: case 26: case 27: | |
| 1937 case 28: case 29: case 30: case 31: | |
| 1938 case ' ': case '\"': case '\\': case '\'': | |
| 1939 case ';': case '#' : case '(' : case ')': | |
| 1940 case ',': case '.' : case '`' : | |
| 1941 case '[': case ']' : case '?' : | |
| 1942 if (i > last) | |
| 793 | 1943 output_string (printcharfun, 0, name, last, i - last); |
| 826 | 1944 write_c_string (printcharfun, "\\"); |
| 428 | 1945 last = i; |
| 1946 } | |
| 1947 } | |
| 793 | 1948 output_string (printcharfun, 0, name, last, size - last); |
| 428 | 1949 } |
| 1950 UNGCPRO; | |
| 1951 } | |
| 1952 | |
| 1953 | |
| 442 | 1954 /* Useful on systems or in places where writing to stdout is unavailable or |
| 1955 not working. */ | |
| 428 | 1956 |
| 1957 static int alternate_do_pointer; | |
| 1957 | 1958 static int alternate_do_size; |
| 1959 static char *alternate_do_string; | |
| 428 | 1960 |
| 1961 DEFUN ("alternate-debugging-output", Falternate_debugging_output, 1, 1, 0, /* | |
| 1962 Append CHARACTER to the array `alternate_do_string'. | |
| 1963 This can be used in place of `external-debugging-output' as a function | |
| 1964 to be passed to `print'. Before calling `print', set `alternate_do_pointer' | |
| 1965 to 0. | |
| 1966 */ | |
| 1967 (character)) | |
| 1968 { | |
| 867 | 1969 Ibyte str[MAX_ICHAR_LEN]; |
| 428 | 1970 Bytecount len; |
| 1971 | |
| 1972 CHECK_CHAR_COERCE_INT (character); | |
| 867 | 1973 len = set_itext_ichar (str, XCHAR (character)); |
| 771 | 1974 write_string_to_alternate_debugging_output (str, len); |
| 1975 | |
| 1976 return character; | |
| 1977 } | |
| 1978 | |
| 1979 static void | |
| 1346 | 1980 write_string_to_alternate_debugging_output (const Ibyte *str, Bytecount len) |
| 771 | 1981 { |
| 1982 int extlen; | |
| 1983 const Extbyte *extptr; | |
| 1984 #if 0 /* We want to see the internal representation, don't we? */ | |
| 2367 | 1985 if (initialized && !inhibit_non_essential_conversion_operations) |
| 771 | 1986 TO_EXTERNAL_FORMAT (DATA, (str, len), |
| 1987 ALLOCA, (extptr, extlen), | |
| 1988 Qterminal); | |
| 1989 else | |
| 1990 #endif /* 0 */ | |
| 1991 { | |
| 1992 extlen = len; | |
| 1993 extptr = (Extbyte *) str; | |
| 1994 } | |
| 1957 | 1995 |
| 1996 /* If not yet initialized, just skip it. */ | |
| 1997 if (alternate_do_string == NULL) | |
| 1998 return; | |
| 1999 | |
| 2000 if (alternate_do_pointer + extlen >= alternate_do_size) | |
| 2001 { | |
| 2002 alternate_do_size = | |
| 2003 max(alternate_do_size * 2, alternate_do_pointer + extlen + 1); | |
| 2004 XREALLOC_ARRAY (alternate_do_string, char, alternate_do_size); | |
| 2005 } | |
| 428 | 2006 memcpy (alternate_do_string + alternate_do_pointer, extptr, extlen); |
| 2007 alternate_do_pointer += extlen; | |
| 2008 alternate_do_string[alternate_do_pointer] = 0; | |
| 2009 } | |
| 2010 | |
| 1346 | 2011 |
| 2012 DEFUN ("set-device-clear-left-side", Fset_device_clear_left_side, 2, 2, 0, /* | |
| 2013 Set whether to output a newline before the next output to a stream device. | |
| 2014 This will happen only if the most recently-outputted character was not | |
| 2015 a newline -- i.e. it will make sure the left side is "clear" of text. | |
| 2016 */ | |
| 2017 (device, value)) | |
| 2018 { | |
| 2019 if (!NILP (device)) | |
| 2020 CHECK_LIVE_DEVICE (device); | |
| 2021 if (NILP (device) || DEVICE_STREAM_P (XDEVICE (device))) | |
| 2022 /* #### This should be per-device */ | |
| 2023 stdout_clear_before_next_output = !NILP (value); | |
| 2024 return Qnil; | |
| 2025 } | |
| 2026 | |
| 2027 DEFUN ("device-left-side-clear-p", Fdevice_left_side_clear_p, 0, 1, 0, /* | |
| 2028 For stream devices, true if the most recent-outputted character was a newline. | |
| 2029 */ | |
| 2030 (device)) | |
| 2031 { | |
| 2032 if (!NILP (device)) | |
| 2033 CHECK_LIVE_DEVICE (device); | |
| 2034 if (NILP (device) || DEVICE_STREAM_P (XDEVICE (device))) | |
| 2035 /* #### This should be per-device */ | |
| 2036 return stdout_needs_newline ? Qt : Qnil; | |
| 2037 return Qnil; | |
| 2038 } | |
| 2039 | |
| 428 | 2040 DEFUN ("external-debugging-output", Fexternal_debugging_output, 1, 3, 0, /* |
| 2041 Write CHAR-OR-STRING to stderr or stdout. | |
| 2042 If optional arg STDOUT-P is non-nil, write to stdout; otherwise, write | |
| 2043 to stderr. You can use this function to write directly to the terminal. | |
| 2044 This function can be used as the STREAM argument of Fprint() or the like. | |
| 2045 | |
| 442 | 2046 Under MS Windows, this writes output to the console window (which is |
| 2047 created, if necessary), unless XEmacs is being run noninteractively | |
| 2048 \(i.e. using the `-batch' argument). | |
| 2049 | |
| 428 | 2050 If you have opened a termscript file (using `open-termscript'), then |
| 2051 the output also will be logged to this file. | |
| 2052 */ | |
| 2053 (char_or_string, stdout_p, device)) | |
| 2054 { | |
| 2055 FILE *file = 0; | |
| 2056 struct console *con = 0; | |
| 2057 | |
| 2058 if (NILP (device)) | |
| 2059 { | |
| 2060 if (!NILP (stdout_p)) | |
| 2061 file = stdout; | |
| 2062 else | |
| 2063 file = stderr; | |
| 2064 } | |
| 2065 else | |
| 2066 { | |
| 2067 CHECK_LIVE_DEVICE (device); | |
| 2068 if (!DEVICE_TTY_P (XDEVICE (device)) && | |
| 2069 !DEVICE_STREAM_P (XDEVICE (device))) | |
| 563 | 2070 wtaerror ("Must be tty or stream device", device); |
| 428 | 2071 con = XCONSOLE (DEVICE_CONSOLE (XDEVICE (device))); |
| 2072 if (DEVICE_TTY_P (XDEVICE (device))) | |
| 2073 file = 0; | |
| 2074 else if (!NILP (stdout_p)) | |
| 2075 file = CONSOLE_STREAM_DATA (con)->out; | |
| 2076 else | |
| 2077 file = CONSOLE_STREAM_DATA (con)->err; | |
| 2078 } | |
| 2079 | |
| 2080 if (STRINGP (char_or_string)) | |
| 2081 write_string_to_stdio_stream (file, con, | |
| 2082 XSTRING_DATA (char_or_string), | |
| 771 | 2083 XSTRING_LENGTH (char_or_string), |
| 2084 print_unbuffered); | |
| 428 | 2085 else |
| 2086 { | |
| 867 | 2087 Ibyte str[MAX_ICHAR_LEN]; |
| 428 | 2088 Bytecount len; |
| 2089 | |
| 2090 CHECK_CHAR_COERCE_INT (char_or_string); | |
| 867 | 2091 len = set_itext_ichar (str, XCHAR (char_or_string)); |
| 771 | 2092 write_string_to_stdio_stream (file, con, str, len, print_unbuffered); |
| 428 | 2093 } |
| 2094 | |
| 2095 return char_or_string; | |
| 2096 } | |
| 2097 | |
| 2098 DEFUN ("open-termscript", Fopen_termscript, 1, 1, "FOpen termscript file: ", /* | |
| 444 | 2099 Start writing all terminal output to FILENAME as well as the terminal. |
| 2100 FILENAME = nil means just close any termscript file currently open. | |
| 428 | 2101 */ |
| 444 | 2102 (filename)) |
| 428 | 2103 { |
| 2104 /* This function can GC */ | |
| 2105 if (termscript != 0) | |
| 2106 { | |
| 771 | 2107 retry_fclose (termscript); |
| 444 | 2108 termscript = 0; |
| 2109 } | |
| 2110 | |
| 2111 if (! NILP (filename)) | |
| 2112 { | |
| 2113 filename = Fexpand_file_name (filename, Qnil); | |
| 771 | 2114 termscript = qxe_fopen (XSTRING_DATA (filename), "w"); |
| 428 | 2115 if (termscript == NULL) |
| 563 | 2116 report_file_error ("Opening termscript", filename); |
| 428 | 2117 } |
| 2118 return Qnil; | |
| 2119 } | |
| 2120 | |
| 440 | 2121 static int debug_print_length = 50; |
| 2122 static int debug_print_level = 15; | |
| 2123 static int debug_print_readably = -1; | |
| 428 | 2124 |
| 1957 | 2125 /* Restore values temporarily bound by debug_prin1. We use this approach to |
| 2126 avoid consing in debug_prin1. That is verboten, since debug_prin1 can be | |
| 2127 called by cons debugging code. */ | |
| 2128 static Lisp_Object | |
| 2286 | 2129 debug_prin1_exit (Lisp_Object UNUSED (ignored)) |
| 1957 | 2130 { |
| 2131 struct debug_bindings *bindings = | |
| 2132 (struct debug_bindings *) XOPAQUE (debug_prin1_bindings)->data; | |
| 2367 | 2133 inhibit_non_essential_conversion_operations = |
| 2134 bindings->inhibit_non_essential_conversion_operations; | |
| 1957 | 2135 print_depth = bindings->print_depth; |
| 2136 print_readably = bindings->print_readably; | |
| 2137 print_unbuffered = bindings->print_unbuffered; | |
| 2138 gc_currently_forbidden = bindings->gc_currently_forbidden; | |
| 2139 Vprint_length = bindings->Vprint_length; | |
| 2140 Vprint_level = bindings->Vprint_level; | |
| 2141 Vinhibit_quit = bindings->Vinhibit_quit; | |
| 2142 return Qnil; | |
| 2143 } | |
| 2144 | |
| 1346 | 2145 /* Print an object, `prin1'-style, to various possible debugging outputs. |
| 2146 Make sure it's completely unbuffered so that, in the event of a crash | |
| 2147 somewhere, we see as much as possible that happened before it. | |
| 2148 */ | |
| 428 | 2149 static void |
| 1346 | 2150 debug_prin1 (Lisp_Object debug_print_obj, int flags) |
| 428 | 2151 { |
| 2152 /* This function can GC */ | |
| 853 | 2153 |
| 2154 /* by doing this, we trick various things that are non-essential | |
| 2155 but might cause crashes into not getting executed. */ | |
| 1957 | 2156 int specdepth; |
| 2157 struct debug_bindings *bindings = | |
| 2158 (struct debug_bindings *) XOPAQUE (debug_prin1_bindings)->data; | |
| 853 | 2159 |
| 2367 | 2160 bindings->inhibit_non_essential_conversion_operations = |
| 2161 inhibit_non_essential_conversion_operations; | |
| 1957 | 2162 bindings->print_depth = print_depth; |
| 2163 bindings->print_readably = print_readably; | |
| 2164 bindings->print_unbuffered = print_unbuffered; | |
| 2165 bindings->gc_currently_forbidden = gc_currently_forbidden; | |
| 2166 bindings->Vprint_length = Vprint_length; | |
| 2167 bindings->Vprint_level = Vprint_level; | |
| 2168 bindings->Vinhibit_quit = Vinhibit_quit; | |
| 2169 specdepth = record_unwind_protect (debug_prin1_exit, Qnil); | |
| 2170 | |
| 2367 | 2171 inhibit_non_essential_conversion_operations = 1; |
| 1957 | 2172 print_depth = 0; |
| 2173 print_readably = debug_print_readably != -1 ? debug_print_readably : 0; | |
| 2174 print_unbuffered++; | |
| 428 | 2175 if (debug_print_length > 0) |
| 1957 | 2176 Vprint_length = make_int (debug_print_length); |
| 428 | 2177 if (debug_print_level > 0) |
| 1957 | 2178 Vprint_level = make_int (debug_print_level); |
| 2179 Vinhibit_quit = Qt; | |
| 1346 | 2180 |
| 2181 if ((flags & EXT_PRINT_STDOUT) || (flags & EXT_PRINT_STDERR)) | |
| 2182 print_internal (debug_print_obj, Qexternal_debugging_output, 1); | |
| 2183 if (flags & EXT_PRINT_ALTERNATE) | |
| 2184 print_internal (debug_print_obj, Qalternate_debugging_output, 1); | |
| 442 | 2185 #ifdef WIN32_NATIVE |
| 1346 | 2186 if (flags & EXT_PRINT_MSWINDOWS) |
| 2187 { | |
| 2188 /* Write out to the debugger, as well */ | |
| 2189 print_internal (debug_print_obj, Qmswindows_debugging_output, 1); | |
| 2190 } | |
| 442 | 2191 #endif |
| 440 | 2192 |
| 802 | 2193 unbind_to (specdepth); |
| 428 | 2194 } |
| 2195 | |
| 2196 void | |
| 1204 | 2197 debug_p4 (Lisp_Object obj) |
| 2198 { | |
| 2367 | 2199 inhibit_non_essential_conversion_operations = 1; |
| 1204 | 2200 if (STRINGP (obj)) |
| 2201 debug_out ("\"%s\"", XSTRING_DATA (obj)); | |
| 2202 else if (CONSP (obj)) | |
| 2203 { | |
| 2204 int first = 1; | |
| 2205 do { | |
| 2206 debug_out (first ? "(" : " "); | |
| 2207 first = 0; | |
| 2208 debug_p4 (XCAR (obj)); | |
| 2209 obj = XCDR (obj); | |
| 2210 } while (CONSP (obj)); | |
| 2211 if (NILP (obj)) | |
| 2212 debug_out (")"); | |
| 2213 else | |
| 2214 { | |
| 2215 debug_out (" . "); | |
| 2216 debug_p4 (obj); | |
| 2217 debug_out (")"); | |
| 2218 } | |
| 2219 } | |
| 2220 else if (VECTORP (obj)) | |
| 2221 { | |
| 2222 int size = XVECTOR_LENGTH (obj); | |
| 2223 int i; | |
| 2224 int first = 1; | |
| 2225 | |
| 2226 for (i = 0; i < size; i++) | |
| 2227 { | |
| 2228 debug_out (first ? "[" : " "); | |
| 2229 first = 0; | |
| 2230 debug_p4 (XVECTOR_DATA (obj)[i]); | |
| 2231 debug_out ("]"); | |
| 2232 } | |
| 2233 } | |
| 2234 else if (SYMBOLP (obj)) | |
| 2235 { | |
| 2236 Lisp_Object name = XSYMBOL_NAME (obj); | |
| 2237 if (!STRINGP (name)) | |
| 2238 debug_out ("<<bad symbol>>"); | |
| 2239 else | |
| 2240 debug_out ("%s", XSTRING_DATA (name)); | |
| 2241 } | |
| 2242 else if (INTP (obj)) | |
| 2243 { | |
| 2244 debug_out ("%ld", XINT (obj)); | |
| 2245 } | |
| 2246 else if (FLOATP (obj)) | |
| 2247 { | |
| 2248 debug_out ("%g", XFLOAT_DATA (obj)); | |
| 2249 } | |
| 2250 else | |
| 2251 { | |
| 2252 struct lrecord_header *header = | |
| 2253 (struct lrecord_header *) XPNTR (obj); | |
| 2254 | |
| 2255 if (header->type >= lrecord_type_last_built_in_type) | |
| 2256 debug_out ("<< bad object type=%d 0x%lx>>", header->type, | |
| 2257 (EMACS_INT) header); | |
| 2258 else | |
| 3263 | 2259 #ifdef NEW_GC |
| 3063 | 2260 debug_out ("#<%s addr=0x%lx uid=0x%lx>", |
| 2720 | 2261 LHEADER_IMPLEMENTATION (header)->name, |
| 3063 | 2262 (EMACS_INT) header, |
| 2720 | 2263 (EMACS_INT) ((struct lrecord_header *) header)->uid); |
| 3263 | 2264 #else /* not NEW_GC */ |
| 3063 | 2265 debug_out ("#<%s addr=0x%lx uid=0x%lx>", |
| 1204 | 2266 LHEADER_IMPLEMENTATION (header)->name, |
| 3063 | 2267 (EMACS_INT) header, |
| 3092 | 2268 (EMACS_INT) (LHEADER_IMPLEMENTATION (header)->basic_p ? |
| 2269 ((struct lrecord_header *) header)->uid : | |
| 2270 ((struct old_lcrecord_header *) header)->uid)); | |
| 3263 | 2271 #endif /* not NEW_GC */ |
| 1204 | 2272 } |
| 2273 | |
| 2367 | 2274 inhibit_non_essential_conversion_operations = 0; |
| 1204 | 2275 } |
| 2276 | |
| 1346 | 2277 static void |
| 2278 ext_print_begin (int dest) | |
| 2279 { | |
| 2280 if (dest & EXT_PRINT_ALTERNATE) | |
| 2281 alternate_do_pointer = 0; | |
| 2282 if (dest & (EXT_PRINT_STDERR | EXT_PRINT_STDOUT)) | |
| 2283 stdout_clear_before_next_output = 1; | |
| 2284 } | |
| 2285 | |
| 2286 static void | |
| 2287 ext_print_end (int dest) | |
| 2288 { | |
| 2289 if (dest & (EXT_PRINT_MSWINDOWS | EXT_PRINT_STDERR | EXT_PRINT_STDOUT)) | |
| 2290 external_out (dest & (EXT_PRINT_MSWINDOWS | EXT_PRINT_STDERR | | |
| 2291 EXT_PRINT_STDOUT), "\n"); | |
| 2292 } | |
| 2293 | |
| 2294 static void | |
| 2295 external_debug_print (Lisp_Object object, int dest) | |
| 2296 { | |
| 2297 ext_print_begin (dest); | |
| 2298 debug_prin1 (object, dest); | |
| 2299 ext_print_end (dest); | |
| 2300 } | |
| 2301 | |
| 1204 | 2302 void |
| 2303 debug_p3 (Lisp_Object obj) | |
| 2304 { | |
| 2305 debug_p4 (obj); | |
| 2367 | 2306 inhibit_non_essential_conversion_operations = 1; |
| 1204 | 2307 debug_out ("\n"); |
| 2367 | 2308 inhibit_non_essential_conversion_operations = 0; |
| 1204 | 2309 } |
| 2310 | |
| 2311 void | |
| 428 | 2312 debug_print (Lisp_Object debug_print_obj) |
| 2313 { | |
| 1346 | 2314 external_debug_print (debug_print_obj, EXT_PRINT_ALL); |
| 428 | 2315 } |
| 2316 | |
| 1204 | 2317 /* Getting tired of typing debug_print() ... */ |
| 2318 void dp (Lisp_Object debug_print_obj); | |
| 2319 void | |
| 2320 dp (Lisp_Object debug_print_obj) | |
| 2321 { | |
| 2322 debug_print (debug_print_obj); | |
| 2323 } | |
| 2324 | |
| 1346 | 2325 /* Alternate debug printer: Return a char * pointer to the output */ |
| 2326 char *dpa (Lisp_Object debug_print_obj); | |
| 2327 char * | |
| 2328 dpa (Lisp_Object debug_print_obj) | |
| 2329 { | |
| 2330 external_debug_print (debug_print_obj, EXT_PRINT_ALTERNATE); | |
| 2331 | |
| 2332 return alternate_do_string; | |
| 2333 } | |
| 2334 | |
| 428 | 2335 /* Debugging kludge -- unbuffered */ |
| 2336 /* This function provided for the benefit of the debugger. */ | |
| 2337 void | |
| 2338 debug_backtrace (void) | |
| 2339 { | |
| 2340 /* This function can GC */ | |
| 853 | 2341 |
| 2342 /* by doing this, we trick various things that are non-essential | |
| 2343 but might cause crashes into not getting executed. */ | |
| 2344 int specdepth = | |
| 2367 | 2345 internal_bind_int (&inhibit_non_essential_conversion_operations, 1); |
| 853 | 2346 |
| 2347 internal_bind_int (&print_depth, 0); | |
| 802 | 2348 internal_bind_int (&print_readably, 0); |
| 2349 internal_bind_int (&print_unbuffered, print_unbuffered + 1); | |
| 428 | 2350 if (debug_print_length > 0) |
| 802 | 2351 internal_bind_lisp_object (&Vprint_length, make_int (debug_print_length)); |
| 428 | 2352 if (debug_print_level > 0) |
| 802 | 2353 internal_bind_lisp_object (&Vprint_level, make_int (debug_print_level)); |
| 2354 /* #### Do we need this? It was in the old code. */ | |
| 2355 internal_bind_lisp_object (&Vinhibit_quit, Vinhibit_quit); | |
| 428 | 2356 |
| 2357 Fbacktrace (Qexternal_debugging_output, Qt); | |
| 2358 stderr_out ("\n"); | |
| 2359 | |
| 802 | 2360 unbind_to (specdepth); |
| 428 | 2361 } |
| 2362 | |
| 1204 | 2363 /* Getting tired of typing debug_backtrace() ... */ |
| 2364 void db (void); | |
| 2365 void | |
| 2366 db (void) | |
| 2367 { | |
| 2368 debug_backtrace (); | |
| 2369 } | |
| 2370 | |
| 428 | 2371 void |
| 2372 debug_short_backtrace (int length) | |
| 2373 { | |
| 2374 int first = 1; | |
| 2375 struct backtrace *bt = backtrace_list; | |
| 771 | 2376 debug_out (" ["); |
| 428 | 2377 while (length > 0 && bt) |
| 2378 { | |
| 2379 if (!first) | |
| 2380 { | |
| 771 | 2381 debug_out (", "); |
| 428 | 2382 } |
| 2383 if (COMPILED_FUNCTIONP (*bt->function)) | |
| 2384 { | |
| 1346 | 2385 #if defined (COMPILED_FUNCTION_ANNOTATION_HACK) |
| 428 | 2386 Lisp_Object ann = |
| 2387 compiled_function_annotation (XCOMPILED_FUNCTION (*bt->function)); | |
| 2388 #else | |
| 2389 Lisp_Object ann = Qnil; | |
| 2390 #endif | |
| 2391 if (!NILP (ann)) | |
| 2392 { | |
| 771 | 2393 debug_out ("<compiled-function from "); |
| 1346 | 2394 debug_prin1 (ann, EXT_PRINT_ALL); |
| 771 | 2395 debug_out (">"); |
| 428 | 2396 } |
| 2397 else | |
| 2398 { | |
| 771 | 2399 debug_out ("<compiled-function of unknown origin>"); |
| 428 | 2400 } |
| 2401 } | |
| 2402 else | |
| 1346 | 2403 debug_prin1 (*bt->function, EXT_PRINT_ALL); |
| 428 | 2404 first = 0; |
| 2405 length--; | |
| 2406 bt = bt->next; | |
| 2407 } | |
| 771 | 2408 debug_out ("]\n"); |
| 428 | 2409 } |
| 2410 | |
| 2411 | |
| 2412 void | |
| 2413 syms_of_print (void) | |
| 2414 { | |
| 563 | 2415 DEFSYMBOL (Qstandard_output); |
| 428 | 2416 |
| 563 | 2417 DEFSYMBOL (Qprint_length); |
| 428 | 2418 |
| 563 | 2419 DEFSYMBOL (Qprint_string_length); |
| 428 | 2420 |
| 563 | 2421 DEFSYMBOL (Qdisplay_error); |
| 2422 DEFSYMBOL (Qprint_message_label); | |
| 428 | 2423 |
| 2424 DEFSUBR (Fprin1); | |
| 2425 DEFSUBR (Fprin1_to_string); | |
| 2426 DEFSUBR (Fprinc); | |
| 2427 DEFSUBR (Fprint); | |
| 2428 DEFSUBR (Ferror_message_string); | |
| 2429 DEFSUBR (Fdisplay_error); | |
| 2430 DEFSUBR (Fterpri); | |
| 2431 DEFSUBR (Fwrite_char); | |
| 2432 DEFSUBR (Falternate_debugging_output); | |
| 1346 | 2433 DEFSUBR (Fset_device_clear_left_side); |
| 2434 DEFSUBR (Fdevice_left_side_clear_p); | |
| 428 | 2435 DEFSUBR (Fexternal_debugging_output); |
| 2436 DEFSUBR (Fopen_termscript); | |
| 563 | 2437 DEFSYMBOL (Qexternal_debugging_output); |
| 2438 DEFSYMBOL (Qalternate_debugging_output); | |
| 442 | 2439 #ifdef HAVE_MS_WINDOWS |
| 563 | 2440 DEFSYMBOL (Qmswindows_debugging_output); |
| 442 | 2441 #endif |
| 428 | 2442 DEFSUBR (Fwith_output_to_temp_buffer); |
| 2443 } | |
| 2444 | |
| 2445 void | |
| 2446 reinit_vars_of_print (void) | |
| 2447 { | |
| 2448 alternate_do_pointer = 0; | |
| 2449 } | |
| 2450 | |
| 2451 void | |
| 2452 vars_of_print (void) | |
| 2453 { | |
| 2454 DEFVAR_LISP ("standard-output", &Vstandard_output /* | |
| 2455 Output stream `print' uses by default for outputting a character. | |
| 2456 This may be any function of one argument. | |
| 2457 It may also be a buffer (output is inserted before point) | |
| 2458 or a marker (output is inserted and the marker is advanced) | |
| 2459 or the symbol t (output appears in the minibuffer line). | |
| 2460 */ ); | |
| 2461 Vstandard_output = Qt; | |
| 2462 | |
| 2463 DEFVAR_LISP ("float-output-format", &Vfloat_output_format /* | |
| 2464 The format descriptor string that lisp uses to print floats. | |
| 2465 This is a %-spec like those accepted by `printf' in C, | |
| 2466 but with some restrictions. It must start with the two characters `%.'. | |
| 2467 After that comes an integer precision specification, | |
| 2468 and then a letter which controls the format. | |
| 2469 The letters allowed are `e', `f' and `g'. | |
| 2470 Use `e' for exponential notation "DIG.DIGITSeEXPT" | |
| 2471 Use `f' for decimal point notation "DIGITS.DIGITS". | |
| 2472 Use `g' to choose the shorter of those two formats for the number at hand. | |
| 2473 The precision in any of these cases is the number of digits following | |
| 2474 the decimal point. With `f', a precision of 0 means to omit the | |
| 2475 decimal point. 0 is not allowed with `f' or `g'. | |
| 2476 | |
| 2477 A value of nil means to use `%.16g'. | |
| 2478 | |
| 2479 Regardless of the value of `float-output-format', a floating point number | |
| 2480 will never be printed in such a way that it is ambiguous with an integer; | |
| 2481 that is, a floating-point number will always be printed with a decimal | |
| 2482 point and/or an exponent, even if the digits following the decimal point | |
| 2483 are all zero. This is to preserve read-equivalence. | |
| 2484 */ ); | |
| 2485 Vfloat_output_format = Qnil; | |
| 2486 | |
| 2487 DEFVAR_LISP ("print-length", &Vprint_length /* | |
| 2488 Maximum length of list or vector to print before abbreviating. | |
| 2489 A value of nil means no limit. | |
| 2490 */ ); | |
| 2491 Vprint_length = Qnil; | |
| 2492 | |
| 2493 DEFVAR_LISP ("print-string-length", &Vprint_string_length /* | |
| 2494 Maximum length of string to print before abbreviating. | |
| 2495 A value of nil means no limit. | |
| 2496 */ ); | |
| 2497 Vprint_string_length = Qnil; | |
| 2498 | |
| 2499 DEFVAR_LISP ("print-level", &Vprint_level /* | |
| 2500 Maximum depth of list nesting to print before abbreviating. | |
| 2501 A value of nil means no limit. | |
| 2502 */ ); | |
| 2503 Vprint_level = Qnil; | |
| 2504 | |
| 2505 DEFVAR_BOOL ("print-escape-newlines", &print_escape_newlines /* | |
| 2506 Non-nil means print newlines in strings as backslash-n. | |
| 2507 */ ); | |
| 2508 print_escape_newlines = 0; | |
| 2509 | |
| 2510 DEFVAR_BOOL ("print-readably", &print_readably /* | |
| 2511 If non-nil, then all objects will be printed in a readable form. | |
| 2512 If an object has no readable representation, then an error is signalled. | |
| 2513 When print-readably is true, compiled-function objects will be written in | |
| 2514 #[...] form instead of in #<compiled-function [...]> form, and two-element | |
| 2515 lists of the form (quote object) will be written as the equivalent 'object. | |
| 2516 Do not SET this variable; bind it instead. | |
| 2517 */ ); | |
| 2518 print_readably = 0; | |
| 2519 | |
| 2520 /* #### I think this should default to t. But we'd better wait | |
| 2521 until we see that it works out. */ | |
| 2522 DEFVAR_LISP ("print-gensym", &Vprint_gensym /* | |
| 2523 If non-nil, then uninterned symbols will be printed specially. | |
| 2524 Uninterned symbols are those which are not present in `obarray', that is, | |
| 2525 those which were made with `make-symbol' or by calling `intern' with a | |
| 2526 second argument. | |
| 2527 | |
| 2528 When print-gensym is true, such symbols will be preceded by "#:", | |
| 2529 which causes the reader to create a new symbol instead of interning | |
| 2530 and returning an existing one. Beware: the #: syntax creates a new | |
| 2531 symbol each time it is seen, so if you print an object which contains | |
| 2532 two pointers to the same uninterned symbol, `read' will not duplicate | |
| 2533 that structure. | |
| 2534 | |
| 2535 If the value of `print-gensym' is a cons cell, then in addition | |
| 2536 refrain from clearing `print-gensym-alist' on entry to and exit from | |
| 2537 printing functions, so that the use of #...# and #...= can carry over | |
| 2538 for several separately printed objects. | |
| 2539 */ ); | |
| 2540 Vprint_gensym = Qnil; | |
| 2541 | |
| 2542 DEFVAR_LISP ("print-gensym-alist", &Vprint_gensym_alist /* | |
| 2543 Association list of elements (GENSYM . N) to guide use of #N# and #N=. | |
| 2544 In each element, GENSYM is an uninterned symbol that has been associated | |
| 2545 with #N= for the specified value of N. | |
| 2546 */ ); | |
| 2547 Vprint_gensym_alist = Qnil; | |
| 2548 | |
| 2549 DEFVAR_LISP ("print-message-label", &Vprint_message_label /* | |
| 2550 Label for minibuffer messages created with `print'. This should | |
| 2551 generally be bound with `let' rather than set. (See `display-message'.) | |
| 2552 */ ); | |
| 2553 Vprint_message_label = Qprint; | |
| 1957 | 2554 |
| 2555 debug_prin1_bindings = | |
| 2556 make_opaque (OPAQUE_UNINIT, sizeof (struct debug_bindings)); | |
| 2557 staticpro (&debug_prin1_bindings); | |
| 2558 | |
| 2559 alternate_do_size = 5000; | |
| 2560 alternate_do_string = xnew_array(char, 5000); | |
| 428 | 2561 } |