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