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