Mercurial > hg > xemacs-beta
annotate src/rangetab.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 /* XEmacs routines to deal with range tables. |
| 2 Copyright (C) 1995 Sun Microsystems, Inc. | |
|
4831
2e15c29cc2b3
fix bug in returning range table ends in unified range table code
Ben Wing <ben@xemacs.org>
parents:
4713
diff
changeset
|
3 Copyright (C) 1995, 2002, 2004, 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 in FSF. */ | |
| 23 | |
| 24 /* Written by Ben Wing, August 1995. */ | |
| 25 | |
| 26 #include <config.h> | |
| 27 #include "lisp.h" | |
| 28 #include "rangetab.h" | |
| 29 | |
| 30 Lisp_Object Qrange_tablep; | |
| 31 Lisp_Object Qrange_table; | |
| 32 | |
| 2421 | 33 Lisp_Object Qstart_closed_end_open; |
| 34 Lisp_Object Qstart_open_end_open; | |
| 35 Lisp_Object Qstart_closed_end_closed; | |
| 36 Lisp_Object Qstart_open_end_closed; | |
| 37 | |
| 428 | 38 |
| 39 /************************************************************************/ | |
| 40 /* Range table object */ | |
| 41 /************************************************************************/ | |
| 42 | |
| 2421 | 43 static enum range_table_type |
| 44 range_table_symbol_to_type (Lisp_Object symbol) | |
| 45 { | |
| 46 if (NILP (symbol)) | |
| 47 return RANGE_START_CLOSED_END_OPEN; | |
| 48 | |
| 49 CHECK_SYMBOL (symbol); | |
| 50 if (EQ (symbol, Qstart_closed_end_open)) | |
| 51 return RANGE_START_CLOSED_END_OPEN; | |
| 52 if (EQ (symbol, Qstart_closed_end_closed)) | |
| 53 return RANGE_START_CLOSED_END_CLOSED; | |
| 54 if (EQ (symbol, Qstart_open_end_open)) | |
| 55 return RANGE_START_OPEN_END_OPEN; | |
| 56 if (EQ (symbol, Qstart_open_end_closed)) | |
| 57 return RANGE_START_OPEN_END_CLOSED; | |
| 58 | |
| 59 invalid_constant ("Unknown range table type", symbol); | |
| 60 RETURN_NOT_REACHED (RANGE_START_CLOSED_END_OPEN); | |
| 61 } | |
| 62 | |
| 63 static Lisp_Object | |
| 64 range_table_type_to_symbol (enum range_table_type type) | |
| 65 { | |
| 66 switch (type) | |
| 67 { | |
| 68 case RANGE_START_CLOSED_END_OPEN: | |
| 69 return Qstart_closed_end_open; | |
| 70 case RANGE_START_CLOSED_END_CLOSED: | |
| 71 return Qstart_closed_end_closed; | |
| 72 case RANGE_START_OPEN_END_OPEN: | |
| 73 return Qstart_open_end_open; | |
| 74 case RANGE_START_OPEN_END_CLOSED: | |
| 75 return Qstart_open_end_closed; | |
| 76 } | |
| 77 | |
| 2500 | 78 ABORT (); |
| 2421 | 79 return Qnil; |
| 80 } | |
| 81 | |
| 428 | 82 /* We use a sorted array of ranges. |
| 83 | |
| 84 #### We should be using the gap array stuff from extents.c. This | |
| 85 is not hard but just requires moving that stuff out of that file. */ | |
| 86 | |
| 87 static Lisp_Object | |
| 88 mark_range_table (Lisp_Object obj) | |
| 89 { | |
| 440 | 90 Lisp_Range_Table *rt = XRANGE_TABLE (obj); |
| 428 | 91 int i; |
| 92 | |
| 93 for (i = 0; i < Dynarr_length (rt->entries); i++) | |
| 94 mark_object (Dynarr_at (rt->entries, i).val); | |
|
4690
257b468bf2ca
Move the #'query-coding-region implementation to C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4391
diff
changeset
|
95 |
| 428 | 96 return Qnil; |
| 97 } | |
| 98 | |
| 99 static void | |
| 2286 | 100 print_range_table (Lisp_Object obj, Lisp_Object printcharfun, |
| 101 int UNUSED (escapeflag)) | |
| 428 | 102 { |
| 440 | 103 Lisp_Range_Table *rt = XRANGE_TABLE (obj); |
| 428 | 104 int i; |
| 105 | |
| 2421 | 106 if (print_readably) |
| 107 write_fmt_string_lisp (printcharfun, "#s(range-table type %s data (", | |
| 108 1, range_table_type_to_symbol (rt->type)); | |
| 109 else | |
|
4952
19a72041c5ed
Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents:
4831
diff
changeset
|
110 write_ascstring (printcharfun, "#<range-table "); |
| 428 | 111 for (i = 0; i < Dynarr_length (rt->entries); i++) |
| 112 { | |
| 113 struct range_table_entry *rte = Dynarr_atp (rt->entries, i); | |
| 2421 | 114 int so, ec; |
| 428 | 115 if (i > 0) |
|
4952
19a72041c5ed
Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents:
4831
diff
changeset
|
116 write_ascstring (printcharfun, " "); |
| 2421 | 117 switch (rt->type) |
| 118 { | |
| 119 case RANGE_START_CLOSED_END_OPEN: so = 0, ec = 0; break; | |
| 120 case RANGE_START_CLOSED_END_CLOSED: so = 0, ec = 1; break; | |
| 121 case RANGE_START_OPEN_END_OPEN: so = 1, ec = 0; break; | |
| 122 case RANGE_START_OPEN_END_CLOSED: so = 1; ec = 1; break; | |
| 2500 | 123 default: ABORT (); so = 0, ec = 0; break; |
| 2421 | 124 } |
| 125 write_fmt_string (printcharfun, "%c%ld %ld%c ", | |
| 126 print_readably ? '(' : so ? '(' : '[', | |
| 127 (long) (rte->first - so), | |
| 128 (long) (rte->last - ec), | |
| 129 print_readably ? ')' : ec ? ']' : ')' | |
| 130 ); | |
| 428 | 131 print_internal (rte->val, printcharfun, 1); |
| 132 } | |
| 2421 | 133 if (print_readably) |
|
4952
19a72041c5ed
Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents:
4831
diff
changeset
|
134 write_ascstring (printcharfun, "))"); |
| 2421 | 135 else |
| 136 write_fmt_string (printcharfun, " 0x%x>", rt->header.uid); | |
| 428 | 137 } |
| 138 | |
| 139 static int | |
|
4906
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4831
diff
changeset
|
140 range_table_equal (Lisp_Object obj1, Lisp_Object obj2, int depth, int foldcase) |
| 428 | 141 { |
| 440 | 142 Lisp_Range_Table *rt1 = XRANGE_TABLE (obj1); |
| 143 Lisp_Range_Table *rt2 = XRANGE_TABLE (obj2); | |
| 428 | 144 int i; |
| 145 | |
| 146 if (Dynarr_length (rt1->entries) != Dynarr_length (rt2->entries)) | |
| 147 return 0; | |
| 148 | |
| 149 for (i = 0; i < Dynarr_length (rt1->entries); i++) | |
| 150 { | |
| 151 struct range_table_entry *rte1 = Dynarr_atp (rt1->entries, i); | |
| 152 struct range_table_entry *rte2 = Dynarr_atp (rt2->entries, i); | |
| 153 | |
| 154 if (rte1->first != rte2->first | |
| 155 || rte1->last != rte2->last | |
|
4906
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4831
diff
changeset
|
156 || !internal_equal_0 (rte1->val, rte2->val, depth + 1, foldcase)) |
| 428 | 157 return 0; |
| 158 } | |
| 159 | |
| 160 return 1; | |
| 161 } | |
| 162 | |
| 2515 | 163 static Hashcode |
| 428 | 164 range_table_entry_hash (struct range_table_entry *rte, int depth) |
| 165 { | |
| 166 return HASH3 (rte->first, rte->last, internal_hash (rte->val, depth + 1)); | |
| 167 } | |
| 168 | |
| 2515 | 169 static Hashcode |
| 428 | 170 range_table_hash (Lisp_Object obj, int depth) |
| 171 { | |
| 440 | 172 Lisp_Range_Table *rt = XRANGE_TABLE (obj); |
| 428 | 173 int i; |
| 174 int size = Dynarr_length (rt->entries); | |
| 2515 | 175 Hashcode hash = size; |
| 428 | 176 |
| 177 /* approach based on internal_array_hash(). */ | |
| 178 if (size <= 5) | |
| 179 { | |
| 180 for (i = 0; i < size; i++) | |
| 181 hash = HASH2 (hash, | |
| 182 range_table_entry_hash (Dynarr_atp (rt->entries, i), | |
| 183 depth)); | |
| 184 return hash; | |
| 185 } | |
| 186 | |
| 187 /* just pick five elements scattered throughout the array. | |
| 188 A slightly better approach would be to offset by some | |
| 189 noise factor from the points chosen below. */ | |
| 190 for (i = 0; i < 5; i++) | |
| 191 hash = HASH2 (hash, range_table_entry_hash (Dynarr_atp (rt->entries, | |
| 192 i*size/5), | |
| 193 depth)); | |
| 194 return hash; | |
| 195 } | |
| 196 | |
| 1204 | 197 static const struct memory_description rte_description_1[] = { |
| 440 | 198 { XD_LISP_OBJECT, offsetof (range_table_entry, val) }, |
| 428 | 199 { XD_END } |
| 200 }; | |
| 201 | |
| 1204 | 202 static const struct sized_memory_description rte_description = { |
| 440 | 203 sizeof (range_table_entry), |
| 428 | 204 rte_description_1 |
| 205 }; | |
| 206 | |
| 1204 | 207 static const struct memory_description rted_description_1[] = { |
| 440 | 208 XD_DYNARR_DESC (range_table_entry_dynarr, &rte_description), |
| 428 | 209 { XD_END } |
| 210 }; | |
| 211 | |
| 1204 | 212 static const struct sized_memory_description rted_description = { |
| 440 | 213 sizeof (range_table_entry_dynarr), |
| 428 | 214 rted_description_1 |
| 215 }; | |
| 216 | |
| 1204 | 217 static const struct memory_description range_table_description[] = { |
| 2551 | 218 { XD_BLOCK_PTR, offsetof (Lisp_Range_Table, entries), 1, |
| 219 { &rted_description } }, | |
| 428 | 220 { XD_END } |
| 221 }; | |
| 222 | |
|
5118
e0db3c197671
merge up to latest default branch, doesn't compile yet
Ben Wing <ben@xemacs.org>
diff
changeset
|
223 DEFINE_DUMPABLE_LISP_OBJECT ("range-table", range_table, |
|
e0db3c197671
merge up to latest default branch, doesn't compile yet
Ben Wing <ben@xemacs.org>
diff
changeset
|
224 mark_range_table, print_range_table, 0, |
|
e0db3c197671
merge up to latest default branch, doesn't compile yet
Ben Wing <ben@xemacs.org>
diff
changeset
|
225 range_table_equal, range_table_hash, |
|
e0db3c197671
merge up to latest default branch, doesn't compile yet
Ben Wing <ben@xemacs.org>
diff
changeset
|
226 range_table_description, |
|
e0db3c197671
merge up to latest default branch, doesn't compile yet
Ben Wing <ben@xemacs.org>
diff
changeset
|
227 Lisp_Range_Table); |
| 428 | 228 |
| 229 /************************************************************************/ | |
| 230 /* Range table operations */ | |
| 231 /************************************************************************/ | |
| 232 | |
| 800 | 233 #ifdef ERROR_CHECK_STRUCTURES |
| 428 | 234 |
| 235 static void | |
| 440 | 236 verify_range_table (Lisp_Range_Table *rt) |
| 428 | 237 { |
| 238 int i; | |
| 239 | |
| 240 for (i = 0; i < Dynarr_length (rt->entries); i++) | |
| 241 { | |
| 242 struct range_table_entry *rte = Dynarr_atp (rt->entries, i); | |
| 243 assert (rte->last >= rte->first); | |
| 244 if (i > 0) | |
| 2421 | 245 assert (Dynarr_at (rt->entries, i - 1).last <= rte->first); |
| 428 | 246 } |
| 247 } | |
| 248 | |
| 249 #else | |
| 250 | |
| 251 #define verify_range_table(rt) | |
| 252 | |
| 253 #endif | |
| 254 | |
| 255 /* Look up in a range table without the Dynarr wrapper. | |
| 256 Used also by the unified range table format. */ | |
| 257 | |
| 258 static Lisp_Object | |
| 259 get_range_table (EMACS_INT pos, int nentries, struct range_table_entry *tab, | |
| 260 Lisp_Object default_) | |
| 261 { | |
| 262 int left = 0, right = nentries; | |
| 263 | |
| 264 /* binary search for the entry. Based on similar code in | |
| 265 extent_list_locate(). */ | |
| 266 while (left != right) | |
| 267 { | |
| 268 /* RIGHT might not point to a valid entry (i.e. it's at the end | |
| 269 of the list), so NEWPOS must round down. */ | |
| 647 | 270 int newpos = (left + right) >> 1; |
| 428 | 271 struct range_table_entry *entry = tab + newpos; |
| 2421 | 272 if (pos >= entry->last) |
| 273 left = newpos + 1; | |
| 428 | 274 else if (pos < entry->first) |
| 275 right = newpos; | |
| 276 else | |
| 277 return entry->val; | |
| 278 } | |
| 279 | |
| 280 return default_; | |
| 281 } | |
| 282 | |
| 283 DEFUN ("range-table-p", Frange_table_p, 1, 1, 0, /* | |
| 284 Return non-nil if OBJECT is a range table. | |
| 285 */ | |
| 286 (object)) | |
| 287 { | |
| 288 return RANGE_TABLEP (object) ? Qt : Qnil; | |
| 289 } | |
| 290 | |
| 2421 | 291 DEFUN ("range-table-type", Frange_table_type, 1, 1, 0, /* |
|
4713
312503644bc3
Correct the docstring for #'range-table-type.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4690
diff
changeset
|
292 Return the type of RANGE-TABLE. |
|
312503644bc3
Correct the docstring for #'range-table-type.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4690
diff
changeset
|
293 |
|
312503644bc3
Correct the docstring for #'range-table-type.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4690
diff
changeset
|
294 This will be a symbol describing how ranges in RANGE-TABLE function at their |
|
312503644bc3
Correct the docstring for #'range-table-type.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4690
diff
changeset
|
295 ends; see `make-range-table'. |
| 2421 | 296 */ |
| 297 (range_table)) | |
| 298 { | |
| 299 CHECK_RANGE_TABLE (range_table); | |
| 300 return range_table_type_to_symbol (XRANGE_TABLE (range_table)->type); | |
| 301 } | |
| 302 | |
| 303 DEFUN ("make-range-table", Fmake_range_table, 0, 1, 0, /* | |
| 428 | 304 Return a new, empty range table. |
| 305 You can manipulate it using `put-range-table', `get-range-table', | |
| 306 `remove-range-table', and `clear-range-table'. | |
| 2421 | 307 Range tables allow you to efficiently set values for ranges of integers. |
| 308 | |
| 309 TYPE is a symbol indicating how ranges are assumed to function at their | |
| 310 ends. It can be one of | |
| 311 | |
| 312 SYMBOL RANGE-START RANGE-END | |
| 313 ------ ----------- --------- | |
| 314 `start-closed-end-open' (the default) closed open | |
| 315 `start-closed-end-closed' closed closed | |
| 316 `start-open-end-open' open open | |
| 317 `start-open-end-closed' open closed | |
| 318 | |
| 319 A `closed' endpoint of a range means that the number at that end is included | |
| 320 in the range. For an `open' endpoint, the number would not be included. | |
| 321 | |
| 322 For example, a closed-open range from 5 to 20 would be indicated as [5, | |
| 323 20) where a bracket indicates a closed end and a parenthesis an open end, | |
| 324 and would mean `all the numbers between 5 and 20', including 5 but not 20. | |
| 325 This seems a little strange at first but is in fact extremely common in | |
| 326 the outside world as well as in computers and makes things work sensibly. | |
| 327 For example, if I say "there are seven days between today and next week | |
| 328 today", I'm including today but not next week today; if I included both, | |
| 329 there would be eight days. Similarly, there are 15 (= 20 - 5) elements in | |
| 330 the range [5, 20), but 16 in the range [5, 20]. | |
| 428 | 331 */ |
| 2421 | 332 (type)) |
| 428 | 333 { |
|
5127
a9c41067dd88
more cleanups, terminology clarification, lots of doc work
Ben Wing <ben@xemacs.org>
parents:
5125
diff
changeset
|
334 Lisp_Object obj = ALLOC_NORMAL_LISP_OBJECT (range_table); |
|
5117
3742ea8250b5
Checking in final CVS version of workspace 'ben-lisp-object'
Ben Wing <ben@xemacs.org>
parents:
3017
diff
changeset
|
335 Lisp_Range_Table *rt = XRANGE_TABLE (obj); |
| 428 | 336 rt->entries = Dynarr_new (range_table_entry); |
| 2421 | 337 rt->type = range_table_symbol_to_type (type); |
|
5117
3742ea8250b5
Checking in final CVS version of workspace 'ben-lisp-object'
Ben Wing <ben@xemacs.org>
parents:
3017
diff
changeset
|
338 return obj; |
| 428 | 339 } |
| 340 | |
| 341 DEFUN ("copy-range-table", Fcopy_range_table, 1, 1, 0, /* | |
| 444 | 342 Return a new range table which is a copy of RANGE-TABLE. |
| 343 It will contain the same values for the same ranges as RANGE-TABLE. | |
| 344 The values will not themselves be copied. | |
| 428 | 345 */ |
| 444 | 346 (range_table)) |
| 428 | 347 { |
| 440 | 348 Lisp_Range_Table *rt, *rtnew; |
|
5117
3742ea8250b5
Checking in final CVS version of workspace 'ben-lisp-object'
Ben Wing <ben@xemacs.org>
parents:
3017
diff
changeset
|
349 Lisp_Object obj; |
| 428 | 350 |
| 444 | 351 CHECK_RANGE_TABLE (range_table); |
| 352 rt = XRANGE_TABLE (range_table); | |
| 428 | 353 |
|
5127
a9c41067dd88
more cleanups, terminology clarification, lots of doc work
Ben Wing <ben@xemacs.org>
parents:
5125
diff
changeset
|
354 obj = ALLOC_NORMAL_LISP_OBJECT (range_table); |
|
5117
3742ea8250b5
Checking in final CVS version of workspace 'ben-lisp-object'
Ben Wing <ben@xemacs.org>
parents:
3017
diff
changeset
|
355 rtnew = XRANGE_TABLE (obj); |
| 428 | 356 rtnew->entries = Dynarr_new (range_table_entry); |
| 2421 | 357 rtnew->type = rt->type; |
| 428 | 358 |
| 4967 | 359 Dynarr_add_many (rtnew->entries, Dynarr_begin (rt->entries), |
| 428 | 360 Dynarr_length (rt->entries)); |
|
5117
3742ea8250b5
Checking in final CVS version of workspace 'ben-lisp-object'
Ben Wing <ben@xemacs.org>
parents:
3017
diff
changeset
|
361 return obj; |
| 428 | 362 } |
| 363 | |
| 364 DEFUN ("get-range-table", Fget_range_table, 2, 3, 0, /* | |
| 444 | 365 Find value for position POS in RANGE-TABLE. |
| 428 | 366 If there is no corresponding value, return DEFAULT (defaults to nil). |
| 367 */ | |
| 444 | 368 (pos, range_table, default_)) |
| 428 | 369 { |
| 440 | 370 Lisp_Range_Table *rt; |
| 428 | 371 |
| 444 | 372 CHECK_RANGE_TABLE (range_table); |
| 373 rt = XRANGE_TABLE (range_table); | |
| 428 | 374 |
| 375 CHECK_INT_COERCE_CHAR (pos); | |
| 376 | |
| 377 return get_range_table (XINT (pos), Dynarr_length (rt->entries), | |
| 4967 | 378 Dynarr_begin (rt->entries), default_); |
| 428 | 379 } |
| 380 | |
|
4831
2e15c29cc2b3
fix bug in returning range table ends in unified range table code
Ben Wing <ben@xemacs.org>
parents:
4713
diff
changeset
|
381 static void |
|
2e15c29cc2b3
fix bug in returning range table ends in unified range table code
Ben Wing <ben@xemacs.org>
parents:
4713
diff
changeset
|
382 external_to_internal_adjust_ends (enum range_table_type type, |
|
2e15c29cc2b3
fix bug in returning range table ends in unified range table code
Ben Wing <ben@xemacs.org>
parents:
4713
diff
changeset
|
383 EMACS_INT *first, EMACS_INT *last) |
|
2e15c29cc2b3
fix bug in returning range table ends in unified range table code
Ben Wing <ben@xemacs.org>
parents:
4713
diff
changeset
|
384 { |
|
2e15c29cc2b3
fix bug in returning range table ends in unified range table code
Ben Wing <ben@xemacs.org>
parents:
4713
diff
changeset
|
385 /* Fix up the numbers in accordance with the open/closedness to make |
|
2e15c29cc2b3
fix bug in returning range table ends in unified range table code
Ben Wing <ben@xemacs.org>
parents:
4713
diff
changeset
|
386 them behave like default open/closed. */ |
|
2e15c29cc2b3
fix bug in returning range table ends in unified range table code
Ben Wing <ben@xemacs.org>
parents:
4713
diff
changeset
|
387 switch (type) |
|
2e15c29cc2b3
fix bug in returning range table ends in unified range table code
Ben Wing <ben@xemacs.org>
parents:
4713
diff
changeset
|
388 { |
|
2e15c29cc2b3
fix bug in returning range table ends in unified range table code
Ben Wing <ben@xemacs.org>
parents:
4713
diff
changeset
|
389 case RANGE_START_CLOSED_END_OPEN: break; |
|
2e15c29cc2b3
fix bug in returning range table ends in unified range table code
Ben Wing <ben@xemacs.org>
parents:
4713
diff
changeset
|
390 case RANGE_START_CLOSED_END_CLOSED: (*last)++; break; |
|
2e15c29cc2b3
fix bug in returning range table ends in unified range table code
Ben Wing <ben@xemacs.org>
parents:
4713
diff
changeset
|
391 case RANGE_START_OPEN_END_OPEN: (*first)++; break; |
|
2e15c29cc2b3
fix bug in returning range table ends in unified range table code
Ben Wing <ben@xemacs.org>
parents:
4713
diff
changeset
|
392 case RANGE_START_OPEN_END_CLOSED: (*first)++, (*last)++; break; |
|
2e15c29cc2b3
fix bug in returning range table ends in unified range table code
Ben Wing <ben@xemacs.org>
parents:
4713
diff
changeset
|
393 } |
|
2e15c29cc2b3
fix bug in returning range table ends in unified range table code
Ben Wing <ben@xemacs.org>
parents:
4713
diff
changeset
|
394 } |
|
2e15c29cc2b3
fix bug in returning range table ends in unified range table code
Ben Wing <ben@xemacs.org>
parents:
4713
diff
changeset
|
395 |
|
2e15c29cc2b3
fix bug in returning range table ends in unified range table code
Ben Wing <ben@xemacs.org>
parents:
4713
diff
changeset
|
396 static void |
|
2e15c29cc2b3
fix bug in returning range table ends in unified range table code
Ben Wing <ben@xemacs.org>
parents:
4713
diff
changeset
|
397 internal_to_external_adjust_ends (enum range_table_type type, |
|
2e15c29cc2b3
fix bug in returning range table ends in unified range table code
Ben Wing <ben@xemacs.org>
parents:
4713
diff
changeset
|
398 EMACS_INT *first, EMACS_INT *last) |
|
2e15c29cc2b3
fix bug in returning range table ends in unified range table code
Ben Wing <ben@xemacs.org>
parents:
4713
diff
changeset
|
399 { |
|
2e15c29cc2b3
fix bug in returning range table ends in unified range table code
Ben Wing <ben@xemacs.org>
parents:
4713
diff
changeset
|
400 /* Reverse the changes made in external_to_internal_adjust_ends(). |
|
2e15c29cc2b3
fix bug in returning range table ends in unified range table code
Ben Wing <ben@xemacs.org>
parents:
4713
diff
changeset
|
401 */ |
|
2e15c29cc2b3
fix bug in returning range table ends in unified range table code
Ben Wing <ben@xemacs.org>
parents:
4713
diff
changeset
|
402 switch (type) |
|
2e15c29cc2b3
fix bug in returning range table ends in unified range table code
Ben Wing <ben@xemacs.org>
parents:
4713
diff
changeset
|
403 { |
|
2e15c29cc2b3
fix bug in returning range table ends in unified range table code
Ben Wing <ben@xemacs.org>
parents:
4713
diff
changeset
|
404 case RANGE_START_CLOSED_END_OPEN: break; |
|
2e15c29cc2b3
fix bug in returning range table ends in unified range table code
Ben Wing <ben@xemacs.org>
parents:
4713
diff
changeset
|
405 case RANGE_START_CLOSED_END_CLOSED: (*last)--; break; |
|
2e15c29cc2b3
fix bug in returning range table ends in unified range table code
Ben Wing <ben@xemacs.org>
parents:
4713
diff
changeset
|
406 case RANGE_START_OPEN_END_OPEN: (*first)--; break; |
|
2e15c29cc2b3
fix bug in returning range table ends in unified range table code
Ben Wing <ben@xemacs.org>
parents:
4713
diff
changeset
|
407 case RANGE_START_OPEN_END_CLOSED: (*first)--, (*last)--; break; |
|
2e15c29cc2b3
fix bug in returning range table ends in unified range table code
Ben Wing <ben@xemacs.org>
parents:
4713
diff
changeset
|
408 } |
|
2e15c29cc2b3
fix bug in returning range table ends in unified range table code
Ben Wing <ben@xemacs.org>
parents:
4713
diff
changeset
|
409 } |
|
2e15c29cc2b3
fix bug in returning range table ends in unified range table code
Ben Wing <ben@xemacs.org>
parents:
4713
diff
changeset
|
410 |
| 428 | 411 void |
| 412 put_range_table (Lisp_Object table, EMACS_INT first, | |
| 413 EMACS_INT last, Lisp_Object val) | |
| 414 { | |
| 415 int i; | |
| 416 int insert_me_here = -1; | |
| 440 | 417 Lisp_Range_Table *rt = XRANGE_TABLE (table); |
| 428 | 418 |
|
4831
2e15c29cc2b3
fix bug in returning range table ends in unified range table code
Ben Wing <ben@xemacs.org>
parents:
4713
diff
changeset
|
419 external_to_internal_adjust_ends (rt->type, &first, &last); |
| 2421 | 420 if (first == last) |
| 421 return; | |
| 422 if (first > last) | |
| 423 /* This will happen if originally first == last and both ends are | |
| 424 open. #### Should we signal an error? */ | |
| 425 return; | |
| 426 | |
| 428 | 427 /* Now insert in the proper place. This gets tricky because |
| 428 we may be overlapping one or more existing ranges and need | |
| 429 to fix them up. */ | |
| 430 | |
| 431 /* First delete all sections of any existing ranges that overlap | |
| 432 the new range. */ | |
| 433 for (i = 0; i < Dynarr_length (rt->entries); i++) | |
| 434 { | |
| 435 struct range_table_entry *entry = Dynarr_atp (rt->entries, i); | |
| 436 /* We insert before the first range that begins at or after the | |
| 437 new range. */ | |
| 438 if (entry->first >= first && insert_me_here < 0) | |
| 439 insert_me_here = i; | |
| 440 if (entry->last < first) | |
| 441 /* completely before the new range. */ | |
| 442 continue; | |
| 443 if (entry->first > last) | |
| 444 /* completely after the new range. No more possibilities of | |
| 445 finding overlapping ranges. */ | |
| 446 break; | |
| 2421 | 447 /* At this point the existing ENTRY overlaps or touches the new one. */ |
| 428 | 448 if (entry->first < first && entry->last <= last) |
| 449 { | |
| 450 /* looks like: | |
| 451 | |
| 2421 | 452 [ NEW ) |
| 453 [ EXISTING ) | |
| 454 | |
| 455 or | |
| 456 | |
| 457 [ NEW ) | |
| 458 [ EXISTING ) | |
| 428 | 459 |
| 460 */ | |
| 461 /* truncate the end off of it. */ | |
| 2421 | 462 entry->last = first; |
| 428 | 463 } |
| 464 else if (entry->first < first && entry->last > last) | |
| 465 /* looks like: | |
| 466 | |
| 2421 | 467 [ NEW ) |
| 468 [ EXISTING ) | |
| 428 | 469 |
| 470 */ | |
| 471 /* need to split this one in two. */ | |
| 472 { | |
| 473 struct range_table_entry insert_me_too; | |
| 474 | |
| 2421 | 475 insert_me_too.first = last; |
| 428 | 476 insert_me_too.last = entry->last; |
| 477 insert_me_too.val = entry->val; | |
| 2421 | 478 entry->last = first; |
| 428 | 479 Dynarr_insert_many (rt->entries, &insert_me_too, 1, i + 1); |
| 480 } | |
| 2421 | 481 else if (entry->last >= last) |
| 428 | 482 { |
| 483 /* looks like: | |
| 484 | |
| 2421 | 485 [ NEW ) |
| 486 [ EXISTING ) | |
| 487 | |
| 488 or | |
| 489 | |
| 490 [ NEW ) | |
| 491 [ EXISTING ) | |
| 428 | 492 |
| 493 */ | |
| 494 /* truncate the start off of it. */ | |
| 2421 | 495 entry->first = last; |
| 428 | 496 } |
| 497 else | |
| 498 { | |
| 499 /* existing is entirely within new. */ | |
| 500 Dynarr_delete_many (rt->entries, i, 1); | |
| 501 i--; /* back up since everything shifted one to the left. */ | |
| 502 } | |
| 503 } | |
| 504 | |
| 505 /* Someone asked us to delete the range, not insert it. */ | |
| 506 if (UNBOUNDP (val)) | |
| 507 return; | |
| 508 | |
| 509 /* Now insert the new entry, maybe at the end. */ | |
| 510 | |
| 511 if (insert_me_here < 0) | |
| 512 insert_me_here = i; | |
| 513 | |
| 514 { | |
| 515 struct range_table_entry insert_me; | |
| 516 | |
| 517 insert_me.first = first; | |
| 518 insert_me.last = last; | |
| 519 insert_me.val = val; | |
| 520 | |
| 521 Dynarr_insert_many (rt->entries, &insert_me, 1, insert_me_here); | |
| 522 } | |
| 523 | |
| 524 /* Now see if we can combine this entry with adjacent ones just | |
| 525 before or after. */ | |
| 526 | |
| 527 if (insert_me_here > 0) | |
| 528 { | |
| 529 struct range_table_entry *entry = Dynarr_atp (rt->entries, | |
| 530 insert_me_here - 1); | |
| 2421 | 531 if (EQ (val, entry->val) && entry->last == first) |
| 428 | 532 { |
| 533 entry->last = last; | |
| 534 Dynarr_delete_many (rt->entries, insert_me_here, 1); | |
| 535 insert_me_here--; | |
| 536 /* We have morphed into a larger range. Update our records | |
| 537 in case we also combine with the one after. */ | |
| 538 first = entry->first; | |
| 539 } | |
| 540 } | |
| 541 | |
| 542 if (insert_me_here < Dynarr_length (rt->entries) - 1) | |
| 543 { | |
| 544 struct range_table_entry *entry = Dynarr_atp (rt->entries, | |
| 545 insert_me_here + 1); | |
| 2421 | 546 if (EQ (val, entry->val) && entry->first == last) |
| 428 | 547 { |
| 548 entry->first = first; | |
| 549 Dynarr_delete_many (rt->entries, insert_me_here, 1); | |
| 550 } | |
| 551 } | |
| 552 } | |
| 553 | |
| 554 DEFUN ("put-range-table", Fput_range_table, 4, 4, 0, /* | |
| 2421 | 555 Set the value for range START .. END to be VALUE in RANGE-TABLE. |
| 428 | 556 */ |
| 444 | 557 (start, end, value, range_table)) |
| 428 | 558 { |
| 559 EMACS_INT first, last; | |
| 560 | |
| 444 | 561 CHECK_RANGE_TABLE (range_table); |
| 428 | 562 CHECK_INT_COERCE_CHAR (start); |
| 563 first = XINT (start); | |
| 564 CHECK_INT_COERCE_CHAR (end); | |
| 565 last = XINT (end); | |
| 566 if (first > last) | |
| 563 | 567 invalid_argument_2 ("start must be <= end", start, end); |
| 428 | 568 |
| 444 | 569 put_range_table (range_table, first, last, value); |
| 570 verify_range_table (XRANGE_TABLE (range_table)); | |
| 428 | 571 return Qnil; |
| 572 } | |
| 573 | |
| 574 DEFUN ("remove-range-table", Fremove_range_table, 3, 3, 0, /* | |
| 2421 | 575 Remove the value for range START .. END in RANGE-TABLE. |
| 428 | 576 */ |
| 444 | 577 (start, end, range_table)) |
| 428 | 578 { |
| 444 | 579 return Fput_range_table (start, end, Qunbound, range_table); |
| 428 | 580 } |
| 581 | |
| 582 DEFUN ("clear-range-table", Fclear_range_table, 1, 1, 0, /* | |
| 444 | 583 Flush RANGE-TABLE. |
| 428 | 584 */ |
| 444 | 585 (range_table)) |
| 428 | 586 { |
| 444 | 587 CHECK_RANGE_TABLE (range_table); |
| 588 Dynarr_reset (XRANGE_TABLE (range_table)->entries); | |
| 428 | 589 return Qnil; |
| 590 } | |
| 591 | |
| 592 DEFUN ("map-range-table", Fmap_range_table, 2, 2, 0, /* | |
| 444 | 593 Map FUNCTION over entries in RANGE-TABLE, calling it with three args, |
| 428 | 594 the beginning and end of the range and the corresponding value. |
| 442 | 595 |
| 596 Results are guaranteed to be correct (i.e. each entry processed | |
| 597 exactly once) if FUNCTION modifies or deletes the current entry | |
| 444 | 598 \(i.e. passes the current range to `put-range-table' or |
|
4391
cbf129b005df
Clarify #'map-range-table docstring.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3017
diff
changeset
|
599 `remove-range-table'). If FUNCTION modifies or deletes any other entry, |
|
cbf129b005df
Clarify #'map-range-table docstring.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3017
diff
changeset
|
600 this guarantee doesn't hold. |
| 428 | 601 */ |
| 444 | 602 (function, range_table)) |
| 428 | 603 { |
| 442 | 604 Lisp_Range_Table *rt; |
| 605 int i; | |
| 606 | |
| 444 | 607 CHECK_RANGE_TABLE (range_table); |
| 442 | 608 CHECK_FUNCTION (function); |
| 609 | |
| 444 | 610 rt = XRANGE_TABLE (range_table); |
| 442 | 611 |
| 612 /* Do not "optimize" by pulling out the length computation below! | |
| 613 FUNCTION may have changed the table. */ | |
| 614 for (i = 0; i < Dynarr_length (rt->entries); i++) | |
| 615 { | |
| 616 struct range_table_entry *entry = Dynarr_atp (rt->entries, i); | |
| 617 EMACS_INT first, last; | |
| 618 Lisp_Object args[4]; | |
| 619 int oldlen; | |
| 620 | |
| 621 again: | |
| 622 first = entry->first; | |
| 623 last = entry->last; | |
| 624 oldlen = Dynarr_length (rt->entries); | |
| 625 args[0] = function; | |
| 2952 | 626 /* Fix up the numbers in accordance with the open/closedness of the |
| 627 table. */ | |
| 628 { | |
| 629 EMACS_INT premier = first, dernier = last; | |
|
4831
2e15c29cc2b3
fix bug in returning range table ends in unified range table code
Ben Wing <ben@xemacs.org>
parents:
4713
diff
changeset
|
630 internal_to_external_adjust_ends (rt->type, &premier, &dernier); |
| 2952 | 631 args[1] = make_int (premier); |
| 632 args[2] = make_int (dernier); | |
| 633 } | |
| 442 | 634 args[3] = entry->val; |
| 635 Ffuncall (countof (args), args); | |
| 636 /* Has FUNCTION removed the entry? */ | |
| 637 if (oldlen > Dynarr_length (rt->entries) | |
| 638 && i < Dynarr_length (rt->entries) | |
| 639 && (first != entry->first || last != entry->last)) | |
| 640 goto again; | |
| 641 } | |
| 642 | |
| 428 | 643 return Qnil; |
| 644 } | |
| 645 | |
| 646 | |
| 647 /************************************************************************/ | |
| 648 /* Range table read syntax */ | |
| 649 /************************************************************************/ | |
| 650 | |
| 651 static int | |
| 2421 | 652 rangetab_type_validate (Lisp_Object UNUSED (keyword), Lisp_Object value, |
| 653 Error_Behavior UNUSED (errb)) | |
| 654 { | |
| 655 /* #### should deal with ERRB */ | |
| 656 range_table_symbol_to_type (value); | |
| 657 return 1; | |
| 658 } | |
| 659 | |
| 660 static int | |
| 2286 | 661 rangetab_data_validate (Lisp_Object UNUSED (keyword), Lisp_Object value, |
| 662 Error_Behavior UNUSED (errb)) | |
| 428 | 663 { |
| 2367 | 664 /* #### should deal with ERRB */ |
| 665 EXTERNAL_PROPERTY_LIST_LOOP_3 (range, data, value) | |
| 428 | 666 { |
| 667 if (!INTP (range) && !CHARP (range) | |
| 668 && !(CONSP (range) && CONSP (XCDR (range)) | |
| 669 && NILP (XCDR (XCDR (range))) | |
| 670 && (INTP (XCAR (range)) || CHARP (XCAR (range))) | |
| 671 && (INTP (XCAR (XCDR (range))) || CHARP (XCAR (XCDR (range)))))) | |
| 563 | 672 sferror ("Invalid range format", range); |
| 428 | 673 } |
| 674 | |
| 675 return 1; | |
| 676 } | |
| 677 | |
| 678 static Lisp_Object | |
| 2421 | 679 rangetab_instantiate (Lisp_Object plist) |
| 428 | 680 { |
| 2425 | 681 Lisp_Object data = Qnil, type = Qnil, rangetab; |
| 428 | 682 |
| 2421 | 683 PROPERTY_LIST_LOOP_3 (key, value, plist) |
| 428 | 684 { |
| 2421 | 685 if (EQ (key, Qtype)) type = value; |
| 686 else if (EQ (key, Qdata)) data = value; | |
| 687 else | |
| 2500 | 688 ABORT (); |
| 2421 | 689 } |
| 690 | |
| 2425 | 691 rangetab = Fmake_range_table (type); |
| 428 | 692 |
| 2421 | 693 { |
| 694 PROPERTY_LIST_LOOP_3 (range, val, data) | |
| 695 { | |
| 696 if (CONSP (range)) | |
| 697 Fput_range_table (Fcar (range), Fcar (Fcdr (range)), val, | |
| 698 rangetab); | |
| 699 else | |
| 700 Fput_range_table (range, range, val, rangetab); | |
| 701 } | |
| 702 } | |
| 428 | 703 |
| 704 return rangetab; | |
| 705 } | |
| 706 | |
| 707 | |
| 708 /************************************************************************/ | |
| 709 /* Unified range tables */ | |
| 710 /************************************************************************/ | |
| 711 | |
| 712 /* A "unified range table" is a format for storing range tables | |
| 713 as contiguous blocks of memory. This is used by the regexp | |
| 714 code, which needs to use range tables to properly handle [] | |
| 715 constructs in the presence of extended characters but wants to | |
| 716 store an entire compiled pattern as a contiguous block of memory. | |
| 717 | |
| 718 Unified range tables are designed so that they can be placed | |
| 719 at an arbitrary (possibly mis-aligned) place in memory. | |
| 720 (Dealing with alignment is a pain in the ass.) | |
| 721 | |
| 722 WARNING: No provisions for garbage collection are currently made. | |
| 723 This means that there must not be any Lisp objects in a unified | |
| 724 range table that need to be marked for garbage collection. | |
| 725 Good candidates for objects that can go into a range table are | |
| 726 | |
| 727 -- numbers and characters (do not need to be marked) | |
| 728 -- nil, t (marked elsewhere) | |
| 729 -- charsets and coding systems (automatically marked because | |
| 730 they are in a marked list, | |
| 731 and can't be removed) | |
| 732 | |
| 733 Good but slightly less so: | |
| 734 | |
| 735 -- symbols (could be uninterned, but that is not likely) | |
| 736 | |
| 737 Somewhat less good: | |
| 738 | |
| 739 -- buffers, frames, devices (could get deleted) | |
| 740 | |
| 741 | |
| 742 It is expected that you work with range tables in the normal | |
| 743 format and then convert to unified format when you are done | |
| 744 making modifications. As such, no functions are provided | |
| 745 for modifying a unified range table. The only operations | |
| 746 you can do to unified range tables are | |
| 747 | |
| 748 -- look up a value | |
| 749 -- retrieve all the ranges in an iterative fashion | |
| 750 | |
| 751 */ | |
| 752 | |
| 753 /* The format of a unified range table is as follows: | |
| 754 | |
| 755 -- The first byte contains the number of bytes to skip to find the | |
| 756 actual start of the table. This deals with alignment constraints, | |
| 757 since the table might want to go at any arbitrary place in memory. | |
| 758 -- The next three bytes contain the number of bytes to skip (from the | |
| 759 *first* byte) to find the stuff after the table. It's stored in | |
| 760 little-endian format because that's how God intended things. We don't | |
| 761 necessarily start the stuff at the very end of the table because | |
| 762 we want to have at least ALIGNOF (EMACS_INT) extra space in case | |
| 763 we have to move the range table around. (It appears that some | |
| 764 architectures don't maintain alignment when reallocing.) | |
| 765 -- At the prescribed offset is a struct unified_range_table, containing | |
| 766 some number of `struct range_table_entry' entries. */ | |
| 767 | |
| 768 struct unified_range_table | |
| 769 { | |
| 770 int nentries; | |
|
4831
2e15c29cc2b3
fix bug in returning range table ends in unified range table code
Ben Wing <ben@xemacs.org>
parents:
4713
diff
changeset
|
771 enum range_table_type type; |
| 428 | 772 struct range_table_entry first; |
| 773 }; | |
| 774 | |
| 775 /* Return size in bytes needed to store the data in a range table. */ | |
| 776 | |
| 777 int | |
| 778 unified_range_table_bytes_needed (Lisp_Object rangetab) | |
| 779 { | |
| 780 return (sizeof (struct range_table_entry) * | |
| 781 (Dynarr_length (XRANGE_TABLE (rangetab)->entries) - 1) + | |
| 782 sizeof (struct unified_range_table) + | |
| 783 /* ALIGNOF a struct may be too big. */ | |
| 784 /* We have four bytes for the size numbers, and an extra | |
| 785 four or eight bytes for making sure we get the alignment | |
| 786 OK. */ | |
| 787 ALIGNOF (EMACS_INT) + 4); | |
| 788 } | |
| 789 | |
| 790 /* Convert a range table into unified format and store in DEST, | |
| 791 which must be able to hold the number of bytes returned by | |
| 792 range_table_bytes_needed(). */ | |
| 793 | |
| 794 void | |
| 795 unified_range_table_copy_data (Lisp_Object rangetab, void *dest) | |
| 796 { | |
| 797 /* We cast to the above structure rather than just casting to | |
| 798 char * and adding sizeof(int), because that will lead to | |
| 799 mis-aligned data on the Alpha machines. */ | |
| 800 struct unified_range_table *un; | |
| 801 range_table_entry_dynarr *rted = XRANGE_TABLE (rangetab)->entries; | |
| 802 int total_needed = unified_range_table_bytes_needed (rangetab); | |
| 826 | 803 void *new_dest = ALIGN_PTR ((char *) dest + 4, EMACS_INT); |
| 428 | 804 |
| 805 * (char *) dest = (char) ((char *) new_dest - (char *) dest); | |
| 806 * ((unsigned char *) dest + 1) = total_needed & 0xFF; | |
| 807 total_needed >>= 8; | |
| 808 * ((unsigned char *) dest + 2) = total_needed & 0xFF; | |
| 809 total_needed >>= 8; | |
| 810 * ((unsigned char *) dest + 3) = total_needed & 0xFF; | |
| 811 un = (struct unified_range_table *) new_dest; | |
| 812 un->nentries = Dynarr_length (rted); | |
|
4831
2e15c29cc2b3
fix bug in returning range table ends in unified range table code
Ben Wing <ben@xemacs.org>
parents:
4713
diff
changeset
|
813 un->type = XRANGE_TABLE (rangetab)->type; |
| 4967 | 814 memcpy (&un->first, Dynarr_begin (rted), |
| 428 | 815 sizeof (struct range_table_entry) * Dynarr_length (rted)); |
| 816 } | |
| 817 | |
| 818 /* Return number of bytes actually used by a unified range table. */ | |
| 819 | |
| 820 int | |
| 821 unified_range_table_bytes_used (void *unrangetab) | |
| 822 { | |
| 823 return ((* ((unsigned char *) unrangetab + 1)) | |
| 824 + ((* ((unsigned char *) unrangetab + 2)) << 8) | |
| 825 + ((* ((unsigned char *) unrangetab + 3)) << 16)); | |
| 826 } | |
| 827 | |
| 828 /* Make sure the table is aligned, and move it around if it's not. */ | |
| 829 static void | |
| 830 align_the_damn_table (void *unrangetab) | |
| 831 { | |
| 832 void *cur_dest = (char *) unrangetab + * (char *) unrangetab; | |
| 826 | 833 if (cur_dest != ALIGN_PTR (cur_dest, EMACS_INT)) |
| 428 | 834 { |
| 835 int count = (unified_range_table_bytes_used (unrangetab) - 4 | |
| 836 - ALIGNOF (EMACS_INT)); | |
| 837 /* Find the proper location, just like above. */ | |
| 826 | 838 void *new_dest = ALIGN_PTR ((char *) unrangetab + 4, EMACS_INT); |
| 428 | 839 /* memmove() works in the presence of overlapping data. */ |
| 840 memmove (new_dest, cur_dest, count); | |
| 841 * (char *) unrangetab = (char) ((char *) new_dest - (char *) unrangetab); | |
| 842 } | |
| 843 } | |
| 844 | |
| 845 /* Look up a value in a unified range table. */ | |
| 846 | |
| 847 Lisp_Object | |
| 848 unified_range_table_lookup (void *unrangetab, EMACS_INT pos, | |
| 849 Lisp_Object default_) | |
| 850 { | |
| 851 void *new_dest; | |
| 852 struct unified_range_table *un; | |
| 853 | |
| 854 align_the_damn_table (unrangetab); | |
| 855 new_dest = (char *) unrangetab + * (char *) unrangetab; | |
| 856 un = (struct unified_range_table *) new_dest; | |
| 857 | |
| 858 return get_range_table (pos, un->nentries, &un->first, default_); | |
| 859 } | |
| 860 | |
| 861 /* Return number of entries in a unified range table. */ | |
| 862 | |
| 863 int | |
| 864 unified_range_table_nentries (void *unrangetab) | |
| 865 { | |
| 866 void *new_dest; | |
| 867 struct unified_range_table *un; | |
| 868 | |
| 869 align_the_damn_table (unrangetab); | |
| 870 new_dest = (char *) unrangetab + * (char *) unrangetab; | |
| 871 un = (struct unified_range_table *) new_dest; | |
| 872 return un->nentries; | |
| 873 } | |
| 874 | |
| 875 /* Return the OFFSETth range (counting from 0) in UNRANGETAB. */ | |
| 876 void | |
| 877 unified_range_table_get_range (void *unrangetab, int offset, | |
| 878 EMACS_INT *min, EMACS_INT *max, | |
| 879 Lisp_Object *val) | |
| 880 { | |
| 881 void *new_dest; | |
| 882 struct unified_range_table *un; | |
| 883 struct range_table_entry *tab; | |
| 884 | |
| 885 align_the_damn_table (unrangetab); | |
| 886 new_dest = (char *) unrangetab + * (char *) unrangetab; | |
| 887 un = (struct unified_range_table *) new_dest; | |
| 888 | |
| 889 assert (offset >= 0 && offset < un->nentries); | |
| 890 tab = (&un->first) + offset; | |
| 891 *min = tab->first; | |
| 892 *max = tab->last; | |
| 893 *val = tab->val; | |
|
4831
2e15c29cc2b3
fix bug in returning range table ends in unified range table code
Ben Wing <ben@xemacs.org>
parents:
4713
diff
changeset
|
894 |
|
2e15c29cc2b3
fix bug in returning range table ends in unified range table code
Ben Wing <ben@xemacs.org>
parents:
4713
diff
changeset
|
895 internal_to_external_adjust_ends (un->type, min, max); |
| 428 | 896 } |
| 897 | |
| 898 | |
| 899 /************************************************************************/ | |
| 900 /* Initialization */ | |
| 901 /************************************************************************/ | |
| 902 | |
| 903 void | |
| 904 syms_of_rangetab (void) | |
| 905 { | |
|
5117
3742ea8250b5
Checking in final CVS version of workspace 'ben-lisp-object'
Ben Wing <ben@xemacs.org>
parents:
3017
diff
changeset
|
906 INIT_LISP_OBJECT (range_table); |
| 442 | 907 |
| 563 | 908 DEFSYMBOL_MULTIWORD_PREDICATE (Qrange_tablep); |
| 909 DEFSYMBOL (Qrange_table); | |
| 428 | 910 |
| 2421 | 911 DEFSYMBOL (Qstart_closed_end_open); |
| 912 DEFSYMBOL (Qstart_open_end_open); | |
| 913 DEFSYMBOL (Qstart_closed_end_closed); | |
| 914 DEFSYMBOL (Qstart_open_end_closed); | |
| 915 | |
| 428 | 916 DEFSUBR (Frange_table_p); |
| 2421 | 917 DEFSUBR (Frange_table_type); |
| 428 | 918 DEFSUBR (Fmake_range_table); |
| 919 DEFSUBR (Fcopy_range_table); | |
| 920 DEFSUBR (Fget_range_table); | |
| 921 DEFSUBR (Fput_range_table); | |
| 922 DEFSUBR (Fremove_range_table); | |
| 923 DEFSUBR (Fclear_range_table); | |
| 924 DEFSUBR (Fmap_range_table); | |
| 925 } | |
| 926 | |
| 927 void | |
| 928 structure_type_create_rangetab (void) | |
| 929 { | |
| 930 struct structure_type *st; | |
| 931 | |
| 932 st = define_structure_type (Qrange_table, 0, rangetab_instantiate); | |
| 933 | |
| 934 define_structure_type_keyword (st, Qdata, rangetab_data_validate); | |
| 2421 | 935 define_structure_type_keyword (st, Qtype, rangetab_type_validate); |
| 428 | 936 } |