Mercurial > hg > xemacs-beta
annotate src/specifier.c @ 5518:3cc7470ea71c
gnuclient: if TMPDIR was set and connect failed, try again with /tmp
2011-06-03 Aidan Kehoe <kehoea@parhasard.net>
* gnuslib.c (connect_to_unix_server):
Retry with /tmp as a directory in which to search for Unix sockets
if an attempt to connect with some other directory failed (which
may be because gnuclient and gnuserv don't share an environment
value for TMPDIR, or because gnuserv was compiled with USE_TMPDIR
turned off).
| author | Aidan Kehoe <kehoea@parhasard.net> |
|---|---|
| date | Fri, 03 Jun 2011 18:40:57 +0100 |
| parents | d12a0c55b174 |
| children | 56144c8593a8 |
| 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. */ | |
| 428 | 289 specbind (Qprint_string_length, make_int (100)); |
| 290 specbind (Qprint_length, make_int (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 { | |
| 888 int len = XINT (Flength (tag_set)); | |
| 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); |
|
5016
2ade80e8c640
enable more warnings and fix them
Ben Wing <ben@xemacs.org>
parents:
5015
diff
changeset
|
1056 int max_args = XINT (Ffunction_max_args (charset_predicate)); |
|
5015
d95c102a96d3
cleanups for specifier font stages, from ben-unicode-internal (preparation for eliminating shadowed warnings)
Ben Wing <ben@xemacs.org>
parents:
5013
diff
changeset
|
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 { |
|
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
|
1165 |
|
d95c102a96d3
cleanups for specifier font stages, from ben-unicode-internal (preparation for eliminating shadowed warnings)
Ben Wing <ben@xemacs.org>
parents:
5013
diff
changeset
|
1166 LIST_LOOP_2 (charset_name, Fcharset_list ()) |
| 3659 | 1167 { |
|
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
|
1168 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
|
1169 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
|
1170 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
|
1171 |
|
d95c102a96d3
cleanups for specifier font stages, from ben-unicode-internal (preparation for eliminating shadowed warnings)
Ben Wing <ben@xemacs.org>
parents:
5013
diff
changeset
|
1172 if (NILP (charset_predicate)) |
|
d95c102a96d3
cleanups for specifier font stages, from ben-unicode-internal (preparation for eliminating shadowed warnings)
Ben Wing <ben@xemacs.org>
parents:
5013
diff
changeset
|
1173 continue; |
|
d95c102a96d3
cleanups for specifier font stages, from ben-unicode-internal (preparation for eliminating shadowed warnings)
Ben Wing <ben@xemacs.org>
parents:
5013
diff
changeset
|
1174 |
|
d95c102a96d3
cleanups for specifier font stages, from ben-unicode-internal (preparation for eliminating shadowed warnings)
Ben Wing <ben@xemacs.org>
parents:
5013
diff
changeset
|
1175 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
|
1176 |
|
d95c102a96d3
cleanups for specifier font stages, from ben-unicode-internal (preparation for eliminating shadowed warnings)
Ben Wing <ben@xemacs.org>
parents:
5013
diff
changeset
|
1177 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
|
1178 if (!NILP (assoc)) |
| 3659 | 1179 { |
|
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
|
1180 assert (CONSP (assoc)); |
| 3659 | 1181 XCDR (assoc) = charpres; |
| 1182 } | |
| 1183 else | |
| 1184 { | |
|
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
|
1185 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
|
1186 Vcharset_tag_lists); |
| 3659 | 1187 } |
| 1188 } | |
| 1189 } | |
| 1190 return Qt; | |
| 1191 } | |
| 1192 | |
| 1193 DEFUN ("define-specifier-tag", Fdefine_specifier_tag, 1, 3, 0, /* | |
| 1194 Define a new specifier tag. | |
| 1195 | |
| 1196 If DEVICE-PREDICATE is specified, it should be a function of one argument | |
| 1197 \(a device) that specifies whether the tag matches that particular device. | |
| 1198 If DEVICE-PREDICATE is omitted, the tag matches all devices. | |
| 1199 | |
| 1200 If CHARSET-PREDICATE is supplied, it should be a function taking a single | |
| 1201 Lisp character set argument. A tag's charset predicate is primarily used to | |
| 1202 determine what font to use for a given \(set of) charset\(s) when that tag | |
| 1203 is used in a set-face-font call; a non-nil return value indicates that the | |
| 1204 tag matches the charset. | |
| 1205 | |
| 1206 The font matching process also has a concept of stages; the defined stages | |
| 1207 are currently `initial' and `final', and there exist specifier tags with | |
| 1208 those names that correspond to those stages. On X11, 'initial is used when | |
| 1209 the font matching process is looking for fonts that match the desired | |
| 1210 registries of the charset--see the `charset-registries' function. If that | |
| 1211 match process fails, then the 'final tag becomes relevant; this means that a | |
| 1212 more general lookup is desired, and that a font doesn't necessarily have to | |
| 1213 match the desired XLFD for the face, just the charset repertoire for this | |
| 1214 charset. It also means that the charset registry and encoding used will be | |
| 1215 `iso10646-1', and the characters will be converted to display using that | |
| 1216 registry. | |
| 1217 | |
| 1218 If a tag set matches no character set; the two-stage match process will | |
| 1219 ignore the tag on its first pass, but if no match is found, it will respect | |
| 1220 it on the second pass, where character set information is ignored. | |
| 1221 | |
| 1222 You can redefine an existing user-defined specifier tag. However, you | |
| 1223 cannot redefine most of the built-in specifier tags \(the device types and | |
| 1224 classes, `initial', and `final') or the symbols nil, t, `all', or `global'. | |
| 1225 Note that if a device type is not supported in this XEmacs, it will not be | |
| 1226 available as a built-in specifier tag; this is probably something we should | |
| 1227 change. | |
| 1228 */ | |
| 1229 (tag, device_predicate, charset_predicate)) | |
| 1230 { | |
| 1231 CHECK_SYMBOL (tag); | |
| 1232 if (valid_device_class_p (tag) || | |
| 1233 valid_console_type_p (tag) || | |
| 1234 EQ (tag, Qinitial) || EQ (tag, Qfinal)) | |
| 1235 invalid_change ("Cannot redefine built-in specifier tags", tag); | |
| 1236 /* Try to prevent common instantiators and locales from being | |
| 1237 redefined, to reduce ambiguity */ | |
| 1238 if (NILP (tag) || EQ (tag, Qt) || EQ (tag, Qall) || EQ (tag, Qglobal)) | |
| 1239 invalid_change ("Cannot define nil, t, `all', or `global'", tag); | |
| 1240 | |
| 1241 if (!NILP (charset_predicate)) | |
| 1242 { | |
|
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
|
1243 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
|
1244 Lisp_Object max_args = Ffunction_max_args (charset_predicate); |
|
d95c102a96d3
cleanups for specifier font stages, from ben-unicode-internal (preparation for eliminating shadowed warnings)
Ben Wing <ben@xemacs.org>
parents:
5013
diff
changeset
|
1245 if (!(INTP (min_args) && XINT (min_args) == 1 && |
|
d95c102a96d3
cleanups for specifier font stages, from ben-unicode-internal (preparation for eliminating shadowed warnings)
Ben Wing <ben@xemacs.org>
parents:
5013
diff
changeset
|
1246 INTP (max_args) && XINT (max_args) == 1)) |
| 3659 | 1247 { |
| 1248 /* We only allow the stage argument to be specifed from C. */ | |
| 1249 invalid_change ("Charset predicate must take one argument", | |
| 1250 tag); | |
| 1251 } | |
| 1252 } | |
| 1253 | |
| 5198 | 1254 return define_specifier_tag (tag, device_predicate, charset_predicate); |
| 428 | 1255 } |
| 1256 | |
| 1257 /* Called at device-creation time to initialize the user-defined | |
| 1258 tag values for the newly-created device. */ | |
| 1259 | |
| 1260 void | |
| 1261 setup_device_initial_specifier_tags (struct device *d) | |
| 1262 { | |
| 1263 Lisp_Object rest, rest2; | |
| 793 | 1264 Lisp_Object device = wrap_device (d); |
| 3836 | 1265 Lisp_Object device_predicate; |
| 3659 | 1266 int list_len; |
| 793 | 1267 |
| 428 | 1268 DEVICE_USER_DEFINED_TAGS (d) = Fcopy_alist (Vuser_defined_tags); |
| 1269 | |
| 1270 /* Now set up the initial values */ | |
| 1271 LIST_LOOP (rest, DEVICE_USER_DEFINED_TAGS (d)) | |
| 1272 XCDR (XCAR (rest)) = Qt; | |
| 1273 | |
| 1274 for (rest = Vuser_defined_tags, rest2 = DEVICE_USER_DEFINED_TAGS (d); | |
| 1275 !NILP (rest); rest = XCDR (rest), rest2 = XCDR (rest2)) | |
| 1276 { | |
| 5198 | 1277 GET_LIST_LENGTH (XCAR(rest), list_len); |
| 1278 | |
| 1279 assert (3 == list_len); | |
| 1280 | |
| 1281 device_predicate = XCADR (XCAR (rest)); | |
|
4426
515b91f904c1
Fix specifier inheritance behavior
Didier Verna <didier@xemacs.org>
parents:
3836
diff
changeset
|
1282 |
| 3659 | 1283 if (NILP (device_predicate)) |
| 1284 { | |
|
4426
515b91f904c1
Fix specifier inheritance behavior
Didier Verna <didier@xemacs.org>
parents:
3836
diff
changeset
|
1285 XCDR (XCAR (rest2)) = Qt; |
| 3659 | 1286 } |
| 428 | 1287 else |
| 3659 | 1288 { |
|
4426
515b91f904c1
Fix specifier inheritance behavior
Didier Verna <didier@xemacs.org>
parents:
3836
diff
changeset
|
1289 device_predicate = !NILP (call_critical_lisp_code |
|
515b91f904c1
Fix specifier inheritance behavior
Didier Verna <didier@xemacs.org>
parents:
3836
diff
changeset
|
1290 (d, device_predicate, device)) |
| 3659 | 1291 ? Qt : Qnil; |
| 3817 | 1292 XCDR (XCAR (rest2)) = device_predicate; |
| 3659 | 1293 } |
| 428 | 1294 } |
| 1295 } | |
| 1296 | |
| 3659 | 1297 void |
| 1298 setup_charset_initial_specifier_tags (Lisp_Object charset) | |
| 1299 { | |
| 1300 Lisp_Object rest, charset_predicate, tag, new_value; | |
|
4426
515b91f904c1
Fix specifier inheritance behavior
Didier Verna <didier@xemacs.org>
parents:
3836
diff
changeset
|
1301 Lisp_Object charset_tag_list = Qnil; |
| 3659 | 1302 |
| 1303 LIST_LOOP (rest, Vuser_defined_tags) | |
| 1304 { | |
|
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
|
1305 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
|
1306 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
|
1307 |
|
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 if (NILP (charset_predicate)) |
| 3659 | 1309 { |
| 1310 continue; | |
| 1311 } | |
| 1312 | |
|
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
|
1313 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
|
1314 charset_tag_list = Fcons (Fcons (tag, new_value), charset_tag_list); |
| 3659 | 1315 } |
| 1316 | |
|
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
|
1317 Fputhash (charset, charset_tag_list, Vcharset_tag_lists); |
| 3659 | 1318 } |
| 1319 | |
| 3673 | 1320 /* VM calls this, in vm-multiple-frames-possible-p, in the event that you're |
| 1321 considering taking it out. */ | |
| 3659 | 1322 |
| 442 | 1323 DEFUN ("device-matching-specifier-tag-list", |
| 1324 Fdevice_matching_specifier_tag_list, | |
| 428 | 1325 0, 1, 0, /* |
| 3673 | 1326 Return a list of all specifier tags matching DEVICE. |
| 1327 DEVICE defaults to the selected device if omitted. | |
| 1328 */ | |
| 428 | 1329 (device)) |
| 1330 { | |
| 1331 struct device *d = decode_device (device); | |
| 1332 Lisp_Object rest, list = Qnil; | |
| 1333 struct gcpro gcpro1; | |
| 1334 | |
| 1335 GCPRO1 (list); | |
| 1336 | |
| 1337 LIST_LOOP (rest, DEVICE_USER_DEFINED_TAGS (d)) | |
| 1338 { | |
| 3836 | 1339 if (!NILP (XCDR (XCAR (rest)))) |
| 428 | 1340 list = Fcons (XCAR (XCAR (rest)), list); |
| 1341 } | |
| 1342 | |
| 1343 list = Fnreverse (list); | |
| 1344 list = Fcons (DEVICE_CLASS (d), list); | |
| 1345 list = Fcons (DEVICE_TYPE (d), list); | |
| 1346 | |
| 1347 RETURN_UNGCPRO (list); | |
| 1348 } | |
| 1349 | |
| 1350 DEFUN ("specifier-tag-list", Fspecifier_tag_list, 0, 0, 0, /* | |
| 1351 Return a list of all currently-defined specifier tags. | |
| 1352 This includes the built-in ones (the device types and classes). | |
| 1353 */ | |
| 1354 ()) | |
| 1355 { | |
| 1356 Lisp_Object list = Qnil, rest; | |
| 1357 struct gcpro gcpro1; | |
| 1358 | |
| 1359 GCPRO1 (list); | |
| 1360 | |
| 1361 LIST_LOOP (rest, Vuser_defined_tags) | |
| 1362 list = Fcons (XCAR (XCAR (rest)), list); | |
| 1363 | |
| 1364 list = Fnreverse (list); | |
| 1365 list = nconc2 (Fcopy_sequence (Vdevice_class_list), list); | |
| 1366 list = nconc2 (Fcopy_sequence (Vconsole_type_list), list); | |
| 1367 | |
| 1368 RETURN_UNGCPRO (list); | |
| 1369 } | |
| 1370 | |
| 3659 | 1371 DEFUN ("specifier-tag-device-predicate", Fspecifier_tag_device_predicate, |
| 1372 1, 1, 0, /* | |
| 1373 Return the device predicate for the given specifier tag. | |
| 428 | 1374 */ |
| 1375 (tag)) | |
| 1376 { | |
| 1377 /* The return value of this function must be GCPRO'd. */ | |
| 1378 CHECK_SYMBOL (tag); | |
| 1379 | |
| 1380 if (NILP (Fvalid_specifier_tag_p (tag))) | |
| 563 | 1381 invalid_argument ("Invalid specifier tag", |
| 3659 | 1382 tag); |
| 428 | 1383 |
| 1384 /* Make up some predicates for the built-in types */ | |
| 1385 | |
| 1386 if (valid_console_type_p (tag)) | |
| 1387 return list3 (Qlambda, list1 (Qdevice), | |
| 1388 list3 (Qeq, list2 (Qquote, tag), | |
| 1389 list2 (Qconsole_type, Qdevice))); | |
| 1390 | |
| 1391 if (valid_device_class_p (tag)) | |
| 1392 return list3 (Qlambda, list1 (Qdevice), | |
| 1393 list3 (Qeq, list2 (Qquote, tag), | |
| 1394 list2 (Qdevice_class, Qdevice))); | |
| 1395 | |
| 3659 | 1396 return XCADR (assq_no_quit (tag, Vuser_defined_tags)); |
| 1397 } | |
| 1398 | |
| 1399 DEFUN ("specifier-tag-charset-predicate", Fspecifier_tag_charset_predicate, | |
| 1400 1, 1, 0, /* | |
| 3673 | 1401 Return the charset predicate for the given specifier tag. |
| 1402 */ | |
| 3659 | 1403 (tag)) |
| 1404 { | |
| 1405 /* The return value of this function must be GCPRO'd. */ | |
| 1406 CHECK_SYMBOL (tag); | |
| 1407 | |
| 1408 if (NILP (Fvalid_specifier_tag_p (tag))) | |
| 1409 invalid_argument ("Invalid specifier tag", | |
| 1410 tag); | |
| 1411 | |
| 1412 return XCADDR (assq_no_quit (tag, Vuser_defined_tags)); | |
| 428 | 1413 } |
| 1414 | |
| 1415 /* Return true if A "matches" B. If EXACT_P is 0, A must be a subset of B. | |
| 3659 | 1416 Otherwise, A must be `equal' to B. The sets must be canonicalized. */ |
| 428 | 1417 static int |
| 1418 tag_sets_match_p (Lisp_Object a, Lisp_Object b, int exact_p) | |
| 1419 { | |
| 1420 if (!exact_p) | |
| 1421 { | |
| 1422 while (!NILP (a) && !NILP (b)) | |
| 1423 { | |
| 1424 if (EQ (XCAR (a), XCAR (b))) | |
| 1425 a = XCDR (a); | |
| 1426 b = XCDR (b); | |
| 1427 } | |
| 1428 | |
| 1429 return NILP (a); | |
| 1430 } | |
| 1431 else | |
| 1432 { | |
| 1433 while (!NILP (a) && !NILP (b)) | |
| 1434 { | |
| 1435 if (!EQ (XCAR (a), XCAR (b))) | |
| 1436 return 0; | |
| 1437 a = XCDR (a); | |
| 1438 b = XCDR (b); | |
| 1439 } | |
| 1440 | |
| 1441 return NILP (a) && NILP (b); | |
| 1442 } | |
| 1443 } | |
| 1444 | |
| 1445 | |
| 1446 /************************************************************************/ | |
| 1447 /* Spec-lists and inst-lists */ | |
| 1448 /************************************************************************/ | |
| 1449 | |
| 1450 static Lisp_Object | |
| 1451 call_validate_method (Lisp_Object boxed_method, Lisp_Object instantiator) | |
| 1452 { | |
| 1453 ((void (*)(Lisp_Object)) get_opaque_ptr (boxed_method)) (instantiator); | |
| 1454 return Qt; | |
| 1455 } | |
| 1456 | |
| 1457 static Lisp_Object | |
| 1458 check_valid_instantiator (Lisp_Object instantiator, | |
| 1459 struct specifier_methods *meths, | |
| 578 | 1460 Error_Behavior errb) |
| 428 | 1461 { |
| 1462 if (meths->validate_method) | |
| 1463 { | |
| 1464 Lisp_Object retval; | |
| 1465 | |
| 1466 if (ERRB_EQ (errb, ERROR_ME)) | |
| 1467 { | |
| 1468 (meths->validate_method) (instantiator); | |
| 1469 retval = Qt; | |
| 1470 } | |
| 1471 else | |
| 1472 { | |
| 1473 Lisp_Object opaque = make_opaque_ptr ((void *) | |
| 1474 meths->validate_method); | |
| 1475 struct gcpro gcpro1; | |
| 1476 | |
| 1477 GCPRO1 (opaque); | |
| 1478 retval = call_with_suspended_errors | |
| 1479 ((lisp_fn_t) call_validate_method, | |
| 1480 Qnil, Qspecifier, errb, 2, opaque, instantiator); | |
| 1481 | |
| 1482 free_opaque_ptr (opaque); | |
| 1483 UNGCPRO; | |
| 1484 } | |
| 1485 | |
| 1486 return retval; | |
| 1487 } | |
| 1488 return Qt; | |
| 1489 } | |
| 1490 | |
| 1491 DEFUN ("check-valid-instantiator", Fcheck_valid_instantiator, 2, 2, 0, /* | |
| 1492 Signal an error if INSTANTIATOR is invalid for SPECIFIER-TYPE. | |
| 1493 */ | |
| 1494 (instantiator, specifier_type)) | |
| 1495 { | |
| 1496 struct specifier_methods *meths = decode_specifier_type (specifier_type, | |
| 1497 ERROR_ME); | |
| 1498 | |
| 1499 return check_valid_instantiator (instantiator, meths, ERROR_ME); | |
| 1500 } | |
| 1501 | |
| 1502 DEFUN ("valid-instantiator-p", Fvalid_instantiator_p, 2, 2, 0, /* | |
| 1503 Return non-nil if INSTANTIATOR is valid for SPECIFIER-TYPE. | |
| 1504 */ | |
| 1505 (instantiator, specifier_type)) | |
| 1506 { | |
| 1507 struct specifier_methods *meths = decode_specifier_type (specifier_type, | |
| 1508 ERROR_ME); | |
| 1509 | |
| 1510 return check_valid_instantiator (instantiator, meths, ERROR_ME_NOT); | |
| 1511 } | |
| 1512 | |
| 1513 static Lisp_Object | |
| 1514 check_valid_inst_list (Lisp_Object inst_list, struct specifier_methods *meths, | |
| 578 | 1515 Error_Behavior errb) |
| 428 | 1516 { |
| 2159 | 1517 EXTERNAL_LIST_LOOP_2 (inst_pair, inst_list) |
| 428 | 1518 { |
| 2159 | 1519 Lisp_Object tag_set; |
| 1520 | |
| 1521 if (!CONSP (inst_pair)) | |
| 428 | 1522 { |
| 563 | 1523 maybe_sferror ( |
| 3659 | 1524 "Invalid instantiator pair", inst_pair, |
| 1525 Qspecifier, errb); | |
| 428 | 1526 return Qnil; |
| 1527 } | |
| 1528 if (NILP (Fvalid_specifier_tag_set_p (tag_set = XCAR (inst_pair)))) | |
| 1529 { | |
| 563 | 1530 maybe_invalid_argument ( |
| 3659 | 1531 "Invalid specifier tag", tag_set, |
| 1532 Qspecifier, errb); | |
| 428 | 1533 return Qnil; |
| 1534 } | |
| 1535 | |
| 1536 if (NILP (check_valid_instantiator (XCDR (inst_pair), meths, errb))) | |
| 1537 return Qnil; | |
| 1538 } | |
| 1539 | |
| 1540 return Qt; | |
| 1541 } | |
| 1542 | |
| 1543 DEFUN ("check-valid-inst-list", Fcheck_valid_inst_list, 2, 2, 0, /* | |
| 1544 Signal an error if INST-LIST is invalid for specifier type TYPE. | |
| 1545 */ | |
| 1546 (inst_list, type)) | |
| 1547 { | |
| 1548 struct specifier_methods *meths = decode_specifier_type (type, ERROR_ME); | |
| 1549 | |
| 1550 return check_valid_inst_list (inst_list, meths, ERROR_ME); | |
| 1551 } | |
| 1552 | |
| 1553 DEFUN ("valid-inst-list-p", Fvalid_inst_list_p, 2, 2, 0, /* | |
| 1554 Return non-nil if INST-LIST is valid for specifier type TYPE. | |
| 1555 */ | |
| 1556 (inst_list, type)) | |
| 1557 { | |
| 1558 struct specifier_methods *meths = decode_specifier_type (type, ERROR_ME); | |
| 1559 | |
| 1560 return check_valid_inst_list (inst_list, meths, ERROR_ME_NOT); | |
| 1561 } | |
| 1562 | |
| 1563 static Lisp_Object | |
| 1564 check_valid_spec_list (Lisp_Object spec_list, struct specifier_methods *meths, | |
| 578 | 1565 Error_Behavior errb) |
| 428 | 1566 { |
| 2159 | 1567 EXTERNAL_LIST_LOOP_2 (spec, spec_list) |
| 428 | 1568 { |
| 2159 | 1569 Lisp_Object locale; |
| 1570 if (!CONSP (spec)) | |
| 428 | 1571 { |
| 563 | 1572 maybe_sferror ( |
| 3659 | 1573 "Invalid specification list", spec_list, |
| 1574 Qspecifier, errb); | |
| 428 | 1575 return Qnil; |
| 1576 } | |
| 1577 if (NILP (Fvalid_specifier_locale_p (locale = XCAR (spec)))) | |
| 1578 { | |
| 563 | 1579 maybe_invalid_argument ( |
| 3659 | 1580 "Invalid specifier locale", locale, |
| 1581 Qspecifier, errb); | |
| 428 | 1582 return Qnil; |
| 1583 } | |
| 1584 | |
| 1585 if (NILP (check_valid_inst_list (XCDR (spec), meths, errb))) | |
| 1586 return Qnil; | |
| 1587 } | |
| 1588 | |
| 1589 return Qt; | |
| 1590 } | |
| 1591 | |
| 1592 DEFUN ("check-valid-spec-list", Fcheck_valid_spec_list, 2, 2, 0, /* | |
| 1593 Signal an error if SPEC-LIST is invalid for specifier type TYPE. | |
| 1594 */ | |
| 1595 (spec_list, type)) | |
| 1596 { | |
| 1597 struct specifier_methods *meths = decode_specifier_type (type, ERROR_ME); | |
| 1598 | |
| 1599 return check_valid_spec_list (spec_list, meths, ERROR_ME); | |
| 1600 } | |
| 1601 | |
| 1602 DEFUN ("valid-spec-list-p", Fvalid_spec_list_p, 2, 2, 0, /* | |
| 1603 Return non-nil if SPEC-LIST is valid for specifier type TYPE. | |
| 1604 */ | |
| 1605 (spec_list, type)) | |
| 1606 { | |
| 1607 struct specifier_methods *meths = decode_specifier_type (type, ERROR_ME); | |
| 1608 | |
| 1609 return check_valid_spec_list (spec_list, meths, ERROR_ME_NOT); | |
| 1610 } | |
| 1611 | |
| 1612 enum spec_add_meth | |
| 1613 decode_how_to_add_specification (Lisp_Object how_to_add) | |
| 1614 { | |
| 1615 if (NILP (how_to_add) || EQ (Qremove_tag_set_prepend, how_to_add)) | |
| 1616 return SPEC_REMOVE_TAG_SET_PREPEND; | |
| 1617 if (EQ (Qremove_tag_set_append, how_to_add)) | |
| 1618 return SPEC_REMOVE_TAG_SET_APPEND; | |
| 1619 if (EQ (Qappend, how_to_add)) | |
| 1620 return SPEC_APPEND; | |
| 1621 if (EQ (Qprepend, how_to_add)) | |
| 1622 return SPEC_PREPEND; | |
| 1623 if (EQ (Qremove_locale, how_to_add)) | |
| 1624 return SPEC_REMOVE_LOCALE; | |
| 1625 if (EQ (Qremove_locale_type, how_to_add)) | |
| 1626 return SPEC_REMOVE_LOCALE_TYPE; | |
| 1627 if (EQ (Qremove_all, how_to_add)) | |
| 1628 return SPEC_REMOVE_ALL; | |
| 1629 | |
| 563 | 1630 invalid_constant ("Invalid `how-to-add' flag", how_to_add); |
| 428 | 1631 |
| 1204 | 1632 RETURN_NOT_REACHED (SPEC_PREPEND); |
| 428 | 1633 } |
| 1634 | |
| 1635 /* Given a specifier object SPEC, return bodily specifier if SPEC is a | |
| 1636 ghost specifier, otherwise return the object itself | |
| 1637 */ | |
| 1638 static Lisp_Object | |
| 1639 bodily_specifier (Lisp_Object spec) | |
| 1640 { | |
| 1641 return (GHOST_SPECIFIER_P (XSPECIFIER (spec)) | |
| 5198 | 1642 ? XSPECIFIER (spec)->magic_parent : spec); |
| 428 | 1643 } |
| 1644 | |
| 1645 /* Signal error if (specifier SPEC is read-only. | |
| 1646 Read only are ghost specifiers unless Vunlock_ghost_specifiers is | |
| 1647 non-nil. All other specifiers are read-write. | |
| 1648 */ | |
| 1649 static void | |
| 1650 check_modifiable_specifier (Lisp_Object spec) | |
| 1651 { | |
| 1652 if (NILP (Vunlock_ghost_specifiers) | |
| 1653 && GHOST_SPECIFIER_P (XSPECIFIER (spec))) | |
| 563 | 1654 signal_error (Qsetting_constant, |
| 1655 "Attempt to modify read-only specifier", | |
| 1656 spec); | |
| 428 | 1657 } |
| 1658 | |
| 1659 int | |
| 1660 unlock_ghost_specifiers_protected (void) | |
| 1661 { | |
| 853 | 1662 return internal_bind_lisp_object (&Vunlock_ghost_specifiers, Qt); |
| 428 | 1663 } |
| 1664 | |
| 1665 /* This gets hit so much that the function call overhead had a | |
| 1666 measurable impact (according to Quantify). #### We should figure | |
| 1667 out the frequency with which this is called with the various types | |
| 1668 and reorder the check accordingly. */ | |
| 1669 #define SPECIFIER_GET_SPEC_LIST(specifier, type) \ | |
| 3659 | 1670 (type == LOCALE_GLOBAL ? &(XSPECIFIER (specifier)->global_specs) : \ |
| 1671 type == LOCALE_DEVICE ? &(XSPECIFIER (specifier)->device_specs) : \ | |
| 1672 type == LOCALE_FRAME ? &(XSPECIFIER (specifier)->frame_specs) : \ | |
| 1673 type == LOCALE_WINDOW ? &(XWEAK_LIST_LIST \ | |
| 1674 (XSPECIFIER (specifier)->window_specs)) : \ | |
| 1675 type == LOCALE_BUFFER ? &(XSPECIFIER (specifier)->buffer_specs) : \ | |
| 1676 0) | |
| 428 | 1677 |
| 1678 static Lisp_Object * | |
| 1679 specifier_get_inst_list (Lisp_Object specifier, Lisp_Object locale, | |
| 1680 enum spec_locale_type type) | |
| 1681 { | |
| 1682 Lisp_Object *spec_list = SPECIFIER_GET_SPEC_LIST (specifier, type); | |
| 1683 Lisp_Object specification; | |
| 1684 | |
| 1685 if (type == LOCALE_GLOBAL) | |
| 1686 return spec_list; | |
| 1687 /* Calling assq_no_quit when it is just going to return nil anyhow | |
| 1688 is extremely expensive. So sayeth Quantify. */ | |
| 1689 if (!CONSP (*spec_list)) | |
| 1690 return 0; | |
| 1691 specification = assq_no_quit (locale, *spec_list); | |
| 1692 if (NILP (specification)) | |
| 1693 return 0; | |
| 1694 return &XCDR (specification); | |
| 1695 } | |
| 1696 | |
| 1697 /* For the given INST_LIST, return a new INST_LIST containing all elements | |
| 1698 where TAG-SET matches the element's tag set. EXACT_P indicates whether | |
| 1699 the match must be exact (as opposed to a subset). SHORT_P indicates | |
| 1700 that the short form (for `specifier-specs') should be returned if | |
| 1701 possible. If COPY_TREE_P, `copy-tree' is used to ensure that no | |
| 1702 elements of the new list are shared with the initial list. | |
| 1703 */ | |
| 1704 | |
| 1705 static Lisp_Object | |
| 1706 specifier_process_inst_list (Lisp_Object inst_list, | |
| 1707 Lisp_Object tag_set, int exact_p, | |
| 1708 int short_p, int copy_tree_p) | |
| 1709 { | |
| 1710 Lisp_Object retval = Qnil; | |
| 1711 Lisp_Object rest; | |
| 1712 struct gcpro gcpro1; | |
| 1713 | |
| 1714 GCPRO1 (retval); | |
| 1715 LIST_LOOP (rest, inst_list) | |
| 1716 { | |
| 1717 Lisp_Object tagged_inst = XCAR (rest); | |
| 1718 Lisp_Object tagged_inst_tag = XCAR (tagged_inst); | |
| 1719 if (tag_sets_match_p (tag_set, tagged_inst_tag, exact_p)) | |
| 1720 { | |
| 1721 if (short_p && NILP (tagged_inst_tag)) | |
| 1722 retval = Fcons (copy_tree_p ? | |
| 1723 Fcopy_tree (XCDR (tagged_inst), Qt) : | |
| 1724 XCDR (tagged_inst), | |
| 1725 retval); | |
| 1726 else | |
| 1727 retval = Fcons (copy_tree_p ? Fcopy_tree (tagged_inst, Qt) : | |
| 1728 tagged_inst, retval); | |
| 1729 } | |
| 1730 } | |
| 1731 retval = Fnreverse (retval); | |
| 1732 UNGCPRO; | |
| 1733 /* If there is a single instantiator and the short form is | |
| 1734 requested, return just the instantiator (rather than a one-element | |
| 1735 list of it) unless it is nil (so that it can be distinguished from | |
| 1736 no instantiators at all). */ | |
| 1737 if (short_p && CONSP (retval) && !NILP (XCAR (retval)) && | |
| 1738 NILP (XCDR (retval))) | |
| 1739 return XCAR (retval); | |
| 1740 else | |
| 1741 return retval; | |
| 1742 } | |
| 1743 | |
| 1744 static Lisp_Object | |
| 1745 specifier_get_external_inst_list (Lisp_Object specifier, Lisp_Object locale, | |
| 1746 enum spec_locale_type type, | |
| 1747 Lisp_Object tag_set, int exact_p, | |
| 1748 int short_p, int copy_tree_p) | |
| 1749 { | |
| 1750 Lisp_Object *inst_list = specifier_get_inst_list (specifier, locale, | |
| 1751 type); | |
| 1752 if (!inst_list || NILP (*inst_list)) | |
| 1753 { | |
| 2953 | 1754 /* nil for *inst_list should only occur in `global' */ |
| 428 | 1755 assert (!inst_list || EQ (locale, Qglobal)); |
| 1756 return Qnil; | |
| 1757 } | |
| 1758 | |
| 1759 return specifier_process_inst_list (*inst_list, tag_set, exact_p, | |
| 1760 short_p, copy_tree_p); | |
| 1761 } | |
| 1762 | |
| 1763 static Lisp_Object | |
| 1764 specifier_get_external_spec_list (Lisp_Object specifier, | |
| 1765 enum spec_locale_type type, | |
| 1766 Lisp_Object tag_set, int exact_p) | |
| 1767 { | |
| 1768 Lisp_Object *spec_list = SPECIFIER_GET_SPEC_LIST (specifier, type); | |
| 1769 Lisp_Object retval = Qnil; | |
| 1770 Lisp_Object rest; | |
| 1771 struct gcpro gcpro1; | |
| 1772 | |
| 1773 assert (type != LOCALE_GLOBAL); | |
| 1774 /* We're about to let stuff go external; make sure there aren't | |
| 1775 any dead objects */ | |
| 1776 *spec_list = cleanup_assoc_list (*spec_list); | |
| 1777 | |
| 1778 GCPRO1 (retval); | |
| 1779 LIST_LOOP (rest, *spec_list) | |
| 1780 { | |
| 1781 Lisp_Object spec = XCAR (rest); | |
| 1782 Lisp_Object inst_list = | |
| 1783 specifier_process_inst_list (XCDR (spec), tag_set, exact_p, 0, 1); | |
| 1784 if (!NILP (inst_list)) | |
| 1785 retval = Fcons (Fcons (XCAR (spec), inst_list), retval); | |
| 1786 } | |
| 1787 RETURN_UNGCPRO (Fnreverse (retval)); | |
| 1788 } | |
| 1789 | |
| 1790 static Lisp_Object * | |
| 1791 specifier_new_spec (Lisp_Object specifier, Lisp_Object locale, | |
| 1792 enum spec_locale_type type) | |
| 1793 { | |
| 1794 Lisp_Object *spec_list = SPECIFIER_GET_SPEC_LIST (specifier, type); | |
| 1795 Lisp_Object new_spec = Fcons (locale, Qnil); | |
| 1796 assert (type != LOCALE_GLOBAL); | |
| 1797 *spec_list = Fcons (new_spec, *spec_list); | |
| 1798 return &XCDR (new_spec); | |
| 1799 } | |
| 1800 | |
| 1801 /* For the given INST_LIST, return a new list comprised of elements | |
| 1802 where TAG_SET does not match the element's tag set. This operation | |
| 1803 is destructive. */ | |
| 1804 | |
| 1805 static Lisp_Object | |
| 1806 specifier_process_remove_inst_list (Lisp_Object inst_list, | |
| 1807 Lisp_Object tag_set, int exact_p, | |
| 1808 int *was_removed) | |
| 1809 { | |
| 1810 Lisp_Object prev = Qnil, rest; | |
| 1811 | |
| 1812 *was_removed = 0; | |
| 1813 | |
| 1814 LIST_LOOP (rest, inst_list) | |
| 1815 { | |
| 1816 if (tag_sets_match_p (tag_set, XCAR (XCAR (rest)), exact_p)) | |
| 1817 { | |
| 1818 /* time to remove. */ | |
| 1819 *was_removed = 1; | |
| 1820 if (NILP (prev)) | |
| 1821 inst_list = XCDR (rest); | |
| 1822 else | |
| 1823 XCDR (prev) = XCDR (rest); | |
| 1824 } | |
| 1825 else | |
| 1826 prev = rest; | |
| 1827 } | |
| 1828 | |
| 1829 return inst_list; | |
| 1830 } | |
| 1831 | |
| 1832 static void | |
| 1833 specifier_remove_spec (Lisp_Object specifier, Lisp_Object locale, | |
| 1834 enum spec_locale_type type, | |
| 1835 Lisp_Object tag_set, int exact_p) | |
| 1836 { | |
| 1837 Lisp_Object *spec_list = SPECIFIER_GET_SPEC_LIST (specifier, type); | |
| 1838 Lisp_Object assoc; | |
| 1839 int was_removed; | |
| 1840 | |
| 1841 if (type == LOCALE_GLOBAL) | |
| 1842 *spec_list = specifier_process_remove_inst_list (*spec_list, tag_set, | |
| 1843 exact_p, &was_removed); | |
| 1844 else | |
| 1845 { | |
| 1846 assoc = assq_no_quit (locale, *spec_list); | |
| 1847 if (NILP (assoc)) | |
| 1848 /* this locale is not found. */ | |
| 1849 return; | |
| 1850 XCDR (assoc) = specifier_process_remove_inst_list (XCDR (assoc), | |
| 1851 tag_set, exact_p, | |
| 1852 &was_removed); | |
| 1853 if (NILP (XCDR (assoc))) | |
| 1854 /* no inst-pairs left; remove this locale entirely. */ | |
| 1855 *spec_list = remassq_no_quit (locale, *spec_list); | |
| 1856 } | |
| 1857 | |
| 1858 if (was_removed) | |
| 1859 MAYBE_SPECMETH (XSPECIFIER (specifier), after_change, | |
| 1860 (bodily_specifier (specifier), locale)); | |
| 1861 } | |
| 1862 | |
| 1863 static void | |
| 1864 specifier_remove_locale_type (Lisp_Object specifier, | |
| 1865 enum spec_locale_type type, | |
| 1866 Lisp_Object tag_set, int exact_p) | |
| 1867 { | |
| 1868 Lisp_Object *spec_list = SPECIFIER_GET_SPEC_LIST (specifier, type); | |
| 1869 Lisp_Object prev = Qnil, rest; | |
| 1870 | |
| 1871 assert (type != LOCALE_GLOBAL); | |
| 1872 LIST_LOOP (rest, *spec_list) | |
| 1873 { | |
| 1874 int was_removed; | |
| 1875 int remove_spec = 0; | |
| 1876 Lisp_Object spec = XCAR (rest); | |
| 1877 | |
| 1878 /* There may be dead objects floating around */ | |
| 1879 /* remember, dead windows can become alive again. */ | |
| 1880 if (!WINDOWP (XCAR (spec)) && object_dead_p (XCAR (spec))) | |
| 1881 { | |
| 1882 remove_spec = 1; | |
| 1883 was_removed = 0; | |
| 1884 } | |
| 1885 else | |
| 1886 { | |
| 1887 XCDR (spec) = specifier_process_remove_inst_list (XCDR (spec), | |
| 1888 tag_set, exact_p, | |
| 1889 &was_removed); | |
| 1890 if (NILP (XCDR (spec))) | |
| 1891 remove_spec = 1; | |
| 1892 } | |
| 1893 | |
| 1894 if (remove_spec) | |
| 1895 { | |
| 1896 if (NILP (prev)) | |
| 1897 *spec_list = XCDR (rest); | |
| 1898 else | |
| 1899 XCDR (prev) = XCDR (rest); | |
| 1900 } | |
| 1901 else | |
| 1902 prev = rest; | |
| 1903 | |
| 1904 if (was_removed) | |
| 1905 MAYBE_SPECMETH (XSPECIFIER (specifier), after_change, | |
| 1906 (bodily_specifier (specifier), XCAR (spec))); | |
| 1907 } | |
| 1908 } | |
| 1909 | |
| 1910 /* NEW_LIST is going to be added to INST_LIST, with add method ADD_METH. | |
| 1911 Frob INST_LIST according to ADD_METH. No need to call an after-change | |
| 1912 function; the calling function will do this. Return either SPEC_PREPEND | |
| 1913 or SPEC_APPEND, indicating whether to prepend or append the NEW_LIST. */ | |
| 1914 | |
| 1915 static enum spec_add_meth | |
| 1916 handle_multiple_add_insts (Lisp_Object *inst_list, | |
| 1917 Lisp_Object new_list, | |
| 1918 enum spec_add_meth add_meth) | |
| 1919 { | |
| 1920 switch (add_meth) | |
| 1921 { | |
| 1922 case SPEC_REMOVE_TAG_SET_APPEND: | |
| 1923 add_meth = SPEC_APPEND; | |
| 1924 goto remove_tag_set; | |
| 1925 case SPEC_REMOVE_TAG_SET_PREPEND: | |
| 1926 add_meth = SPEC_PREPEND; | |
| 1927 remove_tag_set: | |
| 1928 { | |
| 1929 Lisp_Object rest; | |
| 1930 | |
| 1931 LIST_LOOP (rest, new_list) | |
| 1932 { | |
| 1933 Lisp_Object canontag = canonicalize_tag_set (XCAR (XCAR (rest))); | |
| 1934 struct gcpro gcpro1; | |
| 1935 | |
| 1936 GCPRO1 (canontag); | |
| 1937 /* pull out all elements from the existing list with the | |
| 1938 same tag as any tags in NEW_LIST. */ | |
| 1939 *inst_list = remassoc_no_quit (canontag, *inst_list); | |
| 1940 UNGCPRO; | |
| 1941 } | |
| 1942 } | |
| 1943 return add_meth; | |
| 1944 case SPEC_REMOVE_LOCALE: | |
| 1945 *inst_list = Qnil; | |
| 1946 return SPEC_PREPEND; | |
| 1947 case SPEC_APPEND: | |
| 1948 return add_meth; | |
| 1949 default: | |
| 1950 return SPEC_PREPEND; | |
| 1951 } | |
| 1952 } | |
| 1953 | |
| 1954 /* Given a LOCALE and INST_LIST that is going to be added to SPECIFIER, | |
| 1955 copy, canonicalize, and call the going_to_add methods as necessary | |
| 1956 to produce a new list that is the one that really will be added | |
| 1957 to the specifier. */ | |
| 1958 | |
| 1959 static Lisp_Object | |
| 1960 build_up_processed_list (Lisp_Object specifier, Lisp_Object locale, | |
| 1961 Lisp_Object inst_list) | |
| 1962 { | |
| 1963 /* The return value of this function must be GCPRO'd. */ | |
| 1964 Lisp_Object rest, list_to_build_up = Qnil; | |
| 440 | 1965 Lisp_Specifier *sp = XSPECIFIER (specifier); |
| 428 | 1966 struct gcpro gcpro1; |
| 1967 | |
| 1968 GCPRO1 (list_to_build_up); | |
| 1969 LIST_LOOP (rest, inst_list) | |
| 1970 { | |
| 1971 Lisp_Object tag_set = XCAR (XCAR (rest)); | |
| 1972 Lisp_Object sub_inst_list = Qnil; | |
| 434 | 1973 Lisp_Object instantiator; |
| 428 | 1974 struct gcpro ngcpro1, ngcpro2; |
| 1975 | |
| 434 | 1976 if (HAS_SPECMETH_P (sp, copy_instantiator)) |
| 1977 instantiator = SPECMETH (sp, copy_instantiator, | |
| 1978 (XCDR (XCAR (rest)))); | |
| 1979 else | |
| 1980 instantiator = Fcopy_tree (XCDR (XCAR (rest)), Qt); | |
| 1981 | |
| 428 | 1982 NGCPRO2 (instantiator, sub_inst_list); |
| 1983 /* call the will-add method; it may GC */ | |
| 1984 sub_inst_list = HAS_SPECMETH_P (sp, going_to_add) ? | |
| 1985 SPECMETH (sp, going_to_add, | |
| 1986 (bodily_specifier (specifier), locale, | |
| 1987 tag_set, instantiator)) : | |
| 1988 Qt; | |
| 1989 if (EQ (sub_inst_list, Qt)) | |
| 1990 /* no change here. */ | |
| 1991 sub_inst_list = list1 (Fcons (canonicalize_tag_set (tag_set), | |
| 1992 instantiator)); | |
| 1993 else | |
| 1994 { | |
| 1995 /* now canonicalize all the tag sets in the new objects */ | |
| 1996 Lisp_Object rest2; | |
| 1997 LIST_LOOP (rest2, sub_inst_list) | |
| 1998 XCAR (XCAR (rest2)) = canonicalize_tag_set (XCAR (XCAR (rest2))); | |
| 1999 } | |
| 2000 | |
| 2001 list_to_build_up = nconc2 (sub_inst_list, list_to_build_up); | |
| 2002 NUNGCPRO; | |
| 2003 } | |
| 2004 | |
| 2005 RETURN_UNGCPRO (Fnreverse (list_to_build_up)); | |
| 2006 } | |
| 2007 | |
| 2008 /* Add a specification (locale and instantiator list) to a specifier. | |
| 2009 ADD_METH specifies what to do with existing specifications in the | |
| 2010 specifier, and is an enum that corresponds to the values in | |
| 2011 `add-spec-to-specifier'. The calling routine is responsible for | |
| 2012 validating LOCALE and INST-LIST, but the tag-sets in INST-LIST | |
| 2013 do not need to be canonicalized. */ | |
| 2014 | |
| 3659 | 2015 /* #### I really need to rethink the after-change |
| 2016 functions to make them easier to use and more efficient. */ | |
| 428 | 2017 |
| 2018 static void | |
| 2019 specifier_add_spec (Lisp_Object specifier, Lisp_Object locale, | |
| 2020 Lisp_Object inst_list, enum spec_add_meth add_meth) | |
| 2021 { | |
| 440 | 2022 Lisp_Specifier *sp = XSPECIFIER (specifier); |
| 428 | 2023 enum spec_locale_type type = locale_type_from_locale (locale); |
| 2024 Lisp_Object *orig_inst_list, tem; | |
| 2025 Lisp_Object list_to_build_up = Qnil; | |
| 2026 struct gcpro gcpro1; | |
| 2027 | |
| 1015 | 2028 if (NILP (inst_list)) |
| 2029 return; | |
| 2030 | |
| 428 | 2031 GCPRO1 (list_to_build_up); |
| 2032 list_to_build_up = build_up_processed_list (specifier, locale, inst_list); | |
| 2033 /* Now handle REMOVE_LOCALE_TYPE and REMOVE_ALL. These are the | |
| 2034 add-meth types that affect locales other than this one. */ | |
| 2035 if (add_meth == SPEC_REMOVE_LOCALE_TYPE) | |
| 2036 specifier_remove_locale_type (specifier, type, Qnil, 0); | |
| 2037 else if (add_meth == SPEC_REMOVE_ALL) | |
| 2038 { | |
| 2039 specifier_remove_locale_type (specifier, LOCALE_BUFFER, Qnil, 0); | |
| 2040 specifier_remove_locale_type (specifier, LOCALE_WINDOW, Qnil, 0); | |
| 2041 specifier_remove_locale_type (specifier, LOCALE_FRAME, Qnil, 0); | |
| 2042 specifier_remove_locale_type (specifier, LOCALE_DEVICE, Qnil, 0); | |
| 2043 specifier_remove_spec (specifier, Qglobal, LOCALE_GLOBAL, Qnil, 0); | |
| 2044 } | |
| 2045 | |
| 2046 orig_inst_list = specifier_get_inst_list (specifier, locale, type); | |
| 2047 if (!orig_inst_list) | |
| 2048 orig_inst_list = specifier_new_spec (specifier, locale, type); | |
| 2049 add_meth = handle_multiple_add_insts (orig_inst_list, list_to_build_up, | |
| 2050 add_meth); | |
| 2051 | |
| 2052 if (add_meth == SPEC_PREPEND) | |
| 2053 tem = nconc2 (list_to_build_up, *orig_inst_list); | |
| 2054 else if (add_meth == SPEC_APPEND) | |
| 2055 tem = nconc2 (*orig_inst_list, list_to_build_up); | |
| 2056 else | |
| 442 | 2057 { |
| 2500 | 2058 ABORT (); |
| 442 | 2059 tem = Qnil; |
| 2060 } | |
| 428 | 2061 |
| 2062 *orig_inst_list = tem; | |
| 2063 | |
| 2064 UNGCPRO; | |
| 2065 | |
| 2066 /* call the after-change method */ | |
| 2067 MAYBE_SPECMETH (sp, after_change, | |
| 2068 (bodily_specifier (specifier), locale)); | |
| 2069 } | |
| 2070 | |
| 2071 static void | |
| 2072 specifier_copy_spec (Lisp_Object specifier, Lisp_Object dest, | |
| 2073 Lisp_Object locale, enum spec_locale_type type, | |
| 2074 Lisp_Object tag_set, int exact_p, | |
| 2075 enum spec_add_meth add_meth) | |
| 2076 { | |
| 2077 Lisp_Object inst_list = | |
| 2078 specifier_get_external_inst_list (specifier, locale, type, tag_set, | |
| 2079 exact_p, 0, 0); | |
| 2080 specifier_add_spec (dest, locale, inst_list, add_meth); | |
| 2081 } | |
| 2082 | |
| 2083 static void | |
| 2084 specifier_copy_locale_type (Lisp_Object specifier, Lisp_Object dest, | |
| 2085 enum spec_locale_type type, | |
| 2086 Lisp_Object tag_set, int exact_p, | |
| 2087 enum spec_add_meth add_meth) | |
| 2088 { | |
| 2089 Lisp_Object *src_list = SPECIFIER_GET_SPEC_LIST (specifier, type); | |
| 2090 Lisp_Object rest; | |
| 2091 | |
| 2092 /* This algorithm is O(n^2) in running time. | |
| 2093 It's certainly possible to implement an O(n log n) algorithm, | |
| 2094 but I doubt there's any need to. */ | |
| 2095 | |
| 2096 LIST_LOOP (rest, *src_list) | |
| 2097 { | |
| 2098 Lisp_Object spec = XCAR (rest); | |
| 2099 /* There may be dead objects floating around */ | |
| 2100 /* remember, dead windows can become alive again. */ | |
| 2101 if (WINDOWP (XCAR (spec)) || !object_dead_p (XCAR (spec))) | |
| 2102 specifier_add_spec | |
| 2103 (dest, XCAR (spec), | |
| 2104 specifier_process_inst_list (XCDR (spec), tag_set, exact_p, 0, 0), | |
| 2105 add_meth); | |
| 2106 } | |
| 2107 } | |
| 2108 | |
| 2109 /* map MAPFUN over the locales in SPECIFIER that are given in LOCALE. | |
| 2110 CLOSURE is passed unchanged to MAPFUN. LOCALE can be one of | |
| 2111 | |
| 3659 | 2112 -- nil (same as `all') |
| 2113 -- a single locale, locale type, or `all' | |
| 2114 -- a list of locales, locale types, and/or `all' | |
| 2953 | 2115 |
| 2116 MAPFUN is called for each locale and locale type given; for `all', | |
| 2117 it is called for the locale `global' and for the four possible | |
| 428 | 2118 locale types. In each invocation, either LOCALE will be a locale |
| 2119 and LOCALE_TYPE will be the locale type of this locale, | |
| 2120 or LOCALE will be nil and LOCALE_TYPE will be a locale type. | |
| 2121 If MAPFUN ever returns non-zero, the mapping is halted and the | |
| 2122 value returned is returned from map_specifier(). Otherwise, the | |
| 2123 mapping proceeds to the end and map_specifier() returns 0. | |
| 3659 | 2124 */ |
| 428 | 2125 |
| 2126 static int | |
| 2127 map_specifier (Lisp_Object specifier, Lisp_Object locale, | |
| 2128 int (*mapfun) (Lisp_Object specifier, | |
| 2129 Lisp_Object locale, | |
| 2130 enum spec_locale_type locale_type, | |
| 2131 Lisp_Object tag_set, | |
| 2132 int exact_p, | |
| 2133 void *closure), | |
| 2134 Lisp_Object tag_set, Lisp_Object exact_p, | |
| 2135 void *closure) | |
| 2136 { | |
| 2137 int retval = 0; | |
| 2138 Lisp_Object rest; | |
| 2139 struct gcpro gcpro1, gcpro2; | |
| 2140 | |
| 2141 GCPRO2 (tag_set, locale); | |
| 2142 locale = decode_locale_list (locale); | |
| 2143 tag_set = decode_specifier_tag_set (tag_set); | |
| 2144 tag_set = canonicalize_tag_set (tag_set); | |
| 2145 | |
| 2146 LIST_LOOP (rest, locale) | |
| 2147 { | |
| 2148 Lisp_Object theloc = XCAR (rest); | |
| 2149 if (!NILP (Fvalid_specifier_locale_p (theloc))) | |
| 2150 { | |
| 2151 retval = (*mapfun) (specifier, theloc, | |
| 2152 locale_type_from_locale (theloc), | |
| 2153 tag_set, !NILP (exact_p), closure); | |
| 2154 if (retval) | |
| 2155 break; | |
| 2156 } | |
| 2157 else if (!NILP (Fvalid_specifier_locale_type_p (theloc))) | |
| 2158 { | |
| 2159 retval = (*mapfun) (specifier, Qnil, | |
| 2160 decode_locale_type (theloc), tag_set, | |
| 2161 !NILP (exact_p), closure); | |
| 2162 if (retval) | |
| 2163 break; | |
| 2164 } | |
| 2165 else | |
| 2166 { | |
| 2167 assert (EQ (theloc, Qall)); | |
| 2168 retval = (*mapfun) (specifier, Qnil, LOCALE_BUFFER, tag_set, | |
| 2169 !NILP (exact_p), closure); | |
| 2170 if (retval) | |
| 2171 break; | |
| 2172 retval = (*mapfun) (specifier, Qnil, LOCALE_WINDOW, tag_set, | |
| 2173 !NILP (exact_p), closure); | |
| 2174 if (retval) | |
| 2175 break; | |
| 2176 retval = (*mapfun) (specifier, Qnil, LOCALE_FRAME, tag_set, | |
| 2177 !NILP (exact_p), closure); | |
| 2178 if (retval) | |
| 2179 break; | |
| 2180 retval = (*mapfun) (specifier, Qnil, LOCALE_DEVICE, tag_set, | |
| 2181 !NILP (exact_p), closure); | |
| 2182 if (retval) | |
| 2183 break; | |
| 2184 retval = (*mapfun) (specifier, Qglobal, LOCALE_GLOBAL, tag_set, | |
| 2185 !NILP (exact_p), closure); | |
| 2186 if (retval) | |
| 2187 break; | |
| 2188 } | |
| 2189 } | |
| 2190 | |
| 2191 UNGCPRO; | |
| 2192 return retval; | |
| 2193 } | |
| 2194 | |
| 2195 DEFUN ("add-spec-to-specifier", Fadd_spec_to_specifier, 2, 5, 0, /* | |
| 2196 Add a specification to SPECIFIER. | |
| 2197 The specification maps from LOCALE (which should be a window, buffer, | |
| 2953 | 2198 frame, device, or `global', and defaults to `global') to INSTANTIATOR, |
| 428 | 2199 whose allowed values depend on the type of the specifier. Optional |
| 2200 argument TAG-SET limits the instantiator to apply only to the specified | |
| 2201 tag set, which should be a list of tags all of which must match the | |
| 2202 device being instantiated over (tags are a device type, a device class, | |
| 2203 or tags defined with `define-specifier-tag'). Specifying a single | |
| 2204 symbol for TAG-SET is equivalent to specifying a one-element list | |
| 2205 containing that symbol. Optional argument HOW-TO-ADD specifies what to | |
| 2206 do if there are already specifications in the specifier. | |
| 2207 It should be one of | |
| 2208 | |
| 2953 | 2209 `prepend' Put at the beginning of the current list of |
| 428 | 2210 instantiators for LOCALE. |
| 2953 | 2211 `append' Add to the end of the current list of |
| 428 | 2212 instantiators for LOCALE. |
| 2953 | 2213 `remove-tag-set-prepend' (this is the default) |
| 428 | 2214 Remove any existing instantiators whose tag set is |
| 2215 the same as TAG-SET; then put the new instantiator | |
| 2216 at the beginning of the current list. ("Same tag | |
| 2217 set" means that they contain the same elements. | |
| 2218 The order may be different.) | |
| 2953 | 2219 `remove-tag-set-append' |
| 428 | 2220 Remove any existing instantiators whose tag set is |
| 2221 the same as TAG-SET; then put the new instantiator | |
| 2222 at the end of the current list. | |
| 2953 | 2223 `remove-locale' Remove all previous instantiators for this locale |
| 428 | 2224 before adding the new spec. |
| 2953 | 2225 `remove-locale-type' Remove all specifications for all locales of the |
| 428 | 2226 same type as LOCALE (this includes LOCALE itself) |
| 2227 before adding the new spec. | |
| 2953 | 2228 `remove-all' Remove all specifications from the specifier |
| 428 | 2229 before adding the new spec. |
| 2230 | |
| 2231 You can retrieve the specifications for a particular locale or locale type | |
| 2232 with the function `specifier-spec-list' or `specifier-specs'. | |
| 2233 */ | |
| 2234 (specifier, instantiator, locale, tag_set, how_to_add)) | |
| 2235 { | |
| 2236 enum spec_add_meth add_meth; | |
| 2237 Lisp_Object inst_list; | |
| 2238 struct gcpro gcpro1; | |
| 2239 | |
| 2240 CHECK_SPECIFIER (specifier); | |
| 2241 check_modifiable_specifier (specifier); | |
| 2242 | |
| 2243 locale = decode_locale (locale); | |
| 2244 check_valid_instantiator (instantiator, | |
| 2245 decode_specifier_type | |
| 2246 (Fspecifier_type (specifier), ERROR_ME), | |
| 2247 ERROR_ME); | |
| 2248 /* tag_set might be newly-created material, but it's part of inst_list | |
| 2249 so is properly GC-protected. */ | |
| 2250 tag_set = decode_specifier_tag_set (tag_set); | |
| 2251 add_meth = decode_how_to_add_specification (how_to_add); | |
| 2252 | |
| 2253 inst_list = list1 (Fcons (tag_set, instantiator)); | |
| 2254 GCPRO1 (inst_list); | |
| 2255 specifier_add_spec (specifier, locale, inst_list, add_meth); | |
| 2256 recompute_cached_specifier_everywhere (specifier); | |
| 2257 RETURN_UNGCPRO (Qnil); | |
| 2258 } | |
| 2259 | |
| 2260 DEFUN ("add-spec-list-to-specifier", Fadd_spec_list_to_specifier, 2, 3, 0, /* | |
| 444 | 2261 Add SPEC-LIST (a list of specifications) to SPECIFIER. |
| 2262 The format of SPEC-LIST is | |
| 428 | 2263 |
| 2264 ((LOCALE (TAG-SET . INSTANTIATOR) ...) ...) | |
| 2265 | |
| 2266 where | |
| 2953 | 2267 LOCALE := a window, a buffer, a frame, a device, or `global' |
| 428 | 2268 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
|
2269 is a symbol |
| 428 | 2270 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
|
2271 (see `valid-console-type-p'), or a tag defined with |
|
515b91f904c1
Fix specifier inheritance behavior
Didier Verna <didier@xemacs.org>
parents:
3836
diff
changeset
|
2272 `define-specifier-tag' |
| 428 | 2273 INSTANTIATOR := format determined by the type of specifier |
| 2274 | |
| 2275 The pair (TAG-SET . INSTANTIATOR) is called an `inst-pair'. | |
| 2276 A list of inst-pairs is called an `inst-list'. | |
| 2277 The pair (LOCALE . INST-LIST) is called a `specification' or `spec'. | |
| 2278 A spec-list, then, can be viewed as a list of specifications. | |
| 2279 | |
| 2280 HOW-TO-ADD specifies how to combine the new specifications with | |
| 2281 the existing ones, and has the same semantics as for | |
| 2282 `add-spec-to-specifier'. | |
| 2283 | |
| 2284 In many circumstances, the higher-level function `set-specifier' is | |
| 2285 more convenient and should be used instead. | |
| 2286 */ | |
| 2287 (specifier, spec_list, how_to_add)) | |
| 2288 { | |
| 2289 enum spec_add_meth add_meth; | |
| 2290 Lisp_Object rest; | |
| 2291 | |
| 2292 CHECK_SPECIFIER (specifier); | |
| 2293 check_modifiable_specifier (specifier); | |
| 2294 | |
| 2295 check_valid_spec_list (spec_list, | |
| 2296 decode_specifier_type | |
| 2297 (Fspecifier_type (specifier), ERROR_ME), | |
| 2298 ERROR_ME); | |
| 2299 add_meth = decode_how_to_add_specification (how_to_add); | |
| 2300 | |
| 2301 LIST_LOOP (rest, spec_list) | |
| 2302 { | |
| 2303 /* Placating the GCC god. */ | |
| 2304 Lisp_Object specification = XCAR (rest); | |
| 2305 Lisp_Object locale = XCAR (specification); | |
| 2306 Lisp_Object inst_list = XCDR (specification); | |
| 2307 | |
| 2308 specifier_add_spec (specifier, locale, inst_list, add_meth); | |
| 2309 } | |
| 2310 recompute_cached_specifier_everywhere (specifier); | |
| 2311 return Qnil; | |
| 2312 } | |
| 2313 | |
| 2314 void | |
| 2315 add_spec_to_ghost_specifier (Lisp_Object specifier, Lisp_Object instantiator, | |
| 2316 Lisp_Object locale, Lisp_Object tag_set, | |
| 2317 Lisp_Object how_to_add) | |
| 2318 { | |
| 2319 int depth = unlock_ghost_specifiers_protected (); | |
| 5198 | 2320 Fadd_spec_to_specifier (XSPECIFIER (specifier)->fallback, |
| 428 | 2321 instantiator, locale, tag_set, how_to_add); |
| 771 | 2322 unbind_to (depth); |
| 428 | 2323 } |
| 2324 | |
| 2325 struct specifier_spec_list_closure | |
| 2326 { | |
| 2327 Lisp_Object head, tail; | |
| 2328 }; | |
| 2329 | |
| 2330 static int | |
| 2331 specifier_spec_list_mapfun (Lisp_Object specifier, | |
| 2332 Lisp_Object locale, | |
| 2333 enum spec_locale_type locale_type, | |
| 2334 Lisp_Object tag_set, | |
| 2335 int exact_p, | |
| 2336 void *closure) | |
| 2337 { | |
| 2338 struct specifier_spec_list_closure *cl = | |
| 2339 (struct specifier_spec_list_closure *) closure; | |
| 2340 Lisp_Object partial; | |
| 2341 | |
| 2342 if (NILP (locale)) | |
| 2343 partial = specifier_get_external_spec_list (specifier, | |
| 2344 locale_type, | |
| 2345 tag_set, exact_p); | |
| 2346 else | |
| 2347 { | |
| 2348 partial = specifier_get_external_inst_list (specifier, locale, | |
| 2349 locale_type, tag_set, | |
| 2350 exact_p, 0, 1); | |
| 2351 if (!NILP (partial)) | |
| 2352 partial = list1 (Fcons (locale, partial)); | |
| 2353 } | |
| 2354 if (NILP (partial)) | |
| 2355 return 0; | |
| 2356 | |
| 2357 /* tack on the new list */ | |
| 2358 if (NILP (cl->tail)) | |
| 2359 cl->head = cl->tail = partial; | |
| 2360 else | |
| 2361 XCDR (cl->tail) = partial; | |
| 2362 /* find the new tail */ | |
| 2363 while (CONSP (XCDR (cl->tail))) | |
| 2364 cl->tail = XCDR (cl->tail); | |
| 2365 return 0; | |
| 2366 } | |
| 2367 | |
| 2368 /* For the given SPECIFIER create and return a list of all specs | |
| 2369 contained within it, subject to LOCALE. If LOCALE is a locale, only | |
| 2370 specs in that locale will be returned. If LOCALE is a locale type, | |
| 2371 all specs in all locales of that type will be returned. If LOCALE is | |
| 2372 nil, all specs will be returned. This always copies lists and never | |
| 2373 returns the actual lists, because we do not want someone manipulating | |
| 2374 the actual objects. This may cause a slight loss of potential | |
| 2375 functionality but if we were to allow it then a user could manage to | |
| 2376 violate our assertion that the specs contained in the actual | |
| 2377 specifier lists are all valid. */ | |
| 2378 | |
| 2379 DEFUN ("specifier-spec-list", Fspecifier_spec_list, 1, 4, 0, /* | |
| 2380 Return the spec-list of specifications for SPECIFIER in LOCALE. | |
| 2381 | |
| 2382 If LOCALE is a particular locale (a buffer, window, frame, device, | |
| 2953 | 2383 or `global'), a spec-list consisting of the specification for that |
| 428 | 2384 locale will be returned. |
| 2385 | |
| 2953 | 2386 If LOCALE is a locale type (i.e. `buffer', `window', `frame', or `device'), |
| 428 | 2387 a spec-list of the specifications for all locales of that type will be |
| 2388 returned. | |
| 2389 | |
| 2953 | 2390 If LOCALE is nil or `all', a spec-list of all specifications in SPECIFIER |
| 428 | 2391 will be returned. |
| 2392 | |
| 2953 | 2393 LOCALE can also be a list of locales, locale types, and/or `all'; the |
| 428 | 2394 result is as if `specifier-spec-list' were called on each element of the |
| 2395 list and the results concatenated together. | |
| 2396 | |
| 2397 Only instantiators where TAG-SET (a list of zero or more tags) is a | |
| 2398 subset of (or possibly equal to) the instantiator's tag set are returned. | |
| 2399 \(The default value of nil is a subset of all tag sets, so in this case | |
| 2400 no instantiators will be screened out.) If EXACT-P is non-nil, however, | |
| 2401 TAG-SET must be equal to an instantiator's tag set for the instantiator | |
| 2402 to be returned. | |
| 2403 */ | |
| 3659 | 2404 (specifier, locale, tag_set, exact_p)) |
| 428 | 2405 { |
| 2406 struct specifier_spec_list_closure cl; | |
| 2407 struct gcpro gcpro1, gcpro2; | |
| 2408 | |
| 2409 CHECK_SPECIFIER (specifier); | |
| 2410 cl.head = cl.tail = Qnil; | |
| 2411 GCPRO2 (cl.head, cl.tail); | |
| 2412 map_specifier (specifier, locale, specifier_spec_list_mapfun, | |
| 2413 tag_set, exact_p, &cl); | |
| 2414 UNGCPRO; | |
| 2415 return cl.head; | |
| 2416 } | |
| 2417 | |
| 2418 | |
| 2419 DEFUN ("specifier-specs", Fspecifier_specs, 1, 4, 0, /* | |
| 2420 Return the specification(s) for SPECIFIER in LOCALE. | |
| 2421 | |
| 2422 If LOCALE is a single locale or is a list of one element containing a | |
| 2423 single locale, then a "short form" of the instantiators for that locale | |
| 2424 will be returned. Otherwise, this function is identical to | |
| 2425 `specifier-spec-list'. | |
| 2426 | |
| 2427 The "short form" is designed for readability and not for ease of use | |
| 2428 in Lisp programs, and is as follows: | |
| 2429 | |
| 2430 1. If there is only one instantiator, then an inst-pair (i.e. cons of | |
| 2431 tag and instantiator) will be returned; otherwise a list of | |
| 2432 inst-pairs will be returned. | |
| 2953 | 2433 2. For each inst-pair returned, if the instantiator's tag is `any', |
| 428 | 2434 the tag will be removed and the instantiator itself will be returned |
| 2435 instead of the inst-pair. | |
| 2436 3. If there is only one instantiator, its value is nil, and its tag is | |
| 2953 | 2437 `any', a one-element list containing nil will be returned rather |
| 428 | 2438 than just nil, to distinguish this case from there being no |
| 2439 instantiators at all. | |
| 2440 */ | |
| 2441 (specifier, locale, tag_set, exact_p)) | |
| 2442 { | |
| 2443 if (!NILP (Fvalid_specifier_locale_p (locale)) || | |
| 2444 (CONSP (locale) && !NILP (Fvalid_specifier_locale_p (XCAR (locale))) && | |
| 2445 NILP (XCDR (locale)))) | |
| 2446 { | |
| 2447 struct gcpro gcpro1; | |
| 2448 | |
| 2449 CHECK_SPECIFIER (specifier); | |
| 2450 if (CONSP (locale)) | |
| 2451 locale = XCAR (locale); | |
| 2452 GCPRO1 (tag_set); | |
| 2453 tag_set = decode_specifier_tag_set (tag_set); | |
| 2454 tag_set = canonicalize_tag_set (tag_set); | |
| 2455 RETURN_UNGCPRO | |
| 2456 (specifier_get_external_inst_list (specifier, locale, | |
| 2457 locale_type_from_locale (locale), | |
| 2458 tag_set, !NILP (exact_p), 1, 1)); | |
| 2459 } | |
| 2460 else | |
| 2461 return Fspecifier_spec_list (specifier, locale, tag_set, exact_p); | |
| 2462 } | |
| 2463 | |
| 2464 static int | |
| 2465 remove_specifier_mapfun (Lisp_Object specifier, | |
| 2466 Lisp_Object locale, | |
| 2467 enum spec_locale_type locale_type, | |
| 2468 Lisp_Object tag_set, | |
| 2469 int exact_p, | |
| 2286 | 2470 void *UNUSED (closure)) |
| 428 | 2471 { |
| 2472 if (NILP (locale)) | |
| 2473 specifier_remove_locale_type (specifier, locale_type, tag_set, exact_p); | |
| 2474 else | |
| 2475 specifier_remove_spec (specifier, locale, locale_type, tag_set, exact_p); | |
| 2476 return 0; | |
| 2477 } | |
| 2478 | |
| 2479 DEFUN ("remove-specifier", Fremove_specifier, 1, 4, 0, /* | |
| 2480 Remove specification(s) for SPECIFIER. | |
| 2481 | |
| 2482 If LOCALE is a particular locale (a window, buffer, frame, device, | |
| 2953 | 2483 or `global'), the specification for that locale will be removed. |
| 2484 | |
| 2485 If instead, LOCALE is a locale type (i.e. `window', `buffer', `frame', | |
| 2486 or `device'), the specifications for all locales of that type will be | |
| 428 | 2487 removed. |
| 2488 | |
| 2953 | 2489 If LOCALE is nil or `all', all specifications will be removed. |
| 2490 | |
| 2491 LOCALE can also be a list of locales, locale types, and/or `all'; this | |
| 428 | 2492 is equivalent to calling `remove-specifier' for each of the elements |
| 2493 in the list. | |
| 2494 | |
| 2495 Only instantiators where TAG-SET (a list of zero or more tags) is a | |
| 2496 subset of (or possibly equal to) the instantiator's tag set are removed. | |
| 2497 The default value of nil is a subset of all tag sets, so in this case | |
| 2498 no instantiators will be screened out. If EXACT-P is non-nil, however, | |
| 2499 TAG-SET must be equal to an instantiator's tag set for the instantiator | |
| 2500 to be removed. | |
| 2501 */ | |
| 2502 (specifier, locale, tag_set, exact_p)) | |
| 2503 { | |
| 2504 CHECK_SPECIFIER (specifier); | |
| 2505 check_modifiable_specifier (specifier); | |
| 2506 | |
| 2507 map_specifier (specifier, locale, remove_specifier_mapfun, | |
| 2508 tag_set, exact_p, 0); | |
| 2509 recompute_cached_specifier_everywhere (specifier); | |
| 2510 return Qnil; | |
| 2511 } | |
| 2512 | |
| 2513 void | |
| 2514 remove_ghost_specifier (Lisp_Object specifier, Lisp_Object locale, | |
| 2515 Lisp_Object tag_set, Lisp_Object exact_p) | |
| 2516 { | |
| 2517 int depth = unlock_ghost_specifiers_protected (); | |
| 5198 | 2518 Fremove_specifier (XSPECIFIER (specifier)->fallback, |
| 428 | 2519 locale, tag_set, exact_p); |
| 771 | 2520 unbind_to (depth); |
| 428 | 2521 } |
| 2522 | |
| 2523 struct copy_specifier_closure | |
| 2524 { | |
| 2525 Lisp_Object dest; | |
| 2526 enum spec_add_meth add_meth; | |
| 2527 int add_meth_is_nil; | |
| 2528 }; | |
| 2529 | |
| 2530 static int | |
| 2531 copy_specifier_mapfun (Lisp_Object specifier, | |
| 2532 Lisp_Object locale, | |
| 2533 enum spec_locale_type locale_type, | |
| 2534 Lisp_Object tag_set, | |
| 2535 int exact_p, | |
| 2536 void *closure) | |
| 2537 { | |
| 2538 struct copy_specifier_closure *cl = | |
| 2539 (struct copy_specifier_closure *) closure; | |
| 2540 | |
| 2541 if (NILP (locale)) | |
| 2542 specifier_copy_locale_type (specifier, cl->dest, locale_type, | |
| 2543 tag_set, exact_p, | |
| 2544 cl->add_meth_is_nil ? | |
| 2545 SPEC_REMOVE_LOCALE_TYPE : | |
| 2546 cl->add_meth); | |
| 2547 else | |
| 2548 specifier_copy_spec (specifier, cl->dest, locale, locale_type, | |
| 2549 tag_set, exact_p, | |
| 2550 cl->add_meth_is_nil ? SPEC_REMOVE_LOCALE : | |
| 2551 cl->add_meth); | |
| 2552 return 0; | |
| 2553 } | |
| 2554 | |
| 2555 DEFUN ("copy-specifier", Fcopy_specifier, 1, 6, 0, /* | |
| 2556 Copy SPECIFIER to DEST, or create a new one if DEST is nil. | |
| 2557 | |
| 2558 If DEST is nil or omitted, a new specifier will be created and the | |
| 2559 specifications copied into it. Otherwise, the specifications will be | |
| 2560 copied into the existing specifier in DEST. | |
| 2561 | |
| 2953 | 2562 If LOCALE is nil or `all', all specifications will be copied. If LOCALE |
| 428 | 2563 is a particular locale, the specification for that particular locale will |
| 2564 be copied. If LOCALE is a locale type, the specifications for all locales | |
| 2565 of that type will be copied. LOCALE can also be a list of locales, | |
| 2953 | 2566 locale types, and/or `all'; this is equivalent to calling `copy-specifier' |
| 428 | 2567 for each of the elements of the list. See `specifier-spec-list' for more |
| 2568 information about LOCALE. | |
| 2569 | |
| 2570 Only instantiators where TAG-SET (a list of zero or more tags) is a | |
| 2571 subset of (or possibly equal to) the instantiator's tag set are copied. | |
| 2572 The default value of nil is a subset of all tag sets, so in this case | |
| 2573 no instantiators will be screened out. If EXACT-P is non-nil, however, | |
| 2574 TAG-SET must be equal to an instantiator's tag set for the instantiator | |
| 2575 to be copied. | |
| 2576 | |
| 2577 Optional argument HOW-TO-ADD specifies what to do with existing | |
| 2578 specifications in DEST. If nil, then whichever locales or locale types | |
| 2579 are copied will first be completely erased in DEST. Otherwise, it is | |
| 2580 the same as in `add-spec-to-specifier'. | |
| 2581 */ | |
| 2582 (specifier, dest, locale, tag_set, exact_p, how_to_add)) | |
| 2583 { | |
| 2584 struct gcpro gcpro1; | |
| 2585 struct copy_specifier_closure cl; | |
| 2586 | |
| 2587 CHECK_SPECIFIER (specifier); | |
| 2588 if (NILP (how_to_add)) | |
| 2589 cl.add_meth_is_nil = 1; | |
| 2590 else | |
| 2591 cl.add_meth_is_nil = 0; | |
| 2592 cl.add_meth = decode_how_to_add_specification (how_to_add); | |
| 2593 if (NILP (dest)) | |
| 2594 { | |
| 2595 /* #### What about copying the extra data? */ | |
| 2596 dest = make_specifier (XSPECIFIER (specifier)->methods); | |
| 2597 } | |
| 2598 else | |
| 2599 { | |
| 2600 CHECK_SPECIFIER (dest); | |
| 2601 check_modifiable_specifier (dest); | |
| 2602 if (XSPECIFIER (dest)->methods != XSPECIFIER (specifier)->methods) | |
| 3659 | 2603 invalid_argument ("Specifiers not of same type", Qunbound); |
| 428 | 2604 } |
| 2605 | |
| 2606 cl.dest = dest; | |
| 2607 GCPRO1 (dest); | |
| 2608 map_specifier (specifier, locale, copy_specifier_mapfun, | |
| 2609 tag_set, exact_p, &cl); | |
| 2610 UNGCPRO; | |
| 2611 recompute_cached_specifier_everywhere (dest); | |
| 2612 return dest; | |
| 2613 } | |
| 2614 | |
| 2615 | |
| 2616 /************************************************************************/ | |
| 2953 | 2617 /* Instantiation */ |
| 428 | 2618 /************************************************************************/ |
| 2619 | |
| 2620 static Lisp_Object | |
| 2621 call_validate_matchspec_method (Lisp_Object boxed_method, | |
| 2622 Lisp_Object matchspec) | |
| 2623 { | |
| 2624 ((void (*)(Lisp_Object)) get_opaque_ptr (boxed_method)) (matchspec); | |
| 2625 return Qt; | |
| 2626 } | |
| 2627 | |
| 2628 static Lisp_Object | |
| 2629 check_valid_specifier_matchspec (Lisp_Object matchspec, | |
| 2630 struct specifier_methods *meths, | |
| 578 | 2631 Error_Behavior errb) |
| 428 | 2632 { |
| 2633 if (meths->validate_matchspec_method) | |
| 2634 { | |
| 2635 Lisp_Object retval; | |
| 2636 | |
| 2637 if (ERRB_EQ (errb, ERROR_ME)) | |
| 2638 { | |
| 2639 (meths->validate_matchspec_method) (matchspec); | |
| 2640 retval = Qt; | |
| 2641 } | |
| 2642 else | |
| 2643 { | |
| 2644 Lisp_Object opaque = | |
| 2645 make_opaque_ptr ((void *) meths->validate_matchspec_method); | |
| 2646 struct gcpro gcpro1; | |
| 2647 | |
| 2648 GCPRO1 (opaque); | |
| 2649 retval = call_with_suspended_errors | |
| 2650 ((lisp_fn_t) call_validate_matchspec_method, | |
| 2651 Qnil, Qspecifier, errb, 2, opaque, matchspec); | |
| 2652 | |
| 2653 free_opaque_ptr (opaque); | |
| 2654 UNGCPRO; | |
| 2655 } | |
| 2656 | |
| 2657 return retval; | |
| 2658 } | |
| 2659 else | |
| 2660 { | |
| 563 | 2661 maybe_sferror |
| 428 | 2662 ("Matchspecs not allowed for this specifier type", |
| 2663 intern (meths->name), Qspecifier, errb); | |
| 2664 return Qnil; | |
| 2665 } | |
| 2666 } | |
| 2667 | |
| 442 | 2668 DEFUN ("check-valid-specifier-matchspec", Fcheck_valid_specifier_matchspec, 2, |
| 2669 2, 0, /* | |
| 428 | 2670 Signal an error if MATCHSPEC is invalid for SPECIFIER-TYPE. |
| 2671 See `specifier-matching-instance' for a description of matchspecs. | |
| 2672 */ | |
| 2673 (matchspec, specifier_type)) | |
| 2674 { | |
| 2675 struct specifier_methods *meths = decode_specifier_type (specifier_type, | |
| 2676 ERROR_ME); | |
| 2677 | |
| 2678 return check_valid_specifier_matchspec (matchspec, meths, ERROR_ME); | |
| 2679 } | |
| 2680 | |
| 2681 DEFUN ("valid-specifier-matchspec-p", Fvalid_specifier_matchspec_p, 2, 2, 0, /* | |
| 2682 Return non-nil if MATCHSPEC is valid for SPECIFIER-TYPE. | |
| 2683 See `specifier-matching-instance' for a description of matchspecs. | |
| 2684 */ | |
| 2685 (matchspec, specifier_type)) | |
| 2686 { | |
| 2687 struct specifier_methods *meths = decode_specifier_type (specifier_type, | |
| 2688 ERROR_ME); | |
| 2689 | |
| 2690 return check_valid_specifier_matchspec (matchspec, meths, ERROR_ME_NOT); | |
| 2691 } | |
| 2692 | |
| 2693 /* This function is purposely not callable from Lisp. If a Lisp | |
| 2694 caller wants to set a fallback, they should just set the | |
| 2695 global value. */ | |
| 2696 | |
| 2697 void | |
| 2698 set_specifier_fallback (Lisp_Object specifier, Lisp_Object fallback) | |
| 2699 { | |
| 440 | 2700 Lisp_Specifier *sp = XSPECIFIER (specifier); |
| 428 | 2701 assert (SPECIFIERP (fallback) || |
| 2702 !NILP (Fvalid_inst_list_p (fallback, Fspecifier_type (specifier)))); | |
| 2703 if (SPECIFIERP (fallback)) | |
| 2704 assert (EQ (Fspecifier_type (specifier), Fspecifier_type (fallback))); | |
| 2705 if (BODILY_SPECIFIER_P (sp)) | |
| 5198 | 2706 GHOST_SPECIFIER (sp)->fallback = fallback; |
| 428 | 2707 else |
| 2708 sp->fallback = fallback; | |
| 2709 /* call the after-change method */ | |
| 2710 MAYBE_SPECMETH (sp, after_change, | |
| 2711 (bodily_specifier (specifier), Qfallback)); | |
| 2712 recompute_cached_specifier_everywhere (specifier); | |
| 2713 } | |
| 2714 | |
| 2715 DEFUN ("specifier-fallback", Fspecifier_fallback, 1, 1, 0, /* | |
| 2716 Return the fallback value for SPECIFIER. | |
| 2717 Fallback values are provided by the C code for certain built-in | |
| 2953 | 2718 specifiers to make sure that instantiation won't fail even if all |
| 428 | 2719 specs are removed from the specifier, or to implement simple |
| 2720 inheritance behavior (e.g. this method is used to ensure that | |
| 2953 | 2721 faces other than `default' inherit their attributes from `default'). |
| 428 | 2722 By design, you cannot change the fallback value, and specifiers |
| 2723 created with `make-specifier' will never have a fallback (although | |
| 2724 a similar, Lisp-accessible capability may be provided in the future | |
| 2725 to allow for inheritance). | |
| 2726 | |
| 2953 | 2727 The fallback value will be an inst-list that is instantiated like |
| 428 | 2728 any other inst-list, a specifier of the same type as SPECIFIER |
| 2729 \(results in inheritance), or nil for no fallback. | |
| 2730 | |
| 2953 | 2731 When you instantiate a specifier, you can explicitly request that the |
| 428 | 2732 fallback not be consulted. (The C code does this, for example, when |
| 2733 merging faces.) See `specifier-instance'. | |
| 2734 */ | |
| 2735 (specifier)) | |
| 2736 { | |
| 2737 CHECK_SPECIFIER (specifier); | |
| 2738 return Fcopy_tree (XSPECIFIER (specifier)->fallback, Qt); | |
| 2739 } | |
| 2740 | |
| 2741 static Lisp_Object | |
| 2742 specifier_instance_from_inst_list (Lisp_Object specifier, | |
| 2743 Lisp_Object matchspec, | |
| 2744 Lisp_Object domain, | |
| 2745 Lisp_Object inst_list, | |
| 578 | 2746 Error_Behavior errb, int no_quit, |
| 2953 | 2747 Lisp_Object depth, |
|
4426
515b91f904c1
Fix specifier inheritance behavior
Didier Verna <didier@xemacs.org>
parents:
3836
diff
changeset
|
2748 Lisp_Object *instantiator, |
|
515b91f904c1
Fix specifier inheritance behavior
Didier Verna <didier@xemacs.org>
parents:
3836
diff
changeset
|
2749 int no_fallback) |
| 428 | 2750 { |
| 2751 /* This function can GC */ | |
| 440 | 2752 Lisp_Specifier *sp; |
| 3659 | 2753 Lisp_Object device, charset = Qnil, rest; |
| 2754 int count = specpdl_depth (), respected_charsets = 0; | |
| 428 | 2755 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
|
2756 enum font_specifier_matchspec_stages stage = STAGE_INITIAL; |
| 428 | 2757 |
| 2758 GCPRO2 (specifier, inst_list); | |
| 2759 | |
| 2760 sp = XSPECIFIER (specifier); | |
| 442 | 2761 device = DOMAIN_DEVICE (domain); |
| 428 | 2762 |
| 2763 if (no_quit) | |
| 3659 | 2764 /* The instantiate method is allowed to call eval. Since it |
| 2765 is quite common for this function to get called from somewhere in | |
| 2766 redisplay we need to make sure that quits are ignored. Otherwise | |
| 2767 Fsignal will abort. */ | |
| 428 | 2768 specbind (Qinhibit_quit, Qt); |
| 2769 | |
| 3659 | 2770 #ifdef MULE |
| 4828 | 2771 /* #### FIXME Does this font-specific stuff need to be here and not in |
| 2772 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
|
2773 if (CONSP (matchspec) && (CHARSETP (Ffind_charset (XCAR (matchspec))))) |
| 3659 | 2774 { |
|
5015
d95c102a96d3
cleanups for specifier font stages, from ben-unicode-internal (preparation for eliminating shadowed warnings)
Ben Wing <ben@xemacs.org>
parents:
5013
diff
changeset
|
2775 charset = Ffind_charset (XCAR (matchspec)); |
| 3659 | 2776 |
| 2777 #ifdef DEBUG_XEMACS | |
| 2778 /* This is mostly to have somewhere to set debug breakpoints. */ | |
| 4853 | 2779 if (!EQ (charset, Vcharset_ascii)) |
| 3659 | 2780 { |
| 4853 | 2781 (void) 0; |
| 3659 | 2782 } |
| 2783 #endif /* DEBUG_XEMACS */ | |
| 2784 | |
|
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
|
2785 if (!NILP (XCDR (matchspec))) |
| 3659 | 2786 { |
| 2787 | |
|
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
|
2788 #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
|
2789 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
|
2790 { \ |
|
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 stage = enumstage; \ |
| 3659 | 2792 } |
| 2793 | |
|
5015
d95c102a96d3
cleanups for specifier font stages, from ben-unicode-internal (preparation for eliminating shadowed warnings)
Ben Wing <ben@xemacs.org>
parents:
5013
diff
changeset
|
2794 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
|
2795 else FROB (final, STAGE_FINAL) |
| 5198 | 2796 else assert (0); |
| 3659 | 2797 #undef FROB |
| 2798 | |
| 2799 } | |
| 2800 } | |
| 2801 #endif /* MULE */ | |
| 2802 | |
| 5198 | 2803 LIST_LOOP (rest, inst_list) |
| 3659 | 2804 { |
| 2805 Lisp_Object tagged_inst = XCAR (rest); | |
| 2806 Lisp_Object tag_set = XCAR (tagged_inst); | |
| 2807 Lisp_Object val, the_instantiator; | |
| 2808 | |
| 2809 if (!device_matches_specifier_tag_set_p (device, tag_set)) | |
| 2810 { | |
|
4426
515b91f904c1
Fix specifier inheritance behavior
Didier Verna <didier@xemacs.org>
parents:
3836
diff
changeset
|
2811 continue; |
| 3659 | 2812 } |
| 2813 | |
| 2814 val = XCDR (tagged_inst); | |
| 2815 the_instantiator = val; | |
| 2816 | |
| 5198 | 2817 if (!NILP (charset) && |
| 3659 | 2818 !(charset_matches_specifier_tag_set_p (charset, tag_set, stage))) |
| 2819 { | |
| 2820 ++respected_charsets; | |
| 2821 continue; | |
| 2822 } | |
| 2823 | |
| 2824 if (HAS_SPECMETH_P (sp, instantiate)) | |
| 2825 val = call_with_suspended_errors | |
| 2826 ((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
|
2827 Qunbound, Qspecifier, ERROR_ME_WARN, 5, specifier, |
|
4426
515b91f904c1
Fix specifier inheritance behavior
Didier Verna <didier@xemacs.org>
parents:
3836
diff
changeset
|
2828 matchspec, domain, val, depth, no_fallback); |
| 3659 | 2829 |
| 2830 if (!UNBOUNDP (val)) | |
| 2831 { | |
| 2832 unbind_to (count); | |
| 2833 UNGCPRO; | |
| 2834 if (instantiator) | |
| 2835 *instantiator = the_instantiator; | |
| 2836 return val; | |
| 2837 } | |
| 2838 } | |
| 2839 | |
| 2840 /* We've checked all the tag sets, and checking the charset part of the | |
| 2841 specifier never returned 0 (preventing the attempted instantiation), so | |
| 2842 there's no need to loop for the second time to avoid checking the | |
| 2843 charsets. */ | |
| 2844 if (!respected_charsets) | |
| 2845 { | |
| 2846 unbind_to (count); | |
| 2847 UNGCPRO; | |
| 2848 return Qunbound; | |
| 2849 } | |
| 2850 | |
| 2851 /* Right, didn't instantiate a specifier last time, perhaps because we | |
| 2852 paid attention to the charset-specific aspects of the specifier. Try | |
| 2853 again without checking the charset information. | |
| 2854 | |
| 2855 We can't emulate the approach for devices, defaulting to matching all | |
| 2856 character sets for a given specifier, because $random font instantiator | |
| 2857 cannot usefully show all character sets, and indeed having it try is a | |
| 2858 failure on our part. */ | |
| 428 | 2859 LIST_LOOP (rest, inst_list) |
| 2860 { | |
| 2861 Lisp_Object tagged_inst = XCAR (rest); | |
| 2862 Lisp_Object tag_set = XCAR (tagged_inst); | |
| 3659 | 2863 Lisp_Object val, the_instantiator; |
| 2864 | |
| 2865 if (!device_matches_specifier_tag_set_p (device, tag_set)) | |
| 428 | 2866 { |
|
4426
515b91f904c1
Fix specifier inheritance behavior
Didier Verna <didier@xemacs.org>
parents:
3836
diff
changeset
|
2867 continue; |
| 3659 | 2868 } |
| 2869 | |
| 2870 val = XCDR (tagged_inst); | |
| 2871 the_instantiator = val; | |
| 2872 | |
| 2873 if (HAS_SPECMETH_P (sp, instantiate)) | |
| 2874 val = call_with_suspended_errors | |
| 2875 ((lisp_fn_t) RAW_SPECMETH (sp, instantiate), | |
| 2876 Qunbound, Qspecifier, errb, 5, specifier, | |
|
4426
515b91f904c1
Fix specifier inheritance behavior
Didier Verna <didier@xemacs.org>
parents:
3836
diff
changeset
|
2877 matchspec, domain, val, depth, no_fallback); |
| 3659 | 2878 |
| 2879 if (!UNBOUNDP (val)) | |
| 2880 { | |
| 2881 unbind_to (count); | |
| 2882 UNGCPRO; | |
| 2883 if (instantiator) | |
| 2884 *instantiator = the_instantiator; | |
| 2885 return val; | |
| 428 | 2886 } |
| 2887 } | |
| 2888 | |
| 771 | 2889 unbind_to (count); |
| 428 | 2890 UNGCPRO; |
| 2891 return Qunbound; | |
| 2892 } | |
| 2893 | |
| 2894 /* Given a SPECIFIER and a DOMAIN, return a specific instance for that | |
| 2895 specifier. Try to find one by checking the specifier types from most | |
| 4437 | 2896 specific (window) to most general (global). If we find an instance, |
| 428 | 2897 return it. Otherwise return Qunbound. */ |
| 2898 | |
| 2899 #define CHECK_INSTANCE_ENTRY(key, matchspec, type) do { \ | |
| 3659 | 2900 Lisp_Object *CIE_inst_list = \ |
| 2901 specifier_get_inst_list (specifier, key, type); \ | |
| 2902 if (CIE_inst_list) \ | |
| 2903 { \ | |
| 2904 Lisp_Object CIE_val = \ | |
| 2905 specifier_instance_from_inst_list (specifier, matchspec, \ | |
| 2906 domain, *CIE_inst_list, \ | |
| 2907 errb, no_quit, depth, \ | |
|
4426
515b91f904c1
Fix specifier inheritance behavior
Didier Verna <didier@xemacs.org>
parents:
3836
diff
changeset
|
2908 instantiator, no_fallback); \ |
| 3659 | 2909 if (!UNBOUNDP (CIE_val)) \ |
| 2910 return CIE_val; \ | |
| 2911 } \ | |
| 2912 } while (0) | |
| 428 | 2913 |
| 2914 /* We accept any window, frame or device domain and do our checking | |
| 2915 starting from as specific a locale type as we can determine from the | |
| 2916 domain we are passed and going on up through as many other locale types | |
| 2917 as we can determine. In practice, when called from redisplay the | |
| 2918 arg will usually be a window and occasionally a frame. If | |
| 2919 triggered by a user call, who knows what it will usually be. */ | |
| 2953 | 2920 |
| 2921 static Lisp_Object | |
| 2922 specifier_instance_1 (Lisp_Object specifier, Lisp_Object matchspec, | |
| 2923 Lisp_Object domain, Error_Behavior errb, int no_quit, | |
| 2924 int no_fallback, Lisp_Object depth, | |
| 2925 Lisp_Object *instantiator) | |
| 428 | 2926 { |
| 2927 Lisp_Object buffer = Qnil; | |
| 2928 Lisp_Object window = Qnil; | |
| 2929 Lisp_Object frame = Qnil; | |
| 2930 Lisp_Object device = Qnil; | |
| 444 | 2931 Lisp_Specifier *sp = XSPECIFIER (specifier); |
| 428 | 2932 |
| 2953 | 2933 if (instantiator) |
| 2934 *instantiator = Qunbound; | |
| 2935 | |
| 428 | 2936 /* Attempt to determine buffer, window, frame, and device from the |
| 2937 domain. */ | |
| 442 | 2938 /* #### get image instances out of domains! */ |
| 2939 if (IMAGE_INSTANCEP (domain)) | |
| 2940 window = DOMAIN_WINDOW (domain); | |
| 2941 else if (WINDOWP (domain)) | |
| 428 | 2942 window = domain; |
| 2943 else if (FRAMEP (domain)) | |
| 2944 frame = domain; | |
| 2945 else if (DEVICEP (domain)) | |
| 2946 device = domain; | |
| 2947 else | |
| 442 | 2948 /* dmoore writes: [dammit, this should just signal an error or something |
| 2949 shouldn't it?] | |
| 2950 | |
| 2951 No. Errors are handled in Lisp primitives implementation. | |
| 428 | 2952 Invalid domain is a design error here - kkm. */ |
| 2500 | 2953 ABORT (); |
| 428 | 2954 |
| 2955 if (NILP (buffer) && !NILP (window)) | |
| 444 | 2956 buffer = WINDOW_BUFFER (XWINDOW (window)); |
| 428 | 2957 if (NILP (frame) && !NILP (window)) |
| 2958 frame = XWINDOW (window)->frame; | |
| 2959 if (NILP (device)) | |
| 2960 /* frame had better exist; if device is undeterminable, something | |
| 2961 really went wrong. */ | |
| 444 | 2962 device = FRAME_DEVICE (XFRAME (frame)); |
| 428 | 2963 |
| 2964 /* device had better be determined by now; abort if not. */ | |
| 2286 | 2965 (void) DEVICE_CLASS (XDEVICE (device)); |
| 428 | 2966 |
| 2967 depth = make_int (1 + XINT (depth)); | |
| 2968 if (XINT (depth) > 20) | |
| 2969 { | |
| 563 | 2970 maybe_signal_error (Qstack_overflow, |
| 2971 "Apparent loop in specifier inheritance", | |
| 2972 Qunbound, Qspecifier, errb); | |
| 428 | 2973 /* The specification is fucked; at least try the fallback |
| 2974 (which better not be fucked, because it's not changeable | |
| 2975 from Lisp). */ | |
| 2976 depth = Qzero; | |
| 2977 goto do_fallback; | |
| 2978 } | |
| 2979 | |
| 434 | 2980 retry: |
| 428 | 2981 /* First see if we can generate one from the window specifiers. */ |
| 2982 if (!NILP (window)) | |
| 2983 CHECK_INSTANCE_ENTRY (window, matchspec, LOCALE_WINDOW); | |
| 2984 | |
| 2985 /* Next see if we can generate one from the buffer specifiers. */ | |
| 2986 if (!NILP (buffer)) | |
| 2987 CHECK_INSTANCE_ENTRY (buffer, matchspec, LOCALE_BUFFER); | |
| 2988 | |
| 2989 /* Next see if we can generate one from the frame specifiers. */ | |
| 2990 if (!NILP (frame)) | |
| 2991 CHECK_INSTANCE_ENTRY (frame, matchspec, LOCALE_FRAME); | |
| 2992 | |
| 2993 /* If we still haven't succeeded try with the device specifiers. */ | |
| 2994 CHECK_INSTANCE_ENTRY (device, matchspec, LOCALE_DEVICE); | |
| 2995 | |
| 2996 /* Last and least try the global specifiers. */ | |
| 2997 CHECK_INSTANCE_ENTRY (Qglobal, matchspec, LOCALE_GLOBAL); | |
| 2998 | |
| 434 | 2999 do_fallback: |
| 428 | 3000 /* We're out of specifiers and we still haven't generated an |
| 3001 instance. At least try the fallback ... If this fails, | |
| 3002 then we just return Qunbound. */ | |
| 3003 | |
| 3004 if (no_fallback || NILP (sp->fallback)) | |
| 3005 /* I said, I don't want the fallbacks. */ | |
| 3006 return Qunbound; | |
| 3007 | |
| 3008 if (SPECIFIERP (sp->fallback)) | |
| 3009 { | |
| 3010 /* If you introduced loops in the default specifier chain, | |
| 3011 then you're fucked, so you better not do this. */ | |
| 3012 specifier = sp->fallback; | |
| 3013 sp = XSPECIFIER (specifier); | |
| 3014 goto retry; | |
| 3015 } | |
| 3016 | |
| 3017 assert (CONSP (sp->fallback)); | |
| 3018 return specifier_instance_from_inst_list (specifier, matchspec, domain, | |
| 3019 sp->fallback, errb, no_quit, | |
|
4426
515b91f904c1
Fix specifier inheritance behavior
Didier Verna <didier@xemacs.org>
parents:
3836
diff
changeset
|
3020 depth, instantiator, |
|
515b91f904c1
Fix specifier inheritance behavior
Didier Verna <didier@xemacs.org>
parents:
3836
diff
changeset
|
3021 no_fallback); |
| 428 | 3022 } |
| 3023 #undef CHECK_INSTANCE_ENTRY | |
| 3024 | |
| 3025 Lisp_Object | |
| 2953 | 3026 specifier_instance (Lisp_Object specifier, Lisp_Object matchspec, |
| 3027 Lisp_Object domain, Error_Behavior errb, int no_quit, | |
| 3028 int no_fallback, Lisp_Object depth) | |
| 3029 { | |
| 3030 return specifier_instance_1 (specifier, matchspec, domain, errb, | |
| 3031 no_quit, no_fallback, depth, NULL); | |
| 3032 } | |
| 3033 | |
| 3034 Lisp_Object | |
| 428 | 3035 specifier_instance_no_quit (Lisp_Object specifier, Lisp_Object matchspec, |
| 578 | 3036 Lisp_Object domain, Error_Behavior errb, |
| 428 | 3037 int no_fallback, Lisp_Object depth) |
| 3038 { | |
| 2953 | 3039 return specifier_instance_1 (specifier, matchspec, domain, errb, |
| 3040 1, no_fallback, depth, NULL); | |
| 3041 } | |
| 3042 | |
| 3043 static Lisp_Object | |
| 3044 specifier_matching_foo (Lisp_Object specifier, | |
| 3045 Lisp_Object matchspec, | |
| 3046 Lisp_Object domain, | |
| 3047 Lisp_Object default_, | |
| 3048 Lisp_Object no_fallback, | |
| 3049 int want_instantiator) | |
| 3050 { | |
| 3051 Lisp_Object instance, instantiator; | |
| 3052 | |
| 3053 CHECK_SPECIFIER (specifier); | |
| 3054 if (!UNBOUNDP (matchspec)) | |
| 3055 check_valid_specifier_matchspec (matchspec, | |
| 3056 XSPECIFIER (specifier)->methods, | |
| 3057 ERROR_ME); | |
| 3058 domain = decode_domain (domain); | |
| 3059 | |
| 3060 instance = specifier_instance_1 (specifier, matchspec, domain, ERROR_ME, | |
| 3061 0, !NILP (no_fallback), Qzero, | |
| 3062 &instantiator); | |
| 3063 return UNBOUNDP (instance) ? default_ : want_instantiator ? instantiator : | |
| 3064 instance; | |
| 428 | 3065 } |
| 3066 | |
| 3067 DEFUN ("specifier-instance", Fspecifier_instance, 1, 4, 0, /* | |
| 3068 Instantiate SPECIFIER (return its value) in DOMAIN. | |
| 3069 If no instance can be generated for this domain, return DEFAULT. | |
| 3070 | |
| 2953 | 3071 DOMAIN is nearly always a window (defaulting to the selected window if |
| 3072 omitted), but can be a window, frame, or device. Other values that are legal | |
| 428 | 3073 as a locale (e.g. a buffer) are not valid as a domain because they do not |
| 3074 provide enough information to identify a particular device (see | |
| 2953 | 3075 `valid-specifier-domain-p'). Window domains are used internally in nearly |
| 3076 all circumstances when computing specifier instances of display properties. | |
| 3077 Frame domains are used in a few circumstances (such as when computing the | |
| 3078 geometry of a frame based on properties such as the toolbar widths), and | |
| 3079 device domains are rarely if ever used internally. | |
| 3080 | |
| 3081 This function looks through the specifications in SPECIFIER that correspond | |
| 3082 to DOMAIN, from most specific (specifications for DOMAIN itself) to most | |
| 3083 general (global specifications), for matching instantiators, and attempts | |
| 3084 to compute an instance value for each instantiator found. The first | |
| 3085 successfully computed value is returned. The corresponding instantiator | |
| 3086 can be returned using `specifier-instantiator'. | |
| 3087 | |
| 3088 A specifier is a generalized object for controlling the value of a property -- | |
| 3089 typically, but not necessarily, a display-related property -- that can vary | |
| 3090 over particular buffers, frames, device types, etc. | |
| 3091 | |
| 3092 A fundamental distinction must be made between the specification of a | |
| 3093 property's value, and the resulting value itself. This distinction is | |
| 3094 clearest in the case of an image -- the specification describes the source | |
| 3095 of the image (for example, a file of JPEG data), and the resulting value | |
| 3096 encapsulates a window-system object describing the image as displayed on a | |
| 3097 particular device (for example, a particular X display). The specification | |
| 3098 might also be an instruction of the form "use the background pixmap of the | |
| 3099 `modeline' face". A similar mapping exists between color strings and | |
| 3100 color-instance objects, and font strings and font-instance objects. In | |
| 3101 some cases, the specification and the resulting value are of the same type, | |
| 3102 but the distinction is still logically made. | |
| 3103 | |
| 3104 The specification of a value is called an instantiator, and the resulting | |
| 3105 value the instance. | |
| 428 | 3106 |
| 3107 "Instantiating" a specifier in a particular domain means determining | |
| 3108 the specifier's "value" in that domain. This is accomplished by | |
| 3109 searching through the specifications in the specifier that correspond | |
| 3110 to all locales that can be derived from the given domain, from specific | |
| 3111 to general. In most cases, the domain is an Emacs window. In that case | |
| 3112 specifications are searched for as follows: | |
| 3113 | |
| 3114 1. A specification whose locale is the window itself; | |
| 3115 2. A specification whose locale is the window's buffer; | |
| 3116 3. A specification whose locale is the window's frame; | |
| 3117 4. A specification whose locale is the window's frame's device; | |
| 2953 | 3118 5. A specification whose locale is `global'. |
| 428 | 3119 |
| 3120 If all of those fail, then the C-code-provided fallback value for | |
| 3121 this specifier is consulted (see `specifier-fallback'). If it is | |
| 3122 an inst-list, then this function attempts to instantiate that list | |
| 3123 just as when a specification is located in the first five steps above. | |
| 3124 If the fallback is a specifier, `specifier-instance' is called | |
| 3125 recursively on this specifier and the return value used. Note, | |
| 3126 however, that if the optional argument NO-FALLBACK is non-nil, | |
| 3127 the fallback value will not be consulted. | |
| 3128 | |
| 3129 Note that there may be more than one specification matching a particular | |
| 3130 locale; all such specifications are considered before looking for any | |
| 3131 specifications for more general locales. Any particular specification | |
| 3132 that is found may be rejected because its tag set does not match the | |
| 3133 device being instantiated over, or because the specification is not | |
| 3134 valid for the device of the given domain (e.g. the font or color name | |
| 3135 does not exist for this particular X server). | |
| 3136 | |
| 793 | 3137 NOTE: When errors occur in the process of trying a particular instantiator, |
| 3138 and the instantiator is thus skipped, warnings will be issued at level | |
| 3139 `debug'. Normally, such warnings are ignored entirely, but you can change | |
| 3140 this by setting `log-warning-minimum-level'. This is useful if you're | |
| 3141 trying to debug why particular instantiators are not being processed. | |
| 3142 | |
| 428 | 3143 The returned value is dependent on the type of specifier. For example, |
| 3144 for a font specifier (as returned by the `face-font' function), the returned | |
| 3145 value will be a font-instance object. For glyphs, the returned value | |
| 2953 | 3146 will be an image-instance object. |
| 428 | 3147 |
| 3148 See also `specifier-matching-instance'. | |
| 3149 */ | |
| 3150 (specifier, domain, default_, no_fallback)) | |
| 3151 { | |
| 2953 | 3152 return specifier_matching_foo (specifier, Qunbound, domain, default_, |
| 3153 no_fallback, 0); | |
| 3154 } | |
| 3155 | |
| 3156 DEFUN ("specifier-instantiator", Fspecifier_instantiator, 1, 4, 0, /* | |
| 3157 Return instantiator that would be used to instantiate SPECIFIER in DOMAIN. | |
| 3158 If no instance can be generated for this domain, return DEFAULT. | |
| 3159 | |
| 3160 DOMAIN should be a window, frame, or device. Other values that are legal | |
| 3161 as a locale (e.g. a buffer) are not valid as a domain because they do not | |
| 3162 provide enough information to identify a particular device (see | |
| 3163 `valid-specifier-domain-p'). DOMAIN defaults to the selected window | |
| 3164 if omitted. | |
| 3165 | |
| 3166 See `specifier-instance' for more information about the instantiation process. | |
| 3167 */ | |
| 3168 (specifier, domain, default_, no_fallback)) | |
| 3169 { | |
| 3170 return specifier_matching_foo (specifier, Qunbound, domain, default_, | |
| 3171 no_fallback, 1); | |
| 428 | 3172 } |
| 3173 | |
| 5484 | 3174 /* MATCHSPEC is backward-incompatible with code written to 21.4's API. |
| 3175 So far such code has been seen only in x-symbol-mule.el, and that | |
| 3176 was addressed by a change `face-property-matching-instance'. | |
| 3177 See tracker issue752 for a more general patch against 21.5.29. */ | |
| 428 | 3178 DEFUN ("specifier-matching-instance", Fspecifier_matching_instance, 2, 5, 0, /* |
| 3179 Return an instance for SPECIFIER in DOMAIN that matches MATCHSPEC. | |
| 3180 If no instance can be generated for this domain, return DEFAULT. | |
| 3181 | |
| 3182 This function is identical to `specifier-instance' except that a | |
| 3183 specification will only be considered if it matches MATCHSPEC. | |
| 3184 The definition of "match", and allowed values for MATCHSPEC, are | |
| 3185 dependent on the particular type of specifier. Here are some examples: | |
| 3186 | |
| 3187 -- For chartable (e.g. display table) specifiers, MATCHSPEC should be a | |
| 3188 character, and the specification (a chartable) must give a value for | |
| 3189 that character in order to be considered. This allows you to specify, | |
| 3190 e.g., a buffer-local display table that only gives values for particular | |
| 3191 characters. All other characters are handled as if the buffer-local | |
| 3192 display table is not there. (Chartable specifiers are not yet | |
| 3193 implemented.) | |
| 3194 | |
|
4426
515b91f904c1
Fix specifier inheritance behavior
Didier Verna <didier@xemacs.org>
parents:
3836
diff
changeset
|
3195 -- For font specifiers, MATCHSPEC should be a cons (CHARSET . STAGE). |
| 3674 | 3196 The defined stages are currently `initial' and `final'. On X11, 'initial |
| 3197 is used when the font matching process is looking for fonts that match | |
| 3198 the desired registries of the charset--see the `charset-registries' | |
| 3199 function. If that match process fails, then the 'final stage comes into | |
| 3200 play; this means that a more general lookup is desired, and that a font | |
| 3201 doesn't necessarily have to match the desired XLFD for the face, just the | |
| 3202 charset repertoire for this charset. It also means that the charset | |
| 3203 registry and encoding used will be `iso10646-1', and the characters will | |
| 3204 be converted to display using that registry. | |
| 3205 | |
| 3206 See `define-specifier-tag' for details on how to create a tag that | |
| 3207 specifies a given character set and stage combination. You can supply | |
| 3208 such a tag to `set-face-font' in order to set a face's font for that | |
| 3209 character set and stage combination. | |
| 428 | 3210 */ |
| 3211 (specifier, matchspec, domain, default_, no_fallback)) | |
| 3212 { | |
| 2953 | 3213 return specifier_matching_foo (specifier, matchspec, domain, default_, |
| 3214 no_fallback, 0); | |
| 3215 } | |
| 3216 | |
| 3217 DEFUN ("specifier-matching-instantiator", Fspecifier_matching_instantiator, | |
| 3218 2, 5, 0, /* | |
| 3219 Return instantiator for instance of SPECIFIER in DOMAIN that matches MATCHSPEC. | |
| 3220 If no instance can be generated for this domain, return DEFAULT. | |
| 3221 | |
| 3222 This function is identical to `specifier-matching-instance' but returns | |
| 3223 the instantiator used to generate the instance, rather than the actual | |
| 3224 instance. | |
| 3225 */ | |
| 3226 (specifier, matchspec, domain, default_, no_fallback)) | |
| 3227 { | |
| 3228 return specifier_matching_foo (specifier, matchspec, domain, default_, | |
| 3229 no_fallback, 1); | |
| 3230 } | |
| 3231 | |
| 3232 static Lisp_Object | |
| 3233 specifier_matching_foo_from_inst_list (Lisp_Object specifier, | |
| 3234 Lisp_Object matchspec, | |
| 3235 Lisp_Object domain, | |
| 3236 Lisp_Object inst_list, | |
| 3237 Lisp_Object default_, | |
| 3238 int want_instantiator) | |
| 3239 { | |
| 3240 Lisp_Object val = Qunbound; | |
| 3241 Lisp_Specifier *sp = XSPECIFIER (specifier); | |
| 3242 struct gcpro gcpro1; | |
| 3243 Lisp_Object built_up_list = Qnil; | |
| 3244 Lisp_Object instantiator; | |
| 428 | 3245 |
| 3246 CHECK_SPECIFIER (specifier); | |
| 2953 | 3247 if (!UNBOUNDP (matchspec)) |
| 3248 check_valid_specifier_matchspec (matchspec, | |
| 3249 XSPECIFIER (specifier)->methods, | |
| 3250 ERROR_ME); | |
| 3251 check_valid_domain (domain); | |
| 3252 check_valid_inst_list (inst_list, sp->methods, ERROR_ME); | |
| 3253 GCPRO1 (built_up_list); | |
| 3254 built_up_list = build_up_processed_list (specifier, domain, inst_list); | |
| 3255 if (!NILP (built_up_list)) | |
| 3256 val = specifier_instance_from_inst_list (specifier, matchspec, domain, | |
| 3257 built_up_list, ERROR_ME, | |
|
4426
515b91f904c1
Fix specifier inheritance behavior
Didier Verna <didier@xemacs.org>
parents:
3836
diff
changeset
|
3258 0, Qzero, &instantiator, 0); |
| 2953 | 3259 UNGCPRO; |
| 3260 return UNBOUNDP (val) ? default_ : want_instantiator ? instantiator : val; | |
| 3261 | |
| 428 | 3262 } |
| 3263 | |
| 3264 DEFUN ("specifier-instance-from-inst-list", Fspecifier_instance_from_inst_list, | |
| 3265 3, 4, 0, /* | |
| 3266 Attempt to convert a particular inst-list into an instance. | |
| 3267 This attempts to instantiate INST-LIST in the given DOMAIN, | |
| 3268 as if INST-LIST existed in a specification in SPECIFIER. If | |
| 3269 the instantiation fails, DEFAULT is returned. In most circumstances, | |
| 3270 you should not use this function; use `specifier-instance' instead. | |
| 3271 */ | |
| 3272 (specifier, domain, inst_list, default_)) | |
| 3273 { | |
| 2953 | 3274 return specifier_matching_foo_from_inst_list (specifier, Qunbound, |
| 3275 domain, inst_list, default_, | |
| 3276 0); | |
| 3277 } | |
| 3278 | |
|
4426
515b91f904c1
Fix specifier inheritance behavior
Didier Verna <didier@xemacs.org>
parents:
3836
diff
changeset
|
3279 DEFUN ("specifier-instantiator-from-inst-list", |
| 3659 | 3280 Fspecifier_instantiator_from_inst_list, 3, 4, 0, /* |
| 2953 | 3281 Attempt to convert an inst-list into an instance; return instantiator. |
| 3282 This is identical to `specifier-instance-from-inst-list' but returns | |
| 3283 the instantiator used to generate the instance, rather than the instance | |
| 3284 itself. | |
| 3285 */ | |
| 3286 (specifier, domain, inst_list, default_)) | |
| 3287 { | |
| 3288 return specifier_matching_foo_from_inst_list (specifier, Qunbound, | |
| 3289 domain, inst_list, default_, | |
| 3290 1); | |
| 428 | 3291 } |
| 3292 | |
| 442 | 3293 DEFUN ("specifier-matching-instance-from-inst-list", |
| 3294 Fspecifier_matching_instance_from_inst_list, | |
| 428 | 3295 4, 5, 0, /* |
| 3296 Attempt to convert a particular inst-list into an instance. | |
| 3297 This attempts to instantiate INST-LIST in the given DOMAIN | |
| 3298 \(as if INST-LIST existed in a specification in SPECIFIER), | |
| 3299 matching the specifications against MATCHSPEC. | |
| 3300 | |
| 3301 This function is analogous to `specifier-instance-from-inst-list' | |
| 3302 but allows for specification-matching as in `specifier-matching-instance'. | |
| 3303 See that function for a description of exactly how the matching process | |
| 3304 works. | |
| 3305 */ | |
| 3306 (specifier, matchspec, domain, inst_list, default_)) | |
| 3307 { | |
| 2953 | 3308 return specifier_matching_foo_from_inst_list (specifier, matchspec, |
| 3309 domain, inst_list, default_, | |
| 3310 0); | |
| 3311 } | |
| 3312 | |
| 3313 DEFUN ("specifier-matching-instantiator-from-inst-list", | |
| 3314 Fspecifier_matching_instantiator_from_inst_list, | |
| 3315 4, 5, 0, /* | |
| 3316 Attempt to convert an inst-list into an instance; return instantiator. | |
| 3317 This is identical to `specifier-matching-instance-from-inst-list' but returns | |
| 3318 the instantiator used to generate the instance, rather than the instance | |
| 3319 itself. | |
| 3320 */ | |
| 3321 (specifier, matchspec, domain, inst_list, default_)) | |
| 3322 { | |
| 3323 return specifier_matching_foo_from_inst_list (specifier, matchspec, | |
| 3324 domain, inst_list, default_, | |
| 3325 1); | |
| 428 | 3326 } |
| 3327 | |
| 3328 | |
| 3329 /************************************************************************/ | |
| 3330 /* Caching in the struct window or frame */ | |
| 3331 /************************************************************************/ | |
| 3332 | |
| 853 | 3333 /* Cause the current value of SPECIFIER in the domain of each frame and/or |
| 3334 window to be cached in the struct frame at STRUCT_FRAME_OFFSET and the | |
| 3335 struct window at STRUCT_WINDOW_OFFSET. When the value changes in a | |
| 3336 particular window, VALUE_CHANGED_IN_WINDOW is called. When the value | |
| 3337 changes in a particular frame, VALUE_CHANGED_IN_FRAME is called. | |
| 3338 | |
| 3339 Either STRUCT_WINDOW_OFFSET or STRUCT_FRAME_OFFSET can be 0 to indicate | |
| 3340 no caching in that sort of object. However, if they're not 0, you | |
| 3341 must supply a corresponding value-changed function. (This is the case | |
| 3342 so that you are forced to consider the ramifications of a value change. | |
| 3343 You nearly always need to do something, e.g. set a dirty flag.) | |
| 3344 | |
| 3345 If you create a built-in specifier, you should do the following: | |
| 3346 | |
| 3347 - Make sure the file you create the specifier in has a | |
| 3659 | 3348 specifier_vars_of_foo() function. If not, create it, declare it in |
| 3349 symsinit.h, and make sure it's called in the appropriate place in | |
| 3350 emacs.c. | |
| 853 | 3351 - In specifier_vars_of_foo(), do a DEFVAR_SPECIFIER(), followed by |
| 3659 | 3352 initializing the specifier using Fmake_specifier(), followed by |
| 3353 set_specifier_fallback(), followed (optionally) by | |
| 3354 set_specifier_caching(). | |
| 853 | 3355 - If you used set_specifier_caching(), make sure to create the |
| 3659 | 3356 appropriate value-changed functions. Also make sure to add the |
| 3357 appropriate slots where the values are cached to frameslots.h and | |
| 3358 winslots.h. | |
| 853 | 3359 |
| 3360 Do a grep for menubar_visible_p for an example. | |
| 3361 */ | |
| 428 | 3362 |
| 3363 /* #### It would be nice if the specifier caching automatically knew | |
| 3364 about specifier fallbacks, so we didn't have to do it ourselves. */ | |
| 3365 | |
| 3366 void | |
| 3367 set_specifier_caching (Lisp_Object specifier, int struct_window_offset, | |
| 3368 void (*value_changed_in_window) | |
| 3369 (Lisp_Object specifier, struct window *w, | |
| 3370 Lisp_Object oldval), | |
| 3371 int struct_frame_offset, | |
| 3372 void (*value_changed_in_frame) | |
| 3373 (Lisp_Object specifier, struct frame *f, | |
| 444 | 3374 Lisp_Object oldval), |
| 3375 int always_recompute) | |
| 428 | 3376 { |
| 440 | 3377 Lisp_Specifier *sp = XSPECIFIER (specifier); |
| 428 | 3378 assert (!GHOST_SPECIFIER_P (sp)); |
| 3379 | |
| 3380 if (!sp->caching) | |
| 3092 | 3381 #ifdef NEW_GC |
|
5127
a9c41067dd88
more cleanups, terminology clarification, lots of doc work
Ben Wing <ben@xemacs.org>
parents:
5125
diff
changeset
|
3382 sp->caching = XSPECIFIER_CACHING (ALLOC_NORMAL_LISP_OBJECT (specifier_caching)); |
| 3092 | 3383 #else /* not NEW_GC */ |
| 3659 | 3384 sp->caching = xnew_and_zero (struct specifier_caching); |
| 3092 | 3385 #endif /* not NEW_GC */ |
| 428 | 3386 sp->caching->offset_into_struct_window = struct_window_offset; |
| 3387 sp->caching->value_changed_in_window = value_changed_in_window; | |
| 3388 sp->caching->offset_into_struct_frame = struct_frame_offset; | |
| 3389 sp->caching->value_changed_in_frame = value_changed_in_frame; | |
| 853 | 3390 if (struct_window_offset) |
| 3391 assert (value_changed_in_window); | |
| 3392 if (struct_frame_offset) | |
| 3393 assert (value_changed_in_frame); | |
| 444 | 3394 sp->caching->always_recompute = always_recompute; |
| 428 | 3395 Vcached_specifiers = Fcons (specifier, Vcached_specifiers); |
| 3396 if (BODILY_SPECIFIER_P (sp)) | |
| 5198 | 3397 GHOST_SPECIFIER (sp)->caching = sp->caching; |
| 428 | 3398 recompute_cached_specifier_everywhere (specifier); |
| 3399 } | |
| 3400 | |
| 3401 static void | |
| 3402 recompute_one_cached_specifier_in_window (Lisp_Object specifier, | |
| 3403 struct window *w) | |
| 3404 { | |
| 3405 Lisp_Object window; | |
| 444 | 3406 Lisp_Object newval, *location, oldval; |
| 428 | 3407 |
| 3408 assert (!GHOST_SPECIFIER_P (XSPECIFIER (specifier))); | |
| 3409 | |
| 793 | 3410 window = wrap_window (w); |
| 428 | 3411 |
| 3412 newval = specifier_instance (specifier, Qunbound, window, ERROR_ME_WARN, | |
| 3413 0, 0, Qzero); | |
| 3414 /* If newval ended up Qunbound, then the calling functions | |
| 3415 better be able to deal. If not, set a default so this | |
| 3416 never happens or correct it in the value_changed_in_window | |
| 3417 method. */ | |
| 3418 location = (Lisp_Object *) | |
| 3419 ((char *) w + XSPECIFIER (specifier)->caching->offset_into_struct_window); | |
| 442 | 3420 /* #### What's the point of this check, other than to optimize image |
| 3421 instance instantiation? Unless you specify a caching instantiate | |
| 3422 method the instantiation that specifier_instance will do will | |
| 3423 always create a new copy. Thus EQ will always fail. Unfortunately | |
| 3424 calling equal is no good either as this doesn't take into account | |
| 3425 things attached to the specifier - for instance strings on | |
| 3426 extents. --andyp */ | |
| 444 | 3427 if (!EQ (newval, *location) || XSPECIFIER (specifier)->caching->always_recompute) |
| 428 | 3428 { |
| 444 | 3429 oldval = *location; |
| 428 | 3430 *location = newval; |
| 3431 (XSPECIFIER (specifier)->caching->value_changed_in_window) | |
| 3432 (specifier, w, oldval); | |
| 3433 } | |
| 3434 } | |
| 3435 | |
| 3436 static void | |
| 3437 recompute_one_cached_specifier_in_frame (Lisp_Object specifier, | |
| 3438 struct frame *f) | |
| 3439 { | |
| 3440 Lisp_Object frame; | |
| 444 | 3441 Lisp_Object newval, *location, oldval; |
| 428 | 3442 |
| 3443 assert (!GHOST_SPECIFIER_P (XSPECIFIER (specifier))); | |
| 3444 | |
| 793 | 3445 frame = wrap_frame (f); |
| 428 | 3446 |
| 3447 newval = specifier_instance (specifier, Qunbound, frame, ERROR_ME_WARN, | |
| 3448 0, 0, Qzero); | |
| 3449 /* If newval ended up Qunbound, then the calling functions | |
| 3450 better be able to deal. If not, set a default so this | |
| 3451 never happens or correct it in the value_changed_in_frame | |
| 3452 method. */ | |
| 3453 location = (Lisp_Object *) | |
| 3454 ((char *) f + XSPECIFIER (specifier)->caching->offset_into_struct_frame); | |
| 444 | 3455 if (!EQ (newval, *location) || XSPECIFIER (specifier)->caching->always_recompute) |
| 428 | 3456 { |
| 444 | 3457 oldval = *location; |
| 428 | 3458 *location = newval; |
| 3459 (XSPECIFIER (specifier)->caching->value_changed_in_frame) | |
| 3460 (specifier, f, oldval); | |
| 3461 } | |
| 3462 } | |
| 3463 | |
| 3464 void | |
| 3465 recompute_all_cached_specifiers_in_window (struct window *w) | |
| 3466 { | |
| 3467 Lisp_Object rest; | |
| 3468 | |
| 3469 LIST_LOOP (rest, Vcached_specifiers) | |
| 3470 { | |
| 3471 Lisp_Object specifier = XCAR (rest); | |
| 3472 if (XSPECIFIER (specifier)->caching->offset_into_struct_window) | |
| 3473 recompute_one_cached_specifier_in_window (specifier, w); | |
| 3474 } | |
| 3475 } | |
| 3476 | |
| 3477 void | |
| 3478 recompute_all_cached_specifiers_in_frame (struct frame *f) | |
| 3479 { | |
| 3480 Lisp_Object rest; | |
| 3481 | |
| 3482 LIST_LOOP (rest, Vcached_specifiers) | |
| 3483 { | |
| 3484 Lisp_Object specifier = XCAR (rest); | |
| 3485 if (XSPECIFIER (specifier)->caching->offset_into_struct_frame) | |
| 3486 recompute_one_cached_specifier_in_frame (specifier, f); | |
| 3487 } | |
| 3488 } | |
| 3489 | |
| 3490 static int | |
| 3491 recompute_cached_specifier_everywhere_mapfun (struct window *w, | |
| 3492 void *closure) | |
| 3493 { | |
| 3494 Lisp_Object specifier = Qnil; | |
| 3495 | |
| 5013 | 3496 specifier = GET_LISP_FROM_VOID (closure); |
| 428 | 3497 recompute_one_cached_specifier_in_window (specifier, w); |
| 3498 return 0; | |
| 3499 } | |
| 3500 | |
| 3501 static void | |
| 3502 recompute_cached_specifier_everywhere (Lisp_Object specifier) | |
| 3503 { | |
| 3504 Lisp_Object frmcons, devcons, concons; | |
| 3505 | |
| 3506 specifier = bodily_specifier (specifier); | |
| 3507 | |
| 3508 if (!XSPECIFIER (specifier)->caching) | |
| 3509 return; | |
| 3510 | |
| 3511 if (XSPECIFIER (specifier)->caching->offset_into_struct_window) | |
| 3512 { | |
| 3513 FRAME_LOOP_NO_BREAK (frmcons, devcons, concons) | |
| 3514 map_windows (XFRAME (XCAR (frmcons)), | |
| 3515 recompute_cached_specifier_everywhere_mapfun, | |
| 5013 | 3516 STORE_LISP_IN_VOID (specifier)); |
| 428 | 3517 } |
| 3518 | |
| 3519 if (XSPECIFIER (specifier)->caching->offset_into_struct_frame) | |
| 3520 { | |
| 3521 FRAME_LOOP_NO_BREAK (frmcons, devcons, concons) | |
| 3522 recompute_one_cached_specifier_in_frame (specifier, | |
| 3523 XFRAME (XCAR (frmcons))); | |
| 3524 } | |
| 3525 } | |
| 3526 | |
| 3527 DEFUN ("set-specifier-dirty-flag", Fset_specifier_dirty_flag, 1, 1, 0, /* | |
| 3528 Force recomputation of any caches associated with SPECIFIER. | |
| 3529 Note that this automatically happens whenever you change a specification | |
| 3530 in SPECIFIER; you do not have to call this function then. | |
| 3531 One example of where this function is useful is when you have a | |
| 3532 toolbar button whose `active-p' field is an expression to be | |
| 3533 evaluated. Calling `set-specifier-dirty-flag' on the | |
| 3534 toolbar specifier will force the `active-p' fields to be | |
| 3535 recomputed. | |
| 3536 */ | |
| 3537 (specifier)) | |
| 3538 { | |
| 3539 CHECK_SPECIFIER (specifier); | |
| 3540 recompute_cached_specifier_everywhere (specifier); | |
| 3541 return Qnil; | |
| 3542 } | |
| 3543 | |
| 3544 | |
| 3545 /************************************************************************/ | |
| 3546 /* Generic specifier type */ | |
| 3547 /************************************************************************/ | |
| 3548 | |
| 3549 DEFINE_SPECIFIER_TYPE (generic); | |
| 3550 | |
| 3551 #if 0 | |
| 3552 | |
| 3553 /* This is the string that used to be in `generic-specifier-p'. | |
| 3554 The idea is good, but it doesn't quite work in the form it's | |
| 3555 in. (One major problem is that validating an instantiator | |
| 3556 is supposed to require only that the specifier type is passed, | |
| 3557 while with this approach the actual specifier is needed.) | |
| 3558 | |
| 3559 What really needs to be done is to write a function | |
| 3560 `make-specifier-type' that creates new specifier types. | |
| 442 | 3561 |
| 3562 #### [I'll look into this for 19.14.] Well, sometime. (Currently | |
| 3563 May 2000, 21.2 is in development. 19.14 was released in June 1996.) */ | |
| 428 | 3564 |
| 3565 "A generic specifier is a generalized kind of specifier with user-defined\n" | |
| 3566 "semantics. The instantiator can be any kind of Lisp object, and the\n" | |
| 3567 "instance computed from it is likewise any kind of Lisp object. The\n" | |
| 3568 "SPECIFIER-DATA should be an alist of methods governing how the specifier\n" | |
| 3569 "works. All methods are optional, and reasonable default methods will be\n" | |
| 2953 | 3570 "provided. Currently there are two defined methods: `instantiate' and\n" |
| 3571 "`validate'.\n" | |
| 428 | 3572 "\n" |
| 2953 | 3573 "`instantiate' specifies how to do the instantiation; if omitted, the\n" |
| 428 | 3574 "instantiator itself is simply returned as the instance. The method\n" |
| 3575 "should be a function that accepts three parameters (a specifier, the\n" | |
| 3576 "instantiator that matched the domain being instantiated over, and that\n" | |
| 3577 "domain), and should return a one-element list containing the instance,\n" | |
| 3578 "or nil if no instance exists. Note that the domain passed to this function\n" | |
| 3579 "is the domain being instantiated over, which may not be the same as the\n" | |
| 3580 "locale contained in the specification corresponding to the instantiator\n" | |
| 3581 "(for example, the domain being instantiated over could be a window, but\n" | |
| 3582 "the locale corresponding to the passed instantiator could be the window's\n" | |
| 3583 "buffer or frame).\n" | |
| 3584 "\n" | |
| 2953 | 3585 "`validate' specifies whether a given instantiator is valid; if omitted,\n" |
| 428 | 3586 "all instantiators are considered valid. It should be a function of\n" |
| 3587 "two arguments: an instantiator and a flag CAN-SIGNAL-ERROR. If this\n" | |
| 3588 "flag is false, the function must simply return t or nil indicating\n" | |
| 3589 "whether the instantiator is valid. If this flag is true, the function\n" | |
| 3590 "is free to signal an error if it encounters an invalid instantiator\n" | |
| 3591 "(this can be useful for issuing a specific error about exactly why the\n" | |
| 3592 "instantiator is valid). It can also return nil to indicate an invalid\n" | |
| 3593 "instantiator; in this case, a general error will be signalled." | |
| 3594 | |
| 3595 #endif /* 0 */ | |
| 3596 | |
| 3597 DEFUN ("generic-specifier-p", Fgeneric_specifier_p, 1, 1, 0, /* | |
| 3598 Return non-nil if OBJECT is a generic specifier. | |
| 3599 | |
| 442 | 3600 See `make-generic-specifier' for a description of possible generic |
| 3601 instantiators. | |
| 428 | 3602 */ |
| 3603 (object)) | |
| 3604 { | |
| 3605 return GENERIC_SPECIFIERP (object) ? Qt : Qnil; | |
| 3606 } | |
| 3607 | |
| 3608 | |
| 3609 /************************************************************************/ | |
| 3610 /* Integer specifier type */ | |
| 3611 /************************************************************************/ | |
| 3612 | |
| 3613 DEFINE_SPECIFIER_TYPE (integer); | |
| 3614 | |
| 3615 static void | |
| 3616 integer_validate (Lisp_Object instantiator) | |
| 3617 { | |
| 3618 CHECK_INT (instantiator); | |
| 3619 } | |
| 3620 | |
| 3621 DEFUN ("integer-specifier-p", Finteger_specifier_p, 1, 1, 0, /* | |
| 3622 Return non-nil if OBJECT is an integer specifier. | |
| 442 | 3623 |
| 3624 See `make-integer-specifier' for a description of possible integer | |
| 3625 instantiators. | |
| 428 | 3626 */ |
| 3627 (object)) | |
| 3628 { | |
| 3629 return INTEGER_SPECIFIERP (object) ? Qt : Qnil; | |
| 3630 } | |
| 3631 | |
| 3632 /************************************************************************/ | |
| 3633 /* Non-negative-integer specifier type */ | |
| 3634 /************************************************************************/ | |
| 3635 | |
| 3636 DEFINE_SPECIFIER_TYPE (natnum); | |
| 3637 | |
| 3638 static void | |
| 3639 natnum_validate (Lisp_Object instantiator) | |
| 3640 { | |
| 3641 CHECK_NATNUM (instantiator); | |
| 3642 } | |
| 3643 | |
| 3644 DEFUN ("natnum-specifier-p", Fnatnum_specifier_p, 1, 1, 0, /* | |
| 3645 Return non-nil if OBJECT is a natnum (non-negative-integer) specifier. | |
| 442 | 3646 |
| 3647 See `make-natnum-specifier' for a description of possible natnum | |
| 3648 instantiators. | |
| 428 | 3649 */ |
| 3650 (object)) | |
| 3651 { | |
| 3652 return NATNUM_SPECIFIERP (object) ? Qt : Qnil; | |
| 3653 } | |
| 3654 | |
| 3655 /************************************************************************/ | |
| 3656 /* Boolean specifier type */ | |
| 3657 /************************************************************************/ | |
| 3658 | |
| 3659 DEFINE_SPECIFIER_TYPE (boolean); | |
| 3660 | |
| 3661 static void | |
| 3662 boolean_validate (Lisp_Object instantiator) | |
| 3663 { | |
| 3664 if (!EQ (instantiator, Qt) && !EQ (instantiator, Qnil)) | |
| 563 | 3665 invalid_constant ("Must be t or nil", instantiator); |
| 428 | 3666 } |
| 3667 | |
| 3668 DEFUN ("boolean-specifier-p", Fboolean_specifier_p, 1, 1, 0, /* | |
| 3669 Return non-nil if OBJECT is a boolean specifier. | |
| 442 | 3670 |
| 3671 See `make-boolean-specifier' for a description of possible boolean | |
| 3672 instantiators. | |
| 428 | 3673 */ |
| 3674 (object)) | |
| 3675 { | |
| 3676 return BOOLEAN_SPECIFIERP (object) ? Qt : Qnil; | |
| 3677 } | |
| 3678 | |
| 3679 /************************************************************************/ | |
| 3680 /* Display table specifier type */ | |
| 3681 /************************************************************************/ | |
| 3682 | |
| 3683 DEFINE_SPECIFIER_TYPE (display_table); | |
| 3684 | |
| 3659 | 3685 #define VALID_SINGLE_DISPTABLE_INSTANTIATOR_P(instantiator) \ |
| 3686 (VECTORP (instantiator) \ | |
| 3687 || (CHAR_TABLEP (instantiator) \ | |
| 3688 && (XCHAR_TABLE_TYPE (instantiator) == CHAR_TABLE_TYPE_CHAR \ | |
| 442 | 3689 || XCHAR_TABLE_TYPE (instantiator) == CHAR_TABLE_TYPE_GENERIC)) \ |
| 428 | 3690 || RANGE_TABLEP (instantiator)) |
| 3691 | |
| 3692 static void | |
| 3693 display_table_validate (Lisp_Object instantiator) | |
| 3694 { | |
| 3695 if (NILP (instantiator)) | |
| 3696 /* OK */ | |
| 3697 ; | |
| 3698 else if (CONSP (instantiator)) | |
| 3699 { | |
| 2367 | 3700 EXTERNAL_LIST_LOOP_2 (car, instantiator) |
| 428 | 3701 { |
| 3702 if (!VALID_SINGLE_DISPTABLE_INSTANTIATOR_P (car)) | |
| 3703 goto lose; | |
| 3704 } | |
| 3705 } | |
| 3706 else | |
| 3707 { | |
| 3708 if (!VALID_SINGLE_DISPTABLE_INSTANTIATOR_P (instantiator)) | |
| 3709 { | |
| 3710 lose: | |
| 442 | 3711 dead_wrong_type_argument |
| 3712 (display_table_specifier_methods->predicate_symbol, | |
| 3659 | 3713 instantiator); |
| 428 | 3714 } |
| 3715 } | |
| 3716 } | |
| 3717 | |
| 3718 DEFUN ("display-table-specifier-p", Fdisplay_table_specifier_p, 1, 1, 0, /* | |
| 3719 Return non-nil if OBJECT is a display-table specifier. | |
| 442 | 3720 |
| 3721 See `current-display-table' for a description of possible display-table | |
| 3722 instantiators. | |
| 428 | 3723 */ |
| 3724 (object)) | |
| 3725 { | |
| 3726 return DISPLAYTABLE_SPECIFIERP (object) ? Qt : Qnil; | |
| 3727 } | |
| 3728 | |
|
5179
14fda1dbdb26
add memory usage info for specifiers
Ben Wing <ben@xemacs.org>
parents:
5169
diff
changeset
|
3729 |
|
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 #ifdef MEMORY_USAGE_STATS |
|
14fda1dbdb26
add memory usage info for specifiers
Ben Wing <ben@xemacs.org>
parents:
5169
diff
changeset
|
3732 |
|
14fda1dbdb26
add memory usage info for specifiers
Ben Wing <ben@xemacs.org>
parents:
5169
diff
changeset
|
3733 struct specifier_stats |
|
14fda1dbdb26
add memory usage info for specifiers
Ben Wing <ben@xemacs.org>
parents:
5169
diff
changeset
|
3734 { |
|
14fda1dbdb26
add memory usage info for specifiers
Ben Wing <ben@xemacs.org>
parents:
5169
diff
changeset
|
3735 struct usage_stats u; |
|
14fda1dbdb26
add memory usage info for specifiers
Ben Wing <ben@xemacs.org>
parents:
5169
diff
changeset
|
3736 /* Ancillary Lisp */ |
|
14fda1dbdb26
add memory usage info for specifiers
Ben Wing <ben@xemacs.org>
parents:
5169
diff
changeset
|
3737 Bytecount global, device, frame, window, buffer, fallback; |
|
14fda1dbdb26
add memory usage info for specifiers
Ben Wing <ben@xemacs.org>
parents:
5169
diff
changeset
|
3738 Bytecount magic_parent; |
|
14fda1dbdb26
add memory usage info for specifiers
Ben Wing <ben@xemacs.org>
parents:
5169
diff
changeset
|
3739 }; |
|
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 static void |
|
5202
1c615eb1e4b2
disable specifier memory usage for the moment
Ben Wing <ben@xemacs.org>
parents:
5198
diff
changeset
|
3742 specifier_memory_usage (Lisp_Object UNUSED (specifier), |
|
1c615eb1e4b2
disable specifier memory usage for the moment
Ben Wing <ben@xemacs.org>
parents:
5198
diff
changeset
|
3743 struct generic_usage_stats * UNUSED (gustats)) |
|
5179
14fda1dbdb26
add memory usage info for specifiers
Ben Wing <ben@xemacs.org>
parents:
5169
diff
changeset
|
3744 { |
|
5202
1c615eb1e4b2
disable specifier memory usage for the moment
Ben Wing <ben@xemacs.org>
parents:
5198
diff
changeset
|
3745 #if 0 |
|
5179
14fda1dbdb26
add memory usage info for specifiers
Ben Wing <ben@xemacs.org>
parents:
5169
diff
changeset
|
3746 struct specifier_stats *stats = (struct specifier_stats *) gustats; |
|
14fda1dbdb26
add memory usage info for specifiers
Ben Wing <ben@xemacs.org>
parents:
5169
diff
changeset
|
3747 Lisp_Specifier *spec = XSPECIFIER (specifier); |
|
14fda1dbdb26
add memory usage info for specifiers
Ben Wing <ben@xemacs.org>
parents:
5169
diff
changeset
|
3748 |
|
5202
1c615eb1e4b2
disable specifier memory usage for the moment
Ben Wing <ben@xemacs.org>
parents:
5198
diff
changeset
|
3749 /* #### 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
|
3750 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
|
3751 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
|
3752 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
|
3753 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
|
3754 structures shouldn't exist. */ |
|
5179
14fda1dbdb26
add memory usage info for specifiers
Ben Wing <ben@xemacs.org>
parents:
5169
diff
changeset
|
3755 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
|
3756 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
|
3757 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
|
3758 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
|
3759 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
|
3760 stats->fallback = tree_memory_usage (spec->fallback, 1); |
|
14fda1dbdb26
add memory usage info for specifiers
Ben Wing <ben@xemacs.org>
parents:
5169
diff
changeset
|
3761 if (SPECIFIERP (spec->magic_parent)) |
|
14fda1dbdb26
add memory usage info for specifiers
Ben Wing <ben@xemacs.org>
parents:
5169
diff
changeset
|
3762 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
|
3763 #endif |
|
5179
14fda1dbdb26
add memory usage info for specifiers
Ben Wing <ben@xemacs.org>
parents:
5169
diff
changeset
|
3764 } |
|
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 #endif /* MEMORY_USAGE_STATS */ |
| 428 | 3767 |
| 3768 /************************************************************************/ | |
| 3769 /* Initialization */ | |
| 3770 /************************************************************************/ | |
|
5179
14fda1dbdb26
add memory usage info for specifiers
Ben Wing <ben@xemacs.org>
parents:
5169
diff
changeset
|
3771 |
|
14fda1dbdb26
add memory usage info for specifiers
Ben Wing <ben@xemacs.org>
parents:
5169
diff
changeset
|
3772 void |
|
14fda1dbdb26
add memory usage info for specifiers
Ben Wing <ben@xemacs.org>
parents:
5169
diff
changeset
|
3773 specifier_objects_create (void) |
|
14fda1dbdb26
add memory usage info for specifiers
Ben Wing <ben@xemacs.org>
parents:
5169
diff
changeset
|
3774 { |
|
14fda1dbdb26
add memory usage info for specifiers
Ben Wing <ben@xemacs.org>
parents:
5169
diff
changeset
|
3775 #ifdef MEMORY_USAGE_STATS |
|
14fda1dbdb26
add memory usage info for specifiers
Ben Wing <ben@xemacs.org>
parents:
5169
diff
changeset
|
3776 OBJECT_HAS_METHOD (specifier, memory_usage); |
|
14fda1dbdb26
add memory usage info for specifiers
Ben Wing <ben@xemacs.org>
parents:
5169
diff
changeset
|
3777 #endif |
|
14fda1dbdb26
add memory usage info for specifiers
Ben Wing <ben@xemacs.org>
parents:
5169
diff
changeset
|
3778 } |
| 428 | 3779 |
| 3780 void | |
| 3781 syms_of_specifier (void) | |
| 3782 { | |
|
5117
3742ea8250b5
Checking in final CVS version of workspace 'ben-lisp-object'
Ben Wing <ben@xemacs.org>
parents:
3017
diff
changeset
|
3783 INIT_LISP_OBJECT (specifier); |
| 3092 | 3784 #ifdef NEW_GC |
|
5118
e0db3c197671
merge up to latest default branch, doesn't compile yet
Ben Wing <ben@xemacs.org>
diff
changeset
|
3785 INIT_LISP_OBJECT (specifier_caching); |
| 3092 | 3786 #endif /* NEW_GC */ |
| 442 | 3787 |
| 3788 DEFSYMBOL (Qspecifierp); | |
| 3789 | |
| 3790 DEFSYMBOL (Qconsole_type); | |
| 3791 DEFSYMBOL (Qdevice_class); | |
| 3792 | |
| 3793 /* specifier types defined in general.c. */ | |
| 428 | 3794 |
| 3795 DEFSUBR (Fvalid_specifier_type_p); | |
| 3796 DEFSUBR (Fspecifier_type_list); | |
| 3797 DEFSUBR (Fmake_specifier); | |
| 3798 DEFSUBR (Fspecifierp); | |
| 3799 DEFSUBR (Fspecifier_type); | |
| 3800 | |
| 3801 DEFSUBR (Fvalid_specifier_locale_p); | |
| 3802 DEFSUBR (Fvalid_specifier_domain_p); | |
| 3803 DEFSUBR (Fvalid_specifier_locale_type_p); | |
| 3804 DEFSUBR (Fspecifier_locale_type_from_locale); | |
| 3805 | |
| 3806 DEFSUBR (Fvalid_specifier_tag_p); | |
| 3807 DEFSUBR (Fvalid_specifier_tag_set_p); | |
| 3808 DEFSUBR (Fcanonicalize_tag_set); | |
| 3809 DEFSUBR (Fdevice_matches_specifier_tag_set_p); | |
| 3810 DEFSUBR (Fdefine_specifier_tag); | |
| 3811 DEFSUBR (Fdevice_matching_specifier_tag_list); | |
| 3673 | 3812 |
| 428 | 3813 DEFSUBR (Fspecifier_tag_list); |
| 3659 | 3814 DEFSUBR (Fspecifier_tag_device_predicate); |
| 3815 DEFSUBR (Fspecifier_tag_charset_predicate); | |
| 428 | 3816 |
| 3817 DEFSUBR (Fcheck_valid_instantiator); | |
| 3818 DEFSUBR (Fvalid_instantiator_p); | |
| 3819 DEFSUBR (Fcheck_valid_inst_list); | |
| 3820 DEFSUBR (Fvalid_inst_list_p); | |
| 3821 DEFSUBR (Fcheck_valid_spec_list); | |
| 3822 DEFSUBR (Fvalid_spec_list_p); | |
| 3823 DEFSUBR (Fadd_spec_to_specifier); | |
| 3824 DEFSUBR (Fadd_spec_list_to_specifier); | |
| 3825 DEFSUBR (Fspecifier_spec_list); | |
| 3826 DEFSUBR (Fspecifier_specs); | |
| 3827 DEFSUBR (Fremove_specifier); | |
| 3828 DEFSUBR (Fcopy_specifier); | |
| 3829 | |
| 3830 DEFSUBR (Fcheck_valid_specifier_matchspec); | |
| 3831 DEFSUBR (Fvalid_specifier_matchspec_p); | |
| 3832 DEFSUBR (Fspecifier_fallback); | |
| 3833 DEFSUBR (Fspecifier_instance); | |
| 2953 | 3834 DEFSUBR (Fspecifier_instantiator); |
| 428 | 3835 DEFSUBR (Fspecifier_matching_instance); |
| 2953 | 3836 DEFSUBR (Fspecifier_matching_instantiator); |
| 428 | 3837 DEFSUBR (Fspecifier_instance_from_inst_list); |
| 2953 | 3838 DEFSUBR (Fspecifier_instantiator_from_inst_list); |
| 428 | 3839 DEFSUBR (Fspecifier_matching_instance_from_inst_list); |
| 2953 | 3840 DEFSUBR (Fspecifier_matching_instantiator_from_inst_list); |
| 428 | 3841 DEFSUBR (Fset_specifier_dirty_flag); |
| 3842 | |
| 3843 DEFSUBR (Fgeneric_specifier_p); | |
| 3844 DEFSUBR (Finteger_specifier_p); | |
| 3845 DEFSUBR (Fnatnum_specifier_p); | |
| 3846 DEFSUBR (Fboolean_specifier_p); | |
| 3847 DEFSUBR (Fdisplay_table_specifier_p); | |
| 3848 | |
| 3849 /* Symbols pertaining to specifier creation. Specifiers are created | |
| 3850 in the syms_of() functions. */ | |
| 3851 | |
| 3852 /* locales are defined in general.c. */ | |
| 3853 | |
| 442 | 3854 /* some how-to-add flags in general.c. */ |
| 3855 DEFSYMBOL (Qremove_tag_set_prepend); | |
| 3856 DEFSYMBOL (Qremove_tag_set_append); | |
| 3857 DEFSYMBOL (Qremove_locale); | |
| 3858 DEFSYMBOL (Qremove_locale_type); | |
| 428 | 3859 } |
| 3860 | |
| 3861 void | |
| 3862 specifier_type_create (void) | |
| 3863 { | |
| 3864 the_specifier_type_entry_dynarr = Dynarr_new (specifier_type_entry); | |
| 2367 | 3865 dump_add_root_block_ptr (&the_specifier_type_entry_dynarr, &sted_description); |
| 428 | 3866 |
| 3867 Vspecifier_type_list = Qnil; | |
| 3868 staticpro (&Vspecifier_type_list); | |
| 3869 | |
| 3870 INITIALIZE_SPECIFIER_TYPE (generic, "generic", "generic-specifier-p"); | |
| 3871 | |
| 3872 INITIALIZE_SPECIFIER_TYPE (integer, "integer", "integer-specifier-p"); | |
| 3873 | |
| 3874 SPECIFIER_HAS_METHOD (integer, validate); | |
| 3875 | |
| 3876 INITIALIZE_SPECIFIER_TYPE (natnum, "natnum", "natnum-specifier-p"); | |
| 3877 | |
| 3878 SPECIFIER_HAS_METHOD (natnum, validate); | |
| 3879 | |
| 3880 INITIALIZE_SPECIFIER_TYPE (boolean, "boolean", "boolean-specifier-p"); | |
| 3881 | |
| 3882 SPECIFIER_HAS_METHOD (boolean, validate); | |
| 3883 | |
| 442 | 3884 INITIALIZE_SPECIFIER_TYPE (display_table, "display-table", |
| 3885 "display-table-p"); | |
| 428 | 3886 |
| 3887 SPECIFIER_HAS_METHOD (display_table, validate); | |
| 3888 } | |
| 3889 | |
| 3890 void | |
| 3891 reinit_specifier_type_create (void) | |
| 3892 { | |
| 3893 REINITIALIZE_SPECIFIER_TYPE (generic); | |
| 3894 REINITIALIZE_SPECIFIER_TYPE (integer); | |
| 3895 REINITIALIZE_SPECIFIER_TYPE (natnum); | |
| 3896 REINITIALIZE_SPECIFIER_TYPE (boolean); | |
| 3897 REINITIALIZE_SPECIFIER_TYPE (display_table); | |
| 3898 } | |
| 3899 | |
| 3900 void | |
| 3901 vars_of_specifier (void) | |
| 3902 { | |
|
5179
14fda1dbdb26
add memory usage info for specifiers
Ben Wing <ben@xemacs.org>
parents:
5169
diff
changeset
|
3903 #ifdef MEMORY_USAGE_STATS |
|
14fda1dbdb26
add memory usage info for specifiers
Ben Wing <ben@xemacs.org>
parents:
5169
diff
changeset
|
3904 OBJECT_HAS_PROPERTY (specifier, memusage_stats_list, |
|
14fda1dbdb26
add memory usage info for specifiers
Ben Wing <ben@xemacs.org>
parents:
5169
diff
changeset
|
3905 listu (Qt, Qglobal, Qdevice, Qframe, Qwindow, Qbuffer, |
|
14fda1dbdb26
add memory usage info for specifiers
Ben Wing <ben@xemacs.org>
parents:
5169
diff
changeset
|
3906 Qfallback, intern ("magic-parent"), |
|
14fda1dbdb26
add memory usage info for specifiers
Ben Wing <ben@xemacs.org>
parents:
5169
diff
changeset
|
3907 Qunbound)); |
|
14fda1dbdb26
add memory usage info for specifiers
Ben Wing <ben@xemacs.org>
parents:
5169
diff
changeset
|
3908 #endif /* MEMORY_USAGE_STATS */ |
|
14fda1dbdb26
add memory usage info for specifiers
Ben Wing <ben@xemacs.org>
parents:
5169
diff
changeset
|
3909 |
| 428 | 3910 Vcached_specifiers = Qnil; |
| 3911 staticpro (&Vcached_specifiers); | |
| 3912 | |
| 3913 /* Do NOT mark through this, or specifiers will never be GC'd. | |
| 3914 This is the same deal as for weak hash tables. */ | |
| 3915 Vall_specifiers = Qnil; | |
| 452 | 3916 dump_add_weak_object_chain (&Vall_specifiers); |
| 428 | 3917 |
| 3918 Vuser_defined_tags = Qnil; | |
| 3919 staticpro (&Vuser_defined_tags); | |
| 3920 | |
| 3921 Vunlock_ghost_specifiers = Qnil; | |
| 3922 staticpro (&Vunlock_ghost_specifiers); | |
| 3659 | 3923 |
|
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
|
3924 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
|
3925 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
|
3926 staticpro (&Vcharset_tag_lists); |
| 428 | 3927 } |