1 /* Specifier implementation
2 Copyright (C) 1994, 1995 Board of Trustees, University of Illinois.
3 Copyright (C) 1995, 1996 Ben Wing.
4 Copyright (C) 1995 Sun Microsystems, Inc.
6 This file is part of SXEmacs
8 SXEmacs is free software: you can redistribute it and/or modify
9 it under the terms of the GNU General Public License as published by
10 the Free Software Foundation, either version 3 of the License, or
11 (at your option) any later version.
13 SXEmacs is distributed in the hope that it will be useful,
14 but WITHOUT ANY WARRANTY; without even the implied warranty of
15 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
16 GNU General Public License for more details.
18 You should have received a copy of the GNU General Public License
19 along with this program. If not, see <http://www.gnu.org/licenses/>. */
22 /* Synched up with: Not in FSF. */
24 /* Design by Ben Wing;
25 Original version by Chuck Thompson;
26 rewritten by Ben Wing;
27 Magic specifiers by Kirill Katsnelson;
37 #include "specifier.h"
42 Lisp_Object Qspecifierp;
43 Lisp_Object Qremove_tag_set_prepend, Qremove_tag_set_append;
44 Lisp_Object Qremove_locale, Qremove_locale_type;
46 Lisp_Object Qconsole_type, Qdevice_class;
48 Lisp_Object Qspecifier_syntax_error;
49 Lisp_Object Qspecifier_argument_error;
50 Lisp_Object Qspecifier_change_error;
52 static Lisp_Object Vuser_defined_tags;
54 typedef struct specifier_type_entry specifier_type_entry;
55 struct specifier_type_entry {
57 struct specifier_methods *meths;
61 Dynarr_declare(specifier_type_entry);
62 } specifier_type_entry_dynarr;
64 static specifier_type_entry_dynarr *the_specifier_type_entry_dynarr;
66 static const struct lrecord_description ste_description_1[] = {
67 {XD_LISP_OBJECT, offsetof(specifier_type_entry, symbol)},
68 {XD_STRUCT_PTR, offsetof(specifier_type_entry, meths), 1,
69 &specifier_methods_description},
73 static const struct struct_description ste_description = {
74 sizeof(specifier_type_entry),
78 static const struct lrecord_description sted_description_1[] = {
79 XD_DYNARR_DESC(specifier_type_entry_dynarr, &ste_description),
83 static const struct struct_description sted_description = {
84 sizeof(specifier_type_entry_dynarr),
88 static Lisp_Object Vspecifier_type_list;
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;
94 static Lisp_Object Vunlock_ghost_specifiers;
96 /* #### The purpose of this is to check for inheritance loops
97 in specifiers that can inherit from other specifiers, but it's
100 #### Look into this for 19.14. */
101 /* static Lisp_Object_dynarr current_specifiers; */
103 static void recompute_cached_specifier_everywhere(Lisp_Object specifier);
105 EXFUN(Fspecifier_specs, 4);
106 EXFUN(Fremove_specifier, 4);
108 /************************************************************************/
109 /* Specifier object methods */
110 /************************************************************************/
112 /* Remove dead objects from the specified assoc list. */
114 static Lisp_Object cleanup_assoc_list(Lisp_Object list)
116 Lisp_Object loop, prev, retval;
118 loop = retval = list;
121 while (!NILP(loop)) {
122 Lisp_Object entry = XCAR(loop);
123 Lisp_Object key = XCAR(entry);
125 /* remember, dead windows can become alive again. */
126 if (!WINDOWP(key) && object_dead_p(key)) {
128 /* Removing the head. */
129 retval = XCDR(retval);
131 Fsetcdr(prev, XCDR(loop));
142 /* Remove dead objects from the various lists so that they
143 don't keep getting marked as long as this specifier exists and
144 therefore wasting memory. */
146 void cleanup_specifiers(void)
150 for (rest = Vall_specifiers;
151 !NILP(rest); rest = XSPECIFIER(rest)->next_specifier) {
152 Lisp_Specifier *sp = XSPECIFIER(rest);
153 /* This effectively changes the specifier specs.
154 However, there's no need to call
155 recompute_cached_specifier_everywhere() or the
156 after-change methods because the only specs we
157 are removing are for dead objects, and they can
158 never have any effect on the specifier values:
159 specifiers can only be instantiated over live
160 objects, and you can't derive a dead object
162 sp->device_specs = cleanup_assoc_list(sp->device_specs);
163 sp->frame_specs = cleanup_assoc_list(sp->frame_specs);
164 sp->buffer_specs = cleanup_assoc_list(sp->buffer_specs);
165 /* windows are handled specially because dead windows
166 can be resurrected */
170 void kill_specifier_buffer_locals(Lisp_Object buffer)
174 for (rest = Vall_specifiers;
175 !NILP(rest); rest = XSPECIFIER(rest)->next_specifier) {
176 Lisp_Specifier *sp = XSPECIFIER(rest);
178 /* Make sure we're actually going to be changing something.
179 Fremove_specifier() always calls
180 recompute_cached_specifier_everywhere() (#### but should
181 be smarter about this). */
182 if (!NILP(assq_no_quit(buffer, sp->buffer_specs)))
183 Fremove_specifier(rest, buffer, Qnil, Qnil);
187 static Lisp_Object mark_specifier(Lisp_Object obj)
189 Lisp_Specifier *specifier = XSPECIFIER(obj);
191 mark_object(specifier->global_specs);
192 mark_object(specifier->device_specs);
193 mark_object(specifier->frame_specs);
194 mark_object(specifier->window_specs);
195 mark_object(specifier->buffer_specs);
196 mark_object(specifier->magic_parent);
197 mark_object(specifier->fallback);
198 if (!GHOST_SPECIFIER_P(XSPECIFIER(obj)))
199 MAYBE_SPECMETH(specifier, mark, (obj));
203 /* The idea here is that the specifier specs point to locales
204 (windows, buffers, frames, and devices), and we want to make sure
205 that the specs disappear automatically when the associated locale
206 is no longer in use. For all but windows, "no longer in use"
207 corresponds exactly to when the object is deleted (non-deleted
208 objects are always held permanently in special lists, and deleted
209 objects are never on these lists and never reusable). To handle
210 this, we just have cleanup_specifiers() called periodically
211 (at the beginning of garbage collection); it removes all dead
214 For windows, however, it's trickier because dead objects can be
215 converted to live ones again if the dead object is in a window
216 configuration. Therefore, for windows, "no longer in use"
217 corresponds to when the window object is garbage-collected.
218 We now use weak lists for this purpose.
222 void prune_specifiers(void)
224 Lisp_Object rest, prev = Qnil;
226 for (rest = Vall_specifiers;
227 !NILP(rest); rest = XSPECIFIER(rest)->next_specifier) {
228 if (!marked_p(rest)) {
229 Lisp_Specifier *sp = XSPECIFIER(rest);
230 /* A bit of assertion that we're removing both parts of the
231 magic one altogether */
232 #if !defined HAVE_BDWGC || !defined EF_USE_BDWGC
233 # define MARKED_P(a) marked_p(a)
235 # define MARKED_P(a) 1
237 assert(!MAGIC_SPECIFIER_P(sp)
238 || ( BODILY_SPECIFIER_P(sp) &&
239 MARKED_P(sp->fallback) )
240 || ( GHOST_SPECIFIER_P(sp) &&
241 MARKED_P(sp->magic_parent)));
243 /* This specifier is garbage. Remove it from the list. */
245 Vall_specifiers = sp->next_specifier;
247 XSPECIFIER(prev)->next_specifier =
255 print_specifier(Lisp_Object obj, Lisp_Object printcharfun, int escapeflag)
257 Lisp_Specifier *sp = XSPECIFIER(obj);
258 int count = specpdl_depth();
259 Lisp_Object the_specs;
262 error("printing unreadable object #<%s-specifier 0x%x>",
263 sp->methods->name, sp->header.uid);
265 write_fmt_string(printcharfun, "#<%s-specifier global=", sp->methods->name);
266 specbind(Qprint_string_length, make_int(100));
267 specbind(Qprint_length, make_int(5));
268 the_specs = Fspecifier_specs(obj, Qglobal, Qnil, Qnil);
270 /* there are no global specs */
271 write_c_string("<unspecified>", printcharfun);
273 print_internal(the_specs, printcharfun, 1);
274 if (!NILP(sp->fallback)) {
275 write_c_string(" fallback=", printcharfun);
276 print_internal(sp->fallback, printcharfun, escapeflag);
278 unbind_to(count, Qnil);
279 write_fmt_str(printcharfun," 0x%x>", sp->header.uid);
282 static void finalize_specifier(void *header, int for_disksave)
284 Lisp_Specifier *sp = (Lisp_Specifier *) header;
285 /* don't be snafued by the disksave finalization. */
286 if (!for_disksave && !GHOST_SPECIFIER_P(sp) && sp->caching) {
292 static int specifier_equal(Lisp_Object obj1, Lisp_Object obj2, int depth)
294 Lisp_Specifier *s1 = XSPECIFIER(obj1);
295 Lisp_Specifier *s2 = XSPECIFIER(obj2);
297 Lisp_Object old_inhibit_quit = Vinhibit_quit;
299 /* This function can be called from within redisplay.
300 internal_equal can trigger a quit. That leads to Bad Things. */
305 (s1->methods == s2->methods &&
306 internal_equal(s1->global_specs, s2->global_specs, depth) &&
307 internal_equal(s1->device_specs, s2->device_specs, depth) &&
308 internal_equal(s1->frame_specs, s2->frame_specs, depth) &&
309 internal_equal(s1->window_specs, s2->window_specs, depth) &&
310 internal_equal(s1->buffer_specs, s2->buffer_specs, depth) &&
311 internal_equal(s1->fallback, s2->fallback, depth));
313 if (retval && HAS_SPECMETH_P(s1, equal))
314 retval = SPECMETH(s1, equal, (obj1, obj2, depth - 1));
316 Vinhibit_quit = old_inhibit_quit;
320 static unsigned long specifier_hash(Lisp_Object obj, int depth)
322 Lisp_Specifier *s = XSPECIFIER(obj);
324 /* specifier hashing is a bit problematic because there are so
325 many places where data can be stored. We pick what are perhaps
326 the most likely places where interesting stuff will be. */
327 return HASH5((HAS_SPECMETH_P(s, hash) ?
328 SPECMETH(s, hash, (obj, depth)) : 0),
329 (unsigned long)s->methods,
330 internal_hash(s->global_specs, depth + 1),
331 internal_hash(s->frame_specs, depth + 1),
332 internal_hash(s->buffer_specs, depth + 1));
336 aligned_sizeof_specifier(size_t specifier_type_specific_size)
338 return ALIGN_SIZE(offsetof(Lisp_Specifier, data)
339 + specifier_type_specific_size, ALIGNOF(sxe_max_align_t));
342 static size_t sizeof_specifier(const void *header)
344 const Lisp_Specifier *p = (const Lisp_Specifier *)header;
345 return aligned_sizeof_specifier(GHOST_SPECIFIER_P(p)
346 ? 0 : p->methods->extra_data_size);
349 static const struct lrecord_description specifier_methods_description_1[] = {
350 {XD_LISP_OBJECT, offsetof(struct specifier_methods, predicate_symbol)},
354 const struct struct_description specifier_methods_description = {
355 sizeof(struct specifier_methods),
356 specifier_methods_description_1
359 static const struct lrecord_description specifier_caching_description_1[] = {
363 static const struct struct_description specifier_caching_description = {
364 sizeof(struct specifier_caching),
365 specifier_caching_description_1
368 static const struct lrecord_description specifier_description[] = {
369 {XD_STRUCT_PTR, offsetof(Lisp_Specifier, methods), 1,
370 &specifier_methods_description},
371 {XD_LO_LINK, offsetof(Lisp_Specifier, next_specifier)},
372 {XD_LISP_OBJECT, offsetof(Lisp_Specifier, global_specs)},
373 {XD_LISP_OBJECT, offsetof(Lisp_Specifier, device_specs)},
374 {XD_LISP_OBJECT, offsetof(Lisp_Specifier, frame_specs)},
375 {XD_LISP_OBJECT, offsetof(Lisp_Specifier, window_specs)},
376 {XD_LISP_OBJECT, offsetof(Lisp_Specifier, buffer_specs)},
377 {XD_STRUCT_PTR, offsetof(Lisp_Specifier, caching), 1,
378 &specifier_caching_description},
379 {XD_LISP_OBJECT, offsetof(Lisp_Specifier, magic_parent)},
380 {XD_LISP_OBJECT, offsetof(Lisp_Specifier, fallback)},
384 const struct lrecord_description specifier_empty_extra_description[] = {
388 DEFINE_LRECORD_SEQUENCE_IMPLEMENTATION("specifier", specifier,
389 mark_specifier, print_specifier,
391 specifier_equal, specifier_hash,
392 specifier_description,
393 sizeof_specifier, Lisp_Specifier);
395 /************************************************************************/
396 /* Creating specifiers */
397 /************************************************************************/
399 static struct specifier_methods *decode_specifier_type(Lisp_Object type,
404 for (i = 0; i < Dynarr_length(the_specifier_type_entry_dynarr); i++) {
407 Dynarr_at(the_specifier_type_entry_dynarr, i).symbol))
408 return Dynarr_at(the_specifier_type_entry_dynarr,
412 maybe_signal_type_error(Qspecifier_argument_error,
413 "Invalid specifier type", type, Qspecifier,
419 static int valid_specifier_type_p(Lisp_Object type)
421 return decode_specifier_type(type, ERROR_ME_NOT) != 0;
424 DEFUN("valid-specifier-type-p", Fvalid_specifier_type_p, 1, 1, 0, /*
425 Given a SPECIFIER-TYPE, return non-nil if it is valid.
426 Valid types are 'generic, 'integer, 'boolean, 'color, 'font, 'image,
427 'face-boolean, and 'toolbar.
431 return valid_specifier_type_p(specifier_type) ? Qt : Qnil;
434 DEFUN("specifier-type-list", Fspecifier_type_list, 0, 0, 0, /*
435 Return a list of valid specifier types.
439 return Fcopy_sequence(Vspecifier_type_list);
443 add_entry_to_specifier_type_list(Lisp_Object symbol,
444 struct specifier_methods *meths)
446 struct specifier_type_entry entry;
448 entry.symbol = symbol;
450 Dynarr_add(the_specifier_type_entry_dynarr, entry);
451 Vspecifier_type_list = Fcons(symbol, Vspecifier_type_list);
455 make_specifier_internal(struct specifier_methods *spec_meths,
456 size_t data_size, int call_create_meth)
458 Lisp_Object specifier;
459 Lisp_Specifier *sp = (Lisp_Specifier *)
460 alloc_lcrecord(aligned_sizeof_specifier(data_size),
463 sp->methods = spec_meths;
464 sp->global_specs = Qnil;
465 sp->device_specs = Qnil;
466 sp->frame_specs = Qnil;
467 sp->window_specs = make_weak_list(WEAK_LIST_KEY_ASSOC);
468 sp->buffer_specs = Qnil;
470 sp->magic_parent = Qnil;
472 sp->next_specifier = Vall_specifiers;
474 XSETSPECIFIER(specifier, sp);
475 Vall_specifiers = specifier;
477 if (call_create_meth) {
480 MAYBE_SPECMETH(XSPECIFIER(specifier), create, (specifier));
486 static Lisp_Object make_specifier(struct specifier_methods *meths)
488 return make_specifier_internal(meths, meths->extra_data_size, 1);
491 Lisp_Object make_magic_specifier(Lisp_Object type)
493 /* This function can GC */
494 struct specifier_methods *meths = decode_specifier_type(type, ERROR_ME);
495 Lisp_Object bodily, ghost;
498 bodily = make_specifier(meths);
500 ghost = make_specifier_internal(meths, 0, 0);
503 /* Connect guys together */
504 XSPECIFIER(bodily)->magic_parent = Qt;
505 XSPECIFIER(bodily)->fallback = ghost;
506 XSPECIFIER(ghost)->magic_parent = bodily;
511 DEFUN("make-specifier", Fmake_specifier, 1, 1, 0, /*
512 Return a new specifier object of type TYPE.
514 A specifier is an object that can be used to keep track of a property
515 whose value can be per-buffer, per-window, per-frame, or per-device,
516 and can further be restricted to a particular console-type or
517 device-class. Specifiers are used, for example, for the various
518 built-in properties of a face; this allows a face to have different
519 values in different frames, buffers, etc.
521 When speaking of the value of a specifier, it is important to
522 distinguish between the *setting* of a specifier, called an
523 \"instantiator\", and the *actual value*, called an \"instance\". You
524 put various possible instantiators (i.e. settings) into a specifier
525 and associate them with particular locales (buffer, window, frame,
526 device, global), and then the instance (i.e. actual value) is
527 retrieved in a specific domain (window, frame, device) by looking
528 through the possible instantiators (i.e. settings). This process is
529 called \"instantiation\".
531 To put settings into a specifier, use `set-specifier', or the
532 lower-level functions `add-spec-to-specifier' and
533 `add-spec-list-to-specifier'. You can also temporarily bind a setting
534 to a specifier using `let-specifier'. To retrieve settings, use
535 `specifier-specs', or its lower-level counterpart
536 `specifier-spec-list'. To determine the actual value, use
537 `specifier-instance'.
539 For more information, see `set-specifier', `specifier-instance',
540 `specifier-specs', and `add-spec-to-specifier'; or, for a detailed
541 description of specifiers, including how exactly the instantiation
542 process works, see the chapter on specifiers in the SXEmacs Lisp
545 TYPE specifies the particular type of specifier, and should be one of
546 the symbols 'generic, 'integer, 'natnum, 'boolean, 'color, 'font,
547 'image, 'face-boolean, 'display-table, 'gutter, 'gutter-size,
548 'gutter-visible or 'toolbar.
550 For more information on particular types of specifiers, see the
551 functions `make-generic-specifier', `make-integer-specifier',
552 `make-natnum-specifier', `make-boolean-specifier',
553 `make-color-specifier', `make-font-specifier', `make-image-specifier',
554 `make-face-boolean-specifier', `make-gutter-size-specifier',
555 `make-gutter-visible-specifier', `default-toolbar', `default-gutter',
556 and `current-display-table'.
560 /* This function can GC */
561 struct specifier_methods *meths = decode_specifier_type(type, ERROR_ME);
563 return make_specifier(meths);
566 DEFUN("specifierp", Fspecifierp, 1, 1, 0, /*
567 Return t if OBJECT is a specifier.
569 A specifier is an object that can be used to keep track of a property
570 whose value can be per-buffer, per-window, per-frame, or per-device,
571 and can further be restricted to a particular console-type or device-class.
572 See `make-specifier'.
576 return SPECIFIERP(object) ? Qt : Qnil;
579 DEFUN("specifier-type", Fspecifier_type, 1, 1, 0, /*
580 Return the type of SPECIFIER.
584 CHECK_SPECIFIER(specifier);
585 return intern(XSPECIFIER(specifier)->methods->name);
588 /************************************************************************/
589 /* Locales and domains */
590 /************************************************************************/
592 DEFUN("valid-specifier-locale-p", Fvalid_specifier_locale_p, 1, 1, 0, /*
593 Return t if LOCALE is a valid specifier locale.
594 Valid locales are devices, frames, windows, buffers, and 'global.
599 /* This cannot GC. */
600 return ((DEVICEP(locale) && DEVICE_LIVE_P(XDEVICE(locale))) ||
601 (FRAMEP(locale) && FRAME_LIVE_P(XFRAME(locale))) ||
602 (BUFFERP(locale) && BUFFER_LIVE_P(XBUFFER(locale))) ||
603 /* dead windows are allowed because they may become live
604 windows again when a window configuration is restored */
605 WINDOWP(locale) || EQ(locale, Qglobal))
609 DEFUN("valid-specifier-domain-p", Fvalid_specifier_domain_p, 1, 1, 0, /*
610 Return t if DOMAIN is a valid specifier domain.
611 A domain is used to instance a specifier (i.e. determine the specifier's
612 value in that domain). Valid domains are image instances, windows, frames,
613 and devices. \(nil is not valid.) image instances are pseudo-domains since
614 instantiation will actually occur in the window the image instance itself is
619 /* This cannot GC. */
620 return ((DEVICEP(domain) && DEVICE_LIVE_P(XDEVICE(domain))) ||
621 (FRAMEP(domain) && FRAME_LIVE_P(XFRAME(domain))) ||
622 (WINDOWP(domain) && WINDOW_LIVE_P(XWINDOW(domain))) ||
623 /* #### get image instances out of domains! */
624 IMAGE_INSTANCEP(domain))
628 DEFUN("valid-specifier-locale-type-p", Fvalid_specifier_locale_type_p, 1, 1, 0,
630 Given a specifier LOCALE-TYPE, return non-nil if it is valid.
631 Valid locale types are 'global, 'device, 'frame, 'window, and 'buffer.
632 \(Note, however, that in functions that accept either a locale or a locale
633 type, 'global is considered an individual locale.)
637 /* This cannot GC. */
638 return (EQ(locale_type, Qglobal) ||
639 EQ(locale_type, Qdevice) ||
640 EQ(locale_type, Qframe) ||
641 EQ(locale_type, Qwindow) ||
642 EQ(locale_type, Qbuffer)) ? Qt : Qnil;
645 static void check_valid_locale_or_locale_type(Lisp_Object locale)
647 /* This cannot GC. */
648 if (EQ(locale, Qall) ||
649 !NILP(Fvalid_specifier_locale_p(locale)) ||
650 !NILP(Fvalid_specifier_locale_type_p(locale)))
652 signal_type_error(Qspecifier_argument_error,
653 "Invalid specifier locale or locale type", locale);
656 DEFUN("specifier-locale-type-from-locale", Fspecifier_locale_type_from_locale, 1, 1, 0, /*
657 Given a specifier LOCALE, return its type.
661 /* This cannot GC. */
662 if (NILP(Fvalid_specifier_locale_p(locale)))
663 signal_type_error(Qspecifier_argument_error,
664 "Invalid specifier locale", locale);
673 assert(EQ(locale, Qglobal));
677 static Lisp_Object decode_locale(Lisp_Object locale)
679 /* This cannot GC. */
682 else if (!NILP(Fvalid_specifier_locale_p(locale)))
685 signal_type_error(Qspecifier_argument_error,
686 "Invalid specifier locale", locale);
691 static enum spec_locale_type decode_locale_type(Lisp_Object locale_type)
693 /* This cannot GC. */
694 if (EQ(locale_type, Qglobal))
695 return LOCALE_GLOBAL;
696 if (EQ(locale_type, Qdevice))
697 return LOCALE_DEVICE;
698 if (EQ(locale_type, Qframe))
700 if (EQ(locale_type, Qwindow))
701 return LOCALE_WINDOW;
702 if (EQ(locale_type, Qbuffer))
703 return LOCALE_BUFFER;
705 signal_type_error(Qspecifier_argument_error,
706 "Invalid specifier locale type", locale_type);
707 return LOCALE_GLOBAL; /* not reached */
710 Lisp_Object decode_locale_list(Lisp_Object locale)
712 /* This cannot GC. */
713 /* The return value of this function must be GCPRO'd. */
716 } else if (CONSP(locale)) {
717 EXTERNAL_LIST_LOOP_2(elt, locale)
718 check_valid_locale_or_locale_type(elt);
721 check_valid_locale_or_locale_type(locale);
722 return list1(locale);
726 static enum spec_locale_type locale_type_from_locale(Lisp_Object locale)
728 return decode_locale_type(Fspecifier_locale_type_from_locale(locale));
731 static void check_valid_domain(Lisp_Object domain)
733 if (NILP(Fvalid_specifier_domain_p(domain)))
734 signal_type_error(Qspecifier_argument_error,
735 "Invalid specifier domain", domain);
738 Lisp_Object decode_domain(Lisp_Object domain)
741 return Fselected_window(Qnil);
742 check_valid_domain(domain);
746 /************************************************************************/
748 /************************************************************************/
750 DEFUN("valid-specifier-tag-p", Fvalid_specifier_tag_p, 1, 1, 0, /*
751 Return non-nil if TAG is a valid specifier tag.
752 See also `valid-specifier-tag-set-p'.
756 return (valid_console_type_p(tag) ||
757 valid_device_class_p(tag) ||
758 !NILP(assq_no_quit(tag, Vuser_defined_tags))) ? Qt : Qnil;
761 DEFUN("valid-specifier-tag-set-p", Fvalid_specifier_tag_set_p, 1, 1, 0, /*
762 Return non-nil if TAG-SET is a valid specifier tag set.
764 A specifier tag set is an entity that is attached to an instantiator
765 and can be used to restrict the scope of that instantiator to a
766 particular device class or device type and/or to mark instantiators
767 added by a particular package so that they can be later removed.
769 A specifier tag set consists of a list of zero of more specifier tags,
770 each of which is a symbol that is recognized by SXEmacs as a tag.
771 \(The valid device types and device classes are always tags, as are
772 any tags defined by `define-specifier-tag'.) It is called a "tag set"
773 \(as opposed to a list) because the order of the tags or the number of
774 times a particular tag occurs does not matter.
776 Each tag has a predicate associated with it, which specifies whether
777 that tag applies to a particular device. The tags which are device types
778 and classes match devices of that type or class. User-defined tags can
779 have any predicate, or none (meaning that all devices match). When
780 attempting to instance a specifier, a particular instantiator is only
781 considered if the device of the domain being instanced over matches
782 all tags in the tag set attached to that instantiator.
784 Most of the time, a tag set is not specified, and the instantiator
785 gets a null tag set, which matches all devices.
791 for (rest = tag_set; !NILP(rest); rest = XCDR(rest)) {
794 if (NILP(Fvalid_specifier_tag_p(XCAR(rest))))
801 Lisp_Object decode_specifier_tag_set(Lisp_Object tag_set)
803 /* The return value of this function must be GCPRO'd. */
804 if (!NILP(Fvalid_specifier_tag_p(tag_set)))
805 return list1(tag_set);
806 if (NILP(Fvalid_specifier_tag_set_p(tag_set)))
807 signal_type_error(Qspecifier_argument_error,
808 "Invalid specifier tag-set", tag_set);
812 static Lisp_Object canonicalize_tag_set(Lisp_Object tag_set)
814 int len = XINT(Flength(tag_set));
815 Lisp_Object *tags, rest;
818 /* We assume in this function that the tag_set has already been
819 validated, so there are no surprises. */
821 if (len == 0 || len == 1)
822 /* most common case */
825 tags = alloca_array(Lisp_Object, len);
828 LIST_LOOP(rest, tag_set)
829 tags[i++] = XCAR(rest);
831 /* Sort the list of tags. We use a bubble sort here (copied from
832 extent_fragment_update()) -- reduces the function call overhead,
833 and is the fastest sort for small numbers of items. */
835 for (i = 1; i < len; i++) {
838 strcmp((char *)string_data(XSYMBOL(tags[j])->name),
839 (char *)string_data(XSYMBOL(tags[j + 1])->name)) >
841 Lisp_Object tmp = tags[j];
842 tags[j] = tags[j + 1];
848 /* Now eliminate duplicates. */
850 for (i = 1, j = 1; i < len; i++) {
851 /* j holds the destination, i the source. */
852 if (!EQ(tags[i], tags[i - 1]))
856 return Flist(j, tags);
859 DEFUN("canonicalize-tag-set", Fcanonicalize_tag_set, 1, 1, 0, /*
860 Canonicalize the given tag set.
861 Two canonicalized tag sets can be compared with `equal' to see if they
862 represent the same tag set. (Specifically, canonicalizing involves
863 sorting by symbol name and removing duplicates.)
867 if (NILP(Fvalid_specifier_tag_set_p(tag_set)))
868 signal_type_error(Qspecifier_argument_error, "Invalid tag set",
870 return canonicalize_tag_set(tag_set);
874 device_matches_specifier_tag_set_p(Lisp_Object device, Lisp_Object tag_set)
876 Lisp_Object devtype, devclass, rest;
877 struct device *d = XDEVICE(device);
879 devtype = DEVICE_TYPE(d);
880 devclass = DEVICE_CLASS(d);
882 LIST_LOOP(rest, tag_set) {
883 Lisp_Object tag = XCAR(rest);
886 if (EQ(tag, devtype) || EQ(tag, devclass))
888 assoc = assq_no_quit(tag, DEVICE_USER_DEFINED_TAGS(d));
889 /* other built-in tags (device types/classes) are not in
890 the user-defined-tags list. */
891 if (NILP(assoc) || NILP(XCDR(assoc)))
898 DEFUN("device-matches-specifier-tag-set-p", Fdevice_matches_specifier_tag_set_p, 2, 2, 0, /*
899 Return non-nil if DEVICE matches specifier tag set TAG-SET.
900 This means that DEVICE matches each tag in the tag set. (Every
901 tag recognized by SXEmacs has a predicate associated with it that
902 specifies which devices match it.)
906 CHECK_LIVE_DEVICE(device);
908 if (NILP(Fvalid_specifier_tag_set_p(tag_set)))
909 signal_type_error(Qspecifier_argument_error, "Invalid tag set",
912 return device_matches_specifier_tag_set_p(device, tag_set) ? Qt : Qnil;
915 DEFUN("define-specifier-tag", Fdefine_specifier_tag, 1, 2, 0, /*
916 Define a new specifier tag.
917 If PREDICATE is specified, it should be a function of one argument
918 \(a device) that specifies whether the tag matches that particular
919 device. If PREDICATE is omitted, the tag matches all devices.
921 You can redefine an existing user-defined specifier tag. However,
922 you cannot redefine the built-in specifier tags (the device types
923 and classes) or the symbols nil, t, 'all, or 'global.
927 Lisp_Object assoc, devcons, concons;
931 if (valid_device_class_p(tag) || valid_console_type_p(tag))
932 signal_type_error(Qspecifier_change_error,
933 "Cannot redefine built-in specifier tags",
935 /* Try to prevent common instantiators and locales from being
936 redefined, to reduce ambiguity */
937 if (NILP(tag) || EQ(tag, Qt) || EQ(tag, Qall) || EQ(tag, Qglobal))
938 signal_type_error(Qspecifier_change_error,
939 "Cannot define nil, t, 'all, or 'global",
941 assoc = assq_no_quit(tag, Vuser_defined_tags);
945 Fcons(Fcons(tag, predicate), Vuser_defined_tags);
946 DEVICE_LOOP_NO_BREAK(devcons, concons) {
947 struct device *d = XDEVICE(XCAR(devcons));
948 /* Initially set the value to t in case of error
950 DEVICE_USER_DEFINED_TAGS(d) =
951 Fcons(Fcons(tag, Qt), DEVICE_USER_DEFINED_TAGS(d));
953 } else if (!NILP(predicate) && !NILP(XCDR(assoc))) {
955 XCDR(assoc) = predicate;
958 /* recompute the tag values for all devices. However, in the special
959 case where both the old and new predicates are nil, we know that
960 we don't have to do this. (It's probably common for people to
961 call (define-specifier-tag) more than once on the same tag,
962 and the most common case is where PREDICATE is not specified.) */
965 DEVICE_LOOP_NO_BREAK(devcons, concons) {
966 Lisp_Object device = XCAR(devcons);
967 assoc = assq_no_quit(tag,
968 DEVICE_USER_DEFINED_TAGS(XDEVICE
970 assert(CONSP(assoc));
975 !NILP(call1(predicate, device)) ? Qt : Qnil;
982 /* Called at device-creation time to initialize the user-defined
983 tag values for the newly-created device. */
985 void setup_device_initial_specifier_tags(struct device *d)
987 Lisp_Object rest, rest2;
990 XSETDEVICE(device, d);
992 DEVICE_USER_DEFINED_TAGS(d) = Fcopy_alist(Vuser_defined_tags);
994 /* Now set up the initial values */
995 LIST_LOOP(rest, DEVICE_USER_DEFINED_TAGS(d))
996 XCDR(XCAR(rest)) = Qt;
998 for (rest = Vuser_defined_tags, rest2 = DEVICE_USER_DEFINED_TAGS(d);
999 !NILP(rest); rest = XCDR(rest), rest2 = XCDR(rest2)) {
1000 Lisp_Object predicate = XCDR(XCAR(rest));
1001 if (NILP(predicate))
1002 XCDR(XCAR(rest2)) = Qt;
1005 !NILP(call1(predicate, device)) ? Qt : Qnil;
1009 DEFUN("device-matching-specifier-tag-list", Fdevice_matching_specifier_tag_list, 0, 1, 0, /*
1010 Return a list of all specifier tags matching DEVICE.
1011 DEVICE defaults to the selected device if omitted.
1015 struct device *d = decode_device(device);
1016 Lisp_Object rest, list = Qnil;
1017 struct gcpro gcpro1;
1021 LIST_LOOP(rest, DEVICE_USER_DEFINED_TAGS(d)) {
1022 if (!NILP(XCDR(XCAR(rest))))
1023 list = Fcons(XCAR(XCAR(rest)), list);
1026 list = Fnreverse(list);
1027 list = Fcons(DEVICE_CLASS(d), list);
1028 list = Fcons(DEVICE_TYPE(d), list);
1030 RETURN_UNGCPRO(list);
1033 DEFUN("specifier-tag-list", Fspecifier_tag_list, 0, 0, 0, /*
1034 Return a list of all currently-defined specifier tags.
1035 This includes the built-in ones (the device types and classes).
1039 Lisp_Object list = Qnil, rest;
1040 struct gcpro gcpro1;
1044 LIST_LOOP(rest, Vuser_defined_tags)
1045 list = Fcons(XCAR(XCAR(rest)), list);
1047 list = Fnreverse(list);
1048 list = nconc2(Fcopy_sequence(Vdevice_class_list), list);
1049 list = nconc2(Fcopy_sequence(Vconsole_type_list), list);
1051 RETURN_UNGCPRO(list);
1054 DEFUN("specifier-tag-predicate", Fspecifier_tag_predicate, 1, 1, 0, /*
1055 Return the predicate for the given specifier tag.
1059 /* The return value of this function must be GCPRO'd. */
1062 if (NILP(Fvalid_specifier_tag_p(tag)))
1063 signal_type_error(Qspecifier_argument_error,
1064 "Invalid specifier tag", tag);
1066 /* Make up some predicates for the built-in types */
1068 if (valid_console_type_p(tag))
1069 return list3(Qlambda, list1(Qdevice),
1070 list3(Qeq, list2(Qquote, tag),
1071 list2(Qconsole_type, Qdevice)));
1073 if (valid_device_class_p(tag))
1074 return list3(Qlambda, list1(Qdevice),
1075 list3(Qeq, list2(Qquote, tag),
1076 list2(Qdevice_class, Qdevice)));
1079 Lisp_Object tmp = assq_no_quit(tag, Vuser_defined_tags);
1084 /* Return true if A "matches" B. If EXACT_P is 0, A must be a subset of B.
1085 Otherwise, A must be `equal' to B. The sets must be canonicalized. */
1086 static int tag_sets_match_p(Lisp_Object a, Lisp_Object b, int exact_p)
1089 while (!NILP(a) && !NILP(b)) {
1090 if (EQ(XCAR(a), XCAR(b)))
1097 while (!NILP(a) && !NILP(b)) {
1098 if (!EQ(XCAR(a), XCAR(b)))
1104 return NILP(a) && NILP(b);
1108 /************************************************************************/
1109 /* Spec-lists and inst-lists */
1110 /************************************************************************/
1113 call_validate_method(Lisp_Object boxed_method, Lisp_Object instantiator)
1115 ((void (*)(Lisp_Object))get_opaque_ptr(boxed_method)) (instantiator);
1120 check_valid_instantiator(Lisp_Object instantiator,
1121 struct specifier_methods *meths, Error_behavior errb)
1123 if (meths->validate_method) {
1126 if (ERRB_EQ(errb, ERROR_ME)) {
1127 (meths->validate_method) (instantiator);
1130 Lisp_Object opaque = make_opaque_ptr((void *)
1133 struct gcpro gcpro1;
1136 retval = call_with_suspended_errors
1137 ((lisp_fn_t) call_validate_method,
1138 Qnil, Qspecifier, errb, 2, opaque, instantiator);
1140 free_opaque_ptr(opaque);
1149 DEFUN("check-valid-instantiator", Fcheck_valid_instantiator, 2, 2, 0, /*
1150 Signal an error if INSTANTIATOR is invalid for SPECIFIER-TYPE.
1152 (instantiator, specifier_type))
1154 struct specifier_methods *meths = decode_specifier_type(specifier_type,
1157 return check_valid_instantiator(instantiator, meths, ERROR_ME);
1160 DEFUN("valid-instantiator-p", Fvalid_instantiator_p, 2, 2, 0, /*
1161 Return non-nil if INSTANTIATOR is valid for SPECIFIER-TYPE.
1163 (instantiator, specifier_type))
1165 struct specifier_methods *meths = decode_specifier_type(specifier_type,
1168 return check_valid_instantiator(instantiator, meths, ERROR_ME_NOT);
1172 check_valid_inst_list(Lisp_Object inst_list, struct specifier_methods *meths,
1173 Error_behavior errb)
1177 LIST_LOOP(rest, inst_list) {
1178 Lisp_Object inst_pair, tag_set;
1181 maybe_signal_type_error(Qspecifier_syntax_error,
1182 "Invalid instantiator list",
1183 inst_list, Qspecifier, errb);
1186 if (!CONSP(inst_pair = XCAR(rest))) {
1187 maybe_signal_type_error(Qspecifier_syntax_error,
1188 "Invalid instantiator pair",
1189 inst_pair, Qspecifier, errb);
1192 if (NILP(Fvalid_specifier_tag_set_p(tag_set = XCAR(inst_pair)))) {
1193 maybe_signal_type_error(Qspecifier_syntax_error,
1194 "Invalid specifier tag",
1195 tag_set, Qspecifier, errb);
1200 (check_valid_instantiator(XCDR(inst_pair), meths, errb)))
1207 DEFUN("check-valid-inst-list", Fcheck_valid_inst_list, 2, 2, 0, /*
1208 Signal an error if INST-LIST is invalid for specifier type TYPE.
1212 struct specifier_methods *meths = decode_specifier_type(type, ERROR_ME);
1214 return check_valid_inst_list(inst_list, meths, ERROR_ME);
1217 DEFUN("valid-inst-list-p", Fvalid_inst_list_p, 2, 2, 0, /*
1218 Return non-nil if INST-LIST is valid for specifier type TYPE.
1222 struct specifier_methods *meths = decode_specifier_type(type, ERROR_ME);
1224 return check_valid_inst_list(inst_list, meths, ERROR_ME_NOT);
1228 check_valid_spec_list(Lisp_Object spec_list, struct specifier_methods *meths,
1229 Error_behavior errb)
1233 LIST_LOOP(rest, spec_list) {
1234 Lisp_Object spec, locale;
1235 if (!CONSP(rest) || !CONSP(spec = XCAR(rest))) {
1236 maybe_signal_type_error(Qspecifier_syntax_error,
1237 "Invalid specification list",
1238 spec_list, Qspecifier, errb);
1241 if (NILP(Fvalid_specifier_locale_p(locale = XCAR(spec)))) {
1242 maybe_signal_type_error(Qspecifier_syntax_error,
1243 "Invalid specifier locale",
1244 locale, Qspecifier, errb);
1248 if (NILP(check_valid_inst_list(XCDR(spec), meths, errb)))
1255 DEFUN("check-valid-spec-list", Fcheck_valid_spec_list, 2, 2, 0, /*
1256 Signal an error if SPEC-LIST is invalid for specifier type TYPE.
1260 struct specifier_methods *meths = decode_specifier_type(type, ERROR_ME);
1262 return check_valid_spec_list(spec_list, meths, ERROR_ME);
1265 DEFUN("valid-spec-list-p", Fvalid_spec_list_p, 2, 2, 0, /*
1266 Return non-nil if SPEC-LIST is valid for specifier type TYPE.
1270 struct specifier_methods *meths = decode_specifier_type(type, ERROR_ME);
1272 return check_valid_spec_list(spec_list, meths, ERROR_ME_NOT);
1275 enum spec_add_meth decode_how_to_add_specification(Lisp_Object how_to_add)
1277 if (NILP(how_to_add) || EQ(Qremove_tag_set_prepend, how_to_add))
1278 return SPEC_REMOVE_TAG_SET_PREPEND;
1279 if (EQ(Qremove_tag_set_append, how_to_add))
1280 return SPEC_REMOVE_TAG_SET_APPEND;
1281 if (EQ(Qappend, how_to_add))
1283 if (EQ(Qprepend, how_to_add))
1284 return SPEC_PREPEND;
1285 if (EQ(Qremove_locale, how_to_add))
1286 return SPEC_REMOVE_LOCALE;
1287 if (EQ(Qremove_locale_type, how_to_add))
1288 return SPEC_REMOVE_LOCALE_TYPE;
1289 if (EQ(Qremove_all, how_to_add))
1290 return SPEC_REMOVE_ALL;
1292 signal_type_error(Qspecifier_argument_error,
1293 "Invalid `how-to-add' flag", how_to_add);
1295 return SPEC_PREPEND; /* not reached */
1298 /* Given a specifier object SPEC, return bodily specifier if SPEC is a
1299 ghost specifier, otherwise return the object itself
1301 static Lisp_Object bodily_specifier(Lisp_Object spec)
1303 return (GHOST_SPECIFIER_P(XSPECIFIER(spec))
1304 ? XSPECIFIER(spec)->magic_parent : spec);
1307 /* Signal error if (specifier SPEC is read-only.
1308 Read only are ghost specifiers unless Vunlock_ghost_specifiers is
1309 non-nil. All other specifiers are read-write.
1311 static void check_modifiable_specifier(Lisp_Object spec)
1313 if (NILP(Vunlock_ghost_specifiers)
1314 && GHOST_SPECIFIER_P(XSPECIFIER(spec)))
1315 signal_type_error(Qspecifier_change_error,
1316 "Attempt to modify read-only specifier",
1320 /* Helper function which unwind protects the value of
1321 Vunlock_ghost_specifiers, then sets it to non-nil value */
1322 static Lisp_Object restore_unlock_value(Lisp_Object val)
1324 Vunlock_ghost_specifiers = val;
1328 int unlock_ghost_specifiers_protected(void)
1330 int depth = specpdl_depth();
1331 record_unwind_protect(restore_unlock_value, Vunlock_ghost_specifiers);
1332 Vunlock_ghost_specifiers = Qt;
1336 /* This gets hit so much that the function call overhead had a
1337 measurable impact (according to Quantify). #### We should figure
1338 out the frequency with which this is called with the various types
1339 and reorder the check accordingly. */
1340 #define SPECIFIER_GET_SPEC_LIST(specifier, type) \
1341 (type == LOCALE_GLOBAL ? &(XSPECIFIER (specifier)->global_specs) : \
1342 type == LOCALE_DEVICE ? &(XSPECIFIER (specifier)->device_specs) : \
1343 type == LOCALE_FRAME ? &(XSPECIFIER (specifier)->frame_specs) : \
1344 type == LOCALE_WINDOW ? &(XWEAK_LIST_LIST \
1345 (XSPECIFIER (specifier)->window_specs)) : \
1346 type == LOCALE_BUFFER ? &(XSPECIFIER (specifier)->buffer_specs) : \
1349 static Lisp_Object *specifier_get_inst_list(Lisp_Object specifier,
1351 enum spec_locale_type type)
1353 Lisp_Object *spec_list = SPECIFIER_GET_SPEC_LIST(specifier, type);
1354 Lisp_Object specification;
1356 if (type == LOCALE_GLOBAL)
1358 /* Calling assq_no_quit when it is just going to return nil anyhow
1359 is extremely expensive. So sayeth Quantify. */
1360 if (!CONSP(*spec_list))
1362 specification = assq_no_quit(locale, *spec_list);
1363 if (NILP(specification))
1365 return &XCDR(specification);
1368 /* For the given INST_LIST, return a new INST_LIST containing all elements
1369 where TAG-SET matches the element's tag set. EXACT_P indicates whether
1370 the match must be exact (as opposed to a subset). SHORT_P indicates
1371 that the short form (for `specifier-specs') should be returned if
1372 possible. If COPY_TREE_P, `copy-tree' is used to ensure that no
1373 elements of the new list are shared with the initial list.
1377 specifier_process_inst_list(Lisp_Object inst_list,
1378 Lisp_Object tag_set, int exact_p,
1379 int short_p, int copy_tree_p)
1381 Lisp_Object retval = Qnil;
1383 struct gcpro gcpro1;
1386 LIST_LOOP(rest, inst_list) {
1387 Lisp_Object tagged_inst = XCAR(rest);
1388 Lisp_Object tagged_inst_tag = XCAR(tagged_inst);
1389 if (tag_sets_match_p(tag_set, tagged_inst_tag, exact_p)) {
1390 if (short_p && NILP(tagged_inst_tag))
1391 retval = Fcons(copy_tree_p ?
1392 Fcopy_tree(XCDR(tagged_inst),
1394 XCDR(tagged_inst), retval);
1398 Fcopy_tree(tagged_inst,
1399 Qt) : tagged_inst, retval);
1402 retval = Fnreverse(retval);
1404 /* If there is a single instantiator and the short form is
1405 requested, return just the instantiator (rather than a one-element
1406 list of it) unless it is nil (so that it can be distinguished from
1407 no instantiators at all). */
1408 if (short_p && CONSP(retval) && !NILP(XCAR(retval)) &&
1410 return XCAR(retval);
1416 specifier_get_external_inst_list(Lisp_Object specifier, Lisp_Object locale,
1417 enum spec_locale_type type,
1418 Lisp_Object tag_set, int exact_p,
1419 int short_p, int copy_tree_p)
1421 Lisp_Object *inst_list = specifier_get_inst_list(specifier, locale,
1423 if (!inst_list || NILP(*inst_list)) {
1424 /* nil for *inst_list should only occur in 'global */
1425 assert(!inst_list || EQ(locale, Qglobal));
1429 return specifier_process_inst_list(*inst_list, tag_set, exact_p,
1430 short_p, copy_tree_p);
1434 specifier_get_external_spec_list(Lisp_Object specifier,
1435 enum spec_locale_type type,
1436 Lisp_Object tag_set, int exact_p)
1438 Lisp_Object *spec_list = SPECIFIER_GET_SPEC_LIST(specifier, type);
1439 Lisp_Object retval = Qnil;
1441 struct gcpro gcpro1;
1443 assert(type != LOCALE_GLOBAL);
1444 /* We're about to let stuff go external; make sure there aren't
1446 *spec_list = cleanup_assoc_list(*spec_list);
1449 LIST_LOOP(rest, *spec_list) {
1450 Lisp_Object spec = XCAR(rest);
1451 Lisp_Object inst_list =
1452 specifier_process_inst_list(XCDR(spec), tag_set, exact_p, 0,
1454 if (!NILP(inst_list))
1455 retval = Fcons(Fcons(XCAR(spec), inst_list), retval);
1457 RETURN_UNGCPRO(Fnreverse(retval));
1460 static Lisp_Object *specifier_new_spec(Lisp_Object specifier,
1462 enum spec_locale_type type)
1464 Lisp_Object *spec_list = SPECIFIER_GET_SPEC_LIST(specifier, type);
1465 Lisp_Object new_spec = Fcons(locale, Qnil);
1466 assert(type != LOCALE_GLOBAL);
1467 *spec_list = Fcons(new_spec, *spec_list);
1468 return &XCDR(new_spec);
1471 /* For the given INST_LIST, return a new list comprised of elements
1472 where TAG_SET does not match the element's tag set. This operation
1476 specifier_process_remove_inst_list(Lisp_Object inst_list,
1477 Lisp_Object tag_set, int exact_p,
1480 Lisp_Object prev = Qnil, rest;
1484 LIST_LOOP(rest, inst_list) {
1485 if (tag_sets_match_p(tag_set, XCAR(XCAR(rest)), exact_p)) {
1486 /* time to remove. */
1489 inst_list = XCDR(rest);
1491 XCDR(prev) = XCDR(rest);
1500 specifier_remove_spec(Lisp_Object specifier, Lisp_Object locale,
1501 enum spec_locale_type type,
1502 Lisp_Object tag_set, int exact_p)
1504 Lisp_Object *spec_list = SPECIFIER_GET_SPEC_LIST(specifier, type);
1508 if (type == LOCALE_GLOBAL)
1510 specifier_process_remove_inst_list(*spec_list, tag_set,
1511 exact_p, &was_removed);
1513 assoc = assq_no_quit(locale, *spec_list);
1515 /* this locale is not found. */
1517 XCDR(assoc) = specifier_process_remove_inst_list(XCDR(assoc),
1521 if (NILP(XCDR(assoc)))
1522 /* no inst-pairs left; remove this locale entirely. */
1523 *spec_list = remassq_no_quit(locale, *spec_list);
1527 MAYBE_SPECMETH(XSPECIFIER(specifier), after_change,
1528 (bodily_specifier(specifier), locale));
1532 specifier_remove_locale_type(Lisp_Object specifier,
1533 enum spec_locale_type type,
1534 Lisp_Object tag_set, int exact_p)
1536 Lisp_Object *spec_list = SPECIFIER_GET_SPEC_LIST(specifier, type);
1537 Lisp_Object prev = Qnil, rest;
1539 assert(type != LOCALE_GLOBAL);
1540 LIST_LOOP(rest, *spec_list) {
1542 int remove_spec = 0;
1543 Lisp_Object spec = XCAR(rest);
1545 /* There may be dead objects floating around */
1546 /* remember, dead windows can become alive again. */
1547 if (!WINDOWP(XCAR(spec)) && object_dead_p(XCAR(spec))) {
1552 specifier_process_remove_inst_list(XCDR(spec),
1555 if (NILP(XCDR(spec)))
1561 *spec_list = XCDR(rest);
1563 XCDR(prev) = XCDR(rest);
1568 MAYBE_SPECMETH(XSPECIFIER(specifier), after_change,
1569 (bodily_specifier(specifier),
1574 /* NEW_LIST is going to be added to INST_LIST, with add method ADD_METH.
1575 Frob INST_LIST according to ADD_METH. No need to call an after-change
1576 function; the calling function will do this. Return either SPEC_PREPEND
1577 or SPEC_APPEND, indicating whether to prepend or append the NEW_LIST. */
1579 static enum spec_add_meth
1580 handle_multiple_add_insts(Lisp_Object * inst_list,
1581 Lisp_Object new_list, enum spec_add_meth add_meth)
1584 case SPEC_REMOVE_TAG_SET_APPEND:
1585 add_meth = SPEC_APPEND;
1586 goto remove_tag_set;
1587 case SPEC_REMOVE_TAG_SET_PREPEND: {
1590 add_meth = SPEC_PREPEND;
1593 LIST_LOOP(rest, new_list) {
1594 Lisp_Object canontag =
1595 canonicalize_tag_set(XCAR(XCAR(rest)));
1596 struct gcpro gcpro1;
1599 /* pull out all elements from the existing list with the
1600 same tag as any tags in NEW_LIST. */
1601 *inst_list = remassoc_no_quit(canontag, *inst_list);
1606 case SPEC_REMOVE_LOCALE:
1608 return SPEC_PREPEND;
1613 case SPEC_REMOVE_LOCALE_TYPE:
1614 case SPEC_REMOVE_ALL:
1616 return SPEC_PREPEND;
1620 /* Given a LOCALE and INST_LIST that is going to be added to SPECIFIER,
1621 copy, canonicalize, and call the going_to_add methods as necessary
1622 to produce a new list that is the one that really will be added
1623 to the specifier. */
1626 build_up_processed_list(Lisp_Object specifier, Lisp_Object locale,
1627 Lisp_Object inst_list)
1629 /* The return value of this function must be GCPRO'd. */
1630 Lisp_Object rest, list_to_build_up = Qnil;
1631 Lisp_Specifier *sp = XSPECIFIER(specifier);
1632 struct gcpro gcpro1;
1634 GCPRO1(list_to_build_up);
1635 LIST_LOOP(rest, inst_list) {
1636 Lisp_Object tag_set = XCAR(XCAR(rest));
1637 Lisp_Object sub_inst_list = Qnil;
1638 Lisp_Object instantiator;
1639 struct gcpro ngcpro1, ngcpro2;
1641 if (HAS_SPECMETH_P(sp, copy_instantiator))
1642 instantiator = SPECMETH(sp, copy_instantiator,
1643 (XCDR(XCAR(rest))));
1645 instantiator = Fcopy_tree(XCDR(XCAR(rest)), Qt);
1647 NGCPRO2(instantiator, sub_inst_list);
1648 /* call the will-add method; it may GC */
1649 sub_inst_list = HAS_SPECMETH_P(sp, going_to_add) ?
1650 SPECMETH(sp, going_to_add,
1651 (bodily_specifier(specifier), locale,
1652 tag_set, instantiator)) : Qt;
1653 if (EQ(sub_inst_list, Qt))
1654 /* no change here. */
1657 (canonicalize_tag_set(tag_set),
1660 /* now canonicalize all the tag sets in the new objects */
1662 LIST_LOOP(rest2, sub_inst_list)
1664 canonicalize_tag_set(XCAR(XCAR(rest2)));
1667 list_to_build_up = nconc2(sub_inst_list, list_to_build_up);
1671 RETURN_UNGCPRO(Fnreverse(list_to_build_up));
1674 /* Add a specification (locale and instantiator list) to a specifier.
1675 ADD_METH specifies what to do with existing specifications in the
1676 specifier, and is an enum that corresponds to the values in
1677 `add-spec-to-specifier'. The calling routine is responsible for
1678 validating LOCALE and INST-LIST, but the tag-sets in INST-LIST
1679 do not need to be canonicalized. */
1681 /* #### I really need to rethink the after-change
1682 functions to make them easier to use and more efficient. */
1685 specifier_add_spec(Lisp_Object specifier, Lisp_Object locale,
1686 Lisp_Object inst_list, enum spec_add_meth add_meth)
1688 Lisp_Specifier *sp = XSPECIFIER(specifier);
1689 enum spec_locale_type type = locale_type_from_locale(locale);
1690 Lisp_Object *orig_inst_list, tem;
1691 Lisp_Object list_to_build_up = Qnil;
1692 struct gcpro gcpro1;
1694 GCPRO1(list_to_build_up);
1696 build_up_processed_list(specifier, locale, inst_list);
1697 /* Now handle REMOVE_LOCALE_TYPE and REMOVE_ALL. These are the
1698 add-meth types that affect locales other than this one. */
1699 if (add_meth == SPEC_REMOVE_LOCALE_TYPE)
1700 specifier_remove_locale_type(specifier, type, Qnil, 0);
1701 else if (add_meth == SPEC_REMOVE_ALL) {
1702 specifier_remove_locale_type(specifier, LOCALE_BUFFER, Qnil, 0);
1703 specifier_remove_locale_type(specifier, LOCALE_WINDOW, Qnil, 0);
1704 specifier_remove_locale_type(specifier, LOCALE_FRAME, Qnil, 0);
1705 specifier_remove_locale_type(specifier, LOCALE_DEVICE, Qnil, 0);
1706 specifier_remove_spec(specifier, Qglobal, LOCALE_GLOBAL, Qnil,
1710 orig_inst_list = specifier_get_inst_list(specifier, locale, type);
1711 if (!orig_inst_list)
1712 orig_inst_list = specifier_new_spec(specifier, locale, type);
1713 add_meth = handle_multiple_add_insts(orig_inst_list, list_to_build_up,
1716 if (add_meth == SPEC_PREPEND)
1717 tem = nconc2(list_to_build_up, *orig_inst_list);
1718 else if (add_meth == SPEC_APPEND)
1719 tem = nconc2(*orig_inst_list, list_to_build_up);
1725 *orig_inst_list = tem;
1729 /* call the after-change method */
1730 MAYBE_SPECMETH(sp, after_change, (bodily_specifier(specifier), locale));
1734 specifier_copy_spec(Lisp_Object specifier, Lisp_Object dest,
1735 Lisp_Object locale, enum spec_locale_type type,
1736 Lisp_Object tag_set, int exact_p,
1737 enum spec_add_meth add_meth)
1739 Lisp_Object inst_list =
1740 specifier_get_external_inst_list(specifier, locale, type, tag_set,
1742 specifier_add_spec(dest, locale, inst_list, add_meth);
1746 specifier_copy_locale_type(Lisp_Object specifier, Lisp_Object dest,
1747 enum spec_locale_type type,
1748 Lisp_Object tag_set, int exact_p,
1749 enum spec_add_meth add_meth)
1751 Lisp_Object *src_list = SPECIFIER_GET_SPEC_LIST(specifier, type);
1754 /* This algorithm is O(n^2) in running time.
1755 It's certainly possible to implement an O(n log n) algorithm,
1756 but I doubt there's any need to. */
1758 LIST_LOOP(rest, *src_list) {
1759 Lisp_Object spec = XCAR(rest);
1760 /* There may be dead objects floating around */
1761 /* remember, dead windows can become alive again. */
1762 if (WINDOWP(XCAR(spec)) || !object_dead_p(XCAR(spec)))
1765 specifier_process_inst_list(XCDR(spec), tag_set,
1771 /* map MAPFUN over the locales in SPECIFIER that are given in LOCALE.
1772 CLOSURE is passed unchanged to MAPFUN. LOCALE can be one of
1774 -- nil (same as 'all)
1775 -- a single locale, locale type, or 'all
1776 -- a list of locales, locale types, and/or 'all
1778 MAPFUN is called for each locale and locale type given; for 'all,
1779 it is called for the locale 'global and for the four possible
1780 locale types. In each invocation, either LOCALE will be a locale
1781 and LOCALE_TYPE will be the locale type of this locale,
1782 or LOCALE will be nil and LOCALE_TYPE will be a locale type.
1783 If MAPFUN ever returns non-zero, the mapping is halted and the
1784 value returned is returned from map_specifier(). Otherwise, the
1785 mapping proceeds to the end and map_specifier() returns 0.
1789 map_specifier(Lisp_Object specifier, Lisp_Object locale,
1790 int (*mapfun) (Lisp_Object specifier,
1792 enum spec_locale_type locale_type,
1793 Lisp_Object tag_set,
1796 Lisp_Object tag_set, Lisp_Object exact_p, void *closure)
1800 struct gcpro gcpro1, gcpro2;
1802 GCPRO2(tag_set, locale);
1803 locale = decode_locale_list(locale);
1804 tag_set = decode_specifier_tag_set(tag_set);
1805 tag_set = canonicalize_tag_set(tag_set);
1807 LIST_LOOP(rest, locale) {
1808 Lisp_Object theloc = XCAR(rest);
1809 if (!NILP(Fvalid_specifier_locale_p(theloc))) {
1810 retval = (*mapfun) (specifier, theloc,
1811 locale_type_from_locale(theloc),
1812 tag_set, !NILP(exact_p), closure);
1815 } else if (!NILP(Fvalid_specifier_locale_type_p(theloc))) {
1816 retval = (*mapfun) (specifier, Qnil,
1817 decode_locale_type(theloc), tag_set,
1818 !NILP(exact_p), closure);
1822 assert(EQ(theloc, Qall));
1824 (*mapfun) (specifier, Qnil, LOCALE_BUFFER, tag_set,
1825 !NILP(exact_p), closure);
1829 (*mapfun) (specifier, Qnil, LOCALE_WINDOW, tag_set,
1830 !NILP(exact_p), closure);
1834 (*mapfun) (specifier, Qnil, LOCALE_FRAME, tag_set,
1835 !NILP(exact_p), closure);
1839 (*mapfun) (specifier, Qnil, LOCALE_DEVICE, tag_set,
1840 !NILP(exact_p), closure);
1844 (*mapfun) (specifier, Qglobal, LOCALE_GLOBAL,
1845 tag_set, !NILP(exact_p), closure);
1855 DEFUN("add-spec-to-specifier", Fadd_spec_to_specifier, 2, 5, 0, /*
1856 Add a specification to SPECIFIER.
1857 The specification maps from LOCALE (which should be a window, buffer,
1858 frame, device, or 'global, and defaults to 'global) to INSTANTIATOR,
1859 whose allowed values depend on the type of the specifier. Optional
1860 argument TAG-SET limits the instantiator to apply only to the specified
1861 tag set, which should be a list of tags all of which must match the
1862 device being instantiated over (tags are a device type, a device class,
1863 or tags defined with `define-specifier-tag'). Specifying a single
1864 symbol for TAG-SET is equivalent to specifying a one-element list
1865 containing that symbol. Optional argument HOW-TO-ADD specifies what to
1866 do if there are already specifications in the specifier.
1869 'prepend Put at the beginning of the current list of
1870 instantiators for LOCALE.
1871 'append Add to the end of the current list of
1872 instantiators for LOCALE.
1873 'remove-tag-set-prepend (this is the default)
1874 Remove any existing instantiators whose tag set is
1875 the same as TAG-SET; then put the new instantiator
1876 at the beginning of the current list. ("Same tag
1877 set" means that they contain the same elements.
1878 The order may be different.)
1879 'remove-tag-set-append
1880 Remove any existing instantiators whose tag set is
1881 the same as TAG-SET; then put the new instantiator
1882 at the end of the current list.
1883 'remove-locale Remove all previous instantiators for this locale
1884 before adding the new spec.
1885 'remove-locale-type Remove all specifications for all locales of the
1886 same type as LOCALE (this includes LOCALE itself)
1887 before adding the new spec.
1888 'remove-all Remove all specifications from the specifier
1889 before adding the new spec.
1891 You can retrieve the specifications for a particular locale or locale type
1892 with the function `specifier-spec-list' or `specifier-specs'.
1894 (specifier, instantiator, locale, tag_set, how_to_add))
1896 enum spec_add_meth add_meth;
1897 Lisp_Object inst_list;
1898 struct gcpro gcpro1;
1900 CHECK_SPECIFIER(specifier);
1901 check_modifiable_specifier(specifier);
1903 locale = decode_locale(locale);
1904 check_valid_instantiator(instantiator,
1905 decode_specifier_type
1906 (Fspecifier_type(specifier), ERROR_ME),
1908 /* tag_set might be newly-created material, but it's part of inst_list
1909 so is properly GC-protected. */
1910 tag_set = decode_specifier_tag_set(tag_set);
1911 add_meth = decode_how_to_add_specification(how_to_add);
1913 inst_list = list1(Fcons(tag_set, instantiator));
1915 specifier_add_spec(specifier, locale, inst_list, add_meth);
1916 recompute_cached_specifier_everywhere(specifier);
1917 RETURN_UNGCPRO(Qnil);
1920 DEFUN("add-spec-list-to-specifier", Fadd_spec_list_to_specifier, 2, 3, 0, /*
1921 Add SPEC-LIST (a list of specifications) to SPECIFIER.
1922 The format of SPEC-LIST is
1924 ((LOCALE (TAG-SET . INSTANTIATOR) ...) ...)
1927 LOCALE := a window, a buffer, a frame, a device, or 'global
1928 TAG-SET := an unordered list of zero or more TAGS, each of which
1930 TAG := a device class (see `valid-device-class-p'), a device type
1931 (see `valid-console-type-p'), or a tag defined with
1932 `define-specifier-tag'
1933 INSTANTIATOR := format determined by the type of specifier
1935 The pair (TAG-SET . INSTANTIATOR) is called an `inst-pair'.
1936 A list of inst-pairs is called an `inst-list'.
1937 The pair (LOCALE . INST-LIST) is called a `specification' or `spec'.
1938 A spec-list, then, can be viewed as a list of specifications.
1940 HOW-TO-ADD specifies how to combine the new specifications with
1941 the existing ones, and has the same semantics as for
1942 `add-spec-to-specifier'.
1944 In many circumstances, the higher-level function `set-specifier' is
1945 more convenient and should be used instead.
1947 (specifier, spec_list, how_to_add))
1949 enum spec_add_meth add_meth;
1952 CHECK_SPECIFIER(specifier);
1953 check_modifiable_specifier(specifier);
1955 check_valid_spec_list(spec_list,
1956 decode_specifier_type
1957 (Fspecifier_type(specifier), ERROR_ME), ERROR_ME);
1958 add_meth = decode_how_to_add_specification(how_to_add);
1960 LIST_LOOP(rest, spec_list) {
1961 /* Placating the GCC god. */
1962 Lisp_Object specification = XCAR(rest);
1963 Lisp_Object locale = XCAR(specification);
1964 Lisp_Object inst_list = XCDR(specification);
1966 specifier_add_spec(specifier, locale, inst_list, add_meth);
1968 recompute_cached_specifier_everywhere(specifier);
1973 add_spec_to_ghost_specifier(Lisp_Object specifier, Lisp_Object instantiator,
1974 Lisp_Object locale, Lisp_Object tag_set,
1975 Lisp_Object how_to_add)
1977 int depth = unlock_ghost_specifiers_protected();
1978 Fadd_spec_to_specifier(XSPECIFIER(specifier)->fallback,
1979 instantiator, locale, tag_set, how_to_add);
1980 unbind_to(depth, Qnil);
1983 struct specifier_spec_list_closure {
1984 Lisp_Object head, tail;
1988 specifier_spec_list_mapfun(Lisp_Object specifier,
1990 enum spec_locale_type locale_type,
1991 Lisp_Object tag_set, int exact_p, void *closure)
1993 struct specifier_spec_list_closure *cl =
1994 (struct specifier_spec_list_closure *)closure;
1995 Lisp_Object partial;
1998 partial = specifier_get_external_spec_list(specifier,
2002 partial = specifier_get_external_inst_list(specifier, locale,
2003 locale_type, tag_set,
2006 partial = list1(Fcons(locale, partial));
2011 /* tack on the new list */
2013 cl->head = cl->tail = partial;
2015 XCDR(cl->tail) = partial;
2016 /* find the new tail */
2017 while (CONSP(XCDR(cl->tail)))
2018 cl->tail = XCDR(cl->tail);
2022 /* For the given SPECIFIER create and return a list of all specs
2023 contained within it, subject to LOCALE. If LOCALE is a locale, only
2024 specs in that locale will be returned. If LOCALE is a locale type,
2025 all specs in all locales of that type will be returned. If LOCALE is
2026 nil, all specs will be returned. This always copies lists and never
2027 returns the actual lists, because we do not want someone manipulating
2028 the actual objects. This may cause a slight loss of potential
2029 functionality but if we were to allow it then a user could manage to
2030 violate our assertion that the specs contained in the actual
2031 specifier lists are all valid. */
2033 DEFUN("specifier-spec-list", Fspecifier_spec_list, 1, 4, 0, /*
2034 Return the spec-list of specifications for SPECIFIER in LOCALE.
2036 If LOCALE is a particular locale (a buffer, window, frame, device,
2037 or 'global), a spec-list consisting of the specification for that
2038 locale will be returned.
2040 If LOCALE is a locale type (i.e. 'buffer, 'window, 'frame, or 'device),
2041 a spec-list of the specifications for all locales of that type will be
2044 If LOCALE is nil or 'all, a spec-list of all specifications in SPECIFIER
2047 LOCALE can also be a list of locales, locale types, and/or 'all; the
2048 result is as if `specifier-spec-list' were called on each element of the
2049 list and the results concatenated together.
2051 Only instantiators where TAG-SET (a list of zero or more tags) is a
2052 subset of (or possibly equal to) the instantiator's tag set are returned.
2053 \(The default value of nil is a subset of all tag sets, so in this case
2054 no instantiators will be screened out.) If EXACT-P is non-nil, however,
2055 TAG-SET must be equal to an instantiator's tag set for the instantiator
2058 (specifier, locale, tag_set, exact_p))
2060 struct specifier_spec_list_closure cl;
2061 struct gcpro gcpro1, gcpro2;
2063 CHECK_SPECIFIER(specifier);
2064 cl.head = cl.tail = Qnil;
2065 GCPRO2(cl.head, cl.tail);
2066 map_specifier(specifier, locale, specifier_spec_list_mapfun,
2067 tag_set, exact_p, &cl);
2072 DEFUN("specifier-specs", Fspecifier_specs, 1, 4, 0, /*
2073 Return the specification(s) for SPECIFIER in LOCALE.
2075 If LOCALE is a single locale or is a list of one element containing a
2076 single locale, then a "short form" of the instantiators for that locale
2077 will be returned. Otherwise, this function is identical to
2078 `specifier-spec-list'.
2080 The "short form" is designed for readability and not for ease of use
2081 in Lisp programs, and is as follows:
2083 1. If there is only one instantiator, then an inst-pair (i.e. cons of
2084 tag and instantiator) will be returned; otherwise a list of
2085 inst-pairs will be returned.
2086 2. For each inst-pair returned, if the instantiator's tag is 'any,
2087 the tag will be removed and the instantiator itself will be returned
2088 instead of the inst-pair.
2089 3. If there is only one instantiator, its value is nil, and its tag is
2090 'any, a one-element list containing nil will be returned rather
2091 than just nil, to distinguish this case from there being no
2092 instantiators at all.
2094 (specifier, locale, tag_set, exact_p))
2096 if (!NILP(Fvalid_specifier_locale_p(locale)) ||
2097 (CONSP(locale) && !NILP(Fvalid_specifier_locale_p(XCAR(locale))) &&
2098 NILP(XCDR(locale)))) {
2099 struct gcpro gcpro1;
2101 CHECK_SPECIFIER(specifier);
2103 locale = XCAR(locale);
2105 tag_set = decode_specifier_tag_set(tag_set);
2106 tag_set = canonicalize_tag_set(tag_set);
2108 (specifier_get_external_inst_list(specifier, locale,
2109 locale_type_from_locale
2111 !NILP(exact_p), 1, 1));
2113 return Fspecifier_spec_list(specifier, locale, tag_set,
2118 remove_specifier_mapfun(Lisp_Object specifier,
2120 enum spec_locale_type locale_type,
2121 Lisp_Object tag_set, int exact_p, void *ignored_closure)
2124 specifier_remove_locale_type(specifier, locale_type, tag_set,
2127 specifier_remove_spec(specifier, locale, locale_type, tag_set,
2132 DEFUN("remove-specifier", Fremove_specifier, 1, 4, 0, /*
2133 Remove specification(s) for SPECIFIER.
2135 If LOCALE is a particular locale (a window, buffer, frame, device,
2136 or 'global), the specification for that locale will be removed.
2138 If instead, LOCALE is a locale type (i.e. 'window, 'buffer, 'frame,
2139 or 'device), the specifications for all locales of that type will be
2142 If LOCALE is nil or 'all, all specifications will be removed.
2144 LOCALE can also be a list of locales, locale types, and/or 'all; this
2145 is equivalent to calling `remove-specifier' for each of the elements
2148 Only instantiators where TAG-SET (a list of zero or more tags) is a
2149 subset of (or possibly equal to) the instantiator's tag set are removed.
2150 The default value of nil is a subset of all tag sets, so in this case
2151 no instantiators will be screened out. If EXACT-P is non-nil, however,
2152 TAG-SET must be equal to an instantiator's tag set for the instantiator
2155 (specifier, locale, tag_set, exact_p))
2157 CHECK_SPECIFIER(specifier);
2158 check_modifiable_specifier(specifier);
2160 map_specifier(specifier, locale, remove_specifier_mapfun,
2161 tag_set, exact_p, 0);
2162 recompute_cached_specifier_everywhere(specifier);
2167 remove_ghost_specifier(Lisp_Object specifier, Lisp_Object locale,
2168 Lisp_Object tag_set, Lisp_Object exact_p)
2170 int depth = unlock_ghost_specifiers_protected();
2171 Fremove_specifier(XSPECIFIER(specifier)->fallback,
2172 locale, tag_set, exact_p);
2173 unbind_to(depth, Qnil);
2176 struct copy_specifier_closure {
2178 enum spec_add_meth add_meth;
2179 int add_meth_is_nil;
2183 copy_specifier_mapfun(Lisp_Object specifier,
2185 enum spec_locale_type locale_type,
2186 Lisp_Object tag_set, int exact_p, void *closure)
2188 struct copy_specifier_closure *cl =
2189 (struct copy_specifier_closure *)closure;
2192 specifier_copy_locale_type(specifier, cl->dest, locale_type,
2194 cl->add_meth_is_nil ?
2195 SPEC_REMOVE_LOCALE_TYPE :
2198 specifier_copy_spec(specifier, cl->dest, locale, locale_type,
2200 cl->add_meth_is_nil ? SPEC_REMOVE_LOCALE :
2205 DEFUN("copy-specifier", Fcopy_specifier, 1, 6, 0, /*
2206 Copy SPECIFIER to DEST, or create a new one if DEST is nil.
2208 If DEST is nil or omitted, a new specifier will be created and the
2209 specifications copied into it. Otherwise, the specifications will be
2210 copied into the existing specifier in DEST.
2212 If LOCALE is nil or 'all, all specifications will be copied. If LOCALE
2213 is a particular locale, the specification for that particular locale will
2214 be copied. If LOCALE is a locale type, the specifications for all locales
2215 of that type will be copied. LOCALE can also be a list of locales,
2216 locale types, and/or 'all; this is equivalent to calling `copy-specifier'
2217 for each of the elements of the list. See `specifier-spec-list' for more
2218 information about LOCALE.
2220 Only instantiators where TAG-SET (a list of zero or more tags) is a
2221 subset of (or possibly equal to) the instantiator's tag set are copied.
2222 The default value of nil is a subset of all tag sets, so in this case
2223 no instantiators will be screened out. If EXACT-P is non-nil, however,
2224 TAG-SET must be equal to an instantiator's tag set for the instantiator
2227 Optional argument HOW-TO-ADD specifies what to do with existing
2228 specifications in DEST. If nil, then whichever locales or locale types
2229 are copied will first be completely erased in DEST. Otherwise, it is
2230 the same as in `add-spec-to-specifier'.
2232 (specifier, dest, locale, tag_set, exact_p, how_to_add))
2234 struct gcpro gcpro1;
2235 struct copy_specifier_closure cl;
2237 CHECK_SPECIFIER(specifier);
2238 if (NILP(how_to_add))
2239 cl.add_meth_is_nil = 1;
2241 cl.add_meth_is_nil = 0;
2242 cl.add_meth = decode_how_to_add_specification(how_to_add);
2244 /* #### What about copying the extra data? */
2245 dest = make_specifier(XSPECIFIER(specifier)->methods);
2247 CHECK_SPECIFIER(dest);
2248 check_modifiable_specifier(dest);
2249 if (XSPECIFIER(dest)->methods != XSPECIFIER(specifier)->methods)
2250 error("Specifiers not of same type");
2255 map_specifier(specifier, locale, copy_specifier_mapfun,
2256 tag_set, exact_p, &cl);
2258 recompute_cached_specifier_everywhere(dest);
2262 /************************************************************************/
2264 /************************************************************************/
2267 call_validate_matchspec_method(Lisp_Object boxed_method, Lisp_Object matchspec)
2269 ((void (*)(Lisp_Object))get_opaque_ptr(boxed_method)) (matchspec);
2274 check_valid_specifier_matchspec(Lisp_Object matchspec,
2275 struct specifier_methods *meths,
2276 Error_behavior errb)
2278 if (meths->validate_matchspec_method) {
2281 if (ERRB_EQ(errb, ERROR_ME)) {
2282 (meths->validate_matchspec_method) (matchspec);
2285 Lisp_Object opaque =
2286 make_opaque_ptr((void *)meths->
2287 validate_matchspec_method);
2288 struct gcpro gcpro1;
2291 retval = call_with_suspended_errors
2292 ((lisp_fn_t) call_validate_matchspec_method,
2293 Qnil, Qspecifier, errb, 2, opaque, matchspec);
2295 free_opaque_ptr(opaque);
2301 maybe_signal_simple_error
2302 ("Matchspecs not allowed for this specifier type",
2303 intern(meths->name), Qspecifier, errb);
2308 DEFUN("check-valid-specifier-matchspec", Fcheck_valid_specifier_matchspec, 2, 2, 0, /*
2309 Signal an error if MATCHSPEC is invalid for SPECIFIER-TYPE.
2310 See `specifier-matching-instance' for a description of matchspecs.
2312 (matchspec, specifier_type))
2314 struct specifier_methods *meths = decode_specifier_type(specifier_type,
2317 return check_valid_specifier_matchspec(matchspec, meths, ERROR_ME);
2320 DEFUN("valid-specifier-matchspec-p", Fvalid_specifier_matchspec_p, 2, 2, 0, /*
2321 Return non-nil if MATCHSPEC is valid for SPECIFIER-TYPE.
2322 See `specifier-matching-instance' for a description of matchspecs.
2324 (matchspec, specifier_type))
2326 struct specifier_methods *meths = decode_specifier_type(specifier_type,
2329 return check_valid_specifier_matchspec(matchspec, meths, ERROR_ME_NOT);
2332 /* This function is purposely not callable from Lisp. If a Lisp
2333 caller wants to set a fallback, they should just set the
2336 void set_specifier_fallback(Lisp_Object specifier, Lisp_Object fallback)
2338 Lisp_Specifier *sp = XSPECIFIER(specifier);
2339 assert(SPECIFIERP(fallback) ||
2340 !NILP(Fvalid_inst_list_p(fallback, Fspecifier_type(specifier))));
2341 if (SPECIFIERP(fallback))
2343 (Fspecifier_type(specifier), Fspecifier_type(fallback)));
2344 if (BODILY_SPECIFIER_P(sp))
2345 GHOST_SPECIFIER(sp)->fallback = fallback;
2347 sp->fallback = fallback;
2348 /* call the after-change method */
2349 MAYBE_SPECMETH(sp, after_change,
2350 (bodily_specifier(specifier), Qfallback));
2351 recompute_cached_specifier_everywhere(specifier);
2354 DEFUN("specifier-fallback", Fspecifier_fallback, 1, 1, 0, /*
2355 Return the fallback value for SPECIFIER.
2356 Fallback values are provided by the C code for certain built-in
2357 specifiers to make sure that instancing won't fail even if all
2358 specs are removed from the specifier, or to implement simple
2359 inheritance behavior (e.g. this method is used to ensure that
2360 faces other than 'default inherit their attributes from 'default).
2361 By design, you cannot change the fallback value, and specifiers
2362 created with `make-specifier' will never have a fallback (although
2363 a similar, Lisp-accessible capability may be provided in the future
2364 to allow for inheritance).
2366 The fallback value will be an inst-list that is instanced like
2367 any other inst-list, a specifier of the same type as SPECIFIER
2368 \(results in inheritance), or nil for no fallback.
2370 When you instance a specifier, you can explicitly request that the
2371 fallback not be consulted. (The C code does this, for example, when
2372 merging faces.) See `specifier-instance'.
2376 CHECK_SPECIFIER(specifier);
2377 return Fcopy_tree(XSPECIFIER(specifier)->fallback, Qt);
2381 specifier_instance_from_inst_list(Lisp_Object specifier,
2382 Lisp_Object matchspec,
2384 Lisp_Object inst_list,
2385 Error_behavior errb, int no_quit,
2388 /* This function can GC */
2392 int count = specpdl_depth();
2393 struct gcpro gcpro1, gcpro2;
2395 GCPRO2(specifier, inst_list);
2397 sp = XSPECIFIER(specifier);
2398 device = DOMAIN_DEVICE(domain);
2401 /* The instantiate method is allowed to call eval. Since it
2402 is quite common for this function to get called from somewhere in
2403 redisplay we need to make sure that quits are ignored. Otherwise
2404 Fsignal will abort. */
2405 specbind(Qinhibit_quit, Qt);
2407 LIST_LOOP(rest, inst_list) {
2408 Lisp_Object tagged_inst = XCAR(rest);
2409 Lisp_Object tag_set = XCAR(tagged_inst);
2411 if (device_matches_specifier_tag_set_p(device, tag_set)) {
2412 Lisp_Object val = XCDR(tagged_inst);
2414 if (HAS_SPECMETH_P(sp, instantiate))
2415 val = call_with_suspended_errors
2416 ((lisp_fn_t) RAW_SPECMETH(sp, instantiate),
2417 Qunbound, Qspecifier, errb, 5, specifier,
2418 matchspec, domain, val, depth);
2420 if (!UNBOUNDP(val)) {
2421 unbind_to(count, Qnil);
2428 unbind_to(count, Qnil);
2433 /* Given a SPECIFIER and a DOMAIN, return a specific instance for that
2434 specifier. Try to find one by checking the specifier types from most
2435 specific (buffer) to most general (global). If we find an instance,
2436 return it. Otherwise return Qunbound. */
2438 #define CHECK_INSTANCE_ENTRY(key, matchspec, type) do { \
2439 Lisp_Object *CIE_inst_list = \
2440 specifier_get_inst_list (specifier, key, type); \
2441 if (CIE_inst_list) \
2443 Lisp_Object CIE_val = \
2444 specifier_instance_from_inst_list (specifier, matchspec, \
2445 domain, *CIE_inst_list, \
2446 errb, no_quit, depth); \
2447 if (!UNBOUNDP (CIE_val)) \
2452 /* We accept any window, frame or device domain and do our checking
2453 starting from as specific a locale type as we can determine from the
2454 domain we are passed and going on up through as many other locale types
2455 as we can determine. In practice, when called from redisplay the
2456 arg will usually be a window and occasionally a frame. If
2457 triggered by a user call, who knows what it will usually be. */
2459 specifier_instance(Lisp_Object specifier, Lisp_Object matchspec,
2460 Lisp_Object domain, Error_behavior errb, int no_quit,
2461 int no_fallback, Lisp_Object depth)
2463 Lisp_Object buffer = Qnil;
2464 Lisp_Object window = Qnil;
2465 Lisp_Object frame = Qnil;
2466 Lisp_Object device = Qnil;
2467 Lisp_Object tag = Qnil; /* #### currently unused */
2468 Lisp_Specifier *sp = XSPECIFIER(specifier);
2470 /* Attempt to determine buffer, window, frame, and device from the
2472 /* #### get image instances out of domains! */
2473 if (IMAGE_INSTANCEP(domain))
2474 window = DOMAIN_WINDOW(domain);
2475 else if (WINDOWP(domain))
2477 else if (FRAMEP(domain))
2479 else if (DEVICEP(domain))
2482 /* dmoore writes: [dammit, this should just signal an error or something
2485 No. Errors are handled in Lisp primitives implementation.
2486 Invalid domain is a design error here - kkm. */
2489 if (NILP(buffer) && !NILP(window))
2490 buffer = WINDOW_BUFFER(XWINDOW(window));
2491 if (NILP(frame) && !NILP(window))
2492 frame = XWINDOW(window)->frame;
2494 /* frame had better exist; if device is undeterminable, something
2495 really went wrong. */
2496 device = FRAME_DEVICE(XFRAME(frame));
2498 /* device had better be determined by now; abort if not. */
2499 tag = DEVICE_CLASS(XDEVICE(device));
2500 (void)tag; // Silence set-not-read warning.
2502 depth = make_int(1 + XINT(depth));
2503 if (XINT(depth) > 20) {
2504 maybe_error(Qspecifier, errb,
2505 "Apparent loop in specifier inheritance");
2506 /* The specification is fucked; at least try the fallback
2507 (which better not be fucked, because it's not changeable
2514 /* First see if we can generate one from the window specifiers. */
2516 CHECK_INSTANCE_ENTRY(window, matchspec, LOCALE_WINDOW);
2518 /* Next see if we can generate one from the buffer specifiers. */
2520 CHECK_INSTANCE_ENTRY(buffer, matchspec, LOCALE_BUFFER);
2522 /* Next see if we can generate one from the frame specifiers. */
2524 CHECK_INSTANCE_ENTRY(frame, matchspec, LOCALE_FRAME);
2526 /* If we still haven't succeeded try with the device specifiers. */
2527 CHECK_INSTANCE_ENTRY(device, matchspec, LOCALE_DEVICE);
2529 /* Last and least try the global specifiers. */
2530 CHECK_INSTANCE_ENTRY(Qglobal, matchspec, LOCALE_GLOBAL);
2533 /* We're out of specifiers and we still haven't generated an
2534 instance. At least try the fallback ... If this fails,
2535 then we just return Qunbound. */
2537 if (no_fallback || NILP(sp->fallback))
2538 /* I said, I don't want the fallbacks. */
2541 if (SPECIFIERP(sp->fallback)) {
2542 /* If you introduced loops in the default specifier chain,
2543 then you're fucked, so you better not do this. */
2544 specifier = sp->fallback;
2545 sp = XSPECIFIER(specifier);
2549 assert(CONSP(sp->fallback));
2550 return specifier_instance_from_inst_list(specifier, matchspec, domain,
2551 sp->fallback, errb, no_quit,
2555 #undef CHECK_INSTANCE_ENTRY
2558 specifier_instance_no_quit(Lisp_Object specifier, Lisp_Object matchspec,
2559 Lisp_Object domain, Error_behavior errb,
2560 int no_fallback, Lisp_Object depth)
2562 return specifier_instance(specifier, matchspec, domain, errb,
2563 1, no_fallback, depth);
2566 DEFUN("specifier-instance", Fspecifier_instance, 1, 4, 0, /*
2567 Instantiate SPECIFIER (return its value) in DOMAIN.
2568 If no instance can be generated for this domain, return DEFAULT.
2570 DOMAIN should be a window, frame, or device. Other values that are legal
2571 as a locale (e.g. a buffer) are not valid as a domain because they do not
2572 provide enough information to identify a particular device (see
2573 `valid-specifier-domain-p'). DOMAIN defaults to the selected window
2576 "Instantiating" a specifier in a particular domain means determining
2577 the specifier's "value" in that domain. This is accomplished by
2578 searching through the specifications in the specifier that correspond
2579 to all locales that can be derived from the given domain, from specific
2580 to general. In most cases, the domain is an Emacs window. In that case
2581 specifications are searched for as follows:
2583 1. A specification whose locale is the window itself;
2584 2. A specification whose locale is the window's buffer;
2585 3. A specification whose locale is the window's frame;
2586 4. A specification whose locale is the window's frame's device;
2587 5. A specification whose locale is 'global.
2589 If all of those fail, then the C-code-provided fallback value for
2590 this specifier is consulted (see `specifier-fallback'). If it is
2591 an inst-list, then this function attempts to instantiate that list
2592 just as when a specification is located in the first five steps above.
2593 If the fallback is a specifier, `specifier-instance' is called
2594 recursively on this specifier and the return value used. Note,
2595 however, that if the optional argument NO-FALLBACK is non-nil,
2596 the fallback value will not be consulted.
2598 Note that there may be more than one specification matching a particular
2599 locale; all such specifications are considered before looking for any
2600 specifications for more general locales. Any particular specification
2601 that is found may be rejected because its tag set does not match the
2602 device being instantiated over, or because the specification is not
2603 valid for the device of the given domain (e.g. the font or color name
2604 does not exist for this particular X server).
2606 The returned value is dependent on the type of specifier. For example,
2607 for a font specifier (as returned by the `face-font' function), the returned
2608 value will be a font-instance object. For glyphs, the returned value
2609 will be a string, pixmap, or subwindow.
2611 See also `specifier-matching-instance'.
2613 (specifier, domain, default_, no_fallback))
2615 Lisp_Object instance;
2617 CHECK_SPECIFIER(specifier);
2618 domain = decode_domain(domain);
2620 instance = specifier_instance(specifier, Qunbound, domain, ERROR_ME, 0,
2621 !NILP(no_fallback), Qzero);
2622 return UNBOUNDP(instance) ? default_ : instance;
2625 DEFUN("specifier-matching-instance", Fspecifier_matching_instance, 2, 5, 0, /*
2626 Return an instance for SPECIFIER in DOMAIN that matches MATCHSPEC.
2627 If no instance can be generated for this domain, return DEFAULT.
2629 This function is identical to `specifier-instance' except that a
2630 specification will only be considered if it matches MATCHSPEC.
2631 The definition of "match", and allowed values for MATCHSPEC, are
2632 dependent on the particular type of specifier. Here are some examples:
2634 -- For chartable (e.g. display table) specifiers, MATCHSPEC should be a
2635 character, and the specification (a chartable) must give a value for
2636 that character in order to be considered. This allows you to specify,
2637 e.g., a buffer-local display table that only gives values for particular
2638 characters. All other characters are handled as if the buffer-local
2639 display table is not there. (Chartable specifiers are not yet
2642 -- For font specifiers, MATCHSPEC should be a charset, and the specification
2643 (a font string) must have a registry that matches the charset's registry.
2644 (This only makes sense with Mule support.) This makes it easy to choose a
2645 font that can display a particular character. (This is what redisplay
2648 (specifier, matchspec, domain, default_, no_fallback))
2650 Lisp_Object instance;
2652 CHECK_SPECIFIER(specifier);
2653 check_valid_specifier_matchspec(matchspec,
2654 XSPECIFIER(specifier)->methods,
2656 domain = decode_domain(domain);
2658 instance = specifier_instance(specifier, matchspec, domain, ERROR_ME,
2659 0, !NILP(no_fallback), Qzero);
2660 return UNBOUNDP(instance) ? default_ : instance;
2663 DEFUN("specifier-instance-from-inst-list", Fspecifier_instance_from_inst_list, 3, 4, 0, /*
2664 Attempt to convert a particular inst-list into an instance.
2665 This attempts to instantiate INST-LIST in the given DOMAIN,
2666 as if INST-LIST existed in a specification in SPECIFIER. If
2667 the instantiation fails, DEFAULT is returned. In most circumstances,
2668 you should not use this function; use `specifier-instance' instead.
2670 (specifier, domain, inst_list, default_))
2672 Lisp_Object val = Qunbound;
2673 Lisp_Specifier *sp = XSPECIFIER(specifier);
2674 struct gcpro gcpro1;
2675 Lisp_Object built_up_list = Qnil;
2677 CHECK_SPECIFIER(specifier);
2678 check_valid_domain(domain);
2679 check_valid_inst_list(inst_list, sp->methods, ERROR_ME);
2680 GCPRO1(built_up_list);
2681 built_up_list = build_up_processed_list(specifier, domain, inst_list);
2682 if (!NILP(built_up_list))
2684 specifier_instance_from_inst_list(specifier, Qunbound,
2685 domain, built_up_list,
2686 ERROR_ME, 0, Qzero);
2688 return UNBOUNDP(val) ? default_ : val;
2691 DEFUN("specifier-matching-instance-from-inst-list", Fspecifier_matching_instance_from_inst_list, 4, 5, 0, /*
2692 Attempt to convert a particular inst-list into an instance.
2693 This attempts to instantiate INST-LIST in the given DOMAIN
2694 \(as if INST-LIST existed in a specification in SPECIFIER),
2695 matching the specifications against MATCHSPEC.
2697 This function is analogous to `specifier-instance-from-inst-list'
2698 but allows for specification-matching as in `specifier-matching-instance'.
2699 See that function for a description of exactly how the matching process
2702 (specifier, matchspec, domain, inst_list, default_))
2704 Lisp_Object val = Qunbound;
2705 Lisp_Specifier *sp = XSPECIFIER(specifier);
2706 struct gcpro gcpro1;
2707 Lisp_Object built_up_list = Qnil;
2709 CHECK_SPECIFIER(specifier);
2710 check_valid_specifier_matchspec(matchspec,
2711 XSPECIFIER(specifier)->methods,
2713 check_valid_domain(domain);
2714 check_valid_inst_list(inst_list, sp->methods, ERROR_ME);
2715 GCPRO1(built_up_list);
2716 built_up_list = build_up_processed_list(specifier, domain, inst_list);
2717 if (!NILP(built_up_list))
2719 specifier_instance_from_inst_list(specifier, matchspec,
2720 domain, built_up_list,
2721 ERROR_ME, 0, Qzero);
2723 return UNBOUNDP(val) ? default_ : val;
2726 /************************************************************************/
2727 /* Caching in the struct window or frame */
2728 /************************************************************************/
2730 /* Either STRUCT_WINDOW_OFFSET or STRUCT_FRAME_OFFSET can be 0 to indicate
2731 no caching in that sort of object. */
2733 /* #### It would be nice if the specifier caching automatically knew
2734 about specifier fallbacks, so we didn't have to do it ourselves. */
2737 set_specifier_caching(Lisp_Object specifier, int struct_window_offset,
2738 void (*value_changed_in_window)
2739 (Lisp_Object specifier, struct window * w,
2740 Lisp_Object oldval),
2741 int struct_frame_offset, void (*value_changed_in_frame)
2742 (Lisp_Object specifier, struct frame * f,
2743 Lisp_Object oldval), int always_recompute)
2745 Lisp_Specifier *sp = XSPECIFIER(specifier);
2746 assert(!GHOST_SPECIFIER_P(sp));
2749 sp->caching = xnew_and_zero(struct specifier_caching);
2750 sp->caching->offset_into_struct_window = struct_window_offset;
2751 sp->caching->value_changed_in_window = value_changed_in_window;
2752 sp->caching->offset_into_struct_frame = struct_frame_offset;
2753 sp->caching->value_changed_in_frame = value_changed_in_frame;
2754 sp->caching->always_recompute = always_recompute;
2755 Vcached_specifiers = Fcons(specifier, Vcached_specifiers);
2756 if (BODILY_SPECIFIER_P(sp))
2757 GHOST_SPECIFIER(sp)->caching = sp->caching;
2758 recompute_cached_specifier_everywhere(specifier);
2762 recompute_one_cached_specifier_in_window(Lisp_Object specifier,
2766 Lisp_Object newval, *location, oldval;
2768 assert(!GHOST_SPECIFIER_P(XSPECIFIER(specifier)));
2770 XSETWINDOW(window, w);
2772 newval = specifier_instance(specifier, Qunbound, window, ERROR_ME_WARN,
2774 /* If newval ended up Qunbound, then the calling functions
2775 better be able to deal. If not, set a default so this
2776 never happens or correct it in the value_changed_in_window
2778 location = (Lisp_Object *)
2780 XSPECIFIER(specifier)->caching->offset_into_struct_window);
2781 /* #### What's the point of this check, other than to optimize image
2782 instance instantiation? Unless you specify a caching instantiate
2783 method the instantiation that specifier_instance will do will
2784 always create a new copy. Thus EQ will always fail. Unfortunately
2785 calling equal is no good either as this doesn't take into account
2786 things attached to the specifier - for instance strings on
2788 if (!EQ(newval, *location)
2789 || XSPECIFIER(specifier)->caching->always_recompute) {
2792 (XSPECIFIER(specifier)->caching->value_changed_in_window)
2793 (specifier, w, oldval);
2798 recompute_one_cached_specifier_in_frame(Lisp_Object specifier, struct frame *f)
2801 Lisp_Object newval, *location, oldval;
2803 assert(!GHOST_SPECIFIER_P(XSPECIFIER(specifier)));
2805 XSETFRAME(frame, f);
2807 newval = specifier_instance(specifier, Qunbound, frame, ERROR_ME_WARN,
2809 /* If newval ended up Qunbound, then the calling functions
2810 better be able to deal. If not, set a default so this
2811 never happens or correct it in the value_changed_in_frame
2813 location = (Lisp_Object *)
2815 XSPECIFIER(specifier)->caching->offset_into_struct_frame);
2816 if (!EQ(newval, *location)
2817 || XSPECIFIER(specifier)->caching->always_recompute) {
2820 (XSPECIFIER(specifier)->caching->value_changed_in_frame)
2821 (specifier, f, oldval);
2825 void recompute_all_cached_specifiers_in_window(struct window *w)
2829 LIST_LOOP(rest, Vcached_specifiers) {
2830 Lisp_Object specifier = XCAR(rest);
2831 if (XSPECIFIER(specifier)->caching->offset_into_struct_window)
2832 recompute_one_cached_specifier_in_window(specifier, w);
2836 void recompute_all_cached_specifiers_in_frame(struct frame *f)
2840 LIST_LOOP(rest, Vcached_specifiers) {
2841 Lisp_Object specifier = XCAR(rest);
2842 if (XSPECIFIER(specifier)->caching->offset_into_struct_frame)
2843 recompute_one_cached_specifier_in_frame(specifier, f);
2848 recompute_cached_specifier_everywhere_mapfun(struct window *w, void *closure)
2850 Lisp_Object specifier = Qnil;
2852 VOID_TO_LISP(specifier, closure);
2853 recompute_one_cached_specifier_in_window(specifier, w);
2857 static void recompute_cached_specifier_everywhere(Lisp_Object specifier)
2859 Lisp_Object frmcons, devcons, concons;
2861 specifier = bodily_specifier(specifier);
2863 if (!XSPECIFIER(specifier)->caching)
2866 if (XSPECIFIER(specifier)->caching->offset_into_struct_window) {
2867 FRAME_LOOP_NO_BREAK(frmcons, devcons, concons)
2868 map_windows(XFRAME(XCAR(frmcons)),
2869 recompute_cached_specifier_everywhere_mapfun,
2870 LISP_TO_VOID(specifier));
2873 if (XSPECIFIER(specifier)->caching->offset_into_struct_frame) {
2874 FRAME_LOOP_NO_BREAK(frmcons, devcons, concons)
2875 recompute_one_cached_specifier_in_frame(specifier,
2881 DEFUN("set-specifier-dirty-flag", Fset_specifier_dirty_flag, 1, 1, 0, /*
2882 Force recomputation of any caches associated with SPECIFIER.
2883 Note that this automatically happens whenever you change a specification
2884 in SPECIFIER; you do not have to call this function then.
2885 One example of where this function is useful is when you have a
2886 toolbar button whose `active-p' field is an expression to be
2887 evaluated. Calling `set-specifier-dirty-flag' on the
2888 toolbar specifier will force the `active-p' fields to be
2893 CHECK_SPECIFIER(specifier);
2894 recompute_cached_specifier_everywhere(specifier);
2898 /************************************************************************/
2899 /* Generic specifier type */
2900 /************************************************************************/
2902 DEFINE_SPECIFIER_TYPE(generic);
2906 /* This is the string that used to be in `generic-specifier-p'.
2907 The idea is good, but it doesn't quite work in the form it's
2908 in. (One major problem is that validating an instantiator
2909 is supposed to require only that the specifier type is passed,
2910 while with this approach the actual specifier is needed.)
2912 What really needs to be done is to write a function
2913 `make-specifier-type' that creates new specifier types.
2915 #### [I'll look into this for 19.14.] Well, sometime. (Currently
2916 May 2000, 21.2 is in development. 19.14 was released in June 1996.) */
2918 "A generic specifier is a generalized kind of specifier with user-defined\n"
2919 "semantics. The instantiator can be any kind of Lisp object, and the\n"
2920 "instance computed from it is likewise any kind of Lisp object. The\n"
2921 "SPECIFIER-DATA should be an alist of methods governing how the specifier\n"
2922 "works. All methods are optional, and reasonable default methods will be\n"
2923 "provided. Currently there are two defined methods: 'instantiate and\n"
2926 "'instantiate specifies how to do the instantiation; if omitted, the\n"
2927 "instantiator itself is simply returned as the instance. The method\n"
2928 "should be a function that accepts three parameters (a specifier, the\n"
2929 "instantiator that matched the domain being instantiated over, and that\n"
2930 "domain), and should return a one-element list containing the instance,\n"
2931 "or nil if no instance exists. Note that the domain passed to this function\n"
2932 "is the domain being instantiated over, which may not be the same as the\n"
2933 "locale contained in the specification corresponding to the instantiator\n"
2934 "(for example, the domain being instantiated over could be a window, but\n"
2935 "the locale corresponding to the passed instantiator could be the window's\n"
2936 "buffer or frame).\n"
2938 "'validate specifies whether a given instantiator is valid; if omitted,\n"
2939 "all instantiators are considered valid. It should be a function of\n"
2940 "two arguments: an instantiator and a flag CAN-SIGNAL-ERROR. If this\n"
2941 "flag is false, the function must simply return t or nil indicating\n"
2942 "whether the instantiator is valid. If this flag is true, the function\n"
2943 "is free to signal an error if it encounters an invalid instantiator\n"
2944 "(this can be useful for issuing a specific error about exactly why the\n"
2945 "instantiator is valid). It can also return nil to indicate an invalid\n"
2946 "instantiator; in this case, a general error will be signalled."
2948 DEFUN("generic-specifier-p", Fgeneric_specifier_p, 1, 1, 0, /*
2949 Return non-nil if OBJECT is a generic specifier.
2951 See `make-generic-specifier' for a description of possible generic
2956 return GENERIC_SPECIFIERP(object) ? Qt : Qnil;
2959 /************************************************************************/
2960 /* Integer specifier type */
2961 /************************************************************************/
2963 DEFINE_SPECIFIER_TYPE(integer);
2965 static void integer_validate(Lisp_Object instantiator)
2967 CHECK_INT(instantiator);
2970 DEFUN("integer-specifier-p", Finteger_specifier_p, 1, 1, 0, /*
2971 Return non-nil if OBJECT is an integer specifier.
2973 See `make-integer-specifier' for a description of possible integer
2978 return INTEGER_SPECIFIERP(object) ? Qt : Qnil;
2981 /************************************************************************/
2982 /* Non-negative-integer specifier type */
2983 /************************************************************************/
2985 DEFINE_SPECIFIER_TYPE(natnum);
2987 static void natnum_validate(Lisp_Object instantiator)
2989 CHECK_NATNUM(instantiator);
2992 DEFUN("natnum-specifier-p", Fnatnum_specifier_p, 1, 1, 0, /*
2993 Return non-nil if OBJECT is a natnum (non-negative-integer) specifier.
2995 See `make-natnum-specifier' for a description of possible natnum
3000 return NATNUM_SPECIFIERP(object) ? Qt : Qnil;
3003 /************************************************************************/
3004 /* Boolean specifier type */
3005 /************************************************************************/
3007 DEFINE_SPECIFIER_TYPE(boolean);
3009 static void boolean_validate(Lisp_Object instantiator)
3011 if (!EQ(instantiator, Qt) && !EQ(instantiator, Qnil))
3012 signal_type_error(Qspecifier_argument_error, "Must be t or nil",
3016 DEFUN("boolean-specifier-p", Fboolean_specifier_p, 1, 1, 0, /*
3017 Return non-nil if OBJECT is a boolean specifier.
3019 See `make-boolean-specifier' for a description of possible boolean
3024 return BOOLEAN_SPECIFIERP(object) ? Qt : Qnil;
3027 /************************************************************************/
3028 /* Display table specifier type */
3029 /************************************************************************/
3031 DEFINE_SPECIFIER_TYPE(display_table);
3033 #define VALID_SINGLE_DISPTABLE_INSTANTIATOR_P(instantiator) \
3034 (VECTORP (instantiator) \
3035 || (CHAR_TABLEP (instantiator) \
3036 && (XCHAR_TABLE_TYPE (instantiator) == CHAR_TABLE_TYPE_CHAR \
3037 || XCHAR_TABLE_TYPE (instantiator) == CHAR_TABLE_TYPE_GENERIC)) \
3038 || RANGE_TABLEP (instantiator))
3040 static void display_table_validate(Lisp_Object instantiator)
3042 if (NILP(instantiator))
3045 else if (CONSP(instantiator)) {
3047 EXTERNAL_LIST_LOOP(tail, instantiator) {
3048 Lisp_Object car = XCAR(tail);
3049 if (!VALID_SINGLE_DISPTABLE_INSTANTIATOR_P(car))
3053 if (!VALID_SINGLE_DISPTABLE_INSTANTIATOR_P(instantiator)) {
3055 dead_wrong_type_argument
3056 (display_table_specifier_methods->predicate_symbol,
3062 DEFUN("display-table-specifier-p", Fdisplay_table_specifier_p, 1, 1, 0, /*
3063 Return non-nil if OBJECT is a display-table specifier.
3065 See `current-display-table' for a description of possible display-table
3070 return DISPLAYTABLE_SPECIFIERP(object) ? Qt : Qnil;
3073 /************************************************************************/
3074 /* Initialization */
3075 /************************************************************************/
3077 void syms_of_specifier(void)
3079 INIT_LRECORD_IMPLEMENTATION(specifier);
3081 DEFSYMBOL(Qspecifierp);
3083 DEFSYMBOL(Qconsole_type);
3084 DEFSYMBOL(Qdevice_class);
3086 /* specifier types defined in general.c. */
3088 DEFSUBR(Fvalid_specifier_type_p);
3089 DEFSUBR(Fspecifier_type_list);
3090 DEFSUBR(Fmake_specifier);
3091 DEFSUBR(Fspecifierp);
3092 DEFSUBR(Fspecifier_type);
3094 DEFSUBR(Fvalid_specifier_locale_p);
3095 DEFSUBR(Fvalid_specifier_domain_p);
3096 DEFSUBR(Fvalid_specifier_locale_type_p);
3097 DEFSUBR(Fspecifier_locale_type_from_locale);
3099 DEFSUBR(Fvalid_specifier_tag_p);
3100 DEFSUBR(Fvalid_specifier_tag_set_p);
3101 DEFSUBR(Fcanonicalize_tag_set);
3102 DEFSUBR(Fdevice_matches_specifier_tag_set_p);
3103 DEFSUBR(Fdefine_specifier_tag);
3104 DEFSUBR(Fdevice_matching_specifier_tag_list);
3105 DEFSUBR(Fspecifier_tag_list);
3106 DEFSUBR(Fspecifier_tag_predicate);
3108 DEFSUBR(Fcheck_valid_instantiator);
3109 DEFSUBR(Fvalid_instantiator_p);
3110 DEFSUBR(Fcheck_valid_inst_list);
3111 DEFSUBR(Fvalid_inst_list_p);
3112 DEFSUBR(Fcheck_valid_spec_list);
3113 DEFSUBR(Fvalid_spec_list_p);
3114 DEFSUBR(Fadd_spec_to_specifier);
3115 DEFSUBR(Fadd_spec_list_to_specifier);
3116 DEFSUBR(Fspecifier_spec_list);
3117 DEFSUBR(Fspecifier_specs);
3118 DEFSUBR(Fremove_specifier);
3119 DEFSUBR(Fcopy_specifier);
3121 DEFSUBR(Fcheck_valid_specifier_matchspec);
3122 DEFSUBR(Fvalid_specifier_matchspec_p);
3123 DEFSUBR(Fspecifier_fallback);
3124 DEFSUBR(Fspecifier_instance);
3125 DEFSUBR(Fspecifier_matching_instance);
3126 DEFSUBR(Fspecifier_instance_from_inst_list);
3127 DEFSUBR(Fspecifier_matching_instance_from_inst_list);
3128 DEFSUBR(Fset_specifier_dirty_flag);
3130 DEFSUBR(Fgeneric_specifier_p);
3131 DEFSUBR(Finteger_specifier_p);
3132 DEFSUBR(Fnatnum_specifier_p);
3133 DEFSUBR(Fboolean_specifier_p);
3134 DEFSUBR(Fdisplay_table_specifier_p);
3136 /* Symbols pertaining to specifier creation. Specifiers are created
3137 in the syms_of() functions. */
3139 /* locales are defined in general.c. */
3141 /* some how-to-add flags in general.c. */
3142 DEFSYMBOL(Qremove_tag_set_prepend);
3143 DEFSYMBOL(Qremove_tag_set_append);
3144 DEFSYMBOL(Qremove_locale);
3145 DEFSYMBOL(Qremove_locale_type);
3147 DEFERROR_STANDARD(Qspecifier_syntax_error, Qsyntax_error);
3148 DEFERROR_STANDARD(Qspecifier_argument_error, Qinvalid_argument);
3149 DEFERROR_STANDARD(Qspecifier_change_error, Qinvalid_change);
3152 void specifier_type_create(void)
3154 the_specifier_type_entry_dynarr = Dynarr_new(specifier_type_entry);
3155 dump_add_root_struct_ptr(&the_specifier_type_entry_dynarr,
3158 Vspecifier_type_list = Qnil;
3159 staticpro(&Vspecifier_type_list);
3161 INITIALIZE_SPECIFIER_TYPE(generic, "generic", "generic-specifier-p");
3163 INITIALIZE_SPECIFIER_TYPE(integer, "integer", "integer-specifier-p");
3165 SPECIFIER_HAS_METHOD(integer, validate);
3167 INITIALIZE_SPECIFIER_TYPE(natnum, "natnum", "natnum-specifier-p");
3169 SPECIFIER_HAS_METHOD(natnum, validate);
3171 INITIALIZE_SPECIFIER_TYPE(boolean, "boolean", "boolean-specifier-p");
3173 SPECIFIER_HAS_METHOD(boolean, validate);
3175 INITIALIZE_SPECIFIER_TYPE(display_table, "display-table",
3178 SPECIFIER_HAS_METHOD(display_table, validate);
3181 void reinit_specifier_type_create(void)
3183 REINITIALIZE_SPECIFIER_TYPE(generic);
3184 REINITIALIZE_SPECIFIER_TYPE(integer);
3185 REINITIALIZE_SPECIFIER_TYPE(natnum);
3186 REINITIALIZE_SPECIFIER_TYPE(boolean);
3187 REINITIALIZE_SPECIFIER_TYPE(display_table);
3190 void vars_of_specifier(void)
3192 Vcached_specifiers = Qnil;
3193 staticpro(&Vcached_specifiers);
3195 /* Do NOT mark through this, or specifiers will never be GC'd.
3196 This is the same deal as for weak hash tables. */
3197 Vall_specifiers = Qnil;
3198 dump_add_weak_object_chain(&Vall_specifiers);
3200 Vuser_defined_tags = Qnil;
3201 staticpro(&Vuser_defined_tags);
3203 Vunlock_ghost_specifiers = Qnil;
3204 staticpro(&Vunlock_ghost_specifiers);