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