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 sub_inst_list = Qnil;
1652 Lisp_Object instantiator;
1653 struct gcpro ngcpro1, ngcpro2;
1655 if (HAS_SPECMETH_P (sp, copy_instantiator))
1656 instantiator = SPECMETH (sp, copy_instantiator,
1657 (XCDR (XCAR (rest))));
1659 instantiator = Fcopy_tree (XCDR (XCAR (rest)), Qt);
1661 NGCPRO2 (instantiator, sub_inst_list);
1662 /* call the will-add method; it may GC */
1663 sub_inst_list = HAS_SPECMETH_P (sp, going_to_add) ?
1664 SPECMETH (sp, going_to_add,
1665 (bodily_specifier (specifier), locale,
1666 tag_set, instantiator)) :
1668 if (EQ (sub_inst_list, Qt))
1669 /* no change here. */
1670 sub_inst_list = list1 (Fcons (canonicalize_tag_set (tag_set),
1674 /* now canonicalize all the tag sets in the new objects */
1676 LIST_LOOP (rest2, sub_inst_list)
1677 XCAR (XCAR (rest2)) = canonicalize_tag_set (XCAR (XCAR (rest2)));
1680 list_to_build_up = nconc2 (sub_inst_list, list_to_build_up);
1684 RETURN_UNGCPRO (Fnreverse (list_to_build_up));
1687 /* Add a specification (locale and instantiator list) to a specifier.
1688 ADD_METH specifies what to do with existing specifications in the
1689 specifier, and is an enum that corresponds to the values in
1690 `add-spec-to-specifier'. The calling routine is responsible for
1691 validating LOCALE and INST-LIST, but the tag-sets in INST-LIST
1692 do not need to be canonicalized. */
1694 /* #### I really need to rethink the after-change
1695 functions to make them easier to use and more efficient. */
1698 specifier_add_spec (Lisp_Object specifier, Lisp_Object locale,
1699 Lisp_Object inst_list, enum spec_add_meth add_meth)
1701 struct Lisp_Specifier *sp = XSPECIFIER (specifier);
1702 enum spec_locale_type type = locale_type_from_locale (locale);
1703 Lisp_Object *orig_inst_list, tem;
1704 Lisp_Object list_to_build_up = Qnil;
1705 struct gcpro gcpro1;
1707 GCPRO1 (list_to_build_up);
1708 list_to_build_up = build_up_processed_list (specifier, locale, inst_list);
1709 /* Now handle REMOVE_LOCALE_TYPE and REMOVE_ALL. These are the
1710 add-meth types that affect locales other than this one. */
1711 if (add_meth == SPEC_REMOVE_LOCALE_TYPE)
1712 specifier_remove_locale_type (specifier, type, Qnil, 0);
1713 else if (add_meth == SPEC_REMOVE_ALL)
1715 specifier_remove_locale_type (specifier, LOCALE_BUFFER, Qnil, 0);
1716 specifier_remove_locale_type (specifier, LOCALE_WINDOW, Qnil, 0);
1717 specifier_remove_locale_type (specifier, LOCALE_FRAME, Qnil, 0);
1718 specifier_remove_locale_type (specifier, LOCALE_DEVICE, Qnil, 0);
1719 specifier_remove_spec (specifier, Qglobal, LOCALE_GLOBAL, Qnil, 0);
1722 orig_inst_list = specifier_get_inst_list (specifier, locale, type);
1723 if (!orig_inst_list)
1724 orig_inst_list = specifier_new_spec (specifier, locale, type);
1725 add_meth = handle_multiple_add_insts (orig_inst_list, list_to_build_up,
1728 if (add_meth == SPEC_PREPEND)
1729 tem = nconc2 (list_to_build_up, *orig_inst_list);
1730 else if (add_meth == SPEC_APPEND)
1731 tem = nconc2 (*orig_inst_list, list_to_build_up);
1735 *orig_inst_list = tem;
1739 /* call the after-change method */
1740 MAYBE_SPECMETH (sp, after_change,
1741 (bodily_specifier (specifier), locale));
1745 specifier_copy_spec (Lisp_Object specifier, Lisp_Object dest,
1746 Lisp_Object locale, enum spec_locale_type type,
1747 Lisp_Object tag_set, int exact_p,
1748 enum spec_add_meth add_meth)
1750 Lisp_Object inst_list =
1751 specifier_get_external_inst_list (specifier, locale, type, tag_set,
1753 specifier_add_spec (dest, locale, inst_list, add_meth);
1757 specifier_copy_locale_type (Lisp_Object specifier, Lisp_Object dest,
1758 enum spec_locale_type type,
1759 Lisp_Object tag_set, int exact_p,
1760 enum spec_add_meth add_meth)
1762 Lisp_Object *src_list = SPECIFIER_GET_SPEC_LIST (specifier, type);
1765 /* This algorithm is O(n^2) in running time.
1766 It's certainly possible to implement an O(n log n) algorithm,
1767 but I doubt there's any need to. */
1769 LIST_LOOP (rest, *src_list)
1771 Lisp_Object spec = XCAR (rest);
1772 /* There may be dead objects floating around */
1773 /* remember, dead windows can become alive again. */
1774 if (WINDOWP (XCAR (spec)) || !object_dead_p (XCAR (spec)))
1777 specifier_process_inst_list (XCDR (spec), tag_set, exact_p, 0, 0),
1782 /* map MAPFUN over the locales in SPECIFIER that are given in LOCALE.
1783 CLOSURE is passed unchanged to MAPFUN. LOCALE can be one of
1785 -- nil (same as 'all)
1786 -- a single locale, locale type, or 'all
1787 -- a list of locales, locale types, and/or 'all
1789 MAPFUN is called for each locale and locale type given; for 'all,
1790 it is called for the locale 'global and for the four possible
1791 locale types. In each invocation, either LOCALE will be a locale
1792 and LOCALE_TYPE will be the locale type of this locale,
1793 or LOCALE will be nil and LOCALE_TYPE will be a locale type.
1794 If MAPFUN ever returns non-zero, the mapping is halted and the
1795 value returned is returned from map_specifier(). Otherwise, the
1796 mapping proceeds to the end and map_specifier() returns 0.
1800 map_specifier (Lisp_Object specifier, Lisp_Object locale,
1801 int (*mapfun) (Lisp_Object specifier,
1803 enum spec_locale_type locale_type,
1804 Lisp_Object tag_set,
1807 Lisp_Object tag_set, Lisp_Object exact_p,
1812 struct gcpro gcpro1, gcpro2;
1814 GCPRO2 (tag_set, locale);
1815 locale = decode_locale_list (locale);
1816 tag_set = decode_specifier_tag_set (tag_set);
1817 tag_set = canonicalize_tag_set (tag_set);
1819 LIST_LOOP (rest, locale)
1821 Lisp_Object theloc = XCAR (rest);
1822 if (!NILP (Fvalid_specifier_locale_p (theloc)))
1824 retval = (*mapfun) (specifier, theloc,
1825 locale_type_from_locale (theloc),
1826 tag_set, !NILP (exact_p), closure);
1830 else if (!NILP (Fvalid_specifier_locale_type_p (theloc)))
1832 retval = (*mapfun) (specifier, Qnil,
1833 decode_locale_type (theloc), tag_set,
1834 !NILP (exact_p), closure);
1840 assert (EQ (theloc, Qall));
1841 retval = (*mapfun) (specifier, Qnil, LOCALE_BUFFER, tag_set,
1842 !NILP (exact_p), closure);
1845 retval = (*mapfun) (specifier, Qnil, LOCALE_WINDOW, tag_set,
1846 !NILP (exact_p), closure);
1849 retval = (*mapfun) (specifier, Qnil, LOCALE_FRAME, tag_set,
1850 !NILP (exact_p), closure);
1853 retval = (*mapfun) (specifier, Qnil, LOCALE_DEVICE, tag_set,
1854 !NILP (exact_p), closure);
1857 retval = (*mapfun) (specifier, Qglobal, LOCALE_GLOBAL, tag_set,
1858 !NILP (exact_p), closure);
1868 DEFUN ("add-spec-to-specifier", Fadd_spec_to_specifier, 2, 5, 0, /*
1869 Add a specification to SPECIFIER.
1870 The specification maps from LOCALE (which should be a window, buffer,
1871 frame, device, or 'global, and defaults to 'global) to INSTANTIATOR,
1872 whose allowed values depend on the type of the specifier. Optional
1873 argument TAG-SET limits the instantiator to apply only to the specified
1874 tag set, which should be a list of tags all of which must match the
1875 device being instantiated over (tags are a device type, a device class,
1876 or tags defined with `define-specifier-tag'). Specifying a single
1877 symbol for TAG-SET is equivalent to specifying a one-element list
1878 containing that symbol. Optional argument HOW-TO-ADD specifies what to
1879 do if there are already specifications in the specifier.
1882 'prepend Put at the beginning of the current list of
1883 instantiators for LOCALE.
1884 'append Add to the end of the current list of
1885 instantiators for LOCALE.
1886 'remove-tag-set-prepend (this is the default)
1887 Remove any existing instantiators whose tag set is
1888 the same as TAG-SET; then put the new instantiator
1889 at the beginning of the current list. ("Same tag
1890 set" means that they contain the same elements.
1891 The order may be different.)
1892 'remove-tag-set-append
1893 Remove any existing instantiators whose tag set is
1894 the same as TAG-SET; then put the new instantiator
1895 at the end of the current list.
1896 'remove-locale Remove all previous instantiators for this locale
1897 before adding the new spec.
1898 'remove-locale-type Remove all specifications for all locales of the
1899 same type as LOCALE (this includes LOCALE itself)
1900 before adding the new spec.
1901 'remove-all Remove all specifications from the specifier
1902 before adding the new spec.
1904 You can retrieve the specifications for a particular locale or locale type
1905 with the function `specifier-spec-list' or `specifier-specs'.
1907 (specifier, instantiator, locale, tag_set, how_to_add))
1909 enum spec_add_meth add_meth;
1910 Lisp_Object inst_list;
1911 struct gcpro gcpro1;
1913 CHECK_SPECIFIER (specifier);
1914 check_modifiable_specifier (specifier);
1916 locale = decode_locale (locale);
1917 check_valid_instantiator (instantiator,
1918 decode_specifier_type
1919 (Fspecifier_type (specifier), ERROR_ME),
1921 /* tag_set might be newly-created material, but it's part of inst_list
1922 so is properly GC-protected. */
1923 tag_set = decode_specifier_tag_set (tag_set);
1924 add_meth = decode_how_to_add_specification (how_to_add);
1926 inst_list = list1 (Fcons (tag_set, instantiator));
1928 specifier_add_spec (specifier, locale, inst_list, add_meth);
1929 recompute_cached_specifier_everywhere (specifier);
1930 RETURN_UNGCPRO (Qnil);
1933 DEFUN ("add-spec-list-to-specifier", Fadd_spec_list_to_specifier, 2, 3, 0, /*
1934 Add a spec-list (a list of specifications) to SPECIFIER.
1935 The format of a spec-list is
1937 ((LOCALE (TAG-SET . INSTANTIATOR) ...) ...)
1940 LOCALE := a window, a buffer, a frame, a device, or 'global
1941 TAG-SET := an unordered list of zero or more TAGS, each of which
1943 TAG := a device class (see `valid-device-class-p'), a device type
1944 (see `valid-console-type-p'), or a tag defined with
1945 `define-specifier-tag'
1946 INSTANTIATOR := format determined by the type of specifier
1948 The pair (TAG-SET . INSTANTIATOR) is called an `inst-pair'.
1949 A list of inst-pairs is called an `inst-list'.
1950 The pair (LOCALE . INST-LIST) is called a `specification' or `spec'.
1951 A spec-list, then, can be viewed as a list of specifications.
1953 HOW-TO-ADD specifies how to combine the new specifications with
1954 the existing ones, and has the same semantics as for
1955 `add-spec-to-specifier'.
1957 In many circumstances, the higher-level function `set-specifier' is
1958 more convenient and should be used instead.
1960 (specifier, spec_list, how_to_add))
1962 enum spec_add_meth add_meth;
1965 CHECK_SPECIFIER (specifier);
1966 check_modifiable_specifier (specifier);
1968 check_valid_spec_list (spec_list,
1969 decode_specifier_type
1970 (Fspecifier_type (specifier), ERROR_ME),
1972 add_meth = decode_how_to_add_specification (how_to_add);
1974 LIST_LOOP (rest, spec_list)
1976 /* Placating the GCC god. */
1977 Lisp_Object specification = XCAR (rest);
1978 Lisp_Object locale = XCAR (specification);
1979 Lisp_Object inst_list = XCDR (specification);
1981 specifier_add_spec (specifier, locale, inst_list, add_meth);
1983 recompute_cached_specifier_everywhere (specifier);
1988 add_spec_to_ghost_specifier (Lisp_Object specifier, Lisp_Object instantiator,
1989 Lisp_Object locale, Lisp_Object tag_set,
1990 Lisp_Object how_to_add)
1992 int depth = unlock_ghost_specifiers_protected ();
1993 Fadd_spec_to_specifier (XSPECIFIER(specifier)->fallback,
1994 instantiator, locale, tag_set, how_to_add);
1995 unbind_to (depth, Qnil);
1998 struct specifier_spec_list_closure
2000 Lisp_Object head, tail;
2004 specifier_spec_list_mapfun (Lisp_Object specifier,
2006 enum spec_locale_type locale_type,
2007 Lisp_Object tag_set,
2011 struct specifier_spec_list_closure *cl =
2012 (struct specifier_spec_list_closure *) closure;
2013 Lisp_Object partial;
2016 partial = specifier_get_external_spec_list (specifier,
2021 partial = specifier_get_external_inst_list (specifier, locale,
2022 locale_type, tag_set,
2024 if (!NILP (partial))
2025 partial = list1 (Fcons (locale, partial));
2030 /* tack on the new list */
2031 if (NILP (cl->tail))
2032 cl->head = cl->tail = partial;
2034 XCDR (cl->tail) = partial;
2035 /* find the new tail */
2036 while (CONSP (XCDR (cl->tail)))
2037 cl->tail = XCDR (cl->tail);
2041 /* For the given SPECIFIER create and return a list of all specs
2042 contained within it, subject to LOCALE. If LOCALE is a locale, only
2043 specs in that locale will be returned. If LOCALE is a locale type,
2044 all specs in all locales of that type will be returned. If LOCALE is
2045 nil, all specs will be returned. This always copies lists and never
2046 returns the actual lists, because we do not want someone manipulating
2047 the actual objects. This may cause a slight loss of potential
2048 functionality but if we were to allow it then a user could manage to
2049 violate our assertion that the specs contained in the actual
2050 specifier lists are all valid. */
2052 DEFUN ("specifier-spec-list", Fspecifier_spec_list, 1, 4, 0, /*
2053 Return the spec-list of specifications for SPECIFIER in LOCALE.
2055 If LOCALE is a particular locale (a buffer, window, frame, device,
2056 or 'global), a spec-list consisting of the specification for that
2057 locale will be returned.
2059 If LOCALE is a locale type (i.e. 'buffer, 'window, 'frame, or 'device),
2060 a spec-list of the specifications for all locales of that type will be
2063 If LOCALE is nil or 'all, a spec-list of all specifications in SPECIFIER
2066 LOCALE can also be a list of locales, locale types, and/or 'all; the
2067 result is as if `specifier-spec-list' were called on each element of the
2068 list and the results concatenated together.
2070 Only instantiators where TAG-SET (a list of zero or more tags) is a
2071 subset of (or possibly equal to) the instantiator's tag set are returned.
2072 \(The default value of nil is a subset of all tag sets, so in this case
2073 no instantiators will be screened out.) If EXACT-P is non-nil, however,
2074 TAG-SET must be equal to an instantiator's tag set for the instantiator
2077 (specifier, locale, tag_set, exact_p))
2079 struct specifier_spec_list_closure cl;
2080 struct gcpro gcpro1, gcpro2;
2082 CHECK_SPECIFIER (specifier);
2083 cl.head = cl.tail = Qnil;
2084 GCPRO2 (cl.head, cl.tail);
2085 map_specifier (specifier, locale, specifier_spec_list_mapfun,
2086 tag_set, exact_p, &cl);
2092 DEFUN ("specifier-specs", Fspecifier_specs, 1, 4, 0, /*
2093 Return the specification(s) for SPECIFIER in LOCALE.
2095 If LOCALE is a single locale or is a list of one element containing a
2096 single locale, then a "short form" of the instantiators for that locale
2097 will be returned. Otherwise, this function is identical to
2098 `specifier-spec-list'.
2100 The "short form" is designed for readability and not for ease of use
2101 in Lisp programs, and is as follows:
2103 1. If there is only one instantiator, then an inst-pair (i.e. cons of
2104 tag and instantiator) will be returned; otherwise a list of
2105 inst-pairs will be returned.
2106 2. For each inst-pair returned, if the instantiator's tag is 'any,
2107 the tag will be removed and the instantiator itself will be returned
2108 instead of the inst-pair.
2109 3. If there is only one instantiator, its value is nil, and its tag is
2110 'any, a one-element list containing nil will be returned rather
2111 than just nil, to distinguish this case from there being no
2112 instantiators at all.
2114 (specifier, locale, tag_set, exact_p))
2116 if (!NILP (Fvalid_specifier_locale_p (locale)) ||
2117 (CONSP (locale) && !NILP (Fvalid_specifier_locale_p (XCAR (locale))) &&
2118 NILP (XCDR (locale))))
2120 struct gcpro gcpro1;
2122 CHECK_SPECIFIER (specifier);
2124 locale = XCAR (locale);
2126 tag_set = decode_specifier_tag_set (tag_set);
2127 tag_set = canonicalize_tag_set (tag_set);
2129 (specifier_get_external_inst_list (specifier, locale,
2130 locale_type_from_locale (locale),
2131 tag_set, !NILP (exact_p), 1, 1));
2134 return Fspecifier_spec_list (specifier, locale, tag_set, exact_p);
2138 remove_specifier_mapfun (Lisp_Object specifier,
2140 enum spec_locale_type locale_type,
2141 Lisp_Object tag_set,
2143 void *ignored_closure)
2146 specifier_remove_locale_type (specifier, locale_type, tag_set, exact_p);
2148 specifier_remove_spec (specifier, locale, locale_type, tag_set, exact_p);
2152 DEFUN ("remove-specifier", Fremove_specifier, 1, 4, 0, /*
2153 Remove specification(s) for SPECIFIER.
2155 If LOCALE is a particular locale (a window, buffer, frame, device,
2156 or 'global), the specification for that locale will be removed.
2158 If instead, LOCALE is a locale type (i.e. 'window, 'buffer, 'frame,
2159 or 'device), the specifications for all locales of that type will be
2162 If LOCALE is nil or 'all, all specifications will be removed.
2164 LOCALE can also be a list of locales, locale types, and/or 'all; this
2165 is equivalent to calling `remove-specifier' for each of the elements
2168 Only instantiators where TAG-SET (a list of zero or more tags) is a
2169 subset of (or possibly equal to) the instantiator's tag set are removed.
2170 The default value of nil is a subset of all tag sets, so in this case
2171 no instantiators will be screened out. If EXACT-P is non-nil, however,
2172 TAG-SET must be equal to an instantiator's tag set for the instantiator
2175 (specifier, locale, tag_set, exact_p))
2177 CHECK_SPECIFIER (specifier);
2178 check_modifiable_specifier (specifier);
2180 map_specifier (specifier, locale, remove_specifier_mapfun,
2181 tag_set, exact_p, 0);
2182 recompute_cached_specifier_everywhere (specifier);
2187 remove_ghost_specifier (Lisp_Object specifier, Lisp_Object locale,
2188 Lisp_Object tag_set, Lisp_Object exact_p)
2190 int depth = unlock_ghost_specifiers_protected ();
2191 Fremove_specifier (XSPECIFIER(specifier)->fallback,
2192 locale, tag_set, exact_p);
2193 unbind_to (depth, Qnil);
2196 struct copy_specifier_closure
2199 enum spec_add_meth add_meth;
2200 int add_meth_is_nil;
2204 copy_specifier_mapfun (Lisp_Object specifier,
2206 enum spec_locale_type locale_type,
2207 Lisp_Object tag_set,
2211 struct copy_specifier_closure *cl =
2212 (struct copy_specifier_closure *) closure;
2215 specifier_copy_locale_type (specifier, cl->dest, locale_type,
2217 cl->add_meth_is_nil ?
2218 SPEC_REMOVE_LOCALE_TYPE :
2221 specifier_copy_spec (specifier, cl->dest, locale, locale_type,
2223 cl->add_meth_is_nil ? SPEC_REMOVE_LOCALE :
2228 DEFUN ("copy-specifier", Fcopy_specifier, 1, 6, 0, /*
2229 Copy SPECIFIER to DEST, or create a new one if DEST is nil.
2231 If DEST is nil or omitted, a new specifier will be created and the
2232 specifications copied into it. Otherwise, the specifications will be
2233 copied into the existing specifier in DEST.
2235 If LOCALE is nil or 'all, all specifications will be copied. If LOCALE
2236 is a particular locale, the specification for that particular locale will
2237 be copied. If LOCALE is a locale type, the specifications for all locales
2238 of that type will be copied. LOCALE can also be a list of locales,
2239 locale types, and/or 'all; this is equivalent to calling `copy-specifier'
2240 for each of the elements of the list. See `specifier-spec-list' for more
2241 information about LOCALE.
2243 Only instantiators where TAG-SET (a list of zero or more tags) is a
2244 subset of (or possibly equal to) the instantiator's tag set are copied.
2245 The default value of nil is a subset of all tag sets, so in this case
2246 no instantiators will be screened out. If EXACT-P is non-nil, however,
2247 TAG-SET must be equal to an instantiator's tag set for the instantiator
2250 Optional argument HOW-TO-ADD specifies what to do with existing
2251 specifications in DEST. If nil, then whichever locales or locale types
2252 are copied will first be completely erased in DEST. Otherwise, it is
2253 the same as in `add-spec-to-specifier'.
2255 (specifier, dest, locale, tag_set, exact_p, how_to_add))
2257 struct gcpro gcpro1;
2258 struct copy_specifier_closure cl;
2260 CHECK_SPECIFIER (specifier);
2261 if (NILP (how_to_add))
2262 cl.add_meth_is_nil = 1;
2264 cl.add_meth_is_nil = 0;
2265 cl.add_meth = decode_how_to_add_specification (how_to_add);
2268 /* #### What about copying the extra data? */
2269 dest = make_specifier (XSPECIFIER (specifier)->methods);
2273 CHECK_SPECIFIER (dest);
2274 check_modifiable_specifier (dest);
2275 if (XSPECIFIER (dest)->methods != XSPECIFIER (specifier)->methods)
2276 error ("Specifiers not of same type");
2281 map_specifier (specifier, locale, copy_specifier_mapfun,
2282 tag_set, exact_p, &cl);
2284 recompute_cached_specifier_everywhere (dest);
2289 /************************************************************************/
2291 /************************************************************************/
2294 call_validate_matchspec_method (Lisp_Object boxed_method,
2295 Lisp_Object matchspec)
2297 ((void (*)(Lisp_Object)) get_opaque_ptr (boxed_method)) (matchspec);
2302 check_valid_specifier_matchspec (Lisp_Object matchspec,
2303 struct specifier_methods *meths,
2304 Error_behavior errb)
2306 if (meths->validate_matchspec_method)
2310 if (ERRB_EQ (errb, ERROR_ME))
2312 (meths->validate_matchspec_method) (matchspec);
2317 Lisp_Object opaque =
2318 make_opaque_ptr ((void *) meths->validate_matchspec_method);
2319 struct gcpro gcpro1;
2322 retval = call_with_suspended_errors
2323 ((lisp_fn_t) call_validate_matchspec_method,
2324 Qnil, Qspecifier, errb, 2, opaque, matchspec);
2326 free_opaque_ptr (opaque);
2334 maybe_signal_simple_error
2335 ("Matchspecs not allowed for this specifier type",
2336 intern (meths->name), Qspecifier, errb);
2341 DEFUN ("check-valid-specifier-matchspec", Fcheck_valid_specifier_matchspec, 2, 2, 0, /*
2342 Signal an error if MATCHSPEC is invalid for SPECIFIER-TYPE.
2343 See `specifier-matching-instance' for a description of matchspecs.
2345 (matchspec, specifier_type))
2347 struct specifier_methods *meths = decode_specifier_type (specifier_type,
2350 return check_valid_specifier_matchspec (matchspec, meths, ERROR_ME);
2353 DEFUN ("valid-specifier-matchspec-p", Fvalid_specifier_matchspec_p, 2, 2, 0, /*
2354 Return non-nil if MATCHSPEC is valid for SPECIFIER-TYPE.
2355 See `specifier-matching-instance' for a description of matchspecs.
2357 (matchspec, specifier_type))
2359 struct specifier_methods *meths = decode_specifier_type (specifier_type,
2362 return check_valid_specifier_matchspec (matchspec, meths, ERROR_ME_NOT);
2365 /* This function is purposely not callable from Lisp. If a Lisp
2366 caller wants to set a fallback, they should just set the
2370 set_specifier_fallback (Lisp_Object specifier, Lisp_Object fallback)
2372 struct Lisp_Specifier *sp = XSPECIFIER (specifier);
2373 assert (SPECIFIERP (fallback) ||
2374 !NILP (Fvalid_inst_list_p (fallback, Fspecifier_type (specifier))));
2375 if (SPECIFIERP (fallback))
2376 assert (EQ (Fspecifier_type (specifier), Fspecifier_type (fallback)));
2377 if (BODILY_SPECIFIER_P (sp))
2378 GHOST_SPECIFIER(sp)->fallback = fallback;
2380 sp->fallback = fallback;
2381 /* call the after-change method */
2382 MAYBE_SPECMETH (sp, after_change,
2383 (bodily_specifier (specifier), Qfallback));
2384 recompute_cached_specifier_everywhere (specifier);
2387 DEFUN ("specifier-fallback", Fspecifier_fallback, 1, 1, 0, /*
2388 Return the fallback value for SPECIFIER.
2389 Fallback values are provided by the C code for certain built-in
2390 specifiers to make sure that instancing won't fail even if all
2391 specs are removed from the specifier, or to implement simple
2392 inheritance behavior (e.g. this method is used to ensure that
2393 faces other than 'default inherit their attributes from 'default).
2394 By design, you cannot change the fallback value, and specifiers
2395 created with `make-specifier' will never have a fallback (although
2396 a similar, Lisp-accessible capability may be provided in the future
2397 to allow for inheritance).
2399 The fallback value will be an inst-list that is instanced like
2400 any other inst-list, a specifier of the same type as SPECIFIER
2401 \(results in inheritance), or nil for no fallback.
2403 When you instance a specifier, you can explicitly request that the
2404 fallback not be consulted. (The C code does this, for example, when
2405 merging faces.) See `specifier-instance'.
2409 CHECK_SPECIFIER (specifier);
2410 return Fcopy_tree (XSPECIFIER (specifier)->fallback, Qt);
2414 specifier_instance_from_inst_list (Lisp_Object specifier,
2415 Lisp_Object matchspec,
2417 Lisp_Object inst_list,
2418 Error_behavior errb, int no_quit,
2421 /* This function can GC */
2422 struct Lisp_Specifier *sp;
2425 int count = specpdl_depth ();
2426 struct gcpro gcpro1, gcpro2;
2428 GCPRO2 (specifier, inst_list);
2430 sp = XSPECIFIER (specifier);
2431 device = DFW_DEVICE (domain);
2434 /* The instantiate method is allowed to call eval. Since it
2435 is quite common for this function to get called from somewhere in
2436 redisplay we need to make sure that quits are ignored. Otherwise
2437 Fsignal will abort. */
2438 specbind (Qinhibit_quit, Qt);
2440 LIST_LOOP (rest, inst_list)
2442 Lisp_Object tagged_inst = XCAR (rest);
2443 Lisp_Object tag_set = XCAR (tagged_inst);
2445 if (device_matches_specifier_tag_set_p (device, tag_set))
2447 Lisp_Object val = XCDR (tagged_inst);
2449 if (HAS_SPECMETH_P (sp, instantiate))
2450 val = call_with_suspended_errors
2451 ((lisp_fn_t) RAW_SPECMETH (sp, instantiate),
2452 Qunbound, Qspecifier, errb, 5, specifier,
2453 matchspec, domain, val, depth);
2455 if (!UNBOUNDP (val))
2457 unbind_to (count, Qnil);
2464 unbind_to (count, Qnil);
2469 /* Given a SPECIFIER and a DOMAIN, return a specific instance for that
2470 specifier. Try to find one by checking the specifier types from most
2471 specific (buffer) to most general (global). If we find an instance,
2472 return it. Otherwise return Qunbound. */
2474 #define CHECK_INSTANCE_ENTRY(key, matchspec, type) do { \
2475 Lisp_Object *CIE_inst_list = \
2476 specifier_get_inst_list (specifier, key, type); \
2477 if (CIE_inst_list) \
2479 Lisp_Object CIE_val = \
2480 specifier_instance_from_inst_list (specifier, matchspec, \
2481 domain, *CIE_inst_list, \
2482 errb, no_quit, depth); \
2483 if (!UNBOUNDP (CIE_val)) \
2488 /* We accept any window, frame or device domain and do our checking
2489 starting from as specific a locale type as we can determine from the
2490 domain we are passed and going on up through as many other locale types
2491 as we can determine. In practice, when called from redisplay the
2492 arg will usually be a window and occasionally a frame. If
2493 triggered by a user call, who knows what it will usually be. */
2495 specifier_instance (Lisp_Object specifier, Lisp_Object matchspec,
2496 Lisp_Object domain, Error_behavior errb, int no_quit,
2497 int no_fallback, Lisp_Object depth)
2499 Lisp_Object buffer = Qnil;
2500 Lisp_Object window = Qnil;
2501 Lisp_Object frame = Qnil;
2502 Lisp_Object device = Qnil;
2503 Lisp_Object tag = Qnil;
2505 struct Lisp_Specifier *sp;
2507 sp = XSPECIFIER (specifier);
2509 /* Attempt to determine buffer, window, frame, and device from the
2511 if (WINDOWP (domain))
2513 else if (FRAMEP (domain))
2515 else if (DEVICEP (domain))
2518 /* #### dmoore - dammit, this should just signal an error or something
2520 #### No. Errors are handled in Lisp primitives implementation.
2521 Invalid domain is a design error here - kkm. */
2524 if (NILP (buffer) && !NILP (window))
2525 buffer = XWINDOW (window)->buffer;
2526 if (NILP (frame) && !NILP (window))
2527 frame = XWINDOW (window)->frame;
2529 /* frame had better exist; if device is undeterminable, something
2530 really went wrong. */
2531 device = XFRAME (frame)->device;
2533 /* device had better be determined by now; abort if not. */
2534 d = XDEVICE (device);
2535 tag = DEVICE_CLASS (d);
2537 depth = make_int (1 + XINT (depth));
2538 if (XINT (depth) > 20)
2540 maybe_error (Qspecifier, errb, "Apparent loop in specifier inheritance");
2541 /* The specification is fucked; at least try the fallback
2542 (which better not be fucked, because it's not changeable
2549 /* First see if we can generate one from the window specifiers. */
2551 CHECK_INSTANCE_ENTRY (window, matchspec, LOCALE_WINDOW);
2553 /* Next see if we can generate one from the buffer specifiers. */
2555 CHECK_INSTANCE_ENTRY (buffer, matchspec, LOCALE_BUFFER);
2557 /* Next see if we can generate one from the frame specifiers. */
2559 CHECK_INSTANCE_ENTRY (frame, matchspec, LOCALE_FRAME);
2561 /* If we still haven't succeeded try with the device specifiers. */
2562 CHECK_INSTANCE_ENTRY (device, matchspec, LOCALE_DEVICE);
2564 /* Last and least try the global specifiers. */
2565 CHECK_INSTANCE_ENTRY (Qglobal, matchspec, LOCALE_GLOBAL);
2568 /* We're out of specifiers and we still haven't generated an
2569 instance. At least try the fallback ... If this fails,
2570 then we just return Qunbound. */
2572 if (no_fallback || NILP (sp->fallback))
2573 /* I said, I don't want the fallbacks. */
2576 if (SPECIFIERP (sp->fallback))
2578 /* If you introduced loops in the default specifier chain,
2579 then you're fucked, so you better not do this. */
2580 specifier = sp->fallback;
2581 sp = XSPECIFIER (specifier);
2585 assert (CONSP (sp->fallback));
2586 return specifier_instance_from_inst_list (specifier, matchspec, domain,
2587 sp->fallback, errb, no_quit,
2590 #undef CHECK_INSTANCE_ENTRY
2593 specifier_instance_no_quit (Lisp_Object specifier, Lisp_Object matchspec,
2594 Lisp_Object domain, Error_behavior errb,
2595 int no_fallback, Lisp_Object depth)
2597 return specifier_instance (specifier, matchspec, domain, errb,
2598 1, no_fallback, depth);
2601 DEFUN ("specifier-instance", Fspecifier_instance, 1, 4, 0, /*
2602 Instantiate SPECIFIER (return its value) in DOMAIN.
2603 If no instance can be generated for this domain, return DEFAULT.
2605 DOMAIN should be a window, frame, or device. Other values that are legal
2606 as a locale (e.g. a buffer) are not valid as a domain because they do not
2607 provide enough information to identify a particular device (see
2608 `valid-specifier-domain-p'). DOMAIN defaults to the selected window
2611 "Instantiating" a specifier in a particular domain means determining
2612 the specifier's "value" in that domain. This is accomplished by
2613 searching through the specifications in the specifier that correspond
2614 to all locales that can be derived from the given domain, from specific
2615 to general. In most cases, the domain is an Emacs window. In that case
2616 specifications are searched for as follows:
2618 1. A specification whose locale is the window itself;
2619 2. A specification whose locale is the window's buffer;
2620 3. A specification whose locale is the window's frame;
2621 4. A specification whose locale is the window's frame's device;
2622 5. A specification whose locale is 'global.
2624 If all of those fail, then the C-code-provided fallback value for
2625 this specifier is consulted (see `specifier-fallback'). If it is
2626 an inst-list, then this function attempts to instantiate that list
2627 just as when a specification is located in the first five steps above.
2628 If the fallback is a specifier, `specifier-instance' is called
2629 recursively on this specifier and the return value used. Note,
2630 however, that if the optional argument NO-FALLBACK is non-nil,
2631 the fallback value will not be consulted.
2633 Note that there may be more than one specification matching a particular
2634 locale; all such specifications are considered before looking for any
2635 specifications for more general locales. Any particular specification
2636 that is found may be rejected because its tag set does not match the
2637 device being instantiated over, or because the specification is not
2638 valid for the device of the given domain (e.g. the font or color name
2639 does not exist for this particular X server).
2641 The returned value is dependent on the type of specifier. For example,
2642 for a font specifier (as returned by the `face-font' function), the returned
2643 value will be a font-instance object. For glyphs, the returned value
2644 will be a string, pixmap, or subwindow.
2646 See also `specifier-matching-instance'.
2648 (specifier, domain, default_, no_fallback))
2650 Lisp_Object instance;
2652 CHECK_SPECIFIER (specifier);
2653 domain = decode_domain (domain);
2655 instance = specifier_instance (specifier, Qunbound, domain, ERROR_ME, 0,
2656 !NILP (no_fallback), Qzero);
2657 return UNBOUNDP (instance) ? default_ : instance;
2660 DEFUN ("specifier-matching-instance", Fspecifier_matching_instance, 2, 5, 0, /*
2661 Return an instance for SPECIFIER in DOMAIN that matches MATCHSPEC.
2662 If no instance can be generated for this domain, return DEFAULT.
2664 This function is identical to `specifier-instance' except that a
2665 specification will only be considered if it matches MATCHSPEC.
2666 The definition of "match", and allowed values for MATCHSPEC, are
2667 dependent on the particular type of specifier. Here are some examples:
2669 -- For chartable (e.g. display table) specifiers, MATCHSPEC should be a
2670 character, and the specification (a chartable) must give a value for
2671 that character in order to be considered. This allows you to specify,
2672 e.g., a buffer-local display table that only gives values for particular
2673 characters. All other characters are handled as if the buffer-local
2674 display table is not there. (Chartable specifiers are not yet
2677 -- For font specifiers, MATCHSPEC should be a charset, and the specification
2678 (a font string) must have a registry that matches the charset's registry.
2679 (This only makes sense with Mule support.) This makes it easy to choose a
2680 font that can display a particular character. (This is what redisplay
2683 (specifier, matchspec, domain, default_, no_fallback))
2685 Lisp_Object instance;
2687 CHECK_SPECIFIER (specifier);
2688 check_valid_specifier_matchspec (matchspec, XSPECIFIER (specifier)->methods,
2690 domain = decode_domain (domain);
2692 instance = specifier_instance (specifier, matchspec, domain, ERROR_ME,
2693 0, !NILP (no_fallback), Qzero);
2694 return UNBOUNDP (instance) ? default_ : instance;
2697 DEFUN ("specifier-instance-from-inst-list", Fspecifier_instance_from_inst_list,
2699 Attempt to convert a particular inst-list into an instance.
2700 This attempts to instantiate INST-LIST in the given DOMAIN,
2701 as if INST-LIST existed in a specification in SPECIFIER. If
2702 the instantiation fails, DEFAULT is returned. In most circumstances,
2703 you should not use this function; use `specifier-instance' instead.
2705 (specifier, domain, inst_list, default_))
2707 Lisp_Object val = Qunbound;
2708 struct Lisp_Specifier *sp = XSPECIFIER (specifier);
2709 struct gcpro gcpro1;
2710 Lisp_Object built_up_list = Qnil;
2712 CHECK_SPECIFIER (specifier);
2713 check_valid_domain (domain);
2714 check_valid_inst_list (inst_list, sp->methods, ERROR_ME);
2715 GCPRO1 (built_up_list);
2716 built_up_list = build_up_processed_list (specifier, domain, inst_list);
2717 if (!NILP (built_up_list))
2718 val = specifier_instance_from_inst_list (specifier, Qunbound, domain,
2719 built_up_list, ERROR_ME,
2722 return UNBOUNDP (val) ? default_ : val;
2725 DEFUN ("specifier-matching-instance-from-inst-list", Fspecifier_matching_instance_from_inst_list,
2727 Attempt to convert a particular inst-list into an instance.
2728 This attempts to instantiate INST-LIST in the given DOMAIN
2729 \(as if INST-LIST existed in a specification in SPECIFIER),
2730 matching the specifications against MATCHSPEC.
2732 This function is analogous to `specifier-instance-from-inst-list'
2733 but allows for specification-matching as in `specifier-matching-instance'.
2734 See that function for a description of exactly how the matching process
2737 (specifier, matchspec, domain, inst_list, default_))
2739 Lisp_Object val = Qunbound;
2740 struct Lisp_Specifier *sp = XSPECIFIER (specifier);
2741 struct gcpro gcpro1;
2742 Lisp_Object built_up_list = Qnil;
2744 CHECK_SPECIFIER (specifier);
2745 check_valid_specifier_matchspec (matchspec, XSPECIFIER (specifier)->methods,
2747 check_valid_domain (domain);
2748 check_valid_inst_list (inst_list, sp->methods, ERROR_ME);
2749 GCPRO1 (built_up_list);
2750 built_up_list = build_up_processed_list (specifier, domain, inst_list);
2751 if (!NILP (built_up_list))
2752 val = specifier_instance_from_inst_list (specifier, matchspec, domain,
2753 built_up_list, ERROR_ME,
2756 return UNBOUNDP (val) ? default_ : val;
2760 /************************************************************************/
2761 /* Caching in the struct window or frame */
2762 /************************************************************************/
2764 /* Either STRUCT_WINDOW_OFFSET or STRUCT_FRAME_OFFSET can be 0 to indicate
2765 no caching in that sort of object. */
2767 /* #### It would be nice if the specifier caching automatically knew
2768 about specifier fallbacks, so we didn't have to do it ourselves. */
2771 set_specifier_caching (Lisp_Object specifier, int struct_window_offset,
2772 void (*value_changed_in_window)
2773 (Lisp_Object specifier, struct window *w,
2774 Lisp_Object oldval),
2775 int struct_frame_offset,
2776 void (*value_changed_in_frame)
2777 (Lisp_Object specifier, struct frame *f,
2778 Lisp_Object oldval))
2780 struct Lisp_Specifier *sp = XSPECIFIER (specifier);
2781 assert (!GHOST_SPECIFIER_P (sp));
2784 sp->caching = xnew_and_zero (struct specifier_caching);
2785 sp->caching->offset_into_struct_window = struct_window_offset;
2786 sp->caching->value_changed_in_window = value_changed_in_window;
2787 sp->caching->offset_into_struct_frame = struct_frame_offset;
2788 sp->caching->value_changed_in_frame = value_changed_in_frame;
2789 Vcached_specifiers = Fcons (specifier, Vcached_specifiers);
2790 if (BODILY_SPECIFIER_P (sp))
2791 GHOST_SPECIFIER(sp)->caching = sp->caching;
2792 recompute_cached_specifier_everywhere (specifier);
2796 recompute_one_cached_specifier_in_window (Lisp_Object specifier,
2800 Lisp_Object newval, *location;
2802 assert (!GHOST_SPECIFIER_P (XSPECIFIER (specifier)));
2804 XSETWINDOW (window, w);
2806 newval = specifier_instance (specifier, Qunbound, window, ERROR_ME_WARN,
2808 /* If newval ended up Qunbound, then the calling functions
2809 better be able to deal. If not, set a default so this
2810 never happens or correct it in the value_changed_in_window
2812 location = (Lisp_Object *)
2813 ((char *) w + XSPECIFIER (specifier)->caching->offset_into_struct_window);
2814 if (!EQ (newval, *location))
2816 Lisp_Object oldval = *location;
2818 (XSPECIFIER (specifier)->caching->value_changed_in_window)
2819 (specifier, w, oldval);
2824 recompute_one_cached_specifier_in_frame (Lisp_Object specifier,
2828 Lisp_Object newval, *location;
2830 assert (!GHOST_SPECIFIER_P (XSPECIFIER (specifier)));
2832 XSETFRAME (frame, f);
2834 newval = specifier_instance (specifier, Qunbound, frame, ERROR_ME_WARN,
2836 /* If newval ended up Qunbound, then the calling functions
2837 better be able to deal. If not, set a default so this
2838 never happens or correct it in the value_changed_in_frame
2840 location = (Lisp_Object *)
2841 ((char *) f + XSPECIFIER (specifier)->caching->offset_into_struct_frame);
2842 if (!EQ (newval, *location))
2844 Lisp_Object oldval = *location;
2846 (XSPECIFIER (specifier)->caching->value_changed_in_frame)
2847 (specifier, f, oldval);
2852 recompute_all_cached_specifiers_in_window (struct window *w)
2856 LIST_LOOP (rest, Vcached_specifiers)
2858 Lisp_Object specifier = XCAR (rest);
2859 if (XSPECIFIER (specifier)->caching->offset_into_struct_window)
2860 recompute_one_cached_specifier_in_window (specifier, w);
2865 recompute_all_cached_specifiers_in_frame (struct frame *f)
2869 LIST_LOOP (rest, Vcached_specifiers)
2871 Lisp_Object specifier = XCAR (rest);
2872 if (XSPECIFIER (specifier)->caching->offset_into_struct_frame)
2873 recompute_one_cached_specifier_in_frame (specifier, f);
2878 recompute_cached_specifier_everywhere_mapfun (struct window *w,
2881 Lisp_Object specifier = Qnil;
2883 VOID_TO_LISP (specifier, closure);
2884 recompute_one_cached_specifier_in_window (specifier, w);
2889 recompute_cached_specifier_everywhere (Lisp_Object specifier)
2891 Lisp_Object frmcons, devcons, concons;
2893 specifier = bodily_specifier (specifier);
2895 if (!XSPECIFIER (specifier)->caching)
2898 if (XSPECIFIER (specifier)->caching->offset_into_struct_window)
2900 FRAME_LOOP_NO_BREAK (frmcons, devcons, concons)
2901 map_windows (XFRAME (XCAR (frmcons)),
2902 recompute_cached_specifier_everywhere_mapfun,
2903 LISP_TO_VOID (specifier));
2906 if (XSPECIFIER (specifier)->caching->offset_into_struct_frame)
2908 FRAME_LOOP_NO_BREAK (frmcons, devcons, concons)
2909 recompute_one_cached_specifier_in_frame (specifier,
2910 XFRAME (XCAR (frmcons)));
2914 DEFUN ("set-specifier-dirty-flag", Fset_specifier_dirty_flag, 1, 1, 0, /*
2915 Force recomputation of any caches associated with SPECIFIER.
2916 Note that this automatically happens whenever you change a specification
2917 in SPECIFIER; you do not have to call this function then.
2918 One example of where this function is useful is when you have a
2919 toolbar button whose `active-p' field is an expression to be
2920 evaluated. Calling `set-specifier-dirty-flag' on the
2921 toolbar specifier will force the `active-p' fields to be
2926 CHECK_SPECIFIER (specifier);
2927 recompute_cached_specifier_everywhere (specifier);
2932 /************************************************************************/
2933 /* Generic specifier type */
2934 /************************************************************************/
2936 DEFINE_SPECIFIER_TYPE (generic);
2940 /* This is the string that used to be in `generic-specifier-p'.
2941 The idea is good, but it doesn't quite work in the form it's
2942 in. (One major problem is that validating an instantiator
2943 is supposed to require only that the specifier type is passed,
2944 while with this approach the actual specifier is needed.)
2946 What really needs to be done is to write a function
2947 `make-specifier-type' that creates new specifier types.
2948 #### I'll look into this for 19.14.
2951 "A generic specifier is a generalized kind of specifier with user-defined\n"
2952 "semantics. The instantiator can be any kind of Lisp object, and the\n"
2953 "instance computed from it is likewise any kind of Lisp object. The\n"
2954 "SPECIFIER-DATA should be an alist of methods governing how the specifier\n"
2955 "works. All methods are optional, and reasonable default methods will be\n"
2956 "provided. Currently there are two defined methods: 'instantiate and\n"
2959 "'instantiate specifies how to do the instantiation; if omitted, the\n"
2960 "instantiator itself is simply returned as the instance. The method\n"
2961 "should be a function that accepts three parameters (a specifier, the\n"
2962 "instantiator that matched the domain being instantiated over, and that\n"
2963 "domain), and should return a one-element list containing the instance,\n"
2964 "or nil if no instance exists. Note that the domain passed to this function\n"
2965 "is the domain being instantiated over, which may not be the same as the\n"
2966 "locale contained in the specification corresponding to the instantiator\n"
2967 "(for example, the domain being instantiated over could be a window, but\n"
2968 "the locale corresponding to the passed instantiator could be the window's\n"
2969 "buffer or frame).\n"
2971 "'validate specifies whether a given instantiator is valid; if omitted,\n"
2972 "all instantiators are considered valid. It should be a function of\n"
2973 "two arguments: an instantiator and a flag CAN-SIGNAL-ERROR. If this\n"
2974 "flag is false, the function must simply return t or nil indicating\n"
2975 "whether the instantiator is valid. If this flag is true, the function\n"
2976 "is free to signal an error if it encounters an invalid instantiator\n"
2977 "(this can be useful for issuing a specific error about exactly why the\n"
2978 "instantiator is valid). It can also return nil to indicate an invalid\n"
2979 "instantiator; in this case, a general error will be signalled."
2983 DEFUN ("generic-specifier-p", Fgeneric_specifier_p, 1, 1, 0, /*
2984 Return non-nil if OBJECT is a generic specifier.
2986 A generic specifier allows any kind of Lisp object as an instantiator,
2987 and returns back the Lisp object unchanged when it is instantiated.
2991 return GENERIC_SPECIFIERP (object) ? Qt : Qnil;
2995 /************************************************************************/
2996 /* Integer specifier type */
2997 /************************************************************************/
2999 DEFINE_SPECIFIER_TYPE (integer);
3002 integer_validate (Lisp_Object instantiator)
3004 CHECK_INT (instantiator);
3007 DEFUN ("integer-specifier-p", Finteger_specifier_p, 1, 1, 0, /*
3008 Return non-nil if OBJECT is an integer specifier.
3012 return INTEGER_SPECIFIERP (object) ? Qt : Qnil;
3015 /************************************************************************/
3016 /* Non-negative-integer specifier type */
3017 /************************************************************************/
3019 DEFINE_SPECIFIER_TYPE (natnum);
3022 natnum_validate (Lisp_Object instantiator)
3024 CHECK_NATNUM (instantiator);
3027 DEFUN ("natnum-specifier-p", Fnatnum_specifier_p, 1, 1, 0, /*
3028 Return non-nil if OBJECT is a natnum (non-negative-integer) specifier.
3032 return NATNUM_SPECIFIERP (object) ? Qt : Qnil;
3035 /************************************************************************/
3036 /* Boolean specifier type */
3037 /************************************************************************/
3039 DEFINE_SPECIFIER_TYPE (boolean);
3042 boolean_validate (Lisp_Object instantiator)
3044 if (!EQ (instantiator, Qt) && !EQ (instantiator, Qnil))
3045 signal_simple_error ("Must be t or nil", instantiator);
3048 DEFUN ("boolean-specifier-p", Fboolean_specifier_p, 1, 1, 0, /*
3049 Return non-nil if OBJECT is a boolean specifier.
3053 return BOOLEAN_SPECIFIERP (object) ? Qt : Qnil;
3056 /************************************************************************/
3057 /* Display table specifier type */
3058 /************************************************************************/
3060 DEFINE_SPECIFIER_TYPE (display_table);
3062 #define VALID_SINGLE_DISPTABLE_INSTANTIATOR_P(instantiator) \
3063 (VECTORP (instantiator) \
3064 || (CHAR_TABLEP (instantiator) \
3065 && (XCHAR_TABLE_TYPE (instantiator) == CHAR_TABLE_TYPE_CHAR \
3066 || XCHAR_TABLE_TYPE (instantiator) == CHAR_TABLE_TYPE_GENERIC)) \
3067 || RANGE_TABLEP (instantiator))
3070 display_table_validate (Lisp_Object instantiator)
3072 if (NILP (instantiator))
3075 else if (CONSP (instantiator))
3078 EXTERNAL_LIST_LOOP (tail, instantiator)
3080 Lisp_Object car = XCAR (tail);
3081 if (!VALID_SINGLE_DISPTABLE_INSTANTIATOR_P (car))
3087 if (!VALID_SINGLE_DISPTABLE_INSTANTIATOR_P (instantiator))
3090 dead_wrong_type_argument (display_table_specifier_methods->predicate_symbol,
3096 DEFUN ("display-table-specifier-p", Fdisplay_table_specifier_p, 1, 1, 0, /*
3097 Return non-nil if OBJECT is a display-table specifier.
3101 return DISPLAYTABLE_SPECIFIERP (object) ? Qt : Qnil;
3105 /************************************************************************/
3106 /* Initialization */
3107 /************************************************************************/
3110 syms_of_specifier (void)
3112 defsymbol (&Qspecifierp, "specifierp");
3114 defsymbol (&Qconsole_type, "console-type");
3115 defsymbol (&Qdevice_class, "device-class");
3117 /* Qinteger, Qboolean, Qgeneric defined in general.c */
3118 defsymbol (&Qnatnum, "natnum");
3120 DEFSUBR (Fvalid_specifier_type_p);
3121 DEFSUBR (Fspecifier_type_list);
3122 DEFSUBR (Fmake_specifier);
3123 DEFSUBR (Fspecifierp);
3124 DEFSUBR (Fspecifier_type);
3126 DEFSUBR (Fvalid_specifier_locale_p);
3127 DEFSUBR (Fvalid_specifier_domain_p);
3128 DEFSUBR (Fvalid_specifier_locale_type_p);
3129 DEFSUBR (Fspecifier_locale_type_from_locale);
3131 DEFSUBR (Fvalid_specifier_tag_p);
3132 DEFSUBR (Fvalid_specifier_tag_set_p);
3133 DEFSUBR (Fcanonicalize_tag_set);
3134 DEFSUBR (Fdevice_matches_specifier_tag_set_p);
3135 DEFSUBR (Fdefine_specifier_tag);
3136 DEFSUBR (Fdevice_matching_specifier_tag_list);
3137 DEFSUBR (Fspecifier_tag_list);
3138 DEFSUBR (Fspecifier_tag_predicate);
3140 DEFSUBR (Fcheck_valid_instantiator);
3141 DEFSUBR (Fvalid_instantiator_p);
3142 DEFSUBR (Fcheck_valid_inst_list);
3143 DEFSUBR (Fvalid_inst_list_p);
3144 DEFSUBR (Fcheck_valid_spec_list);
3145 DEFSUBR (Fvalid_spec_list_p);
3146 DEFSUBR (Fadd_spec_to_specifier);
3147 DEFSUBR (Fadd_spec_list_to_specifier);
3148 DEFSUBR (Fspecifier_spec_list);
3149 DEFSUBR (Fspecifier_specs);
3150 DEFSUBR (Fremove_specifier);
3151 DEFSUBR (Fcopy_specifier);
3153 DEFSUBR (Fcheck_valid_specifier_matchspec);
3154 DEFSUBR (Fvalid_specifier_matchspec_p);
3155 DEFSUBR (Fspecifier_fallback);
3156 DEFSUBR (Fspecifier_instance);
3157 DEFSUBR (Fspecifier_matching_instance);
3158 DEFSUBR (Fspecifier_instance_from_inst_list);
3159 DEFSUBR (Fspecifier_matching_instance_from_inst_list);
3160 DEFSUBR (Fset_specifier_dirty_flag);
3162 DEFSUBR (Fgeneric_specifier_p);
3163 DEFSUBR (Finteger_specifier_p);
3164 DEFSUBR (Fnatnum_specifier_p);
3165 DEFSUBR (Fboolean_specifier_p);
3166 DEFSUBR (Fdisplay_table_specifier_p);
3168 /* Symbols pertaining to specifier creation. Specifiers are created
3169 in the syms_of() functions. */
3171 /* locales are defined in general.c. */
3173 defsymbol (&Qprepend, "prepend");
3174 defsymbol (&Qappend, "append");
3175 defsymbol (&Qremove_tag_set_prepend, "remove-tag-set-prepend");
3176 defsymbol (&Qremove_tag_set_append, "remove-tag-set-append");
3177 defsymbol (&Qremove_locale, "remove-locale");
3178 defsymbol (&Qremove_locale_type, "remove-locale-type");
3179 defsymbol (&Qremove_all, "remove-all");
3181 defsymbol (&Qfallback, "fallback");
3185 specifier_type_create (void)
3187 the_specifier_type_entry_dynarr = Dynarr_new (specifier_type_entry);
3188 dumpstruct (&the_specifier_type_entry_dynarr, &sted_description);
3190 Vspecifier_type_list = Qnil;
3191 staticpro (&Vspecifier_type_list);
3193 INITIALIZE_SPECIFIER_TYPE (generic, "generic", "generic-specifier-p");
3195 INITIALIZE_SPECIFIER_TYPE (integer, "integer", "integer-specifier-p");
3197 SPECIFIER_HAS_METHOD (integer, validate);
3199 INITIALIZE_SPECIFIER_TYPE (natnum, "natnum", "natnum-specifier-p");
3201 SPECIFIER_HAS_METHOD (natnum, validate);
3203 INITIALIZE_SPECIFIER_TYPE (boolean, "boolean", "boolean-specifier-p");
3205 SPECIFIER_HAS_METHOD (boolean, validate);
3207 INITIALIZE_SPECIFIER_TYPE (display_table, "display-table", "display-table-p");
3209 SPECIFIER_HAS_METHOD (display_table, validate);
3213 reinit_specifier_type_create (void)
3215 REINITIALIZE_SPECIFIER_TYPE (generic);
3216 REINITIALIZE_SPECIFIER_TYPE (integer);
3217 REINITIALIZE_SPECIFIER_TYPE (natnum);
3218 REINITIALIZE_SPECIFIER_TYPE (boolean);
3219 REINITIALIZE_SPECIFIER_TYPE (display_table);
3223 vars_of_specifier (void)
3225 Vcached_specifiers = Qnil;
3226 staticpro (&Vcached_specifiers);
3228 /* Do NOT mark through this, or specifiers will never be GC'd.
3229 This is the same deal as for weak hash tables. */
3230 Vall_specifiers = Qnil;
3231 pdump_wire_list (&Vall_specifiers);
3233 Vuser_defined_tags = Qnil;
3234 staticpro (&Vuser_defined_tags);
3236 Vunlock_ghost_specifiers = Qnil;
3237 staticpro (&Vunlock_ghost_specifiers);