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