Mercurial > hg > xemacs-beta
annotate src/specifier.c @ 5712:bee2e2568828 r21-5-33
XEmacs 21.5.33 "horseradish" is released.
| author | Stephen J. Turnbull <stephen@xemacs.org> |
|---|---|
| date | Sat, 05 Jan 2013 02:11:22 +0900 |
| 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 } |