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