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