Mercurial > hg > xemacs-beta
annotate src/chartab.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 | 71ee43b8a74d |
| rev | line source |
|---|---|
| 428 | 1 /* XEmacs routines to deal with char tables. |
| 2 Copyright (C) 1992, 1995 Free Software Foundation, Inc. | |
| 3 Copyright (C) 1995 Sun Microsystems, Inc. | |
| 1296 | 4 Copyright (C) 1995, 1996, 2002, 2003 Ben Wing. |
| 428 | 5 Copyright (C) 1995, 1997, 1999 Electrotechnical Laboratory, JAPAN. |
| 6 Licensed to the Free Software Foundation. | |
| 7 | |
| 8 This file is part of XEmacs. | |
| 9 | |
| 10 XEmacs is free software; you can redistribute it and/or modify it | |
| 11 under the terms of the GNU General Public License as published by the | |
| 12 Free Software Foundation; either version 2, or (at your option) any | |
| 13 later version. | |
| 14 | |
| 15 XEmacs is distributed in the hope that it will be useful, but WITHOUT | |
| 16 ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or | |
| 17 FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License | |
| 18 for more details. | |
| 19 | |
| 20 You should have received a copy of the GNU General Public License | |
| 21 along with XEmacs; see the file COPYING. If not, write to | |
| 22 the Free Software Foundation, Inc., 59 Temple Place - Suite 330, | |
| 23 Boston, MA 02111-1307, USA. */ | |
| 24 | |
| 25 /* Synched up with: Mule 2.3. Not synched with FSF. | |
| 26 | |
| 27 This file was written independently of the FSF implementation, | |
| 28 and is not compatible. */ | |
| 29 | |
| 30 /* Authorship: | |
| 31 | |
| 32 Ben Wing: wrote, for 19.13 (Mule). Some category table stuff | |
| 33 loosely based on the original Mule. | |
| 34 Jareth Hein: fixed a couple of bugs in the implementation, and | |
| 35 added regex support for categories with check_category_at | |
| 36 */ | |
| 37 | |
| 38 #include <config.h> | |
| 39 #include "lisp.h" | |
| 40 | |
| 41 #include "buffer.h" | |
| 42 #include "chartab.h" | |
| 43 #include "syntax.h" | |
| 44 | |
| 45 Lisp_Object Qchar_tablep, Qchar_table; | |
| 46 | |
| 47 Lisp_Object Vall_syntax_tables; | |
| 48 | |
| 49 #ifdef MULE | |
| 50 Lisp_Object Qcategory_table_p; | |
| 51 Lisp_Object Qcategory_designator_p; | |
| 52 Lisp_Object Qcategory_table_value_p; | |
| 53 | |
| 54 Lisp_Object Vstandard_category_table; | |
| 55 | |
| 56 /* Variables to determine word boundary. */ | |
| 57 Lisp_Object Vword_combining_categories, Vword_separating_categories; | |
| 58 #endif /* MULE */ | |
| 59 | |
| 826 | 60 static int check_valid_char_table_value (Lisp_Object value, |
| 61 enum char_table_type type, | |
| 62 Error_Behavior errb); | |
| 63 | |
| 428 | 64 |
| 65 /* A char table maps from ranges of characters to values. | |
| 66 | |
| 67 Implementing a general data structure that maps from arbitrary | |
| 68 ranges of numbers to values is tricky to do efficiently. As it | |
| 69 happens, it should suffice (and is usually more convenient, anyway) | |
| 70 when dealing with characters to restrict the sorts of ranges that | |
| 71 can be assigned values, as follows: | |
| 72 | |
| 73 1) All characters. | |
| 74 2) All characters in a charset. | |
| 75 3) All characters in a particular row of a charset, where a "row" | |
| 76 means all characters with the same first byte. | |
| 77 4) A particular character in a charset. | |
| 78 | |
| 79 We use char tables to generalize the 256-element vectors now | |
| 80 littering the Emacs code. | |
| 81 | |
| 82 Possible uses (all should be converted at some point): | |
| 83 | |
| 84 1) category tables | |
| 85 2) syntax tables | |
| 86 3) display tables | |
| 87 4) case tables | |
| 88 5) keyboard-translate-table? | |
| 89 | |
| 90 We provide an | |
| 91 abstract type to generalize the Emacs vectors and Mule | |
| 92 vectors-of-vectors goo. | |
| 93 */ | |
| 94 | |
| 95 /************************************************************************/ | |
| 96 /* Char Table object */ | |
| 97 /************************************************************************/ | |
| 98 | |
| 99 #ifdef MULE | |
| 100 | |
| 101 static Lisp_Object | |
| 102 mark_char_table_entry (Lisp_Object obj) | |
| 103 { | |
| 440 | 104 Lisp_Char_Table_Entry *cte = XCHAR_TABLE_ENTRY (obj); |
| 428 | 105 int i; |
| 106 | |
| 107 for (i = 0; i < 96; i++) | |
| 108 { | |
| 109 mark_object (cte->level2[i]); | |
| 110 } | |
| 111 return Qnil; | |
| 112 } | |
| 113 | |
| 114 static int | |
|
4906
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4580
diff
changeset
|
115 char_table_entry_equal (Lisp_Object obj1, Lisp_Object obj2, int depth, |
|
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4580
diff
changeset
|
116 int foldcase) |
| 428 | 117 { |
| 440 | 118 Lisp_Char_Table_Entry *cte1 = XCHAR_TABLE_ENTRY (obj1); |
| 119 Lisp_Char_Table_Entry *cte2 = XCHAR_TABLE_ENTRY (obj2); | |
| 428 | 120 int i; |
| 121 | |
| 122 for (i = 0; i < 96; i++) | |
|
4906
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4580
diff
changeset
|
123 if (!internal_equal_0 (cte1->level2[i], cte2->level2[i], depth + 1, |
|
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4580
diff
changeset
|
124 foldcase)) |
| 428 | 125 return 0; |
| 126 | |
| 127 return 1; | |
| 128 } | |
| 129 | |
| 665 | 130 static Hashcode |
| 428 | 131 char_table_entry_hash (Lisp_Object obj, int depth) |
| 132 { | |
| 440 | 133 Lisp_Char_Table_Entry *cte = XCHAR_TABLE_ENTRY (obj); |
| 428 | 134 |
| 826 | 135 return internal_array_hash (cte->level2, 96, depth + 1); |
| 428 | 136 } |
| 137 | |
| 1204 | 138 static const struct memory_description char_table_entry_description[] = { |
| 440 | 139 { XD_LISP_OBJECT_ARRAY, offsetof (Lisp_Char_Table_Entry, level2), 96 }, |
| 428 | 140 { XD_END } |
| 141 }; | |
| 142 | |
|
5118
e0db3c197671
merge up to latest default branch, doesn't compile yet
Ben Wing <ben@xemacs.org>
diff
changeset
|
143 DEFINE_DUMPABLE_LISP_OBJECT ("char-table-entry", char_table_entry, |
|
5124
623d57b7fbe8
separate regular and disksave finalization, print method fixes.
Ben Wing <ben@xemacs.org>
parents:
5120
diff
changeset
|
144 mark_char_table_entry, internal_object_printer, |
|
5118
e0db3c197671
merge up to latest default branch, doesn't compile yet
Ben Wing <ben@xemacs.org>
diff
changeset
|
145 0, char_table_entry_equal, |
|
e0db3c197671
merge up to latest default branch, doesn't compile yet
Ben Wing <ben@xemacs.org>
diff
changeset
|
146 char_table_entry_hash, |
|
e0db3c197671
merge up to latest default branch, doesn't compile yet
Ben Wing <ben@xemacs.org>
diff
changeset
|
147 char_table_entry_description, |
|
e0db3c197671
merge up to latest default branch, doesn't compile yet
Ben Wing <ben@xemacs.org>
diff
changeset
|
148 Lisp_Char_Table_Entry); |
| 934 | 149 |
| 428 | 150 #endif /* MULE */ |
| 151 | |
| 152 static Lisp_Object | |
| 153 mark_char_table (Lisp_Object obj) | |
| 154 { | |
| 440 | 155 Lisp_Char_Table *ct = XCHAR_TABLE (obj); |
| 428 | 156 int i; |
| 157 | |
| 158 for (i = 0; i < NUM_ASCII_CHARS; i++) | |
| 159 mark_object (ct->ascii[i]); | |
| 160 #ifdef MULE | |
| 161 for (i = 0; i < NUM_LEADING_BYTES; i++) | |
| 162 mark_object (ct->level1[i]); | |
| 163 #endif | |
| 793 | 164 mark_object (ct->parent); |
| 165 mark_object (ct->default_); | |
| 428 | 166 return ct->mirror_table; |
| 167 } | |
| 168 | |
| 169 /* WARNING: All functions of this nature need to be written extremely | |
| 170 carefully to avoid crashes during GC. Cf. prune_specifiers() | |
| 171 and prune_weak_hash_tables(). */ | |
| 172 | |
| 173 void | |
| 174 prune_syntax_tables (void) | |
| 175 { | |
| 176 Lisp_Object rest, prev = Qnil; | |
| 177 | |
| 178 for (rest = Vall_syntax_tables; | |
| 179 !NILP (rest); | |
| 180 rest = XCHAR_TABLE (rest)->next_table) | |
| 181 { | |
| 182 if (! marked_p (rest)) | |
| 183 { | |
| 184 /* This table is garbage. Remove it from the list. */ | |
| 185 if (NILP (prev)) | |
| 186 Vall_syntax_tables = XCHAR_TABLE (rest)->next_table; | |
| 187 else | |
| 188 XCHAR_TABLE (prev)->next_table = | |
| 189 XCHAR_TABLE (rest)->next_table; | |
| 190 } | |
| 191 } | |
| 192 } | |
| 193 | |
| 194 static Lisp_Object | |
| 195 char_table_type_to_symbol (enum char_table_type type) | |
| 196 { | |
| 197 switch (type) | |
| 198 { | |
| 2500 | 199 default: ABORT(); |
| 428 | 200 case CHAR_TABLE_TYPE_GENERIC: return Qgeneric; |
| 201 case CHAR_TABLE_TYPE_SYNTAX: return Qsyntax; | |
| 202 case CHAR_TABLE_TYPE_DISPLAY: return Qdisplay; | |
| 203 case CHAR_TABLE_TYPE_CHAR: return Qchar; | |
| 204 #ifdef MULE | |
| 205 case CHAR_TABLE_TYPE_CATEGORY: return Qcategory; | |
| 206 #endif | |
| 207 } | |
| 208 } | |
| 209 | |
| 210 static enum char_table_type | |
| 211 symbol_to_char_table_type (Lisp_Object symbol) | |
| 212 { | |
| 213 CHECK_SYMBOL (symbol); | |
| 214 | |
| 215 if (EQ (symbol, Qgeneric)) return CHAR_TABLE_TYPE_GENERIC; | |
| 216 if (EQ (symbol, Qsyntax)) return CHAR_TABLE_TYPE_SYNTAX; | |
| 217 if (EQ (symbol, Qdisplay)) return CHAR_TABLE_TYPE_DISPLAY; | |
| 218 if (EQ (symbol, Qchar)) return CHAR_TABLE_TYPE_CHAR; | |
| 219 #ifdef MULE | |
| 220 if (EQ (symbol, Qcategory)) return CHAR_TABLE_TYPE_CATEGORY; | |
| 221 #endif | |
| 222 | |
| 563 | 223 invalid_constant ("Unrecognized char table type", symbol); |
| 1204 | 224 RETURN_NOT_REACHED (CHAR_TABLE_TYPE_GENERIC); |
| 428 | 225 } |
| 226 | |
| 227 static void | |
| 826 | 228 decode_char_table_range (Lisp_Object range, struct chartab_range *outrange) |
| 428 | 229 { |
| 4932 | 230 xzero (*outrange); |
| 826 | 231 if (EQ (range, Qt)) |
| 232 outrange->type = CHARTAB_RANGE_ALL; | |
| 233 else if (CHAR_OR_CHAR_INTP (range)) | |
| 234 { | |
| 235 outrange->type = CHARTAB_RANGE_CHAR; | |
| 236 outrange->ch = XCHAR_OR_CHAR_INT (range); | |
| 237 } | |
| 238 #ifndef MULE | |
| 428 | 239 else |
| 826 | 240 sferror ("Range must be t or a character", range); |
| 241 #else /* MULE */ | |
| 242 else if (VECTORP (range)) | |
| 243 { | |
| 244 Lisp_Vector *vec = XVECTOR (range); | |
| 245 Lisp_Object *elts = vector_data (vec); | |
| 246 if (vector_length (vec) != 2) | |
| 247 sferror ("Length of charset row vector must be 2", | |
| 248 range); | |
| 249 outrange->type = CHARTAB_RANGE_ROW; | |
| 250 outrange->charset = Fget_charset (elts[0]); | |
| 251 CHECK_INT (elts[1]); | |
| 252 outrange->row = XINT (elts[1]); | |
| 253 switch (XCHARSET_TYPE (outrange->charset)) | |
| 254 { | |
| 255 case CHARSET_TYPE_94: | |
| 256 case CHARSET_TYPE_96: | |
| 257 sferror ("Charset in row vector must be multi-byte", | |
| 258 outrange->charset); | |
| 259 case CHARSET_TYPE_94X94: | |
| 260 check_int_range (outrange->row, 33, 126); | |
| 261 break; | |
| 262 case CHARSET_TYPE_96X96: | |
| 263 check_int_range (outrange->row, 32, 127); | |
| 264 break; | |
| 265 default: | |
| 2500 | 266 ABORT (); |
| 826 | 267 } |
| 268 } | |
| 269 else | |
| 270 { | |
| 271 if (!CHARSETP (range) && !SYMBOLP (range)) | |
| 272 sferror | |
| 273 ("Char table range must be t, charset, char, or vector", range); | |
| 274 outrange->type = CHARTAB_RANGE_CHARSET; | |
| 275 outrange->charset = Fget_charset (range); | |
| 276 } | |
| 277 #endif /* MULE */ | |
| 428 | 278 } |
| 279 | |
| 826 | 280 static Lisp_Object |
| 281 encode_char_table_range (struct chartab_range *range) | |
| 428 | 282 { |
| 826 | 283 switch (range->type) |
| 428 | 284 { |
| 826 | 285 case CHARTAB_RANGE_ALL: |
| 286 return Qt; | |
| 287 | |
| 288 #ifdef MULE | |
| 289 case CHARTAB_RANGE_CHARSET: | |
| 290 return XCHARSET_NAME (Fget_charset (range->charset)); | |
| 428 | 291 |
| 826 | 292 case CHARTAB_RANGE_ROW: |
| 293 return vector2 (XCHARSET_NAME (Fget_charset (range->charset)), | |
| 294 make_int (range->row)); | |
| 295 #endif | |
| 296 case CHARTAB_RANGE_CHAR: | |
| 297 return make_char (range->ch); | |
| 298 default: | |
| 2500 | 299 ABORT (); |
| 428 | 300 } |
| 826 | 301 return Qnil; /* not reached */ |
| 428 | 302 } |
| 303 | |
| 826 | 304 struct ptemap |
| 428 | 305 { |
| 826 | 306 Lisp_Object printcharfun; |
| 307 int first; | |
| 308 }; | |
| 428 | 309 |
| 826 | 310 static int |
| 2286 | 311 print_table_entry (struct chartab_range *range, Lisp_Object UNUSED (table), |
| 826 | 312 Lisp_Object val, void *arg) |
| 313 { | |
| 314 struct ptemap *a = (struct ptemap *) arg; | |
| 315 struct gcpro gcpro1; | |
| 316 Lisp_Object lisprange; | |
| 317 if (!a->first) | |
|
4952
19a72041c5ed
Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents:
4932
diff
changeset
|
318 write_ascstring (a->printcharfun, " "); |
| 826 | 319 a->first = 0; |
| 320 lisprange = encode_char_table_range (range); | |
| 321 GCPRO1 (lisprange); | |
|
4580
1d11ecca9cd0
Print char table values correctly.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4469
diff
changeset
|
322 write_fmt_string_lisp (a->printcharfun, "%s %S", 2, lisprange, val); |
| 826 | 323 UNGCPRO; |
| 324 return 0; | |
| 428 | 325 } |
| 326 | |
| 327 static void | |
| 2286 | 328 print_char_table (Lisp_Object obj, Lisp_Object printcharfun, |
| 329 int UNUSED (escapeflag)) | |
| 428 | 330 { |
| 440 | 331 Lisp_Char_Table *ct = XCHAR_TABLE (obj); |
| 826 | 332 struct chartab_range range; |
| 333 struct ptemap arg; | |
| 334 | |
| 335 range.type = CHARTAB_RANGE_ALL; | |
| 336 arg.printcharfun = printcharfun; | |
| 337 arg.first = 1; | |
| 428 | 338 |
| 793 | 339 write_fmt_string_lisp (printcharfun, "#s(char-table type %s data (", |
| 340 1, char_table_type_to_symbol (ct->type)); | |
| 826 | 341 map_char_table (obj, &range, print_table_entry, &arg); |
|
4952
19a72041c5ed
Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents:
4932
diff
changeset
|
342 write_ascstring (printcharfun, "))"); |
| 428 | 343 |
| 826 | 344 /* #### need to print and read the default; but that will allow the |
| 345 default to be modified, which we don't (yet) support -- but FSF does */ | |
| 428 | 346 } |
| 347 | |
| 348 static int | |
|
4906
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4580
diff
changeset
|
349 char_table_equal (Lisp_Object obj1, Lisp_Object obj2, int depth, int foldcase) |
| 428 | 350 { |
| 440 | 351 Lisp_Char_Table *ct1 = XCHAR_TABLE (obj1); |
| 352 Lisp_Char_Table *ct2 = XCHAR_TABLE (obj2); | |
| 428 | 353 int i; |
| 354 | |
| 355 if (CHAR_TABLE_TYPE (ct1) != CHAR_TABLE_TYPE (ct2)) | |
| 356 return 0; | |
| 357 | |
| 358 for (i = 0; i < NUM_ASCII_CHARS; i++) | |
|
4906
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4580
diff
changeset
|
359 if (!internal_equal_0 (ct1->ascii[i], ct2->ascii[i], depth + 1, foldcase)) |
| 428 | 360 return 0; |
| 361 | |
| 362 #ifdef MULE | |
| 363 for (i = 0; i < NUM_LEADING_BYTES; i++) | |
|
4906
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4580
diff
changeset
|
364 if (!internal_equal_0 (ct1->level1[i], ct2->level1[i], depth + 1, foldcase)) |
| 428 | 365 return 0; |
| 366 #endif /* MULE */ | |
| 367 | |
|
4906
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4580
diff
changeset
|
368 return internal_equal_0 (ct1->default_, ct2->default_, depth + 1, foldcase); |
| 428 | 369 } |
| 370 | |
| 665 | 371 static Hashcode |
| 428 | 372 char_table_hash (Lisp_Object obj, int depth) |
| 373 { | |
| 440 | 374 Lisp_Char_Table *ct = XCHAR_TABLE (obj); |
| 665 | 375 Hashcode hashval = internal_array_hash (ct->ascii, NUM_ASCII_CHARS, |
| 826 | 376 depth + 1); |
| 428 | 377 #ifdef MULE |
| 378 hashval = HASH2 (hashval, | |
| 826 | 379 internal_array_hash (ct->level1, NUM_LEADING_BYTES, |
| 380 depth + 1)); | |
| 428 | 381 #endif /* MULE */ |
| 826 | 382 return HASH2 (hashval, internal_hash (ct->default_, depth + 1)); |
| 428 | 383 } |
| 384 | |
| 1204 | 385 static const struct memory_description char_table_description[] = { |
| 440 | 386 { XD_LISP_OBJECT_ARRAY, offsetof (Lisp_Char_Table, ascii), NUM_ASCII_CHARS }, |
| 428 | 387 #ifdef MULE |
| 440 | 388 { XD_LISP_OBJECT_ARRAY, offsetof (Lisp_Char_Table, level1), NUM_LEADING_BYTES }, |
| 428 | 389 #endif |
| 793 | 390 { XD_LISP_OBJECT, offsetof (Lisp_Char_Table, parent) }, |
| 391 { XD_LISP_OBJECT, offsetof (Lisp_Char_Table, default_) }, | |
| 440 | 392 { XD_LISP_OBJECT, offsetof (Lisp_Char_Table, mirror_table) }, |
| 393 { XD_LO_LINK, offsetof (Lisp_Char_Table, next_table) }, | |
| 428 | 394 { XD_END } |
| 395 }; | |
| 396 | |
|
5118
e0db3c197671
merge up to latest default branch, doesn't compile yet
Ben Wing <ben@xemacs.org>
diff
changeset
|
397 DEFINE_DUMPABLE_LISP_OBJECT ("char-table", char_table, |
|
e0db3c197671
merge up to latest default branch, doesn't compile yet
Ben Wing <ben@xemacs.org>
diff
changeset
|
398 mark_char_table, print_char_table, 0, |
|
e0db3c197671
merge up to latest default branch, doesn't compile yet
Ben Wing <ben@xemacs.org>
diff
changeset
|
399 char_table_equal, char_table_hash, |
|
e0db3c197671
merge up to latest default branch, doesn't compile yet
Ben Wing <ben@xemacs.org>
diff
changeset
|
400 char_table_description, |
|
e0db3c197671
merge up to latest default branch, doesn't compile yet
Ben Wing <ben@xemacs.org>
diff
changeset
|
401 Lisp_Char_Table); |
| 428 | 402 |
| 403 DEFUN ("char-table-p", Fchar_table_p, 1, 1, 0, /* | |
| 404 Return non-nil if OBJECT is a char table. | |
| 405 */ | |
| 406 (object)) | |
| 407 { | |
| 408 return CHAR_TABLEP (object) ? Qt : Qnil; | |
| 409 } | |
| 410 | |
| 411 DEFUN ("char-table-type-list", Fchar_table_type_list, 0, 0, 0, /* | |
| 412 Return a list of the recognized char table types. | |
| 800 | 413 See `make-char-table'. |
| 428 | 414 */ |
| 415 ()) | |
| 416 { | |
| 417 #ifdef MULE | |
| 418 return list5 (Qchar, Qcategory, Qdisplay, Qgeneric, Qsyntax); | |
| 419 #else | |
| 420 return list4 (Qchar, Qdisplay, Qgeneric, Qsyntax); | |
| 421 #endif | |
| 422 } | |
| 423 | |
| 424 DEFUN ("valid-char-table-type-p", Fvalid_char_table_type_p, 1, 1, 0, /* | |
| 425 Return t if TYPE if a recognized char table type. | |
| 800 | 426 See `make-char-table'. |
| 428 | 427 */ |
| 428 (type)) | |
| 429 { | |
| 430 return (EQ (type, Qchar) || | |
| 431 #ifdef MULE | |
| 432 EQ (type, Qcategory) || | |
| 433 #endif | |
| 434 EQ (type, Qdisplay) || | |
| 435 EQ (type, Qgeneric) || | |
| 436 EQ (type, Qsyntax)) ? Qt : Qnil; | |
| 437 } | |
| 438 | |
| 439 DEFUN ("char-table-type", Fchar_table_type, 1, 1, 0, /* | |
| 444 | 440 Return the type of CHAR-TABLE. |
| 800 | 441 See `make-char-table'. |
| 428 | 442 */ |
| 444 | 443 (char_table)) |
| 428 | 444 { |
| 444 | 445 CHECK_CHAR_TABLE (char_table); |
| 446 return char_table_type_to_symbol (XCHAR_TABLE (char_table)->type); | |
| 428 | 447 } |
| 448 | |
| 1296 | 449 static void |
| 450 set_char_table_dirty (Lisp_Object table) | |
| 451 { | |
| 452 assert (!XCHAR_TABLE (table)->mirror_table_p); | |
| 453 XCHAR_TABLE (XCHAR_TABLE (table)->mirror_table)->dirty = 1; | |
| 454 } | |
| 455 | |
| 428 | 456 void |
| 826 | 457 set_char_table_default (Lisp_Object table, Lisp_Object value) |
| 458 { | |
| 459 Lisp_Char_Table *ct = XCHAR_TABLE (table); | |
| 460 ct->default_ = value; | |
| 461 if (ct->type == CHAR_TABLE_TYPE_SYNTAX) | |
| 1296 | 462 set_char_table_dirty (table); |
| 826 | 463 } |
| 464 | |
| 465 static void | |
| 440 | 466 fill_char_table (Lisp_Char_Table *ct, Lisp_Object value) |
| 428 | 467 { |
| 468 int i; | |
| 469 | |
| 470 for (i = 0; i < NUM_ASCII_CHARS; i++) | |
| 471 ct->ascii[i] = value; | |
| 472 #ifdef MULE | |
| 473 for (i = 0; i < NUM_LEADING_BYTES; i++) | |
| 1296 | 474 { |
| 1330 | 475 /* Don't get stymied when initting the table, or when trying to |
| 476 free a pdump object. */ | |
| 1296 | 477 if (!EQ (ct->level1[i], Qnull_pointer) && |
| 1330 | 478 CHAR_TABLE_ENTRYP (ct->level1[i]) && |
| 479 !OBJECT_DUMPED_P (ct->level1[1])) | |
|
5127
a9c41067dd88
more cleanups, terminology clarification, lots of doc work
Ben Wing <ben@xemacs.org>
parents:
5125
diff
changeset
|
480 free_normal_lisp_object (ct->level1[i]); |
| 1296 | 481 ct->level1[i] = value; |
| 482 } | |
| 428 | 483 #endif /* MULE */ |
| 484 | |
| 485 if (ct->type == CHAR_TABLE_TYPE_SYNTAX) | |
| 1296 | 486 set_char_table_dirty (wrap_char_table (ct)); |
| 428 | 487 } |
| 488 | |
| 489 DEFUN ("reset-char-table", Freset_char_table, 1, 1, 0, /* | |
| 444 | 490 Reset CHAR-TABLE to its default state. |
| 428 | 491 */ |
| 444 | 492 (char_table)) |
| 428 | 493 { |
| 440 | 494 Lisp_Char_Table *ct; |
| 826 | 495 Lisp_Object def; |
| 428 | 496 |
| 444 | 497 CHECK_CHAR_TABLE (char_table); |
| 498 ct = XCHAR_TABLE (char_table); | |
| 428 | 499 |
| 500 switch (ct->type) | |
| 501 { | |
| 502 case CHAR_TABLE_TYPE_CHAR: | |
| 826 | 503 def = make_char (0); |
| 428 | 504 break; |
| 505 case CHAR_TABLE_TYPE_DISPLAY: | |
| 506 case CHAR_TABLE_TYPE_GENERIC: | |
| 507 #ifdef MULE | |
| 508 case CHAR_TABLE_TYPE_CATEGORY: | |
| 509 #endif /* MULE */ | |
| 826 | 510 def = Qnil; |
| 428 | 511 break; |
| 512 | |
| 513 case CHAR_TABLE_TYPE_SYNTAX: | |
| 826 | 514 def = make_int (Sinherit); |
| 428 | 515 break; |
| 516 | |
| 517 default: | |
| 2500 | 518 ABORT (); |
| 826 | 519 def = Qnil; |
| 520 break; | |
| 428 | 521 } |
| 522 | |
| 826 | 523 /* Avoid doubly updating the syntax table by setting the default ourselves, |
| 524 since set_char_table_default() also updates. */ | |
| 525 ct->default_ = def; | |
| 526 fill_char_table (ct, Qunbound); | |
| 527 | |
| 428 | 528 return Qnil; |
| 529 } | |
| 530 | |
| 531 DEFUN ("make-char-table", Fmake_char_table, 1, 1, 0, /* | |
| 532 Return a new, empty char table of type TYPE. | |
| 800 | 533 |
| 534 A char table is a table that maps characters (or ranges of characters) | |
| 535 to values. Char tables are specialized for characters, only allowing | |
| 536 particular sorts of ranges to be assigned values. Although this | |
| 537 loses in generality, it makes for extremely fast (constant-time) | |
| 538 lookups, and thus is feasible for applications that do an extremely | |
| 539 large number of lookups (e.g. scanning a buffer for a character in | |
| 540 a particular syntax, where a lookup in the syntax table must occur | |
| 541 once per character). | |
| 542 | |
| 543 When Mule support exists, the types of ranges that can be assigned | |
| 544 values are | |
| 545 | |
| 2714 | 546 -- all characters (represented by t) |
| 800 | 547 -- an entire charset |
| 2714 | 548 -- a single row in a two-octet charset (represented by a vector of two |
| 549 elements: a two-octet charset and a row number; the row must be an | |
| 550 integer, not a character) | |
| 800 | 551 -- a single character |
| 552 | |
| 553 When Mule support is not present, the types of ranges that can be | |
| 554 assigned values are | |
| 555 | |
| 2714 | 556 -- all characters (represented by t) |
| 800 | 557 -- a single character |
| 558 | |
| 559 To create a char table, use `make-char-table'. | |
| 560 To modify a char table, use `put-char-table' or `remove-char-table'. | |
| 561 To retrieve the value for a particular character, use `get-char-table'. | |
| 826 | 562 See also `map-char-table', `reset-char-table', `copy-char-table', |
| 800 | 563 `char-table-p', `valid-char-table-type-p', `char-table-type-list', |
| 564 `valid-char-table-value-p', and `check-char-table-value'. | |
| 565 | |
| 566 Each char table type is used for a different purpose and allows different | |
| 567 sorts of values. The different char table types are | |
| 568 | |
| 569 `category' | |
|
4469
c661944aa259
Fill out docstrings for #'translate-region, #'make-char-table.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3881
diff
changeset
|
570 Used for category tables, which specify the regexp categories that a |
|
c661944aa259
Fill out docstrings for #'translate-region, #'make-char-table.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3881
diff
changeset
|
571 character is in. The valid values are nil or a bit vector of 95 |
|
c661944aa259
Fill out docstrings for #'translate-region, #'make-char-table.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3881
diff
changeset
|
572 elements, and values default to nil. Higher-level Lisp functions |
|
c661944aa259
Fill out docstrings for #'translate-region, #'make-char-table.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3881
diff
changeset
|
573 are provided for working with category tables. Currently categories |
| 800 | 574 and category tables only exist when Mule support is present. |
| 575 `char' | |
|
4469
c661944aa259
Fill out docstrings for #'translate-region, #'make-char-table.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3881
diff
changeset
|
576 A generalized char table, for mapping from one character to another. |
|
c661944aa259
Fill out docstrings for #'translate-region, #'make-char-table.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3881
diff
changeset
|
577 Used for case tables, syntax matching tables, |
|
c661944aa259
Fill out docstrings for #'translate-region, #'make-char-table.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3881
diff
changeset
|
578 `keyboard-translate-table', etc. The valid values are characters, |
|
c661944aa259
Fill out docstrings for #'translate-region, #'make-char-table.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3881
diff
changeset
|
579 and the default result given by `get-char-table' if a value hasn't |
|
c661944aa259
Fill out docstrings for #'translate-region, #'make-char-table.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3881
diff
changeset
|
580 been set for a given character or for a range that includes it, is |
|
c661944aa259
Fill out docstrings for #'translate-region, #'make-char-table.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3881
diff
changeset
|
581 ?\x00. |
| 800 | 582 `generic' |
|
4469
c661944aa259
Fill out docstrings for #'translate-region, #'make-char-table.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3881
diff
changeset
|
583 An even more generalized char table, for mapping from a character to |
|
c661944aa259
Fill out docstrings for #'translate-region, #'make-char-table.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3881
diff
changeset
|
584 anything. The default result given by `get-char-table' is nil. |
| 800 | 585 `display' |
|
4469
c661944aa259
Fill out docstrings for #'translate-region, #'make-char-table.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3881
diff
changeset
|
586 Used for display tables, which specify how a particular character is |
|
c661944aa259
Fill out docstrings for #'translate-region, #'make-char-table.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3881
diff
changeset
|
587 to appear when displayed. #### Not yet implemented; currently, the |
|
c661944aa259
Fill out docstrings for #'translate-region, #'make-char-table.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3881
diff
changeset
|
588 display table code uses generic char tables, and it's not clear that |
|
c661944aa259
Fill out docstrings for #'translate-region, #'make-char-table.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3881
diff
changeset
|
589 implementing this char table type would be useful. |
| 800 | 590 `syntax' |
| 591 Used for syntax tables, which specify the syntax of a particular | |
| 592 character. Higher-level Lisp functions are provided for | |
|
4469
c661944aa259
Fill out docstrings for #'translate-region, #'make-char-table.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3881
diff
changeset
|
593 working with syntax tables. The valid values are integers, and the |
|
c661944aa259
Fill out docstrings for #'translate-region, #'make-char-table.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3881
diff
changeset
|
594 default result given by `get-char-table' is the syntax code for |
|
c661944aa259
Fill out docstrings for #'translate-region, #'make-char-table.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3881
diff
changeset
|
595 `inherit'. |
| 428 | 596 */ |
| 597 (type)) | |
| 598 { | |
|
5127
a9c41067dd88
more cleanups, terminology clarification, lots of doc work
Ben Wing <ben@xemacs.org>
parents:
5125
diff
changeset
|
599 Lisp_Object obj = ALLOC_NORMAL_LISP_OBJECT (char_table); |
|
5117
3742ea8250b5
Checking in final CVS version of workspace 'ben-lisp-object'
Ben Wing <ben@xemacs.org>
parents:
3025
diff
changeset
|
600 Lisp_Char_Table *ct = XCHAR_TABLE (obj); |
| 428 | 601 enum char_table_type ty = symbol_to_char_table_type (type); |
| 602 | |
| 603 ct->type = ty; | |
| 604 if (ty == CHAR_TABLE_TYPE_SYNTAX) | |
| 605 { | |
| 826 | 606 /* Qgeneric not Qsyntax because a syntax table has a mirror table |
| 607 and we don't want infinite recursion */ | |
| 428 | 608 ct->mirror_table = Fmake_char_table (Qgeneric); |
| 3145 | 609 set_char_table_default (ct->mirror_table, make_int (Sword)); |
| 1296 | 610 XCHAR_TABLE (ct->mirror_table)->mirror_table_p = 1; |
| 611 XCHAR_TABLE (ct->mirror_table)->mirror_table = obj; | |
| 428 | 612 } |
| 613 else | |
| 614 ct->mirror_table = Qnil; | |
| 615 ct->next_table = Qnil; | |
| 793 | 616 ct->parent = Qnil; |
| 617 ct->default_ = Qnil; | |
| 428 | 618 if (ty == CHAR_TABLE_TYPE_SYNTAX) |
| 619 { | |
| 620 ct->next_table = Vall_syntax_tables; | |
| 621 Vall_syntax_tables = obj; | |
| 622 } | |
| 623 Freset_char_table (obj); | |
| 624 return obj; | |
| 625 } | |
| 626 | |
| 627 #ifdef MULE | |
| 628 | |
| 629 static Lisp_Object | |
| 630 make_char_table_entry (Lisp_Object initval) | |
| 631 { | |
| 632 int i; | |
|
5127
a9c41067dd88
more cleanups, terminology clarification, lots of doc work
Ben Wing <ben@xemacs.org>
parents:
5125
diff
changeset
|
633 Lisp_Object obj = ALLOC_NORMAL_LISP_OBJECT (char_table_entry); |
|
5117
3742ea8250b5
Checking in final CVS version of workspace 'ben-lisp-object'
Ben Wing <ben@xemacs.org>
parents:
3025
diff
changeset
|
634 Lisp_Char_Table_Entry *cte = XCHAR_TABLE_ENTRY (obj); |
| 428 | 635 |
| 636 for (i = 0; i < 96; i++) | |
| 637 cte->level2[i] = initval; | |
| 638 | |
|
5117
3742ea8250b5
Checking in final CVS version of workspace 'ben-lisp-object'
Ben Wing <ben@xemacs.org>
parents:
3025
diff
changeset
|
639 return obj; |
| 428 | 640 } |
| 641 | |
| 642 static Lisp_Object | |
| 643 copy_char_table_entry (Lisp_Object entry) | |
| 644 { | |
| 440 | 645 Lisp_Char_Table_Entry *cte = XCHAR_TABLE_ENTRY (entry); |
| 428 | 646 int i; |
|
5127
a9c41067dd88
more cleanups, terminology clarification, lots of doc work
Ben Wing <ben@xemacs.org>
parents:
5125
diff
changeset
|
647 Lisp_Object obj = ALLOC_NORMAL_LISP_OBJECT (char_table_entry); |
|
5117
3742ea8250b5
Checking in final CVS version of workspace 'ben-lisp-object'
Ben Wing <ben@xemacs.org>
parents:
3025
diff
changeset
|
648 Lisp_Char_Table_Entry *ctenew = XCHAR_TABLE_ENTRY (obj); |
| 428 | 649 |
| 650 for (i = 0; i < 96; i++) | |
| 651 { | |
| 3025 | 652 Lisp_Object new_ = cte->level2[i]; |
| 653 if (CHAR_TABLE_ENTRYP (new_)) | |
| 654 ctenew->level2[i] = copy_char_table_entry (new_); | |
| 428 | 655 else |
| 3025 | 656 ctenew->level2[i] = new_; |
| 428 | 657 } |
| 658 | |
|
5117
3742ea8250b5
Checking in final CVS version of workspace 'ben-lisp-object'
Ben Wing <ben@xemacs.org>
parents:
3025
diff
changeset
|
659 return obj; |
| 428 | 660 } |
| 661 | |
| 662 #endif /* MULE */ | |
| 663 | |
| 664 DEFUN ("copy-char-table", Fcopy_char_table, 1, 1, 0, /* | |
| 444 | 665 Return a new char table which is a copy of CHAR-TABLE. |
| 428 | 666 It will contain the same values for the same characters and ranges |
| 444 | 667 as CHAR-TABLE. The values will not themselves be copied. |
| 428 | 668 */ |
| 444 | 669 (char_table)) |
| 428 | 670 { |
| 440 | 671 Lisp_Char_Table *ct, *ctnew; |
| 428 | 672 Lisp_Object obj; |
| 673 int i; | |
| 674 | |
| 444 | 675 CHECK_CHAR_TABLE (char_table); |
| 676 ct = XCHAR_TABLE (char_table); | |
| 3879 | 677 assert(!ct->mirror_table_p); |
|
5127
a9c41067dd88
more cleanups, terminology clarification, lots of doc work
Ben Wing <ben@xemacs.org>
parents:
5125
diff
changeset
|
678 obj = ALLOC_NORMAL_LISP_OBJECT (char_table); |
|
5117
3742ea8250b5
Checking in final CVS version of workspace 'ben-lisp-object'
Ben Wing <ben@xemacs.org>
parents:
3025
diff
changeset
|
679 ctnew = XCHAR_TABLE (obj); |
| 428 | 680 ctnew->type = ct->type; |
| 793 | 681 ctnew->parent = ct->parent; |
| 682 ctnew->default_ = ct->default_; | |
| 3879 | 683 ctnew->mirror_table_p = 0; |
| 428 | 684 |
| 685 for (i = 0; i < NUM_ASCII_CHARS; i++) | |
| 686 { | |
| 3025 | 687 Lisp_Object new_ = ct->ascii[i]; |
| 428 | 688 #ifdef MULE |
| 3025 | 689 assert (! (CHAR_TABLE_ENTRYP (new_))); |
| 428 | 690 #endif /* MULE */ |
| 3025 | 691 ctnew->ascii[i] = new_; |
| 428 | 692 } |
| 693 | |
| 694 #ifdef MULE | |
| 695 | |
| 696 for (i = 0; i < NUM_LEADING_BYTES; i++) | |
| 697 { | |
| 3025 | 698 Lisp_Object new_ = ct->level1[i]; |
| 699 if (CHAR_TABLE_ENTRYP (new_)) | |
| 700 ctnew->level1[i] = copy_char_table_entry (new_); | |
| 428 | 701 else |
| 3025 | 702 ctnew->level1[i] = new_; |
| 428 | 703 } |
| 704 | |
| 705 #endif /* MULE */ | |
| 706 | |
| 3881 | 707 if (!EQ (ct->mirror_table, Qnil)) |
| 1296 | 708 { |
| 3879 | 709 ctnew->mirror_table = Fmake_char_table (Qgeneric); |
| 710 set_char_table_default (ctnew->mirror_table, make_int (Sword)); | |
| 1296 | 711 XCHAR_TABLE (ctnew->mirror_table)->mirror_table = obj; |
| 3879 | 712 XCHAR_TABLE (ctnew->mirror_table)->mirror_table_p = 1; |
| 713 XCHAR_TABLE (ctnew->mirror_table)->dirty = 1; | |
| 1296 | 714 } |
| 428 | 715 else |
| 3879 | 716 ctnew->mirror_table = Qnil; |
| 717 | |
| 428 | 718 ctnew->next_table = Qnil; |
| 719 if (ctnew->type == CHAR_TABLE_TYPE_SYNTAX) | |
| 720 { | |
| 721 ctnew->next_table = Vall_syntax_tables; | |
| 722 Vall_syntax_tables = obj; | |
| 723 } | |
| 724 return obj; | |
| 725 } | |
| 726 | |
| 727 #ifdef MULE | |
| 728 | |
| 826 | 729 /* called from get_char_table(). */ |
| 428 | 730 Lisp_Object |
| 440 | 731 get_non_ascii_char_table_value (Lisp_Char_Table *ct, int leading_byte, |
| 867 | 732 Ichar c) |
| 428 | 733 { |
| 734 Lisp_Object val; | |
| 826 | 735 Lisp_Object charset = charset_by_leading_byte (leading_byte); |
| 428 | 736 int byte1, byte2; |
| 737 | |
| 867 | 738 BREAKUP_ICHAR_1_UNSAFE (c, charset, byte1, byte2); |
| 428 | 739 val = ct->level1[leading_byte - MIN_LEADING_BYTE]; |
| 740 if (CHAR_TABLE_ENTRYP (val)) | |
| 741 { | |
| 440 | 742 Lisp_Char_Table_Entry *cte = XCHAR_TABLE_ENTRY (val); |
| 428 | 743 val = cte->level2[byte1 - 32]; |
| 744 if (CHAR_TABLE_ENTRYP (val)) | |
| 745 { | |
| 746 cte = XCHAR_TABLE_ENTRY (val); | |
| 747 assert (byte2 >= 32); | |
| 748 val = cte->level2[byte2 - 32]; | |
| 749 assert (!CHAR_TABLE_ENTRYP (val)); | |
| 750 } | |
| 751 } | |
| 752 | |
| 753 return val; | |
| 754 } | |
| 755 | |
| 756 #endif /* MULE */ | |
| 757 | |
| 826 | 758 DEFUN ("char-table-default", Fchar_table_default, 1, 1, 0, /* |
| 759 Return the default value for CHAR-TABLE. When an entry for a character | |
| 760 does not exist, the default is returned. | |
| 761 */ | |
| 762 (char_table)) | |
| 428 | 763 { |
| 826 | 764 CHECK_CHAR_TABLE (char_table); |
| 765 return XCHAR_TABLE (char_table)->default_; | |
| 428 | 766 } |
| 767 | |
| 826 | 768 DEFUN ("set-char-table-default", Fset_char_table_default, 2, 2, 0, /* |
| 769 Set the default value for CHAR-TABLE to DEFAULT. | |
| 770 Currently, the default value for syntax tables cannot be changed. | |
| 771 (This policy might change in the future.) | |
| 772 */ | |
| 773 (char_table, default_)) | |
| 774 { | |
| 775 CHECK_CHAR_TABLE (char_table); | |
| 776 if (XCHAR_TABLE_TYPE (char_table) == CHAR_TABLE_TYPE_SYNTAX) | |
| 777 invalid_change ("Can't change default for syntax tables", char_table); | |
| 778 check_valid_char_table_value (default_, XCHAR_TABLE_TYPE (char_table), | |
| 779 ERROR_ME); | |
| 780 set_char_table_default (char_table, default_); | |
| 781 return Qnil; | |
| 782 } | |
| 428 | 783 |
| 784 DEFUN ("get-char-table", Fget_char_table, 2, 2, 0, /* | |
| 444 | 785 Find value for CHARACTER in CHAR-TABLE. |
| 428 | 786 */ |
| 444 | 787 (character, char_table)) |
| 428 | 788 { |
| 444 | 789 CHECK_CHAR_TABLE (char_table); |
| 790 CHECK_CHAR_COERCE_INT (character); | |
| 428 | 791 |
| 826 | 792 return get_char_table (XCHAR (character), char_table); |
| 793 } | |
| 794 | |
| 795 static int | |
| 2286 | 796 copy_mapper (struct chartab_range *range, Lisp_Object UNUSED (table), |
| 826 | 797 Lisp_Object val, void *arg) |
| 798 { | |
| 5013 | 799 put_char_table (GET_LISP_FROM_VOID (arg), range, val); |
| 826 | 800 return 0; |
| 801 } | |
| 802 | |
| 803 void | |
| 804 copy_char_table_range (Lisp_Object from, Lisp_Object to, | |
| 805 struct chartab_range *range) | |
| 806 { | |
| 5013 | 807 map_char_table (from, range, copy_mapper, STORE_LISP_IN_VOID (to)); |
| 826 | 808 } |
| 809 | |
| 1296 | 810 static Lisp_Object |
| 811 get_range_char_table_1 (struct chartab_range *range, Lisp_Object table, | |
| 812 Lisp_Object multi) | |
| 826 | 813 { |
| 814 Lisp_Char_Table *ct = XCHAR_TABLE (table); | |
| 815 Lisp_Object retval = Qnil; | |
| 816 | |
| 817 switch (range->type) | |
| 818 { | |
| 819 case CHARTAB_RANGE_CHAR: | |
| 820 return get_char_table (range->ch, table); | |
| 821 | |
| 822 case CHARTAB_RANGE_ALL: | |
| 823 { | |
| 824 int i; | |
| 825 retval = ct->ascii[0]; | |
| 826 | |
| 827 for (i = 1; i < NUM_ASCII_CHARS; i++) | |
| 828 if (!EQ (retval, ct->ascii[i])) | |
| 829 return multi; | |
| 830 | |
| 831 #ifdef MULE | |
| 832 for (i = MIN_LEADING_BYTE; i < MIN_LEADING_BYTE + NUM_LEADING_BYTES; | |
| 833 i++) | |
| 834 { | |
| 835 if (!CHARSETP (charset_by_leading_byte (i)) | |
| 836 || i == LEADING_BYTE_ASCII | |
| 837 || i == LEADING_BYTE_CONTROL_1) | |
| 838 continue; | |
| 839 if (!EQ (retval, ct->level1[i - MIN_LEADING_BYTE])) | |
| 840 return multi; | |
| 841 } | |
| 842 #endif /* MULE */ | |
| 843 | |
| 844 break; | |
| 845 } | |
| 846 | |
| 847 #ifdef MULE | |
| 848 case CHARTAB_RANGE_CHARSET: | |
| 849 if (EQ (range->charset, Vcharset_ascii)) | |
| 850 { | |
| 851 int i; | |
| 852 retval = ct->ascii[0]; | |
| 853 | |
| 854 for (i = 1; i < 128; i++) | |
| 855 if (!EQ (retval, ct->ascii[i])) | |
| 856 return multi; | |
| 857 break; | |
| 858 } | |
| 859 | |
| 860 if (EQ (range->charset, Vcharset_control_1)) | |
| 861 { | |
| 862 int i; | |
| 863 retval = ct->ascii[128]; | |
| 864 | |
| 865 for (i = 129; i < 160; i++) | |
| 866 if (!EQ (retval, ct->ascii[i])) | |
| 867 return multi; | |
| 868 break; | |
| 869 } | |
| 870 | |
| 871 { | |
| 872 retval = ct->level1[XCHARSET_LEADING_BYTE (range->charset) - | |
| 873 MIN_LEADING_BYTE]; | |
| 874 if (CHAR_TABLE_ENTRYP (retval)) | |
| 875 return multi; | |
| 876 break; | |
| 877 } | |
| 878 | |
| 879 case CHARTAB_RANGE_ROW: | |
| 880 { | |
| 881 retval = ct->level1[XCHARSET_LEADING_BYTE (range->charset) - | |
| 882 MIN_LEADING_BYTE]; | |
| 883 if (!CHAR_TABLE_ENTRYP (retval)) | |
| 884 break; | |
| 885 retval = XCHAR_TABLE_ENTRY (retval)->level2[range->row - 32]; | |
| 886 if (CHAR_TABLE_ENTRYP (retval)) | |
| 887 return multi; | |
| 888 break; | |
| 889 } | |
| 890 #endif /* not MULE */ | |
| 891 | |
| 892 default: | |
| 2500 | 893 ABORT (); |
| 826 | 894 } |
| 895 | |
| 896 if (UNBOUNDP (retval)) | |
| 897 return ct->default_; | |
| 898 return retval; | |
| 428 | 899 } |
| 900 | |
| 1296 | 901 Lisp_Object |
| 902 get_range_char_table (struct chartab_range *range, Lisp_Object table, | |
| 903 Lisp_Object multi) | |
| 904 { | |
| 905 if (range->type == CHARTAB_RANGE_CHAR) | |
| 906 return get_char_table (range->ch, table); | |
| 907 else | |
| 908 return get_range_char_table_1 (range, table, multi); | |
| 909 } | |
| 910 | |
| 911 #ifdef ERROR_CHECK_TYPES | |
| 912 | |
| 913 /* Only exists so as not to trip an assert in get_char_table(). */ | |
| 914 Lisp_Object | |
| 915 updating_mirror_get_range_char_table (struct chartab_range *range, | |
| 916 Lisp_Object table, | |
| 917 Lisp_Object multi) | |
| 918 { | |
| 919 if (range->type == CHARTAB_RANGE_CHAR) | |
| 920 return get_char_table_1 (range->ch, table); | |
| 921 else | |
| 922 return get_range_char_table_1 (range, table, multi); | |
| 923 } | |
| 924 | |
| 925 #endif /* ERROR_CHECK_TYPES */ | |
| 926 | |
| 428 | 927 DEFUN ("get-range-char-table", Fget_range_char_table, 2, 3, 0, /* |
| 2714 | 928 Find value for RANGE in CHAR-TABLE. |
| 428 | 929 If there is more than one value, return MULTI (defaults to nil). |
| 2714 | 930 |
| 931 Valid values for RANGE are single characters, charsets, a row in a | |
| 932 two-octet charset, and all characters. See `put-char-table'. | |
| 428 | 933 */ |
| 444 | 934 (range, char_table, multi)) |
| 428 | 935 { |
| 936 struct chartab_range rainj; | |
| 937 | |
| 938 if (CHAR_OR_CHAR_INTP (range)) | |
| 444 | 939 return Fget_char_table (range, char_table); |
| 940 CHECK_CHAR_TABLE (char_table); | |
| 428 | 941 |
| 942 decode_char_table_range (range, &rainj); | |
| 826 | 943 return get_range_char_table (&rainj, char_table, multi); |
| 428 | 944 } |
| 826 | 945 |
| 428 | 946 static int |
| 947 check_valid_char_table_value (Lisp_Object value, enum char_table_type type, | |
| 578 | 948 Error_Behavior errb) |
| 428 | 949 { |
| 950 switch (type) | |
| 951 { | |
| 952 case CHAR_TABLE_TYPE_SYNTAX: | |
| 953 if (!ERRB_EQ (errb, ERROR_ME)) | |
| 954 return INTP (value) || (CONSP (value) && INTP (XCAR (value)) | |
| 955 && CHAR_OR_CHAR_INTP (XCDR (value))); | |
| 956 if (CONSP (value)) | |
| 957 { | |
| 958 Lisp_Object cdr = XCDR (value); | |
| 959 CHECK_INT (XCAR (value)); | |
| 960 CHECK_CHAR_COERCE_INT (cdr); | |
| 961 } | |
| 962 else | |
| 963 CHECK_INT (value); | |
| 964 break; | |
| 965 | |
| 966 #ifdef MULE | |
| 967 case CHAR_TABLE_TYPE_CATEGORY: | |
| 968 if (!ERRB_EQ (errb, ERROR_ME)) | |
| 969 return CATEGORY_TABLE_VALUEP (value); | |
| 970 CHECK_CATEGORY_TABLE_VALUE (value); | |
| 971 break; | |
| 972 #endif /* MULE */ | |
| 973 | |
| 974 case CHAR_TABLE_TYPE_GENERIC: | |
| 975 return 1; | |
| 976 | |
| 977 case CHAR_TABLE_TYPE_DISPLAY: | |
| 978 /* #### fix this */ | |
| 563 | 979 maybe_signal_error (Qunimplemented, |
| 980 "Display char tables not yet implemented", | |
| 981 value, Qchar_table, errb); | |
| 428 | 982 return 0; |
| 983 | |
| 984 case CHAR_TABLE_TYPE_CHAR: | |
| 985 if (!ERRB_EQ (errb, ERROR_ME)) | |
| 986 return CHAR_OR_CHAR_INTP (value); | |
| 987 CHECK_CHAR_COERCE_INT (value); | |
| 988 break; | |
| 989 | |
| 990 default: | |
| 2500 | 991 ABORT (); |
| 428 | 992 } |
| 993 | |
| 801 | 994 return 0; /* not (usually) reached */ |
| 428 | 995 } |
| 996 | |
| 997 static Lisp_Object | |
| 998 canonicalize_char_table_value (Lisp_Object value, enum char_table_type type) | |
| 999 { | |
| 1000 switch (type) | |
| 1001 { | |
| 1002 case CHAR_TABLE_TYPE_SYNTAX: | |
| 1003 if (CONSP (value)) | |
| 1004 { | |
| 1005 Lisp_Object car = XCAR (value); | |
| 1006 Lisp_Object cdr = XCDR (value); | |
| 1007 CHECK_CHAR_COERCE_INT (cdr); | |
| 1008 return Fcons (car, cdr); | |
| 1009 } | |
| 1010 break; | |
| 1011 case CHAR_TABLE_TYPE_CHAR: | |
| 1012 CHECK_CHAR_COERCE_INT (value); | |
| 1013 break; | |
| 1014 default: | |
| 1015 break; | |
| 1016 } | |
| 1017 return value; | |
| 1018 } | |
| 1019 | |
| 1020 DEFUN ("valid-char-table-value-p", Fvalid_char_table_value_p, 2, 2, 0, /* | |
| 1021 Return non-nil if VALUE is a valid value for CHAR-TABLE-TYPE. | |
| 1022 */ | |
| 1023 (value, char_table_type)) | |
| 1024 { | |
| 1025 enum char_table_type type = symbol_to_char_table_type (char_table_type); | |
| 1026 | |
| 1027 return check_valid_char_table_value (value, type, ERROR_ME_NOT) ? Qt : Qnil; | |
| 1028 } | |
| 1029 | |
| 1030 DEFUN ("check-valid-char-table-value", Fcheck_valid_char_table_value, 2, 2, 0, /* | |
| 1031 Signal an error if VALUE is not a valid value for CHAR-TABLE-TYPE. | |
| 1032 */ | |
| 1033 (value, char_table_type)) | |
| 1034 { | |
| 1035 enum char_table_type type = symbol_to_char_table_type (char_table_type); | |
| 1036 | |
| 1037 check_valid_char_table_value (value, type, ERROR_ME); | |
| 1038 return Qnil; | |
| 1039 } | |
| 1040 | |
| 826 | 1041 /* Assign VAL to all characters in RANGE in char table TABLE. */ |
| 428 | 1042 |
| 1043 void | |
| 826 | 1044 put_char_table (Lisp_Object table, struct chartab_range *range, |
| 428 | 1045 Lisp_Object val) |
| 1046 { | |
| 826 | 1047 Lisp_Char_Table *ct = XCHAR_TABLE (table); |
| 1048 | |
| 428 | 1049 switch (range->type) |
| 1050 { | |
| 1051 case CHARTAB_RANGE_ALL: | |
| 1052 fill_char_table (ct, val); | |
| 1296 | 1053 return; /* fill_char_table() recorded the table as dirty. */ |
| 428 | 1054 |
| 1055 #ifdef MULE | |
| 1056 case CHARTAB_RANGE_CHARSET: | |
| 1057 if (EQ (range->charset, Vcharset_ascii)) | |
| 1058 { | |
| 1059 int i; | |
| 1060 for (i = 0; i < 128; i++) | |
| 1061 ct->ascii[i] = val; | |
| 1062 } | |
| 1063 else if (EQ (range->charset, Vcharset_control_1)) | |
| 1064 { | |
| 1065 int i; | |
| 1066 for (i = 128; i < 160; i++) | |
| 1067 ct->ascii[i] = val; | |
| 1068 } | |
| 1069 else | |
| 1070 { | |
| 1071 int lb = XCHARSET_LEADING_BYTE (range->charset) - MIN_LEADING_BYTE; | |
| 1330 | 1072 if (CHAR_TABLE_ENTRYP (ct->level1[lb]) && |
| 1073 !OBJECT_DUMPED_P (ct->level1[lb])) | |
|
5127
a9c41067dd88
more cleanups, terminology clarification, lots of doc work
Ben Wing <ben@xemacs.org>
parents:
5125
diff
changeset
|
1074 free_normal_lisp_object (ct->level1[lb]); |
| 428 | 1075 ct->level1[lb] = val; |
| 1076 } | |
| 1077 break; | |
| 1078 | |
| 1079 case CHARTAB_RANGE_ROW: | |
| 1080 { | |
| 440 | 1081 Lisp_Char_Table_Entry *cte; |
| 428 | 1082 int lb = XCHARSET_LEADING_BYTE (range->charset) - MIN_LEADING_BYTE; |
| 1083 /* make sure that there is a separate entry for the row. */ | |
| 1084 if (!CHAR_TABLE_ENTRYP (ct->level1[lb])) | |
| 1085 ct->level1[lb] = make_char_table_entry (ct->level1[lb]); | |
| 1086 cte = XCHAR_TABLE_ENTRY (ct->level1[lb]); | |
| 1087 cte->level2[range->row - 32] = val; | |
| 1088 } | |
| 1089 break; | |
| 1090 #endif /* MULE */ | |
| 1091 | |
| 1092 case CHARTAB_RANGE_CHAR: | |
| 1093 #ifdef MULE | |
| 1094 { | |
| 1095 Lisp_Object charset; | |
| 1096 int byte1, byte2; | |
| 1097 | |
| 867 | 1098 BREAKUP_ICHAR (range->ch, charset, byte1, byte2); |
| 428 | 1099 if (EQ (charset, Vcharset_ascii)) |
| 1100 ct->ascii[byte1] = val; | |
| 1101 else if (EQ (charset, Vcharset_control_1)) | |
| 1102 ct->ascii[byte1 + 128] = val; | |
| 1103 else | |
| 1104 { | |
| 440 | 1105 Lisp_Char_Table_Entry *cte; |
| 428 | 1106 int lb = XCHARSET_LEADING_BYTE (charset) - MIN_LEADING_BYTE; |
| 1107 /* make sure that there is a separate entry for the row. */ | |
| 1108 if (!CHAR_TABLE_ENTRYP (ct->level1[lb])) | |
| 1109 ct->level1[lb] = make_char_table_entry (ct->level1[lb]); | |
| 1110 cte = XCHAR_TABLE_ENTRY (ct->level1[lb]); | |
| 1111 /* now CTE is a char table entry for the charset; | |
| 1112 each entry is for a single row (or character of | |
| 1113 a one-octet charset). */ | |
| 1114 if (XCHARSET_DIMENSION (charset) == 1) | |
| 1115 cte->level2[byte1 - 32] = val; | |
| 1116 else | |
| 1117 { | |
| 1118 /* assigning to one character in a two-octet charset. */ | |
| 1119 /* make sure that the charset row contains a separate | |
| 1120 entry for each character. */ | |
| 1121 if (!CHAR_TABLE_ENTRYP (cte->level2[byte1 - 32])) | |
| 1122 cte->level2[byte1 - 32] = | |
| 1123 make_char_table_entry (cte->level2[byte1 - 32]); | |
| 1124 cte = XCHAR_TABLE_ENTRY (cte->level2[byte1 - 32]); | |
| 1125 cte->level2[byte2 - 32] = val; | |
| 1126 } | |
| 1127 } | |
| 1128 } | |
| 1129 #else /* not MULE */ | |
| 1130 ct->ascii[(unsigned char) (range->ch)] = val; | |
| 1131 break; | |
| 1132 #endif /* not MULE */ | |
| 1133 } | |
| 1134 | |
| 1135 if (ct->type == CHAR_TABLE_TYPE_SYNTAX) | |
| 1296 | 1136 set_char_table_dirty (wrap_char_table (ct)); |
| 428 | 1137 } |
| 1138 | |
| 1139 DEFUN ("put-char-table", Fput_char_table, 3, 3, 0, /* | |
| 444 | 1140 Set the value for chars in RANGE to be VALUE in CHAR-TABLE. |
| 428 | 1141 |
| 1142 RANGE specifies one or more characters to be affected and should be | |
| 1143 one of the following: | |
| 1144 | |
| 1145 -- t (all characters are affected) | |
| 1146 -- A charset (only allowed when Mule support is present) | |
| 2714 | 1147 -- A vector of two elements: a two-octet charset and a row number; the row |
| 1148 must be an integer, not a character (only allowed when Mule support is | |
| 1149 present) | |
| 428 | 1150 -- A single character |
| 1151 | |
| 444 | 1152 VALUE must be a value appropriate for the type of CHAR-TABLE. |
| 800 | 1153 See `make-char-table'. |
| 428 | 1154 */ |
| 444 | 1155 (range, value, char_table)) |
| 428 | 1156 { |
| 440 | 1157 Lisp_Char_Table *ct; |
| 428 | 1158 struct chartab_range rainj; |
| 1159 | |
| 444 | 1160 CHECK_CHAR_TABLE (char_table); |
| 1161 ct = XCHAR_TABLE (char_table); | |
| 1162 check_valid_char_table_value (value, ct->type, ERROR_ME); | |
| 428 | 1163 decode_char_table_range (range, &rainj); |
| 444 | 1164 value = canonicalize_char_table_value (value, ct->type); |
| 826 | 1165 put_char_table (char_table, &rainj, value); |
| 1166 return Qnil; | |
| 1167 } | |
| 1168 | |
| 1169 DEFUN ("remove-char-table", Fremove_char_table, 2, 2, 0, /* | |
| 1170 Remove any value from chars in RANGE in CHAR-TABLE. | |
| 1171 | |
| 1172 RANGE specifies one or more characters to be affected and should be | |
| 1173 one of the following: | |
| 1174 | |
| 1175 -- t (all characters are affected) | |
| 1176 -- A charset (only allowed when Mule support is present) | |
| 1177 -- A vector of two elements: a two-octet charset and a row number | |
| 1178 (only allowed when Mule support is present) | |
| 1179 -- A single character | |
| 1180 | |
| 2726 | 1181 With all values removed, the default value will be returned by |
| 1182 `get-char-table' and `get-range-char-table'. | |
| 826 | 1183 */ |
| 1184 (range, char_table)) | |
| 1185 { | |
| 1186 struct chartab_range rainj; | |
| 1187 | |
| 1188 CHECK_CHAR_TABLE (char_table); | |
| 1189 decode_char_table_range (range, &rainj); | |
| 1190 put_char_table (char_table, &rainj, Qunbound); | |
| 428 | 1191 return Qnil; |
| 1192 } | |
| 1193 | |
| 1194 /* Map FN over the ASCII chars in CT. */ | |
| 1195 | |
| 1196 static int | |
| 826 | 1197 map_over_charset_ascii_1 (Lisp_Char_Table *ct, |
| 1198 int start, int stop, | |
| 1199 int (*fn) (struct chartab_range *range, | |
| 1200 Lisp_Object table, Lisp_Object val, | |
| 1201 void *arg), | |
| 1202 void *arg) | |
| 1203 { | |
| 1204 struct chartab_range rainj; | |
| 1205 int i, retval; | |
| 1206 | |
| 1207 rainj.type = CHARTAB_RANGE_CHAR; | |
| 1208 | |
| 1209 for (i = start, retval = 0; i <= stop && retval == 0; i++) | |
| 1210 { | |
| 867 | 1211 rainj.ch = (Ichar) i; |
| 826 | 1212 if (!UNBOUNDP (ct->ascii[i])) |
| 1213 retval = (fn) (&rainj, wrap_char_table (ct), ct->ascii[i], arg); | |
| 1214 } | |
| 1215 | |
| 1216 return retval; | |
| 1217 } | |
| 1218 | |
| 1219 | |
| 1220 /* Map FN over the ASCII chars in CT. */ | |
| 1221 | |
| 1222 static int | |
| 440 | 1223 map_over_charset_ascii (Lisp_Char_Table *ct, |
| 428 | 1224 int (*fn) (struct chartab_range *range, |
| 826 | 1225 Lisp_Object table, Lisp_Object val, |
| 1226 void *arg), | |
| 428 | 1227 void *arg) |
| 1228 { | |
| 826 | 1229 return map_over_charset_ascii_1 (ct, 0, |
| 428 | 1230 #ifdef MULE |
| 826 | 1231 127, |
| 428 | 1232 #else |
| 826 | 1233 255, |
| 428 | 1234 #endif |
| 826 | 1235 fn, arg); |
| 428 | 1236 } |
| 1237 | |
| 1238 #ifdef MULE | |
| 1239 | |
| 1240 /* Map FN over the Control-1 chars in CT. */ | |
| 1241 | |
| 1242 static int | |
| 440 | 1243 map_over_charset_control_1 (Lisp_Char_Table *ct, |
| 428 | 1244 int (*fn) (struct chartab_range *range, |
| 826 | 1245 Lisp_Object table, Lisp_Object val, |
| 1246 void *arg), | |
| 428 | 1247 void *arg) |
| 1248 { | |
| 826 | 1249 return map_over_charset_ascii_1 (ct, 128, 159, fn, arg); |
| 428 | 1250 } |
| 1251 | |
| 1252 /* Map FN over the row ROW of two-byte charset CHARSET. | |
| 1253 There must be a separate value for that row in the char table. | |
| 1254 CTE specifies the char table entry for CHARSET. */ | |
| 1255 | |
| 1256 static int | |
| 826 | 1257 map_over_charset_row (Lisp_Char_Table *ct, |
| 1258 Lisp_Char_Table_Entry *cte, | |
| 428 | 1259 Lisp_Object charset, int row, |
| 1260 int (*fn) (struct chartab_range *range, | |
| 826 | 1261 Lisp_Object table, Lisp_Object val, |
| 1262 void *arg), | |
| 428 | 1263 void *arg) |
| 1264 { | |
| 1265 Lisp_Object val = cte->level2[row - 32]; | |
| 1266 | |
| 826 | 1267 if (UNBOUNDP (val)) |
| 1268 return 0; | |
| 1269 else if (!CHAR_TABLE_ENTRYP (val)) | |
| 428 | 1270 { |
| 1271 struct chartab_range rainj; | |
| 826 | 1272 |
| 428 | 1273 rainj.type = CHARTAB_RANGE_ROW; |
| 1274 rainj.charset = charset; | |
| 1275 rainj.row = row; | |
| 826 | 1276 return (fn) (&rainj, wrap_char_table (ct), val, arg); |
| 428 | 1277 } |
| 1278 else | |
| 1279 { | |
| 1280 struct chartab_range rainj; | |
| 1281 int i, retval; | |
| 826 | 1282 int start, stop; |
| 1283 | |
| 1284 get_charset_limits (charset, &start, &stop); | |
| 428 | 1285 |
| 1286 cte = XCHAR_TABLE_ENTRY (val); | |
| 1287 | |
| 1288 rainj.type = CHARTAB_RANGE_CHAR; | |
| 1289 | |
| 826 | 1290 for (i = start, retval = 0; i <= stop && retval == 0; i++) |
| 428 | 1291 { |
| 867 | 1292 rainj.ch = make_ichar (charset, row, i); |
| 826 | 1293 if (!UNBOUNDP (cte->level2[i - 32])) |
| 1294 retval = (fn) (&rainj, wrap_char_table (ct), cte->level2[i - 32], | |
| 1295 arg); | |
| 428 | 1296 } |
| 1297 return retval; | |
| 1298 } | |
| 1299 } | |
| 1300 | |
| 1301 | |
| 1302 static int | |
| 440 | 1303 map_over_other_charset (Lisp_Char_Table *ct, int lb, |
| 428 | 1304 int (*fn) (struct chartab_range *range, |
| 826 | 1305 Lisp_Object table, Lisp_Object val, |
| 1306 void *arg), | |
| 428 | 1307 void *arg) |
| 1308 { | |
| 1309 Lisp_Object val = ct->level1[lb - MIN_LEADING_BYTE]; | |
| 826 | 1310 Lisp_Object charset = charset_by_leading_byte (lb); |
| 428 | 1311 |
| 1312 if (!CHARSETP (charset) | |
| 1313 || lb == LEADING_BYTE_ASCII | |
| 1314 || lb == LEADING_BYTE_CONTROL_1) | |
| 1315 return 0; | |
| 1316 | |
| 826 | 1317 if (UNBOUNDP (val)) |
| 1318 return 0; | |
| 428 | 1319 if (!CHAR_TABLE_ENTRYP (val)) |
| 1320 { | |
| 1321 struct chartab_range rainj; | |
| 1322 | |
| 1323 rainj.type = CHARTAB_RANGE_CHARSET; | |
| 1324 rainj.charset = charset; | |
| 826 | 1325 return (fn) (&rainj, wrap_char_table (ct), val, arg); |
| 428 | 1326 } |
| 1327 { | |
| 440 | 1328 Lisp_Char_Table_Entry *cte = XCHAR_TABLE_ENTRY (val); |
| 826 | 1329 int start, stop; |
| 428 | 1330 int i, retval; |
| 1331 | |
| 826 | 1332 get_charset_limits (charset, &start, &stop); |
| 428 | 1333 if (XCHARSET_DIMENSION (charset) == 1) |
| 1334 { | |
| 1335 struct chartab_range rainj; | |
| 1336 rainj.type = CHARTAB_RANGE_CHAR; | |
| 1337 | |
| 826 | 1338 for (i = start, retval = 0; i <= stop && retval == 0; i++) |
| 428 | 1339 { |
| 867 | 1340 rainj.ch = make_ichar (charset, i, 0); |
| 826 | 1341 if (!UNBOUNDP (cte->level2[i - 32])) |
| 1342 retval = (fn) (&rainj, wrap_char_table (ct), cte->level2[i - 32], | |
| 1343 arg); | |
| 428 | 1344 } |
| 1345 } | |
| 1346 else | |
| 1347 { | |
| 826 | 1348 for (i = start, retval = 0; i <= stop && retval == 0; i++) |
| 1349 retval = map_over_charset_row (ct, cte, charset, i, fn, arg); | |
| 428 | 1350 } |
| 1351 | |
| 1352 return retval; | |
| 1353 } | |
| 1354 } | |
| 1355 | |
| 1356 #endif /* MULE */ | |
| 1357 | |
| 1358 /* Map FN (with client data ARG) over range RANGE in char table CT. | |
| 1359 Mapping stops the first time FN returns non-zero, and that value | |
| 826 | 1360 becomes the return value of map_char_table(). |
| 1361 | |
| 1362 #### This mapping code is way ugly. The FSF version, in contrast, | |
| 1363 is short and sweet, and much more recursive. There should be some way | |
| 1364 of cleaning this up. */ | |
| 428 | 1365 |
| 1366 int | |
| 826 | 1367 map_char_table (Lisp_Object table, |
| 428 | 1368 struct chartab_range *range, |
| 1369 int (*fn) (struct chartab_range *range, | |
| 826 | 1370 Lisp_Object table, Lisp_Object val, void *arg), |
| 428 | 1371 void *arg) |
| 1372 { | |
| 826 | 1373 Lisp_Char_Table *ct = XCHAR_TABLE (table); |
| 428 | 1374 switch (range->type) |
| 1375 { | |
| 1376 case CHARTAB_RANGE_ALL: | |
| 1377 { | |
| 1378 int retval; | |
| 1379 | |
| 1380 retval = map_over_charset_ascii (ct, fn, arg); | |
| 1381 if (retval) | |
| 1382 return retval; | |
| 1383 #ifdef MULE | |
| 1384 retval = map_over_charset_control_1 (ct, fn, arg); | |
| 1385 if (retval) | |
| 1386 return retval; | |
| 1387 { | |
| 1388 int i; | |
| 1389 int start = MIN_LEADING_BYTE; | |
| 1390 int stop = start + NUM_LEADING_BYTES; | |
| 1391 | |
| 1392 for (i = start, retval = 0; i < stop && retval == 0; i++) | |
| 1393 { | |
| 771 | 1394 if (i != LEADING_BYTE_ASCII && i != LEADING_BYTE_CONTROL_1) |
| 1395 retval = map_over_other_charset (ct, i, fn, arg); | |
| 428 | 1396 } |
| 1397 } | |
| 1398 #endif /* MULE */ | |
| 1399 return retval; | |
| 1400 } | |
| 1401 | |
| 1402 #ifdef MULE | |
| 1403 case CHARTAB_RANGE_CHARSET: | |
| 1404 return map_over_other_charset (ct, | |
| 1405 XCHARSET_LEADING_BYTE (range->charset), | |
| 1406 fn, arg); | |
| 1407 | |
| 1408 case CHARTAB_RANGE_ROW: | |
| 1409 { | |
| 771 | 1410 Lisp_Object val = ct->level1[XCHARSET_LEADING_BYTE (range->charset) - |
| 1411 MIN_LEADING_BYTE]; | |
| 826 | 1412 |
| 1413 if (CHAR_TABLE_ENTRYP (val)) | |
| 1414 return map_over_charset_row (ct, XCHAR_TABLE_ENTRY (val), | |
| 1415 range->charset, range->row, fn, arg); | |
| 1416 else if (!UNBOUNDP (val)) | |
| 428 | 1417 { |
| 1418 struct chartab_range rainj; | |
| 1419 | |
| 1420 rainj.type = CHARTAB_RANGE_ROW; | |
| 1421 rainj.charset = range->charset; | |
| 1422 rainj.row = range->row; | |
| 826 | 1423 return (fn) (&rainj, table, val, arg); |
| 428 | 1424 } |
| 1425 else | |
| 826 | 1426 return 0; |
| 428 | 1427 } |
| 1428 #endif /* MULE */ | |
| 1429 | |
| 1430 case CHARTAB_RANGE_CHAR: | |
| 1431 { | |
| 867 | 1432 Ichar ch = range->ch; |
| 826 | 1433 Lisp_Object val = get_char_table (ch, table); |
| 428 | 1434 struct chartab_range rainj; |
| 1435 | |
| 826 | 1436 if (!UNBOUNDP (val)) |
| 1437 { | |
| 1438 rainj.type = CHARTAB_RANGE_CHAR; | |
| 1439 rainj.ch = ch; | |
| 1440 return (fn) (&rainj, table, val, arg); | |
| 1441 } | |
| 1442 else | |
| 1443 return 0; | |
| 428 | 1444 } |
| 1445 | |
| 1446 default: | |
| 2500 | 1447 ABORT (); |
| 428 | 1448 } |
| 1449 | |
| 1450 return 0; | |
| 1451 } | |
| 1452 | |
| 1453 struct slow_map_char_table_arg | |
| 1454 { | |
| 1455 Lisp_Object function; | |
| 1456 Lisp_Object retval; | |
| 1457 }; | |
| 1458 | |
| 1459 static int | |
| 1460 slow_map_char_table_fun (struct chartab_range *range, | |
| 2286 | 1461 Lisp_Object UNUSED (table), Lisp_Object val, |
| 1462 void *arg) | |
| 428 | 1463 { |
| 1464 struct slow_map_char_table_arg *closure = | |
| 1465 (struct slow_map_char_table_arg *) arg; | |
| 1466 | |
| 826 | 1467 closure->retval = call2 (closure->function, encode_char_table_range (range), |
| 1468 val); | |
| 428 | 1469 return !NILP (closure->retval); |
| 1470 } | |
| 1471 | |
| 1472 DEFUN ("map-char-table", Fmap_char_table, 2, 3, 0, /* | |
| 2726 | 1473 Map FUNCTION over CHAR-TABLE until it returns non-nil; return that value. |
| 1474 FUNCTION is called with two arguments, each key and entry in the table. | |
| 1475 | |
| 1476 RANGE specifies a subrange to map over. If omitted or t, it defaults to | |
| 1477 the entire table. | |
| 428 | 1478 |
| 2726 | 1479 Both RANGE and the keys passed to FUNCTION are in the same format as the |
| 1480 RANGE argument to `put-char-table'. N.B. This function does NOT map over | |
| 1481 all characters in RANGE, but over the subranges that have been assigned to. | |
| 1482 Thus this function is most suitable for searching a char-table, or for | |
| 1483 populating one char-table based on the contents of another. The current | |
| 1484 implementation does not coalesce ranges all of whose values are the same. | |
| 428 | 1485 */ |
| 444 | 1486 (function, char_table, range)) |
| 428 | 1487 { |
| 1488 struct slow_map_char_table_arg slarg; | |
| 1489 struct gcpro gcpro1, gcpro2; | |
| 1490 struct chartab_range rainj; | |
| 1491 | |
| 444 | 1492 CHECK_CHAR_TABLE (char_table); |
| 428 | 1493 if (NILP (range)) |
| 1494 range = Qt; | |
| 1495 decode_char_table_range (range, &rainj); | |
| 1496 slarg.function = function; | |
| 1497 slarg.retval = Qnil; | |
| 1498 GCPRO2 (slarg.function, slarg.retval); | |
| 826 | 1499 map_char_table (char_table, &rainj, slow_map_char_table_fun, &slarg); |
| 428 | 1500 UNGCPRO; |
| 1501 | |
| 1502 return slarg.retval; | |
| 1503 } | |
| 1504 | |
| 1505 | |
| 1506 | |
| 1507 /************************************************************************/ | |
| 1508 /* Char table read syntax */ | |
| 1509 /************************************************************************/ | |
| 1510 | |
| 1511 static int | |
| 2286 | 1512 chartab_type_validate (Lisp_Object UNUSED (keyword), Lisp_Object value, |
| 1513 Error_Behavior UNUSED (errb)) | |
| 428 | 1514 { |
| 1515 /* #### should deal with ERRB */ | |
| 1516 symbol_to_char_table_type (value); | |
| 1517 return 1; | |
| 1518 } | |
| 1519 | |
| 826 | 1520 /* #### Document the print/read format; esp. what's this cons element? */ |
| 1521 | |
| 428 | 1522 static int |
| 2286 | 1523 chartab_data_validate (Lisp_Object UNUSED (keyword), Lisp_Object value, |
| 1524 Error_Behavior UNUSED (errb)) | |
| 428 | 1525 { |
| 1526 /* #### should deal with ERRB */ | |
| 2367 | 1527 EXTERNAL_PROPERTY_LIST_LOOP_3 (range, data, value) |
| 428 | 1528 { |
| 1529 struct chartab_range dummy; | |
| 1530 | |
| 1531 if (CONSP (range)) | |
| 1532 { | |
| 1533 if (!CONSP (XCDR (range)) | |
| 1534 || !NILP (XCDR (XCDR (range)))) | |
| 563 | 1535 sferror ("Invalid range format", range); |
| 428 | 1536 decode_char_table_range (XCAR (range), &dummy); |
| 1537 decode_char_table_range (XCAR (XCDR (range)), &dummy); | |
| 1538 } | |
| 1539 else | |
| 1540 decode_char_table_range (range, &dummy); | |
| 1541 } | |
| 1542 | |
| 1543 return 1; | |
| 1544 } | |
| 1545 | |
| 1546 static Lisp_Object | |
| 1547 chartab_instantiate (Lisp_Object data) | |
| 1548 { | |
| 1549 Lisp_Object chartab; | |
| 1550 Lisp_Object type = Qgeneric; | |
| 1551 Lisp_Object dataval = Qnil; | |
| 1552 | |
| 1553 while (!NILP (data)) | |
| 1554 { | |
| 1555 Lisp_Object keyw = Fcar (data); | |
| 1556 Lisp_Object valw; | |
| 1557 | |
| 1558 data = Fcdr (data); | |
| 1559 valw = Fcar (data); | |
| 1560 data = Fcdr (data); | |
| 1561 if (EQ (keyw, Qtype)) | |
| 1562 type = valw; | |
| 1563 else if (EQ (keyw, Qdata)) | |
| 1564 dataval = valw; | |
| 1565 } | |
| 1566 | |
| 1567 chartab = Fmake_char_table (type); | |
| 1568 | |
| 1569 data = dataval; | |
| 1570 while (!NILP (data)) | |
| 1571 { | |
| 1572 Lisp_Object range = Fcar (data); | |
| 1573 Lisp_Object val = Fcar (Fcdr (data)); | |
| 1574 | |
| 1575 data = Fcdr (Fcdr (data)); | |
| 1576 if (CONSP (range)) | |
| 1577 { | |
| 1578 if (CHAR_OR_CHAR_INTP (XCAR (range))) | |
| 1579 { | |
| 867 | 1580 Ichar first = XCHAR_OR_CHAR_INT (Fcar (range)); |
| 1581 Ichar last = XCHAR_OR_CHAR_INT (Fcar (Fcdr (range))); | |
| 1582 Ichar i; | |
| 428 | 1583 |
| 1584 for (i = first; i <= last; i++) | |
| 1585 Fput_char_table (make_char (i), val, chartab); | |
| 1586 } | |
| 1587 else | |
| 2500 | 1588 ABORT (); |
| 428 | 1589 } |
| 1590 else | |
| 1591 Fput_char_table (range, val, chartab); | |
| 1592 } | |
| 1593 | |
| 1594 return chartab; | |
| 1595 } | |
| 1596 | |
| 1597 #ifdef MULE | |
| 1598 | |
| 1599 | |
| 1600 /************************************************************************/ | |
| 1601 /* Category Tables, specifically */ | |
| 1602 /************************************************************************/ | |
| 1603 | |
| 1604 DEFUN ("category-table-p", Fcategory_table_p, 1, 1, 0, /* | |
| 444 | 1605 Return t if OBJECT is a category table. |
| 428 | 1606 A category table is a type of char table used for keeping track of |
| 1607 categories. Categories are used for classifying characters for use | |
| 1608 in regexps -- you can refer to a category rather than having to use | |
| 1609 a complicated [] expression (and category lookups are significantly | |
| 1610 faster). | |
| 1611 | |
| 1612 There are 95 different categories available, one for each printable | |
| 1613 character (including space) in the ASCII charset. Each category | |
| 1614 is designated by one such character, called a "category designator". | |
| 1615 They are specified in a regexp using the syntax "\\cX", where X is | |
| 1616 a category designator. | |
| 1617 | |
| 1618 A category table specifies, for each character, the categories that | |
| 1619 the character is in. Note that a character can be in more than one | |
| 1620 category. More specifically, a category table maps from a character | |
| 1621 to either the value nil (meaning the character is in no categories) | |
| 1622 or a 95-element bit vector, specifying for each of the 95 categories | |
| 1623 whether the character is in that category. | |
| 1624 | |
| 1625 Special Lisp functions are provided that abstract this, so you do not | |
| 1626 have to directly manipulate bit vectors. | |
| 1627 */ | |
| 444 | 1628 (object)) |
| 428 | 1629 { |
| 444 | 1630 return (CHAR_TABLEP (object) && |
| 1631 XCHAR_TABLE_TYPE (object) == CHAR_TABLE_TYPE_CATEGORY) ? | |
| 428 | 1632 Qt : Qnil; |
| 1633 } | |
| 1634 | |
| 1635 static Lisp_Object | |
| 444 | 1636 check_category_table (Lisp_Object object, Lisp_Object default_) |
| 428 | 1637 { |
| 444 | 1638 if (NILP (object)) |
| 1639 object = default_; | |
| 1640 while (NILP (Fcategory_table_p (object))) | |
| 1641 object = wrong_type_argument (Qcategory_table_p, object); | |
| 1642 return object; | |
| 428 | 1643 } |
| 1644 | |
| 1645 int | |
| 867 | 1646 check_category_char (Ichar ch, Lisp_Object table, |
| 647 | 1647 int designator, int not_p) |
| 428 | 1648 { |
| 1649 REGISTER Lisp_Object temp; | |
| 1650 if (NILP (Fcategory_table_p (table))) | |
| 563 | 1651 wtaerror ("Expected category table", table); |
| 826 | 1652 temp = get_char_table (ch, table); |
| 428 | 1653 if (NILP (temp)) |
| 458 | 1654 return not_p; |
| 428 | 1655 |
| 1656 designator -= ' '; | |
| 458 | 1657 return bit_vector_bit (XBIT_VECTOR (temp), designator) ? !not_p : not_p; |
| 428 | 1658 } |
| 1659 | |
| 1660 DEFUN ("check-category-at", Fcheck_category_at, 2, 4, 0, /* | |
| 444 | 1661 Return t if category of the character at POSITION includes DESIGNATOR. |
| 1662 Optional third arg BUFFER specifies which buffer to use, and defaults | |
| 1663 to the current buffer. | |
| 1664 Optional fourth arg CATEGORY-TABLE specifies the category table to | |
| 1665 use, and defaults to BUFFER's category table. | |
| 428 | 1666 */ |
| 444 | 1667 (position, designator, buffer, category_table)) |
| 428 | 1668 { |
| 1669 Lisp_Object ctbl; | |
| 867 | 1670 Ichar ch; |
| 647 | 1671 int des; |
| 428 | 1672 struct buffer *buf = decode_buffer (buffer, 0); |
| 1673 | |
| 444 | 1674 CHECK_INT (position); |
| 428 | 1675 CHECK_CATEGORY_DESIGNATOR (designator); |
| 1676 des = XCHAR (designator); | |
| 788 | 1677 ctbl = check_category_table (category_table, buf->category_table); |
| 444 | 1678 ch = BUF_FETCH_CHAR (buf, XINT (position)); |
| 428 | 1679 return check_category_char (ch, ctbl, des, 0) ? Qt : Qnil; |
| 1680 } | |
| 1681 | |
| 1682 DEFUN ("char-in-category-p", Fchar_in_category_p, 2, 3, 0, /* | |
| 788 | 1683 Return non-nil if category of CHARACTER includes DESIGNATOR. |
| 444 | 1684 Optional third arg CATEGORY-TABLE specifies the category table to use, |
| 788 | 1685 and defaults to the current buffer's category table. |
| 428 | 1686 */ |
| 444 | 1687 (character, designator, category_table)) |
| 428 | 1688 { |
| 1689 Lisp_Object ctbl; | |
| 867 | 1690 Ichar ch; |
| 647 | 1691 int des; |
| 428 | 1692 |
| 1693 CHECK_CATEGORY_DESIGNATOR (designator); | |
| 1694 des = XCHAR (designator); | |
| 444 | 1695 CHECK_CHAR (character); |
| 1696 ch = XCHAR (character); | |
| 788 | 1697 ctbl = check_category_table (category_table, current_buffer->category_table); |
| 428 | 1698 return check_category_char (ch, ctbl, des, 0) ? Qt : Qnil; |
| 1699 } | |
| 1700 | |
| 1701 DEFUN ("category-table", Fcategory_table, 0, 1, 0, /* | |
| 444 | 1702 Return BUFFER's current category table. |
| 1703 BUFFER defaults to the current buffer. | |
| 428 | 1704 */ |
| 1705 (buffer)) | |
| 1706 { | |
| 1707 return decode_buffer (buffer, 0)->category_table; | |
| 1708 } | |
| 1709 | |
| 1710 DEFUN ("standard-category-table", Fstandard_category_table, 0, 0, 0, /* | |
| 1711 Return the standard category table. | |
| 1712 This is the one used for new buffers. | |
| 1713 */ | |
| 1714 ()) | |
| 1715 { | |
| 1716 return Vstandard_category_table; | |
| 1717 } | |
| 1718 | |
| 1719 DEFUN ("copy-category-table", Fcopy_category_table, 0, 1, 0, /* | |
| 444 | 1720 Return a new category table which is a copy of CATEGORY-TABLE. |
| 1721 CATEGORY-TABLE defaults to the standard category table. | |
| 428 | 1722 */ |
| 444 | 1723 (category_table)) |
| 428 | 1724 { |
| 1725 if (NILP (Vstandard_category_table)) | |
| 1726 return Fmake_char_table (Qcategory); | |
| 1727 | |
| 444 | 1728 category_table = |
| 1729 check_category_table (category_table, Vstandard_category_table); | |
| 1730 return Fcopy_char_table (category_table); | |
| 428 | 1731 } |
| 1732 | |
| 1733 DEFUN ("set-category-table", Fset_category_table, 1, 2, 0, /* | |
| 444 | 1734 Select CATEGORY-TABLE as the new category table for BUFFER. |
| 428 | 1735 BUFFER defaults to the current buffer if omitted. |
| 1736 */ | |
| 444 | 1737 (category_table, buffer)) |
| 428 | 1738 { |
| 1739 struct buffer *buf = decode_buffer (buffer, 0); | |
| 444 | 1740 category_table = check_category_table (category_table, Qnil); |
| 1741 buf->category_table = category_table; | |
| 428 | 1742 /* Indicate that this buffer now has a specified category table. */ |
| 1743 buf->local_var_flags |= XINT (buffer_local_flags.category_table); | |
| 444 | 1744 return category_table; |
| 428 | 1745 } |
| 1746 | |
| 1747 DEFUN ("category-designator-p", Fcategory_designator_p, 1, 1, 0, /* | |
| 444 | 1748 Return t if OBJECT is a category designator (a char in the range ' ' to '~'). |
| 428 | 1749 */ |
| 444 | 1750 (object)) |
| 428 | 1751 { |
| 444 | 1752 return CATEGORY_DESIGNATORP (object) ? Qt : Qnil; |
| 428 | 1753 } |
| 1754 | |
| 1755 DEFUN ("category-table-value-p", Fcategory_table_value_p, 1, 1, 0, /* | |
| 444 | 1756 Return t if OBJECT is a category table value. |
| 428 | 1757 Valid values are nil or a bit vector of size 95. |
| 1758 */ | |
| 444 | 1759 (object)) |
| 428 | 1760 { |
| 444 | 1761 return CATEGORY_TABLE_VALUEP (object) ? Qt : Qnil; |
| 428 | 1762 } |
| 1763 | |
| 1764 | |
| 1765 #define CATEGORYP(x) \ | |
| 1766 (CHARP (x) && XCHAR (x) >= 0x20 && XCHAR (x) <= 0x7E) | |
| 1767 | |
| 826 | 1768 #define CATEGORY_SET(c) get_char_table (c, current_buffer->category_table) |
| 428 | 1769 |
| 1770 /* Return 1 if CATEGORY_SET contains CATEGORY, else return 0. | |
| 1771 The faster version of `!NILP (Faref (category_set, category))'. */ | |
| 1772 #define CATEGORY_MEMBER(category, category_set) \ | |
| 1773 (bit_vector_bit(XBIT_VECTOR (category_set), category - 32)) | |
| 1774 | |
| 1775 /* Return 1 if there is a word boundary between two word-constituent | |
| 1776 characters C1 and C2 if they appear in this order, else return 0. | |
| 1777 Use the macro WORD_BOUNDARY_P instead of calling this function | |
| 1778 directly. */ | |
| 1779 | |
| 1780 int | |
| 867 | 1781 word_boundary_p (Ichar c1, Ichar c2) |
| 428 | 1782 { |
| 1783 Lisp_Object category_set1, category_set2; | |
| 1784 Lisp_Object tail; | |
| 1785 int default_result; | |
| 1786 | |
| 1787 #if 0 | |
| 1788 if (COMPOSITE_CHAR_P (c1)) | |
| 1789 c1 = cmpchar_component (c1, 0, 1); | |
| 1790 if (COMPOSITE_CHAR_P (c2)) | |
| 1791 c2 = cmpchar_component (c2, 0, 1); | |
| 1792 #endif | |
| 1793 | |
| 867 | 1794 if (EQ (ichar_charset (c1), ichar_charset (c2))) |
| 428 | 1795 { |
| 1796 tail = Vword_separating_categories; | |
| 1797 default_result = 0; | |
| 1798 } | |
| 1799 else | |
| 1800 { | |
| 1801 tail = Vword_combining_categories; | |
| 1802 default_result = 1; | |
| 1803 } | |
| 1804 | |
| 1805 category_set1 = CATEGORY_SET (c1); | |
| 1806 if (NILP (category_set1)) | |
| 1807 return default_result; | |
| 1808 category_set2 = CATEGORY_SET (c2); | |
| 1809 if (NILP (category_set2)) | |
| 1810 return default_result; | |
| 1811 | |
| 853 | 1812 for (; CONSP (tail); tail = XCDR (tail)) |
| 428 | 1813 { |
| 853 | 1814 Lisp_Object elt = XCAR (tail); |
| 428 | 1815 |
| 1816 if (CONSP (elt) | |
| 853 | 1817 && CATEGORYP (XCAR (elt)) |
| 1818 && CATEGORYP (XCDR (elt)) | |
| 1819 && CATEGORY_MEMBER (XCHAR (XCAR (elt)), category_set1) | |
| 1820 && CATEGORY_MEMBER (XCHAR (XCDR (elt)), category_set2)) | |
| 428 | 1821 return !default_result; |
| 1822 } | |
| 1823 return default_result; | |
| 1824 } | |
| 1825 #endif /* MULE */ | |
| 1826 | |
| 1827 | |
| 1828 void | |
| 1829 syms_of_chartab (void) | |
| 1830 { | |
|
5117
3742ea8250b5
Checking in final CVS version of workspace 'ben-lisp-object'
Ben Wing <ben@xemacs.org>
parents:
3025
diff
changeset
|
1831 INIT_LISP_OBJECT (char_table); |
| 442 | 1832 |
| 428 | 1833 #ifdef MULE |
|
5117
3742ea8250b5
Checking in final CVS version of workspace 'ben-lisp-object'
Ben Wing <ben@xemacs.org>
parents:
3025
diff
changeset
|
1834 INIT_LISP_OBJECT (char_table_entry); |
| 442 | 1835 |
| 563 | 1836 DEFSYMBOL (Qcategory_table_p); |
| 1837 DEFSYMBOL (Qcategory_designator_p); | |
| 1838 DEFSYMBOL (Qcategory_table_value_p); | |
| 428 | 1839 #endif /* MULE */ |
| 1840 | |
| 563 | 1841 DEFSYMBOL (Qchar_table); |
| 1842 DEFSYMBOL_MULTIWORD_PREDICATE (Qchar_tablep); | |
| 428 | 1843 |
| 1844 DEFSUBR (Fchar_table_p); | |
| 1845 DEFSUBR (Fchar_table_type_list); | |
| 1846 DEFSUBR (Fvalid_char_table_type_p); | |
| 1847 DEFSUBR (Fchar_table_type); | |
| 826 | 1848 DEFSUBR (Fchar_table_default); |
| 1849 DEFSUBR (Fset_char_table_default); | |
| 428 | 1850 DEFSUBR (Freset_char_table); |
| 1851 DEFSUBR (Fmake_char_table); | |
| 1852 DEFSUBR (Fcopy_char_table); | |
| 1853 DEFSUBR (Fget_char_table); | |
| 1854 DEFSUBR (Fget_range_char_table); | |
| 1855 DEFSUBR (Fvalid_char_table_value_p); | |
| 1856 DEFSUBR (Fcheck_valid_char_table_value); | |
| 1857 DEFSUBR (Fput_char_table); | |
| 826 | 1858 DEFSUBR (Fremove_char_table); |
| 428 | 1859 DEFSUBR (Fmap_char_table); |
| 1860 | |
| 1861 #ifdef MULE | |
| 1862 DEFSUBR (Fcategory_table_p); | |
| 1863 DEFSUBR (Fcategory_table); | |
| 1864 DEFSUBR (Fstandard_category_table); | |
| 1865 DEFSUBR (Fcopy_category_table); | |
| 1866 DEFSUBR (Fset_category_table); | |
| 1867 DEFSUBR (Fcheck_category_at); | |
| 1868 DEFSUBR (Fchar_in_category_p); | |
| 1869 DEFSUBR (Fcategory_designator_p); | |
| 1870 DEFSUBR (Fcategory_table_value_p); | |
| 1871 #endif /* MULE */ | |
| 1872 | |
| 1873 } | |
| 1874 | |
| 1875 void | |
| 1876 vars_of_chartab (void) | |
| 1877 { | |
| 1878 /* DO NOT staticpro this. It works just like Vweak_hash_tables. */ | |
| 1879 Vall_syntax_tables = Qnil; | |
| 452 | 1880 dump_add_weak_object_chain (&Vall_syntax_tables); |
| 428 | 1881 } |
| 1882 | |
| 1883 void | |
| 1884 structure_type_create_chartab (void) | |
| 1885 { | |
| 1886 struct structure_type *st; | |
| 1887 | |
| 1888 st = define_structure_type (Qchar_table, 0, chartab_instantiate); | |
| 1889 | |
| 1890 define_structure_type_keyword (st, Qtype, chartab_type_validate); | |
| 1891 define_structure_type_keyword (st, Qdata, chartab_data_validate); | |
| 1892 } | |
| 1893 | |
| 1894 void | |
| 1895 complex_vars_of_chartab (void) | |
| 1896 { | |
| 1897 #ifdef MULE | |
| 1898 /* Set this now, so first buffer creation can refer to it. */ | |
| 1899 /* Make it nil before calling copy-category-table | |
| 1900 so that copy-category-table will know not to try to copy from garbage */ | |
| 1901 Vstandard_category_table = Qnil; | |
| 1902 Vstandard_category_table = Fcopy_category_table (Qnil); | |
| 1903 staticpro (&Vstandard_category_table); | |
| 1904 | |
| 1905 DEFVAR_LISP ("word-combining-categories", &Vword_combining_categories /* | |
| 1906 List of pair (cons) of categories to determine word boundary. | |
| 1907 | |
| 1908 Emacs treats a sequence of word constituent characters as a single | |
| 1909 word (i.e. finds no word boundary between them) iff they belongs to | |
| 1910 the same charset. But, exceptions are allowed in the following cases. | |
| 1911 | |
| 444 | 1912 \(1) The case that characters are in different charsets is controlled |
| 428 | 1913 by the variable `word-combining-categories'. |
| 1914 | |
| 1915 Emacs finds no word boundary between characters of different charsets | |
| 1916 if they have categories matching some element of this list. | |
| 1917 | |
| 1918 More precisely, if an element of this list is a cons of category CAT1 | |
| 1919 and CAT2, and a multibyte character C1 which has CAT1 is followed by | |
| 1920 C2 which has CAT2, there's no word boundary between C1 and C2. | |
| 1921 | |
| 1922 For instance, to tell that ASCII characters and Latin-1 characters can | |
| 1923 form a single word, the element `(?l . ?l)' should be in this list | |
| 1924 because both characters have the category `l' (Latin characters). | |
| 1925 | |
| 444 | 1926 \(2) The case that character are in the same charset is controlled by |
| 428 | 1927 the variable `word-separating-categories'. |
| 1928 | |
| 1929 Emacs find a word boundary between characters of the same charset | |
| 1930 if they have categories matching some element of this list. | |
| 1931 | |
| 1932 More precisely, if an element of this list is a cons of category CAT1 | |
| 1933 and CAT2, and a multibyte character C1 which has CAT1 is followed by | |
| 1934 C2 which has CAT2, there's a word boundary between C1 and C2. | |
| 1935 | |
| 1936 For instance, to tell that there's a word boundary between Japanese | |
| 1937 Hiragana and Japanese Kanji (both are in the same charset), the | |
| 1938 element `(?H . ?C) should be in this list. | |
| 1939 */ ); | |
| 1940 | |
| 1941 Vword_combining_categories = Qnil; | |
| 1942 | |
| 1943 DEFVAR_LISP ("word-separating-categories", &Vword_separating_categories /* | |
| 1944 List of pair (cons) of categories to determine word boundary. | |
| 1945 See the documentation of the variable `word-combining-categories'. | |
| 1946 */ ); | |
| 1947 | |
| 1948 Vword_separating_categories = Qnil; | |
| 1949 #endif /* MULE */ | |
| 1950 } |