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 specifier_type_entry_dynarr *the_specifier_type_entry_dynarr;
69 static Lisp_Object Vspecifier_type_list;
71 static Lisp_Object Vcached_specifiers;
72 /* Do NOT mark through this, or specifiers will never be GC'd. */
73 static Lisp_Object Vall_specifiers;
75 static Lisp_Object Vunlock_ghost_specifiers;
77 /* #### The purpose of this is to check for inheritance loops
78 in specifiers that can inherit from other specifiers, but it's
81 #### Look into this for 19.14. */
82 /* static Lisp_Object_dynarr current_specifiers; */
84 static void recompute_cached_specifier_everywhere (Lisp_Object specifier);
86 EXFUN (Fspecifier_specs, 4);
87 EXFUN (Fremove_specifier, 4);
90 /************************************************************************/
91 /* Specifier object methods */
92 /************************************************************************/
94 /* Remove dead objects from the specified assoc list. */
97 cleanup_assoc_list (Lisp_Object list)
99 Lisp_Object loop, prev, retval;
101 loop = retval = list;
106 Lisp_Object entry = XCAR (loop);
107 Lisp_Object key = XCAR (entry);
109 /* remember, dead windows can become alive again. */
110 if (!WINDOWP (key) && object_dead_p (key))
114 /* Removing the head. */
115 retval = XCDR (retval);
119 Fsetcdr (prev, XCDR (loop));
131 /* Remove dead objects from the various lists so that they
132 don't keep getting marked as long as this specifier exists and
133 therefore wasting memory. */
136 cleanup_specifiers (void)
140 for (rest = Vall_specifiers;
142 rest = XSPECIFIER (rest)->next_specifier)
144 struct Lisp_Specifier *sp = XSPECIFIER (rest);
145 /* This effectively changes the specifier specs.
146 However, there's no need to call
147 recompute_cached_specifier_everywhere() or the
148 after-change methods because the only specs we
149 are removing are for dead objects, and they can
150 never have any effect on the specifier values:
151 specifiers can only be instantiated over live
152 objects, and you can't derive a dead object
154 sp->device_specs = cleanup_assoc_list (sp->device_specs);
155 sp->frame_specs = cleanup_assoc_list (sp->frame_specs);
156 sp->buffer_specs = cleanup_assoc_list (sp->buffer_specs);
157 /* windows are handled specially because dead windows
158 can be resurrected */
163 kill_specifier_buffer_locals (Lisp_Object buffer)
167 for (rest = Vall_specifiers;
169 rest = XSPECIFIER (rest)->next_specifier)
171 struct Lisp_Specifier *sp = XSPECIFIER (rest);
173 /* Make sure we're actually going to be changing something.
174 Fremove_specifier() always calls
175 recompute_cached_specifier_everywhere() (#### but should
176 be smarter about this). */
177 if (!NILP (assq_no_quit (buffer, sp->buffer_specs)))
178 Fremove_specifier (rest, buffer, Qnil, Qnil);
183 mark_specifier (Lisp_Object obj, void (*markobj) (Lisp_Object))
185 struct Lisp_Specifier *specifier = XSPECIFIER (obj);
187 markobj (specifier->global_specs);
188 markobj (specifier->device_specs);
189 markobj (specifier->frame_specs);
190 markobj (specifier->window_specs);
191 markobj (specifier->buffer_specs);
192 markobj (specifier->magic_parent);
193 markobj (specifier->fallback);
194 if (!GHOST_SPECIFIER_P (XSPECIFIER (obj)))
195 MAYBE_SPECMETH (specifier, mark, (obj, markobj));
199 /* The idea here is that the specifier specs point to locales
200 (windows, buffers, frames, and devices), and we want to make sure
201 that the specs disappear automatically when the associated locale
202 is no longer in use. For all but windows, "no longer in use"
203 corresponds exactly to when the object is deleted (non-deleted
204 objects are always held permanently in special lists, and deleted
205 objects are never on these lists and never reusable). To handle
206 this, we just have cleanup_specifiers() called periodically
207 (at the beginning of garbage collection); it removes all dead
210 For windows, however, it's trickier because dead objects can be
211 converted to live ones again if the dead object is in a window
212 configuration. Therefore, for windows, "no longer in use"
213 corresponds to when the window object is garbage-collected.
214 We now use weak lists for this purpose.
219 prune_specifiers (int (*obj_marked_p) (Lisp_Object))
221 Lisp_Object rest, prev = Qnil;
223 for (rest = Vall_specifiers;
225 rest = XSPECIFIER (rest)->next_specifier)
227 if (! obj_marked_p (rest))
229 struct Lisp_Specifier* sp = XSPECIFIER (rest);
230 /* A bit of assertion that we're removing both parts of the
231 magic one altogether */
232 assert (!GC_MAGIC_SPECIFIER_P(sp)
233 || (GC_BODILY_SPECIFIER_P(sp) && obj_marked_p (sp->fallback))
234 || (GC_GHOST_SPECIFIER_P(sp) && obj_marked_p (sp->magic_parent)));
235 /* This specifier is garbage. Remove it from the list. */
237 Vall_specifiers = sp->next_specifier;
239 XSPECIFIER (prev)->next_specifier = sp->next_specifier;
247 print_specifier (Lisp_Object obj, Lisp_Object printcharfun, int escapeflag)
249 struct Lisp_Specifier *sp = XSPECIFIER (obj);
251 int count = specpdl_depth ();
252 Lisp_Object the_specs;
255 error ("printing unreadable object #<%s-specifier 0x%x>",
256 sp->methods->name, sp->header.uid);
258 sprintf (buf, "#<%s-specifier global=", sp->methods->name);
259 write_c_string (buf, printcharfun);
260 specbind (Qprint_string_length, make_int (100));
261 specbind (Qprint_length, make_int (5));
262 the_specs = Fspecifier_specs (obj, Qglobal, Qnil, Qnil);
263 if (NILP (the_specs))
264 /* there are no global specs */
265 write_c_string ("<unspecified>", printcharfun);
267 print_internal (the_specs, printcharfun, 1);
268 if (!NILP (sp->fallback))
270 write_c_string (" fallback=", printcharfun);
271 print_internal (sp->fallback, printcharfun, escapeflag);
273 unbind_to (count, Qnil);
274 sprintf (buf, " 0x%x>", sp->header.uid);
275 write_c_string (buf, printcharfun);
279 finalize_specifier (void *header, int for_disksave)
281 struct Lisp_Specifier *sp = (struct Lisp_Specifier *) header;
282 /* don't be snafued by the disksave finalization. */
283 if (!for_disksave && !GC_GHOST_SPECIFIER_P(sp) && sp->caching)
291 specifier_equal (Lisp_Object obj1, Lisp_Object obj2, int depth)
293 struct Lisp_Specifier *s1 = XSPECIFIER (obj1);
294 struct Lisp_Specifier *s2 = XSPECIFIER (obj2);
296 Lisp_Object old_inhibit_quit = Vinhibit_quit;
298 /* This function can be called from within redisplay.
299 internal_equal can trigger a quit. That leads to Bad Things. */
304 (s1->methods == s2->methods &&
305 internal_equal (s1->global_specs, s2->global_specs, depth) &&
306 internal_equal (s1->device_specs, s2->device_specs, depth) &&
307 internal_equal (s1->frame_specs, s2->frame_specs, depth) &&
308 internal_equal (s1->window_specs, s2->window_specs, depth) &&
309 internal_equal (s1->buffer_specs, s2->buffer_specs, depth) &&
310 internal_equal (s1->fallback, s2->fallback, depth));
312 if (retval && HAS_SPECMETH_P (s1, equal))
313 retval = SPECMETH (s1, equal, (obj1, obj2, depth - 1));
315 Vinhibit_quit = old_inhibit_quit;
320 specifier_hash (Lisp_Object obj, int depth)
322 struct Lisp_Specifier *s = XSPECIFIER (obj);
324 /* specifier hashing is a bit problematic because there are so
325 many places where data can be stored. We pick what are perhaps
326 the most likely places where interesting stuff will be. */
327 return HASH5 ((HAS_SPECMETH_P (s, hash) ?
328 SPECMETH (s, hash, (obj, depth)) : 0),
329 (unsigned long) s->methods,
330 internal_hash (s->global_specs, depth + 1),
331 internal_hash (s->frame_specs, depth + 1),
332 internal_hash (s->buffer_specs, depth + 1));
336 sizeof_specifier (CONST void *header)
338 if (GHOST_SPECIFIER_P ((struct Lisp_Specifier *) header))
339 return sizeof (struct Lisp_Specifier);
342 CONST struct Lisp_Specifier *p = (CONST struct Lisp_Specifier *) header;
343 return sizeof (*p) + p->methods->extra_data_size - 1;
347 DEFINE_LRECORD_SEQUENCE_IMPLEMENTATION ("specifier", specifier,
348 mark_specifier, print_specifier,
350 specifier_equal, specifier_hash, 0,
352 struct Lisp_Specifier);
354 /************************************************************************/
355 /* Creating specifiers */
356 /************************************************************************/
358 static struct specifier_methods *
359 decode_specifier_type (Lisp_Object type, Error_behavior errb)
363 for (i = 0; i < Dynarr_length (the_specifier_type_entry_dynarr); i++)
365 if (EQ (type, Dynarr_at (the_specifier_type_entry_dynarr, i).symbol))
366 return Dynarr_at (the_specifier_type_entry_dynarr, i).meths;
369 maybe_signal_simple_error ("Invalid specifier type", type,
376 valid_specifier_type_p (Lisp_Object type)
378 return decode_specifier_type (type, ERROR_ME_NOT) != 0;
381 DEFUN ("valid-specifier-type-p", Fvalid_specifier_type_p, 1, 1, 0, /*
382 Given a SPECIFIER-TYPE, return non-nil if it is valid.
383 Valid types are 'generic, 'integer, boolean, 'color, 'font, 'image,
384 'face-boolean, and 'toolbar.
388 return valid_specifier_type_p (specifier_type) ? Qt : Qnil;
391 DEFUN ("specifier-type-list", Fspecifier_type_list, 0, 0, 0, /*
392 Return a list of valid specifier types.
396 return Fcopy_sequence (Vspecifier_type_list);
400 add_entry_to_specifier_type_list (Lisp_Object symbol,
401 struct specifier_methods *meths)
403 struct specifier_type_entry entry;
405 entry.symbol = symbol;
407 Dynarr_add (the_specifier_type_entry_dynarr, entry);
408 Vspecifier_type_list = Fcons (symbol, Vspecifier_type_list);
412 make_specifier_internal (struct specifier_methods *spec_meths,
413 size_t data_size, int call_create_meth)
415 Lisp_Object specifier;
416 struct Lisp_Specifier *sp = (struct Lisp_Specifier *)
417 alloc_lcrecord (sizeof (struct Lisp_Specifier) +
418 data_size - 1, &lrecord_specifier);
420 sp->methods = spec_meths;
421 sp->global_specs = Qnil;
422 sp->device_specs = Qnil;
423 sp->frame_specs = Qnil;
424 sp->window_specs = make_weak_list (WEAK_LIST_KEY_ASSOC);
425 sp->buffer_specs = Qnil;
427 sp->magic_parent = Qnil;
429 sp->next_specifier = Vall_specifiers;
431 XSETSPECIFIER (specifier, sp);
432 Vall_specifiers = specifier;
434 if (call_create_meth)
438 MAYBE_SPECMETH (XSPECIFIER (specifier), create, (specifier));
445 make_specifier (struct specifier_methods *meths)
447 return make_specifier_internal (meths, meths->extra_data_size, 1);
451 make_magic_specifier (Lisp_Object type)
453 /* This function can GC */
454 struct specifier_methods *meths = decode_specifier_type (type, ERROR_ME);
455 Lisp_Object bodily, ghost;
458 bodily = make_specifier (meths);
460 ghost = make_specifier_internal (meths, 0, 0);
463 /* Connect guys together */
464 XSPECIFIER(bodily)->magic_parent = Qt;
465 XSPECIFIER(bodily)->fallback = ghost;
466 XSPECIFIER(ghost)->magic_parent = bodily;
471 DEFUN ("make-specifier", Fmake_specifier, 1, 1, 0, /*
472 Return a new specifier object of type TYPE.
474 A specifier is an object that can be used to keep track of a property
475 whose value can be per-buffer, per-window, per-frame, or per-device,
476 and can further be restricted to a particular console-type or device-class.
477 Specifiers are used, for example, for the various built-in properties of a
478 face; this allows a face to have different values in different frames,
479 buffers, etc. For more information, see `specifier-instance',
480 `specifier-specs', and `add-spec-to-specifier'; or, for a detailed
481 description of specifiers, including how they are instantiated over a
482 particular domain (i.e. how their value in that domain is determined),
483 see the chapter on specifiers in the XEmacs Lisp Reference Manual.
485 TYPE specifies the particular type of specifier, and should be one of
486 the symbols 'generic, 'integer, 'boolean, 'color, 'font, 'image,
487 'face-boolean, or 'toolbar.
489 For more information on particular types of specifiers, see the functions
490 `generic-specifier-p', `integer-specifier-p', `boolean-specifier-p',
491 `color-specifier-p', `font-specifier-p', `image-specifier-p',
492 `face-boolean-specifier-p', and `toolbar-specifier-p'.
496 /* This function can GC */
497 struct specifier_methods *meths = decode_specifier_type (type,
500 return make_specifier (meths);
503 DEFUN ("specifierp", Fspecifierp, 1, 1, 0, /*
504 Return t if OBJECT is a specifier.
506 A specifier is an object that can be used to keep track of a property
507 whose value can be per-buffer, per-window, per-frame, or per-device,
508 and can further be restricted to a particular console-type or device-class.
509 See `make-specifier'.
513 return SPECIFIERP (object) ? Qt : Qnil;
516 DEFUN ("specifier-type", Fspecifier_type, 1, 1, 0, /*
517 Return the type of SPECIFIER.
521 CHECK_SPECIFIER (specifier);
522 return intern (XSPECIFIER (specifier)->methods->name);
526 /************************************************************************/
527 /* Locales and domains */
528 /************************************************************************/
530 DEFUN ("valid-specifier-locale-p", Fvalid_specifier_locale_p, 1, 1, 0, /*
531 Return t if LOCALE is a valid specifier locale.
532 Valid locales are devices, frames, windows, buffers, and 'global.
537 /* This cannot GC. */
538 return ((DEVICEP (locale) && DEVICE_LIVE_P (XDEVICE (locale))) ||
539 (FRAMEP (locale) && FRAME_LIVE_P (XFRAME (locale))) ||
540 (BUFFERP (locale) && BUFFER_LIVE_P (XBUFFER (locale))) ||
541 /* dead windows are allowed because they may become live
542 windows again when a window configuration is restored */
544 EQ (locale, Qglobal))
548 DEFUN ("valid-specifier-domain-p", Fvalid_specifier_domain_p, 1, 1, 0, /*
549 Return t if DOMAIN is a valid specifier domain.
550 A domain is used to instance a specifier (i.e. determine the specifier's
551 value in that domain). Valid domains are windows, frames, and devices.
556 /* This cannot GC. */
557 return ((DEVICEP (domain) && DEVICE_LIVE_P (XDEVICE (domain))) ||
558 (FRAMEP (domain) && FRAME_LIVE_P (XFRAME (domain))) ||
559 (WINDOWP (domain) && WINDOW_LIVE_P (XWINDOW (domain))))
563 DEFUN ("valid-specifier-locale-type-p", Fvalid_specifier_locale_type_p, 1, 1, 0, /*
564 Given a specifier LOCALE-TYPE, return non-nil if it is valid.
565 Valid locale types are 'global, 'device, 'frame, 'window, and 'buffer.
566 \(Note, however, that in functions that accept either a locale or a locale
567 type, 'global is considered an individual locale.)
571 /* This cannot GC. */
572 return (EQ (locale_type, Qglobal) ||
573 EQ (locale_type, Qdevice) ||
574 EQ (locale_type, Qframe) ||
575 EQ (locale_type, Qwindow) ||
576 EQ (locale_type, Qbuffer)) ? Qt : Qnil;
580 check_valid_locale_or_locale_type (Lisp_Object locale)
582 /* This cannot GC. */
583 if (EQ (locale, Qall) ||
584 !NILP (Fvalid_specifier_locale_p (locale)) ||
585 !NILP (Fvalid_specifier_locale_type_p (locale)))
587 signal_simple_error ("Invalid specifier locale or locale type", locale);
590 DEFUN ("specifier-locale-type-from-locale", Fspecifier_locale_type_from_locale,
592 Given a specifier LOCALE, return its type.
596 /* This cannot GC. */
597 if (NILP (Fvalid_specifier_locale_p (locale)))
598 signal_simple_error ("Invalid specifier locale", locale);
599 if (DEVICEP (locale)) return Qdevice;
600 if (FRAMEP (locale)) return Qframe;
601 if (WINDOWP (locale)) return Qwindow;
602 if (BUFFERP (locale)) return Qbuffer;
603 assert (EQ (locale, Qglobal));
608 decode_locale (Lisp_Object locale)
610 /* This cannot GC. */
613 else if (!NILP (Fvalid_specifier_locale_p (locale)))
616 signal_simple_error ("Invalid specifier locale", locale);
621 static enum spec_locale_type
622 decode_locale_type (Lisp_Object locale_type)
624 /* This cannot GC. */
625 if (EQ (locale_type, Qglobal)) return LOCALE_GLOBAL;
626 if (EQ (locale_type, Qdevice)) return LOCALE_DEVICE;
627 if (EQ (locale_type, Qframe)) return LOCALE_FRAME;
628 if (EQ (locale_type, Qwindow)) return LOCALE_WINDOW;
629 if (EQ (locale_type, Qbuffer)) return LOCALE_BUFFER;
631 signal_simple_error ("Invalid specifier locale type", locale_type);
632 return LOCALE_GLOBAL; /* not reached */
636 decode_locale_list (Lisp_Object locale)
638 /* This cannot GC. */
639 /* The return value of this function must be GCPRO'd. */
644 else if (CONSP (locale))
647 EXTERNAL_LIST_LOOP_2 (elt, locale)
648 check_valid_locale_or_locale_type (elt);
653 check_valid_locale_or_locale_type (locale);
654 return list1 (locale);
658 static enum spec_locale_type
659 locale_type_from_locale (Lisp_Object locale)
661 return decode_locale_type (Fspecifier_locale_type_from_locale (locale));
665 check_valid_domain (Lisp_Object domain)
667 if (NILP (Fvalid_specifier_domain_p (domain)))
668 signal_simple_error ("Invalid specifier domain", domain);
672 decode_domain (Lisp_Object domain)
675 return Fselected_window (Qnil);
676 check_valid_domain (domain);
681 /************************************************************************/
683 /************************************************************************/
685 DEFUN ("valid-specifier-tag-p", Fvalid_specifier_tag_p, 1, 1, 0, /*
686 Return non-nil if TAG is a valid specifier tag.
687 See also `valid-specifier-tag-set-p'.
691 return (valid_console_type_p (tag) ||
692 valid_device_class_p (tag) ||
693 !NILP (assq_no_quit (tag, Vuser_defined_tags))) ? Qt : Qnil;
696 DEFUN ("valid-specifier-tag-set-p", Fvalid_specifier_tag_set_p, 1, 1, 0, /*
697 Return non-nil if TAG-SET is a valid specifier tag set.
699 A specifier tag set is an entity that is attached to an instantiator
700 and can be used to restrict the scope of that instantiator to a
701 particular device class or device type and/or to mark instantiators
702 added by a particular package so that they can be later removed.
704 A specifier tag set consists of a list of zero of more specifier tags,
705 each of which is a symbol that is recognized by XEmacs as a tag.
706 \(The valid device types and device classes are always tags, as are
707 any tags defined by `define-specifier-tag'.) It is called a "tag set"
708 \(as opposed to a list) because the order of the tags or the number of
709 times a particular tag occurs does not matter.
711 Each tag has a predicate associated with it, which specifies whether
712 that tag applies to a particular device. The tags which are device types
713 and classes match devices of that type or class. User-defined tags can
714 have any predicate, or none (meaning that all devices match). When
715 attempting to instance a specifier, a particular instantiator is only
716 considered if the device of the domain being instanced over matches
717 all tags in the tag set attached to that instantiator.
719 Most of the time, a tag set is not specified, and the instantiator
720 gets a null tag set, which matches all devices.
726 for (rest = tag_set; !NILP (rest); rest = XCDR (rest))
730 if (NILP (Fvalid_specifier_tag_p (XCAR (rest))))
738 decode_specifier_tag_set (Lisp_Object tag_set)
740 /* The return value of this function must be GCPRO'd. */
741 if (!NILP (Fvalid_specifier_tag_p (tag_set)))
742 return list1 (tag_set);
743 if (NILP (Fvalid_specifier_tag_set_p (tag_set)))
744 signal_simple_error ("Invalid specifier tag-set", tag_set);
749 canonicalize_tag_set (Lisp_Object tag_set)
751 int len = XINT (Flength (tag_set));
752 Lisp_Object *tags, rest;
755 /* We assume in this function that the tag_set has already been
756 validated, so there are no surprises. */
758 if (len == 0 || len == 1)
759 /* most common case */
762 tags = alloca_array (Lisp_Object, len);
765 LIST_LOOP (rest, tag_set)
766 tags[i++] = XCAR (rest);
768 /* Sort the list of tags. We use a bubble sort here (copied from
769 extent_fragment_update()) -- reduces the function call overhead,
770 and is the fastest sort for small numbers of items. */
772 for (i = 1; i < len; i++)
776 strcmp ((char *) string_data (XSYMBOL (tags[j])->name),
777 (char *) string_data (XSYMBOL (tags[j+1])->name)) > 0)
779 Lisp_Object tmp = tags[j];
786 /* Now eliminate duplicates. */
788 for (i = 1, j = 1; i < len; i++)
790 /* j holds the destination, i the source. */
791 if (!EQ (tags[i], tags[i-1]))
795 return Flist (j, tags);
798 DEFUN ("canonicalize-tag-set", Fcanonicalize_tag_set, 1, 1, 0, /*
799 Canonicalize the given tag set.
800 Two canonicalized tag sets can be compared with `equal' to see if they
801 represent the same tag set. (Specifically, canonicalizing involves
802 sorting by symbol name and removing duplicates.)
806 if (NILP (Fvalid_specifier_tag_set_p (tag_set)))
807 signal_simple_error ("Invalid tag set", tag_set);
808 return canonicalize_tag_set (tag_set);
812 device_matches_specifier_tag_set_p (Lisp_Object device, Lisp_Object tag_set)
814 Lisp_Object devtype, devclass, rest;
815 struct device *d = XDEVICE (device);
817 devtype = DEVICE_TYPE (d);
818 devclass = DEVICE_CLASS (d);
820 LIST_LOOP (rest, tag_set)
822 Lisp_Object tag = XCAR (rest);
825 if (EQ (tag, devtype) || EQ (tag, devclass))
827 assoc = assq_no_quit (tag, DEVICE_USER_DEFINED_TAGS (d));
828 /* other built-in tags (device types/classes) are not in
829 the user-defined-tags list. */
830 if (NILP (assoc) || NILP (XCDR (assoc)))
837 DEFUN ("device-matches-specifier-tag-set-p", Fdevice_matches_specifier_tag_set_p, 2, 2, 0, /*
838 Return non-nil if DEVICE matches specifier tag set TAG-SET.
839 This means that DEVICE matches each tag in the tag set. (Every
840 tag recognized by XEmacs has a predicate associated with it that
841 specifies which devices match it.)
845 CHECK_LIVE_DEVICE (device);
847 if (NILP (Fvalid_specifier_tag_set_p (tag_set)))
848 signal_simple_error ("Invalid tag set", tag_set);
850 return device_matches_specifier_tag_set_p (device, tag_set) ? Qt : Qnil;
853 DEFUN ("define-specifier-tag", Fdefine_specifier_tag, 1, 2, 0, /*
854 Define a new specifier tag.
855 If PREDICATE is specified, it should be a function of one argument
856 \(a device) that specifies whether the tag matches that particular
857 device. If PREDICATE is omitted, the tag matches all devices.
859 You can redefine an existing user-defined specifier tag. However,
860 you cannot redefine the built-in specifier tags (the device types
861 and classes) or the symbols nil, t, 'all, or 'global.
865 Lisp_Object assoc, devcons, concons;
869 if (valid_device_class_p (tag) ||
870 valid_console_type_p (tag))
871 signal_simple_error ("Cannot redefine built-in specifier tags", tag);
872 /* Try to prevent common instantiators and locales from being
873 redefined, to reduce ambiguity */
874 if (NILP (tag) || EQ (tag, Qt) || EQ (tag, Qall) || EQ (tag, Qglobal))
875 signal_simple_error ("Cannot define nil, t, 'all, or 'global",
877 assoc = assq_no_quit (tag, Vuser_defined_tags);
881 Vuser_defined_tags = Fcons (Fcons (tag, predicate), Vuser_defined_tags);
882 DEVICE_LOOP_NO_BREAK (devcons, concons)
884 struct device *d = XDEVICE (XCAR (devcons));
885 /* Initially set the value to t in case of error
887 DEVICE_USER_DEFINED_TAGS (d) =
888 Fcons (Fcons (tag, Qt), DEVICE_USER_DEFINED_TAGS (d));
891 else if (!NILP (predicate) && !NILP (XCDR (assoc)))
894 XCDR (assoc) = predicate;
897 /* recompute the tag values for all devices. However, in the special
898 case where both the old and new predicates are nil, we know that
899 we don't have to do this. (It's probably common for people to
900 call (define-specifier-tag) more than once on the same tag,
901 and the most common case is where PREDICATE is not specified.) */
905 DEVICE_LOOP_NO_BREAK (devcons, concons)
907 Lisp_Object device = XCAR (devcons);
908 assoc = assq_no_quit (tag,
909 DEVICE_USER_DEFINED_TAGS (XDEVICE (device)));
910 assert (CONSP (assoc));
911 if (NILP (predicate))
914 XCDR (assoc) = !NILP (call1 (predicate, device)) ? Qt : Qnil;
921 /* Called at device-creation time to initialize the user-defined
922 tag values for the newly-created device. */
925 setup_device_initial_specifier_tags (struct device *d)
927 Lisp_Object rest, rest2;
930 XSETDEVICE (device, d);
932 DEVICE_USER_DEFINED_TAGS (d) = Fcopy_alist (Vuser_defined_tags);
934 /* Now set up the initial values */
935 LIST_LOOP (rest, DEVICE_USER_DEFINED_TAGS (d))
936 XCDR (XCAR (rest)) = Qt;
938 for (rest = Vuser_defined_tags, rest2 = DEVICE_USER_DEFINED_TAGS (d);
939 !NILP (rest); rest = XCDR (rest), rest2 = XCDR (rest2))
941 Lisp_Object predicate = XCDR (XCAR (rest));
942 if (NILP (predicate))
943 XCDR (XCAR (rest2)) = Qt;
945 XCDR (XCAR (rest2)) = !NILP (call1 (predicate, device)) ? Qt : Qnil;
949 DEFUN ("device-matching-specifier-tag-list", Fdevice_matching_specifier_tag_list,
951 Return a list of all specifier tags matching DEVICE.
952 DEVICE defaults to the selected device if omitted.
956 struct device *d = decode_device (device);
957 Lisp_Object rest, list = Qnil;
962 LIST_LOOP (rest, DEVICE_USER_DEFINED_TAGS (d))
964 if (!NILP (XCDR (XCAR (rest))))
965 list = Fcons (XCAR (XCAR (rest)), list);
968 list = Fnreverse (list);
969 list = Fcons (DEVICE_CLASS (d), list);
970 list = Fcons (DEVICE_TYPE (d), list);
972 RETURN_UNGCPRO (list);
975 DEFUN ("specifier-tag-list", Fspecifier_tag_list, 0, 0, 0, /*
976 Return a list of all currently-defined specifier tags.
977 This includes the built-in ones (the device types and classes).
981 Lisp_Object list = Qnil, rest;
986 LIST_LOOP (rest, Vuser_defined_tags)
987 list = Fcons (XCAR (XCAR (rest)), list);
989 list = Fnreverse (list);
990 list = nconc2 (Fcopy_sequence (Vdevice_class_list), list);
991 list = nconc2 (Fcopy_sequence (Vconsole_type_list), list);
993 RETURN_UNGCPRO (list);
996 DEFUN ("specifier-tag-predicate", Fspecifier_tag_predicate, 1, 1, 0, /*
997 Return the predicate for the given specifier tag.
1001 /* The return value of this function must be GCPRO'd. */
1004 if (NILP (Fvalid_specifier_tag_p (tag)))
1005 signal_simple_error ("Invalid specifier tag", tag);
1007 /* Make up some predicates for the built-in types */
1009 if (valid_console_type_p (tag))
1010 return list3 (Qlambda, list1 (Qdevice),
1011 list3 (Qeq, list2 (Qquote, tag),
1012 list2 (Qconsole_type, Qdevice)));
1014 if (valid_device_class_p (tag))
1015 return list3 (Qlambda, list1 (Qdevice),
1016 list3 (Qeq, list2 (Qquote, tag),
1017 list2 (Qdevice_class, Qdevice)));
1019 return XCDR (assq_no_quit (tag, Vuser_defined_tags));
1022 /* Return true if A "matches" B. If EXACT_P is 0, A must be a subset of B.
1023 Otherwise, A must be `equal' to B. The sets must be canonicalized. */
1025 tag_sets_match_p (Lisp_Object a, Lisp_Object b, int exact_p)
1029 while (!NILP (a) && !NILP (b))
1031 if (EQ (XCAR (a), XCAR (b)))
1040 while (!NILP (a) && !NILP (b))
1042 if (!EQ (XCAR (a), XCAR (b)))
1048 return NILP (a) && NILP (b);
1053 /************************************************************************/
1054 /* Spec-lists and inst-lists */
1055 /************************************************************************/
1058 call_validate_method (Lisp_Object boxed_method, Lisp_Object instantiator)
1060 ((void (*)(Lisp_Object)) get_opaque_ptr (boxed_method)) (instantiator);
1065 check_valid_instantiator (Lisp_Object instantiator,
1066 struct specifier_methods *meths,
1067 Error_behavior errb)
1069 if (meths->validate_method)
1073 if (ERRB_EQ (errb, ERROR_ME))
1075 (meths->validate_method) (instantiator);
1080 Lisp_Object opaque = make_opaque_ptr ((void *)
1081 meths->validate_method);
1082 struct gcpro gcpro1;
1085 retval = call_with_suspended_errors
1086 ((lisp_fn_t) call_validate_method,
1087 Qnil, Qspecifier, errb, 2, opaque, instantiator);
1089 free_opaque_ptr (opaque);
1098 DEFUN ("check-valid-instantiator", Fcheck_valid_instantiator, 2, 2, 0, /*
1099 Signal an error if INSTANTIATOR is invalid for SPECIFIER-TYPE.
1101 (instantiator, specifier_type))
1103 struct specifier_methods *meths = decode_specifier_type (specifier_type,
1106 return check_valid_instantiator (instantiator, meths, ERROR_ME);
1109 DEFUN ("valid-instantiator-p", Fvalid_instantiator_p, 2, 2, 0, /*
1110 Return non-nil if INSTANTIATOR is valid for SPECIFIER-TYPE.
1112 (instantiator, specifier_type))
1114 struct specifier_methods *meths = decode_specifier_type (specifier_type,
1117 return check_valid_instantiator (instantiator, meths, ERROR_ME_NOT);
1121 check_valid_inst_list (Lisp_Object inst_list, struct specifier_methods *meths,
1122 Error_behavior errb)
1126 LIST_LOOP (rest, inst_list)
1128 Lisp_Object inst_pair, tag_set;
1132 maybe_signal_simple_error ("Invalid instantiator list", inst_list,
1136 if (!CONSP (inst_pair = XCAR (rest)))
1138 maybe_signal_simple_error ("Invalid instantiator pair", inst_pair,
1142 if (NILP (Fvalid_specifier_tag_set_p (tag_set = XCAR (inst_pair))))
1144 maybe_signal_simple_error ("Invalid specifier tag", tag_set,
1149 if (NILP (check_valid_instantiator (XCDR (inst_pair), meths, errb)))
1156 DEFUN ("check-valid-inst-list", Fcheck_valid_inst_list, 2, 2, 0, /*
1157 Signal an error if INST-LIST is invalid for specifier type TYPE.
1161 struct specifier_methods *meths = decode_specifier_type (type, ERROR_ME);
1163 return check_valid_inst_list (inst_list, meths, ERROR_ME);
1166 DEFUN ("valid-inst-list-p", Fvalid_inst_list_p, 2, 2, 0, /*
1167 Return non-nil if INST-LIST is valid for specifier type TYPE.
1171 struct specifier_methods *meths = decode_specifier_type (type, ERROR_ME);
1173 return check_valid_inst_list (inst_list, meths, ERROR_ME_NOT);
1177 check_valid_spec_list (Lisp_Object spec_list, struct specifier_methods *meths,
1178 Error_behavior errb)
1182 LIST_LOOP (rest, spec_list)
1184 Lisp_Object spec, locale;
1185 if (!CONSP (rest) || !CONSP (spec = XCAR (rest)))
1187 maybe_signal_simple_error ("Invalid specification list", spec_list,
1191 if (NILP (Fvalid_specifier_locale_p (locale = XCAR (spec))))
1193 maybe_signal_simple_error ("Invalid specifier locale", locale,
1198 if (NILP (check_valid_inst_list (XCDR (spec), meths, errb)))
1205 DEFUN ("check-valid-spec-list", Fcheck_valid_spec_list, 2, 2, 0, /*
1206 Signal an error if SPEC-LIST is invalid for specifier type TYPE.
1210 struct specifier_methods *meths = decode_specifier_type (type, ERROR_ME);
1212 return check_valid_spec_list (spec_list, meths, ERROR_ME);
1215 DEFUN ("valid-spec-list-p", Fvalid_spec_list_p, 2, 2, 0, /*
1216 Return non-nil if SPEC-LIST is valid for specifier type TYPE.
1220 struct specifier_methods *meths = decode_specifier_type (type, ERROR_ME);
1222 return check_valid_spec_list (spec_list, meths, ERROR_ME_NOT);
1226 decode_how_to_add_specification (Lisp_Object how_to_add)
1228 if (NILP (how_to_add) || EQ (Qremove_tag_set_prepend, how_to_add))
1229 return SPEC_REMOVE_TAG_SET_PREPEND;
1230 if (EQ (Qremove_tag_set_append, how_to_add))
1231 return SPEC_REMOVE_TAG_SET_APPEND;
1232 if (EQ (Qappend, how_to_add))
1234 if (EQ (Qprepend, how_to_add))
1235 return SPEC_PREPEND;
1236 if (EQ (Qremove_locale, how_to_add))
1237 return SPEC_REMOVE_LOCALE;
1238 if (EQ (Qremove_locale_type, how_to_add))
1239 return SPEC_REMOVE_LOCALE_TYPE;
1240 if (EQ (Qremove_all, how_to_add))
1241 return SPEC_REMOVE_ALL;
1243 signal_simple_error ("Invalid `how-to-add' flag", how_to_add);
1245 return SPEC_PREPEND; /* not reached */
1248 /* Given a specifier object SPEC, return bodily specifier if SPEC is a
1249 ghost specifier, otherwise return the object itself
1252 bodily_specifier (Lisp_Object spec)
1254 return (GHOST_SPECIFIER_P (XSPECIFIER (spec))
1255 ? XSPECIFIER(spec)->magic_parent : spec);
1258 /* Signal error if (specifier SPEC is read-only.
1259 Read only are ghost specifiers unless Vunlock_ghost_specifiers is
1260 non-nil. All other specifiers are read-write.
1263 check_modifiable_specifier (Lisp_Object spec)
1265 if (NILP (Vunlock_ghost_specifiers)
1266 && GHOST_SPECIFIER_P (XSPECIFIER (spec)))
1267 signal_simple_error ("Attempt to modify read-only specifier",
1271 /* Helper function which unwind protects the value of
1272 Vunlock_ghost_specifiers, then sets it to non-nil value */
1274 restore_unlock_value (Lisp_Object val)
1276 Vunlock_ghost_specifiers = val;
1281 unlock_ghost_specifiers_protected (void)
1283 int depth = specpdl_depth ();
1284 record_unwind_protect (restore_unlock_value,
1285 Vunlock_ghost_specifiers);
1286 Vunlock_ghost_specifiers = Qt;
1290 /* This gets hit so much that the function call overhead had a
1291 measurable impact (according to Quantify). #### We should figure
1292 out the frequency with which this is called with the various types
1293 and reorder the check accordingly. */
1294 #define SPECIFIER_GET_SPEC_LIST(specifier, type) \
1295 (type == LOCALE_GLOBAL ? &(XSPECIFIER (specifier)->global_specs) : \
1296 type == LOCALE_DEVICE ? &(XSPECIFIER (specifier)->device_specs) : \
1297 type == LOCALE_FRAME ? &(XSPECIFIER (specifier)->frame_specs) : \
1298 type == LOCALE_WINDOW ? &(XWEAK_LIST_LIST \
1299 (XSPECIFIER (specifier)->window_specs)) : \
1300 type == LOCALE_BUFFER ? &(XSPECIFIER (specifier)->buffer_specs) : \
1303 static Lisp_Object *
1304 specifier_get_inst_list (Lisp_Object specifier, Lisp_Object locale,
1305 enum spec_locale_type type)
1307 Lisp_Object *spec_list = SPECIFIER_GET_SPEC_LIST (specifier, type);
1308 Lisp_Object specification;
1310 if (type == LOCALE_GLOBAL)
1312 /* Calling assq_no_quit when it is just going to return nil anyhow
1313 is extremely expensive. So sayeth Quantify. */
1314 if (!CONSP (*spec_list))
1316 specification = assq_no_quit (locale, *spec_list);
1317 if (NILP (specification))
1319 return &XCDR (specification);
1322 /* For the given INST_LIST, return a new INST_LIST containing all elements
1323 where TAG-SET matches the element's tag set. EXACT_P indicates whether
1324 the match must be exact (as opposed to a subset). SHORT_P indicates
1325 that the short form (for `specifier-specs') should be returned if
1326 possible. If COPY_TREE_P, `copy-tree' is used to ensure that no
1327 elements of the new list are shared with the initial list.
1331 specifier_process_inst_list (Lisp_Object inst_list,
1332 Lisp_Object tag_set, int exact_p,
1333 int short_p, int copy_tree_p)
1335 Lisp_Object retval = Qnil;
1337 struct gcpro gcpro1;
1340 LIST_LOOP (rest, inst_list)
1342 Lisp_Object tagged_inst = XCAR (rest);
1343 Lisp_Object tagged_inst_tag = XCAR (tagged_inst);
1344 if (tag_sets_match_p (tag_set, tagged_inst_tag, exact_p))
1346 if (short_p && NILP (tagged_inst_tag))
1347 retval = Fcons (copy_tree_p ?
1348 Fcopy_tree (XCDR (tagged_inst), Qt) :
1352 retval = Fcons (copy_tree_p ? Fcopy_tree (tagged_inst, Qt) :
1353 tagged_inst, retval);
1356 retval = Fnreverse (retval);
1358 /* If there is a single instantiator and the short form is
1359 requested, return just the instantiator (rather than a one-element
1360 list of it) unless it is nil (so that it can be distinguished from
1361 no instantiators at all). */
1362 if (short_p && CONSP (retval) && !NILP (XCAR (retval)) &&
1363 NILP (XCDR (retval)))
1364 return XCAR (retval);
1370 specifier_get_external_inst_list (Lisp_Object specifier, Lisp_Object locale,
1371 enum spec_locale_type type,
1372 Lisp_Object tag_set, int exact_p,
1373 int short_p, int copy_tree_p)
1375 Lisp_Object *inst_list = specifier_get_inst_list (specifier, locale,
1377 if (!inst_list || NILP (*inst_list))
1379 /* nil for *inst_list should only occur in 'global */
1380 assert (!inst_list || EQ (locale, Qglobal));
1384 return specifier_process_inst_list (*inst_list, tag_set, exact_p,
1385 short_p, copy_tree_p);
1389 specifier_get_external_spec_list (Lisp_Object specifier,
1390 enum spec_locale_type type,
1391 Lisp_Object tag_set, int exact_p)
1393 Lisp_Object *spec_list = SPECIFIER_GET_SPEC_LIST (specifier, type);
1394 Lisp_Object retval = Qnil;
1396 struct gcpro gcpro1;
1398 assert (type != LOCALE_GLOBAL);
1399 /* We're about to let stuff go external; make sure there aren't
1401 *spec_list = cleanup_assoc_list (*spec_list);
1404 LIST_LOOP (rest, *spec_list)
1406 Lisp_Object spec = XCAR (rest);
1407 Lisp_Object inst_list =
1408 specifier_process_inst_list (XCDR (spec), tag_set, exact_p, 0, 1);
1409 if (!NILP (inst_list))
1410 retval = Fcons (Fcons (XCAR (spec), inst_list), retval);
1412 RETURN_UNGCPRO (Fnreverse (retval));
1415 static Lisp_Object *
1416 specifier_new_spec (Lisp_Object specifier, Lisp_Object locale,
1417 enum spec_locale_type type)
1419 Lisp_Object *spec_list = SPECIFIER_GET_SPEC_LIST (specifier, type);
1420 Lisp_Object new_spec = Fcons (locale, Qnil);
1421 assert (type != LOCALE_GLOBAL);
1422 *spec_list = Fcons (new_spec, *spec_list);
1423 return &XCDR (new_spec);
1426 /* For the given INST_LIST, return a new list comprised of elements
1427 where TAG_SET does not match the element's tag set. This operation
1431 specifier_process_remove_inst_list (Lisp_Object inst_list,
1432 Lisp_Object tag_set, int exact_p,
1435 Lisp_Object prev = Qnil, rest;
1439 LIST_LOOP (rest, inst_list)
1441 if (tag_sets_match_p (tag_set, XCAR (XCAR (rest)), exact_p))
1443 /* time to remove. */
1446 inst_list = XCDR (rest);
1448 XCDR (prev) = XCDR (rest);
1458 specifier_remove_spec (Lisp_Object specifier, Lisp_Object locale,
1459 enum spec_locale_type type,
1460 Lisp_Object tag_set, int exact_p)
1462 Lisp_Object *spec_list = SPECIFIER_GET_SPEC_LIST (specifier, type);
1466 if (type == LOCALE_GLOBAL)
1467 *spec_list = specifier_process_remove_inst_list (*spec_list, tag_set,
1468 exact_p, &was_removed);
1471 assoc = assq_no_quit (locale, *spec_list);
1473 /* this locale is not found. */
1475 XCDR (assoc) = specifier_process_remove_inst_list (XCDR (assoc),
1478 if (NILP (XCDR (assoc)))
1479 /* no inst-pairs left; remove this locale entirely. */
1480 *spec_list = remassq_no_quit (locale, *spec_list);
1484 MAYBE_SPECMETH (XSPECIFIER (specifier), after_change,
1485 (bodily_specifier (specifier), locale));
1489 specifier_remove_locale_type (Lisp_Object specifier,
1490 enum spec_locale_type type,
1491 Lisp_Object tag_set, int exact_p)
1493 Lisp_Object *spec_list = SPECIFIER_GET_SPEC_LIST (specifier, type);
1494 Lisp_Object prev = Qnil, rest;
1496 assert (type != LOCALE_GLOBAL);
1497 LIST_LOOP (rest, *spec_list)
1500 int remove_spec = 0;
1501 Lisp_Object spec = XCAR (rest);
1503 /* There may be dead objects floating around */
1504 /* remember, dead windows can become alive again. */
1505 if (!WINDOWP (XCAR (spec)) && object_dead_p (XCAR (spec)))
1512 XCDR (spec) = specifier_process_remove_inst_list (XCDR (spec),
1515 if (NILP (XCDR (spec)))
1522 *spec_list = XCDR (rest);
1524 XCDR (prev) = XCDR (rest);
1530 MAYBE_SPECMETH (XSPECIFIER (specifier), after_change,
1531 (bodily_specifier (specifier), XCAR (spec)));
1535 /* NEW_LIST is going to be added to INST_LIST, with add method ADD_METH.
1536 Frob INST_LIST according to ADD_METH. No need to call an after-change
1537 function; the calling function will do this. Return either SPEC_PREPEND
1538 or SPEC_APPEND, indicating whether to prepend or append the NEW_LIST. */
1540 static enum spec_add_meth
1541 handle_multiple_add_insts (Lisp_Object *inst_list,
1542 Lisp_Object new_list,
1543 enum spec_add_meth add_meth)
1547 case SPEC_REMOVE_TAG_SET_APPEND:
1548 add_meth = SPEC_APPEND;
1549 goto remove_tag_set;
1550 case SPEC_REMOVE_TAG_SET_PREPEND:
1551 add_meth = SPEC_PREPEND;
1556 LIST_LOOP (rest, new_list)
1558 Lisp_Object canontag = canonicalize_tag_set (XCAR (XCAR (rest)));
1559 struct gcpro gcpro1;
1562 /* pull out all elements from the existing list with the
1563 same tag as any tags in NEW_LIST. */
1564 *inst_list = remassoc_no_quit (canontag, *inst_list);
1569 case SPEC_REMOVE_LOCALE:
1571 return SPEC_PREPEND;
1575 return SPEC_PREPEND;
1579 /* Given a LOCALE and INST_LIST that is going to be added to SPECIFIER,
1580 copy, canonicalize, and call the going_to_add methods as necessary
1581 to produce a new list that is the one that really will be added
1582 to the specifier. */
1585 build_up_processed_list (Lisp_Object specifier, Lisp_Object locale,
1586 Lisp_Object inst_list)
1588 /* The return value of this function must be GCPRO'd. */
1589 Lisp_Object rest, list_to_build_up = Qnil;
1590 struct Lisp_Specifier *sp = XSPECIFIER (specifier);
1591 struct gcpro gcpro1;
1593 GCPRO1 (list_to_build_up);
1594 LIST_LOOP (rest, inst_list)
1596 Lisp_Object tag_set = XCAR (XCAR (rest));
1597 Lisp_Object instantiator = Fcopy_tree (XCDR (XCAR (rest)), Qt);
1598 Lisp_Object sub_inst_list = Qnil;
1599 struct gcpro ngcpro1, ngcpro2;
1601 NGCPRO2 (instantiator, sub_inst_list);
1602 /* call the will-add method; it may GC */
1603 sub_inst_list = HAS_SPECMETH_P (sp, going_to_add) ?
1604 SPECMETH (sp, going_to_add,
1605 (bodily_specifier (specifier), locale,
1606 tag_set, instantiator)) :
1608 if (EQ (sub_inst_list, Qt))
1609 /* no change here. */
1610 sub_inst_list = list1 (Fcons (canonicalize_tag_set (tag_set),
1614 /* now canonicalize all the tag sets in the new objects */
1616 LIST_LOOP (rest2, sub_inst_list)
1617 XCAR (XCAR (rest2)) = canonicalize_tag_set (XCAR (XCAR (rest2)));
1620 list_to_build_up = nconc2 (sub_inst_list, list_to_build_up);
1624 RETURN_UNGCPRO (Fnreverse (list_to_build_up));
1627 /* Add a specification (locale and instantiator list) to a specifier.
1628 ADD_METH specifies what to do with existing specifications in the
1629 specifier, and is an enum that corresponds to the values in
1630 `add-spec-to-specifier'. The calling routine is responsible for
1631 validating LOCALE and INST-LIST, but the tag-sets in INST-LIST
1632 do not need to be canonicalized. */
1634 /* #### I really need to rethink the after-change
1635 functions to make them easier to use and more efficient. */
1638 specifier_add_spec (Lisp_Object specifier, Lisp_Object locale,
1639 Lisp_Object inst_list, enum spec_add_meth add_meth)
1641 struct Lisp_Specifier *sp = XSPECIFIER (specifier);
1642 enum spec_locale_type type = locale_type_from_locale (locale);
1643 Lisp_Object *orig_inst_list, tem;
1644 Lisp_Object list_to_build_up = Qnil;
1645 struct gcpro gcpro1;
1647 GCPRO1 (list_to_build_up);
1648 list_to_build_up = build_up_processed_list (specifier, locale, inst_list);
1649 /* Now handle REMOVE_LOCALE_TYPE and REMOVE_ALL. These are the
1650 add-meth types that affect locales other than this one. */
1651 if (add_meth == SPEC_REMOVE_LOCALE_TYPE)
1652 specifier_remove_locale_type (specifier, type, Qnil, 0);
1653 else if (add_meth == SPEC_REMOVE_ALL)
1655 specifier_remove_locale_type (specifier, LOCALE_BUFFER, Qnil, 0);
1656 specifier_remove_locale_type (specifier, LOCALE_WINDOW, Qnil, 0);
1657 specifier_remove_locale_type (specifier, LOCALE_FRAME, Qnil, 0);
1658 specifier_remove_locale_type (specifier, LOCALE_DEVICE, Qnil, 0);
1659 specifier_remove_spec (specifier, Qglobal, LOCALE_GLOBAL, Qnil, 0);
1662 orig_inst_list = specifier_get_inst_list (specifier, locale, type);
1663 if (!orig_inst_list)
1664 orig_inst_list = specifier_new_spec (specifier, locale, type);
1665 add_meth = handle_multiple_add_insts (orig_inst_list, list_to_build_up,
1668 if (add_meth == SPEC_PREPEND)
1669 tem = nconc2 (list_to_build_up, *orig_inst_list);
1670 else if (add_meth == SPEC_APPEND)
1671 tem = nconc2 (*orig_inst_list, list_to_build_up);
1675 *orig_inst_list = tem;
1679 /* call the after-change method */
1680 MAYBE_SPECMETH (sp, after_change,
1681 (bodily_specifier (specifier), locale));
1685 specifier_copy_spec (Lisp_Object specifier, Lisp_Object dest,
1686 Lisp_Object locale, enum spec_locale_type type,
1687 Lisp_Object tag_set, int exact_p,
1688 enum spec_add_meth add_meth)
1690 Lisp_Object inst_list =
1691 specifier_get_external_inst_list (specifier, locale, type, tag_set,
1693 specifier_add_spec (dest, locale, inst_list, add_meth);
1697 specifier_copy_locale_type (Lisp_Object specifier, Lisp_Object dest,
1698 enum spec_locale_type type,
1699 Lisp_Object tag_set, int exact_p,
1700 enum spec_add_meth add_meth)
1702 Lisp_Object *src_list = SPECIFIER_GET_SPEC_LIST (specifier, type);
1705 /* This algorithm is O(n^2) in running time.
1706 It's certainly possible to implement an O(n log n) algorithm,
1707 but I doubt there's any need to. */
1709 LIST_LOOP (rest, *src_list)
1711 Lisp_Object spec = XCAR (rest);
1712 /* There may be dead objects floating around */
1713 /* remember, dead windows can become alive again. */
1714 if (WINDOWP (XCAR (spec)) || !object_dead_p (XCAR (spec)))
1717 specifier_process_inst_list (XCDR (spec), tag_set, exact_p, 0, 0),
1722 /* map MAPFUN over the locales in SPECIFIER that are given in LOCALE.
1723 CLOSURE is passed unchanged to MAPFUN. LOCALE can be one of
1725 -- nil (same as 'all)
1726 -- a single locale, locale type, or 'all
1727 -- a list of locales, locale types, and/or 'all
1729 MAPFUN is called for each locale and locale type given; for 'all,
1730 it is called for the locale 'global and for the four possible
1731 locale types. In each invocation, either LOCALE will be a locale
1732 and LOCALE_TYPE will be the locale type of this locale,
1733 or LOCALE will be nil and LOCALE_TYPE will be a locale type.
1734 If MAPFUN ever returns non-zero, the mapping is halted and the
1735 value returned is returned from map_specifier(). Otherwise, the
1736 mapping proceeds to the end and map_specifier() returns 0.
1740 map_specifier (Lisp_Object specifier, Lisp_Object locale,
1741 int (*mapfun) (Lisp_Object specifier,
1743 enum spec_locale_type locale_type,
1744 Lisp_Object tag_set,
1747 Lisp_Object tag_set, Lisp_Object exact_p,
1752 struct gcpro gcpro1, gcpro2;
1754 GCPRO2 (tag_set, locale);
1755 locale = decode_locale_list (locale);
1756 tag_set = decode_specifier_tag_set (tag_set);
1757 tag_set = canonicalize_tag_set (tag_set);
1759 LIST_LOOP (rest, locale)
1761 Lisp_Object theloc = XCAR (rest);
1762 if (!NILP (Fvalid_specifier_locale_p (theloc)))
1764 retval = (*mapfun) (specifier, theloc,
1765 locale_type_from_locale (theloc),
1766 tag_set, !NILP (exact_p), closure);
1770 else if (!NILP (Fvalid_specifier_locale_type_p (theloc)))
1772 retval = (*mapfun) (specifier, Qnil,
1773 decode_locale_type (theloc), tag_set,
1774 !NILP (exact_p), closure);
1780 assert (EQ (theloc, Qall));
1781 retval = (*mapfun) (specifier, Qnil, LOCALE_BUFFER, tag_set,
1782 !NILP (exact_p), closure);
1785 retval = (*mapfun) (specifier, Qnil, LOCALE_WINDOW, tag_set,
1786 !NILP (exact_p), closure);
1789 retval = (*mapfun) (specifier, Qnil, LOCALE_FRAME, tag_set,
1790 !NILP (exact_p), closure);
1793 retval = (*mapfun) (specifier, Qnil, LOCALE_DEVICE, tag_set,
1794 !NILP (exact_p), closure);
1797 retval = (*mapfun) (specifier, Qglobal, LOCALE_GLOBAL, tag_set,
1798 !NILP (exact_p), closure);
1808 DEFUN ("add-spec-to-specifier", Fadd_spec_to_specifier, 2, 5, 0, /*
1809 Add a specification to SPECIFIER.
1810 The specification maps from LOCALE (which should be a window, buffer,
1811 frame, device, or 'global, and defaults to 'global) to INSTANTIATOR,
1812 whose allowed values depend on the type of the specifier. Optional
1813 argument TAG-SET limits the instantiator to apply only to the specified
1814 tag set, which should be a list of tags all of which must match the
1815 device being instantiated over (tags are a device type, a device class,
1816 or tags defined with `define-specifier-tag'). Specifying a single
1817 symbol for TAG-SET is equivalent to specifying a one-element list
1818 containing that symbol. Optional argument HOW-TO-ADD specifies what to
1819 do if there are already specifications in the specifier.
1822 'prepend Put at the beginning of the current list of
1823 instantiators for LOCALE.
1824 'append Add to the end of the current list of
1825 instantiators for LOCALE.
1826 'remove-tag-set-prepend (this is the default)
1827 Remove any existing instantiators whose tag set is
1828 the same as TAG-SET; then put the new instantiator
1829 at the beginning of the current list. ("Same tag
1830 set" means that they contain the same elements.
1831 The order may be different.)
1832 'remove-tag-set-append
1833 Remove any existing instantiators whose tag set is
1834 the same as TAG-SET; then put the new instantiator
1835 at the end of the current list.
1836 'remove-locale Remove all previous instantiators for this locale
1837 before adding the new spec.
1838 'remove-locale-type Remove all specifications for all locales of the
1839 same type as LOCALE (this includes LOCALE itself)
1840 before adding the new spec.
1841 'remove-all Remove all specifications from the specifier
1842 before adding the new spec.
1844 You can retrieve the specifications for a particular locale or locale type
1845 with the function `specifier-spec-list' or `specifier-specs'.
1847 (specifier, instantiator, locale, tag_set, how_to_add))
1849 enum spec_add_meth add_meth;
1850 Lisp_Object inst_list;
1851 struct gcpro gcpro1;
1853 CHECK_SPECIFIER (specifier);
1854 check_modifiable_specifier (specifier);
1856 locale = decode_locale (locale);
1857 check_valid_instantiator (instantiator,
1858 decode_specifier_type
1859 (Fspecifier_type (specifier), ERROR_ME),
1861 /* tag_set might be newly-created material, but it's part of inst_list
1862 so is properly GC-protected. */
1863 tag_set = decode_specifier_tag_set (tag_set);
1864 add_meth = decode_how_to_add_specification (how_to_add);
1866 inst_list = list1 (Fcons (tag_set, instantiator));
1868 specifier_add_spec (specifier, locale, inst_list, add_meth);
1869 recompute_cached_specifier_everywhere (specifier);
1870 RETURN_UNGCPRO (Qnil);
1873 DEFUN ("add-spec-list-to-specifier", Fadd_spec_list_to_specifier, 2, 3, 0, /*
1874 Add a spec-list (a list of specifications) to SPECIFIER.
1875 The format of a spec-list is
1877 ((LOCALE (TAG-SET . INSTANTIATOR) ...) ...)
1880 LOCALE := a window, a buffer, a frame, a device, or 'global
1881 TAG-SET := an unordered list of zero or more TAGS, each of which
1883 TAG := a device class (see `valid-device-class-p'), a device type
1884 (see `valid-console-type-p'), or a tag defined with
1885 `define-specifier-tag'
1886 INSTANTIATOR := format determined by the type of specifier
1888 The pair (TAG-SET . INSTANTIATOR) is called an `inst-pair'.
1889 A list of inst-pairs is called an `inst-list'.
1890 The pair (LOCALE . INST-LIST) is called a `specification' or `spec'.
1891 A spec-list, then, can be viewed as a list of specifications.
1893 HOW-TO-ADD specifies how to combine the new specifications with
1894 the existing ones, and has the same semantics as for
1895 `add-spec-to-specifier'.
1897 In many circumstances, the higher-level function `set-specifier' is
1898 more convenient and should be used instead.
1900 (specifier, spec_list, how_to_add))
1902 enum spec_add_meth add_meth;
1905 CHECK_SPECIFIER (specifier);
1906 check_modifiable_specifier (specifier);
1908 check_valid_spec_list (spec_list,
1909 decode_specifier_type
1910 (Fspecifier_type (specifier), ERROR_ME),
1912 add_meth = decode_how_to_add_specification (how_to_add);
1914 LIST_LOOP (rest, spec_list)
1916 /* Placating the GCC god. */
1917 Lisp_Object specification = XCAR (rest);
1918 Lisp_Object locale = XCAR (specification);
1919 Lisp_Object inst_list = XCDR (specification);
1921 specifier_add_spec (specifier, locale, inst_list, add_meth);
1923 recompute_cached_specifier_everywhere (specifier);
1928 add_spec_to_ghost_specifier (Lisp_Object specifier, Lisp_Object instantiator,
1929 Lisp_Object locale, Lisp_Object tag_set,
1930 Lisp_Object how_to_add)
1932 int depth = unlock_ghost_specifiers_protected ();
1933 Fadd_spec_to_specifier (XSPECIFIER(specifier)->fallback,
1934 instantiator, locale, tag_set, how_to_add);
1935 unbind_to (depth, Qnil);
1938 struct specifier_spec_list_closure
1940 Lisp_Object head, tail;
1944 specifier_spec_list_mapfun (Lisp_Object specifier,
1946 enum spec_locale_type locale_type,
1947 Lisp_Object tag_set,
1951 struct specifier_spec_list_closure *cl =
1952 (struct specifier_spec_list_closure *) closure;
1953 Lisp_Object partial;
1956 partial = specifier_get_external_spec_list (specifier,
1961 partial = specifier_get_external_inst_list (specifier, locale,
1962 locale_type, tag_set,
1964 if (!NILP (partial))
1965 partial = list1 (Fcons (locale, partial));
1970 /* tack on the new list */
1971 if (NILP (cl->tail))
1972 cl->head = cl->tail = partial;
1974 XCDR (cl->tail) = partial;
1975 /* find the new tail */
1976 while (CONSP (XCDR (cl->tail)))
1977 cl->tail = XCDR (cl->tail);
1981 /* For the given SPECIFIER create and return a list of all specs
1982 contained within it, subject to LOCALE. If LOCALE is a locale, only
1983 specs in that locale will be returned. If LOCALE is a locale type,
1984 all specs in all locales of that type will be returned. If LOCALE is
1985 nil, all specs will be returned. This always copies lists and never
1986 returns the actual lists, because we do not want someone manipulating
1987 the actual objects. This may cause a slight loss of potential
1988 functionality but if we were to allow it then a user could manage to
1989 violate our assertion that the specs contained in the actual
1990 specifier lists are all valid. */
1992 DEFUN ("specifier-spec-list", Fspecifier_spec_list, 1, 4, 0, /*
1993 Return the spec-list of specifications for SPECIFIER in LOCALE.
1995 If LOCALE is a particular locale (a buffer, window, frame, device,
1996 or 'global), a spec-list consisting of the specification for that
1997 locale will be returned.
1999 If LOCALE is a locale type (i.e. 'buffer, 'window, 'frame, or 'device),
2000 a spec-list of the specifications for all locales of that type will be
2003 If LOCALE is nil or 'all, a spec-list of all specifications in SPECIFIER
2006 LOCALE can also be a list of locales, locale types, and/or 'all; the
2007 result is as if `specifier-spec-list' were called on each element of the
2008 list and the results concatenated together.
2010 Only instantiators where TAG-SET (a list of zero or more tags) is a
2011 subset of (or possibly equal to) the instantiator's tag set are returned.
2012 \(The default value of nil is a subset of all tag sets, so in this case
2013 no instantiators will be screened out.) If EXACT-P is non-nil, however,
2014 TAG-SET must be equal to an instantiator's tag set for the instantiator
2017 (specifier, locale, tag_set, exact_p))
2019 struct specifier_spec_list_closure cl;
2020 struct gcpro gcpro1, gcpro2;
2022 CHECK_SPECIFIER (specifier);
2023 cl.head = cl.tail = Qnil;
2024 GCPRO2 (cl.head, cl.tail);
2025 map_specifier (specifier, locale, specifier_spec_list_mapfun,
2026 tag_set, exact_p, &cl);
2032 DEFUN ("specifier-specs", Fspecifier_specs, 1, 4, 0, /*
2033 Return the specification(s) for SPECIFIER in LOCALE.
2035 If LOCALE is a single locale or is a list of one element containing a
2036 single locale, then a "short form" of the instantiators for that locale
2037 will be returned. Otherwise, this function is identical to
2038 `specifier-spec-list'.
2040 The "short form" is designed for readability and not for ease of use
2041 in Lisp programs, and is as follows:
2043 1. If there is only one instantiator, then an inst-pair (i.e. cons of
2044 tag and instantiator) will be returned; otherwise a list of
2045 inst-pairs will be returned.
2046 2. For each inst-pair returned, if the instantiator's tag is 'any,
2047 the tag will be removed and the instantiator itself will be returned
2048 instead of the inst-pair.
2049 3. If there is only one instantiator, its value is nil, and its tag is
2050 'any, a one-element list containing nil will be returned rather
2051 than just nil, to distinguish this case from there being no
2052 instantiators at all.
2054 (specifier, locale, tag_set, exact_p))
2056 if (!NILP (Fvalid_specifier_locale_p (locale)) ||
2057 (CONSP (locale) && !NILP (Fvalid_specifier_locale_p (XCAR (locale))) &&
2058 NILP (XCDR (locale))))
2060 struct gcpro gcpro1;
2062 CHECK_SPECIFIER (specifier);
2064 locale = XCAR (locale);
2066 tag_set = decode_specifier_tag_set (tag_set);
2067 tag_set = canonicalize_tag_set (tag_set);
2069 (specifier_get_external_inst_list (specifier, locale,
2070 locale_type_from_locale (locale),
2071 tag_set, !NILP (exact_p), 1, 1));
2074 return Fspecifier_spec_list (specifier, locale, tag_set, exact_p);
2078 remove_specifier_mapfun (Lisp_Object specifier,
2080 enum spec_locale_type locale_type,
2081 Lisp_Object tag_set,
2083 void *ignored_closure)
2086 specifier_remove_locale_type (specifier, locale_type, tag_set, exact_p);
2088 specifier_remove_spec (specifier, locale, locale_type, tag_set, exact_p);
2092 DEFUN ("remove-specifier", Fremove_specifier, 1, 4, 0, /*
2093 Remove specification(s) for SPECIFIER.
2095 If LOCALE is a particular locale (a window, buffer, frame, device,
2096 or 'global), the specification for that locale will be removed.
2098 If instead, LOCALE is a locale type (i.e. 'window, 'buffer, 'frame,
2099 or 'device), the specifications for all locales of that type will be
2102 If LOCALE is nil or 'all, all specifications will be removed.
2104 LOCALE can also be a list of locales, locale types, and/or 'all; this
2105 is equivalent to calling `remove-specifier' for each of the elements
2108 Only instantiators where TAG-SET (a list of zero or more tags) is a
2109 subset of (or possibly equal to) the instantiator's tag set are removed.
2110 The default value of nil is a subset of all tag sets, so in this case
2111 no instantiators will be screened out. If EXACT-P is non-nil, however,
2112 TAG-SET must be equal to an instantiator's tag set for the instantiator
2115 (specifier, locale, tag_set, exact_p))
2117 CHECK_SPECIFIER (specifier);
2118 check_modifiable_specifier (specifier);
2120 map_specifier (specifier, locale, remove_specifier_mapfun,
2121 tag_set, exact_p, 0);
2122 recompute_cached_specifier_everywhere (specifier);
2127 remove_ghost_specifier (Lisp_Object specifier, Lisp_Object locale,
2128 Lisp_Object tag_set, Lisp_Object exact_p)
2130 int depth = unlock_ghost_specifiers_protected ();
2131 Fremove_specifier (XSPECIFIER(specifier)->fallback,
2132 locale, tag_set, exact_p);
2133 unbind_to (depth, Qnil);
2136 struct copy_specifier_closure
2139 enum spec_add_meth add_meth;
2140 int add_meth_is_nil;
2144 copy_specifier_mapfun (Lisp_Object specifier,
2146 enum spec_locale_type locale_type,
2147 Lisp_Object tag_set,
2151 struct copy_specifier_closure *cl =
2152 (struct copy_specifier_closure *) closure;
2155 specifier_copy_locale_type (specifier, cl->dest, locale_type,
2157 cl->add_meth_is_nil ?
2158 SPEC_REMOVE_LOCALE_TYPE :
2161 specifier_copy_spec (specifier, cl->dest, locale, locale_type,
2163 cl->add_meth_is_nil ? SPEC_REMOVE_LOCALE :
2168 DEFUN ("copy-specifier", Fcopy_specifier, 1, 6, 0, /*
2169 Copy SPECIFIER to DEST, or create a new one if DEST is nil.
2171 If DEST is nil or omitted, a new specifier will be created and the
2172 specifications copied into it. Otherwise, the specifications will be
2173 copied into the existing specifier in DEST.
2175 If LOCALE is nil or 'all, all specifications will be copied. If LOCALE
2176 is a particular locale, the specification for that particular locale will
2177 be copied. If LOCALE is a locale type, the specifications for all locales
2178 of that type will be copied. LOCALE can also be a list of locales,
2179 locale types, and/or 'all; this is equivalent to calling `copy-specifier'
2180 for each of the elements of the list. See `specifier-spec-list' for more
2181 information about LOCALE.
2183 Only instantiators where TAG-SET (a list of zero or more tags) is a
2184 subset of (or possibly equal to) the instantiator's tag set are copied.
2185 The default value of nil is a subset of all tag sets, so in this case
2186 no instantiators will be screened out. If EXACT-P is non-nil, however,
2187 TAG-SET must be equal to an instantiator's tag set for the instantiator
2190 Optional argument HOW-TO-ADD specifies what to do with existing
2191 specifications in DEST. If nil, then whichever locales or locale types
2192 are copied will first be completely erased in DEST. Otherwise, it is
2193 the same as in `add-spec-to-specifier'.
2195 (specifier, dest, locale, tag_set, exact_p, how_to_add))
2197 struct gcpro gcpro1;
2198 struct copy_specifier_closure cl;
2200 CHECK_SPECIFIER (specifier);
2201 if (NILP (how_to_add))
2202 cl.add_meth_is_nil = 1;
2204 cl.add_meth_is_nil = 0;
2205 cl.add_meth = decode_how_to_add_specification (how_to_add);
2208 /* #### What about copying the extra data? */
2209 dest = make_specifier (XSPECIFIER (specifier)->methods);
2213 CHECK_SPECIFIER (dest);
2214 check_modifiable_specifier (dest);
2215 if (XSPECIFIER (dest)->methods != XSPECIFIER (specifier)->methods)
2216 error ("Specifiers not of same type");
2221 map_specifier (specifier, locale, copy_specifier_mapfun,
2222 tag_set, exact_p, &cl);
2224 recompute_cached_specifier_everywhere (dest);
2229 /************************************************************************/
2231 /************************************************************************/
2234 call_validate_matchspec_method (Lisp_Object boxed_method,
2235 Lisp_Object matchspec)
2237 ((void (*)(Lisp_Object)) get_opaque_ptr (boxed_method)) (matchspec);
2242 check_valid_specifier_matchspec (Lisp_Object matchspec,
2243 struct specifier_methods *meths,
2244 Error_behavior errb)
2246 if (meths->validate_matchspec_method)
2250 if (ERRB_EQ (errb, ERROR_ME))
2252 (meths->validate_matchspec_method) (matchspec);
2257 Lisp_Object opaque =
2258 make_opaque_ptr ((void *) meths->validate_matchspec_method);
2259 struct gcpro gcpro1;
2262 retval = call_with_suspended_errors
2263 ((lisp_fn_t) call_validate_matchspec_method,
2264 Qnil, Qspecifier, errb, 2, opaque, matchspec);
2266 free_opaque_ptr (opaque);
2274 maybe_signal_simple_error
2275 ("Matchspecs not allowed for this specifier type",
2276 intern (meths->name), Qspecifier, errb);
2281 DEFUN ("check-valid-specifier-matchspec", Fcheck_valid_specifier_matchspec, 2, 2, 0, /*
2282 Signal an error if MATCHSPEC is invalid for SPECIFIER-TYPE.
2283 See `specifier-matching-instance' for a description of matchspecs.
2285 (matchspec, specifier_type))
2287 struct specifier_methods *meths = decode_specifier_type (specifier_type,
2290 return check_valid_specifier_matchspec (matchspec, meths, ERROR_ME);
2293 DEFUN ("valid-specifier-matchspec-p", Fvalid_specifier_matchspec_p, 2, 2, 0, /*
2294 Return non-nil if MATCHSPEC is valid for SPECIFIER-TYPE.
2295 See `specifier-matching-instance' for a description of matchspecs.
2297 (matchspec, specifier_type))
2299 struct specifier_methods *meths = decode_specifier_type (specifier_type,
2302 return check_valid_specifier_matchspec (matchspec, meths, ERROR_ME_NOT);
2305 /* This function is purposely not callable from Lisp. If a Lisp
2306 caller wants to set a fallback, they should just set the
2310 set_specifier_fallback (Lisp_Object specifier, Lisp_Object fallback)
2312 struct Lisp_Specifier *sp = XSPECIFIER (specifier);
2313 assert (SPECIFIERP (fallback) ||
2314 !NILP (Fvalid_inst_list_p (fallback, Fspecifier_type (specifier))));
2315 if (SPECIFIERP (fallback))
2316 assert (EQ (Fspecifier_type (specifier), Fspecifier_type (fallback)));
2317 if (BODILY_SPECIFIER_P (sp))
2318 GHOST_SPECIFIER(sp)->fallback = fallback;
2320 sp->fallback = fallback;
2321 /* call the after-change method */
2322 MAYBE_SPECMETH (sp, after_change,
2323 (bodily_specifier (specifier), Qfallback));
2324 recompute_cached_specifier_everywhere (specifier);
2327 DEFUN ("specifier-fallback", Fspecifier_fallback, 1, 1, 0, /*
2328 Return the fallback value for SPECIFIER.
2329 Fallback values are provided by the C code for certain built-in
2330 specifiers to make sure that instancing won't fail even if all
2331 specs are removed from the specifier, or to implement simple
2332 inheritance behavior (e.g. this method is used to ensure that
2333 faces other than 'default inherit their attributes from 'default).
2334 By design, you cannot change the fallback value, and specifiers
2335 created with `make-specifier' will never have a fallback (although
2336 a similar, Lisp-accessible capability may be provided in the future
2337 to allow for inheritance).
2339 The fallback value will be an inst-list that is instanced like
2340 any other inst-list, a specifier of the same type as SPECIFIER
2341 \(results in inheritance), or nil for no fallback.
2343 When you instance a specifier, you can explicitly request that the
2344 fallback not be consulted. (The C code does this, for example, when
2345 merging faces.) See `specifier-instance'.
2349 CHECK_SPECIFIER (specifier);
2350 return Fcopy_tree (XSPECIFIER (specifier)->fallback, Qt);
2354 specifier_instance_from_inst_list (Lisp_Object specifier,
2355 Lisp_Object matchspec,
2357 Lisp_Object inst_list,
2358 Error_behavior errb, int no_quit,
2361 /* This function can GC */
2362 struct Lisp_Specifier *sp;
2365 int count = specpdl_depth ();
2366 struct gcpro gcpro1, gcpro2;
2368 GCPRO2 (specifier, inst_list);
2370 sp = XSPECIFIER (specifier);
2371 device = DFW_DEVICE (domain);
2374 /* The instantiate method is allowed to call eval. Since it
2375 is quite common for this function to get called from somewhere in
2376 redisplay we need to make sure that quits are ignored. Otherwise
2377 Fsignal will abort. */
2378 specbind (Qinhibit_quit, Qt);
2380 LIST_LOOP (rest, inst_list)
2382 Lisp_Object tagged_inst = XCAR (rest);
2383 Lisp_Object tag_set = XCAR (tagged_inst);
2385 if (device_matches_specifier_tag_set_p (device, tag_set))
2387 Lisp_Object val = XCDR (tagged_inst);
2389 if (HAS_SPECMETH_P (sp, instantiate))
2390 val = call_with_suspended_errors
2391 ((lisp_fn_t) RAW_SPECMETH (sp, instantiate),
2392 Qunbound, Qspecifier, errb, 5, specifier,
2393 matchspec, domain, val, depth);
2395 if (!UNBOUNDP (val))
2397 unbind_to (count, Qnil);
2404 unbind_to (count, Qnil);
2409 /* Given a SPECIFIER and a DOMAIN, return a specific instance for that
2410 specifier. Try to find one by checking the specifier types from most
2411 specific (buffer) to most general (global). If we find an instance,
2412 return it. Otherwise return Qunbound. */
2414 #define CHECK_INSTANCE_ENTRY(key, matchspec, type) do { \
2415 Lisp_Object *CIE_inst_list = \
2416 specifier_get_inst_list (specifier, key, type); \
2417 if (CIE_inst_list) \
2419 Lisp_Object CIE_val = \
2420 specifier_instance_from_inst_list (specifier, matchspec, \
2421 domain, *CIE_inst_list, \
2422 errb, no_quit, depth); \
2423 if (!UNBOUNDP (CIE_val)) \
2428 /* We accept any window, frame or device domain and do our checking
2429 starting from as specific a locale type as we can determine from the
2430 domain we are passed and going on up through as many other locale types
2431 as we can determine. In practice, when called from redisplay the
2432 arg will usually be a window and occasionally a frame. If
2433 triggered by a user call, who knows what it will usually be. */
2435 specifier_instance (Lisp_Object specifier, Lisp_Object matchspec,
2436 Lisp_Object domain, Error_behavior errb, int no_quit,
2437 int no_fallback, Lisp_Object depth)
2439 Lisp_Object buffer = Qnil;
2440 Lisp_Object window = Qnil;
2441 Lisp_Object frame = Qnil;
2442 Lisp_Object device = Qnil;
2443 Lisp_Object tag = Qnil;
2445 struct Lisp_Specifier *sp;
2447 sp = XSPECIFIER (specifier);
2449 /* Attempt to determine buffer, window, frame, and device from the
2451 if (WINDOWP (domain))
2453 else if (FRAMEP (domain))
2455 else if (DEVICEP (domain))
2458 /* #### dmoore - dammit, this should just signal an error or something
2460 #### No. Errors are handled in Lisp primitives implementation.
2461 Invalid domain is a design error here - kkm. */
2464 if (NILP (buffer) && !NILP (window))
2465 buffer = XWINDOW (window)->buffer;
2466 if (NILP (frame) && !NILP (window))
2467 frame = XWINDOW (window)->frame;
2469 /* frame had better exist; if device is undeterminable, something
2470 really went wrong. */
2471 device = XFRAME (frame)->device;
2473 /* device had better be determined by now; abort if not. */
2474 d = XDEVICE (device);
2475 tag = DEVICE_CLASS (d);
2477 depth = make_int (1 + XINT (depth));
2478 if (XINT (depth) > 20)
2480 maybe_error (Qspecifier, errb, "Apparent loop in specifier inheritance");
2481 /* The specification is fucked; at least try the fallback
2482 (which better not be fucked, because it's not changeable
2489 /* First see if we can generate one from the window specifiers. */
2491 CHECK_INSTANCE_ENTRY (window, matchspec, LOCALE_WINDOW);
2493 /* Next see if we can generate one from the buffer specifiers. */
2495 CHECK_INSTANCE_ENTRY (buffer, matchspec, LOCALE_BUFFER);
2497 /* Next see if we can generate one from the frame specifiers. */
2499 CHECK_INSTANCE_ENTRY (frame, matchspec, LOCALE_FRAME);
2501 /* If we still haven't succeeded try with the device specifiers. */
2502 CHECK_INSTANCE_ENTRY (device, matchspec, LOCALE_DEVICE);
2504 /* Last and least try the global specifiers. */
2505 CHECK_INSTANCE_ENTRY (Qglobal, matchspec, LOCALE_GLOBAL);
2508 /* We're out of specifiers and we still haven't generated an
2509 instance. At least try the fallback ... If this fails,
2510 then we just return Qunbound. */
2512 if (no_fallback || NILP (sp->fallback))
2513 /* I said, I don't want the fallbacks. */
2516 if (SPECIFIERP (sp->fallback))
2518 /* If you introduced loops in the default specifier chain,
2519 then you're fucked, so you better not do this. */
2520 specifier = sp->fallback;
2521 sp = XSPECIFIER (specifier);
2525 assert (CONSP (sp->fallback));
2526 return specifier_instance_from_inst_list (specifier, matchspec, domain,
2527 sp->fallback, errb, no_quit,
2530 #undef CHECK_INSTANCE_ENTRY
2533 specifier_instance_no_quit (Lisp_Object specifier, Lisp_Object matchspec,
2534 Lisp_Object domain, Error_behavior errb,
2535 int no_fallback, Lisp_Object depth)
2537 return specifier_instance (specifier, matchspec, domain, errb,
2538 1, no_fallback, depth);
2541 DEFUN ("specifier-instance", Fspecifier_instance, 1, 4, 0, /*
2542 Instantiate SPECIFIER (return its value) in DOMAIN.
2543 If no instance can be generated for this domain, return DEFAULT.
2545 DOMAIN should be a window, frame, or device. Other values that are legal
2546 as a locale (e.g. a buffer) are not valid as a domain because they do not
2547 provide enough information to identify a particular device (see
2548 `valid-specifier-domain-p'). DOMAIN defaults to the selected window
2551 "Instantiating" a specifier in a particular domain means determining
2552 the specifier's "value" in that domain. This is accomplished by
2553 searching through the specifications in the specifier that correspond
2554 to all locales that can be derived from the given domain, from specific
2555 to general. In most cases, the domain is an Emacs window. In that case
2556 specifications are searched for as follows:
2558 1. A specification whose locale is the window itself;
2559 2. A specification whose locale is the window's buffer;
2560 3. A specification whose locale is the window's frame;
2561 4. A specification whose locale is the window's frame's device;
2562 5. A specification whose locale is 'global.
2564 If all of those fail, then the C-code-provided fallback value for
2565 this specifier is consulted (see `specifier-fallback'). If it is
2566 an inst-list, then this function attempts to instantiate that list
2567 just as when a specification is located in the first five steps above.
2568 If the fallback is a specifier, `specifier-instance' is called
2569 recursively on this specifier and the return value used. Note,
2570 however, that if the optional argument NO-FALLBACK is non-nil,
2571 the fallback value will not be consulted.
2573 Note that there may be more than one specification matching a particular
2574 locale; all such specifications are considered before looking for any
2575 specifications for more general locales. Any particular specification
2576 that is found may be rejected because its tag set does not match the
2577 device being instantiated over, or because the specification is not
2578 valid for the device of the given domain (e.g. the font or color name
2579 does not exist for this particular X server).
2581 The returned value is dependent on the type of specifier. For example,
2582 for a font specifier (as returned by the `face-font' function), the returned
2583 value will be a font-instance object. For glyphs, the returned value
2584 will be a string, pixmap, or subwindow.
2586 See also `specifier-matching-instance'.
2588 (specifier, domain, default_, no_fallback))
2590 Lisp_Object instance;
2592 CHECK_SPECIFIER (specifier);
2593 domain = decode_domain (domain);
2595 instance = specifier_instance (specifier, Qunbound, domain, ERROR_ME, 0,
2596 !NILP (no_fallback), Qzero);
2597 return UNBOUNDP (instance) ? default_ : instance;
2600 DEFUN ("specifier-matching-instance", Fspecifier_matching_instance, 2, 5, 0, /*
2601 Return an instance for SPECIFIER in DOMAIN that matches MATCHSPEC.
2602 If no instance can be generated for this domain, return DEFAULT.
2604 This function is identical to `specifier-instance' except that a
2605 specification will only be considered if it matches MATCHSPEC.
2606 The definition of "match", and allowed values for MATCHSPEC, are
2607 dependent on the particular type of specifier. Here are some examples:
2609 -- For chartable (e.g. display table) specifiers, MATCHSPEC should be a
2610 character, and the specification (a chartable) must give a value for
2611 that character in order to be considered. This allows you to specify,
2612 e.g., a buffer-local display table that only gives values for particular
2613 characters. All other characters are handled as if the buffer-local
2614 display table is not there. (Chartable specifiers are not yet
2617 -- For font specifiers, MATCHSPEC should be a charset, and the specification
2618 (a font string) must have a registry that matches the charset's registry.
2619 (This only makes sense with Mule support.) This makes it easy to choose a
2620 font that can display a particular character. (This is what redisplay
2623 (specifier, matchspec, domain, default_, no_fallback))
2625 Lisp_Object instance;
2627 CHECK_SPECIFIER (specifier);
2628 check_valid_specifier_matchspec (matchspec, XSPECIFIER (specifier)->methods,
2630 domain = decode_domain (domain);
2632 instance = specifier_instance (specifier, matchspec, domain, ERROR_ME,
2633 0, !NILP (no_fallback), Qzero);
2634 return UNBOUNDP (instance) ? default_ : instance;
2637 DEFUN ("specifier-instance-from-inst-list", Fspecifier_instance_from_inst_list,
2639 Attempt to convert a particular inst-list into an instance.
2640 This attempts to instantiate INST-LIST in the given DOMAIN,
2641 as if INST-LIST existed in a specification in SPECIFIER. If
2642 the instantiation fails, DEFAULT is returned. In most circumstances,
2643 you should not use this function; use `specifier-instance' instead.
2645 (specifier, domain, inst_list, default_))
2647 Lisp_Object val = Qunbound;
2648 struct Lisp_Specifier *sp = XSPECIFIER (specifier);
2649 struct gcpro gcpro1;
2650 Lisp_Object built_up_list = Qnil;
2652 CHECK_SPECIFIER (specifier);
2653 check_valid_domain (domain);
2654 check_valid_inst_list (inst_list, sp->methods, ERROR_ME);
2655 GCPRO1 (built_up_list);
2656 built_up_list = build_up_processed_list (specifier, domain, inst_list);
2657 if (!NILP (built_up_list))
2658 val = specifier_instance_from_inst_list (specifier, Qunbound, domain,
2659 built_up_list, ERROR_ME,
2662 return UNBOUNDP (val) ? default_ : val;
2665 DEFUN ("specifier-matching-instance-from-inst-list", Fspecifier_matching_instance_from_inst_list,
2667 Attempt to convert a particular inst-list into an instance.
2668 This attempts to instantiate INST-LIST in the given DOMAIN
2669 \(as if INST-LIST existed in a specification in SPECIFIER),
2670 matching the specifications against MATCHSPEC.
2672 This function is analogous to `specifier-instance-from-inst-list'
2673 but allows for specification-matching as in `specifier-matching-instance'.
2674 See that function for a description of exactly how the matching process
2677 (specifier, matchspec, domain, inst_list, default_))
2679 Lisp_Object val = Qunbound;
2680 struct Lisp_Specifier *sp = XSPECIFIER (specifier);
2681 struct gcpro gcpro1;
2682 Lisp_Object built_up_list = Qnil;
2684 CHECK_SPECIFIER (specifier);
2685 check_valid_specifier_matchspec (matchspec, XSPECIFIER (specifier)->methods,
2687 check_valid_domain (domain);
2688 check_valid_inst_list (inst_list, sp->methods, ERROR_ME);
2689 GCPRO1 (built_up_list);
2690 built_up_list = build_up_processed_list (specifier, domain, inst_list);
2691 if (!NILP (built_up_list))
2692 val = specifier_instance_from_inst_list (specifier, matchspec, domain,
2693 built_up_list, ERROR_ME,
2696 return UNBOUNDP (val) ? default_ : val;
2700 /************************************************************************/
2701 /* Caching in the struct window or frame */
2702 /************************************************************************/
2704 /* Either STRUCT_WINDOW_OFFSET or STRUCT_FRAME_OFFSET can be 0 to indicate
2705 no caching in that sort of object. */
2707 /* #### It would be nice if the specifier caching automatically knew
2708 about specifier fallbacks, so we didn't have to do it ourselves. */
2711 set_specifier_caching (Lisp_Object specifier, int struct_window_offset,
2712 void (*value_changed_in_window)
2713 (Lisp_Object specifier, struct window *w,
2714 Lisp_Object oldval),
2715 int struct_frame_offset,
2716 void (*value_changed_in_frame)
2717 (Lisp_Object specifier, struct frame *f,
2718 Lisp_Object oldval))
2720 struct Lisp_Specifier *sp = XSPECIFIER (specifier);
2721 assert (!GHOST_SPECIFIER_P (sp));
2724 sp->caching = xnew_and_zero (struct specifier_caching);
2725 sp->caching->offset_into_struct_window = struct_window_offset;
2726 sp->caching->value_changed_in_window = value_changed_in_window;
2727 sp->caching->offset_into_struct_frame = struct_frame_offset;
2728 sp->caching->value_changed_in_frame = value_changed_in_frame;
2729 Vcached_specifiers = Fcons (specifier, Vcached_specifiers);
2730 if (BODILY_SPECIFIER_P (sp))
2731 GHOST_SPECIFIER(sp)->caching = sp->caching;
2732 recompute_cached_specifier_everywhere (specifier);
2736 recompute_one_cached_specifier_in_window (Lisp_Object specifier,
2740 Lisp_Object newval, *location;
2742 assert (!GHOST_SPECIFIER_P (XSPECIFIER (specifier)));
2744 XSETWINDOW (window, w);
2746 newval = specifier_instance (specifier, Qunbound, window, ERROR_ME_WARN,
2748 /* If newval ended up Qunbound, then the calling functions
2749 better be able to deal. If not, set a default so this
2750 never happens or correct it in the value_changed_in_window
2752 location = (Lisp_Object *)
2753 ((char *) w + XSPECIFIER (specifier)->caching->offset_into_struct_window);
2754 if (!EQ (newval, *location))
2756 Lisp_Object oldval = *location;
2758 (XSPECIFIER (specifier)->caching->value_changed_in_window)
2759 (specifier, w, oldval);
2764 recompute_one_cached_specifier_in_frame (Lisp_Object specifier,
2768 Lisp_Object newval, *location;
2770 assert (!GHOST_SPECIFIER_P (XSPECIFIER (specifier)));
2772 XSETFRAME (frame, f);
2774 newval = specifier_instance (specifier, Qunbound, frame, ERROR_ME_WARN,
2776 /* If newval ended up Qunbound, then the calling functions
2777 better be able to deal. If not, set a default so this
2778 never happens or correct it in the value_changed_in_frame
2780 location = (Lisp_Object *)
2781 ((char *) f + XSPECIFIER (specifier)->caching->offset_into_struct_frame);
2782 if (!EQ (newval, *location))
2784 Lisp_Object oldval = *location;
2786 (XSPECIFIER (specifier)->caching->value_changed_in_frame)
2787 (specifier, f, oldval);
2792 recompute_all_cached_specifiers_in_window (struct window *w)
2796 LIST_LOOP (rest, Vcached_specifiers)
2798 Lisp_Object specifier = XCAR (rest);
2799 if (XSPECIFIER (specifier)->caching->offset_into_struct_window)
2800 recompute_one_cached_specifier_in_window (specifier, w);
2805 recompute_all_cached_specifiers_in_frame (struct frame *f)
2809 LIST_LOOP (rest, Vcached_specifiers)
2811 Lisp_Object specifier = XCAR (rest);
2812 if (XSPECIFIER (specifier)->caching->offset_into_struct_frame)
2813 recompute_one_cached_specifier_in_frame (specifier, f);
2818 recompute_cached_specifier_everywhere_mapfun (struct window *w,
2821 Lisp_Object specifier = Qnil;
2823 VOID_TO_LISP (specifier, closure);
2824 recompute_one_cached_specifier_in_window (specifier, w);
2829 recompute_cached_specifier_everywhere (Lisp_Object specifier)
2831 Lisp_Object frmcons, devcons, concons;
2833 specifier = bodily_specifier (specifier);
2835 if (!XSPECIFIER (specifier)->caching)
2838 if (XSPECIFIER (specifier)->caching->offset_into_struct_window)
2840 FRAME_LOOP_NO_BREAK (frmcons, devcons, concons)
2841 map_windows (XFRAME (XCAR (frmcons)),
2842 recompute_cached_specifier_everywhere_mapfun,
2843 LISP_TO_VOID (specifier));
2846 if (XSPECIFIER (specifier)->caching->offset_into_struct_frame)
2848 FRAME_LOOP_NO_BREAK (frmcons, devcons, concons)
2849 recompute_one_cached_specifier_in_frame (specifier,
2850 XFRAME (XCAR (frmcons)));
2854 DEFUN ("set-specifier-dirty-flag", Fset_specifier_dirty_flag, 1, 1, 0, /*
2855 Force recomputation of any caches associated with SPECIFIER.
2856 Note that this automatically happens whenever you change a specification
2857 in SPECIFIER; you do not have to call this function then.
2858 One example of where this function is useful is when you have a
2859 toolbar button whose `active-p' field is an expression to be
2860 evaluated. Calling `set-specifier-dirty-flag' on the
2861 toolbar specifier will force the `active-p' fields to be
2866 CHECK_SPECIFIER (specifier);
2867 recompute_cached_specifier_everywhere (specifier);
2872 /************************************************************************/
2873 /* Generic specifier type */
2874 /************************************************************************/
2876 DEFINE_SPECIFIER_TYPE (generic);
2880 /* This is the string that used to be in `generic-specifier-p'.
2881 The idea is good, but it doesn't quite work in the form it's
2882 in. (One major problem is that validating an instantiator
2883 is supposed to require only that the specifier type is passed,
2884 while with this approach the actual specifier is needed.)
2886 What really needs to be done is to write a function
2887 `make-specifier-type' that creates new specifier types.
2888 #### I'll look into this for 19.14.
2891 "A generic specifier is a generalized kind of specifier with user-defined\n"
2892 "semantics. The instantiator can be any kind of Lisp object, and the\n"
2893 "instance computed from it is likewise any kind of Lisp object. The\n"
2894 "SPECIFIER-DATA should be an alist of methods governing how the specifier\n"
2895 "works. All methods are optional, and reasonable default methods will be\n"
2896 "provided. Currently there are two defined methods: 'instantiate and\n"
2899 "'instantiate specifies how to do the instantiation; if omitted, the\n"
2900 "instantiator itself is simply returned as the instance. The method\n"
2901 "should be a function that accepts three parameters (a specifier, the\n"
2902 "instantiator that matched the domain being instantiated over, and that\n"
2903 "domain), and should return a one-element list containing the instance,\n"
2904 "or nil if no instance exists. Note that the domain passed to this function\n"
2905 "is the domain being instantiated over, which may not be the same as the\n"
2906 "locale contained in the specification corresponding to the instantiator\n"
2907 "(for example, the domain being instantiated over could be a window, but\n"
2908 "the locale corresponding to the passed instantiator could be the window's\n"
2909 "buffer or frame).\n"
2911 "'validate specifies whether a given instantiator is valid; if omitted,\n"
2912 "all instantiators are considered valid. It should be a function of\n"
2913 "two arguments: an instantiator and a flag CAN-SIGNAL-ERROR. If this\n"
2914 "flag is false, the function must simply return t or nil indicating\n"
2915 "whether the instantiator is valid. If this flag is true, the function\n"
2916 "is free to signal an error if it encounters an invalid instantiator\n"
2917 "(this can be useful for issuing a specific error about exactly why the\n"
2918 "instantiator is valid). It can also return nil to indicate an invalid\n"
2919 "instantiator; in this case, a general error will be signalled."
2923 DEFUN ("generic-specifier-p", Fgeneric_specifier_p, 1, 1, 0, /*
2924 Return non-nil if OBJECT is a generic specifier.
2926 A generic specifier allows any kind of Lisp object as an instantiator,
2927 and returns back the Lisp object unchanged when it is instantiated.
2931 return GENERIC_SPECIFIERP (object) ? Qt : Qnil;
2935 /************************************************************************/
2936 /* Integer specifier type */
2937 /************************************************************************/
2939 DEFINE_SPECIFIER_TYPE (integer);
2942 integer_validate (Lisp_Object instantiator)
2944 CHECK_INT (instantiator);
2947 DEFUN ("integer-specifier-p", Finteger_specifier_p, 1, 1, 0, /*
2948 Return non-nil if OBJECT is an integer specifier.
2952 return INTEGER_SPECIFIERP (object) ? Qt : Qnil;
2955 /************************************************************************/
2956 /* Non-negative-integer specifier type */
2957 /************************************************************************/
2959 DEFINE_SPECIFIER_TYPE (natnum);
2962 natnum_validate (Lisp_Object instantiator)
2964 CHECK_NATNUM (instantiator);
2967 DEFUN ("natnum-specifier-p", Fnatnum_specifier_p, 1, 1, 0, /*
2968 Return non-nil if OBJECT is a natnum (non-negative-integer) specifier.
2972 return NATNUM_SPECIFIERP (object) ? Qt : Qnil;
2975 /************************************************************************/
2976 /* Boolean specifier type */
2977 /************************************************************************/
2979 DEFINE_SPECIFIER_TYPE (boolean);
2982 boolean_validate (Lisp_Object instantiator)
2984 if (!EQ (instantiator, Qt) && !EQ (instantiator, Qnil))
2985 signal_simple_error ("Must be t or nil", instantiator);
2988 DEFUN ("boolean-specifier-p", Fboolean_specifier_p, 1, 1, 0, /*
2989 Return non-nil if OBJECT is a boolean specifier.
2993 return BOOLEAN_SPECIFIERP (object) ? Qt : Qnil;
2996 /************************************************************************/
2997 /* Display table specifier type */
2998 /************************************************************************/
3000 DEFINE_SPECIFIER_TYPE (display_table);
3002 #define VALID_SINGLE_DISPTABLE_INSTANTIATOR_P(instantiator) \
3003 (VECTORP (instantiator) \
3004 || (CHAR_TABLEP (instantiator) \
3005 && (XCHAR_TABLE_TYPE (instantiator) == CHAR_TABLE_TYPE_CHAR \
3006 || XCHAR_TABLE_TYPE (instantiator) == CHAR_TABLE_TYPE_GENERIC)) \
3007 || RANGE_TABLEP (instantiator))
3010 display_table_validate (Lisp_Object instantiator)
3012 if (NILP (instantiator))
3015 else if (CONSP (instantiator))
3018 EXTERNAL_LIST_LOOP (tail, instantiator)
3020 Lisp_Object car = XCAR (tail);
3021 if (!VALID_SINGLE_DISPTABLE_INSTANTIATOR_P (car))
3027 if (!VALID_SINGLE_DISPTABLE_INSTANTIATOR_P (instantiator))
3030 dead_wrong_type_argument (display_table_specifier_methods->predicate_symbol,
3036 DEFUN ("display-table-specifier-p", Fdisplay_table_specifier_p, 1, 1, 0, /*
3037 Return non-nil if OBJECT is a display-table specifier.
3041 return DISPLAYTABLE_SPECIFIERP (object) ? Qt : Qnil;
3045 /************************************************************************/
3046 /* Initialization */
3047 /************************************************************************/
3050 syms_of_specifier (void)
3052 defsymbol (&Qspecifierp, "specifierp");
3054 defsymbol (&Qconsole_type, "console-type");
3055 defsymbol (&Qdevice_class, "device-class");
3057 /* Qinteger, Qboolean, Qgeneric defined in general.c */
3058 defsymbol (&Qnatnum, "natnum");
3060 DEFSUBR (Fvalid_specifier_type_p);
3061 DEFSUBR (Fspecifier_type_list);
3062 DEFSUBR (Fmake_specifier);
3063 DEFSUBR (Fspecifierp);
3064 DEFSUBR (Fspecifier_type);
3066 DEFSUBR (Fvalid_specifier_locale_p);
3067 DEFSUBR (Fvalid_specifier_domain_p);
3068 DEFSUBR (Fvalid_specifier_locale_type_p);
3069 DEFSUBR (Fspecifier_locale_type_from_locale);
3071 DEFSUBR (Fvalid_specifier_tag_p);
3072 DEFSUBR (Fvalid_specifier_tag_set_p);
3073 DEFSUBR (Fcanonicalize_tag_set);
3074 DEFSUBR (Fdevice_matches_specifier_tag_set_p);
3075 DEFSUBR (Fdefine_specifier_tag);
3076 DEFSUBR (Fdevice_matching_specifier_tag_list);
3077 DEFSUBR (Fspecifier_tag_list);
3078 DEFSUBR (Fspecifier_tag_predicate);
3080 DEFSUBR (Fcheck_valid_instantiator);
3081 DEFSUBR (Fvalid_instantiator_p);
3082 DEFSUBR (Fcheck_valid_inst_list);
3083 DEFSUBR (Fvalid_inst_list_p);
3084 DEFSUBR (Fcheck_valid_spec_list);
3085 DEFSUBR (Fvalid_spec_list_p);
3086 DEFSUBR (Fadd_spec_to_specifier);
3087 DEFSUBR (Fadd_spec_list_to_specifier);
3088 DEFSUBR (Fspecifier_spec_list);
3089 DEFSUBR (Fspecifier_specs);
3090 DEFSUBR (Fremove_specifier);
3091 DEFSUBR (Fcopy_specifier);
3093 DEFSUBR (Fcheck_valid_specifier_matchspec);
3094 DEFSUBR (Fvalid_specifier_matchspec_p);
3095 DEFSUBR (Fspecifier_fallback);
3096 DEFSUBR (Fspecifier_instance);
3097 DEFSUBR (Fspecifier_matching_instance);
3098 DEFSUBR (Fspecifier_instance_from_inst_list);
3099 DEFSUBR (Fspecifier_matching_instance_from_inst_list);
3100 DEFSUBR (Fset_specifier_dirty_flag);
3102 DEFSUBR (Fgeneric_specifier_p);
3103 DEFSUBR (Finteger_specifier_p);
3104 DEFSUBR (Fnatnum_specifier_p);
3105 DEFSUBR (Fboolean_specifier_p);
3106 DEFSUBR (Fdisplay_table_specifier_p);
3108 /* Symbols pertaining to specifier creation. Specifiers are created
3109 in the syms_of() functions. */
3111 /* locales are defined in general.c. */
3113 defsymbol (&Qprepend, "prepend");
3114 defsymbol (&Qappend, "append");
3115 defsymbol (&Qremove_tag_set_prepend, "remove-tag-set-prepend");
3116 defsymbol (&Qremove_tag_set_append, "remove-tag-set-append");
3117 defsymbol (&Qremove_locale, "remove-locale");
3118 defsymbol (&Qremove_locale_type, "remove-locale-type");
3119 defsymbol (&Qremove_all, "remove-all");
3121 defsymbol (&Qfallback, "fallback");
3125 specifier_type_create (void)
3127 the_specifier_type_entry_dynarr = Dynarr_new (specifier_type_entry);
3129 Vspecifier_type_list = Qnil;
3130 staticpro (&Vspecifier_type_list);
3132 INITIALIZE_SPECIFIER_TYPE (generic, "generic", "generic-specifier-p");
3134 INITIALIZE_SPECIFIER_TYPE (integer, "integer", "integer-specifier-p");
3136 SPECIFIER_HAS_METHOD (integer, validate);
3138 INITIALIZE_SPECIFIER_TYPE (natnum, "natnum", "natnum-specifier-p");
3140 SPECIFIER_HAS_METHOD (natnum, validate);
3142 INITIALIZE_SPECIFIER_TYPE (boolean, "boolean", "boolean-specifier-p");
3144 SPECIFIER_HAS_METHOD (boolean, validate);
3146 INITIALIZE_SPECIFIER_TYPE (display_table, "display-table", "display-table-p");
3148 SPECIFIER_HAS_METHOD (display_table, validate);
3152 vars_of_specifier (void)
3154 Vcached_specifiers = Qnil;
3155 staticpro (&Vcached_specifiers);
3157 /* Do NOT mark through this, or specifiers will never be GC'd.
3158 This is the same deal as for weak hash tables. */
3159 Vall_specifiers = Qnil;
3161 Vuser_defined_tags = Qnil;
3162 staticpro (&Vuser_defined_tags);
3164 Vunlock_ghost_specifiers = Qnil;
3165 staticpro (&Vunlock_ghost_specifiers);