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