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, 'gutter, 'gutter-size, 'gutter-visible or 'toolbar.
548 For more information on particular types of specifiers, see the
549 functions `generic-specifier-p', `integer-specifier-p',
550 `boolean-specifier-p', `color-specifier-p', `font-specifier-p',
551 `image-specifier-p', `face-boolean-specifier-p', `gutter-specifier-p,
552 `gutter-size-specifier-p, `gutter-visible-specifier-p and
553 `toolbar-specifier-p'.
557 /* This function can GC */
558 struct specifier_methods *meths = decode_specifier_type (type,
561 return make_specifier (meths);
564 DEFUN ("specifierp", Fspecifierp, 1, 1, 0, /*
565 Return t if OBJECT is a specifier.
567 A specifier is an object that can be used to keep track of a property
568 whose value can be per-buffer, per-window, per-frame, or per-device,
569 and can further be restricted to a particular console-type or device-class.
570 See `make-specifier'.
574 return SPECIFIERP (object) ? Qt : Qnil;
577 DEFUN ("specifier-type", Fspecifier_type, 1, 1, 0, /*
578 Return the type of SPECIFIER.
582 CHECK_SPECIFIER (specifier);
583 return intern (XSPECIFIER (specifier)->methods->name);
587 /************************************************************************/
588 /* Locales and domains */
589 /************************************************************************/
591 DEFUN ("valid-specifier-locale-p", Fvalid_specifier_locale_p, 1, 1, 0, /*
592 Return t if LOCALE is a valid specifier locale.
593 Valid locales are devices, frames, windows, buffers, and 'global.
598 /* This cannot GC. */
599 return ((DEVICEP (locale) && DEVICE_LIVE_P (XDEVICE (locale))) ||
600 (FRAMEP (locale) && FRAME_LIVE_P (XFRAME (locale))) ||
601 (BUFFERP (locale) && BUFFER_LIVE_P (XBUFFER (locale))) ||
602 /* dead windows are allowed because they may become live
603 windows again when a window configuration is restored */
605 EQ (locale, Qglobal))
609 DEFUN ("valid-specifier-domain-p", Fvalid_specifier_domain_p, 1, 1, 0, /*
610 Return t if DOMAIN is a valid specifier domain.
611 A domain is used to instance a specifier (i.e. determine the specifier's
612 value in that domain). Valid domains are windows, frames, and devices.
617 /* This cannot GC. */
618 return ((DEVICEP (domain) && DEVICE_LIVE_P (XDEVICE (domain))) ||
619 (FRAMEP (domain) && FRAME_LIVE_P (XFRAME (domain))) ||
620 (WINDOWP (domain) && WINDOW_LIVE_P (XWINDOW (domain))))
624 DEFUN ("valid-specifier-locale-type-p", Fvalid_specifier_locale_type_p, 1, 1, 0, /*
625 Given a specifier LOCALE-TYPE, return non-nil if it is valid.
626 Valid locale types are 'global, 'device, 'frame, 'window, and 'buffer.
627 \(Note, however, that in functions that accept either a locale or a locale
628 type, 'global is considered an individual locale.)
632 /* This cannot GC. */
633 return (EQ (locale_type, Qglobal) ||
634 EQ (locale_type, Qdevice) ||
635 EQ (locale_type, Qframe) ||
636 EQ (locale_type, Qwindow) ||
637 EQ (locale_type, Qbuffer)) ? Qt : Qnil;
641 check_valid_locale_or_locale_type (Lisp_Object locale)
643 /* This cannot GC. */
644 if (EQ (locale, Qall) ||
645 !NILP (Fvalid_specifier_locale_p (locale)) ||
646 !NILP (Fvalid_specifier_locale_type_p (locale)))
648 signal_simple_error ("Invalid specifier locale or locale type", locale);
651 DEFUN ("specifier-locale-type-from-locale", Fspecifier_locale_type_from_locale,
653 Given a specifier LOCALE, return its type.
657 /* This cannot GC. */
658 if (NILP (Fvalid_specifier_locale_p (locale)))
659 signal_simple_error ("Invalid specifier locale", locale);
660 if (DEVICEP (locale)) return Qdevice;
661 if (FRAMEP (locale)) return Qframe;
662 if (WINDOWP (locale)) return Qwindow;
663 if (BUFFERP (locale)) return Qbuffer;
664 assert (EQ (locale, Qglobal));
669 decode_locale (Lisp_Object locale)
671 /* This cannot GC. */
674 else if (!NILP (Fvalid_specifier_locale_p (locale)))
677 signal_simple_error ("Invalid specifier locale", locale);
682 static enum spec_locale_type
683 decode_locale_type (Lisp_Object locale_type)
685 /* This cannot GC. */
686 if (EQ (locale_type, Qglobal)) return LOCALE_GLOBAL;
687 if (EQ (locale_type, Qdevice)) return LOCALE_DEVICE;
688 if (EQ (locale_type, Qframe)) return LOCALE_FRAME;
689 if (EQ (locale_type, Qwindow)) return LOCALE_WINDOW;
690 if (EQ (locale_type, Qbuffer)) return LOCALE_BUFFER;
692 signal_simple_error ("Invalid specifier locale type", locale_type);
693 return LOCALE_GLOBAL; /* not reached */
697 decode_locale_list (Lisp_Object locale)
699 /* This cannot GC. */
700 /* The return value of this function must be GCPRO'd. */
705 else if (CONSP (locale))
708 EXTERNAL_LIST_LOOP_2 (elt, locale)
709 check_valid_locale_or_locale_type (elt);
714 check_valid_locale_or_locale_type (locale);
715 return list1 (locale);
719 static enum spec_locale_type
720 locale_type_from_locale (Lisp_Object locale)
722 return decode_locale_type (Fspecifier_locale_type_from_locale (locale));
726 check_valid_domain (Lisp_Object domain)
728 if (NILP (Fvalid_specifier_domain_p (domain)))
729 signal_simple_error ("Invalid specifier domain", domain);
733 decode_domain (Lisp_Object domain)
736 return Fselected_window (Qnil);
737 check_valid_domain (domain);
742 /************************************************************************/
744 /************************************************************************/
746 DEFUN ("valid-specifier-tag-p", Fvalid_specifier_tag_p, 1, 1, 0, /*
747 Return non-nil if TAG is a valid specifier tag.
748 See also `valid-specifier-tag-set-p'.
752 return (valid_console_type_p (tag) ||
753 valid_device_class_p (tag) ||
754 !NILP (assq_no_quit (tag, Vuser_defined_tags))) ? Qt : Qnil;
757 DEFUN ("valid-specifier-tag-set-p", Fvalid_specifier_tag_set_p, 1, 1, 0, /*
758 Return non-nil if TAG-SET is a valid specifier tag set.
760 A specifier tag set is an entity that is attached to an instantiator
761 and can be used to restrict the scope of that instantiator to a
762 particular device class or device type and/or to mark instantiators
763 added by a particular package so that they can be later removed.
765 A specifier tag set consists of a list of zero of more specifier tags,
766 each of which is a symbol that is recognized by XEmacs as a tag.
767 \(The valid device types and device classes are always tags, as are
768 any tags defined by `define-specifier-tag'.) It is called a "tag set"
769 \(as opposed to a list) because the order of the tags or the number of
770 times a particular tag occurs does not matter.
772 Each tag has a predicate associated with it, which specifies whether
773 that tag applies to a particular device. The tags which are device types
774 and classes match devices of that type or class. User-defined tags can
775 have any predicate, or none (meaning that all devices match). When
776 attempting to instance a specifier, a particular instantiator is only
777 considered if the device of the domain being instanced over matches
778 all tags in the tag set attached to that instantiator.
780 Most of the time, a tag set is not specified, and the instantiator
781 gets a null tag set, which matches all devices.
787 for (rest = tag_set; !NILP (rest); rest = XCDR (rest))
791 if (NILP (Fvalid_specifier_tag_p (XCAR (rest))))
799 decode_specifier_tag_set (Lisp_Object tag_set)
801 /* The return value of this function must be GCPRO'd. */
802 if (!NILP (Fvalid_specifier_tag_p (tag_set)))
803 return list1 (tag_set);
804 if (NILP (Fvalid_specifier_tag_set_p (tag_set)))
805 signal_simple_error ("Invalid specifier tag-set", tag_set);
810 canonicalize_tag_set (Lisp_Object tag_set)
812 int len = XINT (Flength (tag_set));
813 Lisp_Object *tags, rest;
816 /* We assume in this function that the tag_set has already been
817 validated, so there are no surprises. */
819 if (len == 0 || len == 1)
820 /* most common case */
823 tags = alloca_array (Lisp_Object, len);
826 LIST_LOOP (rest, tag_set)
827 tags[i++] = XCAR (rest);
829 /* Sort the list of tags. We use a bubble sort here (copied from
830 extent_fragment_update()) -- reduces the function call overhead,
831 and is the fastest sort for small numbers of items. */
833 for (i = 1; i < len; i++)
837 strcmp ((char *) string_data (XSYMBOL (tags[j])->name),
838 (char *) string_data (XSYMBOL (tags[j+1])->name)) > 0)
840 Lisp_Object tmp = tags[j];
847 /* Now eliminate duplicates. */
849 for (i = 1, j = 1; i < len; i++)
851 /* j holds the destination, i the source. */
852 if (!EQ (tags[i], tags[i-1]))
856 return Flist (j, tags);
859 DEFUN ("canonicalize-tag-set", Fcanonicalize_tag_set, 1, 1, 0, /*
860 Canonicalize the given tag set.
861 Two canonicalized tag sets can be compared with `equal' to see if they
862 represent the same tag set. (Specifically, canonicalizing involves
863 sorting by symbol name and removing duplicates.)
867 if (NILP (Fvalid_specifier_tag_set_p (tag_set)))
868 signal_simple_error ("Invalid tag set", tag_set);
869 return canonicalize_tag_set (tag_set);
873 device_matches_specifier_tag_set_p (Lisp_Object device, Lisp_Object tag_set)
875 Lisp_Object devtype, devclass, rest;
876 struct device *d = XDEVICE (device);
878 devtype = DEVICE_TYPE (d);
879 devclass = DEVICE_CLASS (d);
881 LIST_LOOP (rest, tag_set)
883 Lisp_Object tag = XCAR (rest);
886 if (EQ (tag, devtype) || EQ (tag, devclass))
888 assoc = assq_no_quit (tag, DEVICE_USER_DEFINED_TAGS (d));
889 /* other built-in tags (device types/classes) are not in
890 the user-defined-tags list. */
891 if (NILP (assoc) || NILP (XCDR (assoc)))
898 DEFUN ("device-matches-specifier-tag-set-p", Fdevice_matches_specifier_tag_set_p, 2, 2, 0, /*
899 Return non-nil if DEVICE matches specifier tag set TAG-SET.
900 This means that DEVICE matches each tag in the tag set. (Every
901 tag recognized by XEmacs has a predicate associated with it that
902 specifies which devices match it.)
906 CHECK_LIVE_DEVICE (device);
908 if (NILP (Fvalid_specifier_tag_set_p (tag_set)))
909 signal_simple_error ("Invalid tag set", tag_set);
911 return device_matches_specifier_tag_set_p (device, tag_set) ? Qt : Qnil;
914 DEFUN ("define-specifier-tag", Fdefine_specifier_tag, 1, 2, 0, /*
915 Define a new specifier tag.
916 If PREDICATE is specified, it should be a function of one argument
917 \(a device) that specifies whether the tag matches that particular
918 device. If PREDICATE is omitted, the tag matches all devices.
920 You can redefine an existing user-defined specifier tag. However,
921 you cannot redefine the built-in specifier tags (the device types
922 and classes) or the symbols nil, t, 'all, or 'global.
926 Lisp_Object assoc, devcons, concons;
930 if (valid_device_class_p (tag) ||
931 valid_console_type_p (tag))
932 signal_simple_error ("Cannot redefine built-in specifier tags", tag);
933 /* Try to prevent common instantiators and locales from being
934 redefined, to reduce ambiguity */
935 if (NILP (tag) || EQ (tag, Qt) || EQ (tag, Qall) || EQ (tag, Qglobal))
936 signal_simple_error ("Cannot define nil, t, 'all, or 'global",
938 assoc = assq_no_quit (tag, Vuser_defined_tags);
942 Vuser_defined_tags = Fcons (Fcons (tag, predicate), Vuser_defined_tags);
943 DEVICE_LOOP_NO_BREAK (devcons, concons)
945 struct device *d = XDEVICE (XCAR (devcons));
946 /* Initially set the value to t in case of error
948 DEVICE_USER_DEFINED_TAGS (d) =
949 Fcons (Fcons (tag, Qt), DEVICE_USER_DEFINED_TAGS (d));
952 else if (!NILP (predicate) && !NILP (XCDR (assoc)))
955 XCDR (assoc) = predicate;
958 /* recompute the tag values for all devices. However, in the special
959 case where both the old and new predicates are nil, we know that
960 we don't have to do this. (It's probably common for people to
961 call (define-specifier-tag) more than once on the same tag,
962 and the most common case is where PREDICATE is not specified.) */
966 DEVICE_LOOP_NO_BREAK (devcons, concons)
968 Lisp_Object device = XCAR (devcons);
969 assoc = assq_no_quit (tag,
970 DEVICE_USER_DEFINED_TAGS (XDEVICE (device)));
971 assert (CONSP (assoc));
972 if (NILP (predicate))
975 XCDR (assoc) = !NILP (call1 (predicate, device)) ? Qt : Qnil;
982 /* Called at device-creation time to initialize the user-defined
983 tag values for the newly-created device. */
986 setup_device_initial_specifier_tags (struct device *d)
988 Lisp_Object rest, rest2;
991 XSETDEVICE (device, d);
993 DEVICE_USER_DEFINED_TAGS (d) = Fcopy_alist (Vuser_defined_tags);
995 /* Now set up the initial values */
996 LIST_LOOP (rest, DEVICE_USER_DEFINED_TAGS (d))
997 XCDR (XCAR (rest)) = Qt;
999 for (rest = Vuser_defined_tags, rest2 = DEVICE_USER_DEFINED_TAGS (d);
1000 !NILP (rest); rest = XCDR (rest), rest2 = XCDR (rest2))
1002 Lisp_Object predicate = XCDR (XCAR (rest));
1003 if (NILP (predicate))
1004 XCDR (XCAR (rest2)) = Qt;
1006 XCDR (XCAR (rest2)) = !NILP (call1 (predicate, device)) ? Qt : Qnil;
1010 DEFUN ("device-matching-specifier-tag-list", Fdevice_matching_specifier_tag_list,
1012 Return a list of all specifier tags matching DEVICE.
1013 DEVICE defaults to the selected device if omitted.
1017 struct device *d = decode_device (device);
1018 Lisp_Object rest, list = Qnil;
1019 struct gcpro gcpro1;
1023 LIST_LOOP (rest, DEVICE_USER_DEFINED_TAGS (d))
1025 if (!NILP (XCDR (XCAR (rest))))
1026 list = Fcons (XCAR (XCAR (rest)), list);
1029 list = Fnreverse (list);
1030 list = Fcons (DEVICE_CLASS (d), list);
1031 list = Fcons (DEVICE_TYPE (d), list);
1033 RETURN_UNGCPRO (list);
1036 DEFUN ("specifier-tag-list", Fspecifier_tag_list, 0, 0, 0, /*
1037 Return a list of all currently-defined specifier tags.
1038 This includes the built-in ones (the device types and classes).
1042 Lisp_Object list = Qnil, rest;
1043 struct gcpro gcpro1;
1047 LIST_LOOP (rest, Vuser_defined_tags)
1048 list = Fcons (XCAR (XCAR (rest)), list);
1050 list = Fnreverse (list);
1051 list = nconc2 (Fcopy_sequence (Vdevice_class_list), list);
1052 list = nconc2 (Fcopy_sequence (Vconsole_type_list), list);
1054 RETURN_UNGCPRO (list);
1057 DEFUN ("specifier-tag-predicate", Fspecifier_tag_predicate, 1, 1, 0, /*
1058 Return the predicate for the given specifier tag.
1062 /* The return value of this function must be GCPRO'd. */
1065 if (NILP (Fvalid_specifier_tag_p (tag)))
1066 signal_simple_error ("Invalid specifier tag", tag);
1068 /* Make up some predicates for the built-in types */
1070 if (valid_console_type_p (tag))
1071 return list3 (Qlambda, list1 (Qdevice),
1072 list3 (Qeq, list2 (Qquote, tag),
1073 list2 (Qconsole_type, Qdevice)));
1075 if (valid_device_class_p (tag))
1076 return list3 (Qlambda, list1 (Qdevice),
1077 list3 (Qeq, list2 (Qquote, tag),
1078 list2 (Qdevice_class, Qdevice)));
1080 return XCDR (assq_no_quit (tag, Vuser_defined_tags));
1083 /* Return true if A "matches" B. If EXACT_P is 0, A must be a subset of B.
1084 Otherwise, A must be `equal' to B. The sets must be canonicalized. */
1086 tag_sets_match_p (Lisp_Object a, Lisp_Object b, int exact_p)
1090 while (!NILP (a) && !NILP (b))
1092 if (EQ (XCAR (a), XCAR (b)))
1101 while (!NILP (a) && !NILP (b))
1103 if (!EQ (XCAR (a), XCAR (b)))
1109 return NILP (a) && NILP (b);
1114 /************************************************************************/
1115 /* Spec-lists and inst-lists */
1116 /************************************************************************/
1119 call_validate_method (Lisp_Object boxed_method, Lisp_Object instantiator)
1121 ((void (*)(Lisp_Object)) get_opaque_ptr (boxed_method)) (instantiator);
1126 check_valid_instantiator (Lisp_Object instantiator,
1127 struct specifier_methods *meths,
1128 Error_behavior errb)
1130 if (meths->validate_method)
1134 if (ERRB_EQ (errb, ERROR_ME))
1136 (meths->validate_method) (instantiator);
1141 Lisp_Object opaque = make_opaque_ptr ((void *)
1142 meths->validate_method);
1143 struct gcpro gcpro1;
1146 retval = call_with_suspended_errors
1147 ((lisp_fn_t) call_validate_method,
1148 Qnil, Qspecifier, errb, 2, opaque, instantiator);
1150 free_opaque_ptr (opaque);
1159 DEFUN ("check-valid-instantiator", Fcheck_valid_instantiator, 2, 2, 0, /*
1160 Signal an error if INSTANTIATOR is invalid for SPECIFIER-TYPE.
1162 (instantiator, specifier_type))
1164 struct specifier_methods *meths = decode_specifier_type (specifier_type,
1167 return check_valid_instantiator (instantiator, meths, ERROR_ME);
1170 DEFUN ("valid-instantiator-p", Fvalid_instantiator_p, 2, 2, 0, /*
1171 Return non-nil if INSTANTIATOR is valid for SPECIFIER-TYPE.
1173 (instantiator, specifier_type))
1175 struct specifier_methods *meths = decode_specifier_type (specifier_type,
1178 return check_valid_instantiator (instantiator, meths, ERROR_ME_NOT);
1182 check_valid_inst_list (Lisp_Object inst_list, struct specifier_methods *meths,
1183 Error_behavior errb)
1187 LIST_LOOP (rest, inst_list)
1189 Lisp_Object inst_pair, tag_set;
1193 maybe_signal_simple_error ("Invalid instantiator list", inst_list,
1197 if (!CONSP (inst_pair = XCAR (rest)))
1199 maybe_signal_simple_error ("Invalid instantiator pair", inst_pair,
1203 if (NILP (Fvalid_specifier_tag_set_p (tag_set = XCAR (inst_pair))))
1205 maybe_signal_simple_error ("Invalid specifier tag", tag_set,
1210 if (NILP (check_valid_instantiator (XCDR (inst_pair), meths, errb)))
1217 DEFUN ("check-valid-inst-list", Fcheck_valid_inst_list, 2, 2, 0, /*
1218 Signal an error if INST-LIST is invalid for specifier type TYPE.
1222 struct specifier_methods *meths = decode_specifier_type (type, ERROR_ME);
1224 return check_valid_inst_list (inst_list, meths, ERROR_ME);
1227 DEFUN ("valid-inst-list-p", Fvalid_inst_list_p, 2, 2, 0, /*
1228 Return non-nil if INST-LIST is valid for specifier type TYPE.
1232 struct specifier_methods *meths = decode_specifier_type (type, ERROR_ME);
1234 return check_valid_inst_list (inst_list, meths, ERROR_ME_NOT);
1238 check_valid_spec_list (Lisp_Object spec_list, struct specifier_methods *meths,
1239 Error_behavior errb)
1243 LIST_LOOP (rest, spec_list)
1245 Lisp_Object spec, locale;
1246 if (!CONSP (rest) || !CONSP (spec = XCAR (rest)))
1248 maybe_signal_simple_error ("Invalid specification list", spec_list,
1252 if (NILP (Fvalid_specifier_locale_p (locale = XCAR (spec))))
1254 maybe_signal_simple_error ("Invalid specifier locale", locale,
1259 if (NILP (check_valid_inst_list (XCDR (spec), meths, errb)))
1266 DEFUN ("check-valid-spec-list", Fcheck_valid_spec_list, 2, 2, 0, /*
1267 Signal an error if SPEC-LIST is invalid for specifier type TYPE.
1271 struct specifier_methods *meths = decode_specifier_type (type, ERROR_ME);
1273 return check_valid_spec_list (spec_list, meths, ERROR_ME);
1276 DEFUN ("valid-spec-list-p", Fvalid_spec_list_p, 2, 2, 0, /*
1277 Return non-nil if SPEC-LIST is valid for specifier type TYPE.
1281 struct specifier_methods *meths = decode_specifier_type (type, ERROR_ME);
1283 return check_valid_spec_list (spec_list, meths, ERROR_ME_NOT);
1287 decode_how_to_add_specification (Lisp_Object how_to_add)
1289 if (NILP (how_to_add) || EQ (Qremove_tag_set_prepend, how_to_add))
1290 return SPEC_REMOVE_TAG_SET_PREPEND;
1291 if (EQ (Qremove_tag_set_append, how_to_add))
1292 return SPEC_REMOVE_TAG_SET_APPEND;
1293 if (EQ (Qappend, how_to_add))
1295 if (EQ (Qprepend, how_to_add))
1296 return SPEC_PREPEND;
1297 if (EQ (Qremove_locale, how_to_add))
1298 return SPEC_REMOVE_LOCALE;
1299 if (EQ (Qremove_locale_type, how_to_add))
1300 return SPEC_REMOVE_LOCALE_TYPE;
1301 if (EQ (Qremove_all, how_to_add))
1302 return SPEC_REMOVE_ALL;
1304 signal_simple_error ("Invalid `how-to-add' flag", how_to_add);
1306 return SPEC_PREPEND; /* not reached */
1309 /* Given a specifier object SPEC, return bodily specifier if SPEC is a
1310 ghost specifier, otherwise return the object itself
1313 bodily_specifier (Lisp_Object spec)
1315 return (GHOST_SPECIFIER_P (XSPECIFIER (spec))
1316 ? XSPECIFIER(spec)->magic_parent : spec);
1319 /* Signal error if (specifier SPEC is read-only.
1320 Read only are ghost specifiers unless Vunlock_ghost_specifiers is
1321 non-nil. All other specifiers are read-write.
1324 check_modifiable_specifier (Lisp_Object spec)
1326 if (NILP (Vunlock_ghost_specifiers)
1327 && GHOST_SPECIFIER_P (XSPECIFIER (spec)))
1328 signal_simple_error ("Attempt to modify read-only specifier",
1332 /* Helper function which unwind protects the value of
1333 Vunlock_ghost_specifiers, then sets it to non-nil value */
1335 restore_unlock_value (Lisp_Object val)
1337 Vunlock_ghost_specifiers = val;
1342 unlock_ghost_specifiers_protected (void)
1344 int depth = specpdl_depth ();
1345 record_unwind_protect (restore_unlock_value,
1346 Vunlock_ghost_specifiers);
1347 Vunlock_ghost_specifiers = Qt;
1351 /* This gets hit so much that the function call overhead had a
1352 measurable impact (according to Quantify). #### We should figure
1353 out the frequency with which this is called with the various types
1354 and reorder the check accordingly. */
1355 #define SPECIFIER_GET_SPEC_LIST(specifier, type) \
1356 (type == LOCALE_GLOBAL ? &(XSPECIFIER (specifier)->global_specs) : \
1357 type == LOCALE_DEVICE ? &(XSPECIFIER (specifier)->device_specs) : \
1358 type == LOCALE_FRAME ? &(XSPECIFIER (specifier)->frame_specs) : \
1359 type == LOCALE_WINDOW ? &(XWEAK_LIST_LIST \
1360 (XSPECIFIER (specifier)->window_specs)) : \
1361 type == LOCALE_BUFFER ? &(XSPECIFIER (specifier)->buffer_specs) : \
1364 static Lisp_Object *
1365 specifier_get_inst_list (Lisp_Object specifier, Lisp_Object locale,
1366 enum spec_locale_type type)
1368 Lisp_Object *spec_list = SPECIFIER_GET_SPEC_LIST (specifier, type);
1369 Lisp_Object specification;
1371 if (type == LOCALE_GLOBAL)
1373 /* Calling assq_no_quit when it is just going to return nil anyhow
1374 is extremely expensive. So sayeth Quantify. */
1375 if (!CONSP (*spec_list))
1377 specification = assq_no_quit (locale, *spec_list);
1378 if (NILP (specification))
1380 return &XCDR (specification);
1383 /* For the given INST_LIST, return a new INST_LIST containing all elements
1384 where TAG-SET matches the element's tag set. EXACT_P indicates whether
1385 the match must be exact (as opposed to a subset). SHORT_P indicates
1386 that the short form (for `specifier-specs') should be returned if
1387 possible. If COPY_TREE_P, `copy-tree' is used to ensure that no
1388 elements of the new list are shared with the initial list.
1392 specifier_process_inst_list (Lisp_Object inst_list,
1393 Lisp_Object tag_set, int exact_p,
1394 int short_p, int copy_tree_p)
1396 Lisp_Object retval = Qnil;
1398 struct gcpro gcpro1;
1401 LIST_LOOP (rest, inst_list)
1403 Lisp_Object tagged_inst = XCAR (rest);
1404 Lisp_Object tagged_inst_tag = XCAR (tagged_inst);
1405 if (tag_sets_match_p (tag_set, tagged_inst_tag, exact_p))
1407 if (short_p && NILP (tagged_inst_tag))
1408 retval = Fcons (copy_tree_p ?
1409 Fcopy_tree (XCDR (tagged_inst), Qt) :
1413 retval = Fcons (copy_tree_p ? Fcopy_tree (tagged_inst, Qt) :
1414 tagged_inst, retval);
1417 retval = Fnreverse (retval);
1419 /* If there is a single instantiator and the short form is
1420 requested, return just the instantiator (rather than a one-element
1421 list of it) unless it is nil (so that it can be distinguished from
1422 no instantiators at all). */
1423 if (short_p && CONSP (retval) && !NILP (XCAR (retval)) &&
1424 NILP (XCDR (retval)))
1425 return XCAR (retval);
1431 specifier_get_external_inst_list (Lisp_Object specifier, Lisp_Object locale,
1432 enum spec_locale_type type,
1433 Lisp_Object tag_set, int exact_p,
1434 int short_p, int copy_tree_p)
1436 Lisp_Object *inst_list = specifier_get_inst_list (specifier, locale,
1438 if (!inst_list || NILP (*inst_list))
1440 /* nil for *inst_list should only occur in 'global */
1441 assert (!inst_list || EQ (locale, Qglobal));
1445 return specifier_process_inst_list (*inst_list, tag_set, exact_p,
1446 short_p, copy_tree_p);
1450 specifier_get_external_spec_list (Lisp_Object specifier,
1451 enum spec_locale_type type,
1452 Lisp_Object tag_set, int exact_p)
1454 Lisp_Object *spec_list = SPECIFIER_GET_SPEC_LIST (specifier, type);
1455 Lisp_Object retval = Qnil;
1457 struct gcpro gcpro1;
1459 assert (type != LOCALE_GLOBAL);
1460 /* We're about to let stuff go external; make sure there aren't
1462 *spec_list = cleanup_assoc_list (*spec_list);
1465 LIST_LOOP (rest, *spec_list)
1467 Lisp_Object spec = XCAR (rest);
1468 Lisp_Object inst_list =
1469 specifier_process_inst_list (XCDR (spec), tag_set, exact_p, 0, 1);
1470 if (!NILP (inst_list))
1471 retval = Fcons (Fcons (XCAR (spec), inst_list), retval);
1473 RETURN_UNGCPRO (Fnreverse (retval));
1476 static Lisp_Object *
1477 specifier_new_spec (Lisp_Object specifier, Lisp_Object locale,
1478 enum spec_locale_type type)
1480 Lisp_Object *spec_list = SPECIFIER_GET_SPEC_LIST (specifier, type);
1481 Lisp_Object new_spec = Fcons (locale, Qnil);
1482 assert (type != LOCALE_GLOBAL);
1483 *spec_list = Fcons (new_spec, *spec_list);
1484 return &XCDR (new_spec);
1487 /* For the given INST_LIST, return a new list comprised of elements
1488 where TAG_SET does not match the element's tag set. This operation
1492 specifier_process_remove_inst_list (Lisp_Object inst_list,
1493 Lisp_Object tag_set, int exact_p,
1496 Lisp_Object prev = Qnil, rest;
1500 LIST_LOOP (rest, inst_list)
1502 if (tag_sets_match_p (tag_set, XCAR (XCAR (rest)), exact_p))
1504 /* time to remove. */
1507 inst_list = XCDR (rest);
1509 XCDR (prev) = XCDR (rest);
1519 specifier_remove_spec (Lisp_Object specifier, Lisp_Object locale,
1520 enum spec_locale_type type,
1521 Lisp_Object tag_set, int exact_p)
1523 Lisp_Object *spec_list = SPECIFIER_GET_SPEC_LIST (specifier, type);
1527 if (type == LOCALE_GLOBAL)
1528 *spec_list = specifier_process_remove_inst_list (*spec_list, tag_set,
1529 exact_p, &was_removed);
1532 assoc = assq_no_quit (locale, *spec_list);
1534 /* this locale is not found. */
1536 XCDR (assoc) = specifier_process_remove_inst_list (XCDR (assoc),
1539 if (NILP (XCDR (assoc)))
1540 /* no inst-pairs left; remove this locale entirely. */
1541 *spec_list = remassq_no_quit (locale, *spec_list);
1545 MAYBE_SPECMETH (XSPECIFIER (specifier), after_change,
1546 (bodily_specifier (specifier), locale));
1550 specifier_remove_locale_type (Lisp_Object specifier,
1551 enum spec_locale_type type,
1552 Lisp_Object tag_set, int exact_p)
1554 Lisp_Object *spec_list = SPECIFIER_GET_SPEC_LIST (specifier, type);
1555 Lisp_Object prev = Qnil, rest;
1557 assert (type != LOCALE_GLOBAL);
1558 LIST_LOOP (rest, *spec_list)
1561 int remove_spec = 0;
1562 Lisp_Object spec = XCAR (rest);
1564 /* There may be dead objects floating around */
1565 /* remember, dead windows can become alive again. */
1566 if (!WINDOWP (XCAR (spec)) && object_dead_p (XCAR (spec)))
1573 XCDR (spec) = specifier_process_remove_inst_list (XCDR (spec),
1576 if (NILP (XCDR (spec)))
1583 *spec_list = XCDR (rest);
1585 XCDR (prev) = XCDR (rest);
1591 MAYBE_SPECMETH (XSPECIFIER (specifier), after_change,
1592 (bodily_specifier (specifier), XCAR (spec)));
1596 /* NEW_LIST is going to be added to INST_LIST, with add method ADD_METH.
1597 Frob INST_LIST according to ADD_METH. No need to call an after-change
1598 function; the calling function will do this. Return either SPEC_PREPEND
1599 or SPEC_APPEND, indicating whether to prepend or append the NEW_LIST. */
1601 static enum spec_add_meth
1602 handle_multiple_add_insts (Lisp_Object *inst_list,
1603 Lisp_Object new_list,
1604 enum spec_add_meth add_meth)
1608 case SPEC_REMOVE_TAG_SET_APPEND:
1609 add_meth = SPEC_APPEND;
1610 goto remove_tag_set;
1611 case SPEC_REMOVE_TAG_SET_PREPEND:
1612 add_meth = SPEC_PREPEND;
1617 LIST_LOOP (rest, new_list)
1619 Lisp_Object canontag = canonicalize_tag_set (XCAR (XCAR (rest)));
1620 struct gcpro gcpro1;
1623 /* pull out all elements from the existing list with the
1624 same tag as any tags in NEW_LIST. */
1625 *inst_list = remassoc_no_quit (canontag, *inst_list);
1630 case SPEC_REMOVE_LOCALE:
1632 return SPEC_PREPEND;
1636 return SPEC_PREPEND;
1640 /* Given a LOCALE and INST_LIST that is going to be added to SPECIFIER,
1641 copy, canonicalize, and call the going_to_add methods as necessary
1642 to produce a new list that is the one that really will be added
1643 to the specifier. */
1646 build_up_processed_list (Lisp_Object specifier, Lisp_Object locale,
1647 Lisp_Object inst_list)
1649 /* The return value of this function must be GCPRO'd. */
1650 Lisp_Object rest, list_to_build_up = Qnil;
1651 Lisp_Specifier *sp = XSPECIFIER (specifier);
1652 struct gcpro gcpro1;
1654 GCPRO1 (list_to_build_up);
1655 LIST_LOOP (rest, inst_list)
1657 Lisp_Object tag_set = XCAR (XCAR (rest));
1658 Lisp_Object sub_inst_list = Qnil;
1659 Lisp_Object instantiator;
1660 struct gcpro ngcpro1, ngcpro2;
1662 if (HAS_SPECMETH_P (sp, copy_instantiator))
1663 instantiator = SPECMETH (sp, copy_instantiator,
1664 (XCDR (XCAR (rest))));
1666 instantiator = Fcopy_tree (XCDR (XCAR (rest)), Qt);
1668 NGCPRO2 (instantiator, sub_inst_list);
1669 /* call the will-add method; it may GC */
1670 sub_inst_list = HAS_SPECMETH_P (sp, going_to_add) ?
1671 SPECMETH (sp, going_to_add,
1672 (bodily_specifier (specifier), locale,
1673 tag_set, instantiator)) :
1675 if (EQ (sub_inst_list, Qt))
1676 /* no change here. */
1677 sub_inst_list = list1 (Fcons (canonicalize_tag_set (tag_set),
1681 /* now canonicalize all the tag sets in the new objects */
1683 LIST_LOOP (rest2, sub_inst_list)
1684 XCAR (XCAR (rest2)) = canonicalize_tag_set (XCAR (XCAR (rest2)));
1687 list_to_build_up = nconc2 (sub_inst_list, list_to_build_up);
1691 RETURN_UNGCPRO (Fnreverse (list_to_build_up));
1694 /* Add a specification (locale and instantiator list) to a specifier.
1695 ADD_METH specifies what to do with existing specifications in the
1696 specifier, and is an enum that corresponds to the values in
1697 `add-spec-to-specifier'. The calling routine is responsible for
1698 validating LOCALE and INST-LIST, but the tag-sets in INST-LIST
1699 do not need to be canonicalized. */
1701 /* #### I really need to rethink the after-change
1702 functions to make them easier to use and more efficient. */
1705 specifier_add_spec (Lisp_Object specifier, Lisp_Object locale,
1706 Lisp_Object inst_list, enum spec_add_meth add_meth)
1708 Lisp_Specifier *sp = XSPECIFIER (specifier);
1709 enum spec_locale_type type = locale_type_from_locale (locale);
1710 Lisp_Object *orig_inst_list, tem;
1711 Lisp_Object list_to_build_up = Qnil;
1712 struct gcpro gcpro1;
1714 GCPRO1 (list_to_build_up);
1715 list_to_build_up = build_up_processed_list (specifier, locale, inst_list);
1716 /* Now handle REMOVE_LOCALE_TYPE and REMOVE_ALL. These are the
1717 add-meth types that affect locales other than this one. */
1718 if (add_meth == SPEC_REMOVE_LOCALE_TYPE)
1719 specifier_remove_locale_type (specifier, type, Qnil, 0);
1720 else if (add_meth == SPEC_REMOVE_ALL)
1722 specifier_remove_locale_type (specifier, LOCALE_BUFFER, Qnil, 0);
1723 specifier_remove_locale_type (specifier, LOCALE_WINDOW, Qnil, 0);
1724 specifier_remove_locale_type (specifier, LOCALE_FRAME, Qnil, 0);
1725 specifier_remove_locale_type (specifier, LOCALE_DEVICE, Qnil, 0);
1726 specifier_remove_spec (specifier, Qglobal, LOCALE_GLOBAL, Qnil, 0);
1729 orig_inst_list = specifier_get_inst_list (specifier, locale, type);
1730 if (!orig_inst_list)
1731 orig_inst_list = specifier_new_spec (specifier, locale, type);
1732 add_meth = handle_multiple_add_insts (orig_inst_list, list_to_build_up,
1735 if (add_meth == SPEC_PREPEND)
1736 tem = nconc2 (list_to_build_up, *orig_inst_list);
1737 else if (add_meth == SPEC_APPEND)
1738 tem = nconc2 (*orig_inst_list, list_to_build_up);
1742 *orig_inst_list = tem;
1746 /* call the after-change method */
1747 MAYBE_SPECMETH (sp, after_change,
1748 (bodily_specifier (specifier), locale));
1752 specifier_copy_spec (Lisp_Object specifier, Lisp_Object dest,
1753 Lisp_Object locale, enum spec_locale_type type,
1754 Lisp_Object tag_set, int exact_p,
1755 enum spec_add_meth add_meth)
1757 Lisp_Object inst_list =
1758 specifier_get_external_inst_list (specifier, locale, type, tag_set,
1760 specifier_add_spec (dest, locale, inst_list, add_meth);
1764 specifier_copy_locale_type (Lisp_Object specifier, Lisp_Object dest,
1765 enum spec_locale_type type,
1766 Lisp_Object tag_set, int exact_p,
1767 enum spec_add_meth add_meth)
1769 Lisp_Object *src_list = SPECIFIER_GET_SPEC_LIST (specifier, type);
1772 /* This algorithm is O(n^2) in running time.
1773 It's certainly possible to implement an O(n log n) algorithm,
1774 but I doubt there's any need to. */
1776 LIST_LOOP (rest, *src_list)
1778 Lisp_Object spec = XCAR (rest);
1779 /* There may be dead objects floating around */
1780 /* remember, dead windows can become alive again. */
1781 if (WINDOWP (XCAR (spec)) || !object_dead_p (XCAR (spec)))
1784 specifier_process_inst_list (XCDR (spec), tag_set, exact_p, 0, 0),
1789 /* map MAPFUN over the locales in SPECIFIER that are given in LOCALE.
1790 CLOSURE is passed unchanged to MAPFUN. LOCALE can be one of
1792 -- nil (same as 'all)
1793 -- a single locale, locale type, or 'all
1794 -- a list of locales, locale types, and/or 'all
1796 MAPFUN is called for each locale and locale type given; for 'all,
1797 it is called for the locale 'global and for the four possible
1798 locale types. In each invocation, either LOCALE will be a locale
1799 and LOCALE_TYPE will be the locale type of this locale,
1800 or LOCALE will be nil and LOCALE_TYPE will be a locale type.
1801 If MAPFUN ever returns non-zero, the mapping is halted and the
1802 value returned is returned from map_specifier(). Otherwise, the
1803 mapping proceeds to the end and map_specifier() returns 0.
1807 map_specifier (Lisp_Object specifier, Lisp_Object locale,
1808 int (*mapfun) (Lisp_Object specifier,
1810 enum spec_locale_type locale_type,
1811 Lisp_Object tag_set,
1814 Lisp_Object tag_set, Lisp_Object exact_p,
1819 struct gcpro gcpro1, gcpro2;
1821 GCPRO2 (tag_set, locale);
1822 locale = decode_locale_list (locale);
1823 tag_set = decode_specifier_tag_set (tag_set);
1824 tag_set = canonicalize_tag_set (tag_set);
1826 LIST_LOOP (rest, locale)
1828 Lisp_Object theloc = XCAR (rest);
1829 if (!NILP (Fvalid_specifier_locale_p (theloc)))
1831 retval = (*mapfun) (specifier, theloc,
1832 locale_type_from_locale (theloc),
1833 tag_set, !NILP (exact_p), closure);
1837 else if (!NILP (Fvalid_specifier_locale_type_p (theloc)))
1839 retval = (*mapfun) (specifier, Qnil,
1840 decode_locale_type (theloc), tag_set,
1841 !NILP (exact_p), closure);
1847 assert (EQ (theloc, Qall));
1848 retval = (*mapfun) (specifier, Qnil, LOCALE_BUFFER, tag_set,
1849 !NILP (exact_p), closure);
1852 retval = (*mapfun) (specifier, Qnil, LOCALE_WINDOW, tag_set,
1853 !NILP (exact_p), closure);
1856 retval = (*mapfun) (specifier, Qnil, LOCALE_FRAME, tag_set,
1857 !NILP (exact_p), closure);
1860 retval = (*mapfun) (specifier, Qnil, LOCALE_DEVICE, tag_set,
1861 !NILP (exact_p), closure);
1864 retval = (*mapfun) (specifier, Qglobal, LOCALE_GLOBAL, tag_set,
1865 !NILP (exact_p), closure);
1875 DEFUN ("add-spec-to-specifier", Fadd_spec_to_specifier, 2, 5, 0, /*
1876 Add a specification to SPECIFIER.
1877 The specification maps from LOCALE (which should be a window, buffer,
1878 frame, device, or 'global, and defaults to 'global) to INSTANTIATOR,
1879 whose allowed values depend on the type of the specifier. Optional
1880 argument TAG-SET limits the instantiator to apply only to the specified
1881 tag set, which should be a list of tags all of which must match the
1882 device being instantiated over (tags are a device type, a device class,
1883 or tags defined with `define-specifier-tag'). Specifying a single
1884 symbol for TAG-SET is equivalent to specifying a one-element list
1885 containing that symbol. Optional argument HOW-TO-ADD specifies what to
1886 do if there are already specifications in the specifier.
1889 'prepend Put at the beginning of the current list of
1890 instantiators for LOCALE.
1891 'append Add to the end of the current list of
1892 instantiators for LOCALE.
1893 'remove-tag-set-prepend (this is the default)
1894 Remove any existing instantiators whose tag set is
1895 the same as TAG-SET; then put the new instantiator
1896 at the beginning of the current list. ("Same tag
1897 set" means that they contain the same elements.
1898 The order may be different.)
1899 'remove-tag-set-append
1900 Remove any existing instantiators whose tag set is
1901 the same as TAG-SET; then put the new instantiator
1902 at the end of the current list.
1903 'remove-locale Remove all previous instantiators for this locale
1904 before adding the new spec.
1905 'remove-locale-type Remove all specifications for all locales of the
1906 same type as LOCALE (this includes LOCALE itself)
1907 before adding the new spec.
1908 'remove-all Remove all specifications from the specifier
1909 before adding the new spec.
1911 You can retrieve the specifications for a particular locale or locale type
1912 with the function `specifier-spec-list' or `specifier-specs'.
1914 (specifier, instantiator, locale, tag_set, how_to_add))
1916 enum spec_add_meth add_meth;
1917 Lisp_Object inst_list;
1918 struct gcpro gcpro1;
1920 CHECK_SPECIFIER (specifier);
1921 check_modifiable_specifier (specifier);
1923 locale = decode_locale (locale);
1924 check_valid_instantiator (instantiator,
1925 decode_specifier_type
1926 (Fspecifier_type (specifier), ERROR_ME),
1928 /* tag_set might be newly-created material, but it's part of inst_list
1929 so is properly GC-protected. */
1930 tag_set = decode_specifier_tag_set (tag_set);
1931 add_meth = decode_how_to_add_specification (how_to_add);
1933 inst_list = list1 (Fcons (tag_set, instantiator));
1935 specifier_add_spec (specifier, locale, inst_list, add_meth);
1936 recompute_cached_specifier_everywhere (specifier);
1937 RETURN_UNGCPRO (Qnil);
1940 DEFUN ("add-spec-list-to-specifier", Fadd_spec_list_to_specifier, 2, 3, 0, /*
1941 Add a spec-list (a list of specifications) to SPECIFIER.
1942 The format of a spec-list is
1944 ((LOCALE (TAG-SET . INSTANTIATOR) ...) ...)
1947 LOCALE := a window, a buffer, a frame, a device, or 'global
1948 TAG-SET := an unordered list of zero or more TAGS, each of which
1950 TAG := a device class (see `valid-device-class-p'), a device type
1951 (see `valid-console-type-p'), or a tag defined with
1952 `define-specifier-tag'
1953 INSTANTIATOR := format determined by the type of specifier
1955 The pair (TAG-SET . INSTANTIATOR) is called an `inst-pair'.
1956 A list of inst-pairs is called an `inst-list'.
1957 The pair (LOCALE . INST-LIST) is called a `specification' or `spec'.
1958 A spec-list, then, can be viewed as a list of specifications.
1960 HOW-TO-ADD specifies how to combine the new specifications with
1961 the existing ones, and has the same semantics as for
1962 `add-spec-to-specifier'.
1964 In many circumstances, the higher-level function `set-specifier' is
1965 more convenient and should be used instead.
1967 (specifier, spec_list, how_to_add))
1969 enum spec_add_meth add_meth;
1972 CHECK_SPECIFIER (specifier);
1973 check_modifiable_specifier (specifier);
1975 check_valid_spec_list (spec_list,
1976 decode_specifier_type
1977 (Fspecifier_type (specifier), ERROR_ME),
1979 add_meth = decode_how_to_add_specification (how_to_add);
1981 LIST_LOOP (rest, spec_list)
1983 /* Placating the GCC god. */
1984 Lisp_Object specification = XCAR (rest);
1985 Lisp_Object locale = XCAR (specification);
1986 Lisp_Object inst_list = XCDR (specification);
1988 specifier_add_spec (specifier, locale, inst_list, add_meth);
1990 recompute_cached_specifier_everywhere (specifier);
1995 add_spec_to_ghost_specifier (Lisp_Object specifier, Lisp_Object instantiator,
1996 Lisp_Object locale, Lisp_Object tag_set,
1997 Lisp_Object how_to_add)
1999 int depth = unlock_ghost_specifiers_protected ();
2000 Fadd_spec_to_specifier (XSPECIFIER(specifier)->fallback,
2001 instantiator, locale, tag_set, how_to_add);
2002 unbind_to (depth, Qnil);
2005 struct specifier_spec_list_closure
2007 Lisp_Object head, tail;
2011 specifier_spec_list_mapfun (Lisp_Object specifier,
2013 enum spec_locale_type locale_type,
2014 Lisp_Object tag_set,
2018 struct specifier_spec_list_closure *cl =
2019 (struct specifier_spec_list_closure *) closure;
2020 Lisp_Object partial;
2023 partial = specifier_get_external_spec_list (specifier,
2028 partial = specifier_get_external_inst_list (specifier, locale,
2029 locale_type, tag_set,
2031 if (!NILP (partial))
2032 partial = list1 (Fcons (locale, partial));
2037 /* tack on the new list */
2038 if (NILP (cl->tail))
2039 cl->head = cl->tail = partial;
2041 XCDR (cl->tail) = partial;
2042 /* find the new tail */
2043 while (CONSP (XCDR (cl->tail)))
2044 cl->tail = XCDR (cl->tail);
2048 /* For the given SPECIFIER create and return a list of all specs
2049 contained within it, subject to LOCALE. If LOCALE is a locale, only
2050 specs in that locale will be returned. If LOCALE is a locale type,
2051 all specs in all locales of that type will be returned. If LOCALE is
2052 nil, all specs will be returned. This always copies lists and never
2053 returns the actual lists, because we do not want someone manipulating
2054 the actual objects. This may cause a slight loss of potential
2055 functionality but if we were to allow it then a user could manage to
2056 violate our assertion that the specs contained in the actual
2057 specifier lists are all valid. */
2059 DEFUN ("specifier-spec-list", Fspecifier_spec_list, 1, 4, 0, /*
2060 Return the spec-list of specifications for SPECIFIER in LOCALE.
2062 If LOCALE is a particular locale (a buffer, window, frame, device,
2063 or 'global), a spec-list consisting of the specification for that
2064 locale will be returned.
2066 If LOCALE is a locale type (i.e. 'buffer, 'window, 'frame, or 'device),
2067 a spec-list of the specifications for all locales of that type will be
2070 If LOCALE is nil or 'all, a spec-list of all specifications in SPECIFIER
2073 LOCALE can also be a list of locales, locale types, and/or 'all; the
2074 result is as if `specifier-spec-list' were called on each element of the
2075 list and the results concatenated together.
2077 Only instantiators where TAG-SET (a list of zero or more tags) is a
2078 subset of (or possibly equal to) the instantiator's tag set are returned.
2079 \(The default value of nil is a subset of all tag sets, so in this case
2080 no instantiators will be screened out.) If EXACT-P is non-nil, however,
2081 TAG-SET must be equal to an instantiator's tag set for the instantiator
2084 (specifier, locale, tag_set, exact_p))
2086 struct specifier_spec_list_closure cl;
2087 struct gcpro gcpro1, gcpro2;
2089 CHECK_SPECIFIER (specifier);
2090 cl.head = cl.tail = Qnil;
2091 GCPRO2 (cl.head, cl.tail);
2092 map_specifier (specifier, locale, specifier_spec_list_mapfun,
2093 tag_set, exact_p, &cl);
2099 DEFUN ("specifier-specs", Fspecifier_specs, 1, 4, 0, /*
2100 Return the specification(s) for SPECIFIER in LOCALE.
2102 If LOCALE is a single locale or is a list of one element containing a
2103 single locale, then a "short form" of the instantiators for that locale
2104 will be returned. Otherwise, this function is identical to
2105 `specifier-spec-list'.
2107 The "short form" is designed for readability and not for ease of use
2108 in Lisp programs, and is as follows:
2110 1. If there is only one instantiator, then an inst-pair (i.e. cons of
2111 tag and instantiator) will be returned; otherwise a list of
2112 inst-pairs will be returned.
2113 2. For each inst-pair returned, if the instantiator's tag is 'any,
2114 the tag will be removed and the instantiator itself will be returned
2115 instead of the inst-pair.
2116 3. If there is only one instantiator, its value is nil, and its tag is
2117 'any, a one-element list containing nil will be returned rather
2118 than just nil, to distinguish this case from there being no
2119 instantiators at all.
2121 (specifier, locale, tag_set, exact_p))
2123 if (!NILP (Fvalid_specifier_locale_p (locale)) ||
2124 (CONSP (locale) && !NILP (Fvalid_specifier_locale_p (XCAR (locale))) &&
2125 NILP (XCDR (locale))))
2127 struct gcpro gcpro1;
2129 CHECK_SPECIFIER (specifier);
2131 locale = XCAR (locale);
2133 tag_set = decode_specifier_tag_set (tag_set);
2134 tag_set = canonicalize_tag_set (tag_set);
2136 (specifier_get_external_inst_list (specifier, locale,
2137 locale_type_from_locale (locale),
2138 tag_set, !NILP (exact_p), 1, 1));
2141 return Fspecifier_spec_list (specifier, locale, tag_set, exact_p);
2145 remove_specifier_mapfun (Lisp_Object specifier,
2147 enum spec_locale_type locale_type,
2148 Lisp_Object tag_set,
2150 void *ignored_closure)
2153 specifier_remove_locale_type (specifier, locale_type, tag_set, exact_p);
2155 specifier_remove_spec (specifier, locale, locale_type, tag_set, exact_p);
2159 DEFUN ("remove-specifier", Fremove_specifier, 1, 4, 0, /*
2160 Remove specification(s) for SPECIFIER.
2162 If LOCALE is a particular locale (a window, buffer, frame, device,
2163 or 'global), the specification for that locale will be removed.
2165 If instead, LOCALE is a locale type (i.e. 'window, 'buffer, 'frame,
2166 or 'device), the specifications for all locales of that type will be
2169 If LOCALE is nil or 'all, all specifications will be removed.
2171 LOCALE can also be a list of locales, locale types, and/or 'all; this
2172 is equivalent to calling `remove-specifier' for each of the elements
2175 Only instantiators where TAG-SET (a list of zero or more tags) is a
2176 subset of (or possibly equal to) the instantiator's tag set are removed.
2177 The default value of nil is a subset of all tag sets, so in this case
2178 no instantiators will be screened out. If EXACT-P is non-nil, however,
2179 TAG-SET must be equal to an instantiator's tag set for the instantiator
2182 (specifier, locale, tag_set, exact_p))
2184 CHECK_SPECIFIER (specifier);
2185 check_modifiable_specifier (specifier);
2187 map_specifier (specifier, locale, remove_specifier_mapfun,
2188 tag_set, exact_p, 0);
2189 recompute_cached_specifier_everywhere (specifier);
2194 remove_ghost_specifier (Lisp_Object specifier, Lisp_Object locale,
2195 Lisp_Object tag_set, Lisp_Object exact_p)
2197 int depth = unlock_ghost_specifiers_protected ();
2198 Fremove_specifier (XSPECIFIER(specifier)->fallback,
2199 locale, tag_set, exact_p);
2200 unbind_to (depth, Qnil);
2203 struct copy_specifier_closure
2206 enum spec_add_meth add_meth;
2207 int add_meth_is_nil;
2211 copy_specifier_mapfun (Lisp_Object specifier,
2213 enum spec_locale_type locale_type,
2214 Lisp_Object tag_set,
2218 struct copy_specifier_closure *cl =
2219 (struct copy_specifier_closure *) closure;
2222 specifier_copy_locale_type (specifier, cl->dest, locale_type,
2224 cl->add_meth_is_nil ?
2225 SPEC_REMOVE_LOCALE_TYPE :
2228 specifier_copy_spec (specifier, cl->dest, locale, locale_type,
2230 cl->add_meth_is_nil ? SPEC_REMOVE_LOCALE :
2235 DEFUN ("copy-specifier", Fcopy_specifier, 1, 6, 0, /*
2236 Copy SPECIFIER to DEST, or create a new one if DEST is nil.
2238 If DEST is nil or omitted, a new specifier will be created and the
2239 specifications copied into it. Otherwise, the specifications will be
2240 copied into the existing specifier in DEST.
2242 If LOCALE is nil or 'all, all specifications will be copied. If LOCALE
2243 is a particular locale, the specification for that particular locale will
2244 be copied. If LOCALE is a locale type, the specifications for all locales
2245 of that type will be copied. LOCALE can also be a list of locales,
2246 locale types, and/or 'all; this is equivalent to calling `copy-specifier'
2247 for each of the elements of the list. See `specifier-spec-list' for more
2248 information about LOCALE.
2250 Only instantiators where TAG-SET (a list of zero or more tags) is a
2251 subset of (or possibly equal to) the instantiator's tag set are copied.
2252 The default value of nil is a subset of all tag sets, so in this case
2253 no instantiators will be screened out. If EXACT-P is non-nil, however,
2254 TAG-SET must be equal to an instantiator's tag set for the instantiator
2257 Optional argument HOW-TO-ADD specifies what to do with existing
2258 specifications in DEST. If nil, then whichever locales or locale types
2259 are copied will first be completely erased in DEST. Otherwise, it is
2260 the same as in `add-spec-to-specifier'.
2262 (specifier, dest, locale, tag_set, exact_p, how_to_add))
2264 struct gcpro gcpro1;
2265 struct copy_specifier_closure cl;
2267 CHECK_SPECIFIER (specifier);
2268 if (NILP (how_to_add))
2269 cl.add_meth_is_nil = 1;
2271 cl.add_meth_is_nil = 0;
2272 cl.add_meth = decode_how_to_add_specification (how_to_add);
2275 /* #### What about copying the extra data? */
2276 dest = make_specifier (XSPECIFIER (specifier)->methods);
2280 CHECK_SPECIFIER (dest);
2281 check_modifiable_specifier (dest);
2282 if (XSPECIFIER (dest)->methods != XSPECIFIER (specifier)->methods)
2283 error ("Specifiers not of same type");
2288 map_specifier (specifier, locale, copy_specifier_mapfun,
2289 tag_set, exact_p, &cl);
2291 recompute_cached_specifier_everywhere (dest);
2296 /************************************************************************/
2298 /************************************************************************/
2301 call_validate_matchspec_method (Lisp_Object boxed_method,
2302 Lisp_Object matchspec)
2304 ((void (*)(Lisp_Object)) get_opaque_ptr (boxed_method)) (matchspec);
2309 check_valid_specifier_matchspec (Lisp_Object matchspec,
2310 struct specifier_methods *meths,
2311 Error_behavior errb)
2313 if (meths->validate_matchspec_method)
2317 if (ERRB_EQ (errb, ERROR_ME))
2319 (meths->validate_matchspec_method) (matchspec);
2324 Lisp_Object opaque =
2325 make_opaque_ptr ((void *) meths->validate_matchspec_method);
2326 struct gcpro gcpro1;
2329 retval = call_with_suspended_errors
2330 ((lisp_fn_t) call_validate_matchspec_method,
2331 Qnil, Qspecifier, errb, 2, opaque, matchspec);
2333 free_opaque_ptr (opaque);
2341 maybe_signal_simple_error
2342 ("Matchspecs not allowed for this specifier type",
2343 intern (meths->name), Qspecifier, errb);
2348 DEFUN ("check-valid-specifier-matchspec", Fcheck_valid_specifier_matchspec, 2, 2, 0, /*
2349 Signal an error if MATCHSPEC is invalid for SPECIFIER-TYPE.
2350 See `specifier-matching-instance' for a description of matchspecs.
2352 (matchspec, specifier_type))
2354 struct specifier_methods *meths = decode_specifier_type (specifier_type,
2357 return check_valid_specifier_matchspec (matchspec, meths, ERROR_ME);
2360 DEFUN ("valid-specifier-matchspec-p", Fvalid_specifier_matchspec_p, 2, 2, 0, /*
2361 Return non-nil if MATCHSPEC is valid for SPECIFIER-TYPE.
2362 See `specifier-matching-instance' for a description of matchspecs.
2364 (matchspec, specifier_type))
2366 struct specifier_methods *meths = decode_specifier_type (specifier_type,
2369 return check_valid_specifier_matchspec (matchspec, meths, ERROR_ME_NOT);
2372 /* This function is purposely not callable from Lisp. If a Lisp
2373 caller wants to set a fallback, they should just set the
2377 set_specifier_fallback (Lisp_Object specifier, Lisp_Object fallback)
2379 Lisp_Specifier *sp = XSPECIFIER (specifier);
2380 assert (SPECIFIERP (fallback) ||
2381 !NILP (Fvalid_inst_list_p (fallback, Fspecifier_type (specifier))));
2382 if (SPECIFIERP (fallback))
2383 assert (EQ (Fspecifier_type (specifier), Fspecifier_type (fallback)));
2384 if (BODILY_SPECIFIER_P (sp))
2385 GHOST_SPECIFIER(sp)->fallback = fallback;
2387 sp->fallback = fallback;
2388 /* call the after-change method */
2389 MAYBE_SPECMETH (sp, after_change,
2390 (bodily_specifier (specifier), Qfallback));
2391 recompute_cached_specifier_everywhere (specifier);
2394 DEFUN ("specifier-fallback", Fspecifier_fallback, 1, 1, 0, /*
2395 Return the fallback value for SPECIFIER.
2396 Fallback values are provided by the C code for certain built-in
2397 specifiers to make sure that instancing won't fail even if all
2398 specs are removed from the specifier, or to implement simple
2399 inheritance behavior (e.g. this method is used to ensure that
2400 faces other than 'default inherit their attributes from 'default).
2401 By design, you cannot change the fallback value, and specifiers
2402 created with `make-specifier' will never have a fallback (although
2403 a similar, Lisp-accessible capability may be provided in the future
2404 to allow for inheritance).
2406 The fallback value will be an inst-list that is instanced like
2407 any other inst-list, a specifier of the same type as SPECIFIER
2408 \(results in inheritance), or nil for no fallback.
2410 When you instance a specifier, you can explicitly request that the
2411 fallback not be consulted. (The C code does this, for example, when
2412 merging faces.) See `specifier-instance'.
2416 CHECK_SPECIFIER (specifier);
2417 return Fcopy_tree (XSPECIFIER (specifier)->fallback, Qt);
2421 specifier_instance_from_inst_list (Lisp_Object specifier,
2422 Lisp_Object matchspec,
2424 Lisp_Object inst_list,
2425 Error_behavior errb, int no_quit,
2428 /* This function can GC */
2432 int count = specpdl_depth ();
2433 struct gcpro gcpro1, gcpro2;
2435 GCPRO2 (specifier, inst_list);
2437 sp = XSPECIFIER (specifier);
2438 device = DFW_DEVICE (domain);
2441 /* The instantiate method is allowed to call eval. Since it
2442 is quite common for this function to get called from somewhere in
2443 redisplay we need to make sure that quits are ignored. Otherwise
2444 Fsignal will abort. */
2445 specbind (Qinhibit_quit, Qt);
2447 LIST_LOOP (rest, inst_list)
2449 Lisp_Object tagged_inst = XCAR (rest);
2450 Lisp_Object tag_set = XCAR (tagged_inst);
2452 if (device_matches_specifier_tag_set_p (device, tag_set))
2454 Lisp_Object val = XCDR (tagged_inst);
2456 if (HAS_SPECMETH_P (sp, instantiate))
2457 val = call_with_suspended_errors
2458 ((lisp_fn_t) RAW_SPECMETH (sp, instantiate),
2459 Qunbound, Qspecifier, errb, 5, specifier,
2460 matchspec, domain, val, depth);
2462 if (!UNBOUNDP (val))
2464 unbind_to (count, Qnil);
2471 unbind_to (count, Qnil);
2476 /* Given a SPECIFIER and a DOMAIN, return a specific instance for that
2477 specifier. Try to find one by checking the specifier types from most
2478 specific (buffer) to most general (global). If we find an instance,
2479 return it. Otherwise return Qunbound. */
2481 #define CHECK_INSTANCE_ENTRY(key, matchspec, type) do { \
2482 Lisp_Object *CIE_inst_list = \
2483 specifier_get_inst_list (specifier, key, type); \
2484 if (CIE_inst_list) \
2486 Lisp_Object CIE_val = \
2487 specifier_instance_from_inst_list (specifier, matchspec, \
2488 domain, *CIE_inst_list, \
2489 errb, no_quit, depth); \
2490 if (!UNBOUNDP (CIE_val)) \
2495 /* We accept any window, frame or device domain and do our checking
2496 starting from as specific a locale type as we can determine from the
2497 domain we are passed and going on up through as many other locale types
2498 as we can determine. In practice, when called from redisplay the
2499 arg will usually be a window and occasionally a frame. If
2500 triggered by a user call, who knows what it will usually be. */
2502 specifier_instance (Lisp_Object specifier, Lisp_Object matchspec,
2503 Lisp_Object domain, Error_behavior errb, int no_quit,
2504 int no_fallback, Lisp_Object depth)
2506 Lisp_Object buffer = Qnil;
2507 Lisp_Object window = Qnil;
2508 Lisp_Object frame = Qnil;
2509 Lisp_Object device = Qnil;
2510 Lisp_Object tag = Qnil;
2514 sp = XSPECIFIER (specifier);
2516 /* Attempt to determine buffer, window, frame, and device from the
2518 if (WINDOWP (domain))
2520 else if (FRAMEP (domain))
2522 else if (DEVICEP (domain))
2525 /* #### dmoore - dammit, this should just signal an error or something
2527 #### No. Errors are handled in Lisp primitives implementation.
2528 Invalid domain is a design error here - kkm. */
2531 if (NILP (buffer) && !NILP (window))
2532 buffer = XWINDOW (window)->buffer;
2533 if (NILP (frame) && !NILP (window))
2534 frame = XWINDOW (window)->frame;
2536 /* frame had better exist; if device is undeterminable, something
2537 really went wrong. */
2538 device = XFRAME (frame)->device;
2540 /* device had better be determined by now; abort if not. */
2541 d = XDEVICE (device);
2542 tag = DEVICE_CLASS (d);
2544 depth = make_int (1 + XINT (depth));
2545 if (XINT (depth) > 20)
2547 maybe_error (Qspecifier, errb, "Apparent loop in specifier inheritance");
2548 /* The specification is fucked; at least try the fallback
2549 (which better not be fucked, because it's not changeable
2556 /* First see if we can generate one from the window specifiers. */
2558 CHECK_INSTANCE_ENTRY (window, matchspec, LOCALE_WINDOW);
2560 /* Next see if we can generate one from the buffer specifiers. */
2562 CHECK_INSTANCE_ENTRY (buffer, matchspec, LOCALE_BUFFER);
2564 /* Next see if we can generate one from the frame specifiers. */
2566 CHECK_INSTANCE_ENTRY (frame, matchspec, LOCALE_FRAME);
2568 /* If we still haven't succeeded try with the device specifiers. */
2569 CHECK_INSTANCE_ENTRY (device, matchspec, LOCALE_DEVICE);
2571 /* Last and least try the global specifiers. */
2572 CHECK_INSTANCE_ENTRY (Qglobal, matchspec, LOCALE_GLOBAL);
2575 /* We're out of specifiers and we still haven't generated an
2576 instance. At least try the fallback ... If this fails,
2577 then we just return Qunbound. */
2579 if (no_fallback || NILP (sp->fallback))
2580 /* I said, I don't want the fallbacks. */
2583 if (SPECIFIERP (sp->fallback))
2585 /* If you introduced loops in the default specifier chain,
2586 then you're fucked, so you better not do this. */
2587 specifier = sp->fallback;
2588 sp = XSPECIFIER (specifier);
2592 assert (CONSP (sp->fallback));
2593 return specifier_instance_from_inst_list (specifier, matchspec, domain,
2594 sp->fallback, errb, no_quit,
2597 #undef CHECK_INSTANCE_ENTRY
2600 specifier_instance_no_quit (Lisp_Object specifier, Lisp_Object matchspec,
2601 Lisp_Object domain, Error_behavior errb,
2602 int no_fallback, Lisp_Object depth)
2604 return specifier_instance (specifier, matchspec, domain, errb,
2605 1, no_fallback, depth);
2608 DEFUN ("specifier-instance", Fspecifier_instance, 1, 4, 0, /*
2609 Instantiate SPECIFIER (return its value) in DOMAIN.
2610 If no instance can be generated for this domain, return DEFAULT.
2612 DOMAIN should be a window, frame, or device. Other values that are legal
2613 as a locale (e.g. a buffer) are not valid as a domain because they do not
2614 provide enough information to identify a particular device (see
2615 `valid-specifier-domain-p'). DOMAIN defaults to the selected window
2618 "Instantiating" a specifier in a particular domain means determining
2619 the specifier's "value" in that domain. This is accomplished by
2620 searching through the specifications in the specifier that correspond
2621 to all locales that can be derived from the given domain, from specific
2622 to general. In most cases, the domain is an Emacs window. In that case
2623 specifications are searched for as follows:
2625 1. A specification whose locale is the window itself;
2626 2. A specification whose locale is the window's buffer;
2627 3. A specification whose locale is the window's frame;
2628 4. A specification whose locale is the window's frame's device;
2629 5. A specification whose locale is 'global.
2631 If all of those fail, then the C-code-provided fallback value for
2632 this specifier is consulted (see `specifier-fallback'). If it is
2633 an inst-list, then this function attempts to instantiate that list
2634 just as when a specification is located in the first five steps above.
2635 If the fallback is a specifier, `specifier-instance' is called
2636 recursively on this specifier and the return value used. Note,
2637 however, that if the optional argument NO-FALLBACK is non-nil,
2638 the fallback value will not be consulted.
2640 Note that there may be more than one specification matching a particular
2641 locale; all such specifications are considered before looking for any
2642 specifications for more general locales. Any particular specification
2643 that is found may be rejected because its tag set does not match the
2644 device being instantiated over, or because the specification is not
2645 valid for the device of the given domain (e.g. the font or color name
2646 does not exist for this particular X server).
2648 The returned value is dependent on the type of specifier. For example,
2649 for a font specifier (as returned by the `face-font' function), the returned
2650 value will be a font-instance object. For glyphs, the returned value
2651 will be a string, pixmap, or subwindow.
2653 See also `specifier-matching-instance'.
2655 (specifier, domain, default_, no_fallback))
2657 Lisp_Object instance;
2659 CHECK_SPECIFIER (specifier);
2660 domain = decode_domain (domain);
2662 instance = specifier_instance (specifier, Qunbound, domain, ERROR_ME, 0,
2663 !NILP (no_fallback), Qzero);
2664 return UNBOUNDP (instance) ? default_ : instance;
2667 DEFUN ("specifier-matching-instance", Fspecifier_matching_instance, 2, 5, 0, /*
2668 Return an instance for SPECIFIER in DOMAIN that matches MATCHSPEC.
2669 If no instance can be generated for this domain, return DEFAULT.
2671 This function is identical to `specifier-instance' except that a
2672 specification will only be considered if it matches MATCHSPEC.
2673 The definition of "match", and allowed values for MATCHSPEC, are
2674 dependent on the particular type of specifier. Here are some examples:
2676 -- For chartable (e.g. display table) specifiers, MATCHSPEC should be a
2677 character, and the specification (a chartable) must give a value for
2678 that character in order to be considered. This allows you to specify,
2679 e.g., a buffer-local display table that only gives values for particular
2680 characters. All other characters are handled as if the buffer-local
2681 display table is not there. (Chartable specifiers are not yet
2684 -- For font specifiers, MATCHSPEC should be a charset, and the specification
2685 (a font string) must have a registry that matches the charset's registry.
2686 (This only makes sense with Mule support.) This makes it easy to choose a
2687 font that can display a particular character. (This is what redisplay
2690 (specifier, matchspec, domain, default_, no_fallback))
2692 Lisp_Object instance;
2694 CHECK_SPECIFIER (specifier);
2695 check_valid_specifier_matchspec (matchspec, XSPECIFIER (specifier)->methods,
2697 domain = decode_domain (domain);
2699 instance = specifier_instance (specifier, matchspec, domain, ERROR_ME,
2700 0, !NILP (no_fallback), Qzero);
2701 return UNBOUNDP (instance) ? default_ : instance;
2704 DEFUN ("specifier-instance-from-inst-list", Fspecifier_instance_from_inst_list,
2706 Attempt to convert a particular inst-list into an instance.
2707 This attempts to instantiate INST-LIST in the given DOMAIN,
2708 as if INST-LIST existed in a specification in SPECIFIER. If
2709 the instantiation fails, DEFAULT is returned. In most circumstances,
2710 you should not use this function; use `specifier-instance' instead.
2712 (specifier, domain, inst_list, default_))
2714 Lisp_Object val = Qunbound;
2715 Lisp_Specifier *sp = XSPECIFIER (specifier);
2716 struct gcpro gcpro1;
2717 Lisp_Object built_up_list = Qnil;
2719 CHECK_SPECIFIER (specifier);
2720 check_valid_domain (domain);
2721 check_valid_inst_list (inst_list, sp->methods, ERROR_ME);
2722 GCPRO1 (built_up_list);
2723 built_up_list = build_up_processed_list (specifier, domain, inst_list);
2724 if (!NILP (built_up_list))
2725 val = specifier_instance_from_inst_list (specifier, Qunbound, domain,
2726 built_up_list, ERROR_ME,
2729 return UNBOUNDP (val) ? default_ : val;
2732 DEFUN ("specifier-matching-instance-from-inst-list", Fspecifier_matching_instance_from_inst_list,
2734 Attempt to convert a particular inst-list into an instance.
2735 This attempts to instantiate INST-LIST in the given DOMAIN
2736 \(as if INST-LIST existed in a specification in SPECIFIER),
2737 matching the specifications against MATCHSPEC.
2739 This function is analogous to `specifier-instance-from-inst-list'
2740 but allows for specification-matching as in `specifier-matching-instance'.
2741 See that function for a description of exactly how the matching process
2744 (specifier, matchspec, domain, inst_list, default_))
2746 Lisp_Object val = Qunbound;
2747 Lisp_Specifier *sp = XSPECIFIER (specifier);
2748 struct gcpro gcpro1;
2749 Lisp_Object built_up_list = Qnil;
2751 CHECK_SPECIFIER (specifier);
2752 check_valid_specifier_matchspec (matchspec, XSPECIFIER (specifier)->methods,
2754 check_valid_domain (domain);
2755 check_valid_inst_list (inst_list, sp->methods, ERROR_ME);
2756 GCPRO1 (built_up_list);
2757 built_up_list = build_up_processed_list (specifier, domain, inst_list);
2758 if (!NILP (built_up_list))
2759 val = specifier_instance_from_inst_list (specifier, matchspec, domain,
2760 built_up_list, ERROR_ME,
2763 return UNBOUNDP (val) ? default_ : val;
2767 /************************************************************************/
2768 /* Caching in the struct window or frame */
2769 /************************************************************************/
2771 /* Either STRUCT_WINDOW_OFFSET or STRUCT_FRAME_OFFSET can be 0 to indicate
2772 no caching in that sort of object. */
2774 /* #### It would be nice if the specifier caching automatically knew
2775 about specifier fallbacks, so we didn't have to do it ourselves. */
2778 set_specifier_caching (Lisp_Object specifier, int struct_window_offset,
2779 void (*value_changed_in_window)
2780 (Lisp_Object specifier, struct window *w,
2781 Lisp_Object oldval),
2782 int struct_frame_offset,
2783 void (*value_changed_in_frame)
2784 (Lisp_Object specifier, struct frame *f,
2785 Lisp_Object oldval))
2787 Lisp_Specifier *sp = XSPECIFIER (specifier);
2788 assert (!GHOST_SPECIFIER_P (sp));
2791 sp->caching = xnew_and_zero (struct specifier_caching);
2792 sp->caching->offset_into_struct_window = struct_window_offset;
2793 sp->caching->value_changed_in_window = value_changed_in_window;
2794 sp->caching->offset_into_struct_frame = struct_frame_offset;
2795 sp->caching->value_changed_in_frame = value_changed_in_frame;
2796 Vcached_specifiers = Fcons (specifier, Vcached_specifiers);
2797 if (BODILY_SPECIFIER_P (sp))
2798 GHOST_SPECIFIER(sp)->caching = sp->caching;
2799 recompute_cached_specifier_everywhere (specifier);
2803 recompute_one_cached_specifier_in_window (Lisp_Object specifier,
2807 Lisp_Object newval, *location;
2809 assert (!GHOST_SPECIFIER_P (XSPECIFIER (specifier)));
2811 XSETWINDOW (window, w);
2813 newval = specifier_instance (specifier, Qunbound, window, ERROR_ME_WARN,
2815 /* If newval ended up Qunbound, then the calling functions
2816 better be able to deal. If not, set a default so this
2817 never happens or correct it in the value_changed_in_window
2819 location = (Lisp_Object *)
2820 ((char *) w + XSPECIFIER (specifier)->caching->offset_into_struct_window);
2821 /* #### What's the point of this check, other than to optimize image
2822 instance instantiation? Unless you specify a caching instantiate
2823 method the instantiation that specifier_instance will do will
2824 always create a new copy. Thus EQ will always fail. Unfortunately
2825 calling equal is no good either as this doesn't take into account
2826 things attached to the specifier - for instance strings on
2828 if (!EQ (newval, *location))
2830 Lisp_Object oldval = *location;
2832 (XSPECIFIER (specifier)->caching->value_changed_in_window)
2833 (specifier, w, oldval);
2838 recompute_one_cached_specifier_in_frame (Lisp_Object specifier,
2842 Lisp_Object newval, *location;
2844 assert (!GHOST_SPECIFIER_P (XSPECIFIER (specifier)));
2846 XSETFRAME (frame, f);
2848 newval = specifier_instance (specifier, Qunbound, frame, ERROR_ME_WARN,
2850 /* If newval ended up Qunbound, then the calling functions
2851 better be able to deal. If not, set a default so this
2852 never happens or correct it in the value_changed_in_frame
2854 location = (Lisp_Object *)
2855 ((char *) f + XSPECIFIER (specifier)->caching->offset_into_struct_frame);
2856 if (!EQ (newval, *location))
2858 Lisp_Object oldval = *location;
2860 (XSPECIFIER (specifier)->caching->value_changed_in_frame)
2861 (specifier, f, oldval);
2866 recompute_all_cached_specifiers_in_window (struct window *w)
2870 LIST_LOOP (rest, Vcached_specifiers)
2872 Lisp_Object specifier = XCAR (rest);
2873 if (XSPECIFIER (specifier)->caching->offset_into_struct_window)
2874 recompute_one_cached_specifier_in_window (specifier, w);
2879 recompute_all_cached_specifiers_in_frame (struct frame *f)
2883 LIST_LOOP (rest, Vcached_specifiers)
2885 Lisp_Object specifier = XCAR (rest);
2886 if (XSPECIFIER (specifier)->caching->offset_into_struct_frame)
2887 recompute_one_cached_specifier_in_frame (specifier, f);
2892 recompute_cached_specifier_everywhere_mapfun (struct window *w,
2895 Lisp_Object specifier = Qnil;
2897 VOID_TO_LISP (specifier, closure);
2898 recompute_one_cached_specifier_in_window (specifier, w);
2903 recompute_cached_specifier_everywhere (Lisp_Object specifier)
2905 Lisp_Object frmcons, devcons, concons;
2907 specifier = bodily_specifier (specifier);
2909 if (!XSPECIFIER (specifier)->caching)
2912 if (XSPECIFIER (specifier)->caching->offset_into_struct_window)
2914 FRAME_LOOP_NO_BREAK (frmcons, devcons, concons)
2915 map_windows (XFRAME (XCAR (frmcons)),
2916 recompute_cached_specifier_everywhere_mapfun,
2917 LISP_TO_VOID (specifier));
2920 if (XSPECIFIER (specifier)->caching->offset_into_struct_frame)
2922 FRAME_LOOP_NO_BREAK (frmcons, devcons, concons)
2923 recompute_one_cached_specifier_in_frame (specifier,
2924 XFRAME (XCAR (frmcons)));
2928 DEFUN ("set-specifier-dirty-flag", Fset_specifier_dirty_flag, 1, 1, 0, /*
2929 Force recomputation of any caches associated with SPECIFIER.
2930 Note that this automatically happens whenever you change a specification
2931 in SPECIFIER; you do not have to call this function then.
2932 One example of where this function is useful is when you have a
2933 toolbar button whose `active-p' field is an expression to be
2934 evaluated. Calling `set-specifier-dirty-flag' on the
2935 toolbar specifier will force the `active-p' fields to be
2940 CHECK_SPECIFIER (specifier);
2941 recompute_cached_specifier_everywhere (specifier);
2946 /************************************************************************/
2947 /* Generic specifier type */
2948 /************************************************************************/
2950 DEFINE_SPECIFIER_TYPE (generic);
2954 /* This is the string that used to be in `generic-specifier-p'.
2955 The idea is good, but it doesn't quite work in the form it's
2956 in. (One major problem is that validating an instantiator
2957 is supposed to require only that the specifier type is passed,
2958 while with this approach the actual specifier is needed.)
2960 What really needs to be done is to write a function
2961 `make-specifier-type' that creates new specifier types.
2962 #### I'll look into this for 19.14.
2965 "A generic specifier is a generalized kind of specifier with user-defined\n"
2966 "semantics. The instantiator can be any kind of Lisp object, and the\n"
2967 "instance computed from it is likewise any kind of Lisp object. The\n"
2968 "SPECIFIER-DATA should be an alist of methods governing how the specifier\n"
2969 "works. All methods are optional, and reasonable default methods will be\n"
2970 "provided. Currently there are two defined methods: 'instantiate and\n"
2973 "'instantiate specifies how to do the instantiation; if omitted, the\n"
2974 "instantiator itself is simply returned as the instance. The method\n"
2975 "should be a function that accepts three parameters (a specifier, the\n"
2976 "instantiator that matched the domain being instantiated over, and that\n"
2977 "domain), and should return a one-element list containing the instance,\n"
2978 "or nil if no instance exists. Note that the domain passed to this function\n"
2979 "is the domain being instantiated over, which may not be the same as the\n"
2980 "locale contained in the specification corresponding to the instantiator\n"
2981 "(for example, the domain being instantiated over could be a window, but\n"
2982 "the locale corresponding to the passed instantiator could be the window's\n"
2983 "buffer or frame).\n"
2985 "'validate specifies whether a given instantiator is valid; if omitted,\n"
2986 "all instantiators are considered valid. It should be a function of\n"
2987 "two arguments: an instantiator and a flag CAN-SIGNAL-ERROR. If this\n"
2988 "flag is false, the function must simply return t or nil indicating\n"
2989 "whether the instantiator is valid. If this flag is true, the function\n"
2990 "is free to signal an error if it encounters an invalid instantiator\n"
2991 "(this can be useful for issuing a specific error about exactly why the\n"
2992 "instantiator is valid). It can also return nil to indicate an invalid\n"
2993 "instantiator; in this case, a general error will be signalled."
2997 DEFUN ("generic-specifier-p", Fgeneric_specifier_p, 1, 1, 0, /*
2998 Return non-nil if OBJECT is a generic specifier.
3000 A generic specifier allows any kind of Lisp object as an instantiator,
3001 and returns back the Lisp object unchanged when it is instantiated.
3005 return GENERIC_SPECIFIERP (object) ? Qt : Qnil;
3009 /************************************************************************/
3010 /* Integer specifier type */
3011 /************************************************************************/
3013 DEFINE_SPECIFIER_TYPE (integer);
3016 integer_validate (Lisp_Object instantiator)
3018 CHECK_INT (instantiator);
3021 DEFUN ("integer-specifier-p", Finteger_specifier_p, 1, 1, 0, /*
3022 Return non-nil if OBJECT is an integer specifier.
3026 return INTEGER_SPECIFIERP (object) ? Qt : Qnil;
3029 /************************************************************************/
3030 /* Non-negative-integer specifier type */
3031 /************************************************************************/
3033 DEFINE_SPECIFIER_TYPE (natnum);
3036 natnum_validate (Lisp_Object instantiator)
3038 CHECK_NATNUM (instantiator);
3041 DEFUN ("natnum-specifier-p", Fnatnum_specifier_p, 1, 1, 0, /*
3042 Return non-nil if OBJECT is a natnum (non-negative-integer) specifier.
3046 return NATNUM_SPECIFIERP (object) ? Qt : Qnil;
3049 /************************************************************************/
3050 /* Boolean specifier type */
3051 /************************************************************************/
3053 DEFINE_SPECIFIER_TYPE (boolean);
3056 boolean_validate (Lisp_Object instantiator)
3058 if (!EQ (instantiator, Qt) && !EQ (instantiator, Qnil))
3059 signal_simple_error ("Must be t or nil", instantiator);
3062 DEFUN ("boolean-specifier-p", Fboolean_specifier_p, 1, 1, 0, /*
3063 Return non-nil if OBJECT is a boolean specifier.
3067 return BOOLEAN_SPECIFIERP (object) ? Qt : Qnil;
3070 /************************************************************************/
3071 /* Display table specifier type */
3072 /************************************************************************/
3074 DEFINE_SPECIFIER_TYPE (display_table);
3076 #define VALID_SINGLE_DISPTABLE_INSTANTIATOR_P(instantiator) \
3077 (VECTORP (instantiator) \
3078 || (CHAR_TABLEP (instantiator) \
3079 && (XCHAR_TABLE_TYPE (instantiator) == CHAR_TABLE_TYPE_CHAR \
3080 || XCHAR_TABLE_TYPE (instantiator) == CHAR_TABLE_TYPE_GENERIC)) \
3081 || RANGE_TABLEP (instantiator))
3084 display_table_validate (Lisp_Object instantiator)
3086 if (NILP (instantiator))
3089 else if (CONSP (instantiator))
3092 EXTERNAL_LIST_LOOP (tail, instantiator)
3094 Lisp_Object car = XCAR (tail);
3095 if (!VALID_SINGLE_DISPTABLE_INSTANTIATOR_P (car))
3101 if (!VALID_SINGLE_DISPTABLE_INSTANTIATOR_P (instantiator))
3104 dead_wrong_type_argument (display_table_specifier_methods->predicate_symbol,
3110 DEFUN ("display-table-specifier-p", Fdisplay_table_specifier_p, 1, 1, 0, /*
3111 Return non-nil if OBJECT is a display-table specifier.
3115 return DISPLAYTABLE_SPECIFIERP (object) ? Qt : Qnil;
3119 /************************************************************************/
3120 /* Initialization */
3121 /************************************************************************/
3124 syms_of_specifier (void)
3126 INIT_LRECORD_IMPLEMENTATION (specifier);
3128 defsymbol (&Qspecifierp, "specifierp");
3130 defsymbol (&Qconsole_type, "console-type");
3131 defsymbol (&Qdevice_class, "device-class");
3133 /* Qinteger, Qboolean, Qgeneric defined in general.c */
3134 defsymbol (&Qnatnum, "natnum");
3136 DEFSUBR (Fvalid_specifier_type_p);
3137 DEFSUBR (Fspecifier_type_list);
3138 DEFSUBR (Fmake_specifier);
3139 DEFSUBR (Fspecifierp);
3140 DEFSUBR (Fspecifier_type);
3142 DEFSUBR (Fvalid_specifier_locale_p);
3143 DEFSUBR (Fvalid_specifier_domain_p);
3144 DEFSUBR (Fvalid_specifier_locale_type_p);
3145 DEFSUBR (Fspecifier_locale_type_from_locale);
3147 DEFSUBR (Fvalid_specifier_tag_p);
3148 DEFSUBR (Fvalid_specifier_tag_set_p);
3149 DEFSUBR (Fcanonicalize_tag_set);
3150 DEFSUBR (Fdevice_matches_specifier_tag_set_p);
3151 DEFSUBR (Fdefine_specifier_tag);
3152 DEFSUBR (Fdevice_matching_specifier_tag_list);
3153 DEFSUBR (Fspecifier_tag_list);
3154 DEFSUBR (Fspecifier_tag_predicate);
3156 DEFSUBR (Fcheck_valid_instantiator);
3157 DEFSUBR (Fvalid_instantiator_p);
3158 DEFSUBR (Fcheck_valid_inst_list);
3159 DEFSUBR (Fvalid_inst_list_p);
3160 DEFSUBR (Fcheck_valid_spec_list);
3161 DEFSUBR (Fvalid_spec_list_p);
3162 DEFSUBR (Fadd_spec_to_specifier);
3163 DEFSUBR (Fadd_spec_list_to_specifier);
3164 DEFSUBR (Fspecifier_spec_list);
3165 DEFSUBR (Fspecifier_specs);
3166 DEFSUBR (Fremove_specifier);
3167 DEFSUBR (Fcopy_specifier);
3169 DEFSUBR (Fcheck_valid_specifier_matchspec);
3170 DEFSUBR (Fvalid_specifier_matchspec_p);
3171 DEFSUBR (Fspecifier_fallback);
3172 DEFSUBR (Fspecifier_instance);
3173 DEFSUBR (Fspecifier_matching_instance);
3174 DEFSUBR (Fspecifier_instance_from_inst_list);
3175 DEFSUBR (Fspecifier_matching_instance_from_inst_list);
3176 DEFSUBR (Fset_specifier_dirty_flag);
3178 DEFSUBR (Fgeneric_specifier_p);
3179 DEFSUBR (Finteger_specifier_p);
3180 DEFSUBR (Fnatnum_specifier_p);
3181 DEFSUBR (Fboolean_specifier_p);
3182 DEFSUBR (Fdisplay_table_specifier_p);
3184 /* Symbols pertaining to specifier creation. Specifiers are created
3185 in the syms_of() functions. */
3187 /* locales are defined in general.c. */
3189 defsymbol (&Qprepend, "prepend");
3190 defsymbol (&Qappend, "append");
3191 defsymbol (&Qremove_tag_set_prepend, "remove-tag-set-prepend");
3192 defsymbol (&Qremove_tag_set_append, "remove-tag-set-append");
3193 defsymbol (&Qremove_locale, "remove-locale");
3194 defsymbol (&Qremove_locale_type, "remove-locale-type");
3195 defsymbol (&Qremove_all, "remove-all");
3197 defsymbol (&Qfallback, "fallback");
3201 specifier_type_create (void)
3203 the_specifier_type_entry_dynarr = Dynarr_new (specifier_type_entry);
3204 dumpstruct (&the_specifier_type_entry_dynarr, &sted_description);
3206 Vspecifier_type_list = Qnil;
3207 staticpro (&Vspecifier_type_list);
3209 INITIALIZE_SPECIFIER_TYPE (generic, "generic", "generic-specifier-p");
3211 INITIALIZE_SPECIFIER_TYPE (integer, "integer", "integer-specifier-p");
3213 SPECIFIER_HAS_METHOD (integer, validate);
3215 INITIALIZE_SPECIFIER_TYPE (natnum, "natnum", "natnum-specifier-p");
3217 SPECIFIER_HAS_METHOD (natnum, validate);
3219 INITIALIZE_SPECIFIER_TYPE (boolean, "boolean", "boolean-specifier-p");
3221 SPECIFIER_HAS_METHOD (boolean, validate);
3223 INITIALIZE_SPECIFIER_TYPE (display_table, "display-table", "display-table-p");
3225 SPECIFIER_HAS_METHOD (display_table, validate);
3229 reinit_specifier_type_create (void)
3231 REINITIALIZE_SPECIFIER_TYPE (generic);
3232 REINITIALIZE_SPECIFIER_TYPE (integer);
3233 REINITIALIZE_SPECIFIER_TYPE (natnum);
3234 REINITIALIZE_SPECIFIER_TYPE (boolean);
3235 REINITIALIZE_SPECIFIER_TYPE (display_table);
3239 vars_of_specifier (void)
3241 Vcached_specifiers = Qnil;
3242 staticpro (&Vcached_specifiers);
3244 /* Do NOT mark through this, or specifiers will never be GC'd.
3245 This is the same deal as for weak hash tables. */
3246 Vall_specifiers = Qnil;
3247 pdump_wire_list (&Vall_specifiers);
3249 Vuser_defined_tags = Qnil;
3250 staticpro (&Vuser_defined_tags);
3252 Vunlock_ghost_specifiers = Qnil;
3253 staticpro (&Vunlock_ghost_specifiers);