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 XEmacs.
8 XEmacs is free software; you can redistribute it and/or modify it
9 under the terms of the GNU General Public License as published by the
10 Free Software Foundation; either version 2, or (at your option) any
13 XEmacs is distributed in the hope that it will be useful, but WITHOUT
14 ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or
15 FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
18 You should have received a copy of the GNU General Public License
19 along with XEmacs; see the file COPYING. If not, write to
20 the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
21 Boston, MA 02111-1307, USA. */
23 /* Synched up with: Not in FSF. */
25 /* Design by Ben Wing;
26 Original version by Chuck Thompson;
27 rewritten by Ben Wing;
28 Magic specifiers by Kirill Katsnelson;
38 #include "specifier.h"
43 Lisp_Object Qspecifierp;
44 Lisp_Object Qprepend, Qappend, Qremove_tag_set_prepend, Qremove_tag_set_append;
45 Lisp_Object Qremove_locale, Qremove_locale_type, Qremove_all;
46 Lisp_Object Qfallback;
48 /* Qinteger, Qboolean, Qgeneric defined in general.c. */
51 Lisp_Object Qconsole_type, Qdevice_class;
53 static Lisp_Object Vuser_defined_tags;
55 typedef struct specifier_type_entry specifier_type_entry;
56 struct specifier_type_entry
59 struct specifier_methods *meths;
64 Dynarr_declare (specifier_type_entry);
65 } specifier_type_entry_dynarr;
67 static specifier_type_entry_dynarr *the_specifier_type_entry_dynarr;
69 static const struct lrecord_description ste_description_1[] = {
70 { XD_LISP_OBJECT, offsetof(specifier_type_entry, symbol), 1 },
71 { XD_STRUCT_PTR, offsetof(specifier_type_entry, meths), 1, &specifier_methods_description },
75 static const struct struct_description ste_description = {
76 sizeof(specifier_type_entry),
80 static const struct lrecord_description sted_description_1[] = {
81 XD_DYNARR_DESC(specifier_type_entry_dynarr, &ste_description),
85 static const struct struct_description sted_description = {
86 sizeof(specifier_type_entry_dynarr),
90 static Lisp_Object Vspecifier_type_list;
92 static Lisp_Object Vcached_specifiers;
93 /* Do NOT mark through this, or specifiers will never be GC'd. */
94 static Lisp_Object Vall_specifiers;
96 static Lisp_Object Vunlock_ghost_specifiers;
98 /* #### The purpose of this is to check for inheritance loops
99 in specifiers that can inherit from other specifiers, but it's
102 #### Look into this for 19.14. */
103 /* static Lisp_Object_dynarr current_specifiers; */
105 static void recompute_cached_specifier_everywhere (Lisp_Object specifier);
107 EXFUN (Fspecifier_specs, 4);
108 EXFUN (Fremove_specifier, 4);
111 /************************************************************************/
112 /* Specifier object methods */
113 /************************************************************************/
115 /* Remove dead objects from the specified assoc list. */
118 cleanup_assoc_list (Lisp_Object list)
120 Lisp_Object loop, prev, retval;
122 loop = retval = list;
127 Lisp_Object entry = XCAR (loop);
128 Lisp_Object key = XCAR (entry);
130 /* remember, dead windows can become alive again. */
131 if (!WINDOWP (key) && object_dead_p (key))
135 /* Removing the head. */
136 retval = XCDR (retval);
140 Fsetcdr (prev, XCDR (loop));
152 /* Remove dead objects from the various lists so that they
153 don't keep getting marked as long as this specifier exists and
154 therefore wasting memory. */
157 cleanup_specifiers (void)
161 for (rest = Vall_specifiers;
163 rest = XSPECIFIER (rest)->next_specifier)
165 struct Lisp_Specifier *sp = XSPECIFIER (rest);
166 /* This effectively changes the specifier specs.
167 However, there's no need to call
168 recompute_cached_specifier_everywhere() or the
169 after-change methods because the only specs we
170 are removing are for dead objects, and they can
171 never have any effect on the specifier values:
172 specifiers can only be instantiated over live
173 objects, and you can't derive a dead object
175 sp->device_specs = cleanup_assoc_list (sp->device_specs);
176 sp->frame_specs = cleanup_assoc_list (sp->frame_specs);
177 sp->buffer_specs = cleanup_assoc_list (sp->buffer_specs);
178 /* windows are handled specially because dead windows
179 can be resurrected */
184 kill_specifier_buffer_locals (Lisp_Object buffer)
188 for (rest = Vall_specifiers;
190 rest = XSPECIFIER (rest)->next_specifier)
192 struct Lisp_Specifier *sp = XSPECIFIER (rest);
194 /* Make sure we're actually going to be changing something.
195 Fremove_specifier() always calls
196 recompute_cached_specifier_everywhere() (#### but should
197 be smarter about this). */
198 if (!NILP (assq_no_quit (buffer, sp->buffer_specs)))
199 Fremove_specifier (rest, buffer, Qnil, Qnil);
204 mark_specifier (Lisp_Object obj)
206 struct Lisp_Specifier *specifier = XSPECIFIER (obj);
208 mark_object (specifier->global_specs);
209 mark_object (specifier->device_specs);
210 mark_object (specifier->frame_specs);
211 mark_object (specifier->window_specs);
212 mark_object (specifier->buffer_specs);
213 mark_object (specifier->magic_parent);
214 mark_object (specifier->fallback);
215 if (!GHOST_SPECIFIER_P (XSPECIFIER (obj)))
216 MAYBE_SPECMETH (specifier, mark, (obj));
220 /* The idea here is that the specifier specs point to locales
221 (windows, buffers, frames, and devices), and we want to make sure
222 that the specs disappear automatically when the associated locale
223 is no longer in use. For all but windows, "no longer in use"
224 corresponds exactly to when the object is deleted (non-deleted
225 objects are always held permanently in special lists, and deleted
226 objects are never on these lists and never reusable). To handle
227 this, we just have cleanup_specifiers() called periodically
228 (at the beginning of garbage collection); it removes all dead
231 For windows, however, it's trickier because dead objects can be
232 converted to live ones again if the dead object is in a window
233 configuration. Therefore, for windows, "no longer in use"
234 corresponds to when the window object is garbage-collected.
235 We now use weak lists for this purpose.
240 prune_specifiers (void)
242 Lisp_Object rest, prev = Qnil;
244 for (rest = Vall_specifiers;
246 rest = XSPECIFIER (rest)->next_specifier)
248 if (! marked_p (rest))
250 struct Lisp_Specifier* sp = XSPECIFIER (rest);
251 /* A bit of assertion that we're removing both parts of the
252 magic one altogether */
253 assert (!MAGIC_SPECIFIER_P(sp)
254 || (BODILY_SPECIFIER_P(sp) && marked_p (sp->fallback))
255 || (GHOST_SPECIFIER_P(sp) && marked_p (sp->magic_parent)));
256 /* This specifier is garbage. Remove it from the list. */
258 Vall_specifiers = sp->next_specifier;
260 XSPECIFIER (prev)->next_specifier = sp->next_specifier;
268 print_specifier (Lisp_Object obj, Lisp_Object printcharfun, int escapeflag)
270 struct Lisp_Specifier *sp = XSPECIFIER (obj);
272 int count = specpdl_depth ();
273 Lisp_Object the_specs;
276 error ("printing unreadable object #<%s-specifier 0x%x>",
277 sp->methods->name, sp->header.uid);
279 sprintf (buf, "#<%s-specifier global=", sp->methods->name);
280 write_c_string (buf, printcharfun);
281 specbind (Qprint_string_length, make_int (100));
282 specbind (Qprint_length, make_int (5));
283 the_specs = Fspecifier_specs (obj, Qglobal, Qnil, Qnil);
284 if (NILP (the_specs))
285 /* there are no global specs */
286 write_c_string ("<unspecified>", printcharfun);
288 print_internal (the_specs, printcharfun, 1);
289 if (!NILP (sp->fallback))
291 write_c_string (" fallback=", printcharfun);
292 print_internal (sp->fallback, printcharfun, escapeflag);
294 unbind_to (count, Qnil);
295 sprintf (buf, " 0x%x>", sp->header.uid);
296 write_c_string (buf, printcharfun);
300 finalize_specifier (void *header, int for_disksave)
302 struct Lisp_Specifier *sp = (struct Lisp_Specifier *) header;
303 /* don't be snafued by the disksave finalization. */
304 if (!for_disksave && !GHOST_SPECIFIER_P(sp) && sp->caching)
312 specifier_equal (Lisp_Object obj1, Lisp_Object obj2, int depth)
314 struct Lisp_Specifier *s1 = XSPECIFIER (obj1);
315 struct Lisp_Specifier *s2 = XSPECIFIER (obj2);
317 Lisp_Object old_inhibit_quit = Vinhibit_quit;
319 /* This function can be called from within redisplay.
320 internal_equal can trigger a quit. That leads to Bad Things. */
325 (s1->methods == s2->methods &&
326 internal_equal (s1->global_specs, s2->global_specs, depth) &&
327 internal_equal (s1->device_specs, s2->device_specs, depth) &&
328 internal_equal (s1->frame_specs, s2->frame_specs, depth) &&
329 internal_equal (s1->window_specs, s2->window_specs, depth) &&
330 internal_equal (s1->buffer_specs, s2->buffer_specs, depth) &&
331 internal_equal (s1->fallback, s2->fallback, depth));
333 if (retval && HAS_SPECMETH_P (s1, equal))
334 retval = SPECMETH (s1, equal, (obj1, obj2, depth - 1));
336 Vinhibit_quit = old_inhibit_quit;
341 specifier_hash (Lisp_Object obj, int depth)
343 struct Lisp_Specifier *s = XSPECIFIER (obj);
345 /* specifier hashing is a bit problematic because there are so
346 many places where data can be stored. We pick what are perhaps
347 the most likely places where interesting stuff will be. */
348 return HASH5 ((HAS_SPECMETH_P (s, hash) ?
349 SPECMETH (s, hash, (obj, depth)) : 0),
350 (unsigned long) s->methods,
351 internal_hash (s->global_specs, depth + 1),
352 internal_hash (s->frame_specs, depth + 1),
353 internal_hash (s->buffer_specs, depth + 1));
357 sizeof_specifier (CONST void *header)
359 if (GHOST_SPECIFIER_P ((struct Lisp_Specifier *) header))
360 return offsetof (struct Lisp_Specifier, data);
363 CONST struct Lisp_Specifier *p = (CONST struct Lisp_Specifier *) header;
364 return offsetof (struct Lisp_Specifier, data) + p->methods->extra_data_size;
368 static const struct lrecord_description specifier_methods_description_1[] = {
369 { XD_LISP_OBJECT, offsetof(struct specifier_methods, predicate_symbol), 1 },
373 const struct struct_description specifier_methods_description = {
374 sizeof(struct specifier_methods),
375 specifier_methods_description_1
378 static const struct lrecord_description specifier_caching_description_1[] = {
382 static const struct struct_description specifier_caching_description = {
383 sizeof(struct specifier_caching),
384 specifier_caching_description_1
387 static const struct lrecord_description specifier_description[] = {
388 { XD_STRUCT_PTR, offsetof(struct Lisp_Specifier, methods), 1, &specifier_methods_description },
389 { XD_LO_LINK, offsetof(struct Lisp_Specifier, next_specifier) },
390 { XD_LISP_OBJECT, offsetof(struct Lisp_Specifier, global_specs), 5 },
391 { XD_STRUCT_PTR, offsetof(struct Lisp_Specifier, caching), 1, &specifier_caching_description },
392 { XD_LISP_OBJECT, offsetof(struct Lisp_Specifier, magic_parent), 2 },
396 const struct lrecord_description specifier_empty_extra_description[] = {
400 DEFINE_LRECORD_SEQUENCE_IMPLEMENTATION ("specifier", specifier,
401 mark_specifier, print_specifier,
403 specifier_equal, specifier_hash,
404 specifier_description,
406 struct Lisp_Specifier);
408 /************************************************************************/
409 /* Creating specifiers */
410 /************************************************************************/
412 static struct specifier_methods *
413 decode_specifier_type (Lisp_Object type, Error_behavior errb)
417 for (i = 0; i < Dynarr_length (the_specifier_type_entry_dynarr); i++)
419 if (EQ (type, Dynarr_at (the_specifier_type_entry_dynarr, i).symbol))
420 return Dynarr_at (the_specifier_type_entry_dynarr, i).meths;
423 maybe_signal_simple_error ("Invalid specifier type", type,
430 valid_specifier_type_p (Lisp_Object type)
432 return decode_specifier_type (type, ERROR_ME_NOT) != 0;
435 DEFUN ("valid-specifier-type-p", Fvalid_specifier_type_p, 1, 1, 0, /*
436 Given a SPECIFIER-TYPE, return non-nil if it is valid.
437 Valid types are 'generic, 'integer, boolean, 'color, 'font, 'image,
438 'face-boolean, and 'toolbar.
442 return valid_specifier_type_p (specifier_type) ? Qt : Qnil;
445 DEFUN ("specifier-type-list", Fspecifier_type_list, 0, 0, 0, /*
446 Return a list of valid specifier types.
450 return Fcopy_sequence (Vspecifier_type_list);
454 add_entry_to_specifier_type_list (Lisp_Object symbol,
455 struct specifier_methods *meths)
457 struct specifier_type_entry entry;
459 entry.symbol = symbol;
461 Dynarr_add (the_specifier_type_entry_dynarr, entry);
462 Vspecifier_type_list = Fcons (symbol, Vspecifier_type_list);
466 make_specifier_internal (struct specifier_methods *spec_meths,
467 size_t data_size, int call_create_meth)
469 Lisp_Object specifier;
470 struct Lisp_Specifier *sp = (struct Lisp_Specifier *)
471 alloc_lcrecord (offsetof (struct Lisp_Specifier, data) +
472 data_size, &lrecord_specifier);
474 sp->methods = spec_meths;
475 sp->global_specs = Qnil;
476 sp->device_specs = Qnil;
477 sp->frame_specs = Qnil;
478 sp->window_specs = make_weak_list (WEAK_LIST_KEY_ASSOC);
479 sp->buffer_specs = Qnil;
481 sp->magic_parent = Qnil;
483 sp->next_specifier = Vall_specifiers;
485 XSETSPECIFIER (specifier, sp);
486 Vall_specifiers = specifier;
488 if (call_create_meth)
492 MAYBE_SPECMETH (XSPECIFIER (specifier), create, (specifier));
499 make_specifier (struct specifier_methods *meths)
501 return make_specifier_internal (meths, meths->extra_data_size, 1);
505 make_magic_specifier (Lisp_Object type)
507 /* This function can GC */
508 struct specifier_methods *meths = decode_specifier_type (type, ERROR_ME);
509 Lisp_Object bodily, ghost;
512 bodily = make_specifier (meths);
514 ghost = make_specifier_internal (meths, 0, 0);
517 /* Connect guys together */
518 XSPECIFIER(bodily)->magic_parent = Qt;
519 XSPECIFIER(bodily)->fallback = ghost;
520 XSPECIFIER(ghost)->magic_parent = bodily;
525 DEFUN ("make-specifier", Fmake_specifier, 1, 1, 0, /*
526 Return a new specifier object of type TYPE.
528 A specifier is an object that can be used to keep track of a property
529 whose value can be per-buffer, per-window, per-frame, or per-device,
530 and can further be restricted to a particular console-type or device-class.
531 Specifiers are used, for example, for the various built-in properties of a
532 face; this allows a face to have different values in different frames,
533 buffers, etc. For more information, see `specifier-instance',
534 `specifier-specs', and `add-spec-to-specifier'; or, for a detailed
535 description of specifiers, including how they are instantiated over a
536 particular domain (i.e. how their value in that domain is determined),
537 see the chapter on specifiers in the XEmacs Lisp Reference Manual.
539 TYPE specifies the particular type of specifier, and should be one of
540 the symbols 'generic, 'integer, 'boolean, 'color, 'font, 'image,
541 'face-boolean, or 'toolbar.
543 For more information on particular types of specifiers, see the functions
544 `generic-specifier-p', `integer-specifier-p', `boolean-specifier-p',
545 `color-specifier-p', `font-specifier-p', `image-specifier-p',
546 `face-boolean-specifier-p', and `toolbar-specifier-p'.
550 /* This function can GC */
551 struct specifier_methods *meths = decode_specifier_type (type,
554 return make_specifier (meths);
557 DEFUN ("specifierp", Fspecifierp, 1, 1, 0, /*
558 Return t if OBJECT is a specifier.
560 A specifier is an object that can be used to keep track of a property
561 whose value can be per-buffer, per-window, per-frame, or per-device,
562 and can further be restricted to a particular console-type or device-class.
563 See `make-specifier'.
567 return SPECIFIERP (object) ? Qt : Qnil;
570 DEFUN ("specifier-type", Fspecifier_type, 1, 1, 0, /*
571 Return the type of SPECIFIER.
575 CHECK_SPECIFIER (specifier);
576 return intern (XSPECIFIER (specifier)->methods->name);
580 /************************************************************************/
581 /* Locales and domains */
582 /************************************************************************/
584 DEFUN ("valid-specifier-locale-p", Fvalid_specifier_locale_p, 1, 1, 0, /*
585 Return t if LOCALE is a valid specifier locale.
586 Valid locales are devices, frames, windows, buffers, and 'global.
591 /* This cannot GC. */
592 return ((DEVICEP (locale) && DEVICE_LIVE_P (XDEVICE (locale))) ||
593 (FRAMEP (locale) && FRAME_LIVE_P (XFRAME (locale))) ||
594 (BUFFERP (locale) && BUFFER_LIVE_P (XBUFFER (locale))) ||
595 /* dead windows are allowed because they may become live
596 windows again when a window configuration is restored */
598 EQ (locale, Qglobal))
602 DEFUN ("valid-specifier-domain-p", Fvalid_specifier_domain_p, 1, 1, 0, /*
603 Return t if DOMAIN is a valid specifier domain.
604 A domain is used to instance a specifier (i.e. determine the specifier's
605 value in that domain). Valid domains are windows, frames, and devices.
610 /* This cannot GC. */
611 return ((DEVICEP (domain) && DEVICE_LIVE_P (XDEVICE (domain))) ||
612 (FRAMEP (domain) && FRAME_LIVE_P (XFRAME (domain))) ||
613 (WINDOWP (domain) && WINDOW_LIVE_P (XWINDOW (domain))))
617 DEFUN ("valid-specifier-locale-type-p", Fvalid_specifier_locale_type_p, 1, 1, 0, /*
618 Given a specifier LOCALE-TYPE, return non-nil if it is valid.
619 Valid locale types are 'global, 'device, 'frame, 'window, and 'buffer.
620 \(Note, however, that in functions that accept either a locale or a locale
621 type, 'global is considered an individual locale.)
625 /* This cannot GC. */
626 return (EQ (locale_type, Qglobal) ||
627 EQ (locale_type, Qdevice) ||
628 EQ (locale_type, Qframe) ||
629 EQ (locale_type, Qwindow) ||
630 EQ (locale_type, Qbuffer)) ? Qt : Qnil;
634 check_valid_locale_or_locale_type (Lisp_Object locale)
636 /* This cannot GC. */
637 if (EQ (locale, Qall) ||
638 !NILP (Fvalid_specifier_locale_p (locale)) ||
639 !NILP (Fvalid_specifier_locale_type_p (locale)))
641 signal_simple_error ("Invalid specifier locale or locale type", locale);
644 DEFUN ("specifier-locale-type-from-locale", Fspecifier_locale_type_from_locale,
646 Given a specifier LOCALE, return its type.
650 /* This cannot GC. */
651 if (NILP (Fvalid_specifier_locale_p (locale)))
652 signal_simple_error ("Invalid specifier locale", locale);
653 if (DEVICEP (locale)) return Qdevice;
654 if (FRAMEP (locale)) return Qframe;
655 if (WINDOWP (locale)) return Qwindow;
656 if (BUFFERP (locale)) return Qbuffer;
657 assert (EQ (locale, Qglobal));
662 decode_locale (Lisp_Object locale)
664 /* This cannot GC. */
667 else if (!NILP (Fvalid_specifier_locale_p (locale)))
670 signal_simple_error ("Invalid specifier locale", locale);
675 static enum spec_locale_type
676 decode_locale_type (Lisp_Object locale_type)
678 /* This cannot GC. */
679 if (EQ (locale_type, Qglobal)) return LOCALE_GLOBAL;
680 if (EQ (locale_type, Qdevice)) return LOCALE_DEVICE;
681 if (EQ (locale_type, Qframe)) return LOCALE_FRAME;
682 if (EQ (locale_type, Qwindow)) return LOCALE_WINDOW;
683 if (EQ (locale_type, Qbuffer)) return LOCALE_BUFFER;
685 signal_simple_error ("Invalid specifier locale type", locale_type);
686 return LOCALE_GLOBAL; /* not reached */
690 decode_locale_list (Lisp_Object locale)
692 /* This cannot GC. */
693 /* The return value of this function must be GCPRO'd. */
698 else if (CONSP (locale))
701 EXTERNAL_LIST_LOOP_2 (elt, locale)
702 check_valid_locale_or_locale_type (elt);
707 check_valid_locale_or_locale_type (locale);
708 return list1 (locale);
712 static enum spec_locale_type
713 locale_type_from_locale (Lisp_Object locale)
715 return decode_locale_type (Fspecifier_locale_type_from_locale (locale));
719 check_valid_domain (Lisp_Object domain)
721 if (NILP (Fvalid_specifier_domain_p (domain)))
722 signal_simple_error ("Invalid specifier domain", domain);
726 decode_domain (Lisp_Object domain)
729 return Fselected_window (Qnil);
730 check_valid_domain (domain);
735 /************************************************************************/
737 /************************************************************************/
739 DEFUN ("valid-specifier-tag-p", Fvalid_specifier_tag_p, 1, 1, 0, /*
740 Return non-nil if TAG is a valid specifier tag.
741 See also `valid-specifier-tag-set-p'.
745 return (valid_console_type_p (tag) ||
746 valid_device_class_p (tag) ||
747 !NILP (assq_no_quit (tag, Vuser_defined_tags))) ? Qt : Qnil;
750 DEFUN ("valid-specifier-tag-set-p", Fvalid_specifier_tag_set_p, 1, 1, 0, /*
751 Return non-nil if TAG-SET is a valid specifier tag set.
753 A specifier tag set is an entity that is attached to an instantiator
754 and can be used to restrict the scope of that instantiator to a
755 particular device class or device type and/or to mark instantiators
756 added by a particular package so that they can be later removed.
758 A specifier tag set consists of a list of zero of more specifier tags,
759 each of which is a symbol that is recognized by XEmacs as a tag.
760 \(The valid device types and device classes are always tags, as are
761 any tags defined by `define-specifier-tag'.) It is called a "tag set"
762 \(as opposed to a list) because the order of the tags or the number of
763 times a particular tag occurs does not matter.
765 Each tag has a predicate associated with it, which specifies whether
766 that tag applies to a particular device. The tags which are device types
767 and classes match devices of that type or class. User-defined tags can
768 have any predicate, or none (meaning that all devices match). When
769 attempting to instance a specifier, a particular instantiator is only
770 considered if the device of the domain being instanced over matches
771 all tags in the tag set attached to that instantiator.
773 Most of the time, a tag set is not specified, and the instantiator
774 gets a null tag set, which matches all devices.
780 for (rest = tag_set; !NILP (rest); rest = XCDR (rest))
784 if (NILP (Fvalid_specifier_tag_p (XCAR (rest))))
792 decode_specifier_tag_set (Lisp_Object tag_set)
794 /* The return value of this function must be GCPRO'd. */
795 if (!NILP (Fvalid_specifier_tag_p (tag_set)))
796 return list1 (tag_set);
797 if (NILP (Fvalid_specifier_tag_set_p (tag_set)))
798 signal_simple_error ("Invalid specifier tag-set", tag_set);
803 canonicalize_tag_set (Lisp_Object tag_set)
805 int len = XINT (Flength (tag_set));
806 Lisp_Object *tags, rest;
809 /* We assume in this function that the tag_set has already been
810 validated, so there are no surprises. */
812 if (len == 0 || len == 1)
813 /* most common case */
816 tags = alloca_array (Lisp_Object, len);
819 LIST_LOOP (rest, tag_set)
820 tags[i++] = XCAR (rest);
822 /* Sort the list of tags. We use a bubble sort here (copied from
823 extent_fragment_update()) -- reduces the function call overhead,
824 and is the fastest sort for small numbers of items. */
826 for (i = 1; i < len; i++)
830 strcmp ((char *) string_data (XSYMBOL (tags[j])->name),
831 (char *) string_data (XSYMBOL (tags[j+1])->name)) > 0)
833 Lisp_Object tmp = tags[j];
840 /* Now eliminate duplicates. */
842 for (i = 1, j = 1; i < len; i++)
844 /* j holds the destination, i the source. */
845 if (!EQ (tags[i], tags[i-1]))
849 return Flist (j, tags);
852 DEFUN ("canonicalize-tag-set", Fcanonicalize_tag_set, 1, 1, 0, /*
853 Canonicalize the given tag set.
854 Two canonicalized tag sets can be compared with `equal' to see if they
855 represent the same tag set. (Specifically, canonicalizing involves
856 sorting by symbol name and removing duplicates.)
860 if (NILP (Fvalid_specifier_tag_set_p (tag_set)))
861 signal_simple_error ("Invalid tag set", tag_set);
862 return canonicalize_tag_set (tag_set);
866 device_matches_specifier_tag_set_p (Lisp_Object device, Lisp_Object tag_set)
868 Lisp_Object devtype, devclass, rest;
869 struct device *d = XDEVICE (device);
871 devtype = DEVICE_TYPE (d);
872 devclass = DEVICE_CLASS (d);
874 LIST_LOOP (rest, tag_set)
876 Lisp_Object tag = XCAR (rest);
879 if (EQ (tag, devtype) || EQ (tag, devclass))
881 assoc = assq_no_quit (tag, DEVICE_USER_DEFINED_TAGS (d));
882 /* other built-in tags (device types/classes) are not in
883 the user-defined-tags list. */
884 if (NILP (assoc) || NILP (XCDR (assoc)))
891 DEFUN ("device-matches-specifier-tag-set-p", Fdevice_matches_specifier_tag_set_p, 2, 2, 0, /*
892 Return non-nil if DEVICE matches specifier tag set TAG-SET.
893 This means that DEVICE matches each tag in the tag set. (Every
894 tag recognized by XEmacs has a predicate associated with it that
895 specifies which devices match it.)
899 CHECK_LIVE_DEVICE (device);
901 if (NILP (Fvalid_specifier_tag_set_p (tag_set)))
902 signal_simple_error ("Invalid tag set", tag_set);
904 return device_matches_specifier_tag_set_p (device, tag_set) ? Qt : Qnil;
907 DEFUN ("define-specifier-tag", Fdefine_specifier_tag, 1, 2, 0, /*
908 Define a new specifier tag.
909 If PREDICATE is specified, it should be a function of one argument
910 \(a device) that specifies whether the tag matches that particular
911 device. If PREDICATE is omitted, the tag matches all devices.
913 You can redefine an existing user-defined specifier tag. However,
914 you cannot redefine the built-in specifier tags (the device types
915 and classes) or the symbols nil, t, 'all, or 'global.
919 Lisp_Object assoc, devcons, concons;
923 if (valid_device_class_p (tag) ||
924 valid_console_type_p (tag))
925 signal_simple_error ("Cannot redefine built-in specifier tags", tag);
926 /* Try to prevent common instantiators and locales from being
927 redefined, to reduce ambiguity */
928 if (NILP (tag) || EQ (tag, Qt) || EQ (tag, Qall) || EQ (tag, Qglobal))
929 signal_simple_error ("Cannot define nil, t, 'all, or 'global",
931 assoc = assq_no_quit (tag, Vuser_defined_tags);
935 Vuser_defined_tags = Fcons (Fcons (tag, predicate), Vuser_defined_tags);
936 DEVICE_LOOP_NO_BREAK (devcons, concons)
938 struct device *d = XDEVICE (XCAR (devcons));
939 /* Initially set the value to t in case of error
941 DEVICE_USER_DEFINED_TAGS (d) =
942 Fcons (Fcons (tag, Qt), DEVICE_USER_DEFINED_TAGS (d));
945 else if (!NILP (predicate) && !NILP (XCDR (assoc)))
948 XCDR (assoc) = predicate;
951 /* recompute the tag values for all devices. However, in the special
952 case where both the old and new predicates are nil, we know that
953 we don't have to do this. (It's probably common for people to
954 call (define-specifier-tag) more than once on the same tag,
955 and the most common case is where PREDICATE is not specified.) */
959 DEVICE_LOOP_NO_BREAK (devcons, concons)
961 Lisp_Object device = XCAR (devcons);
962 assoc = assq_no_quit (tag,
963 DEVICE_USER_DEFINED_TAGS (XDEVICE (device)));
964 assert (CONSP (assoc));
965 if (NILP (predicate))
968 XCDR (assoc) = !NILP (call1 (predicate, device)) ? Qt : Qnil;
975 /* Called at device-creation time to initialize the user-defined
976 tag values for the newly-created device. */
979 setup_device_initial_specifier_tags (struct device *d)
981 Lisp_Object rest, rest2;
984 XSETDEVICE (device, d);
986 DEVICE_USER_DEFINED_TAGS (d) = Fcopy_alist (Vuser_defined_tags);
988 /* Now set up the initial values */
989 LIST_LOOP (rest, DEVICE_USER_DEFINED_TAGS (d))
990 XCDR (XCAR (rest)) = Qt;
992 for (rest = Vuser_defined_tags, rest2 = DEVICE_USER_DEFINED_TAGS (d);
993 !NILP (rest); rest = XCDR (rest), rest2 = XCDR (rest2))
995 Lisp_Object predicate = XCDR (XCAR (rest));
996 if (NILP (predicate))
997 XCDR (XCAR (rest2)) = Qt;
999 XCDR (XCAR (rest2)) = !NILP (call1 (predicate, device)) ? Qt : Qnil;
1003 DEFUN ("device-matching-specifier-tag-list", Fdevice_matching_specifier_tag_list,
1005 Return a list of all specifier tags matching DEVICE.
1006 DEVICE defaults to the selected device if omitted.
1010 struct device *d = decode_device (device);
1011 Lisp_Object rest, list = Qnil;
1012 struct gcpro gcpro1;
1016 LIST_LOOP (rest, DEVICE_USER_DEFINED_TAGS (d))
1018 if (!NILP (XCDR (XCAR (rest))))
1019 list = Fcons (XCAR (XCAR (rest)), list);
1022 list = Fnreverse (list);
1023 list = Fcons (DEVICE_CLASS (d), list);
1024 list = Fcons (DEVICE_TYPE (d), list);
1026 RETURN_UNGCPRO (list);
1029 DEFUN ("specifier-tag-list", Fspecifier_tag_list, 0, 0, 0, /*
1030 Return a list of all currently-defined specifier tags.
1031 This includes the built-in ones (the device types and classes).
1035 Lisp_Object list = Qnil, rest;
1036 struct gcpro gcpro1;
1040 LIST_LOOP (rest, Vuser_defined_tags)
1041 list = Fcons (XCAR (XCAR (rest)), list);
1043 list = Fnreverse (list);
1044 list = nconc2 (Fcopy_sequence (Vdevice_class_list), list);
1045 list = nconc2 (Fcopy_sequence (Vconsole_type_list), list);
1047 RETURN_UNGCPRO (list);
1050 DEFUN ("specifier-tag-predicate", Fspecifier_tag_predicate, 1, 1, 0, /*
1051 Return the predicate for the given specifier tag.
1055 /* The return value of this function must be GCPRO'd. */
1058 if (NILP (Fvalid_specifier_tag_p (tag)))
1059 signal_simple_error ("Invalid specifier tag", tag);
1061 /* Make up some predicates for the built-in types */
1063 if (valid_console_type_p (tag))
1064 return list3 (Qlambda, list1 (Qdevice),
1065 list3 (Qeq, list2 (Qquote, tag),
1066 list2 (Qconsole_type, Qdevice)));
1068 if (valid_device_class_p (tag))
1069 return list3 (Qlambda, list1 (Qdevice),
1070 list3 (Qeq, list2 (Qquote, tag),
1071 list2 (Qdevice_class, Qdevice)));
1073 return XCDR (assq_no_quit (tag, Vuser_defined_tags));
1076 /* Return true if A "matches" B. If EXACT_P is 0, A must be a subset of B.
1077 Otherwise, A must be `equal' to B. The sets must be canonicalized. */
1079 tag_sets_match_p (Lisp_Object a, Lisp_Object b, int exact_p)
1083 while (!NILP (a) && !NILP (b))
1085 if (EQ (XCAR (a), XCAR (b)))
1094 while (!NILP (a) && !NILP (b))
1096 if (!EQ (XCAR (a), XCAR (b)))
1102 return NILP (a) && NILP (b);
1107 /************************************************************************/
1108 /* Spec-lists and inst-lists */
1109 /************************************************************************/
1112 call_validate_method (Lisp_Object boxed_method, Lisp_Object instantiator)
1114 ((void (*)(Lisp_Object)) get_opaque_ptr (boxed_method)) (instantiator);
1119 check_valid_instantiator (Lisp_Object instantiator,
1120 struct specifier_methods *meths,
1121 Error_behavior errb)
1123 if (meths->validate_method)
1127 if (ERRB_EQ (errb, ERROR_ME))
1129 (meths->validate_method) (instantiator);
1134 Lisp_Object opaque = make_opaque_ptr ((void *)
1135 meths->validate_method);
1136 struct gcpro gcpro1;
1139 retval = call_with_suspended_errors
1140 ((lisp_fn_t) call_validate_method,
1141 Qnil, Qspecifier, errb, 2, opaque, instantiator);
1143 free_opaque_ptr (opaque);
1152 DEFUN ("check-valid-instantiator", Fcheck_valid_instantiator, 2, 2, 0, /*
1153 Signal an error if INSTANTIATOR is invalid for SPECIFIER-TYPE.
1155 (instantiator, specifier_type))
1157 struct specifier_methods *meths = decode_specifier_type (specifier_type,
1160 return check_valid_instantiator (instantiator, meths, ERROR_ME);
1163 DEFUN ("valid-instantiator-p", Fvalid_instantiator_p, 2, 2, 0, /*
1164 Return non-nil if INSTANTIATOR is valid for SPECIFIER-TYPE.
1166 (instantiator, specifier_type))
1168 struct specifier_methods *meths = decode_specifier_type (specifier_type,
1171 return check_valid_instantiator (instantiator, meths, ERROR_ME_NOT);
1175 check_valid_inst_list (Lisp_Object inst_list, struct specifier_methods *meths,
1176 Error_behavior errb)
1180 LIST_LOOP (rest, inst_list)
1182 Lisp_Object inst_pair, tag_set;
1186 maybe_signal_simple_error ("Invalid instantiator list", inst_list,
1190 if (!CONSP (inst_pair = XCAR (rest)))
1192 maybe_signal_simple_error ("Invalid instantiator pair", inst_pair,
1196 if (NILP (Fvalid_specifier_tag_set_p (tag_set = XCAR (inst_pair))))
1198 maybe_signal_simple_error ("Invalid specifier tag", tag_set,
1203 if (NILP (check_valid_instantiator (XCDR (inst_pair), meths, errb)))
1210 DEFUN ("check-valid-inst-list", Fcheck_valid_inst_list, 2, 2, 0, /*
1211 Signal an error if INST-LIST is invalid for specifier type TYPE.
1215 struct specifier_methods *meths = decode_specifier_type (type, ERROR_ME);
1217 return check_valid_inst_list (inst_list, meths, ERROR_ME);
1220 DEFUN ("valid-inst-list-p", Fvalid_inst_list_p, 2, 2, 0, /*
1221 Return non-nil if INST-LIST is valid for specifier type TYPE.
1225 struct specifier_methods *meths = decode_specifier_type (type, ERROR_ME);
1227 return check_valid_inst_list (inst_list, meths, ERROR_ME_NOT);
1231 check_valid_spec_list (Lisp_Object spec_list, struct specifier_methods *meths,
1232 Error_behavior errb)
1236 LIST_LOOP (rest, spec_list)
1238 Lisp_Object spec, locale;
1239 if (!CONSP (rest) || !CONSP (spec = XCAR (rest)))
1241 maybe_signal_simple_error ("Invalid specification list", spec_list,
1245 if (NILP (Fvalid_specifier_locale_p (locale = XCAR (spec))))
1247 maybe_signal_simple_error ("Invalid specifier locale", locale,
1252 if (NILP (check_valid_inst_list (XCDR (spec), meths, errb)))
1259 DEFUN ("check-valid-spec-list", Fcheck_valid_spec_list, 2, 2, 0, /*
1260 Signal an error if SPEC-LIST is invalid for specifier type TYPE.
1264 struct specifier_methods *meths = decode_specifier_type (type, ERROR_ME);
1266 return check_valid_spec_list (spec_list, meths, ERROR_ME);
1269 DEFUN ("valid-spec-list-p", Fvalid_spec_list_p, 2, 2, 0, /*
1270 Return non-nil if SPEC-LIST is valid for specifier type TYPE.
1274 struct specifier_methods *meths = decode_specifier_type (type, ERROR_ME);
1276 return check_valid_spec_list (spec_list, meths, ERROR_ME_NOT);
1280 decode_how_to_add_specification (Lisp_Object how_to_add)
1282 if (NILP (how_to_add) || EQ (Qremove_tag_set_prepend, how_to_add))
1283 return SPEC_REMOVE_TAG_SET_PREPEND;
1284 if (EQ (Qremove_tag_set_append, how_to_add))
1285 return SPEC_REMOVE_TAG_SET_APPEND;
1286 if (EQ (Qappend, how_to_add))
1288 if (EQ (Qprepend, how_to_add))
1289 return SPEC_PREPEND;
1290 if (EQ (Qremove_locale, how_to_add))
1291 return SPEC_REMOVE_LOCALE;
1292 if (EQ (Qremove_locale_type, how_to_add))
1293 return SPEC_REMOVE_LOCALE_TYPE;
1294 if (EQ (Qremove_all, how_to_add))
1295 return SPEC_REMOVE_ALL;
1297 signal_simple_error ("Invalid `how-to-add' flag", how_to_add);
1299 return SPEC_PREPEND; /* not reached */
1302 /* Given a specifier object SPEC, return bodily specifier if SPEC is a
1303 ghost specifier, otherwise return the object itself
1306 bodily_specifier (Lisp_Object spec)
1308 return (GHOST_SPECIFIER_P (XSPECIFIER (spec))
1309 ? XSPECIFIER(spec)->magic_parent : spec);
1312 /* Signal error if (specifier SPEC is read-only.
1313 Read only are ghost specifiers unless Vunlock_ghost_specifiers is
1314 non-nil. All other specifiers are read-write.
1317 check_modifiable_specifier (Lisp_Object spec)
1319 if (NILP (Vunlock_ghost_specifiers)
1320 && GHOST_SPECIFIER_P (XSPECIFIER (spec)))
1321 signal_simple_error ("Attempt to modify read-only specifier",
1325 /* Helper function which unwind protects the value of
1326 Vunlock_ghost_specifiers, then sets it to non-nil value */
1328 restore_unlock_value (Lisp_Object val)
1330 Vunlock_ghost_specifiers = val;
1335 unlock_ghost_specifiers_protected (void)
1337 int depth = specpdl_depth ();
1338 record_unwind_protect (restore_unlock_value,
1339 Vunlock_ghost_specifiers);
1340 Vunlock_ghost_specifiers = Qt;
1344 /* This gets hit so much that the function call overhead had a
1345 measurable impact (according to Quantify). #### We should figure
1346 out the frequency with which this is called with the various types
1347 and reorder the check accordingly. */
1348 #define SPECIFIER_GET_SPEC_LIST(specifier, type) \
1349 (type == LOCALE_GLOBAL ? &(XSPECIFIER (specifier)->global_specs) : \
1350 type == LOCALE_DEVICE ? &(XSPECIFIER (specifier)->device_specs) : \
1351 type == LOCALE_FRAME ? &(XSPECIFIER (specifier)->frame_specs) : \
1352 type == LOCALE_WINDOW ? &(XWEAK_LIST_LIST \
1353 (XSPECIFIER (specifier)->window_specs)) : \
1354 type == LOCALE_BUFFER ? &(XSPECIFIER (specifier)->buffer_specs) : \
1357 static Lisp_Object *
1358 specifier_get_inst_list (Lisp_Object specifier, Lisp_Object locale,
1359 enum spec_locale_type type)
1361 Lisp_Object *spec_list = SPECIFIER_GET_SPEC_LIST (specifier, type);
1362 Lisp_Object specification;
1364 if (type == LOCALE_GLOBAL)
1366 /* Calling assq_no_quit when it is just going to return nil anyhow
1367 is extremely expensive. So sayeth Quantify. */
1368 if (!CONSP (*spec_list))
1370 specification = assq_no_quit (locale, *spec_list);
1371 if (NILP (specification))
1373 return &XCDR (specification);
1376 /* For the given INST_LIST, return a new INST_LIST containing all elements
1377 where TAG-SET matches the element's tag set. EXACT_P indicates whether
1378 the match must be exact (as opposed to a subset). SHORT_P indicates
1379 that the short form (for `specifier-specs') should be returned if
1380 possible. If COPY_TREE_P, `copy-tree' is used to ensure that no
1381 elements of the new list are shared with the initial list.
1385 specifier_process_inst_list (Lisp_Object inst_list,
1386 Lisp_Object tag_set, int exact_p,
1387 int short_p, int copy_tree_p)
1389 Lisp_Object retval = Qnil;
1391 struct gcpro gcpro1;
1394 LIST_LOOP (rest, inst_list)
1396 Lisp_Object tagged_inst = XCAR (rest);
1397 Lisp_Object tagged_inst_tag = XCAR (tagged_inst);
1398 if (tag_sets_match_p (tag_set, tagged_inst_tag, exact_p))
1400 if (short_p && NILP (tagged_inst_tag))
1401 retval = Fcons (copy_tree_p ?
1402 Fcopy_tree (XCDR (tagged_inst), Qt) :
1406 retval = Fcons (copy_tree_p ? Fcopy_tree (tagged_inst, Qt) :
1407 tagged_inst, retval);
1410 retval = Fnreverse (retval);
1412 /* If there is a single instantiator and the short form is
1413 requested, return just the instantiator (rather than a one-element
1414 list of it) unless it is nil (so that it can be distinguished from
1415 no instantiators at all). */
1416 if (short_p && CONSP (retval) && !NILP (XCAR (retval)) &&
1417 NILP (XCDR (retval)))
1418 return XCAR (retval);
1424 specifier_get_external_inst_list (Lisp_Object specifier, Lisp_Object locale,
1425 enum spec_locale_type type,
1426 Lisp_Object tag_set, int exact_p,
1427 int short_p, int copy_tree_p)
1429 Lisp_Object *inst_list = specifier_get_inst_list (specifier, locale,
1431 if (!inst_list || NILP (*inst_list))
1433 /* nil for *inst_list should only occur in 'global */
1434 assert (!inst_list || EQ (locale, Qglobal));
1438 return specifier_process_inst_list (*inst_list, tag_set, exact_p,
1439 short_p, copy_tree_p);
1443 specifier_get_external_spec_list (Lisp_Object specifier,
1444 enum spec_locale_type type,
1445 Lisp_Object tag_set, int exact_p)
1447 Lisp_Object *spec_list = SPECIFIER_GET_SPEC_LIST (specifier, type);
1448 Lisp_Object retval = Qnil;
1450 struct gcpro gcpro1;
1452 assert (type != LOCALE_GLOBAL);
1453 /* We're about to let stuff go external; make sure there aren't
1455 *spec_list = cleanup_assoc_list (*spec_list);
1458 LIST_LOOP (rest, *spec_list)
1460 Lisp_Object spec = XCAR (rest);
1461 Lisp_Object inst_list =
1462 specifier_process_inst_list (XCDR (spec), tag_set, exact_p, 0, 1);
1463 if (!NILP (inst_list))
1464 retval = Fcons (Fcons (XCAR (spec), inst_list), retval);
1466 RETURN_UNGCPRO (Fnreverse (retval));
1469 static Lisp_Object *
1470 specifier_new_spec (Lisp_Object specifier, Lisp_Object locale,
1471 enum spec_locale_type type)
1473 Lisp_Object *spec_list = SPECIFIER_GET_SPEC_LIST (specifier, type);
1474 Lisp_Object new_spec = Fcons (locale, Qnil);
1475 assert (type != LOCALE_GLOBAL);
1476 *spec_list = Fcons (new_spec, *spec_list);
1477 return &XCDR (new_spec);
1480 /* For the given INST_LIST, return a new list comprised of elements
1481 where TAG_SET does not match the element's tag set. This operation
1485 specifier_process_remove_inst_list (Lisp_Object inst_list,
1486 Lisp_Object tag_set, int exact_p,
1489 Lisp_Object prev = Qnil, rest;
1493 LIST_LOOP (rest, inst_list)
1495 if (tag_sets_match_p (tag_set, XCAR (XCAR (rest)), exact_p))
1497 /* time to remove. */
1500 inst_list = XCDR (rest);
1502 XCDR (prev) = XCDR (rest);
1512 specifier_remove_spec (Lisp_Object specifier, Lisp_Object locale,
1513 enum spec_locale_type type,
1514 Lisp_Object tag_set, int exact_p)
1516 Lisp_Object *spec_list = SPECIFIER_GET_SPEC_LIST (specifier, type);
1520 if (type == LOCALE_GLOBAL)
1521 *spec_list = specifier_process_remove_inst_list (*spec_list, tag_set,
1522 exact_p, &was_removed);
1525 assoc = assq_no_quit (locale, *spec_list);
1527 /* this locale is not found. */
1529 XCDR (assoc) = specifier_process_remove_inst_list (XCDR (assoc),
1532 if (NILP (XCDR (assoc)))
1533 /* no inst-pairs left; remove this locale entirely. */
1534 *spec_list = remassq_no_quit (locale, *spec_list);
1538 MAYBE_SPECMETH (XSPECIFIER (specifier), after_change,
1539 (bodily_specifier (specifier), locale));
1543 specifier_remove_locale_type (Lisp_Object specifier,
1544 enum spec_locale_type type,
1545 Lisp_Object tag_set, int exact_p)
1547 Lisp_Object *spec_list = SPECIFIER_GET_SPEC_LIST (specifier, type);
1548 Lisp_Object prev = Qnil, rest;
1550 assert (type != LOCALE_GLOBAL);
1551 LIST_LOOP (rest, *spec_list)
1554 int remove_spec = 0;
1555 Lisp_Object spec = XCAR (rest);
1557 /* There may be dead objects floating around */
1558 /* remember, dead windows can become alive again. */
1559 if (!WINDOWP (XCAR (spec)) && object_dead_p (XCAR (spec)))
1566 XCDR (spec) = specifier_process_remove_inst_list (XCDR (spec),
1569 if (NILP (XCDR (spec)))
1576 *spec_list = XCDR (rest);
1578 XCDR (prev) = XCDR (rest);
1584 MAYBE_SPECMETH (XSPECIFIER (specifier), after_change,
1585 (bodily_specifier (specifier), XCAR (spec)));
1589 /* NEW_LIST is going to be added to INST_LIST, with add method ADD_METH.
1590 Frob INST_LIST according to ADD_METH. No need to call an after-change
1591 function; the calling function will do this. Return either SPEC_PREPEND
1592 or SPEC_APPEND, indicating whether to prepend or append the NEW_LIST. */
1594 static enum spec_add_meth
1595 handle_multiple_add_insts (Lisp_Object *inst_list,
1596 Lisp_Object new_list,
1597 enum spec_add_meth add_meth)
1601 case SPEC_REMOVE_TAG_SET_APPEND:
1602 add_meth = SPEC_APPEND;
1603 goto remove_tag_set;
1604 case SPEC_REMOVE_TAG_SET_PREPEND:
1605 add_meth = SPEC_PREPEND;
1610 LIST_LOOP (rest, new_list)
1612 Lisp_Object canontag = canonicalize_tag_set (XCAR (XCAR (rest)));
1613 struct gcpro gcpro1;
1616 /* pull out all elements from the existing list with the
1617 same tag as any tags in NEW_LIST. */
1618 *inst_list = remassoc_no_quit (canontag, *inst_list);
1623 case SPEC_REMOVE_LOCALE:
1625 return SPEC_PREPEND;
1629 return SPEC_PREPEND;
1633 /* Given a LOCALE and INST_LIST that is going to be added to SPECIFIER,
1634 copy, canonicalize, and call the going_to_add methods as necessary
1635 to produce a new list that is the one that really will be added
1636 to the specifier. */
1639 build_up_processed_list (Lisp_Object specifier, Lisp_Object locale,
1640 Lisp_Object inst_list)
1642 /* The return value of this function must be GCPRO'd. */
1643 Lisp_Object rest, list_to_build_up = Qnil;
1644 struct Lisp_Specifier *sp = XSPECIFIER (specifier);
1645 struct gcpro gcpro1;
1647 GCPRO1 (list_to_build_up);
1648 LIST_LOOP (rest, inst_list)
1650 Lisp_Object tag_set = XCAR (XCAR (rest));
1651 Lisp_Object instantiator = Fcopy_tree (XCDR (XCAR (rest)), Qt);
1652 Lisp_Object sub_inst_list = Qnil;
1653 struct gcpro ngcpro1, ngcpro2;
1655 NGCPRO2 (instantiator, sub_inst_list);
1656 /* call the will-add method; it may GC */
1657 sub_inst_list = HAS_SPECMETH_P (sp, going_to_add) ?
1658 SPECMETH (sp, going_to_add,
1659 (bodily_specifier (specifier), locale,
1660 tag_set, instantiator)) :
1662 if (EQ (sub_inst_list, Qt))
1663 /* no change here. */
1664 sub_inst_list = list1 (Fcons (canonicalize_tag_set (tag_set),
1668 /* now canonicalize all the tag sets in the new objects */
1670 LIST_LOOP (rest2, sub_inst_list)
1671 XCAR (XCAR (rest2)) = canonicalize_tag_set (XCAR (XCAR (rest2)));
1674 list_to_build_up = nconc2 (sub_inst_list, list_to_build_up);
1678 RETURN_UNGCPRO (Fnreverse (list_to_build_up));
1681 /* Add a specification (locale and instantiator list) to a specifier.
1682 ADD_METH specifies what to do with existing specifications in the
1683 specifier, and is an enum that corresponds to the values in
1684 `add-spec-to-specifier'. The calling routine is responsible for
1685 validating LOCALE and INST-LIST, but the tag-sets in INST-LIST
1686 do not need to be canonicalized. */
1688 /* #### I really need to rethink the after-change
1689 functions to make them easier to use and more efficient. */
1692 specifier_add_spec (Lisp_Object specifier, Lisp_Object locale,
1693 Lisp_Object inst_list, enum spec_add_meth add_meth)
1695 struct Lisp_Specifier *sp = XSPECIFIER (specifier);
1696 enum spec_locale_type type = locale_type_from_locale (locale);
1697 Lisp_Object *orig_inst_list, tem;
1698 Lisp_Object list_to_build_up = Qnil;
1699 struct gcpro gcpro1;
1701 GCPRO1 (list_to_build_up);
1702 list_to_build_up = build_up_processed_list (specifier, locale, inst_list);
1703 /* Now handle REMOVE_LOCALE_TYPE and REMOVE_ALL. These are the
1704 add-meth types that affect locales other than this one. */
1705 if (add_meth == SPEC_REMOVE_LOCALE_TYPE)
1706 specifier_remove_locale_type (specifier, type, Qnil, 0);
1707 else if (add_meth == SPEC_REMOVE_ALL)
1709 specifier_remove_locale_type (specifier, LOCALE_BUFFER, Qnil, 0);
1710 specifier_remove_locale_type (specifier, LOCALE_WINDOW, Qnil, 0);
1711 specifier_remove_locale_type (specifier, LOCALE_FRAME, Qnil, 0);
1712 specifier_remove_locale_type (specifier, LOCALE_DEVICE, Qnil, 0);
1713 specifier_remove_spec (specifier, Qglobal, LOCALE_GLOBAL, Qnil, 0);
1716 orig_inst_list = specifier_get_inst_list (specifier, locale, type);
1717 if (!orig_inst_list)
1718 orig_inst_list = specifier_new_spec (specifier, locale, type);
1719 add_meth = handle_multiple_add_insts (orig_inst_list, list_to_build_up,
1722 if (add_meth == SPEC_PREPEND)
1723 tem = nconc2 (list_to_build_up, *orig_inst_list);
1724 else if (add_meth == SPEC_APPEND)
1725 tem = nconc2 (*orig_inst_list, list_to_build_up);
1729 *orig_inst_list = tem;
1733 /* call the after-change method */
1734 MAYBE_SPECMETH (sp, after_change,
1735 (bodily_specifier (specifier), locale));
1739 specifier_copy_spec (Lisp_Object specifier, Lisp_Object dest,
1740 Lisp_Object locale, enum spec_locale_type type,
1741 Lisp_Object tag_set, int exact_p,
1742 enum spec_add_meth add_meth)
1744 Lisp_Object inst_list =
1745 specifier_get_external_inst_list (specifier, locale, type, tag_set,
1747 specifier_add_spec (dest, locale, inst_list, add_meth);
1751 specifier_copy_locale_type (Lisp_Object specifier, Lisp_Object dest,
1752 enum spec_locale_type type,
1753 Lisp_Object tag_set, int exact_p,
1754 enum spec_add_meth add_meth)
1756 Lisp_Object *src_list = SPECIFIER_GET_SPEC_LIST (specifier, type);
1759 /* This algorithm is O(n^2) in running time.
1760 It's certainly possible to implement an O(n log n) algorithm,
1761 but I doubt there's any need to. */
1763 LIST_LOOP (rest, *src_list)
1765 Lisp_Object spec = XCAR (rest);
1766 /* There may be dead objects floating around */
1767 /* remember, dead windows can become alive again. */
1768 if (WINDOWP (XCAR (spec)) || !object_dead_p (XCAR (spec)))
1771 specifier_process_inst_list (XCDR (spec), tag_set, exact_p, 0, 0),
1776 /* map MAPFUN over the locales in SPECIFIER that are given in LOCALE.
1777 CLOSURE is passed unchanged to MAPFUN. LOCALE can be one of
1779 -- nil (same as 'all)
1780 -- a single locale, locale type, or 'all
1781 -- a list of locales, locale types, and/or 'all
1783 MAPFUN is called for each locale and locale type given; for 'all,
1784 it is called for the locale 'global and for the four possible
1785 locale types. In each invocation, either LOCALE will be a locale
1786 and LOCALE_TYPE will be the locale type of this locale,
1787 or LOCALE will be nil and LOCALE_TYPE will be a locale type.
1788 If MAPFUN ever returns non-zero, the mapping is halted and the
1789 value returned is returned from map_specifier(). Otherwise, the
1790 mapping proceeds to the end and map_specifier() returns 0.
1794 map_specifier (Lisp_Object specifier, Lisp_Object locale,
1795 int (*mapfun) (Lisp_Object specifier,
1797 enum spec_locale_type locale_type,
1798 Lisp_Object tag_set,
1801 Lisp_Object tag_set, Lisp_Object exact_p,
1806 struct gcpro gcpro1, gcpro2;
1808 GCPRO2 (tag_set, locale);
1809 locale = decode_locale_list (locale);
1810 tag_set = decode_specifier_tag_set (tag_set);
1811 tag_set = canonicalize_tag_set (tag_set);
1813 LIST_LOOP (rest, locale)
1815 Lisp_Object theloc = XCAR (rest);
1816 if (!NILP (Fvalid_specifier_locale_p (theloc)))
1818 retval = (*mapfun) (specifier, theloc,
1819 locale_type_from_locale (theloc),
1820 tag_set, !NILP (exact_p), closure);
1824 else if (!NILP (Fvalid_specifier_locale_type_p (theloc)))
1826 retval = (*mapfun) (specifier, Qnil,
1827 decode_locale_type (theloc), tag_set,
1828 !NILP (exact_p), closure);
1834 assert (EQ (theloc, Qall));
1835 retval = (*mapfun) (specifier, Qnil, LOCALE_BUFFER, tag_set,
1836 !NILP (exact_p), closure);
1839 retval = (*mapfun) (specifier, Qnil, LOCALE_WINDOW, tag_set,
1840 !NILP (exact_p), closure);
1843 retval = (*mapfun) (specifier, Qnil, LOCALE_FRAME, tag_set,
1844 !NILP (exact_p), closure);
1847 retval = (*mapfun) (specifier, Qnil, LOCALE_DEVICE, tag_set,
1848 !NILP (exact_p), closure);
1851 retval = (*mapfun) (specifier, Qglobal, LOCALE_GLOBAL, tag_set,
1852 !NILP (exact_p), closure);
1862 DEFUN ("add-spec-to-specifier", Fadd_spec_to_specifier, 2, 5, 0, /*
1863 Add a specification to SPECIFIER.
1864 The specification maps from LOCALE (which should be a window, buffer,
1865 frame, device, or 'global, and defaults to 'global) to INSTANTIATOR,
1866 whose allowed values depend on the type of the specifier. Optional
1867 argument TAG-SET limits the instantiator to apply only to the specified
1868 tag set, which should be a list of tags all of which must match the
1869 device being instantiated over (tags are a device type, a device class,
1870 or tags defined with `define-specifier-tag'). Specifying a single
1871 symbol for TAG-SET is equivalent to specifying a one-element list
1872 containing that symbol. Optional argument HOW-TO-ADD specifies what to
1873 do if there are already specifications in the specifier.
1876 'prepend Put at the beginning of the current list of
1877 instantiators for LOCALE.
1878 'append Add to the end of the current list of
1879 instantiators for LOCALE.
1880 'remove-tag-set-prepend (this is the default)
1881 Remove any existing instantiators whose tag set is
1882 the same as TAG-SET; then put the new instantiator
1883 at the beginning of the current list. ("Same tag
1884 set" means that they contain the same elements.
1885 The order may be different.)
1886 'remove-tag-set-append
1887 Remove any existing instantiators whose tag set is
1888 the same as TAG-SET; then put the new instantiator
1889 at the end of the current list.
1890 'remove-locale Remove all previous instantiators for this locale
1891 before adding the new spec.
1892 'remove-locale-type Remove all specifications for all locales of the
1893 same type as LOCALE (this includes LOCALE itself)
1894 before adding the new spec.
1895 'remove-all Remove all specifications from the specifier
1896 before adding the new spec.
1898 You can retrieve the specifications for a particular locale or locale type
1899 with the function `specifier-spec-list' or `specifier-specs'.
1901 (specifier, instantiator, locale, tag_set, how_to_add))
1903 enum spec_add_meth add_meth;
1904 Lisp_Object inst_list;
1905 struct gcpro gcpro1;
1907 CHECK_SPECIFIER (specifier);
1908 check_modifiable_specifier (specifier);
1910 locale = decode_locale (locale);
1911 check_valid_instantiator (instantiator,
1912 decode_specifier_type
1913 (Fspecifier_type (specifier), ERROR_ME),
1915 /* tag_set might be newly-created material, but it's part of inst_list
1916 so is properly GC-protected. */
1917 tag_set = decode_specifier_tag_set (tag_set);
1918 add_meth = decode_how_to_add_specification (how_to_add);
1920 inst_list = list1 (Fcons (tag_set, instantiator));
1922 specifier_add_spec (specifier, locale, inst_list, add_meth);
1923 recompute_cached_specifier_everywhere (specifier);
1924 RETURN_UNGCPRO (Qnil);
1927 DEFUN ("add-spec-list-to-specifier", Fadd_spec_list_to_specifier, 2, 3, 0, /*
1928 Add a spec-list (a list of specifications) to SPECIFIER.
1929 The format of a spec-list is
1931 ((LOCALE (TAG-SET . INSTANTIATOR) ...) ...)
1934 LOCALE := a window, a buffer, a frame, a device, or 'global
1935 TAG-SET := an unordered list of zero or more TAGS, each of which
1937 TAG := a device class (see `valid-device-class-p'), a device type
1938 (see `valid-console-type-p'), or a tag defined with
1939 `define-specifier-tag'
1940 INSTANTIATOR := format determined by the type of specifier
1942 The pair (TAG-SET . INSTANTIATOR) is called an `inst-pair'.
1943 A list of inst-pairs is called an `inst-list'.
1944 The pair (LOCALE . INST-LIST) is called a `specification' or `spec'.
1945 A spec-list, then, can be viewed as a list of specifications.
1947 HOW-TO-ADD specifies how to combine the new specifications with
1948 the existing ones, and has the same semantics as for
1949 `add-spec-to-specifier'.
1951 In many circumstances, the higher-level function `set-specifier' is
1952 more convenient and should be used instead.
1954 (specifier, spec_list, how_to_add))
1956 enum spec_add_meth add_meth;
1959 CHECK_SPECIFIER (specifier);
1960 check_modifiable_specifier (specifier);
1962 check_valid_spec_list (spec_list,
1963 decode_specifier_type
1964 (Fspecifier_type (specifier), ERROR_ME),
1966 add_meth = decode_how_to_add_specification (how_to_add);
1968 LIST_LOOP (rest, spec_list)
1970 /* Placating the GCC god. */
1971 Lisp_Object specification = XCAR (rest);
1972 Lisp_Object locale = XCAR (specification);
1973 Lisp_Object inst_list = XCDR (specification);
1975 specifier_add_spec (specifier, locale, inst_list, add_meth);
1977 recompute_cached_specifier_everywhere (specifier);
1982 add_spec_to_ghost_specifier (Lisp_Object specifier, Lisp_Object instantiator,
1983 Lisp_Object locale, Lisp_Object tag_set,
1984 Lisp_Object how_to_add)
1986 int depth = unlock_ghost_specifiers_protected ();
1987 Fadd_spec_to_specifier (XSPECIFIER(specifier)->fallback,
1988 instantiator, locale, tag_set, how_to_add);
1989 unbind_to (depth, Qnil);
1992 struct specifier_spec_list_closure
1994 Lisp_Object head, tail;
1998 specifier_spec_list_mapfun (Lisp_Object specifier,
2000 enum spec_locale_type locale_type,
2001 Lisp_Object tag_set,
2005 struct specifier_spec_list_closure *cl =
2006 (struct specifier_spec_list_closure *) closure;
2007 Lisp_Object partial;
2010 partial = specifier_get_external_spec_list (specifier,
2015 partial = specifier_get_external_inst_list (specifier, locale,
2016 locale_type, tag_set,
2018 if (!NILP (partial))
2019 partial = list1 (Fcons (locale, partial));
2024 /* tack on the new list */
2025 if (NILP (cl->tail))
2026 cl->head = cl->tail = partial;
2028 XCDR (cl->tail) = partial;
2029 /* find the new tail */
2030 while (CONSP (XCDR (cl->tail)))
2031 cl->tail = XCDR (cl->tail);
2035 /* For the given SPECIFIER create and return a list of all specs
2036 contained within it, subject to LOCALE. If LOCALE is a locale, only
2037 specs in that locale will be returned. If LOCALE is a locale type,
2038 all specs in all locales of that type will be returned. If LOCALE is
2039 nil, all specs will be returned. This always copies lists and never
2040 returns the actual lists, because we do not want someone manipulating
2041 the actual objects. This may cause a slight loss of potential
2042 functionality but if we were to allow it then a user could manage to
2043 violate our assertion that the specs contained in the actual
2044 specifier lists are all valid. */
2046 DEFUN ("specifier-spec-list", Fspecifier_spec_list, 1, 4, 0, /*
2047 Return the spec-list of specifications for SPECIFIER in LOCALE.
2049 If LOCALE is a particular locale (a buffer, window, frame, device,
2050 or 'global), a spec-list consisting of the specification for that
2051 locale will be returned.
2053 If LOCALE is a locale type (i.e. 'buffer, 'window, 'frame, or 'device),
2054 a spec-list of the specifications for all locales of that type will be
2057 If LOCALE is nil or 'all, a spec-list of all specifications in SPECIFIER
2060 LOCALE can also be a list of locales, locale types, and/or 'all; the
2061 result is as if `specifier-spec-list' were called on each element of the
2062 list and the results concatenated together.
2064 Only instantiators where TAG-SET (a list of zero or more tags) is a
2065 subset of (or possibly equal to) the instantiator's tag set are returned.
2066 \(The default value of nil is a subset of all tag sets, so in this case
2067 no instantiators will be screened out.) If EXACT-P is non-nil, however,
2068 TAG-SET must be equal to an instantiator's tag set for the instantiator
2071 (specifier, locale, tag_set, exact_p))
2073 struct specifier_spec_list_closure cl;
2074 struct gcpro gcpro1, gcpro2;
2076 CHECK_SPECIFIER (specifier);
2077 cl.head = cl.tail = Qnil;
2078 GCPRO2 (cl.head, cl.tail);
2079 map_specifier (specifier, locale, specifier_spec_list_mapfun,
2080 tag_set, exact_p, &cl);
2086 DEFUN ("specifier-specs", Fspecifier_specs, 1, 4, 0, /*
2087 Return the specification(s) for SPECIFIER in LOCALE.
2089 If LOCALE is a single locale or is a list of one element containing a
2090 single locale, then a "short form" of the instantiators for that locale
2091 will be returned. Otherwise, this function is identical to
2092 `specifier-spec-list'.
2094 The "short form" is designed for readability and not for ease of use
2095 in Lisp programs, and is as follows:
2097 1. If there is only one instantiator, then an inst-pair (i.e. cons of
2098 tag and instantiator) will be returned; otherwise a list of
2099 inst-pairs will be returned.
2100 2. For each inst-pair returned, if the instantiator's tag is 'any,
2101 the tag will be removed and the instantiator itself will be returned
2102 instead of the inst-pair.
2103 3. If there is only one instantiator, its value is nil, and its tag is
2104 'any, a one-element list containing nil will be returned rather
2105 than just nil, to distinguish this case from there being no
2106 instantiators at all.
2108 (specifier, locale, tag_set, exact_p))
2110 if (!NILP (Fvalid_specifier_locale_p (locale)) ||
2111 (CONSP (locale) && !NILP (Fvalid_specifier_locale_p (XCAR (locale))) &&
2112 NILP (XCDR (locale))))
2114 struct gcpro gcpro1;
2116 CHECK_SPECIFIER (specifier);
2118 locale = XCAR (locale);
2120 tag_set = decode_specifier_tag_set (tag_set);
2121 tag_set = canonicalize_tag_set (tag_set);
2123 (specifier_get_external_inst_list (specifier, locale,
2124 locale_type_from_locale (locale),
2125 tag_set, !NILP (exact_p), 1, 1));
2128 return Fspecifier_spec_list (specifier, locale, tag_set, exact_p);
2132 remove_specifier_mapfun (Lisp_Object specifier,
2134 enum spec_locale_type locale_type,
2135 Lisp_Object tag_set,
2137 void *ignored_closure)
2140 specifier_remove_locale_type (specifier, locale_type, tag_set, exact_p);
2142 specifier_remove_spec (specifier, locale, locale_type, tag_set, exact_p);
2146 DEFUN ("remove-specifier", Fremove_specifier, 1, 4, 0, /*
2147 Remove specification(s) for SPECIFIER.
2149 If LOCALE is a particular locale (a window, buffer, frame, device,
2150 or 'global), the specification for that locale will be removed.
2152 If instead, LOCALE is a locale type (i.e. 'window, 'buffer, 'frame,
2153 or 'device), the specifications for all locales of that type will be
2156 If LOCALE is nil or 'all, all specifications will be removed.
2158 LOCALE can also be a list of locales, locale types, and/or 'all; this
2159 is equivalent to calling `remove-specifier' for each of the elements
2162 Only instantiators where TAG-SET (a list of zero or more tags) is a
2163 subset of (or possibly equal to) the instantiator's tag set are removed.
2164 The default value of nil is a subset of all tag sets, so in this case
2165 no instantiators will be screened out. If EXACT-P is non-nil, however,
2166 TAG-SET must be equal to an instantiator's tag set for the instantiator
2169 (specifier, locale, tag_set, exact_p))
2171 CHECK_SPECIFIER (specifier);
2172 check_modifiable_specifier (specifier);
2174 map_specifier (specifier, locale, remove_specifier_mapfun,
2175 tag_set, exact_p, 0);
2176 recompute_cached_specifier_everywhere (specifier);
2181 remove_ghost_specifier (Lisp_Object specifier, Lisp_Object locale,
2182 Lisp_Object tag_set, Lisp_Object exact_p)
2184 int depth = unlock_ghost_specifiers_protected ();
2185 Fremove_specifier (XSPECIFIER(specifier)->fallback,
2186 locale, tag_set, exact_p);
2187 unbind_to (depth, Qnil);
2190 struct copy_specifier_closure
2193 enum spec_add_meth add_meth;
2194 int add_meth_is_nil;
2198 copy_specifier_mapfun (Lisp_Object specifier,
2200 enum spec_locale_type locale_type,
2201 Lisp_Object tag_set,
2205 struct copy_specifier_closure *cl =
2206 (struct copy_specifier_closure *) closure;
2209 specifier_copy_locale_type (specifier, cl->dest, locale_type,
2211 cl->add_meth_is_nil ?
2212 SPEC_REMOVE_LOCALE_TYPE :
2215 specifier_copy_spec (specifier, cl->dest, locale, locale_type,
2217 cl->add_meth_is_nil ? SPEC_REMOVE_LOCALE :
2222 DEFUN ("copy-specifier", Fcopy_specifier, 1, 6, 0, /*
2223 Copy SPECIFIER to DEST, or create a new one if DEST is nil.
2225 If DEST is nil or omitted, a new specifier will be created and the
2226 specifications copied into it. Otherwise, the specifications will be
2227 copied into the existing specifier in DEST.
2229 If LOCALE is nil or 'all, all specifications will be copied. If LOCALE
2230 is a particular locale, the specification for that particular locale will
2231 be copied. If LOCALE is a locale type, the specifications for all locales
2232 of that type will be copied. LOCALE can also be a list of locales,
2233 locale types, and/or 'all; this is equivalent to calling `copy-specifier'
2234 for each of the elements of the list. See `specifier-spec-list' for more
2235 information about LOCALE.
2237 Only instantiators where TAG-SET (a list of zero or more tags) is a
2238 subset of (or possibly equal to) the instantiator's tag set are copied.
2239 The default value of nil is a subset of all tag sets, so in this case
2240 no instantiators will be screened out. If EXACT-P is non-nil, however,
2241 TAG-SET must be equal to an instantiator's tag set for the instantiator
2244 Optional argument HOW-TO-ADD specifies what to do with existing
2245 specifications in DEST. If nil, then whichever locales or locale types
2246 are copied will first be completely erased in DEST. Otherwise, it is
2247 the same as in `add-spec-to-specifier'.
2249 (specifier, dest, locale, tag_set, exact_p, how_to_add))
2251 struct gcpro gcpro1;
2252 struct copy_specifier_closure cl;
2254 CHECK_SPECIFIER (specifier);
2255 if (NILP (how_to_add))
2256 cl.add_meth_is_nil = 1;
2258 cl.add_meth_is_nil = 0;
2259 cl.add_meth = decode_how_to_add_specification (how_to_add);
2262 /* #### What about copying the extra data? */
2263 dest = make_specifier (XSPECIFIER (specifier)->methods);
2267 CHECK_SPECIFIER (dest);
2268 check_modifiable_specifier (dest);
2269 if (XSPECIFIER (dest)->methods != XSPECIFIER (specifier)->methods)
2270 error ("Specifiers not of same type");
2275 map_specifier (specifier, locale, copy_specifier_mapfun,
2276 tag_set, exact_p, &cl);
2278 recompute_cached_specifier_everywhere (dest);
2283 /************************************************************************/
2285 /************************************************************************/
2288 call_validate_matchspec_method (Lisp_Object boxed_method,
2289 Lisp_Object matchspec)
2291 ((void (*)(Lisp_Object)) get_opaque_ptr (boxed_method)) (matchspec);
2296 check_valid_specifier_matchspec (Lisp_Object matchspec,
2297 struct specifier_methods *meths,
2298 Error_behavior errb)
2300 if (meths->validate_matchspec_method)
2304 if (ERRB_EQ (errb, ERROR_ME))
2306 (meths->validate_matchspec_method) (matchspec);
2311 Lisp_Object opaque =
2312 make_opaque_ptr ((void *) meths->validate_matchspec_method);
2313 struct gcpro gcpro1;
2316 retval = call_with_suspended_errors
2317 ((lisp_fn_t) call_validate_matchspec_method,
2318 Qnil, Qspecifier, errb, 2, opaque, matchspec);
2320 free_opaque_ptr (opaque);
2328 maybe_signal_simple_error
2329 ("Matchspecs not allowed for this specifier type",
2330 intern (meths->name), Qspecifier, errb);
2335 DEFUN ("check-valid-specifier-matchspec", Fcheck_valid_specifier_matchspec, 2, 2, 0, /*
2336 Signal an error if MATCHSPEC is invalid for SPECIFIER-TYPE.
2337 See `specifier-matching-instance' for a description of matchspecs.
2339 (matchspec, specifier_type))
2341 struct specifier_methods *meths = decode_specifier_type (specifier_type,
2344 return check_valid_specifier_matchspec (matchspec, meths, ERROR_ME);
2347 DEFUN ("valid-specifier-matchspec-p", Fvalid_specifier_matchspec_p, 2, 2, 0, /*
2348 Return non-nil if MATCHSPEC is valid for SPECIFIER-TYPE.
2349 See `specifier-matching-instance' for a description of matchspecs.
2351 (matchspec, specifier_type))
2353 struct specifier_methods *meths = decode_specifier_type (specifier_type,
2356 return check_valid_specifier_matchspec (matchspec, meths, ERROR_ME_NOT);
2359 /* This function is purposely not callable from Lisp. If a Lisp
2360 caller wants to set a fallback, they should just set the
2364 set_specifier_fallback (Lisp_Object specifier, Lisp_Object fallback)
2366 struct Lisp_Specifier *sp = XSPECIFIER (specifier);
2367 assert (SPECIFIERP (fallback) ||
2368 !NILP (Fvalid_inst_list_p (fallback, Fspecifier_type (specifier))));
2369 if (SPECIFIERP (fallback))
2370 assert (EQ (Fspecifier_type (specifier), Fspecifier_type (fallback)));
2371 if (BODILY_SPECIFIER_P (sp))
2372 GHOST_SPECIFIER(sp)->fallback = fallback;
2374 sp->fallback = fallback;
2375 /* call the after-change method */
2376 MAYBE_SPECMETH (sp, after_change,
2377 (bodily_specifier (specifier), Qfallback));
2378 recompute_cached_specifier_everywhere (specifier);
2381 DEFUN ("specifier-fallback", Fspecifier_fallback, 1, 1, 0, /*
2382 Return the fallback value for SPECIFIER.
2383 Fallback values are provided by the C code for certain built-in
2384 specifiers to make sure that instancing won't fail even if all
2385 specs are removed from the specifier, or to implement simple
2386 inheritance behavior (e.g. this method is used to ensure that
2387 faces other than 'default inherit their attributes from 'default).
2388 By design, you cannot change the fallback value, and specifiers
2389 created with `make-specifier' will never have a fallback (although
2390 a similar, Lisp-accessible capability may be provided in the future
2391 to allow for inheritance).
2393 The fallback value will be an inst-list that is instanced like
2394 any other inst-list, a specifier of the same type as SPECIFIER
2395 \(results in inheritance), or nil for no fallback.
2397 When you instance a specifier, you can explicitly request that the
2398 fallback not be consulted. (The C code does this, for example, when
2399 merging faces.) See `specifier-instance'.
2403 CHECK_SPECIFIER (specifier);
2404 return Fcopy_tree (XSPECIFIER (specifier)->fallback, Qt);
2408 specifier_instance_from_inst_list (Lisp_Object specifier,
2409 Lisp_Object matchspec,
2411 Lisp_Object inst_list,
2412 Error_behavior errb, int no_quit,
2415 /* This function can GC */
2416 struct Lisp_Specifier *sp;
2419 int count = specpdl_depth ();
2420 struct gcpro gcpro1, gcpro2;
2422 GCPRO2 (specifier, inst_list);
2424 sp = XSPECIFIER (specifier);
2425 device = DFW_DEVICE (domain);
2428 /* The instantiate method is allowed to call eval. Since it
2429 is quite common for this function to get called from somewhere in
2430 redisplay we need to make sure that quits are ignored. Otherwise
2431 Fsignal will abort. */
2432 specbind (Qinhibit_quit, Qt);
2434 LIST_LOOP (rest, inst_list)
2436 Lisp_Object tagged_inst = XCAR (rest);
2437 Lisp_Object tag_set = XCAR (tagged_inst);
2439 if (device_matches_specifier_tag_set_p (device, tag_set))
2441 Lisp_Object val = XCDR (tagged_inst);
2443 if (HAS_SPECMETH_P (sp, instantiate))
2444 val = call_with_suspended_errors
2445 ((lisp_fn_t) RAW_SPECMETH (sp, instantiate),
2446 Qunbound, Qspecifier, errb, 5, specifier,
2447 matchspec, domain, val, depth);
2449 if (!UNBOUNDP (val))
2451 unbind_to (count, Qnil);
2458 unbind_to (count, Qnil);
2463 /* Given a SPECIFIER and a DOMAIN, return a specific instance for that
2464 specifier. Try to find one by checking the specifier types from most
2465 specific (buffer) to most general (global). If we find an instance,
2466 return it. Otherwise return Qunbound. */
2468 #define CHECK_INSTANCE_ENTRY(key, matchspec, type) do { \
2469 Lisp_Object *CIE_inst_list = \
2470 specifier_get_inst_list (specifier, key, type); \
2471 if (CIE_inst_list) \
2473 Lisp_Object CIE_val = \
2474 specifier_instance_from_inst_list (specifier, matchspec, \
2475 domain, *CIE_inst_list, \
2476 errb, no_quit, depth); \
2477 if (!UNBOUNDP (CIE_val)) \
2482 /* We accept any window, frame or device domain and do our checking
2483 starting from as specific a locale type as we can determine from the
2484 domain we are passed and going on up through as many other locale types
2485 as we can determine. In practice, when called from redisplay the
2486 arg will usually be a window and occasionally a frame. If
2487 triggered by a user call, who knows what it will usually be. */
2489 specifier_instance (Lisp_Object specifier, Lisp_Object matchspec,
2490 Lisp_Object domain, Error_behavior errb, int no_quit,
2491 int no_fallback, Lisp_Object depth)
2493 Lisp_Object buffer = Qnil;
2494 Lisp_Object window = Qnil;
2495 Lisp_Object frame = Qnil;
2496 Lisp_Object device = Qnil;
2497 Lisp_Object tag = Qnil;
2499 struct Lisp_Specifier *sp;
2501 sp = XSPECIFIER (specifier);
2503 /* Attempt to determine buffer, window, frame, and device from the
2505 if (WINDOWP (domain))
2507 else if (FRAMEP (domain))
2509 else if (DEVICEP (domain))
2512 /* #### dmoore - dammit, this should just signal an error or something
2514 #### No. Errors are handled in Lisp primitives implementation.
2515 Invalid domain is a design error here - kkm. */
2518 if (NILP (buffer) && !NILP (window))
2519 buffer = XWINDOW (window)->buffer;
2520 if (NILP (frame) && !NILP (window))
2521 frame = XWINDOW (window)->frame;
2523 /* frame had better exist; if device is undeterminable, something
2524 really went wrong. */
2525 device = XFRAME (frame)->device;
2527 /* device had better be determined by now; abort if not. */
2528 d = XDEVICE (device);
2529 tag = DEVICE_CLASS (d);
2531 depth = make_int (1 + XINT (depth));
2532 if (XINT (depth) > 20)
2534 maybe_error (Qspecifier, errb, "Apparent loop in specifier inheritance");
2535 /* The specification is fucked; at least try the fallback
2536 (which better not be fucked, because it's not changeable
2543 /* First see if we can generate one from the window specifiers. */
2545 CHECK_INSTANCE_ENTRY (window, matchspec, LOCALE_WINDOW);
2547 /* Next see if we can generate one from the buffer specifiers. */
2549 CHECK_INSTANCE_ENTRY (buffer, matchspec, LOCALE_BUFFER);
2551 /* Next see if we can generate one from the frame specifiers. */
2553 CHECK_INSTANCE_ENTRY (frame, matchspec, LOCALE_FRAME);
2555 /* If we still haven't succeeded try with the device specifiers. */
2556 CHECK_INSTANCE_ENTRY (device, matchspec, LOCALE_DEVICE);
2558 /* Last and least try the global specifiers. */
2559 CHECK_INSTANCE_ENTRY (Qglobal, matchspec, LOCALE_GLOBAL);
2562 /* We're out of specifiers and we still haven't generated an
2563 instance. At least try the fallback ... If this fails,
2564 then we just return Qunbound. */
2566 if (no_fallback || NILP (sp->fallback))
2567 /* I said, I don't want the fallbacks. */
2570 if (SPECIFIERP (sp->fallback))
2572 /* If you introduced loops in the default specifier chain,
2573 then you're fucked, so you better not do this. */
2574 specifier = sp->fallback;
2575 sp = XSPECIFIER (specifier);
2579 assert (CONSP (sp->fallback));
2580 return specifier_instance_from_inst_list (specifier, matchspec, domain,
2581 sp->fallback, errb, no_quit,
2584 #undef CHECK_INSTANCE_ENTRY
2587 specifier_instance_no_quit (Lisp_Object specifier, Lisp_Object matchspec,
2588 Lisp_Object domain, Error_behavior errb,
2589 int no_fallback, Lisp_Object depth)
2591 return specifier_instance (specifier, matchspec, domain, errb,
2592 1, no_fallback, depth);
2595 DEFUN ("specifier-instance", Fspecifier_instance, 1, 4, 0, /*
2596 Instantiate SPECIFIER (return its value) in DOMAIN.
2597 If no instance can be generated for this domain, return DEFAULT.
2599 DOMAIN should be a window, frame, or device. Other values that are legal
2600 as a locale (e.g. a buffer) are not valid as a domain because they do not
2601 provide enough information to identify a particular device (see
2602 `valid-specifier-domain-p'). DOMAIN defaults to the selected window
2605 "Instantiating" a specifier in a particular domain means determining
2606 the specifier's "value" in that domain. This is accomplished by
2607 searching through the specifications in the specifier that correspond
2608 to all locales that can be derived from the given domain, from specific
2609 to general. In most cases, the domain is an Emacs window. In that case
2610 specifications are searched for as follows:
2612 1. A specification whose locale is the window itself;
2613 2. A specification whose locale is the window's buffer;
2614 3. A specification whose locale is the window's frame;
2615 4. A specification whose locale is the window's frame's device;
2616 5. A specification whose locale is 'global.
2618 If all of those fail, then the C-code-provided fallback value for
2619 this specifier is consulted (see `specifier-fallback'). If it is
2620 an inst-list, then this function attempts to instantiate that list
2621 just as when a specification is located in the first five steps above.
2622 If the fallback is a specifier, `specifier-instance' is called
2623 recursively on this specifier and the return value used. Note,
2624 however, that if the optional argument NO-FALLBACK is non-nil,
2625 the fallback value will not be consulted.
2627 Note that there may be more than one specification matching a particular
2628 locale; all such specifications are considered before looking for any
2629 specifications for more general locales. Any particular specification
2630 that is found may be rejected because its tag set does not match the
2631 device being instantiated over, or because the specification is not
2632 valid for the device of the given domain (e.g. the font or color name
2633 does not exist for this particular X server).
2635 The returned value is dependent on the type of specifier. For example,
2636 for a font specifier (as returned by the `face-font' function), the returned
2637 value will be a font-instance object. For glyphs, the returned value
2638 will be a string, pixmap, or subwindow.
2640 See also `specifier-matching-instance'.
2642 (specifier, domain, default_, no_fallback))
2644 Lisp_Object instance;
2646 CHECK_SPECIFIER (specifier);
2647 domain = decode_domain (domain);
2649 instance = specifier_instance (specifier, Qunbound, domain, ERROR_ME, 0,
2650 !NILP (no_fallback), Qzero);
2651 return UNBOUNDP (instance) ? default_ : instance;
2654 DEFUN ("specifier-matching-instance", Fspecifier_matching_instance, 2, 5, 0, /*
2655 Return an instance for SPECIFIER in DOMAIN that matches MATCHSPEC.
2656 If no instance can be generated for this domain, return DEFAULT.
2658 This function is identical to `specifier-instance' except that a
2659 specification will only be considered if it matches MATCHSPEC.
2660 The definition of "match", and allowed values for MATCHSPEC, are
2661 dependent on the particular type of specifier. Here are some examples:
2663 -- For chartable (e.g. display table) specifiers, MATCHSPEC should be a
2664 character, and the specification (a chartable) must give a value for
2665 that character in order to be considered. This allows you to specify,
2666 e.g., a buffer-local display table that only gives values for particular
2667 characters. All other characters are handled as if the buffer-local
2668 display table is not there. (Chartable specifiers are not yet
2671 -- For font specifiers, MATCHSPEC should be a charset, and the specification
2672 (a font string) must have a registry that matches the charset's registry.
2673 (This only makes sense with Mule support.) This makes it easy to choose a
2674 font that can display a particular character. (This is what redisplay
2677 (specifier, matchspec, domain, default_, no_fallback))
2679 Lisp_Object instance;
2681 CHECK_SPECIFIER (specifier);
2682 check_valid_specifier_matchspec (matchspec, XSPECIFIER (specifier)->methods,
2684 domain = decode_domain (domain);
2686 instance = specifier_instance (specifier, matchspec, domain, ERROR_ME,
2687 0, !NILP (no_fallback), Qzero);
2688 return UNBOUNDP (instance) ? default_ : instance;
2691 DEFUN ("specifier-instance-from-inst-list", Fspecifier_instance_from_inst_list,
2693 Attempt to convert a particular inst-list into an instance.
2694 This attempts to instantiate INST-LIST in the given DOMAIN,
2695 as if INST-LIST existed in a specification in SPECIFIER. If
2696 the instantiation fails, DEFAULT is returned. In most circumstances,
2697 you should not use this function; use `specifier-instance' instead.
2699 (specifier, domain, inst_list, default_))
2701 Lisp_Object val = Qunbound;
2702 struct Lisp_Specifier *sp = XSPECIFIER (specifier);
2703 struct gcpro gcpro1;
2704 Lisp_Object built_up_list = Qnil;
2706 CHECK_SPECIFIER (specifier);
2707 check_valid_domain (domain);
2708 check_valid_inst_list (inst_list, sp->methods, ERROR_ME);
2709 GCPRO1 (built_up_list);
2710 built_up_list = build_up_processed_list (specifier, domain, inst_list);
2711 if (!NILP (built_up_list))
2712 val = specifier_instance_from_inst_list (specifier, Qunbound, domain,
2713 built_up_list, ERROR_ME,
2716 return UNBOUNDP (val) ? default_ : val;
2719 DEFUN ("specifier-matching-instance-from-inst-list", Fspecifier_matching_instance_from_inst_list,
2721 Attempt to convert a particular inst-list into an instance.
2722 This attempts to instantiate INST-LIST in the given DOMAIN
2723 \(as if INST-LIST existed in a specification in SPECIFIER),
2724 matching the specifications against MATCHSPEC.
2726 This function is analogous to `specifier-instance-from-inst-list'
2727 but allows for specification-matching as in `specifier-matching-instance'.
2728 See that function for a description of exactly how the matching process
2731 (specifier, matchspec, domain, inst_list, default_))
2733 Lisp_Object val = Qunbound;
2734 struct Lisp_Specifier *sp = XSPECIFIER (specifier);
2735 struct gcpro gcpro1;
2736 Lisp_Object built_up_list = Qnil;
2738 CHECK_SPECIFIER (specifier);
2739 check_valid_specifier_matchspec (matchspec, XSPECIFIER (specifier)->methods,
2741 check_valid_domain (domain);
2742 check_valid_inst_list (inst_list, sp->methods, ERROR_ME);
2743 GCPRO1 (built_up_list);
2744 built_up_list = build_up_processed_list (specifier, domain, inst_list);
2745 if (!NILP (built_up_list))
2746 val = specifier_instance_from_inst_list (specifier, matchspec, domain,
2747 built_up_list, ERROR_ME,
2750 return UNBOUNDP (val) ? default_ : val;
2754 /************************************************************************/
2755 /* Caching in the struct window or frame */
2756 /************************************************************************/
2758 /* Either STRUCT_WINDOW_OFFSET or STRUCT_FRAME_OFFSET can be 0 to indicate
2759 no caching in that sort of object. */
2761 /* #### It would be nice if the specifier caching automatically knew
2762 about specifier fallbacks, so we didn't have to do it ourselves. */
2765 set_specifier_caching (Lisp_Object specifier, int struct_window_offset,
2766 void (*value_changed_in_window)
2767 (Lisp_Object specifier, struct window *w,
2768 Lisp_Object oldval),
2769 int struct_frame_offset,
2770 void (*value_changed_in_frame)
2771 (Lisp_Object specifier, struct frame *f,
2772 Lisp_Object oldval))
2774 struct Lisp_Specifier *sp = XSPECIFIER (specifier);
2775 assert (!GHOST_SPECIFIER_P (sp));
2778 sp->caching = xnew_and_zero (struct specifier_caching);
2779 sp->caching->offset_into_struct_window = struct_window_offset;
2780 sp->caching->value_changed_in_window = value_changed_in_window;
2781 sp->caching->offset_into_struct_frame = struct_frame_offset;
2782 sp->caching->value_changed_in_frame = value_changed_in_frame;
2783 Vcached_specifiers = Fcons (specifier, Vcached_specifiers);
2784 if (BODILY_SPECIFIER_P (sp))
2785 GHOST_SPECIFIER(sp)->caching = sp->caching;
2786 recompute_cached_specifier_everywhere (specifier);
2790 recompute_one_cached_specifier_in_window (Lisp_Object specifier,
2794 Lisp_Object newval, *location;
2796 assert (!GHOST_SPECIFIER_P (XSPECIFIER (specifier)));
2798 XSETWINDOW (window, w);
2800 newval = specifier_instance (specifier, Qunbound, window, ERROR_ME_WARN,
2802 /* If newval ended up Qunbound, then the calling functions
2803 better be able to deal. If not, set a default so this
2804 never happens or correct it in the value_changed_in_window
2806 location = (Lisp_Object *)
2807 ((char *) w + XSPECIFIER (specifier)->caching->offset_into_struct_window);
2808 if (!EQ (newval, *location))
2810 Lisp_Object oldval = *location;
2812 (XSPECIFIER (specifier)->caching->value_changed_in_window)
2813 (specifier, w, oldval);
2818 recompute_one_cached_specifier_in_frame (Lisp_Object specifier,
2822 Lisp_Object newval, *location;
2824 assert (!GHOST_SPECIFIER_P (XSPECIFIER (specifier)));
2826 XSETFRAME (frame, f);
2828 newval = specifier_instance (specifier, Qunbound, frame, ERROR_ME_WARN,
2830 /* If newval ended up Qunbound, then the calling functions
2831 better be able to deal. If not, set a default so this
2832 never happens or correct it in the value_changed_in_frame
2834 location = (Lisp_Object *)
2835 ((char *) f + XSPECIFIER (specifier)->caching->offset_into_struct_frame);
2836 if (!EQ (newval, *location))
2838 Lisp_Object oldval = *location;
2840 (XSPECIFIER (specifier)->caching->value_changed_in_frame)
2841 (specifier, f, oldval);
2846 recompute_all_cached_specifiers_in_window (struct window *w)
2850 LIST_LOOP (rest, Vcached_specifiers)
2852 Lisp_Object specifier = XCAR (rest);
2853 if (XSPECIFIER (specifier)->caching->offset_into_struct_window)
2854 recompute_one_cached_specifier_in_window (specifier, w);
2859 recompute_all_cached_specifiers_in_frame (struct frame *f)
2863 LIST_LOOP (rest, Vcached_specifiers)
2865 Lisp_Object specifier = XCAR (rest);
2866 if (XSPECIFIER (specifier)->caching->offset_into_struct_frame)
2867 recompute_one_cached_specifier_in_frame (specifier, f);
2872 recompute_cached_specifier_everywhere_mapfun (struct window *w,
2875 Lisp_Object specifier = Qnil;
2877 VOID_TO_LISP (specifier, closure);
2878 recompute_one_cached_specifier_in_window (specifier, w);
2883 recompute_cached_specifier_everywhere (Lisp_Object specifier)
2885 Lisp_Object frmcons, devcons, concons;
2887 specifier = bodily_specifier (specifier);
2889 if (!XSPECIFIER (specifier)->caching)
2892 if (XSPECIFIER (specifier)->caching->offset_into_struct_window)
2894 FRAME_LOOP_NO_BREAK (frmcons, devcons, concons)
2895 map_windows (XFRAME (XCAR (frmcons)),
2896 recompute_cached_specifier_everywhere_mapfun,
2897 LISP_TO_VOID (specifier));
2900 if (XSPECIFIER (specifier)->caching->offset_into_struct_frame)
2902 FRAME_LOOP_NO_BREAK (frmcons, devcons, concons)
2903 recompute_one_cached_specifier_in_frame (specifier,
2904 XFRAME (XCAR (frmcons)));
2908 DEFUN ("set-specifier-dirty-flag", Fset_specifier_dirty_flag, 1, 1, 0, /*
2909 Force recomputation of any caches associated with SPECIFIER.
2910 Note that this automatically happens whenever you change a specification
2911 in SPECIFIER; you do not have to call this function then.
2912 One example of where this function is useful is when you have a
2913 toolbar button whose `active-p' field is an expression to be
2914 evaluated. Calling `set-specifier-dirty-flag' on the
2915 toolbar specifier will force the `active-p' fields to be
2920 CHECK_SPECIFIER (specifier);
2921 recompute_cached_specifier_everywhere (specifier);
2926 /************************************************************************/
2927 /* Generic specifier type */
2928 /************************************************************************/
2930 DEFINE_SPECIFIER_TYPE (generic);
2934 /* This is the string that used to be in `generic-specifier-p'.
2935 The idea is good, but it doesn't quite work in the form it's
2936 in. (One major problem is that validating an instantiator
2937 is supposed to require only that the specifier type is passed,
2938 while with this approach the actual specifier is needed.)
2940 What really needs to be done is to write a function
2941 `make-specifier-type' that creates new specifier types.
2942 #### I'll look into this for 19.14.
2945 "A generic specifier is a generalized kind of specifier with user-defined\n"
2946 "semantics. The instantiator can be any kind of Lisp object, and the\n"
2947 "instance computed from it is likewise any kind of Lisp object. The\n"
2948 "SPECIFIER-DATA should be an alist of methods governing how the specifier\n"
2949 "works. All methods are optional, and reasonable default methods will be\n"
2950 "provided. Currently there are two defined methods: 'instantiate and\n"
2953 "'instantiate specifies how to do the instantiation; if omitted, the\n"
2954 "instantiator itself is simply returned as the instance. The method\n"
2955 "should be a function that accepts three parameters (a specifier, the\n"
2956 "instantiator that matched the domain being instantiated over, and that\n"
2957 "domain), and should return a one-element list containing the instance,\n"
2958 "or nil if no instance exists. Note that the domain passed to this function\n"
2959 "is the domain being instantiated over, which may not be the same as the\n"
2960 "locale contained in the specification corresponding to the instantiator\n"
2961 "(for example, the domain being instantiated over could be a window, but\n"
2962 "the locale corresponding to the passed instantiator could be the window's\n"
2963 "buffer or frame).\n"
2965 "'validate specifies whether a given instantiator is valid; if omitted,\n"
2966 "all instantiators are considered valid. It should be a function of\n"
2967 "two arguments: an instantiator and a flag CAN-SIGNAL-ERROR. If this\n"
2968 "flag is false, the function must simply return t or nil indicating\n"
2969 "whether the instantiator is valid. If this flag is true, the function\n"
2970 "is free to signal an error if it encounters an invalid instantiator\n"
2971 "(this can be useful for issuing a specific error about exactly why the\n"
2972 "instantiator is valid). It can also return nil to indicate an invalid\n"
2973 "instantiator; in this case, a general error will be signalled."
2977 DEFUN ("generic-specifier-p", Fgeneric_specifier_p, 1, 1, 0, /*
2978 Return non-nil if OBJECT is a generic specifier.
2980 A generic specifier allows any kind of Lisp object as an instantiator,
2981 and returns back the Lisp object unchanged when it is instantiated.
2985 return GENERIC_SPECIFIERP (object) ? Qt : Qnil;
2989 /************************************************************************/
2990 /* Integer specifier type */
2991 /************************************************************************/
2993 DEFINE_SPECIFIER_TYPE (integer);
2996 integer_validate (Lisp_Object instantiator)
2998 CHECK_INT (instantiator);
3001 DEFUN ("integer-specifier-p", Finteger_specifier_p, 1, 1, 0, /*
3002 Return non-nil if OBJECT is an integer specifier.
3006 return INTEGER_SPECIFIERP (object) ? Qt : Qnil;
3009 /************************************************************************/
3010 /* Non-negative-integer specifier type */
3011 /************************************************************************/
3013 DEFINE_SPECIFIER_TYPE (natnum);
3016 natnum_validate (Lisp_Object instantiator)
3018 CHECK_NATNUM (instantiator);
3021 DEFUN ("natnum-specifier-p", Fnatnum_specifier_p, 1, 1, 0, /*
3022 Return non-nil if OBJECT is a natnum (non-negative-integer) specifier.
3026 return NATNUM_SPECIFIERP (object) ? Qt : Qnil;
3029 /************************************************************************/
3030 /* Boolean specifier type */
3031 /************************************************************************/
3033 DEFINE_SPECIFIER_TYPE (boolean);
3036 boolean_validate (Lisp_Object instantiator)
3038 if (!EQ (instantiator, Qt) && !EQ (instantiator, Qnil))
3039 signal_simple_error ("Must be t or nil", instantiator);
3042 DEFUN ("boolean-specifier-p", Fboolean_specifier_p, 1, 1, 0, /*
3043 Return non-nil if OBJECT is a boolean specifier.
3047 return BOOLEAN_SPECIFIERP (object) ? Qt : Qnil;
3050 /************************************************************************/
3051 /* Display table specifier type */
3052 /************************************************************************/
3054 DEFINE_SPECIFIER_TYPE (display_table);
3056 #define VALID_SINGLE_DISPTABLE_INSTANTIATOR_P(instantiator) \
3057 (VECTORP (instantiator) \
3058 || (CHAR_TABLEP (instantiator) \
3059 && (XCHAR_TABLE_TYPE (instantiator) == CHAR_TABLE_TYPE_CHAR \
3060 || XCHAR_TABLE_TYPE (instantiator) == CHAR_TABLE_TYPE_GENERIC)) \
3061 || RANGE_TABLEP (instantiator))
3064 display_table_validate (Lisp_Object instantiator)
3066 if (NILP (instantiator))
3069 else if (CONSP (instantiator))
3072 EXTERNAL_LIST_LOOP (tail, instantiator)
3074 Lisp_Object car = XCAR (tail);
3075 if (!VALID_SINGLE_DISPTABLE_INSTANTIATOR_P (car))
3081 if (!VALID_SINGLE_DISPTABLE_INSTANTIATOR_P (instantiator))
3084 dead_wrong_type_argument (display_table_specifier_methods->predicate_symbol,
3090 DEFUN ("display-table-specifier-p", Fdisplay_table_specifier_p, 1, 1, 0, /*
3091 Return non-nil if OBJECT is a display-table specifier.
3095 return DISPLAYTABLE_SPECIFIERP (object) ? Qt : Qnil;
3099 /************************************************************************/
3100 /* Initialization */
3101 /************************************************************************/
3104 syms_of_specifier (void)
3106 defsymbol (&Qspecifierp, "specifierp");
3108 defsymbol (&Qconsole_type, "console-type");
3109 defsymbol (&Qdevice_class, "device-class");
3111 /* Qinteger, Qboolean, Qgeneric defined in general.c */
3112 defsymbol (&Qnatnum, "natnum");
3114 DEFSUBR (Fvalid_specifier_type_p);
3115 DEFSUBR (Fspecifier_type_list);
3116 DEFSUBR (Fmake_specifier);
3117 DEFSUBR (Fspecifierp);
3118 DEFSUBR (Fspecifier_type);
3120 DEFSUBR (Fvalid_specifier_locale_p);
3121 DEFSUBR (Fvalid_specifier_domain_p);
3122 DEFSUBR (Fvalid_specifier_locale_type_p);
3123 DEFSUBR (Fspecifier_locale_type_from_locale);
3125 DEFSUBR (Fvalid_specifier_tag_p);
3126 DEFSUBR (Fvalid_specifier_tag_set_p);
3127 DEFSUBR (Fcanonicalize_tag_set);
3128 DEFSUBR (Fdevice_matches_specifier_tag_set_p);
3129 DEFSUBR (Fdefine_specifier_tag);
3130 DEFSUBR (Fdevice_matching_specifier_tag_list);
3131 DEFSUBR (Fspecifier_tag_list);
3132 DEFSUBR (Fspecifier_tag_predicate);
3134 DEFSUBR (Fcheck_valid_instantiator);
3135 DEFSUBR (Fvalid_instantiator_p);
3136 DEFSUBR (Fcheck_valid_inst_list);
3137 DEFSUBR (Fvalid_inst_list_p);
3138 DEFSUBR (Fcheck_valid_spec_list);
3139 DEFSUBR (Fvalid_spec_list_p);
3140 DEFSUBR (Fadd_spec_to_specifier);
3141 DEFSUBR (Fadd_spec_list_to_specifier);
3142 DEFSUBR (Fspecifier_spec_list);
3143 DEFSUBR (Fspecifier_specs);
3144 DEFSUBR (Fremove_specifier);
3145 DEFSUBR (Fcopy_specifier);
3147 DEFSUBR (Fcheck_valid_specifier_matchspec);
3148 DEFSUBR (Fvalid_specifier_matchspec_p);
3149 DEFSUBR (Fspecifier_fallback);
3150 DEFSUBR (Fspecifier_instance);
3151 DEFSUBR (Fspecifier_matching_instance);
3152 DEFSUBR (Fspecifier_instance_from_inst_list);
3153 DEFSUBR (Fspecifier_matching_instance_from_inst_list);
3154 DEFSUBR (Fset_specifier_dirty_flag);
3156 DEFSUBR (Fgeneric_specifier_p);
3157 DEFSUBR (Finteger_specifier_p);
3158 DEFSUBR (Fnatnum_specifier_p);
3159 DEFSUBR (Fboolean_specifier_p);
3160 DEFSUBR (Fdisplay_table_specifier_p);
3162 /* Symbols pertaining to specifier creation. Specifiers are created
3163 in the syms_of() functions. */
3165 /* locales are defined in general.c. */
3167 defsymbol (&Qprepend, "prepend");
3168 defsymbol (&Qappend, "append");
3169 defsymbol (&Qremove_tag_set_prepend, "remove-tag-set-prepend");
3170 defsymbol (&Qremove_tag_set_append, "remove-tag-set-append");
3171 defsymbol (&Qremove_locale, "remove-locale");
3172 defsymbol (&Qremove_locale_type, "remove-locale-type");
3173 defsymbol (&Qremove_all, "remove-all");
3175 defsymbol (&Qfallback, "fallback");
3179 specifier_type_create (void)
3181 the_specifier_type_entry_dynarr = Dynarr_new (specifier_type_entry);
3182 dumpstruct (&the_specifier_type_entry_dynarr, &sted_description);
3184 Vspecifier_type_list = Qnil;
3185 staticpro (&Vspecifier_type_list);
3187 INITIALIZE_SPECIFIER_TYPE (generic, "generic", "generic-specifier-p");
3189 INITIALIZE_SPECIFIER_TYPE (integer, "integer", "integer-specifier-p");
3191 SPECIFIER_HAS_METHOD (integer, validate);
3193 INITIALIZE_SPECIFIER_TYPE (natnum, "natnum", "natnum-specifier-p");
3195 SPECIFIER_HAS_METHOD (natnum, validate);
3197 INITIALIZE_SPECIFIER_TYPE (boolean, "boolean", "boolean-specifier-p");
3199 SPECIFIER_HAS_METHOD (boolean, validate);
3201 INITIALIZE_SPECIFIER_TYPE (display_table, "display-table", "display-table-p");
3203 SPECIFIER_HAS_METHOD (display_table, validate);
3207 reinit_specifier_type_create (void)
3209 REINITIALIZE_SPECIFIER_TYPE (generic);
3210 REINITIALIZE_SPECIFIER_TYPE (integer);
3211 REINITIALIZE_SPECIFIER_TYPE (natnum);
3212 REINITIALIZE_SPECIFIER_TYPE (boolean);
3213 REINITIALIZE_SPECIFIER_TYPE (display_table);
3217 vars_of_specifier (void)
3219 Vcached_specifiers = Qnil;
3220 staticpro (&Vcached_specifiers);
3222 /* Do NOT mark through this, or specifiers will never be GC'd.
3223 This is the same deal as for weak hash tables. */
3224 Vall_specifiers = Qnil;
3225 pdump_wire_list (&Vall_specifiers);
3227 Vuser_defined_tags = Qnil;
3228 staticpro (&Vuser_defined_tags);
3230 Vunlock_ghost_specifiers = Qnil;
3231 staticpro (&Vunlock_ghost_specifiers);