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 Qremove_tag_set_prepend, Qremove_tag_set_append;
45 Lisp_Object Qremove_locale, Qremove_locale_type;
47 Lisp_Object Qconsole_type, Qdevice_class;
49 Lisp_Object Qspecifier_syntax_error;
50 Lisp_Object Qspecifier_argument_error;
51 Lisp_Object Qspecifier_change_error;
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,
72 &specifier_methods_description },
76 static const struct struct_description ste_description = {
77 sizeof (specifier_type_entry),
81 static const struct lrecord_description sted_description_1[] = {
82 XD_DYNARR_DESC (specifier_type_entry_dynarr, &ste_description),
86 static const struct struct_description sted_description = {
87 sizeof (specifier_type_entry_dynarr),
91 static Lisp_Object Vspecifier_type_list;
93 static Lisp_Object Vcached_specifiers;
94 /* Do NOT mark through this, or specifiers will never be GC'd. */
95 static Lisp_Object Vall_specifiers;
97 static Lisp_Object Vunlock_ghost_specifiers;
99 /* #### The purpose of this is to check for inheritance loops
100 in specifiers that can inherit from other specifiers, but it's
103 #### Look into this for 19.14. */
104 /* static Lisp_Object_dynarr current_specifiers; */
106 static void recompute_cached_specifier_everywhere (Lisp_Object specifier);
108 EXFUN (Fspecifier_specs, 4);
109 EXFUN (Fremove_specifier, 4);
112 /************************************************************************/
113 /* Specifier object methods */
114 /************************************************************************/
116 /* Remove dead objects from the specified assoc list. */
119 cleanup_assoc_list (Lisp_Object list)
121 Lisp_Object loop, prev, retval;
123 loop = retval = list;
128 Lisp_Object entry = XCAR (loop);
129 Lisp_Object key = XCAR (entry);
131 /* remember, dead windows can become alive again. */
132 if (!WINDOWP (key) && object_dead_p (key))
136 /* Removing the head. */
137 retval = XCDR (retval);
141 Fsetcdr (prev, XCDR (loop));
153 /* Remove dead objects from the various lists so that they
154 don't keep getting marked as long as this specifier exists and
155 therefore wasting memory. */
158 cleanup_specifiers (void)
162 for (rest = Vall_specifiers;
164 rest = XSPECIFIER (rest)->next_specifier)
166 Lisp_Specifier *sp = XSPECIFIER (rest);
167 /* This effectively changes the specifier specs.
168 However, there's no need to call
169 recompute_cached_specifier_everywhere() or the
170 after-change methods because the only specs we
171 are removing are for dead objects, and they can
172 never have any effect on the specifier values:
173 specifiers can only be instantiated over live
174 objects, and you can't derive a dead object
176 sp->device_specs = cleanup_assoc_list (sp->device_specs);
177 sp->frame_specs = cleanup_assoc_list (sp->frame_specs);
178 sp->buffer_specs = cleanup_assoc_list (sp->buffer_specs);
179 /* windows are handled specially because dead windows
180 can be resurrected */
185 kill_specifier_buffer_locals (Lisp_Object buffer)
189 for (rest = Vall_specifiers;
191 rest = XSPECIFIER (rest)->next_specifier)
193 Lisp_Specifier *sp = XSPECIFIER (rest);
195 /* Make sure we're actually going to be changing something.
196 Fremove_specifier() always calls
197 recompute_cached_specifier_everywhere() (#### but should
198 be smarter about this). */
199 if (!NILP (assq_no_quit (buffer, sp->buffer_specs)))
200 Fremove_specifier (rest, buffer, Qnil, Qnil);
205 mark_specifier (Lisp_Object obj)
207 Lisp_Specifier *specifier = XSPECIFIER (obj);
209 mark_object (specifier->global_specs);
210 mark_object (specifier->device_specs);
211 mark_object (specifier->frame_specs);
212 mark_object (specifier->window_specs);
213 mark_object (specifier->buffer_specs);
214 mark_object (specifier->magic_parent);
215 mark_object (specifier->fallback);
216 if (!GHOST_SPECIFIER_P (XSPECIFIER (obj)))
217 MAYBE_SPECMETH (specifier, mark, (obj));
221 /* The idea here is that the specifier specs point to locales
222 (windows, buffers, frames, and devices), and we want to make sure
223 that the specs disappear automatically when the associated locale
224 is no longer in use. For all but windows, "no longer in use"
225 corresponds exactly to when the object is deleted (non-deleted
226 objects are always held permanently in special lists, and deleted
227 objects are never on these lists and never reusable). To handle
228 this, we just have cleanup_specifiers() called periodically
229 (at the beginning of garbage collection); it removes all dead
232 For windows, however, it's trickier because dead objects can be
233 converted to live ones again if the dead object is in a window
234 configuration. Therefore, for windows, "no longer in use"
235 corresponds to when the window object is garbage-collected.
236 We now use weak lists for this purpose.
241 prune_specifiers (void)
243 Lisp_Object rest, prev = Qnil;
245 for (rest = Vall_specifiers;
247 rest = XSPECIFIER (rest)->next_specifier)
249 if (! marked_p (rest))
251 Lisp_Specifier* sp = XSPECIFIER (rest);
252 /* A bit of assertion that we're removing both parts of the
253 magic one altogether */
254 assert (!MAGIC_SPECIFIER_P(sp)
255 || (BODILY_SPECIFIER_P(sp) && marked_p (sp->fallback))
256 || (GHOST_SPECIFIER_P(sp) && marked_p (sp->magic_parent)));
257 /* This specifier is garbage. Remove it from the list. */
259 Vall_specifiers = sp->next_specifier;
261 XSPECIFIER (prev)->next_specifier = sp->next_specifier;
269 print_specifier (Lisp_Object obj, Lisp_Object printcharfun, int escapeflag)
271 Lisp_Specifier *sp = XSPECIFIER (obj);
273 int count = specpdl_depth ();
274 Lisp_Object the_specs;
277 error ("printing unreadable object #<%s-specifier 0x%x>",
278 sp->methods->name, sp->header.uid);
280 sprintf (buf, "#<%s-specifier global=", sp->methods->name);
281 write_c_string (buf, printcharfun);
282 specbind (Qprint_string_length, make_int (100));
283 specbind (Qprint_length, make_int (5));
284 the_specs = Fspecifier_specs (obj, Qglobal, Qnil, Qnil);
285 if (NILP (the_specs))
286 /* there are no global specs */
287 write_c_string ("<unspecified>", printcharfun);
289 print_internal (the_specs, printcharfun, 1);
290 if (!NILP (sp->fallback))
292 write_c_string (" fallback=", printcharfun);
293 print_internal (sp->fallback, printcharfun, escapeflag);
295 unbind_to (count, Qnil);
296 sprintf (buf, " 0x%x>", sp->header.uid);
297 write_c_string (buf, printcharfun);
301 finalize_specifier (void *header, int for_disksave)
303 Lisp_Specifier *sp = (Lisp_Specifier *) header;
304 /* don't be snafued by the disksave finalization. */
305 if (!for_disksave && !GHOST_SPECIFIER_P(sp) && sp->caching)
313 specifier_equal (Lisp_Object obj1, Lisp_Object obj2, int depth)
315 Lisp_Specifier *s1 = XSPECIFIER (obj1);
316 Lisp_Specifier *s2 = XSPECIFIER (obj2);
318 Lisp_Object old_inhibit_quit = Vinhibit_quit;
320 /* This function can be called from within redisplay.
321 internal_equal can trigger a quit. That leads to Bad Things. */
326 (s1->methods == s2->methods &&
327 internal_equal (s1->global_specs, s2->global_specs, depth) &&
328 internal_equal (s1->device_specs, s2->device_specs, depth) &&
329 internal_equal (s1->frame_specs, s2->frame_specs, depth) &&
330 internal_equal (s1->window_specs, s2->window_specs, depth) &&
331 internal_equal (s1->buffer_specs, s2->buffer_specs, depth) &&
332 internal_equal (s1->fallback, s2->fallback, depth));
334 if (retval && HAS_SPECMETH_P (s1, equal))
335 retval = SPECMETH (s1, equal, (obj1, obj2, depth - 1));
337 Vinhibit_quit = old_inhibit_quit;
342 specifier_hash (Lisp_Object obj, int depth)
344 Lisp_Specifier *s = XSPECIFIER (obj);
346 /* specifier hashing is a bit problematic because there are so
347 many places where data can be stored. We pick what are perhaps
348 the most likely places where interesting stuff will be. */
349 return HASH5 ((HAS_SPECMETH_P (s, hash) ?
350 SPECMETH (s, hash, (obj, depth)) : 0),
351 (unsigned long) s->methods,
352 internal_hash (s->global_specs, depth + 1),
353 internal_hash (s->frame_specs, depth + 1),
354 internal_hash (s->buffer_specs, depth + 1));
358 sizeof_specifier (const void *header)
360 if (GHOST_SPECIFIER_P ((Lisp_Specifier *) header))
361 return offsetof (Lisp_Specifier, data);
364 const Lisp_Specifier *p = (const Lisp_Specifier *) header;
365 return offsetof (Lisp_Specifier, data) + p->methods->extra_data_size;
369 static const struct lrecord_description specifier_methods_description_1[] = {
370 { XD_LISP_OBJECT, offsetof (struct specifier_methods, predicate_symbol) },
374 const struct struct_description specifier_methods_description = {
375 sizeof (struct specifier_methods),
376 specifier_methods_description_1
379 static const struct lrecord_description specifier_caching_description_1[] = {
383 static const struct struct_description specifier_caching_description = {
384 sizeof (struct specifier_caching),
385 specifier_caching_description_1
388 static const struct lrecord_description specifier_description[] = {
389 { XD_STRUCT_PTR, offsetof (Lisp_Specifier, methods), 1,
390 &specifier_methods_description },
391 { XD_LO_LINK, offsetof (Lisp_Specifier, next_specifier) },
392 { XD_LISP_OBJECT, offsetof (Lisp_Specifier, global_specs) },
393 { XD_LISP_OBJECT, offsetof (Lisp_Specifier, device_specs) },
394 { XD_LISP_OBJECT, offsetof (Lisp_Specifier, frame_specs) },
395 { XD_LISP_OBJECT, offsetof (Lisp_Specifier, window_specs) },
396 { XD_LISP_OBJECT, offsetof (Lisp_Specifier, buffer_specs) },
397 { XD_STRUCT_PTR, offsetof (Lisp_Specifier, caching), 1,
398 &specifier_caching_description },
399 { XD_LISP_OBJECT, offsetof (Lisp_Specifier, magic_parent) },
400 { XD_LISP_OBJECT, offsetof (Lisp_Specifier, fallback) },
404 const struct lrecord_description specifier_empty_extra_description[] = {
408 DEFINE_LRECORD_SEQUENCE_IMPLEMENTATION ("specifier", specifier,
409 mark_specifier, print_specifier,
411 specifier_equal, specifier_hash,
412 specifier_description,
416 /************************************************************************/
417 /* Creating specifiers */
418 /************************************************************************/
420 static struct specifier_methods *
421 decode_specifier_type (Lisp_Object type, Error_behavior errb)
425 for (i = 0; i < Dynarr_length (the_specifier_type_entry_dynarr); i++)
427 if (EQ (type, Dynarr_at (the_specifier_type_entry_dynarr, i).symbol))
428 return Dynarr_at (the_specifier_type_entry_dynarr, i).meths;
431 maybe_signal_type_error (Qspecifier_argument_error, "Invalid specifier type",
432 type, Qspecifier, errb);
438 valid_specifier_type_p (Lisp_Object type)
440 return decode_specifier_type (type, ERROR_ME_NOT) != 0;
443 DEFUN ("valid-specifier-type-p", Fvalid_specifier_type_p, 1, 1, 0, /*
444 Given a SPECIFIER-TYPE, return non-nil if it is valid.
445 Valid types are 'generic, 'integer, boolean, 'color, 'font, 'image,
446 'face-boolean, and 'toolbar.
450 return valid_specifier_type_p (specifier_type) ? Qt : Qnil;
453 DEFUN ("specifier-type-list", Fspecifier_type_list, 0, 0, 0, /*
454 Return a list of valid specifier types.
458 return Fcopy_sequence (Vspecifier_type_list);
462 add_entry_to_specifier_type_list (Lisp_Object symbol,
463 struct specifier_methods *meths)
465 struct specifier_type_entry entry;
467 entry.symbol = symbol;
469 Dynarr_add (the_specifier_type_entry_dynarr, entry);
470 Vspecifier_type_list = Fcons (symbol, Vspecifier_type_list);
474 make_specifier_internal (struct specifier_methods *spec_meths,
475 size_t data_size, int call_create_meth)
477 Lisp_Object specifier;
478 Lisp_Specifier *sp = (Lisp_Specifier *)
479 alloc_lcrecord (offsetof (Lisp_Specifier, data) + data_size,
482 sp->methods = spec_meths;
483 sp->global_specs = Qnil;
484 sp->device_specs = Qnil;
485 sp->frame_specs = Qnil;
486 sp->window_specs = make_weak_list (WEAK_LIST_KEY_ASSOC);
487 sp->buffer_specs = Qnil;
489 sp->magic_parent = Qnil;
491 sp->next_specifier = Vall_specifiers;
493 XSETSPECIFIER (specifier, sp);
494 Vall_specifiers = specifier;
496 if (call_create_meth)
500 MAYBE_SPECMETH (XSPECIFIER (specifier), create, (specifier));
507 make_specifier (struct specifier_methods *meths)
509 return make_specifier_internal (meths, meths->extra_data_size, 1);
513 make_magic_specifier (Lisp_Object type)
515 /* This function can GC */
516 struct specifier_methods *meths = decode_specifier_type (type, ERROR_ME);
517 Lisp_Object bodily, ghost;
520 bodily = make_specifier (meths);
522 ghost = make_specifier_internal (meths, 0, 0);
525 /* Connect guys together */
526 XSPECIFIER(bodily)->magic_parent = Qt;
527 XSPECIFIER(bodily)->fallback = ghost;
528 XSPECIFIER(ghost)->magic_parent = bodily;
533 DEFUN ("make-specifier", Fmake_specifier, 1, 1, 0, /*
534 Return a new specifier object of type TYPE.
536 A specifier is an object that can be used to keep track of a property
537 whose value can be per-buffer, per-window, per-frame, or per-device,
538 and can further be restricted to a particular console-type or
539 device-class. Specifiers are used, for example, for the various
540 built-in properties of a face; this allows a face to have different
541 values in different frames, buffers, etc.
543 When speaking of the value of a specifier, it is important to
544 distinguish between the *setting* of a specifier, called an
545 \"instantiator\", and the *actual value*, called an \"instance\". You
546 put various possible instantiators (i.e. settings) into a specifier
547 and associate them with particular locales (buffer, window, frame,
548 device, global), and then the instance (i.e. actual value) is
549 retrieved in a specific domain (window, frame, device) by looking
550 through the possible instantiators (i.e. settings). This process is
551 called \"instantiation\".
553 To put settings into a specifier, use `set-specifier', or the
554 lower-level functions `add-spec-to-specifier' and
555 `add-spec-list-to-specifier'. You can also temporarily bind a setting
556 to a specifier using `let-specifier'. To retrieve settings, use
557 `specifier-specs', or its lower-level counterpart
558 `specifier-spec-list'. To determine the actual value, use
559 `specifier-instance'.
561 For more information, see `set-specifier', `specifier-instance',
562 `specifier-specs', and `add-spec-to-specifier'; or, for a detailed
563 description of specifiers, including how exactly the instantiation
564 process works, see the chapter on specifiers in the XEmacs Lisp
567 TYPE specifies the particular type of specifier, and should be one of
568 the symbols 'generic, 'integer, 'natnum, 'boolean, 'color, 'font,
569 'image, 'face-boolean, 'display-table, 'gutter, 'gutter-size,
570 'gutter-visible or 'toolbar.
572 For more information on particular types of specifiers, see the
573 functions `make-generic-specifier', `make-integer-specifier',
574 `make-natnum-specifier', `make-boolean-specifier',
575 `make-color-specifier', `make-font-specifier', `make-image-specifier',
576 `make-face-boolean-specifier', `make-gutter-size-specifier',
577 `make-gutter-visible-specifier', `default-toolbar', `default-gutter',
578 and `current-display-table'.
582 /* This function can GC */
583 struct specifier_methods *meths = decode_specifier_type (type, ERROR_ME);
585 return make_specifier (meths);
588 DEFUN ("specifierp", Fspecifierp, 1, 1, 0, /*
589 Return t if OBJECT is a specifier.
591 A specifier is an object that can be used to keep track of a property
592 whose value can be per-buffer, per-window, per-frame, or per-device,
593 and can further be restricted to a particular console-type or device-class.
594 See `make-specifier'.
598 return SPECIFIERP (object) ? Qt : Qnil;
601 DEFUN ("specifier-type", Fspecifier_type, 1, 1, 0, /*
602 Return the type of SPECIFIER.
606 CHECK_SPECIFIER (specifier);
607 return intern (XSPECIFIER (specifier)->methods->name);
611 /************************************************************************/
612 /* Locales and domains */
613 /************************************************************************/
615 DEFUN ("valid-specifier-locale-p", Fvalid_specifier_locale_p, 1, 1, 0, /*
616 Return t if LOCALE is a valid specifier locale.
617 Valid locales are devices, frames, windows, buffers, and 'global.
622 /* This cannot GC. */
623 return ((DEVICEP (locale) && DEVICE_LIVE_P (XDEVICE (locale))) ||
624 (FRAMEP (locale) && FRAME_LIVE_P (XFRAME (locale))) ||
625 (BUFFERP (locale) && BUFFER_LIVE_P (XBUFFER (locale))) ||
626 /* dead windows are allowed because they may become live
627 windows again when a window configuration is restored */
629 EQ (locale, Qglobal))
633 DEFUN ("valid-specifier-domain-p", Fvalid_specifier_domain_p, 1, 1, 0, /*
634 Return t if DOMAIN is a valid specifier domain.
635 A domain is used to instance a specifier (i.e. determine the specifier's
636 value in that domain). Valid domains are image instances, windows, frames,
637 and devices. \(nil is not valid.) image instances are pseudo-domains since
638 instantiation will actually occur in the window the image instance itself is
643 /* This cannot GC. */
644 return ((DEVICEP (domain) && DEVICE_LIVE_P (XDEVICE (domain))) ||
645 (FRAMEP (domain) && FRAME_LIVE_P (XFRAME (domain))) ||
646 (WINDOWP (domain) && WINDOW_LIVE_P (XWINDOW (domain))) ||
647 /* #### get image instances out of domains! */
648 IMAGE_INSTANCEP (domain))
652 DEFUN ("valid-specifier-locale-type-p", Fvalid_specifier_locale_type_p, 1, 1, 0,
654 Given a specifier LOCALE-TYPE, return non-nil if it is valid.
655 Valid locale types are 'global, 'device, 'frame, 'window, and 'buffer.
656 \(Note, however, that in functions that accept either a locale or a locale
657 type, 'global is considered an individual locale.)
661 /* This cannot GC. */
662 return (EQ (locale_type, Qglobal) ||
663 EQ (locale_type, Qdevice) ||
664 EQ (locale_type, Qframe) ||
665 EQ (locale_type, Qwindow) ||
666 EQ (locale_type, Qbuffer)) ? Qt : Qnil;
670 check_valid_locale_or_locale_type (Lisp_Object locale)
672 /* This cannot GC. */
673 if (EQ (locale, Qall) ||
674 !NILP (Fvalid_specifier_locale_p (locale)) ||
675 !NILP (Fvalid_specifier_locale_type_p (locale)))
677 signal_type_error (Qspecifier_argument_error,
678 "Invalid specifier locale or locale type", locale);
681 DEFUN ("specifier-locale-type-from-locale", Fspecifier_locale_type_from_locale,
683 Given a specifier LOCALE, return its type.
687 /* This cannot GC. */
688 if (NILP (Fvalid_specifier_locale_p (locale)))
689 signal_type_error (Qspecifier_argument_error, "Invalid specifier locale",
691 if (DEVICEP (locale)) return Qdevice;
692 if (FRAMEP (locale)) return Qframe;
693 if (WINDOWP (locale)) return Qwindow;
694 if (BUFFERP (locale)) return Qbuffer;
695 assert (EQ (locale, Qglobal));
700 decode_locale (Lisp_Object locale)
702 /* This cannot GC. */
705 else if (!NILP (Fvalid_specifier_locale_p (locale)))
708 signal_type_error (Qspecifier_argument_error, "Invalid specifier locale",
714 static enum spec_locale_type
715 decode_locale_type (Lisp_Object locale_type)
717 /* This cannot GC. */
718 if (EQ (locale_type, Qglobal)) return LOCALE_GLOBAL;
719 if (EQ (locale_type, Qdevice)) return LOCALE_DEVICE;
720 if (EQ (locale_type, Qframe)) return LOCALE_FRAME;
721 if (EQ (locale_type, Qwindow)) return LOCALE_WINDOW;
722 if (EQ (locale_type, Qbuffer)) return LOCALE_BUFFER;
724 signal_type_error (Qspecifier_argument_error, "Invalid specifier locale type",
726 return LOCALE_GLOBAL; /* not reached */
730 decode_locale_list (Lisp_Object locale)
732 /* This cannot GC. */
733 /* The return value of this function must be GCPRO'd. */
738 else if (CONSP (locale))
740 EXTERNAL_LIST_LOOP_2 (elt, locale)
741 check_valid_locale_or_locale_type (elt);
746 check_valid_locale_or_locale_type (locale);
747 return list1 (locale);
751 static enum spec_locale_type
752 locale_type_from_locale (Lisp_Object locale)
754 return decode_locale_type (Fspecifier_locale_type_from_locale (locale));
758 check_valid_domain (Lisp_Object domain)
760 if (NILP (Fvalid_specifier_domain_p (domain)))
761 signal_type_error (Qspecifier_argument_error, "Invalid specifier domain",
766 decode_domain (Lisp_Object domain)
769 return Fselected_window (Qnil);
770 check_valid_domain (domain);
775 /************************************************************************/
777 /************************************************************************/
779 DEFUN ("valid-specifier-tag-p", Fvalid_specifier_tag_p, 1, 1, 0, /*
780 Return non-nil if TAG is a valid specifier tag.
781 See also `valid-specifier-tag-set-p'.
785 return (valid_console_type_p (tag) ||
786 valid_device_class_p (tag) ||
787 !NILP (assq_no_quit (tag, Vuser_defined_tags))) ? Qt : Qnil;
790 DEFUN ("valid-specifier-tag-set-p", Fvalid_specifier_tag_set_p, 1, 1, 0, /*
791 Return non-nil if TAG-SET is a valid specifier tag set.
793 A specifier tag set is an entity that is attached to an instantiator
794 and can be used to restrict the scope of that instantiator to a
795 particular device class or device type and/or to mark instantiators
796 added by a particular package so that they can be later removed.
798 A specifier tag set consists of a list of zero of more specifier tags,
799 each of which is a symbol that is recognized by XEmacs as a tag.
800 \(The valid device types and device classes are always tags, as are
801 any tags defined by `define-specifier-tag'.) It is called a "tag set"
802 \(as opposed to a list) because the order of the tags or the number of
803 times a particular tag occurs does not matter.
805 Each tag has a predicate associated with it, which specifies whether
806 that tag applies to a particular device. The tags which are device types
807 and classes match devices of that type or class. User-defined tags can
808 have any predicate, or none (meaning that all devices match). When
809 attempting to instance a specifier, a particular instantiator is only
810 considered if the device of the domain being instanced over matches
811 all tags in the tag set attached to that instantiator.
813 Most of the time, a tag set is not specified, and the instantiator
814 gets a null tag set, which matches all devices.
820 for (rest = tag_set; !NILP (rest); rest = XCDR (rest))
824 if (NILP (Fvalid_specifier_tag_p (XCAR (rest))))
832 decode_specifier_tag_set (Lisp_Object tag_set)
834 /* The return value of this function must be GCPRO'd. */
835 if (!NILP (Fvalid_specifier_tag_p (tag_set)))
836 return list1 (tag_set);
837 if (NILP (Fvalid_specifier_tag_set_p (tag_set)))
838 signal_type_error (Qspecifier_argument_error, "Invalid specifier tag-set",
844 canonicalize_tag_set (Lisp_Object tag_set)
846 int len = XINT (Flength (tag_set));
847 Lisp_Object *tags, rest;
850 /* We assume in this function that the tag_set has already been
851 validated, so there are no surprises. */
853 if (len == 0 || len == 1)
854 /* most common case */
857 tags = alloca_array (Lisp_Object, len);
860 LIST_LOOP (rest, tag_set)
861 tags[i++] = XCAR (rest);
863 /* Sort the list of tags. We use a bubble sort here (copied from
864 extent_fragment_update()) -- reduces the function call overhead,
865 and is the fastest sort for small numbers of items. */
867 for (i = 1; i < len; i++)
871 strcmp ((char *) string_data (XSYMBOL (tags[j])->name),
872 (char *) string_data (XSYMBOL (tags[j+1])->name)) > 0)
874 Lisp_Object tmp = tags[j];
881 /* Now eliminate duplicates. */
883 for (i = 1, j = 1; i < len; i++)
885 /* j holds the destination, i the source. */
886 if (!EQ (tags[i], tags[i-1]))
890 return Flist (j, tags);
893 DEFUN ("canonicalize-tag-set", Fcanonicalize_tag_set, 1, 1, 0, /*
894 Canonicalize the given tag set.
895 Two canonicalized tag sets can be compared with `equal' to see if they
896 represent the same tag set. (Specifically, canonicalizing involves
897 sorting by symbol name and removing duplicates.)
901 if (NILP (Fvalid_specifier_tag_set_p (tag_set)))
902 signal_type_error (Qspecifier_argument_error, "Invalid tag set", tag_set);
903 return canonicalize_tag_set (tag_set);
907 device_matches_specifier_tag_set_p (Lisp_Object device, Lisp_Object tag_set)
909 Lisp_Object devtype, devclass, rest;
910 struct device *d = XDEVICE (device);
912 devtype = DEVICE_TYPE (d);
913 devclass = DEVICE_CLASS (d);
915 LIST_LOOP (rest, tag_set)
917 Lisp_Object tag = XCAR (rest);
920 if (EQ (tag, devtype) || EQ (tag, devclass))
922 assoc = assq_no_quit (tag, DEVICE_USER_DEFINED_TAGS (d));
923 /* other built-in tags (device types/classes) are not in
924 the user-defined-tags list. */
925 if (NILP (assoc) || NILP (XCDR (assoc)))
932 DEFUN ("device-matches-specifier-tag-set-p",
933 Fdevice_matches_specifier_tag_set_p, 2, 2, 0, /*
934 Return non-nil if DEVICE matches specifier tag set TAG-SET.
935 This means that DEVICE matches each tag in the tag set. (Every
936 tag recognized by XEmacs has a predicate associated with it that
937 specifies which devices match it.)
941 CHECK_LIVE_DEVICE (device);
943 if (NILP (Fvalid_specifier_tag_set_p (tag_set)))
944 signal_type_error (Qspecifier_argument_error, "Invalid tag set", tag_set);
946 return device_matches_specifier_tag_set_p (device, tag_set) ? Qt : Qnil;
949 DEFUN ("define-specifier-tag", Fdefine_specifier_tag, 1, 2, 0, /*
950 Define a new specifier tag.
951 If PREDICATE is specified, it should be a function of one argument
952 \(a device) that specifies whether the tag matches that particular
953 device. If PREDICATE is omitted, the tag matches all devices.
955 You can redefine an existing user-defined specifier tag. However,
956 you cannot redefine the built-in specifier tags (the device types
957 and classes) or the symbols nil, t, 'all, or 'global.
961 Lisp_Object assoc, devcons, concons;
965 if (valid_device_class_p (tag) ||
966 valid_console_type_p (tag))
967 signal_type_error (Qspecifier_change_error,
968 "Cannot redefine built-in specifier tags", tag);
969 /* Try to prevent common instantiators and locales from being
970 redefined, to reduce ambiguity */
971 if (NILP (tag) || EQ (tag, Qt) || EQ (tag, Qall) || EQ (tag, Qglobal))
972 signal_type_error (Qspecifier_change_error, "Cannot define nil, t, 'all, or 'global",
974 assoc = assq_no_quit (tag, Vuser_defined_tags);
978 Vuser_defined_tags = Fcons (Fcons (tag, predicate), Vuser_defined_tags);
979 DEVICE_LOOP_NO_BREAK (devcons, concons)
981 struct device *d = XDEVICE (XCAR (devcons));
982 /* Initially set the value to t in case of error
984 DEVICE_USER_DEFINED_TAGS (d) =
985 Fcons (Fcons (tag, Qt), DEVICE_USER_DEFINED_TAGS (d));
988 else if (!NILP (predicate) && !NILP (XCDR (assoc)))
991 XCDR (assoc) = predicate;
994 /* recompute the tag values for all devices. However, in the special
995 case where both the old and new predicates are nil, we know that
996 we don't have to do this. (It's probably common for people to
997 call (define-specifier-tag) more than once on the same tag,
998 and the most common case is where PREDICATE is not specified.) */
1002 DEVICE_LOOP_NO_BREAK (devcons, concons)
1004 Lisp_Object device = XCAR (devcons);
1005 assoc = assq_no_quit (tag,
1006 DEVICE_USER_DEFINED_TAGS (XDEVICE (device)));
1007 assert (CONSP (assoc));
1008 if (NILP (predicate))
1011 XCDR (assoc) = !NILP (call1 (predicate, device)) ? Qt : Qnil;
1018 /* Called at device-creation time to initialize the user-defined
1019 tag values for the newly-created device. */
1022 setup_device_initial_specifier_tags (struct device *d)
1024 Lisp_Object rest, rest2;
1027 XSETDEVICE (device, d);
1029 DEVICE_USER_DEFINED_TAGS (d) = Fcopy_alist (Vuser_defined_tags);
1031 /* Now set up the initial values */
1032 LIST_LOOP (rest, DEVICE_USER_DEFINED_TAGS (d))
1033 XCDR (XCAR (rest)) = Qt;
1035 for (rest = Vuser_defined_tags, rest2 = DEVICE_USER_DEFINED_TAGS (d);
1036 !NILP (rest); rest = XCDR (rest), rest2 = XCDR (rest2))
1038 Lisp_Object predicate = XCDR (XCAR (rest));
1039 if (NILP (predicate))
1040 XCDR (XCAR (rest2)) = Qt;
1042 XCDR (XCAR (rest2)) = !NILP (call1 (predicate, device)) ? Qt : Qnil;
1046 DEFUN ("device-matching-specifier-tag-list",
1047 Fdevice_matching_specifier_tag_list,
1049 Return a list of all specifier tags matching DEVICE.
1050 DEVICE defaults to the selected device if omitted.
1054 struct device *d = decode_device (device);
1055 Lisp_Object rest, list = Qnil;
1056 struct gcpro gcpro1;
1060 LIST_LOOP (rest, DEVICE_USER_DEFINED_TAGS (d))
1062 if (!NILP (XCDR (XCAR (rest))))
1063 list = Fcons (XCAR (XCAR (rest)), list);
1066 list = Fnreverse (list);
1067 list = Fcons (DEVICE_CLASS (d), list);
1068 list = Fcons (DEVICE_TYPE (d), list);
1070 RETURN_UNGCPRO (list);
1073 DEFUN ("specifier-tag-list", Fspecifier_tag_list, 0, 0, 0, /*
1074 Return a list of all currently-defined specifier tags.
1075 This includes the built-in ones (the device types and classes).
1079 Lisp_Object list = Qnil, rest;
1080 struct gcpro gcpro1;
1084 LIST_LOOP (rest, Vuser_defined_tags)
1085 list = Fcons (XCAR (XCAR (rest)), list);
1087 list = Fnreverse (list);
1088 list = nconc2 (Fcopy_sequence (Vdevice_class_list), list);
1089 list = nconc2 (Fcopy_sequence (Vconsole_type_list), list);
1091 RETURN_UNGCPRO (list);
1094 DEFUN ("specifier-tag-predicate", Fspecifier_tag_predicate, 1, 1, 0, /*
1095 Return the predicate for the given specifier tag.
1099 /* The return value of this function must be GCPRO'd. */
1102 if (NILP (Fvalid_specifier_tag_p (tag)))
1103 signal_type_error (Qspecifier_argument_error, "Invalid specifier tag",
1106 /* Make up some predicates for the built-in types */
1108 if (valid_console_type_p (tag))
1109 return list3 (Qlambda, list1 (Qdevice),
1110 list3 (Qeq, list2 (Qquote, tag),
1111 list2 (Qconsole_type, Qdevice)));
1113 if (valid_device_class_p (tag))
1114 return list3 (Qlambda, list1 (Qdevice),
1115 list3 (Qeq, list2 (Qquote, tag),
1116 list2 (Qdevice_class, Qdevice)));
1118 return XCDR (assq_no_quit (tag, Vuser_defined_tags));
1121 /* Return true if A "matches" B. If EXACT_P is 0, A must be a subset of B.
1122 Otherwise, A must be `equal' to B. The sets must be canonicalized. */
1124 tag_sets_match_p (Lisp_Object a, Lisp_Object b, int exact_p)
1128 while (!NILP (a) && !NILP (b))
1130 if (EQ (XCAR (a), XCAR (b)))
1139 while (!NILP (a) && !NILP (b))
1141 if (!EQ (XCAR (a), XCAR (b)))
1147 return NILP (a) && NILP (b);
1152 /************************************************************************/
1153 /* Spec-lists and inst-lists */
1154 /************************************************************************/
1157 call_validate_method (Lisp_Object boxed_method, Lisp_Object instantiator)
1159 ((void (*)(Lisp_Object)) get_opaque_ptr (boxed_method)) (instantiator);
1164 check_valid_instantiator (Lisp_Object instantiator,
1165 struct specifier_methods *meths,
1166 Error_behavior errb)
1168 if (meths->validate_method)
1172 if (ERRB_EQ (errb, ERROR_ME))
1174 (meths->validate_method) (instantiator);
1179 Lisp_Object opaque = make_opaque_ptr ((void *)
1180 meths->validate_method);
1181 struct gcpro gcpro1;
1184 retval = call_with_suspended_errors
1185 ((lisp_fn_t) call_validate_method,
1186 Qnil, Qspecifier, errb, 2, opaque, instantiator);
1188 free_opaque_ptr (opaque);
1197 DEFUN ("check-valid-instantiator", Fcheck_valid_instantiator, 2, 2, 0, /*
1198 Signal an error if INSTANTIATOR is invalid for SPECIFIER-TYPE.
1200 (instantiator, specifier_type))
1202 struct specifier_methods *meths = decode_specifier_type (specifier_type,
1205 return check_valid_instantiator (instantiator, meths, ERROR_ME);
1208 DEFUN ("valid-instantiator-p", Fvalid_instantiator_p, 2, 2, 0, /*
1209 Return non-nil if INSTANTIATOR is valid for SPECIFIER-TYPE.
1211 (instantiator, specifier_type))
1213 struct specifier_methods *meths = decode_specifier_type (specifier_type,
1216 return check_valid_instantiator (instantiator, meths, ERROR_ME_NOT);
1220 check_valid_inst_list (Lisp_Object inst_list, struct specifier_methods *meths,
1221 Error_behavior errb)
1225 LIST_LOOP (rest, inst_list)
1227 Lisp_Object inst_pair, tag_set;
1231 maybe_signal_type_error (Qspecifier_syntax_error,
1232 "Invalid instantiator list", inst_list,
1236 if (!CONSP (inst_pair = XCAR (rest)))
1238 maybe_signal_type_error (Qspecifier_syntax_error,
1239 "Invalid instantiator pair", inst_pair,
1243 if (NILP (Fvalid_specifier_tag_set_p (tag_set = XCAR (inst_pair))))
1245 maybe_signal_type_error (Qspecifier_syntax_error,
1246 "Invalid specifier tag", tag_set,
1251 if (NILP (check_valid_instantiator (XCDR (inst_pair), meths, errb)))
1258 DEFUN ("check-valid-inst-list", Fcheck_valid_inst_list, 2, 2, 0, /*
1259 Signal an error if INST-LIST is invalid for specifier type TYPE.
1263 struct specifier_methods *meths = decode_specifier_type (type, ERROR_ME);
1265 return check_valid_inst_list (inst_list, meths, ERROR_ME);
1268 DEFUN ("valid-inst-list-p", Fvalid_inst_list_p, 2, 2, 0, /*
1269 Return non-nil if INST-LIST is valid for specifier type TYPE.
1273 struct specifier_methods *meths = decode_specifier_type (type, ERROR_ME);
1275 return check_valid_inst_list (inst_list, meths, ERROR_ME_NOT);
1279 check_valid_spec_list (Lisp_Object spec_list, struct specifier_methods *meths,
1280 Error_behavior errb)
1284 LIST_LOOP (rest, spec_list)
1286 Lisp_Object spec, locale;
1287 if (!CONSP (rest) || !CONSP (spec = XCAR (rest)))
1289 maybe_signal_type_error (Qspecifier_syntax_error,
1290 "Invalid specification list", spec_list,
1294 if (NILP (Fvalid_specifier_locale_p (locale = XCAR (spec))))
1296 maybe_signal_type_error (Qspecifier_syntax_error,
1297 "Invalid specifier locale", locale,
1302 if (NILP (check_valid_inst_list (XCDR (spec), meths, errb)))
1309 DEFUN ("check-valid-spec-list", Fcheck_valid_spec_list, 2, 2, 0, /*
1310 Signal an error if SPEC-LIST is invalid for specifier type TYPE.
1314 struct specifier_methods *meths = decode_specifier_type (type, ERROR_ME);
1316 return check_valid_spec_list (spec_list, meths, ERROR_ME);
1319 DEFUN ("valid-spec-list-p", Fvalid_spec_list_p, 2, 2, 0, /*
1320 Return non-nil if SPEC-LIST is valid for specifier type TYPE.
1324 struct specifier_methods *meths = decode_specifier_type (type, ERROR_ME);
1326 return check_valid_spec_list (spec_list, meths, ERROR_ME_NOT);
1330 decode_how_to_add_specification (Lisp_Object how_to_add)
1332 if (NILP (how_to_add) || EQ (Qremove_tag_set_prepend, how_to_add))
1333 return SPEC_REMOVE_TAG_SET_PREPEND;
1334 if (EQ (Qremove_tag_set_append, how_to_add))
1335 return SPEC_REMOVE_TAG_SET_APPEND;
1336 if (EQ (Qappend, how_to_add))
1338 if (EQ (Qprepend, how_to_add))
1339 return SPEC_PREPEND;
1340 if (EQ (Qremove_locale, how_to_add))
1341 return SPEC_REMOVE_LOCALE;
1342 if (EQ (Qremove_locale_type, how_to_add))
1343 return SPEC_REMOVE_LOCALE_TYPE;
1344 if (EQ (Qremove_all, how_to_add))
1345 return SPEC_REMOVE_ALL;
1347 signal_type_error (Qspecifier_argument_error, "Invalid `how-to-add' flag",
1350 return SPEC_PREPEND; /* not reached */
1353 /* Given a specifier object SPEC, return bodily specifier if SPEC is a
1354 ghost specifier, otherwise return the object itself
1357 bodily_specifier (Lisp_Object spec)
1359 return (GHOST_SPECIFIER_P (XSPECIFIER (spec))
1360 ? XSPECIFIER(spec)->magic_parent : spec);
1363 /* Signal error if (specifier SPEC is read-only.
1364 Read only are ghost specifiers unless Vunlock_ghost_specifiers is
1365 non-nil. All other specifiers are read-write.
1368 check_modifiable_specifier (Lisp_Object spec)
1370 if (NILP (Vunlock_ghost_specifiers)
1371 && GHOST_SPECIFIER_P (XSPECIFIER (spec)))
1372 signal_type_error (Qspecifier_change_error,
1373 "Attempt to modify read-only specifier",
1377 /* Helper function which unwind protects the value of
1378 Vunlock_ghost_specifiers, then sets it to non-nil value */
1380 restore_unlock_value (Lisp_Object val)
1382 Vunlock_ghost_specifiers = val;
1387 unlock_ghost_specifiers_protected (void)
1389 int depth = specpdl_depth ();
1390 record_unwind_protect (restore_unlock_value,
1391 Vunlock_ghost_specifiers);
1392 Vunlock_ghost_specifiers = Qt;
1396 /* This gets hit so much that the function call overhead had a
1397 measurable impact (according to Quantify). #### We should figure
1398 out the frequency with which this is called with the various types
1399 and reorder the check accordingly. */
1400 #define SPECIFIER_GET_SPEC_LIST(specifier, type) \
1401 (type == LOCALE_GLOBAL ? &(XSPECIFIER (specifier)->global_specs) : \
1402 type == LOCALE_DEVICE ? &(XSPECIFIER (specifier)->device_specs) : \
1403 type == LOCALE_FRAME ? &(XSPECIFIER (specifier)->frame_specs) : \
1404 type == LOCALE_WINDOW ? &(XWEAK_LIST_LIST \
1405 (XSPECIFIER (specifier)->window_specs)) : \
1406 type == LOCALE_BUFFER ? &(XSPECIFIER (specifier)->buffer_specs) : \
1409 static Lisp_Object *
1410 specifier_get_inst_list (Lisp_Object specifier, Lisp_Object locale,
1411 enum spec_locale_type type)
1413 Lisp_Object *spec_list = SPECIFIER_GET_SPEC_LIST (specifier, type);
1414 Lisp_Object specification;
1416 if (type == LOCALE_GLOBAL)
1418 /* Calling assq_no_quit when it is just going to return nil anyhow
1419 is extremely expensive. So sayeth Quantify. */
1420 if (!CONSP (*spec_list))
1422 specification = assq_no_quit (locale, *spec_list);
1423 if (NILP (specification))
1425 return &XCDR (specification);
1428 /* For the given INST_LIST, return a new INST_LIST containing all elements
1429 where TAG-SET matches the element's tag set. EXACT_P indicates whether
1430 the match must be exact (as opposed to a subset). SHORT_P indicates
1431 that the short form (for `specifier-specs') should be returned if
1432 possible. If COPY_TREE_P, `copy-tree' is used to ensure that no
1433 elements of the new list are shared with the initial list.
1437 specifier_process_inst_list (Lisp_Object inst_list,
1438 Lisp_Object tag_set, int exact_p,
1439 int short_p, int copy_tree_p)
1441 Lisp_Object retval = Qnil;
1443 struct gcpro gcpro1;
1446 LIST_LOOP (rest, inst_list)
1448 Lisp_Object tagged_inst = XCAR (rest);
1449 Lisp_Object tagged_inst_tag = XCAR (tagged_inst);
1450 if (tag_sets_match_p (tag_set, tagged_inst_tag, exact_p))
1452 if (short_p && NILP (tagged_inst_tag))
1453 retval = Fcons (copy_tree_p ?
1454 Fcopy_tree (XCDR (tagged_inst), Qt) :
1458 retval = Fcons (copy_tree_p ? Fcopy_tree (tagged_inst, Qt) :
1459 tagged_inst, retval);
1462 retval = Fnreverse (retval);
1464 /* If there is a single instantiator and the short form is
1465 requested, return just the instantiator (rather than a one-element
1466 list of it) unless it is nil (so that it can be distinguished from
1467 no instantiators at all). */
1468 if (short_p && CONSP (retval) && !NILP (XCAR (retval)) &&
1469 NILP (XCDR (retval)))
1470 return XCAR (retval);
1476 specifier_get_external_inst_list (Lisp_Object specifier, Lisp_Object locale,
1477 enum spec_locale_type type,
1478 Lisp_Object tag_set, int exact_p,
1479 int short_p, int copy_tree_p)
1481 Lisp_Object *inst_list = specifier_get_inst_list (specifier, locale,
1483 if (!inst_list || NILP (*inst_list))
1485 /* nil for *inst_list should only occur in 'global */
1486 assert (!inst_list || EQ (locale, Qglobal));
1490 return specifier_process_inst_list (*inst_list, tag_set, exact_p,
1491 short_p, copy_tree_p);
1495 specifier_get_external_spec_list (Lisp_Object specifier,
1496 enum spec_locale_type type,
1497 Lisp_Object tag_set, int exact_p)
1499 Lisp_Object *spec_list = SPECIFIER_GET_SPEC_LIST (specifier, type);
1500 Lisp_Object retval = Qnil;
1502 struct gcpro gcpro1;
1504 assert (type != LOCALE_GLOBAL);
1505 /* We're about to let stuff go external; make sure there aren't
1507 *spec_list = cleanup_assoc_list (*spec_list);
1510 LIST_LOOP (rest, *spec_list)
1512 Lisp_Object spec = XCAR (rest);
1513 Lisp_Object inst_list =
1514 specifier_process_inst_list (XCDR (spec), tag_set, exact_p, 0, 1);
1515 if (!NILP (inst_list))
1516 retval = Fcons (Fcons (XCAR (spec), inst_list), retval);
1518 RETURN_UNGCPRO (Fnreverse (retval));
1521 static Lisp_Object *
1522 specifier_new_spec (Lisp_Object specifier, Lisp_Object locale,
1523 enum spec_locale_type type)
1525 Lisp_Object *spec_list = SPECIFIER_GET_SPEC_LIST (specifier, type);
1526 Lisp_Object new_spec = Fcons (locale, Qnil);
1527 assert (type != LOCALE_GLOBAL);
1528 *spec_list = Fcons (new_spec, *spec_list);
1529 return &XCDR (new_spec);
1532 /* For the given INST_LIST, return a new list comprised of elements
1533 where TAG_SET does not match the element's tag set. This operation
1537 specifier_process_remove_inst_list (Lisp_Object inst_list,
1538 Lisp_Object tag_set, int exact_p,
1541 Lisp_Object prev = Qnil, rest;
1545 LIST_LOOP (rest, inst_list)
1547 if (tag_sets_match_p (tag_set, XCAR (XCAR (rest)), exact_p))
1549 /* time to remove. */
1552 inst_list = XCDR (rest);
1554 XCDR (prev) = XCDR (rest);
1564 specifier_remove_spec (Lisp_Object specifier, Lisp_Object locale,
1565 enum spec_locale_type type,
1566 Lisp_Object tag_set, int exact_p)
1568 Lisp_Object *spec_list = SPECIFIER_GET_SPEC_LIST (specifier, type);
1572 if (type == LOCALE_GLOBAL)
1573 *spec_list = specifier_process_remove_inst_list (*spec_list, tag_set,
1574 exact_p, &was_removed);
1577 assoc = assq_no_quit (locale, *spec_list);
1579 /* this locale is not found. */
1581 XCDR (assoc) = specifier_process_remove_inst_list (XCDR (assoc),
1584 if (NILP (XCDR (assoc)))
1585 /* no inst-pairs left; remove this locale entirely. */
1586 *spec_list = remassq_no_quit (locale, *spec_list);
1590 MAYBE_SPECMETH (XSPECIFIER (specifier), after_change,
1591 (bodily_specifier (specifier), locale));
1595 specifier_remove_locale_type (Lisp_Object specifier,
1596 enum spec_locale_type type,
1597 Lisp_Object tag_set, int exact_p)
1599 Lisp_Object *spec_list = SPECIFIER_GET_SPEC_LIST (specifier, type);
1600 Lisp_Object prev = Qnil, rest;
1602 assert (type != LOCALE_GLOBAL);
1603 LIST_LOOP (rest, *spec_list)
1606 int remove_spec = 0;
1607 Lisp_Object spec = XCAR (rest);
1609 /* There may be dead objects floating around */
1610 /* remember, dead windows can become alive again. */
1611 if (!WINDOWP (XCAR (spec)) && object_dead_p (XCAR (spec)))
1618 XCDR (spec) = specifier_process_remove_inst_list (XCDR (spec),
1621 if (NILP (XCDR (spec)))
1628 *spec_list = XCDR (rest);
1630 XCDR (prev) = XCDR (rest);
1636 MAYBE_SPECMETH (XSPECIFIER (specifier), after_change,
1637 (bodily_specifier (specifier), XCAR (spec)));
1641 /* NEW_LIST is going to be added to INST_LIST, with add method ADD_METH.
1642 Frob INST_LIST according to ADD_METH. No need to call an after-change
1643 function; the calling function will do this. Return either SPEC_PREPEND
1644 or SPEC_APPEND, indicating whether to prepend or append the NEW_LIST. */
1646 static enum spec_add_meth
1647 handle_multiple_add_insts (Lisp_Object *inst_list,
1648 Lisp_Object new_list,
1649 enum spec_add_meth add_meth)
1653 case SPEC_REMOVE_TAG_SET_APPEND:
1654 add_meth = SPEC_APPEND;
1655 goto remove_tag_set;
1656 case SPEC_REMOVE_TAG_SET_PREPEND:
1657 add_meth = SPEC_PREPEND;
1662 LIST_LOOP (rest, new_list)
1664 Lisp_Object canontag = canonicalize_tag_set (XCAR (XCAR (rest)));
1665 struct gcpro gcpro1;
1668 /* pull out all elements from the existing list with the
1669 same tag as any tags in NEW_LIST. */
1670 *inst_list = remassoc_no_quit (canontag, *inst_list);
1675 case SPEC_REMOVE_LOCALE:
1677 return SPEC_PREPEND;
1681 return SPEC_PREPEND;
1685 /* Given a LOCALE and INST_LIST that is going to be added to SPECIFIER,
1686 copy, canonicalize, and call the going_to_add methods as necessary
1687 to produce a new list that is the one that really will be added
1688 to the specifier. */
1691 build_up_processed_list (Lisp_Object specifier, Lisp_Object locale,
1692 Lisp_Object inst_list)
1694 /* The return value of this function must be GCPRO'd. */
1695 Lisp_Object rest, list_to_build_up = Qnil;
1696 Lisp_Specifier *sp = XSPECIFIER (specifier);
1697 struct gcpro gcpro1;
1699 GCPRO1 (list_to_build_up);
1700 LIST_LOOP (rest, inst_list)
1702 Lisp_Object tag_set = XCAR (XCAR (rest));
1703 Lisp_Object sub_inst_list = Qnil;
1704 Lisp_Object instantiator;
1705 struct gcpro ngcpro1, ngcpro2;
1707 if (HAS_SPECMETH_P (sp, copy_instantiator))
1708 instantiator = SPECMETH (sp, copy_instantiator,
1709 (XCDR (XCAR (rest))));
1711 instantiator = Fcopy_tree (XCDR (XCAR (rest)), Qt);
1713 NGCPRO2 (instantiator, sub_inst_list);
1714 /* call the will-add method; it may GC */
1715 sub_inst_list = HAS_SPECMETH_P (sp, going_to_add) ?
1716 SPECMETH (sp, going_to_add,
1717 (bodily_specifier (specifier), locale,
1718 tag_set, instantiator)) :
1720 if (EQ (sub_inst_list, Qt))
1721 /* no change here. */
1722 sub_inst_list = list1 (Fcons (canonicalize_tag_set (tag_set),
1726 /* now canonicalize all the tag sets in the new objects */
1728 LIST_LOOP (rest2, sub_inst_list)
1729 XCAR (XCAR (rest2)) = canonicalize_tag_set (XCAR (XCAR (rest2)));
1732 list_to_build_up = nconc2 (sub_inst_list, list_to_build_up);
1736 RETURN_UNGCPRO (Fnreverse (list_to_build_up));
1739 /* Add a specification (locale and instantiator list) to a specifier.
1740 ADD_METH specifies what to do with existing specifications in the
1741 specifier, and is an enum that corresponds to the values in
1742 `add-spec-to-specifier'. The calling routine is responsible for
1743 validating LOCALE and INST-LIST, but the tag-sets in INST-LIST
1744 do not need to be canonicalized. */
1746 /* #### I really need to rethink the after-change
1747 functions to make them easier to use and more efficient. */
1750 specifier_add_spec (Lisp_Object specifier, Lisp_Object locale,
1751 Lisp_Object inst_list, enum spec_add_meth add_meth)
1753 Lisp_Specifier *sp = XSPECIFIER (specifier);
1754 enum spec_locale_type type = locale_type_from_locale (locale);
1755 Lisp_Object *orig_inst_list, tem;
1756 Lisp_Object list_to_build_up = Qnil;
1757 struct gcpro gcpro1;
1759 GCPRO1 (list_to_build_up);
1760 list_to_build_up = build_up_processed_list (specifier, locale, inst_list);
1761 /* Now handle REMOVE_LOCALE_TYPE and REMOVE_ALL. These are the
1762 add-meth types that affect locales other than this one. */
1763 if (add_meth == SPEC_REMOVE_LOCALE_TYPE)
1764 specifier_remove_locale_type (specifier, type, Qnil, 0);
1765 else if (add_meth == SPEC_REMOVE_ALL)
1767 specifier_remove_locale_type (specifier, LOCALE_BUFFER, Qnil, 0);
1768 specifier_remove_locale_type (specifier, LOCALE_WINDOW, Qnil, 0);
1769 specifier_remove_locale_type (specifier, LOCALE_FRAME, Qnil, 0);
1770 specifier_remove_locale_type (specifier, LOCALE_DEVICE, Qnil, 0);
1771 specifier_remove_spec (specifier, Qglobal, LOCALE_GLOBAL, Qnil, 0);
1774 orig_inst_list = specifier_get_inst_list (specifier, locale, type);
1775 if (!orig_inst_list)
1776 orig_inst_list = specifier_new_spec (specifier, locale, type);
1777 add_meth = handle_multiple_add_insts (orig_inst_list, list_to_build_up,
1780 if (add_meth == SPEC_PREPEND)
1781 tem = nconc2 (list_to_build_up, *orig_inst_list);
1782 else if (add_meth == SPEC_APPEND)
1783 tem = nconc2 (*orig_inst_list, list_to_build_up);
1790 *orig_inst_list = tem;
1794 /* call the after-change method */
1795 MAYBE_SPECMETH (sp, after_change,
1796 (bodily_specifier (specifier), locale));
1800 specifier_copy_spec (Lisp_Object specifier, Lisp_Object dest,
1801 Lisp_Object locale, enum spec_locale_type type,
1802 Lisp_Object tag_set, int exact_p,
1803 enum spec_add_meth add_meth)
1805 Lisp_Object inst_list =
1806 specifier_get_external_inst_list (specifier, locale, type, tag_set,
1808 specifier_add_spec (dest, locale, inst_list, add_meth);
1812 specifier_copy_locale_type (Lisp_Object specifier, Lisp_Object dest,
1813 enum spec_locale_type type,
1814 Lisp_Object tag_set, int exact_p,
1815 enum spec_add_meth add_meth)
1817 Lisp_Object *src_list = SPECIFIER_GET_SPEC_LIST (specifier, type);
1820 /* This algorithm is O(n^2) in running time.
1821 It's certainly possible to implement an O(n log n) algorithm,
1822 but I doubt there's any need to. */
1824 LIST_LOOP (rest, *src_list)
1826 Lisp_Object spec = XCAR (rest);
1827 /* There may be dead objects floating around */
1828 /* remember, dead windows can become alive again. */
1829 if (WINDOWP (XCAR (spec)) || !object_dead_p (XCAR (spec)))
1832 specifier_process_inst_list (XCDR (spec), tag_set, exact_p, 0, 0),
1837 /* map MAPFUN over the locales in SPECIFIER that are given in LOCALE.
1838 CLOSURE is passed unchanged to MAPFUN. LOCALE can be one of
1840 -- nil (same as 'all)
1841 -- a single locale, locale type, or 'all
1842 -- a list of locales, locale types, and/or 'all
1844 MAPFUN is called for each locale and locale type given; for 'all,
1845 it is called for the locale 'global and for the four possible
1846 locale types. In each invocation, either LOCALE will be a locale
1847 and LOCALE_TYPE will be the locale type of this locale,
1848 or LOCALE will be nil and LOCALE_TYPE will be a locale type.
1849 If MAPFUN ever returns non-zero, the mapping is halted and the
1850 value returned is returned from map_specifier(). Otherwise, the
1851 mapping proceeds to the end and map_specifier() returns 0.
1855 map_specifier (Lisp_Object specifier, Lisp_Object locale,
1856 int (*mapfun) (Lisp_Object specifier,
1858 enum spec_locale_type locale_type,
1859 Lisp_Object tag_set,
1862 Lisp_Object tag_set, Lisp_Object exact_p,
1867 struct gcpro gcpro1, gcpro2;
1869 GCPRO2 (tag_set, locale);
1870 locale = decode_locale_list (locale);
1871 tag_set = decode_specifier_tag_set (tag_set);
1872 tag_set = canonicalize_tag_set (tag_set);
1874 LIST_LOOP (rest, locale)
1876 Lisp_Object theloc = XCAR (rest);
1877 if (!NILP (Fvalid_specifier_locale_p (theloc)))
1879 retval = (*mapfun) (specifier, theloc,
1880 locale_type_from_locale (theloc),
1881 tag_set, !NILP (exact_p), closure);
1885 else if (!NILP (Fvalid_specifier_locale_type_p (theloc)))
1887 retval = (*mapfun) (specifier, Qnil,
1888 decode_locale_type (theloc), tag_set,
1889 !NILP (exact_p), closure);
1895 assert (EQ (theloc, Qall));
1896 retval = (*mapfun) (specifier, Qnil, LOCALE_BUFFER, tag_set,
1897 !NILP (exact_p), closure);
1900 retval = (*mapfun) (specifier, Qnil, LOCALE_WINDOW, tag_set,
1901 !NILP (exact_p), closure);
1904 retval = (*mapfun) (specifier, Qnil, LOCALE_FRAME, tag_set,
1905 !NILP (exact_p), closure);
1908 retval = (*mapfun) (specifier, Qnil, LOCALE_DEVICE, tag_set,
1909 !NILP (exact_p), closure);
1912 retval = (*mapfun) (specifier, Qglobal, LOCALE_GLOBAL, tag_set,
1913 !NILP (exact_p), closure);
1923 DEFUN ("add-spec-to-specifier", Fadd_spec_to_specifier, 2, 5, 0, /*
1924 Add a specification to SPECIFIER.
1925 The specification maps from LOCALE (which should be a window, buffer,
1926 frame, device, or 'global, and defaults to 'global) to INSTANTIATOR,
1927 whose allowed values depend on the type of the specifier. Optional
1928 argument TAG-SET limits the instantiator to apply only to the specified
1929 tag set, which should be a list of tags all of which must match the
1930 device being instantiated over (tags are a device type, a device class,
1931 or tags defined with `define-specifier-tag'). Specifying a single
1932 symbol for TAG-SET is equivalent to specifying a one-element list
1933 containing that symbol. Optional argument HOW-TO-ADD specifies what to
1934 do if there are already specifications in the specifier.
1937 'prepend Put at the beginning of the current list of
1938 instantiators for LOCALE.
1939 'append Add to the end of the current list of
1940 instantiators for LOCALE.
1941 'remove-tag-set-prepend (this is the default)
1942 Remove any existing instantiators whose tag set is
1943 the same as TAG-SET; then put the new instantiator
1944 at the beginning of the current list. ("Same tag
1945 set" means that they contain the same elements.
1946 The order may be different.)
1947 'remove-tag-set-append
1948 Remove any existing instantiators whose tag set is
1949 the same as TAG-SET; then put the new instantiator
1950 at the end of the current list.
1951 'remove-locale Remove all previous instantiators for this locale
1952 before adding the new spec.
1953 'remove-locale-type Remove all specifications for all locales of the
1954 same type as LOCALE (this includes LOCALE itself)
1955 before adding the new spec.
1956 'remove-all Remove all specifications from the specifier
1957 before adding the new spec.
1959 You can retrieve the specifications for a particular locale or locale type
1960 with the function `specifier-spec-list' or `specifier-specs'.
1962 (specifier, instantiator, locale, tag_set, how_to_add))
1964 enum spec_add_meth add_meth;
1965 Lisp_Object inst_list;
1966 struct gcpro gcpro1;
1968 CHECK_SPECIFIER (specifier);
1969 check_modifiable_specifier (specifier);
1971 locale = decode_locale (locale);
1972 check_valid_instantiator (instantiator,
1973 decode_specifier_type
1974 (Fspecifier_type (specifier), ERROR_ME),
1976 /* tag_set might be newly-created material, but it's part of inst_list
1977 so is properly GC-protected. */
1978 tag_set = decode_specifier_tag_set (tag_set);
1979 add_meth = decode_how_to_add_specification (how_to_add);
1981 inst_list = list1 (Fcons (tag_set, instantiator));
1983 specifier_add_spec (specifier, locale, inst_list, add_meth);
1984 recompute_cached_specifier_everywhere (specifier);
1985 RETURN_UNGCPRO (Qnil);
1988 DEFUN ("add-spec-list-to-specifier", Fadd_spec_list_to_specifier, 2, 3, 0, /*
1989 Add SPEC-LIST (a list of specifications) to SPECIFIER.
1990 The format of SPEC-LIST is
1992 ((LOCALE (TAG-SET . INSTANTIATOR) ...) ...)
1995 LOCALE := a window, a buffer, a frame, a device, or 'global
1996 TAG-SET := an unordered list of zero or more TAGS, each of which
1998 TAG := a device class (see `valid-device-class-p'), a device type
1999 (see `valid-console-type-p'), or a tag defined with
2000 `define-specifier-tag'
2001 INSTANTIATOR := format determined by the type of specifier
2003 The pair (TAG-SET . INSTANTIATOR) is called an `inst-pair'.
2004 A list of inst-pairs is called an `inst-list'.
2005 The pair (LOCALE . INST-LIST) is called a `specification' or `spec'.
2006 A spec-list, then, can be viewed as a list of specifications.
2008 HOW-TO-ADD specifies how to combine the new specifications with
2009 the existing ones, and has the same semantics as for
2010 `add-spec-to-specifier'.
2012 In many circumstances, the higher-level function `set-specifier' is
2013 more convenient and should be used instead.
2015 (specifier, spec_list, how_to_add))
2017 enum spec_add_meth add_meth;
2020 CHECK_SPECIFIER (specifier);
2021 check_modifiable_specifier (specifier);
2023 check_valid_spec_list (spec_list,
2024 decode_specifier_type
2025 (Fspecifier_type (specifier), ERROR_ME),
2027 add_meth = decode_how_to_add_specification (how_to_add);
2029 LIST_LOOP (rest, spec_list)
2031 /* Placating the GCC god. */
2032 Lisp_Object specification = XCAR (rest);
2033 Lisp_Object locale = XCAR (specification);
2034 Lisp_Object inst_list = XCDR (specification);
2036 specifier_add_spec (specifier, locale, inst_list, add_meth);
2038 recompute_cached_specifier_everywhere (specifier);
2043 add_spec_to_ghost_specifier (Lisp_Object specifier, Lisp_Object instantiator,
2044 Lisp_Object locale, Lisp_Object tag_set,
2045 Lisp_Object how_to_add)
2047 int depth = unlock_ghost_specifiers_protected ();
2048 Fadd_spec_to_specifier (XSPECIFIER(specifier)->fallback,
2049 instantiator, locale, tag_set, how_to_add);
2050 unbind_to (depth, Qnil);
2053 struct specifier_spec_list_closure
2055 Lisp_Object head, tail;
2059 specifier_spec_list_mapfun (Lisp_Object specifier,
2061 enum spec_locale_type locale_type,
2062 Lisp_Object tag_set,
2066 struct specifier_spec_list_closure *cl =
2067 (struct specifier_spec_list_closure *) closure;
2068 Lisp_Object partial;
2071 partial = specifier_get_external_spec_list (specifier,
2076 partial = specifier_get_external_inst_list (specifier, locale,
2077 locale_type, tag_set,
2079 if (!NILP (partial))
2080 partial = list1 (Fcons (locale, partial));
2085 /* tack on the new list */
2086 if (NILP (cl->tail))
2087 cl->head = cl->tail = partial;
2089 XCDR (cl->tail) = partial;
2090 /* find the new tail */
2091 while (CONSP (XCDR (cl->tail)))
2092 cl->tail = XCDR (cl->tail);
2096 /* For the given SPECIFIER create and return a list of all specs
2097 contained within it, subject to LOCALE. If LOCALE is a locale, only
2098 specs in that locale will be returned. If LOCALE is a locale type,
2099 all specs in all locales of that type will be returned. If LOCALE is
2100 nil, all specs will be returned. This always copies lists and never
2101 returns the actual lists, because we do not want someone manipulating
2102 the actual objects. This may cause a slight loss of potential
2103 functionality but if we were to allow it then a user could manage to
2104 violate our assertion that the specs contained in the actual
2105 specifier lists are all valid. */
2107 DEFUN ("specifier-spec-list", Fspecifier_spec_list, 1, 4, 0, /*
2108 Return the spec-list of specifications for SPECIFIER in LOCALE.
2110 If LOCALE is a particular locale (a buffer, window, frame, device,
2111 or 'global), a spec-list consisting of the specification for that
2112 locale will be returned.
2114 If LOCALE is a locale type (i.e. 'buffer, 'window, 'frame, or 'device),
2115 a spec-list of the specifications for all locales of that type will be
2118 If LOCALE is nil or 'all, a spec-list of all specifications in SPECIFIER
2121 LOCALE can also be a list of locales, locale types, and/or 'all; the
2122 result is as if `specifier-spec-list' were called on each element of the
2123 list and the results concatenated together.
2125 Only instantiators where TAG-SET (a list of zero or more tags) is a
2126 subset of (or possibly equal to) the instantiator's tag set are returned.
2127 \(The default value of nil is a subset of all tag sets, so in this case
2128 no instantiators will be screened out.) If EXACT-P is non-nil, however,
2129 TAG-SET must be equal to an instantiator's tag set for the instantiator
2132 (specifier, locale, tag_set, exact_p))
2134 struct specifier_spec_list_closure cl;
2135 struct gcpro gcpro1, gcpro2;
2137 CHECK_SPECIFIER (specifier);
2138 cl.head = cl.tail = Qnil;
2139 GCPRO2 (cl.head, cl.tail);
2140 map_specifier (specifier, locale, specifier_spec_list_mapfun,
2141 tag_set, exact_p, &cl);
2147 DEFUN ("specifier-specs", Fspecifier_specs, 1, 4, 0, /*
2148 Return the specification(s) for SPECIFIER in LOCALE.
2150 If LOCALE is a single locale or is a list of one element containing a
2151 single locale, then a "short form" of the instantiators for that locale
2152 will be returned. Otherwise, this function is identical to
2153 `specifier-spec-list'.
2155 The "short form" is designed for readability and not for ease of use
2156 in Lisp programs, and is as follows:
2158 1. If there is only one instantiator, then an inst-pair (i.e. cons of
2159 tag and instantiator) will be returned; otherwise a list of
2160 inst-pairs will be returned.
2161 2. For each inst-pair returned, if the instantiator's tag is 'any,
2162 the tag will be removed and the instantiator itself will be returned
2163 instead of the inst-pair.
2164 3. If there is only one instantiator, its value is nil, and its tag is
2165 'any, a one-element list containing nil will be returned rather
2166 than just nil, to distinguish this case from there being no
2167 instantiators at all.
2169 (specifier, locale, tag_set, exact_p))
2171 if (!NILP (Fvalid_specifier_locale_p (locale)) ||
2172 (CONSP (locale) && !NILP (Fvalid_specifier_locale_p (XCAR (locale))) &&
2173 NILP (XCDR (locale))))
2175 struct gcpro gcpro1;
2177 CHECK_SPECIFIER (specifier);
2179 locale = XCAR (locale);
2181 tag_set = decode_specifier_tag_set (tag_set);
2182 tag_set = canonicalize_tag_set (tag_set);
2184 (specifier_get_external_inst_list (specifier, locale,
2185 locale_type_from_locale (locale),
2186 tag_set, !NILP (exact_p), 1, 1));
2189 return Fspecifier_spec_list (specifier, locale, tag_set, exact_p);
2193 remove_specifier_mapfun (Lisp_Object specifier,
2195 enum spec_locale_type locale_type,
2196 Lisp_Object tag_set,
2198 void *ignored_closure)
2201 specifier_remove_locale_type (specifier, locale_type, tag_set, exact_p);
2203 specifier_remove_spec (specifier, locale, locale_type, tag_set, exact_p);
2207 DEFUN ("remove-specifier", Fremove_specifier, 1, 4, 0, /*
2208 Remove specification(s) for SPECIFIER.
2210 If LOCALE is a particular locale (a window, buffer, frame, device,
2211 or 'global), the specification for that locale will be removed.
2213 If instead, LOCALE is a locale type (i.e. 'window, 'buffer, 'frame,
2214 or 'device), the specifications for all locales of that type will be
2217 If LOCALE is nil or 'all, all specifications will be removed.
2219 LOCALE can also be a list of locales, locale types, and/or 'all; this
2220 is equivalent to calling `remove-specifier' for each of the elements
2223 Only instantiators where TAG-SET (a list of zero or more tags) is a
2224 subset of (or possibly equal to) the instantiator's tag set are removed.
2225 The default value of nil is a subset of all tag sets, so in this case
2226 no instantiators will be screened out. If EXACT-P is non-nil, however,
2227 TAG-SET must be equal to an instantiator's tag set for the instantiator
2230 (specifier, locale, tag_set, exact_p))
2232 CHECK_SPECIFIER (specifier);
2233 check_modifiable_specifier (specifier);
2235 map_specifier (specifier, locale, remove_specifier_mapfun,
2236 tag_set, exact_p, 0);
2237 recompute_cached_specifier_everywhere (specifier);
2242 remove_ghost_specifier (Lisp_Object specifier, Lisp_Object locale,
2243 Lisp_Object tag_set, Lisp_Object exact_p)
2245 int depth = unlock_ghost_specifiers_protected ();
2246 Fremove_specifier (XSPECIFIER(specifier)->fallback,
2247 locale, tag_set, exact_p);
2248 unbind_to (depth, Qnil);
2251 struct copy_specifier_closure
2254 enum spec_add_meth add_meth;
2255 int add_meth_is_nil;
2259 copy_specifier_mapfun (Lisp_Object specifier,
2261 enum spec_locale_type locale_type,
2262 Lisp_Object tag_set,
2266 struct copy_specifier_closure *cl =
2267 (struct copy_specifier_closure *) closure;
2270 specifier_copy_locale_type (specifier, cl->dest, locale_type,
2272 cl->add_meth_is_nil ?
2273 SPEC_REMOVE_LOCALE_TYPE :
2276 specifier_copy_spec (specifier, cl->dest, locale, locale_type,
2278 cl->add_meth_is_nil ? SPEC_REMOVE_LOCALE :
2283 DEFUN ("copy-specifier", Fcopy_specifier, 1, 6, 0, /*
2284 Copy SPECIFIER to DEST, or create a new one if DEST is nil.
2286 If DEST is nil or omitted, a new specifier will be created and the
2287 specifications copied into it. Otherwise, the specifications will be
2288 copied into the existing specifier in DEST.
2290 If LOCALE is nil or 'all, all specifications will be copied. If LOCALE
2291 is a particular locale, the specification for that particular locale will
2292 be copied. If LOCALE is a locale type, the specifications for all locales
2293 of that type will be copied. LOCALE can also be a list of locales,
2294 locale types, and/or 'all; this is equivalent to calling `copy-specifier'
2295 for each of the elements of the list. See `specifier-spec-list' for more
2296 information about LOCALE.
2298 Only instantiators where TAG-SET (a list of zero or more tags) is a
2299 subset of (or possibly equal to) the instantiator's tag set are copied.
2300 The default value of nil is a subset of all tag sets, so in this case
2301 no instantiators will be screened out. If EXACT-P is non-nil, however,
2302 TAG-SET must be equal to an instantiator's tag set for the instantiator
2305 Optional argument HOW-TO-ADD specifies what to do with existing
2306 specifications in DEST. If nil, then whichever locales or locale types
2307 are copied will first be completely erased in DEST. Otherwise, it is
2308 the same as in `add-spec-to-specifier'.
2310 (specifier, dest, locale, tag_set, exact_p, how_to_add))
2312 struct gcpro gcpro1;
2313 struct copy_specifier_closure cl;
2315 CHECK_SPECIFIER (specifier);
2316 if (NILP (how_to_add))
2317 cl.add_meth_is_nil = 1;
2319 cl.add_meth_is_nil = 0;
2320 cl.add_meth = decode_how_to_add_specification (how_to_add);
2323 /* #### What about copying the extra data? */
2324 dest = make_specifier (XSPECIFIER (specifier)->methods);
2328 CHECK_SPECIFIER (dest);
2329 check_modifiable_specifier (dest);
2330 if (XSPECIFIER (dest)->methods != XSPECIFIER (specifier)->methods)
2331 error ("Specifiers not of same type");
2336 map_specifier (specifier, locale, copy_specifier_mapfun,
2337 tag_set, exact_p, &cl);
2339 recompute_cached_specifier_everywhere (dest);
2344 /************************************************************************/
2346 /************************************************************************/
2349 call_validate_matchspec_method (Lisp_Object boxed_method,
2350 Lisp_Object matchspec)
2352 ((void (*)(Lisp_Object)) get_opaque_ptr (boxed_method)) (matchspec);
2357 check_valid_specifier_matchspec (Lisp_Object matchspec,
2358 struct specifier_methods *meths,
2359 Error_behavior errb)
2361 if (meths->validate_matchspec_method)
2365 if (ERRB_EQ (errb, ERROR_ME))
2367 (meths->validate_matchspec_method) (matchspec);
2372 Lisp_Object opaque =
2373 make_opaque_ptr ((void *) meths->validate_matchspec_method);
2374 struct gcpro gcpro1;
2377 retval = call_with_suspended_errors
2378 ((lisp_fn_t) call_validate_matchspec_method,
2379 Qnil, Qspecifier, errb, 2, opaque, matchspec);
2381 free_opaque_ptr (opaque);
2389 maybe_signal_simple_error
2390 ("Matchspecs not allowed for this specifier type",
2391 intern (meths->name), Qspecifier, errb);
2396 DEFUN ("check-valid-specifier-matchspec", Fcheck_valid_specifier_matchspec, 2,
2398 Signal an error if MATCHSPEC is invalid for SPECIFIER-TYPE.
2399 See `specifier-matching-instance' for a description of matchspecs.
2401 (matchspec, specifier_type))
2403 struct specifier_methods *meths = decode_specifier_type (specifier_type,
2406 return check_valid_specifier_matchspec (matchspec, meths, ERROR_ME);
2409 DEFUN ("valid-specifier-matchspec-p", Fvalid_specifier_matchspec_p, 2, 2, 0, /*
2410 Return non-nil if MATCHSPEC is valid for SPECIFIER-TYPE.
2411 See `specifier-matching-instance' for a description of matchspecs.
2413 (matchspec, specifier_type))
2415 struct specifier_methods *meths = decode_specifier_type (specifier_type,
2418 return check_valid_specifier_matchspec (matchspec, meths, ERROR_ME_NOT);
2421 /* This function is purposely not callable from Lisp. If a Lisp
2422 caller wants to set a fallback, they should just set the
2426 set_specifier_fallback (Lisp_Object specifier, Lisp_Object fallback)
2428 Lisp_Specifier *sp = XSPECIFIER (specifier);
2429 assert (SPECIFIERP (fallback) ||
2430 !NILP (Fvalid_inst_list_p (fallback, Fspecifier_type (specifier))));
2431 if (SPECIFIERP (fallback))
2432 assert (EQ (Fspecifier_type (specifier), Fspecifier_type (fallback)));
2433 if (BODILY_SPECIFIER_P (sp))
2434 GHOST_SPECIFIER(sp)->fallback = fallback;
2436 sp->fallback = fallback;
2437 /* call the after-change method */
2438 MAYBE_SPECMETH (sp, after_change,
2439 (bodily_specifier (specifier), Qfallback));
2440 recompute_cached_specifier_everywhere (specifier);
2443 DEFUN ("specifier-fallback", Fspecifier_fallback, 1, 1, 0, /*
2444 Return the fallback value for SPECIFIER.
2445 Fallback values are provided by the C code for certain built-in
2446 specifiers to make sure that instancing won't fail even if all
2447 specs are removed from the specifier, or to implement simple
2448 inheritance behavior (e.g. this method is used to ensure that
2449 faces other than 'default inherit their attributes from 'default).
2450 By design, you cannot change the fallback value, and specifiers
2451 created with `make-specifier' will never have a fallback (although
2452 a similar, Lisp-accessible capability may be provided in the future
2453 to allow for inheritance).
2455 The fallback value will be an inst-list that is instanced like
2456 any other inst-list, a specifier of the same type as SPECIFIER
2457 \(results in inheritance), or nil for no fallback.
2459 When you instance a specifier, you can explicitly request that the
2460 fallback not be consulted. (The C code does this, for example, when
2461 merging faces.) See `specifier-instance'.
2465 CHECK_SPECIFIER (specifier);
2466 return Fcopy_tree (XSPECIFIER (specifier)->fallback, Qt);
2470 specifier_instance_from_inst_list (Lisp_Object specifier,
2471 Lisp_Object matchspec,
2473 Lisp_Object inst_list,
2474 Error_behavior errb, int no_quit,
2477 /* This function can GC */
2481 int count = specpdl_depth ();
2482 struct gcpro gcpro1, gcpro2;
2484 GCPRO2 (specifier, inst_list);
2486 sp = XSPECIFIER (specifier);
2487 device = DOMAIN_DEVICE (domain);
2490 /* The instantiate method is allowed to call eval. Since it
2491 is quite common for this function to get called from somewhere in
2492 redisplay we need to make sure that quits are ignored. Otherwise
2493 Fsignal will abort. */
2494 specbind (Qinhibit_quit, Qt);
2496 LIST_LOOP (rest, inst_list)
2498 Lisp_Object tagged_inst = XCAR (rest);
2499 Lisp_Object tag_set = XCAR (tagged_inst);
2501 if (device_matches_specifier_tag_set_p (device, tag_set))
2503 Lisp_Object val = XCDR (tagged_inst);
2505 if (HAS_SPECMETH_P (sp, instantiate))
2506 val = call_with_suspended_errors
2507 ((lisp_fn_t) RAW_SPECMETH (sp, instantiate),
2508 Qunbound, Qspecifier, errb, 5, specifier,
2509 matchspec, domain, val, depth);
2511 if (!UNBOUNDP (val))
2513 unbind_to (count, Qnil);
2520 unbind_to (count, Qnil);
2525 /* Given a SPECIFIER and a DOMAIN, return a specific instance for that
2526 specifier. Try to find one by checking the specifier types from most
2527 specific (buffer) to most general (global). If we find an instance,
2528 return it. Otherwise return Qunbound. */
2530 #define CHECK_INSTANCE_ENTRY(key, matchspec, type) do { \
2531 Lisp_Object *CIE_inst_list = \
2532 specifier_get_inst_list (specifier, key, type); \
2533 if (CIE_inst_list) \
2535 Lisp_Object CIE_val = \
2536 specifier_instance_from_inst_list (specifier, matchspec, \
2537 domain, *CIE_inst_list, \
2538 errb, no_quit, depth); \
2539 if (!UNBOUNDP (CIE_val)) \
2544 /* We accept any window, frame or device domain and do our checking
2545 starting from as specific a locale type as we can determine from the
2546 domain we are passed and going on up through as many other locale types
2547 as we can determine. In practice, when called from redisplay the
2548 arg will usually be a window and occasionally a frame. If
2549 triggered by a user call, who knows what it will usually be. */
2551 specifier_instance (Lisp_Object specifier, Lisp_Object matchspec,
2552 Lisp_Object domain, Error_behavior errb, int no_quit,
2553 int no_fallback, Lisp_Object depth)
2555 Lisp_Object buffer = Qnil;
2556 Lisp_Object window = Qnil;
2557 Lisp_Object frame = Qnil;
2558 Lisp_Object device = Qnil;
2559 Lisp_Object tag = Qnil; /* #### currently unused */
2560 Lisp_Specifier *sp = XSPECIFIER (specifier);
2562 /* Attempt to determine buffer, window, frame, and device from the
2564 /* #### get image instances out of domains! */
2565 if (IMAGE_INSTANCEP (domain))
2566 window = DOMAIN_WINDOW (domain);
2567 else if (WINDOWP (domain))
2569 else if (FRAMEP (domain))
2571 else if (DEVICEP (domain))
2574 /* dmoore writes: [dammit, this should just signal an error or something
2577 No. Errors are handled in Lisp primitives implementation.
2578 Invalid domain is a design error here - kkm. */
2581 if (NILP (buffer) && !NILP (window))
2582 buffer = WINDOW_BUFFER (XWINDOW (window));
2583 if (NILP (frame) && !NILP (window))
2584 frame = XWINDOW (window)->frame;
2586 /* frame had better exist; if device is undeterminable, something
2587 really went wrong. */
2588 device = FRAME_DEVICE (XFRAME (frame));
2590 /* device had better be determined by now; abort if not. */
2591 tag = DEVICE_CLASS (XDEVICE (device));
2593 depth = make_int (1 + XINT (depth));
2594 if (XINT (depth) > 20)
2596 maybe_error (Qspecifier, errb, "Apparent loop in specifier inheritance");
2597 /* The specification is fucked; at least try the fallback
2598 (which better not be fucked, because it's not changeable
2605 /* First see if we can generate one from the window specifiers. */
2607 CHECK_INSTANCE_ENTRY (window, matchspec, LOCALE_WINDOW);
2609 /* Next see if we can generate one from the buffer specifiers. */
2611 CHECK_INSTANCE_ENTRY (buffer, matchspec, LOCALE_BUFFER);
2613 /* Next see if we can generate one from the frame specifiers. */
2615 CHECK_INSTANCE_ENTRY (frame, matchspec, LOCALE_FRAME);
2617 /* If we still haven't succeeded try with the device specifiers. */
2618 CHECK_INSTANCE_ENTRY (device, matchspec, LOCALE_DEVICE);
2620 /* Last and least try the global specifiers. */
2621 CHECK_INSTANCE_ENTRY (Qglobal, matchspec, LOCALE_GLOBAL);
2624 /* We're out of specifiers and we still haven't generated an
2625 instance. At least try the fallback ... If this fails,
2626 then we just return Qunbound. */
2628 if (no_fallback || NILP (sp->fallback))
2629 /* I said, I don't want the fallbacks. */
2632 if (SPECIFIERP (sp->fallback))
2634 /* If you introduced loops in the default specifier chain,
2635 then you're fucked, so you better not do this. */
2636 specifier = sp->fallback;
2637 sp = XSPECIFIER (specifier);
2641 assert (CONSP (sp->fallback));
2642 return specifier_instance_from_inst_list (specifier, matchspec, domain,
2643 sp->fallback, errb, no_quit,
2646 #undef CHECK_INSTANCE_ENTRY
2649 specifier_instance_no_quit (Lisp_Object specifier, Lisp_Object matchspec,
2650 Lisp_Object domain, Error_behavior errb,
2651 int no_fallback, Lisp_Object depth)
2653 return specifier_instance (specifier, matchspec, domain, errb,
2654 1, no_fallback, depth);
2657 DEFUN ("specifier-instance", Fspecifier_instance, 1, 4, 0, /*
2658 Instantiate SPECIFIER (return its value) in DOMAIN.
2659 If no instance can be generated for this domain, return DEFAULT.
2661 DOMAIN should be a window, frame, or device. Other values that are legal
2662 as a locale (e.g. a buffer) are not valid as a domain because they do not
2663 provide enough information to identify a particular device (see
2664 `valid-specifier-domain-p'). DOMAIN defaults to the selected window
2667 "Instantiating" a specifier in a particular domain means determining
2668 the specifier's "value" in that domain. This is accomplished by
2669 searching through the specifications in the specifier that correspond
2670 to all locales that can be derived from the given domain, from specific
2671 to general. In most cases, the domain is an Emacs window. In that case
2672 specifications are searched for as follows:
2674 1. A specification whose locale is the window itself;
2675 2. A specification whose locale is the window's buffer;
2676 3. A specification whose locale is the window's frame;
2677 4. A specification whose locale is the window's frame's device;
2678 5. A specification whose locale is 'global.
2680 If all of those fail, then the C-code-provided fallback value for
2681 this specifier is consulted (see `specifier-fallback'). If it is
2682 an inst-list, then this function attempts to instantiate that list
2683 just as when a specification is located in the first five steps above.
2684 If the fallback is a specifier, `specifier-instance' is called
2685 recursively on this specifier and the return value used. Note,
2686 however, that if the optional argument NO-FALLBACK is non-nil,
2687 the fallback value will not be consulted.
2689 Note that there may be more than one specification matching a particular
2690 locale; all such specifications are considered before looking for any
2691 specifications for more general locales. Any particular specification
2692 that is found may be rejected because its tag set does not match the
2693 device being instantiated over, or because the specification is not
2694 valid for the device of the given domain (e.g. the font or color name
2695 does not exist for this particular X server).
2697 The returned value is dependent on the type of specifier. For example,
2698 for a font specifier (as returned by the `face-font' function), the returned
2699 value will be a font-instance object. For glyphs, the returned value
2700 will be a string, pixmap, or subwindow.
2702 See also `specifier-matching-instance'.
2704 (specifier, domain, default_, no_fallback))
2706 Lisp_Object instance;
2708 CHECK_SPECIFIER (specifier);
2709 domain = decode_domain (domain);
2711 instance = specifier_instance (specifier, Qunbound, domain, ERROR_ME, 0,
2712 !NILP (no_fallback), Qzero);
2713 return UNBOUNDP (instance) ? default_ : instance;
2716 DEFUN ("specifier-matching-instance", Fspecifier_matching_instance, 2, 5, 0, /*
2717 Return an instance for SPECIFIER in DOMAIN that matches MATCHSPEC.
2718 If no instance can be generated for this domain, return DEFAULT.
2720 This function is identical to `specifier-instance' except that a
2721 specification will only be considered if it matches MATCHSPEC.
2722 The definition of "match", and allowed values for MATCHSPEC, are
2723 dependent on the particular type of specifier. Here are some examples:
2725 -- For chartable (e.g. display table) specifiers, MATCHSPEC should be a
2726 character, and the specification (a chartable) must give a value for
2727 that character in order to be considered. This allows you to specify,
2728 e.g., a buffer-local display table that only gives values for particular
2729 characters. All other characters are handled as if the buffer-local
2730 display table is not there. (Chartable specifiers are not yet
2733 -- For font specifiers, MATCHSPEC should be a charset, and the specification
2734 (a font string) must have a registry that matches the charset's registry.
2735 (This only makes sense with Mule support.) This makes it easy to choose a
2736 font that can display a particular character. (This is what redisplay
2739 (specifier, matchspec, domain, default_, no_fallback))
2741 Lisp_Object instance;
2743 CHECK_SPECIFIER (specifier);
2744 check_valid_specifier_matchspec (matchspec, XSPECIFIER (specifier)->methods,
2746 domain = decode_domain (domain);
2748 instance = specifier_instance (specifier, matchspec, domain, ERROR_ME,
2749 0, !NILP (no_fallback), Qzero);
2750 return UNBOUNDP (instance) ? default_ : instance;
2753 DEFUN ("specifier-instance-from-inst-list", Fspecifier_instance_from_inst_list,
2755 Attempt to convert a particular inst-list into an instance.
2756 This attempts to instantiate INST-LIST in the given DOMAIN,
2757 as if INST-LIST existed in a specification in SPECIFIER. If
2758 the instantiation fails, DEFAULT is returned. In most circumstances,
2759 you should not use this function; use `specifier-instance' instead.
2761 (specifier, domain, inst_list, default_))
2763 Lisp_Object val = Qunbound;
2764 Lisp_Specifier *sp = XSPECIFIER (specifier);
2765 struct gcpro gcpro1;
2766 Lisp_Object built_up_list = Qnil;
2768 CHECK_SPECIFIER (specifier);
2769 check_valid_domain (domain);
2770 check_valid_inst_list (inst_list, sp->methods, ERROR_ME);
2771 GCPRO1 (built_up_list);
2772 built_up_list = build_up_processed_list (specifier, domain, inst_list);
2773 if (!NILP (built_up_list))
2774 val = specifier_instance_from_inst_list (specifier, Qunbound, domain,
2775 built_up_list, ERROR_ME,
2778 return UNBOUNDP (val) ? default_ : val;
2781 DEFUN ("specifier-matching-instance-from-inst-list",
2782 Fspecifier_matching_instance_from_inst_list,
2784 Attempt to convert a particular inst-list into an instance.
2785 This attempts to instantiate INST-LIST in the given DOMAIN
2786 \(as if INST-LIST existed in a specification in SPECIFIER),
2787 matching the specifications against MATCHSPEC.
2789 This function is analogous to `specifier-instance-from-inst-list'
2790 but allows for specification-matching as in `specifier-matching-instance'.
2791 See that function for a description of exactly how the matching process
2794 (specifier, matchspec, domain, inst_list, default_))
2796 Lisp_Object val = Qunbound;
2797 Lisp_Specifier *sp = XSPECIFIER (specifier);
2798 struct gcpro gcpro1;
2799 Lisp_Object built_up_list = Qnil;
2801 CHECK_SPECIFIER (specifier);
2802 check_valid_specifier_matchspec (matchspec, XSPECIFIER (specifier)->methods,
2804 check_valid_domain (domain);
2805 check_valid_inst_list (inst_list, sp->methods, ERROR_ME);
2806 GCPRO1 (built_up_list);
2807 built_up_list = build_up_processed_list (specifier, domain, inst_list);
2808 if (!NILP (built_up_list))
2809 val = specifier_instance_from_inst_list (specifier, matchspec, domain,
2810 built_up_list, ERROR_ME,
2813 return UNBOUNDP (val) ? default_ : val;
2817 /************************************************************************/
2818 /* Caching in the struct window or frame */
2819 /************************************************************************/
2821 /* Either STRUCT_WINDOW_OFFSET or STRUCT_FRAME_OFFSET can be 0 to indicate
2822 no caching in that sort of object. */
2824 /* #### It would be nice if the specifier caching automatically knew
2825 about specifier fallbacks, so we didn't have to do it ourselves. */
2828 set_specifier_caching (Lisp_Object specifier, int struct_window_offset,
2829 void (*value_changed_in_window)
2830 (Lisp_Object specifier, struct window *w,
2831 Lisp_Object oldval),
2832 int struct_frame_offset,
2833 void (*value_changed_in_frame)
2834 (Lisp_Object specifier, struct frame *f,
2835 Lisp_Object oldval),
2836 int always_recompute)
2838 Lisp_Specifier *sp = XSPECIFIER (specifier);
2839 assert (!GHOST_SPECIFIER_P (sp));
2842 sp->caching = xnew_and_zero (struct specifier_caching);
2843 sp->caching->offset_into_struct_window = struct_window_offset;
2844 sp->caching->value_changed_in_window = value_changed_in_window;
2845 sp->caching->offset_into_struct_frame = struct_frame_offset;
2846 sp->caching->value_changed_in_frame = value_changed_in_frame;
2847 sp->caching->always_recompute = always_recompute;
2848 Vcached_specifiers = Fcons (specifier, Vcached_specifiers);
2849 if (BODILY_SPECIFIER_P (sp))
2850 GHOST_SPECIFIER(sp)->caching = sp->caching;
2851 recompute_cached_specifier_everywhere (specifier);
2855 recompute_one_cached_specifier_in_window (Lisp_Object specifier,
2859 Lisp_Object newval, *location, oldval;
2861 assert (!GHOST_SPECIFIER_P (XSPECIFIER (specifier)));
2863 XSETWINDOW (window, w);
2865 newval = specifier_instance (specifier, Qunbound, window, ERROR_ME_WARN,
2867 /* If newval ended up Qunbound, then the calling functions
2868 better be able to deal. If not, set a default so this
2869 never happens or correct it in the value_changed_in_window
2871 location = (Lisp_Object *)
2872 ((char *) w + XSPECIFIER (specifier)->caching->offset_into_struct_window);
2873 /* #### What's the point of this check, other than to optimize image
2874 instance instantiation? Unless you specify a caching instantiate
2875 method the instantiation that specifier_instance will do will
2876 always create a new copy. Thus EQ will always fail. Unfortunately
2877 calling equal is no good either as this doesn't take into account
2878 things attached to the specifier - for instance strings on
2880 if (!EQ (newval, *location) || XSPECIFIER (specifier)->caching->always_recompute)
2884 (XSPECIFIER (specifier)->caching->value_changed_in_window)
2885 (specifier, w, oldval);
2890 recompute_one_cached_specifier_in_frame (Lisp_Object specifier,
2894 Lisp_Object newval, *location, oldval;
2896 assert (!GHOST_SPECIFIER_P (XSPECIFIER (specifier)));
2898 XSETFRAME (frame, f);
2900 newval = specifier_instance (specifier, Qunbound, frame, ERROR_ME_WARN,
2902 /* If newval ended up Qunbound, then the calling functions
2903 better be able to deal. If not, set a default so this
2904 never happens or correct it in the value_changed_in_frame
2906 location = (Lisp_Object *)
2907 ((char *) f + XSPECIFIER (specifier)->caching->offset_into_struct_frame);
2908 if (!EQ (newval, *location) || XSPECIFIER (specifier)->caching->always_recompute)
2912 (XSPECIFIER (specifier)->caching->value_changed_in_frame)
2913 (specifier, f, oldval);
2918 recompute_all_cached_specifiers_in_window (struct window *w)
2922 LIST_LOOP (rest, Vcached_specifiers)
2924 Lisp_Object specifier = XCAR (rest);
2925 if (XSPECIFIER (specifier)->caching->offset_into_struct_window)
2926 recompute_one_cached_specifier_in_window (specifier, w);
2931 recompute_all_cached_specifiers_in_frame (struct frame *f)
2935 LIST_LOOP (rest, Vcached_specifiers)
2937 Lisp_Object specifier = XCAR (rest);
2938 if (XSPECIFIER (specifier)->caching->offset_into_struct_frame)
2939 recompute_one_cached_specifier_in_frame (specifier, f);
2944 recompute_cached_specifier_everywhere_mapfun (struct window *w,
2947 Lisp_Object specifier = Qnil;
2949 VOID_TO_LISP (specifier, closure);
2950 recompute_one_cached_specifier_in_window (specifier, w);
2955 recompute_cached_specifier_everywhere (Lisp_Object specifier)
2957 Lisp_Object frmcons, devcons, concons;
2959 specifier = bodily_specifier (specifier);
2961 if (!XSPECIFIER (specifier)->caching)
2964 if (XSPECIFIER (specifier)->caching->offset_into_struct_window)
2966 FRAME_LOOP_NO_BREAK (frmcons, devcons, concons)
2967 map_windows (XFRAME (XCAR (frmcons)),
2968 recompute_cached_specifier_everywhere_mapfun,
2969 LISP_TO_VOID (specifier));
2972 if (XSPECIFIER (specifier)->caching->offset_into_struct_frame)
2974 FRAME_LOOP_NO_BREAK (frmcons, devcons, concons)
2975 recompute_one_cached_specifier_in_frame (specifier,
2976 XFRAME (XCAR (frmcons)));
2980 DEFUN ("set-specifier-dirty-flag", Fset_specifier_dirty_flag, 1, 1, 0, /*
2981 Force recomputation of any caches associated with SPECIFIER.
2982 Note that this automatically happens whenever you change a specification
2983 in SPECIFIER; you do not have to call this function then.
2984 One example of where this function is useful is when you have a
2985 toolbar button whose `active-p' field is an expression to be
2986 evaluated. Calling `set-specifier-dirty-flag' on the
2987 toolbar specifier will force the `active-p' fields to be
2992 CHECK_SPECIFIER (specifier);
2993 recompute_cached_specifier_everywhere (specifier);
2998 /************************************************************************/
2999 /* Generic specifier type */
3000 /************************************************************************/
3002 DEFINE_SPECIFIER_TYPE (generic);
3006 /* This is the string that used to be in `generic-specifier-p'.
3007 The idea is good, but it doesn't quite work in the form it's
3008 in. (One major problem is that validating an instantiator
3009 is supposed to require only that the specifier type is passed,
3010 while with this approach the actual specifier is needed.)
3012 What really needs to be done is to write a function
3013 `make-specifier-type' that creates new specifier types.
3015 #### [I'll look into this for 19.14.] Well, sometime. (Currently
3016 May 2000, 21.2 is in development. 19.14 was released in June 1996.) */
3018 "A generic specifier is a generalized kind of specifier with user-defined\n"
3019 "semantics. The instantiator can be any kind of Lisp object, and the\n"
3020 "instance computed from it is likewise any kind of Lisp object. The\n"
3021 "SPECIFIER-DATA should be an alist of methods governing how the specifier\n"
3022 "works. All methods are optional, and reasonable default methods will be\n"
3023 "provided. Currently there are two defined methods: 'instantiate and\n"
3026 "'instantiate specifies how to do the instantiation; if omitted, the\n"
3027 "instantiator itself is simply returned as the instance. The method\n"
3028 "should be a function that accepts three parameters (a specifier, the\n"
3029 "instantiator that matched the domain being instantiated over, and that\n"
3030 "domain), and should return a one-element list containing the instance,\n"
3031 "or nil if no instance exists. Note that the domain passed to this function\n"
3032 "is the domain being instantiated over, which may not be the same as the\n"
3033 "locale contained in the specification corresponding to the instantiator\n"
3034 "(for example, the domain being instantiated over could be a window, but\n"
3035 "the locale corresponding to the passed instantiator could be the window's\n"
3036 "buffer or frame).\n"
3038 "'validate specifies whether a given instantiator is valid; if omitted,\n"
3039 "all instantiators are considered valid. It should be a function of\n"
3040 "two arguments: an instantiator and a flag CAN-SIGNAL-ERROR. If this\n"
3041 "flag is false, the function must simply return t or nil indicating\n"
3042 "whether the instantiator is valid. If this flag is true, the function\n"
3043 "is free to signal an error if it encounters an invalid instantiator\n"
3044 "(this can be useful for issuing a specific error about exactly why the\n"
3045 "instantiator is valid). It can also return nil to indicate an invalid\n"
3046 "instantiator; in this case, a general error will be signalled."
3050 DEFUN ("generic-specifier-p", Fgeneric_specifier_p, 1, 1, 0, /*
3051 Return non-nil if OBJECT is a generic specifier.
3053 See `make-generic-specifier' for a description of possible generic
3058 return GENERIC_SPECIFIERP (object) ? Qt : Qnil;
3062 /************************************************************************/
3063 /* Integer specifier type */
3064 /************************************************************************/
3066 DEFINE_SPECIFIER_TYPE (integer);
3069 integer_validate (Lisp_Object instantiator)
3071 CHECK_INT (instantiator);
3074 DEFUN ("integer-specifier-p", Finteger_specifier_p, 1, 1, 0, /*
3075 Return non-nil if OBJECT is an integer specifier.
3077 See `make-integer-specifier' for a description of possible integer
3082 return INTEGER_SPECIFIERP (object) ? Qt : Qnil;
3085 /************************************************************************/
3086 /* Non-negative-integer specifier type */
3087 /************************************************************************/
3089 DEFINE_SPECIFIER_TYPE (natnum);
3092 natnum_validate (Lisp_Object instantiator)
3094 CHECK_NATNUM (instantiator);
3097 DEFUN ("natnum-specifier-p", Fnatnum_specifier_p, 1, 1, 0, /*
3098 Return non-nil if OBJECT is a natnum (non-negative-integer) specifier.
3100 See `make-natnum-specifier' for a description of possible natnum
3105 return NATNUM_SPECIFIERP (object) ? Qt : Qnil;
3108 /************************************************************************/
3109 /* Boolean specifier type */
3110 /************************************************************************/
3112 DEFINE_SPECIFIER_TYPE (boolean);
3115 boolean_validate (Lisp_Object instantiator)
3117 if (!EQ (instantiator, Qt) && !EQ (instantiator, Qnil))
3118 signal_type_error (Qspecifier_argument_error, "Must be t or nil",
3122 DEFUN ("boolean-specifier-p", Fboolean_specifier_p, 1, 1, 0, /*
3123 Return non-nil if OBJECT is a boolean specifier.
3125 See `make-boolean-specifier' for a description of possible boolean
3130 return BOOLEAN_SPECIFIERP (object) ? Qt : Qnil;
3133 /************************************************************************/
3134 /* Display table specifier type */
3135 /************************************************************************/
3137 DEFINE_SPECIFIER_TYPE (display_table);
3139 #define VALID_SINGLE_DISPTABLE_INSTANTIATOR_P(instantiator) \
3140 (VECTORP (instantiator) \
3141 || (CHAR_TABLEP (instantiator) \
3142 && (XCHAR_TABLE_TYPE (instantiator) == CHAR_TABLE_TYPE_CHAR \
3143 || XCHAR_TABLE_TYPE (instantiator) == CHAR_TABLE_TYPE_GENERIC)) \
3144 || RANGE_TABLEP (instantiator))
3147 display_table_validate (Lisp_Object instantiator)
3149 if (NILP (instantiator))
3152 else if (CONSP (instantiator))
3155 EXTERNAL_LIST_LOOP (tail, instantiator)
3157 Lisp_Object car = XCAR (tail);
3158 if (!VALID_SINGLE_DISPTABLE_INSTANTIATOR_P (car))
3164 if (!VALID_SINGLE_DISPTABLE_INSTANTIATOR_P (instantiator))
3167 dead_wrong_type_argument
3168 (display_table_specifier_methods->predicate_symbol,
3174 DEFUN ("display-table-specifier-p", Fdisplay_table_specifier_p, 1, 1, 0, /*
3175 Return non-nil if OBJECT is a display-table specifier.
3177 See `current-display-table' for a description of possible display-table
3182 return DISPLAYTABLE_SPECIFIERP (object) ? Qt : Qnil;
3186 /************************************************************************/
3187 /* Initialization */
3188 /************************************************************************/
3191 syms_of_specifier (void)
3193 INIT_LRECORD_IMPLEMENTATION (specifier);
3195 DEFSYMBOL (Qspecifierp);
3197 DEFSYMBOL (Qconsole_type);
3198 DEFSYMBOL (Qdevice_class);
3200 /* specifier types defined in general.c. */
3202 DEFSUBR (Fvalid_specifier_type_p);
3203 DEFSUBR (Fspecifier_type_list);
3204 DEFSUBR (Fmake_specifier);
3205 DEFSUBR (Fspecifierp);
3206 DEFSUBR (Fspecifier_type);
3208 DEFSUBR (Fvalid_specifier_locale_p);
3209 DEFSUBR (Fvalid_specifier_domain_p);
3210 DEFSUBR (Fvalid_specifier_locale_type_p);
3211 DEFSUBR (Fspecifier_locale_type_from_locale);
3213 DEFSUBR (Fvalid_specifier_tag_p);
3214 DEFSUBR (Fvalid_specifier_tag_set_p);
3215 DEFSUBR (Fcanonicalize_tag_set);
3216 DEFSUBR (Fdevice_matches_specifier_tag_set_p);
3217 DEFSUBR (Fdefine_specifier_tag);
3218 DEFSUBR (Fdevice_matching_specifier_tag_list);
3219 DEFSUBR (Fspecifier_tag_list);
3220 DEFSUBR (Fspecifier_tag_predicate);
3222 DEFSUBR (Fcheck_valid_instantiator);
3223 DEFSUBR (Fvalid_instantiator_p);
3224 DEFSUBR (Fcheck_valid_inst_list);
3225 DEFSUBR (Fvalid_inst_list_p);
3226 DEFSUBR (Fcheck_valid_spec_list);
3227 DEFSUBR (Fvalid_spec_list_p);
3228 DEFSUBR (Fadd_spec_to_specifier);
3229 DEFSUBR (Fadd_spec_list_to_specifier);
3230 DEFSUBR (Fspecifier_spec_list);
3231 DEFSUBR (Fspecifier_specs);
3232 DEFSUBR (Fremove_specifier);
3233 DEFSUBR (Fcopy_specifier);
3235 DEFSUBR (Fcheck_valid_specifier_matchspec);
3236 DEFSUBR (Fvalid_specifier_matchspec_p);
3237 DEFSUBR (Fspecifier_fallback);
3238 DEFSUBR (Fspecifier_instance);
3239 DEFSUBR (Fspecifier_matching_instance);
3240 DEFSUBR (Fspecifier_instance_from_inst_list);
3241 DEFSUBR (Fspecifier_matching_instance_from_inst_list);
3242 DEFSUBR (Fset_specifier_dirty_flag);
3244 DEFSUBR (Fgeneric_specifier_p);
3245 DEFSUBR (Finteger_specifier_p);
3246 DEFSUBR (Fnatnum_specifier_p);
3247 DEFSUBR (Fboolean_specifier_p);
3248 DEFSUBR (Fdisplay_table_specifier_p);
3250 /* Symbols pertaining to specifier creation. Specifiers are created
3251 in the syms_of() functions. */
3253 /* locales are defined in general.c. */
3255 /* some how-to-add flags in general.c. */
3256 DEFSYMBOL (Qremove_tag_set_prepend);
3257 DEFSYMBOL (Qremove_tag_set_append);
3258 DEFSYMBOL (Qremove_locale);
3259 DEFSYMBOL (Qremove_locale_type);
3261 DEFERROR_STANDARD (Qspecifier_syntax_error, Qsyntax_error);
3262 DEFERROR_STANDARD (Qspecifier_argument_error, Qinvalid_argument);
3263 DEFERROR_STANDARD (Qspecifier_change_error, Qinvalid_change);
3267 specifier_type_create (void)
3269 the_specifier_type_entry_dynarr = Dynarr_new (specifier_type_entry);
3270 dumpstruct (&the_specifier_type_entry_dynarr, &sted_description);
3272 Vspecifier_type_list = Qnil;
3273 staticpro (&Vspecifier_type_list);
3275 INITIALIZE_SPECIFIER_TYPE (generic, "generic", "generic-specifier-p");
3277 INITIALIZE_SPECIFIER_TYPE (integer, "integer", "integer-specifier-p");
3279 SPECIFIER_HAS_METHOD (integer, validate);
3281 INITIALIZE_SPECIFIER_TYPE (natnum, "natnum", "natnum-specifier-p");
3283 SPECIFIER_HAS_METHOD (natnum, validate);
3285 INITIALIZE_SPECIFIER_TYPE (boolean, "boolean", "boolean-specifier-p");
3287 SPECIFIER_HAS_METHOD (boolean, validate);
3289 INITIALIZE_SPECIFIER_TYPE (display_table, "display-table",
3292 SPECIFIER_HAS_METHOD (display_table, validate);
3296 reinit_specifier_type_create (void)
3298 REINITIALIZE_SPECIFIER_TYPE (generic);
3299 REINITIALIZE_SPECIFIER_TYPE (integer);
3300 REINITIALIZE_SPECIFIER_TYPE (natnum);
3301 REINITIALIZE_SPECIFIER_TYPE (boolean);
3302 REINITIALIZE_SPECIFIER_TYPE (display_table);
3306 vars_of_specifier (void)
3308 Vcached_specifiers = Qnil;
3309 staticpro (&Vcached_specifiers);
3311 /* Do NOT mark through this, or specifiers will never be GC'd.
3312 This is the same deal as for weak hash tables. */
3313 Vall_specifiers = Qnil;
3314 pdump_wire_list (&Vall_specifiers);
3316 Vuser_defined_tags = Qnil;
3317 staticpro (&Vuser_defined_tags);
3319 Vunlock_ghost_specifiers = Qnil;
3320 staticpro (&Vunlock_ghost_specifiers);