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