(JSP-5368): Separate JX1-7A24.
[chise/xemacs-chise.git.1] / src / specifier.c
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.
5
6 This file is part of XEmacs.
7
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
11 later version.
12
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
16 for more details.
17
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.  */
22
23 /* Synched up with: Not in FSF. */
24
25 /* Design by Ben Wing;
26    Original version by Chuck Thompson;
27    rewritten by Ben Wing;
28    Magic specifiers by Kirill Katsnelson;
29 */
30
31 #include <config.h>
32 #include "lisp.h"
33
34 #include "buffer.h"
35 #include "device.h"
36 #include "frame.h"
37 #include "opaque.h"
38 #include "specifier.h"
39 #include "window.h"
40 #include "chartab.h"
41 #include "rangetab.h"
42
43 Lisp_Object Qspecifierp;
44 Lisp_Object Qremove_tag_set_prepend, Qremove_tag_set_append;
45 Lisp_Object Qremove_locale, Qremove_locale_type;
46
47 Lisp_Object Qconsole_type, Qdevice_class;
48
49 Lisp_Object Qspecifier_syntax_error;
50 Lisp_Object Qspecifier_argument_error;
51 Lisp_Object Qspecifier_change_error;
52
53 static Lisp_Object Vuser_defined_tags;
54
55 typedef struct specifier_type_entry specifier_type_entry;
56 struct specifier_type_entry
57 {
58   Lisp_Object symbol;
59   struct specifier_methods *meths;
60 };
61
62 typedef struct
63 {
64   Dynarr_declare (specifier_type_entry);
65 } specifier_type_entry_dynarr;
66
67 static specifier_type_entry_dynarr *the_specifier_type_entry_dynarr;
68
69 static const struct lrecord_description ste_description_1[] = {
70   { XD_LISP_OBJECT, offsetof (specifier_type_entry, symbol) },
71   { XD_STRUCT_PTR,  offsetof (specifier_type_entry, meths), 1,
72     &specifier_methods_description },
73   { XD_END }
74 };
75
76 static const struct struct_description ste_description = {
77   sizeof (specifier_type_entry),
78   ste_description_1
79 };
80
81 static const struct lrecord_description sted_description_1[] = {
82   XD_DYNARR_DESC (specifier_type_entry_dynarr, &ste_description),
83   { XD_END }
84 };
85
86 static const struct struct_description sted_description = {
87   sizeof (specifier_type_entry_dynarr),
88   sted_description_1
89 };
90
91 static Lisp_Object Vspecifier_type_list;
92
93 static Lisp_Object Vcached_specifiers;
94 /* Do NOT mark through this, or specifiers will never be GC'd. */
95 static Lisp_Object Vall_specifiers;
96
97 static Lisp_Object Vunlock_ghost_specifiers;
98
99 /* #### The purpose of this is to check for inheritance loops
100    in specifiers that can inherit from other specifiers, but it's
101    not yet implemented.
102
103    #### Look into this for 19.14. */
104 /* static Lisp_Object_dynarr current_specifiers; */
105
106 static void recompute_cached_specifier_everywhere (Lisp_Object specifier);
107
108 EXFUN (Fspecifier_specs, 4);
109 EXFUN (Fremove_specifier, 4);
110
111 \f
112 /************************************************************************/
113 /*                       Specifier object methods                       */
114 /************************************************************************/
115
116 /* Remove dead objects from the specified assoc list. */
117
118 static Lisp_Object
119 cleanup_assoc_list (Lisp_Object list)
120 {
121   Lisp_Object loop, prev, retval;
122
123   loop = retval = list;
124   prev = Qnil;
125
126   while (!NILP (loop))
127     {
128       Lisp_Object entry = XCAR (loop);
129       Lisp_Object key = XCAR (entry);
130
131       /* remember, dead windows can become alive again. */
132       if (!WINDOWP (key) && object_dead_p (key))
133         {
134           if (NILP (prev))
135             {
136               /* Removing the head. */
137               retval = XCDR (retval);
138             }
139           else
140             {
141               Fsetcdr (prev, XCDR (loop));
142             }
143         }
144       else
145         prev = loop;
146
147       loop = XCDR (loop);
148     }
149
150   return retval;
151 }
152
153 /* Remove dead objects from the various lists so that they
154    don't keep getting marked as long as this specifier exists and
155    therefore wasting memory. */
156
157 void
158 cleanup_specifiers (void)
159 {
160   Lisp_Object rest;
161
162   for (rest = Vall_specifiers;
163        !NILP (rest);
164        rest = XSPECIFIER (rest)->next_specifier)
165     {
166       Lisp_Specifier *sp = XSPECIFIER (rest);
167       /* This effectively changes the specifier specs.
168          However, there's no need to call
169          recompute_cached_specifier_everywhere() or the
170          after-change methods because the only specs we
171          are removing are for dead objects, and they can
172          never have any effect on the specifier values:
173          specifiers can only be instantiated over live
174          objects, and you can't derive a dead object
175          from a live one. */
176       sp->device_specs = cleanup_assoc_list (sp->device_specs);
177       sp->frame_specs = cleanup_assoc_list (sp->frame_specs);
178       sp->buffer_specs = cleanup_assoc_list (sp->buffer_specs);
179       /* windows are handled specially because dead windows
180          can be resurrected */
181     }
182 }
183
184 void
185 kill_specifier_buffer_locals (Lisp_Object buffer)
186 {
187   Lisp_Object rest;
188
189   for (rest = Vall_specifiers;
190        !NILP (rest);
191        rest = XSPECIFIER (rest)->next_specifier)
192     {
193       Lisp_Specifier *sp = XSPECIFIER (rest);
194
195       /* Make sure we're actually going to be changing something.
196          Fremove_specifier() always calls
197          recompute_cached_specifier_everywhere() (#### but should
198          be smarter about this). */
199       if (!NILP (assq_no_quit (buffer, sp->buffer_specs)))
200         Fremove_specifier (rest, buffer, Qnil, Qnil);
201     }
202 }
203
204 static Lisp_Object
205 mark_specifier (Lisp_Object obj)
206 {
207   Lisp_Specifier *specifier = XSPECIFIER (obj);
208
209   mark_object (specifier->global_specs);
210   mark_object (specifier->device_specs);
211   mark_object (specifier->frame_specs);
212   mark_object (specifier->window_specs);
213   mark_object (specifier->buffer_specs);
214   mark_object (specifier->magic_parent);
215   mark_object (specifier->fallback);
216   if (!GHOST_SPECIFIER_P (XSPECIFIER (obj)))
217     MAYBE_SPECMETH (specifier, mark, (obj));
218   return Qnil;
219 }
220
221 /* The idea here is that the specifier specs point to locales
222    (windows, buffers, frames, and devices), and we want to make sure
223    that the specs disappear automatically when the associated locale
224    is no longer in use.  For all but windows, "no longer in use"
225    corresponds exactly to when the object is deleted (non-deleted
226    objects are always held permanently in special lists, and deleted
227    objects are never on these lists and never reusable).  To handle
228    this, we just have cleanup_specifiers() called periodically
229    (at the beginning of garbage collection); it removes all dead
230    objects.
231
232    For windows, however, it's trickier because dead objects can be
233    converted to live ones again if the dead object is in a window
234    configuration.  Therefore, for windows, "no longer in use"
235    corresponds to when the window object is garbage-collected.
236    We now use weak lists for this purpose.
237
238 */
239
240 void
241 prune_specifiers (void)
242 {
243   Lisp_Object rest, prev = Qnil;
244
245   for (rest = Vall_specifiers;
246        !NILP (rest);
247        rest = XSPECIFIER (rest)->next_specifier)
248     {
249       if (! marked_p (rest))
250         {
251           Lisp_Specifier* sp = XSPECIFIER (rest);
252           /* A bit of assertion that we're removing both parts of the
253              magic one altogether */
254           assert (!MAGIC_SPECIFIER_P(sp)
255                   || (BODILY_SPECIFIER_P(sp) && marked_p (sp->fallback))
256                   || (GHOST_SPECIFIER_P(sp) && marked_p (sp->magic_parent)));
257           /* This specifier is garbage.  Remove it from the list. */
258           if (NILP (prev))
259             Vall_specifiers = sp->next_specifier;
260           else
261             XSPECIFIER (prev)->next_specifier = sp->next_specifier;
262         }
263       else
264         prev = rest;
265     }
266 }
267
268 static void
269 print_specifier (Lisp_Object obj, Lisp_Object printcharfun, int escapeflag)
270 {
271   Lisp_Specifier *sp = XSPECIFIER (obj);
272   char buf[100];
273   int count = specpdl_depth ();
274   Lisp_Object the_specs;
275
276   if (print_readably)
277     error ("printing unreadable object #<%s-specifier 0x%x>",
278            sp->methods->name, sp->header.uid);
279
280   sprintf (buf, "#<%s-specifier global=", sp->methods->name);
281   write_c_string (buf, printcharfun);
282   specbind (Qprint_string_length, make_int (100));
283   specbind (Qprint_length, make_int (5));
284   the_specs = Fspecifier_specs (obj, Qglobal, Qnil, Qnil);
285   if (NILP (the_specs))
286     /* there are no global specs */
287     write_c_string ("<unspecified>", printcharfun);
288   else
289     print_internal (the_specs, printcharfun, 1);
290   if (!NILP (sp->fallback))
291     {
292       write_c_string (" fallback=", printcharfun);
293       print_internal (sp->fallback, printcharfun, escapeflag);
294     }
295   unbind_to (count, Qnil);
296   sprintf (buf, " 0x%x>", sp->header.uid);
297   write_c_string (buf, printcharfun);
298 }
299
300 static void
301 finalize_specifier (void *header, int for_disksave)
302 {
303   Lisp_Specifier *sp = (Lisp_Specifier *) header;
304   /* don't be snafued by the disksave finalization. */
305   if (!for_disksave && !GHOST_SPECIFIER_P(sp) && sp->caching)
306     {
307       xfree (sp->caching);
308       sp->caching = 0;
309     }
310 }
311
312 static int
313 specifier_equal (Lisp_Object obj1, Lisp_Object obj2, int depth)
314 {
315   Lisp_Specifier *s1 = XSPECIFIER (obj1);
316   Lisp_Specifier *s2 = XSPECIFIER (obj2);
317   int retval;
318   Lisp_Object old_inhibit_quit = Vinhibit_quit;
319
320   /* This function can be called from within redisplay.
321      internal_equal can trigger a quit.  That leads to Bad Things. */
322   Vinhibit_quit = Qt;
323
324   depth++;
325   retval =
326     (s1->methods == s2->methods &&
327      internal_equal (s1->global_specs, s2->global_specs, depth) &&
328      internal_equal (s1->device_specs, s2->device_specs, depth) &&
329      internal_equal (s1->frame_specs,  s2->frame_specs,  depth) &&
330      internal_equal (s1->window_specs, s2->window_specs, depth) &&
331      internal_equal (s1->buffer_specs, s2->buffer_specs, depth) &&
332      internal_equal (s1->fallback,     s2->fallback,     depth));
333
334   if (retval && HAS_SPECMETH_P (s1, equal))
335     retval = SPECMETH (s1, equal, (obj1, obj2, depth - 1));
336
337   Vinhibit_quit = old_inhibit_quit;
338   return retval;
339 }
340
341 static unsigned long
342 specifier_hash (Lisp_Object obj, int depth)
343 {
344   Lisp_Specifier *s = XSPECIFIER (obj);
345
346   /* specifier hashing is a bit problematic because there are so
347      many places where data can be stored.  We pick what are perhaps
348      the most likely places where interesting stuff will be. */
349   return HASH5 ((HAS_SPECMETH_P (s, hash) ?
350                  SPECMETH (s, hash, (obj, depth)) : 0),
351                 (unsigned long) s->methods,
352                 internal_hash (s->global_specs, depth + 1),
353                 internal_hash (s->frame_specs,  depth + 1),
354                 internal_hash (s->buffer_specs, depth + 1));
355 }
356
357 inline static size_t
358 aligned_sizeof_specifier (size_t specifier_type_specific_size)
359 {
360   return ALIGN_SIZE (offsetof (Lisp_Specifier, data)
361                      + specifier_type_specific_size,
362                      ALIGNOF (max_align_t));
363 }
364
365 static size_t
366 sizeof_specifier (const void *header)
367 {
368   const Lisp_Specifier *p = (const Lisp_Specifier *) header;
369   return aligned_sizeof_specifier (GHOST_SPECIFIER_P (p)
370                                    ? 0
371                                    : p->methods->extra_data_size);
372 }
373
374 static const struct lrecord_description specifier_methods_description_1[] = {
375   { XD_LISP_OBJECT, offsetof (struct specifier_methods, predicate_symbol) },
376   { XD_END }
377 };
378
379 const struct struct_description specifier_methods_description = {
380   sizeof (struct specifier_methods),
381   specifier_methods_description_1
382 };
383
384 static const struct lrecord_description specifier_caching_description_1[] = {
385   { XD_END }
386 };
387
388 static const struct struct_description specifier_caching_description = {
389   sizeof (struct specifier_caching),
390   specifier_caching_description_1
391 };
392
393 static const struct lrecord_description specifier_description[] = {
394   { XD_STRUCT_PTR,  offsetof (Lisp_Specifier, methods), 1,
395     &specifier_methods_description },
396   { XD_LO_LINK,     offsetof (Lisp_Specifier, next_specifier) },
397   { XD_LISP_OBJECT, offsetof (Lisp_Specifier, global_specs) },
398   { XD_LISP_OBJECT, offsetof (Lisp_Specifier, device_specs) },
399   { XD_LISP_OBJECT, offsetof (Lisp_Specifier, frame_specs) },
400   { XD_LISP_OBJECT, offsetof (Lisp_Specifier, window_specs) },
401   { XD_LISP_OBJECT, offsetof (Lisp_Specifier, buffer_specs) },
402   { XD_STRUCT_PTR,  offsetof (Lisp_Specifier, caching), 1,
403     &specifier_caching_description },
404   { XD_LISP_OBJECT, offsetof (Lisp_Specifier, magic_parent) },
405   { XD_LISP_OBJECT, offsetof (Lisp_Specifier, fallback) },
406   { XD_SPECIFIER_END }
407 };
408
409 const struct lrecord_description specifier_empty_extra_description[] = {
410   { XD_END }
411 };
412
413 DEFINE_LRECORD_SEQUENCE_IMPLEMENTATION ("specifier", specifier,
414                                         mark_specifier, print_specifier,
415                                         finalize_specifier,
416                                         specifier_equal, specifier_hash,
417                                         specifier_description,
418                                         sizeof_specifier,
419                                         Lisp_Specifier);
420 \f
421 /************************************************************************/
422 /*                       Creating specifiers                            */
423 /************************************************************************/
424
425 static struct specifier_methods *
426 decode_specifier_type (Lisp_Object type, Error_behavior errb)
427 {
428   int i;
429
430   for (i = 0; i < Dynarr_length (the_specifier_type_entry_dynarr); i++)
431     {
432       if (EQ (type, Dynarr_at (the_specifier_type_entry_dynarr, i).symbol))
433         return Dynarr_at (the_specifier_type_entry_dynarr, i).meths;
434     }
435
436   maybe_signal_type_error (Qspecifier_argument_error, "Invalid specifier type",
437                            type, Qspecifier, errb);
438
439   return 0;
440 }
441
442 static int
443 valid_specifier_type_p (Lisp_Object type)
444 {
445   return decode_specifier_type (type, ERROR_ME_NOT) != 0;
446 }
447
448 DEFUN ("valid-specifier-type-p", Fvalid_specifier_type_p, 1, 1, 0, /*
449 Given a SPECIFIER-TYPE, return non-nil if it is valid.
450 Valid types are 'generic, 'integer, 'boolean, 'color, 'font, 'image,
451 'face-boolean, and 'toolbar.
452 */
453        (specifier_type))
454 {
455   return valid_specifier_type_p (specifier_type) ? Qt : Qnil;
456 }
457
458 DEFUN ("specifier-type-list", Fspecifier_type_list, 0, 0, 0, /*
459 Return a list of valid specifier types.
460 */
461        ())
462 {
463   return Fcopy_sequence (Vspecifier_type_list);
464 }
465
466 void
467 add_entry_to_specifier_type_list (Lisp_Object symbol,
468                                   struct specifier_methods *meths)
469 {
470   struct specifier_type_entry entry;
471
472   entry.symbol = symbol;
473   entry.meths = meths;
474   Dynarr_add (the_specifier_type_entry_dynarr, entry);
475   Vspecifier_type_list = Fcons (symbol, Vspecifier_type_list);
476 }
477
478 static Lisp_Object
479 make_specifier_internal (struct specifier_methods *spec_meths,
480                          size_t data_size, int call_create_meth)
481 {
482   Lisp_Object specifier;
483   Lisp_Specifier *sp = (Lisp_Specifier *)
484     alloc_lcrecord (aligned_sizeof_specifier (data_size), &lrecord_specifier);
485
486   sp->methods = spec_meths;
487   sp->global_specs = Qnil;
488   sp->device_specs = Qnil;
489   sp->frame_specs = Qnil;
490   sp->window_specs = make_weak_list (WEAK_LIST_KEY_ASSOC);
491   sp->buffer_specs = Qnil;
492   sp->fallback = Qnil;
493   sp->magic_parent = Qnil;
494   sp->caching = 0;
495   sp->next_specifier = Vall_specifiers;
496
497   XSETSPECIFIER (specifier, sp);
498   Vall_specifiers = specifier;
499
500   if (call_create_meth)
501     {
502       struct gcpro gcpro1;
503       GCPRO1 (specifier);
504       MAYBE_SPECMETH (XSPECIFIER (specifier), create, (specifier));
505       UNGCPRO;
506     }
507   return specifier;
508 }
509
510 static Lisp_Object
511 make_specifier (struct specifier_methods *meths)
512 {
513   return make_specifier_internal (meths, meths->extra_data_size, 1);
514 }
515
516 Lisp_Object
517 make_magic_specifier (Lisp_Object type)
518 {
519   /* This function can GC */
520   struct specifier_methods *meths = decode_specifier_type (type, ERROR_ME);
521   Lisp_Object bodily, ghost;
522   struct gcpro gcpro1;
523
524   bodily = make_specifier (meths);
525   GCPRO1 (bodily);
526   ghost  = make_specifier_internal (meths, 0, 0);
527   UNGCPRO;
528
529   /* Connect guys together */
530   XSPECIFIER(bodily)->magic_parent = Qt;
531   XSPECIFIER(bodily)->fallback = ghost;
532   XSPECIFIER(ghost)->magic_parent = bodily;
533
534   return bodily;
535 }
536
537 DEFUN ("make-specifier", Fmake_specifier, 1, 1, 0, /*
538 Return a new specifier object of type TYPE.
539
540 A specifier is an object that can be used to keep track of a property
541 whose value can be per-buffer, per-window, per-frame, or per-device,
542 and can further be restricted to a particular console-type or
543 device-class.  Specifiers are used, for example, for the various
544 built-in properties of a face; this allows a face to have different
545 values in different frames, buffers, etc.
546
547 When speaking of the value of a specifier, it is important to
548 distinguish between the *setting* of a specifier, called an
549 \"instantiator\", and the *actual value*, called an \"instance\".  You
550 put various possible instantiators (i.e. settings) into a specifier
551 and associate them with particular locales (buffer, window, frame,
552 device, global), and then the instance (i.e. actual value) is
553 retrieved in a specific domain (window, frame, device) by looking
554 through the possible instantiators (i.e. settings).  This process is
555 called \"instantiation\".
556
557 To put settings into a specifier, use `set-specifier', or the
558 lower-level functions `add-spec-to-specifier' and
559 `add-spec-list-to-specifier'.  You can also temporarily bind a setting
560 to a specifier using `let-specifier'.  To retrieve settings, use
561 `specifier-specs', or its lower-level counterpart
562 `specifier-spec-list'.  To determine the actual value, use
563 `specifier-instance'.
564
565 For more information, see `set-specifier', `specifier-instance',
566 `specifier-specs', and `add-spec-to-specifier'; or, for a detailed
567 description of specifiers, including how exactly the instantiation
568 process works, see the chapter on specifiers in the XEmacs Lisp
569 Reference Manual.
570
571 TYPE specifies the particular type of specifier, and should be one of
572 the symbols 'generic, 'integer, 'natnum, 'boolean, 'color, 'font,
573 'image, 'face-boolean, 'display-table, 'gutter, 'gutter-size,
574 'gutter-visible or 'toolbar.
575
576 For more information on particular types of specifiers, see the
577 functions `make-generic-specifier', `make-integer-specifier',
578 `make-natnum-specifier', `make-boolean-specifier',
579 `make-color-specifier', `make-font-specifier', `make-image-specifier',
580 `make-face-boolean-specifier', `make-gutter-size-specifier',
581 `make-gutter-visible-specifier', `default-toolbar', `default-gutter',
582 and `current-display-table'.
583 */
584        (type))
585 {
586   /* This function can GC */
587   struct specifier_methods *meths = decode_specifier_type (type, ERROR_ME);
588
589   return make_specifier (meths);
590 }
591
592 DEFUN ("specifierp", Fspecifierp, 1, 1, 0, /*
593 Return t if OBJECT is a specifier.
594
595 A specifier is an object that can be used to keep track of a property
596 whose value can be per-buffer, per-window, per-frame, or per-device,
597 and can further be restricted to a particular console-type or device-class.
598 See `make-specifier'.
599 */
600        (object))
601 {
602   return SPECIFIERP (object) ? Qt : Qnil;
603 }
604
605 DEFUN ("specifier-type", Fspecifier_type, 1, 1, 0, /*
606 Return the type of SPECIFIER.
607 */
608        (specifier))
609 {
610   CHECK_SPECIFIER (specifier);
611   return intern (XSPECIFIER (specifier)->methods->name);
612 }
613
614 \f
615 /************************************************************************/
616 /*                       Locales and domains                            */
617 /************************************************************************/
618
619 DEFUN ("valid-specifier-locale-p", Fvalid_specifier_locale_p, 1, 1, 0, /*
620 Return t if LOCALE is a valid specifier locale.
621 Valid locales are devices, frames, windows, buffers, and 'global.
622 \(nil is not valid.)
623 */
624        (locale))
625 {
626   /* This cannot GC. */
627   return ((DEVICEP (locale) && DEVICE_LIVE_P (XDEVICE (locale))) ||
628           (FRAMEP  (locale) && FRAME_LIVE_P  (XFRAME  (locale))) ||
629           (BUFFERP (locale) && BUFFER_LIVE_P (XBUFFER (locale))) ||
630           /* dead windows are allowed because they may become live
631              windows again when a window configuration is restored */
632           WINDOWP (locale) ||
633           EQ (locale, Qglobal))
634     ? Qt : Qnil;
635 }
636
637 DEFUN ("valid-specifier-domain-p", Fvalid_specifier_domain_p, 1, 1, 0, /*
638 Return t if DOMAIN is a valid specifier domain.
639 A domain is used to instance a specifier (i.e. determine the specifier's
640 value in that domain).  Valid domains are image instances, windows, frames,
641 and devices. \(nil is not valid.) image instances are pseudo-domains since
642 instantiation will actually occur in the window the image instance itself is
643 instantiated in.
644 */
645      (domain))
646 {
647   /* This cannot GC. */
648   return ((DEVICEP (domain) && DEVICE_LIVE_P (XDEVICE (domain))) ||
649           (FRAMEP  (domain) && FRAME_LIVE_P  (XFRAME  (domain))) ||
650           (WINDOWP (domain) && WINDOW_LIVE_P (XWINDOW (domain))) ||
651           /* #### get image instances out of domains! */
652           IMAGE_INSTANCEP (domain))
653     ? Qt : Qnil;
654 }
655
656 DEFUN ("valid-specifier-locale-type-p", Fvalid_specifier_locale_type_p, 1, 1, 0,
657        /*
658 Given a specifier LOCALE-TYPE, return non-nil if it is valid.
659 Valid locale types are 'global, 'device, 'frame, 'window, and 'buffer.
660 \(Note, however, that in functions that accept either a locale or a locale
661 type, 'global is considered an individual locale.)
662 */
663      (locale_type))
664 {
665   /* This cannot GC. */
666   return (EQ (locale_type, Qglobal) ||
667           EQ (locale_type, Qdevice) ||
668           EQ (locale_type, Qframe)  ||
669           EQ (locale_type, Qwindow) ||
670           EQ (locale_type, Qbuffer)) ? Qt : Qnil;
671 }
672
673 static void
674 check_valid_locale_or_locale_type (Lisp_Object locale)
675 {
676   /* This cannot GC. */
677   if (EQ (locale, Qall) ||
678       !NILP (Fvalid_specifier_locale_p (locale)) ||
679       !NILP (Fvalid_specifier_locale_type_p (locale)))
680     return;
681   signal_type_error (Qspecifier_argument_error,
682                      "Invalid specifier locale or locale type", locale);
683 }
684
685 DEFUN ("specifier-locale-type-from-locale", Fspecifier_locale_type_from_locale,
686        1, 1, 0, /*
687 Given a specifier LOCALE, return its type.
688 */
689        (locale))
690 {
691   /* This cannot GC. */
692   if (NILP (Fvalid_specifier_locale_p (locale)))
693     signal_type_error (Qspecifier_argument_error, "Invalid specifier locale",
694                        locale);
695   if (DEVICEP (locale)) return Qdevice;
696   if (FRAMEP  (locale)) return Qframe;
697   if (WINDOWP (locale)) return Qwindow;
698   if (BUFFERP (locale)) return Qbuffer;
699   assert (EQ (locale, Qglobal));
700   return Qglobal;
701 }
702
703 static Lisp_Object
704 decode_locale (Lisp_Object locale)
705 {
706   /* This cannot GC. */
707   if (NILP (locale))
708     return Qglobal;
709   else if (!NILP (Fvalid_specifier_locale_p (locale)))
710     return locale;
711   else
712     signal_type_error (Qspecifier_argument_error, "Invalid specifier locale",
713                        locale);
714
715   return Qnil;
716 }
717
718 static enum spec_locale_type
719 decode_locale_type (Lisp_Object locale_type)
720 {
721   /* This cannot GC. */
722   if (EQ (locale_type, Qglobal)) return LOCALE_GLOBAL;
723   if (EQ (locale_type, Qdevice)) return LOCALE_DEVICE;
724   if (EQ (locale_type, Qframe))  return LOCALE_FRAME;
725   if (EQ (locale_type, Qwindow)) return LOCALE_WINDOW;
726   if (EQ (locale_type, Qbuffer)) return LOCALE_BUFFER;
727
728   signal_type_error (Qspecifier_argument_error, "Invalid specifier locale type",
729                      locale_type);
730   return LOCALE_GLOBAL; /* not reached */
731 }
732
733 Lisp_Object
734 decode_locale_list (Lisp_Object locale)
735 {
736   /* This cannot GC. */
737   /* The return value of this function must be GCPRO'd. */
738   if (NILP (locale))
739     {
740       return list1 (Qall);
741     }
742   else if (CONSP (locale))
743     {
744       EXTERNAL_LIST_LOOP_2 (elt, locale)
745         check_valid_locale_or_locale_type (elt);
746       return locale;
747     }
748   else
749     {
750       check_valid_locale_or_locale_type (locale);
751       return list1 (locale);
752     }
753 }
754
755 static enum spec_locale_type
756 locale_type_from_locale (Lisp_Object locale)
757 {
758   return decode_locale_type (Fspecifier_locale_type_from_locale (locale));
759 }
760
761 static void
762 check_valid_domain (Lisp_Object domain)
763 {
764   if (NILP (Fvalid_specifier_domain_p (domain)))
765     signal_type_error (Qspecifier_argument_error, "Invalid specifier domain",
766                        domain);
767 }
768
769 Lisp_Object
770 decode_domain (Lisp_Object domain)
771 {
772   if (NILP (domain))
773     return Fselected_window (Qnil);
774   check_valid_domain (domain);
775   return domain;
776 }
777
778 \f
779 /************************************************************************/
780 /*                                 Tags                                 */
781 /************************************************************************/
782
783 DEFUN ("valid-specifier-tag-p", Fvalid_specifier_tag_p, 1, 1, 0, /*
784 Return non-nil if TAG is a valid specifier tag.
785 See also `valid-specifier-tag-set-p'.
786 */
787        (tag))
788 {
789   return (valid_console_type_p (tag) ||
790           valid_device_class_p (tag) ||
791           !NILP (assq_no_quit (tag, Vuser_defined_tags))) ? Qt : Qnil;
792 }
793
794 DEFUN ("valid-specifier-tag-set-p", Fvalid_specifier_tag_set_p, 1, 1, 0, /*
795 Return non-nil if TAG-SET is a valid specifier tag set.
796
797 A specifier tag set is an entity that is attached to an instantiator
798 and can be used to restrict the scope of that instantiator to a
799 particular device class or device type and/or to mark instantiators
800 added by a particular package so that they can be later removed.
801
802 A specifier tag set consists of a list of zero of more specifier tags,
803 each of which is a symbol that is recognized by XEmacs as a tag.
804 \(The valid device types and device classes are always tags, as are
805 any tags defined by `define-specifier-tag'.) It is called a "tag set"
806 \(as opposed to a list) because the order of the tags or the number of
807 times a particular tag occurs does not matter.
808
809 Each tag has a predicate associated with it, which specifies whether
810 that tag applies to a particular device.  The tags which are device types
811 and classes match devices of that type or class.  User-defined tags can
812 have any predicate, or none (meaning that all devices match).  When
813 attempting to instance a specifier, a particular instantiator is only
814 considered if the device of the domain being instanced over matches
815 all tags in the tag set attached to that instantiator.
816
817 Most of the time, a tag set is not specified, and the instantiator
818 gets a null tag set, which matches all devices.
819 */
820      (tag_set))
821 {
822   Lisp_Object rest;
823
824   for (rest = tag_set; !NILP (rest); rest = XCDR (rest))
825     {
826       if (!CONSP (rest))
827         return Qnil;
828       if (NILP (Fvalid_specifier_tag_p (XCAR (rest))))
829         return Qnil;
830       QUIT;
831     }
832   return Qt;
833 }
834
835 Lisp_Object
836 decode_specifier_tag_set (Lisp_Object tag_set)
837 {
838   /* The return value of this function must be GCPRO'd. */
839   if (!NILP (Fvalid_specifier_tag_p (tag_set)))
840     return list1 (tag_set);
841   if (NILP (Fvalid_specifier_tag_set_p (tag_set)))
842     signal_type_error (Qspecifier_argument_error, "Invalid specifier tag-set",
843                        tag_set);
844   return tag_set;
845 }
846
847 static Lisp_Object
848 canonicalize_tag_set (Lisp_Object tag_set)
849 {
850   int len = XINT (Flength (tag_set));
851   Lisp_Object *tags, rest;
852   int i, j;
853
854   /* We assume in this function that the tag_set has already been
855      validated, so there are no surprises. */
856
857   if (len == 0 || len == 1)
858     /* most common case */
859     return tag_set;
860
861   tags = alloca_array (Lisp_Object, len);
862
863   i = 0;
864   LIST_LOOP (rest, tag_set)
865     tags[i++] = XCAR (rest);
866
867   /* Sort the list of tags.  We use a bubble sort here (copied from
868      extent_fragment_update()) -- reduces the function call overhead,
869      and is the fastest sort for small numbers of items. */
870
871   for (i = 1; i < len; i++)
872     {
873       j = i - 1;
874       while (j >= 0 &&
875              strcmp ((char *) string_data (XSYMBOL (tags[j])->name),
876                      (char *) string_data (XSYMBOL (tags[j+1])->name)) > 0)
877         {
878           Lisp_Object tmp = tags[j];
879           tags[j] = tags[j+1];
880           tags[j+1] = tmp;
881           j--;
882         }
883     }
884
885   /* Now eliminate duplicates. */
886
887   for (i = 1, j = 1; i < len; i++)
888     {
889       /* j holds the destination, i the source. */
890       if (!EQ (tags[i], tags[i-1]))
891         tags[j++] = tags[i];
892     }
893
894   return Flist (j, tags);
895 }
896
897 DEFUN ("canonicalize-tag-set", Fcanonicalize_tag_set, 1, 1, 0, /*
898 Canonicalize the given tag set.
899 Two canonicalized tag sets can be compared with `equal' to see if they
900 represent the same tag set. (Specifically, canonicalizing involves
901 sorting by symbol name and removing duplicates.)
902 */
903        (tag_set))
904 {
905   if (NILP (Fvalid_specifier_tag_set_p (tag_set)))
906     signal_type_error (Qspecifier_argument_error, "Invalid tag set", tag_set);
907   return canonicalize_tag_set (tag_set);
908 }
909
910 static int
911 device_matches_specifier_tag_set_p (Lisp_Object device, Lisp_Object tag_set)
912 {
913   Lisp_Object devtype, devclass, rest;
914   struct device *d = XDEVICE (device);
915
916   devtype = DEVICE_TYPE (d);
917   devclass = DEVICE_CLASS (d);
918
919   LIST_LOOP (rest, tag_set)
920     {
921       Lisp_Object tag = XCAR (rest);
922       Lisp_Object assoc;
923
924       if (EQ (tag, devtype) || EQ (tag, devclass))
925         continue;
926       assoc = assq_no_quit (tag, DEVICE_USER_DEFINED_TAGS (d));
927       /* other built-in tags (device types/classes) are not in
928          the user-defined-tags list. */
929       if (NILP (assoc) || NILP (XCDR (assoc)))
930         return 0;
931     }
932
933   return 1;
934 }
935
936 DEFUN ("device-matches-specifier-tag-set-p",
937        Fdevice_matches_specifier_tag_set_p, 2, 2, 0, /*
938 Return non-nil if DEVICE matches specifier tag set TAG-SET.
939 This means that DEVICE matches each tag in the tag set. (Every
940 tag recognized by XEmacs has a predicate associated with it that
941 specifies which devices match it.)
942 */
943        (device, tag_set))
944 {
945   CHECK_LIVE_DEVICE (device);
946
947   if (NILP (Fvalid_specifier_tag_set_p (tag_set)))
948     signal_type_error (Qspecifier_argument_error, "Invalid tag set", tag_set);
949
950   return device_matches_specifier_tag_set_p (device, tag_set) ? Qt : Qnil;
951 }
952
953 DEFUN ("define-specifier-tag", Fdefine_specifier_tag, 1, 2, 0, /*
954 Define a new specifier tag.
955 If PREDICATE is specified, it should be a function of one argument
956 \(a device) that specifies whether the tag matches that particular
957 device.  If PREDICATE is omitted, the tag matches all devices.
958
959 You can redefine an existing user-defined specifier tag.  However,
960 you cannot redefine the built-in specifier tags (the device types
961 and classes) or the symbols nil, t, 'all, or 'global.
962 */
963        (tag, predicate))
964 {
965   Lisp_Object assoc, devcons, concons;
966   int recompute = 0;
967
968   CHECK_SYMBOL (tag);
969   if (valid_device_class_p (tag) ||
970       valid_console_type_p (tag))
971     signal_type_error (Qspecifier_change_error,
972                        "Cannot redefine built-in specifier tags", tag);
973   /* Try to prevent common instantiators and locales from being
974      redefined, to reduce ambiguity */
975   if (NILP (tag) || EQ (tag, Qt) || EQ (tag, Qall) || EQ (tag, Qglobal))
976     signal_type_error (Qspecifier_change_error, "Cannot define nil, t, 'all, or 'global",
977                        tag);
978   assoc = assq_no_quit (tag, Vuser_defined_tags);
979   if (NILP (assoc))
980     {
981       recompute = 1;
982       Vuser_defined_tags = Fcons (Fcons (tag, predicate), Vuser_defined_tags);
983       DEVICE_LOOP_NO_BREAK (devcons, concons)
984         {
985           struct device *d = XDEVICE (XCAR (devcons));
986           /* Initially set the value to t in case of error
987              in predicate */
988           DEVICE_USER_DEFINED_TAGS (d) =
989             Fcons (Fcons (tag, Qt), DEVICE_USER_DEFINED_TAGS (d));
990         }
991     }
992   else if (!NILP (predicate) && !NILP (XCDR (assoc)))
993     {
994       recompute = 1;
995       XCDR (assoc) = predicate;
996     }
997
998   /* recompute the tag values for all devices.  However, in the special
999      case where both the old and new predicates are nil, we know that
1000      we don't have to do this. (It's probably common for people to
1001      call (define-specifier-tag) more than once on the same tag,
1002      and the most common case is where PREDICATE is not specified.) */
1003
1004   if (recompute)
1005     {
1006       DEVICE_LOOP_NO_BREAK (devcons, concons)
1007         {
1008           Lisp_Object device = XCAR (devcons);
1009           assoc = assq_no_quit (tag,
1010                                 DEVICE_USER_DEFINED_TAGS (XDEVICE (device)));
1011           assert (CONSP (assoc));
1012           if (NILP (predicate))
1013             XCDR (assoc) = Qt;
1014           else
1015             XCDR (assoc) = !NILP (call1 (predicate, device)) ? Qt : Qnil;
1016         }
1017     }
1018
1019   return Qnil;
1020 }
1021
1022 /* Called at device-creation time to initialize the user-defined
1023    tag values for the newly-created device. */
1024
1025 void
1026 setup_device_initial_specifier_tags (struct device *d)
1027 {
1028   Lisp_Object rest, rest2;
1029   Lisp_Object device;
1030
1031   XSETDEVICE (device, d);
1032
1033   DEVICE_USER_DEFINED_TAGS (d) = Fcopy_alist (Vuser_defined_tags);
1034
1035   /* Now set up the initial values */
1036   LIST_LOOP (rest, DEVICE_USER_DEFINED_TAGS (d))
1037     XCDR (XCAR (rest)) = Qt;
1038
1039   for (rest = Vuser_defined_tags, rest2 = DEVICE_USER_DEFINED_TAGS (d);
1040        !NILP (rest); rest = XCDR (rest), rest2 = XCDR (rest2))
1041     {
1042       Lisp_Object predicate = XCDR (XCAR (rest));
1043       if (NILP (predicate))
1044         XCDR (XCAR (rest2)) = Qt;
1045       else
1046         XCDR (XCAR (rest2)) = !NILP (call1 (predicate, device)) ? Qt : Qnil;
1047     }
1048 }
1049
1050 DEFUN ("device-matching-specifier-tag-list",
1051        Fdevice_matching_specifier_tag_list,
1052        0, 1, 0, /*
1053 Return a list of all specifier tags matching DEVICE.
1054 DEVICE defaults to the selected device if omitted.
1055 */
1056        (device))
1057 {
1058   struct device *d = decode_device (device);
1059   Lisp_Object rest, list = Qnil;
1060   struct gcpro gcpro1;
1061
1062   GCPRO1 (list);
1063
1064   LIST_LOOP (rest, DEVICE_USER_DEFINED_TAGS (d))
1065     {
1066       if (!NILP (XCDR (XCAR (rest))))
1067         list = Fcons (XCAR (XCAR (rest)), list);
1068     }
1069
1070   list = Fnreverse (list);
1071   list = Fcons (DEVICE_CLASS (d), list);
1072   list = Fcons (DEVICE_TYPE  (d), list);
1073
1074   RETURN_UNGCPRO (list);
1075 }
1076
1077 DEFUN ("specifier-tag-list", Fspecifier_tag_list, 0, 0, 0, /*
1078 Return a list of all currently-defined specifier tags.
1079 This includes the built-in ones (the device types and classes).
1080 */
1081        ())
1082 {
1083   Lisp_Object list = Qnil, rest;
1084   struct gcpro gcpro1;
1085
1086   GCPRO1 (list);
1087
1088   LIST_LOOP (rest, Vuser_defined_tags)
1089     list = Fcons (XCAR (XCAR (rest)), list);
1090
1091   list = Fnreverse (list);
1092   list = nconc2 (Fcopy_sequence (Vdevice_class_list), list);
1093   list = nconc2 (Fcopy_sequence (Vconsole_type_list), list);
1094
1095   RETURN_UNGCPRO (list);
1096 }
1097
1098 DEFUN ("specifier-tag-predicate", Fspecifier_tag_predicate, 1, 1, 0, /*
1099 Return the predicate for the given specifier tag.
1100 */
1101        (tag))
1102 {
1103   /* The return value of this function must be GCPRO'd. */
1104   CHECK_SYMBOL (tag);
1105
1106   if (NILP (Fvalid_specifier_tag_p (tag)))
1107     signal_type_error (Qspecifier_argument_error, "Invalid specifier tag",
1108                        tag);
1109
1110   /* Make up some predicates for the built-in types */
1111
1112   if (valid_console_type_p (tag))
1113     return list3 (Qlambda, list1 (Qdevice),
1114                   list3 (Qeq, list2 (Qquote, tag),
1115                          list2 (Qconsole_type, Qdevice)));
1116
1117   if (valid_device_class_p (tag))
1118     return list3 (Qlambda, list1 (Qdevice),
1119                   list3 (Qeq, list2 (Qquote, tag),
1120                          list2 (Qdevice_class, Qdevice)));
1121
1122   return XCDR (assq_no_quit (tag, Vuser_defined_tags));
1123 }
1124
1125 /* Return true if A "matches" B.  If EXACT_P is 0, A must be a subset of B.
1126   Otherwise, A must be `equal' to B.  The sets must be canonicalized. */
1127 static int
1128 tag_sets_match_p (Lisp_Object a, Lisp_Object b, int exact_p)
1129 {
1130   if (!exact_p)
1131     {
1132       while (!NILP (a) && !NILP (b))
1133         {
1134           if (EQ (XCAR (a), XCAR (b)))
1135             a = XCDR (a);
1136           b = XCDR (b);
1137         }
1138
1139       return NILP (a);
1140     }
1141   else
1142     {
1143       while (!NILP (a) && !NILP (b))
1144         {
1145           if (!EQ (XCAR (a), XCAR (b)))
1146             return 0;
1147           a = XCDR (a);
1148           b = XCDR (b);
1149         }
1150
1151       return NILP (a) && NILP (b);
1152     }
1153 }
1154
1155 \f
1156 /************************************************************************/
1157 /*                       Spec-lists and inst-lists                      */
1158 /************************************************************************/
1159
1160 static Lisp_Object
1161 call_validate_method (Lisp_Object boxed_method, Lisp_Object instantiator)
1162 {
1163   ((void (*)(Lisp_Object)) get_opaque_ptr (boxed_method)) (instantiator);
1164   return Qt;
1165 }
1166
1167 static Lisp_Object
1168 check_valid_instantiator (Lisp_Object instantiator,
1169                           struct specifier_methods *meths,
1170                           Error_behavior errb)
1171 {
1172   if (meths->validate_method)
1173     {
1174       Lisp_Object retval;
1175
1176       if (ERRB_EQ (errb, ERROR_ME))
1177         {
1178           (meths->validate_method) (instantiator);
1179           retval = Qt;
1180         }
1181       else
1182         {
1183           Lisp_Object opaque = make_opaque_ptr ((void *)
1184                                                 meths->validate_method);
1185           struct gcpro gcpro1;
1186
1187           GCPRO1 (opaque);
1188           retval = call_with_suspended_errors
1189             ((lisp_fn_t) call_validate_method,
1190              Qnil, Qspecifier, errb, 2, opaque, instantiator);
1191
1192           free_opaque_ptr (opaque);
1193           UNGCPRO;
1194         }
1195
1196       return retval;
1197     }
1198   return Qt;
1199 }
1200
1201 DEFUN ("check-valid-instantiator", Fcheck_valid_instantiator, 2, 2, 0, /*
1202 Signal an error if INSTANTIATOR is invalid for SPECIFIER-TYPE.
1203 */
1204        (instantiator, specifier_type))
1205 {
1206   struct specifier_methods *meths = decode_specifier_type (specifier_type,
1207                                                            ERROR_ME);
1208
1209   return check_valid_instantiator (instantiator, meths, ERROR_ME);
1210 }
1211
1212 DEFUN ("valid-instantiator-p", Fvalid_instantiator_p, 2, 2, 0, /*
1213 Return non-nil if INSTANTIATOR is valid for SPECIFIER-TYPE.
1214 */
1215        (instantiator, specifier_type))
1216 {
1217   struct specifier_methods *meths = decode_specifier_type (specifier_type,
1218                                                            ERROR_ME);
1219
1220   return check_valid_instantiator (instantiator, meths, ERROR_ME_NOT);
1221 }
1222
1223 static Lisp_Object
1224 check_valid_inst_list (Lisp_Object inst_list, struct specifier_methods *meths,
1225                        Error_behavior errb)
1226 {
1227   Lisp_Object rest;
1228
1229   LIST_LOOP (rest, inst_list)
1230     {
1231       Lisp_Object inst_pair, tag_set;
1232
1233       if (!CONSP (rest))
1234         {
1235           maybe_signal_type_error (Qspecifier_syntax_error,
1236                                    "Invalid instantiator list", inst_list,
1237                                      Qspecifier, errb);
1238           return Qnil;
1239         }
1240       if (!CONSP (inst_pair = XCAR (rest)))
1241         {
1242           maybe_signal_type_error (Qspecifier_syntax_error,
1243                                    "Invalid instantiator pair", inst_pair,
1244                                      Qspecifier, errb);
1245           return Qnil;
1246         }
1247       if (NILP (Fvalid_specifier_tag_set_p (tag_set = XCAR (inst_pair))))
1248         {
1249           maybe_signal_type_error (Qspecifier_syntax_error,
1250                                    "Invalid specifier tag", tag_set,
1251                                      Qspecifier, errb);
1252           return Qnil;
1253         }
1254
1255       if (NILP (check_valid_instantiator (XCDR (inst_pair), meths, errb)))
1256         return Qnil;
1257     }
1258
1259   return Qt;
1260 }
1261
1262 DEFUN ("check-valid-inst-list", Fcheck_valid_inst_list, 2, 2, 0, /*
1263 Signal an error if INST-LIST is invalid for specifier type TYPE.
1264 */
1265        (inst_list, type))
1266 {
1267   struct specifier_methods *meths = decode_specifier_type (type, ERROR_ME);
1268
1269   return check_valid_inst_list (inst_list, meths, ERROR_ME);
1270 }
1271
1272 DEFUN ("valid-inst-list-p", Fvalid_inst_list_p, 2, 2, 0, /*
1273 Return non-nil if INST-LIST is valid for specifier type TYPE.
1274 */
1275        (inst_list, type))
1276 {
1277   struct specifier_methods *meths = decode_specifier_type (type, ERROR_ME);
1278
1279   return check_valid_inst_list (inst_list, meths, ERROR_ME_NOT);
1280 }
1281
1282 static Lisp_Object
1283 check_valid_spec_list (Lisp_Object spec_list, struct specifier_methods *meths,
1284                        Error_behavior errb)
1285 {
1286   Lisp_Object rest;
1287
1288   LIST_LOOP (rest, spec_list)
1289     {
1290       Lisp_Object spec, locale;
1291       if (!CONSP (rest) || !CONSP (spec = XCAR (rest)))
1292         {
1293           maybe_signal_type_error (Qspecifier_syntax_error,
1294                                    "Invalid specification list", spec_list,
1295                                      Qspecifier, errb);
1296           return Qnil;
1297         }
1298       if (NILP (Fvalid_specifier_locale_p (locale = XCAR (spec))))
1299         {
1300           maybe_signal_type_error (Qspecifier_syntax_error,
1301                                    "Invalid specifier locale", locale,
1302                                      Qspecifier, errb);
1303           return Qnil;
1304         }
1305
1306       if (NILP (check_valid_inst_list (XCDR (spec), meths, errb)))
1307         return Qnil;
1308     }
1309
1310   return Qt;
1311 }
1312
1313 DEFUN ("check-valid-spec-list", Fcheck_valid_spec_list, 2, 2, 0, /*
1314 Signal an error if SPEC-LIST is invalid for specifier type TYPE.
1315 */
1316        (spec_list, type))
1317 {
1318   struct specifier_methods *meths = decode_specifier_type (type, ERROR_ME);
1319
1320   return check_valid_spec_list (spec_list, meths, ERROR_ME);
1321 }
1322
1323 DEFUN ("valid-spec-list-p", Fvalid_spec_list_p, 2, 2, 0, /*
1324 Return non-nil if SPEC-LIST is valid for specifier type TYPE.
1325 */
1326        (spec_list, type))
1327 {
1328   struct specifier_methods *meths = decode_specifier_type (type, ERROR_ME);
1329
1330   return check_valid_spec_list (spec_list, meths, ERROR_ME_NOT);
1331 }
1332
1333 enum spec_add_meth
1334 decode_how_to_add_specification (Lisp_Object how_to_add)
1335 {
1336   if (NILP (how_to_add) || EQ (Qremove_tag_set_prepend, how_to_add))
1337     return SPEC_REMOVE_TAG_SET_PREPEND;
1338   if (EQ (Qremove_tag_set_append, how_to_add))
1339     return SPEC_REMOVE_TAG_SET_APPEND;
1340   if (EQ (Qappend, how_to_add))
1341     return SPEC_APPEND;
1342   if (EQ (Qprepend, how_to_add))
1343     return SPEC_PREPEND;
1344   if (EQ (Qremove_locale, how_to_add))
1345     return SPEC_REMOVE_LOCALE;
1346   if (EQ (Qremove_locale_type, how_to_add))
1347     return SPEC_REMOVE_LOCALE_TYPE;
1348   if (EQ (Qremove_all, how_to_add))
1349     return SPEC_REMOVE_ALL;
1350
1351   signal_type_error (Qspecifier_argument_error, "Invalid `how-to-add' flag",
1352                      how_to_add);
1353
1354   return SPEC_PREPEND;          /* not reached */
1355 }
1356
1357 /* Given a specifier object SPEC, return bodily specifier if SPEC is a
1358    ghost specifier, otherwise return the object itself
1359 */
1360 static Lisp_Object
1361 bodily_specifier (Lisp_Object spec)
1362 {
1363   return (GHOST_SPECIFIER_P (XSPECIFIER (spec))
1364           ? XSPECIFIER(spec)->magic_parent : spec);
1365 }
1366
1367 /* Signal error if (specifier SPEC is read-only.
1368    Read only are ghost specifiers unless Vunlock_ghost_specifiers is
1369    non-nil.  All other specifiers are read-write.
1370 */
1371 static void
1372 check_modifiable_specifier (Lisp_Object spec)
1373 {
1374   if (NILP (Vunlock_ghost_specifiers)
1375       && GHOST_SPECIFIER_P (XSPECIFIER (spec)))
1376     signal_type_error (Qspecifier_change_error,
1377                        "Attempt to modify read-only specifier",
1378                          list1 (spec));
1379 }
1380
1381 /* Helper function which unwind protects the value of
1382    Vunlock_ghost_specifiers, then sets it to non-nil value */
1383 static Lisp_Object
1384 restore_unlock_value (Lisp_Object val)
1385 {
1386   Vunlock_ghost_specifiers = val;
1387   return val;
1388 }
1389
1390 int
1391 unlock_ghost_specifiers_protected (void)
1392 {
1393   int depth = specpdl_depth ();
1394   record_unwind_protect (restore_unlock_value,
1395                          Vunlock_ghost_specifiers);
1396   Vunlock_ghost_specifiers = Qt;
1397   return depth;
1398 }
1399
1400 /* This gets hit so much that the function call overhead had a
1401    measurable impact (according to Quantify).  #### We should figure
1402    out the frequency with which this is called with the various types
1403    and reorder the check accordingly. */
1404 #define SPECIFIER_GET_SPEC_LIST(specifier, type)                        \
1405 (type == LOCALE_GLOBAL ? &(XSPECIFIER (specifier)->global_specs)   :    \
1406  type == LOCALE_DEVICE ? &(XSPECIFIER (specifier)->device_specs)   :    \
1407  type == LOCALE_FRAME  ? &(XSPECIFIER (specifier)->frame_specs)    :    \
1408  type == LOCALE_WINDOW ? &(XWEAK_LIST_LIST                              \
1409                            (XSPECIFIER (specifier)->window_specs)) :    \
1410  type == LOCALE_BUFFER ? &(XSPECIFIER (specifier)->buffer_specs)   :    \
1411  0)
1412
1413 static Lisp_Object *
1414 specifier_get_inst_list (Lisp_Object specifier, Lisp_Object locale,
1415                          enum spec_locale_type type)
1416 {
1417   Lisp_Object *spec_list = SPECIFIER_GET_SPEC_LIST (specifier, type);
1418   Lisp_Object specification;
1419
1420   if (type == LOCALE_GLOBAL)
1421     return spec_list;
1422   /* Calling assq_no_quit when it is just going to return nil anyhow
1423      is extremely expensive.  So sayeth Quantify. */
1424   if (!CONSP (*spec_list))
1425     return 0;
1426   specification = assq_no_quit (locale, *spec_list);
1427   if (NILP (specification))
1428     return 0;
1429   return &XCDR (specification);
1430 }
1431
1432 /* For the given INST_LIST, return a new INST_LIST containing all elements
1433    where TAG-SET matches the element's tag set.  EXACT_P indicates whether
1434    the match must be exact (as opposed to a subset).  SHORT_P indicates
1435    that the short form (for `specifier-specs') should be returned if
1436    possible.  If COPY_TREE_P, `copy-tree' is used to ensure that no
1437    elements of the new list are shared with the initial list.
1438 */
1439
1440 static Lisp_Object
1441 specifier_process_inst_list (Lisp_Object inst_list,
1442                              Lisp_Object tag_set, int exact_p,
1443                              int short_p, int copy_tree_p)
1444 {
1445   Lisp_Object retval = Qnil;
1446   Lisp_Object rest;
1447   struct gcpro gcpro1;
1448
1449   GCPRO1 (retval);
1450   LIST_LOOP (rest, inst_list)
1451     {
1452       Lisp_Object tagged_inst = XCAR (rest);
1453       Lisp_Object tagged_inst_tag = XCAR (tagged_inst);
1454       if (tag_sets_match_p (tag_set, tagged_inst_tag, exact_p))
1455         {
1456           if (short_p && NILP (tagged_inst_tag))
1457             retval = Fcons (copy_tree_p ?
1458                             Fcopy_tree (XCDR (tagged_inst), Qt) :
1459                             XCDR (tagged_inst),
1460                             retval);
1461           else
1462             retval = Fcons (copy_tree_p ? Fcopy_tree (tagged_inst, Qt) :
1463                             tagged_inst, retval);
1464         }
1465     }
1466   retval = Fnreverse (retval);
1467   UNGCPRO;
1468   /* If there is a single instantiator and the short form is
1469      requested, return just the instantiator (rather than a one-element
1470      list of it) unless it is nil (so that it can be distinguished from
1471      no instantiators at all). */
1472   if (short_p && CONSP (retval) && !NILP (XCAR (retval)) &&
1473       NILP (XCDR (retval)))
1474     return XCAR (retval);
1475   else
1476     return retval;
1477 }
1478
1479 static Lisp_Object
1480 specifier_get_external_inst_list (Lisp_Object specifier, Lisp_Object locale,
1481                                   enum spec_locale_type type,
1482                                   Lisp_Object tag_set, int exact_p,
1483                                   int short_p, int copy_tree_p)
1484 {
1485   Lisp_Object *inst_list = specifier_get_inst_list (specifier, locale,
1486                                                     type);
1487   if (!inst_list || NILP (*inst_list))
1488     {
1489       /* nil for *inst_list should only occur in 'global */
1490       assert (!inst_list || EQ (locale, Qglobal));
1491       return Qnil;
1492     }
1493
1494   return specifier_process_inst_list (*inst_list, tag_set, exact_p,
1495                                       short_p, copy_tree_p);
1496 }
1497
1498 static Lisp_Object
1499 specifier_get_external_spec_list (Lisp_Object specifier,
1500                                   enum spec_locale_type type,
1501                                   Lisp_Object tag_set, int exact_p)
1502 {
1503   Lisp_Object *spec_list = SPECIFIER_GET_SPEC_LIST (specifier, type);
1504   Lisp_Object retval = Qnil;
1505   Lisp_Object rest;
1506   struct gcpro gcpro1;
1507
1508   assert (type != LOCALE_GLOBAL);
1509   /* We're about to let stuff go external; make sure there aren't
1510      any dead objects */
1511   *spec_list = cleanup_assoc_list (*spec_list);
1512
1513   GCPRO1 (retval);
1514   LIST_LOOP (rest, *spec_list)
1515     {
1516       Lisp_Object spec = XCAR (rest);
1517       Lisp_Object inst_list =
1518         specifier_process_inst_list (XCDR (spec), tag_set, exact_p, 0, 1);
1519       if (!NILP (inst_list))
1520         retval = Fcons (Fcons (XCAR (spec), inst_list), retval);
1521     }
1522   RETURN_UNGCPRO (Fnreverse (retval));
1523 }
1524
1525 static Lisp_Object *
1526 specifier_new_spec (Lisp_Object specifier, Lisp_Object locale,
1527                     enum spec_locale_type type)
1528 {
1529   Lisp_Object *spec_list = SPECIFIER_GET_SPEC_LIST (specifier, type);
1530   Lisp_Object new_spec = Fcons (locale, Qnil);
1531   assert (type != LOCALE_GLOBAL);
1532   *spec_list = Fcons (new_spec, *spec_list);
1533   return &XCDR (new_spec);
1534 }
1535
1536 /* For the given INST_LIST, return a new list comprised of elements
1537    where TAG_SET does not match the element's tag set.  This operation
1538    is destructive. */
1539
1540 static Lisp_Object
1541 specifier_process_remove_inst_list (Lisp_Object inst_list,
1542                                     Lisp_Object tag_set, int exact_p,
1543                                     int *was_removed)
1544 {
1545   Lisp_Object prev = Qnil, rest;
1546
1547   *was_removed = 0;
1548
1549   LIST_LOOP (rest, inst_list)
1550     {
1551       if (tag_sets_match_p (tag_set, XCAR (XCAR (rest)), exact_p))
1552         {
1553           /* time to remove. */
1554           *was_removed = 1;
1555           if (NILP (prev))
1556             inst_list = XCDR (rest);
1557           else
1558             XCDR (prev) = XCDR (rest);
1559         }
1560       else
1561         prev = rest;
1562     }
1563
1564   return inst_list;
1565 }
1566
1567 static void
1568 specifier_remove_spec (Lisp_Object specifier, Lisp_Object locale,
1569                        enum spec_locale_type type,
1570                        Lisp_Object tag_set, int exact_p)
1571 {
1572   Lisp_Object *spec_list = SPECIFIER_GET_SPEC_LIST (specifier, type);
1573   Lisp_Object assoc;
1574   int was_removed;
1575
1576   if (type == LOCALE_GLOBAL)
1577     *spec_list = specifier_process_remove_inst_list (*spec_list, tag_set,
1578                                                      exact_p, &was_removed);
1579   else
1580     {
1581       assoc = assq_no_quit (locale, *spec_list);
1582       if (NILP (assoc))
1583         /* this locale is not found. */
1584         return;
1585       XCDR (assoc) = specifier_process_remove_inst_list (XCDR (assoc),
1586                                                          tag_set, exact_p,
1587                                                          &was_removed);
1588       if (NILP (XCDR (assoc)))
1589         /* no inst-pairs left; remove this locale entirely. */
1590         *spec_list = remassq_no_quit (locale, *spec_list);
1591     }
1592
1593   if (was_removed)
1594     MAYBE_SPECMETH (XSPECIFIER (specifier), after_change,
1595                     (bodily_specifier (specifier), locale));
1596 }
1597
1598 static void
1599 specifier_remove_locale_type (Lisp_Object specifier,
1600                               enum spec_locale_type type,
1601                               Lisp_Object tag_set, int exact_p)
1602 {
1603   Lisp_Object *spec_list = SPECIFIER_GET_SPEC_LIST (specifier, type);
1604   Lisp_Object prev = Qnil, rest;
1605
1606   assert (type != LOCALE_GLOBAL);
1607   LIST_LOOP (rest, *spec_list)
1608     {
1609       int was_removed;
1610       int remove_spec = 0;
1611       Lisp_Object spec = XCAR (rest);
1612
1613       /* There may be dead objects floating around */
1614       /* remember, dead windows can become alive again. */
1615       if (!WINDOWP (XCAR (spec)) && object_dead_p (XCAR (spec)))
1616         {
1617           remove_spec = 1;
1618           was_removed = 0;
1619         }
1620       else
1621         {
1622           XCDR (spec) = specifier_process_remove_inst_list (XCDR (spec),
1623                                                             tag_set, exact_p,
1624                                                             &was_removed);
1625           if (NILP (XCDR (spec)))
1626             remove_spec = 1;
1627         }
1628
1629       if (remove_spec)
1630         {
1631           if (NILP (prev))
1632             *spec_list = XCDR (rest);
1633           else
1634             XCDR (prev) = XCDR (rest);
1635         }
1636       else
1637         prev = rest;
1638
1639       if (was_removed)
1640         MAYBE_SPECMETH (XSPECIFIER (specifier), after_change,
1641                         (bodily_specifier (specifier), XCAR (spec)));
1642     }
1643 }
1644
1645 /* NEW_LIST is going to be added to INST_LIST, with add method ADD_METH.
1646    Frob INST_LIST according to ADD_METH.  No need to call an after-change
1647    function; the calling function will do this.  Return either SPEC_PREPEND
1648    or SPEC_APPEND, indicating whether to prepend or append the NEW_LIST. */
1649
1650 static enum spec_add_meth
1651 handle_multiple_add_insts (Lisp_Object *inst_list,
1652                            Lisp_Object new_list,
1653                            enum spec_add_meth add_meth)
1654 {
1655   switch (add_meth)
1656     {
1657     case SPEC_REMOVE_TAG_SET_APPEND:
1658       add_meth = SPEC_APPEND;
1659       goto remove_tag_set;
1660     case SPEC_REMOVE_TAG_SET_PREPEND:
1661       add_meth = SPEC_PREPEND;
1662     remove_tag_set:
1663       {
1664         Lisp_Object rest;
1665
1666         LIST_LOOP (rest, new_list)
1667           {
1668             Lisp_Object canontag = canonicalize_tag_set (XCAR (XCAR (rest)));
1669             struct gcpro gcpro1;
1670
1671             GCPRO1 (canontag);
1672             /* pull out all elements from the existing list with the
1673                same tag as any tags in NEW_LIST. */
1674             *inst_list = remassoc_no_quit (canontag, *inst_list);
1675             UNGCPRO;
1676           }
1677       }
1678       return add_meth;
1679     case SPEC_REMOVE_LOCALE:
1680       *inst_list = Qnil;
1681       return SPEC_PREPEND;
1682     case SPEC_APPEND:
1683       return add_meth;
1684     default:
1685       return SPEC_PREPEND;
1686     }
1687 }
1688
1689 /* Given a LOCALE and INST_LIST that is going to be added to SPECIFIER,
1690    copy, canonicalize, and call the going_to_add methods as necessary
1691    to produce a new list that is the one that really will be added
1692    to the specifier. */
1693
1694 static Lisp_Object
1695 build_up_processed_list (Lisp_Object specifier, Lisp_Object locale,
1696                          Lisp_Object inst_list)
1697 {
1698   /* The return value of this function must be GCPRO'd. */
1699   Lisp_Object rest, list_to_build_up = Qnil;
1700   Lisp_Specifier *sp = XSPECIFIER (specifier);
1701   struct gcpro gcpro1;
1702
1703   GCPRO1 (list_to_build_up);
1704   LIST_LOOP (rest, inst_list)
1705     {
1706       Lisp_Object tag_set = XCAR (XCAR (rest));
1707       Lisp_Object sub_inst_list = Qnil;
1708       Lisp_Object instantiator;
1709       struct gcpro ngcpro1, ngcpro2;
1710
1711       if (HAS_SPECMETH_P (sp, copy_instantiator))
1712         instantiator = SPECMETH (sp, copy_instantiator,
1713                                  (XCDR (XCAR (rest))));
1714       else
1715         instantiator = Fcopy_tree (XCDR (XCAR (rest)), Qt);
1716
1717       NGCPRO2 (instantiator, sub_inst_list);
1718       /* call the will-add method; it may GC */
1719       sub_inst_list = HAS_SPECMETH_P (sp, going_to_add) ?
1720         SPECMETH (sp, going_to_add,
1721                   (bodily_specifier (specifier), locale,
1722                    tag_set, instantiator)) :
1723         Qt;
1724       if (EQ (sub_inst_list, Qt))
1725         /* no change here. */
1726         sub_inst_list = list1 (Fcons (canonicalize_tag_set (tag_set),
1727                                       instantiator));
1728       else
1729         {
1730           /* now canonicalize all the tag sets in the new objects */
1731           Lisp_Object rest2;
1732           LIST_LOOP (rest2, sub_inst_list)
1733             XCAR (XCAR (rest2)) = canonicalize_tag_set (XCAR (XCAR (rest2)));
1734         }
1735
1736       list_to_build_up = nconc2 (sub_inst_list, list_to_build_up);
1737       NUNGCPRO;
1738     }
1739
1740   RETURN_UNGCPRO (Fnreverse (list_to_build_up));
1741 }
1742
1743 /* Add a specification (locale and instantiator list) to a specifier.
1744    ADD_METH specifies what to do with existing specifications in the
1745    specifier, and is an enum that corresponds to the values in
1746    `add-spec-to-specifier'.  The calling routine is responsible for
1747    validating LOCALE and INST-LIST, but the tag-sets in INST-LIST
1748    do not need to be canonicalized. */
1749
1750   /* #### I really need to rethink the after-change
1751      functions to make them easier to use and more efficient. */
1752
1753 static void
1754 specifier_add_spec (Lisp_Object specifier, Lisp_Object locale,
1755                     Lisp_Object inst_list, enum spec_add_meth add_meth)
1756 {
1757   Lisp_Specifier *sp = XSPECIFIER (specifier);
1758   enum spec_locale_type type = locale_type_from_locale (locale);
1759   Lisp_Object *orig_inst_list, tem;
1760   Lisp_Object list_to_build_up = Qnil;
1761   struct gcpro gcpro1;
1762
1763   GCPRO1 (list_to_build_up);
1764   list_to_build_up = build_up_processed_list (specifier, locale, inst_list);
1765   /* Now handle REMOVE_LOCALE_TYPE and REMOVE_ALL.  These are the
1766      add-meth types that affect locales other than this one. */
1767   if (add_meth == SPEC_REMOVE_LOCALE_TYPE)
1768     specifier_remove_locale_type (specifier, type, Qnil, 0);
1769   else if (add_meth == SPEC_REMOVE_ALL)
1770     {
1771       specifier_remove_locale_type (specifier, LOCALE_BUFFER, Qnil, 0);
1772       specifier_remove_locale_type (specifier, LOCALE_WINDOW, Qnil, 0);
1773       specifier_remove_locale_type (specifier, LOCALE_FRAME,  Qnil, 0);
1774       specifier_remove_locale_type (specifier, LOCALE_DEVICE, Qnil, 0);
1775       specifier_remove_spec (specifier, Qglobal, LOCALE_GLOBAL, Qnil, 0);
1776     }
1777
1778   orig_inst_list = specifier_get_inst_list (specifier, locale, type);
1779   if (!orig_inst_list)
1780     orig_inst_list = specifier_new_spec (specifier, locale, type);
1781   add_meth = handle_multiple_add_insts (orig_inst_list, list_to_build_up,
1782                                         add_meth);
1783
1784   if (add_meth == SPEC_PREPEND)
1785     tem = nconc2 (list_to_build_up, *orig_inst_list);
1786   else if (add_meth == SPEC_APPEND)
1787     tem = nconc2 (*orig_inst_list, list_to_build_up);
1788   else
1789     {
1790       ABORT ();
1791       tem = Qnil;
1792     }
1793
1794   *orig_inst_list = tem;
1795
1796   UNGCPRO;
1797
1798   /* call the after-change method */
1799   MAYBE_SPECMETH (sp, after_change,
1800                   (bodily_specifier (specifier), locale));
1801 }
1802
1803 static void
1804 specifier_copy_spec (Lisp_Object specifier, Lisp_Object dest,
1805                      Lisp_Object locale, enum spec_locale_type type,
1806                      Lisp_Object tag_set, int exact_p,
1807                      enum spec_add_meth add_meth)
1808 {
1809   Lisp_Object inst_list =
1810     specifier_get_external_inst_list (specifier, locale, type, tag_set,
1811                                       exact_p, 0, 0);
1812   specifier_add_spec (dest, locale, inst_list, add_meth);
1813 }
1814
1815 static void
1816 specifier_copy_locale_type (Lisp_Object specifier, Lisp_Object dest,
1817                             enum spec_locale_type type,
1818                             Lisp_Object tag_set, int exact_p,
1819                             enum spec_add_meth add_meth)
1820 {
1821   Lisp_Object *src_list = SPECIFIER_GET_SPEC_LIST (specifier, type);
1822   Lisp_Object rest;
1823
1824   /* This algorithm is O(n^2) in running time.
1825      It's certainly possible to implement an O(n log n) algorithm,
1826      but I doubt there's any need to. */
1827
1828   LIST_LOOP (rest, *src_list)
1829     {
1830       Lisp_Object spec = XCAR (rest);
1831       /* There may be dead objects floating around */
1832       /* remember, dead windows can become alive again. */
1833       if (WINDOWP (XCAR (spec)) || !object_dead_p (XCAR (spec)))
1834         specifier_add_spec
1835           (dest, XCAR (spec),
1836            specifier_process_inst_list (XCDR (spec), tag_set, exact_p, 0, 0),
1837            add_meth);
1838     }
1839 }
1840
1841 /* map MAPFUN over the locales in SPECIFIER that are given in LOCALE.
1842    CLOSURE is passed unchanged to MAPFUN.  LOCALE can be one of
1843
1844      -- nil (same as 'all)
1845      -- a single locale, locale type, or 'all
1846      -- a list of locales, locale types, and/or 'all
1847
1848    MAPFUN is called for each locale and locale type given; for 'all,
1849    it is called for the locale 'global and for the four possible
1850    locale types.  In each invocation, either LOCALE will be a locale
1851    and LOCALE_TYPE will be the locale type of this locale,
1852    or LOCALE will be nil and LOCALE_TYPE will be a locale type.
1853    If MAPFUN ever returns non-zero, the mapping is halted and the
1854    value returned is returned from map_specifier().  Otherwise, the
1855    mapping proceeds to the end and map_specifier() returns 0.
1856  */
1857
1858 static int
1859 map_specifier (Lisp_Object specifier, Lisp_Object locale,
1860                int (*mapfun) (Lisp_Object specifier,
1861                               Lisp_Object locale,
1862                               enum spec_locale_type locale_type,
1863                               Lisp_Object tag_set,
1864                               int exact_p,
1865                               void *closure),
1866                Lisp_Object tag_set, Lisp_Object exact_p,
1867                void *closure)
1868 {
1869   int retval = 0;
1870   Lisp_Object rest;
1871   struct gcpro gcpro1, gcpro2;
1872
1873   GCPRO2 (tag_set, locale);
1874   locale = decode_locale_list (locale);
1875   tag_set = decode_specifier_tag_set (tag_set);
1876   tag_set = canonicalize_tag_set (tag_set);
1877
1878   LIST_LOOP (rest, locale)
1879     {
1880       Lisp_Object theloc = XCAR (rest);
1881       if (!NILP (Fvalid_specifier_locale_p (theloc)))
1882         {
1883           retval = (*mapfun) (specifier, theloc,
1884                               locale_type_from_locale (theloc),
1885                               tag_set, !NILP (exact_p), closure);
1886           if (retval)
1887             break;
1888         }
1889       else if (!NILP (Fvalid_specifier_locale_type_p (theloc)))
1890         {
1891           retval = (*mapfun) (specifier, Qnil,
1892                               decode_locale_type (theloc), tag_set,
1893                               !NILP (exact_p), closure);
1894           if (retval)
1895             break;
1896         }
1897       else
1898         {
1899           assert (EQ (theloc, Qall));
1900           retval = (*mapfun) (specifier, Qnil, LOCALE_BUFFER, tag_set,
1901                               !NILP (exact_p), closure);
1902           if (retval)
1903             break;
1904           retval = (*mapfun) (specifier, Qnil, LOCALE_WINDOW, tag_set,
1905                               !NILP (exact_p), closure);
1906           if (retval)
1907             break;
1908           retval = (*mapfun) (specifier, Qnil, LOCALE_FRAME, tag_set,
1909                               !NILP (exact_p), closure);
1910           if (retval)
1911             break;
1912           retval = (*mapfun) (specifier, Qnil, LOCALE_DEVICE, tag_set,
1913                               !NILP (exact_p), closure);
1914           if (retval)
1915             break;
1916           retval = (*mapfun) (specifier, Qglobal, LOCALE_GLOBAL, tag_set,
1917                               !NILP (exact_p), closure);
1918           if (retval)
1919             break;
1920         }
1921     }
1922
1923   UNGCPRO;
1924   return retval;
1925 }
1926
1927 DEFUN ("add-spec-to-specifier", Fadd_spec_to_specifier, 2, 5, 0, /*
1928 Add a specification to SPECIFIER.
1929 The specification maps from LOCALE (which should be a window, buffer,
1930 frame, device, or 'global, and defaults to 'global) to INSTANTIATOR,
1931 whose allowed values depend on the type of the specifier.  Optional
1932 argument TAG-SET limits the instantiator to apply only to the specified
1933 tag set, which should be a list of tags all of which must match the
1934 device being instantiated over (tags are a device type, a device class,
1935 or tags defined with `define-specifier-tag').  Specifying a single
1936 symbol for TAG-SET is equivalent to specifying a one-element list
1937 containing that symbol.  Optional argument HOW-TO-ADD specifies what to
1938 do if there are already specifications in the specifier.
1939 It should be one of
1940
1941   'prepend              Put at the beginning of the current list of
1942                         instantiators for LOCALE.
1943   'append               Add to the end of the current list of
1944                         instantiators for LOCALE.
1945   'remove-tag-set-prepend (this is the default)
1946                         Remove any existing instantiators whose tag set is
1947                         the same as TAG-SET; then put the new instantiator
1948                         at the beginning of the current list. ("Same tag
1949                         set" means that they contain the same elements.
1950                         The order may be different.)
1951   'remove-tag-set-append
1952                         Remove any existing instantiators whose tag set is
1953                         the same as TAG-SET; then put the new instantiator
1954                         at the end of the current list.
1955   'remove-locale        Remove all previous instantiators for this locale
1956                         before adding the new spec.
1957   'remove-locale-type   Remove all specifications for all locales of the
1958                         same type as LOCALE (this includes LOCALE itself)
1959                         before adding the new spec.
1960   'remove-all           Remove all specifications from the specifier
1961                         before adding the new spec.
1962
1963 You can retrieve the specifications for a particular locale or locale type
1964 with the function `specifier-spec-list' or `specifier-specs'.
1965 */
1966        (specifier, instantiator, locale, tag_set, how_to_add))
1967 {
1968   enum spec_add_meth add_meth;
1969   Lisp_Object inst_list;
1970   struct gcpro gcpro1;
1971
1972   CHECK_SPECIFIER (specifier);
1973   check_modifiable_specifier (specifier);
1974
1975   locale = decode_locale (locale);
1976   check_valid_instantiator (instantiator,
1977                             decode_specifier_type
1978                             (Fspecifier_type (specifier), ERROR_ME),
1979                             ERROR_ME);
1980   /* tag_set might be newly-created material, but it's part of inst_list
1981      so is properly GC-protected. */
1982   tag_set = decode_specifier_tag_set (tag_set);
1983   add_meth = decode_how_to_add_specification (how_to_add);
1984
1985   inst_list = list1 (Fcons (tag_set, instantiator));
1986   GCPRO1 (inst_list);
1987   specifier_add_spec (specifier, locale, inst_list, add_meth);
1988   recompute_cached_specifier_everywhere (specifier);
1989   RETURN_UNGCPRO (Qnil);
1990 }
1991
1992 DEFUN ("add-spec-list-to-specifier", Fadd_spec_list_to_specifier, 2, 3, 0, /*
1993 Add SPEC-LIST (a list of specifications) to SPECIFIER.
1994 The format of SPEC-LIST is
1995
1996   ((LOCALE (TAG-SET . INSTANTIATOR) ...) ...)
1997
1998 where
1999   LOCALE := a window, a buffer, a frame, a device, or 'global
2000   TAG-SET := an unordered list of zero or more TAGS, each of which
2001              is a symbol
2002   TAG := a device class (see `valid-device-class-p'), a device type
2003          (see `valid-console-type-p'), or a tag defined with
2004          `define-specifier-tag'
2005   INSTANTIATOR := format determined by the type of specifier
2006
2007 The pair (TAG-SET . INSTANTIATOR) is called an `inst-pair'.
2008 A list of inst-pairs is called an `inst-list'.
2009 The pair (LOCALE . INST-LIST) is called a `specification' or `spec'.
2010 A spec-list, then, can be viewed as a list of specifications.
2011
2012 HOW-TO-ADD specifies how to combine the new specifications with
2013 the existing ones, and has the same semantics as for
2014 `add-spec-to-specifier'.
2015
2016 In many circumstances, the higher-level function `set-specifier' is
2017 more convenient and should be used instead.
2018 */
2019        (specifier, spec_list, how_to_add))
2020 {
2021   enum spec_add_meth add_meth;
2022   Lisp_Object rest;
2023
2024   CHECK_SPECIFIER (specifier);
2025   check_modifiable_specifier (specifier);
2026
2027   check_valid_spec_list (spec_list,
2028                          decode_specifier_type
2029                          (Fspecifier_type (specifier), ERROR_ME),
2030                          ERROR_ME);
2031   add_meth = decode_how_to_add_specification (how_to_add);
2032
2033   LIST_LOOP (rest, spec_list)
2034     {
2035       /* Placating the GCC god. */
2036       Lisp_Object specification = XCAR (rest);
2037       Lisp_Object locale    = XCAR (specification);
2038       Lisp_Object inst_list = XCDR (specification);
2039
2040       specifier_add_spec (specifier, locale, inst_list, add_meth);
2041     }
2042   recompute_cached_specifier_everywhere (specifier);
2043   return Qnil;
2044 }
2045
2046 void
2047 add_spec_to_ghost_specifier (Lisp_Object specifier, Lisp_Object instantiator,
2048                              Lisp_Object locale, Lisp_Object tag_set,
2049                              Lisp_Object how_to_add)
2050 {
2051   int depth = unlock_ghost_specifiers_protected ();
2052   Fadd_spec_to_specifier (XSPECIFIER(specifier)->fallback,
2053                           instantiator, locale, tag_set, how_to_add);
2054   unbind_to (depth, Qnil);
2055 }
2056
2057 struct specifier_spec_list_closure
2058 {
2059   Lisp_Object head, tail;
2060 };
2061
2062 static int
2063 specifier_spec_list_mapfun (Lisp_Object specifier,
2064                             Lisp_Object locale,
2065                             enum spec_locale_type locale_type,
2066                             Lisp_Object tag_set,
2067                             int exact_p,
2068                             void *closure)
2069 {
2070   struct specifier_spec_list_closure *cl =
2071     (struct specifier_spec_list_closure *) closure;
2072   Lisp_Object partial;
2073
2074   if (NILP (locale))
2075     partial = specifier_get_external_spec_list (specifier,
2076                                                 locale_type,
2077                                                 tag_set, exact_p);
2078   else
2079     {
2080       partial = specifier_get_external_inst_list (specifier, locale,
2081                                                   locale_type, tag_set,
2082                                                   exact_p, 0, 1);
2083       if (!NILP (partial))
2084         partial = list1 (Fcons (locale, partial));
2085     }
2086   if (NILP (partial))
2087     return 0;
2088
2089   /* tack on the new list */
2090   if (NILP (cl->tail))
2091     cl->head = cl->tail = partial;
2092   else
2093     XCDR (cl->tail) = partial;
2094   /* find the new tail */
2095   while (CONSP (XCDR (cl->tail)))
2096     cl->tail = XCDR (cl->tail);
2097   return 0;
2098 }
2099
2100 /* For the given SPECIFIER create and return a list of all specs
2101    contained within it, subject to LOCALE.  If LOCALE is a locale, only
2102    specs in that locale will be returned.  If LOCALE is a locale type,
2103    all specs in all locales of that type will be returned.  If LOCALE is
2104    nil, all specs will be returned.  This always copies lists and never
2105    returns the actual lists, because we do not want someone manipulating
2106    the actual objects.  This may cause a slight loss of potential
2107    functionality but if we were to allow it then a user could manage to
2108    violate our assertion that the specs contained in the actual
2109    specifier lists are all valid. */
2110
2111 DEFUN ("specifier-spec-list", Fspecifier_spec_list, 1, 4, 0, /*
2112 Return the spec-list of specifications for SPECIFIER in LOCALE.
2113
2114 If LOCALE is a particular locale (a buffer, window, frame, device,
2115 or 'global), a spec-list consisting of the specification for that
2116 locale will be returned.
2117
2118 If LOCALE is a locale type (i.e. 'buffer, 'window, 'frame, or 'device),
2119 a spec-list of the specifications for all locales of that type will be
2120 returned.
2121
2122 If LOCALE is nil or 'all, a spec-list of all specifications in SPECIFIER
2123 will be returned.
2124
2125 LOCALE can also be a list of locales, locale types, and/or 'all; the
2126 result is as if `specifier-spec-list' were called on each element of the
2127 list and the results concatenated together.
2128
2129 Only instantiators where TAG-SET (a list of zero or more tags) is a
2130 subset of (or possibly equal to) the instantiator's tag set are returned.
2131 \(The default value of nil is a subset of all tag sets, so in this case
2132 no instantiators will be screened out.) If EXACT-P is non-nil, however,
2133 TAG-SET must be equal to an instantiator's tag set for the instantiator
2134 to be returned.
2135 */
2136      (specifier, locale, tag_set, exact_p))
2137 {
2138   struct specifier_spec_list_closure cl;
2139   struct gcpro gcpro1, gcpro2;
2140
2141   CHECK_SPECIFIER (specifier);
2142   cl.head = cl.tail = Qnil;
2143   GCPRO2 (cl.head, cl.tail);
2144   map_specifier (specifier, locale, specifier_spec_list_mapfun,
2145                  tag_set, exact_p, &cl);
2146   UNGCPRO;
2147   return cl.head;
2148 }
2149
2150
2151 DEFUN ("specifier-specs", Fspecifier_specs, 1, 4, 0, /*
2152 Return the specification(s) for SPECIFIER in LOCALE.
2153
2154 If LOCALE is a single locale or is a list of one element containing a
2155 single locale, then a "short form" of the instantiators for that locale
2156 will be returned.  Otherwise, this function is identical to
2157 `specifier-spec-list'.
2158
2159 The "short form" is designed for readability and not for ease of use
2160 in Lisp programs, and is as follows:
2161
2162 1. If there is only one instantiator, then an inst-pair (i.e. cons of
2163    tag and instantiator) will be returned; otherwise a list of
2164    inst-pairs will be returned.
2165 2. For each inst-pair returned, if the instantiator's tag is 'any,
2166    the tag will be removed and the instantiator itself will be returned
2167    instead of the inst-pair.
2168 3. If there is only one instantiator, its value is nil, and its tag is
2169    'any, a one-element list containing nil will be returned rather
2170    than just nil, to distinguish this case from there being no
2171    instantiators at all.
2172 */
2173        (specifier, locale, tag_set, exact_p))
2174 {
2175   if (!NILP (Fvalid_specifier_locale_p (locale)) ||
2176       (CONSP (locale) && !NILP (Fvalid_specifier_locale_p (XCAR (locale))) &&
2177        NILP (XCDR (locale))))
2178     {
2179       struct gcpro gcpro1;
2180
2181       CHECK_SPECIFIER (specifier);
2182       if (CONSP (locale))
2183         locale = XCAR (locale);
2184       GCPRO1 (tag_set);
2185       tag_set = decode_specifier_tag_set (tag_set);
2186       tag_set = canonicalize_tag_set (tag_set);
2187       RETURN_UNGCPRO
2188         (specifier_get_external_inst_list (specifier, locale,
2189                                            locale_type_from_locale (locale),
2190                                            tag_set, !NILP (exact_p), 1, 1));
2191     }
2192   else
2193     return Fspecifier_spec_list (specifier, locale, tag_set, exact_p);
2194 }
2195
2196 static int
2197 remove_specifier_mapfun (Lisp_Object specifier,
2198                          Lisp_Object locale,
2199                          enum spec_locale_type locale_type,
2200                          Lisp_Object tag_set,
2201                          int exact_p,
2202                          void *ignored_closure)
2203 {
2204   if (NILP (locale))
2205     specifier_remove_locale_type (specifier, locale_type, tag_set, exact_p);
2206   else
2207     specifier_remove_spec (specifier, locale, locale_type, tag_set, exact_p);
2208   return 0;
2209 }
2210
2211 DEFUN ("remove-specifier", Fremove_specifier, 1, 4, 0, /*
2212 Remove specification(s) for SPECIFIER.
2213
2214 If LOCALE is a particular locale (a window, buffer, frame, device,
2215 or 'global), the specification for that locale will be removed.
2216
2217 If instead, LOCALE is a locale type (i.e. 'window, 'buffer, 'frame,
2218 or 'device), the specifications for all locales of that type will be
2219 removed.
2220
2221 If LOCALE is nil or 'all, all specifications will be removed.
2222
2223 LOCALE can also be a list of locales, locale types, and/or 'all; this
2224 is equivalent to calling `remove-specifier' for each of the elements
2225 in the list.
2226
2227 Only instantiators where TAG-SET (a list of zero or more tags) is a
2228 subset of (or possibly equal to) the instantiator's tag set are removed.
2229 The default value of nil is a subset of all tag sets, so in this case
2230 no instantiators will be screened out. If EXACT-P is non-nil, however,
2231 TAG-SET must be equal to an instantiator's tag set for the instantiator
2232 to be removed.
2233 */
2234        (specifier, locale, tag_set, exact_p))
2235 {
2236   CHECK_SPECIFIER (specifier);
2237   check_modifiable_specifier (specifier);
2238
2239   map_specifier (specifier, locale, remove_specifier_mapfun,
2240                  tag_set, exact_p, 0);
2241   recompute_cached_specifier_everywhere (specifier);
2242   return Qnil;
2243 }
2244
2245 void
2246 remove_ghost_specifier (Lisp_Object specifier, Lisp_Object locale,
2247                         Lisp_Object tag_set, Lisp_Object exact_p)
2248 {
2249   int depth = unlock_ghost_specifiers_protected ();
2250   Fremove_specifier (XSPECIFIER(specifier)->fallback,
2251                      locale, tag_set, exact_p);
2252   unbind_to (depth, Qnil);
2253 }
2254
2255 struct copy_specifier_closure
2256 {
2257   Lisp_Object dest;
2258   enum spec_add_meth add_meth;
2259   int add_meth_is_nil;
2260 };
2261
2262 static int
2263 copy_specifier_mapfun (Lisp_Object specifier,
2264                        Lisp_Object locale,
2265                        enum spec_locale_type locale_type,
2266                        Lisp_Object tag_set,
2267                        int exact_p,
2268                        void *closure)
2269 {
2270   struct copy_specifier_closure *cl =
2271     (struct copy_specifier_closure *) closure;
2272
2273   if (NILP (locale))
2274     specifier_copy_locale_type (specifier, cl->dest, locale_type,
2275                                 tag_set, exact_p,
2276                                 cl->add_meth_is_nil ?
2277                                 SPEC_REMOVE_LOCALE_TYPE :
2278                                 cl->add_meth);
2279   else
2280     specifier_copy_spec (specifier, cl->dest, locale, locale_type,
2281                          tag_set, exact_p,
2282                          cl->add_meth_is_nil ? SPEC_REMOVE_LOCALE :
2283                          cl->add_meth);
2284   return 0;
2285 }
2286
2287 DEFUN ("copy-specifier", Fcopy_specifier, 1, 6, 0, /*
2288 Copy SPECIFIER to DEST, or create a new one if DEST is nil.
2289
2290 If DEST is nil or omitted, a new specifier will be created and the
2291 specifications copied into it.  Otherwise, the specifications will be
2292 copied into the existing specifier in DEST.
2293
2294 If LOCALE is nil or 'all, all specifications will be copied.  If LOCALE
2295 is a particular locale, the specification for that particular locale will
2296 be copied.  If LOCALE is a locale type, the specifications for all locales
2297 of that type will be copied.  LOCALE can also be a list of locales,
2298 locale types, and/or 'all; this is equivalent to calling `copy-specifier'
2299 for each of the elements of the list.  See `specifier-spec-list' for more
2300 information about LOCALE.
2301
2302 Only instantiators where TAG-SET (a list of zero or more tags) is a
2303 subset of (or possibly equal to) the instantiator's tag set are copied.
2304 The default value of nil is a subset of all tag sets, so in this case
2305 no instantiators will be screened out. If EXACT-P is non-nil, however,
2306 TAG-SET must be equal to an instantiator's tag set for the instantiator
2307 to be copied.
2308
2309 Optional argument HOW-TO-ADD specifies what to do with existing
2310 specifications in DEST.  If nil, then whichever locales or locale types
2311 are copied will first be completely erased in DEST.  Otherwise, it is
2312 the same as in `add-spec-to-specifier'.
2313 */
2314        (specifier, dest, locale, tag_set, exact_p, how_to_add))
2315 {
2316   struct gcpro gcpro1;
2317   struct copy_specifier_closure cl;
2318
2319   CHECK_SPECIFIER (specifier);
2320   if (NILP (how_to_add))
2321     cl.add_meth_is_nil = 1;
2322   else
2323     cl.add_meth_is_nil = 0;
2324   cl.add_meth = decode_how_to_add_specification (how_to_add);
2325   if (NILP (dest))
2326     {
2327       /* #### What about copying the extra data? */
2328       dest = make_specifier (XSPECIFIER (specifier)->methods);
2329     }
2330   else
2331     {
2332       CHECK_SPECIFIER (dest);
2333       check_modifiable_specifier (dest);
2334       if (XSPECIFIER (dest)->methods != XSPECIFIER (specifier)->methods)
2335         error ("Specifiers not of same type");
2336     }
2337
2338   cl.dest = dest;
2339   GCPRO1 (dest);
2340   map_specifier (specifier, locale, copy_specifier_mapfun,
2341                  tag_set, exact_p, &cl);
2342   UNGCPRO;
2343   recompute_cached_specifier_everywhere (dest);
2344   return dest;
2345 }
2346
2347 \f
2348 /************************************************************************/
2349 /*                              Instancing                              */
2350 /************************************************************************/
2351
2352 static Lisp_Object
2353 call_validate_matchspec_method (Lisp_Object boxed_method,
2354                                 Lisp_Object matchspec)
2355 {
2356   ((void (*)(Lisp_Object)) get_opaque_ptr (boxed_method)) (matchspec);
2357   return Qt;
2358 }
2359
2360 static Lisp_Object
2361 check_valid_specifier_matchspec (Lisp_Object matchspec,
2362                                  struct specifier_methods *meths,
2363                                  Error_behavior errb)
2364 {
2365   if (meths->validate_matchspec_method)
2366     {
2367       Lisp_Object retval;
2368
2369       if (ERRB_EQ (errb, ERROR_ME))
2370         {
2371           (meths->validate_matchspec_method) (matchspec);
2372           retval = Qt;
2373         }
2374       else
2375         {
2376           Lisp_Object opaque =
2377             make_opaque_ptr ((void *) meths->validate_matchspec_method);
2378           struct gcpro gcpro1;
2379
2380           GCPRO1 (opaque);
2381           retval = call_with_suspended_errors
2382             ((lisp_fn_t) call_validate_matchspec_method,
2383              Qnil, Qspecifier, errb, 2, opaque, matchspec);
2384
2385           free_opaque_ptr (opaque);
2386           UNGCPRO;
2387         }
2388
2389       return retval;
2390     }
2391   else
2392     {
2393       maybe_signal_simple_error
2394         ("Matchspecs not allowed for this specifier type",
2395          intern (meths->name), Qspecifier, errb);
2396       return Qnil;
2397     }
2398 }
2399
2400 DEFUN ("check-valid-specifier-matchspec", Fcheck_valid_specifier_matchspec, 2,
2401        2, 0, /*
2402 Signal an error if MATCHSPEC is invalid for SPECIFIER-TYPE.
2403 See `specifier-matching-instance' for a description of matchspecs.
2404 */
2405        (matchspec, specifier_type))
2406 {
2407   struct specifier_methods *meths = decode_specifier_type (specifier_type,
2408                                                            ERROR_ME);
2409
2410   return check_valid_specifier_matchspec (matchspec, meths, ERROR_ME);
2411 }
2412
2413 DEFUN ("valid-specifier-matchspec-p", Fvalid_specifier_matchspec_p, 2, 2, 0, /*
2414 Return non-nil if MATCHSPEC is valid for SPECIFIER-TYPE.
2415 See `specifier-matching-instance' for a description of matchspecs.
2416 */
2417        (matchspec, specifier_type))
2418 {
2419   struct specifier_methods *meths = decode_specifier_type (specifier_type,
2420                                                            ERROR_ME);
2421
2422   return check_valid_specifier_matchspec (matchspec, meths, ERROR_ME_NOT);
2423 }
2424
2425 /* This function is purposely not callable from Lisp.  If a Lisp
2426    caller wants to set a fallback, they should just set the
2427    global value. */
2428
2429 void
2430 set_specifier_fallback (Lisp_Object specifier, Lisp_Object fallback)
2431 {
2432   Lisp_Specifier *sp = XSPECIFIER (specifier);
2433   assert (SPECIFIERP (fallback) ||
2434           !NILP (Fvalid_inst_list_p (fallback, Fspecifier_type (specifier))));
2435   if (SPECIFIERP (fallback))
2436     assert (EQ (Fspecifier_type (specifier), Fspecifier_type (fallback)));
2437   if (BODILY_SPECIFIER_P (sp))
2438     GHOST_SPECIFIER(sp)->fallback = fallback;
2439   else
2440     sp->fallback = fallback;
2441   /* call the after-change method */
2442   MAYBE_SPECMETH (sp, after_change,
2443                   (bodily_specifier (specifier), Qfallback));
2444   recompute_cached_specifier_everywhere (specifier);
2445 }
2446
2447 DEFUN ("specifier-fallback", Fspecifier_fallback, 1, 1, 0, /*
2448 Return the fallback value for SPECIFIER.
2449 Fallback values are provided by the C code for certain built-in
2450 specifiers to make sure that instancing won't fail even if all
2451 specs are removed from the specifier, or to implement simple
2452 inheritance behavior (e.g. this method is used to ensure that
2453 faces other than 'default inherit their attributes from 'default).
2454 By design, you cannot change the fallback value, and specifiers
2455 created with `make-specifier' will never have a fallback (although
2456 a similar, Lisp-accessible capability may be provided in the future
2457 to allow for inheritance).
2458
2459 The fallback value will be an inst-list that is instanced like
2460 any other inst-list, a specifier of the same type as SPECIFIER
2461 \(results in inheritance), or nil for no fallback.
2462
2463 When you instance a specifier, you can explicitly request that the
2464 fallback not be consulted. (The C code does this, for example, when
2465 merging faces.) See `specifier-instance'.
2466 */
2467        (specifier))
2468 {
2469   CHECK_SPECIFIER (specifier);
2470   return Fcopy_tree (XSPECIFIER (specifier)->fallback, Qt);
2471 }
2472
2473 static Lisp_Object
2474 specifier_instance_from_inst_list (Lisp_Object specifier,
2475                                    Lisp_Object matchspec,
2476                                    Lisp_Object domain,
2477                                    Lisp_Object inst_list,
2478                                    Error_behavior errb, int no_quit,
2479                                    Lisp_Object depth)
2480 {
2481   /* This function can GC */
2482   Lisp_Specifier *sp;
2483   Lisp_Object device;
2484   Lisp_Object rest;
2485   int count = specpdl_depth ();
2486   struct gcpro gcpro1, gcpro2;
2487
2488   GCPRO2 (specifier, inst_list);
2489
2490   sp = XSPECIFIER (specifier);
2491   device = DOMAIN_DEVICE (domain);
2492
2493   if (no_quit)
2494   /* The instantiate method is allowed to call eval.  Since it
2495      is quite common for this function to get called from somewhere in
2496      redisplay we need to make sure that quits are ignored.  Otherwise
2497      Fsignal will ABORT. */
2498     specbind (Qinhibit_quit, Qt);
2499
2500   LIST_LOOP (rest, inst_list)
2501     {
2502       Lisp_Object tagged_inst = XCAR (rest);
2503       Lisp_Object tag_set = XCAR (tagged_inst);
2504
2505       if (device_matches_specifier_tag_set_p (device, tag_set))
2506         {
2507           Lisp_Object val = XCDR (tagged_inst);
2508
2509           if (HAS_SPECMETH_P (sp, instantiate))
2510             val = call_with_suspended_errors
2511               ((lisp_fn_t) RAW_SPECMETH (sp, instantiate),
2512                Qunbound, Qspecifier, errb, 5, specifier,
2513                matchspec, domain, val, depth);
2514
2515           if (!UNBOUNDP (val))
2516             {
2517               unbind_to (count, Qnil);
2518               UNGCPRO;
2519               return val;
2520             }
2521         }
2522     }
2523
2524   unbind_to (count, Qnil);
2525   UNGCPRO;
2526   return Qunbound;
2527 }
2528
2529 /* Given a SPECIFIER and a DOMAIN, return a specific instance for that
2530    specifier. Try to find one by checking the specifier types from most
2531    specific (buffer) to most general (global).  If we find an instance,
2532    return it.  Otherwise return Qunbound. */
2533
2534 #define CHECK_INSTANCE_ENTRY(key, matchspec, type) do {                 \
2535   Lisp_Object *CIE_inst_list =                                          \
2536     specifier_get_inst_list (specifier, key, type);                     \
2537   if (CIE_inst_list)                                                    \
2538     {                                                                   \
2539       Lisp_Object CIE_val =                                             \
2540         specifier_instance_from_inst_list (specifier, matchspec,        \
2541                                            domain, *CIE_inst_list,      \
2542                                            errb, no_quit, depth);       \
2543       if (!UNBOUNDP (CIE_val))                                          \
2544         return CIE_val;                                                 \
2545     }                                                                   \
2546 } while (0)
2547
2548 /* We accept any window, frame or device domain and do our checking
2549    starting from as specific a locale type as we can determine from the
2550    domain we are passed and going on up through as many other locale types
2551    as we can determine.  In practice, when called from redisplay the
2552    arg will usually be a window and occasionally a frame.  If
2553    triggered by a user call, who knows what it will usually be. */
2554 Lisp_Object
2555 specifier_instance (Lisp_Object specifier, Lisp_Object matchspec,
2556                     Lisp_Object domain, Error_behavior errb, int no_quit,
2557                     int no_fallback, Lisp_Object depth)
2558 {
2559   Lisp_Object buffer = Qnil;
2560   Lisp_Object window = Qnil;
2561   Lisp_Object frame = Qnil;
2562   Lisp_Object device = Qnil;
2563   Lisp_Object tag = Qnil;       /* #### currently unused */
2564   Lisp_Specifier *sp = XSPECIFIER (specifier);
2565
2566   /* Attempt to determine buffer, window, frame, and device from the
2567      domain. */
2568   /* #### get image instances out of domains! */
2569   if (IMAGE_INSTANCEP (domain))
2570     window = DOMAIN_WINDOW (domain);
2571   else if (WINDOWP (domain))
2572     window = domain;
2573   else if (FRAMEP (domain))
2574     frame = domain;
2575   else if (DEVICEP (domain))
2576     device = domain;
2577   else
2578     /* dmoore writes: [dammit, this should just signal an error or something
2579        shouldn't it?]
2580
2581        No. Errors are handled in Lisp primitives implementation.
2582        Invalid domain is a design error here - kkm. */
2583     ABORT ();
2584
2585   if (NILP (buffer) && !NILP (window))
2586     buffer = WINDOW_BUFFER (XWINDOW (window));
2587   if (NILP (frame) && !NILP (window))
2588     frame = XWINDOW (window)->frame;
2589   if (NILP (device))
2590     /* frame had better exist; if device is undeterminable, something
2591        really went wrong. */
2592     device = FRAME_DEVICE (XFRAME (frame));
2593
2594   /* device had better be determined by now; ABORT if not. */
2595   tag = DEVICE_CLASS (XDEVICE (device));
2596
2597   depth = make_int (1 + XINT (depth));
2598   if (XINT (depth) > 20)
2599     {
2600       maybe_error (Qspecifier, errb, "Apparent loop in specifier inheritance");
2601       /* The specification is fucked; at least try the fallback
2602          (which better not be fucked, because it's not changeable
2603          from Lisp). */
2604       depth = Qzero;
2605       goto do_fallback;
2606     }
2607
2608  retry:
2609   /* First see if we can generate one from the window specifiers. */
2610   if (!NILP (window))
2611     CHECK_INSTANCE_ENTRY (window, matchspec, LOCALE_WINDOW);
2612
2613   /* Next see if we can generate one from the buffer specifiers. */
2614   if (!NILP (buffer))
2615     CHECK_INSTANCE_ENTRY (buffer, matchspec, LOCALE_BUFFER);
2616
2617   /* Next see if we can generate one from the frame specifiers. */
2618   if (!NILP (frame))
2619     CHECK_INSTANCE_ENTRY (frame, matchspec, LOCALE_FRAME);
2620
2621   /* If we still haven't succeeded try with the device specifiers. */
2622   CHECK_INSTANCE_ENTRY (device, matchspec, LOCALE_DEVICE);
2623
2624   /* Last and least try the global specifiers. */
2625   CHECK_INSTANCE_ENTRY (Qglobal, matchspec, LOCALE_GLOBAL);
2626
2627  do_fallback:
2628   /* We're out of specifiers and we still haven't generated an
2629      instance.  At least try the fallback ...  If this fails,
2630      then we just return Qunbound. */
2631
2632   if (no_fallback || NILP (sp->fallback))
2633     /* I said, I don't want the fallbacks. */
2634     return Qunbound;
2635
2636   if (SPECIFIERP (sp->fallback))
2637     {
2638       /* If you introduced loops in the default specifier chain,
2639          then you're fucked, so you better not do this. */
2640       specifier = sp->fallback;
2641       sp = XSPECIFIER (specifier);
2642       goto retry;
2643     }
2644
2645   assert (CONSP (sp->fallback));
2646   return specifier_instance_from_inst_list (specifier, matchspec, domain,
2647                                             sp->fallback, errb, no_quit,
2648                                             depth);
2649 }
2650 #undef CHECK_INSTANCE_ENTRY
2651
2652 Lisp_Object
2653 specifier_instance_no_quit (Lisp_Object specifier, Lisp_Object matchspec,
2654                             Lisp_Object domain, Error_behavior errb,
2655                             int no_fallback, Lisp_Object depth)
2656 {
2657   return specifier_instance (specifier, matchspec, domain, errb,
2658                              1, no_fallback, depth);
2659 }
2660
2661 DEFUN ("specifier-instance", Fspecifier_instance, 1, 4, 0, /*
2662 Instantiate SPECIFIER (return its value) in DOMAIN.
2663 If no instance can be generated for this domain, return DEFAULT.
2664
2665 DOMAIN should be a window, frame, or device.  Other values that are legal
2666 as a locale (e.g. a buffer) are not valid as a domain because they do not
2667 provide enough information to identify a particular device (see
2668 `valid-specifier-domain-p').  DOMAIN defaults to the selected window
2669 if omitted.
2670
2671 "Instantiating" a specifier in a particular domain means determining
2672 the specifier's "value" in that domain.  This is accomplished by
2673 searching through the specifications in the specifier that correspond
2674 to all locales that can be derived from the given domain, from specific
2675 to general.  In most cases, the domain is an Emacs window.  In that case
2676 specifications are searched for as follows:
2677
2678 1. A specification whose locale is the window itself;
2679 2. A specification whose locale is the window's buffer;
2680 3. A specification whose locale is the window's frame;
2681 4. A specification whose locale is the window's frame's device;
2682 5. A specification whose locale is 'global.
2683
2684 If all of those fail, then the C-code-provided fallback value for
2685 this specifier is consulted (see `specifier-fallback').  If it is
2686 an inst-list, then this function attempts to instantiate that list
2687 just as when a specification is located in the first five steps above.
2688 If the fallback is a specifier, `specifier-instance' is called
2689 recursively on this specifier and the return value used.  Note,
2690 however, that if the optional argument NO-FALLBACK is non-nil,
2691 the fallback value will not be consulted.
2692
2693 Note that there may be more than one specification matching a particular
2694 locale; all such specifications are considered before looking for any
2695 specifications for more general locales.  Any particular specification
2696 that is found may be rejected because its tag set does not match the
2697 device being instantiated over, or because the specification is not
2698 valid for the device of the given domain (e.g. the font or color name
2699 does not exist for this particular X server).
2700
2701 The returned value is dependent on the type of specifier.  For example,
2702 for a font specifier (as returned by the `face-font' function), the returned
2703 value will be a font-instance object.  For glyphs, the returned value
2704 will be a string, pixmap, or subwindow.
2705
2706 See also `specifier-matching-instance'.
2707 */
2708        (specifier, domain, default_, no_fallback))
2709 {
2710   Lisp_Object instance;
2711
2712   CHECK_SPECIFIER (specifier);
2713   domain = decode_domain (domain);
2714
2715   instance = specifier_instance (specifier, Qunbound, domain, ERROR_ME, 0,
2716                                  !NILP (no_fallback), Qzero);
2717   return UNBOUNDP (instance) ? default_ : instance;
2718 }
2719
2720 DEFUN ("specifier-matching-instance", Fspecifier_matching_instance, 2, 5, 0, /*
2721 Return an instance for SPECIFIER in DOMAIN that matches MATCHSPEC.
2722 If no instance can be generated for this domain, return DEFAULT.
2723
2724 This function is identical to `specifier-instance' except that a
2725 specification will only be considered if it matches MATCHSPEC.
2726 The definition of "match", and allowed values for MATCHSPEC, are
2727 dependent on the particular type of specifier.  Here are some examples:
2728
2729 -- For chartable (e.g. display table) specifiers, MATCHSPEC should be a
2730    character, and the specification (a chartable) must give a value for
2731    that character in order to be considered.  This allows you to specify,
2732    e.g., a buffer-local display table that only gives values for particular
2733    characters.  All other characters are handled as if the buffer-local
2734    display table is not there. (Chartable specifiers are not yet
2735    implemented.)
2736
2737 -- For font specifiers, MATCHSPEC should be a charset, and the specification
2738    (a font string) must have a registry that matches the charset's registry.
2739    (This only makes sense with Mule support.) This makes it easy to choose a
2740    font that can display a particular character. (This is what redisplay
2741    does, in fact.)
2742 */
2743        (specifier, matchspec, domain, default_, no_fallback))
2744 {
2745   Lisp_Object instance;
2746
2747   CHECK_SPECIFIER (specifier);
2748   check_valid_specifier_matchspec (matchspec, XSPECIFIER (specifier)->methods,
2749                                    ERROR_ME);
2750   domain = decode_domain (domain);
2751
2752   instance = specifier_instance (specifier, matchspec, domain, ERROR_ME,
2753                                  0, !NILP (no_fallback), Qzero);
2754   return UNBOUNDP (instance) ? default_ : instance;
2755 }
2756
2757 DEFUN ("specifier-instance-from-inst-list", Fspecifier_instance_from_inst_list,
2758        3, 4, 0, /*
2759 Attempt to convert a particular inst-list into an instance.
2760 This attempts to instantiate INST-LIST in the given DOMAIN,
2761 as if INST-LIST existed in a specification in SPECIFIER.  If
2762 the instantiation fails, DEFAULT is returned.  In most circumstances,
2763 you should not use this function; use `specifier-instance' instead.
2764 */
2765        (specifier, domain, inst_list, default_))
2766 {
2767   Lisp_Object val = Qunbound;
2768   Lisp_Specifier *sp = XSPECIFIER (specifier);
2769   struct gcpro gcpro1;
2770   Lisp_Object built_up_list = Qnil;
2771
2772   CHECK_SPECIFIER (specifier);
2773   check_valid_domain (domain);
2774   check_valid_inst_list (inst_list, sp->methods, ERROR_ME);
2775   GCPRO1 (built_up_list);
2776   built_up_list = build_up_processed_list (specifier, domain, inst_list);
2777   if (!NILP (built_up_list))
2778     val = specifier_instance_from_inst_list (specifier, Qunbound, domain,
2779                                              built_up_list, ERROR_ME,
2780                                              0, Qzero);
2781   UNGCPRO;
2782   return UNBOUNDP (val) ? default_ : val;
2783 }
2784
2785 DEFUN ("specifier-matching-instance-from-inst-list",
2786        Fspecifier_matching_instance_from_inst_list,
2787        4, 5, 0, /*
2788 Attempt to convert a particular inst-list into an instance.
2789 This attempts to instantiate INST-LIST in the given DOMAIN
2790 \(as if INST-LIST existed in a specification in SPECIFIER),
2791 matching the specifications against MATCHSPEC.
2792
2793 This function is analogous to `specifier-instance-from-inst-list'
2794 but allows for specification-matching as in `specifier-matching-instance'.
2795 See that function for a description of exactly how the matching process
2796 works.
2797 */
2798        (specifier, matchspec, domain, inst_list, default_))
2799 {
2800   Lisp_Object val = Qunbound;
2801   Lisp_Specifier *sp = XSPECIFIER (specifier);
2802   struct gcpro gcpro1;
2803   Lisp_Object built_up_list = Qnil;
2804
2805   CHECK_SPECIFIER (specifier);
2806   check_valid_specifier_matchspec (matchspec, XSPECIFIER (specifier)->methods,
2807                                    ERROR_ME);
2808   check_valid_domain (domain);
2809   check_valid_inst_list (inst_list, sp->methods, ERROR_ME);
2810   GCPRO1 (built_up_list);
2811   built_up_list = build_up_processed_list (specifier, domain, inst_list);
2812   if (!NILP (built_up_list))
2813     val = specifier_instance_from_inst_list (specifier, matchspec, domain,
2814                                              built_up_list, ERROR_ME,
2815                                              0, Qzero);
2816   UNGCPRO;
2817   return UNBOUNDP (val) ? default_ : val;
2818 }
2819
2820 \f
2821 /************************************************************************/
2822 /*                 Caching in the struct window or frame                */
2823 /************************************************************************/
2824
2825 /* Either STRUCT_WINDOW_OFFSET or STRUCT_FRAME_OFFSET can be 0 to indicate
2826    no caching in that sort of object. */
2827
2828 /* #### It would be nice if the specifier caching automatically knew
2829    about specifier fallbacks, so we didn't have to do it ourselves. */
2830
2831 void
2832 set_specifier_caching (Lisp_Object specifier, int struct_window_offset,
2833                        void (*value_changed_in_window)
2834                        (Lisp_Object specifier, struct window *w,
2835                         Lisp_Object oldval),
2836                        int struct_frame_offset,
2837                        void (*value_changed_in_frame)
2838                        (Lisp_Object specifier, struct frame *f,
2839                         Lisp_Object oldval),
2840                        int always_recompute)
2841 {
2842   Lisp_Specifier *sp = XSPECIFIER (specifier);
2843   assert (!GHOST_SPECIFIER_P (sp));
2844
2845   if (!sp->caching)
2846     sp->caching = xnew_and_zero (struct specifier_caching);
2847   sp->caching->offset_into_struct_window = struct_window_offset;
2848   sp->caching->value_changed_in_window = value_changed_in_window;
2849   sp->caching->offset_into_struct_frame = struct_frame_offset;
2850   sp->caching->value_changed_in_frame = value_changed_in_frame;
2851   sp->caching->always_recompute = always_recompute;
2852   Vcached_specifiers = Fcons (specifier, Vcached_specifiers);
2853   if (BODILY_SPECIFIER_P (sp))
2854     GHOST_SPECIFIER(sp)->caching = sp->caching;
2855   recompute_cached_specifier_everywhere (specifier);
2856 }
2857
2858 static void
2859 recompute_one_cached_specifier_in_window (Lisp_Object specifier,
2860                                           struct window *w)
2861 {
2862   Lisp_Object window;
2863   Lisp_Object newval, *location, oldval;
2864
2865   assert (!GHOST_SPECIFIER_P (XSPECIFIER (specifier)));
2866
2867   XSETWINDOW (window, w);
2868
2869   newval = specifier_instance (specifier, Qunbound, window, ERROR_ME_WARN,
2870                                0, 0, Qzero);
2871   /* If newval ended up Qunbound, then the calling functions
2872      better be able to deal.  If not, set a default so this
2873      never happens or correct it in the value_changed_in_window
2874      method. */
2875   location = (Lisp_Object *)
2876     ((char *) w + XSPECIFIER (specifier)->caching->offset_into_struct_window);
2877   /* #### What's the point of this check, other than to optimize image
2878      instance instantiation? Unless you specify a caching instantiate
2879      method the instantiation that specifier_instance will do will
2880      always create a new copy. Thus EQ will always fail. Unfortunately
2881      calling equal is no good either as this doesn't take into account
2882      things attached to the specifier - for instance strings on
2883      extents. --andyp */
2884   if (!EQ (newval, *location) || XSPECIFIER (specifier)->caching->always_recompute)
2885     {
2886       oldval = *location;
2887       *location = newval;
2888       (XSPECIFIER (specifier)->caching->value_changed_in_window)
2889         (specifier, w, oldval);
2890     }
2891 }
2892
2893 static void
2894 recompute_one_cached_specifier_in_frame (Lisp_Object specifier,
2895                                          struct frame *f)
2896 {
2897   Lisp_Object frame;
2898   Lisp_Object newval, *location, oldval;
2899
2900   assert (!GHOST_SPECIFIER_P (XSPECIFIER (specifier)));
2901
2902   XSETFRAME (frame, f);
2903
2904   newval = specifier_instance (specifier, Qunbound, frame, ERROR_ME_WARN,
2905                                0, 0, Qzero);
2906   /* If newval ended up Qunbound, then the calling functions
2907      better be able to deal.  If not, set a default so this
2908      never happens or correct it in the value_changed_in_frame
2909      method. */
2910   location = (Lisp_Object *)
2911     ((char *) f + XSPECIFIER (specifier)->caching->offset_into_struct_frame);
2912   if (!EQ (newval, *location) || XSPECIFIER (specifier)->caching->always_recompute)
2913     {
2914       oldval = *location;
2915       *location = newval;
2916       (XSPECIFIER (specifier)->caching->value_changed_in_frame)
2917         (specifier, f, oldval);
2918     }
2919 }
2920
2921 void
2922 recompute_all_cached_specifiers_in_window (struct window *w)
2923 {
2924   Lisp_Object rest;
2925
2926   LIST_LOOP (rest, Vcached_specifiers)
2927     {
2928       Lisp_Object specifier = XCAR (rest);
2929       if (XSPECIFIER (specifier)->caching->offset_into_struct_window)
2930         recompute_one_cached_specifier_in_window (specifier, w);
2931     }
2932 }
2933
2934 void
2935 recompute_all_cached_specifiers_in_frame (struct frame *f)
2936 {
2937   Lisp_Object rest;
2938
2939   LIST_LOOP (rest, Vcached_specifiers)
2940     {
2941       Lisp_Object specifier = XCAR (rest);
2942       if (XSPECIFIER (specifier)->caching->offset_into_struct_frame)
2943         recompute_one_cached_specifier_in_frame (specifier, f);
2944     }
2945 }
2946
2947 static int
2948 recompute_cached_specifier_everywhere_mapfun (struct window *w,
2949                                               void *closure)
2950 {
2951   Lisp_Object specifier = Qnil;
2952
2953   VOID_TO_LISP (specifier, closure);
2954   recompute_one_cached_specifier_in_window (specifier, w);
2955   return 0;
2956 }
2957
2958 static void
2959 recompute_cached_specifier_everywhere (Lisp_Object specifier)
2960 {
2961   Lisp_Object frmcons, devcons, concons;
2962
2963   specifier = bodily_specifier (specifier);
2964
2965   if (!XSPECIFIER (specifier)->caching)
2966     return;
2967
2968   if (XSPECIFIER (specifier)->caching->offset_into_struct_window)
2969     {
2970       FRAME_LOOP_NO_BREAK (frmcons, devcons, concons)
2971         map_windows (XFRAME (XCAR (frmcons)),
2972                      recompute_cached_specifier_everywhere_mapfun,
2973                      LISP_TO_VOID (specifier));
2974     }
2975
2976   if (XSPECIFIER (specifier)->caching->offset_into_struct_frame)
2977     {
2978       FRAME_LOOP_NO_BREAK (frmcons, devcons, concons)
2979         recompute_one_cached_specifier_in_frame (specifier,
2980                                                  XFRAME (XCAR (frmcons)));
2981     }
2982 }
2983
2984 DEFUN ("set-specifier-dirty-flag", Fset_specifier_dirty_flag, 1, 1, 0, /*
2985 Force recomputation of any caches associated with SPECIFIER.
2986 Note that this automatically happens whenever you change a specification
2987  in SPECIFIER; you do not have to call this function then.
2988 One example of where this function is useful is when you have a
2989  toolbar button whose `active-p' field is an expression to be
2990  evaluated.  Calling `set-specifier-dirty-flag' on the
2991  toolbar specifier will force the `active-p' fields to be
2992  recomputed.
2993 */
2994        (specifier))
2995 {
2996   CHECK_SPECIFIER (specifier);
2997   recompute_cached_specifier_everywhere (specifier);
2998   return Qnil;
2999 }
3000
3001 \f
3002 /************************************************************************/
3003 /*                        Generic specifier type                        */
3004 /************************************************************************/
3005
3006 DEFINE_SPECIFIER_TYPE (generic);
3007
3008 #if 0
3009
3010 /* This is the string that used to be in `generic-specifier-p'.
3011    The idea is good, but it doesn't quite work in the form it's
3012    in. (One major problem is that validating an instantiator
3013    is supposed to require only that the specifier type is passed,
3014    while with this approach the actual specifier is needed.)
3015
3016    What really needs to be done is to write a function
3017    `make-specifier-type' that creates new specifier types.
3018
3019    #### [I'll look into this for 19.14.]  Well, sometime. (Currently
3020    May 2000, 21.2 is in development.  19.14 was released in June 1996.) */
3021
3022 "A generic specifier is a generalized kind of specifier with user-defined\n"
3023 "semantics.  The instantiator can be any kind of Lisp object, and the\n"
3024 "instance computed from it is likewise any kind of Lisp object.  The\n"
3025 "SPECIFIER-DATA should be an alist of methods governing how the specifier\n"
3026 "works.  All methods are optional, and reasonable default methods will be\n"
3027 "provided.  Currently there are two defined methods: 'instantiate and\n"
3028 "'validate.\n"
3029 "\n"
3030 "'instantiate specifies how to do the instantiation; if omitted, the\n"
3031 "instantiator itself is simply returned as the instance.  The method\n"
3032 "should be a function that accepts three parameters (a specifier, the\n"
3033 "instantiator that matched the domain being instantiated over, and that\n"
3034 "domain), and should return a one-element list containing the instance,\n"
3035 "or nil if no instance exists.  Note that the domain passed to this function\n"
3036 "is the domain being instantiated over, which may not be the same as the\n"
3037 "locale contained in the specification corresponding to the instantiator\n"
3038 "(for example, the domain being instantiated over could be a window, but\n"
3039 "the locale corresponding to the passed instantiator could be the window's\n"
3040 "buffer or frame).\n"
3041 "\n"
3042 "'validate specifies whether a given instantiator is valid; if omitted,\n"
3043 "all instantiators are considered valid.  It should be a function of\n"
3044 "two arguments: an instantiator and a flag CAN-SIGNAL-ERROR.  If this\n"
3045 "flag is false, the function must simply return t or nil indicating\n"
3046 "whether the instantiator is valid.  If this flag is true, the function\n"
3047 "is free to signal an error if it encounters an invalid instantiator\n"
3048 "(this can be useful for issuing a specific error about exactly why the\n"
3049 "instantiator is valid).  It can also return nil to indicate an invalid\n"
3050 "instantiator; in this case, a general error will be signalled."
3051
3052 #endif /* 0 */
3053
3054 DEFUN ("generic-specifier-p", Fgeneric_specifier_p, 1, 1, 0, /*
3055 Return non-nil if OBJECT is a generic specifier.
3056
3057 See `make-generic-specifier' for a description of possible generic
3058 instantiators.
3059 */
3060        (object))
3061 {
3062   return GENERIC_SPECIFIERP (object) ? Qt : Qnil;
3063 }
3064
3065
3066 /************************************************************************/
3067 /*                        Integer specifier type                        */
3068 /************************************************************************/
3069
3070 DEFINE_SPECIFIER_TYPE (integer);
3071
3072 static void
3073 integer_validate (Lisp_Object instantiator)
3074 {
3075   CHECK_INT (instantiator);
3076 }
3077
3078 DEFUN ("integer-specifier-p", Finteger_specifier_p, 1, 1, 0, /*
3079 Return non-nil if OBJECT is an integer specifier.
3080
3081 See `make-integer-specifier' for a description of possible integer
3082 instantiators.
3083 */
3084        (object))
3085 {
3086   return INTEGER_SPECIFIERP (object) ? Qt : Qnil;
3087 }
3088
3089 /************************************************************************/
3090 /*                   Non-negative-integer specifier type                */
3091 /************************************************************************/
3092
3093 DEFINE_SPECIFIER_TYPE (natnum);
3094
3095 static void
3096 natnum_validate (Lisp_Object instantiator)
3097 {
3098   CHECK_NATNUM (instantiator);
3099 }
3100
3101 DEFUN ("natnum-specifier-p", Fnatnum_specifier_p, 1, 1, 0, /*
3102 Return non-nil if OBJECT is a natnum (non-negative-integer) specifier.
3103
3104 See `make-natnum-specifier' for a description of possible natnum
3105 instantiators.
3106 */
3107        (object))
3108 {
3109   return NATNUM_SPECIFIERP (object) ? Qt : Qnil;
3110 }
3111
3112 /************************************************************************/
3113 /*                        Boolean specifier type                        */
3114 /************************************************************************/
3115
3116 DEFINE_SPECIFIER_TYPE (boolean);
3117
3118 static void
3119 boolean_validate (Lisp_Object instantiator)
3120 {
3121   if (!EQ (instantiator, Qt) && !EQ (instantiator, Qnil))
3122     signal_type_error (Qspecifier_argument_error, "Must be t or nil",
3123                        instantiator);
3124 }
3125
3126 DEFUN ("boolean-specifier-p", Fboolean_specifier_p, 1, 1, 0, /*
3127 Return non-nil if OBJECT is a boolean specifier.
3128
3129 See `make-boolean-specifier' for a description of possible boolean
3130 instantiators.
3131 */
3132        (object))
3133 {
3134   return BOOLEAN_SPECIFIERP (object) ? Qt : Qnil;
3135 }
3136
3137 /************************************************************************/
3138 /*                        Display table specifier type                  */
3139 /************************************************************************/
3140
3141 DEFINE_SPECIFIER_TYPE (display_table);
3142
3143 #define VALID_SINGLE_DISPTABLE_INSTANTIATOR_P(instantiator)                \
3144   (VECTORP (instantiator)                                                  \
3145    || (CHAR_TABLEP (instantiator)                                          \
3146        && (XCHAR_TABLE_TYPE (instantiator) == CHAR_TABLE_TYPE_CHAR         \
3147            || XCHAR_TABLE_TYPE (instantiator) == CHAR_TABLE_TYPE_GENERIC)) \
3148    || RANGE_TABLEP (instantiator))
3149
3150 static void
3151 display_table_validate (Lisp_Object instantiator)
3152 {
3153   if (NILP (instantiator))
3154     /* OK */
3155     ;
3156   else if (CONSP (instantiator))
3157     {
3158       Lisp_Object tail;
3159       EXTERNAL_LIST_LOOP (tail, instantiator)
3160         {
3161           Lisp_Object car = XCAR (tail);
3162           if (!VALID_SINGLE_DISPTABLE_INSTANTIATOR_P (car))
3163             goto lose;
3164         }
3165     }
3166   else
3167     {
3168       if (!VALID_SINGLE_DISPTABLE_INSTANTIATOR_P (instantiator))
3169         {
3170         lose:
3171           dead_wrong_type_argument
3172             (display_table_specifier_methods->predicate_symbol,
3173                                     instantiator);
3174         }
3175     }
3176 }
3177
3178 DEFUN ("display-table-specifier-p", Fdisplay_table_specifier_p, 1, 1, 0, /*
3179 Return non-nil if OBJECT is a display-table specifier.
3180
3181 See `current-display-table' for a description of possible display-table
3182 instantiators.
3183 */
3184        (object))
3185 {
3186   return DISPLAYTABLE_SPECIFIERP (object) ? Qt : Qnil;
3187 }
3188
3189 \f
3190 /************************************************************************/
3191 /*                           Initialization                             */
3192 /************************************************************************/
3193
3194 void
3195 syms_of_specifier (void)
3196 {
3197   INIT_LRECORD_IMPLEMENTATION (specifier);
3198
3199   DEFSYMBOL (Qspecifierp);
3200
3201   DEFSYMBOL (Qconsole_type);
3202   DEFSYMBOL (Qdevice_class);
3203
3204   /* specifier types defined in general.c. */
3205
3206   DEFSUBR (Fvalid_specifier_type_p);
3207   DEFSUBR (Fspecifier_type_list);
3208   DEFSUBR (Fmake_specifier);
3209   DEFSUBR (Fspecifierp);
3210   DEFSUBR (Fspecifier_type);
3211
3212   DEFSUBR (Fvalid_specifier_locale_p);
3213   DEFSUBR (Fvalid_specifier_domain_p);
3214   DEFSUBR (Fvalid_specifier_locale_type_p);
3215   DEFSUBR (Fspecifier_locale_type_from_locale);
3216
3217   DEFSUBR (Fvalid_specifier_tag_p);
3218   DEFSUBR (Fvalid_specifier_tag_set_p);
3219   DEFSUBR (Fcanonicalize_tag_set);
3220   DEFSUBR (Fdevice_matches_specifier_tag_set_p);
3221   DEFSUBR (Fdefine_specifier_tag);
3222   DEFSUBR (Fdevice_matching_specifier_tag_list);
3223   DEFSUBR (Fspecifier_tag_list);
3224   DEFSUBR (Fspecifier_tag_predicate);
3225
3226   DEFSUBR (Fcheck_valid_instantiator);
3227   DEFSUBR (Fvalid_instantiator_p);
3228   DEFSUBR (Fcheck_valid_inst_list);
3229   DEFSUBR (Fvalid_inst_list_p);
3230   DEFSUBR (Fcheck_valid_spec_list);
3231   DEFSUBR (Fvalid_spec_list_p);
3232   DEFSUBR (Fadd_spec_to_specifier);
3233   DEFSUBR (Fadd_spec_list_to_specifier);
3234   DEFSUBR (Fspecifier_spec_list);
3235   DEFSUBR (Fspecifier_specs);
3236   DEFSUBR (Fremove_specifier);
3237   DEFSUBR (Fcopy_specifier);
3238
3239   DEFSUBR (Fcheck_valid_specifier_matchspec);
3240   DEFSUBR (Fvalid_specifier_matchspec_p);
3241   DEFSUBR (Fspecifier_fallback);
3242   DEFSUBR (Fspecifier_instance);
3243   DEFSUBR (Fspecifier_matching_instance);
3244   DEFSUBR (Fspecifier_instance_from_inst_list);
3245   DEFSUBR (Fspecifier_matching_instance_from_inst_list);
3246   DEFSUBR (Fset_specifier_dirty_flag);
3247
3248   DEFSUBR (Fgeneric_specifier_p);
3249   DEFSUBR (Finteger_specifier_p);
3250   DEFSUBR (Fnatnum_specifier_p);
3251   DEFSUBR (Fboolean_specifier_p);
3252   DEFSUBR (Fdisplay_table_specifier_p);
3253
3254   /* Symbols pertaining to specifier creation.  Specifiers are created
3255      in the syms_of() functions. */
3256
3257   /* locales are defined in general.c. */
3258
3259   /* some how-to-add flags in general.c. */
3260   DEFSYMBOL (Qremove_tag_set_prepend);
3261   DEFSYMBOL (Qremove_tag_set_append);
3262   DEFSYMBOL (Qremove_locale);
3263   DEFSYMBOL (Qremove_locale_type);
3264
3265   DEFERROR_STANDARD (Qspecifier_syntax_error, Qsyntax_error);
3266   DEFERROR_STANDARD (Qspecifier_argument_error, Qinvalid_argument);
3267   DEFERROR_STANDARD (Qspecifier_change_error, Qinvalid_change);
3268 }
3269
3270 void
3271 specifier_type_create (void)
3272 {
3273   the_specifier_type_entry_dynarr = Dynarr_new (specifier_type_entry);
3274   dump_add_root_struct_ptr (&the_specifier_type_entry_dynarr, &sted_description);
3275
3276   Vspecifier_type_list = Qnil;
3277   staticpro (&Vspecifier_type_list);
3278
3279   INITIALIZE_SPECIFIER_TYPE (generic, "generic", "generic-specifier-p");
3280
3281   INITIALIZE_SPECIFIER_TYPE (integer, "integer", "integer-specifier-p");
3282
3283   SPECIFIER_HAS_METHOD (integer, validate);
3284
3285   INITIALIZE_SPECIFIER_TYPE (natnum, "natnum", "natnum-specifier-p");
3286
3287   SPECIFIER_HAS_METHOD (natnum, validate);
3288
3289   INITIALIZE_SPECIFIER_TYPE (boolean, "boolean", "boolean-specifier-p");
3290
3291   SPECIFIER_HAS_METHOD (boolean, validate);
3292
3293   INITIALIZE_SPECIFIER_TYPE (display_table, "display-table",
3294                              "display-table-p");
3295
3296   SPECIFIER_HAS_METHOD (display_table, validate);
3297 }
3298
3299 void
3300 reinit_specifier_type_create (void)
3301 {
3302   REINITIALIZE_SPECIFIER_TYPE (generic);
3303   REINITIALIZE_SPECIFIER_TYPE (integer);
3304   REINITIALIZE_SPECIFIER_TYPE (natnum);
3305   REINITIALIZE_SPECIFIER_TYPE (boolean);
3306   REINITIALIZE_SPECIFIER_TYPE (display_table);
3307 }
3308
3309 void
3310 vars_of_specifier (void)
3311 {
3312   Vcached_specifiers = Qnil;
3313   staticpro (&Vcached_specifiers);
3314
3315   /* Do NOT mark through this, or specifiers will never be GC'd.
3316      This is the same deal as for weak hash tables. */
3317   Vall_specifiers = Qnil;
3318   dump_add_weak_object_chain (&Vall_specifiers);
3319
3320   Vuser_defined_tags = Qnil;
3321   staticpro (&Vuser_defined_tags);
3322
3323   Vunlock_ghost_specifiers = Qnil;
3324   staticpro (&Vunlock_ghost_specifiers);
3325 }