1 /* Specifier implementation
2 Copyright (C) 1994, 1995 Board of Trustees, University of Illinois.
3 Copyright (C) 1995, 1996 Ben Wing.
4 Copyright (C) 1995 Sun Microsystems, Inc.
6 This file is part of XEmacs.
8 XEmacs is free software; you can redistribute it and/or modify it
9 under the terms of the GNU General Public License as published by the
10 Free Software Foundation; either version 2, or (at your option) any
13 XEmacs is distributed in the hope that it will be useful, but WITHOUT
14 ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or
15 FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
18 You should have received a copy of the GNU General Public License
19 along with XEmacs; see the file COPYING. If not, write to
20 the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
21 Boston, MA 02111-1307, USA. */
23 /* Synched up with: Not in FSF. */
25 /* Design by Ben Wing;
26 Original version by Chuck Thompson;
27 rewritten by Ben Wing;
28 Magic specifiers by Kirill Katsnelson;
38 #include "specifier.h"
43 Lisp_Object Qspecifierp;
44 Lisp_Object Qprepend, Qremove_tag_set_prepend, Qremove_tag_set_append;
45 Lisp_Object Qremove_locale, Qremove_locale_type, Qremove_all;
46 Lisp_Object Qfallback;
48 /* Qinteger, Qboolean, Qgeneric defined in general.c. */
51 Lisp_Object Qconsole_type, Qdevice_class;
53 static Lisp_Object Vuser_defined_tags;
55 typedef struct specifier_type_entry specifier_type_entry;
56 struct specifier_type_entry
59 struct specifier_methods *meths;
64 Dynarr_declare (specifier_type_entry);
65 } specifier_type_entry_dynarr;
67 static specifier_type_entry_dynarr *the_specifier_type_entry_dynarr;
69 static const struct lrecord_description ste_description_1[] = {
70 { XD_LISP_OBJECT, offsetof (specifier_type_entry, symbol) },
71 { XD_STRUCT_PTR, offsetof (specifier_type_entry, meths), 1, &specifier_methods_description },
75 static const struct struct_description ste_description = {
76 sizeof (specifier_type_entry),
80 static const struct lrecord_description sted_description_1[] = {
81 XD_DYNARR_DESC (specifier_type_entry_dynarr, &ste_description),
85 static const struct struct_description sted_description = {
86 sizeof (specifier_type_entry_dynarr),
90 static Lisp_Object Vspecifier_type_list;
92 static Lisp_Object Vcached_specifiers;
93 /* Do NOT mark through this, or specifiers will never be GC'd. */
94 static Lisp_Object Vall_specifiers;
96 static Lisp_Object Vunlock_ghost_specifiers;
98 /* #### The purpose of this is to check for inheritance loops
99 in specifiers that can inherit from other specifiers, but it's
102 #### Look into this for 19.14. */
103 /* static Lisp_Object_dynarr current_specifiers; */
105 static void recompute_cached_specifier_everywhere (Lisp_Object specifier);
107 EXFUN (Fspecifier_specs, 4);
108 EXFUN (Fremove_specifier, 4);
111 /************************************************************************/
112 /* Specifier object methods */
113 /************************************************************************/
115 /* Remove dead objects from the specified assoc list. */
118 cleanup_assoc_list (Lisp_Object list)
120 Lisp_Object loop, prev, retval;
122 loop = retval = list;
127 Lisp_Object entry = XCAR (loop);
128 Lisp_Object key = XCAR (entry);
130 /* remember, dead windows can become alive again. */
131 if (!WINDOWP (key) && object_dead_p (key))
135 /* Removing the head. */
136 retval = XCDR (retval);
140 Fsetcdr (prev, XCDR (loop));
152 /* Remove dead objects from the various lists so that they
153 don't keep getting marked as long as this specifier exists and
154 therefore wasting memory. */
157 cleanup_specifiers (void)
161 for (rest = Vall_specifiers;
163 rest = XSPECIFIER (rest)->next_specifier)
165 Lisp_Specifier *sp = XSPECIFIER (rest);
166 /* This effectively changes the specifier specs.
167 However, there's no need to call
168 recompute_cached_specifier_everywhere() or the
169 after-change methods because the only specs we
170 are removing are for dead objects, and they can
171 never have any effect on the specifier values:
172 specifiers can only be instantiated over live
173 objects, and you can't derive a dead object
175 sp->device_specs = cleanup_assoc_list (sp->device_specs);
176 sp->frame_specs = cleanup_assoc_list (sp->frame_specs);
177 sp->buffer_specs = cleanup_assoc_list (sp->buffer_specs);
178 /* windows are handled specially because dead windows
179 can be resurrected */
184 kill_specifier_buffer_locals (Lisp_Object buffer)
188 for (rest = Vall_specifiers;
190 rest = XSPECIFIER (rest)->next_specifier)
192 Lisp_Specifier *sp = XSPECIFIER (rest);
194 /* Make sure we're actually going to be changing something.
195 Fremove_specifier() always calls
196 recompute_cached_specifier_everywhere() (#### but should
197 be smarter about this). */
198 if (!NILP (assq_no_quit (buffer, sp->buffer_specs)))
199 Fremove_specifier (rest, buffer, Qnil, Qnil);
204 mark_specifier (Lisp_Object obj)
206 Lisp_Specifier *specifier = XSPECIFIER (obj);
208 mark_object (specifier->global_specs);
209 mark_object (specifier->device_specs);
210 mark_object (specifier->frame_specs);
211 mark_object (specifier->window_specs);
212 mark_object (specifier->buffer_specs);
213 mark_object (specifier->magic_parent);
214 mark_object (specifier->fallback);
215 if (!GHOST_SPECIFIER_P (XSPECIFIER (obj)))
216 MAYBE_SPECMETH (specifier, mark, (obj));
220 /* The idea here is that the specifier specs point to locales
221 (windows, buffers, frames, and devices), and we want to make sure
222 that the specs disappear automatically when the associated locale
223 is no longer in use. For all but windows, "no longer in use"
224 corresponds exactly to when the object is deleted (non-deleted
225 objects are always held permanently in special lists, and deleted
226 objects are never on these lists and never reusable). To handle
227 this, we just have cleanup_specifiers() called periodically
228 (at the beginning of garbage collection); it removes all dead
231 For windows, however, it's trickier because dead objects can be
232 converted to live ones again if the dead object is in a window
233 configuration. Therefore, for windows, "no longer in use"
234 corresponds to when the window object is garbage-collected.
235 We now use weak lists for this purpose.
240 prune_specifiers (void)
242 Lisp_Object rest, prev = Qnil;
244 for (rest = Vall_specifiers;
246 rest = XSPECIFIER (rest)->next_specifier)
248 if (! marked_p (rest))
250 Lisp_Specifier* sp = XSPECIFIER (rest);
251 /* A bit of assertion that we're removing both parts of the
252 magic one altogether */
253 assert (!MAGIC_SPECIFIER_P(sp)
254 || (BODILY_SPECIFIER_P(sp) && marked_p (sp->fallback))
255 || (GHOST_SPECIFIER_P(sp) && marked_p (sp->magic_parent)));
256 /* This specifier is garbage. Remove it from the list. */
258 Vall_specifiers = sp->next_specifier;
260 XSPECIFIER (prev)->next_specifier = sp->next_specifier;
268 print_specifier (Lisp_Object obj, Lisp_Object printcharfun, int escapeflag)
270 Lisp_Specifier *sp = XSPECIFIER (obj);
272 int count = specpdl_depth ();
273 Lisp_Object the_specs;
276 error ("printing unreadable object #<%s-specifier 0x%x>",
277 sp->methods->name, sp->header.uid);
279 sprintf (buf, "#<%s-specifier global=", sp->methods->name);
280 write_c_string (buf, printcharfun);
281 specbind (Qprint_string_length, make_int (100));
282 specbind (Qprint_length, make_int (5));
283 the_specs = Fspecifier_specs (obj, Qglobal, Qnil, Qnil);
284 if (NILP (the_specs))
285 /* there are no global specs */
286 write_c_string ("<unspecified>", printcharfun);
288 print_internal (the_specs, printcharfun, 1);
289 if (!NILP (sp->fallback))
291 write_c_string (" fallback=", printcharfun);
292 print_internal (sp->fallback, printcharfun, escapeflag);
294 unbind_to (count, Qnil);
295 sprintf (buf, " 0x%x>", sp->header.uid);
296 write_c_string (buf, printcharfun);
300 finalize_specifier (void *header, int for_disksave)
302 Lisp_Specifier *sp = (Lisp_Specifier *) header;
303 /* don't be snafued by the disksave finalization. */
304 if (!for_disksave && !GHOST_SPECIFIER_P(sp) && sp->caching)
312 specifier_equal (Lisp_Object obj1, Lisp_Object obj2, int depth)
314 Lisp_Specifier *s1 = XSPECIFIER (obj1);
315 Lisp_Specifier *s2 = XSPECIFIER (obj2);
317 Lisp_Object old_inhibit_quit = Vinhibit_quit;
319 /* This function can be called from within redisplay.
320 internal_equal can trigger a quit. That leads to Bad Things. */
325 (s1->methods == s2->methods &&
326 internal_equal (s1->global_specs, s2->global_specs, depth) &&
327 internal_equal (s1->device_specs, s2->device_specs, depth) &&
328 internal_equal (s1->frame_specs, s2->frame_specs, depth) &&
329 internal_equal (s1->window_specs, s2->window_specs, depth) &&
330 internal_equal (s1->buffer_specs, s2->buffer_specs, depth) &&
331 internal_equal (s1->fallback, s2->fallback, depth));
333 if (retval && HAS_SPECMETH_P (s1, equal))
334 retval = SPECMETH (s1, equal, (obj1, obj2, depth - 1));
336 Vinhibit_quit = old_inhibit_quit;
341 specifier_hash (Lisp_Object obj, int depth)
343 Lisp_Specifier *s = XSPECIFIER (obj);
345 /* specifier hashing is a bit problematic because there are so
346 many places where data can be stored. We pick what are perhaps
347 the most likely places where interesting stuff will be. */
348 return HASH5 ((HAS_SPECMETH_P (s, hash) ?
349 SPECMETH (s, hash, (obj, depth)) : 0),
350 (unsigned long) s->methods,
351 internal_hash (s->global_specs, depth + 1),
352 internal_hash (s->frame_specs, depth + 1),
353 internal_hash (s->buffer_specs, depth + 1));
357 sizeof_specifier (const void *header)
359 if (GHOST_SPECIFIER_P ((Lisp_Specifier *) header))
360 return offsetof (Lisp_Specifier, data);
363 const Lisp_Specifier *p = (const Lisp_Specifier *) header;
364 return offsetof (Lisp_Specifier, data) + p->methods->extra_data_size;
368 static const struct lrecord_description specifier_methods_description_1[] = {
369 { XD_LISP_OBJECT, offsetof (struct specifier_methods, predicate_symbol) },
373 const struct struct_description specifier_methods_description = {
374 sizeof (struct specifier_methods),
375 specifier_methods_description_1
378 static const struct lrecord_description specifier_caching_description_1[] = {
382 static const struct struct_description specifier_caching_description = {
383 sizeof (struct specifier_caching),
384 specifier_caching_description_1
387 static const struct lrecord_description specifier_description[] = {
388 { XD_STRUCT_PTR, offsetof (Lisp_Specifier, methods), 1, &specifier_methods_description },
389 { XD_LO_LINK, offsetof (Lisp_Specifier, next_specifier) },
390 { XD_LISP_OBJECT, offsetof (Lisp_Specifier, global_specs) },
391 { XD_LISP_OBJECT, offsetof (Lisp_Specifier, device_specs) },
392 { XD_LISP_OBJECT, offsetof (Lisp_Specifier, frame_specs) },
393 { XD_LISP_OBJECT, offsetof (Lisp_Specifier, window_specs) },
394 { XD_LISP_OBJECT, offsetof (Lisp_Specifier, buffer_specs) },
395 { XD_STRUCT_PTR, offsetof (Lisp_Specifier, caching), 1, &specifier_caching_description },
396 { XD_LISP_OBJECT, offsetof (Lisp_Specifier, magic_parent) },
397 { XD_LISP_OBJECT, offsetof (Lisp_Specifier, fallback) },
401 const struct lrecord_description specifier_empty_extra_description[] = {
405 DEFINE_LRECORD_SEQUENCE_IMPLEMENTATION ("specifier", specifier,
406 mark_specifier, print_specifier,
408 specifier_equal, specifier_hash,
409 specifier_description,
413 /************************************************************************/
414 /* Creating specifiers */
415 /************************************************************************/
417 static struct specifier_methods *
418 decode_specifier_type (Lisp_Object type, Error_behavior errb)
422 for (i = 0; i < Dynarr_length (the_specifier_type_entry_dynarr); i++)
424 if (EQ (type, Dynarr_at (the_specifier_type_entry_dynarr, i).symbol))
425 return Dynarr_at (the_specifier_type_entry_dynarr, i).meths;
428 maybe_signal_simple_error ("Invalid specifier type", type,
435 valid_specifier_type_p (Lisp_Object type)
437 return decode_specifier_type (type, ERROR_ME_NOT) != 0;
440 DEFUN ("valid-specifier-type-p", Fvalid_specifier_type_p, 1, 1, 0, /*
441 Given a SPECIFIER-TYPE, return non-nil if it is valid.
442 Valid types are 'generic, 'integer, boolean, 'color, 'font, 'image,
443 'face-boolean, and 'toolbar.
447 return valid_specifier_type_p (specifier_type) ? Qt : Qnil;
450 DEFUN ("specifier-type-list", Fspecifier_type_list, 0, 0, 0, /*
451 Return a list of valid specifier types.
455 return Fcopy_sequence (Vspecifier_type_list);
459 add_entry_to_specifier_type_list (Lisp_Object symbol,
460 struct specifier_methods *meths)
462 struct specifier_type_entry entry;
464 entry.symbol = symbol;
466 Dynarr_add (the_specifier_type_entry_dynarr, entry);
467 Vspecifier_type_list = Fcons (symbol, Vspecifier_type_list);
471 make_specifier_internal (struct specifier_methods *spec_meths,
472 size_t data_size, int call_create_meth)
474 Lisp_Object specifier;
475 Lisp_Specifier *sp = (Lisp_Specifier *)
476 alloc_lcrecord (offsetof (Lisp_Specifier, data) + data_size,
479 sp->methods = spec_meths;
480 sp->global_specs = Qnil;
481 sp->device_specs = Qnil;
482 sp->frame_specs = Qnil;
483 sp->window_specs = make_weak_list (WEAK_LIST_KEY_ASSOC);
484 sp->buffer_specs = Qnil;
486 sp->magic_parent = Qnil;
488 sp->next_specifier = Vall_specifiers;
490 XSETSPECIFIER (specifier, sp);
491 Vall_specifiers = specifier;
493 if (call_create_meth)
497 MAYBE_SPECMETH (XSPECIFIER (specifier), create, (specifier));
504 make_specifier (struct specifier_methods *meths)
506 return make_specifier_internal (meths, meths->extra_data_size, 1);
510 make_magic_specifier (Lisp_Object type)
512 /* This function can GC */
513 struct specifier_methods *meths = decode_specifier_type (type, ERROR_ME);
514 Lisp_Object bodily, ghost;
517 bodily = make_specifier (meths);
519 ghost = make_specifier_internal (meths, 0, 0);
522 /* Connect guys together */
523 XSPECIFIER(bodily)->magic_parent = Qt;
524 XSPECIFIER(bodily)->fallback = ghost;
525 XSPECIFIER(ghost)->magic_parent = bodily;
530 DEFUN ("make-specifier", Fmake_specifier, 1, 1, 0, /*
531 Return a new specifier object of type TYPE.
533 A specifier is an object that can be used to keep track of a property
534 whose value can be per-buffer, per-window, per-frame, or per-device,
535 and can further be restricted to a particular console-type or
536 device-class. Specifiers are used, for example, for the various
537 built-in properties of a face; this allows a face to have different
538 values in different frames, buffers, etc.
540 When speaking of the value of a specifier, it is important to
541 distinguish between the *setting* of a specifier, called an
542 \"instantiator\", and the *actual value*, called an \"instance\". You
543 put various possible instantiators (i.e. settings) into a specifier
544 and associate them with particular locales (buffer, window, frame,
545 device, global), and then the instance (i.e. actual value) is
546 retrieved in a specific domain (window, frame, device) by looking
547 through the possible instantiators (i.e. settings). This process is
548 called \"instantiation\".
550 To put settings into a specifier, use `set-specifier', or the
551 lower-level functions `add-spec-to-specifier' and
552 `add-spec-list-to-specifier'. You can also temporarily bind a setting
553 to a specifier using `let-specifier'. To retrieve settings, use
554 `specifier-specs', or its lower-level counterpart
555 `specifier-spec-list'. To determine the actual value, use
556 `specifier-instance'.
558 For more information, see `set-specifier', `specifier-instance',
559 `specifier-specs', and `add-spec-to-specifier'; or, for a detailed
560 description of specifiers, including how exactly the instantiation
561 process works, see the chapter on specifiers in the XEmacs Lisp
564 TYPE specifies the particular type of specifier, and should be one of
565 the symbols 'generic, 'integer, 'natnum, 'boolean, 'color, 'font,
566 'image, 'face-boolean, 'display-table, 'gutter, 'gutter-size,
567 'gutter-visible or 'toolbar.
569 For more information on particular types of specifiers, see the
570 functions `make-generic-specifier', `make-integer-specifier',
571 `make-natnum-specifier', `make-boolean-specifier',
572 `make-color-specifier', `make-font-specifier', `make-image-specifier',
573 `make-face-boolean-specifier', `make-gutter-size-specifier',
574 `make-gutter-visible-specifier', `default-toolbar', `default-gutter',
575 and `current-display-table'.
579 /* This function can GC */
580 struct specifier_methods *meths = decode_specifier_type (type, ERROR_ME);
582 return make_specifier (meths);
585 DEFUN ("specifierp", Fspecifierp, 1, 1, 0, /*
586 Return t if OBJECT is a specifier.
588 A specifier is an object that can be used to keep track of a property
589 whose value can be per-buffer, per-window, per-frame, or per-device,
590 and can further be restricted to a particular console-type or device-class.
591 See `make-specifier'.
595 return SPECIFIERP (object) ? Qt : Qnil;
598 DEFUN ("specifier-type", Fspecifier_type, 1, 1, 0, /*
599 Return the type of SPECIFIER.
603 CHECK_SPECIFIER (specifier);
604 return intern (XSPECIFIER (specifier)->methods->name);
608 /************************************************************************/
609 /* Locales and domains */
610 /************************************************************************/
612 DEFUN ("valid-specifier-locale-p", Fvalid_specifier_locale_p, 1, 1, 0, /*
613 Return t if LOCALE is a valid specifier locale.
614 Valid locales are devices, frames, windows, buffers, and 'global.
619 /* This cannot GC. */
620 return ((DEVICEP (locale) && DEVICE_LIVE_P (XDEVICE (locale))) ||
621 (FRAMEP (locale) && FRAME_LIVE_P (XFRAME (locale))) ||
622 (BUFFERP (locale) && BUFFER_LIVE_P (XBUFFER (locale))) ||
623 /* dead windows are allowed because they may become live
624 windows again when a window configuration is restored */
626 EQ (locale, Qglobal))
630 DEFUN ("valid-specifier-domain-p", Fvalid_specifier_domain_p, 1, 1, 0, /*
631 Return t if DOMAIN is a valid specifier domain.
632 A domain is used to instance a specifier (i.e. determine the specifier's
633 value in that domain). Valid domains are image instances, windows, frames,
634 and devices. \(nil is not valid.) image instances are pseudo-domains since
635 instantiation will actually occur in the window the image instance itself is
640 /* This cannot GC. */
641 return ((DEVICEP (domain) && DEVICE_LIVE_P (XDEVICE (domain))) ||
642 (FRAMEP (domain) && FRAME_LIVE_P (XFRAME (domain))) ||
643 (WINDOWP (domain) && WINDOW_LIVE_P (XWINDOW (domain))) ||
644 /* #### get image instances out of domains! */
645 IMAGE_INSTANCEP (domain))
649 DEFUN ("valid-specifier-locale-type-p", Fvalid_specifier_locale_type_p, 1, 1, 0, /*
650 Given a specifier LOCALE-TYPE, return non-nil if it is valid.
651 Valid locale types are 'global, 'device, 'frame, 'window, and 'buffer.
652 \(Note, however, that in functions that accept either a locale or a locale
653 type, 'global is considered an individual locale.)
657 /* This cannot GC. */
658 return (EQ (locale_type, Qglobal) ||
659 EQ (locale_type, Qdevice) ||
660 EQ (locale_type, Qframe) ||
661 EQ (locale_type, Qwindow) ||
662 EQ (locale_type, Qbuffer)) ? Qt : Qnil;
666 check_valid_locale_or_locale_type (Lisp_Object locale)
668 /* This cannot GC. */
669 if (EQ (locale, Qall) ||
670 !NILP (Fvalid_specifier_locale_p (locale)) ||
671 !NILP (Fvalid_specifier_locale_type_p (locale)))
673 signal_simple_error ("Invalid specifier locale or locale type", locale);
676 DEFUN ("specifier-locale-type-from-locale", Fspecifier_locale_type_from_locale,
678 Given a specifier LOCALE, return its type.
682 /* This cannot GC. */
683 if (NILP (Fvalid_specifier_locale_p (locale)))
684 signal_simple_error ("Invalid specifier locale", locale);
685 if (DEVICEP (locale)) return Qdevice;
686 if (FRAMEP (locale)) return Qframe;
687 if (WINDOWP (locale)) return Qwindow;
688 if (BUFFERP (locale)) return Qbuffer;
689 assert (EQ (locale, Qglobal));
694 decode_locale (Lisp_Object locale)
696 /* This cannot GC. */
699 else if (!NILP (Fvalid_specifier_locale_p (locale)))
702 signal_simple_error ("Invalid specifier locale", locale);
707 static enum spec_locale_type
708 decode_locale_type (Lisp_Object locale_type)
710 /* This cannot GC. */
711 if (EQ (locale_type, Qglobal)) return LOCALE_GLOBAL;
712 if (EQ (locale_type, Qdevice)) return LOCALE_DEVICE;
713 if (EQ (locale_type, Qframe)) return LOCALE_FRAME;
714 if (EQ (locale_type, Qwindow)) return LOCALE_WINDOW;
715 if (EQ (locale_type, Qbuffer)) return LOCALE_BUFFER;
717 signal_simple_error ("Invalid specifier locale type", locale_type);
718 return LOCALE_GLOBAL; /* not reached */
722 decode_locale_list (Lisp_Object locale)
724 /* This cannot GC. */
725 /* The return value of this function must be GCPRO'd. */
730 else if (CONSP (locale))
733 EXTERNAL_LIST_LOOP_2 (elt, locale)
734 check_valid_locale_or_locale_type (elt);
739 check_valid_locale_or_locale_type (locale);
740 return list1 (locale);
744 static enum spec_locale_type
745 locale_type_from_locale (Lisp_Object locale)
747 return decode_locale_type (Fspecifier_locale_type_from_locale (locale));
751 check_valid_domain (Lisp_Object domain)
753 if (NILP (Fvalid_specifier_domain_p (domain)))
754 signal_simple_error ("Invalid specifier domain", domain);
758 decode_domain (Lisp_Object domain)
761 return Fselected_window (Qnil);
762 check_valid_domain (domain);
767 /************************************************************************/
769 /************************************************************************/
771 DEFUN ("valid-specifier-tag-p", Fvalid_specifier_tag_p, 1, 1, 0, /*
772 Return non-nil if TAG is a valid specifier tag.
773 See also `valid-specifier-tag-set-p'.
777 return (valid_console_type_p (tag) ||
778 valid_device_class_p (tag) ||
779 !NILP (assq_no_quit (tag, Vuser_defined_tags))) ? Qt : Qnil;
782 DEFUN ("valid-specifier-tag-set-p", Fvalid_specifier_tag_set_p, 1, 1, 0, /*
783 Return non-nil if TAG-SET is a valid specifier tag set.
785 A specifier tag set is an entity that is attached to an instantiator
786 and can be used to restrict the scope of that instantiator to a
787 particular device class or device type and/or to mark instantiators
788 added by a particular package so that they can be later removed.
790 A specifier tag set consists of a list of zero of more specifier tags,
791 each of which is a symbol that is recognized by XEmacs as a tag.
792 \(The valid device types and device classes are always tags, as are
793 any tags defined by `define-specifier-tag'.) It is called a "tag set"
794 \(as opposed to a list) because the order of the tags or the number of
795 times a particular tag occurs does not matter.
797 Each tag has a predicate associated with it, which specifies whether
798 that tag applies to a particular device. The tags which are device types
799 and classes match devices of that type or class. User-defined tags can
800 have any predicate, or none (meaning that all devices match). When
801 attempting to instance a specifier, a particular instantiator is only
802 considered if the device of the domain being instanced over matches
803 all tags in the tag set attached to that instantiator.
805 Most of the time, a tag set is not specified, and the instantiator
806 gets a null tag set, which matches all devices.
812 for (rest = tag_set; !NILP (rest); rest = XCDR (rest))
816 if (NILP (Fvalid_specifier_tag_p (XCAR (rest))))
824 decode_specifier_tag_set (Lisp_Object tag_set)
826 /* The return value of this function must be GCPRO'd. */
827 if (!NILP (Fvalid_specifier_tag_p (tag_set)))
828 return list1 (tag_set);
829 if (NILP (Fvalid_specifier_tag_set_p (tag_set)))
830 signal_simple_error ("Invalid specifier tag-set", tag_set);
835 canonicalize_tag_set (Lisp_Object tag_set)
837 int len = XINT (Flength (tag_set));
838 Lisp_Object *tags, rest;
841 /* We assume in this function that the tag_set has already been
842 validated, so there are no surprises. */
844 if (len == 0 || len == 1)
845 /* most common case */
848 tags = alloca_array (Lisp_Object, len);
851 LIST_LOOP (rest, tag_set)
852 tags[i++] = XCAR (rest);
854 /* Sort the list of tags. We use a bubble sort here (copied from
855 extent_fragment_update()) -- reduces the function call overhead,
856 and is the fastest sort for small numbers of items. */
858 for (i = 1; i < len; i++)
862 strcmp ((char *) string_data (XSYMBOL (tags[j])->name),
863 (char *) string_data (XSYMBOL (tags[j+1])->name)) > 0)
865 Lisp_Object tmp = tags[j];
872 /* Now eliminate duplicates. */
874 for (i = 1, j = 1; i < len; i++)
876 /* j holds the destination, i the source. */
877 if (!EQ (tags[i], tags[i-1]))
881 return Flist (j, tags);
884 DEFUN ("canonicalize-tag-set", Fcanonicalize_tag_set, 1, 1, 0, /*
885 Canonicalize the given tag set.
886 Two canonicalized tag sets can be compared with `equal' to see if they
887 represent the same tag set. (Specifically, canonicalizing involves
888 sorting by symbol name and removing duplicates.)
892 if (NILP (Fvalid_specifier_tag_set_p (tag_set)))
893 signal_simple_error ("Invalid tag set", tag_set);
894 return canonicalize_tag_set (tag_set);
898 device_matches_specifier_tag_set_p (Lisp_Object device, Lisp_Object tag_set)
900 Lisp_Object devtype, devclass, rest;
901 struct device *d = XDEVICE (device);
903 devtype = DEVICE_TYPE (d);
904 devclass = DEVICE_CLASS (d);
906 LIST_LOOP (rest, tag_set)
908 Lisp_Object tag = XCAR (rest);
911 if (EQ (tag, devtype) || EQ (tag, devclass))
913 assoc = assq_no_quit (tag, DEVICE_USER_DEFINED_TAGS (d));
914 /* other built-in tags (device types/classes) are not in
915 the user-defined-tags list. */
916 if (NILP (assoc) || NILP (XCDR (assoc)))
923 DEFUN ("device-matches-specifier-tag-set-p", Fdevice_matches_specifier_tag_set_p, 2, 2, 0, /*
924 Return non-nil if DEVICE matches specifier tag set TAG-SET.
925 This means that DEVICE matches each tag in the tag set. (Every
926 tag recognized by XEmacs has a predicate associated with it that
927 specifies which devices match it.)
931 CHECK_LIVE_DEVICE (device);
933 if (NILP (Fvalid_specifier_tag_set_p (tag_set)))
934 signal_simple_error ("Invalid tag set", tag_set);
936 return device_matches_specifier_tag_set_p (device, tag_set) ? Qt : Qnil;
939 DEFUN ("define-specifier-tag", Fdefine_specifier_tag, 1, 2, 0, /*
940 Define a new specifier tag.
941 If PREDICATE is specified, it should be a function of one argument
942 \(a device) that specifies whether the tag matches that particular
943 device. If PREDICATE is omitted, the tag matches all devices.
945 You can redefine an existing user-defined specifier tag. However,
946 you cannot redefine the built-in specifier tags (the device types
947 and classes) or the symbols nil, t, 'all, or 'global.
951 Lisp_Object assoc, devcons, concons;
955 if (valid_device_class_p (tag) ||
956 valid_console_type_p (tag))
957 signal_simple_error ("Cannot redefine built-in specifier tags", tag);
958 /* Try to prevent common instantiators and locales from being
959 redefined, to reduce ambiguity */
960 if (NILP (tag) || EQ (tag, Qt) || EQ (tag, Qall) || EQ (tag, Qglobal))
961 signal_simple_error ("Cannot define nil, t, 'all, or 'global",
963 assoc = assq_no_quit (tag, Vuser_defined_tags);
967 Vuser_defined_tags = Fcons (Fcons (tag, predicate), Vuser_defined_tags);
968 DEVICE_LOOP_NO_BREAK (devcons, concons)
970 struct device *d = XDEVICE (XCAR (devcons));
971 /* Initially set the value to t in case of error
973 DEVICE_USER_DEFINED_TAGS (d) =
974 Fcons (Fcons (tag, Qt), DEVICE_USER_DEFINED_TAGS (d));
977 else if (!NILP (predicate) && !NILP (XCDR (assoc)))
980 XCDR (assoc) = predicate;
983 /* recompute the tag values for all devices. However, in the special
984 case where both the old and new predicates are nil, we know that
985 we don't have to do this. (It's probably common for people to
986 call (define-specifier-tag) more than once on the same tag,
987 and the most common case is where PREDICATE is not specified.) */
991 DEVICE_LOOP_NO_BREAK (devcons, concons)
993 Lisp_Object device = XCAR (devcons);
994 assoc = assq_no_quit (tag,
995 DEVICE_USER_DEFINED_TAGS (XDEVICE (device)));
996 assert (CONSP (assoc));
997 if (NILP (predicate))
1000 XCDR (assoc) = !NILP (call1 (predicate, device)) ? Qt : Qnil;
1007 /* Called at device-creation time to initialize the user-defined
1008 tag values for the newly-created device. */
1011 setup_device_initial_specifier_tags (struct device *d)
1013 Lisp_Object rest, rest2;
1016 XSETDEVICE (device, d);
1018 DEVICE_USER_DEFINED_TAGS (d) = Fcopy_alist (Vuser_defined_tags);
1020 /* Now set up the initial values */
1021 LIST_LOOP (rest, DEVICE_USER_DEFINED_TAGS (d))
1022 XCDR (XCAR (rest)) = Qt;
1024 for (rest = Vuser_defined_tags, rest2 = DEVICE_USER_DEFINED_TAGS (d);
1025 !NILP (rest); rest = XCDR (rest), rest2 = XCDR (rest2))
1027 Lisp_Object predicate = XCDR (XCAR (rest));
1028 if (NILP (predicate))
1029 XCDR (XCAR (rest2)) = Qt;
1031 XCDR (XCAR (rest2)) = !NILP (call1 (predicate, device)) ? Qt : Qnil;
1035 DEFUN ("device-matching-specifier-tag-list", Fdevice_matching_specifier_tag_list,
1037 Return a list of all specifier tags matching DEVICE.
1038 DEVICE defaults to the selected device if omitted.
1042 struct device *d = decode_device (device);
1043 Lisp_Object rest, list = Qnil;
1044 struct gcpro gcpro1;
1048 LIST_LOOP (rest, DEVICE_USER_DEFINED_TAGS (d))
1050 if (!NILP (XCDR (XCAR (rest))))
1051 list = Fcons (XCAR (XCAR (rest)), list);
1054 list = Fnreverse (list);
1055 list = Fcons (DEVICE_CLASS (d), list);
1056 list = Fcons (DEVICE_TYPE (d), list);
1058 RETURN_UNGCPRO (list);
1061 DEFUN ("specifier-tag-list", Fspecifier_tag_list, 0, 0, 0, /*
1062 Return a list of all currently-defined specifier tags.
1063 This includes the built-in ones (the device types and classes).
1067 Lisp_Object list = Qnil, rest;
1068 struct gcpro gcpro1;
1072 LIST_LOOP (rest, Vuser_defined_tags)
1073 list = Fcons (XCAR (XCAR (rest)), list);
1075 list = Fnreverse (list);
1076 list = nconc2 (Fcopy_sequence (Vdevice_class_list), list);
1077 list = nconc2 (Fcopy_sequence (Vconsole_type_list), list);
1079 RETURN_UNGCPRO (list);
1082 DEFUN ("specifier-tag-predicate", Fspecifier_tag_predicate, 1, 1, 0, /*
1083 Return the predicate for the given specifier tag.
1087 /* The return value of this function must be GCPRO'd. */
1090 if (NILP (Fvalid_specifier_tag_p (tag)))
1091 signal_simple_error ("Invalid specifier tag", tag);
1093 /* Make up some predicates for the built-in types */
1095 if (valid_console_type_p (tag))
1096 return list3 (Qlambda, list1 (Qdevice),
1097 list3 (Qeq, list2 (Qquote, tag),
1098 list2 (Qconsole_type, Qdevice)));
1100 if (valid_device_class_p (tag))
1101 return list3 (Qlambda, list1 (Qdevice),
1102 list3 (Qeq, list2 (Qquote, tag),
1103 list2 (Qdevice_class, Qdevice)));
1105 return XCDR (assq_no_quit (tag, Vuser_defined_tags));
1108 /* Return true if A "matches" B. If EXACT_P is 0, A must be a subset of B.
1109 Otherwise, A must be `equal' to B. The sets must be canonicalized. */
1111 tag_sets_match_p (Lisp_Object a, Lisp_Object b, int exact_p)
1115 while (!NILP (a) && !NILP (b))
1117 if (EQ (XCAR (a), XCAR (b)))
1126 while (!NILP (a) && !NILP (b))
1128 if (!EQ (XCAR (a), XCAR (b)))
1134 return NILP (a) && NILP (b);
1139 /************************************************************************/
1140 /* Spec-lists and inst-lists */
1141 /************************************************************************/
1144 call_validate_method (Lisp_Object boxed_method, Lisp_Object instantiator)
1146 ((void (*)(Lisp_Object)) get_opaque_ptr (boxed_method)) (instantiator);
1151 check_valid_instantiator (Lisp_Object instantiator,
1152 struct specifier_methods *meths,
1153 Error_behavior errb)
1155 if (meths->validate_method)
1159 if (ERRB_EQ (errb, ERROR_ME))
1161 (meths->validate_method) (instantiator);
1166 Lisp_Object opaque = make_opaque_ptr ((void *)
1167 meths->validate_method);
1168 struct gcpro gcpro1;
1171 retval = call_with_suspended_errors
1172 ((lisp_fn_t) call_validate_method,
1173 Qnil, Qspecifier, errb, 2, opaque, instantiator);
1175 free_opaque_ptr (opaque);
1184 DEFUN ("check-valid-instantiator", Fcheck_valid_instantiator, 2, 2, 0, /*
1185 Signal an error if INSTANTIATOR is invalid for SPECIFIER-TYPE.
1187 (instantiator, specifier_type))
1189 struct specifier_methods *meths = decode_specifier_type (specifier_type,
1192 return check_valid_instantiator (instantiator, meths, ERROR_ME);
1195 DEFUN ("valid-instantiator-p", Fvalid_instantiator_p, 2, 2, 0, /*
1196 Return non-nil if INSTANTIATOR is valid for SPECIFIER-TYPE.
1198 (instantiator, specifier_type))
1200 struct specifier_methods *meths = decode_specifier_type (specifier_type,
1203 return check_valid_instantiator (instantiator, meths, ERROR_ME_NOT);
1207 check_valid_inst_list (Lisp_Object inst_list, struct specifier_methods *meths,
1208 Error_behavior errb)
1212 LIST_LOOP (rest, inst_list)
1214 Lisp_Object inst_pair, tag_set;
1218 maybe_signal_simple_error ("Invalid instantiator list", inst_list,
1222 if (!CONSP (inst_pair = XCAR (rest)))
1224 maybe_signal_simple_error ("Invalid instantiator pair", inst_pair,
1228 if (NILP (Fvalid_specifier_tag_set_p (tag_set = XCAR (inst_pair))))
1230 maybe_signal_simple_error ("Invalid specifier tag", tag_set,
1235 if (NILP (check_valid_instantiator (XCDR (inst_pair), meths, errb)))
1242 DEFUN ("check-valid-inst-list", Fcheck_valid_inst_list, 2, 2, 0, /*
1243 Signal an error if INST-LIST is invalid for specifier type TYPE.
1247 struct specifier_methods *meths = decode_specifier_type (type, ERROR_ME);
1249 return check_valid_inst_list (inst_list, meths, ERROR_ME);
1252 DEFUN ("valid-inst-list-p", Fvalid_inst_list_p, 2, 2, 0, /*
1253 Return non-nil if INST-LIST is valid for specifier type TYPE.
1257 struct specifier_methods *meths = decode_specifier_type (type, ERROR_ME);
1259 return check_valid_inst_list (inst_list, meths, ERROR_ME_NOT);
1263 check_valid_spec_list (Lisp_Object spec_list, struct specifier_methods *meths,
1264 Error_behavior errb)
1268 LIST_LOOP (rest, spec_list)
1270 Lisp_Object spec, locale;
1271 if (!CONSP (rest) || !CONSP (spec = XCAR (rest)))
1273 maybe_signal_simple_error ("Invalid specification list", spec_list,
1277 if (NILP (Fvalid_specifier_locale_p (locale = XCAR (spec))))
1279 maybe_signal_simple_error ("Invalid specifier locale", locale,
1284 if (NILP (check_valid_inst_list (XCDR (spec), meths, errb)))
1291 DEFUN ("check-valid-spec-list", Fcheck_valid_spec_list, 2, 2, 0, /*
1292 Signal an error if SPEC-LIST is invalid for specifier type TYPE.
1296 struct specifier_methods *meths = decode_specifier_type (type, ERROR_ME);
1298 return check_valid_spec_list (spec_list, meths, ERROR_ME);
1301 DEFUN ("valid-spec-list-p", Fvalid_spec_list_p, 2, 2, 0, /*
1302 Return non-nil if SPEC-LIST is valid for specifier type TYPE.
1306 struct specifier_methods *meths = decode_specifier_type (type, ERROR_ME);
1308 return check_valid_spec_list (spec_list, meths, ERROR_ME_NOT);
1312 decode_how_to_add_specification (Lisp_Object how_to_add)
1314 if (NILP (how_to_add) || EQ (Qremove_tag_set_prepend, how_to_add))
1315 return SPEC_REMOVE_TAG_SET_PREPEND;
1316 if (EQ (Qremove_tag_set_append, how_to_add))
1317 return SPEC_REMOVE_TAG_SET_APPEND;
1318 if (EQ (Qappend, how_to_add))
1320 if (EQ (Qprepend, how_to_add))
1321 return SPEC_PREPEND;
1322 if (EQ (Qremove_locale, how_to_add))
1323 return SPEC_REMOVE_LOCALE;
1324 if (EQ (Qremove_locale_type, how_to_add))
1325 return SPEC_REMOVE_LOCALE_TYPE;
1326 if (EQ (Qremove_all, how_to_add))
1327 return SPEC_REMOVE_ALL;
1329 signal_simple_error ("Invalid `how-to-add' flag", how_to_add);
1331 return SPEC_PREPEND; /* not reached */
1334 /* Given a specifier object SPEC, return bodily specifier if SPEC is a
1335 ghost specifier, otherwise return the object itself
1338 bodily_specifier (Lisp_Object spec)
1340 return (GHOST_SPECIFIER_P (XSPECIFIER (spec))
1341 ? XSPECIFIER(spec)->magic_parent : spec);
1344 /* Signal error if (specifier SPEC is read-only.
1345 Read only are ghost specifiers unless Vunlock_ghost_specifiers is
1346 non-nil. All other specifiers are read-write.
1349 check_modifiable_specifier (Lisp_Object spec)
1351 if (NILP (Vunlock_ghost_specifiers)
1352 && GHOST_SPECIFIER_P (XSPECIFIER (spec)))
1353 signal_simple_error ("Attempt to modify read-only specifier",
1357 /* Helper function which unwind protects the value of
1358 Vunlock_ghost_specifiers, then sets it to non-nil value */
1360 restore_unlock_value (Lisp_Object val)
1362 Vunlock_ghost_specifiers = val;
1367 unlock_ghost_specifiers_protected (void)
1369 int depth = specpdl_depth ();
1370 record_unwind_protect (restore_unlock_value,
1371 Vunlock_ghost_specifiers);
1372 Vunlock_ghost_specifiers = Qt;
1376 /* This gets hit so much that the function call overhead had a
1377 measurable impact (according to Quantify). #### We should figure
1378 out the frequency with which this is called with the various types
1379 and reorder the check accordingly. */
1380 #define SPECIFIER_GET_SPEC_LIST(specifier, type) \
1381 (type == LOCALE_GLOBAL ? &(XSPECIFIER (specifier)->global_specs) : \
1382 type == LOCALE_DEVICE ? &(XSPECIFIER (specifier)->device_specs) : \
1383 type == LOCALE_FRAME ? &(XSPECIFIER (specifier)->frame_specs) : \
1384 type == LOCALE_WINDOW ? &(XWEAK_LIST_LIST \
1385 (XSPECIFIER (specifier)->window_specs)) : \
1386 type == LOCALE_BUFFER ? &(XSPECIFIER (specifier)->buffer_specs) : \
1389 static Lisp_Object *
1390 specifier_get_inst_list (Lisp_Object specifier, Lisp_Object locale,
1391 enum spec_locale_type type)
1393 Lisp_Object *spec_list = SPECIFIER_GET_SPEC_LIST (specifier, type);
1394 Lisp_Object specification;
1396 if (type == LOCALE_GLOBAL)
1398 /* Calling assq_no_quit when it is just going to return nil anyhow
1399 is extremely expensive. So sayeth Quantify. */
1400 if (!CONSP (*spec_list))
1402 specification = assq_no_quit (locale, *spec_list);
1403 if (NILP (specification))
1405 return &XCDR (specification);
1408 /* For the given INST_LIST, return a new INST_LIST containing all elements
1409 where TAG-SET matches the element's tag set. EXACT_P indicates whether
1410 the match must be exact (as opposed to a subset). SHORT_P indicates
1411 that the short form (for `specifier-specs') should be returned if
1412 possible. If COPY_TREE_P, `copy-tree' is used to ensure that no
1413 elements of the new list are shared with the initial list.
1417 specifier_process_inst_list (Lisp_Object inst_list,
1418 Lisp_Object tag_set, int exact_p,
1419 int short_p, int copy_tree_p)
1421 Lisp_Object retval = Qnil;
1423 struct gcpro gcpro1;
1426 LIST_LOOP (rest, inst_list)
1428 Lisp_Object tagged_inst = XCAR (rest);
1429 Lisp_Object tagged_inst_tag = XCAR (tagged_inst);
1430 if (tag_sets_match_p (tag_set, tagged_inst_tag, exact_p))
1432 if (short_p && NILP (tagged_inst_tag))
1433 retval = Fcons (copy_tree_p ?
1434 Fcopy_tree (XCDR (tagged_inst), Qt) :
1438 retval = Fcons (copy_tree_p ? Fcopy_tree (tagged_inst, Qt) :
1439 tagged_inst, retval);
1442 retval = Fnreverse (retval);
1444 /* If there is a single instantiator and the short form is
1445 requested, return just the instantiator (rather than a one-element
1446 list of it) unless it is nil (so that it can be distinguished from
1447 no instantiators at all). */
1448 if (short_p && CONSP (retval) && !NILP (XCAR (retval)) &&
1449 NILP (XCDR (retval)))
1450 return XCAR (retval);
1456 specifier_get_external_inst_list (Lisp_Object specifier, Lisp_Object locale,
1457 enum spec_locale_type type,
1458 Lisp_Object tag_set, int exact_p,
1459 int short_p, int copy_tree_p)
1461 Lisp_Object *inst_list = specifier_get_inst_list (specifier, locale,
1463 if (!inst_list || NILP (*inst_list))
1465 /* nil for *inst_list should only occur in 'global */
1466 assert (!inst_list || EQ (locale, Qglobal));
1470 return specifier_process_inst_list (*inst_list, tag_set, exact_p,
1471 short_p, copy_tree_p);
1475 specifier_get_external_spec_list (Lisp_Object specifier,
1476 enum spec_locale_type type,
1477 Lisp_Object tag_set, int exact_p)
1479 Lisp_Object *spec_list = SPECIFIER_GET_SPEC_LIST (specifier, type);
1480 Lisp_Object retval = Qnil;
1482 struct gcpro gcpro1;
1484 assert (type != LOCALE_GLOBAL);
1485 /* We're about to let stuff go external; make sure there aren't
1487 *spec_list = cleanup_assoc_list (*spec_list);
1490 LIST_LOOP (rest, *spec_list)
1492 Lisp_Object spec = XCAR (rest);
1493 Lisp_Object inst_list =
1494 specifier_process_inst_list (XCDR (spec), tag_set, exact_p, 0, 1);
1495 if (!NILP (inst_list))
1496 retval = Fcons (Fcons (XCAR (spec), inst_list), retval);
1498 RETURN_UNGCPRO (Fnreverse (retval));
1501 static Lisp_Object *
1502 specifier_new_spec (Lisp_Object specifier, Lisp_Object locale,
1503 enum spec_locale_type type)
1505 Lisp_Object *spec_list = SPECIFIER_GET_SPEC_LIST (specifier, type);
1506 Lisp_Object new_spec = Fcons (locale, Qnil);
1507 assert (type != LOCALE_GLOBAL);
1508 *spec_list = Fcons (new_spec, *spec_list);
1509 return &XCDR (new_spec);
1512 /* For the given INST_LIST, return a new list comprised of elements
1513 where TAG_SET does not match the element's tag set. This operation
1517 specifier_process_remove_inst_list (Lisp_Object inst_list,
1518 Lisp_Object tag_set, int exact_p,
1521 Lisp_Object prev = Qnil, rest;
1525 LIST_LOOP (rest, inst_list)
1527 if (tag_sets_match_p (tag_set, XCAR (XCAR (rest)), exact_p))
1529 /* time to remove. */
1532 inst_list = XCDR (rest);
1534 XCDR (prev) = XCDR (rest);
1544 specifier_remove_spec (Lisp_Object specifier, Lisp_Object locale,
1545 enum spec_locale_type type,
1546 Lisp_Object tag_set, int exact_p)
1548 Lisp_Object *spec_list = SPECIFIER_GET_SPEC_LIST (specifier, type);
1552 if (type == LOCALE_GLOBAL)
1553 *spec_list = specifier_process_remove_inst_list (*spec_list, tag_set,
1554 exact_p, &was_removed);
1557 assoc = assq_no_quit (locale, *spec_list);
1559 /* this locale is not found. */
1561 XCDR (assoc) = specifier_process_remove_inst_list (XCDR (assoc),
1564 if (NILP (XCDR (assoc)))
1565 /* no inst-pairs left; remove this locale entirely. */
1566 *spec_list = remassq_no_quit (locale, *spec_list);
1570 MAYBE_SPECMETH (XSPECIFIER (specifier), after_change,
1571 (bodily_specifier (specifier), locale));
1575 specifier_remove_locale_type (Lisp_Object specifier,
1576 enum spec_locale_type type,
1577 Lisp_Object tag_set, int exact_p)
1579 Lisp_Object *spec_list = SPECIFIER_GET_SPEC_LIST (specifier, type);
1580 Lisp_Object prev = Qnil, rest;
1582 assert (type != LOCALE_GLOBAL);
1583 LIST_LOOP (rest, *spec_list)
1586 int remove_spec = 0;
1587 Lisp_Object spec = XCAR (rest);
1589 /* There may be dead objects floating around */
1590 /* remember, dead windows can become alive again. */
1591 if (!WINDOWP (XCAR (spec)) && object_dead_p (XCAR (spec)))
1598 XCDR (spec) = specifier_process_remove_inst_list (XCDR (spec),
1601 if (NILP (XCDR (spec)))
1608 *spec_list = XCDR (rest);
1610 XCDR (prev) = XCDR (rest);
1616 MAYBE_SPECMETH (XSPECIFIER (specifier), after_change,
1617 (bodily_specifier (specifier), XCAR (spec)));
1621 /* NEW_LIST is going to be added to INST_LIST, with add method ADD_METH.
1622 Frob INST_LIST according to ADD_METH. No need to call an after-change
1623 function; the calling function will do this. Return either SPEC_PREPEND
1624 or SPEC_APPEND, indicating whether to prepend or append the NEW_LIST. */
1626 static enum spec_add_meth
1627 handle_multiple_add_insts (Lisp_Object *inst_list,
1628 Lisp_Object new_list,
1629 enum spec_add_meth add_meth)
1633 case SPEC_REMOVE_TAG_SET_APPEND:
1634 add_meth = SPEC_APPEND;
1635 goto remove_tag_set;
1636 case SPEC_REMOVE_TAG_SET_PREPEND:
1637 add_meth = SPEC_PREPEND;
1642 LIST_LOOP (rest, new_list)
1644 Lisp_Object canontag = canonicalize_tag_set (XCAR (XCAR (rest)));
1645 struct gcpro gcpro1;
1648 /* pull out all elements from the existing list with the
1649 same tag as any tags in NEW_LIST. */
1650 *inst_list = remassoc_no_quit (canontag, *inst_list);
1655 case SPEC_REMOVE_LOCALE:
1657 return SPEC_PREPEND;
1661 return SPEC_PREPEND;
1665 /* Given a LOCALE and INST_LIST that is going to be added to SPECIFIER,
1666 copy, canonicalize, and call the going_to_add methods as necessary
1667 to produce a new list that is the one that really will be added
1668 to the specifier. */
1671 build_up_processed_list (Lisp_Object specifier, Lisp_Object locale,
1672 Lisp_Object inst_list)
1674 /* The return value of this function must be GCPRO'd. */
1675 Lisp_Object rest, list_to_build_up = Qnil;
1676 Lisp_Specifier *sp = XSPECIFIER (specifier);
1677 struct gcpro gcpro1;
1679 GCPRO1 (list_to_build_up);
1680 LIST_LOOP (rest, inst_list)
1682 Lisp_Object tag_set = XCAR (XCAR (rest));
1683 Lisp_Object sub_inst_list = Qnil;
1684 Lisp_Object instantiator;
1685 struct gcpro ngcpro1, ngcpro2;
1687 if (HAS_SPECMETH_P (sp, copy_instantiator))
1688 instantiator = SPECMETH (sp, copy_instantiator,
1689 (XCDR (XCAR (rest))));
1691 instantiator = Fcopy_tree (XCDR (XCAR (rest)), Qt);
1693 NGCPRO2 (instantiator, sub_inst_list);
1694 /* call the will-add method; it may GC */
1695 sub_inst_list = HAS_SPECMETH_P (sp, going_to_add) ?
1696 SPECMETH (sp, going_to_add,
1697 (bodily_specifier (specifier), locale,
1698 tag_set, instantiator)) :
1700 if (EQ (sub_inst_list, Qt))
1701 /* no change here. */
1702 sub_inst_list = list1 (Fcons (canonicalize_tag_set (tag_set),
1706 /* now canonicalize all the tag sets in the new objects */
1708 LIST_LOOP (rest2, sub_inst_list)
1709 XCAR (XCAR (rest2)) = canonicalize_tag_set (XCAR (XCAR (rest2)));
1712 list_to_build_up = nconc2 (sub_inst_list, list_to_build_up);
1716 RETURN_UNGCPRO (Fnreverse (list_to_build_up));
1719 /* Add a specification (locale and instantiator list) to a specifier.
1720 ADD_METH specifies what to do with existing specifications in the
1721 specifier, and is an enum that corresponds to the values in
1722 `add-spec-to-specifier'. The calling routine is responsible for
1723 validating LOCALE and INST-LIST, but the tag-sets in INST-LIST
1724 do not need to be canonicalized. */
1726 /* #### I really need to rethink the after-change
1727 functions to make them easier to use and more efficient. */
1730 specifier_add_spec (Lisp_Object specifier, Lisp_Object locale,
1731 Lisp_Object inst_list, enum spec_add_meth add_meth)
1733 Lisp_Specifier *sp = XSPECIFIER (specifier);
1734 enum spec_locale_type type = locale_type_from_locale (locale);
1735 Lisp_Object *orig_inst_list, tem;
1736 Lisp_Object list_to_build_up = Qnil;
1737 struct gcpro gcpro1;
1739 GCPRO1 (list_to_build_up);
1740 list_to_build_up = build_up_processed_list (specifier, locale, inst_list);
1741 /* Now handle REMOVE_LOCALE_TYPE and REMOVE_ALL. These are the
1742 add-meth types that affect locales other than this one. */
1743 if (add_meth == SPEC_REMOVE_LOCALE_TYPE)
1744 specifier_remove_locale_type (specifier, type, Qnil, 0);
1745 else if (add_meth == SPEC_REMOVE_ALL)
1747 specifier_remove_locale_type (specifier, LOCALE_BUFFER, Qnil, 0);
1748 specifier_remove_locale_type (specifier, LOCALE_WINDOW, Qnil, 0);
1749 specifier_remove_locale_type (specifier, LOCALE_FRAME, Qnil, 0);
1750 specifier_remove_locale_type (specifier, LOCALE_DEVICE, Qnil, 0);
1751 specifier_remove_spec (specifier, Qglobal, LOCALE_GLOBAL, Qnil, 0);
1754 orig_inst_list = specifier_get_inst_list (specifier, locale, type);
1755 if (!orig_inst_list)
1756 orig_inst_list = specifier_new_spec (specifier, locale, type);
1757 add_meth = handle_multiple_add_insts (orig_inst_list, list_to_build_up,
1760 if (add_meth == SPEC_PREPEND)
1761 tem = nconc2 (list_to_build_up, *orig_inst_list);
1762 else if (add_meth == SPEC_APPEND)
1763 tem = nconc2 (*orig_inst_list, list_to_build_up);
1767 *orig_inst_list = tem;
1771 /* call the after-change method */
1772 MAYBE_SPECMETH (sp, after_change,
1773 (bodily_specifier (specifier), locale));
1777 specifier_copy_spec (Lisp_Object specifier, Lisp_Object dest,
1778 Lisp_Object locale, enum spec_locale_type type,
1779 Lisp_Object tag_set, int exact_p,
1780 enum spec_add_meth add_meth)
1782 Lisp_Object inst_list =
1783 specifier_get_external_inst_list (specifier, locale, type, tag_set,
1785 specifier_add_spec (dest, locale, inst_list, add_meth);
1789 specifier_copy_locale_type (Lisp_Object specifier, Lisp_Object dest,
1790 enum spec_locale_type type,
1791 Lisp_Object tag_set, int exact_p,
1792 enum spec_add_meth add_meth)
1794 Lisp_Object *src_list = SPECIFIER_GET_SPEC_LIST (specifier, type);
1797 /* This algorithm is O(n^2) in running time.
1798 It's certainly possible to implement an O(n log n) algorithm,
1799 but I doubt there's any need to. */
1801 LIST_LOOP (rest, *src_list)
1803 Lisp_Object spec = XCAR (rest);
1804 /* There may be dead objects floating around */
1805 /* remember, dead windows can become alive again. */
1806 if (WINDOWP (XCAR (spec)) || !object_dead_p (XCAR (spec)))
1809 specifier_process_inst_list (XCDR (spec), tag_set, exact_p, 0, 0),
1814 /* map MAPFUN over the locales in SPECIFIER that are given in LOCALE.
1815 CLOSURE is passed unchanged to MAPFUN. LOCALE can be one of
1817 -- nil (same as 'all)
1818 -- a single locale, locale type, or 'all
1819 -- a list of locales, locale types, and/or 'all
1821 MAPFUN is called for each locale and locale type given; for 'all,
1822 it is called for the locale 'global and for the four possible
1823 locale types. In each invocation, either LOCALE will be a locale
1824 and LOCALE_TYPE will be the locale type of this locale,
1825 or LOCALE will be nil and LOCALE_TYPE will be a locale type.
1826 If MAPFUN ever returns non-zero, the mapping is halted and the
1827 value returned is returned from map_specifier(). Otherwise, the
1828 mapping proceeds to the end and map_specifier() returns 0.
1832 map_specifier (Lisp_Object specifier, Lisp_Object locale,
1833 int (*mapfun) (Lisp_Object specifier,
1835 enum spec_locale_type locale_type,
1836 Lisp_Object tag_set,
1839 Lisp_Object tag_set, Lisp_Object exact_p,
1844 struct gcpro gcpro1, gcpro2;
1846 GCPRO2 (tag_set, locale);
1847 locale = decode_locale_list (locale);
1848 tag_set = decode_specifier_tag_set (tag_set);
1849 tag_set = canonicalize_tag_set (tag_set);
1851 LIST_LOOP (rest, locale)
1853 Lisp_Object theloc = XCAR (rest);
1854 if (!NILP (Fvalid_specifier_locale_p (theloc)))
1856 retval = (*mapfun) (specifier, theloc,
1857 locale_type_from_locale (theloc),
1858 tag_set, !NILP (exact_p), closure);
1862 else if (!NILP (Fvalid_specifier_locale_type_p (theloc)))
1864 retval = (*mapfun) (specifier, Qnil,
1865 decode_locale_type (theloc), tag_set,
1866 !NILP (exact_p), closure);
1872 assert (EQ (theloc, Qall));
1873 retval = (*mapfun) (specifier, Qnil, LOCALE_BUFFER, tag_set,
1874 !NILP (exact_p), closure);
1877 retval = (*mapfun) (specifier, Qnil, LOCALE_WINDOW, tag_set,
1878 !NILP (exact_p), closure);
1881 retval = (*mapfun) (specifier, Qnil, LOCALE_FRAME, tag_set,
1882 !NILP (exact_p), closure);
1885 retval = (*mapfun) (specifier, Qnil, LOCALE_DEVICE, tag_set,
1886 !NILP (exact_p), closure);
1889 retval = (*mapfun) (specifier, Qglobal, LOCALE_GLOBAL, tag_set,
1890 !NILP (exact_p), closure);
1900 DEFUN ("add-spec-to-specifier", Fadd_spec_to_specifier, 2, 5, 0, /*
1901 Add a specification to SPECIFIER.
1902 The specification maps from LOCALE (which should be a window, buffer,
1903 frame, device, or 'global, and defaults to 'global) to INSTANTIATOR,
1904 whose allowed values depend on the type of the specifier. Optional
1905 argument TAG-SET limits the instantiator to apply only to the specified
1906 tag set, which should be a list of tags all of which must match the
1907 device being instantiated over (tags are a device type, a device class,
1908 or tags defined with `define-specifier-tag'). Specifying a single
1909 symbol for TAG-SET is equivalent to specifying a one-element list
1910 containing that symbol. Optional argument HOW-TO-ADD specifies what to
1911 do if there are already specifications in the specifier.
1914 'prepend Put at the beginning of the current list of
1915 instantiators for LOCALE.
1916 'append Add to the end of the current list of
1917 instantiators for LOCALE.
1918 'remove-tag-set-prepend (this is the default)
1919 Remove any existing instantiators whose tag set is
1920 the same as TAG-SET; then put the new instantiator
1921 at the beginning of the current list. ("Same tag
1922 set" means that they contain the same elements.
1923 The order may be different.)
1924 'remove-tag-set-append
1925 Remove any existing instantiators whose tag set is
1926 the same as TAG-SET; then put the new instantiator
1927 at the end of the current list.
1928 'remove-locale Remove all previous instantiators for this locale
1929 before adding the new spec.
1930 'remove-locale-type Remove all specifications for all locales of the
1931 same type as LOCALE (this includes LOCALE itself)
1932 before adding the new spec.
1933 'remove-all Remove all specifications from the specifier
1934 before adding the new spec.
1936 You can retrieve the specifications for a particular locale or locale type
1937 with the function `specifier-spec-list' or `specifier-specs'.
1939 (specifier, instantiator, locale, tag_set, how_to_add))
1941 enum spec_add_meth add_meth;
1942 Lisp_Object inst_list;
1943 struct gcpro gcpro1;
1945 CHECK_SPECIFIER (specifier);
1946 check_modifiable_specifier (specifier);
1948 locale = decode_locale (locale);
1949 check_valid_instantiator (instantiator,
1950 decode_specifier_type
1951 (Fspecifier_type (specifier), ERROR_ME),
1953 /* tag_set might be newly-created material, but it's part of inst_list
1954 so is properly GC-protected. */
1955 tag_set = decode_specifier_tag_set (tag_set);
1956 add_meth = decode_how_to_add_specification (how_to_add);
1958 inst_list = list1 (Fcons (tag_set, instantiator));
1960 specifier_add_spec (specifier, locale, inst_list, add_meth);
1961 recompute_cached_specifier_everywhere (specifier);
1962 RETURN_UNGCPRO (Qnil);
1965 DEFUN ("add-spec-list-to-specifier", Fadd_spec_list_to_specifier, 2, 3, 0, /*
1966 Add a spec-list (a list of specifications) to SPECIFIER.
1967 The format of a spec-list is
1969 ((LOCALE (TAG-SET . INSTANTIATOR) ...) ...)
1972 LOCALE := a window, a buffer, a frame, a device, or 'global
1973 TAG-SET := an unordered list of zero or more TAGS, each of which
1975 TAG := a device class (see `valid-device-class-p'), a device type
1976 (see `valid-console-type-p'), or a tag defined with
1977 `define-specifier-tag'
1978 INSTANTIATOR := format determined by the type of specifier
1980 The pair (TAG-SET . INSTANTIATOR) is called an `inst-pair'.
1981 A list of inst-pairs is called an `inst-list'.
1982 The pair (LOCALE . INST-LIST) is called a `specification' or `spec'.
1983 A spec-list, then, can be viewed as a list of specifications.
1985 HOW-TO-ADD specifies how to combine the new specifications with
1986 the existing ones, and has the same semantics as for
1987 `add-spec-to-specifier'.
1989 In many circumstances, the higher-level function `set-specifier' is
1990 more convenient and should be used instead.
1992 (specifier, spec_list, how_to_add))
1994 enum spec_add_meth add_meth;
1997 CHECK_SPECIFIER (specifier);
1998 check_modifiable_specifier (specifier);
2000 check_valid_spec_list (spec_list,
2001 decode_specifier_type
2002 (Fspecifier_type (specifier), ERROR_ME),
2004 add_meth = decode_how_to_add_specification (how_to_add);
2006 LIST_LOOP (rest, spec_list)
2008 /* Placating the GCC god. */
2009 Lisp_Object specification = XCAR (rest);
2010 Lisp_Object locale = XCAR (specification);
2011 Lisp_Object inst_list = XCDR (specification);
2013 specifier_add_spec (specifier, locale, inst_list, add_meth);
2015 recompute_cached_specifier_everywhere (specifier);
2020 add_spec_to_ghost_specifier (Lisp_Object specifier, Lisp_Object instantiator,
2021 Lisp_Object locale, Lisp_Object tag_set,
2022 Lisp_Object how_to_add)
2024 int depth = unlock_ghost_specifiers_protected ();
2025 Fadd_spec_to_specifier (XSPECIFIER(specifier)->fallback,
2026 instantiator, locale, tag_set, how_to_add);
2027 unbind_to (depth, Qnil);
2030 struct specifier_spec_list_closure
2032 Lisp_Object head, tail;
2036 specifier_spec_list_mapfun (Lisp_Object specifier,
2038 enum spec_locale_type locale_type,
2039 Lisp_Object tag_set,
2043 struct specifier_spec_list_closure *cl =
2044 (struct specifier_spec_list_closure *) closure;
2045 Lisp_Object partial;
2048 partial = specifier_get_external_spec_list (specifier,
2053 partial = specifier_get_external_inst_list (specifier, locale,
2054 locale_type, tag_set,
2056 if (!NILP (partial))
2057 partial = list1 (Fcons (locale, partial));
2062 /* tack on the new list */
2063 if (NILP (cl->tail))
2064 cl->head = cl->tail = partial;
2066 XCDR (cl->tail) = partial;
2067 /* find the new tail */
2068 while (CONSP (XCDR (cl->tail)))
2069 cl->tail = XCDR (cl->tail);
2073 /* For the given SPECIFIER create and return a list of all specs
2074 contained within it, subject to LOCALE. If LOCALE is a locale, only
2075 specs in that locale will be returned. If LOCALE is a locale type,
2076 all specs in all locales of that type will be returned. If LOCALE is
2077 nil, all specs will be returned. This always copies lists and never
2078 returns the actual lists, because we do not want someone manipulating
2079 the actual objects. This may cause a slight loss of potential
2080 functionality but if we were to allow it then a user could manage to
2081 violate our assertion that the specs contained in the actual
2082 specifier lists are all valid. */
2084 DEFUN ("specifier-spec-list", Fspecifier_spec_list, 1, 4, 0, /*
2085 Return the spec-list of specifications for SPECIFIER in LOCALE.
2087 If LOCALE is a particular locale (a buffer, window, frame, device,
2088 or 'global), a spec-list consisting of the specification for that
2089 locale will be returned.
2091 If LOCALE is a locale type (i.e. 'buffer, 'window, 'frame, or 'device),
2092 a spec-list of the specifications for all locales of that type will be
2095 If LOCALE is nil or 'all, a spec-list of all specifications in SPECIFIER
2098 LOCALE can also be a list of locales, locale types, and/or 'all; the
2099 result is as if `specifier-spec-list' were called on each element of the
2100 list and the results concatenated together.
2102 Only instantiators where TAG-SET (a list of zero or more tags) is a
2103 subset of (or possibly equal to) the instantiator's tag set are returned.
2104 \(The default value of nil is a subset of all tag sets, so in this case
2105 no instantiators will be screened out.) If EXACT-P is non-nil, however,
2106 TAG-SET must be equal to an instantiator's tag set for the instantiator
2109 (specifier, locale, tag_set, exact_p))
2111 struct specifier_spec_list_closure cl;
2112 struct gcpro gcpro1, gcpro2;
2114 CHECK_SPECIFIER (specifier);
2115 cl.head = cl.tail = Qnil;
2116 GCPRO2 (cl.head, cl.tail);
2117 map_specifier (specifier, locale, specifier_spec_list_mapfun,
2118 tag_set, exact_p, &cl);
2124 DEFUN ("specifier-specs", Fspecifier_specs, 1, 4, 0, /*
2125 Return the specification(s) for SPECIFIER in LOCALE.
2127 If LOCALE is a single locale or is a list of one element containing a
2128 single locale, then a "short form" of the instantiators for that locale
2129 will be returned. Otherwise, this function is identical to
2130 `specifier-spec-list'.
2132 The "short form" is designed for readability and not for ease of use
2133 in Lisp programs, and is as follows:
2135 1. If there is only one instantiator, then an inst-pair (i.e. cons of
2136 tag and instantiator) will be returned; otherwise a list of
2137 inst-pairs will be returned.
2138 2. For each inst-pair returned, if the instantiator's tag is 'any,
2139 the tag will be removed and the instantiator itself will be returned
2140 instead of the inst-pair.
2141 3. If there is only one instantiator, its value is nil, and its tag is
2142 'any, a one-element list containing nil will be returned rather
2143 than just nil, to distinguish this case from there being no
2144 instantiators at all.
2146 (specifier, locale, tag_set, exact_p))
2148 if (!NILP (Fvalid_specifier_locale_p (locale)) ||
2149 (CONSP (locale) && !NILP (Fvalid_specifier_locale_p (XCAR (locale))) &&
2150 NILP (XCDR (locale))))
2152 struct gcpro gcpro1;
2154 CHECK_SPECIFIER (specifier);
2156 locale = XCAR (locale);
2158 tag_set = decode_specifier_tag_set (tag_set);
2159 tag_set = canonicalize_tag_set (tag_set);
2161 (specifier_get_external_inst_list (specifier, locale,
2162 locale_type_from_locale (locale),
2163 tag_set, !NILP (exact_p), 1, 1));
2166 return Fspecifier_spec_list (specifier, locale, tag_set, exact_p);
2170 remove_specifier_mapfun (Lisp_Object specifier,
2172 enum spec_locale_type locale_type,
2173 Lisp_Object tag_set,
2175 void *ignored_closure)
2178 specifier_remove_locale_type (specifier, locale_type, tag_set, exact_p);
2180 specifier_remove_spec (specifier, locale, locale_type, tag_set, exact_p);
2184 DEFUN ("remove-specifier", Fremove_specifier, 1, 4, 0, /*
2185 Remove specification(s) for SPECIFIER.
2187 If LOCALE is a particular locale (a window, buffer, frame, device,
2188 or 'global), the specification for that locale will be removed.
2190 If instead, LOCALE is a locale type (i.e. 'window, 'buffer, 'frame,
2191 or 'device), the specifications for all locales of that type will be
2194 If LOCALE is nil or 'all, all specifications will be removed.
2196 LOCALE can also be a list of locales, locale types, and/or 'all; this
2197 is equivalent to calling `remove-specifier' for each of the elements
2200 Only instantiators where TAG-SET (a list of zero or more tags) is a
2201 subset of (or possibly equal to) the instantiator's tag set are removed.
2202 The default value of nil is a subset of all tag sets, so in this case
2203 no instantiators will be screened out. If EXACT-P is non-nil, however,
2204 TAG-SET must be equal to an instantiator's tag set for the instantiator
2207 (specifier, locale, tag_set, exact_p))
2209 CHECK_SPECIFIER (specifier);
2210 check_modifiable_specifier (specifier);
2212 map_specifier (specifier, locale, remove_specifier_mapfun,
2213 tag_set, exact_p, 0);
2214 recompute_cached_specifier_everywhere (specifier);
2219 remove_ghost_specifier (Lisp_Object specifier, Lisp_Object locale,
2220 Lisp_Object tag_set, Lisp_Object exact_p)
2222 int depth = unlock_ghost_specifiers_protected ();
2223 Fremove_specifier (XSPECIFIER(specifier)->fallback,
2224 locale, tag_set, exact_p);
2225 unbind_to (depth, Qnil);
2228 struct copy_specifier_closure
2231 enum spec_add_meth add_meth;
2232 int add_meth_is_nil;
2236 copy_specifier_mapfun (Lisp_Object specifier,
2238 enum spec_locale_type locale_type,
2239 Lisp_Object tag_set,
2243 struct copy_specifier_closure *cl =
2244 (struct copy_specifier_closure *) closure;
2247 specifier_copy_locale_type (specifier, cl->dest, locale_type,
2249 cl->add_meth_is_nil ?
2250 SPEC_REMOVE_LOCALE_TYPE :
2253 specifier_copy_spec (specifier, cl->dest, locale, locale_type,
2255 cl->add_meth_is_nil ? SPEC_REMOVE_LOCALE :
2260 DEFUN ("copy-specifier", Fcopy_specifier, 1, 6, 0, /*
2261 Copy SPECIFIER to DEST, or create a new one if DEST is nil.
2263 If DEST is nil or omitted, a new specifier will be created and the
2264 specifications copied into it. Otherwise, the specifications will be
2265 copied into the existing specifier in DEST.
2267 If LOCALE is nil or 'all, all specifications will be copied. If LOCALE
2268 is a particular locale, the specification for that particular locale will
2269 be copied. If LOCALE is a locale type, the specifications for all locales
2270 of that type will be copied. LOCALE can also be a list of locales,
2271 locale types, and/or 'all; this is equivalent to calling `copy-specifier'
2272 for each of the elements of the list. See `specifier-spec-list' for more
2273 information about LOCALE.
2275 Only instantiators where TAG-SET (a list of zero or more tags) is a
2276 subset of (or possibly equal to) the instantiator's tag set are copied.
2277 The default value of nil is a subset of all tag sets, so in this case
2278 no instantiators will be screened out. If EXACT-P is non-nil, however,
2279 TAG-SET must be equal to an instantiator's tag set for the instantiator
2282 Optional argument HOW-TO-ADD specifies what to do with existing
2283 specifications in DEST. If nil, then whichever locales or locale types
2284 are copied will first be completely erased in DEST. Otherwise, it is
2285 the same as in `add-spec-to-specifier'.
2287 (specifier, dest, locale, tag_set, exact_p, how_to_add))
2289 struct gcpro gcpro1;
2290 struct copy_specifier_closure cl;
2292 CHECK_SPECIFIER (specifier);
2293 if (NILP (how_to_add))
2294 cl.add_meth_is_nil = 1;
2296 cl.add_meth_is_nil = 0;
2297 cl.add_meth = decode_how_to_add_specification (how_to_add);
2300 /* #### What about copying the extra data? */
2301 dest = make_specifier (XSPECIFIER (specifier)->methods);
2305 CHECK_SPECIFIER (dest);
2306 check_modifiable_specifier (dest);
2307 if (XSPECIFIER (dest)->methods != XSPECIFIER (specifier)->methods)
2308 error ("Specifiers not of same type");
2313 map_specifier (specifier, locale, copy_specifier_mapfun,
2314 tag_set, exact_p, &cl);
2316 recompute_cached_specifier_everywhere (dest);
2321 /************************************************************************/
2323 /************************************************************************/
2326 call_validate_matchspec_method (Lisp_Object boxed_method,
2327 Lisp_Object matchspec)
2329 ((void (*)(Lisp_Object)) get_opaque_ptr (boxed_method)) (matchspec);
2334 check_valid_specifier_matchspec (Lisp_Object matchspec,
2335 struct specifier_methods *meths,
2336 Error_behavior errb)
2338 if (meths->validate_matchspec_method)
2342 if (ERRB_EQ (errb, ERROR_ME))
2344 (meths->validate_matchspec_method) (matchspec);
2349 Lisp_Object opaque =
2350 make_opaque_ptr ((void *) meths->validate_matchspec_method);
2351 struct gcpro gcpro1;
2354 retval = call_with_suspended_errors
2355 ((lisp_fn_t) call_validate_matchspec_method,
2356 Qnil, Qspecifier, errb, 2, opaque, matchspec);
2358 free_opaque_ptr (opaque);
2366 maybe_signal_simple_error
2367 ("Matchspecs not allowed for this specifier type",
2368 intern (meths->name), Qspecifier, errb);
2373 DEFUN ("check-valid-specifier-matchspec", Fcheck_valid_specifier_matchspec, 2, 2, 0, /*
2374 Signal an error if MATCHSPEC is invalid for SPECIFIER-TYPE.
2375 See `specifier-matching-instance' for a description of matchspecs.
2377 (matchspec, specifier_type))
2379 struct specifier_methods *meths = decode_specifier_type (specifier_type,
2382 return check_valid_specifier_matchspec (matchspec, meths, ERROR_ME);
2385 DEFUN ("valid-specifier-matchspec-p", Fvalid_specifier_matchspec_p, 2, 2, 0, /*
2386 Return non-nil if MATCHSPEC is valid for SPECIFIER-TYPE.
2387 See `specifier-matching-instance' for a description of matchspecs.
2389 (matchspec, specifier_type))
2391 struct specifier_methods *meths = decode_specifier_type (specifier_type,
2394 return check_valid_specifier_matchspec (matchspec, meths, ERROR_ME_NOT);
2397 /* This function is purposely not callable from Lisp. If a Lisp
2398 caller wants to set a fallback, they should just set the
2402 set_specifier_fallback (Lisp_Object specifier, Lisp_Object fallback)
2404 Lisp_Specifier *sp = XSPECIFIER (specifier);
2405 assert (SPECIFIERP (fallback) ||
2406 !NILP (Fvalid_inst_list_p (fallback, Fspecifier_type (specifier))));
2407 if (SPECIFIERP (fallback))
2408 assert (EQ (Fspecifier_type (specifier), Fspecifier_type (fallback)));
2409 if (BODILY_SPECIFIER_P (sp))
2410 GHOST_SPECIFIER(sp)->fallback = fallback;
2412 sp->fallback = fallback;
2413 /* call the after-change method */
2414 MAYBE_SPECMETH (sp, after_change,
2415 (bodily_specifier (specifier), Qfallback));
2416 recompute_cached_specifier_everywhere (specifier);
2419 DEFUN ("specifier-fallback", Fspecifier_fallback, 1, 1, 0, /*
2420 Return the fallback value for SPECIFIER.
2421 Fallback values are provided by the C code for certain built-in
2422 specifiers to make sure that instancing won't fail even if all
2423 specs are removed from the specifier, or to implement simple
2424 inheritance behavior (e.g. this method is used to ensure that
2425 faces other than 'default inherit their attributes from 'default).
2426 By design, you cannot change the fallback value, and specifiers
2427 created with `make-specifier' will never have a fallback (although
2428 a similar, Lisp-accessible capability may be provided in the future
2429 to allow for inheritance).
2431 The fallback value will be an inst-list that is instanced like
2432 any other inst-list, a specifier of the same type as SPECIFIER
2433 \(results in inheritance), or nil for no fallback.
2435 When you instance a specifier, you can explicitly request that the
2436 fallback not be consulted. (The C code does this, for example, when
2437 merging faces.) See `specifier-instance'.
2441 CHECK_SPECIFIER (specifier);
2442 return Fcopy_tree (XSPECIFIER (specifier)->fallback, Qt);
2446 specifier_instance_from_inst_list (Lisp_Object specifier,
2447 Lisp_Object matchspec,
2449 Lisp_Object inst_list,
2450 Error_behavior errb, int no_quit,
2453 /* This function can GC */
2457 int count = specpdl_depth ();
2458 struct gcpro gcpro1, gcpro2;
2460 GCPRO2 (specifier, inst_list);
2462 sp = XSPECIFIER (specifier);
2463 device = DOMAIN_DEVICE (domain);
2466 /* The instantiate method is allowed to call eval. Since it
2467 is quite common for this function to get called from somewhere in
2468 redisplay we need to make sure that quits are ignored. Otherwise
2469 Fsignal will abort. */
2470 specbind (Qinhibit_quit, Qt);
2472 LIST_LOOP (rest, inst_list)
2474 Lisp_Object tagged_inst = XCAR (rest);
2475 Lisp_Object tag_set = XCAR (tagged_inst);
2477 if (device_matches_specifier_tag_set_p (device, tag_set))
2479 Lisp_Object val = XCDR (tagged_inst);
2481 if (HAS_SPECMETH_P (sp, instantiate))
2482 val = call_with_suspended_errors
2483 ((lisp_fn_t) RAW_SPECMETH (sp, instantiate),
2484 Qunbound, Qspecifier, errb, 5, specifier,
2485 matchspec, domain, val, depth);
2487 if (!UNBOUNDP (val))
2489 unbind_to (count, Qnil);
2496 unbind_to (count, Qnil);
2501 /* Given a SPECIFIER and a DOMAIN, return a specific instance for that
2502 specifier. Try to find one by checking the specifier types from most
2503 specific (buffer) to most general (global). If we find an instance,
2504 return it. Otherwise return Qunbound. */
2506 #define CHECK_INSTANCE_ENTRY(key, matchspec, type) do { \
2507 Lisp_Object *CIE_inst_list = \
2508 specifier_get_inst_list (specifier, key, type); \
2509 if (CIE_inst_list) \
2511 Lisp_Object CIE_val = \
2512 specifier_instance_from_inst_list (specifier, matchspec, \
2513 domain, *CIE_inst_list, \
2514 errb, no_quit, depth); \
2515 if (!UNBOUNDP (CIE_val)) \
2520 /* We accept any window, frame or device domain and do our checking
2521 starting from as specific a locale type as we can determine from the
2522 domain we are passed and going on up through as many other locale types
2523 as we can determine. In practice, when called from redisplay the
2524 arg will usually be a window and occasionally a frame. If
2525 triggered by a user call, who knows what it will usually be. */
2527 specifier_instance (Lisp_Object specifier, Lisp_Object matchspec,
2528 Lisp_Object domain, Error_behavior errb, int no_quit,
2529 int no_fallback, Lisp_Object depth)
2531 Lisp_Object buffer = Qnil;
2532 Lisp_Object window = Qnil;
2533 Lisp_Object frame = Qnil;
2534 Lisp_Object device = Qnil;
2535 Lisp_Object tag = Qnil;
2539 sp = XSPECIFIER (specifier);
2541 /* Attempt to determine buffer, window, frame, and device from the
2543 /* #### get image instances out of domains! */
2544 if (IMAGE_INSTANCEP (domain))
2545 window = DOMAIN_WINDOW (domain);
2546 else if (WINDOWP (domain))
2548 else if (FRAMEP (domain))
2550 else if (DEVICEP (domain))
2553 /* dmoore writes: [dammit, this should just signal an error or something
2556 No. Errors are handled in Lisp primitives implementation.
2557 Invalid domain is a design error here - kkm. */
2560 if (NILP (buffer) && !NILP (window))
2561 buffer = XWINDOW (window)->buffer;
2562 if (NILP (frame) && !NILP (window))
2563 frame = XWINDOW (window)->frame;
2565 /* frame had better exist; if device is undeterminable, something
2566 really went wrong. */
2567 device = XFRAME (frame)->device;
2569 /* device had better be determined by now; abort if not. */
2570 d = XDEVICE (device);
2571 tag = DEVICE_CLASS (d);
2573 depth = make_int (1 + XINT (depth));
2574 if (XINT (depth) > 20)
2576 maybe_error (Qspecifier, errb, "Apparent loop in specifier inheritance");
2577 /* The specification is fucked; at least try the fallback
2578 (which better not be fucked, because it's not changeable
2585 /* First see if we can generate one from the window specifiers. */
2587 CHECK_INSTANCE_ENTRY (window, matchspec, LOCALE_WINDOW);
2589 /* Next see if we can generate one from the buffer specifiers. */
2591 CHECK_INSTANCE_ENTRY (buffer, matchspec, LOCALE_BUFFER);
2593 /* Next see if we can generate one from the frame specifiers. */
2595 CHECK_INSTANCE_ENTRY (frame, matchspec, LOCALE_FRAME);
2597 /* If we still haven't succeeded try with the device specifiers. */
2598 CHECK_INSTANCE_ENTRY (device, matchspec, LOCALE_DEVICE);
2600 /* Last and least try the global specifiers. */
2601 CHECK_INSTANCE_ENTRY (Qglobal, matchspec, LOCALE_GLOBAL);
2604 /* We're out of specifiers and we still haven't generated an
2605 instance. At least try the fallback ... If this fails,
2606 then we just return Qunbound. */
2608 if (no_fallback || NILP (sp->fallback))
2609 /* I said, I don't want the fallbacks. */
2612 if (SPECIFIERP (sp->fallback))
2614 /* If you introduced loops in the default specifier chain,
2615 then you're fucked, so you better not do this. */
2616 specifier = sp->fallback;
2617 sp = XSPECIFIER (specifier);
2621 assert (CONSP (sp->fallback));
2622 return specifier_instance_from_inst_list (specifier, matchspec, domain,
2623 sp->fallback, errb, no_quit,
2626 #undef CHECK_INSTANCE_ENTRY
2629 specifier_instance_no_quit (Lisp_Object specifier, Lisp_Object matchspec,
2630 Lisp_Object domain, Error_behavior errb,
2631 int no_fallback, Lisp_Object depth)
2633 return specifier_instance (specifier, matchspec, domain, errb,
2634 1, no_fallback, depth);
2637 DEFUN ("specifier-instance", Fspecifier_instance, 1, 4, 0, /*
2638 Instantiate SPECIFIER (return its value) in DOMAIN.
2639 If no instance can be generated for this domain, return DEFAULT.
2641 DOMAIN should be a window, frame, or device. Other values that are legal
2642 as a locale (e.g. a buffer) are not valid as a domain because they do not
2643 provide enough information to identify a particular device (see
2644 `valid-specifier-domain-p'). DOMAIN defaults to the selected window
2647 "Instantiating" a specifier in a particular domain means determining
2648 the specifier's "value" in that domain. This is accomplished by
2649 searching through the specifications in the specifier that correspond
2650 to all locales that can be derived from the given domain, from specific
2651 to general. In most cases, the domain is an Emacs window. In that case
2652 specifications are searched for as follows:
2654 1. A specification whose locale is the window itself;
2655 2. A specification whose locale is the window's buffer;
2656 3. A specification whose locale is the window's frame;
2657 4. A specification whose locale is the window's frame's device;
2658 5. A specification whose locale is 'global.
2660 If all of those fail, then the C-code-provided fallback value for
2661 this specifier is consulted (see `specifier-fallback'). If it is
2662 an inst-list, then this function attempts to instantiate that list
2663 just as when a specification is located in the first five steps above.
2664 If the fallback is a specifier, `specifier-instance' is called
2665 recursively on this specifier and the return value used. Note,
2666 however, that if the optional argument NO-FALLBACK is non-nil,
2667 the fallback value will not be consulted.
2669 Note that there may be more than one specification matching a particular
2670 locale; all such specifications are considered before looking for any
2671 specifications for more general locales. Any particular specification
2672 that is found may be rejected because its tag set does not match the
2673 device being instantiated over, or because the specification is not
2674 valid for the device of the given domain (e.g. the font or color name
2675 does not exist for this particular X server).
2677 The returned value is dependent on the type of specifier. For example,
2678 for a font specifier (as returned by the `face-font' function), the returned
2679 value will be a font-instance object. For glyphs, the returned value
2680 will be a string, pixmap, or subwindow.
2682 See also `specifier-matching-instance'.
2684 (specifier, domain, default_, no_fallback))
2686 Lisp_Object instance;
2688 CHECK_SPECIFIER (specifier);
2689 domain = decode_domain (domain);
2691 instance = specifier_instance (specifier, Qunbound, domain, ERROR_ME, 0,
2692 !NILP (no_fallback), Qzero);
2693 return UNBOUNDP (instance) ? default_ : instance;
2696 DEFUN ("specifier-matching-instance", Fspecifier_matching_instance, 2, 5, 0, /*
2697 Return an instance for SPECIFIER in DOMAIN that matches MATCHSPEC.
2698 If no instance can be generated for this domain, return DEFAULT.
2700 This function is identical to `specifier-instance' except that a
2701 specification will only be considered if it matches MATCHSPEC.
2702 The definition of "match", and allowed values for MATCHSPEC, are
2703 dependent on the particular type of specifier. Here are some examples:
2705 -- For chartable (e.g. display table) specifiers, MATCHSPEC should be a
2706 character, and the specification (a chartable) must give a value for
2707 that character in order to be considered. This allows you to specify,
2708 e.g., a buffer-local display table that only gives values for particular
2709 characters. All other characters are handled as if the buffer-local
2710 display table is not there. (Chartable specifiers are not yet
2713 -- For font specifiers, MATCHSPEC should be a charset, and the specification
2714 (a font string) must have a registry that matches the charset's registry.
2715 (This only makes sense with Mule support.) This makes it easy to choose a
2716 font that can display a particular character. (This is what redisplay
2719 (specifier, matchspec, domain, default_, no_fallback))
2721 Lisp_Object instance;
2723 CHECK_SPECIFIER (specifier);
2724 check_valid_specifier_matchspec (matchspec, XSPECIFIER (specifier)->methods,
2726 domain = decode_domain (domain);
2728 instance = specifier_instance (specifier, matchspec, domain, ERROR_ME,
2729 0, !NILP (no_fallback), Qzero);
2730 return UNBOUNDP (instance) ? default_ : instance;
2733 DEFUN ("specifier-instance-from-inst-list", Fspecifier_instance_from_inst_list,
2735 Attempt to convert a particular inst-list into an instance.
2736 This attempts to instantiate INST-LIST in the given DOMAIN,
2737 as if INST-LIST existed in a specification in SPECIFIER. If
2738 the instantiation fails, DEFAULT is returned. In most circumstances,
2739 you should not use this function; use `specifier-instance' instead.
2741 (specifier, domain, inst_list, default_))
2743 Lisp_Object val = Qunbound;
2744 Lisp_Specifier *sp = XSPECIFIER (specifier);
2745 struct gcpro gcpro1;
2746 Lisp_Object built_up_list = Qnil;
2748 CHECK_SPECIFIER (specifier);
2749 check_valid_domain (domain);
2750 check_valid_inst_list (inst_list, sp->methods, ERROR_ME);
2751 GCPRO1 (built_up_list);
2752 built_up_list = build_up_processed_list (specifier, domain, inst_list);
2753 if (!NILP (built_up_list))
2754 val = specifier_instance_from_inst_list (specifier, Qunbound, domain,
2755 built_up_list, ERROR_ME,
2758 return UNBOUNDP (val) ? default_ : val;
2761 DEFUN ("specifier-matching-instance-from-inst-list", Fspecifier_matching_instance_from_inst_list,
2763 Attempt to convert a particular inst-list into an instance.
2764 This attempts to instantiate INST-LIST in the given DOMAIN
2765 \(as if INST-LIST existed in a specification in SPECIFIER),
2766 matching the specifications against MATCHSPEC.
2768 This function is analogous to `specifier-instance-from-inst-list'
2769 but allows for specification-matching as in `specifier-matching-instance'.
2770 See that function for a description of exactly how the matching process
2773 (specifier, matchspec, domain, inst_list, default_))
2775 Lisp_Object val = Qunbound;
2776 Lisp_Specifier *sp = XSPECIFIER (specifier);
2777 struct gcpro gcpro1;
2778 Lisp_Object built_up_list = Qnil;
2780 CHECK_SPECIFIER (specifier);
2781 check_valid_specifier_matchspec (matchspec, XSPECIFIER (specifier)->methods,
2783 check_valid_domain (domain);
2784 check_valid_inst_list (inst_list, sp->methods, ERROR_ME);
2785 GCPRO1 (built_up_list);
2786 built_up_list = build_up_processed_list (specifier, domain, inst_list);
2787 if (!NILP (built_up_list))
2788 val = specifier_instance_from_inst_list (specifier, matchspec, domain,
2789 built_up_list, ERROR_ME,
2792 return UNBOUNDP (val) ? default_ : val;
2796 /************************************************************************/
2797 /* Caching in the struct window or frame */
2798 /************************************************************************/
2800 /* Either STRUCT_WINDOW_OFFSET or STRUCT_FRAME_OFFSET can be 0 to indicate
2801 no caching in that sort of object. */
2803 /* #### It would be nice if the specifier caching automatically knew
2804 about specifier fallbacks, so we didn't have to do it ourselves. */
2807 set_specifier_caching (Lisp_Object specifier, int struct_window_offset,
2808 void (*value_changed_in_window)
2809 (Lisp_Object specifier, struct window *w,
2810 Lisp_Object oldval),
2811 int struct_frame_offset,
2812 void (*value_changed_in_frame)
2813 (Lisp_Object specifier, struct frame *f,
2814 Lisp_Object oldval))
2816 Lisp_Specifier *sp = XSPECIFIER (specifier);
2817 assert (!GHOST_SPECIFIER_P (sp));
2820 sp->caching = xnew_and_zero (struct specifier_caching);
2821 sp->caching->offset_into_struct_window = struct_window_offset;
2822 sp->caching->value_changed_in_window = value_changed_in_window;
2823 sp->caching->offset_into_struct_frame = struct_frame_offset;
2824 sp->caching->value_changed_in_frame = value_changed_in_frame;
2825 Vcached_specifiers = Fcons (specifier, Vcached_specifiers);
2826 if (BODILY_SPECIFIER_P (sp))
2827 GHOST_SPECIFIER(sp)->caching = sp->caching;
2828 recompute_cached_specifier_everywhere (specifier);
2832 recompute_one_cached_specifier_in_window (Lisp_Object specifier,
2836 Lisp_Object newval, *location;
2838 assert (!GHOST_SPECIFIER_P (XSPECIFIER (specifier)));
2840 XSETWINDOW (window, w);
2842 newval = specifier_instance (specifier, Qunbound, window, ERROR_ME_WARN,
2844 /* If newval ended up Qunbound, then the calling functions
2845 better be able to deal. If not, set a default so this
2846 never happens or correct it in the value_changed_in_window
2848 location = (Lisp_Object *)
2849 ((char *) w + XSPECIFIER (specifier)->caching->offset_into_struct_window);
2850 /* #### What's the point of this check, other than to optimize image
2851 instance instantiation? Unless you specify a caching instantiate
2852 method the instantiation that specifier_instance will do will
2853 always create a new copy. Thus EQ will always fail. Unfortunately
2854 calling equal is no good either as this doesn't take into account
2855 things attached to the specifier - for instance strings on
2857 if (!EQ (newval, *location))
2859 Lisp_Object oldval = *location;
2861 (XSPECIFIER (specifier)->caching->value_changed_in_window)
2862 (specifier, w, oldval);
2867 recompute_one_cached_specifier_in_frame (Lisp_Object specifier,
2871 Lisp_Object newval, *location;
2873 assert (!GHOST_SPECIFIER_P (XSPECIFIER (specifier)));
2875 XSETFRAME (frame, f);
2877 newval = specifier_instance (specifier, Qunbound, frame, ERROR_ME_WARN,
2879 /* If newval ended up Qunbound, then the calling functions
2880 better be able to deal. If not, set a default so this
2881 never happens or correct it in the value_changed_in_frame
2883 location = (Lisp_Object *)
2884 ((char *) f + XSPECIFIER (specifier)->caching->offset_into_struct_frame);
2885 if (!EQ (newval, *location))
2887 Lisp_Object oldval = *location;
2889 (XSPECIFIER (specifier)->caching->value_changed_in_frame)
2890 (specifier, f, oldval);
2895 recompute_all_cached_specifiers_in_window (struct window *w)
2899 LIST_LOOP (rest, Vcached_specifiers)
2901 Lisp_Object specifier = XCAR (rest);
2902 if (XSPECIFIER (specifier)->caching->offset_into_struct_window)
2903 recompute_one_cached_specifier_in_window (specifier, w);
2908 recompute_all_cached_specifiers_in_frame (struct frame *f)
2912 LIST_LOOP (rest, Vcached_specifiers)
2914 Lisp_Object specifier = XCAR (rest);
2915 if (XSPECIFIER (specifier)->caching->offset_into_struct_frame)
2916 recompute_one_cached_specifier_in_frame (specifier, f);
2921 recompute_cached_specifier_everywhere_mapfun (struct window *w,
2924 Lisp_Object specifier = Qnil;
2926 VOID_TO_LISP (specifier, closure);
2927 recompute_one_cached_specifier_in_window (specifier, w);
2932 recompute_cached_specifier_everywhere (Lisp_Object specifier)
2934 Lisp_Object frmcons, devcons, concons;
2936 specifier = bodily_specifier (specifier);
2938 if (!XSPECIFIER (specifier)->caching)
2941 if (XSPECIFIER (specifier)->caching->offset_into_struct_window)
2943 FRAME_LOOP_NO_BREAK (frmcons, devcons, concons)
2944 map_windows (XFRAME (XCAR (frmcons)),
2945 recompute_cached_specifier_everywhere_mapfun,
2946 LISP_TO_VOID (specifier));
2949 if (XSPECIFIER (specifier)->caching->offset_into_struct_frame)
2951 FRAME_LOOP_NO_BREAK (frmcons, devcons, concons)
2952 recompute_one_cached_specifier_in_frame (specifier,
2953 XFRAME (XCAR (frmcons)));
2957 DEFUN ("set-specifier-dirty-flag", Fset_specifier_dirty_flag, 1, 1, 0, /*
2958 Force recomputation of any caches associated with SPECIFIER.
2959 Note that this automatically happens whenever you change a specification
2960 in SPECIFIER; you do not have to call this function then.
2961 One example of where this function is useful is when you have a
2962 toolbar button whose `active-p' field is an expression to be
2963 evaluated. Calling `set-specifier-dirty-flag' on the
2964 toolbar specifier will force the `active-p' fields to be
2969 CHECK_SPECIFIER (specifier);
2970 recompute_cached_specifier_everywhere (specifier);
2975 /************************************************************************/
2976 /* Generic specifier type */
2977 /************************************************************************/
2979 DEFINE_SPECIFIER_TYPE (generic);
2983 /* This is the string that used to be in `generic-specifier-p'.
2984 The idea is good, but it doesn't quite work in the form it's
2985 in. (One major problem is that validating an instantiator
2986 is supposed to require only that the specifier type is passed,
2987 while with this approach the actual specifier is needed.)
2989 What really needs to be done is to write a function
2990 `make-specifier-type' that creates new specifier types.
2992 #### [I'll look into this for 19.14.] Well, sometime. (Currently
2993 May 2000, 21.2 is in development. 19.14 was released in June 1996.) */
2995 "A generic specifier is a generalized kind of specifier with user-defined\n"
2996 "semantics. The instantiator can be any kind of Lisp object, and the\n"
2997 "instance computed from it is likewise any kind of Lisp object. The\n"
2998 "SPECIFIER-DATA should be an alist of methods governing how the specifier\n"
2999 "works. All methods are optional, and reasonable default methods will be\n"
3000 "provided. Currently there are two defined methods: 'instantiate and\n"
3003 "'instantiate specifies how to do the instantiation; if omitted, the\n"
3004 "instantiator itself is simply returned as the instance. The method\n"
3005 "should be a function that accepts three parameters (a specifier, the\n"
3006 "instantiator that matched the domain being instantiated over, and that\n"
3007 "domain), and should return a one-element list containing the instance,\n"
3008 "or nil if no instance exists. Note that the domain passed to this function\n"
3009 "is the domain being instantiated over, which may not be the same as the\n"
3010 "locale contained in the specification corresponding to the instantiator\n"
3011 "(for example, the domain being instantiated over could be a window, but\n"
3012 "the locale corresponding to the passed instantiator could be the window's\n"
3013 "buffer or frame).\n"
3015 "'validate specifies whether a given instantiator is valid; if omitted,\n"
3016 "all instantiators are considered valid. It should be a function of\n"
3017 "two arguments: an instantiator and a flag CAN-SIGNAL-ERROR. If this\n"
3018 "flag is false, the function must simply return t or nil indicating\n"
3019 "whether the instantiator is valid. If this flag is true, the function\n"
3020 "is free to signal an error if it encounters an invalid instantiator\n"
3021 "(this can be useful for issuing a specific error about exactly why the\n"
3022 "instantiator is valid). It can also return nil to indicate an invalid\n"
3023 "instantiator; in this case, a general error will be signalled."
3027 DEFUN ("generic-specifier-p", Fgeneric_specifier_p, 1, 1, 0, /*
3028 Return non-nil if OBJECT is a generic specifier.
3030 See `make-generic-specifier' for a description of possible generic
3035 return GENERIC_SPECIFIERP (object) ? Qt : Qnil;
3039 /************************************************************************/
3040 /* Integer specifier type */
3041 /************************************************************************/
3043 DEFINE_SPECIFIER_TYPE (integer);
3046 integer_validate (Lisp_Object instantiator)
3048 CHECK_INT (instantiator);
3051 DEFUN ("integer-specifier-p", Finteger_specifier_p, 1, 1, 0, /*
3052 Return non-nil if OBJECT is an integer specifier.
3054 See `make-integer-specifier' for a description of possible integer
3059 return INTEGER_SPECIFIERP (object) ? Qt : Qnil;
3062 /************************************************************************/
3063 /* Non-negative-integer specifier type */
3064 /************************************************************************/
3066 DEFINE_SPECIFIER_TYPE (natnum);
3069 natnum_validate (Lisp_Object instantiator)
3071 CHECK_NATNUM (instantiator);
3074 DEFUN ("natnum-specifier-p", Fnatnum_specifier_p, 1, 1, 0, /*
3075 Return non-nil if OBJECT is a natnum (non-negative-integer) specifier.
3077 See `make-natnum-specifier' for a description of possible natnum
3082 return NATNUM_SPECIFIERP (object) ? Qt : Qnil;
3085 /************************************************************************/
3086 /* Boolean specifier type */
3087 /************************************************************************/
3089 DEFINE_SPECIFIER_TYPE (boolean);
3092 boolean_validate (Lisp_Object instantiator)
3094 if (!EQ (instantiator, Qt) && !EQ (instantiator, Qnil))
3095 signal_simple_error ("Must be t or nil", instantiator);
3098 DEFUN ("boolean-specifier-p", Fboolean_specifier_p, 1, 1, 0, /*
3099 Return non-nil if OBJECT is a boolean specifier.
3101 See `make-boolean-specifier' for a description of possible boolean
3106 return BOOLEAN_SPECIFIERP (object) ? Qt : Qnil;
3109 /************************************************************************/
3110 /* Display table specifier type */
3111 /************************************************************************/
3113 DEFINE_SPECIFIER_TYPE (display_table);
3115 #define VALID_SINGLE_DISPTABLE_INSTANTIATOR_P(instantiator) \
3116 (VECTORP (instantiator) \
3117 || (CHAR_TABLEP (instantiator) \
3118 && (XCHAR_TABLE_TYPE (instantiator) == CHAR_TABLE_TYPE_CHAR \
3119 || XCHAR_TABLE_TYPE (instantiator) == CHAR_TABLE_TYPE_GENERIC)) \
3120 || RANGE_TABLEP (instantiator))
3123 display_table_validate (Lisp_Object instantiator)
3125 if (NILP (instantiator))
3128 else if (CONSP (instantiator))
3131 EXTERNAL_LIST_LOOP (tail, instantiator)
3133 Lisp_Object car = XCAR (tail);
3134 if (!VALID_SINGLE_DISPTABLE_INSTANTIATOR_P (car))
3140 if (!VALID_SINGLE_DISPTABLE_INSTANTIATOR_P (instantiator))
3143 dead_wrong_type_argument (display_table_specifier_methods->predicate_symbol,
3149 DEFUN ("display-table-specifier-p", Fdisplay_table_specifier_p, 1, 1, 0, /*
3150 Return non-nil if OBJECT is a display-table specifier.
3152 See `current-display-table' for a description of possible display-table
3157 return DISPLAYTABLE_SPECIFIERP (object) ? Qt : Qnil;
3161 /************************************************************************/
3162 /* Initialization */
3163 /************************************************************************/
3166 syms_of_specifier (void)
3168 INIT_LRECORD_IMPLEMENTATION (specifier);
3170 defsymbol (&Qspecifierp, "specifierp");
3172 defsymbol (&Qconsole_type, "console-type");
3173 defsymbol (&Qdevice_class, "device-class");
3175 /* Qinteger, Qboolean, Qgeneric defined in general.c */
3176 defsymbol (&Qnatnum, "natnum");
3178 DEFSUBR (Fvalid_specifier_type_p);
3179 DEFSUBR (Fspecifier_type_list);
3180 DEFSUBR (Fmake_specifier);
3181 DEFSUBR (Fspecifierp);
3182 DEFSUBR (Fspecifier_type);
3184 DEFSUBR (Fvalid_specifier_locale_p);
3185 DEFSUBR (Fvalid_specifier_domain_p);
3186 DEFSUBR (Fvalid_specifier_locale_type_p);
3187 DEFSUBR (Fspecifier_locale_type_from_locale);
3189 DEFSUBR (Fvalid_specifier_tag_p);
3190 DEFSUBR (Fvalid_specifier_tag_set_p);
3191 DEFSUBR (Fcanonicalize_tag_set);
3192 DEFSUBR (Fdevice_matches_specifier_tag_set_p);
3193 DEFSUBR (Fdefine_specifier_tag);
3194 DEFSUBR (Fdevice_matching_specifier_tag_list);
3195 DEFSUBR (Fspecifier_tag_list);
3196 DEFSUBR (Fspecifier_tag_predicate);
3198 DEFSUBR (Fcheck_valid_instantiator);
3199 DEFSUBR (Fvalid_instantiator_p);
3200 DEFSUBR (Fcheck_valid_inst_list);
3201 DEFSUBR (Fvalid_inst_list_p);
3202 DEFSUBR (Fcheck_valid_spec_list);
3203 DEFSUBR (Fvalid_spec_list_p);
3204 DEFSUBR (Fadd_spec_to_specifier);
3205 DEFSUBR (Fadd_spec_list_to_specifier);
3206 DEFSUBR (Fspecifier_spec_list);
3207 DEFSUBR (Fspecifier_specs);
3208 DEFSUBR (Fremove_specifier);
3209 DEFSUBR (Fcopy_specifier);
3211 DEFSUBR (Fcheck_valid_specifier_matchspec);
3212 DEFSUBR (Fvalid_specifier_matchspec_p);
3213 DEFSUBR (Fspecifier_fallback);
3214 DEFSUBR (Fspecifier_instance);
3215 DEFSUBR (Fspecifier_matching_instance);
3216 DEFSUBR (Fspecifier_instance_from_inst_list);
3217 DEFSUBR (Fspecifier_matching_instance_from_inst_list);
3218 DEFSUBR (Fset_specifier_dirty_flag);
3220 DEFSUBR (Fgeneric_specifier_p);
3221 DEFSUBR (Finteger_specifier_p);
3222 DEFSUBR (Fnatnum_specifier_p);
3223 DEFSUBR (Fboolean_specifier_p);
3224 DEFSUBR (Fdisplay_table_specifier_p);
3226 /* Symbols pertaining to specifier creation. Specifiers are created
3227 in the syms_of() functions. */
3229 /* locales are defined in general.c. */
3231 defsymbol (&Qprepend, "prepend");
3232 defsymbol (&Qremove_tag_set_prepend, "remove-tag-set-prepend");
3233 defsymbol (&Qremove_tag_set_append, "remove-tag-set-append");
3234 defsymbol (&Qremove_locale, "remove-locale");
3235 defsymbol (&Qremove_locale_type, "remove-locale-type");
3236 defsymbol (&Qremove_all, "remove-all");
3238 defsymbol (&Qfallback, "fallback");
3242 specifier_type_create (void)
3244 the_specifier_type_entry_dynarr = Dynarr_new (specifier_type_entry);
3245 dumpstruct (&the_specifier_type_entry_dynarr, &sted_description);
3247 Vspecifier_type_list = Qnil;
3248 staticpro (&Vspecifier_type_list);
3250 INITIALIZE_SPECIFIER_TYPE (generic, "generic", "generic-specifier-p");
3252 INITIALIZE_SPECIFIER_TYPE (integer, "integer", "integer-specifier-p");
3254 SPECIFIER_HAS_METHOD (integer, validate);
3256 INITIALIZE_SPECIFIER_TYPE (natnum, "natnum", "natnum-specifier-p");
3258 SPECIFIER_HAS_METHOD (natnum, validate);
3260 INITIALIZE_SPECIFIER_TYPE (boolean, "boolean", "boolean-specifier-p");
3262 SPECIFIER_HAS_METHOD (boolean, validate);
3264 INITIALIZE_SPECIFIER_TYPE (display_table, "display-table", "display-table-p");
3266 SPECIFIER_HAS_METHOD (display_table, validate);
3270 reinit_specifier_type_create (void)
3272 REINITIALIZE_SPECIFIER_TYPE (generic);
3273 REINITIALIZE_SPECIFIER_TYPE (integer);
3274 REINITIALIZE_SPECIFIER_TYPE (natnum);
3275 REINITIALIZE_SPECIFIER_TYPE (boolean);
3276 REINITIALIZE_SPECIFIER_TYPE (display_table);
3280 vars_of_specifier (void)
3282 Vcached_specifiers = Qnil;
3283 staticpro (&Vcached_specifiers);
3285 /* Do NOT mark through this, or specifiers will never be GC'd.
3286 This is the same deal as for weak hash tables. */
3287 Vall_specifiers = Qnil;
3288 pdump_wire_list (&Vall_specifiers);
3290 Vuser_defined_tags = Qnil;
3291 staticpro (&Vuser_defined_tags);
3293 Vunlock_ghost_specifiers = Qnil;
3294 staticpro (&Vunlock_ghost_specifiers);