1 /* Specifier implementation
2 Copyright (C) 1994, 1995 Board of Trustees, University of Illinois.
3 Copyright (C) 1995, 1996 Ben Wing.
4 Copyright (C) 1995 Sun Microsystems, Inc.
6 This file is part of XEmacs.
8 XEmacs is free software; you can redistribute it and/or modify it
9 under the terms of the GNU General Public License as published by the
10 Free Software Foundation; either version 2, or (at your option) any
13 XEmacs is distributed in the hope that it will be useful, but WITHOUT
14 ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or
15 FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
18 You should have received a copy of the GNU General Public License
19 along with XEmacs; see the file COPYING. If not, write to
20 the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
21 Boston, MA 02111-1307, USA. */
23 /* Synched up with: Not in FSF. */
25 /* Design by Ben Wing;
26 Original version by Chuck Thompson;
27 rewritten by Ben Wing;
28 Magic specifiers by Kirill Katsnelson;
38 #include "specifier.h"
43 Lisp_Object Qspecifierp;
44 Lisp_Object Qprepend, Qappend, Qremove_tag_set_prepend, Qremove_tag_set_append;
45 Lisp_Object Qremove_locale, Qremove_locale_type, Qremove_all;
46 Lisp_Object Qfallback;
48 /* Qinteger, Qboolean, Qgeneric defined in general.c. */
51 Lisp_Object Qconsole_type, Qdevice_class;
53 static Lisp_Object Vuser_defined_tags;
55 typedef struct specifier_type_entry specifier_type_entry;
56 struct specifier_type_entry
59 struct specifier_methods *meths;
64 Dynarr_declare (specifier_type_entry);
65 } specifier_type_entry_dynarr;
67 static specifier_type_entry_dynarr *the_specifier_type_entry_dynarr;
69 static const struct lrecord_description ste_description_1[] = {
70 { XD_LISP_OBJECT, offsetof (specifier_type_entry, symbol) },
71 { XD_STRUCT_PTR, offsetof (specifier_type_entry, meths), 1, &specifier_methods_description },
75 static const struct struct_description ste_description = {
76 sizeof (specifier_type_entry),
80 static const struct lrecord_description sted_description_1[] = {
81 XD_DYNARR_DESC (specifier_type_entry_dynarr, &ste_description),
85 static const struct struct_description sted_description = {
86 sizeof (specifier_type_entry_dynarr),
90 static Lisp_Object Vspecifier_type_list;
92 static Lisp_Object Vcached_specifiers;
93 /* Do NOT mark through this, or specifiers will never be GC'd. */
94 static Lisp_Object Vall_specifiers;
96 static Lisp_Object Vunlock_ghost_specifiers;
98 /* #### The purpose of this is to check for inheritance loops
99 in specifiers that can inherit from other specifiers, but it's
102 #### Look into this for 19.14. */
103 /* static Lisp_Object_dynarr current_specifiers; */
105 static void recompute_cached_specifier_everywhere (Lisp_Object specifier);
107 EXFUN (Fspecifier_specs, 4);
108 EXFUN (Fremove_specifier, 4);
111 /************************************************************************/
112 /* Specifier object methods */
113 /************************************************************************/
115 /* Remove dead objects from the specified assoc list. */
118 cleanup_assoc_list (Lisp_Object list)
120 Lisp_Object loop, prev, retval;
122 loop = retval = list;
127 Lisp_Object entry = XCAR (loop);
128 Lisp_Object key = XCAR (entry);
130 /* remember, dead windows can become alive again. */
131 if (!WINDOWP (key) && object_dead_p (key))
135 /* Removing the head. */
136 retval = XCDR (retval);
140 Fsetcdr (prev, XCDR (loop));
152 /* Remove dead objects from the various lists so that they
153 don't keep getting marked as long as this specifier exists and
154 therefore wasting memory. */
157 cleanup_specifiers (void)
161 for (rest = Vall_specifiers;
163 rest = XSPECIFIER (rest)->next_specifier)
165 Lisp_Specifier *sp = XSPECIFIER (rest);
166 /* This effectively changes the specifier specs.
167 However, there's no need to call
168 recompute_cached_specifier_everywhere() or the
169 after-change methods because the only specs we
170 are removing are for dead objects, and they can
171 never have any effect on the specifier values:
172 specifiers can only be instantiated over live
173 objects, and you can't derive a dead object
175 sp->device_specs = cleanup_assoc_list (sp->device_specs);
176 sp->frame_specs = cleanup_assoc_list (sp->frame_specs);
177 sp->buffer_specs = cleanup_assoc_list (sp->buffer_specs);
178 /* windows are handled specially because dead windows
179 can be resurrected */
184 kill_specifier_buffer_locals (Lisp_Object buffer)
188 for (rest = Vall_specifiers;
190 rest = XSPECIFIER (rest)->next_specifier)
192 Lisp_Specifier *sp = XSPECIFIER (rest);
194 /* Make sure we're actually going to be changing something.
195 Fremove_specifier() always calls
196 recompute_cached_specifier_everywhere() (#### but should
197 be smarter about this). */
198 if (!NILP (assq_no_quit (buffer, sp->buffer_specs)))
199 Fremove_specifier (rest, buffer, Qnil, Qnil);
204 mark_specifier (Lisp_Object obj)
206 Lisp_Specifier *specifier = XSPECIFIER (obj);
208 mark_object (specifier->global_specs);
209 mark_object (specifier->device_specs);
210 mark_object (specifier->frame_specs);
211 mark_object (specifier->window_specs);
212 mark_object (specifier->buffer_specs);
213 mark_object (specifier->magic_parent);
214 mark_object (specifier->fallback);
215 if (!GHOST_SPECIFIER_P (XSPECIFIER (obj)))
216 MAYBE_SPECMETH (specifier, mark, (obj));
220 /* The idea here is that the specifier specs point to locales
221 (windows, buffers, frames, and devices), and we want to make sure
222 that the specs disappear automatically when the associated locale
223 is no longer in use. For all but windows, "no longer in use"
224 corresponds exactly to when the object is deleted (non-deleted
225 objects are always held permanently in special lists, and deleted
226 objects are never on these lists and never reusable). To handle
227 this, we just have cleanup_specifiers() called periodically
228 (at the beginning of garbage collection); it removes all dead
231 For windows, however, it's trickier because dead objects can be
232 converted to live ones again if the dead object is in a window
233 configuration. Therefore, for windows, "no longer in use"
234 corresponds to when the window object is garbage-collected.
235 We now use weak lists for this purpose.
240 prune_specifiers (void)
242 Lisp_Object rest, prev = Qnil;
244 for (rest = Vall_specifiers;
246 rest = XSPECIFIER (rest)->next_specifier)
248 if (! marked_p (rest))
250 Lisp_Specifier* sp = XSPECIFIER (rest);
251 /* A bit of assertion that we're removing both parts of the
252 magic one altogether */
253 assert (!MAGIC_SPECIFIER_P(sp)
254 || (BODILY_SPECIFIER_P(sp) && marked_p (sp->fallback))
255 || (GHOST_SPECIFIER_P(sp) && marked_p (sp->magic_parent)));
256 /* This specifier is garbage. Remove it from the list. */
258 Vall_specifiers = sp->next_specifier;
260 XSPECIFIER (prev)->next_specifier = sp->next_specifier;
268 print_specifier (Lisp_Object obj, Lisp_Object printcharfun, int escapeflag)
270 Lisp_Specifier *sp = XSPECIFIER (obj);
272 int count = specpdl_depth ();
273 Lisp_Object the_specs;
276 error ("printing unreadable object #<%s-specifier 0x%x>",
277 sp->methods->name, sp->header.uid);
279 sprintf (buf, "#<%s-specifier global=", sp->methods->name);
280 write_c_string (buf, printcharfun);
281 specbind (Qprint_string_length, make_int (100));
282 specbind (Qprint_length, make_int (5));
283 the_specs = Fspecifier_specs (obj, Qglobal, Qnil, Qnil);
284 if (NILP (the_specs))
285 /* there are no global specs */
286 write_c_string ("<unspecified>", printcharfun);
288 print_internal (the_specs, printcharfun, 1);
289 if (!NILP (sp->fallback))
291 write_c_string (" fallback=", printcharfun);
292 print_internal (sp->fallback, printcharfun, escapeflag);
294 unbind_to (count, Qnil);
295 sprintf (buf, " 0x%x>", sp->header.uid);
296 write_c_string (buf, printcharfun);
300 finalize_specifier (void *header, int for_disksave)
302 Lisp_Specifier *sp = (Lisp_Specifier *) header;
303 /* don't be snafued by the disksave finalization. */
304 if (!for_disksave && !GHOST_SPECIFIER_P(sp) && sp->caching)
312 specifier_equal (Lisp_Object obj1, Lisp_Object obj2, int depth)
314 Lisp_Specifier *s1 = XSPECIFIER (obj1);
315 Lisp_Specifier *s2 = XSPECIFIER (obj2);
317 Lisp_Object old_inhibit_quit = Vinhibit_quit;
319 /* This function can be called from within redisplay.
320 internal_equal can trigger a quit. That leads to Bad Things. */
325 (s1->methods == s2->methods &&
326 internal_equal (s1->global_specs, s2->global_specs, depth) &&
327 internal_equal (s1->device_specs, s2->device_specs, depth) &&
328 internal_equal (s1->frame_specs, s2->frame_specs, depth) &&
329 internal_equal (s1->window_specs, s2->window_specs, depth) &&
330 internal_equal (s1->buffer_specs, s2->buffer_specs, depth) &&
331 internal_equal (s1->fallback, s2->fallback, depth));
333 if (retval && HAS_SPECMETH_P (s1, equal))
334 retval = SPECMETH (s1, equal, (obj1, obj2, depth - 1));
336 Vinhibit_quit = old_inhibit_quit;
341 specifier_hash (Lisp_Object obj, int depth)
343 Lisp_Specifier *s = XSPECIFIER (obj);
345 /* specifier hashing is a bit problematic because there are so
346 many places where data can be stored. We pick what are perhaps
347 the most likely places where interesting stuff will be. */
348 return HASH5 ((HAS_SPECMETH_P (s, hash) ?
349 SPECMETH (s, hash, (obj, depth)) : 0),
350 (unsigned long) s->methods,
351 internal_hash (s->global_specs, depth + 1),
352 internal_hash (s->frame_specs, depth + 1),
353 internal_hash (s->buffer_specs, depth + 1));
357 sizeof_specifier (const void *header)
359 if (GHOST_SPECIFIER_P ((Lisp_Specifier *) header))
360 return offsetof (Lisp_Specifier, data);
363 const Lisp_Specifier *p = (const Lisp_Specifier *) header;
364 return offsetof (Lisp_Specifier, data) + p->methods->extra_data_size;
368 static const struct lrecord_description specifier_methods_description_1[] = {
369 { XD_LISP_OBJECT, offsetof (struct specifier_methods, predicate_symbol) },
373 const struct struct_description specifier_methods_description = {
374 sizeof (struct specifier_methods),
375 specifier_methods_description_1
378 static const struct lrecord_description specifier_caching_description_1[] = {
382 static const struct struct_description specifier_caching_description = {
383 sizeof (struct specifier_caching),
384 specifier_caching_description_1
387 static const struct lrecord_description specifier_description[] = {
388 { XD_STRUCT_PTR, offsetof (Lisp_Specifier, methods), 1, &specifier_methods_description },
389 { XD_LO_LINK, offsetof (Lisp_Specifier, next_specifier) },
390 { XD_LISP_OBJECT, offsetof (Lisp_Specifier, global_specs) },
391 { XD_LISP_OBJECT, offsetof (Lisp_Specifier, device_specs) },
392 { XD_LISP_OBJECT, offsetof (Lisp_Specifier, frame_specs) },
393 { XD_LISP_OBJECT, offsetof (Lisp_Specifier, window_specs) },
394 { XD_LISP_OBJECT, offsetof (Lisp_Specifier, buffer_specs) },
395 { XD_STRUCT_PTR, offsetof (Lisp_Specifier, caching), 1, &specifier_caching_description },
396 { XD_LISP_OBJECT, offsetof (Lisp_Specifier, magic_parent) },
397 { XD_LISP_OBJECT, offsetof (Lisp_Specifier, fallback) },
401 const struct lrecord_description specifier_empty_extra_description[] = {
405 DEFINE_LRECORD_SEQUENCE_IMPLEMENTATION ("specifier", specifier,
406 mark_specifier, print_specifier,
408 specifier_equal, specifier_hash,
409 specifier_description,
413 /************************************************************************/
414 /* Creating specifiers */
415 /************************************************************************/
417 static struct specifier_methods *
418 decode_specifier_type (Lisp_Object type, Error_behavior errb)
422 for (i = 0; i < Dynarr_length (the_specifier_type_entry_dynarr); i++)
424 if (EQ (type, Dynarr_at (the_specifier_type_entry_dynarr, i).symbol))
425 return Dynarr_at (the_specifier_type_entry_dynarr, i).meths;
428 maybe_signal_simple_error ("Invalid specifier type", type,
435 valid_specifier_type_p (Lisp_Object type)
437 return decode_specifier_type (type, ERROR_ME_NOT) != 0;
440 DEFUN ("valid-specifier-type-p", Fvalid_specifier_type_p, 1, 1, 0, /*
441 Given a SPECIFIER-TYPE, return non-nil if it is valid.
442 Valid types are 'generic, 'integer, boolean, 'color, 'font, 'image,
443 'face-boolean, and 'toolbar.
447 return valid_specifier_type_p (specifier_type) ? Qt : Qnil;
450 DEFUN ("specifier-type-list", Fspecifier_type_list, 0, 0, 0, /*
451 Return a list of valid specifier types.
455 return Fcopy_sequence (Vspecifier_type_list);
459 add_entry_to_specifier_type_list (Lisp_Object symbol,
460 struct specifier_methods *meths)
462 struct specifier_type_entry entry;
464 entry.symbol = symbol;
466 Dynarr_add (the_specifier_type_entry_dynarr, entry);
467 Vspecifier_type_list = Fcons (symbol, Vspecifier_type_list);
471 make_specifier_internal (struct specifier_methods *spec_meths,
472 size_t data_size, int call_create_meth)
474 Lisp_Object specifier;
475 Lisp_Specifier *sp = (Lisp_Specifier *)
476 alloc_lcrecord (offsetof (Lisp_Specifier, data) + data_size,
479 sp->methods = spec_meths;
480 sp->global_specs = Qnil;
481 sp->device_specs = Qnil;
482 sp->frame_specs = Qnil;
483 sp->window_specs = make_weak_list (WEAK_LIST_KEY_ASSOC);
484 sp->buffer_specs = Qnil;
486 sp->magic_parent = Qnil;
488 sp->next_specifier = Vall_specifiers;
490 XSETSPECIFIER (specifier, sp);
491 Vall_specifiers = specifier;
493 if (call_create_meth)
497 MAYBE_SPECMETH (XSPECIFIER (specifier), create, (specifier));
504 make_specifier (struct specifier_methods *meths)
506 return make_specifier_internal (meths, meths->extra_data_size, 1);
510 make_magic_specifier (Lisp_Object type)
512 /* This function can GC */
513 struct specifier_methods *meths = decode_specifier_type (type, ERROR_ME);
514 Lisp_Object bodily, ghost;
517 bodily = make_specifier (meths);
519 ghost = make_specifier_internal (meths, 0, 0);
522 /* Connect guys together */
523 XSPECIFIER(bodily)->magic_parent = Qt;
524 XSPECIFIER(bodily)->fallback = ghost;
525 XSPECIFIER(ghost)->magic_parent = bodily;
530 DEFUN ("make-specifier", Fmake_specifier, 1, 1, 0, /*
531 Return a new specifier object of type TYPE.
533 A specifier is an object that can be used to keep track of a property
534 whose value can be per-buffer, per-window, per-frame, or per-device,
535 and can further be restricted to a particular console-type or device-class.
536 Specifiers are used, for example, for the various built-in properties of a
537 face; this allows a face to have different values in different frames,
538 buffers, etc. For more information, see `specifier-instance',
539 `specifier-specs', and `add-spec-to-specifier'; or, for a detailed
540 description of specifiers, including how they are instantiated over a
541 particular domain (i.e. how their value in that domain is determined),
542 see the chapter on specifiers in the XEmacs Lisp Reference Manual.
544 TYPE specifies the particular type of specifier, and should be one of
545 the symbols 'generic, 'integer, 'boolean, 'color, 'font, 'image,
546 'face-boolean, or 'toolbar.
548 For more information on particular types of specifiers, see the functions
549 `generic-specifier-p', `integer-specifier-p', `boolean-specifier-p',
550 `color-specifier-p', `font-specifier-p', `image-specifier-p',
551 `face-boolean-specifier-p', and `toolbar-specifier-p'.
555 /* This function can GC */
556 struct specifier_methods *meths = decode_specifier_type (type,
559 return make_specifier (meths);
562 DEFUN ("specifierp", Fspecifierp, 1, 1, 0, /*
563 Return t if OBJECT is a specifier.
565 A specifier is an object that can be used to keep track of a property
566 whose value can be per-buffer, per-window, per-frame, or per-device,
567 and can further be restricted to a particular console-type or device-class.
568 See `make-specifier'.
572 return SPECIFIERP (object) ? Qt : Qnil;
575 DEFUN ("specifier-type", Fspecifier_type, 1, 1, 0, /*
576 Return the type of SPECIFIER.
580 CHECK_SPECIFIER (specifier);
581 return intern (XSPECIFIER (specifier)->methods->name);
585 /************************************************************************/
586 /* Locales and domains */
587 /************************************************************************/
589 DEFUN ("valid-specifier-locale-p", Fvalid_specifier_locale_p, 1, 1, 0, /*
590 Return t if LOCALE is a valid specifier locale.
591 Valid locales are devices, frames, windows, buffers, and 'global.
596 /* This cannot GC. */
597 return ((DEVICEP (locale) && DEVICE_LIVE_P (XDEVICE (locale))) ||
598 (FRAMEP (locale) && FRAME_LIVE_P (XFRAME (locale))) ||
599 (BUFFERP (locale) && BUFFER_LIVE_P (XBUFFER (locale))) ||
600 /* dead windows are allowed because they may become live
601 windows again when a window configuration is restored */
603 EQ (locale, Qglobal))
607 DEFUN ("valid-specifier-domain-p", Fvalid_specifier_domain_p, 1, 1, 0, /*
608 Return t if DOMAIN is a valid specifier domain.
609 A domain is used to instance a specifier (i.e. determine the specifier's
610 value in that domain). Valid domains are windows, frames, and devices.
615 /* This cannot GC. */
616 return ((DEVICEP (domain) && DEVICE_LIVE_P (XDEVICE (domain))) ||
617 (FRAMEP (domain) && FRAME_LIVE_P (XFRAME (domain))) ||
618 (WINDOWP (domain) && WINDOW_LIVE_P (XWINDOW (domain))))
622 DEFUN ("valid-specifier-locale-type-p", Fvalid_specifier_locale_type_p, 1, 1, 0, /*
623 Given a specifier LOCALE-TYPE, return non-nil if it is valid.
624 Valid locale types are 'global, 'device, 'frame, 'window, and 'buffer.
625 \(Note, however, that in functions that accept either a locale or a locale
626 type, 'global is considered an individual locale.)
630 /* This cannot GC. */
631 return (EQ (locale_type, Qglobal) ||
632 EQ (locale_type, Qdevice) ||
633 EQ (locale_type, Qframe) ||
634 EQ (locale_type, Qwindow) ||
635 EQ (locale_type, Qbuffer)) ? Qt : Qnil;
639 check_valid_locale_or_locale_type (Lisp_Object locale)
641 /* This cannot GC. */
642 if (EQ (locale, Qall) ||
643 !NILP (Fvalid_specifier_locale_p (locale)) ||
644 !NILP (Fvalid_specifier_locale_type_p (locale)))
646 signal_simple_error ("Invalid specifier locale or locale type", locale);
649 DEFUN ("specifier-locale-type-from-locale", Fspecifier_locale_type_from_locale,
651 Given a specifier LOCALE, return its type.
655 /* This cannot GC. */
656 if (NILP (Fvalid_specifier_locale_p (locale)))
657 signal_simple_error ("Invalid specifier locale", locale);
658 if (DEVICEP (locale)) return Qdevice;
659 if (FRAMEP (locale)) return Qframe;
660 if (WINDOWP (locale)) return Qwindow;
661 if (BUFFERP (locale)) return Qbuffer;
662 assert (EQ (locale, Qglobal));
667 decode_locale (Lisp_Object locale)
669 /* This cannot GC. */
672 else if (!NILP (Fvalid_specifier_locale_p (locale)))
675 signal_simple_error ("Invalid specifier locale", locale);
680 static enum spec_locale_type
681 decode_locale_type (Lisp_Object locale_type)
683 /* This cannot GC. */
684 if (EQ (locale_type, Qglobal)) return LOCALE_GLOBAL;
685 if (EQ (locale_type, Qdevice)) return LOCALE_DEVICE;
686 if (EQ (locale_type, Qframe)) return LOCALE_FRAME;
687 if (EQ (locale_type, Qwindow)) return LOCALE_WINDOW;
688 if (EQ (locale_type, Qbuffer)) return LOCALE_BUFFER;
690 signal_simple_error ("Invalid specifier locale type", locale_type);
691 return LOCALE_GLOBAL; /* not reached */
695 decode_locale_list (Lisp_Object locale)
697 /* This cannot GC. */
698 /* The return value of this function must be GCPRO'd. */
703 else if (CONSP (locale))
706 EXTERNAL_LIST_LOOP_2 (elt, locale)
707 check_valid_locale_or_locale_type (elt);
712 check_valid_locale_or_locale_type (locale);
713 return list1 (locale);
717 static enum spec_locale_type
718 locale_type_from_locale (Lisp_Object locale)
720 return decode_locale_type (Fspecifier_locale_type_from_locale (locale));
724 check_valid_domain (Lisp_Object domain)
726 if (NILP (Fvalid_specifier_domain_p (domain)))
727 signal_simple_error ("Invalid specifier domain", domain);
731 decode_domain (Lisp_Object domain)
734 return Fselected_window (Qnil);
735 check_valid_domain (domain);
740 /************************************************************************/
742 /************************************************************************/
744 DEFUN ("valid-specifier-tag-p", Fvalid_specifier_tag_p, 1, 1, 0, /*
745 Return non-nil if TAG is a valid specifier tag.
746 See also `valid-specifier-tag-set-p'.
750 return (valid_console_type_p (tag) ||
751 valid_device_class_p (tag) ||
752 !NILP (assq_no_quit (tag, Vuser_defined_tags))) ? Qt : Qnil;
755 DEFUN ("valid-specifier-tag-set-p", Fvalid_specifier_tag_set_p, 1, 1, 0, /*
756 Return non-nil if TAG-SET is a valid specifier tag set.
758 A specifier tag set is an entity that is attached to an instantiator
759 and can be used to restrict the scope of that instantiator to a
760 particular device class or device type and/or to mark instantiators
761 added by a particular package so that they can be later removed.
763 A specifier tag set consists of a list of zero of more specifier tags,
764 each of which is a symbol that is recognized by XEmacs as a tag.
765 \(The valid device types and device classes are always tags, as are
766 any tags defined by `define-specifier-tag'.) It is called a "tag set"
767 \(as opposed to a list) because the order of the tags or the number of
768 times a particular tag occurs does not matter.
770 Each tag has a predicate associated with it, which specifies whether
771 that tag applies to a particular device. The tags which are device types
772 and classes match devices of that type or class. User-defined tags can
773 have any predicate, or none (meaning that all devices match). When
774 attempting to instance a specifier, a particular instantiator is only
775 considered if the device of the domain being instanced over matches
776 all tags in the tag set attached to that instantiator.
778 Most of the time, a tag set is not specified, and the instantiator
779 gets a null tag set, which matches all devices.
785 for (rest = tag_set; !NILP (rest); rest = XCDR (rest))
789 if (NILP (Fvalid_specifier_tag_p (XCAR (rest))))
797 decode_specifier_tag_set (Lisp_Object tag_set)
799 /* The return value of this function must be GCPRO'd. */
800 if (!NILP (Fvalid_specifier_tag_p (tag_set)))
801 return list1 (tag_set);
802 if (NILP (Fvalid_specifier_tag_set_p (tag_set)))
803 signal_simple_error ("Invalid specifier tag-set", tag_set);
808 canonicalize_tag_set (Lisp_Object tag_set)
810 int len = XINT (Flength (tag_set));
811 Lisp_Object *tags, rest;
814 /* We assume in this function that the tag_set has already been
815 validated, so there are no surprises. */
817 if (len == 0 || len == 1)
818 /* most common case */
821 tags = alloca_array (Lisp_Object, len);
824 LIST_LOOP (rest, tag_set)
825 tags[i++] = XCAR (rest);
827 /* Sort the list of tags. We use a bubble sort here (copied from
828 extent_fragment_update()) -- reduces the function call overhead,
829 and is the fastest sort for small numbers of items. */
831 for (i = 1; i < len; i++)
835 strcmp ((char *) string_data (XSYMBOL (tags[j])->name),
836 (char *) string_data (XSYMBOL (tags[j+1])->name)) > 0)
838 Lisp_Object tmp = tags[j];
845 /* Now eliminate duplicates. */
847 for (i = 1, j = 1; i < len; i++)
849 /* j holds the destination, i the source. */
850 if (!EQ (tags[i], tags[i-1]))
854 return Flist (j, tags);
857 DEFUN ("canonicalize-tag-set", Fcanonicalize_tag_set, 1, 1, 0, /*
858 Canonicalize the given tag set.
859 Two canonicalized tag sets can be compared with `equal' to see if they
860 represent the same tag set. (Specifically, canonicalizing involves
861 sorting by symbol name and removing duplicates.)
865 if (NILP (Fvalid_specifier_tag_set_p (tag_set)))
866 signal_simple_error ("Invalid tag set", tag_set);
867 return canonicalize_tag_set (tag_set);
871 device_matches_specifier_tag_set_p (Lisp_Object device, Lisp_Object tag_set)
873 Lisp_Object devtype, devclass, rest;
874 struct device *d = XDEVICE (device);
876 devtype = DEVICE_TYPE (d);
877 devclass = DEVICE_CLASS (d);
879 LIST_LOOP (rest, tag_set)
881 Lisp_Object tag = XCAR (rest);
884 if (EQ (tag, devtype) || EQ (tag, devclass))
886 assoc = assq_no_quit (tag, DEVICE_USER_DEFINED_TAGS (d));
887 /* other built-in tags (device types/classes) are not in
888 the user-defined-tags list. */
889 if (NILP (assoc) || NILP (XCDR (assoc)))
896 DEFUN ("device-matches-specifier-tag-set-p", Fdevice_matches_specifier_tag_set_p, 2, 2, 0, /*
897 Return non-nil if DEVICE matches specifier tag set TAG-SET.
898 This means that DEVICE matches each tag in the tag set. (Every
899 tag recognized by XEmacs has a predicate associated with it that
900 specifies which devices match it.)
904 CHECK_LIVE_DEVICE (device);
906 if (NILP (Fvalid_specifier_tag_set_p (tag_set)))
907 signal_simple_error ("Invalid tag set", tag_set);
909 return device_matches_specifier_tag_set_p (device, tag_set) ? Qt : Qnil;
912 DEFUN ("define-specifier-tag", Fdefine_specifier_tag, 1, 2, 0, /*
913 Define a new specifier tag.
914 If PREDICATE is specified, it should be a function of one argument
915 \(a device) that specifies whether the tag matches that particular
916 device. If PREDICATE is omitted, the tag matches all devices.
918 You can redefine an existing user-defined specifier tag. However,
919 you cannot redefine the built-in specifier tags (the device types
920 and classes) or the symbols nil, t, 'all, or 'global.
924 Lisp_Object assoc, devcons, concons;
928 if (valid_device_class_p (tag) ||
929 valid_console_type_p (tag))
930 signal_simple_error ("Cannot redefine built-in specifier tags", tag);
931 /* Try to prevent common instantiators and locales from being
932 redefined, to reduce ambiguity */
933 if (NILP (tag) || EQ (tag, Qt) || EQ (tag, Qall) || EQ (tag, Qglobal))
934 signal_simple_error ("Cannot define nil, t, 'all, or 'global",
936 assoc = assq_no_quit (tag, Vuser_defined_tags);
940 Vuser_defined_tags = Fcons (Fcons (tag, predicate), Vuser_defined_tags);
941 DEVICE_LOOP_NO_BREAK (devcons, concons)
943 struct device *d = XDEVICE (XCAR (devcons));
944 /* Initially set the value to t in case of error
946 DEVICE_USER_DEFINED_TAGS (d) =
947 Fcons (Fcons (tag, Qt), DEVICE_USER_DEFINED_TAGS (d));
950 else if (!NILP (predicate) && !NILP (XCDR (assoc)))
953 XCDR (assoc) = predicate;
956 /* recompute the tag values for all devices. However, in the special
957 case where both the old and new predicates are nil, we know that
958 we don't have to do this. (It's probably common for people to
959 call (define-specifier-tag) more than once on the same tag,
960 and the most common case is where PREDICATE is not specified.) */
964 DEVICE_LOOP_NO_BREAK (devcons, concons)
966 Lisp_Object device = XCAR (devcons);
967 assoc = assq_no_quit (tag,
968 DEVICE_USER_DEFINED_TAGS (XDEVICE (device)));
969 assert (CONSP (assoc));
970 if (NILP (predicate))
973 XCDR (assoc) = !NILP (call1 (predicate, device)) ? Qt : Qnil;
980 /* Called at device-creation time to initialize the user-defined
981 tag values for the newly-created device. */
984 setup_device_initial_specifier_tags (struct device *d)
986 Lisp_Object rest, rest2;
989 XSETDEVICE (device, d);
991 DEVICE_USER_DEFINED_TAGS (d) = Fcopy_alist (Vuser_defined_tags);
993 /* Now set up the initial values */
994 LIST_LOOP (rest, DEVICE_USER_DEFINED_TAGS (d))
995 XCDR (XCAR (rest)) = Qt;
997 for (rest = Vuser_defined_tags, rest2 = DEVICE_USER_DEFINED_TAGS (d);
998 !NILP (rest); rest = XCDR (rest), rest2 = XCDR (rest2))
1000 Lisp_Object predicate = XCDR (XCAR (rest));
1001 if (NILP (predicate))
1002 XCDR (XCAR (rest2)) = Qt;
1004 XCDR (XCAR (rest2)) = !NILP (call1 (predicate, device)) ? Qt : Qnil;
1008 DEFUN ("device-matching-specifier-tag-list", Fdevice_matching_specifier_tag_list,
1010 Return a list of all specifier tags matching DEVICE.
1011 DEVICE defaults to the selected device if omitted.
1015 struct device *d = decode_device (device);
1016 Lisp_Object rest, list = Qnil;
1017 struct gcpro gcpro1;
1021 LIST_LOOP (rest, DEVICE_USER_DEFINED_TAGS (d))
1023 if (!NILP (XCDR (XCAR (rest))))
1024 list = Fcons (XCAR (XCAR (rest)), list);
1027 list = Fnreverse (list);
1028 list = Fcons (DEVICE_CLASS (d), list);
1029 list = Fcons (DEVICE_TYPE (d), list);
1031 RETURN_UNGCPRO (list);
1034 DEFUN ("specifier-tag-list", Fspecifier_tag_list, 0, 0, 0, /*
1035 Return a list of all currently-defined specifier tags.
1036 This includes the built-in ones (the device types and classes).
1040 Lisp_Object list = Qnil, rest;
1041 struct gcpro gcpro1;
1045 LIST_LOOP (rest, Vuser_defined_tags)
1046 list = Fcons (XCAR (XCAR (rest)), list);
1048 list = Fnreverse (list);
1049 list = nconc2 (Fcopy_sequence (Vdevice_class_list), list);
1050 list = nconc2 (Fcopy_sequence (Vconsole_type_list), list);
1052 RETURN_UNGCPRO (list);
1055 DEFUN ("specifier-tag-predicate", Fspecifier_tag_predicate, 1, 1, 0, /*
1056 Return the predicate for the given specifier tag.
1060 /* The return value of this function must be GCPRO'd. */
1063 if (NILP (Fvalid_specifier_tag_p (tag)))
1064 signal_simple_error ("Invalid specifier tag", tag);
1066 /* Make up some predicates for the built-in types */
1068 if (valid_console_type_p (tag))
1069 return list3 (Qlambda, list1 (Qdevice),
1070 list3 (Qeq, list2 (Qquote, tag),
1071 list2 (Qconsole_type, Qdevice)));
1073 if (valid_device_class_p (tag))
1074 return list3 (Qlambda, list1 (Qdevice),
1075 list3 (Qeq, list2 (Qquote, tag),
1076 list2 (Qdevice_class, Qdevice)));
1078 return XCDR (assq_no_quit (tag, Vuser_defined_tags));
1081 /* Return true if A "matches" B. If EXACT_P is 0, A must be a subset of B.
1082 Otherwise, A must be `equal' to B. The sets must be canonicalized. */
1084 tag_sets_match_p (Lisp_Object a, Lisp_Object b, int exact_p)
1088 while (!NILP (a) && !NILP (b))
1090 if (EQ (XCAR (a), XCAR (b)))
1099 while (!NILP (a) && !NILP (b))
1101 if (!EQ (XCAR (a), XCAR (b)))
1107 return NILP (a) && NILP (b);
1112 /************************************************************************/
1113 /* Spec-lists and inst-lists */
1114 /************************************************************************/
1117 call_validate_method (Lisp_Object boxed_method, Lisp_Object instantiator)
1119 ((void (*)(Lisp_Object)) get_opaque_ptr (boxed_method)) (instantiator);
1124 check_valid_instantiator (Lisp_Object instantiator,
1125 struct specifier_methods *meths,
1126 Error_behavior errb)
1128 if (meths->validate_method)
1132 if (ERRB_EQ (errb, ERROR_ME))
1134 (meths->validate_method) (instantiator);
1139 Lisp_Object opaque = make_opaque_ptr ((void *)
1140 meths->validate_method);
1141 struct gcpro gcpro1;
1144 retval = call_with_suspended_errors
1145 ((lisp_fn_t) call_validate_method,
1146 Qnil, Qspecifier, errb, 2, opaque, instantiator);
1148 free_opaque_ptr (opaque);
1157 DEFUN ("check-valid-instantiator", Fcheck_valid_instantiator, 2, 2, 0, /*
1158 Signal an error if INSTANTIATOR is invalid for SPECIFIER-TYPE.
1160 (instantiator, specifier_type))
1162 struct specifier_methods *meths = decode_specifier_type (specifier_type,
1165 return check_valid_instantiator (instantiator, meths, ERROR_ME);
1168 DEFUN ("valid-instantiator-p", Fvalid_instantiator_p, 2, 2, 0, /*
1169 Return non-nil if INSTANTIATOR is valid for SPECIFIER-TYPE.
1171 (instantiator, specifier_type))
1173 struct specifier_methods *meths = decode_specifier_type (specifier_type,
1176 return check_valid_instantiator (instantiator, meths, ERROR_ME_NOT);
1180 check_valid_inst_list (Lisp_Object inst_list, struct specifier_methods *meths,
1181 Error_behavior errb)
1185 LIST_LOOP (rest, inst_list)
1187 Lisp_Object inst_pair, tag_set;
1191 maybe_signal_simple_error ("Invalid instantiator list", inst_list,
1195 if (!CONSP (inst_pair = XCAR (rest)))
1197 maybe_signal_simple_error ("Invalid instantiator pair", inst_pair,
1201 if (NILP (Fvalid_specifier_tag_set_p (tag_set = XCAR (inst_pair))))
1203 maybe_signal_simple_error ("Invalid specifier tag", tag_set,
1208 if (NILP (check_valid_instantiator (XCDR (inst_pair), meths, errb)))
1215 DEFUN ("check-valid-inst-list", Fcheck_valid_inst_list, 2, 2, 0, /*
1216 Signal an error if INST-LIST is invalid for specifier type TYPE.
1220 struct specifier_methods *meths = decode_specifier_type (type, ERROR_ME);
1222 return check_valid_inst_list (inst_list, meths, ERROR_ME);
1225 DEFUN ("valid-inst-list-p", Fvalid_inst_list_p, 2, 2, 0, /*
1226 Return non-nil if INST-LIST is valid for specifier type TYPE.
1230 struct specifier_methods *meths = decode_specifier_type (type, ERROR_ME);
1232 return check_valid_inst_list (inst_list, meths, ERROR_ME_NOT);
1236 check_valid_spec_list (Lisp_Object spec_list, struct specifier_methods *meths,
1237 Error_behavior errb)
1241 LIST_LOOP (rest, spec_list)
1243 Lisp_Object spec, locale;
1244 if (!CONSP (rest) || !CONSP (spec = XCAR (rest)))
1246 maybe_signal_simple_error ("Invalid specification list", spec_list,
1250 if (NILP (Fvalid_specifier_locale_p (locale = XCAR (spec))))
1252 maybe_signal_simple_error ("Invalid specifier locale", locale,
1257 if (NILP (check_valid_inst_list (XCDR (spec), meths, errb)))
1264 DEFUN ("check-valid-spec-list", Fcheck_valid_spec_list, 2, 2, 0, /*
1265 Signal an error if SPEC-LIST is invalid for specifier type TYPE.
1269 struct specifier_methods *meths = decode_specifier_type (type, ERROR_ME);
1271 return check_valid_spec_list (spec_list, meths, ERROR_ME);
1274 DEFUN ("valid-spec-list-p", Fvalid_spec_list_p, 2, 2, 0, /*
1275 Return non-nil if SPEC-LIST is valid for specifier type TYPE.
1279 struct specifier_methods *meths = decode_specifier_type (type, ERROR_ME);
1281 return check_valid_spec_list (spec_list, meths, ERROR_ME_NOT);
1285 decode_how_to_add_specification (Lisp_Object how_to_add)
1287 if (NILP (how_to_add) || EQ (Qremove_tag_set_prepend, how_to_add))
1288 return SPEC_REMOVE_TAG_SET_PREPEND;
1289 if (EQ (Qremove_tag_set_append, how_to_add))
1290 return SPEC_REMOVE_TAG_SET_APPEND;
1291 if (EQ (Qappend, how_to_add))
1293 if (EQ (Qprepend, how_to_add))
1294 return SPEC_PREPEND;
1295 if (EQ (Qremove_locale, how_to_add))
1296 return SPEC_REMOVE_LOCALE;
1297 if (EQ (Qremove_locale_type, how_to_add))
1298 return SPEC_REMOVE_LOCALE_TYPE;
1299 if (EQ (Qremove_all, how_to_add))
1300 return SPEC_REMOVE_ALL;
1302 signal_simple_error ("Invalid `how-to-add' flag", how_to_add);
1304 return SPEC_PREPEND; /* not reached */
1307 /* Given a specifier object SPEC, return bodily specifier if SPEC is a
1308 ghost specifier, otherwise return the object itself
1311 bodily_specifier (Lisp_Object spec)
1313 return (GHOST_SPECIFIER_P (XSPECIFIER (spec))
1314 ? XSPECIFIER(spec)->magic_parent : spec);
1317 /* Signal error if (specifier SPEC is read-only.
1318 Read only are ghost specifiers unless Vunlock_ghost_specifiers is
1319 non-nil. All other specifiers are read-write.
1322 check_modifiable_specifier (Lisp_Object spec)
1324 if (NILP (Vunlock_ghost_specifiers)
1325 && GHOST_SPECIFIER_P (XSPECIFIER (spec)))
1326 signal_simple_error ("Attempt to modify read-only specifier",
1330 /* Helper function which unwind protects the value of
1331 Vunlock_ghost_specifiers, then sets it to non-nil value */
1333 restore_unlock_value (Lisp_Object val)
1335 Vunlock_ghost_specifiers = val;
1340 unlock_ghost_specifiers_protected (void)
1342 int depth = specpdl_depth ();
1343 record_unwind_protect (restore_unlock_value,
1344 Vunlock_ghost_specifiers);
1345 Vunlock_ghost_specifiers = Qt;
1349 /* This gets hit so much that the function call overhead had a
1350 measurable impact (according to Quantify). #### We should figure
1351 out the frequency with which this is called with the various types
1352 and reorder the check accordingly. */
1353 #define SPECIFIER_GET_SPEC_LIST(specifier, type) \
1354 (type == LOCALE_GLOBAL ? &(XSPECIFIER (specifier)->global_specs) : \
1355 type == LOCALE_DEVICE ? &(XSPECIFIER (specifier)->device_specs) : \
1356 type == LOCALE_FRAME ? &(XSPECIFIER (specifier)->frame_specs) : \
1357 type == LOCALE_WINDOW ? &(XWEAK_LIST_LIST \
1358 (XSPECIFIER (specifier)->window_specs)) : \
1359 type == LOCALE_BUFFER ? &(XSPECIFIER (specifier)->buffer_specs) : \
1362 static Lisp_Object *
1363 specifier_get_inst_list (Lisp_Object specifier, Lisp_Object locale,
1364 enum spec_locale_type type)
1366 Lisp_Object *spec_list = SPECIFIER_GET_SPEC_LIST (specifier, type);
1367 Lisp_Object specification;
1369 if (type == LOCALE_GLOBAL)
1371 /* Calling assq_no_quit when it is just going to return nil anyhow
1372 is extremely expensive. So sayeth Quantify. */
1373 if (!CONSP (*spec_list))
1375 specification = assq_no_quit (locale, *spec_list);
1376 if (NILP (specification))
1378 return &XCDR (specification);
1381 /* For the given INST_LIST, return a new INST_LIST containing all elements
1382 where TAG-SET matches the element's tag set. EXACT_P indicates whether
1383 the match must be exact (as opposed to a subset). SHORT_P indicates
1384 that the short form (for `specifier-specs') should be returned if
1385 possible. If COPY_TREE_P, `copy-tree' is used to ensure that no
1386 elements of the new list are shared with the initial list.
1390 specifier_process_inst_list (Lisp_Object inst_list,
1391 Lisp_Object tag_set, int exact_p,
1392 int short_p, int copy_tree_p)
1394 Lisp_Object retval = Qnil;
1396 struct gcpro gcpro1;
1399 LIST_LOOP (rest, inst_list)
1401 Lisp_Object tagged_inst = XCAR (rest);
1402 Lisp_Object tagged_inst_tag = XCAR (tagged_inst);
1403 if (tag_sets_match_p (tag_set, tagged_inst_tag, exact_p))
1405 if (short_p && NILP (tagged_inst_tag))
1406 retval = Fcons (copy_tree_p ?
1407 Fcopy_tree (XCDR (tagged_inst), Qt) :
1411 retval = Fcons (copy_tree_p ? Fcopy_tree (tagged_inst, Qt) :
1412 tagged_inst, retval);
1415 retval = Fnreverse (retval);
1417 /* If there is a single instantiator and the short form is
1418 requested, return just the instantiator (rather than a one-element
1419 list of it) unless it is nil (so that it can be distinguished from
1420 no instantiators at all). */
1421 if (short_p && CONSP (retval) && !NILP (XCAR (retval)) &&
1422 NILP (XCDR (retval)))
1423 return XCAR (retval);
1429 specifier_get_external_inst_list (Lisp_Object specifier, Lisp_Object locale,
1430 enum spec_locale_type type,
1431 Lisp_Object tag_set, int exact_p,
1432 int short_p, int copy_tree_p)
1434 Lisp_Object *inst_list = specifier_get_inst_list (specifier, locale,
1436 if (!inst_list || NILP (*inst_list))
1438 /* nil for *inst_list should only occur in 'global */
1439 assert (!inst_list || EQ (locale, Qglobal));
1443 return specifier_process_inst_list (*inst_list, tag_set, exact_p,
1444 short_p, copy_tree_p);
1448 specifier_get_external_spec_list (Lisp_Object specifier,
1449 enum spec_locale_type type,
1450 Lisp_Object tag_set, int exact_p)
1452 Lisp_Object *spec_list = SPECIFIER_GET_SPEC_LIST (specifier, type);
1453 Lisp_Object retval = Qnil;
1455 struct gcpro gcpro1;
1457 assert (type != LOCALE_GLOBAL);
1458 /* We're about to let stuff go external; make sure there aren't
1460 *spec_list = cleanup_assoc_list (*spec_list);
1463 LIST_LOOP (rest, *spec_list)
1465 Lisp_Object spec = XCAR (rest);
1466 Lisp_Object inst_list =
1467 specifier_process_inst_list (XCDR (spec), tag_set, exact_p, 0, 1);
1468 if (!NILP (inst_list))
1469 retval = Fcons (Fcons (XCAR (spec), inst_list), retval);
1471 RETURN_UNGCPRO (Fnreverse (retval));
1474 static Lisp_Object *
1475 specifier_new_spec (Lisp_Object specifier, Lisp_Object locale,
1476 enum spec_locale_type type)
1478 Lisp_Object *spec_list = SPECIFIER_GET_SPEC_LIST (specifier, type);
1479 Lisp_Object new_spec = Fcons (locale, Qnil);
1480 assert (type != LOCALE_GLOBAL);
1481 *spec_list = Fcons (new_spec, *spec_list);
1482 return &XCDR (new_spec);
1485 /* For the given INST_LIST, return a new list comprised of elements
1486 where TAG_SET does not match the element's tag set. This operation
1490 specifier_process_remove_inst_list (Lisp_Object inst_list,
1491 Lisp_Object tag_set, int exact_p,
1494 Lisp_Object prev = Qnil, rest;
1498 LIST_LOOP (rest, inst_list)
1500 if (tag_sets_match_p (tag_set, XCAR (XCAR (rest)), exact_p))
1502 /* time to remove. */
1505 inst_list = XCDR (rest);
1507 XCDR (prev) = XCDR (rest);
1517 specifier_remove_spec (Lisp_Object specifier, Lisp_Object locale,
1518 enum spec_locale_type type,
1519 Lisp_Object tag_set, int exact_p)
1521 Lisp_Object *spec_list = SPECIFIER_GET_SPEC_LIST (specifier, type);
1525 if (type == LOCALE_GLOBAL)
1526 *spec_list = specifier_process_remove_inst_list (*spec_list, tag_set,
1527 exact_p, &was_removed);
1530 assoc = assq_no_quit (locale, *spec_list);
1532 /* this locale is not found. */
1534 XCDR (assoc) = specifier_process_remove_inst_list (XCDR (assoc),
1537 if (NILP (XCDR (assoc)))
1538 /* no inst-pairs left; remove this locale entirely. */
1539 *spec_list = remassq_no_quit (locale, *spec_list);
1543 MAYBE_SPECMETH (XSPECIFIER (specifier), after_change,
1544 (bodily_specifier (specifier), locale));
1548 specifier_remove_locale_type (Lisp_Object specifier,
1549 enum spec_locale_type type,
1550 Lisp_Object tag_set, int exact_p)
1552 Lisp_Object *spec_list = SPECIFIER_GET_SPEC_LIST (specifier, type);
1553 Lisp_Object prev = Qnil, rest;
1555 assert (type != LOCALE_GLOBAL);
1556 LIST_LOOP (rest, *spec_list)
1559 int remove_spec = 0;
1560 Lisp_Object spec = XCAR (rest);
1562 /* There may be dead objects floating around */
1563 /* remember, dead windows can become alive again. */
1564 if (!WINDOWP (XCAR (spec)) && object_dead_p (XCAR (spec)))
1571 XCDR (spec) = specifier_process_remove_inst_list (XCDR (spec),
1574 if (NILP (XCDR (spec)))
1581 *spec_list = XCDR (rest);
1583 XCDR (prev) = XCDR (rest);
1589 MAYBE_SPECMETH (XSPECIFIER (specifier), after_change,
1590 (bodily_specifier (specifier), XCAR (spec)));
1594 /* NEW_LIST is going to be added to INST_LIST, with add method ADD_METH.
1595 Frob INST_LIST according to ADD_METH. No need to call an after-change
1596 function; the calling function will do this. Return either SPEC_PREPEND
1597 or SPEC_APPEND, indicating whether to prepend or append the NEW_LIST. */
1599 static enum spec_add_meth
1600 handle_multiple_add_insts (Lisp_Object *inst_list,
1601 Lisp_Object new_list,
1602 enum spec_add_meth add_meth)
1606 case SPEC_REMOVE_TAG_SET_APPEND:
1607 add_meth = SPEC_APPEND;
1608 goto remove_tag_set;
1609 case SPEC_REMOVE_TAG_SET_PREPEND:
1610 add_meth = SPEC_PREPEND;
1615 LIST_LOOP (rest, new_list)
1617 Lisp_Object canontag = canonicalize_tag_set (XCAR (XCAR (rest)));
1618 struct gcpro gcpro1;
1621 /* pull out all elements from the existing list with the
1622 same tag as any tags in NEW_LIST. */
1623 *inst_list = remassoc_no_quit (canontag, *inst_list);
1628 case SPEC_REMOVE_LOCALE:
1630 return SPEC_PREPEND;
1634 return SPEC_PREPEND;
1638 /* Given a LOCALE and INST_LIST that is going to be added to SPECIFIER,
1639 copy, canonicalize, and call the going_to_add methods as necessary
1640 to produce a new list that is the one that really will be added
1641 to the specifier. */
1644 build_up_processed_list (Lisp_Object specifier, Lisp_Object locale,
1645 Lisp_Object inst_list)
1647 /* The return value of this function must be GCPRO'd. */
1648 Lisp_Object rest, list_to_build_up = Qnil;
1649 Lisp_Specifier *sp = XSPECIFIER (specifier);
1650 struct gcpro gcpro1;
1652 GCPRO1 (list_to_build_up);
1653 LIST_LOOP (rest, inst_list)
1655 Lisp_Object tag_set = XCAR (XCAR (rest));
1656 Lisp_Object sub_inst_list = Qnil;
1657 Lisp_Object instantiator;
1658 struct gcpro ngcpro1, ngcpro2;
1660 if (HAS_SPECMETH_P (sp, copy_instantiator))
1661 instantiator = SPECMETH (sp, copy_instantiator,
1662 (XCDR (XCAR (rest))));
1664 instantiator = Fcopy_tree (XCDR (XCAR (rest)), Qt);
1666 NGCPRO2 (instantiator, sub_inst_list);
1667 /* call the will-add method; it may GC */
1668 sub_inst_list = HAS_SPECMETH_P (sp, going_to_add) ?
1669 SPECMETH (sp, going_to_add,
1670 (bodily_specifier (specifier), locale,
1671 tag_set, instantiator)) :
1673 if (EQ (sub_inst_list, Qt))
1674 /* no change here. */
1675 sub_inst_list = list1 (Fcons (canonicalize_tag_set (tag_set),
1679 /* now canonicalize all the tag sets in the new objects */
1681 LIST_LOOP (rest2, sub_inst_list)
1682 XCAR (XCAR (rest2)) = canonicalize_tag_set (XCAR (XCAR (rest2)));
1685 list_to_build_up = nconc2 (sub_inst_list, list_to_build_up);
1689 RETURN_UNGCPRO (Fnreverse (list_to_build_up));
1692 /* Add a specification (locale and instantiator list) to a specifier.
1693 ADD_METH specifies what to do with existing specifications in the
1694 specifier, and is an enum that corresponds to the values in
1695 `add-spec-to-specifier'. The calling routine is responsible for
1696 validating LOCALE and INST-LIST, but the tag-sets in INST-LIST
1697 do not need to be canonicalized. */
1699 /* #### I really need to rethink the after-change
1700 functions to make them easier to use and more efficient. */
1703 specifier_add_spec (Lisp_Object specifier, Lisp_Object locale,
1704 Lisp_Object inst_list, enum spec_add_meth add_meth)
1706 Lisp_Specifier *sp = XSPECIFIER (specifier);
1707 enum spec_locale_type type = locale_type_from_locale (locale);
1708 Lisp_Object *orig_inst_list, tem;
1709 Lisp_Object list_to_build_up = Qnil;
1710 struct gcpro gcpro1;
1712 GCPRO1 (list_to_build_up);
1713 list_to_build_up = build_up_processed_list (specifier, locale, inst_list);
1714 /* Now handle REMOVE_LOCALE_TYPE and REMOVE_ALL. These are the
1715 add-meth types that affect locales other than this one. */
1716 if (add_meth == SPEC_REMOVE_LOCALE_TYPE)
1717 specifier_remove_locale_type (specifier, type, Qnil, 0);
1718 else if (add_meth == SPEC_REMOVE_ALL)
1720 specifier_remove_locale_type (specifier, LOCALE_BUFFER, Qnil, 0);
1721 specifier_remove_locale_type (specifier, LOCALE_WINDOW, Qnil, 0);
1722 specifier_remove_locale_type (specifier, LOCALE_FRAME, Qnil, 0);
1723 specifier_remove_locale_type (specifier, LOCALE_DEVICE, Qnil, 0);
1724 specifier_remove_spec (specifier, Qglobal, LOCALE_GLOBAL, Qnil, 0);
1727 orig_inst_list = specifier_get_inst_list (specifier, locale, type);
1728 if (!orig_inst_list)
1729 orig_inst_list = specifier_new_spec (specifier, locale, type);
1730 add_meth = handle_multiple_add_insts (orig_inst_list, list_to_build_up,
1733 if (add_meth == SPEC_PREPEND)
1734 tem = nconc2 (list_to_build_up, *orig_inst_list);
1735 else if (add_meth == SPEC_APPEND)
1736 tem = nconc2 (*orig_inst_list, list_to_build_up);
1740 *orig_inst_list = tem;
1744 /* call the after-change method */
1745 MAYBE_SPECMETH (sp, after_change,
1746 (bodily_specifier (specifier), locale));
1750 specifier_copy_spec (Lisp_Object specifier, Lisp_Object dest,
1751 Lisp_Object locale, enum spec_locale_type type,
1752 Lisp_Object tag_set, int exact_p,
1753 enum spec_add_meth add_meth)
1755 Lisp_Object inst_list =
1756 specifier_get_external_inst_list (specifier, locale, type, tag_set,
1758 specifier_add_spec (dest, locale, inst_list, add_meth);
1762 specifier_copy_locale_type (Lisp_Object specifier, Lisp_Object dest,
1763 enum spec_locale_type type,
1764 Lisp_Object tag_set, int exact_p,
1765 enum spec_add_meth add_meth)
1767 Lisp_Object *src_list = SPECIFIER_GET_SPEC_LIST (specifier, type);
1770 /* This algorithm is O(n^2) in running time.
1771 It's certainly possible to implement an O(n log n) algorithm,
1772 but I doubt there's any need to. */
1774 LIST_LOOP (rest, *src_list)
1776 Lisp_Object spec = XCAR (rest);
1777 /* There may be dead objects floating around */
1778 /* remember, dead windows can become alive again. */
1779 if (WINDOWP (XCAR (spec)) || !object_dead_p (XCAR (spec)))
1782 specifier_process_inst_list (XCDR (spec), tag_set, exact_p, 0, 0),
1787 /* map MAPFUN over the locales in SPECIFIER that are given in LOCALE.
1788 CLOSURE is passed unchanged to MAPFUN. LOCALE can be one of
1790 -- nil (same as 'all)
1791 -- a single locale, locale type, or 'all
1792 -- a list of locales, locale types, and/or 'all
1794 MAPFUN is called for each locale and locale type given; for 'all,
1795 it is called for the locale 'global and for the four possible
1796 locale types. In each invocation, either LOCALE will be a locale
1797 and LOCALE_TYPE will be the locale type of this locale,
1798 or LOCALE will be nil and LOCALE_TYPE will be a locale type.
1799 If MAPFUN ever returns non-zero, the mapping is halted and the
1800 value returned is returned from map_specifier(). Otherwise, the
1801 mapping proceeds to the end and map_specifier() returns 0.
1805 map_specifier (Lisp_Object specifier, Lisp_Object locale,
1806 int (*mapfun) (Lisp_Object specifier,
1808 enum spec_locale_type locale_type,
1809 Lisp_Object tag_set,
1812 Lisp_Object tag_set, Lisp_Object exact_p,
1817 struct gcpro gcpro1, gcpro2;
1819 GCPRO2 (tag_set, locale);
1820 locale = decode_locale_list (locale);
1821 tag_set = decode_specifier_tag_set (tag_set);
1822 tag_set = canonicalize_tag_set (tag_set);
1824 LIST_LOOP (rest, locale)
1826 Lisp_Object theloc = XCAR (rest);
1827 if (!NILP (Fvalid_specifier_locale_p (theloc)))
1829 retval = (*mapfun) (specifier, theloc,
1830 locale_type_from_locale (theloc),
1831 tag_set, !NILP (exact_p), closure);
1835 else if (!NILP (Fvalid_specifier_locale_type_p (theloc)))
1837 retval = (*mapfun) (specifier, Qnil,
1838 decode_locale_type (theloc), tag_set,
1839 !NILP (exact_p), closure);
1845 assert (EQ (theloc, Qall));
1846 retval = (*mapfun) (specifier, Qnil, LOCALE_BUFFER, tag_set,
1847 !NILP (exact_p), closure);
1850 retval = (*mapfun) (specifier, Qnil, LOCALE_WINDOW, tag_set,
1851 !NILP (exact_p), closure);
1854 retval = (*mapfun) (specifier, Qnil, LOCALE_FRAME, tag_set,
1855 !NILP (exact_p), closure);
1858 retval = (*mapfun) (specifier, Qnil, LOCALE_DEVICE, tag_set,
1859 !NILP (exact_p), closure);
1862 retval = (*mapfun) (specifier, Qglobal, LOCALE_GLOBAL, tag_set,
1863 !NILP (exact_p), closure);
1873 DEFUN ("add-spec-to-specifier", Fadd_spec_to_specifier, 2, 5, 0, /*
1874 Add a specification to SPECIFIER.
1875 The specification maps from LOCALE (which should be a window, buffer,
1876 frame, device, or 'global, and defaults to 'global) to INSTANTIATOR,
1877 whose allowed values depend on the type of the specifier. Optional
1878 argument TAG-SET limits the instantiator to apply only to the specified
1879 tag set, which should be a list of tags all of which must match the
1880 device being instantiated over (tags are a device type, a device class,
1881 or tags defined with `define-specifier-tag'). Specifying a single
1882 symbol for TAG-SET is equivalent to specifying a one-element list
1883 containing that symbol. Optional argument HOW-TO-ADD specifies what to
1884 do if there are already specifications in the specifier.
1887 'prepend Put at the beginning of the current list of
1888 instantiators for LOCALE.
1889 'append Add to the end of the current list of
1890 instantiators for LOCALE.
1891 'remove-tag-set-prepend (this is the default)
1892 Remove any existing instantiators whose tag set is
1893 the same as TAG-SET; then put the new instantiator
1894 at the beginning of the current list. ("Same tag
1895 set" means that they contain the same elements.
1896 The order may be different.)
1897 'remove-tag-set-append
1898 Remove any existing instantiators whose tag set is
1899 the same as TAG-SET; then put the new instantiator
1900 at the end of the current list.
1901 'remove-locale Remove all previous instantiators for this locale
1902 before adding the new spec.
1903 'remove-locale-type Remove all specifications for all locales of the
1904 same type as LOCALE (this includes LOCALE itself)
1905 before adding the new spec.
1906 'remove-all Remove all specifications from the specifier
1907 before adding the new spec.
1909 You can retrieve the specifications for a particular locale or locale type
1910 with the function `specifier-spec-list' or `specifier-specs'.
1912 (specifier, instantiator, locale, tag_set, how_to_add))
1914 enum spec_add_meth add_meth;
1915 Lisp_Object inst_list;
1916 struct gcpro gcpro1;
1918 CHECK_SPECIFIER (specifier);
1919 check_modifiable_specifier (specifier);
1921 locale = decode_locale (locale);
1922 check_valid_instantiator (instantiator,
1923 decode_specifier_type
1924 (Fspecifier_type (specifier), ERROR_ME),
1926 /* tag_set might be newly-created material, but it's part of inst_list
1927 so is properly GC-protected. */
1928 tag_set = decode_specifier_tag_set (tag_set);
1929 add_meth = decode_how_to_add_specification (how_to_add);
1931 inst_list = list1 (Fcons (tag_set, instantiator));
1933 specifier_add_spec (specifier, locale, inst_list, add_meth);
1934 recompute_cached_specifier_everywhere (specifier);
1935 RETURN_UNGCPRO (Qnil);
1938 DEFUN ("add-spec-list-to-specifier", Fadd_spec_list_to_specifier, 2, 3, 0, /*
1939 Add a spec-list (a list of specifications) to SPECIFIER.
1940 The format of a spec-list is
1942 ((LOCALE (TAG-SET . INSTANTIATOR) ...) ...)
1945 LOCALE := a window, a buffer, a frame, a device, or 'global
1946 TAG-SET := an unordered list of zero or more TAGS, each of which
1948 TAG := a device class (see `valid-device-class-p'), a device type
1949 (see `valid-console-type-p'), or a tag defined with
1950 `define-specifier-tag'
1951 INSTANTIATOR := format determined by the type of specifier
1953 The pair (TAG-SET . INSTANTIATOR) is called an `inst-pair'.
1954 A list of inst-pairs is called an `inst-list'.
1955 The pair (LOCALE . INST-LIST) is called a `specification' or `spec'.
1956 A spec-list, then, can be viewed as a list of specifications.
1958 HOW-TO-ADD specifies how to combine the new specifications with
1959 the existing ones, and has the same semantics as for
1960 `add-spec-to-specifier'.
1962 In many circumstances, the higher-level function `set-specifier' is
1963 more convenient and should be used instead.
1965 (specifier, spec_list, how_to_add))
1967 enum spec_add_meth add_meth;
1970 CHECK_SPECIFIER (specifier);
1971 check_modifiable_specifier (specifier);
1973 check_valid_spec_list (spec_list,
1974 decode_specifier_type
1975 (Fspecifier_type (specifier), ERROR_ME),
1977 add_meth = decode_how_to_add_specification (how_to_add);
1979 LIST_LOOP (rest, spec_list)
1981 /* Placating the GCC god. */
1982 Lisp_Object specification = XCAR (rest);
1983 Lisp_Object locale = XCAR (specification);
1984 Lisp_Object inst_list = XCDR (specification);
1986 specifier_add_spec (specifier, locale, inst_list, add_meth);
1988 recompute_cached_specifier_everywhere (specifier);
1993 add_spec_to_ghost_specifier (Lisp_Object specifier, Lisp_Object instantiator,
1994 Lisp_Object locale, Lisp_Object tag_set,
1995 Lisp_Object how_to_add)
1997 int depth = unlock_ghost_specifiers_protected ();
1998 Fadd_spec_to_specifier (XSPECIFIER(specifier)->fallback,
1999 instantiator, locale, tag_set, how_to_add);
2000 unbind_to (depth, Qnil);
2003 struct specifier_spec_list_closure
2005 Lisp_Object head, tail;
2009 specifier_spec_list_mapfun (Lisp_Object specifier,
2011 enum spec_locale_type locale_type,
2012 Lisp_Object tag_set,
2016 struct specifier_spec_list_closure *cl =
2017 (struct specifier_spec_list_closure *) closure;
2018 Lisp_Object partial;
2021 partial = specifier_get_external_spec_list (specifier,
2026 partial = specifier_get_external_inst_list (specifier, locale,
2027 locale_type, tag_set,
2029 if (!NILP (partial))
2030 partial = list1 (Fcons (locale, partial));
2035 /* tack on the new list */
2036 if (NILP (cl->tail))
2037 cl->head = cl->tail = partial;
2039 XCDR (cl->tail) = partial;
2040 /* find the new tail */
2041 while (CONSP (XCDR (cl->tail)))
2042 cl->tail = XCDR (cl->tail);
2046 /* For the given SPECIFIER create and return a list of all specs
2047 contained within it, subject to LOCALE. If LOCALE is a locale, only
2048 specs in that locale will be returned. If LOCALE is a locale type,
2049 all specs in all locales of that type will be returned. If LOCALE is
2050 nil, all specs will be returned. This always copies lists and never
2051 returns the actual lists, because we do not want someone manipulating
2052 the actual objects. This may cause a slight loss of potential
2053 functionality but if we were to allow it then a user could manage to
2054 violate our assertion that the specs contained in the actual
2055 specifier lists are all valid. */
2057 DEFUN ("specifier-spec-list", Fspecifier_spec_list, 1, 4, 0, /*
2058 Return the spec-list of specifications for SPECIFIER in LOCALE.
2060 If LOCALE is a particular locale (a buffer, window, frame, device,
2061 or 'global), a spec-list consisting of the specification for that
2062 locale will be returned.
2064 If LOCALE is a locale type (i.e. 'buffer, 'window, 'frame, or 'device),
2065 a spec-list of the specifications for all locales of that type will be
2068 If LOCALE is nil or 'all, a spec-list of all specifications in SPECIFIER
2071 LOCALE can also be a list of locales, locale types, and/or 'all; the
2072 result is as if `specifier-spec-list' were called on each element of the
2073 list and the results concatenated together.
2075 Only instantiators where TAG-SET (a list of zero or more tags) is a
2076 subset of (or possibly equal to) the instantiator's tag set are returned.
2077 \(The default value of nil is a subset of all tag sets, so in this case
2078 no instantiators will be screened out.) If EXACT-P is non-nil, however,
2079 TAG-SET must be equal to an instantiator's tag set for the instantiator
2082 (specifier, locale, tag_set, exact_p))
2084 struct specifier_spec_list_closure cl;
2085 struct gcpro gcpro1, gcpro2;
2087 CHECK_SPECIFIER (specifier);
2088 cl.head = cl.tail = Qnil;
2089 GCPRO2 (cl.head, cl.tail);
2090 map_specifier (specifier, locale, specifier_spec_list_mapfun,
2091 tag_set, exact_p, &cl);
2097 DEFUN ("specifier-specs", Fspecifier_specs, 1, 4, 0, /*
2098 Return the specification(s) for SPECIFIER in LOCALE.
2100 If LOCALE is a single locale or is a list of one element containing a
2101 single locale, then a "short form" of the instantiators for that locale
2102 will be returned. Otherwise, this function is identical to
2103 `specifier-spec-list'.
2105 The "short form" is designed for readability and not for ease of use
2106 in Lisp programs, and is as follows:
2108 1. If there is only one instantiator, then an inst-pair (i.e. cons of
2109 tag and instantiator) will be returned; otherwise a list of
2110 inst-pairs will be returned.
2111 2. For each inst-pair returned, if the instantiator's tag is 'any,
2112 the tag will be removed and the instantiator itself will be returned
2113 instead of the inst-pair.
2114 3. If there is only one instantiator, its value is nil, and its tag is
2115 'any, a one-element list containing nil will be returned rather
2116 than just nil, to distinguish this case from there being no
2117 instantiators at all.
2119 (specifier, locale, tag_set, exact_p))
2121 if (!NILP (Fvalid_specifier_locale_p (locale)) ||
2122 (CONSP (locale) && !NILP (Fvalid_specifier_locale_p (XCAR (locale))) &&
2123 NILP (XCDR (locale))))
2125 struct gcpro gcpro1;
2127 CHECK_SPECIFIER (specifier);
2129 locale = XCAR (locale);
2131 tag_set = decode_specifier_tag_set (tag_set);
2132 tag_set = canonicalize_tag_set (tag_set);
2134 (specifier_get_external_inst_list (specifier, locale,
2135 locale_type_from_locale (locale),
2136 tag_set, !NILP (exact_p), 1, 1));
2139 return Fspecifier_spec_list (specifier, locale, tag_set, exact_p);
2143 remove_specifier_mapfun (Lisp_Object specifier,
2145 enum spec_locale_type locale_type,
2146 Lisp_Object tag_set,
2148 void *ignored_closure)
2151 specifier_remove_locale_type (specifier, locale_type, tag_set, exact_p);
2153 specifier_remove_spec (specifier, locale, locale_type, tag_set, exact_p);
2157 DEFUN ("remove-specifier", Fremove_specifier, 1, 4, 0, /*
2158 Remove specification(s) for SPECIFIER.
2160 If LOCALE is a particular locale (a window, buffer, frame, device,
2161 or 'global), the specification for that locale will be removed.
2163 If instead, LOCALE is a locale type (i.e. 'window, 'buffer, 'frame,
2164 or 'device), the specifications for all locales of that type will be
2167 If LOCALE is nil or 'all, all specifications will be removed.
2169 LOCALE can also be a list of locales, locale types, and/or 'all; this
2170 is equivalent to calling `remove-specifier' for each of the elements
2173 Only instantiators where TAG-SET (a list of zero or more tags) is a
2174 subset of (or possibly equal to) the instantiator's tag set are removed.
2175 The default value of nil is a subset of all tag sets, so in this case
2176 no instantiators will be screened out. If EXACT-P is non-nil, however,
2177 TAG-SET must be equal to an instantiator's tag set for the instantiator
2180 (specifier, locale, tag_set, exact_p))
2182 CHECK_SPECIFIER (specifier);
2183 check_modifiable_specifier (specifier);
2185 map_specifier (specifier, locale, remove_specifier_mapfun,
2186 tag_set, exact_p, 0);
2187 recompute_cached_specifier_everywhere (specifier);
2192 remove_ghost_specifier (Lisp_Object specifier, Lisp_Object locale,
2193 Lisp_Object tag_set, Lisp_Object exact_p)
2195 int depth = unlock_ghost_specifiers_protected ();
2196 Fremove_specifier (XSPECIFIER(specifier)->fallback,
2197 locale, tag_set, exact_p);
2198 unbind_to (depth, Qnil);
2201 struct copy_specifier_closure
2204 enum spec_add_meth add_meth;
2205 int add_meth_is_nil;
2209 copy_specifier_mapfun (Lisp_Object specifier,
2211 enum spec_locale_type locale_type,
2212 Lisp_Object tag_set,
2216 struct copy_specifier_closure *cl =
2217 (struct copy_specifier_closure *) closure;
2220 specifier_copy_locale_type (specifier, cl->dest, locale_type,
2222 cl->add_meth_is_nil ?
2223 SPEC_REMOVE_LOCALE_TYPE :
2226 specifier_copy_spec (specifier, cl->dest, locale, locale_type,
2228 cl->add_meth_is_nil ? SPEC_REMOVE_LOCALE :
2233 DEFUN ("copy-specifier", Fcopy_specifier, 1, 6, 0, /*
2234 Copy SPECIFIER to DEST, or create a new one if DEST is nil.
2236 If DEST is nil or omitted, a new specifier will be created and the
2237 specifications copied into it. Otherwise, the specifications will be
2238 copied into the existing specifier in DEST.
2240 If LOCALE is nil or 'all, all specifications will be copied. If LOCALE
2241 is a particular locale, the specification for that particular locale will
2242 be copied. If LOCALE is a locale type, the specifications for all locales
2243 of that type will be copied. LOCALE can also be a list of locales,
2244 locale types, and/or 'all; this is equivalent to calling `copy-specifier'
2245 for each of the elements of the list. See `specifier-spec-list' for more
2246 information about LOCALE.
2248 Only instantiators where TAG-SET (a list of zero or more tags) is a
2249 subset of (or possibly equal to) the instantiator's tag set are copied.
2250 The default value of nil is a subset of all tag sets, so in this case
2251 no instantiators will be screened out. If EXACT-P is non-nil, however,
2252 TAG-SET must be equal to an instantiator's tag set for the instantiator
2255 Optional argument HOW-TO-ADD specifies what to do with existing
2256 specifications in DEST. If nil, then whichever locales or locale types
2257 are copied will first be completely erased in DEST. Otherwise, it is
2258 the same as in `add-spec-to-specifier'.
2260 (specifier, dest, locale, tag_set, exact_p, how_to_add))
2262 struct gcpro gcpro1;
2263 struct copy_specifier_closure cl;
2265 CHECK_SPECIFIER (specifier);
2266 if (NILP (how_to_add))
2267 cl.add_meth_is_nil = 1;
2269 cl.add_meth_is_nil = 0;
2270 cl.add_meth = decode_how_to_add_specification (how_to_add);
2273 /* #### What about copying the extra data? */
2274 dest = make_specifier (XSPECIFIER (specifier)->methods);
2278 CHECK_SPECIFIER (dest);
2279 check_modifiable_specifier (dest);
2280 if (XSPECIFIER (dest)->methods != XSPECIFIER (specifier)->methods)
2281 error ("Specifiers not of same type");
2286 map_specifier (specifier, locale, copy_specifier_mapfun,
2287 tag_set, exact_p, &cl);
2289 recompute_cached_specifier_everywhere (dest);
2294 /************************************************************************/
2296 /************************************************************************/
2299 call_validate_matchspec_method (Lisp_Object boxed_method,
2300 Lisp_Object matchspec)
2302 ((void (*)(Lisp_Object)) get_opaque_ptr (boxed_method)) (matchspec);
2307 check_valid_specifier_matchspec (Lisp_Object matchspec,
2308 struct specifier_methods *meths,
2309 Error_behavior errb)
2311 if (meths->validate_matchspec_method)
2315 if (ERRB_EQ (errb, ERROR_ME))
2317 (meths->validate_matchspec_method) (matchspec);
2322 Lisp_Object opaque =
2323 make_opaque_ptr ((void *) meths->validate_matchspec_method);
2324 struct gcpro gcpro1;
2327 retval = call_with_suspended_errors
2328 ((lisp_fn_t) call_validate_matchspec_method,
2329 Qnil, Qspecifier, errb, 2, opaque, matchspec);
2331 free_opaque_ptr (opaque);
2339 maybe_signal_simple_error
2340 ("Matchspecs not allowed for this specifier type",
2341 intern (meths->name), Qspecifier, errb);
2346 DEFUN ("check-valid-specifier-matchspec", Fcheck_valid_specifier_matchspec, 2, 2, 0, /*
2347 Signal an error if MATCHSPEC is invalid for SPECIFIER-TYPE.
2348 See `specifier-matching-instance' for a description of matchspecs.
2350 (matchspec, specifier_type))
2352 struct specifier_methods *meths = decode_specifier_type (specifier_type,
2355 return check_valid_specifier_matchspec (matchspec, meths, ERROR_ME);
2358 DEFUN ("valid-specifier-matchspec-p", Fvalid_specifier_matchspec_p, 2, 2, 0, /*
2359 Return non-nil if MATCHSPEC is valid for SPECIFIER-TYPE.
2360 See `specifier-matching-instance' for a description of matchspecs.
2362 (matchspec, specifier_type))
2364 struct specifier_methods *meths = decode_specifier_type (specifier_type,
2367 return check_valid_specifier_matchspec (matchspec, meths, ERROR_ME_NOT);
2370 /* This function is purposely not callable from Lisp. If a Lisp
2371 caller wants to set a fallback, they should just set the
2375 set_specifier_fallback (Lisp_Object specifier, Lisp_Object fallback)
2377 Lisp_Specifier *sp = XSPECIFIER (specifier);
2378 assert (SPECIFIERP (fallback) ||
2379 !NILP (Fvalid_inst_list_p (fallback, Fspecifier_type (specifier))));
2380 if (SPECIFIERP (fallback))
2381 assert (EQ (Fspecifier_type (specifier), Fspecifier_type (fallback)));
2382 if (BODILY_SPECIFIER_P (sp))
2383 GHOST_SPECIFIER(sp)->fallback = fallback;
2385 sp->fallback = fallback;
2386 /* call the after-change method */
2387 MAYBE_SPECMETH (sp, after_change,
2388 (bodily_specifier (specifier), Qfallback));
2389 recompute_cached_specifier_everywhere (specifier);
2392 DEFUN ("specifier-fallback", Fspecifier_fallback, 1, 1, 0, /*
2393 Return the fallback value for SPECIFIER.
2394 Fallback values are provided by the C code for certain built-in
2395 specifiers to make sure that instancing won't fail even if all
2396 specs are removed from the specifier, or to implement simple
2397 inheritance behavior (e.g. this method is used to ensure that
2398 faces other than 'default inherit their attributes from 'default).
2399 By design, you cannot change the fallback value, and specifiers
2400 created with `make-specifier' will never have a fallback (although
2401 a similar, Lisp-accessible capability may be provided in the future
2402 to allow for inheritance).
2404 The fallback value will be an inst-list that is instanced like
2405 any other inst-list, a specifier of the same type as SPECIFIER
2406 \(results in inheritance), or nil for no fallback.
2408 When you instance a specifier, you can explicitly request that the
2409 fallback not be consulted. (The C code does this, for example, when
2410 merging faces.) See `specifier-instance'.
2414 CHECK_SPECIFIER (specifier);
2415 return Fcopy_tree (XSPECIFIER (specifier)->fallback, Qt);
2419 specifier_instance_from_inst_list (Lisp_Object specifier,
2420 Lisp_Object matchspec,
2422 Lisp_Object inst_list,
2423 Error_behavior errb, int no_quit,
2426 /* This function can GC */
2430 int count = specpdl_depth ();
2431 struct gcpro gcpro1, gcpro2;
2433 GCPRO2 (specifier, inst_list);
2435 sp = XSPECIFIER (specifier);
2436 device = DFW_DEVICE (domain);
2439 /* The instantiate method is allowed to call eval. Since it
2440 is quite common for this function to get called from somewhere in
2441 redisplay we need to make sure that quits are ignored. Otherwise
2442 Fsignal will abort. */
2443 specbind (Qinhibit_quit, Qt);
2445 LIST_LOOP (rest, inst_list)
2447 Lisp_Object tagged_inst = XCAR (rest);
2448 Lisp_Object tag_set = XCAR (tagged_inst);
2450 if (device_matches_specifier_tag_set_p (device, tag_set))
2452 Lisp_Object val = XCDR (tagged_inst);
2454 if (HAS_SPECMETH_P (sp, instantiate))
2455 val = call_with_suspended_errors
2456 ((lisp_fn_t) RAW_SPECMETH (sp, instantiate),
2457 Qunbound, Qspecifier, errb, 5, specifier,
2458 matchspec, domain, val, depth);
2460 if (!UNBOUNDP (val))
2462 unbind_to (count, Qnil);
2469 unbind_to (count, Qnil);
2474 /* Given a SPECIFIER and a DOMAIN, return a specific instance for that
2475 specifier. Try to find one by checking the specifier types from most
2476 specific (buffer) to most general (global). If we find an instance,
2477 return it. Otherwise return Qunbound. */
2479 #define CHECK_INSTANCE_ENTRY(key, matchspec, type) do { \
2480 Lisp_Object *CIE_inst_list = \
2481 specifier_get_inst_list (specifier, key, type); \
2482 if (CIE_inst_list) \
2484 Lisp_Object CIE_val = \
2485 specifier_instance_from_inst_list (specifier, matchspec, \
2486 domain, *CIE_inst_list, \
2487 errb, no_quit, depth); \
2488 if (!UNBOUNDP (CIE_val)) \
2493 /* We accept any window, frame or device domain and do our checking
2494 starting from as specific a locale type as we can determine from the
2495 domain we are passed and going on up through as many other locale types
2496 as we can determine. In practice, when called from redisplay the
2497 arg will usually be a window and occasionally a frame. If
2498 triggered by a user call, who knows what it will usually be. */
2500 specifier_instance (Lisp_Object specifier, Lisp_Object matchspec,
2501 Lisp_Object domain, Error_behavior errb, int no_quit,
2502 int no_fallback, Lisp_Object depth)
2504 Lisp_Object buffer = Qnil;
2505 Lisp_Object window = Qnil;
2506 Lisp_Object frame = Qnil;
2507 Lisp_Object device = Qnil;
2508 Lisp_Object tag = Qnil;
2512 sp = XSPECIFIER (specifier);
2514 /* Attempt to determine buffer, window, frame, and device from the
2516 if (WINDOWP (domain))
2518 else if (FRAMEP (domain))
2520 else if (DEVICEP (domain))
2523 /* #### dmoore - dammit, this should just signal an error or something
2525 #### No. Errors are handled in Lisp primitives implementation.
2526 Invalid domain is a design error here - kkm. */
2529 if (NILP (buffer) && !NILP (window))
2530 buffer = XWINDOW (window)->buffer;
2531 if (NILP (frame) && !NILP (window))
2532 frame = XWINDOW (window)->frame;
2534 /* frame had better exist; if device is undeterminable, something
2535 really went wrong. */
2536 device = XFRAME (frame)->device;
2538 /* device had better be determined by now; abort if not. */
2539 d = XDEVICE (device);
2540 tag = DEVICE_CLASS (d);
2542 depth = make_int (1 + XINT (depth));
2543 if (XINT (depth) > 20)
2545 maybe_error (Qspecifier, errb, "Apparent loop in specifier inheritance");
2546 /* The specification is fucked; at least try the fallback
2547 (which better not be fucked, because it's not changeable
2554 /* First see if we can generate one from the window specifiers. */
2556 CHECK_INSTANCE_ENTRY (window, matchspec, LOCALE_WINDOW);
2558 /* Next see if we can generate one from the buffer specifiers. */
2560 CHECK_INSTANCE_ENTRY (buffer, matchspec, LOCALE_BUFFER);
2562 /* Next see if we can generate one from the frame specifiers. */
2564 CHECK_INSTANCE_ENTRY (frame, matchspec, LOCALE_FRAME);
2566 /* If we still haven't succeeded try with the device specifiers. */
2567 CHECK_INSTANCE_ENTRY (device, matchspec, LOCALE_DEVICE);
2569 /* Last and least try the global specifiers. */
2570 CHECK_INSTANCE_ENTRY (Qglobal, matchspec, LOCALE_GLOBAL);
2573 /* We're out of specifiers and we still haven't generated an
2574 instance. At least try the fallback ... If this fails,
2575 then we just return Qunbound. */
2577 if (no_fallback || NILP (sp->fallback))
2578 /* I said, I don't want the fallbacks. */
2581 if (SPECIFIERP (sp->fallback))
2583 /* If you introduced loops in the default specifier chain,
2584 then you're fucked, so you better not do this. */
2585 specifier = sp->fallback;
2586 sp = XSPECIFIER (specifier);
2590 assert (CONSP (sp->fallback));
2591 return specifier_instance_from_inst_list (specifier, matchspec, domain,
2592 sp->fallback, errb, no_quit,
2595 #undef CHECK_INSTANCE_ENTRY
2598 specifier_instance_no_quit (Lisp_Object specifier, Lisp_Object matchspec,
2599 Lisp_Object domain, Error_behavior errb,
2600 int no_fallback, Lisp_Object depth)
2602 return specifier_instance (specifier, matchspec, domain, errb,
2603 1, no_fallback, depth);
2606 DEFUN ("specifier-instance", Fspecifier_instance, 1, 4, 0, /*
2607 Instantiate SPECIFIER (return its value) in DOMAIN.
2608 If no instance can be generated for this domain, return DEFAULT.
2610 DOMAIN should be a window, frame, or device. Other values that are legal
2611 as a locale (e.g. a buffer) are not valid as a domain because they do not
2612 provide enough information to identify a particular device (see
2613 `valid-specifier-domain-p'). DOMAIN defaults to the selected window
2616 "Instantiating" a specifier in a particular domain means determining
2617 the specifier's "value" in that domain. This is accomplished by
2618 searching through the specifications in the specifier that correspond
2619 to all locales that can be derived from the given domain, from specific
2620 to general. In most cases, the domain is an Emacs window. In that case
2621 specifications are searched for as follows:
2623 1. A specification whose locale is the window itself;
2624 2. A specification whose locale is the window's buffer;
2625 3. A specification whose locale is the window's frame;
2626 4. A specification whose locale is the window's frame's device;
2627 5. A specification whose locale is 'global.
2629 If all of those fail, then the C-code-provided fallback value for
2630 this specifier is consulted (see `specifier-fallback'). If it is
2631 an inst-list, then this function attempts to instantiate that list
2632 just as when a specification is located in the first five steps above.
2633 If the fallback is a specifier, `specifier-instance' is called
2634 recursively on this specifier and the return value used. Note,
2635 however, that if the optional argument NO-FALLBACK is non-nil,
2636 the fallback value will not be consulted.
2638 Note that there may be more than one specification matching a particular
2639 locale; all such specifications are considered before looking for any
2640 specifications for more general locales. Any particular specification
2641 that is found may be rejected because its tag set does not match the
2642 device being instantiated over, or because the specification is not
2643 valid for the device of the given domain (e.g. the font or color name
2644 does not exist for this particular X server).
2646 The returned value is dependent on the type of specifier. For example,
2647 for a font specifier (as returned by the `face-font' function), the returned
2648 value will be a font-instance object. For glyphs, the returned value
2649 will be a string, pixmap, or subwindow.
2651 See also `specifier-matching-instance'.
2653 (specifier, domain, default_, no_fallback))
2655 Lisp_Object instance;
2657 CHECK_SPECIFIER (specifier);
2658 domain = decode_domain (domain);
2660 instance = specifier_instance (specifier, Qunbound, domain, ERROR_ME, 0,
2661 !NILP (no_fallback), Qzero);
2662 return UNBOUNDP (instance) ? default_ : instance;
2665 DEFUN ("specifier-matching-instance", Fspecifier_matching_instance, 2, 5, 0, /*
2666 Return an instance for SPECIFIER in DOMAIN that matches MATCHSPEC.
2667 If no instance can be generated for this domain, return DEFAULT.
2669 This function is identical to `specifier-instance' except that a
2670 specification will only be considered if it matches MATCHSPEC.
2671 The definition of "match", and allowed values for MATCHSPEC, are
2672 dependent on the particular type of specifier. Here are some examples:
2674 -- For chartable (e.g. display table) specifiers, MATCHSPEC should be a
2675 character, and the specification (a chartable) must give a value for
2676 that character in order to be considered. This allows you to specify,
2677 e.g., a buffer-local display table that only gives values for particular
2678 characters. All other characters are handled as if the buffer-local
2679 display table is not there. (Chartable specifiers are not yet
2682 -- For font specifiers, MATCHSPEC should be a charset, and the specification
2683 (a font string) must have a registry that matches the charset's registry.
2684 (This only makes sense with Mule support.) This makes it easy to choose a
2685 font that can display a particular character. (This is what redisplay
2688 (specifier, matchspec, domain, default_, no_fallback))
2690 Lisp_Object instance;
2692 CHECK_SPECIFIER (specifier);
2693 check_valid_specifier_matchspec (matchspec, XSPECIFIER (specifier)->methods,
2695 domain = decode_domain (domain);
2697 instance = specifier_instance (specifier, matchspec, domain, ERROR_ME,
2698 0, !NILP (no_fallback), Qzero);
2699 return UNBOUNDP (instance) ? default_ : instance;
2702 DEFUN ("specifier-instance-from-inst-list", Fspecifier_instance_from_inst_list,
2704 Attempt to convert a particular inst-list into an instance.
2705 This attempts to instantiate INST-LIST in the given DOMAIN,
2706 as if INST-LIST existed in a specification in SPECIFIER. If
2707 the instantiation fails, DEFAULT is returned. In most circumstances,
2708 you should not use this function; use `specifier-instance' instead.
2710 (specifier, domain, inst_list, default_))
2712 Lisp_Object val = Qunbound;
2713 Lisp_Specifier *sp = XSPECIFIER (specifier);
2714 struct gcpro gcpro1;
2715 Lisp_Object built_up_list = Qnil;
2717 CHECK_SPECIFIER (specifier);
2718 check_valid_domain (domain);
2719 check_valid_inst_list (inst_list, sp->methods, ERROR_ME);
2720 GCPRO1 (built_up_list);
2721 built_up_list = build_up_processed_list (specifier, domain, inst_list);
2722 if (!NILP (built_up_list))
2723 val = specifier_instance_from_inst_list (specifier, Qunbound, domain,
2724 built_up_list, ERROR_ME,
2727 return UNBOUNDP (val) ? default_ : val;
2730 DEFUN ("specifier-matching-instance-from-inst-list", Fspecifier_matching_instance_from_inst_list,
2732 Attempt to convert a particular inst-list into an instance.
2733 This attempts to instantiate INST-LIST in the given DOMAIN
2734 \(as if INST-LIST existed in a specification in SPECIFIER),
2735 matching the specifications against MATCHSPEC.
2737 This function is analogous to `specifier-instance-from-inst-list'
2738 but allows for specification-matching as in `specifier-matching-instance'.
2739 See that function for a description of exactly how the matching process
2742 (specifier, matchspec, domain, inst_list, default_))
2744 Lisp_Object val = Qunbound;
2745 Lisp_Specifier *sp = XSPECIFIER (specifier);
2746 struct gcpro gcpro1;
2747 Lisp_Object built_up_list = Qnil;
2749 CHECK_SPECIFIER (specifier);
2750 check_valid_specifier_matchspec (matchspec, XSPECIFIER (specifier)->methods,
2752 check_valid_domain (domain);
2753 check_valid_inst_list (inst_list, sp->methods, ERROR_ME);
2754 GCPRO1 (built_up_list);
2755 built_up_list = build_up_processed_list (specifier, domain, inst_list);
2756 if (!NILP (built_up_list))
2757 val = specifier_instance_from_inst_list (specifier, matchspec, domain,
2758 built_up_list, ERROR_ME,
2761 return UNBOUNDP (val) ? default_ : val;
2765 /************************************************************************/
2766 /* Caching in the struct window or frame */
2767 /************************************************************************/
2769 /* Either STRUCT_WINDOW_OFFSET or STRUCT_FRAME_OFFSET can be 0 to indicate
2770 no caching in that sort of object. */
2772 /* #### It would be nice if the specifier caching automatically knew
2773 about specifier fallbacks, so we didn't have to do it ourselves. */
2776 set_specifier_caching (Lisp_Object specifier, int struct_window_offset,
2777 void (*value_changed_in_window)
2778 (Lisp_Object specifier, struct window *w,
2779 Lisp_Object oldval),
2780 int struct_frame_offset,
2781 void (*value_changed_in_frame)
2782 (Lisp_Object specifier, struct frame *f,
2783 Lisp_Object oldval))
2785 Lisp_Specifier *sp = XSPECIFIER (specifier);
2786 assert (!GHOST_SPECIFIER_P (sp));
2789 sp->caching = xnew_and_zero (struct specifier_caching);
2790 sp->caching->offset_into_struct_window = struct_window_offset;
2791 sp->caching->value_changed_in_window = value_changed_in_window;
2792 sp->caching->offset_into_struct_frame = struct_frame_offset;
2793 sp->caching->value_changed_in_frame = value_changed_in_frame;
2794 Vcached_specifiers = Fcons (specifier, Vcached_specifiers);
2795 if (BODILY_SPECIFIER_P (sp))
2796 GHOST_SPECIFIER(sp)->caching = sp->caching;
2797 recompute_cached_specifier_everywhere (specifier);
2801 recompute_one_cached_specifier_in_window (Lisp_Object specifier,
2805 Lisp_Object newval, *location;
2807 assert (!GHOST_SPECIFIER_P (XSPECIFIER (specifier)));
2809 XSETWINDOW (window, w);
2811 newval = specifier_instance (specifier, Qunbound, window, ERROR_ME_WARN,
2813 /* If newval ended up Qunbound, then the calling functions
2814 better be able to deal. If not, set a default so this
2815 never happens or correct it in the value_changed_in_window
2817 location = (Lisp_Object *)
2818 ((char *) w + XSPECIFIER (specifier)->caching->offset_into_struct_window);
2819 if (!EQ (newval, *location))
2821 Lisp_Object oldval = *location;
2823 (XSPECIFIER (specifier)->caching->value_changed_in_window)
2824 (specifier, w, oldval);
2829 recompute_one_cached_specifier_in_frame (Lisp_Object specifier,
2833 Lisp_Object newval, *location;
2835 assert (!GHOST_SPECIFIER_P (XSPECIFIER (specifier)));
2837 XSETFRAME (frame, f);
2839 newval = specifier_instance (specifier, Qunbound, frame, ERROR_ME_WARN,
2841 /* If newval ended up Qunbound, then the calling functions
2842 better be able to deal. If not, set a default so this
2843 never happens or correct it in the value_changed_in_frame
2845 location = (Lisp_Object *)
2846 ((char *) f + XSPECIFIER (specifier)->caching->offset_into_struct_frame);
2847 if (!EQ (newval, *location))
2849 Lisp_Object oldval = *location;
2851 (XSPECIFIER (specifier)->caching->value_changed_in_frame)
2852 (specifier, f, oldval);
2857 recompute_all_cached_specifiers_in_window (struct window *w)
2861 LIST_LOOP (rest, Vcached_specifiers)
2863 Lisp_Object specifier = XCAR (rest);
2864 if (XSPECIFIER (specifier)->caching->offset_into_struct_window)
2865 recompute_one_cached_specifier_in_window (specifier, w);
2870 recompute_all_cached_specifiers_in_frame (struct frame *f)
2874 LIST_LOOP (rest, Vcached_specifiers)
2876 Lisp_Object specifier = XCAR (rest);
2877 if (XSPECIFIER (specifier)->caching->offset_into_struct_frame)
2878 recompute_one_cached_specifier_in_frame (specifier, f);
2883 recompute_cached_specifier_everywhere_mapfun (struct window *w,
2886 Lisp_Object specifier = Qnil;
2888 VOID_TO_LISP (specifier, closure);
2889 recompute_one_cached_specifier_in_window (specifier, w);
2894 recompute_cached_specifier_everywhere (Lisp_Object specifier)
2896 Lisp_Object frmcons, devcons, concons;
2898 specifier = bodily_specifier (specifier);
2900 if (!XSPECIFIER (specifier)->caching)
2903 if (XSPECIFIER (specifier)->caching->offset_into_struct_window)
2905 FRAME_LOOP_NO_BREAK (frmcons, devcons, concons)
2906 map_windows (XFRAME (XCAR (frmcons)),
2907 recompute_cached_specifier_everywhere_mapfun,
2908 LISP_TO_VOID (specifier));
2911 if (XSPECIFIER (specifier)->caching->offset_into_struct_frame)
2913 FRAME_LOOP_NO_BREAK (frmcons, devcons, concons)
2914 recompute_one_cached_specifier_in_frame (specifier,
2915 XFRAME (XCAR (frmcons)));
2919 DEFUN ("set-specifier-dirty-flag", Fset_specifier_dirty_flag, 1, 1, 0, /*
2920 Force recomputation of any caches associated with SPECIFIER.
2921 Note that this automatically happens whenever you change a specification
2922 in SPECIFIER; you do not have to call this function then.
2923 One example of where this function is useful is when you have a
2924 toolbar button whose `active-p' field is an expression to be
2925 evaluated. Calling `set-specifier-dirty-flag' on the
2926 toolbar specifier will force the `active-p' fields to be
2931 CHECK_SPECIFIER (specifier);
2932 recompute_cached_specifier_everywhere (specifier);
2937 /************************************************************************/
2938 /* Generic specifier type */
2939 /************************************************************************/
2941 DEFINE_SPECIFIER_TYPE (generic);
2945 /* This is the string that used to be in `generic-specifier-p'.
2946 The idea is good, but it doesn't quite work in the form it's
2947 in. (One major problem is that validating an instantiator
2948 is supposed to require only that the specifier type is passed,
2949 while with this approach the actual specifier is needed.)
2951 What really needs to be done is to write a function
2952 `make-specifier-type' that creates new specifier types.
2953 #### I'll look into this for 19.14.
2956 "A generic specifier is a generalized kind of specifier with user-defined\n"
2957 "semantics. The instantiator can be any kind of Lisp object, and the\n"
2958 "instance computed from it is likewise any kind of Lisp object. The\n"
2959 "SPECIFIER-DATA should be an alist of methods governing how the specifier\n"
2960 "works. All methods are optional, and reasonable default methods will be\n"
2961 "provided. Currently there are two defined methods: 'instantiate and\n"
2964 "'instantiate specifies how to do the instantiation; if omitted, the\n"
2965 "instantiator itself is simply returned as the instance. The method\n"
2966 "should be a function that accepts three parameters (a specifier, the\n"
2967 "instantiator that matched the domain being instantiated over, and that\n"
2968 "domain), and should return a one-element list containing the instance,\n"
2969 "or nil if no instance exists. Note that the domain passed to this function\n"
2970 "is the domain being instantiated over, which may not be the same as the\n"
2971 "locale contained in the specification corresponding to the instantiator\n"
2972 "(for example, the domain being instantiated over could be a window, but\n"
2973 "the locale corresponding to the passed instantiator could be the window's\n"
2974 "buffer or frame).\n"
2976 "'validate specifies whether a given instantiator is valid; if omitted,\n"
2977 "all instantiators are considered valid. It should be a function of\n"
2978 "two arguments: an instantiator and a flag CAN-SIGNAL-ERROR. If this\n"
2979 "flag is false, the function must simply return t or nil indicating\n"
2980 "whether the instantiator is valid. If this flag is true, the function\n"
2981 "is free to signal an error if it encounters an invalid instantiator\n"
2982 "(this can be useful for issuing a specific error about exactly why the\n"
2983 "instantiator is valid). It can also return nil to indicate an invalid\n"
2984 "instantiator; in this case, a general error will be signalled."
2988 DEFUN ("generic-specifier-p", Fgeneric_specifier_p, 1, 1, 0, /*
2989 Return non-nil if OBJECT is a generic specifier.
2991 A generic specifier allows any kind of Lisp object as an instantiator,
2992 and returns back the Lisp object unchanged when it is instantiated.
2996 return GENERIC_SPECIFIERP (object) ? Qt : Qnil;
3000 /************************************************************************/
3001 /* Integer specifier type */
3002 /************************************************************************/
3004 DEFINE_SPECIFIER_TYPE (integer);
3007 integer_validate (Lisp_Object instantiator)
3009 CHECK_INT (instantiator);
3012 DEFUN ("integer-specifier-p", Finteger_specifier_p, 1, 1, 0, /*
3013 Return non-nil if OBJECT is an integer specifier.
3017 return INTEGER_SPECIFIERP (object) ? Qt : Qnil;
3020 /************************************************************************/
3021 /* Non-negative-integer specifier type */
3022 /************************************************************************/
3024 DEFINE_SPECIFIER_TYPE (natnum);
3027 natnum_validate (Lisp_Object instantiator)
3029 CHECK_NATNUM (instantiator);
3032 DEFUN ("natnum-specifier-p", Fnatnum_specifier_p, 1, 1, 0, /*
3033 Return non-nil if OBJECT is a natnum (non-negative-integer) specifier.
3037 return NATNUM_SPECIFIERP (object) ? Qt : Qnil;
3040 /************************************************************************/
3041 /* Boolean specifier type */
3042 /************************************************************************/
3044 DEFINE_SPECIFIER_TYPE (boolean);
3047 boolean_validate (Lisp_Object instantiator)
3049 if (!EQ (instantiator, Qt) && !EQ (instantiator, Qnil))
3050 signal_simple_error ("Must be t or nil", instantiator);
3053 DEFUN ("boolean-specifier-p", Fboolean_specifier_p, 1, 1, 0, /*
3054 Return non-nil if OBJECT is a boolean specifier.
3058 return BOOLEAN_SPECIFIERP (object) ? Qt : Qnil;
3061 /************************************************************************/
3062 /* Display table specifier type */
3063 /************************************************************************/
3065 DEFINE_SPECIFIER_TYPE (display_table);
3067 #define VALID_SINGLE_DISPTABLE_INSTANTIATOR_P(instantiator) \
3068 (VECTORP (instantiator) \
3069 || (CHAR_TABLEP (instantiator) \
3070 && (XCHAR_TABLE_TYPE (instantiator) == CHAR_TABLE_TYPE_CHAR \
3071 || XCHAR_TABLE_TYPE (instantiator) == CHAR_TABLE_TYPE_GENERIC)) \
3072 || RANGE_TABLEP (instantiator))
3075 display_table_validate (Lisp_Object instantiator)
3077 if (NILP (instantiator))
3080 else if (CONSP (instantiator))
3083 EXTERNAL_LIST_LOOP (tail, instantiator)
3085 Lisp_Object car = XCAR (tail);
3086 if (!VALID_SINGLE_DISPTABLE_INSTANTIATOR_P (car))
3092 if (!VALID_SINGLE_DISPTABLE_INSTANTIATOR_P (instantiator))
3095 dead_wrong_type_argument (display_table_specifier_methods->predicate_symbol,
3101 DEFUN ("display-table-specifier-p", Fdisplay_table_specifier_p, 1, 1, 0, /*
3102 Return non-nil if OBJECT is a display-table specifier.
3106 return DISPLAYTABLE_SPECIFIERP (object) ? Qt : Qnil;
3110 /************************************************************************/
3111 /* Initialization */
3112 /************************************************************************/
3115 syms_of_specifier (void)
3117 INIT_LRECORD_IMPLEMENTATION (specifier);
3119 defsymbol (&Qspecifierp, "specifierp");
3121 defsymbol (&Qconsole_type, "console-type");
3122 defsymbol (&Qdevice_class, "device-class");
3124 /* Qinteger, Qboolean, Qgeneric defined in general.c */
3125 defsymbol (&Qnatnum, "natnum");
3127 DEFSUBR (Fvalid_specifier_type_p);
3128 DEFSUBR (Fspecifier_type_list);
3129 DEFSUBR (Fmake_specifier);
3130 DEFSUBR (Fspecifierp);
3131 DEFSUBR (Fspecifier_type);
3133 DEFSUBR (Fvalid_specifier_locale_p);
3134 DEFSUBR (Fvalid_specifier_domain_p);
3135 DEFSUBR (Fvalid_specifier_locale_type_p);
3136 DEFSUBR (Fspecifier_locale_type_from_locale);
3138 DEFSUBR (Fvalid_specifier_tag_p);
3139 DEFSUBR (Fvalid_specifier_tag_set_p);
3140 DEFSUBR (Fcanonicalize_tag_set);
3141 DEFSUBR (Fdevice_matches_specifier_tag_set_p);
3142 DEFSUBR (Fdefine_specifier_tag);
3143 DEFSUBR (Fdevice_matching_specifier_tag_list);
3144 DEFSUBR (Fspecifier_tag_list);
3145 DEFSUBR (Fspecifier_tag_predicate);
3147 DEFSUBR (Fcheck_valid_instantiator);
3148 DEFSUBR (Fvalid_instantiator_p);
3149 DEFSUBR (Fcheck_valid_inst_list);
3150 DEFSUBR (Fvalid_inst_list_p);
3151 DEFSUBR (Fcheck_valid_spec_list);
3152 DEFSUBR (Fvalid_spec_list_p);
3153 DEFSUBR (Fadd_spec_to_specifier);
3154 DEFSUBR (Fadd_spec_list_to_specifier);
3155 DEFSUBR (Fspecifier_spec_list);
3156 DEFSUBR (Fspecifier_specs);
3157 DEFSUBR (Fremove_specifier);
3158 DEFSUBR (Fcopy_specifier);
3160 DEFSUBR (Fcheck_valid_specifier_matchspec);
3161 DEFSUBR (Fvalid_specifier_matchspec_p);
3162 DEFSUBR (Fspecifier_fallback);
3163 DEFSUBR (Fspecifier_instance);
3164 DEFSUBR (Fspecifier_matching_instance);
3165 DEFSUBR (Fspecifier_instance_from_inst_list);
3166 DEFSUBR (Fspecifier_matching_instance_from_inst_list);
3167 DEFSUBR (Fset_specifier_dirty_flag);
3169 DEFSUBR (Fgeneric_specifier_p);
3170 DEFSUBR (Finteger_specifier_p);
3171 DEFSUBR (Fnatnum_specifier_p);
3172 DEFSUBR (Fboolean_specifier_p);
3173 DEFSUBR (Fdisplay_table_specifier_p);
3175 /* Symbols pertaining to specifier creation. Specifiers are created
3176 in the syms_of() functions. */
3178 /* locales are defined in general.c. */
3180 defsymbol (&Qprepend, "prepend");
3181 defsymbol (&Qappend, "append");
3182 defsymbol (&Qremove_tag_set_prepend, "remove-tag-set-prepend");
3183 defsymbol (&Qremove_tag_set_append, "remove-tag-set-append");
3184 defsymbol (&Qremove_locale, "remove-locale");
3185 defsymbol (&Qremove_locale_type, "remove-locale-type");
3186 defsymbol (&Qremove_all, "remove-all");
3188 defsymbol (&Qfallback, "fallback");
3192 specifier_type_create (void)
3194 the_specifier_type_entry_dynarr = Dynarr_new (specifier_type_entry);
3195 dumpstruct (&the_specifier_type_entry_dynarr, &sted_description);
3197 Vspecifier_type_list = Qnil;
3198 staticpro (&Vspecifier_type_list);
3200 INITIALIZE_SPECIFIER_TYPE (generic, "generic", "generic-specifier-p");
3202 INITIALIZE_SPECIFIER_TYPE (integer, "integer", "integer-specifier-p");
3204 SPECIFIER_HAS_METHOD (integer, validate);
3206 INITIALIZE_SPECIFIER_TYPE (natnum, "natnum", "natnum-specifier-p");
3208 SPECIFIER_HAS_METHOD (natnum, validate);
3210 INITIALIZE_SPECIFIER_TYPE (boolean, "boolean", "boolean-specifier-p");
3212 SPECIFIER_HAS_METHOD (boolean, validate);
3214 INITIALIZE_SPECIFIER_TYPE (display_table, "display-table", "display-table-p");
3216 SPECIFIER_HAS_METHOD (display_table, validate);
3220 reinit_specifier_type_create (void)
3222 REINITIALIZE_SPECIFIER_TYPE (generic);
3223 REINITIALIZE_SPECIFIER_TYPE (integer);
3224 REINITIALIZE_SPECIFIER_TYPE (natnum);
3225 REINITIALIZE_SPECIFIER_TYPE (boolean);
3226 REINITIALIZE_SPECIFIER_TYPE (display_table);
3230 vars_of_specifier (void)
3232 Vcached_specifiers = Qnil;
3233 staticpro (&Vcached_specifiers);
3235 /* Do NOT mark through this, or specifiers will never be GC'd.
3236 This is the same deal as for weak hash tables. */
3237 Vall_specifiers = Qnil;
3238 pdump_wire_list (&Vall_specifiers);
3240 Vuser_defined_tags = Qnil;
3241 staticpro (&Vuser_defined_tags);
3243 Vunlock_ghost_specifiers = Qnil;
3244 staticpro (&Vunlock_ghost_specifiers);