Mercurial > hg > xemacs-beta
annotate src/specifier.c @ 5146:88bd4f3ef8e4
make lrecord UID's have a separate UID space for each object, resurrect debug SOE code in extents.c
-------------------- ChangeLog entries follow: --------------------
src/ChangeLog addition:
2010-03-15 Ben Wing <ben@xemacs.org>
* alloc.c:
* alloc.c (c_readonly):
* alloc.c (deadbeef_memory):
* alloc.c (make_compiled_function):
* alloc.c (make_button_data):
* alloc.c (make_motion_data):
* alloc.c (make_process_data):
* alloc.c (make_timeout_data):
* alloc.c (make_magic_data):
* alloc.c (make_magic_eval_data):
* alloc.c (make_eval_data):
* alloc.c (make_misc_user_data):
* alloc.c (noseeum_make_marker):
* alloc.c (ADDITIONAL_FREE_string):
* alloc.c (common_init_alloc_early):
* alloc.c (init_alloc_once_early):
* bytecode.c (print_compiled_function):
* bytecode.c (mark_compiled_function):
* casetab.c:
* casetab.c (print_case_table):
* console.c:
* console.c (print_console):
* database.c (print_database):
* database.c (finalize_database):
* device-msw.c (sync_printer_with_devmode):
* device-msw.c (print_devmode):
* device-msw.c (finalize_devmode):
* device.c:
* device.c (print_device):
* elhash.c:
* elhash.c (print_hash_table):
* eval.c (print_multiple_value):
* eval.c (mark_multiple_value):
* events.c (deinitialize_event):
* events.c (print_event):
* events.c (event_equal):
* extents.c:
* extents.c (soe_dump):
* extents.c (soe_insert):
* extents.c (soe_delete):
* extents.c (soe_move):
* extents.c (extent_fragment_update):
* extents.c (print_extent_1):
* extents.c (print_extent):
* extents.c (vars_of_extents):
* frame.c:
* frame.c (print_frame):
* free-hook.c:
* free-hook.c (check_free):
* glyphs.c:
* glyphs.c (print_image_instance):
* glyphs.c (print_glyph):
* gui.c:
* gui.c (copy_gui_item):
* hash.c:
* hash.c (NULL_ENTRY):
* hash.c (KEYS_DIFFER_P):
* keymap.c (print_keymap):
* keymap.c (MARKED_SLOT):
* lisp.h:
* lrecord.h:
* lrecord.h (LISP_OBJECT_UID):
* lrecord.h (set_lheader_implementation):
* lrecord.h (struct old_lcrecord_header):
* lstream.c (print_lstream):
* lstream.c (finalize_lstream):
* marker.c (print_marker):
* marker.c (marker_equal):
* mc-alloc.c (visit_all_used_page_headers):
* mule-charset.c:
* mule-charset.c (print_charset):
* objects.c (print_color_instance):
* objects.c (print_font_instance):
* objects.c (finalize_font_instance):
* opaque.c (print_opaque):
* opaque.c (print_opaque_ptr):
* opaque.c (equal_opaque_ptr):
* print.c (internal_object_printer):
* print.c (enum printing_badness):
* rangetab.c (print_range_table):
* rangetab.c (range_table_equal):
* specifier.c (print_specifier):
* specifier.c (finalize_specifier):
* symbols.c:
* symbols.c (print_symbol_value_magic):
* tooltalk.c:
* tooltalk.c (print_tooltalk_message):
* tooltalk.c (print_tooltalk_pattern):
* window.c (print_window):
* window.c (debug_print_window):
(1) Make lrecord UID's have a separate UID space for each object.
Otherwise, with 20-bit UID's, we rapidly wrap around, especially
when common objects like conses and strings increment the UID value
for every object created. (Originally I tried making two UID spaces,
one for objects that always print readably and hence don't display
the UID, and one for other objects. But certain objects like markers
for which a UID is displayed are still generated rapidly enough that
UID overflow is a serious issue.) This also has the advantage of
making UID values smaller, hence easier to remember -- their main
purpose is to make it easier to keep track of different objects of
the same type when debugging code. Make sure we dump lrecord UID's
so that we don't have problems with pdumped and non-dumped objects
having the same UID.
(2) Display UID's consistently whenever an object (a) doesn't
consistently print readably (objects like cons and string, which
always print readably, can't display a UID), and (b) doesn't
otherwise have a unique property that makes objects of a
particular type distinguishable. (E.g. buffers didn't and still
don't print an ID, but the buffer name uniquely identifies the
buffer.) Some types, such as event, extent, compiled-function,
didn't always (or didn't ever) display an ID; others (such as
marker, extent, lstream, opaque, opaque-ptr, any object using
internal_object_printer()) used to display the actual machine
pointer instead.
(3) Rename NORMAL_LISP_OBJECT_UID to LISP_OBJECT_UID; make it work
over all Lisp objects and take a Lisp object, not a struct pointer.
(4) Some misc cleanups in alloc.c, elhash.c.
(5) Change code in events.c that "deinitializes" an event so that
it doesn't increment the event UID counter in the process. Also
use deadbeef_memory() to overwrite memory instead of doing the same
with custom code. In the process, make deadbeef_memory() in
alloc.c always available, and delete extraneous copy in mc-alloc.c.
Also capitalize all uses of 0xDEADBEEF. Similarly in elhash.c
call deadbeef_memory().
(6) Resurrect "debug SOE" code in extents.c. Make it conditional
on DEBUG_XEMACS and on a `debug-soe' variable, rather than on
SOE_DEBUG. Make it output to stderr, not stdout.
(7) Delete some custom print methods that were identical to
external_object_printer().
| author | Ben Wing <ben@xemacs.org> |
|---|---|
| date | Mon, 15 Mar 2010 16:35:38 -0500 |
| parents | f965e31a35f0 |
| children | 6c6d78781d59 |
| rev | line source |
|---|---|
| 428 | 1 /* Specifier implementation |
| 2 Copyright (C) 1994, 1995 Board of Trustees, University of Illinois. | |
|
5015
d95c102a96d3
cleanups for specifier font stages, from ben-unicode-internal (preparation for eliminating shadowed warnings)
Ben Wing <ben@xemacs.org>
parents:
5013
diff
changeset
|
3 Copyright (C) 1995, 1996, 2002, 2005, 2010 Ben Wing. |
| 428 | 4 Copyright (C) 1995 Sun Microsystems, Inc. |
| 5 | |
| 6 This file is part of XEmacs. | |
| 7 | |
| 8 XEmacs is free software; you can redistribute it and/or modify it | |
| 9 under the terms of the GNU General Public License as published by the | |
| 10 Free Software Foundation; either version 2, or (at your option) any | |
| 11 later version. | |
| 12 | |
| 13 XEmacs is distributed in the hope that it will be useful, but WITHOUT | |
| 14 ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or | |
| 15 FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License | |
| 16 for more details. | |
| 17 | |
| 18 You should have received a copy of the GNU General Public License | |
| 19 along with XEmacs; see the file COPYING. If not, write to | |
| 20 the Free Software Foundation, Inc., 59 Temple Place - Suite 330, | |
| 21 Boston, MA 02111-1307, USA. */ | |
| 22 | |
| 23 /* Synched up with: Not in FSF. */ | |
| 24 | |
| 25 /* Design by Ben Wing; | |
| 2953 | 26 Written by Ben Wing based on prototype for 19.12 by Chuck Thompson. |
| 27 Magic specifiers by Kirill Katsnelson. | |
| 428 | 28 */ |
| 29 | |
| 30 #include <config.h> | |
| 31 #include "lisp.h" | |
| 32 | |
| 33 #include "buffer.h" | |
| 800 | 34 #include "chartab.h" |
| 872 | 35 #include "device-impl.h" |
|
5015
d95c102a96d3
cleanups for specifier font stages, from ben-unicode-internal (preparation for eliminating shadowed warnings)
Ben Wing <ben@xemacs.org>
parents:
5013
diff
changeset
|
36 #include "elhash.h" |
| 428 | 37 #include "frame.h" |
| 800 | 38 #include "glyphs.h" |
| 428 | 39 #include "opaque.h" |
| 800 | 40 #include "rangetab.h" |
| 428 | 41 #include "specifier.h" |
| 42 #include "window.h" | |
| 43 | |
| 44 Lisp_Object Qspecifierp; | |
| 442 | 45 Lisp_Object Qremove_tag_set_prepend, Qremove_tag_set_append; |
| 46 Lisp_Object Qremove_locale, Qremove_locale_type; | |
| 428 | 47 |
| 48 Lisp_Object Qconsole_type, Qdevice_class; | |
| 49 | |
| 50 static Lisp_Object Vuser_defined_tags; | |
|
5015
d95c102a96d3
cleanups for specifier font stages, from ben-unicode-internal (preparation for eliminating shadowed warnings)
Ben Wing <ben@xemacs.org>
parents:
5013
diff
changeset
|
51 /* This is a hash table mapping charsets to "tag lists". A tag list here |
|
d95c102a96d3
cleanups for specifier font stages, from ben-unicode-internal (preparation for eliminating shadowed warnings)
Ben Wing <ben@xemacs.org>
parents:
5013
diff
changeset
|
52 is an assoc list mapping charset tags to size-two vectors (one for the |
|
d95c102a96d3
cleanups for specifier font stages, from ben-unicode-internal (preparation for eliminating shadowed warnings)
Ben Wing <ben@xemacs.org>
parents:
5013
diff
changeset
|
53 initial stage, one for the final stage) containing t or nil, indicating |
|
d95c102a96d3
cleanups for specifier font stages, from ben-unicode-internal (preparation for eliminating shadowed warnings)
Ben Wing <ben@xemacs.org>
parents:
5013
diff
changeset
|
54 whether the charset tag matches the charset for the given stage. These |
|
d95c102a96d3
cleanups for specifier font stages, from ben-unicode-internal (preparation for eliminating shadowed warnings)
Ben Wing <ben@xemacs.org>
parents:
5013
diff
changeset
|
55 values are determined at the time a charset tag is defined by calling |
|
d95c102a96d3
cleanups for specifier font stages, from ben-unicode-internal (preparation for eliminating shadowed warnings)
Ben Wing <ben@xemacs.org>
parents:
5013
diff
changeset
|
56 the charset predicate on all the existing charsets, and at the time a |
|
d95c102a96d3
cleanups for specifier font stages, from ben-unicode-internal (preparation for eliminating shadowed warnings)
Ben Wing <ben@xemacs.org>
parents:
5013
diff
changeset
|
57 charset is defined by calling the predicate on all existing charset |
|
d95c102a96d3
cleanups for specifier font stages, from ben-unicode-internal (preparation for eliminating shadowed warnings)
Ben Wing <ben@xemacs.org>
parents:
5013
diff
changeset
|
58 tags. */ |
| 3659 | 59 static Lisp_Object Vcharset_tag_lists; |
| 428 | 60 |
| 61 typedef struct specifier_type_entry specifier_type_entry; | |
| 62 struct specifier_type_entry | |
| 63 { | |
| 64 Lisp_Object symbol; | |
| 65 struct specifier_methods *meths; | |
| 66 }; | |
| 67 | |
| 68 typedef struct | |
| 69 { | |
| 70 Dynarr_declare (specifier_type_entry); | |
| 71 } specifier_type_entry_dynarr; | |
| 72 | |
| 73 static specifier_type_entry_dynarr *the_specifier_type_entry_dynarr; | |
| 74 | |
| 1204 | 75 static const struct memory_description ste_description_1[] = { |
| 440 | 76 { XD_LISP_OBJECT, offsetof (specifier_type_entry, symbol) }, |
| 2367 | 77 { XD_BLOCK_PTR, offsetof (specifier_type_entry, meths), 1, |
| 2551 | 78 { &specifier_methods_description } }, |
| 428 | 79 { XD_END } |
| 80 }; | |
| 81 | |
| 1204 | 82 static const struct sized_memory_description ste_description = { |
| 440 | 83 sizeof (specifier_type_entry), |
| 428 | 84 ste_description_1 |
| 85 }; | |
| 86 | |
| 1204 | 87 static const struct memory_description sted_description_1[] = { |
| 440 | 88 XD_DYNARR_DESC (specifier_type_entry_dynarr, &ste_description), |
| 428 | 89 { XD_END } |
| 90 }; | |
| 91 | |
| 1204 | 92 static const struct sized_memory_description sted_description = { |
| 440 | 93 sizeof (specifier_type_entry_dynarr), |
| 428 | 94 sted_description_1 |
| 95 }; | |
| 96 | |
| 97 static Lisp_Object Vspecifier_type_list; | |
| 98 | |
| 99 static Lisp_Object Vcached_specifiers; | |
| 100 /* Do NOT mark through this, or specifiers will never be GC'd. */ | |
| 101 static Lisp_Object Vall_specifiers; | |
| 102 | |
| 103 static Lisp_Object Vunlock_ghost_specifiers; | |
| 104 | |
| 105 /* #### The purpose of this is to check for inheritance loops | |
| 106 in specifiers that can inherit from other specifiers, but it's | |
| 107 not yet implemented. | |
| 108 | |
| 109 #### Look into this for 19.14. */ | |
| 110 /* static Lisp_Object_dynarr current_specifiers; */ | |
| 111 | |
| 112 static void recompute_cached_specifier_everywhere (Lisp_Object specifier); | |
| 113 | |
| 114 EXFUN (Fspecifier_specs, 4); | |
| 115 EXFUN (Fremove_specifier, 4); | |
| 116 | |
| 117 | |
| 118 /************************************************************************/ | |
| 119 /* Specifier object methods */ | |
| 120 /************************************************************************/ | |
| 121 | |
| 122 /* Remove dead objects from the specified assoc list. */ | |
| 123 | |
| 124 static Lisp_Object | |
| 125 cleanup_assoc_list (Lisp_Object list) | |
| 126 { | |
| 127 Lisp_Object loop, prev, retval; | |
| 128 | |
| 129 loop = retval = list; | |
| 130 prev = Qnil; | |
| 131 | |
| 132 while (!NILP (loop)) | |
| 133 { | |
| 134 Lisp_Object entry = XCAR (loop); | |
| 135 Lisp_Object key = XCAR (entry); | |
| 136 | |
| 137 /* remember, dead windows can become alive again. */ | |
| 138 if (!WINDOWP (key) && object_dead_p (key)) | |
| 139 { | |
| 140 if (NILP (prev)) | |
| 141 { | |
| 142 /* Removing the head. */ | |
| 143 retval = XCDR (retval); | |
| 144 } | |
| 145 else | |
| 146 { | |
| 147 Fsetcdr (prev, XCDR (loop)); | |
| 148 } | |
| 149 } | |
| 150 else | |
| 151 prev = loop; | |
| 152 | |
| 153 loop = XCDR (loop); | |
| 154 } | |
| 155 | |
| 156 return retval; | |
| 157 } | |
| 158 | |
| 159 /* Remove dead objects from the various lists so that they | |
| 160 don't keep getting marked as long as this specifier exists and | |
| 161 therefore wasting memory. */ | |
| 162 | |
| 163 void | |
| 164 cleanup_specifiers (void) | |
| 165 { | |
| 166 Lisp_Object rest; | |
| 167 | |
| 168 for (rest = Vall_specifiers; | |
| 169 !NILP (rest); | |
| 170 rest = XSPECIFIER (rest)->next_specifier) | |
| 171 { | |
| 440 | 172 Lisp_Specifier *sp = XSPECIFIER (rest); |
| 428 | 173 /* This effectively changes the specifier specs. |
| 174 However, there's no need to call | |
| 175 recompute_cached_specifier_everywhere() or the | |
| 176 after-change methods because the only specs we | |
| 177 are removing are for dead objects, and they can | |
| 178 never have any effect on the specifier values: | |
| 179 specifiers can only be instantiated over live | |
| 180 objects, and you can't derive a dead object | |
| 181 from a live one. */ | |
| 182 sp->device_specs = cleanup_assoc_list (sp->device_specs); | |
| 183 sp->frame_specs = cleanup_assoc_list (sp->frame_specs); | |
| 184 sp->buffer_specs = cleanup_assoc_list (sp->buffer_specs); | |
| 185 /* windows are handled specially because dead windows | |
| 186 can be resurrected */ | |
| 187 } | |
| 188 } | |
| 189 | |
| 190 void | |
| 191 kill_specifier_buffer_locals (Lisp_Object buffer) | |
| 192 { | |
| 193 Lisp_Object rest; | |
| 194 | |
| 195 for (rest = Vall_specifiers; | |
| 196 !NILP (rest); | |
| 197 rest = XSPECIFIER (rest)->next_specifier) | |
| 198 { | |
| 440 | 199 Lisp_Specifier *sp = XSPECIFIER (rest); |
| 428 | 200 |
| 201 /* Make sure we're actually going to be changing something. | |
| 202 Fremove_specifier() always calls | |
| 203 recompute_cached_specifier_everywhere() (#### but should | |
| 204 be smarter about this). */ | |
| 205 if (!NILP (assq_no_quit (buffer, sp->buffer_specs))) | |
| 206 Fremove_specifier (rest, buffer, Qnil, Qnil); | |
| 207 } | |
| 208 } | |
| 209 | |
| 210 static Lisp_Object | |
| 211 mark_specifier (Lisp_Object obj) | |
| 212 { | |
| 440 | 213 Lisp_Specifier *specifier = XSPECIFIER (obj); |
| 428 | 214 |
| 215 mark_object (specifier->global_specs); | |
| 216 mark_object (specifier->device_specs); | |
| 217 mark_object (specifier->frame_specs); | |
| 218 mark_object (specifier->window_specs); | |
| 219 mark_object (specifier->buffer_specs); | |
| 220 mark_object (specifier->magic_parent); | |
| 221 mark_object (specifier->fallback); | |
| 222 if (!GHOST_SPECIFIER_P (XSPECIFIER (obj))) | |
| 223 MAYBE_SPECMETH (specifier, mark, (obj)); | |
| 224 return Qnil; | |
| 225 } | |
| 226 | |
| 227 /* The idea here is that the specifier specs point to locales | |
| 228 (windows, buffers, frames, and devices), and we want to make sure | |
| 229 that the specs disappear automatically when the associated locale | |
| 230 is no longer in use. For all but windows, "no longer in use" | |
| 231 corresponds exactly to when the object is deleted (non-deleted | |
| 232 objects are always held permanently in special lists, and deleted | |
| 233 objects are never on these lists and never reusable). To handle | |
| 234 this, we just have cleanup_specifiers() called periodically | |
| 235 (at the beginning of garbage collection); it removes all dead | |
| 236 objects. | |
| 237 | |
| 238 For windows, however, it's trickier because dead objects can be | |
| 239 converted to live ones again if the dead object is in a window | |
| 240 configuration. Therefore, for windows, "no longer in use" | |
| 241 corresponds to when the window object is garbage-collected. | |
| 242 We now use weak lists for this purpose. | |
| 243 | |
| 244 */ | |
| 245 | |
| 246 void | |
| 247 prune_specifiers (void) | |
| 248 { | |
| 249 Lisp_Object rest, prev = Qnil; | |
| 250 | |
| 251 for (rest = Vall_specifiers; | |
| 252 !NILP (rest); | |
| 253 rest = XSPECIFIER (rest)->next_specifier) | |
| 254 { | |
| 255 if (! marked_p (rest)) | |
| 256 { | |
| 440 | 257 Lisp_Specifier* sp = XSPECIFIER (rest); |
| 428 | 258 /* A bit of assertion that we're removing both parts of the |
|
4426
515b91f904c1
Fix specifier inheritance behavior
Didier Verna <didier@xemacs.org>
parents:
3836
diff
changeset
|
259 magic one altogether */ |
| 428 | 260 assert (!MAGIC_SPECIFIER_P(sp) |
| 261 || (BODILY_SPECIFIER_P(sp) && marked_p (sp->fallback)) | |
| 262 || (GHOST_SPECIFIER_P(sp) && marked_p (sp->magic_parent))); | |
| 263 /* This specifier is garbage. Remove it from the list. */ | |
| 264 if (NILP (prev)) | |
| 265 Vall_specifiers = sp->next_specifier; | |
| 266 else | |
| 267 XSPECIFIER (prev)->next_specifier = sp->next_specifier; | |
| 268 } | |
| 269 else | |
| 270 prev = rest; | |
| 271 } | |
| 272 } | |
| 273 | |
| 274 static void | |
| 2286 | 275 print_specifier (Lisp_Object obj, Lisp_Object printcharfun, |
| 276 int UNUSED (escapeflag)) | |
| 428 | 277 { |
| 440 | 278 Lisp_Specifier *sp = XSPECIFIER (obj); |
| 428 | 279 int count = specpdl_depth (); |
| 280 Lisp_Object the_specs; | |
| 281 | |
| 282 if (print_readably) | |
|
5142
f965e31a35f0
reduce lcrecord headers to 2 words, rename printing_unreadable_object
Ben Wing <ben@xemacs.org>
parents:
5127
diff
changeset
|
283 printing_unreadable_object_fmt ("#<%s-specifier 0x%x>", |
|
5146
88bd4f3ef8e4
make lrecord UID's have a separate UID space for each object, resurrect debug SOE code in extents.c
Ben Wing <ben@xemacs.org>
parents:
5142
diff
changeset
|
284 sp->methods->name, LISP_OBJECT_UID (obj)); |
| 428 | 285 |
| 800 | 286 write_fmt_string (printcharfun, "#<%s-specifier global=", sp->methods->name); |
| 872 | 287 #if 0 |
| 288 /* #### Not obvious this is useful, and overrides user settings; if we | |
| 289 resurrect this, create variables like `print-specifier-length' so it | |
| 290 can be controlled. */ | |
| 428 | 291 specbind (Qprint_string_length, make_int (100)); |
| 292 specbind (Qprint_length, make_int (5)); | |
| 872 | 293 #endif |
| 428 | 294 the_specs = Fspecifier_specs (obj, Qglobal, Qnil, Qnil); |
| 295 if (NILP (the_specs)) | |
| 296 /* there are no global specs */ | |
|
4952
19a72041c5ed
Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents:
4853
diff
changeset
|
297 write_ascstring (printcharfun, "<unspecified>"); |
| 428 | 298 else |
| 299 print_internal (the_specs, printcharfun, 1); | |
| 300 if (!NILP (sp->fallback)) | |
| 301 { | |
| 800 | 302 write_fmt_string_lisp (printcharfun, " fallback=%S", 1, sp->fallback); |
| 428 | 303 } |
| 771 | 304 unbind_to (count); |
|
5146
88bd4f3ef8e4
make lrecord UID's have a separate UID space for each object, resurrect debug SOE code in extents.c
Ben Wing <ben@xemacs.org>
parents:
5142
diff
changeset
|
305 write_fmt_string (printcharfun, " 0x%x>", LISP_OBJECT_UID (obj)); |
| 428 | 306 } |
| 307 | |
| 3263 | 308 #ifndef NEW_GC |
| 428 | 309 static void |
|
5127
a9c41067dd88
more cleanups, terminology clarification, lots of doc work
Ben Wing <ben@xemacs.org>
parents:
5125
diff
changeset
|
310 finalize_specifier (Lisp_Object obj) |
| 428 | 311 { |
|
5127
a9c41067dd88
more cleanups, terminology clarification, lots of doc work
Ben Wing <ben@xemacs.org>
parents:
5125
diff
changeset
|
312 Lisp_Specifier *sp = XSPECIFIER (obj); |
|
5124
623d57b7fbe8
separate regular and disksave finalization, print method fixes.
Ben Wing <ben@xemacs.org>
parents:
5120
diff
changeset
|
313 if (!GHOST_SPECIFIER_P(sp) && sp->caching) |
| 428 | 314 { |
|
4976
16112448d484
Rename xfree(FOO, TYPE) -> xfree(FOO)
Ben Wing <ben@xemacs.org>
parents:
4962
diff
changeset
|
315 xfree (sp->caching); |
| 428 | 316 sp->caching = 0; |
| 317 } | |
| 318 } | |
| 3263 | 319 #endif /* not NEW_GC */ |
| 428 | 320 |
| 321 static int | |
|
4906
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4853
diff
changeset
|
322 specifier_equal (Lisp_Object obj1, Lisp_Object obj2, int depth, int foldcase) |
| 428 | 323 { |
| 440 | 324 Lisp_Specifier *s1 = XSPECIFIER (obj1); |
| 325 Lisp_Specifier *s2 = XSPECIFIER (obj2); | |
| 428 | 326 int retval; |
| 327 Lisp_Object old_inhibit_quit = Vinhibit_quit; | |
| 328 | |
| 329 /* This function can be called from within redisplay. | |
| 330 internal_equal can trigger a quit. That leads to Bad Things. */ | |
| 331 Vinhibit_quit = Qt; | |
| 332 | |
| 333 depth++; | |
| 334 retval = | |
| 335 (s1->methods == s2->methods && | |
|
4906
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4853
diff
changeset
|
336 internal_equal_0 (s1->global_specs, s2->global_specs, depth, foldcase) && |
|
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4853
diff
changeset
|
337 internal_equal_0 (s1->device_specs, s2->device_specs, depth, foldcase) && |
|
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4853
diff
changeset
|
338 internal_equal_0 (s1->frame_specs, s2->frame_specs, depth, foldcase) && |
|
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4853
diff
changeset
|
339 internal_equal_0 (s1->window_specs, s2->window_specs, depth, foldcase) && |
|
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4853
diff
changeset
|
340 internal_equal_0 (s1->buffer_specs, s2->buffer_specs, depth, foldcase) && |
|
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4853
diff
changeset
|
341 internal_equal_0 (s1->fallback, s2->fallback, depth, foldcase)); |
| 428 | 342 |
| 343 if (retval && HAS_SPECMETH_P (s1, equal)) | |
| 344 retval = SPECMETH (s1, equal, (obj1, obj2, depth - 1)); | |
| 345 | |
| 346 Vinhibit_quit = old_inhibit_quit; | |
| 347 return retval; | |
| 348 } | |
| 349 | |
| 2515 | 350 static Hashcode |
| 428 | 351 specifier_hash (Lisp_Object obj, int depth) |
| 352 { | |
| 440 | 353 Lisp_Specifier *s = XSPECIFIER (obj); |
| 428 | 354 |
| 355 /* specifier hashing is a bit problematic because there are so | |
| 356 many places where data can be stored. We pick what are perhaps | |
| 357 the most likely places where interesting stuff will be. */ | |
| 358 return HASH5 ((HAS_SPECMETH_P (s, hash) ? | |
| 359 SPECMETH (s, hash, (obj, depth)) : 0), | |
| 2515 | 360 (Hashcode) s->methods, |
| 428 | 361 internal_hash (s->global_specs, depth + 1), |
| 362 internal_hash (s->frame_specs, depth + 1), | |
| 363 internal_hash (s->buffer_specs, depth + 1)); | |
| 364 } | |
| 365 | |
| 665 | 366 inline static Bytecount |
| 367 aligned_sizeof_specifier (Bytecount specifier_type_specific_size) | |
| 456 | 368 { |
| 826 | 369 return MAX_ALIGN_SIZE (offsetof (Lisp_Specifier, data) |
| 370 + specifier_type_specific_size); | |
| 456 | 371 } |
| 372 | |
| 665 | 373 static Bytecount |
|
5127
a9c41067dd88
more cleanups, terminology clarification, lots of doc work
Ben Wing <ben@xemacs.org>
parents:
5125
diff
changeset
|
374 sizeof_specifier (Lisp_Object obj) |
| 428 | 375 { |
|
5127
a9c41067dd88
more cleanups, terminology clarification, lots of doc work
Ben Wing <ben@xemacs.org>
parents:
5125
diff
changeset
|
376 const Lisp_Specifier *p = XSPECIFIER (obj); |
| 456 | 377 return aligned_sizeof_specifier (GHOST_SPECIFIER_P (p) |
| 378 ? 0 | |
| 379 : p->methods->extra_data_size); | |
| 428 | 380 } |
| 381 | |
| 1204 | 382 static const struct memory_description specifier_methods_description_1[] = { |
| 440 | 383 { XD_LISP_OBJECT, offsetof (struct specifier_methods, predicate_symbol) }, |
| 428 | 384 { XD_END } |
| 385 }; | |
| 386 | |
| 1204 | 387 const struct sized_memory_description specifier_methods_description = { |
| 440 | 388 sizeof (struct specifier_methods), |
| 428 | 389 specifier_methods_description_1 |
| 390 }; | |
| 391 | |
| 1204 | 392 static const struct memory_description specifier_caching_description_1[] = { |
| 428 | 393 { XD_END } |
| 394 }; | |
| 395 | |
| 3092 | 396 #ifdef NEW_GC |
|
5118
e0db3c197671
merge up to latest default branch, doesn't compile yet
Ben Wing <ben@xemacs.org>
diff
changeset
|
397 DEFINE_DUMPABLE_INTERNAL_LISP_OBJECT ("specifier-caching", specifier_caching, |
|
e0db3c197671
merge up to latest default branch, doesn't compile yet
Ben Wing <ben@xemacs.org>
diff
changeset
|
398 0, specifier_caching_description_1, |
|
e0db3c197671
merge up to latest default branch, doesn't compile yet
Ben Wing <ben@xemacs.org>
diff
changeset
|
399 struct specifier_caching); |
| 3092 | 400 #else /* not NEW_GC */ |
| 1204 | 401 static const struct sized_memory_description specifier_caching_description = { |
| 440 | 402 sizeof (struct specifier_caching), |
| 428 | 403 specifier_caching_description_1 |
| 404 }; | |
| 3092 | 405 #endif /* not NEW_GC */ |
| 428 | 406 |
| 1204 | 407 static const struct sized_memory_description specifier_extra_description_map[] |
| 408 = { | |
| 409 { offsetof (Lisp_Specifier, methods) }, | |
| 410 { offsetof (struct specifier_methods, extra_description) }, | |
| 411 { -1 }, | |
| 412 }; | |
| 413 | |
| 414 const struct memory_description specifier_description[] = { | |
| 2367 | 415 { XD_BLOCK_PTR, offsetof (Lisp_Specifier, methods), 1, |
| 2551 | 416 { &specifier_methods_description } }, |
| 440 | 417 { XD_LO_LINK, offsetof (Lisp_Specifier, next_specifier) }, |
| 418 { XD_LISP_OBJECT, offsetof (Lisp_Specifier, global_specs) }, | |
| 419 { XD_LISP_OBJECT, offsetof (Lisp_Specifier, device_specs) }, | |
| 420 { XD_LISP_OBJECT, offsetof (Lisp_Specifier, frame_specs) }, | |
| 421 { XD_LISP_OBJECT, offsetof (Lisp_Specifier, window_specs) }, | |
| 422 { XD_LISP_OBJECT, offsetof (Lisp_Specifier, buffer_specs) }, | |
| 3092 | 423 #ifdef NEW_GC |
| 424 { XD_LISP_OBJECT, offsetof (Lisp_Specifier, caching) }, | |
| 425 #else /* not NEW_GC */ | |
| 2367 | 426 { XD_BLOCK_PTR, offsetof (Lisp_Specifier, caching), 1, |
| 2551 | 427 { &specifier_caching_description } }, |
| 3092 | 428 #endif /* not NEW_GC */ |
| 440 | 429 { XD_LISP_OBJECT, offsetof (Lisp_Specifier, magic_parent) }, |
| 430 { XD_LISP_OBJECT, offsetof (Lisp_Specifier, fallback) }, | |
| 2367 | 431 { XD_BLOCK_ARRAY, offsetof (Lisp_Specifier, data), 1, |
| 2551 | 432 { specifier_extra_description_map } }, |
| 428 | 433 { XD_END } |
| 434 }; | |
| 435 | |
| 1204 | 436 static const struct memory_description specifier_empty_extra_description_1[] = |
| 3659 | 437 { |
| 438 { XD_END } | |
| 439 }; | |
| 1204 | 440 |
| 441 const struct sized_memory_description specifier_empty_extra_description = { | |
| 442 0, specifier_empty_extra_description_1 | |
| 443 }; | |
| 444 | |
| 3263 | 445 #ifdef NEW_GC |
|
5118
e0db3c197671
merge up to latest default branch, doesn't compile yet
Ben Wing <ben@xemacs.org>
diff
changeset
|
446 DEFINE_DUMPABLE_SIZABLE_LISP_OBJECT ("specifier", specifier, |
|
e0db3c197671
merge up to latest default branch, doesn't compile yet
Ben Wing <ben@xemacs.org>
diff
changeset
|
447 mark_specifier, print_specifier, |
|
e0db3c197671
merge up to latest default branch, doesn't compile yet
Ben Wing <ben@xemacs.org>
diff
changeset
|
448 0, specifier_equal, specifier_hash, |
|
e0db3c197671
merge up to latest default branch, doesn't compile yet
Ben Wing <ben@xemacs.org>
diff
changeset
|
449 specifier_description, |
|
e0db3c197671
merge up to latest default branch, doesn't compile yet
Ben Wing <ben@xemacs.org>
diff
changeset
|
450 sizeof_specifier, |
|
e0db3c197671
merge up to latest default branch, doesn't compile yet
Ben Wing <ben@xemacs.org>
diff
changeset
|
451 Lisp_Specifier); |
| 3263 | 452 #else /* not NEW_GC */ |
|
5118
e0db3c197671
merge up to latest default branch, doesn't compile yet
Ben Wing <ben@xemacs.org>
diff
changeset
|
453 DEFINE_DUMPABLE_SIZABLE_LISP_OBJECT ("specifier", specifier, |
|
e0db3c197671
merge up to latest default branch, doesn't compile yet
Ben Wing <ben@xemacs.org>
diff
changeset
|
454 mark_specifier, print_specifier, |
|
e0db3c197671
merge up to latest default branch, doesn't compile yet
Ben Wing <ben@xemacs.org>
diff
changeset
|
455 finalize_specifier, |
|
e0db3c197671
merge up to latest default branch, doesn't compile yet
Ben Wing <ben@xemacs.org>
diff
changeset
|
456 specifier_equal, specifier_hash, |
|
e0db3c197671
merge up to latest default branch, doesn't compile yet
Ben Wing <ben@xemacs.org>
diff
changeset
|
457 specifier_description, |
|
e0db3c197671
merge up to latest default branch, doesn't compile yet
Ben Wing <ben@xemacs.org>
diff
changeset
|
458 sizeof_specifier, |
|
e0db3c197671
merge up to latest default branch, doesn't compile yet
Ben Wing <ben@xemacs.org>
diff
changeset
|
459 Lisp_Specifier); |
| 3263 | 460 #endif /* not NEW_GC */ |
| 428 | 461 |
| 462 /************************************************************************/ | |
| 463 /* Creating specifiers */ | |
| 464 /************************************************************************/ | |
| 465 | |
| 466 static struct specifier_methods * | |
| 578 | 467 decode_specifier_type (Lisp_Object type, Error_Behavior errb) |
| 428 | 468 { |
| 469 int i; | |
| 470 | |
| 471 for (i = 0; i < Dynarr_length (the_specifier_type_entry_dynarr); i++) | |
| 472 { | |
| 473 if (EQ (type, Dynarr_at (the_specifier_type_entry_dynarr, i).symbol)) | |
| 474 return Dynarr_at (the_specifier_type_entry_dynarr, i).meths; | |
| 475 } | |
| 476 | |
| 563 | 477 maybe_invalid_argument ("Invalid specifier type", |
| 3659 | 478 type, Qspecifier, errb); |
| 428 | 479 |
| 480 return 0; | |
| 481 } | |
| 482 | |
| 483 static int | |
| 484 valid_specifier_type_p (Lisp_Object type) | |
| 485 { | |
| 486 return decode_specifier_type (type, ERROR_ME_NOT) != 0; | |
| 487 } | |
| 488 | |
| 489 DEFUN ("valid-specifier-type-p", Fvalid_specifier_type_p, 1, 1, 0, /* | |
| 490 Given a SPECIFIER-TYPE, return non-nil if it is valid. | |
| 2953 | 491 Valid types are `generic', `integer', `boolean', `color', `font', `image', |
| 492 `face-boolean', and `toolbar'. | |
| 428 | 493 */ |
| 494 (specifier_type)) | |
| 495 { | |
| 496 return valid_specifier_type_p (specifier_type) ? Qt : Qnil; | |
| 497 } | |
| 498 | |
| 499 DEFUN ("specifier-type-list", Fspecifier_type_list, 0, 0, 0, /* | |
| 500 Return a list of valid specifier types. | |
| 501 */ | |
| 502 ()) | |
| 503 { | |
| 504 return Fcopy_sequence (Vspecifier_type_list); | |
| 505 } | |
| 506 | |
| 507 void | |
| 508 add_entry_to_specifier_type_list (Lisp_Object symbol, | |
| 509 struct specifier_methods *meths) | |
| 510 { | |
| 511 struct specifier_type_entry entry; | |
| 512 | |
| 513 entry.symbol = symbol; | |
| 514 entry.meths = meths; | |
| 515 Dynarr_add (the_specifier_type_entry_dynarr, entry); | |
| 516 Vspecifier_type_list = Fcons (symbol, Vspecifier_type_list); | |
| 517 } | |
| 518 | |
| 519 static Lisp_Object | |
| 520 make_specifier_internal (struct specifier_methods *spec_meths, | |
| 665 | 521 Bytecount data_size, int call_create_meth) |
| 428 | 522 { |
|
5117
3742ea8250b5
Checking in final CVS version of workspace 'ben-lisp-object'
Ben Wing <ben@xemacs.org>
parents:
3017
diff
changeset
|
523 Lisp_Object specifier = |
|
3742ea8250b5
Checking in final CVS version of workspace 'ben-lisp-object'
Ben Wing <ben@xemacs.org>
parents:
3017
diff
changeset
|
524 ALLOC_SIZED_LISP_OBJECT (aligned_sizeof_specifier (data_size), specifier); |
|
3742ea8250b5
Checking in final CVS version of workspace 'ben-lisp-object'
Ben Wing <ben@xemacs.org>
parents:
3017
diff
changeset
|
525 Lisp_Specifier *sp = XSPECIFIER (specifier); |
| 428 | 526 |
| 527 sp->methods = spec_meths; | |
| 528 sp->global_specs = Qnil; | |
| 529 sp->device_specs = Qnil; | |
| 530 sp->frame_specs = Qnil; | |
| 531 sp->window_specs = make_weak_list (WEAK_LIST_KEY_ASSOC); | |
| 532 sp->buffer_specs = Qnil; | |
| 533 sp->fallback = Qnil; | |
| 534 sp->magic_parent = Qnil; | |
| 535 sp->caching = 0; | |
| 536 sp->next_specifier = Vall_specifiers; | |
| 537 | |
| 538 Vall_specifiers = specifier; | |
| 539 | |
| 540 if (call_create_meth) | |
| 541 { | |
| 542 struct gcpro gcpro1; | |
| 543 GCPRO1 (specifier); | |
| 544 MAYBE_SPECMETH (XSPECIFIER (specifier), create, (specifier)); | |
| 545 UNGCPRO; | |
| 546 } | |
| 547 return specifier; | |
| 548 } | |
| 549 | |
| 550 static Lisp_Object | |
| 551 make_specifier (struct specifier_methods *meths) | |
| 552 { | |
| 553 return make_specifier_internal (meths, meths->extra_data_size, 1); | |
| 554 } | |
| 555 | |
| 556 Lisp_Object | |
| 557 make_magic_specifier (Lisp_Object type) | |
| 558 { | |
| 559 /* This function can GC */ | |
| 560 struct specifier_methods *meths = decode_specifier_type (type, ERROR_ME); | |
| 561 Lisp_Object bodily, ghost; | |
| 562 struct gcpro gcpro1; | |
| 563 | |
| 564 bodily = make_specifier (meths); | |
| 565 GCPRO1 (bodily); | |
| 566 ghost = make_specifier_internal (meths, 0, 0); | |
| 567 UNGCPRO; | |
| 568 | |
| 569 /* Connect guys together */ | |
| 570 XSPECIFIER(bodily)->magic_parent = Qt; | |
| 571 XSPECIFIER(bodily)->fallback = ghost; | |
| 572 XSPECIFIER(ghost)->magic_parent = bodily; | |
| 573 | |
| 574 return bodily; | |
| 575 } | |
| 576 | |
| 577 DEFUN ("make-specifier", Fmake_specifier, 1, 1, 0, /* | |
| 578 Return a new specifier object of type TYPE. | |
| 579 | |
| 580 A specifier is an object that can be used to keep track of a property | |
| 581 whose value can be per-buffer, per-window, per-frame, or per-device, | |
| 442 | 582 and can further be restricted to a particular console-type or |
| 583 device-class. Specifiers are used, for example, for the various | |
| 584 built-in properties of a face; this allows a face to have different | |
| 585 values in different frames, buffers, etc. | |
| 586 | |
| 587 When speaking of the value of a specifier, it is important to | |
| 588 distinguish between the *setting* of a specifier, called an | |
| 589 \"instantiator\", and the *actual value*, called an \"instance\". You | |
| 590 put various possible instantiators (i.e. settings) into a specifier | |
| 591 and associate them with particular locales (buffer, window, frame, | |
| 592 device, global), and then the instance (i.e. actual value) is | |
| 593 retrieved in a specific domain (window, frame, device) by looking | |
| 594 through the possible instantiators (i.e. settings). This process is | |
| 595 called \"instantiation\". | |
| 444 | 596 |
| 442 | 597 To put settings into a specifier, use `set-specifier', or the |
| 598 lower-level functions `add-spec-to-specifier' and | |
| 599 `add-spec-list-to-specifier'. You can also temporarily bind a setting | |
| 600 to a specifier using `let-specifier'. To retrieve settings, use | |
| 601 `specifier-specs', or its lower-level counterpart | |
| 2953 | 602 `specifier-spec-list'. |
| 603 | |
| 604 To determine the actual value (i.e. the instance) in a particular domain, use | |
| 605 `specifier-instance'. To determine the corresponding setting that yielded | |
| 606 the value (i.e. the instantiator), use `specifier-instantiator'. | |
| 442 | 607 |
| 608 For more information, see `set-specifier', `specifier-instance', | |
| 428 | 609 `specifier-specs', and `add-spec-to-specifier'; or, for a detailed |
| 442 | 610 description of specifiers, including how exactly the instantiation |
| 611 process works, see the chapter on specifiers in the XEmacs Lisp | |
| 612 Reference Manual. | |
| 428 | 613 |
| 614 TYPE specifies the particular type of specifier, and should be one of | |
| 2953 | 615 the symbols `generic', `integer', `natnum', `boolean', `color', `font', |
| 616 `image', `face-boolean', `display-table', `gutter', `gutter-size', | |
| 617 `gutter-visible' or `toolbar'. | |
| 442 | 618 |
| 619 For more information on particular types of specifiers, see the | |
| 620 functions `make-generic-specifier', `make-integer-specifier', | |
| 621 `make-natnum-specifier', `make-boolean-specifier', | |
| 622 `make-color-specifier', `make-font-specifier', `make-image-specifier', | |
| 623 `make-face-boolean-specifier', `make-gutter-size-specifier', | |
| 624 `make-gutter-visible-specifier', `default-toolbar', `default-gutter', | |
| 625 and `current-display-table'. | |
| 428 | 626 */ |
| 627 (type)) | |
| 628 { | |
| 629 /* This function can GC */ | |
| 442 | 630 struct specifier_methods *meths = decode_specifier_type (type, ERROR_ME); |
| 428 | 631 |
| 632 return make_specifier (meths); | |
| 633 } | |
| 634 | |
| 635 DEFUN ("specifierp", Fspecifierp, 1, 1, 0, /* | |
| 636 Return t if OBJECT is a specifier. | |
| 637 | |
| 638 A specifier is an object that can be used to keep track of a property | |
| 639 whose value can be per-buffer, per-window, per-frame, or per-device, | |
| 640 and can further be restricted to a particular console-type or device-class. | |
| 641 See `make-specifier'. | |
| 642 */ | |
| 643 (object)) | |
| 644 { | |
| 645 return SPECIFIERP (object) ? Qt : Qnil; | |
| 646 } | |
| 647 | |
| 648 DEFUN ("specifier-type", Fspecifier_type, 1, 1, 0, /* | |
| 649 Return the type of SPECIFIER. | |
| 650 */ | |
| 651 (specifier)) | |
| 652 { | |
| 653 CHECK_SPECIFIER (specifier); | |
| 654 return intern (XSPECIFIER (specifier)->methods->name); | |
| 655 } | |
| 656 | |
| 657 | |
| 658 /************************************************************************/ | |
| 659 /* Locales and domains */ | |
| 660 /************************************************************************/ | |
| 661 | |
| 662 DEFUN ("valid-specifier-locale-p", Fvalid_specifier_locale_p, 1, 1, 0, /* | |
| 663 Return t if LOCALE is a valid specifier locale. | |
| 2953 | 664 Valid locales are devices, frames, windows, buffers, and `global'. |
| 428 | 665 \(nil is not valid.) |
| 666 */ | |
| 667 (locale)) | |
| 668 { | |
| 669 /* This cannot GC. */ | |
| 670 return ((DEVICEP (locale) && DEVICE_LIVE_P (XDEVICE (locale))) || | |
| 671 (FRAMEP (locale) && FRAME_LIVE_P (XFRAME (locale))) || | |
| 672 (BUFFERP (locale) && BUFFER_LIVE_P (XBUFFER (locale))) || | |
| 673 /* dead windows are allowed because they may become live | |
| 674 windows again when a window configuration is restored */ | |
| 675 WINDOWP (locale) || | |
| 676 EQ (locale, Qglobal)) | |
| 677 ? Qt : Qnil; | |
| 678 } | |
| 679 | |
| 680 DEFUN ("valid-specifier-domain-p", Fvalid_specifier_domain_p, 1, 1, 0, /* | |
| 681 Return t if DOMAIN is a valid specifier domain. | |
| 2953 | 682 A domain is used to instantiate a specifier (i.e. determine the specifier's |
| 442 | 683 value in that domain). Valid domains are image instances, windows, frames, |
| 684 and devices. \(nil is not valid.) image instances are pseudo-domains since | |
| 685 instantiation will actually occur in the window the image instance itself is | |
| 686 instantiated in. | |
| 428 | 687 */ |
| 3659 | 688 (domain)) |
| 428 | 689 { |
| 690 /* This cannot GC. */ | |
| 691 return ((DEVICEP (domain) && DEVICE_LIVE_P (XDEVICE (domain))) || | |
| 692 (FRAMEP (domain) && FRAME_LIVE_P (XFRAME (domain))) || | |
| 442 | 693 (WINDOWP (domain) && WINDOW_LIVE_P (XWINDOW (domain))) || |
| 694 /* #### get image instances out of domains! */ | |
| 695 IMAGE_INSTANCEP (domain)) | |
| 428 | 696 ? Qt : Qnil; |
| 697 } | |
| 698 | |
|
4426
515b91f904c1
Fix specifier inheritance behavior
Didier Verna <didier@xemacs.org>
parents:
3836
diff
changeset
|
699 DEFUN ("valid-specifier-locale-type-p", Fvalid_specifier_locale_type_p, 1, |
| 3659 | 700 1, 0, /* |
| 428 | 701 Given a specifier LOCALE-TYPE, return non-nil if it is valid. |
| 2953 | 702 Valid locale types are `global', `device', `frame', `window', and `buffer'. |
| 428 | 703 \(Note, however, that in functions that accept either a locale or a locale |
| 2953 | 704 type, `global' is considered an individual locale.) |
| 428 | 705 */ |
| 3659 | 706 (locale_type)) |
| 428 | 707 { |
| 708 /* This cannot GC. */ | |
| 709 return (EQ (locale_type, Qglobal) || | |
| 710 EQ (locale_type, Qdevice) || | |
| 711 EQ (locale_type, Qframe) || | |
| 712 EQ (locale_type, Qwindow) || | |
| 713 EQ (locale_type, Qbuffer)) ? Qt : Qnil; | |
| 714 } | |
| 715 | |
| 716 static void | |
| 717 check_valid_locale_or_locale_type (Lisp_Object locale) | |
| 718 { | |
| 719 /* This cannot GC. */ | |
| 720 if (EQ (locale, Qall) || | |
| 721 !NILP (Fvalid_specifier_locale_p (locale)) || | |
| 722 !NILP (Fvalid_specifier_locale_type_p (locale))) | |
| 723 return; | |
| 563 | 724 invalid_argument ("Invalid specifier locale or locale type", locale); |
| 428 | 725 } |
| 726 | |
| 727 DEFUN ("specifier-locale-type-from-locale", Fspecifier_locale_type_from_locale, | |
| 728 1, 1, 0, /* | |
| 729 Given a specifier LOCALE, return its type. | |
| 730 */ | |
| 731 (locale)) | |
| 732 { | |
| 733 /* This cannot GC. */ | |
| 734 if (NILP (Fvalid_specifier_locale_p (locale))) | |
| 563 | 735 invalid_argument ("Invalid specifier locale", |
| 3659 | 736 locale); |
| 428 | 737 if (DEVICEP (locale)) return Qdevice; |
| 738 if (FRAMEP (locale)) return Qframe; | |
| 739 if (WINDOWP (locale)) return Qwindow; | |
| 740 if (BUFFERP (locale)) return Qbuffer; | |
| 741 assert (EQ (locale, Qglobal)); | |
| 742 return Qglobal; | |
| 743 } | |
| 744 | |
| 745 static Lisp_Object | |
| 746 decode_locale (Lisp_Object locale) | |
| 747 { | |
| 748 /* This cannot GC. */ | |
| 749 if (NILP (locale)) | |
| 750 return Qglobal; | |
| 751 else if (!NILP (Fvalid_specifier_locale_p (locale))) | |
| 752 return locale; | |
| 753 else | |
| 563 | 754 invalid_argument ("Invalid specifier locale", |
| 3659 | 755 locale); |
| 428 | 756 |
| 757 return Qnil; | |
| 758 } | |
| 759 | |
| 760 static enum spec_locale_type | |
| 761 decode_locale_type (Lisp_Object locale_type) | |
| 762 { | |
| 763 /* This cannot GC. */ | |
| 764 if (EQ (locale_type, Qglobal)) return LOCALE_GLOBAL; | |
| 765 if (EQ (locale_type, Qdevice)) return LOCALE_DEVICE; | |
| 766 if (EQ (locale_type, Qframe)) return LOCALE_FRAME; | |
| 767 if (EQ (locale_type, Qwindow)) return LOCALE_WINDOW; | |
| 768 if (EQ (locale_type, Qbuffer)) return LOCALE_BUFFER; | |
| 769 | |
| 563 | 770 invalid_argument ("Invalid specifier locale type", |
| 3659 | 771 locale_type); |
| 1204 | 772 RETURN_NOT_REACHED (LOCALE_GLOBAL); |
| 428 | 773 } |
| 774 | |
| 775 Lisp_Object | |
| 776 decode_locale_list (Lisp_Object locale) | |
| 777 { | |
| 778 /* This cannot GC. */ | |
| 779 /* The return value of this function must be GCPRO'd. */ | |
| 780 if (NILP (locale)) | |
| 781 { | |
| 782 return list1 (Qall); | |
| 783 } | |
| 784 else if (CONSP (locale)) | |
| 785 { | |
| 786 EXTERNAL_LIST_LOOP_2 (elt, locale) | |
| 787 check_valid_locale_or_locale_type (elt); | |
| 788 return locale; | |
| 789 } | |
| 790 else | |
| 791 { | |
| 792 check_valid_locale_or_locale_type (locale); | |
| 793 return list1 (locale); | |
| 794 } | |
| 795 } | |
| 796 | |
| 797 static enum spec_locale_type | |
| 798 locale_type_from_locale (Lisp_Object locale) | |
| 799 { | |
| 800 return decode_locale_type (Fspecifier_locale_type_from_locale (locale)); | |
| 801 } | |
| 802 | |
| 803 static void | |
| 804 check_valid_domain (Lisp_Object domain) | |
| 805 { | |
| 806 if (NILP (Fvalid_specifier_domain_p (domain))) | |
| 563 | 807 invalid_argument ("Invalid specifier domain", |
| 3659 | 808 domain); |
| 428 | 809 } |
| 810 | |
| 442 | 811 Lisp_Object |
| 428 | 812 decode_domain (Lisp_Object domain) |
| 813 { | |
| 814 if (NILP (domain)) | |
| 815 return Fselected_window (Qnil); | |
| 816 check_valid_domain (domain); | |
| 817 return domain; | |
| 818 } | |
| 819 | |
| 820 | |
| 821 /************************************************************************/ | |
| 822 /* Tags */ | |
| 823 /************************************************************************/ | |
| 824 | |
| 825 DEFUN ("valid-specifier-tag-p", Fvalid_specifier_tag_p, 1, 1, 0, /* | |
| 826 Return non-nil if TAG is a valid specifier tag. | |
| 827 See also `valid-specifier-tag-set-p'. | |
| 828 */ | |
| 829 (tag)) | |
| 830 { | |
| 831 return (valid_console_type_p (tag) || | |
| 832 valid_device_class_p (tag) || | |
| 833 !NILP (assq_no_quit (tag, Vuser_defined_tags))) ? Qt : Qnil; | |
| 834 } | |
| 835 | |
| 836 DEFUN ("valid-specifier-tag-set-p", Fvalid_specifier_tag_set_p, 1, 1, 0, /* | |
| 837 Return non-nil if TAG-SET is a valid specifier tag set. | |
| 838 | |
| 3659 | 839 A specifier tag set is an entity that is attached to an instantiator and can |
| 840 be used to restrict the scope of that instantiator to a particular device | |
| 841 class, device type, or charset. It can also be used to mark instantiators | |
| 842 added by a particular package so that they can be later removed as a group. | |
| 428 | 843 |
| 844 A specifier tag set consists of a list of zero of more specifier tags, | |
| 845 each of which is a symbol that is recognized by XEmacs as a tag. | |
| 846 \(The valid device types and device classes are always tags, as are | |
| 847 any tags defined by `define-specifier-tag'.) It is called a "tag set" | |
| 848 \(as opposed to a list) because the order of the tags or the number of | |
| 849 times a particular tag occurs does not matter. | |
| 850 | |
| 3659 | 851 Each tag has two predicates associated with it, which specify, respectively, |
| 852 whether that tag applies to a particular device and whether it applies to a | |
| 853 particular character set. The predefined tags which are device types and | |
| 854 classes match devices of that type or class. User-defined tags can have any | |
| 855 device predicate, or none (meaning that all devices match). When attempting | |
| 856 to instantiate a specifier, a particular instantiator is only considered if | |
| 857 the device of the domain being instantiated over matches all tags in the tag | |
| 858 set attached to that instantiator. | |
| 859 | |
| 860 If a charset is to be considered--which is only the case for face | |
| 861 instantiators--this consideration may be done twice. The first iteration | |
| 862 pays attention to the character set predicates; if no instantiator can be | |
| 863 found in that case, the search is repeated ignoring the character set | |
| 864 predicates. | |
| 428 | 865 |
| 866 Most of the time, a tag set is not specified, and the instantiator | |
| 867 gets a null tag set, which matches all devices. | |
| 868 */ | |
| 3659 | 869 (tag_set)) |
| 428 | 870 { |
| 871 Lisp_Object rest; | |
| 872 | |
| 873 for (rest = tag_set; !NILP (rest); rest = XCDR (rest)) | |
| 874 { | |
| 875 if (!CONSP (rest)) | |
| 876 return Qnil; | |
| 877 if (NILP (Fvalid_specifier_tag_p (XCAR (rest)))) | |
| 878 return Qnil; | |
| 879 QUIT; | |
| 880 } | |
| 881 return Qt; | |
| 882 } | |
| 883 | |
| 884 Lisp_Object | |
| 885 decode_specifier_tag_set (Lisp_Object tag_set) | |
| 886 { | |
| 887 /* The return value of this function must be GCPRO'd. */ | |
| 888 if (!NILP (Fvalid_specifier_tag_p (tag_set))) | |
| 889 return list1 (tag_set); | |
| 890 if (NILP (Fvalid_specifier_tag_set_p (tag_set))) | |
| 563 | 891 invalid_argument ("Invalid specifier tag-set", |
| 3659 | 892 tag_set); |
| 428 | 893 return tag_set; |
| 894 } | |
| 895 | |
| 896 static Lisp_Object | |
| 897 canonicalize_tag_set (Lisp_Object tag_set) | |
| 898 { | |
| 899 int len = XINT (Flength (tag_set)); | |
| 900 Lisp_Object *tags, rest; | |
| 901 int i, j; | |
| 902 | |
| 903 /* We assume in this function that the tag_set has already been | |
| 904 validated, so there are no surprises. */ | |
| 905 | |
| 906 if (len == 0 || len == 1) | |
| 907 /* most common case */ | |
| 908 return tag_set; | |
| 909 | |
| 910 tags = alloca_array (Lisp_Object, len); | |
| 911 | |
| 912 i = 0; | |
| 913 LIST_LOOP (rest, tag_set) | |
| 914 tags[i++] = XCAR (rest); | |
| 915 | |
| 916 /* Sort the list of tags. We use a bubble sort here (copied from | |
| 917 extent_fragment_update()) -- reduces the function call overhead, | |
| 918 and is the fastest sort for small numbers of items. */ | |
| 919 | |
| 920 for (i = 1; i < len; i++) | |
| 921 { | |
| 922 j = i - 1; | |
| 923 while (j >= 0 && | |
| 793 | 924 qxestrcmp (XSTRING_DATA (XSYMBOL (tags[j])->name), |
| 925 XSTRING_DATA (XSYMBOL (tags[j+1])->name)) > 0) | |
| 428 | 926 { |
| 927 Lisp_Object tmp = tags[j]; | |
| 928 tags[j] = tags[j+1]; | |
| 929 tags[j+1] = tmp; | |
| 930 j--; | |
| 931 } | |
| 932 } | |
| 933 | |
| 934 /* Now eliminate duplicates. */ | |
| 935 | |
| 936 for (i = 1, j = 1; i < len; i++) | |
| 937 { | |
| 938 /* j holds the destination, i the source. */ | |
| 939 if (!EQ (tags[i], tags[i-1])) | |
| 940 tags[j++] = tags[i]; | |
| 941 } | |
| 942 | |
| 943 return Flist (j, tags); | |
| 944 } | |
| 945 | |
| 946 DEFUN ("canonicalize-tag-set", Fcanonicalize_tag_set, 1, 1, 0, /* | |
| 947 Canonicalize the given tag set. | |
| 948 Two canonicalized tag sets can be compared with `equal' to see if they | |
| 949 represent the same tag set. (Specifically, canonicalizing involves | |
| 950 sorting by symbol name and removing duplicates.) | |
| 951 */ | |
| 952 (tag_set)) | |
| 953 { | |
| 954 if (NILP (Fvalid_specifier_tag_set_p (tag_set))) | |
| 563 | 955 invalid_argument ("Invalid tag set", tag_set); |
| 428 | 956 return canonicalize_tag_set (tag_set); |
| 957 } | |
| 958 | |
| 959 static int | |
| 960 device_matches_specifier_tag_set_p (Lisp_Object device, Lisp_Object tag_set) | |
| 961 { | |
| 962 Lisp_Object devtype, devclass, rest; | |
| 963 struct device *d = XDEVICE (device); | |
| 964 | |
| 965 devtype = DEVICE_TYPE (d); | |
| 966 devclass = DEVICE_CLASS (d); | |
| 967 | |
| 968 LIST_LOOP (rest, tag_set) | |
| 969 { | |
| 970 Lisp_Object tag = XCAR (rest); | |
| 971 Lisp_Object assoc; | |
| 972 | |
| 973 if (EQ (tag, devtype) || EQ (tag, devclass)) | |
| 974 continue; | |
| 975 assoc = assq_no_quit (tag, DEVICE_USER_DEFINED_TAGS (d)); | |
| 976 /* other built-in tags (device types/classes) are not in | |
| 977 the user-defined-tags list. */ | |
| 978 if (NILP (assoc) || NILP (XCDR (assoc))) | |
| 979 return 0; | |
| 980 } | |
| 981 | |
| 982 return 1; | |
| 983 } | |
| 984 | |
| 3659 | 985 static int |
|
5015
d95c102a96d3
cleanups for specifier font stages, from ben-unicode-internal (preparation for eliminating shadowed warnings)
Ben Wing <ben@xemacs.org>
parents:
5013
diff
changeset
|
986 charset_matches_specifier_tag_set_p (Lisp_Object charset, Lisp_Object tag_set, |
|
4426
515b91f904c1
Fix specifier inheritance behavior
Didier Verna <didier@xemacs.org>
parents:
3836
diff
changeset
|
987 enum font_specifier_matchspec_stages |
| 3659 | 988 stage) |
| 989 { | |
| 990 Lisp_Object rest; | |
| 991 int res = 0; | |
| 992 | |
|
5015
d95c102a96d3
cleanups for specifier font stages, from ben-unicode-internal (preparation for eliminating shadowed warnings)
Ben Wing <ben@xemacs.org>
parents:
5013
diff
changeset
|
993 assert(stage < NUM_MATCHSPEC_STAGES); |
| 3659 | 994 |
| 995 LIST_LOOP (rest, tag_set) | |
| 996 { | |
| 997 Lisp_Object tag = XCAR (rest); | |
| 998 Lisp_Object assoc; | |
|
5015
d95c102a96d3
cleanups for specifier font stages, from ben-unicode-internal (preparation for eliminating shadowed warnings)
Ben Wing <ben@xemacs.org>
parents:
5013
diff
changeset
|
999 Lisp_Object tag_list = Fgethash (charset, Vcharset_tag_lists, Qnil); |
| 3659 | 1000 |
| 3736 | 1001 /* In the event that, during the creation of a charset, no specifier |
|
4426
515b91f904c1
Fix specifier inheritance behavior
Didier Verna <didier@xemacs.org>
parents:
3836
diff
changeset
|
1002 tags exist for which CHARSET-PREDICATE has been specified, then |
|
515b91f904c1
Fix specifier inheritance behavior
Didier Verna <didier@xemacs.org>
parents:
3836
diff
changeset
|
1003 that charset's entry in Vcharset_tag_lists will be nil, and this |
|
515b91f904c1
Fix specifier inheritance behavior
Didier Verna <didier@xemacs.org>
parents:
3836
diff
changeset
|
1004 charset shouldn't match. */ |
|
515b91f904c1
Fix specifier inheritance behavior
Didier Verna <didier@xemacs.org>
parents:
3836
diff
changeset
|
1005 |
|
5015
d95c102a96d3
cleanups for specifier font stages, from ben-unicode-internal (preparation for eliminating shadowed warnings)
Ben Wing <ben@xemacs.org>
parents:
5013
diff
changeset
|
1006 if (NILP (tag_list)) |
|
4426
515b91f904c1
Fix specifier inheritance behavior
Didier Verna <didier@xemacs.org>
parents:
3836
diff
changeset
|
1007 { |
|
515b91f904c1
Fix specifier inheritance behavior
Didier Verna <didier@xemacs.org>
parents:
3836
diff
changeset
|
1008 return 0; |
|
515b91f904c1
Fix specifier inheritance behavior
Didier Verna <didier@xemacs.org>
parents:
3836
diff
changeset
|
1009 } |
| 3659 | 1010 |
| 1011 /* Now, find out what the pre-calculated value is. */ | |
|
5015
d95c102a96d3
cleanups for specifier font stages, from ben-unicode-internal (preparation for eliminating shadowed warnings)
Ben Wing <ben@xemacs.org>
parents:
5013
diff
changeset
|
1012 assoc = assq_no_quit (tag, tag_list); |
|
d95c102a96d3
cleanups for specifier font stages, from ben-unicode-internal (preparation for eliminating shadowed warnings)
Ben Wing <ben@xemacs.org>
parents:
5013
diff
changeset
|
1013 |
|
d95c102a96d3
cleanups for specifier font stages, from ben-unicode-internal (preparation for eliminating shadowed warnings)
Ben Wing <ben@xemacs.org>
parents:
5013
diff
changeset
|
1014 if (!(NILP (assoc))) |
| 3659 | 1015 { |
|
5015
d95c102a96d3
cleanups for specifier font stages, from ben-unicode-internal (preparation for eliminating shadowed warnings)
Ben Wing <ben@xemacs.org>
parents:
5013
diff
changeset
|
1016 assert (VECTORP (XCDR (assoc))); |
| 3659 | 1017 |
| 1018 /* In the event that a tag specifies a charset, then the specifier | |
| 1019 must match for (this stage and this charset) for all | |
| 1020 charset-specifying tags. */ | |
|
5015
d95c102a96d3
cleanups for specifier font stages, from ben-unicode-internal (preparation for eliminating shadowed warnings)
Ben Wing <ben@xemacs.org>
parents:
5013
diff
changeset
|
1021 if (NILP (XVECTOR_DATA (XCDR (assoc))[stage])) |
| 3659 | 1022 { |
| 1023 /* It doesn't match for this tag, even though the tag | |
| 1024 specifies a charset. Return 0. */ | |
| 1025 return 0; | |
| 1026 } | |
| 1027 | |
| 1028 /* This tag specifies charset limitations, and this charset and | |
| 1029 stage match those charset limitations. | |
| 1030 | |
| 1031 In the event that a later tag specifies charset limitations | |
| 1032 that don't match, the return 0 above prevents us giving a | |
| 1033 positive match. */ | |
| 1034 res = 1; | |
| 1035 } | |
| 1036 } | |
| 1037 | |
| 1038 return res; | |
| 1039 } | |
| 1040 | |
| 1041 | |
| 442 | 1042 DEFUN ("device-matches-specifier-tag-set-p", |
| 1043 Fdevice_matches_specifier_tag_set_p, 2, 2, 0, /* | |
| 428 | 1044 Return non-nil if DEVICE matches specifier tag set TAG-SET. |
| 1045 This means that DEVICE matches each tag in the tag set. (Every | |
| 1046 tag recognized by XEmacs has a predicate associated with it that | |
| 1047 specifies which devices match it.) | |
| 1048 */ | |
| 1049 (device, tag_set)) | |
| 1050 { | |
| 1051 CHECK_LIVE_DEVICE (device); | |
| 1052 | |
| 1053 if (NILP (Fvalid_specifier_tag_set_p (tag_set))) | |
| 563 | 1054 invalid_argument ("Invalid tag set", tag_set); |
| 428 | 1055 |
| 1056 return device_matches_specifier_tag_set_p (device, tag_set) ? Qt : Qnil; | |
| 1057 } | |
| 1058 | |
|
5015
d95c102a96d3
cleanups for specifier font stages, from ben-unicode-internal (preparation for eliminating shadowed warnings)
Ben Wing <ben@xemacs.org>
parents:
5013
diff
changeset
|
1059 /* Call CHARSET_PREDICATE on CHARSET, evaluating it at both stages (initial |
|
d95c102a96d3
cleanups for specifier font stages, from ben-unicode-internal (preparation for eliminating shadowed warnings)
Ben Wing <ben@xemacs.org>
parents:
5013
diff
changeset
|
1060 and final) and returning a size-two vector of the results. */ |
|
d95c102a96d3
cleanups for specifier font stages, from ben-unicode-internal (preparation for eliminating shadowed warnings)
Ben Wing <ben@xemacs.org>
parents:
5013
diff
changeset
|
1061 |
|
d95c102a96d3
cleanups for specifier font stages, from ben-unicode-internal (preparation for eliminating shadowed warnings)
Ben Wing <ben@xemacs.org>
parents:
5013
diff
changeset
|
1062 static Lisp_Object |
|
d95c102a96d3
cleanups for specifier font stages, from ben-unicode-internal (preparation for eliminating shadowed warnings)
Ben Wing <ben@xemacs.org>
parents:
5013
diff
changeset
|
1063 call_charset_predicate (Lisp_Object charset_predicate, Lisp_Object charset) |
|
d95c102a96d3
cleanups for specifier font stages, from ben-unicode-internal (preparation for eliminating shadowed warnings)
Ben Wing <ben@xemacs.org>
parents:
5013
diff
changeset
|
1064 { |
|
d95c102a96d3
cleanups for specifier font stages, from ben-unicode-internal (preparation for eliminating shadowed warnings)
Ben Wing <ben@xemacs.org>
parents:
5013
diff
changeset
|
1065 struct gcpro gcpro1; |
|
d95c102a96d3
cleanups for specifier font stages, from ben-unicode-internal (preparation for eliminating shadowed warnings)
Ben Wing <ben@xemacs.org>
parents:
5013
diff
changeset
|
1066 Lisp_Object charpres = make_vector (NUM_MATCHSPEC_STAGES, Qnil); |
|
5016
2ade80e8c640
enable more warnings and fix them
Ben Wing <ben@xemacs.org>
parents:
5015
diff
changeset
|
1067 int max_args = XINT (Ffunction_max_args (charset_predicate)); |
|
5015
d95c102a96d3
cleanups for specifier font stages, from ben-unicode-internal (preparation for eliminating shadowed warnings)
Ben Wing <ben@xemacs.org>
parents:
5013
diff
changeset
|
1068 GCPRO1 (charpres); |
|
d95c102a96d3
cleanups for specifier font stages, from ben-unicode-internal (preparation for eliminating shadowed warnings)
Ben Wing <ben@xemacs.org>
parents:
5013
diff
changeset
|
1069 |
|
d95c102a96d3
cleanups for specifier font stages, from ben-unicode-internal (preparation for eliminating shadowed warnings)
Ben Wing <ben@xemacs.org>
parents:
5013
diff
changeset
|
1070 |
|
d95c102a96d3
cleanups for specifier font stages, from ben-unicode-internal (preparation for eliminating shadowed warnings)
Ben Wing <ben@xemacs.org>
parents:
5013
diff
changeset
|
1071 #define DEFINE_SPECIFIER_TAG_FROB(stage, enumstage) \ |
|
d95c102a96d3
cleanups for specifier font stages, from ben-unicode-internal (preparation for eliminating shadowed warnings)
Ben Wing <ben@xemacs.org>
parents:
5013
diff
changeset
|
1072 do { \ |
|
d95c102a96d3
cleanups for specifier font stages, from ben-unicode-internal (preparation for eliminating shadowed warnings)
Ben Wing <ben@xemacs.org>
parents:
5013
diff
changeset
|
1073 if (max_args > 1) \ |
|
d95c102a96d3
cleanups for specifier font stages, from ben-unicode-internal (preparation for eliminating shadowed warnings)
Ben Wing <ben@xemacs.org>
parents:
5013
diff
changeset
|
1074 { \ |
|
d95c102a96d3
cleanups for specifier font stages, from ben-unicode-internal (preparation for eliminating shadowed warnings)
Ben Wing <ben@xemacs.org>
parents:
5013
diff
changeset
|
1075 XVECTOR_DATA (charpres)[enumstage] = \ |
|
d95c102a96d3
cleanups for specifier font stages, from ben-unicode-internal (preparation for eliminating shadowed warnings)
Ben Wing <ben@xemacs.org>
parents:
5013
diff
changeset
|
1076 call2_trapping_problems \ |
|
d95c102a96d3
cleanups for specifier font stages, from ben-unicode-internal (preparation for eliminating shadowed warnings)
Ben Wing <ben@xemacs.org>
parents:
5013
diff
changeset
|
1077 ("Error during specifier tag charset predicate," \ |
|
d95c102a96d3
cleanups for specifier font stages, from ben-unicode-internal (preparation for eliminating shadowed warnings)
Ben Wing <ben@xemacs.org>
parents:
5013
diff
changeset
|
1078 " stage " #stage, charset_predicate, \ |
|
d95c102a96d3
cleanups for specifier font stages, from ben-unicode-internal (preparation for eliminating shadowed warnings)
Ben Wing <ben@xemacs.org>
parents:
5013
diff
changeset
|
1079 charset, Q##stage, 0); \ |
|
d95c102a96d3
cleanups for specifier font stages, from ben-unicode-internal (preparation for eliminating shadowed warnings)
Ben Wing <ben@xemacs.org>
parents:
5013
diff
changeset
|
1080 } \ |
|
d95c102a96d3
cleanups for specifier font stages, from ben-unicode-internal (preparation for eliminating shadowed warnings)
Ben Wing <ben@xemacs.org>
parents:
5013
diff
changeset
|
1081 else \ |
|
d95c102a96d3
cleanups for specifier font stages, from ben-unicode-internal (preparation for eliminating shadowed warnings)
Ben Wing <ben@xemacs.org>
parents:
5013
diff
changeset
|
1082 { \ |
|
d95c102a96d3
cleanups for specifier font stages, from ben-unicode-internal (preparation for eliminating shadowed warnings)
Ben Wing <ben@xemacs.org>
parents:
5013
diff
changeset
|
1083 XVECTOR_DATA (charpres)[enumstage] = \ |
|
d95c102a96d3
cleanups for specifier font stages, from ben-unicode-internal (preparation for eliminating shadowed warnings)
Ben Wing <ben@xemacs.org>
parents:
5013
diff
changeset
|
1084 call1_trapping_problems \ |
|
d95c102a96d3
cleanups for specifier font stages, from ben-unicode-internal (preparation for eliminating shadowed warnings)
Ben Wing <ben@xemacs.org>
parents:
5013
diff
changeset
|
1085 ("Error during specifier tag charset predicate," \ |
|
d95c102a96d3
cleanups for specifier font stages, from ben-unicode-internal (preparation for eliminating shadowed warnings)
Ben Wing <ben@xemacs.org>
parents:
5013
diff
changeset
|
1086 " stage " #stage, charset_predicate, \ |
|
d95c102a96d3
cleanups for specifier font stages, from ben-unicode-internal (preparation for eliminating shadowed warnings)
Ben Wing <ben@xemacs.org>
parents:
5013
diff
changeset
|
1087 charset, 0); \ |
|
d95c102a96d3
cleanups for specifier font stages, from ben-unicode-internal (preparation for eliminating shadowed warnings)
Ben Wing <ben@xemacs.org>
parents:
5013
diff
changeset
|
1088 } \ |
|
d95c102a96d3
cleanups for specifier font stages, from ben-unicode-internal (preparation for eliminating shadowed warnings)
Ben Wing <ben@xemacs.org>
parents:
5013
diff
changeset
|
1089 \ |
|
d95c102a96d3
cleanups for specifier font stages, from ben-unicode-internal (preparation for eliminating shadowed warnings)
Ben Wing <ben@xemacs.org>
parents:
5013
diff
changeset
|
1090 if (UNBOUNDP (XVECTOR_DATA (charpres)[enumstage])) \ |
|
d95c102a96d3
cleanups for specifier font stages, from ben-unicode-internal (preparation for eliminating shadowed warnings)
Ben Wing <ben@xemacs.org>
parents:
5013
diff
changeset
|
1091 { \ |
|
d95c102a96d3
cleanups for specifier font stages, from ben-unicode-internal (preparation for eliminating shadowed warnings)
Ben Wing <ben@xemacs.org>
parents:
5013
diff
changeset
|
1092 XVECTOR_DATA (charpres)[enumstage] = Qnil; \ |
|
d95c102a96d3
cleanups for specifier font stages, from ben-unicode-internal (preparation for eliminating shadowed warnings)
Ben Wing <ben@xemacs.org>
parents:
5013
diff
changeset
|
1093 } \ |
|
d95c102a96d3
cleanups for specifier font stages, from ben-unicode-internal (preparation for eliminating shadowed warnings)
Ben Wing <ben@xemacs.org>
parents:
5013
diff
changeset
|
1094 else if (!NILP (XVECTOR_DATA (charpres)[enumstage])) \ |
|
d95c102a96d3
cleanups for specifier font stages, from ben-unicode-internal (preparation for eliminating shadowed warnings)
Ben Wing <ben@xemacs.org>
parents:
5013
diff
changeset
|
1095 { \ |
|
d95c102a96d3
cleanups for specifier font stages, from ben-unicode-internal (preparation for eliminating shadowed warnings)
Ben Wing <ben@xemacs.org>
parents:
5013
diff
changeset
|
1096 /* Don't want refs to random other objects. */ \ |
|
d95c102a96d3
cleanups for specifier font stages, from ben-unicode-internal (preparation for eliminating shadowed warnings)
Ben Wing <ben@xemacs.org>
parents:
5013
diff
changeset
|
1097 XVECTOR_DATA (charpres)[enumstage] = Qt; \ |
|
d95c102a96d3
cleanups for specifier font stages, from ben-unicode-internal (preparation for eliminating shadowed warnings)
Ben Wing <ben@xemacs.org>
parents:
5013
diff
changeset
|
1098 } \ |
|
d95c102a96d3
cleanups for specifier font stages, from ben-unicode-internal (preparation for eliminating shadowed warnings)
Ben Wing <ben@xemacs.org>
parents:
5013
diff
changeset
|
1099 } while (0) |
|
d95c102a96d3
cleanups for specifier font stages, from ben-unicode-internal (preparation for eliminating shadowed warnings)
Ben Wing <ben@xemacs.org>
parents:
5013
diff
changeset
|
1100 |
|
d95c102a96d3
cleanups for specifier font stages, from ben-unicode-internal (preparation for eliminating shadowed warnings)
Ben Wing <ben@xemacs.org>
parents:
5013
diff
changeset
|
1101 DEFINE_SPECIFIER_TAG_FROB (initial, STAGE_INITIAL); |
|
d95c102a96d3
cleanups for specifier font stages, from ben-unicode-internal (preparation for eliminating shadowed warnings)
Ben Wing <ben@xemacs.org>
parents:
5013
diff
changeset
|
1102 DEFINE_SPECIFIER_TAG_FROB (final, STAGE_FINAL); |
|
d95c102a96d3
cleanups for specifier font stages, from ben-unicode-internal (preparation for eliminating shadowed warnings)
Ben Wing <ben@xemacs.org>
parents:
5013
diff
changeset
|
1103 |
|
d95c102a96d3
cleanups for specifier font stages, from ben-unicode-internal (preparation for eliminating shadowed warnings)
Ben Wing <ben@xemacs.org>
parents:
5013
diff
changeset
|
1104 #undef DEFINE_SPECIFIER_TAG_FROB |
|
d95c102a96d3
cleanups for specifier font stages, from ben-unicode-internal (preparation for eliminating shadowed warnings)
Ben Wing <ben@xemacs.org>
parents:
5013
diff
changeset
|
1105 |
|
d95c102a96d3
cleanups for specifier font stages, from ben-unicode-internal (preparation for eliminating shadowed warnings)
Ben Wing <ben@xemacs.org>
parents:
5013
diff
changeset
|
1106 UNGCPRO; |
|
d95c102a96d3
cleanups for specifier font stages, from ben-unicode-internal (preparation for eliminating shadowed warnings)
Ben Wing <ben@xemacs.org>
parents:
5013
diff
changeset
|
1107 |
|
d95c102a96d3
cleanups for specifier font stages, from ben-unicode-internal (preparation for eliminating shadowed warnings)
Ben Wing <ben@xemacs.org>
parents:
5013
diff
changeset
|
1108 return charpres; |
|
d95c102a96d3
cleanups for specifier font stages, from ben-unicode-internal (preparation for eliminating shadowed warnings)
Ben Wing <ben@xemacs.org>
parents:
5013
diff
changeset
|
1109 } |
|
d95c102a96d3
cleanups for specifier font stages, from ben-unicode-internal (preparation for eliminating shadowed warnings)
Ben Wing <ben@xemacs.org>
parents:
5013
diff
changeset
|
1110 |
| 3659 | 1111 Lisp_Object |
|
5015
d95c102a96d3
cleanups for specifier font stages, from ben-unicode-internal (preparation for eliminating shadowed warnings)
Ben Wing <ben@xemacs.org>
parents:
5013
diff
changeset
|
1112 define_specifier_tag (Lisp_Object tag, Lisp_Object device_predicate, |
|
d95c102a96d3
cleanups for specifier font stages, from ben-unicode-internal (preparation for eliminating shadowed warnings)
Ben Wing <ben@xemacs.org>
parents:
5013
diff
changeset
|
1113 Lisp_Object charset_predicate) |
| 428 | 1114 { |
|
4426
515b91f904c1
Fix specifier inheritance behavior
Didier Verna <didier@xemacs.org>
parents:
3836
diff
changeset
|
1115 Lisp_Object assoc = assq_no_quit (tag, Vuser_defined_tags), |
|
5015
d95c102a96d3
cleanups for specifier font stages, from ben-unicode-internal (preparation for eliminating shadowed warnings)
Ben Wing <ben@xemacs.org>
parents:
5013
diff
changeset
|
1116 concons, devcons; |
|
d95c102a96d3
cleanups for specifier font stages, from ben-unicode-internal (preparation for eliminating shadowed warnings)
Ben Wing <ben@xemacs.org>
parents:
5013
diff
changeset
|
1117 int recompute_devices = 0, recompute_charsets = 0; |
| 3659 | 1118 |
| 428 | 1119 if (NILP (assoc)) |
| 1120 { | |
| 3659 | 1121 recompute_devices = recompute_charsets = 1; |
|
4426
515b91f904c1
Fix specifier inheritance behavior
Didier Verna <didier@xemacs.org>
parents:
3836
diff
changeset
|
1122 Vuser_defined_tags = Fcons (list3 (tag, device_predicate, |
|
515b91f904c1
Fix specifier inheritance behavior
Didier Verna <didier@xemacs.org>
parents:
3836
diff
changeset
|
1123 charset_predicate), |
| 3659 | 1124 Vuser_defined_tags); |
| 428 | 1125 DEVICE_LOOP_NO_BREAK (devcons, concons) |
| 1126 { | |
| 1127 struct device *d = XDEVICE (XCAR (devcons)); | |
| 1128 /* Initially set the value to t in case of error | |
| 3659 | 1129 in device_predicate */ |
| 428 | 1130 DEVICE_USER_DEFINED_TAGS (d) = |
| 1131 Fcons (Fcons (tag, Qt), DEVICE_USER_DEFINED_TAGS (d)); | |
| 1132 } | |
| 1133 } | |
| 3659 | 1134 else if (!NILP (device_predicate) && !NILP (XCADR (assoc))) |
| 428 | 1135 { |
| 3659 | 1136 recompute_devices = 1; |
|
5015
d95c102a96d3
cleanups for specifier font stages, from ben-unicode-internal (preparation for eliminating shadowed warnings)
Ben Wing <ben@xemacs.org>
parents:
5013
diff
changeset
|
1137 XCDR (assoc) = list2 (device_predicate, charset_predicate); |
| 428 | 1138 } |
|
5015
d95c102a96d3
cleanups for specifier font stages, from ben-unicode-internal (preparation for eliminating shadowed warnings)
Ben Wing <ben@xemacs.org>
parents:
5013
diff
changeset
|
1139 else if (!NILP (charset_predicate) || !NILP (XCADDR (assoc))) |
| 3659 | 1140 { |
| 1141 /* If there exists a charset_predicate for the tag currently (even if | |
| 1142 the new charset_predicate is nil), or if we're adding one, we need | |
| 1143 to recompute. This contrasts with the device predicates, where we | |
| 1144 don't need to recompute if the old and new device predicates are | |
| 1145 both nil. */ | |
| 1146 | |
| 1147 recompute_charsets = 1; | |
|
5015
d95c102a96d3
cleanups for specifier font stages, from ben-unicode-internal (preparation for eliminating shadowed warnings)
Ben Wing <ben@xemacs.org>
parents:
5013
diff
changeset
|
1148 XCDR (assoc) = list2 (device_predicate, charset_predicate); |
| 3659 | 1149 } |
| 1150 | |
| 1151 /* Recompute the tag values for all devices and charsets, if necessary. In | |
| 1152 the special case where both the old and new device_predicates are nil, | |
| 1153 we know that we don't have to do it for the device. (It's probably | |
| 1154 common for people to call (define-specifier-tag) more than once on the | |
| 1155 same tag, and the most common case is where DEVICE_PREDICATE is not | |
| 1156 specified.) */ | |
| 1157 | |
| 1158 if (recompute_devices) | |
| 428 | 1159 { |
| 1160 DEVICE_LOOP_NO_BREAK (devcons, concons) | |
| 1161 { | |
| 1162 Lisp_Object device = XCAR (devcons); | |
| 1163 assoc = assq_no_quit (tag, | |
| 1164 DEVICE_USER_DEFINED_TAGS (XDEVICE (device))); | |
| 1165 assert (CONSP (assoc)); | |
| 3659 | 1166 if (NILP (device_predicate)) |
| 428 | 1167 XCDR (assoc) = Qt; |
| 1168 else | |
| 3659 | 1169 XCDR (assoc) = !NILP (call1 (device_predicate, device)) ? Qt |
| 1170 : Qnil; | |
| 428 | 1171 } |
| 1172 } | |
| 1173 | |
|
4426
515b91f904c1
Fix specifier inheritance behavior
Didier Verna <didier@xemacs.org>
parents:
3836
diff
changeset
|
1174 if (recompute_charsets) |
| 3659 | 1175 { |
|
5015
d95c102a96d3
cleanups for specifier font stages, from ben-unicode-internal (preparation for eliminating shadowed warnings)
Ben Wing <ben@xemacs.org>
parents:
5013
diff
changeset
|
1176 |
|
d95c102a96d3
cleanups for specifier font stages, from ben-unicode-internal (preparation for eliminating shadowed warnings)
Ben Wing <ben@xemacs.org>
parents:
5013
diff
changeset
|
1177 LIST_LOOP_2 (charset_name, Fcharset_list ()) |
| 3659 | 1178 { |
|
5015
d95c102a96d3
cleanups for specifier font stages, from ben-unicode-internal (preparation for eliminating shadowed warnings)
Ben Wing <ben@xemacs.org>
parents:
5013
diff
changeset
|
1179 Lisp_Object charset = Fget_charset (charset_name); |
|
d95c102a96d3
cleanups for specifier font stages, from ben-unicode-internal (preparation for eliminating shadowed warnings)
Ben Wing <ben@xemacs.org>
parents:
5013
diff
changeset
|
1180 Lisp_Object tag_list = Fgethash (charset, Vcharset_tag_lists, Qnil); |
|
d95c102a96d3
cleanups for specifier font stages, from ben-unicode-internal (preparation for eliminating shadowed warnings)
Ben Wing <ben@xemacs.org>
parents:
5013
diff
changeset
|
1181 Lisp_Object charpres; |
|
d95c102a96d3
cleanups for specifier font stages, from ben-unicode-internal (preparation for eliminating shadowed warnings)
Ben Wing <ben@xemacs.org>
parents:
5013
diff
changeset
|
1182 |
|
d95c102a96d3
cleanups for specifier font stages, from ben-unicode-internal (preparation for eliminating shadowed warnings)
Ben Wing <ben@xemacs.org>
parents:
5013
diff
changeset
|
1183 if (NILP (charset_predicate)) |
|
d95c102a96d3
cleanups for specifier font stages, from ben-unicode-internal (preparation for eliminating shadowed warnings)
Ben Wing <ben@xemacs.org>
parents:
5013
diff
changeset
|
1184 continue; |
|
d95c102a96d3
cleanups for specifier font stages, from ben-unicode-internal (preparation for eliminating shadowed warnings)
Ben Wing <ben@xemacs.org>
parents:
5013
diff
changeset
|
1185 |
|
d95c102a96d3
cleanups for specifier font stages, from ben-unicode-internal (preparation for eliminating shadowed warnings)
Ben Wing <ben@xemacs.org>
parents:
5013
diff
changeset
|
1186 charpres = call_charset_predicate (charset_predicate, charset); |
|
d95c102a96d3
cleanups for specifier font stages, from ben-unicode-internal (preparation for eliminating shadowed warnings)
Ben Wing <ben@xemacs.org>
parents:
5013
diff
changeset
|
1187 |
|
d95c102a96d3
cleanups for specifier font stages, from ben-unicode-internal (preparation for eliminating shadowed warnings)
Ben Wing <ben@xemacs.org>
parents:
5013
diff
changeset
|
1188 assoc = assq_no_quit (tag, tag_list); |
|
d95c102a96d3
cleanups for specifier font stages, from ben-unicode-internal (preparation for eliminating shadowed warnings)
Ben Wing <ben@xemacs.org>
parents:
5013
diff
changeset
|
1189 if (!NILP (assoc)) |
| 3659 | 1190 { |
|
5015
d95c102a96d3
cleanups for specifier font stages, from ben-unicode-internal (preparation for eliminating shadowed warnings)
Ben Wing <ben@xemacs.org>
parents:
5013
diff
changeset
|
1191 assert (CONSP (assoc)); |
| 3659 | 1192 XCDR (assoc) = charpres; |
| 1193 } | |
| 1194 else | |
| 1195 { | |
|
5015
d95c102a96d3
cleanups for specifier font stages, from ben-unicode-internal (preparation for eliminating shadowed warnings)
Ben Wing <ben@xemacs.org>
parents:
5013
diff
changeset
|
1196 Fputhash (charset, Fcons (Fcons (tag, charpres), tag_list), |
|
d95c102a96d3
cleanups for specifier font stages, from ben-unicode-internal (preparation for eliminating shadowed warnings)
Ben Wing <ben@xemacs.org>
parents:
5013
diff
changeset
|
1197 Vcharset_tag_lists); |
| 3659 | 1198 } |
| 1199 } | |
| 1200 } | |
| 1201 return Qt; | |
| 1202 } | |
| 1203 | |
| 1204 DEFUN ("define-specifier-tag", Fdefine_specifier_tag, 1, 3, 0, /* | |
| 1205 Define a new specifier tag. | |
| 1206 | |
| 1207 If DEVICE-PREDICATE is specified, it should be a function of one argument | |
| 1208 \(a device) that specifies whether the tag matches that particular device. | |
| 1209 If DEVICE-PREDICATE is omitted, the tag matches all devices. | |
| 1210 | |
| 1211 If CHARSET-PREDICATE is supplied, it should be a function taking a single | |
| 1212 Lisp character set argument. A tag's charset predicate is primarily used to | |
| 1213 determine what font to use for a given \(set of) charset\(s) when that tag | |
| 1214 is used in a set-face-font call; a non-nil return value indicates that the | |
| 1215 tag matches the charset. | |
| 1216 | |
| 1217 The font matching process also has a concept of stages; the defined stages | |
| 1218 are currently `initial' and `final', and there exist specifier tags with | |
| 1219 those names that correspond to those stages. On X11, 'initial is used when | |
| 1220 the font matching process is looking for fonts that match the desired | |
| 1221 registries of the charset--see the `charset-registries' function. If that | |
| 1222 match process fails, then the 'final tag becomes relevant; this means that a | |
| 1223 more general lookup is desired, and that a font doesn't necessarily have to | |
| 1224 match the desired XLFD for the face, just the charset repertoire for this | |
| 1225 charset. It also means that the charset registry and encoding used will be | |
| 1226 `iso10646-1', and the characters will be converted to display using that | |
| 1227 registry. | |
| 1228 | |
| 1229 If a tag set matches no character set; the two-stage match process will | |
| 1230 ignore the tag on its first pass, but if no match is found, it will respect | |
| 1231 it on the second pass, where character set information is ignored. | |
| 1232 | |
| 1233 You can redefine an existing user-defined specifier tag. However, you | |
| 1234 cannot redefine most of the built-in specifier tags \(the device types and | |
| 1235 classes, `initial', and `final') or the symbols nil, t, `all', or `global'. | |
| 1236 Note that if a device type is not supported in this XEmacs, it will not be | |
| 1237 available as a built-in specifier tag; this is probably something we should | |
| 1238 change. | |
| 1239 */ | |
| 1240 (tag, device_predicate, charset_predicate)) | |
| 1241 { | |
| 1242 CHECK_SYMBOL (tag); | |
| 1243 if (valid_device_class_p (tag) || | |
| 1244 valid_console_type_p (tag) || | |
| 1245 EQ (tag, Qinitial) || EQ (tag, Qfinal)) | |
| 1246 invalid_change ("Cannot redefine built-in specifier tags", tag); | |
| 1247 /* Try to prevent common instantiators and locales from being | |
| 1248 redefined, to reduce ambiguity */ | |
| 1249 if (NILP (tag) || EQ (tag, Qt) || EQ (tag, Qall) || EQ (tag, Qglobal)) | |
| 1250 invalid_change ("Cannot define nil, t, `all', or `global'", tag); | |
| 1251 | |
| 1252 if (!NILP (charset_predicate)) | |
| 1253 { | |
|
5015
d95c102a96d3
cleanups for specifier font stages, from ben-unicode-internal (preparation for eliminating shadowed warnings)
Ben Wing <ben@xemacs.org>
parents:
5013
diff
changeset
|
1254 Lisp_Object min_args = Ffunction_min_args (charset_predicate); |
|
d95c102a96d3
cleanups for specifier font stages, from ben-unicode-internal (preparation for eliminating shadowed warnings)
Ben Wing <ben@xemacs.org>
parents:
5013
diff
changeset
|
1255 Lisp_Object max_args = Ffunction_max_args (charset_predicate); |
|
d95c102a96d3
cleanups for specifier font stages, from ben-unicode-internal (preparation for eliminating shadowed warnings)
Ben Wing <ben@xemacs.org>
parents:
5013
diff
changeset
|
1256 if (!(INTP (min_args) && XINT (min_args) == 1 && |
|
d95c102a96d3
cleanups for specifier font stages, from ben-unicode-internal (preparation for eliminating shadowed warnings)
Ben Wing <ben@xemacs.org>
parents:
5013
diff
changeset
|
1257 INTP (max_args) && XINT (max_args) == 1)) |
| 3659 | 1258 { |
| 1259 /* We only allow the stage argument to be specifed from C. */ | |
| 1260 invalid_change ("Charset predicate must take one argument", | |
| 1261 tag); | |
| 1262 } | |
| 1263 } | |
| 1264 | |
| 1265 return define_specifier_tag(tag, device_predicate, charset_predicate); | |
| 428 | 1266 } |
| 1267 | |
| 1268 /* Called at device-creation time to initialize the user-defined | |
| 1269 tag values for the newly-created device. */ | |
| 1270 | |
| 1271 void | |
| 1272 setup_device_initial_specifier_tags (struct device *d) | |
| 1273 { | |
| 1274 Lisp_Object rest, rest2; | |
| 793 | 1275 Lisp_Object device = wrap_device (d); |
| 3836 | 1276 Lisp_Object device_predicate; |
| 3659 | 1277 int list_len; |
| 793 | 1278 |
| 428 | 1279 DEVICE_USER_DEFINED_TAGS (d) = Fcopy_alist (Vuser_defined_tags); |
| 1280 | |
| 1281 /* Now set up the initial values */ | |
| 1282 LIST_LOOP (rest, DEVICE_USER_DEFINED_TAGS (d)) | |
| 1283 XCDR (XCAR (rest)) = Qt; | |
| 1284 | |
| 1285 for (rest = Vuser_defined_tags, rest2 = DEVICE_USER_DEFINED_TAGS (d); | |
| 1286 !NILP (rest); rest = XCDR (rest), rest2 = XCDR (rest2)) | |
| 1287 { | |
| 3659 | 1288 GET_LIST_LENGTH(XCAR(rest), list_len); |
| 1289 | |
| 1290 assert(3 == list_len); | |
| 1291 | |
| 1292 device_predicate = XCADR(XCAR (rest)); | |
|
4426
515b91f904c1
Fix specifier inheritance behavior
Didier Verna <didier@xemacs.org>
parents:
3836
diff
changeset
|
1293 |
| 3659 | 1294 if (NILP (device_predicate)) |
| 1295 { | |
|
4426
515b91f904c1
Fix specifier inheritance behavior
Didier Verna <didier@xemacs.org>
parents:
3836
diff
changeset
|
1296 XCDR (XCAR (rest2)) = Qt; |
| 3659 | 1297 } |
| 428 | 1298 else |
| 3659 | 1299 { |
|
4426
515b91f904c1
Fix specifier inheritance behavior
Didier Verna <didier@xemacs.org>
parents:
3836
diff
changeset
|
1300 device_predicate = !NILP (call_critical_lisp_code |
|
515b91f904c1
Fix specifier inheritance behavior
Didier Verna <didier@xemacs.org>
parents:
3836
diff
changeset
|
1301 (d, device_predicate, device)) |
| 3659 | 1302 ? Qt : Qnil; |
| 3817 | 1303 XCDR (XCAR (rest2)) = device_predicate; |
| 3659 | 1304 } |
| 428 | 1305 } |
| 1306 } | |
| 1307 | |
| 3659 | 1308 void |
| 1309 setup_charset_initial_specifier_tags (Lisp_Object charset) | |
| 1310 { | |
| 1311 Lisp_Object rest, charset_predicate, tag, new_value; | |
|
4426
515b91f904c1
Fix specifier inheritance behavior
Didier Verna <didier@xemacs.org>
parents:
3836
diff
changeset
|
1312 Lisp_Object charset_tag_list = Qnil; |
| 3659 | 1313 |
| 1314 LIST_LOOP (rest, Vuser_defined_tags) | |
| 1315 { | |
|
5015
d95c102a96d3
cleanups for specifier font stages, from ben-unicode-internal (preparation for eliminating shadowed warnings)
Ben Wing <ben@xemacs.org>
parents:
5013
diff
changeset
|
1316 tag = XCAR (XCAR (rest)); |
|
d95c102a96d3
cleanups for specifier font stages, from ben-unicode-internal (preparation for eliminating shadowed warnings)
Ben Wing <ben@xemacs.org>
parents:
5013
diff
changeset
|
1317 charset_predicate = XCADDR (XCAR (rest)); |
|
d95c102a96d3
cleanups for specifier font stages, from ben-unicode-internal (preparation for eliminating shadowed warnings)
Ben Wing <ben@xemacs.org>
parents:
5013
diff
changeset
|
1318 |
|
d95c102a96d3
cleanups for specifier font stages, from ben-unicode-internal (preparation for eliminating shadowed warnings)
Ben Wing <ben@xemacs.org>
parents:
5013
diff
changeset
|
1319 if (NILP (charset_predicate)) |
| 3659 | 1320 { |
| 1321 continue; | |
| 1322 } | |
| 1323 | |
|
5015
d95c102a96d3
cleanups for specifier font stages, from ben-unicode-internal (preparation for eliminating shadowed warnings)
Ben Wing <ben@xemacs.org>
parents:
5013
diff
changeset
|
1324 new_value = call_charset_predicate (charset_predicate, charset); |
|
d95c102a96d3
cleanups for specifier font stages, from ben-unicode-internal (preparation for eliminating shadowed warnings)
Ben Wing <ben@xemacs.org>
parents:
5013
diff
changeset
|
1325 charset_tag_list = Fcons (Fcons (tag, new_value), charset_tag_list); |
| 3659 | 1326 } |
| 1327 | |
|
5015
d95c102a96d3
cleanups for specifier font stages, from ben-unicode-internal (preparation for eliminating shadowed warnings)
Ben Wing <ben@xemacs.org>
parents:
5013
diff
changeset
|
1328 Fputhash (charset, charset_tag_list, Vcharset_tag_lists); |
| 3659 | 1329 } |
| 1330 | |
| 3673 | 1331 /* VM calls this, in vm-multiple-frames-possible-p, in the event that you're |
| 1332 considering taking it out. */ | |
| 3659 | 1333 |
| 442 | 1334 DEFUN ("device-matching-specifier-tag-list", |
| 1335 Fdevice_matching_specifier_tag_list, | |
| 428 | 1336 0, 1, 0, /* |
| 3673 | 1337 Return a list of all specifier tags matching DEVICE. |
| 1338 DEVICE defaults to the selected device if omitted. | |
| 1339 */ | |
| 428 | 1340 (device)) |
| 1341 { | |
| 1342 struct device *d = decode_device (device); | |
| 1343 Lisp_Object rest, list = Qnil; | |
| 1344 struct gcpro gcpro1; | |
| 1345 | |
| 1346 GCPRO1 (list); | |
| 1347 | |
| 1348 LIST_LOOP (rest, DEVICE_USER_DEFINED_TAGS (d)) | |
| 1349 { | |
| 3836 | 1350 if (!NILP (XCDR (XCAR (rest)))) |
| 428 | 1351 list = Fcons (XCAR (XCAR (rest)), list); |
| 1352 } | |
| 1353 | |
| 1354 list = Fnreverse (list); | |
| 1355 list = Fcons (DEVICE_CLASS (d), list); | |
| 1356 list = Fcons (DEVICE_TYPE (d), list); | |
| 1357 | |
| 1358 RETURN_UNGCPRO (list); | |
| 1359 } | |
| 1360 | |
| 1361 DEFUN ("specifier-tag-list", Fspecifier_tag_list, 0, 0, 0, /* | |
| 1362 Return a list of all currently-defined specifier tags. | |
| 1363 This includes the built-in ones (the device types and classes). | |
| 1364 */ | |
| 1365 ()) | |
| 1366 { | |
| 1367 Lisp_Object list = Qnil, rest; | |
| 1368 struct gcpro gcpro1; | |
| 1369 | |
| 1370 GCPRO1 (list); | |
| 1371 | |
| 1372 LIST_LOOP (rest, Vuser_defined_tags) | |
| 1373 list = Fcons (XCAR (XCAR (rest)), list); | |
| 1374 | |
| 1375 list = Fnreverse (list); | |
| 1376 list = nconc2 (Fcopy_sequence (Vdevice_class_list), list); | |
| 1377 list = nconc2 (Fcopy_sequence (Vconsole_type_list), list); | |
| 1378 | |
| 1379 RETURN_UNGCPRO (list); | |
| 1380 } | |
| 1381 | |
| 3659 | 1382 DEFUN ("specifier-tag-device-predicate", Fspecifier_tag_device_predicate, |
| 1383 1, 1, 0, /* | |
| 1384 Return the device predicate for the given specifier tag. | |
| 428 | 1385 */ |
| 1386 (tag)) | |
| 1387 { | |
| 1388 /* The return value of this function must be GCPRO'd. */ | |
| 1389 CHECK_SYMBOL (tag); | |
| 1390 | |
| 1391 if (NILP (Fvalid_specifier_tag_p (tag))) | |
| 563 | 1392 invalid_argument ("Invalid specifier tag", |
| 3659 | 1393 tag); |
| 428 | 1394 |
| 1395 /* Make up some predicates for the built-in types */ | |
| 1396 | |
| 1397 if (valid_console_type_p (tag)) | |
| 1398 return list3 (Qlambda, list1 (Qdevice), | |
| 1399 list3 (Qeq, list2 (Qquote, tag), | |
| 1400 list2 (Qconsole_type, Qdevice))); | |
| 1401 | |
| 1402 if (valid_device_class_p (tag)) | |
| 1403 return list3 (Qlambda, list1 (Qdevice), | |
| 1404 list3 (Qeq, list2 (Qquote, tag), | |
| 1405 list2 (Qdevice_class, Qdevice))); | |
| 1406 | |
| 3659 | 1407 return XCADR (assq_no_quit (tag, Vuser_defined_tags)); |
| 1408 } | |
| 1409 | |
| 1410 DEFUN ("specifier-tag-charset-predicate", Fspecifier_tag_charset_predicate, | |
| 1411 1, 1, 0, /* | |
| 3673 | 1412 Return the charset predicate for the given specifier tag. |
| 1413 */ | |
| 3659 | 1414 (tag)) |
| 1415 { | |
| 1416 /* The return value of this function must be GCPRO'd. */ | |
| 1417 CHECK_SYMBOL (tag); | |
| 1418 | |
| 1419 if (NILP (Fvalid_specifier_tag_p (tag))) | |
| 1420 invalid_argument ("Invalid specifier tag", | |
| 1421 tag); | |
| 1422 | |
| 1423 return XCADDR (assq_no_quit (tag, Vuser_defined_tags)); | |
| 428 | 1424 } |
| 1425 | |
| 1426 /* Return true if A "matches" B. If EXACT_P is 0, A must be a subset of B. | |
| 3659 | 1427 Otherwise, A must be `equal' to B. The sets must be canonicalized. */ |
| 428 | 1428 static int |
| 1429 tag_sets_match_p (Lisp_Object a, Lisp_Object b, int exact_p) | |
| 1430 { | |
| 1431 if (!exact_p) | |
| 1432 { | |
| 1433 while (!NILP (a) && !NILP (b)) | |
| 1434 { | |
| 1435 if (EQ (XCAR (a), XCAR (b))) | |
| 1436 a = XCDR (a); | |
| 1437 b = XCDR (b); | |
| 1438 } | |
| 1439 | |
| 1440 return NILP (a); | |
| 1441 } | |
| 1442 else | |
| 1443 { | |
| 1444 while (!NILP (a) && !NILP (b)) | |
| 1445 { | |
| 1446 if (!EQ (XCAR (a), XCAR (b))) | |
| 1447 return 0; | |
| 1448 a = XCDR (a); | |
| 1449 b = XCDR (b); | |
| 1450 } | |
| 1451 | |
| 1452 return NILP (a) && NILP (b); | |
| 1453 } | |
| 1454 } | |
| 1455 | |
| 1456 | |
| 1457 /************************************************************************/ | |
| 1458 /* Spec-lists and inst-lists */ | |
| 1459 /************************************************************************/ | |
| 1460 | |
| 1461 static Lisp_Object | |
| 1462 call_validate_method (Lisp_Object boxed_method, Lisp_Object instantiator) | |
| 1463 { | |
| 1464 ((void (*)(Lisp_Object)) get_opaque_ptr (boxed_method)) (instantiator); | |
| 1465 return Qt; | |
| 1466 } | |
| 1467 | |
| 1468 static Lisp_Object | |
| 1469 check_valid_instantiator (Lisp_Object instantiator, | |
| 1470 struct specifier_methods *meths, | |
| 578 | 1471 Error_Behavior errb) |
| 428 | 1472 { |
| 1473 if (meths->validate_method) | |
| 1474 { | |
| 1475 Lisp_Object retval; | |
| 1476 | |
| 1477 if (ERRB_EQ (errb, ERROR_ME)) | |
| 1478 { | |
| 1479 (meths->validate_method) (instantiator); | |
| 1480 retval = Qt; | |
| 1481 } | |
| 1482 else | |
| 1483 { | |
| 1484 Lisp_Object opaque = make_opaque_ptr ((void *) | |
| 1485 meths->validate_method); | |
| 1486 struct gcpro gcpro1; | |
| 1487 | |
| 1488 GCPRO1 (opaque); | |
| 1489 retval = call_with_suspended_errors | |
| 1490 ((lisp_fn_t) call_validate_method, | |
| 1491 Qnil, Qspecifier, errb, 2, opaque, instantiator); | |
| 1492 | |
| 1493 free_opaque_ptr (opaque); | |
| 1494 UNGCPRO; | |
| 1495 } | |
| 1496 | |
| 1497 return retval; | |
| 1498 } | |
| 1499 return Qt; | |
| 1500 } | |
| 1501 | |
| 1502 DEFUN ("check-valid-instantiator", Fcheck_valid_instantiator, 2, 2, 0, /* | |
| 1503 Signal an error if INSTANTIATOR is invalid for SPECIFIER-TYPE. | |
| 1504 */ | |
| 1505 (instantiator, specifier_type)) | |
| 1506 { | |
| 1507 struct specifier_methods *meths = decode_specifier_type (specifier_type, | |
| 1508 ERROR_ME); | |
| 1509 | |
| 1510 return check_valid_instantiator (instantiator, meths, ERROR_ME); | |
| 1511 } | |
| 1512 | |
| 1513 DEFUN ("valid-instantiator-p", Fvalid_instantiator_p, 2, 2, 0, /* | |
| 1514 Return non-nil if INSTANTIATOR is valid for SPECIFIER-TYPE. | |
| 1515 */ | |
| 1516 (instantiator, specifier_type)) | |
| 1517 { | |
| 1518 struct specifier_methods *meths = decode_specifier_type (specifier_type, | |
| 1519 ERROR_ME); | |
| 1520 | |
| 1521 return check_valid_instantiator (instantiator, meths, ERROR_ME_NOT); | |
| 1522 } | |
| 1523 | |
| 1524 static Lisp_Object | |
| 1525 check_valid_inst_list (Lisp_Object inst_list, struct specifier_methods *meths, | |
| 578 | 1526 Error_Behavior errb) |
| 428 | 1527 { |
| 2159 | 1528 EXTERNAL_LIST_LOOP_2 (inst_pair, inst_list) |
| 428 | 1529 { |
| 2159 | 1530 Lisp_Object tag_set; |
| 1531 | |
| 1532 if (!CONSP (inst_pair)) | |
| 428 | 1533 { |
| 563 | 1534 maybe_sferror ( |
| 3659 | 1535 "Invalid instantiator pair", inst_pair, |
| 1536 Qspecifier, errb); | |
| 428 | 1537 return Qnil; |
| 1538 } | |
| 1539 if (NILP (Fvalid_specifier_tag_set_p (tag_set = XCAR (inst_pair)))) | |
| 1540 { | |
| 563 | 1541 maybe_invalid_argument ( |
| 3659 | 1542 "Invalid specifier tag", tag_set, |
| 1543 Qspecifier, errb); | |
| 428 | 1544 return Qnil; |
| 1545 } | |
| 1546 | |
| 1547 if (NILP (check_valid_instantiator (XCDR (inst_pair), meths, errb))) | |
| 1548 return Qnil; | |
| 1549 } | |
| 1550 | |
| 1551 return Qt; | |
| 1552 } | |
| 1553 | |
| 1554 DEFUN ("check-valid-inst-list", Fcheck_valid_inst_list, 2, 2, 0, /* | |
| 1555 Signal an error if INST-LIST is invalid for specifier type TYPE. | |
| 1556 */ | |
| 1557 (inst_list, type)) | |
| 1558 { | |
| 1559 struct specifier_methods *meths = decode_specifier_type (type, ERROR_ME); | |
| 1560 | |
| 1561 return check_valid_inst_list (inst_list, meths, ERROR_ME); | |
| 1562 } | |
| 1563 | |
| 1564 DEFUN ("valid-inst-list-p", Fvalid_inst_list_p, 2, 2, 0, /* | |
| 1565 Return non-nil if INST-LIST is valid for specifier type TYPE. | |
| 1566 */ | |
| 1567 (inst_list, type)) | |
| 1568 { | |
| 1569 struct specifier_methods *meths = decode_specifier_type (type, ERROR_ME); | |
| 1570 | |
| 1571 return check_valid_inst_list (inst_list, meths, ERROR_ME_NOT); | |
| 1572 } | |
| 1573 | |
| 1574 static Lisp_Object | |
| 1575 check_valid_spec_list (Lisp_Object spec_list, struct specifier_methods *meths, | |
| 578 | 1576 Error_Behavior errb) |
| 428 | 1577 { |
| 2159 | 1578 EXTERNAL_LIST_LOOP_2 (spec, spec_list) |
| 428 | 1579 { |
| 2159 | 1580 Lisp_Object locale; |
| 1581 if (!CONSP (spec)) | |
| 428 | 1582 { |
| 563 | 1583 maybe_sferror ( |
| 3659 | 1584 "Invalid specification list", spec_list, |
| 1585 Qspecifier, errb); | |
| 428 | 1586 return Qnil; |
| 1587 } | |
| 1588 if (NILP (Fvalid_specifier_locale_p (locale = XCAR (spec)))) | |
| 1589 { | |
| 563 | 1590 maybe_invalid_argument ( |
| 3659 | 1591 "Invalid specifier locale", locale, |
| 1592 Qspecifier, errb); | |
| 428 | 1593 return Qnil; |
| 1594 } | |
| 1595 | |
| 1596 if (NILP (check_valid_inst_list (XCDR (spec), meths, errb))) | |
| 1597 return Qnil; | |
| 1598 } | |
| 1599 | |
| 1600 return Qt; | |
| 1601 } | |
| 1602 | |
| 1603 DEFUN ("check-valid-spec-list", Fcheck_valid_spec_list, 2, 2, 0, /* | |
| 1604 Signal an error if SPEC-LIST is invalid for specifier type TYPE. | |
| 1605 */ | |
| 1606 (spec_list, type)) | |
| 1607 { | |
| 1608 struct specifier_methods *meths = decode_specifier_type (type, ERROR_ME); | |
| 1609 | |
| 1610 return check_valid_spec_list (spec_list, meths, ERROR_ME); | |
| 1611 } | |
| 1612 | |
| 1613 DEFUN ("valid-spec-list-p", Fvalid_spec_list_p, 2, 2, 0, /* | |
| 1614 Return non-nil if SPEC-LIST is valid for specifier type TYPE. | |
| 1615 */ | |
| 1616 (spec_list, type)) | |
| 1617 { | |
| 1618 struct specifier_methods *meths = decode_specifier_type (type, ERROR_ME); | |
| 1619 | |
| 1620 return check_valid_spec_list (spec_list, meths, ERROR_ME_NOT); | |
| 1621 } | |
| 1622 | |
| 1623 enum spec_add_meth | |
| 1624 decode_how_to_add_specification (Lisp_Object how_to_add) | |
| 1625 { | |
| 1626 if (NILP (how_to_add) || EQ (Qremove_tag_set_prepend, how_to_add)) | |
| 1627 return SPEC_REMOVE_TAG_SET_PREPEND; | |
| 1628 if (EQ (Qremove_tag_set_append, how_to_add)) | |
| 1629 return SPEC_REMOVE_TAG_SET_APPEND; | |
| 1630 if (EQ (Qappend, how_to_add)) | |
| 1631 return SPEC_APPEND; | |
| 1632 if (EQ (Qprepend, how_to_add)) | |
| 1633 return SPEC_PREPEND; | |
| 1634 if (EQ (Qremove_locale, how_to_add)) | |
| 1635 return SPEC_REMOVE_LOCALE; | |
| 1636 if (EQ (Qremove_locale_type, how_to_add)) | |
| 1637 return SPEC_REMOVE_LOCALE_TYPE; | |
| 1638 if (EQ (Qremove_all, how_to_add)) | |
| 1639 return SPEC_REMOVE_ALL; | |
| 1640 | |
| 563 | 1641 invalid_constant ("Invalid `how-to-add' flag", how_to_add); |
| 428 | 1642 |
| 1204 | 1643 RETURN_NOT_REACHED (SPEC_PREPEND); |
| 428 | 1644 } |
| 1645 | |
| 1646 /* Given a specifier object SPEC, return bodily specifier if SPEC is a | |
| 1647 ghost specifier, otherwise return the object itself | |
| 1648 */ | |
| 1649 static Lisp_Object | |
| 1650 bodily_specifier (Lisp_Object spec) | |
| 1651 { | |
| 1652 return (GHOST_SPECIFIER_P (XSPECIFIER (spec)) | |
| 1653 ? XSPECIFIER(spec)->magic_parent : spec); | |
| 1654 } | |
| 1655 | |
| 1656 /* Signal error if (specifier SPEC is read-only. | |
| 1657 Read only are ghost specifiers unless Vunlock_ghost_specifiers is | |
| 1658 non-nil. All other specifiers are read-write. | |
| 1659 */ | |
| 1660 static void | |
| 1661 check_modifiable_specifier (Lisp_Object spec) | |
| 1662 { | |
| 1663 if (NILP (Vunlock_ghost_specifiers) | |
| 1664 && GHOST_SPECIFIER_P (XSPECIFIER (spec))) | |
| 563 | 1665 signal_error (Qsetting_constant, |
| 1666 "Attempt to modify read-only specifier", | |
| 1667 spec); | |
| 428 | 1668 } |
| 1669 | |
| 1670 int | |
| 1671 unlock_ghost_specifiers_protected (void) | |
| 1672 { | |
| 853 | 1673 return internal_bind_lisp_object (&Vunlock_ghost_specifiers, Qt); |
| 428 | 1674 } |
| 1675 | |
| 1676 /* This gets hit so much that the function call overhead had a | |
| 1677 measurable impact (according to Quantify). #### We should figure | |
| 1678 out the frequency with which this is called with the various types | |
| 1679 and reorder the check accordingly. */ | |
| 1680 #define SPECIFIER_GET_SPEC_LIST(specifier, type) \ | |
| 3659 | 1681 (type == LOCALE_GLOBAL ? &(XSPECIFIER (specifier)->global_specs) : \ |
| 1682 type == LOCALE_DEVICE ? &(XSPECIFIER (specifier)->device_specs) : \ | |
| 1683 type == LOCALE_FRAME ? &(XSPECIFIER (specifier)->frame_specs) : \ | |
| 1684 type == LOCALE_WINDOW ? &(XWEAK_LIST_LIST \ | |
| 1685 (XSPECIFIER (specifier)->window_specs)) : \ | |
| 1686 type == LOCALE_BUFFER ? &(XSPECIFIER (specifier)->buffer_specs) : \ | |
| 1687 0) | |
| 428 | 1688 |
| 1689 static Lisp_Object * | |
| 1690 specifier_get_inst_list (Lisp_Object specifier, Lisp_Object locale, | |
| 1691 enum spec_locale_type type) | |
| 1692 { | |
| 1693 Lisp_Object *spec_list = SPECIFIER_GET_SPEC_LIST (specifier, type); | |
| 1694 Lisp_Object specification; | |
| 1695 | |
| 1696 if (type == LOCALE_GLOBAL) | |
| 1697 return spec_list; | |
| 1698 /* Calling assq_no_quit when it is just going to return nil anyhow | |
| 1699 is extremely expensive. So sayeth Quantify. */ | |
| 1700 if (!CONSP (*spec_list)) | |
| 1701 return 0; | |
| 1702 specification = assq_no_quit (locale, *spec_list); | |
| 1703 if (NILP (specification)) | |
| 1704 return 0; | |
| 1705 return &XCDR (specification); | |
| 1706 } | |
| 1707 | |
| 1708 /* For the given INST_LIST, return a new INST_LIST containing all elements | |
| 1709 where TAG-SET matches the element's tag set. EXACT_P indicates whether | |
| 1710 the match must be exact (as opposed to a subset). SHORT_P indicates | |
| 1711 that the short form (for `specifier-specs') should be returned if | |
| 1712 possible. If COPY_TREE_P, `copy-tree' is used to ensure that no | |
| 1713 elements of the new list are shared with the initial list. | |
| 1714 */ | |
| 1715 | |
| 1716 static Lisp_Object | |
| 1717 specifier_process_inst_list (Lisp_Object inst_list, | |
| 1718 Lisp_Object tag_set, int exact_p, | |
| 1719 int short_p, int copy_tree_p) | |
| 1720 { | |
| 1721 Lisp_Object retval = Qnil; | |
| 1722 Lisp_Object rest; | |
| 1723 struct gcpro gcpro1; | |
| 1724 | |
| 1725 GCPRO1 (retval); | |
| 1726 LIST_LOOP (rest, inst_list) | |
| 1727 { | |
| 1728 Lisp_Object tagged_inst = XCAR (rest); | |
| 1729 Lisp_Object tagged_inst_tag = XCAR (tagged_inst); | |
| 1730 if (tag_sets_match_p (tag_set, tagged_inst_tag, exact_p)) | |
| 1731 { | |
| 1732 if (short_p && NILP (tagged_inst_tag)) | |
| 1733 retval = Fcons (copy_tree_p ? | |
| 1734 Fcopy_tree (XCDR (tagged_inst), Qt) : | |
| 1735 XCDR (tagged_inst), | |
| 1736 retval); | |
| 1737 else | |
| 1738 retval = Fcons (copy_tree_p ? Fcopy_tree (tagged_inst, Qt) : | |
| 1739 tagged_inst, retval); | |
| 1740 } | |
| 1741 } | |
| 1742 retval = Fnreverse (retval); | |
| 1743 UNGCPRO; | |
| 1744 /* If there is a single instantiator and the short form is | |
| 1745 requested, return just the instantiator (rather than a one-element | |
| 1746 list of it) unless it is nil (so that it can be distinguished from | |
| 1747 no instantiators at all). */ | |
| 1748 if (short_p && CONSP (retval) && !NILP (XCAR (retval)) && | |
| 1749 NILP (XCDR (retval))) | |
| 1750 return XCAR (retval); | |
| 1751 else | |
| 1752 return retval; | |
| 1753 } | |
| 1754 | |
| 1755 static Lisp_Object | |
| 1756 specifier_get_external_inst_list (Lisp_Object specifier, Lisp_Object locale, | |
| 1757 enum spec_locale_type type, | |
| 1758 Lisp_Object tag_set, int exact_p, | |
| 1759 int short_p, int copy_tree_p) | |
| 1760 { | |
| 1761 Lisp_Object *inst_list = specifier_get_inst_list (specifier, locale, | |
| 1762 type); | |
| 1763 if (!inst_list || NILP (*inst_list)) | |
| 1764 { | |
| 2953 | 1765 /* nil for *inst_list should only occur in `global' */ |
| 428 | 1766 assert (!inst_list || EQ (locale, Qglobal)); |
| 1767 return Qnil; | |
| 1768 } | |
| 1769 | |
| 1770 return specifier_process_inst_list (*inst_list, tag_set, exact_p, | |
| 1771 short_p, copy_tree_p); | |
| 1772 } | |
| 1773 | |
| 1774 static Lisp_Object | |
| 1775 specifier_get_external_spec_list (Lisp_Object specifier, | |
| 1776 enum spec_locale_type type, | |
| 1777 Lisp_Object tag_set, int exact_p) | |
| 1778 { | |
| 1779 Lisp_Object *spec_list = SPECIFIER_GET_SPEC_LIST (specifier, type); | |
| 1780 Lisp_Object retval = Qnil; | |
| 1781 Lisp_Object rest; | |
| 1782 struct gcpro gcpro1; | |
| 1783 | |
| 1784 assert (type != LOCALE_GLOBAL); | |
| 1785 /* We're about to let stuff go external; make sure there aren't | |
| 1786 any dead objects */ | |
| 1787 *spec_list = cleanup_assoc_list (*spec_list); | |
| 1788 | |
| 1789 GCPRO1 (retval); | |
| 1790 LIST_LOOP (rest, *spec_list) | |
| 1791 { | |
| 1792 Lisp_Object spec = XCAR (rest); | |
| 1793 Lisp_Object inst_list = | |
| 1794 specifier_process_inst_list (XCDR (spec), tag_set, exact_p, 0, 1); | |
| 1795 if (!NILP (inst_list)) | |
| 1796 retval = Fcons (Fcons (XCAR (spec), inst_list), retval); | |
| 1797 } | |
| 1798 RETURN_UNGCPRO (Fnreverse (retval)); | |
| 1799 } | |
| 1800 | |
| 1801 static Lisp_Object * | |
| 1802 specifier_new_spec (Lisp_Object specifier, Lisp_Object locale, | |
| 1803 enum spec_locale_type type) | |
| 1804 { | |
| 1805 Lisp_Object *spec_list = SPECIFIER_GET_SPEC_LIST (specifier, type); | |
| 1806 Lisp_Object new_spec = Fcons (locale, Qnil); | |
| 1807 assert (type != LOCALE_GLOBAL); | |
| 1808 *spec_list = Fcons (new_spec, *spec_list); | |
| 1809 return &XCDR (new_spec); | |
| 1810 } | |
| 1811 | |
| 1812 /* For the given INST_LIST, return a new list comprised of elements | |
| 1813 where TAG_SET does not match the element's tag set. This operation | |
| 1814 is destructive. */ | |
| 1815 | |
| 1816 static Lisp_Object | |
| 1817 specifier_process_remove_inst_list (Lisp_Object inst_list, | |
| 1818 Lisp_Object tag_set, int exact_p, | |
| 1819 int *was_removed) | |
| 1820 { | |
| 1821 Lisp_Object prev = Qnil, rest; | |
| 1822 | |
| 1823 *was_removed = 0; | |
| 1824 | |
| 1825 LIST_LOOP (rest, inst_list) | |
| 1826 { | |
| 1827 if (tag_sets_match_p (tag_set, XCAR (XCAR (rest)), exact_p)) | |
| 1828 { | |
| 1829 /* time to remove. */ | |
| 1830 *was_removed = 1; | |
| 1831 if (NILP (prev)) | |
| 1832 inst_list = XCDR (rest); | |
| 1833 else | |
| 1834 XCDR (prev) = XCDR (rest); | |
| 1835 } | |
| 1836 else | |
| 1837 prev = rest; | |
| 1838 } | |
| 1839 | |
| 1840 return inst_list; | |
| 1841 } | |
| 1842 | |
| 1843 static void | |
| 1844 specifier_remove_spec (Lisp_Object specifier, Lisp_Object locale, | |
| 1845 enum spec_locale_type type, | |
| 1846 Lisp_Object tag_set, int exact_p) | |
| 1847 { | |
| 1848 Lisp_Object *spec_list = SPECIFIER_GET_SPEC_LIST (specifier, type); | |
| 1849 Lisp_Object assoc; | |
| 1850 int was_removed; | |
| 1851 | |
| 1852 if (type == LOCALE_GLOBAL) | |
| 1853 *spec_list = specifier_process_remove_inst_list (*spec_list, tag_set, | |
| 1854 exact_p, &was_removed); | |
| 1855 else | |
| 1856 { | |
| 1857 assoc = assq_no_quit (locale, *spec_list); | |
| 1858 if (NILP (assoc)) | |
| 1859 /* this locale is not found. */ | |
| 1860 return; | |
| 1861 XCDR (assoc) = specifier_process_remove_inst_list (XCDR (assoc), | |
| 1862 tag_set, exact_p, | |
| 1863 &was_removed); | |
| 1864 if (NILP (XCDR (assoc))) | |
| 1865 /* no inst-pairs left; remove this locale entirely. */ | |
| 1866 *spec_list = remassq_no_quit (locale, *spec_list); | |
| 1867 } | |
| 1868 | |
| 1869 if (was_removed) | |
| 1870 MAYBE_SPECMETH (XSPECIFIER (specifier), after_change, | |
| 1871 (bodily_specifier (specifier), locale)); | |
| 1872 } | |
| 1873 | |
| 1874 static void | |
| 1875 specifier_remove_locale_type (Lisp_Object specifier, | |
| 1876 enum spec_locale_type type, | |
| 1877 Lisp_Object tag_set, int exact_p) | |
| 1878 { | |
| 1879 Lisp_Object *spec_list = SPECIFIER_GET_SPEC_LIST (specifier, type); | |
| 1880 Lisp_Object prev = Qnil, rest; | |
| 1881 | |
| 1882 assert (type != LOCALE_GLOBAL); | |
| 1883 LIST_LOOP (rest, *spec_list) | |
| 1884 { | |
| 1885 int was_removed; | |
| 1886 int remove_spec = 0; | |
| 1887 Lisp_Object spec = XCAR (rest); | |
| 1888 | |
| 1889 /* There may be dead objects floating around */ | |
| 1890 /* remember, dead windows can become alive again. */ | |
| 1891 if (!WINDOWP (XCAR (spec)) && object_dead_p (XCAR (spec))) | |
| 1892 { | |
| 1893 remove_spec = 1; | |
| 1894 was_removed = 0; | |
| 1895 } | |
| 1896 else | |
| 1897 { | |
| 1898 XCDR (spec) = specifier_process_remove_inst_list (XCDR (spec), | |
| 1899 tag_set, exact_p, | |
| 1900 &was_removed); | |
| 1901 if (NILP (XCDR (spec))) | |
| 1902 remove_spec = 1; | |
| 1903 } | |
| 1904 | |
| 1905 if (remove_spec) | |
| 1906 { | |
| 1907 if (NILP (prev)) | |
| 1908 *spec_list = XCDR (rest); | |
| 1909 else | |
| 1910 XCDR (prev) = XCDR (rest); | |
| 1911 } | |
| 1912 else | |
| 1913 prev = rest; | |
| 1914 | |
| 1915 if (was_removed) | |
| 1916 MAYBE_SPECMETH (XSPECIFIER (specifier), after_change, | |
| 1917 (bodily_specifier (specifier), XCAR (spec))); | |
| 1918 } | |
| 1919 } | |
| 1920 | |
| 1921 /* NEW_LIST is going to be added to INST_LIST, with add method ADD_METH. | |
| 1922 Frob INST_LIST according to ADD_METH. No need to call an after-change | |
| 1923 function; the calling function will do this. Return either SPEC_PREPEND | |
| 1924 or SPEC_APPEND, indicating whether to prepend or append the NEW_LIST. */ | |
| 1925 | |
| 1926 static enum spec_add_meth | |
| 1927 handle_multiple_add_insts (Lisp_Object *inst_list, | |
| 1928 Lisp_Object new_list, | |
| 1929 enum spec_add_meth add_meth) | |
| 1930 { | |
| 1931 switch (add_meth) | |
| 1932 { | |
| 1933 case SPEC_REMOVE_TAG_SET_APPEND: | |
| 1934 add_meth = SPEC_APPEND; | |
| 1935 goto remove_tag_set; | |
| 1936 case SPEC_REMOVE_TAG_SET_PREPEND: | |
| 1937 add_meth = SPEC_PREPEND; | |
| 1938 remove_tag_set: | |
| 1939 { | |
| 1940 Lisp_Object rest; | |
| 1941 | |
| 1942 LIST_LOOP (rest, new_list) | |
| 1943 { | |
| 1944 Lisp_Object canontag = canonicalize_tag_set (XCAR (XCAR (rest))); | |
| 1945 struct gcpro gcpro1; | |
| 1946 | |
| 1947 GCPRO1 (canontag); | |
| 1948 /* pull out all elements from the existing list with the | |
| 1949 same tag as any tags in NEW_LIST. */ | |
| 1950 *inst_list = remassoc_no_quit (canontag, *inst_list); | |
| 1951 UNGCPRO; | |
| 1952 } | |
| 1953 } | |
| 1954 return add_meth; | |
| 1955 case SPEC_REMOVE_LOCALE: | |
| 1956 *inst_list = Qnil; | |
| 1957 return SPEC_PREPEND; | |
| 1958 case SPEC_APPEND: | |
| 1959 return add_meth; | |
| 1960 default: | |
| 1961 return SPEC_PREPEND; | |
| 1962 } | |
| 1963 } | |
| 1964 | |
| 1965 /* Given a LOCALE and INST_LIST that is going to be added to SPECIFIER, | |
| 1966 copy, canonicalize, and call the going_to_add methods as necessary | |
| 1967 to produce a new list that is the one that really will be added | |
| 1968 to the specifier. */ | |
| 1969 | |
| 1970 static Lisp_Object | |
| 1971 build_up_processed_list (Lisp_Object specifier, Lisp_Object locale, | |
| 1972 Lisp_Object inst_list) | |
| 1973 { | |
| 1974 /* The return value of this function must be GCPRO'd. */ | |
| 1975 Lisp_Object rest, list_to_build_up = Qnil; | |
| 440 | 1976 Lisp_Specifier *sp = XSPECIFIER (specifier); |
| 428 | 1977 struct gcpro gcpro1; |
| 1978 | |
| 1979 GCPRO1 (list_to_build_up); | |
| 1980 LIST_LOOP (rest, inst_list) | |
| 1981 { | |
| 1982 Lisp_Object tag_set = XCAR (XCAR (rest)); | |
| 1983 Lisp_Object sub_inst_list = Qnil; | |
| 434 | 1984 Lisp_Object instantiator; |
| 428 | 1985 struct gcpro ngcpro1, ngcpro2; |
| 1986 | |
| 434 | 1987 if (HAS_SPECMETH_P (sp, copy_instantiator)) |
| 1988 instantiator = SPECMETH (sp, copy_instantiator, | |
| 1989 (XCDR (XCAR (rest)))); | |
| 1990 else | |
| 1991 instantiator = Fcopy_tree (XCDR (XCAR (rest)), Qt); | |
| 1992 | |
| 428 | 1993 NGCPRO2 (instantiator, sub_inst_list); |
| 1994 /* call the will-add method; it may GC */ | |
| 1995 sub_inst_list = HAS_SPECMETH_P (sp, going_to_add) ? | |
| 1996 SPECMETH (sp, going_to_add, | |
| 1997 (bodily_specifier (specifier), locale, | |
| 1998 tag_set, instantiator)) : | |
| 1999 Qt; | |
| 2000 if (EQ (sub_inst_list, Qt)) | |
| 2001 /* no change here. */ | |
| 2002 sub_inst_list = list1 (Fcons (canonicalize_tag_set (tag_set), | |
| 2003 instantiator)); | |
| 2004 else | |
| 2005 { | |
| 2006 /* now canonicalize all the tag sets in the new objects */ | |
| 2007 Lisp_Object rest2; | |
| 2008 LIST_LOOP (rest2, sub_inst_list) | |
| 2009 XCAR (XCAR (rest2)) = canonicalize_tag_set (XCAR (XCAR (rest2))); | |
| 2010 } | |
| 2011 | |
| 2012 list_to_build_up = nconc2 (sub_inst_list, list_to_build_up); | |
| 2013 NUNGCPRO; | |
| 2014 } | |
| 2015 | |
| 2016 RETURN_UNGCPRO (Fnreverse (list_to_build_up)); | |
| 2017 } | |
| 2018 | |
| 2019 /* Add a specification (locale and instantiator list) to a specifier. | |
| 2020 ADD_METH specifies what to do with existing specifications in the | |
| 2021 specifier, and is an enum that corresponds to the values in | |
| 2022 `add-spec-to-specifier'. The calling routine is responsible for | |
| 2023 validating LOCALE and INST-LIST, but the tag-sets in INST-LIST | |
| 2024 do not need to be canonicalized. */ | |
| 2025 | |
| 3659 | 2026 /* #### I really need to rethink the after-change |
| 2027 functions to make them easier to use and more efficient. */ | |
| 428 | 2028 |
| 2029 static void | |
| 2030 specifier_add_spec (Lisp_Object specifier, Lisp_Object locale, | |
| 2031 Lisp_Object inst_list, enum spec_add_meth add_meth) | |
| 2032 { | |
| 440 | 2033 Lisp_Specifier *sp = XSPECIFIER (specifier); |
| 428 | 2034 enum spec_locale_type type = locale_type_from_locale (locale); |
| 2035 Lisp_Object *orig_inst_list, tem; | |
| 2036 Lisp_Object list_to_build_up = Qnil; | |
| 2037 struct gcpro gcpro1; | |
| 2038 | |
| 1015 | 2039 if (NILP (inst_list)) |
| 2040 return; | |
| 2041 | |
| 428 | 2042 GCPRO1 (list_to_build_up); |
| 2043 list_to_build_up = build_up_processed_list (specifier, locale, inst_list); | |
| 2044 /* Now handle REMOVE_LOCALE_TYPE and REMOVE_ALL. These are the | |
| 2045 add-meth types that affect locales other than this one. */ | |
| 2046 if (add_meth == SPEC_REMOVE_LOCALE_TYPE) | |
| 2047 specifier_remove_locale_type (specifier, type, Qnil, 0); | |
| 2048 else if (add_meth == SPEC_REMOVE_ALL) | |
| 2049 { | |
| 2050 specifier_remove_locale_type (specifier, LOCALE_BUFFER, Qnil, 0); | |
| 2051 specifier_remove_locale_type (specifier, LOCALE_WINDOW, Qnil, 0); | |
| 2052 specifier_remove_locale_type (specifier, LOCALE_FRAME, Qnil, 0); | |
| 2053 specifier_remove_locale_type (specifier, LOCALE_DEVICE, Qnil, 0); | |
| 2054 specifier_remove_spec (specifier, Qglobal, LOCALE_GLOBAL, Qnil, 0); | |
| 2055 } | |
| 2056 | |
| 2057 orig_inst_list = specifier_get_inst_list (specifier, locale, type); | |
| 2058 if (!orig_inst_list) | |
| 2059 orig_inst_list = specifier_new_spec (specifier, locale, type); | |
| 2060 add_meth = handle_multiple_add_insts (orig_inst_list, list_to_build_up, | |
| 2061 add_meth); | |
| 2062 | |
| 2063 if (add_meth == SPEC_PREPEND) | |
| 2064 tem = nconc2 (list_to_build_up, *orig_inst_list); | |
| 2065 else if (add_meth == SPEC_APPEND) | |
| 2066 tem = nconc2 (*orig_inst_list, list_to_build_up); | |
| 2067 else | |
| 442 | 2068 { |
| 2500 | 2069 ABORT (); |
| 442 | 2070 tem = Qnil; |
| 2071 } | |
| 428 | 2072 |
| 2073 *orig_inst_list = tem; | |
| 2074 | |
| 2075 UNGCPRO; | |
| 2076 | |
| 2077 /* call the after-change method */ | |
| 2078 MAYBE_SPECMETH (sp, after_change, | |
| 2079 (bodily_specifier (specifier), locale)); | |
| 2080 } | |
| 2081 | |
| 2082 static void | |
| 2083 specifier_copy_spec (Lisp_Object specifier, Lisp_Object dest, | |
| 2084 Lisp_Object locale, enum spec_locale_type type, | |
| 2085 Lisp_Object tag_set, int exact_p, | |
| 2086 enum spec_add_meth add_meth) | |
| 2087 { | |
| 2088 Lisp_Object inst_list = | |
| 2089 specifier_get_external_inst_list (specifier, locale, type, tag_set, | |
| 2090 exact_p, 0, 0); | |
| 2091 specifier_add_spec (dest, locale, inst_list, add_meth); | |
| 2092 } | |
| 2093 | |
| 2094 static void | |
| 2095 specifier_copy_locale_type (Lisp_Object specifier, Lisp_Object dest, | |
| 2096 enum spec_locale_type type, | |
| 2097 Lisp_Object tag_set, int exact_p, | |
| 2098 enum spec_add_meth add_meth) | |
| 2099 { | |
| 2100 Lisp_Object *src_list = SPECIFIER_GET_SPEC_LIST (specifier, type); | |
| 2101 Lisp_Object rest; | |
| 2102 | |
| 2103 /* This algorithm is O(n^2) in running time. | |
| 2104 It's certainly possible to implement an O(n log n) algorithm, | |
| 2105 but I doubt there's any need to. */ | |
| 2106 | |
| 2107 LIST_LOOP (rest, *src_list) | |
| 2108 { | |
| 2109 Lisp_Object spec = XCAR (rest); | |
| 2110 /* There may be dead objects floating around */ | |
| 2111 /* remember, dead windows can become alive again. */ | |
| 2112 if (WINDOWP (XCAR (spec)) || !object_dead_p (XCAR (spec))) | |
| 2113 specifier_add_spec | |
| 2114 (dest, XCAR (spec), | |
| 2115 specifier_process_inst_list (XCDR (spec), tag_set, exact_p, 0, 0), | |
| 2116 add_meth); | |
| 2117 } | |
| 2118 } | |
| 2119 | |
| 2120 /* map MAPFUN over the locales in SPECIFIER that are given in LOCALE. | |
| 2121 CLOSURE is passed unchanged to MAPFUN. LOCALE can be one of | |
| 2122 | |
| 3659 | 2123 -- nil (same as `all') |
| 2124 -- a single locale, locale type, or `all' | |
| 2125 -- a list of locales, locale types, and/or `all' | |
| 2953 | 2126 |
| 2127 MAPFUN is called for each locale and locale type given; for `all', | |
| 2128 it is called for the locale `global' and for the four possible | |
| 428 | 2129 locale types. In each invocation, either LOCALE will be a locale |
| 2130 and LOCALE_TYPE will be the locale type of this locale, | |
| 2131 or LOCALE will be nil and LOCALE_TYPE will be a locale type. | |
| 2132 If MAPFUN ever returns non-zero, the mapping is halted and the | |
| 2133 value returned is returned from map_specifier(). Otherwise, the | |
| 2134 mapping proceeds to the end and map_specifier() returns 0. | |
| 3659 | 2135 */ |
| 428 | 2136 |
| 2137 static int | |
| 2138 map_specifier (Lisp_Object specifier, Lisp_Object locale, | |
| 2139 int (*mapfun) (Lisp_Object specifier, | |
| 2140 Lisp_Object locale, | |
| 2141 enum spec_locale_type locale_type, | |
| 2142 Lisp_Object tag_set, | |
| 2143 int exact_p, | |
| 2144 void *closure), | |
| 2145 Lisp_Object tag_set, Lisp_Object exact_p, | |
| 2146 void *closure) | |
| 2147 { | |
| 2148 int retval = 0; | |
| 2149 Lisp_Object rest; | |
| 2150 struct gcpro gcpro1, gcpro2; | |
| 2151 | |
| 2152 GCPRO2 (tag_set, locale); | |
| 2153 locale = decode_locale_list (locale); | |
| 2154 tag_set = decode_specifier_tag_set (tag_set); | |
| 2155 tag_set = canonicalize_tag_set (tag_set); | |
| 2156 | |
| 2157 LIST_LOOP (rest, locale) | |
| 2158 { | |
| 2159 Lisp_Object theloc = XCAR (rest); | |
| 2160 if (!NILP (Fvalid_specifier_locale_p (theloc))) | |
| 2161 { | |
| 2162 retval = (*mapfun) (specifier, theloc, | |
| 2163 locale_type_from_locale (theloc), | |
| 2164 tag_set, !NILP (exact_p), closure); | |
| 2165 if (retval) | |
| 2166 break; | |
| 2167 } | |
| 2168 else if (!NILP (Fvalid_specifier_locale_type_p (theloc))) | |
| 2169 { | |
| 2170 retval = (*mapfun) (specifier, Qnil, | |
| 2171 decode_locale_type (theloc), tag_set, | |
| 2172 !NILP (exact_p), closure); | |
| 2173 if (retval) | |
| 2174 break; | |
| 2175 } | |
| 2176 else | |
| 2177 { | |
| 2178 assert (EQ (theloc, Qall)); | |
| 2179 retval = (*mapfun) (specifier, Qnil, LOCALE_BUFFER, tag_set, | |
| 2180 !NILP (exact_p), closure); | |
| 2181 if (retval) | |
| 2182 break; | |
| 2183 retval = (*mapfun) (specifier, Qnil, LOCALE_WINDOW, tag_set, | |
| 2184 !NILP (exact_p), closure); | |
| 2185 if (retval) | |
| 2186 break; | |
| 2187 retval = (*mapfun) (specifier, Qnil, LOCALE_FRAME, tag_set, | |
| 2188 !NILP (exact_p), closure); | |
| 2189 if (retval) | |
| 2190 break; | |
| 2191 retval = (*mapfun) (specifier, Qnil, LOCALE_DEVICE, tag_set, | |
| 2192 !NILP (exact_p), closure); | |
| 2193 if (retval) | |
| 2194 break; | |
| 2195 retval = (*mapfun) (specifier, Qglobal, LOCALE_GLOBAL, tag_set, | |
| 2196 !NILP (exact_p), closure); | |
| 2197 if (retval) | |
| 2198 break; | |
| 2199 } | |
| 2200 } | |
| 2201 | |
| 2202 UNGCPRO; | |
| 2203 return retval; | |
| 2204 } | |
| 2205 | |
| 2206 DEFUN ("add-spec-to-specifier", Fadd_spec_to_specifier, 2, 5, 0, /* | |
| 2207 Add a specification to SPECIFIER. | |
| 2208 The specification maps from LOCALE (which should be a window, buffer, | |
| 2953 | 2209 frame, device, or `global', and defaults to `global') to INSTANTIATOR, |
| 428 | 2210 whose allowed values depend on the type of the specifier. Optional |
| 2211 argument TAG-SET limits the instantiator to apply only to the specified | |
| 2212 tag set, which should be a list of tags all of which must match the | |
| 2213 device being instantiated over (tags are a device type, a device class, | |
| 2214 or tags defined with `define-specifier-tag'). Specifying a single | |
| 2215 symbol for TAG-SET is equivalent to specifying a one-element list | |
| 2216 containing that symbol. Optional argument HOW-TO-ADD specifies what to | |
| 2217 do if there are already specifications in the specifier. | |
| 2218 It should be one of | |
| 2219 | |
| 2953 | 2220 `prepend' Put at the beginning of the current list of |
| 428 | 2221 instantiators for LOCALE. |
| 2953 | 2222 `append' Add to the end of the current list of |
| 428 | 2223 instantiators for LOCALE. |
| 2953 | 2224 `remove-tag-set-prepend' (this is the default) |
| 428 | 2225 Remove any existing instantiators whose tag set is |
| 2226 the same as TAG-SET; then put the new instantiator | |
| 2227 at the beginning of the current list. ("Same tag | |
| 2228 set" means that they contain the same elements. | |
| 2229 The order may be different.) | |
| 2953 | 2230 `remove-tag-set-append' |
| 428 | 2231 Remove any existing instantiators whose tag set is |
| 2232 the same as TAG-SET; then put the new instantiator | |
| 2233 at the end of the current list. | |
| 2953 | 2234 `remove-locale' Remove all previous instantiators for this locale |
| 428 | 2235 before adding the new spec. |
| 2953 | 2236 `remove-locale-type' Remove all specifications for all locales of the |
| 428 | 2237 same type as LOCALE (this includes LOCALE itself) |
| 2238 before adding the new spec. | |
| 2953 | 2239 `remove-all' Remove all specifications from the specifier |
| 428 | 2240 before adding the new spec. |
| 2241 | |
| 2242 You can retrieve the specifications for a particular locale or locale type | |
| 2243 with the function `specifier-spec-list' or `specifier-specs'. | |
| 2244 */ | |
| 2245 (specifier, instantiator, locale, tag_set, how_to_add)) | |
| 2246 { | |
| 2247 enum spec_add_meth add_meth; | |
| 2248 Lisp_Object inst_list; | |
| 2249 struct gcpro gcpro1; | |
| 2250 | |
| 2251 CHECK_SPECIFIER (specifier); | |
| 2252 check_modifiable_specifier (specifier); | |
| 2253 | |
| 2254 locale = decode_locale (locale); | |
| 2255 check_valid_instantiator (instantiator, | |
| 2256 decode_specifier_type | |
| 2257 (Fspecifier_type (specifier), ERROR_ME), | |
| 2258 ERROR_ME); | |
| 2259 /* tag_set might be newly-created material, but it's part of inst_list | |
| 2260 so is properly GC-protected. */ | |
| 2261 tag_set = decode_specifier_tag_set (tag_set); | |
| 2262 add_meth = decode_how_to_add_specification (how_to_add); | |
| 2263 | |
| 2264 inst_list = list1 (Fcons (tag_set, instantiator)); | |
| 2265 GCPRO1 (inst_list); | |
| 2266 specifier_add_spec (specifier, locale, inst_list, add_meth); | |
| 2267 recompute_cached_specifier_everywhere (specifier); | |
| 2268 RETURN_UNGCPRO (Qnil); | |
| 2269 } | |
| 2270 | |
| 2271 DEFUN ("add-spec-list-to-specifier", Fadd_spec_list_to_specifier, 2, 3, 0, /* | |
| 444 | 2272 Add SPEC-LIST (a list of specifications) to SPECIFIER. |
| 2273 The format of SPEC-LIST is | |
| 428 | 2274 |
| 2275 ((LOCALE (TAG-SET . INSTANTIATOR) ...) ...) | |
| 2276 | |
| 2277 where | |
| 2953 | 2278 LOCALE := a window, a buffer, a frame, a device, or `global' |
| 428 | 2279 TAG-SET := an unordered list of zero or more TAGS, each of which |
|
4426
515b91f904c1
Fix specifier inheritance behavior
Didier Verna <didier@xemacs.org>
parents:
3836
diff
changeset
|
2280 is a symbol |
| 428 | 2281 TAG := a device class (see `valid-device-class-p'), a device type |
|
4426
515b91f904c1
Fix specifier inheritance behavior
Didier Verna <didier@xemacs.org>
parents:
3836
diff
changeset
|
2282 (see `valid-console-type-p'), or a tag defined with |
|
515b91f904c1
Fix specifier inheritance behavior
Didier Verna <didier@xemacs.org>
parents:
3836
diff
changeset
|
2283 `define-specifier-tag' |
| 428 | 2284 INSTANTIATOR := format determined by the type of specifier |
| 2285 | |
| 2286 The pair (TAG-SET . INSTANTIATOR) is called an `inst-pair'. | |
| 2287 A list of inst-pairs is called an `inst-list'. | |
| 2288 The pair (LOCALE . INST-LIST) is called a `specification' or `spec'. | |
| 2289 A spec-list, then, can be viewed as a list of specifications. | |
| 2290 | |
| 2291 HOW-TO-ADD specifies how to combine the new specifications with | |
| 2292 the existing ones, and has the same semantics as for | |
| 2293 `add-spec-to-specifier'. | |
| 2294 | |
| 2295 In many circumstances, the higher-level function `set-specifier' is | |
| 2296 more convenient and should be used instead. | |
| 2297 */ | |
| 2298 (specifier, spec_list, how_to_add)) | |
| 2299 { | |
| 2300 enum spec_add_meth add_meth; | |
| 2301 Lisp_Object rest; | |
| 2302 | |
| 2303 CHECK_SPECIFIER (specifier); | |
| 2304 check_modifiable_specifier (specifier); | |
| 2305 | |
| 2306 check_valid_spec_list (spec_list, | |
| 2307 decode_specifier_type | |
| 2308 (Fspecifier_type (specifier), ERROR_ME), | |
| 2309 ERROR_ME); | |
| 2310 add_meth = decode_how_to_add_specification (how_to_add); | |
| 2311 | |
| 2312 LIST_LOOP (rest, spec_list) | |
| 2313 { | |
| 2314 /* Placating the GCC god. */ | |
| 2315 Lisp_Object specification = XCAR (rest); | |
| 2316 Lisp_Object locale = XCAR (specification); | |
| 2317 Lisp_Object inst_list = XCDR (specification); | |
| 2318 | |
| 2319 specifier_add_spec (specifier, locale, inst_list, add_meth); | |
| 2320 } | |
| 2321 recompute_cached_specifier_everywhere (specifier); | |
| 2322 return Qnil; | |
| 2323 } | |
| 2324 | |
| 2325 void | |
| 2326 add_spec_to_ghost_specifier (Lisp_Object specifier, Lisp_Object instantiator, | |
| 2327 Lisp_Object locale, Lisp_Object tag_set, | |
| 2328 Lisp_Object how_to_add) | |
| 2329 { | |
| 2330 int depth = unlock_ghost_specifiers_protected (); | |
| 2331 Fadd_spec_to_specifier (XSPECIFIER(specifier)->fallback, | |
| 2332 instantiator, locale, tag_set, how_to_add); | |
| 771 | 2333 unbind_to (depth); |
| 428 | 2334 } |
| 2335 | |
| 2336 struct specifier_spec_list_closure | |
| 2337 { | |
| 2338 Lisp_Object head, tail; | |
| 2339 }; | |
| 2340 | |
| 2341 static int | |
| 2342 specifier_spec_list_mapfun (Lisp_Object specifier, | |
| 2343 Lisp_Object locale, | |
| 2344 enum spec_locale_type locale_type, | |
| 2345 Lisp_Object tag_set, | |
| 2346 int exact_p, | |
| 2347 void *closure) | |
| 2348 { | |
| 2349 struct specifier_spec_list_closure *cl = | |
| 2350 (struct specifier_spec_list_closure *) closure; | |
| 2351 Lisp_Object partial; | |
| 2352 | |
| 2353 if (NILP (locale)) | |
| 2354 partial = specifier_get_external_spec_list (specifier, | |
| 2355 locale_type, | |
| 2356 tag_set, exact_p); | |
| 2357 else | |
| 2358 { | |
| 2359 partial = specifier_get_external_inst_list (specifier, locale, | |
| 2360 locale_type, tag_set, | |
| 2361 exact_p, 0, 1); | |
| 2362 if (!NILP (partial)) | |
| 2363 partial = list1 (Fcons (locale, partial)); | |
| 2364 } | |
| 2365 if (NILP (partial)) | |
| 2366 return 0; | |
| 2367 | |
| 2368 /* tack on the new list */ | |
| 2369 if (NILP (cl->tail)) | |
| 2370 cl->head = cl->tail = partial; | |
| 2371 else | |
| 2372 XCDR (cl->tail) = partial; | |
| 2373 /* find the new tail */ | |
| 2374 while (CONSP (XCDR (cl->tail))) | |
| 2375 cl->tail = XCDR (cl->tail); | |
| 2376 return 0; | |
| 2377 } | |
| 2378 | |
| 2379 /* For the given SPECIFIER create and return a list of all specs | |
| 2380 contained within it, subject to LOCALE. If LOCALE is a locale, only | |
| 2381 specs in that locale will be returned. If LOCALE is a locale type, | |
| 2382 all specs in all locales of that type will be returned. If LOCALE is | |
| 2383 nil, all specs will be returned. This always copies lists and never | |
| 2384 returns the actual lists, because we do not want someone manipulating | |
| 2385 the actual objects. This may cause a slight loss of potential | |
| 2386 functionality but if we were to allow it then a user could manage to | |
| 2387 violate our assertion that the specs contained in the actual | |
| 2388 specifier lists are all valid. */ | |
| 2389 | |
| 2390 DEFUN ("specifier-spec-list", Fspecifier_spec_list, 1, 4, 0, /* | |
| 2391 Return the spec-list of specifications for SPECIFIER in LOCALE. | |
| 2392 | |
| 2393 If LOCALE is a particular locale (a buffer, window, frame, device, | |
| 2953 | 2394 or `global'), a spec-list consisting of the specification for that |
| 428 | 2395 locale will be returned. |
| 2396 | |
| 2953 | 2397 If LOCALE is a locale type (i.e. `buffer', `window', `frame', or `device'), |
| 428 | 2398 a spec-list of the specifications for all locales of that type will be |
| 2399 returned. | |
| 2400 | |
| 2953 | 2401 If LOCALE is nil or `all', a spec-list of all specifications in SPECIFIER |
| 428 | 2402 will be returned. |
| 2403 | |
| 2953 | 2404 LOCALE can also be a list of locales, locale types, and/or `all'; the |
| 428 | 2405 result is as if `specifier-spec-list' were called on each element of the |
| 2406 list and the results concatenated together. | |
| 2407 | |
| 2408 Only instantiators where TAG-SET (a list of zero or more tags) is a | |
| 2409 subset of (or possibly equal to) the instantiator's tag set are returned. | |
| 2410 \(The default value of nil is a subset of all tag sets, so in this case | |
| 2411 no instantiators will be screened out.) If EXACT-P is non-nil, however, | |
| 2412 TAG-SET must be equal to an instantiator's tag set for the instantiator | |
| 2413 to be returned. | |
| 2414 */ | |
| 3659 | 2415 (specifier, locale, tag_set, exact_p)) |
| 428 | 2416 { |
| 2417 struct specifier_spec_list_closure cl; | |
| 2418 struct gcpro gcpro1, gcpro2; | |
| 2419 | |
| 2420 CHECK_SPECIFIER (specifier); | |
| 2421 cl.head = cl.tail = Qnil; | |
| 2422 GCPRO2 (cl.head, cl.tail); | |
| 2423 map_specifier (specifier, locale, specifier_spec_list_mapfun, | |
| 2424 tag_set, exact_p, &cl); | |
| 2425 UNGCPRO; | |
| 2426 return cl.head; | |
| 2427 } | |
| 2428 | |
| 2429 | |
| 2430 DEFUN ("specifier-specs", Fspecifier_specs, 1, 4, 0, /* | |
| 2431 Return the specification(s) for SPECIFIER in LOCALE. | |
| 2432 | |
| 2433 If LOCALE is a single locale or is a list of one element containing a | |
| 2434 single locale, then a "short form" of the instantiators for that locale | |
| 2435 will be returned. Otherwise, this function is identical to | |
| 2436 `specifier-spec-list'. | |
| 2437 | |
| 2438 The "short form" is designed for readability and not for ease of use | |
| 2439 in Lisp programs, and is as follows: | |
| 2440 | |
| 2441 1. If there is only one instantiator, then an inst-pair (i.e. cons of | |
| 2442 tag and instantiator) will be returned; otherwise a list of | |
| 2443 inst-pairs will be returned. | |
| 2953 | 2444 2. For each inst-pair returned, if the instantiator's tag is `any', |
| 428 | 2445 the tag will be removed and the instantiator itself will be returned |
| 2446 instead of the inst-pair. | |
| 2447 3. If there is only one instantiator, its value is nil, and its tag is | |
| 2953 | 2448 `any', a one-element list containing nil will be returned rather |
| 428 | 2449 than just nil, to distinguish this case from there being no |
| 2450 instantiators at all. | |
| 2451 */ | |
| 2452 (specifier, locale, tag_set, exact_p)) | |
| 2453 { | |
| 2454 if (!NILP (Fvalid_specifier_locale_p (locale)) || | |
| 2455 (CONSP (locale) && !NILP (Fvalid_specifier_locale_p (XCAR (locale))) && | |
| 2456 NILP (XCDR (locale)))) | |
| 2457 { | |
| 2458 struct gcpro gcpro1; | |
| 2459 | |
| 2460 CHECK_SPECIFIER (specifier); | |
| 2461 if (CONSP (locale)) | |
| 2462 locale = XCAR (locale); | |
| 2463 GCPRO1 (tag_set); | |
| 2464 tag_set = decode_specifier_tag_set (tag_set); | |
| 2465 tag_set = canonicalize_tag_set (tag_set); | |
| 2466 RETURN_UNGCPRO | |
| 2467 (specifier_get_external_inst_list (specifier, locale, | |
| 2468 locale_type_from_locale (locale), | |
| 2469 tag_set, !NILP (exact_p), 1, 1)); | |
| 2470 } | |
| 2471 else | |
| 2472 return Fspecifier_spec_list (specifier, locale, tag_set, exact_p); | |
| 2473 } | |
| 2474 | |
| 2475 static int | |
| 2476 remove_specifier_mapfun (Lisp_Object specifier, | |
| 2477 Lisp_Object locale, | |
| 2478 enum spec_locale_type locale_type, | |
| 2479 Lisp_Object tag_set, | |
| 2480 int exact_p, | |
| 2286 | 2481 void *UNUSED (closure)) |
| 428 | 2482 { |
| 2483 if (NILP (locale)) | |
| 2484 specifier_remove_locale_type (specifier, locale_type, tag_set, exact_p); | |
| 2485 else | |
| 2486 specifier_remove_spec (specifier, locale, locale_type, tag_set, exact_p); | |
| 2487 return 0; | |
| 2488 } | |
| 2489 | |
| 2490 DEFUN ("remove-specifier", Fremove_specifier, 1, 4, 0, /* | |
| 2491 Remove specification(s) for SPECIFIER. | |
| 2492 | |
| 2493 If LOCALE is a particular locale (a window, buffer, frame, device, | |
| 2953 | 2494 or `global'), the specification for that locale will be removed. |
| 2495 | |
| 2496 If instead, LOCALE is a locale type (i.e. `window', `buffer', `frame', | |
| 2497 or `device'), the specifications for all locales of that type will be | |
| 428 | 2498 removed. |
| 2499 | |
| 2953 | 2500 If LOCALE is nil or `all', all specifications will be removed. |
| 2501 | |
| 2502 LOCALE can also be a list of locales, locale types, and/or `all'; this | |
| 428 | 2503 is equivalent to calling `remove-specifier' for each of the elements |
| 2504 in the list. | |
| 2505 | |
| 2506 Only instantiators where TAG-SET (a list of zero or more tags) is a | |
| 2507 subset of (or possibly equal to) the instantiator's tag set are removed. | |
| 2508 The default value of nil is a subset of all tag sets, so in this case | |
| 2509 no instantiators will be screened out. If EXACT-P is non-nil, however, | |
| 2510 TAG-SET must be equal to an instantiator's tag set for the instantiator | |
| 2511 to be removed. | |
| 2512 */ | |
| 2513 (specifier, locale, tag_set, exact_p)) | |
| 2514 { | |
| 2515 CHECK_SPECIFIER (specifier); | |
| 2516 check_modifiable_specifier (specifier); | |
| 2517 | |
| 2518 map_specifier (specifier, locale, remove_specifier_mapfun, | |
| 2519 tag_set, exact_p, 0); | |
| 2520 recompute_cached_specifier_everywhere (specifier); | |
| 2521 return Qnil; | |
| 2522 } | |
| 2523 | |
| 2524 void | |
| 2525 remove_ghost_specifier (Lisp_Object specifier, Lisp_Object locale, | |
| 2526 Lisp_Object tag_set, Lisp_Object exact_p) | |
| 2527 { | |
| 2528 int depth = unlock_ghost_specifiers_protected (); | |
| 2529 Fremove_specifier (XSPECIFIER(specifier)->fallback, | |
| 2530 locale, tag_set, exact_p); | |
| 771 | 2531 unbind_to (depth); |
| 428 | 2532 } |
| 2533 | |
| 2534 struct copy_specifier_closure | |
| 2535 { | |
| 2536 Lisp_Object dest; | |
| 2537 enum spec_add_meth add_meth; | |
| 2538 int add_meth_is_nil; | |
| 2539 }; | |
| 2540 | |
| 2541 static int | |
| 2542 copy_specifier_mapfun (Lisp_Object specifier, | |
| 2543 Lisp_Object locale, | |
| 2544 enum spec_locale_type locale_type, | |
| 2545 Lisp_Object tag_set, | |
| 2546 int exact_p, | |
| 2547 void *closure) | |
| 2548 { | |
| 2549 struct copy_specifier_closure *cl = | |
| 2550 (struct copy_specifier_closure *) closure; | |
| 2551 | |
| 2552 if (NILP (locale)) | |
| 2553 specifier_copy_locale_type (specifier, cl->dest, locale_type, | |
| 2554 tag_set, exact_p, | |
| 2555 cl->add_meth_is_nil ? | |
| 2556 SPEC_REMOVE_LOCALE_TYPE : | |
| 2557 cl->add_meth); | |
| 2558 else | |
| 2559 specifier_copy_spec (specifier, cl->dest, locale, locale_type, | |
| 2560 tag_set, exact_p, | |
| 2561 cl->add_meth_is_nil ? SPEC_REMOVE_LOCALE : | |
| 2562 cl->add_meth); | |
| 2563 return 0; | |
| 2564 } | |
| 2565 | |
| 2566 DEFUN ("copy-specifier", Fcopy_specifier, 1, 6, 0, /* | |
| 2567 Copy SPECIFIER to DEST, or create a new one if DEST is nil. | |
| 2568 | |
| 2569 If DEST is nil or omitted, a new specifier will be created and the | |
| 2570 specifications copied into it. Otherwise, the specifications will be | |
| 2571 copied into the existing specifier in DEST. | |
| 2572 | |
| 2953 | 2573 If LOCALE is nil or `all', all specifications will be copied. If LOCALE |
| 428 | 2574 is a particular locale, the specification for that particular locale will |
| 2575 be copied. If LOCALE is a locale type, the specifications for all locales | |
| 2576 of that type will be copied. LOCALE can also be a list of locales, | |
| 2953 | 2577 locale types, and/or `all'; this is equivalent to calling `copy-specifier' |
| 428 | 2578 for each of the elements of the list. See `specifier-spec-list' for more |
| 2579 information about LOCALE. | |
| 2580 | |
| 2581 Only instantiators where TAG-SET (a list of zero or more tags) is a | |
| 2582 subset of (or possibly equal to) the instantiator's tag set are copied. | |
| 2583 The default value of nil is a subset of all tag sets, so in this case | |
| 2584 no instantiators will be screened out. If EXACT-P is non-nil, however, | |
| 2585 TAG-SET must be equal to an instantiator's tag set for the instantiator | |
| 2586 to be copied. | |
| 2587 | |
| 2588 Optional argument HOW-TO-ADD specifies what to do with existing | |
| 2589 specifications in DEST. If nil, then whichever locales or locale types | |
| 2590 are copied will first be completely erased in DEST. Otherwise, it is | |
| 2591 the same as in `add-spec-to-specifier'. | |
| 2592 */ | |
| 2593 (specifier, dest, locale, tag_set, exact_p, how_to_add)) | |
| 2594 { | |
| 2595 struct gcpro gcpro1; | |
| 2596 struct copy_specifier_closure cl; | |
| 2597 | |
| 2598 CHECK_SPECIFIER (specifier); | |
| 2599 if (NILP (how_to_add)) | |
| 2600 cl.add_meth_is_nil = 1; | |
| 2601 else | |
| 2602 cl.add_meth_is_nil = 0; | |
| 2603 cl.add_meth = decode_how_to_add_specification (how_to_add); | |
| 2604 if (NILP (dest)) | |
| 2605 { | |
| 2606 /* #### What about copying the extra data? */ | |
| 2607 dest = make_specifier (XSPECIFIER (specifier)->methods); | |
| 2608 } | |
| 2609 else | |
| 2610 { | |
| 2611 CHECK_SPECIFIER (dest); | |
| 2612 check_modifiable_specifier (dest); | |
| 2613 if (XSPECIFIER (dest)->methods != XSPECIFIER (specifier)->methods) | |
| 3659 | 2614 invalid_argument ("Specifiers not of same type", Qunbound); |
| 428 | 2615 } |
| 2616 | |
| 2617 cl.dest = dest; | |
| 2618 GCPRO1 (dest); | |
| 2619 map_specifier (specifier, locale, copy_specifier_mapfun, | |
| 2620 tag_set, exact_p, &cl); | |
| 2621 UNGCPRO; | |
| 2622 recompute_cached_specifier_everywhere (dest); | |
| 2623 return dest; | |
| 2624 } | |
| 2625 | |
| 2626 | |
| 2627 /************************************************************************/ | |
| 2953 | 2628 /* Instantiation */ |
| 428 | 2629 /************************************************************************/ |
| 2630 | |
| 2631 static Lisp_Object | |
| 2632 call_validate_matchspec_method (Lisp_Object boxed_method, | |
| 2633 Lisp_Object matchspec) | |
| 2634 { | |
| 2635 ((void (*)(Lisp_Object)) get_opaque_ptr (boxed_method)) (matchspec); | |
| 2636 return Qt; | |
| 2637 } | |
| 2638 | |
| 2639 static Lisp_Object | |
| 2640 check_valid_specifier_matchspec (Lisp_Object matchspec, | |
| 2641 struct specifier_methods *meths, | |
| 578 | 2642 Error_Behavior errb) |
| 428 | 2643 { |
| 2644 if (meths->validate_matchspec_method) | |
| 2645 { | |
| 2646 Lisp_Object retval; | |
| 2647 | |
| 2648 if (ERRB_EQ (errb, ERROR_ME)) | |
| 2649 { | |
| 2650 (meths->validate_matchspec_method) (matchspec); | |
| 2651 retval = Qt; | |
| 2652 } | |
| 2653 else | |
| 2654 { | |
| 2655 Lisp_Object opaque = | |
| 2656 make_opaque_ptr ((void *) meths->validate_matchspec_method); | |
| 2657 struct gcpro gcpro1; | |
| 2658 | |
| 2659 GCPRO1 (opaque); | |
| 2660 retval = call_with_suspended_errors | |
| 2661 ((lisp_fn_t) call_validate_matchspec_method, | |
| 2662 Qnil, Qspecifier, errb, 2, opaque, matchspec); | |
| 2663 | |
| 2664 free_opaque_ptr (opaque); | |
| 2665 UNGCPRO; | |
| 2666 } | |
| 2667 | |
| 2668 return retval; | |
| 2669 } | |
| 2670 else | |
| 2671 { | |
| 563 | 2672 maybe_sferror |
| 428 | 2673 ("Matchspecs not allowed for this specifier type", |
| 2674 intern (meths->name), Qspecifier, errb); | |
| 2675 return Qnil; | |
| 2676 } | |
| 2677 } | |
| 2678 | |
| 442 | 2679 DEFUN ("check-valid-specifier-matchspec", Fcheck_valid_specifier_matchspec, 2, |
| 2680 2, 0, /* | |
| 428 | 2681 Signal an error if MATCHSPEC is invalid for SPECIFIER-TYPE. |
| 2682 See `specifier-matching-instance' for a description of matchspecs. | |
| 2683 */ | |
| 2684 (matchspec, specifier_type)) | |
| 2685 { | |
| 2686 struct specifier_methods *meths = decode_specifier_type (specifier_type, | |
| 2687 ERROR_ME); | |
| 2688 | |
| 2689 return check_valid_specifier_matchspec (matchspec, meths, ERROR_ME); | |
| 2690 } | |
| 2691 | |
| 2692 DEFUN ("valid-specifier-matchspec-p", Fvalid_specifier_matchspec_p, 2, 2, 0, /* | |
| 2693 Return non-nil if MATCHSPEC is valid for SPECIFIER-TYPE. | |
| 2694 See `specifier-matching-instance' for a description of matchspecs. | |
| 2695 */ | |
| 2696 (matchspec, specifier_type)) | |
| 2697 { | |
| 2698 struct specifier_methods *meths = decode_specifier_type (specifier_type, | |
| 2699 ERROR_ME); | |
| 2700 | |
| 2701 return check_valid_specifier_matchspec (matchspec, meths, ERROR_ME_NOT); | |
| 2702 } | |
| 2703 | |
| 2704 /* This function is purposely not callable from Lisp. If a Lisp | |
| 2705 caller wants to set a fallback, they should just set the | |
| 2706 global value. */ | |
| 2707 | |
| 2708 void | |
| 2709 set_specifier_fallback (Lisp_Object specifier, Lisp_Object fallback) | |
| 2710 { | |
| 440 | 2711 Lisp_Specifier *sp = XSPECIFIER (specifier); |
| 428 | 2712 assert (SPECIFIERP (fallback) || |
| 2713 !NILP (Fvalid_inst_list_p (fallback, Fspecifier_type (specifier)))); | |
| 2714 if (SPECIFIERP (fallback)) | |
| 2715 assert (EQ (Fspecifier_type (specifier), Fspecifier_type (fallback))); | |
| 2716 if (BODILY_SPECIFIER_P (sp)) | |
| 2717 GHOST_SPECIFIER(sp)->fallback = fallback; | |
| 2718 else | |
| 2719 sp->fallback = fallback; | |
| 2720 /* call the after-change method */ | |
| 2721 MAYBE_SPECMETH (sp, after_change, | |
| 2722 (bodily_specifier (specifier), Qfallback)); | |
| 2723 recompute_cached_specifier_everywhere (specifier); | |
| 2724 } | |
| 2725 | |
| 2726 DEFUN ("specifier-fallback", Fspecifier_fallback, 1, 1, 0, /* | |
| 2727 Return the fallback value for SPECIFIER. | |
| 2728 Fallback values are provided by the C code for certain built-in | |
| 2953 | 2729 specifiers to make sure that instantiation won't fail even if all |
| 428 | 2730 specs are removed from the specifier, or to implement simple |
| 2731 inheritance behavior (e.g. this method is used to ensure that | |
| 2953 | 2732 faces other than `default' inherit their attributes from `default'). |
| 428 | 2733 By design, you cannot change the fallback value, and specifiers |
| 2734 created with `make-specifier' will never have a fallback (although | |
| 2735 a similar, Lisp-accessible capability may be provided in the future | |
| 2736 to allow for inheritance). | |
| 2737 | |
| 2953 | 2738 The fallback value will be an inst-list that is instantiated like |
| 428 | 2739 any other inst-list, a specifier of the same type as SPECIFIER |
| 2740 \(results in inheritance), or nil for no fallback. | |
| 2741 | |
| 2953 | 2742 When you instantiate a specifier, you can explicitly request that the |
| 428 | 2743 fallback not be consulted. (The C code does this, for example, when |
| 2744 merging faces.) See `specifier-instance'. | |
| 2745 */ | |
| 2746 (specifier)) | |
| 2747 { | |
| 2748 CHECK_SPECIFIER (specifier); | |
| 2749 return Fcopy_tree (XSPECIFIER (specifier)->fallback, Qt); | |
| 2750 } | |
| 2751 | |
| 2752 static Lisp_Object | |
| 2753 specifier_instance_from_inst_list (Lisp_Object specifier, | |
| 2754 Lisp_Object matchspec, | |
| 2755 Lisp_Object domain, | |
| 2756 Lisp_Object inst_list, | |
| 578 | 2757 Error_Behavior errb, int no_quit, |
| 2953 | 2758 Lisp_Object depth, |
|
4426
515b91f904c1
Fix specifier inheritance behavior
Didier Verna <didier@xemacs.org>
parents:
3836
diff
changeset
|
2759 Lisp_Object *instantiator, |
|
515b91f904c1
Fix specifier inheritance behavior
Didier Verna <didier@xemacs.org>
parents:
3836
diff
changeset
|
2760 int no_fallback) |
| 428 | 2761 { |
| 2762 /* This function can GC */ | |
| 440 | 2763 Lisp_Specifier *sp; |
| 3659 | 2764 Lisp_Object device, charset = Qnil, rest; |
| 2765 int count = specpdl_depth (), respected_charsets = 0; | |
| 428 | 2766 struct gcpro gcpro1, gcpro2; |
|
5015
d95c102a96d3
cleanups for specifier font stages, from ben-unicode-internal (preparation for eliminating shadowed warnings)
Ben Wing <ben@xemacs.org>
parents:
5013
diff
changeset
|
2767 enum font_specifier_matchspec_stages stage = STAGE_INITIAL; |
| 428 | 2768 |
| 2769 GCPRO2 (specifier, inst_list); | |
| 2770 | |
| 2771 sp = XSPECIFIER (specifier); | |
| 442 | 2772 device = DOMAIN_DEVICE (domain); |
| 428 | 2773 |
| 2774 if (no_quit) | |
| 3659 | 2775 /* The instantiate method is allowed to call eval. Since it |
| 2776 is quite common for this function to get called from somewhere in | |
| 2777 redisplay we need to make sure that quits are ignored. Otherwise | |
| 2778 Fsignal will abort. */ | |
| 428 | 2779 specbind (Qinhibit_quit, Qt); |
| 2780 | |
| 3659 | 2781 #ifdef MULE |
| 4828 | 2782 /* #### FIXME Does this font-specific stuff need to be here and not in |
| 2783 the font-specifier-specific code? --ben */ | |
|
5015
d95c102a96d3
cleanups for specifier font stages, from ben-unicode-internal (preparation for eliminating shadowed warnings)
Ben Wing <ben@xemacs.org>
parents:
5013
diff
changeset
|
2784 if (CONSP (matchspec) && (CHARSETP (Ffind_charset (XCAR (matchspec))))) |
| 3659 | 2785 { |
|
5015
d95c102a96d3
cleanups for specifier font stages, from ben-unicode-internal (preparation for eliminating shadowed warnings)
Ben Wing <ben@xemacs.org>
parents:
5013
diff
changeset
|
2786 charset = Ffind_charset (XCAR (matchspec)); |
| 3659 | 2787 |
| 2788 #ifdef DEBUG_XEMACS | |
| 2789 /* This is mostly to have somewhere to set debug breakpoints. */ | |
| 4853 | 2790 if (!EQ (charset, Vcharset_ascii)) |
| 3659 | 2791 { |
| 4853 | 2792 (void) 0; |
| 3659 | 2793 } |
| 2794 #endif /* DEBUG_XEMACS */ | |
| 2795 | |
|
5015
d95c102a96d3
cleanups for specifier font stages, from ben-unicode-internal (preparation for eliminating shadowed warnings)
Ben Wing <ben@xemacs.org>
parents:
5013
diff
changeset
|
2796 if (!NILP (XCDR (matchspec))) |
| 3659 | 2797 { |
| 2798 | |
|
5015
d95c102a96d3
cleanups for specifier font stages, from ben-unicode-internal (preparation for eliminating shadowed warnings)
Ben Wing <ben@xemacs.org>
parents:
5013
diff
changeset
|
2799 #define FROB(new_stage, enumstage) \ |
|
d95c102a96d3
cleanups for specifier font stages, from ben-unicode-internal (preparation for eliminating shadowed warnings)
Ben Wing <ben@xemacs.org>
parents:
5013
diff
changeset
|
2800 if (EQ (Q##new_stage, XCDR (matchspec))) \ |
|
d95c102a96d3
cleanups for specifier font stages, from ben-unicode-internal (preparation for eliminating shadowed warnings)
Ben Wing <ben@xemacs.org>
parents:
5013
diff
changeset
|
2801 { \ |
|
d95c102a96d3
cleanups for specifier font stages, from ben-unicode-internal (preparation for eliminating shadowed warnings)
Ben Wing <ben@xemacs.org>
parents:
5013
diff
changeset
|
2802 stage = enumstage; \ |
| 3659 | 2803 } |
| 2804 | |
|
5015
d95c102a96d3
cleanups for specifier font stages, from ben-unicode-internal (preparation for eliminating shadowed warnings)
Ben Wing <ben@xemacs.org>
parents:
5013
diff
changeset
|
2805 FROB (initial, STAGE_INITIAL) |
|
d95c102a96d3
cleanups for specifier font stages, from ben-unicode-internal (preparation for eliminating shadowed warnings)
Ben Wing <ben@xemacs.org>
parents:
5013
diff
changeset
|
2806 else FROB (final, STAGE_FINAL) |
| 3659 | 2807 else assert(0); |
| 2808 #undef FROB | |
| 2809 | |
| 2810 } | |
| 2811 } | |
| 2812 #endif /* MULE */ | |
| 2813 | |
| 2814 LIST_LOOP(rest, inst_list) | |
| 2815 { | |
| 2816 Lisp_Object tagged_inst = XCAR (rest); | |
| 2817 Lisp_Object tag_set = XCAR (tagged_inst); | |
| 2818 Lisp_Object val, the_instantiator; | |
| 2819 | |
| 2820 if (!device_matches_specifier_tag_set_p (device, tag_set)) | |
| 2821 { | |
|
4426
515b91f904c1
Fix specifier inheritance behavior
Didier Verna <didier@xemacs.org>
parents:
3836
diff
changeset
|
2822 continue; |
| 3659 | 2823 } |
| 2824 | |
| 2825 val = XCDR (tagged_inst); | |
| 2826 the_instantiator = val; | |
| 2827 | |
| 2828 if (!NILP(charset) && | |
| 2829 !(charset_matches_specifier_tag_set_p (charset, tag_set, stage))) | |
| 2830 { | |
| 2831 ++respected_charsets; | |
| 2832 continue; | |
| 2833 } | |
| 2834 | |
| 2835 if (HAS_SPECMETH_P (sp, instantiate)) | |
| 2836 val = call_with_suspended_errors | |
| 2837 ((lisp_fn_t) RAW_SPECMETH (sp, instantiate), | |
| 2838 Qunbound, Qspecifier, errb, 5, specifier, | |
|
4426
515b91f904c1
Fix specifier inheritance behavior
Didier Verna <didier@xemacs.org>
parents:
3836
diff
changeset
|
2839 matchspec, domain, val, depth, no_fallback); |
| 3659 | 2840 |
| 2841 if (!UNBOUNDP (val)) | |
| 2842 { | |
| 2843 unbind_to (count); | |
| 2844 UNGCPRO; | |
| 2845 if (instantiator) | |
| 2846 *instantiator = the_instantiator; | |
| 2847 return val; | |
| 2848 } | |
| 2849 } | |
| 2850 | |
| 2851 /* We've checked all the tag sets, and checking the charset part of the | |
| 2852 specifier never returned 0 (preventing the attempted instantiation), so | |
| 2853 there's no need to loop for the second time to avoid checking the | |
| 2854 charsets. */ | |
| 2855 if (!respected_charsets) | |
| 2856 { | |
| 2857 unbind_to (count); | |
| 2858 UNGCPRO; | |
| 2859 return Qunbound; | |
| 2860 } | |
| 2861 | |
| 2862 /* Right, didn't instantiate a specifier last time, perhaps because we | |
| 2863 paid attention to the charset-specific aspects of the specifier. Try | |
| 2864 again without checking the charset information. | |
| 2865 | |
| 2866 We can't emulate the approach for devices, defaulting to matching all | |
| 2867 character sets for a given specifier, because $random font instantiator | |
| 2868 cannot usefully show all character sets, and indeed having it try is a | |
| 2869 failure on our part. */ | |
| 428 | 2870 LIST_LOOP (rest, inst_list) |
| 2871 { | |
| 2872 Lisp_Object tagged_inst = XCAR (rest); | |
| 2873 Lisp_Object tag_set = XCAR (tagged_inst); | |
| 3659 | 2874 Lisp_Object val, the_instantiator; |
| 2875 | |
| 2876 if (!device_matches_specifier_tag_set_p (device, tag_set)) | |
| 428 | 2877 { |
|
4426
515b91f904c1
Fix specifier inheritance behavior
Didier Verna <didier@xemacs.org>
parents:
3836
diff
changeset
|
2878 continue; |
| 3659 | 2879 } |
| 2880 | |
| 2881 val = XCDR (tagged_inst); | |
| 2882 the_instantiator = val; | |
| 2883 | |
| 2884 if (HAS_SPECMETH_P (sp, instantiate)) | |
| 2885 val = call_with_suspended_errors | |
| 2886 ((lisp_fn_t) RAW_SPECMETH (sp, instantiate), | |
| 2887 Qunbound, Qspecifier, errb, 5, specifier, | |
|
4426
515b91f904c1
Fix specifier inheritance behavior
Didier Verna <didier@xemacs.org>
parents:
3836
diff
changeset
|
2888 matchspec, domain, val, depth, no_fallback); |
| 3659 | 2889 |
| 2890 if (!UNBOUNDP (val)) | |
| 2891 { | |
| 2892 unbind_to (count); | |
| 2893 UNGCPRO; | |
| 2894 if (instantiator) | |
| 2895 *instantiator = the_instantiator; | |
| 2896 return val; | |
| 428 | 2897 } |
| 2898 } | |
| 2899 | |
| 771 | 2900 unbind_to (count); |
| 428 | 2901 UNGCPRO; |
| 2902 return Qunbound; | |
| 2903 } | |
| 2904 | |
| 2905 /* Given a SPECIFIER and a DOMAIN, return a specific instance for that | |
| 2906 specifier. Try to find one by checking the specifier types from most | |
| 4437 | 2907 specific (window) to most general (global). If we find an instance, |
| 428 | 2908 return it. Otherwise return Qunbound. */ |
| 2909 | |
| 2910 #define CHECK_INSTANCE_ENTRY(key, matchspec, type) do { \ | |
| 3659 | 2911 Lisp_Object *CIE_inst_list = \ |
| 2912 specifier_get_inst_list (specifier, key, type); \ | |
| 2913 if (CIE_inst_list) \ | |
| 2914 { \ | |
| 2915 Lisp_Object CIE_val = \ | |
| 2916 specifier_instance_from_inst_list (specifier, matchspec, \ | |
| 2917 domain, *CIE_inst_list, \ | |
| 2918 errb, no_quit, depth, \ | |
|
4426
515b91f904c1
Fix specifier inheritance behavior
Didier Verna <didier@xemacs.org>
parents:
3836
diff
changeset
|
2919 instantiator, no_fallback); \ |
| 3659 | 2920 if (!UNBOUNDP (CIE_val)) \ |
| 2921 return CIE_val; \ | |
| 2922 } \ | |
| 2923 } while (0) | |
| 428 | 2924 |
| 2925 /* We accept any window, frame or device domain and do our checking | |
| 2926 starting from as specific a locale type as we can determine from the | |
| 2927 domain we are passed and going on up through as many other locale types | |
| 2928 as we can determine. In practice, when called from redisplay the | |
| 2929 arg will usually be a window and occasionally a frame. If | |
| 2930 triggered by a user call, who knows what it will usually be. */ | |
| 2953 | 2931 |
| 2932 static Lisp_Object | |
| 2933 specifier_instance_1 (Lisp_Object specifier, Lisp_Object matchspec, | |
| 2934 Lisp_Object domain, Error_Behavior errb, int no_quit, | |
| 2935 int no_fallback, Lisp_Object depth, | |
| 2936 Lisp_Object *instantiator) | |
| 428 | 2937 { |
| 2938 Lisp_Object buffer = Qnil; | |
| 2939 Lisp_Object window = Qnil; | |
| 2940 Lisp_Object frame = Qnil; | |
| 2941 Lisp_Object device = Qnil; | |
| 444 | 2942 Lisp_Specifier *sp = XSPECIFIER (specifier); |
| 428 | 2943 |
| 2953 | 2944 if (instantiator) |
| 2945 *instantiator = Qunbound; | |
| 2946 | |
| 428 | 2947 /* Attempt to determine buffer, window, frame, and device from the |
| 2948 domain. */ | |
| 442 | 2949 /* #### get image instances out of domains! */ |
| 2950 if (IMAGE_INSTANCEP (domain)) | |
| 2951 window = DOMAIN_WINDOW (domain); | |
| 2952 else if (WINDOWP (domain)) | |
| 428 | 2953 window = domain; |
| 2954 else if (FRAMEP (domain)) | |
| 2955 frame = domain; | |
| 2956 else if (DEVICEP (domain)) | |
| 2957 device = domain; | |
| 2958 else | |
| 442 | 2959 /* dmoore writes: [dammit, this should just signal an error or something |
| 2960 shouldn't it?] | |
| 2961 | |
| 2962 No. Errors are handled in Lisp primitives implementation. | |
| 428 | 2963 Invalid domain is a design error here - kkm. */ |
| 2500 | 2964 ABORT (); |
| 428 | 2965 |
| 2966 if (NILP (buffer) && !NILP (window)) | |
| 444 | 2967 buffer = WINDOW_BUFFER (XWINDOW (window)); |
| 428 | 2968 if (NILP (frame) && !NILP (window)) |
| 2969 frame = XWINDOW (window)->frame; | |
| 2970 if (NILP (device)) | |
| 2971 /* frame had better exist; if device is undeterminable, something | |
| 2972 really went wrong. */ | |
| 444 | 2973 device = FRAME_DEVICE (XFRAME (frame)); |
| 428 | 2974 |
| 2975 /* device had better be determined by now; abort if not. */ | |
| 2286 | 2976 (void) DEVICE_CLASS (XDEVICE (device)); |
| 428 | 2977 |
| 2978 depth = make_int (1 + XINT (depth)); | |
| 2979 if (XINT (depth) > 20) | |
| 2980 { | |
| 563 | 2981 maybe_signal_error (Qstack_overflow, |
| 2982 "Apparent loop in specifier inheritance", | |
| 2983 Qunbound, Qspecifier, errb); | |
| 428 | 2984 /* The specification is fucked; at least try the fallback |
| 2985 (which better not be fucked, because it's not changeable | |
| 2986 from Lisp). */ | |
| 2987 depth = Qzero; | |
| 2988 goto do_fallback; | |
| 2989 } | |
| 2990 | |
| 434 | 2991 retry: |
| 428 | 2992 /* First see if we can generate one from the window specifiers. */ |
| 2993 if (!NILP (window)) | |
| 2994 CHECK_INSTANCE_ENTRY (window, matchspec, LOCALE_WINDOW); | |
| 2995 | |
| 2996 /* Next see if we can generate one from the buffer specifiers. */ | |
| 2997 if (!NILP (buffer)) | |
| 2998 CHECK_INSTANCE_ENTRY (buffer, matchspec, LOCALE_BUFFER); | |
| 2999 | |
| 3000 /* Next see if we can generate one from the frame specifiers. */ | |
| 3001 if (!NILP (frame)) | |
| 3002 CHECK_INSTANCE_ENTRY (frame, matchspec, LOCALE_FRAME); | |
| 3003 | |
| 3004 /* If we still haven't succeeded try with the device specifiers. */ | |
| 3005 CHECK_INSTANCE_ENTRY (device, matchspec, LOCALE_DEVICE); | |
| 3006 | |
| 3007 /* Last and least try the global specifiers. */ | |
| 3008 CHECK_INSTANCE_ENTRY (Qglobal, matchspec, LOCALE_GLOBAL); | |
| 3009 | |
| 434 | 3010 do_fallback: |
| 428 | 3011 /* We're out of specifiers and we still haven't generated an |
| 3012 instance. At least try the fallback ... If this fails, | |
| 3013 then we just return Qunbound. */ | |
| 3014 | |
| 3015 if (no_fallback || NILP (sp->fallback)) | |
| 3016 /* I said, I don't want the fallbacks. */ | |
| 3017 return Qunbound; | |
| 3018 | |
| 3019 if (SPECIFIERP (sp->fallback)) | |
| 3020 { | |
| 3021 /* If you introduced loops in the default specifier chain, | |
| 3022 then you're fucked, so you better not do this. */ | |
| 3023 specifier = sp->fallback; | |
| 3024 sp = XSPECIFIER (specifier); | |
| 3025 goto retry; | |
| 3026 } | |
| 3027 | |
| 3028 assert (CONSP (sp->fallback)); | |
| 3029 return specifier_instance_from_inst_list (specifier, matchspec, domain, | |
| 3030 sp->fallback, errb, no_quit, | |
|
4426
515b91f904c1
Fix specifier inheritance behavior
Didier Verna <didier@xemacs.org>
parents:
3836
diff
changeset
|
3031 depth, instantiator, |
|
515b91f904c1
Fix specifier inheritance behavior
Didier Verna <didier@xemacs.org>
parents:
3836
diff
changeset
|
3032 no_fallback); |
| 428 | 3033 } |
| 3034 #undef CHECK_INSTANCE_ENTRY | |
| 3035 | |
| 3036 Lisp_Object | |
| 2953 | 3037 specifier_instance (Lisp_Object specifier, Lisp_Object matchspec, |
| 3038 Lisp_Object domain, Error_Behavior errb, int no_quit, | |
| 3039 int no_fallback, Lisp_Object depth) | |
| 3040 { | |
| 3041 return specifier_instance_1 (specifier, matchspec, domain, errb, | |
| 3042 no_quit, no_fallback, depth, NULL); | |
| 3043 } | |
| 3044 | |
| 3045 Lisp_Object | |
| 428 | 3046 specifier_instance_no_quit (Lisp_Object specifier, Lisp_Object matchspec, |
| 578 | 3047 Lisp_Object domain, Error_Behavior errb, |
| 428 | 3048 int no_fallback, Lisp_Object depth) |
| 3049 { | |
| 2953 | 3050 return specifier_instance_1 (specifier, matchspec, domain, errb, |
| 3051 1, no_fallback, depth, NULL); | |
| 3052 } | |
| 3053 | |
| 3054 static Lisp_Object | |
| 3055 specifier_matching_foo (Lisp_Object specifier, | |
| 3056 Lisp_Object matchspec, | |
| 3057 Lisp_Object domain, | |
| 3058 Lisp_Object default_, | |
| 3059 Lisp_Object no_fallback, | |
| 3060 int want_instantiator) | |
| 3061 { | |
| 3062 Lisp_Object instance, instantiator; | |
| 3063 | |
| 3064 CHECK_SPECIFIER (specifier); | |
| 3065 if (!UNBOUNDP (matchspec)) | |
| 3066 check_valid_specifier_matchspec (matchspec, | |
| 3067 XSPECIFIER (specifier)->methods, | |
| 3068 ERROR_ME); | |
| 3069 domain = decode_domain (domain); | |
| 3070 | |
| 3071 instance = specifier_instance_1 (specifier, matchspec, domain, ERROR_ME, | |
| 3072 0, !NILP (no_fallback), Qzero, | |
| 3073 &instantiator); | |
| 3074 return UNBOUNDP (instance) ? default_ : want_instantiator ? instantiator : | |
| 3075 instance; | |
| 428 | 3076 } |
| 3077 | |
| 3078 DEFUN ("specifier-instance", Fspecifier_instance, 1, 4, 0, /* | |
| 3079 Instantiate SPECIFIER (return its value) in DOMAIN. | |
| 3080 If no instance can be generated for this domain, return DEFAULT. | |
| 3081 | |
| 2953 | 3082 DOMAIN is nearly always a window (defaulting to the selected window if |
| 3083 omitted), but can be a window, frame, or device. Other values that are legal | |
| 428 | 3084 as a locale (e.g. a buffer) are not valid as a domain because they do not |
| 3085 provide enough information to identify a particular device (see | |
| 2953 | 3086 `valid-specifier-domain-p'). Window domains are used internally in nearly |
| 3087 all circumstances when computing specifier instances of display properties. | |
| 3088 Frame domains are used in a few circumstances (such as when computing the | |
| 3089 geometry of a frame based on properties such as the toolbar widths), and | |
| 3090 device domains are rarely if ever used internally. | |
| 3091 | |
| 3092 This function looks through the specifications in SPECIFIER that correspond | |
| 3093 to DOMAIN, from most specific (specifications for DOMAIN itself) to most | |
| 3094 general (global specifications), for matching instantiators, and attempts | |
| 3095 to compute an instance value for each instantiator found. The first | |
| 3096 successfully computed value is returned. The corresponding instantiator | |
| 3097 can be returned using `specifier-instantiator'. | |
| 3098 | |
| 3099 A specifier is a generalized object for controlling the value of a property -- | |
| 3100 typically, but not necessarily, a display-related property -- that can vary | |
| 3101 over particular buffers, frames, device types, etc. | |
| 3102 | |
| 3103 A fundamental distinction must be made between the specification of a | |
| 3104 property's value, and the resulting value itself. This distinction is | |
| 3105 clearest in the case of an image -- the specification describes the source | |
| 3106 of the image (for example, a file of JPEG data), and the resulting value | |
| 3107 encapsulates a window-system object describing the image as displayed on a | |
| 3108 particular device (for example, a particular X display). The specification | |
| 3109 might also be an instruction of the form "use the background pixmap of the | |
| 3110 `modeline' face". A similar mapping exists between color strings and | |
| 3111 color-instance objects, and font strings and font-instance objects. In | |
| 3112 some cases, the specification and the resulting value are of the same type, | |
| 3113 but the distinction is still logically made. | |
| 3114 | |
| 3115 The specification of a value is called an instantiator, and the resulting | |
| 3116 value the instance. | |
| 428 | 3117 |
| 3118 "Instantiating" a specifier in a particular domain means determining | |
| 3119 the specifier's "value" in that domain. This is accomplished by | |
| 3120 searching through the specifications in the specifier that correspond | |
| 3121 to all locales that can be derived from the given domain, from specific | |
| 3122 to general. In most cases, the domain is an Emacs window. In that case | |
| 3123 specifications are searched for as follows: | |
| 3124 | |
| 3125 1. A specification whose locale is the window itself; | |
| 3126 2. A specification whose locale is the window's buffer; | |
| 3127 3. A specification whose locale is the window's frame; | |
| 3128 4. A specification whose locale is the window's frame's device; | |
| 2953 | 3129 5. A specification whose locale is `global'. |
| 428 | 3130 |
| 3131 If all of those fail, then the C-code-provided fallback value for | |
| 3132 this specifier is consulted (see `specifier-fallback'). If it is | |
| 3133 an inst-list, then this function attempts to instantiate that list | |
| 3134 just as when a specification is located in the first five steps above. | |
| 3135 If the fallback is a specifier, `specifier-instance' is called | |
| 3136 recursively on this specifier and the return value used. Note, | |
| 3137 however, that if the optional argument NO-FALLBACK is non-nil, | |
| 3138 the fallback value will not be consulted. | |
| 3139 | |
| 3140 Note that there may be more than one specification matching a particular | |
| 3141 locale; all such specifications are considered before looking for any | |
| 3142 specifications for more general locales. Any particular specification | |
| 3143 that is found may be rejected because its tag set does not match the | |
| 3144 device being instantiated over, or because the specification is not | |
| 3145 valid for the device of the given domain (e.g. the font or color name | |
| 3146 does not exist for this particular X server). | |
| 3147 | |
| 793 | 3148 NOTE: When errors occur in the process of trying a particular instantiator, |
| 3149 and the instantiator is thus skipped, warnings will be issued at level | |
| 3150 `debug'. Normally, such warnings are ignored entirely, but you can change | |
| 3151 this by setting `log-warning-minimum-level'. This is useful if you're | |
| 3152 trying to debug why particular instantiators are not being processed. | |
| 3153 | |
| 428 | 3154 The returned value is dependent on the type of specifier. For example, |
| 3155 for a font specifier (as returned by the `face-font' function), the returned | |
| 3156 value will be a font-instance object. For glyphs, the returned value | |
| 2953 | 3157 will be an image-instance object. |
| 428 | 3158 |
| 3159 See also `specifier-matching-instance'. | |
| 3160 */ | |
| 3161 (specifier, domain, default_, no_fallback)) | |
| 3162 { | |
| 2953 | 3163 return specifier_matching_foo (specifier, Qunbound, domain, default_, |
| 3164 no_fallback, 0); | |
| 3165 } | |
| 3166 | |
| 3167 DEFUN ("specifier-instantiator", Fspecifier_instantiator, 1, 4, 0, /* | |
| 3168 Return instantiator that would be used to instantiate SPECIFIER in DOMAIN. | |
| 3169 If no instance can be generated for this domain, return DEFAULT. | |
| 3170 | |
| 3171 DOMAIN should be a window, frame, or device. Other values that are legal | |
| 3172 as a locale (e.g. a buffer) are not valid as a domain because they do not | |
| 3173 provide enough information to identify a particular device (see | |
| 3174 `valid-specifier-domain-p'). DOMAIN defaults to the selected window | |
| 3175 if omitted. | |
| 3176 | |
| 3177 See `specifier-instance' for more information about the instantiation process. | |
| 3178 */ | |
| 3179 (specifier, domain, default_, no_fallback)) | |
| 3180 { | |
| 3181 return specifier_matching_foo (specifier, Qunbound, domain, default_, | |
| 3182 no_fallback, 1); | |
| 428 | 3183 } |
| 3184 | |
| 3185 DEFUN ("specifier-matching-instance", Fspecifier_matching_instance, 2, 5, 0, /* | |
| 3186 Return an instance for SPECIFIER in DOMAIN that matches MATCHSPEC. | |
| 3187 If no instance can be generated for this domain, return DEFAULT. | |
| 3188 | |
| 3189 This function is identical to `specifier-instance' except that a | |
| 3190 specification will only be considered if it matches MATCHSPEC. | |
| 3191 The definition of "match", and allowed values for MATCHSPEC, are | |
| 3192 dependent on the particular type of specifier. Here are some examples: | |
| 3193 | |
| 3194 -- For chartable (e.g. display table) specifiers, MATCHSPEC should be a | |
| 3195 character, and the specification (a chartable) must give a value for | |
| 3196 that character in order to be considered. This allows you to specify, | |
| 3197 e.g., a buffer-local display table that only gives values for particular | |
| 3198 characters. All other characters are handled as if the buffer-local | |
| 3199 display table is not there. (Chartable specifiers are not yet | |
| 3200 implemented.) | |
| 3201 | |
|
4426
515b91f904c1
Fix specifier inheritance behavior
Didier Verna <didier@xemacs.org>
parents:
3836
diff
changeset
|
3202 -- For font specifiers, MATCHSPEC should be a cons (CHARSET . STAGE). |
| 3674 | 3203 The defined stages are currently `initial' and `final'. On X11, 'initial |
| 3204 is used when the font matching process is looking for fonts that match | |
| 3205 the desired registries of the charset--see the `charset-registries' | |
| 3206 function. If that match process fails, then the 'final stage comes into | |
| 3207 play; this means that a more general lookup is desired, and that a font | |
| 3208 doesn't necessarily have to match the desired XLFD for the face, just the | |
| 3209 charset repertoire for this charset. It also means that the charset | |
| 3210 registry and encoding used will be `iso10646-1', and the characters will | |
| 3211 be converted to display using that registry. | |
| 3212 | |
| 3213 See `define-specifier-tag' for details on how to create a tag that | |
| 3214 specifies a given character set and stage combination. You can supply | |
| 3215 such a tag to `set-face-font' in order to set a face's font for that | |
| 3216 character set and stage combination. | |
| 428 | 3217 */ |
| 3218 (specifier, matchspec, domain, default_, no_fallback)) | |
| 3219 { | |
| 2953 | 3220 return specifier_matching_foo (specifier, matchspec, domain, default_, |
| 3221 no_fallback, 0); | |
| 3222 } | |
| 3223 | |
| 3224 DEFUN ("specifier-matching-instantiator", Fspecifier_matching_instantiator, | |
| 3225 2, 5, 0, /* | |
| 3226 Return instantiator for instance of SPECIFIER in DOMAIN that matches MATCHSPEC. | |
| 3227 If no instance can be generated for this domain, return DEFAULT. | |
| 3228 | |
| 3229 This function is identical to `specifier-matching-instance' but returns | |
| 3230 the instantiator used to generate the instance, rather than the actual | |
| 3231 instance. | |
| 3232 */ | |
| 3233 (specifier, matchspec, domain, default_, no_fallback)) | |
| 3234 { | |
| 3235 return specifier_matching_foo (specifier, matchspec, domain, default_, | |
| 3236 no_fallback, 1); | |
| 3237 } | |
| 3238 | |
| 3239 static Lisp_Object | |
| 3240 specifier_matching_foo_from_inst_list (Lisp_Object specifier, | |
| 3241 Lisp_Object matchspec, | |
| 3242 Lisp_Object domain, | |
| 3243 Lisp_Object inst_list, | |
| 3244 Lisp_Object default_, | |
| 3245 int want_instantiator) | |
| 3246 { | |
| 3247 Lisp_Object val = Qunbound; | |
| 3248 Lisp_Specifier *sp = XSPECIFIER (specifier); | |
| 3249 struct gcpro gcpro1; | |
| 3250 Lisp_Object built_up_list = Qnil; | |
| 3251 Lisp_Object instantiator; | |
| 428 | 3252 |
| 3253 CHECK_SPECIFIER (specifier); | |
| 2953 | 3254 if (!UNBOUNDP (matchspec)) |
| 3255 check_valid_specifier_matchspec (matchspec, | |
| 3256 XSPECIFIER (specifier)->methods, | |
| 3257 ERROR_ME); | |
| 3258 check_valid_domain (domain); | |
| 3259 check_valid_inst_list (inst_list, sp->methods, ERROR_ME); | |
| 3260 GCPRO1 (built_up_list); | |
| 3261 built_up_list = build_up_processed_list (specifier, domain, inst_list); | |
| 3262 if (!NILP (built_up_list)) | |
| 3263 val = specifier_instance_from_inst_list (specifier, matchspec, domain, | |
| 3264 built_up_list, ERROR_ME, | |
|
4426
515b91f904c1
Fix specifier inheritance behavior
Didier Verna <didier@xemacs.org>
parents:
3836
diff
changeset
|
3265 0, Qzero, &instantiator, 0); |
| 2953 | 3266 UNGCPRO; |
| 3267 return UNBOUNDP (val) ? default_ : want_instantiator ? instantiator : val; | |
| 3268 | |
| 428 | 3269 } |
| 3270 | |
| 3271 DEFUN ("specifier-instance-from-inst-list", Fspecifier_instance_from_inst_list, | |
| 3272 3, 4, 0, /* | |
| 3273 Attempt to convert a particular inst-list into an instance. | |
| 3274 This attempts to instantiate INST-LIST in the given DOMAIN, | |
| 3275 as if INST-LIST existed in a specification in SPECIFIER. If | |
| 3276 the instantiation fails, DEFAULT is returned. In most circumstances, | |
| 3277 you should not use this function; use `specifier-instance' instead. | |
| 3278 */ | |
| 3279 (specifier, domain, inst_list, default_)) | |
| 3280 { | |
| 2953 | 3281 return specifier_matching_foo_from_inst_list (specifier, Qunbound, |
| 3282 domain, inst_list, default_, | |
| 3283 0); | |
| 3284 } | |
| 3285 | |
|
4426
515b91f904c1
Fix specifier inheritance behavior
Didier Verna <didier@xemacs.org>
parents:
3836
diff
changeset
|
3286 DEFUN ("specifier-instantiator-from-inst-list", |
| 3659 | 3287 Fspecifier_instantiator_from_inst_list, 3, 4, 0, /* |
| 2953 | 3288 Attempt to convert an inst-list into an instance; return instantiator. |
| 3289 This is identical to `specifier-instance-from-inst-list' but returns | |
| 3290 the instantiator used to generate the instance, rather than the instance | |
| 3291 itself. | |
| 3292 */ | |
| 3293 (specifier, domain, inst_list, default_)) | |
| 3294 { | |
| 3295 return specifier_matching_foo_from_inst_list (specifier, Qunbound, | |
| 3296 domain, inst_list, default_, | |
| 3297 1); | |
| 428 | 3298 } |
| 3299 | |
| 442 | 3300 DEFUN ("specifier-matching-instance-from-inst-list", |
| 3301 Fspecifier_matching_instance_from_inst_list, | |
| 428 | 3302 4, 5, 0, /* |
| 3303 Attempt to convert a particular inst-list into an instance. | |
| 3304 This attempts to instantiate INST-LIST in the given DOMAIN | |
| 3305 \(as if INST-LIST existed in a specification in SPECIFIER), | |
| 3306 matching the specifications against MATCHSPEC. | |
| 3307 | |
| 3308 This function is analogous to `specifier-instance-from-inst-list' | |
| 3309 but allows for specification-matching as in `specifier-matching-instance'. | |
| 3310 See that function for a description of exactly how the matching process | |
| 3311 works. | |
| 3312 */ | |
| 3313 (specifier, matchspec, domain, inst_list, default_)) | |
| 3314 { | |
| 2953 | 3315 return specifier_matching_foo_from_inst_list (specifier, matchspec, |
| 3316 domain, inst_list, default_, | |
| 3317 0); | |
| 3318 } | |
| 3319 | |
| 3320 DEFUN ("specifier-matching-instantiator-from-inst-list", | |
| 3321 Fspecifier_matching_instantiator_from_inst_list, | |
| 3322 4, 5, 0, /* | |
| 3323 Attempt to convert an inst-list into an instance; return instantiator. | |
| 3324 This is identical to `specifier-matching-instance-from-inst-list' but returns | |
| 3325 the instantiator used to generate the instance, rather than the instance | |
| 3326 itself. | |
| 3327 */ | |
| 3328 (specifier, matchspec, domain, inst_list, default_)) | |
| 3329 { | |
| 3330 return specifier_matching_foo_from_inst_list (specifier, matchspec, | |
| 3331 domain, inst_list, default_, | |
| 3332 1); | |
| 428 | 3333 } |
| 3334 | |
| 3335 | |
| 3336 /************************************************************************/ | |
| 3337 /* Caching in the struct window or frame */ | |
| 3338 /************************************************************************/ | |
| 3339 | |
| 853 | 3340 /* Cause the current value of SPECIFIER in the domain of each frame and/or |
| 3341 window to be cached in the struct frame at STRUCT_FRAME_OFFSET and the | |
| 3342 struct window at STRUCT_WINDOW_OFFSET. When the value changes in a | |
| 3343 particular window, VALUE_CHANGED_IN_WINDOW is called. When the value | |
| 3344 changes in a particular frame, VALUE_CHANGED_IN_FRAME is called. | |
| 3345 | |
| 3346 Either STRUCT_WINDOW_OFFSET or STRUCT_FRAME_OFFSET can be 0 to indicate | |
| 3347 no caching in that sort of object. However, if they're not 0, you | |
| 3348 must supply a corresponding value-changed function. (This is the case | |
| 3349 so that you are forced to consider the ramifications of a value change. | |
| 3350 You nearly always need to do something, e.g. set a dirty flag.) | |
| 3351 | |
| 3352 If you create a built-in specifier, you should do the following: | |
| 3353 | |
| 3354 - Make sure the file you create the specifier in has a | |
| 3659 | 3355 specifier_vars_of_foo() function. If not, create it, declare it in |
| 3356 symsinit.h, and make sure it's called in the appropriate place in | |
| 3357 emacs.c. | |
| 853 | 3358 - In specifier_vars_of_foo(), do a DEFVAR_SPECIFIER(), followed by |
| 3659 | 3359 initializing the specifier using Fmake_specifier(), followed by |
| 3360 set_specifier_fallback(), followed (optionally) by | |
| 3361 set_specifier_caching(). | |
| 853 | 3362 - If you used set_specifier_caching(), make sure to create the |
| 3659 | 3363 appropriate value-changed functions. Also make sure to add the |
| 3364 appropriate slots where the values are cached to frameslots.h and | |
| 3365 winslots.h. | |
| 853 | 3366 |
| 3367 Do a grep for menubar_visible_p for an example. | |
| 3368 */ | |
| 428 | 3369 |
| 3370 /* #### It would be nice if the specifier caching automatically knew | |
| 3371 about specifier fallbacks, so we didn't have to do it ourselves. */ | |
| 3372 | |
| 3373 void | |
| 3374 set_specifier_caching (Lisp_Object specifier, int struct_window_offset, | |
| 3375 void (*value_changed_in_window) | |
| 3376 (Lisp_Object specifier, struct window *w, | |
| 3377 Lisp_Object oldval), | |
| 3378 int struct_frame_offset, | |
| 3379 void (*value_changed_in_frame) | |
| 3380 (Lisp_Object specifier, struct frame *f, | |
| 444 | 3381 Lisp_Object oldval), |
| 3382 int always_recompute) | |
| 428 | 3383 { |
| 440 | 3384 Lisp_Specifier *sp = XSPECIFIER (specifier); |
| 428 | 3385 assert (!GHOST_SPECIFIER_P (sp)); |
| 3386 | |
| 3387 if (!sp->caching) | |
| 3092 | 3388 #ifdef NEW_GC |
|
5127
a9c41067dd88
more cleanups, terminology clarification, lots of doc work
Ben Wing <ben@xemacs.org>
parents:
5125
diff
changeset
|
3389 sp->caching = XSPECIFIER_CACHING (ALLOC_NORMAL_LISP_OBJECT (specifier_caching)); |
| 3092 | 3390 #else /* not NEW_GC */ |
| 3659 | 3391 sp->caching = xnew_and_zero (struct specifier_caching); |
| 3092 | 3392 #endif /* not NEW_GC */ |
| 428 | 3393 sp->caching->offset_into_struct_window = struct_window_offset; |
| 3394 sp->caching->value_changed_in_window = value_changed_in_window; | |
| 3395 sp->caching->offset_into_struct_frame = struct_frame_offset; | |
| 3396 sp->caching->value_changed_in_frame = value_changed_in_frame; | |
| 853 | 3397 if (struct_window_offset) |
| 3398 assert (value_changed_in_window); | |
| 3399 if (struct_frame_offset) | |
| 3400 assert (value_changed_in_frame); | |
| 444 | 3401 sp->caching->always_recompute = always_recompute; |
| 428 | 3402 Vcached_specifiers = Fcons (specifier, Vcached_specifiers); |
| 3403 if (BODILY_SPECIFIER_P (sp)) | |
| 3404 GHOST_SPECIFIER(sp)->caching = sp->caching; | |
| 3405 recompute_cached_specifier_everywhere (specifier); | |
| 3406 } | |
| 3407 | |
| 3408 static void | |
| 3409 recompute_one_cached_specifier_in_window (Lisp_Object specifier, | |
| 3410 struct window *w) | |
| 3411 { | |
| 3412 Lisp_Object window; | |
| 444 | 3413 Lisp_Object newval, *location, oldval; |
| 428 | 3414 |
| 3415 assert (!GHOST_SPECIFIER_P (XSPECIFIER (specifier))); | |
| 3416 | |
| 793 | 3417 window = wrap_window (w); |
| 428 | 3418 |
| 3419 newval = specifier_instance (specifier, Qunbound, window, ERROR_ME_WARN, | |
| 3420 0, 0, Qzero); | |
| 3421 /* If newval ended up Qunbound, then the calling functions | |
| 3422 better be able to deal. If not, set a default so this | |
| 3423 never happens or correct it in the value_changed_in_window | |
| 3424 method. */ | |
| 3425 location = (Lisp_Object *) | |
| 3426 ((char *) w + XSPECIFIER (specifier)->caching->offset_into_struct_window); | |
| 442 | 3427 /* #### What's the point of this check, other than to optimize image |
| 3428 instance instantiation? Unless you specify a caching instantiate | |
| 3429 method the instantiation that specifier_instance will do will | |
| 3430 always create a new copy. Thus EQ will always fail. Unfortunately | |
| 3431 calling equal is no good either as this doesn't take into account | |
| 3432 things attached to the specifier - for instance strings on | |
| 3433 extents. --andyp */ | |
| 444 | 3434 if (!EQ (newval, *location) || XSPECIFIER (specifier)->caching->always_recompute) |
| 428 | 3435 { |
| 444 | 3436 oldval = *location; |
| 428 | 3437 *location = newval; |
| 3438 (XSPECIFIER (specifier)->caching->value_changed_in_window) | |
| 3439 (specifier, w, oldval); | |
| 3440 } | |
| 3441 } | |
| 3442 | |
| 3443 static void | |
| 3444 recompute_one_cached_specifier_in_frame (Lisp_Object specifier, | |
| 3445 struct frame *f) | |
| 3446 { | |
| 3447 Lisp_Object frame; | |
| 444 | 3448 Lisp_Object newval, *location, oldval; |
| 428 | 3449 |
| 3450 assert (!GHOST_SPECIFIER_P (XSPECIFIER (specifier))); | |
| 3451 | |
| 793 | 3452 frame = wrap_frame (f); |
| 428 | 3453 |
| 3454 newval = specifier_instance (specifier, Qunbound, frame, ERROR_ME_WARN, | |
| 3455 0, 0, Qzero); | |
| 3456 /* If newval ended up Qunbound, then the calling functions | |
| 3457 better be able to deal. If not, set a default so this | |
| 3458 never happens or correct it in the value_changed_in_frame | |
| 3459 method. */ | |
| 3460 location = (Lisp_Object *) | |
| 3461 ((char *) f + XSPECIFIER (specifier)->caching->offset_into_struct_frame); | |
| 444 | 3462 if (!EQ (newval, *location) || XSPECIFIER (specifier)->caching->always_recompute) |
| 428 | 3463 { |
| 444 | 3464 oldval = *location; |
| 428 | 3465 *location = newval; |
| 3466 (XSPECIFIER (specifier)->caching->value_changed_in_frame) | |
| 3467 (specifier, f, oldval); | |
| 3468 } | |
| 3469 } | |
| 3470 | |
| 3471 void | |
| 3472 recompute_all_cached_specifiers_in_window (struct window *w) | |
| 3473 { | |
| 3474 Lisp_Object rest; | |
| 3475 | |
| 3476 LIST_LOOP (rest, Vcached_specifiers) | |
| 3477 { | |
| 3478 Lisp_Object specifier = XCAR (rest); | |
| 3479 if (XSPECIFIER (specifier)->caching->offset_into_struct_window) | |
| 3480 recompute_one_cached_specifier_in_window (specifier, w); | |
| 3481 } | |
| 3482 } | |
| 3483 | |
| 3484 void | |
| 3485 recompute_all_cached_specifiers_in_frame (struct frame *f) | |
| 3486 { | |
| 3487 Lisp_Object rest; | |
| 3488 | |
| 3489 LIST_LOOP (rest, Vcached_specifiers) | |
| 3490 { | |
| 3491 Lisp_Object specifier = XCAR (rest); | |
| 3492 if (XSPECIFIER (specifier)->caching->offset_into_struct_frame) | |
| 3493 recompute_one_cached_specifier_in_frame (specifier, f); | |
| 3494 } | |
| 3495 } | |
| 3496 | |
| 3497 static int | |
| 3498 recompute_cached_specifier_everywhere_mapfun (struct window *w, | |
| 3499 void *closure) | |
| 3500 { | |
| 3501 Lisp_Object specifier = Qnil; | |
| 3502 | |
| 5013 | 3503 specifier = GET_LISP_FROM_VOID (closure); |
| 428 | 3504 recompute_one_cached_specifier_in_window (specifier, w); |
| 3505 return 0; | |
| 3506 } | |
| 3507 | |
| 3508 static void | |
| 3509 recompute_cached_specifier_everywhere (Lisp_Object specifier) | |
| 3510 { | |
| 3511 Lisp_Object frmcons, devcons, concons; | |
| 3512 | |
| 3513 specifier = bodily_specifier (specifier); | |
| 3514 | |
| 3515 if (!XSPECIFIER (specifier)->caching) | |
| 3516 return; | |
| 3517 | |
| 3518 if (XSPECIFIER (specifier)->caching->offset_into_struct_window) | |
| 3519 { | |
| 3520 FRAME_LOOP_NO_BREAK (frmcons, devcons, concons) | |
| 3521 map_windows (XFRAME (XCAR (frmcons)), | |
| 3522 recompute_cached_specifier_everywhere_mapfun, | |
| 5013 | 3523 STORE_LISP_IN_VOID (specifier)); |
| 428 | 3524 } |
| 3525 | |
| 3526 if (XSPECIFIER (specifier)->caching->offset_into_struct_frame) | |
| 3527 { | |
| 3528 FRAME_LOOP_NO_BREAK (frmcons, devcons, concons) | |
| 3529 recompute_one_cached_specifier_in_frame (specifier, | |
| 3530 XFRAME (XCAR (frmcons))); | |
| 3531 } | |
| 3532 } | |
| 3533 | |
| 3534 DEFUN ("set-specifier-dirty-flag", Fset_specifier_dirty_flag, 1, 1, 0, /* | |
| 3535 Force recomputation of any caches associated with SPECIFIER. | |
| 3536 Note that this automatically happens whenever you change a specification | |
| 3537 in SPECIFIER; you do not have to call this function then. | |
| 3538 One example of where this function is useful is when you have a | |
| 3539 toolbar button whose `active-p' field is an expression to be | |
| 3540 evaluated. Calling `set-specifier-dirty-flag' on the | |
| 3541 toolbar specifier will force the `active-p' fields to be | |
| 3542 recomputed. | |
| 3543 */ | |
| 3544 (specifier)) | |
| 3545 { | |
| 3546 CHECK_SPECIFIER (specifier); | |
| 3547 recompute_cached_specifier_everywhere (specifier); | |
| 3548 return Qnil; | |
| 3549 } | |
| 3550 | |
| 3551 | |
| 3552 /************************************************************************/ | |
| 3553 /* Generic specifier type */ | |
| 3554 /************************************************************************/ | |
| 3555 | |
| 3556 DEFINE_SPECIFIER_TYPE (generic); | |
| 3557 | |
| 3558 #if 0 | |
| 3559 | |
| 3560 /* This is the string that used to be in `generic-specifier-p'. | |
| 3561 The idea is good, but it doesn't quite work in the form it's | |
| 3562 in. (One major problem is that validating an instantiator | |
| 3563 is supposed to require only that the specifier type is passed, | |
| 3564 while with this approach the actual specifier is needed.) | |
| 3565 | |
| 3566 What really needs to be done is to write a function | |
| 3567 `make-specifier-type' that creates new specifier types. | |
| 442 | 3568 |
| 3569 #### [I'll look into this for 19.14.] Well, sometime. (Currently | |
| 3570 May 2000, 21.2 is in development. 19.14 was released in June 1996.) */ | |
| 428 | 3571 |
| 3572 "A generic specifier is a generalized kind of specifier with user-defined\n" | |
| 3573 "semantics. The instantiator can be any kind of Lisp object, and the\n" | |
| 3574 "instance computed from it is likewise any kind of Lisp object. The\n" | |
| 3575 "SPECIFIER-DATA should be an alist of methods governing how the specifier\n" | |
| 3576 "works. All methods are optional, and reasonable default methods will be\n" | |
| 2953 | 3577 "provided. Currently there are two defined methods: `instantiate' and\n" |
| 3578 "`validate'.\n" | |
| 428 | 3579 "\n" |
| 2953 | 3580 "`instantiate' specifies how to do the instantiation; if omitted, the\n" |
| 428 | 3581 "instantiator itself is simply returned as the instance. The method\n" |
| 3582 "should be a function that accepts three parameters (a specifier, the\n" | |
| 3583 "instantiator that matched the domain being instantiated over, and that\n" | |
| 3584 "domain), and should return a one-element list containing the instance,\n" | |
| 3585 "or nil if no instance exists. Note that the domain passed to this function\n" | |
| 3586 "is the domain being instantiated over, which may not be the same as the\n" | |
| 3587 "locale contained in the specification corresponding to the instantiator\n" | |
| 3588 "(for example, the domain being instantiated over could be a window, but\n" | |
| 3589 "the locale corresponding to the passed instantiator could be the window's\n" | |
| 3590 "buffer or frame).\n" | |
| 3591 "\n" | |
| 2953 | 3592 "`validate' specifies whether a given instantiator is valid; if omitted,\n" |
| 428 | 3593 "all instantiators are considered valid. It should be a function of\n" |
| 3594 "two arguments: an instantiator and a flag CAN-SIGNAL-ERROR. If this\n" | |
| 3595 "flag is false, the function must simply return t or nil indicating\n" | |
| 3596 "whether the instantiator is valid. If this flag is true, the function\n" | |
| 3597 "is free to signal an error if it encounters an invalid instantiator\n" | |
| 3598 "(this can be useful for issuing a specific error about exactly why the\n" | |
| 3599 "instantiator is valid). It can also return nil to indicate an invalid\n" | |
| 3600 "instantiator; in this case, a general error will be signalled." | |
| 3601 | |
| 3602 #endif /* 0 */ | |
| 3603 | |
| 3604 DEFUN ("generic-specifier-p", Fgeneric_specifier_p, 1, 1, 0, /* | |
| 3605 Return non-nil if OBJECT is a generic specifier. | |
| 3606 | |
| 442 | 3607 See `make-generic-specifier' for a description of possible generic |
| 3608 instantiators. | |
| 428 | 3609 */ |
| 3610 (object)) | |
| 3611 { | |
| 3612 return GENERIC_SPECIFIERP (object) ? Qt : Qnil; | |
| 3613 } | |
| 3614 | |
| 3615 | |
| 3616 /************************************************************************/ | |
| 3617 /* Integer specifier type */ | |
| 3618 /************************************************************************/ | |
| 3619 | |
| 3620 DEFINE_SPECIFIER_TYPE (integer); | |
| 3621 | |
| 3622 static void | |
| 3623 integer_validate (Lisp_Object instantiator) | |
| 3624 { | |
| 3625 CHECK_INT (instantiator); | |
| 3626 } | |
| 3627 | |
| 3628 DEFUN ("integer-specifier-p", Finteger_specifier_p, 1, 1, 0, /* | |
| 3629 Return non-nil if OBJECT is an integer specifier. | |
| 442 | 3630 |
| 3631 See `make-integer-specifier' for a description of possible integer | |
| 3632 instantiators. | |
| 428 | 3633 */ |
| 3634 (object)) | |
| 3635 { | |
| 3636 return INTEGER_SPECIFIERP (object) ? Qt : Qnil; | |
| 3637 } | |
| 3638 | |
| 3639 /************************************************************************/ | |
| 3640 /* Non-negative-integer specifier type */ | |
| 3641 /************************************************************************/ | |
| 3642 | |
| 3643 DEFINE_SPECIFIER_TYPE (natnum); | |
| 3644 | |
| 3645 static void | |
| 3646 natnum_validate (Lisp_Object instantiator) | |
| 3647 { | |
| 3648 CHECK_NATNUM (instantiator); | |
| 3649 } | |
| 3650 | |
| 3651 DEFUN ("natnum-specifier-p", Fnatnum_specifier_p, 1, 1, 0, /* | |
| 3652 Return non-nil if OBJECT is a natnum (non-negative-integer) specifier. | |
| 442 | 3653 |
| 3654 See `make-natnum-specifier' for a description of possible natnum | |
| 3655 instantiators. | |
| 428 | 3656 */ |
| 3657 (object)) | |
| 3658 { | |
| 3659 return NATNUM_SPECIFIERP (object) ? Qt : Qnil; | |
| 3660 } | |
| 3661 | |
| 3662 /************************************************************************/ | |
| 3663 /* Boolean specifier type */ | |
| 3664 /************************************************************************/ | |
| 3665 | |
| 3666 DEFINE_SPECIFIER_TYPE (boolean); | |
| 3667 | |
| 3668 static void | |
| 3669 boolean_validate (Lisp_Object instantiator) | |
| 3670 { | |
| 3671 if (!EQ (instantiator, Qt) && !EQ (instantiator, Qnil)) | |
| 563 | 3672 invalid_constant ("Must be t or nil", instantiator); |
| 428 | 3673 } |
| 3674 | |
| 3675 DEFUN ("boolean-specifier-p", Fboolean_specifier_p, 1, 1, 0, /* | |
| 3676 Return non-nil if OBJECT is a boolean specifier. | |
| 442 | 3677 |
| 3678 See `make-boolean-specifier' for a description of possible boolean | |
| 3679 instantiators. | |
| 428 | 3680 */ |
| 3681 (object)) | |
| 3682 { | |
| 3683 return BOOLEAN_SPECIFIERP (object) ? Qt : Qnil; | |
| 3684 } | |
| 3685 | |
| 3686 /************************************************************************/ | |
| 3687 /* Display table specifier type */ | |
| 3688 /************************************************************************/ | |
| 3689 | |
| 3690 DEFINE_SPECIFIER_TYPE (display_table); | |
| 3691 | |
| 3659 | 3692 #define VALID_SINGLE_DISPTABLE_INSTANTIATOR_P(instantiator) \ |
| 3693 (VECTORP (instantiator) \ | |
| 3694 || (CHAR_TABLEP (instantiator) \ | |
| 3695 && (XCHAR_TABLE_TYPE (instantiator) == CHAR_TABLE_TYPE_CHAR \ | |
| 442 | 3696 || XCHAR_TABLE_TYPE (instantiator) == CHAR_TABLE_TYPE_GENERIC)) \ |
| 428 | 3697 || RANGE_TABLEP (instantiator)) |
| 3698 | |
| 3699 static void | |
| 3700 display_table_validate (Lisp_Object instantiator) | |
| 3701 { | |
| 3702 if (NILP (instantiator)) | |
| 3703 /* OK */ | |
| 3704 ; | |
| 3705 else if (CONSP (instantiator)) | |
| 3706 { | |
| 2367 | 3707 EXTERNAL_LIST_LOOP_2 (car, instantiator) |
| 428 | 3708 { |
| 3709 if (!VALID_SINGLE_DISPTABLE_INSTANTIATOR_P (car)) | |
| 3710 goto lose; | |
| 3711 } | |
| 3712 } | |
| 3713 else | |
| 3714 { | |
| 3715 if (!VALID_SINGLE_DISPTABLE_INSTANTIATOR_P (instantiator)) | |
| 3716 { | |
| 3717 lose: | |
| 442 | 3718 dead_wrong_type_argument |
| 3719 (display_table_specifier_methods->predicate_symbol, | |
| 3659 | 3720 instantiator); |
| 428 | 3721 } |
| 3722 } | |
| 3723 } | |
| 3724 | |
| 3725 DEFUN ("display-table-specifier-p", Fdisplay_table_specifier_p, 1, 1, 0, /* | |
| 3726 Return non-nil if OBJECT is a display-table specifier. | |
| 442 | 3727 |
| 3728 See `current-display-table' for a description of possible display-table | |
| 3729 instantiators. | |
| 428 | 3730 */ |
| 3731 (object)) | |
| 3732 { | |
| 3733 return DISPLAYTABLE_SPECIFIERP (object) ? Qt : Qnil; | |
| 3734 } | |
| 3735 | |
| 3736 | |
| 3737 /************************************************************************/ | |
| 3738 /* Initialization */ | |
| 3739 /************************************************************************/ | |
| 3740 | |
| 3741 void | |
| 3742 syms_of_specifier (void) | |
| 3743 { | |
|
5117
3742ea8250b5
Checking in final CVS version of workspace 'ben-lisp-object'
Ben Wing <ben@xemacs.org>
parents:
3017
diff
changeset
|
3744 INIT_LISP_OBJECT (specifier); |
| 3092 | 3745 #ifdef NEW_GC |
|
5118
e0db3c197671
merge up to latest default branch, doesn't compile yet
Ben Wing <ben@xemacs.org>
diff
changeset
|
3746 INIT_LISP_OBJECT (specifier_caching); |
| 3092 | 3747 #endif /* NEW_GC */ |
| 442 | 3748 |
| 3749 DEFSYMBOL (Qspecifierp); | |
| 3750 | |
| 3751 DEFSYMBOL (Qconsole_type); | |
| 3752 DEFSYMBOL (Qdevice_class); | |
| 3753 | |
| 3754 /* specifier types defined in general.c. */ | |
| 428 | 3755 |
| 3756 DEFSUBR (Fvalid_specifier_type_p); | |
| 3757 DEFSUBR (Fspecifier_type_list); | |
| 3758 DEFSUBR (Fmake_specifier); | |
| 3759 DEFSUBR (Fspecifierp); | |
| 3760 DEFSUBR (Fspecifier_type); | |
| 3761 | |
| 3762 DEFSUBR (Fvalid_specifier_locale_p); | |
| 3763 DEFSUBR (Fvalid_specifier_domain_p); | |
| 3764 DEFSUBR (Fvalid_specifier_locale_type_p); | |
| 3765 DEFSUBR (Fspecifier_locale_type_from_locale); | |
| 3766 | |
| 3767 DEFSUBR (Fvalid_specifier_tag_p); | |
| 3768 DEFSUBR (Fvalid_specifier_tag_set_p); | |
| 3769 DEFSUBR (Fcanonicalize_tag_set); | |
| 3770 DEFSUBR (Fdevice_matches_specifier_tag_set_p); | |
| 3771 DEFSUBR (Fdefine_specifier_tag); | |
| 3772 DEFSUBR (Fdevice_matching_specifier_tag_list); | |
| 3673 | 3773 |
| 428 | 3774 DEFSUBR (Fspecifier_tag_list); |
| 3659 | 3775 DEFSUBR (Fspecifier_tag_device_predicate); |
| 3776 DEFSUBR (Fspecifier_tag_charset_predicate); | |
| 428 | 3777 |
| 3778 DEFSUBR (Fcheck_valid_instantiator); | |
| 3779 DEFSUBR (Fvalid_instantiator_p); | |
| 3780 DEFSUBR (Fcheck_valid_inst_list); | |
| 3781 DEFSUBR (Fvalid_inst_list_p); | |
| 3782 DEFSUBR (Fcheck_valid_spec_list); | |
| 3783 DEFSUBR (Fvalid_spec_list_p); | |
| 3784 DEFSUBR (Fadd_spec_to_specifier); | |
| 3785 DEFSUBR (Fadd_spec_list_to_specifier); | |
| 3786 DEFSUBR (Fspecifier_spec_list); | |
| 3787 DEFSUBR (Fspecifier_specs); | |
| 3788 DEFSUBR (Fremove_specifier); | |
| 3789 DEFSUBR (Fcopy_specifier); | |
| 3790 | |
| 3791 DEFSUBR (Fcheck_valid_specifier_matchspec); | |
| 3792 DEFSUBR (Fvalid_specifier_matchspec_p); | |
| 3793 DEFSUBR (Fspecifier_fallback); | |
| 3794 DEFSUBR (Fspecifier_instance); | |
| 2953 | 3795 DEFSUBR (Fspecifier_instantiator); |
| 428 | 3796 DEFSUBR (Fspecifier_matching_instance); |
| 2953 | 3797 DEFSUBR (Fspecifier_matching_instantiator); |
| 428 | 3798 DEFSUBR (Fspecifier_instance_from_inst_list); |
| 2953 | 3799 DEFSUBR (Fspecifier_instantiator_from_inst_list); |
| 428 | 3800 DEFSUBR (Fspecifier_matching_instance_from_inst_list); |
| 2953 | 3801 DEFSUBR (Fspecifier_matching_instantiator_from_inst_list); |
| 428 | 3802 DEFSUBR (Fset_specifier_dirty_flag); |
| 3803 | |
| 3804 DEFSUBR (Fgeneric_specifier_p); | |
| 3805 DEFSUBR (Finteger_specifier_p); | |
| 3806 DEFSUBR (Fnatnum_specifier_p); | |
| 3807 DEFSUBR (Fboolean_specifier_p); | |
| 3808 DEFSUBR (Fdisplay_table_specifier_p); | |
| 3809 | |
| 3810 /* Symbols pertaining to specifier creation. Specifiers are created | |
| 3811 in the syms_of() functions. */ | |
| 3812 | |
| 3813 /* locales are defined in general.c. */ | |
| 3814 | |
| 442 | 3815 /* some how-to-add flags in general.c. */ |
| 3816 DEFSYMBOL (Qremove_tag_set_prepend); | |
| 3817 DEFSYMBOL (Qremove_tag_set_append); | |
| 3818 DEFSYMBOL (Qremove_locale); | |
| 3819 DEFSYMBOL (Qremove_locale_type); | |
| 428 | 3820 } |
| 3821 | |
| 3822 void | |
| 3823 specifier_type_create (void) | |
| 3824 { | |
| 3825 the_specifier_type_entry_dynarr = Dynarr_new (specifier_type_entry); | |
| 2367 | 3826 dump_add_root_block_ptr (&the_specifier_type_entry_dynarr, &sted_description); |
| 428 | 3827 |
| 3828 Vspecifier_type_list = Qnil; | |
| 3829 staticpro (&Vspecifier_type_list); | |
| 3830 | |
| 3831 INITIALIZE_SPECIFIER_TYPE (generic, "generic", "generic-specifier-p"); | |
| 3832 | |
| 3833 INITIALIZE_SPECIFIER_TYPE (integer, "integer", "integer-specifier-p"); | |
| 3834 | |
| 3835 SPECIFIER_HAS_METHOD (integer, validate); | |
| 3836 | |
| 3837 INITIALIZE_SPECIFIER_TYPE (natnum, "natnum", "natnum-specifier-p"); | |
| 3838 | |
| 3839 SPECIFIER_HAS_METHOD (natnum, validate); | |
| 3840 | |
| 3841 INITIALIZE_SPECIFIER_TYPE (boolean, "boolean", "boolean-specifier-p"); | |
| 3842 | |
| 3843 SPECIFIER_HAS_METHOD (boolean, validate); | |
| 3844 | |
| 442 | 3845 INITIALIZE_SPECIFIER_TYPE (display_table, "display-table", |
| 3846 "display-table-p"); | |
| 428 | 3847 |
| 3848 SPECIFIER_HAS_METHOD (display_table, validate); | |
| 3849 } | |
| 3850 | |
| 3851 void | |
| 3852 reinit_specifier_type_create (void) | |
| 3853 { | |
| 3854 REINITIALIZE_SPECIFIER_TYPE (generic); | |
| 3855 REINITIALIZE_SPECIFIER_TYPE (integer); | |
| 3856 REINITIALIZE_SPECIFIER_TYPE (natnum); | |
| 3857 REINITIALIZE_SPECIFIER_TYPE (boolean); | |
| 3858 REINITIALIZE_SPECIFIER_TYPE (display_table); | |
| 3859 } | |
| 3860 | |
| 3861 void | |
| 3862 vars_of_specifier (void) | |
| 3863 { | |
| 3864 Vcached_specifiers = Qnil; | |
| 3865 staticpro (&Vcached_specifiers); | |
| 3866 | |
| 3867 /* Do NOT mark through this, or specifiers will never be GC'd. | |
| 3868 This is the same deal as for weak hash tables. */ | |
| 3869 Vall_specifiers = Qnil; | |
| 452 | 3870 dump_add_weak_object_chain (&Vall_specifiers); |
| 428 | 3871 |
| 3872 Vuser_defined_tags = Qnil; | |
| 3873 staticpro (&Vuser_defined_tags); | |
| 3874 | |
| 3875 Vunlock_ghost_specifiers = Qnil; | |
| 3876 staticpro (&Vunlock_ghost_specifiers); | |
| 3659 | 3877 |
|
5015
d95c102a96d3
cleanups for specifier font stages, from ben-unicode-internal (preparation for eliminating shadowed warnings)
Ben Wing <ben@xemacs.org>
parents:
5013
diff
changeset
|
3878 Vcharset_tag_lists = |
|
d95c102a96d3
cleanups for specifier font stages, from ben-unicode-internal (preparation for eliminating shadowed warnings)
Ben Wing <ben@xemacs.org>
parents:
5013
diff
changeset
|
3879 make_lisp_hash_table (50, HASH_TABLE_NON_WEAK, HASH_TABLE_EQ); |
|
4426
515b91f904c1
Fix specifier inheritance behavior
Didier Verna <didier@xemacs.org>
parents:
3836
diff
changeset
|
3880 staticpro (&Vcharset_tag_lists); |
| 428 | 3881 } |