Mercurial > hg > xemacs-beta
annotate src/chartab.c @ 4952:19a72041c5ed
Mule-izing, various fixes related to char * arguments
-------------------- ChangeLog entries follow: --------------------
modules/ChangeLog addition:
2010-01-26 Ben Wing <ben@xemacs.org>
* postgresql/postgresql.c:
* postgresql/postgresql.c (CHECK_LIVE_CONNECTION):
* postgresql/postgresql.c (print_pgresult):
* postgresql/postgresql.c (Fpq_conn_defaults):
* postgresql/postgresql.c (Fpq_connectdb):
* postgresql/postgresql.c (Fpq_connect_start):
* postgresql/postgresql.c (Fpq_result_status):
* postgresql/postgresql.c (Fpq_res_status):
Mule-ize large parts of it.
2010-01-26 Ben Wing <ben@xemacs.org>
* ldap/eldap.c (print_ldap):
* ldap/eldap.c (allocate_ldap):
Use write_ascstring().
src/ChangeLog addition:
2010-01-26 Ben Wing <ben@xemacs.org>
* alloc.c:
* alloc.c (build_ascstring):
* alloc.c (build_msg_cistring):
* alloc.c (staticpro_1):
* alloc.c (staticpro_name):
* alloc.c (staticpro_nodump_1):
* alloc.c (staticpro_nodump_name):
* alloc.c (unstaticpro_nodump_1):
* alloc.c (mcpro_1):
* alloc.c (mcpro_name):
* alloc.c (object_memory_usage_stats):
* alloc.c (common_init_alloc_early):
* alloc.c (init_alloc_once_early):
* buffer.c (print_buffer):
* buffer.c (vars_of_buffer):
* buffer.c (common_init_complex_vars_of_buffer):
* buffer.c (init_initial_directory):
* bytecode.c (invalid_byte_code):
* bytecode.c (print_compiled_function):
* bytecode.c (mark_compiled_function):
* chartab.c (print_table_entry):
* chartab.c (print_char_table):
* config.h.in:
* console-gtk.c:
* console-gtk.c (gtk_device_to_console_connection):
* console-gtk.c (gtk_semi_canonicalize_console_connection):
* console-gtk.c (gtk_canonicalize_console_connection):
* console-gtk.c (gtk_semi_canonicalize_device_connection):
* console-gtk.c (gtk_canonicalize_device_connection):
* console-stream.c (stream_init_frame_1):
* console-stream.c (vars_of_console_stream):
* console-stream.c (init_console_stream):
* console-x.c (x_semi_canonicalize_console_connection):
* console-x.c (x_semi_canonicalize_device_connection):
* console-x.c (x_canonicalize_device_connection):
* console-x.h:
* data.c (eq_with_ebola_notice):
* data.c (Fsubr_interactive):
* data.c (Fnumber_to_string):
* data.c (digit_to_number):
* device-gtk.c (gtk_init_device):
* device-msw.c (print_devmode):
* device-x.c (x_event_name):
* dialog-msw.c (handle_directory_dialog_box):
* dialog-msw.c (handle_file_dialog_box):
* dialog-msw.c (vars_of_dialog_mswindows):
* doc.c (weird_doc):
* doc.c (Fsnarf_documentation):
* doc.c (vars_of_doc):
* dumper.c (pdump):
* dynarr.c:
* dynarr.c (Dynarr_realloc):
* editfns.c (Fuser_real_login_name):
* editfns.c (get_home_directory):
* elhash.c (print_hash_table_data):
* elhash.c (print_hash_table):
* emacs.c (main_1):
* emacs.c (vars_of_emacs):
* emodules.c:
* emodules.c (_emodules_list):
* emodules.c (Fload_module):
* emodules.c (Funload_module):
* emodules.c (Flist_modules):
* emodules.c (find_make_module):
* emodules.c (attempt_module_delete):
* emodules.c (emodules_load):
* emodules.c (emodules_doc_subr):
* emodules.c (emodules_doc_sym):
* emodules.c (syms_of_module):
* emodules.c (vars_of_module):
* emodules.h:
* eval.c (print_subr):
* eval.c (signal_call_debugger):
* eval.c (build_error_data):
* eval.c (signal_error):
* eval.c (maybe_signal_error):
* eval.c (signal_continuable_error):
* eval.c (maybe_signal_continuable_error):
* eval.c (signal_error_2):
* eval.c (maybe_signal_error_2):
* eval.c (signal_continuable_error_2):
* eval.c (maybe_signal_continuable_error_2):
* eval.c (signal_ferror):
* eval.c (maybe_signal_ferror):
* eval.c (signal_continuable_ferror):
* eval.c (maybe_signal_continuable_ferror):
* eval.c (signal_ferror_with_frob):
* eval.c (maybe_signal_ferror_with_frob):
* eval.c (signal_continuable_ferror_with_frob):
* eval.c (maybe_signal_continuable_ferror_with_frob):
* eval.c (syntax_error):
* eval.c (syntax_error_2):
* eval.c (maybe_syntax_error):
* eval.c (sferror):
* eval.c (sferror_2):
* eval.c (maybe_sferror):
* eval.c (invalid_argument):
* eval.c (invalid_argument_2):
* eval.c (maybe_invalid_argument):
* eval.c (invalid_constant):
* eval.c (invalid_constant_2):
* eval.c (maybe_invalid_constant):
* eval.c (invalid_operation):
* eval.c (invalid_operation_2):
* eval.c (maybe_invalid_operation):
* eval.c (invalid_change):
* eval.c (invalid_change_2):
* eval.c (maybe_invalid_change):
* eval.c (invalid_state):
* eval.c (invalid_state_2):
* eval.c (maybe_invalid_state):
* eval.c (wtaerror):
* eval.c (stack_overflow):
* eval.c (out_of_memory):
* eval.c (print_multiple_value):
* eval.c (issue_call_trapping_problems_warning):
* eval.c (backtrace_specials):
* eval.c (backtrace_unevalled_args):
* eval.c (Fbacktrace):
* eval.c (warn_when_safe):
* event-Xt.c (modwarn):
* event-Xt.c (modbarf):
* event-Xt.c (check_modifier):
* event-Xt.c (store_modifier):
* event-Xt.c (emacs_Xt_format_magic_event):
* event-Xt.c (describe_event):
* event-gtk.c (dragndrop_data_received):
* event-gtk.c (store_modifier):
* event-gtk.c (gtk_reset_modifier_mapping):
* event-msw.c (dde_eval_string):
* event-msw.c (Fdde_alloc_advise_item):
* event-msw.c (mswindows_dde_callback):
* event-msw.c (FROB):
* event-msw.c (emacs_mswindows_format_magic_event):
* event-stream.c (external_debugging_print_event):
* event-stream.c (execute_help_form):
* event-stream.c (vars_of_event_stream):
* events.c (print_event_1):
* events.c (print_event):
* events.c (event_equal):
* extents.c (print_extent_1):
* extents.c (print_extent):
* extents.c (vars_of_extents):
* faces.c (print_face):
* faces.c (complex_vars_of_faces):
* file-coding.c:
* file-coding.c (print_coding_system):
* file-coding.c (print_coding_system_in_print_method):
* file-coding.c (default_query_method):
* file-coding.c (find_coding_system):
* file-coding.c (make_coding_system_1):
* file-coding.c (chain_print):
* file-coding.c (undecided_print):
* file-coding.c (gzip_print):
* file-coding.c (vars_of_file_coding):
* file-coding.c (complex_vars_of_file_coding):
* fileio.c:
* fileio.c (report_file_type_error):
* fileio.c (report_error_with_errno):
* fileio.c (report_file_error):
* fileio.c (barf_or_query_if_file_exists):
* fileio.c (vars_of_fileio):
* floatfns.c (matherr):
* fns.c (print_bit_vector):
* fns.c (Fmapconcat):
* fns.c (add_suffix_to_symbol):
* fns.c (add_prefix_to_symbol):
* frame-gtk.c:
* frame-gtk.c (Fgtk_window_id):
* frame-x.c (def):
* frame-x.c (x_cde_transfer_callback):
* frame.c:
* frame.c (Fmake_frame):
* gc.c (show_gc_cursor_and_message):
* gc.c (vars_of_gc):
* glyphs-eimage.c (png_instantiate):
* glyphs-eimage.c (tiff_instantiate):
* glyphs-gtk.c (gtk_print_image_instance):
* glyphs-msw.c (mswindows_print_image_instance):
* glyphs-x.c (x_print_image_instance):
* glyphs-x.c (update_widget_face):
* glyphs.c (make_string_from_file):
* glyphs.c (print_image_instance):
* glyphs.c (signal_image_error):
* glyphs.c (signal_image_error_2):
* glyphs.c (signal_double_image_error):
* glyphs.c (signal_double_image_error_2):
* glyphs.c (xbm_mask_file_munging):
* glyphs.c (pixmap_to_lisp_data):
* glyphs.h:
* gui.c (gui_item_display_flush_left):
* hpplay.c (player_error_internal):
* hpplay.c (myHandler):
* intl-win32.c:
* intl-win32.c (langcode_to_lang):
* intl-win32.c (sublangcode_to_lang):
* intl-win32.c (Fmswindows_get_locale_info):
* intl-win32.c (lcid_to_locale_mule_or_no):
* intl-win32.c (mswindows_multibyte_to_unicode_print):
* intl-win32.c (complex_vars_of_intl_win32):
* keymap.c:
* keymap.c (print_keymap):
* keymap.c (ensure_meta_prefix_char_keymapp):
* keymap.c (Fkey_description):
* keymap.c (Ftext_char_description):
* lisp.h:
* lisp.h (struct):
* lisp.h (DECLARE_INLINE_HEADER):
* lread.c (Fload_internal):
* lread.c (locate_file):
* lread.c (read_escape):
* lread.c (read_raw_string):
* lread.c (read1):
* lread.c (read_list):
* lread.c (read_compiled_function):
* lread.c (init_lread):
* lrecord.h:
* marker.c (print_marker):
* marker.c (marker_equal):
* menubar-msw.c (displayable_menu_item):
* menubar-x.c (command_builder_operate_menu_accelerator):
* menubar.c (vars_of_menubar):
* minibuf.c (reinit_complex_vars_of_minibuf):
* minibuf.c (complex_vars_of_minibuf):
* mule-charset.c (Fmake_charset):
* mule-charset.c (complex_vars_of_mule_charset):
* mule-coding.c (iso2022_print):
* mule-coding.c (fixed_width_query):
* number.c (bignum_print):
* number.c (ratio_print):
* number.c (bigfloat_print):
* number.c (bigfloat_finalize):
* objects-msw.c:
* objects-msw.c (mswindows_color_to_string):
* objects-msw.c (mswindows_color_list):
* objects-tty.c:
* objects-tty.c (tty_font_list):
* objects-tty.c (tty_find_charset_font):
* objects-xlike-inc.c (xft_find_charset_font):
* objects-xlike-inc.c (endif):
* print.c:
* print.c (write_istring):
* print.c (write_ascstring):
* print.c (Fterpri):
* print.c (Fprint):
* print.c (print_error_message):
* print.c (print_vector_internal):
* print.c (print_cons):
* print.c (print_string):
* print.c (printing_unreadable_object):
* print.c (print_internal):
* print.c (print_float):
* print.c (print_symbol):
* process-nt.c (mswindows_report_winsock_error):
* process-nt.c (nt_canonicalize_host_name):
* process-unix.c (unix_canonicalize_host_name):
* process.c (print_process):
* process.c (report_process_error):
* process.c (report_network_error):
* process.c (make_process_internal):
* process.c (Fstart_process_internal):
* process.c (status_message):
* process.c (putenv_internal):
* process.c (vars_of_process):
* process.h:
* profile.c (vars_of_profile):
* rangetab.c (print_range_table):
* realpath.c (vars_of_realpath):
* redisplay.c (vars_of_redisplay):
* search.c (wordify):
* search.c (Freplace_match):
* sheap.c (sheap_adjust_h):
* sound.c (report_sound_error):
* sound.c (Fplay_sound_file):
* specifier.c (print_specifier):
* symbols.c (Fsubr_name):
* symbols.c (do_symval_forwarding):
* symbols.c (set_default_buffer_slot_variable):
* symbols.c (set_default_console_slot_variable):
* symbols.c (store_symval_forwarding):
* symbols.c (default_value):
* symbols.c (defsymbol_massage_name_1):
* symbols.c (defsymbol_massage_name_nodump):
* symbols.c (defsymbol_massage_name):
* symbols.c (defsymbol_massage_multiword_predicate_nodump):
* symbols.c (defsymbol_massage_multiword_predicate):
* symbols.c (defsymbol_nodump):
* symbols.c (defsymbol):
* symbols.c (defkeyword):
* symbols.c (defkeyword_massage_name):
* symbols.c (check_module_subr):
* symbols.c (deferror_1):
* symbols.c (deferror):
* symbols.c (deferror_massage_name):
* symbols.c (deferror_massage_name_and_message):
* symbols.c (defvar_magic):
* symeval.h:
* symeval.h (DEFVAR_SYMVAL_FWD):
* sysdep.c:
* sysdep.c (init_system_name):
* sysdll.c:
* sysdll.c (MAYBE_PREPEND_UNDERSCORE):
* sysdll.c (dll_function):
* sysdll.c (dll_variable):
* sysdll.c (dll_error):
* sysdll.c (dll_open):
* sysdll.c (dll_close):
* sysdll.c (image_for_address):
* sysdll.c (my_find_image):
* sysdll.c (search_linked_libs):
* sysdll.h:
* sysfile.h:
* sysfile.h (DEFAULT_DIRECTORY_FALLBACK):
* syswindows.h:
* tests.c (DFC_CHECK_LENGTH):
* tests.c (DFC_CHECK_CONTENT):
* tests.c (Ftest_hash_tables):
* text.c (vars_of_text):
* text.h:
* tooltalk.c (tt_opnum_string):
* tooltalk.c (tt_message_arg_ival_string):
* tooltalk.c (Ftooltalk_default_procid):
* tooltalk.c (Ftooltalk_default_session):
* tooltalk.c (init_tooltalk):
* tooltalk.c (vars_of_tooltalk):
* ui-gtk.c (Fdll_load):
* ui-gtk.c (type_to_marshaller_type):
* ui-gtk.c (Fgtk_import_function_internal):
* ui-gtk.c (emacs_gtk_object_printer):
* ui-gtk.c (emacs_gtk_boxed_printer):
* unicode.c (unicode_to_ichar):
* unicode.c (unicode_print):
* unicode.c (unicode_query):
* unicode.c (vars_of_unicode):
* unicode.c (complex_vars_of_unicode):
* win32.c:
* win32.c (mswindows_report_process_error):
* window.c (print_window):
* xemacs.def.in.in:
BASIC IDEA: Further fixing up uses of char * and CIbyte *
to reflect their actual semantics; Mule-izing some code;
redoing of the not-yet-working code to handle message translation.
Clean up code to handle message-translation (not yet working).
Create separate versions of build_msg_string() for working with
Ibyte *, CIbyte *, and Ascbyte * arguments. Assert that Ascbyte *
arguments are pure-ASCII. Make build_msg_string() be the same
as build_msg_ascstring(). Create same three versions of GETTEXT()
and DEFER_GETTEXT(). Also create build_defer_string() and
variants for the equivalent of DEFER_GETTEXT() when building a
string. Remove old CGETTEXT(). Clean up code where GETTEXT(),
DEFER_GETTEXT(), build_msg_string(), etc. was being called and
introduce some new calls to build_msg_string(), etc. Remove
GETTEXT() from calls to weird_doc() -- we assume that the
message snarfer knows about weird_doc(). Remove uses of
DEFER_GETTEXT() from error messages in sysdep.c and instead use
special comments /* @@@begin-snarf@@@ */ and /* @@@end-snarf@@@ */
that the message snarfer presumably knows about.
Create build_ascstring() and use it in many instances in place
of build_string(). The purpose of having Ascbyte * variants is
to make the code more self-documenting in terms of what sort of
semantics is expected for char * strings. In fact in the process
of looking for uses of build_string(), much improperly Mule-ized
was discovered.
Mule-ize a lot of code as described in previous paragraph,
e.g. in sysdep.c.
Make the error functions take Ascbyte * strings and fix up a
couple of places where non-pure-ASCII strings were being passed in
(file-coding.c, mule-coding.c, unicode.c). (It's debatable whether
we really need to make the error functions work this way. It
helps catch places where code is written in a way that message
translation won't work, but we may well never implement message
translation.)
Make staticpro() and friends take Ascbyte * strings instead of
raw char * strings. Create a const_Ascbyte_ptr dynarr type
to describe what's held by staticpro_names[] and friends,
create pdump descriptions for const_Ascbyte_ptr dynarrs, and
use them in place of specially-crafted staticpro descriptions.
Mule-ize certain other functions (e.g. x_event_name) by correcting
raw use of char * to Ascbyte *, Rawbyte * or another such type,
and raw use of char[] buffers to another type (usually Ascbyte[]).
Change many uses of write_c_string() to write_msg_string(),
write_ascstring(), etc.
Mule-ize emodules.c, emodules.h, sysdll.h.
Fix some un-Mule-ized code in intl-win32.c.
A comment in event-Xt.c and the limitations of the message
snarfer (make-msgfile or whatever) is presumably incorrect --
it should be smart enough to handle function calls spread over
more than one line. Clean up code in event-Xt.c that was
written awkwardly for this reason.
In config.h.in, instead of NEED_ERROR_CHECK_TYPES_INLINES,
create a more general XEMACS_DEFS_NEEDS_INLINE_DECLS to
indicate when inlined functions need to be declared in
xemacs.defs.in.in, and make use of it in xemacs.defs.in.in.
We need to do this because postgresql.c now calls qxestrdup(),
which is an inline function.
Make nconc2() and other such functions MODULE_API and put
them in xemacs.defs.in.in since postgresql.c now uses them.
Clean up indentation in lread.c and a few other places.
In text.h, document ASSERT_ASCTEXT_ASCII() and
ASSERT_ASCTEXT_ASCII_LEN(), group together the stand-in
encodings and add some more for DLL symbols, function and
variable names, etc.
| author | Ben Wing <ben@xemacs.org> |
|---|---|
| date | Tue, 26 Jan 2010 23:22:30 -0600 |
| parents | 8b63e21b0436 |
| children | e813cf16c015 |
| 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 | |
| 115 char_table_entry_equal (Lisp_Object obj1, Lisp_Object obj2, int depth) | |
| 116 { | |
| 440 | 117 Lisp_Char_Table_Entry *cte1 = XCHAR_TABLE_ENTRY (obj1); |
| 118 Lisp_Char_Table_Entry *cte2 = XCHAR_TABLE_ENTRY (obj2); | |
| 428 | 119 int i; |
| 120 | |
| 121 for (i = 0; i < 96; i++) | |
| 122 if (!internal_equal (cte1->level2[i], cte2->level2[i], depth + 1)) | |
| 123 return 0; | |
| 124 | |
| 125 return 1; | |
| 126 } | |
| 127 | |
| 665 | 128 static Hashcode |
| 428 | 129 char_table_entry_hash (Lisp_Object obj, int depth) |
| 130 { | |
| 440 | 131 Lisp_Char_Table_Entry *cte = XCHAR_TABLE_ENTRY (obj); |
| 428 | 132 |
| 826 | 133 return internal_array_hash (cte->level2, 96, depth + 1); |
| 428 | 134 } |
| 135 | |
| 1204 | 136 static const struct memory_description char_table_entry_description[] = { |
| 440 | 137 { XD_LISP_OBJECT_ARRAY, offsetof (Lisp_Char_Table_Entry, level2), 96 }, |
| 428 | 138 { XD_END } |
| 139 }; | |
| 140 | |
| 934 | 141 DEFINE_LRECORD_IMPLEMENTATION ("char-table-entry", char_table_entry, |
| 142 1, /* dumpable flag */ | |
| 143 mark_char_table_entry, internal_object_printer, | |
| 144 0, char_table_entry_equal, | |
| 145 char_table_entry_hash, | |
| 146 char_table_entry_description, | |
| 147 Lisp_Char_Table_Entry); | |
| 148 | |
| 428 | 149 #endif /* MULE */ |
| 150 | |
| 151 static Lisp_Object | |
| 152 mark_char_table (Lisp_Object obj) | |
| 153 { | |
| 440 | 154 Lisp_Char_Table *ct = XCHAR_TABLE (obj); |
| 428 | 155 int i; |
| 156 | |
| 157 for (i = 0; i < NUM_ASCII_CHARS; i++) | |
| 158 mark_object (ct->ascii[i]); | |
| 159 #ifdef MULE | |
| 160 for (i = 0; i < NUM_LEADING_BYTES; i++) | |
| 161 mark_object (ct->level1[i]); | |
| 162 #endif | |
| 793 | 163 mark_object (ct->parent); |
| 164 mark_object (ct->default_); | |
| 428 | 165 return ct->mirror_table; |
| 166 } | |
| 167 | |
| 168 /* WARNING: All functions of this nature need to be written extremely | |
| 169 carefully to avoid crashes during GC. Cf. prune_specifiers() | |
| 170 and prune_weak_hash_tables(). */ | |
| 171 | |
| 172 void | |
| 173 prune_syntax_tables (void) | |
| 174 { | |
| 175 Lisp_Object rest, prev = Qnil; | |
| 176 | |
| 177 for (rest = Vall_syntax_tables; | |
| 178 !NILP (rest); | |
| 179 rest = XCHAR_TABLE (rest)->next_table) | |
| 180 { | |
| 181 if (! marked_p (rest)) | |
| 182 { | |
| 183 /* This table is garbage. Remove it from the list. */ | |
| 184 if (NILP (prev)) | |
| 185 Vall_syntax_tables = XCHAR_TABLE (rest)->next_table; | |
| 186 else | |
| 187 XCHAR_TABLE (prev)->next_table = | |
| 188 XCHAR_TABLE (rest)->next_table; | |
| 189 } | |
| 190 } | |
| 191 } | |
| 192 | |
| 193 static Lisp_Object | |
| 194 char_table_type_to_symbol (enum char_table_type type) | |
| 195 { | |
| 196 switch (type) | |
| 197 { | |
| 2500 | 198 default: ABORT(); |
| 428 | 199 case CHAR_TABLE_TYPE_GENERIC: return Qgeneric; |
| 200 case CHAR_TABLE_TYPE_SYNTAX: return Qsyntax; | |
| 201 case CHAR_TABLE_TYPE_DISPLAY: return Qdisplay; | |
| 202 case CHAR_TABLE_TYPE_CHAR: return Qchar; | |
| 203 #ifdef MULE | |
| 204 case CHAR_TABLE_TYPE_CATEGORY: return Qcategory; | |
| 205 #endif | |
| 206 } | |
| 207 } | |
| 208 | |
| 209 static enum char_table_type | |
| 210 symbol_to_char_table_type (Lisp_Object symbol) | |
| 211 { | |
| 212 CHECK_SYMBOL (symbol); | |
| 213 | |
| 214 if (EQ (symbol, Qgeneric)) return CHAR_TABLE_TYPE_GENERIC; | |
| 215 if (EQ (symbol, Qsyntax)) return CHAR_TABLE_TYPE_SYNTAX; | |
| 216 if (EQ (symbol, Qdisplay)) return CHAR_TABLE_TYPE_DISPLAY; | |
| 217 if (EQ (symbol, Qchar)) return CHAR_TABLE_TYPE_CHAR; | |
| 218 #ifdef MULE | |
| 219 if (EQ (symbol, Qcategory)) return CHAR_TABLE_TYPE_CATEGORY; | |
| 220 #endif | |
| 221 | |
| 563 | 222 invalid_constant ("Unrecognized char table type", symbol); |
| 1204 | 223 RETURN_NOT_REACHED (CHAR_TABLE_TYPE_GENERIC); |
| 428 | 224 } |
| 225 | |
| 226 static void | |
| 826 | 227 decode_char_table_range (Lisp_Object range, struct chartab_range *outrange) |
| 428 | 228 { |
| 4932 | 229 xzero (*outrange); |
| 826 | 230 if (EQ (range, Qt)) |
| 231 outrange->type = CHARTAB_RANGE_ALL; | |
| 232 else if (CHAR_OR_CHAR_INTP (range)) | |
| 233 { | |
| 234 outrange->type = CHARTAB_RANGE_CHAR; | |
| 235 outrange->ch = XCHAR_OR_CHAR_INT (range); | |
| 236 } | |
| 237 #ifndef MULE | |
| 428 | 238 else |
| 826 | 239 sferror ("Range must be t or a character", range); |
| 240 #else /* MULE */ | |
| 241 else if (VECTORP (range)) | |
| 242 { | |
| 243 Lisp_Vector *vec = XVECTOR (range); | |
| 244 Lisp_Object *elts = vector_data (vec); | |
| 245 if (vector_length (vec) != 2) | |
| 246 sferror ("Length of charset row vector must be 2", | |
| 247 range); | |
| 248 outrange->type = CHARTAB_RANGE_ROW; | |
| 249 outrange->charset = Fget_charset (elts[0]); | |
| 250 CHECK_INT (elts[1]); | |
| 251 outrange->row = XINT (elts[1]); | |
| 252 switch (XCHARSET_TYPE (outrange->charset)) | |
| 253 { | |
| 254 case CHARSET_TYPE_94: | |
| 255 case CHARSET_TYPE_96: | |
| 256 sferror ("Charset in row vector must be multi-byte", | |
| 257 outrange->charset); | |
| 258 case CHARSET_TYPE_94X94: | |
| 259 check_int_range (outrange->row, 33, 126); | |
| 260 break; | |
| 261 case CHARSET_TYPE_96X96: | |
| 262 check_int_range (outrange->row, 32, 127); | |
| 263 break; | |
| 264 default: | |
| 2500 | 265 ABORT (); |
| 826 | 266 } |
| 267 } | |
| 268 else | |
| 269 { | |
| 270 if (!CHARSETP (range) && !SYMBOLP (range)) | |
| 271 sferror | |
| 272 ("Char table range must be t, charset, char, or vector", range); | |
| 273 outrange->type = CHARTAB_RANGE_CHARSET; | |
| 274 outrange->charset = Fget_charset (range); | |
| 275 } | |
| 276 #endif /* MULE */ | |
| 428 | 277 } |
| 278 | |
| 826 | 279 static Lisp_Object |
| 280 encode_char_table_range (struct chartab_range *range) | |
| 428 | 281 { |
| 826 | 282 switch (range->type) |
| 428 | 283 { |
| 826 | 284 case CHARTAB_RANGE_ALL: |
| 285 return Qt; | |
| 286 | |
| 287 #ifdef MULE | |
| 288 case CHARTAB_RANGE_CHARSET: | |
| 289 return XCHARSET_NAME (Fget_charset (range->charset)); | |
| 428 | 290 |
| 826 | 291 case CHARTAB_RANGE_ROW: |
| 292 return vector2 (XCHARSET_NAME (Fget_charset (range->charset)), | |
| 293 make_int (range->row)); | |
| 294 #endif | |
| 295 case CHARTAB_RANGE_CHAR: | |
| 296 return make_char (range->ch); | |
| 297 default: | |
| 2500 | 298 ABORT (); |
| 428 | 299 } |
| 826 | 300 return Qnil; /* not reached */ |
| 428 | 301 } |
| 302 | |
| 826 | 303 struct ptemap |
| 428 | 304 { |
| 826 | 305 Lisp_Object printcharfun; |
| 306 int first; | |
| 307 }; | |
| 428 | 308 |
| 826 | 309 static int |
| 2286 | 310 print_table_entry (struct chartab_range *range, Lisp_Object UNUSED (table), |
| 826 | 311 Lisp_Object val, void *arg) |
| 312 { | |
| 313 struct ptemap *a = (struct ptemap *) arg; | |
| 314 struct gcpro gcpro1; | |
| 315 Lisp_Object lisprange; | |
| 316 if (!a->first) | |
|
4952
19a72041c5ed
Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents:
4932
diff
changeset
|
317 write_ascstring (a->printcharfun, " "); |
| 826 | 318 a->first = 0; |
| 319 lisprange = encode_char_table_range (range); | |
| 320 GCPRO1 (lisprange); | |
|
4580
1d11ecca9cd0
Print char table values correctly.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4469
diff
changeset
|
321 write_fmt_string_lisp (a->printcharfun, "%s %S", 2, lisprange, val); |
| 826 | 322 UNGCPRO; |
| 323 return 0; | |
| 428 | 324 } |
| 325 | |
| 326 static void | |
| 2286 | 327 print_char_table (Lisp_Object obj, Lisp_Object printcharfun, |
| 328 int UNUSED (escapeflag)) | |
| 428 | 329 { |
| 440 | 330 Lisp_Char_Table *ct = XCHAR_TABLE (obj); |
| 826 | 331 struct chartab_range range; |
| 332 struct ptemap arg; | |
| 333 | |
| 334 range.type = CHARTAB_RANGE_ALL; | |
| 335 arg.printcharfun = printcharfun; | |
| 336 arg.first = 1; | |
| 428 | 337 |
| 793 | 338 write_fmt_string_lisp (printcharfun, "#s(char-table type %s data (", |
| 339 1, char_table_type_to_symbol (ct->type)); | |
| 826 | 340 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
|
341 write_ascstring (printcharfun, "))"); |
| 428 | 342 |
| 826 | 343 /* #### need to print and read the default; but that will allow the |
| 344 default to be modified, which we don't (yet) support -- but FSF does */ | |
| 428 | 345 } |
| 346 | |
| 347 static int | |
| 348 char_table_equal (Lisp_Object obj1, Lisp_Object obj2, int depth) | |
| 349 { | |
| 440 | 350 Lisp_Char_Table *ct1 = XCHAR_TABLE (obj1); |
| 351 Lisp_Char_Table *ct2 = XCHAR_TABLE (obj2); | |
| 428 | 352 int i; |
| 353 | |
| 354 if (CHAR_TABLE_TYPE (ct1) != CHAR_TABLE_TYPE (ct2)) | |
| 355 return 0; | |
| 356 | |
| 357 for (i = 0; i < NUM_ASCII_CHARS; i++) | |
| 358 if (!internal_equal (ct1->ascii[i], ct2->ascii[i], depth + 1)) | |
| 359 return 0; | |
| 360 | |
| 361 #ifdef MULE | |
| 362 for (i = 0; i < NUM_LEADING_BYTES; i++) | |
| 363 if (!internal_equal (ct1->level1[i], ct2->level1[i], depth + 1)) | |
| 364 return 0; | |
| 365 #endif /* MULE */ | |
| 366 | |
| 826 | 367 return internal_equal (ct1->default_, ct2->default_, depth + 1); |
| 428 | 368 } |
| 369 | |
| 665 | 370 static Hashcode |
| 428 | 371 char_table_hash (Lisp_Object obj, int depth) |
| 372 { | |
| 440 | 373 Lisp_Char_Table *ct = XCHAR_TABLE (obj); |
| 665 | 374 Hashcode hashval = internal_array_hash (ct->ascii, NUM_ASCII_CHARS, |
| 826 | 375 depth + 1); |
| 428 | 376 #ifdef MULE |
| 377 hashval = HASH2 (hashval, | |
| 826 | 378 internal_array_hash (ct->level1, NUM_LEADING_BYTES, |
| 379 depth + 1)); | |
| 428 | 380 #endif /* MULE */ |
| 826 | 381 return HASH2 (hashval, internal_hash (ct->default_, depth + 1)); |
| 428 | 382 } |
| 383 | |
| 1204 | 384 static const struct memory_description char_table_description[] = { |
| 440 | 385 { XD_LISP_OBJECT_ARRAY, offsetof (Lisp_Char_Table, ascii), NUM_ASCII_CHARS }, |
| 428 | 386 #ifdef MULE |
| 440 | 387 { XD_LISP_OBJECT_ARRAY, offsetof (Lisp_Char_Table, level1), NUM_LEADING_BYTES }, |
| 428 | 388 #endif |
| 793 | 389 { XD_LISP_OBJECT, offsetof (Lisp_Char_Table, parent) }, |
| 390 { XD_LISP_OBJECT, offsetof (Lisp_Char_Table, default_) }, | |
| 440 | 391 { XD_LISP_OBJECT, offsetof (Lisp_Char_Table, mirror_table) }, |
| 392 { XD_LO_LINK, offsetof (Lisp_Char_Table, next_table) }, | |
| 428 | 393 { XD_END } |
| 394 }; | |
| 395 | |
| 934 | 396 DEFINE_LRECORD_IMPLEMENTATION ("char-table", char_table, |
| 397 1, /*dumpable-flag*/ | |
| 398 mark_char_table, print_char_table, 0, | |
| 399 char_table_equal, char_table_hash, | |
| 400 char_table_description, | |
| 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])) | |
| 3017 | 480 FREE_LCRECORD (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 { | |
| 440 | 599 Lisp_Char_Table *ct; |
| 428 | 600 Lisp_Object obj; |
| 601 enum char_table_type ty = symbol_to_char_table_type (type); | |
| 602 | |
| 3017 | 603 ct = ALLOC_LCRECORD_TYPE (Lisp_Char_Table, &lrecord_char_table); |
| 428 | 604 ct->type = ty; |
| 1296 | 605 obj = wrap_char_table (ct); |
| 428 | 606 if (ty == CHAR_TABLE_TYPE_SYNTAX) |
| 607 { | |
| 826 | 608 /* Qgeneric not Qsyntax because a syntax table has a mirror table |
| 609 and we don't want infinite recursion */ | |
| 428 | 610 ct->mirror_table = Fmake_char_table (Qgeneric); |
| 3145 | 611 set_char_table_default (ct->mirror_table, make_int (Sword)); |
| 1296 | 612 XCHAR_TABLE (ct->mirror_table)->mirror_table_p = 1; |
| 613 XCHAR_TABLE (ct->mirror_table)->mirror_table = obj; | |
| 428 | 614 } |
| 615 else | |
| 616 ct->mirror_table = Qnil; | |
| 617 ct->next_table = Qnil; | |
| 793 | 618 ct->parent = Qnil; |
| 619 ct->default_ = Qnil; | |
| 428 | 620 if (ty == CHAR_TABLE_TYPE_SYNTAX) |
| 621 { | |
| 622 ct->next_table = Vall_syntax_tables; | |
| 623 Vall_syntax_tables = obj; | |
| 624 } | |
| 625 Freset_char_table (obj); | |
| 626 return obj; | |
| 627 } | |
| 628 | |
| 629 #ifdef MULE | |
| 630 | |
| 631 static Lisp_Object | |
| 632 make_char_table_entry (Lisp_Object initval) | |
| 633 { | |
| 634 int i; | |
| 440 | 635 Lisp_Char_Table_Entry *cte = |
| 3017 | 636 ALLOC_LCRECORD_TYPE (Lisp_Char_Table_Entry, &lrecord_char_table_entry); |
| 428 | 637 |
| 638 for (i = 0; i < 96; i++) | |
| 639 cte->level2[i] = initval; | |
| 640 | |
| 793 | 641 return wrap_char_table_entry (cte); |
| 428 | 642 } |
| 643 | |
| 644 static Lisp_Object | |
| 645 copy_char_table_entry (Lisp_Object entry) | |
| 646 { | |
| 440 | 647 Lisp_Char_Table_Entry *cte = XCHAR_TABLE_ENTRY (entry); |
| 428 | 648 int i; |
| 440 | 649 Lisp_Char_Table_Entry *ctenew = |
| 3017 | 650 ALLOC_LCRECORD_TYPE (Lisp_Char_Table_Entry, &lrecord_char_table_entry); |
| 428 | 651 |
| 652 for (i = 0; i < 96; i++) | |
| 653 { | |
| 3025 | 654 Lisp_Object new_ = cte->level2[i]; |
| 655 if (CHAR_TABLE_ENTRYP (new_)) | |
| 656 ctenew->level2[i] = copy_char_table_entry (new_); | |
| 428 | 657 else |
| 3025 | 658 ctenew->level2[i] = new_; |
| 428 | 659 } |
| 660 | |
| 793 | 661 return wrap_char_table_entry (ctenew); |
| 428 | 662 } |
| 663 | |
| 664 #endif /* MULE */ | |
| 665 | |
| 666 DEFUN ("copy-char-table", Fcopy_char_table, 1, 1, 0, /* | |
| 444 | 667 Return a new char table which is a copy of CHAR-TABLE. |
| 428 | 668 It will contain the same values for the same characters and ranges |
| 444 | 669 as CHAR-TABLE. The values will not themselves be copied. |
| 428 | 670 */ |
| 444 | 671 (char_table)) |
| 428 | 672 { |
| 440 | 673 Lisp_Char_Table *ct, *ctnew; |
| 428 | 674 Lisp_Object obj; |
| 675 int i; | |
| 676 | |
| 444 | 677 CHECK_CHAR_TABLE (char_table); |
| 678 ct = XCHAR_TABLE (char_table); | |
| 3879 | 679 assert(!ct->mirror_table_p); |
| 3017 | 680 ctnew = ALLOC_LCRECORD_TYPE (Lisp_Char_Table, &lrecord_char_table); |
| 428 | 681 ctnew->type = ct->type; |
| 793 | 682 ctnew->parent = ct->parent; |
| 683 ctnew->default_ = ct->default_; | |
| 3879 | 684 ctnew->mirror_table_p = 0; |
| 1296 | 685 obj = wrap_char_table (ctnew); |
| 428 | 686 |
| 687 for (i = 0; i < NUM_ASCII_CHARS; i++) | |
| 688 { | |
| 3025 | 689 Lisp_Object new_ = ct->ascii[i]; |
| 428 | 690 #ifdef MULE |
| 3025 | 691 assert (! (CHAR_TABLE_ENTRYP (new_))); |
| 428 | 692 #endif /* MULE */ |
| 3025 | 693 ctnew->ascii[i] = new_; |
| 428 | 694 } |
| 695 | |
| 696 #ifdef MULE | |
| 697 | |
| 698 for (i = 0; i < NUM_LEADING_BYTES; i++) | |
| 699 { | |
| 3025 | 700 Lisp_Object new_ = ct->level1[i]; |
| 701 if (CHAR_TABLE_ENTRYP (new_)) | |
| 702 ctnew->level1[i] = copy_char_table_entry (new_); | |
| 428 | 703 else |
| 3025 | 704 ctnew->level1[i] = new_; |
| 428 | 705 } |
| 706 | |
| 707 #endif /* MULE */ | |
| 708 | |
| 3881 | 709 if (!EQ (ct->mirror_table, Qnil)) |
| 1296 | 710 { |
| 3879 | 711 ctnew->mirror_table = Fmake_char_table (Qgeneric); |
| 712 set_char_table_default (ctnew->mirror_table, make_int (Sword)); | |
| 1296 | 713 XCHAR_TABLE (ctnew->mirror_table)->mirror_table = obj; |
| 3879 | 714 XCHAR_TABLE (ctnew->mirror_table)->mirror_table_p = 1; |
| 715 XCHAR_TABLE (ctnew->mirror_table)->dirty = 1; | |
| 1296 | 716 } |
| 428 | 717 else |
| 3879 | 718 ctnew->mirror_table = Qnil; |
| 719 | |
| 428 | 720 ctnew->next_table = Qnil; |
| 721 if (ctnew->type == CHAR_TABLE_TYPE_SYNTAX) | |
| 722 { | |
| 723 ctnew->next_table = Vall_syntax_tables; | |
| 724 Vall_syntax_tables = obj; | |
| 725 } | |
| 726 return obj; | |
| 727 } | |
| 728 | |
| 729 #ifdef MULE | |
| 730 | |
| 826 | 731 /* called from get_char_table(). */ |
| 428 | 732 Lisp_Object |
| 440 | 733 get_non_ascii_char_table_value (Lisp_Char_Table *ct, int leading_byte, |
| 867 | 734 Ichar c) |
| 428 | 735 { |
| 736 Lisp_Object val; | |
| 826 | 737 Lisp_Object charset = charset_by_leading_byte (leading_byte); |
| 428 | 738 int byte1, byte2; |
| 739 | |
| 867 | 740 BREAKUP_ICHAR_1_UNSAFE (c, charset, byte1, byte2); |
| 428 | 741 val = ct->level1[leading_byte - MIN_LEADING_BYTE]; |
| 742 if (CHAR_TABLE_ENTRYP (val)) | |
| 743 { | |
| 440 | 744 Lisp_Char_Table_Entry *cte = XCHAR_TABLE_ENTRY (val); |
| 428 | 745 val = cte->level2[byte1 - 32]; |
| 746 if (CHAR_TABLE_ENTRYP (val)) | |
| 747 { | |
| 748 cte = XCHAR_TABLE_ENTRY (val); | |
| 749 assert (byte2 >= 32); | |
| 750 val = cte->level2[byte2 - 32]; | |
| 751 assert (!CHAR_TABLE_ENTRYP (val)); | |
| 752 } | |
| 753 } | |
| 754 | |
| 755 return val; | |
| 756 } | |
| 757 | |
| 758 #endif /* MULE */ | |
| 759 | |
| 826 | 760 DEFUN ("char-table-default", Fchar_table_default, 1, 1, 0, /* |
| 761 Return the default value for CHAR-TABLE. When an entry for a character | |
| 762 does not exist, the default is returned. | |
| 763 */ | |
| 764 (char_table)) | |
| 428 | 765 { |
| 826 | 766 CHECK_CHAR_TABLE (char_table); |
| 767 return XCHAR_TABLE (char_table)->default_; | |
| 428 | 768 } |
| 769 | |
| 826 | 770 DEFUN ("set-char-table-default", Fset_char_table_default, 2, 2, 0, /* |
| 771 Set the default value for CHAR-TABLE to DEFAULT. | |
| 772 Currently, the default value for syntax tables cannot be changed. | |
| 773 (This policy might change in the future.) | |
| 774 */ | |
| 775 (char_table, default_)) | |
| 776 { | |
| 777 CHECK_CHAR_TABLE (char_table); | |
| 778 if (XCHAR_TABLE_TYPE (char_table) == CHAR_TABLE_TYPE_SYNTAX) | |
| 779 invalid_change ("Can't change default for syntax tables", char_table); | |
| 780 check_valid_char_table_value (default_, XCHAR_TABLE_TYPE (char_table), | |
| 781 ERROR_ME); | |
| 782 set_char_table_default (char_table, default_); | |
| 783 return Qnil; | |
| 784 } | |
| 428 | 785 |
| 786 DEFUN ("get-char-table", Fget_char_table, 2, 2, 0, /* | |
| 444 | 787 Find value for CHARACTER in CHAR-TABLE. |
| 428 | 788 */ |
| 444 | 789 (character, char_table)) |
| 428 | 790 { |
| 444 | 791 CHECK_CHAR_TABLE (char_table); |
| 792 CHECK_CHAR_COERCE_INT (character); | |
| 428 | 793 |
| 826 | 794 return get_char_table (XCHAR (character), char_table); |
| 795 } | |
| 796 | |
| 797 static int | |
| 2286 | 798 copy_mapper (struct chartab_range *range, Lisp_Object UNUSED (table), |
| 826 | 799 Lisp_Object val, void *arg) |
| 800 { | |
| 801 put_char_table (VOID_TO_LISP (arg), range, val); | |
| 802 return 0; | |
| 803 } | |
| 804 | |
| 805 void | |
| 806 copy_char_table_range (Lisp_Object from, Lisp_Object to, | |
| 807 struct chartab_range *range) | |
| 808 { | |
| 809 map_char_table (from, range, copy_mapper, LISP_TO_VOID (to)); | |
| 810 } | |
| 811 | |
| 1296 | 812 static Lisp_Object |
| 813 get_range_char_table_1 (struct chartab_range *range, Lisp_Object table, | |
| 814 Lisp_Object multi) | |
| 826 | 815 { |
| 816 Lisp_Char_Table *ct = XCHAR_TABLE (table); | |
| 817 Lisp_Object retval = Qnil; | |
| 818 | |
| 819 switch (range->type) | |
| 820 { | |
| 821 case CHARTAB_RANGE_CHAR: | |
| 822 return get_char_table (range->ch, table); | |
| 823 | |
| 824 case CHARTAB_RANGE_ALL: | |
| 825 { | |
| 826 int i; | |
| 827 retval = ct->ascii[0]; | |
| 828 | |
| 829 for (i = 1; i < NUM_ASCII_CHARS; i++) | |
| 830 if (!EQ (retval, ct->ascii[i])) | |
| 831 return multi; | |
| 832 | |
| 833 #ifdef MULE | |
| 834 for (i = MIN_LEADING_BYTE; i < MIN_LEADING_BYTE + NUM_LEADING_BYTES; | |
| 835 i++) | |
| 836 { | |
| 837 if (!CHARSETP (charset_by_leading_byte (i)) | |
| 838 || i == LEADING_BYTE_ASCII | |
| 839 || i == LEADING_BYTE_CONTROL_1) | |
| 840 continue; | |
| 841 if (!EQ (retval, ct->level1[i - MIN_LEADING_BYTE])) | |
| 842 return multi; | |
| 843 } | |
| 844 #endif /* MULE */ | |
| 845 | |
| 846 break; | |
| 847 } | |
| 848 | |
| 849 #ifdef MULE | |
| 850 case CHARTAB_RANGE_CHARSET: | |
| 851 if (EQ (range->charset, Vcharset_ascii)) | |
| 852 { | |
| 853 int i; | |
| 854 retval = ct->ascii[0]; | |
| 855 | |
| 856 for (i = 1; i < 128; i++) | |
| 857 if (!EQ (retval, ct->ascii[i])) | |
| 858 return multi; | |
| 859 break; | |
| 860 } | |
| 861 | |
| 862 if (EQ (range->charset, Vcharset_control_1)) | |
| 863 { | |
| 864 int i; | |
| 865 retval = ct->ascii[128]; | |
| 866 | |
| 867 for (i = 129; i < 160; i++) | |
| 868 if (!EQ (retval, ct->ascii[i])) | |
| 869 return multi; | |
| 870 break; | |
| 871 } | |
| 872 | |
| 873 { | |
| 874 retval = ct->level1[XCHARSET_LEADING_BYTE (range->charset) - | |
| 875 MIN_LEADING_BYTE]; | |
| 876 if (CHAR_TABLE_ENTRYP (retval)) | |
| 877 return multi; | |
| 878 break; | |
| 879 } | |
| 880 | |
| 881 case CHARTAB_RANGE_ROW: | |
| 882 { | |
| 883 retval = ct->level1[XCHARSET_LEADING_BYTE (range->charset) - | |
| 884 MIN_LEADING_BYTE]; | |
| 885 if (!CHAR_TABLE_ENTRYP (retval)) | |
| 886 break; | |
| 887 retval = XCHAR_TABLE_ENTRY (retval)->level2[range->row - 32]; | |
| 888 if (CHAR_TABLE_ENTRYP (retval)) | |
| 889 return multi; | |
| 890 break; | |
| 891 } | |
| 892 #endif /* not MULE */ | |
| 893 | |
| 894 default: | |
| 2500 | 895 ABORT (); |
| 826 | 896 } |
| 897 | |
| 898 if (UNBOUNDP (retval)) | |
| 899 return ct->default_; | |
| 900 return retval; | |
| 428 | 901 } |
| 902 | |
| 1296 | 903 Lisp_Object |
| 904 get_range_char_table (struct chartab_range *range, Lisp_Object table, | |
| 905 Lisp_Object multi) | |
| 906 { | |
| 907 if (range->type == CHARTAB_RANGE_CHAR) | |
| 908 return get_char_table (range->ch, table); | |
| 909 else | |
| 910 return get_range_char_table_1 (range, table, multi); | |
| 911 } | |
| 912 | |
| 913 #ifdef ERROR_CHECK_TYPES | |
| 914 | |
| 915 /* Only exists so as not to trip an assert in get_char_table(). */ | |
| 916 Lisp_Object | |
| 917 updating_mirror_get_range_char_table (struct chartab_range *range, | |
| 918 Lisp_Object table, | |
| 919 Lisp_Object multi) | |
| 920 { | |
| 921 if (range->type == CHARTAB_RANGE_CHAR) | |
| 922 return get_char_table_1 (range->ch, table); | |
| 923 else | |
| 924 return get_range_char_table_1 (range, table, multi); | |
| 925 } | |
| 926 | |
| 927 #endif /* ERROR_CHECK_TYPES */ | |
| 928 | |
| 428 | 929 DEFUN ("get-range-char-table", Fget_range_char_table, 2, 3, 0, /* |
| 2714 | 930 Find value for RANGE in CHAR-TABLE. |
| 428 | 931 If there is more than one value, return MULTI (defaults to nil). |
| 2714 | 932 |
| 933 Valid values for RANGE are single characters, charsets, a row in a | |
| 934 two-octet charset, and all characters. See `put-char-table'. | |
| 428 | 935 */ |
| 444 | 936 (range, char_table, multi)) |
| 428 | 937 { |
| 938 struct chartab_range rainj; | |
| 939 | |
| 940 if (CHAR_OR_CHAR_INTP (range)) | |
| 444 | 941 return Fget_char_table (range, char_table); |
| 942 CHECK_CHAR_TABLE (char_table); | |
| 428 | 943 |
| 944 decode_char_table_range (range, &rainj); | |
| 826 | 945 return get_range_char_table (&rainj, char_table, multi); |
| 428 | 946 } |
| 826 | 947 |
| 428 | 948 static int |
| 949 check_valid_char_table_value (Lisp_Object value, enum char_table_type type, | |
| 578 | 950 Error_Behavior errb) |
| 428 | 951 { |
| 952 switch (type) | |
| 953 { | |
| 954 case CHAR_TABLE_TYPE_SYNTAX: | |
| 955 if (!ERRB_EQ (errb, ERROR_ME)) | |
| 956 return INTP (value) || (CONSP (value) && INTP (XCAR (value)) | |
| 957 && CHAR_OR_CHAR_INTP (XCDR (value))); | |
| 958 if (CONSP (value)) | |
| 959 { | |
| 960 Lisp_Object cdr = XCDR (value); | |
| 961 CHECK_INT (XCAR (value)); | |
| 962 CHECK_CHAR_COERCE_INT (cdr); | |
| 963 } | |
| 964 else | |
| 965 CHECK_INT (value); | |
| 966 break; | |
| 967 | |
| 968 #ifdef MULE | |
| 969 case CHAR_TABLE_TYPE_CATEGORY: | |
| 970 if (!ERRB_EQ (errb, ERROR_ME)) | |
| 971 return CATEGORY_TABLE_VALUEP (value); | |
| 972 CHECK_CATEGORY_TABLE_VALUE (value); | |
| 973 break; | |
| 974 #endif /* MULE */ | |
| 975 | |
| 976 case CHAR_TABLE_TYPE_GENERIC: | |
| 977 return 1; | |
| 978 | |
| 979 case CHAR_TABLE_TYPE_DISPLAY: | |
| 980 /* #### fix this */ | |
| 563 | 981 maybe_signal_error (Qunimplemented, |
| 982 "Display char tables not yet implemented", | |
| 983 value, Qchar_table, errb); | |
| 428 | 984 return 0; |
| 985 | |
| 986 case CHAR_TABLE_TYPE_CHAR: | |
| 987 if (!ERRB_EQ (errb, ERROR_ME)) | |
| 988 return CHAR_OR_CHAR_INTP (value); | |
| 989 CHECK_CHAR_COERCE_INT (value); | |
| 990 break; | |
| 991 | |
| 992 default: | |
| 2500 | 993 ABORT (); |
| 428 | 994 } |
| 995 | |
| 801 | 996 return 0; /* not (usually) reached */ |
| 428 | 997 } |
| 998 | |
| 999 static Lisp_Object | |
| 1000 canonicalize_char_table_value (Lisp_Object value, enum char_table_type type) | |
| 1001 { | |
| 1002 switch (type) | |
| 1003 { | |
| 1004 case CHAR_TABLE_TYPE_SYNTAX: | |
| 1005 if (CONSP (value)) | |
| 1006 { | |
| 1007 Lisp_Object car = XCAR (value); | |
| 1008 Lisp_Object cdr = XCDR (value); | |
| 1009 CHECK_CHAR_COERCE_INT (cdr); | |
| 1010 return Fcons (car, cdr); | |
| 1011 } | |
| 1012 break; | |
| 1013 case CHAR_TABLE_TYPE_CHAR: | |
| 1014 CHECK_CHAR_COERCE_INT (value); | |
| 1015 break; | |
| 1016 default: | |
| 1017 break; | |
| 1018 } | |
| 1019 return value; | |
| 1020 } | |
| 1021 | |
| 1022 DEFUN ("valid-char-table-value-p", Fvalid_char_table_value_p, 2, 2, 0, /* | |
| 1023 Return non-nil if VALUE is a valid value for CHAR-TABLE-TYPE. | |
| 1024 */ | |
| 1025 (value, char_table_type)) | |
| 1026 { | |
| 1027 enum char_table_type type = symbol_to_char_table_type (char_table_type); | |
| 1028 | |
| 1029 return check_valid_char_table_value (value, type, ERROR_ME_NOT) ? Qt : Qnil; | |
| 1030 } | |
| 1031 | |
| 1032 DEFUN ("check-valid-char-table-value", Fcheck_valid_char_table_value, 2, 2, 0, /* | |
| 1033 Signal an error if VALUE is not a valid value for CHAR-TABLE-TYPE. | |
| 1034 */ | |
| 1035 (value, char_table_type)) | |
| 1036 { | |
| 1037 enum char_table_type type = symbol_to_char_table_type (char_table_type); | |
| 1038 | |
| 1039 check_valid_char_table_value (value, type, ERROR_ME); | |
| 1040 return Qnil; | |
| 1041 } | |
| 1042 | |
| 826 | 1043 /* Assign VAL to all characters in RANGE in char table TABLE. */ |
| 428 | 1044 |
| 1045 void | |
| 826 | 1046 put_char_table (Lisp_Object table, struct chartab_range *range, |
| 428 | 1047 Lisp_Object val) |
| 1048 { | |
| 826 | 1049 Lisp_Char_Table *ct = XCHAR_TABLE (table); |
| 1050 | |
| 428 | 1051 switch (range->type) |
| 1052 { | |
| 1053 case CHARTAB_RANGE_ALL: | |
| 1054 fill_char_table (ct, val); | |
| 1296 | 1055 return; /* fill_char_table() recorded the table as dirty. */ |
| 428 | 1056 |
| 1057 #ifdef MULE | |
| 1058 case CHARTAB_RANGE_CHARSET: | |
| 1059 if (EQ (range->charset, Vcharset_ascii)) | |
| 1060 { | |
| 1061 int i; | |
| 1062 for (i = 0; i < 128; i++) | |
| 1063 ct->ascii[i] = val; | |
| 1064 } | |
| 1065 else if (EQ (range->charset, Vcharset_control_1)) | |
| 1066 { | |
| 1067 int i; | |
| 1068 for (i = 128; i < 160; i++) | |
| 1069 ct->ascii[i] = val; | |
| 1070 } | |
| 1071 else | |
| 1072 { | |
| 1073 int lb = XCHARSET_LEADING_BYTE (range->charset) - MIN_LEADING_BYTE; | |
| 1330 | 1074 if (CHAR_TABLE_ENTRYP (ct->level1[lb]) && |
| 1075 !OBJECT_DUMPED_P (ct->level1[lb])) | |
| 3017 | 1076 FREE_LCRECORD (ct->level1[lb]); |
| 428 | 1077 ct->level1[lb] = val; |
| 1078 } | |
| 1079 break; | |
| 1080 | |
| 1081 case CHARTAB_RANGE_ROW: | |
| 1082 { | |
| 440 | 1083 Lisp_Char_Table_Entry *cte; |
| 428 | 1084 int lb = XCHARSET_LEADING_BYTE (range->charset) - MIN_LEADING_BYTE; |
| 1085 /* make sure that there is a separate entry for the row. */ | |
| 1086 if (!CHAR_TABLE_ENTRYP (ct->level1[lb])) | |
| 1087 ct->level1[lb] = make_char_table_entry (ct->level1[lb]); | |
| 1088 cte = XCHAR_TABLE_ENTRY (ct->level1[lb]); | |
| 1089 cte->level2[range->row - 32] = val; | |
| 1090 } | |
| 1091 break; | |
| 1092 #endif /* MULE */ | |
| 1093 | |
| 1094 case CHARTAB_RANGE_CHAR: | |
| 1095 #ifdef MULE | |
| 1096 { | |
| 1097 Lisp_Object charset; | |
| 1098 int byte1, byte2; | |
| 1099 | |
| 867 | 1100 BREAKUP_ICHAR (range->ch, charset, byte1, byte2); |
| 428 | 1101 if (EQ (charset, Vcharset_ascii)) |
| 1102 ct->ascii[byte1] = val; | |
| 1103 else if (EQ (charset, Vcharset_control_1)) | |
| 1104 ct->ascii[byte1 + 128] = val; | |
| 1105 else | |
| 1106 { | |
| 440 | 1107 Lisp_Char_Table_Entry *cte; |
| 428 | 1108 int lb = XCHARSET_LEADING_BYTE (charset) - MIN_LEADING_BYTE; |
| 1109 /* make sure that there is a separate entry for the row. */ | |
| 1110 if (!CHAR_TABLE_ENTRYP (ct->level1[lb])) | |
| 1111 ct->level1[lb] = make_char_table_entry (ct->level1[lb]); | |
| 1112 cte = XCHAR_TABLE_ENTRY (ct->level1[lb]); | |
| 1113 /* now CTE is a char table entry for the charset; | |
| 1114 each entry is for a single row (or character of | |
| 1115 a one-octet charset). */ | |
| 1116 if (XCHARSET_DIMENSION (charset) == 1) | |
| 1117 cte->level2[byte1 - 32] = val; | |
| 1118 else | |
| 1119 { | |
| 1120 /* assigning to one character in a two-octet charset. */ | |
| 1121 /* make sure that the charset row contains a separate | |
| 1122 entry for each character. */ | |
| 1123 if (!CHAR_TABLE_ENTRYP (cte->level2[byte1 - 32])) | |
| 1124 cte->level2[byte1 - 32] = | |
| 1125 make_char_table_entry (cte->level2[byte1 - 32]); | |
| 1126 cte = XCHAR_TABLE_ENTRY (cte->level2[byte1 - 32]); | |
| 1127 cte->level2[byte2 - 32] = val; | |
| 1128 } | |
| 1129 } | |
| 1130 } | |
| 1131 #else /* not MULE */ | |
| 1132 ct->ascii[(unsigned char) (range->ch)] = val; | |
| 1133 break; | |
| 1134 #endif /* not MULE */ | |
| 1135 } | |
| 1136 | |
| 1137 if (ct->type == CHAR_TABLE_TYPE_SYNTAX) | |
| 1296 | 1138 set_char_table_dirty (wrap_char_table (ct)); |
| 428 | 1139 } |
| 1140 | |
| 1141 DEFUN ("put-char-table", Fput_char_table, 3, 3, 0, /* | |
| 444 | 1142 Set the value for chars in RANGE to be VALUE in CHAR-TABLE. |
| 428 | 1143 |
| 1144 RANGE specifies one or more characters to be affected and should be | |
| 1145 one of the following: | |
| 1146 | |
| 1147 -- t (all characters are affected) | |
| 1148 -- A charset (only allowed when Mule support is present) | |
| 2714 | 1149 -- A vector of two elements: a two-octet charset and a row number; the row |
| 1150 must be an integer, not a character (only allowed when Mule support is | |
| 1151 present) | |
| 428 | 1152 -- A single character |
| 1153 | |
| 444 | 1154 VALUE must be a value appropriate for the type of CHAR-TABLE. |
| 800 | 1155 See `make-char-table'. |
| 428 | 1156 */ |
| 444 | 1157 (range, value, char_table)) |
| 428 | 1158 { |
| 440 | 1159 Lisp_Char_Table *ct; |
| 428 | 1160 struct chartab_range rainj; |
| 1161 | |
| 444 | 1162 CHECK_CHAR_TABLE (char_table); |
| 1163 ct = XCHAR_TABLE (char_table); | |
| 1164 check_valid_char_table_value (value, ct->type, ERROR_ME); | |
| 428 | 1165 decode_char_table_range (range, &rainj); |
| 444 | 1166 value = canonicalize_char_table_value (value, ct->type); |
| 826 | 1167 put_char_table (char_table, &rainj, value); |
| 1168 return Qnil; | |
| 1169 } | |
| 1170 | |
| 1171 DEFUN ("remove-char-table", Fremove_char_table, 2, 2, 0, /* | |
| 1172 Remove any value from chars in RANGE in CHAR-TABLE. | |
| 1173 | |
| 1174 RANGE specifies one or more characters to be affected and should be | |
| 1175 one of the following: | |
| 1176 | |
| 1177 -- t (all characters are affected) | |
| 1178 -- A charset (only allowed when Mule support is present) | |
| 1179 -- A vector of two elements: a two-octet charset and a row number | |
| 1180 (only allowed when Mule support is present) | |
| 1181 -- A single character | |
| 1182 | |
| 2726 | 1183 With all values removed, the default value will be returned by |
| 1184 `get-char-table' and `get-range-char-table'. | |
| 826 | 1185 */ |
| 1186 (range, char_table)) | |
| 1187 { | |
| 1188 struct chartab_range rainj; | |
| 1189 | |
| 1190 CHECK_CHAR_TABLE (char_table); | |
| 1191 decode_char_table_range (range, &rainj); | |
| 1192 put_char_table (char_table, &rainj, Qunbound); | |
| 428 | 1193 return Qnil; |
| 1194 } | |
| 1195 | |
| 1196 /* Map FN over the ASCII chars in CT. */ | |
| 1197 | |
| 1198 static int | |
| 826 | 1199 map_over_charset_ascii_1 (Lisp_Char_Table *ct, |
| 1200 int start, int stop, | |
| 1201 int (*fn) (struct chartab_range *range, | |
| 1202 Lisp_Object table, Lisp_Object val, | |
| 1203 void *arg), | |
| 1204 void *arg) | |
| 1205 { | |
| 1206 struct chartab_range rainj; | |
| 1207 int i, retval; | |
| 1208 | |
| 1209 rainj.type = CHARTAB_RANGE_CHAR; | |
| 1210 | |
| 1211 for (i = start, retval = 0; i <= stop && retval == 0; i++) | |
| 1212 { | |
| 867 | 1213 rainj.ch = (Ichar) i; |
| 826 | 1214 if (!UNBOUNDP (ct->ascii[i])) |
| 1215 retval = (fn) (&rainj, wrap_char_table (ct), ct->ascii[i], arg); | |
| 1216 } | |
| 1217 | |
| 1218 return retval; | |
| 1219 } | |
| 1220 | |
| 1221 | |
| 1222 /* Map FN over the ASCII chars in CT. */ | |
| 1223 | |
| 1224 static int | |
| 440 | 1225 map_over_charset_ascii (Lisp_Char_Table *ct, |
| 428 | 1226 int (*fn) (struct chartab_range *range, |
| 826 | 1227 Lisp_Object table, Lisp_Object val, |
| 1228 void *arg), | |
| 428 | 1229 void *arg) |
| 1230 { | |
| 826 | 1231 return map_over_charset_ascii_1 (ct, 0, |
| 428 | 1232 #ifdef MULE |
| 826 | 1233 127, |
| 428 | 1234 #else |
| 826 | 1235 255, |
| 428 | 1236 #endif |
| 826 | 1237 fn, arg); |
| 428 | 1238 } |
| 1239 | |
| 1240 #ifdef MULE | |
| 1241 | |
| 1242 /* Map FN over the Control-1 chars in CT. */ | |
| 1243 | |
| 1244 static int | |
| 440 | 1245 map_over_charset_control_1 (Lisp_Char_Table *ct, |
| 428 | 1246 int (*fn) (struct chartab_range *range, |
| 826 | 1247 Lisp_Object table, Lisp_Object val, |
| 1248 void *arg), | |
| 428 | 1249 void *arg) |
| 1250 { | |
| 826 | 1251 return map_over_charset_ascii_1 (ct, 128, 159, fn, arg); |
| 428 | 1252 } |
| 1253 | |
| 1254 /* Map FN over the row ROW of two-byte charset CHARSET. | |
| 1255 There must be a separate value for that row in the char table. | |
| 1256 CTE specifies the char table entry for CHARSET. */ | |
| 1257 | |
| 1258 static int | |
| 826 | 1259 map_over_charset_row (Lisp_Char_Table *ct, |
| 1260 Lisp_Char_Table_Entry *cte, | |
| 428 | 1261 Lisp_Object charset, int row, |
| 1262 int (*fn) (struct chartab_range *range, | |
| 826 | 1263 Lisp_Object table, Lisp_Object val, |
| 1264 void *arg), | |
| 428 | 1265 void *arg) |
| 1266 { | |
| 1267 Lisp_Object val = cte->level2[row - 32]; | |
| 1268 | |
| 826 | 1269 if (UNBOUNDP (val)) |
| 1270 return 0; | |
| 1271 else if (!CHAR_TABLE_ENTRYP (val)) | |
| 428 | 1272 { |
| 1273 struct chartab_range rainj; | |
| 826 | 1274 |
| 428 | 1275 rainj.type = CHARTAB_RANGE_ROW; |
| 1276 rainj.charset = charset; | |
| 1277 rainj.row = row; | |
| 826 | 1278 return (fn) (&rainj, wrap_char_table (ct), val, arg); |
| 428 | 1279 } |
| 1280 else | |
| 1281 { | |
| 1282 struct chartab_range rainj; | |
| 1283 int i, retval; | |
| 826 | 1284 int start, stop; |
| 1285 | |
| 1286 get_charset_limits (charset, &start, &stop); | |
| 428 | 1287 |
| 1288 cte = XCHAR_TABLE_ENTRY (val); | |
| 1289 | |
| 1290 rainj.type = CHARTAB_RANGE_CHAR; | |
| 1291 | |
| 826 | 1292 for (i = start, retval = 0; i <= stop && retval == 0; i++) |
| 428 | 1293 { |
| 867 | 1294 rainj.ch = make_ichar (charset, row, i); |
| 826 | 1295 if (!UNBOUNDP (cte->level2[i - 32])) |
| 1296 retval = (fn) (&rainj, wrap_char_table (ct), cte->level2[i - 32], | |
| 1297 arg); | |
| 428 | 1298 } |
| 1299 return retval; | |
| 1300 } | |
| 1301 } | |
| 1302 | |
| 1303 | |
| 1304 static int | |
| 440 | 1305 map_over_other_charset (Lisp_Char_Table *ct, int lb, |
| 428 | 1306 int (*fn) (struct chartab_range *range, |
| 826 | 1307 Lisp_Object table, Lisp_Object val, |
| 1308 void *arg), | |
| 428 | 1309 void *arg) |
| 1310 { | |
| 1311 Lisp_Object val = ct->level1[lb - MIN_LEADING_BYTE]; | |
| 826 | 1312 Lisp_Object charset = charset_by_leading_byte (lb); |
| 428 | 1313 |
| 1314 if (!CHARSETP (charset) | |
| 1315 || lb == LEADING_BYTE_ASCII | |
| 1316 || lb == LEADING_BYTE_CONTROL_1) | |
| 1317 return 0; | |
| 1318 | |
| 826 | 1319 if (UNBOUNDP (val)) |
| 1320 return 0; | |
| 428 | 1321 if (!CHAR_TABLE_ENTRYP (val)) |
| 1322 { | |
| 1323 struct chartab_range rainj; | |
| 1324 | |
| 1325 rainj.type = CHARTAB_RANGE_CHARSET; | |
| 1326 rainj.charset = charset; | |
| 826 | 1327 return (fn) (&rainj, wrap_char_table (ct), val, arg); |
| 428 | 1328 } |
| 1329 { | |
| 440 | 1330 Lisp_Char_Table_Entry *cte = XCHAR_TABLE_ENTRY (val); |
| 826 | 1331 int start, stop; |
| 428 | 1332 int i, retval; |
| 1333 | |
| 826 | 1334 get_charset_limits (charset, &start, &stop); |
| 428 | 1335 if (XCHARSET_DIMENSION (charset) == 1) |
| 1336 { | |
| 1337 struct chartab_range rainj; | |
| 1338 rainj.type = CHARTAB_RANGE_CHAR; | |
| 1339 | |
| 826 | 1340 for (i = start, retval = 0; i <= stop && retval == 0; i++) |
| 428 | 1341 { |
| 867 | 1342 rainj.ch = make_ichar (charset, i, 0); |
| 826 | 1343 if (!UNBOUNDP (cte->level2[i - 32])) |
| 1344 retval = (fn) (&rainj, wrap_char_table (ct), cte->level2[i - 32], | |
| 1345 arg); | |
| 428 | 1346 } |
| 1347 } | |
| 1348 else | |
| 1349 { | |
| 826 | 1350 for (i = start, retval = 0; i <= stop && retval == 0; i++) |
| 1351 retval = map_over_charset_row (ct, cte, charset, i, fn, arg); | |
| 428 | 1352 } |
| 1353 | |
| 1354 return retval; | |
| 1355 } | |
| 1356 } | |
| 1357 | |
| 1358 #endif /* MULE */ | |
| 1359 | |
| 1360 /* Map FN (with client data ARG) over range RANGE in char table CT. | |
| 1361 Mapping stops the first time FN returns non-zero, and that value | |
| 826 | 1362 becomes the return value of map_char_table(). |
| 1363 | |
| 1364 #### This mapping code is way ugly. The FSF version, in contrast, | |
| 1365 is short and sweet, and much more recursive. There should be some way | |
| 1366 of cleaning this up. */ | |
| 428 | 1367 |
| 1368 int | |
| 826 | 1369 map_char_table (Lisp_Object table, |
| 428 | 1370 struct chartab_range *range, |
| 1371 int (*fn) (struct chartab_range *range, | |
| 826 | 1372 Lisp_Object table, Lisp_Object val, void *arg), |
| 428 | 1373 void *arg) |
| 1374 { | |
| 826 | 1375 Lisp_Char_Table *ct = XCHAR_TABLE (table); |
| 428 | 1376 switch (range->type) |
| 1377 { | |
| 1378 case CHARTAB_RANGE_ALL: | |
| 1379 { | |
| 1380 int retval; | |
| 1381 | |
| 1382 retval = map_over_charset_ascii (ct, fn, arg); | |
| 1383 if (retval) | |
| 1384 return retval; | |
| 1385 #ifdef MULE | |
| 1386 retval = map_over_charset_control_1 (ct, fn, arg); | |
| 1387 if (retval) | |
| 1388 return retval; | |
| 1389 { | |
| 1390 int i; | |
| 1391 int start = MIN_LEADING_BYTE; | |
| 1392 int stop = start + NUM_LEADING_BYTES; | |
| 1393 | |
| 1394 for (i = start, retval = 0; i < stop && retval == 0; i++) | |
| 1395 { | |
| 771 | 1396 if (i != LEADING_BYTE_ASCII && i != LEADING_BYTE_CONTROL_1) |
| 1397 retval = map_over_other_charset (ct, i, fn, arg); | |
| 428 | 1398 } |
| 1399 } | |
| 1400 #endif /* MULE */ | |
| 1401 return retval; | |
| 1402 } | |
| 1403 | |
| 1404 #ifdef MULE | |
| 1405 case CHARTAB_RANGE_CHARSET: | |
| 1406 return map_over_other_charset (ct, | |
| 1407 XCHARSET_LEADING_BYTE (range->charset), | |
| 1408 fn, arg); | |
| 1409 | |
| 1410 case CHARTAB_RANGE_ROW: | |
| 1411 { | |
| 771 | 1412 Lisp_Object val = ct->level1[XCHARSET_LEADING_BYTE (range->charset) - |
| 1413 MIN_LEADING_BYTE]; | |
| 826 | 1414 |
| 1415 if (CHAR_TABLE_ENTRYP (val)) | |
| 1416 return map_over_charset_row (ct, XCHAR_TABLE_ENTRY (val), | |
| 1417 range->charset, range->row, fn, arg); | |
| 1418 else if (!UNBOUNDP (val)) | |
| 428 | 1419 { |
| 1420 struct chartab_range rainj; | |
| 1421 | |
| 1422 rainj.type = CHARTAB_RANGE_ROW; | |
| 1423 rainj.charset = range->charset; | |
| 1424 rainj.row = range->row; | |
| 826 | 1425 return (fn) (&rainj, table, val, arg); |
| 428 | 1426 } |
| 1427 else | |
| 826 | 1428 return 0; |
| 428 | 1429 } |
| 1430 #endif /* MULE */ | |
| 1431 | |
| 1432 case CHARTAB_RANGE_CHAR: | |
| 1433 { | |
| 867 | 1434 Ichar ch = range->ch; |
| 826 | 1435 Lisp_Object val = get_char_table (ch, table); |
| 428 | 1436 struct chartab_range rainj; |
| 1437 | |
| 826 | 1438 if (!UNBOUNDP (val)) |
| 1439 { | |
| 1440 rainj.type = CHARTAB_RANGE_CHAR; | |
| 1441 rainj.ch = ch; | |
| 1442 return (fn) (&rainj, table, val, arg); | |
| 1443 } | |
| 1444 else | |
| 1445 return 0; | |
| 428 | 1446 } |
| 1447 | |
| 1448 default: | |
| 2500 | 1449 ABORT (); |
| 428 | 1450 } |
| 1451 | |
| 1452 return 0; | |
| 1453 } | |
| 1454 | |
| 1455 struct slow_map_char_table_arg | |
| 1456 { | |
| 1457 Lisp_Object function; | |
| 1458 Lisp_Object retval; | |
| 1459 }; | |
| 1460 | |
| 1461 static int | |
| 1462 slow_map_char_table_fun (struct chartab_range *range, | |
| 2286 | 1463 Lisp_Object UNUSED (table), Lisp_Object val, |
| 1464 void *arg) | |
| 428 | 1465 { |
| 1466 struct slow_map_char_table_arg *closure = | |
| 1467 (struct slow_map_char_table_arg *) arg; | |
| 1468 | |
| 826 | 1469 closure->retval = call2 (closure->function, encode_char_table_range (range), |
| 1470 val); | |
| 428 | 1471 return !NILP (closure->retval); |
| 1472 } | |
| 1473 | |
| 1474 DEFUN ("map-char-table", Fmap_char_table, 2, 3, 0, /* | |
| 2726 | 1475 Map FUNCTION over CHAR-TABLE until it returns non-nil; return that value. |
| 1476 FUNCTION is called with two arguments, each key and entry in the table. | |
| 1477 | |
| 1478 RANGE specifies a subrange to map over. If omitted or t, it defaults to | |
| 1479 the entire table. | |
| 428 | 1480 |
| 2726 | 1481 Both RANGE and the keys passed to FUNCTION are in the same format as the |
| 1482 RANGE argument to `put-char-table'. N.B. This function does NOT map over | |
| 1483 all characters in RANGE, but over the subranges that have been assigned to. | |
| 1484 Thus this function is most suitable for searching a char-table, or for | |
| 1485 populating one char-table based on the contents of another. The current | |
| 1486 implementation does not coalesce ranges all of whose values are the same. | |
| 428 | 1487 */ |
| 444 | 1488 (function, char_table, range)) |
| 428 | 1489 { |
| 1490 struct slow_map_char_table_arg slarg; | |
| 1491 struct gcpro gcpro1, gcpro2; | |
| 1492 struct chartab_range rainj; | |
| 1493 | |
| 444 | 1494 CHECK_CHAR_TABLE (char_table); |
| 428 | 1495 if (NILP (range)) |
| 1496 range = Qt; | |
| 1497 decode_char_table_range (range, &rainj); | |
| 1498 slarg.function = function; | |
| 1499 slarg.retval = Qnil; | |
| 1500 GCPRO2 (slarg.function, slarg.retval); | |
| 826 | 1501 map_char_table (char_table, &rainj, slow_map_char_table_fun, &slarg); |
| 428 | 1502 UNGCPRO; |
| 1503 | |
| 1504 return slarg.retval; | |
| 1505 } | |
| 1506 | |
| 1507 | |
| 1508 | |
| 1509 /************************************************************************/ | |
| 1510 /* Char table read syntax */ | |
| 1511 /************************************************************************/ | |
| 1512 | |
| 1513 static int | |
| 2286 | 1514 chartab_type_validate (Lisp_Object UNUSED (keyword), Lisp_Object value, |
| 1515 Error_Behavior UNUSED (errb)) | |
| 428 | 1516 { |
| 1517 /* #### should deal with ERRB */ | |
| 1518 symbol_to_char_table_type (value); | |
| 1519 return 1; | |
| 1520 } | |
| 1521 | |
| 826 | 1522 /* #### Document the print/read format; esp. what's this cons element? */ |
| 1523 | |
| 428 | 1524 static int |
| 2286 | 1525 chartab_data_validate (Lisp_Object UNUSED (keyword), Lisp_Object value, |
| 1526 Error_Behavior UNUSED (errb)) | |
| 428 | 1527 { |
| 1528 /* #### should deal with ERRB */ | |
| 2367 | 1529 EXTERNAL_PROPERTY_LIST_LOOP_3 (range, data, value) |
| 428 | 1530 { |
| 1531 struct chartab_range dummy; | |
| 1532 | |
| 1533 if (CONSP (range)) | |
| 1534 { | |
| 1535 if (!CONSP (XCDR (range)) | |
| 1536 || !NILP (XCDR (XCDR (range)))) | |
| 563 | 1537 sferror ("Invalid range format", range); |
| 428 | 1538 decode_char_table_range (XCAR (range), &dummy); |
| 1539 decode_char_table_range (XCAR (XCDR (range)), &dummy); | |
| 1540 } | |
| 1541 else | |
| 1542 decode_char_table_range (range, &dummy); | |
| 1543 } | |
| 1544 | |
| 1545 return 1; | |
| 1546 } | |
| 1547 | |
| 1548 static Lisp_Object | |
| 1549 chartab_instantiate (Lisp_Object data) | |
| 1550 { | |
| 1551 Lisp_Object chartab; | |
| 1552 Lisp_Object type = Qgeneric; | |
| 1553 Lisp_Object dataval = Qnil; | |
| 1554 | |
| 1555 while (!NILP (data)) | |
| 1556 { | |
| 1557 Lisp_Object keyw = Fcar (data); | |
| 1558 Lisp_Object valw; | |
| 1559 | |
| 1560 data = Fcdr (data); | |
| 1561 valw = Fcar (data); | |
| 1562 data = Fcdr (data); | |
| 1563 if (EQ (keyw, Qtype)) | |
| 1564 type = valw; | |
| 1565 else if (EQ (keyw, Qdata)) | |
| 1566 dataval = valw; | |
| 1567 } | |
| 1568 | |
| 1569 chartab = Fmake_char_table (type); | |
| 1570 | |
| 1571 data = dataval; | |
| 1572 while (!NILP (data)) | |
| 1573 { | |
| 1574 Lisp_Object range = Fcar (data); | |
| 1575 Lisp_Object val = Fcar (Fcdr (data)); | |
| 1576 | |
| 1577 data = Fcdr (Fcdr (data)); | |
| 1578 if (CONSP (range)) | |
| 1579 { | |
| 1580 if (CHAR_OR_CHAR_INTP (XCAR (range))) | |
| 1581 { | |
| 867 | 1582 Ichar first = XCHAR_OR_CHAR_INT (Fcar (range)); |
| 1583 Ichar last = XCHAR_OR_CHAR_INT (Fcar (Fcdr (range))); | |
| 1584 Ichar i; | |
| 428 | 1585 |
| 1586 for (i = first; i <= last; i++) | |
| 1587 Fput_char_table (make_char (i), val, chartab); | |
| 1588 } | |
| 1589 else | |
| 2500 | 1590 ABORT (); |
| 428 | 1591 } |
| 1592 else | |
| 1593 Fput_char_table (range, val, chartab); | |
| 1594 } | |
| 1595 | |
| 1596 return chartab; | |
| 1597 } | |
| 1598 | |
| 1599 #ifdef MULE | |
| 1600 | |
| 1601 | |
| 1602 /************************************************************************/ | |
| 1603 /* Category Tables, specifically */ | |
| 1604 /************************************************************************/ | |
| 1605 | |
| 1606 DEFUN ("category-table-p", Fcategory_table_p, 1, 1, 0, /* | |
| 444 | 1607 Return t if OBJECT is a category table. |
| 428 | 1608 A category table is a type of char table used for keeping track of |
| 1609 categories. Categories are used for classifying characters for use | |
| 1610 in regexps -- you can refer to a category rather than having to use | |
| 1611 a complicated [] expression (and category lookups are significantly | |
| 1612 faster). | |
| 1613 | |
| 1614 There are 95 different categories available, one for each printable | |
| 1615 character (including space) in the ASCII charset. Each category | |
| 1616 is designated by one such character, called a "category designator". | |
| 1617 They are specified in a regexp using the syntax "\\cX", where X is | |
| 1618 a category designator. | |
| 1619 | |
| 1620 A category table specifies, for each character, the categories that | |
| 1621 the character is in. Note that a character can be in more than one | |
| 1622 category. More specifically, a category table maps from a character | |
| 1623 to either the value nil (meaning the character is in no categories) | |
| 1624 or a 95-element bit vector, specifying for each of the 95 categories | |
| 1625 whether the character is in that category. | |
| 1626 | |
| 1627 Special Lisp functions are provided that abstract this, so you do not | |
| 1628 have to directly manipulate bit vectors. | |
| 1629 */ | |
| 444 | 1630 (object)) |
| 428 | 1631 { |
| 444 | 1632 return (CHAR_TABLEP (object) && |
| 1633 XCHAR_TABLE_TYPE (object) == CHAR_TABLE_TYPE_CATEGORY) ? | |
| 428 | 1634 Qt : Qnil; |
| 1635 } | |
| 1636 | |
| 1637 static Lisp_Object | |
| 444 | 1638 check_category_table (Lisp_Object object, Lisp_Object default_) |
| 428 | 1639 { |
| 444 | 1640 if (NILP (object)) |
| 1641 object = default_; | |
| 1642 while (NILP (Fcategory_table_p (object))) | |
| 1643 object = wrong_type_argument (Qcategory_table_p, object); | |
| 1644 return object; | |
| 428 | 1645 } |
| 1646 | |
| 1647 int | |
| 867 | 1648 check_category_char (Ichar ch, Lisp_Object table, |
| 647 | 1649 int designator, int not_p) |
| 428 | 1650 { |
| 1651 REGISTER Lisp_Object temp; | |
| 1652 if (NILP (Fcategory_table_p (table))) | |
| 563 | 1653 wtaerror ("Expected category table", table); |
| 826 | 1654 temp = get_char_table (ch, table); |
| 428 | 1655 if (NILP (temp)) |
| 458 | 1656 return not_p; |
| 428 | 1657 |
| 1658 designator -= ' '; | |
| 458 | 1659 return bit_vector_bit (XBIT_VECTOR (temp), designator) ? !not_p : not_p; |
| 428 | 1660 } |
| 1661 | |
| 1662 DEFUN ("check-category-at", Fcheck_category_at, 2, 4, 0, /* | |
| 444 | 1663 Return t if category of the character at POSITION includes DESIGNATOR. |
| 1664 Optional third arg BUFFER specifies which buffer to use, and defaults | |
| 1665 to the current buffer. | |
| 1666 Optional fourth arg CATEGORY-TABLE specifies the category table to | |
| 1667 use, and defaults to BUFFER's category table. | |
| 428 | 1668 */ |
| 444 | 1669 (position, designator, buffer, category_table)) |
| 428 | 1670 { |
| 1671 Lisp_Object ctbl; | |
| 867 | 1672 Ichar ch; |
| 647 | 1673 int des; |
| 428 | 1674 struct buffer *buf = decode_buffer (buffer, 0); |
| 1675 | |
| 444 | 1676 CHECK_INT (position); |
| 428 | 1677 CHECK_CATEGORY_DESIGNATOR (designator); |
| 1678 des = XCHAR (designator); | |
| 788 | 1679 ctbl = check_category_table (category_table, buf->category_table); |
| 444 | 1680 ch = BUF_FETCH_CHAR (buf, XINT (position)); |
| 428 | 1681 return check_category_char (ch, ctbl, des, 0) ? Qt : Qnil; |
| 1682 } | |
| 1683 | |
| 1684 DEFUN ("char-in-category-p", Fchar_in_category_p, 2, 3, 0, /* | |
| 788 | 1685 Return non-nil if category of CHARACTER includes DESIGNATOR. |
| 444 | 1686 Optional third arg CATEGORY-TABLE specifies the category table to use, |
| 788 | 1687 and defaults to the current buffer's category table. |
| 428 | 1688 */ |
| 444 | 1689 (character, designator, category_table)) |
| 428 | 1690 { |
| 1691 Lisp_Object ctbl; | |
| 867 | 1692 Ichar ch; |
| 647 | 1693 int des; |
| 428 | 1694 |
| 1695 CHECK_CATEGORY_DESIGNATOR (designator); | |
| 1696 des = XCHAR (designator); | |
| 444 | 1697 CHECK_CHAR (character); |
| 1698 ch = XCHAR (character); | |
| 788 | 1699 ctbl = check_category_table (category_table, current_buffer->category_table); |
| 428 | 1700 return check_category_char (ch, ctbl, des, 0) ? Qt : Qnil; |
| 1701 } | |
| 1702 | |
| 1703 DEFUN ("category-table", Fcategory_table, 0, 1, 0, /* | |
| 444 | 1704 Return BUFFER's current category table. |
| 1705 BUFFER defaults to the current buffer. | |
| 428 | 1706 */ |
| 1707 (buffer)) | |
| 1708 { | |
| 1709 return decode_buffer (buffer, 0)->category_table; | |
| 1710 } | |
| 1711 | |
| 1712 DEFUN ("standard-category-table", Fstandard_category_table, 0, 0, 0, /* | |
| 1713 Return the standard category table. | |
| 1714 This is the one used for new buffers. | |
| 1715 */ | |
| 1716 ()) | |
| 1717 { | |
| 1718 return Vstandard_category_table; | |
| 1719 } | |
| 1720 | |
| 1721 DEFUN ("copy-category-table", Fcopy_category_table, 0, 1, 0, /* | |
| 444 | 1722 Return a new category table which is a copy of CATEGORY-TABLE. |
| 1723 CATEGORY-TABLE defaults to the standard category table. | |
| 428 | 1724 */ |
| 444 | 1725 (category_table)) |
| 428 | 1726 { |
| 1727 if (NILP (Vstandard_category_table)) | |
| 1728 return Fmake_char_table (Qcategory); | |
| 1729 | |
| 444 | 1730 category_table = |
| 1731 check_category_table (category_table, Vstandard_category_table); | |
| 1732 return Fcopy_char_table (category_table); | |
| 428 | 1733 } |
| 1734 | |
| 1735 DEFUN ("set-category-table", Fset_category_table, 1, 2, 0, /* | |
| 444 | 1736 Select CATEGORY-TABLE as the new category table for BUFFER. |
| 428 | 1737 BUFFER defaults to the current buffer if omitted. |
| 1738 */ | |
| 444 | 1739 (category_table, buffer)) |
| 428 | 1740 { |
| 1741 struct buffer *buf = decode_buffer (buffer, 0); | |
| 444 | 1742 category_table = check_category_table (category_table, Qnil); |
| 1743 buf->category_table = category_table; | |
| 428 | 1744 /* Indicate that this buffer now has a specified category table. */ |
| 1745 buf->local_var_flags |= XINT (buffer_local_flags.category_table); | |
| 444 | 1746 return category_table; |
| 428 | 1747 } |
| 1748 | |
| 1749 DEFUN ("category-designator-p", Fcategory_designator_p, 1, 1, 0, /* | |
| 444 | 1750 Return t if OBJECT is a category designator (a char in the range ' ' to '~'). |
| 428 | 1751 */ |
| 444 | 1752 (object)) |
| 428 | 1753 { |
| 444 | 1754 return CATEGORY_DESIGNATORP (object) ? Qt : Qnil; |
| 428 | 1755 } |
| 1756 | |
| 1757 DEFUN ("category-table-value-p", Fcategory_table_value_p, 1, 1, 0, /* | |
| 444 | 1758 Return t if OBJECT is a category table value. |
| 428 | 1759 Valid values are nil or a bit vector of size 95. |
| 1760 */ | |
| 444 | 1761 (object)) |
| 428 | 1762 { |
| 444 | 1763 return CATEGORY_TABLE_VALUEP (object) ? Qt : Qnil; |
| 428 | 1764 } |
| 1765 | |
| 1766 | |
| 1767 #define CATEGORYP(x) \ | |
| 1768 (CHARP (x) && XCHAR (x) >= 0x20 && XCHAR (x) <= 0x7E) | |
| 1769 | |
| 826 | 1770 #define CATEGORY_SET(c) get_char_table (c, current_buffer->category_table) |
| 428 | 1771 |
| 1772 /* Return 1 if CATEGORY_SET contains CATEGORY, else return 0. | |
| 1773 The faster version of `!NILP (Faref (category_set, category))'. */ | |
| 1774 #define CATEGORY_MEMBER(category, category_set) \ | |
| 1775 (bit_vector_bit(XBIT_VECTOR (category_set), category - 32)) | |
| 1776 | |
| 1777 /* Return 1 if there is a word boundary between two word-constituent | |
| 1778 characters C1 and C2 if they appear in this order, else return 0. | |
| 1779 Use the macro WORD_BOUNDARY_P instead of calling this function | |
| 1780 directly. */ | |
| 1781 | |
| 1782 int | |
| 867 | 1783 word_boundary_p (Ichar c1, Ichar c2) |
| 428 | 1784 { |
| 1785 Lisp_Object category_set1, category_set2; | |
| 1786 Lisp_Object tail; | |
| 1787 int default_result; | |
| 1788 | |
| 1789 #if 0 | |
| 1790 if (COMPOSITE_CHAR_P (c1)) | |
| 1791 c1 = cmpchar_component (c1, 0, 1); | |
| 1792 if (COMPOSITE_CHAR_P (c2)) | |
| 1793 c2 = cmpchar_component (c2, 0, 1); | |
| 1794 #endif | |
| 1795 | |
| 867 | 1796 if (EQ (ichar_charset (c1), ichar_charset (c2))) |
| 428 | 1797 { |
| 1798 tail = Vword_separating_categories; | |
| 1799 default_result = 0; | |
| 1800 } | |
| 1801 else | |
| 1802 { | |
| 1803 tail = Vword_combining_categories; | |
| 1804 default_result = 1; | |
| 1805 } | |
| 1806 | |
| 1807 category_set1 = CATEGORY_SET (c1); | |
| 1808 if (NILP (category_set1)) | |
| 1809 return default_result; | |
| 1810 category_set2 = CATEGORY_SET (c2); | |
| 1811 if (NILP (category_set2)) | |
| 1812 return default_result; | |
| 1813 | |
| 853 | 1814 for (; CONSP (tail); tail = XCDR (tail)) |
| 428 | 1815 { |
| 853 | 1816 Lisp_Object elt = XCAR (tail); |
| 428 | 1817 |
| 1818 if (CONSP (elt) | |
| 853 | 1819 && CATEGORYP (XCAR (elt)) |
| 1820 && CATEGORYP (XCDR (elt)) | |
| 1821 && CATEGORY_MEMBER (XCHAR (XCAR (elt)), category_set1) | |
| 1822 && CATEGORY_MEMBER (XCHAR (XCDR (elt)), category_set2)) | |
| 428 | 1823 return !default_result; |
| 1824 } | |
| 1825 return default_result; | |
| 1826 } | |
| 1827 #endif /* MULE */ | |
| 1828 | |
| 1829 | |
| 1830 void | |
| 1831 syms_of_chartab (void) | |
| 1832 { | |
| 442 | 1833 INIT_LRECORD_IMPLEMENTATION (char_table); |
| 1834 | |
| 428 | 1835 #ifdef MULE |
| 442 | 1836 INIT_LRECORD_IMPLEMENTATION (char_table_entry); |
| 1837 | |
| 563 | 1838 DEFSYMBOL (Qcategory_table_p); |
| 1839 DEFSYMBOL (Qcategory_designator_p); | |
| 1840 DEFSYMBOL (Qcategory_table_value_p); | |
| 428 | 1841 #endif /* MULE */ |
| 1842 | |
| 563 | 1843 DEFSYMBOL (Qchar_table); |
| 1844 DEFSYMBOL_MULTIWORD_PREDICATE (Qchar_tablep); | |
| 428 | 1845 |
| 1846 DEFSUBR (Fchar_table_p); | |
| 1847 DEFSUBR (Fchar_table_type_list); | |
| 1848 DEFSUBR (Fvalid_char_table_type_p); | |
| 1849 DEFSUBR (Fchar_table_type); | |
| 826 | 1850 DEFSUBR (Fchar_table_default); |
| 1851 DEFSUBR (Fset_char_table_default); | |
| 428 | 1852 DEFSUBR (Freset_char_table); |
| 1853 DEFSUBR (Fmake_char_table); | |
| 1854 DEFSUBR (Fcopy_char_table); | |
| 1855 DEFSUBR (Fget_char_table); | |
| 1856 DEFSUBR (Fget_range_char_table); | |
| 1857 DEFSUBR (Fvalid_char_table_value_p); | |
| 1858 DEFSUBR (Fcheck_valid_char_table_value); | |
| 1859 DEFSUBR (Fput_char_table); | |
| 826 | 1860 DEFSUBR (Fremove_char_table); |
| 428 | 1861 DEFSUBR (Fmap_char_table); |
| 1862 | |
| 1863 #ifdef MULE | |
| 1864 DEFSUBR (Fcategory_table_p); | |
| 1865 DEFSUBR (Fcategory_table); | |
| 1866 DEFSUBR (Fstandard_category_table); | |
| 1867 DEFSUBR (Fcopy_category_table); | |
| 1868 DEFSUBR (Fset_category_table); | |
| 1869 DEFSUBR (Fcheck_category_at); | |
| 1870 DEFSUBR (Fchar_in_category_p); | |
| 1871 DEFSUBR (Fcategory_designator_p); | |
| 1872 DEFSUBR (Fcategory_table_value_p); | |
| 1873 #endif /* MULE */ | |
| 1874 | |
| 1875 } | |
| 1876 | |
| 1877 void | |
| 1878 vars_of_chartab (void) | |
| 1879 { | |
| 1880 /* DO NOT staticpro this. It works just like Vweak_hash_tables. */ | |
| 1881 Vall_syntax_tables = Qnil; | |
| 452 | 1882 dump_add_weak_object_chain (&Vall_syntax_tables); |
| 428 | 1883 } |
| 1884 | |
| 1885 void | |
| 1886 structure_type_create_chartab (void) | |
| 1887 { | |
| 1888 struct structure_type *st; | |
| 1889 | |
| 1890 st = define_structure_type (Qchar_table, 0, chartab_instantiate); | |
| 1891 | |
| 1892 define_structure_type_keyword (st, Qtype, chartab_type_validate); | |
| 1893 define_structure_type_keyword (st, Qdata, chartab_data_validate); | |
| 1894 } | |
| 1895 | |
| 1896 void | |
| 1897 complex_vars_of_chartab (void) | |
| 1898 { | |
| 1899 #ifdef MULE | |
| 1900 /* Set this now, so first buffer creation can refer to it. */ | |
| 1901 /* Make it nil before calling copy-category-table | |
| 1902 so that copy-category-table will know not to try to copy from garbage */ | |
| 1903 Vstandard_category_table = Qnil; | |
| 1904 Vstandard_category_table = Fcopy_category_table (Qnil); | |
| 1905 staticpro (&Vstandard_category_table); | |
| 1906 | |
| 1907 DEFVAR_LISP ("word-combining-categories", &Vword_combining_categories /* | |
| 1908 List of pair (cons) of categories to determine word boundary. | |
| 1909 | |
| 1910 Emacs treats a sequence of word constituent characters as a single | |
| 1911 word (i.e. finds no word boundary between them) iff they belongs to | |
| 1912 the same charset. But, exceptions are allowed in the following cases. | |
| 1913 | |
| 444 | 1914 \(1) The case that characters are in different charsets is controlled |
| 428 | 1915 by the variable `word-combining-categories'. |
| 1916 | |
| 1917 Emacs finds no word boundary between characters of different charsets | |
| 1918 if they have categories matching some element of this list. | |
| 1919 | |
| 1920 More precisely, if an element of this list is a cons of category CAT1 | |
| 1921 and CAT2, and a multibyte character C1 which has CAT1 is followed by | |
| 1922 C2 which has CAT2, there's no word boundary between C1 and C2. | |
| 1923 | |
| 1924 For instance, to tell that ASCII characters and Latin-1 characters can | |
| 1925 form a single word, the element `(?l . ?l)' should be in this list | |
| 1926 because both characters have the category `l' (Latin characters). | |
| 1927 | |
| 444 | 1928 \(2) The case that character are in the same charset is controlled by |
| 428 | 1929 the variable `word-separating-categories'. |
| 1930 | |
| 1931 Emacs find a word boundary between characters of the same charset | |
| 1932 if they have categories matching some element of this list. | |
| 1933 | |
| 1934 More precisely, if an element of this list is a cons of category CAT1 | |
| 1935 and CAT2, and a multibyte character C1 which has CAT1 is followed by | |
| 1936 C2 which has CAT2, there's a word boundary between C1 and C2. | |
| 1937 | |
| 1938 For instance, to tell that there's a word boundary between Japanese | |
| 1939 Hiragana and Japanese Kanji (both are in the same charset), the | |
| 1940 element `(?H . ?C) should be in this list. | |
| 1941 */ ); | |
| 1942 | |
| 1943 Vword_combining_categories = Qnil; | |
| 1944 | |
| 1945 DEFVAR_LISP ("word-separating-categories", &Vword_separating_categories /* | |
| 1946 List of pair (cons) of categories to determine word boundary. | |
| 1947 See the documentation of the variable `word-combining-categories'. | |
| 1948 */ ); | |
| 1949 | |
| 1950 Vword_separating_categories = Qnil; | |
| 1951 #endif /* MULE */ | |
| 1952 } |