XEmacs 21.2-b1

[chise/xemacs-chise.git.1] / src / specifier.c

/* Specifier implementation
   Copyright (C) 1994, 1995 Board of Trustees, University of Illinois.
   Copyright (C) 1995, 1996 Ben Wing.
   Copyright (C) 1995 Sun Microsystems, Inc.

This file is part of XEmacs.

XEmacs is free software; you can redistribute it and/or modify it
under the terms of the GNU General Public License as published by the
Free Software Foundation; either version 2, or (at your option) any
later version.

XEmacs is distributed in the hope that it will be useful, but WITHOUT
ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or
FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License
for more details.

You should have received a copy of the GNU General Public License
along with XEmacs; see the file COPYING.  If not, write to
the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
Boston, MA 02111-1307, USA.  */

/* Synched up with: Not in FSF. */

/* Design by Ben Wing;
   Original version by Chuck Thompson;
   rewritten by Ben Wing;
   Magic specifiers by Kirill Katsnelson;
*/

#include <config.h>
#include "lisp.h"

#include "buffer.h"
#include "device.h"
#include "frame.h"
#include "opaque.h"
#include "specifier.h"
#include "window.h"
#include "glyphs.h"  /* for DISP_TABLE_SIZE definition */

Lisp_Object Qspecifierp;
Lisp_Object Qprepend, Qappend, Qremove_tag_set_prepend, Qremove_tag_set_append;
Lisp_Object Qremove_locale, Qremove_locale_type, Qremove_all;
Lisp_Object Qfallback;

/* Qinteger, Qboolean, Qgeneric defined in general.c. */
Lisp_Object Qnatnum;

Lisp_Object Qconsole_type, Qdevice_class;

static Lisp_Object Vuser_defined_tags;

typedef struct specifier_type_entry specifier_type_entry;
struct specifier_type_entry
{
  Lisp_Object symbol;
  struct specifier_methods *meths;
};

typedef struct
{
  Dynarr_declare (specifier_type_entry);
} specifier_type_entry_dynarr;

specifier_type_entry_dynarr *the_specifier_type_entry_dynarr;

static Lisp_Object Vspecifier_type_list;

static Lisp_Object Vcached_specifiers;
/* Do NOT mark through this, or specifiers will never be GC'd. */
static Lisp_Object Vall_specifiers;

static Lisp_Object Vunlock_ghost_specifiers;

/* #### The purpose of this is to check for inheritance loops
   in specifiers that can inherit from other specifiers, but it's
   not yet implemented.

   #### Look into this for 19.14. */
/* static Lisp_Object_dynarr current_specifiers; */

static void recompute_cached_specifier_everywhere (Lisp_Object specifier);

EXFUN (Fspecifier_specs, 4);
EXFUN (Fremove_specifier, 4);

\f
/************************************************************************/
/*                       Specifier object methods                       */
/************************************************************************/

/* Remove dead objects from the specified assoc list. */

static Lisp_Object
cleanup_assoc_list (Lisp_Object list)
{
  Lisp_Object loop, prev, retval;

  loop = retval = list;
  prev = Qnil;

  while (!NILP (loop))
    {
      Lisp_Object entry = XCAR (loop);
      Lisp_Object key = XCAR (entry);

      /* remember, dead windows can become alive again. */
      if (!WINDOWP (key) && object_dead_p (key))
        {
          if (NILP (prev))
            {
              /* Removing the head. */
              retval = XCDR (retval);
            }
          else
            {
              Fsetcdr (prev, XCDR (loop));
            }
        }
      else
        prev = loop;

      loop = XCDR (loop);
    }

  return retval;
}

/* Remove dead objects from the various lists so that they
   don't keep getting marked as long as this specifier exists and
   therefore wasting memory. */

void
cleanup_specifiers (void)
{
  Lisp_Object rest;

  for (rest = Vall_specifiers;
       !NILP (rest);
       rest = XSPECIFIER (rest)->next_specifier)
    {
      struct Lisp_Specifier *sp = XSPECIFIER (rest);
      /* This effectively changes the specifier specs.
         However, there's no need to call
         recompute_cached_specifier_everywhere() or the
         after-change methods because the only specs we
         are removing are for dead objects, and they can
         never have any effect on the specifier values:
         specifiers can only be instantiated over live
         objects, and you can't derive a dead object
         from a live one. */
      sp->device_specs = cleanup_assoc_list (sp->device_specs);
      sp->frame_specs = cleanup_assoc_list (sp->frame_specs);
      sp->buffer_specs = cleanup_assoc_list (sp->buffer_specs);
      /* windows are handled specially because dead windows
         can be resurrected */
    }
}

void
kill_specifier_buffer_locals (Lisp_Object buffer)
{
  Lisp_Object rest;

  for (rest = Vall_specifiers;
       !NILP (rest);
       rest = XSPECIFIER (rest)->next_specifier)
    {
      struct Lisp_Specifier *sp = XSPECIFIER (rest);

      /* Make sure we're actually going to be changing something.
         Fremove_specifier() always calls
         recompute_cached_specifier_everywhere() (#### but should
         be smarter about this). */
      if (!NILP (assq_no_quit (buffer, sp->buffer_specs)))
        Fremove_specifier (rest, buffer, Qnil, Qnil);
    }
}

static Lisp_Object
mark_specifier (Lisp_Object obj, void (*markobj) (Lisp_Object))
{
  struct Lisp_Specifier *specifier = XSPECIFIER (obj);

  ((markobj) (specifier->global_specs));
  ((markobj) (specifier->device_specs));
  ((markobj) (specifier->frame_specs));
  ((markobj) (specifier->window_specs));
  ((markobj) (specifier->buffer_specs));
  ((markobj) (specifier->magic_parent));
  ((markobj) (specifier->fallback));
  if (!GHOST_SPECIFIER_P (XSPECIFIER (obj)))
    MAYBE_SPECMETH (specifier, mark, (obj, markobj));
  return Qnil;
}

/* The idea here is that the specifier specs point to locales
   (windows, buffers, frames, and devices), and we want to make sure
   that the specs disappear automatically when the associated locale
   is no longer in use.  For all but windows, "no longer in use"
   corresponds exactly to when the object is deleted (non-deleted
   objects are always held permanently in special lists, and deleted
   objects are never on these lists and never reusable).  To handle
   this, we just have cleanup_specifiers() called periodically
   (at the beginning of garbage collection); it removes all dead
   objects.

   For windows, however, it's trickier because dead objects can be
   converted to live ones again if the dead object is in a window
   configuration.  Therefore, for windows, "no longer in use"
   corresponds to when the window object is garbage-collected.
   We now use weak lists for this purpose.

*/

void
prune_specifiers (int (*obj_marked_p) (Lisp_Object))
{
  Lisp_Object rest, prev = Qnil;

  for (rest = Vall_specifiers;
       !GC_NILP (rest);
       rest = XSPECIFIER (rest)->next_specifier)
    {
      if (! ((*obj_marked_p) (rest)))
        {
          struct Lisp_Specifier* sp = XSPECIFIER (rest);
          /* A bit of assertion that we're removing both parts of the
             magic one altogether */
          assert (!GC_MAGIC_SPECIFIER_P(sp)
                  || (GC_BODILY_SPECIFIER_P(sp) && (*obj_marked_p)(sp->fallback))
                  || (GC_GHOST_SPECIFIER_P(sp) && (*obj_marked_p)(sp->magic_parent)));
          /* This specifier is garbage.  Remove it from the list. */
          if (GC_NILP (prev))
            Vall_specifiers = sp->next_specifier;
          else
            XSPECIFIER (prev)->next_specifier = sp->next_specifier;
        }
      else
        prev = rest;
    }
}

static void
print_specifier (Lisp_Object obj, Lisp_Object printcharfun, int escapeflag)
{
  struct Lisp_Specifier *sp = XSPECIFIER (obj);
  char buf[100];
  int count = specpdl_depth ();
  Lisp_Object the_specs;

  if (print_readably)
    error ("printing unreadable object #<%s-specifier 0x%x>",
           sp->methods->name, sp->header.uid);

  sprintf (buf, "#<%s-specifier global=", sp->methods->name);
  write_c_string (buf, printcharfun);
  specbind (Qprint_string_length, make_int (100));
  specbind (Qprint_length, make_int (5));
  the_specs = Fspecifier_specs (obj, Qglobal, Qnil, Qnil);
  if (NILP (the_specs))
    /* there are no global specs */
    write_c_string ("<unspecified>", printcharfun);
  else
    print_internal (the_specs, printcharfun, 1);
  if (!NILP (sp->fallback))
    {
      write_c_string (" fallback=", printcharfun);
      print_internal (sp->fallback, printcharfun, escapeflag);
    }
  unbind_to (count, Qnil);
  sprintf (buf, " 0x%x>", sp->header.uid);
  write_c_string (buf, printcharfun);
}

static void
finalize_specifier (void *header, int for_disksave)
{
  struct Lisp_Specifier *sp = (struct Lisp_Specifier *) header;
  /* don't be snafued by the disksave finalization. */
  if (!for_disksave && !GC_GHOST_SPECIFIER_P(sp) && sp->caching)
    {
      xfree (sp->caching);
      sp->caching = 0;
    }
}

static int
specifier_equal (Lisp_Object o1, Lisp_Object o2, int depth)
{
  struct Lisp_Specifier *s1 = XSPECIFIER (o1);
  struct Lisp_Specifier *s2 = XSPECIFIER (o2);
  int retval;
  Lisp_Object old_inhibit_quit = Vinhibit_quit;

  /* This function can be called from within redisplay.
     internal_equal can trigger a quit.  That leads to Bad Things. */
  Vinhibit_quit = Qt;

  depth++;
  retval =
    (s1->methods == s2->methods &&
     internal_equal (s1->global_specs, s2->global_specs, depth) &&
     internal_equal (s1->device_specs, s2->device_specs, depth) &&
     internal_equal (s1->frame_specs,  s2->frame_specs,  depth) &&
     internal_equal (s1->window_specs, s2->window_specs, depth) &&
     internal_equal (s1->buffer_specs, s2->buffer_specs, depth) &&
     internal_equal (s1->fallback,     s2->fallback,     depth));

  if (retval && HAS_SPECMETH_P (s1, equal))
    retval = SPECMETH (s1, equal, (o1, o2, depth - 1));

  Vinhibit_quit = old_inhibit_quit;
  return retval;
}

static unsigned long
specifier_hash (Lisp_Object obj, int depth)
{
  struct Lisp_Specifier *s = XSPECIFIER (obj);

  /* specifier hashing is a bit problematic because there are so
     many places where data can be stored.  We pick what are perhaps
     the most likely places where interesting stuff will be. */
  return HASH5 ((HAS_SPECMETH_P (s, hash) ?
                 SPECMETH (s, hash, (obj, depth)) : 0),
                (unsigned long) s->methods,
                internal_hash (s->global_specs, depth + 1),
                internal_hash (s->frame_specs,  depth + 1),
                internal_hash (s->buffer_specs, depth + 1));
}

static size_t
sizeof_specifier (CONST void *header)
{
  if (GHOST_SPECIFIER_P ((struct Lisp_Specifier *) header))
    return sizeof (struct Lisp_Specifier);
  else
    {
      CONST struct Lisp_Specifier *p = (CONST struct Lisp_Specifier *) header;
      return sizeof (*p) + p->methods->extra_data_size - 1;
    }
}

DEFINE_LRECORD_SEQUENCE_IMPLEMENTATION ("specifier", specifier,
                                        mark_specifier, print_specifier,
                                        finalize_specifier,
                                        specifier_equal, specifier_hash,
                                        sizeof_specifier,
                                        struct Lisp_Specifier);
\f
/************************************************************************/
/*                       Creating specifiers                            */
/************************************************************************/

static struct specifier_methods *
decode_specifier_type (Lisp_Object type, Error_behavior errb)
{
  int i;

  for (i = 0; i < Dynarr_length (the_specifier_type_entry_dynarr); i++)
    {
      if (EQ (type, Dynarr_at (the_specifier_type_entry_dynarr, i).symbol))
        return Dynarr_at (the_specifier_type_entry_dynarr, i).meths;
    }

  maybe_signal_simple_error ("Invalid specifier type", type,
                             Qspecifier, errb);

  return 0;
}

static int
valid_specifier_type_p (Lisp_Object type)
{
  return decode_specifier_type (type, ERROR_ME_NOT) != 0;
}

DEFUN ("valid-specifier-type-p", Fvalid_specifier_type_p, 1, 1, 0, /*
Given a SPECIFIER-TYPE, return non-nil if it is valid.
Valid types are 'generic, 'integer, boolean, 'color, 'font, 'image,
'face-boolean, and 'toolbar.
*/
       (specifier_type))
{
  return valid_specifier_type_p (specifier_type) ? Qt : Qnil;
}

DEFUN ("specifier-type-list", Fspecifier_type_list, 0, 0, 0, /*
Return a list of valid specifier types.
*/
       ())
{
  return Fcopy_sequence (Vspecifier_type_list);
}

void
add_entry_to_specifier_type_list (Lisp_Object symbol,
                                  struct specifier_methods *meths)
{
  struct specifier_type_entry entry;

  entry.symbol = symbol;
  entry.meths = meths;
  Dynarr_add (the_specifier_type_entry_dynarr, entry);
  Vspecifier_type_list = Fcons (symbol, Vspecifier_type_list);
}

static Lisp_Object
make_specifier_internal (struct specifier_methods *spec_meths,
                         size_t data_size, int call_create_meth)
{
  Lisp_Object specifier;
  struct Lisp_Specifier *sp = (struct Lisp_Specifier *)
    alloc_lcrecord (sizeof (struct Lisp_Specifier) +
                    data_size - 1, lrecord_specifier);

  sp->methods = spec_meths;
  sp->global_specs = Qnil;
  sp->device_specs = Qnil;
  sp->frame_specs = Qnil;
  sp->window_specs = make_weak_list (WEAK_LIST_KEY_ASSOC);
  sp->buffer_specs = Qnil;
  sp->fallback = Qnil;
  sp->magic_parent = Qnil;
  sp->caching = 0;
  sp->next_specifier = Vall_specifiers;

  XSETSPECIFIER (specifier, sp);
  Vall_specifiers = specifier;

  if (call_create_meth)
    {
      struct gcpro gcpro1;
      GCPRO1 (specifier);
      MAYBE_SPECMETH (XSPECIFIER (specifier), create, (specifier));
      UNGCPRO;
    }
  return specifier;
}

static Lisp_Object
make_specifier (struct specifier_methods *meths)
{
  return make_specifier_internal (meths, meths->extra_data_size, 1);
}

Lisp_Object
make_magic_specifier (Lisp_Object type)
{
  /* This function can GC */
  struct specifier_methods *meths = decode_specifier_type (type, ERROR_ME);
  Lisp_Object bodily, ghost;
  struct gcpro gcpro1;

  bodily = make_specifier (meths);
  GCPRO1 (bodily);
  ghost  = make_specifier_internal (meths, 0, 0);
  UNGCPRO;

  /* Connect guys together */
  XSPECIFIER(bodily)->magic_parent = Qt;
  XSPECIFIER(bodily)->fallback = ghost;
  XSPECIFIER(ghost)->magic_parent = bodily;

  return bodily;
}

DEFUN ("make-specifier", Fmake_specifier, 1, 1, 0, /*
Return a new specifier object of type TYPE.

A specifier is an object that can be used to keep track of a property
whose value can be per-buffer, per-window, per-frame, or per-device,
and can further be restricted to a particular console-type or device-class.
Specifiers are used, for example, for the various built-in properties of a
face; this allows a face to have different values in different frames,
buffers, etc.  For more information, see `specifier-instance',
`specifier-specs', and `add-spec-to-specifier'; or, for a detailed
description of specifiers, including how they are instantiated over a
particular domain (i.e. how their value in that domain is determined),
see the chapter on specifiers in the XEmacs Lisp Reference Manual.

TYPE specifies the particular type of specifier, and should be one of
the symbols 'generic, 'integer, 'boolean, 'color, 'font, 'image,
'face-boolean, or 'toolbar.

For more information on particular types of specifiers, see the functions
`generic-specifier-p', `integer-specifier-p', `boolean-specifier-p',
`color-specifier-p', `font-specifier-p', `image-specifier-p',
`face-boolean-specifier-p', and `toolbar-specifier-p'.
*/
       (type))
{
  /* This function can GC */
  struct specifier_methods *meths = decode_specifier_type (type,
                                                           ERROR_ME);

  return make_specifier (meths);
}

DEFUN ("specifierp", Fspecifierp, 1, 1, 0, /*
Return t if OBJECT is a specifier.

A specifier is an object that can be used to keep track of a property
whose value can be per-buffer, per-window, per-frame, or per-device,
and can further be restricted to a particular console-type or device-class.
See `make-specifier'.
*/
       (object))
{
  return SPECIFIERP (object) ? Qt : Qnil;
}

DEFUN ("specifier-type", Fspecifier_type, 1, 1, 0, /*
Return the type of SPECIFIER.
*/
       (specifier))
{
  CHECK_SPECIFIER (specifier);
  return intern (XSPECIFIER (specifier)->methods->name);
}

\f
/************************************************************************/
/*                       Locales and domains                            */
/************************************************************************/

DEFUN ("valid-specifier-locale-p", Fvalid_specifier_locale_p, 1, 1, 0, /*
Return t if LOCALE is a valid specifier locale.
Valid locales are devices, frames, windows, buffers, and 'global.
\(nil is not valid.)
*/
       (locale))
{
  /* This cannot GC. */
  return ((DEVICEP (locale) && DEVICE_LIVE_P (XDEVICE (locale))) ||
          (FRAMEP  (locale) && FRAME_LIVE_P  (XFRAME  (locale))) ||
          (BUFFERP (locale) && BUFFER_LIVE_P (XBUFFER (locale))) ||
          /* dead windows are allowed because they may become live
             windows again when a window configuration is restored */
          WINDOWP (locale) ||
          EQ (locale, Qglobal))
    ? Qt : Qnil;
}

DEFUN ("valid-specifier-domain-p", Fvalid_specifier_domain_p, 1, 1, 0, /*
Return t if DOMAIN is a valid specifier domain.
A domain is used to instance a specifier (i.e. determine the specifier's
value in that domain).  Valid domains are windows, frames, and devices.
\(nil is not valid.)
*/
     (domain))
{
  /* This cannot GC. */
  return ((DEVICEP (domain) && DEVICE_LIVE_P (XDEVICE (domain))) ||
          (FRAMEP  (domain) && FRAME_LIVE_P  (XFRAME  (domain))) ||
          (WINDOWP (domain) && WINDOW_LIVE_P (XWINDOW (domain))))
    ? Qt : Qnil;
}

DEFUN ("valid-specifier-locale-type-p", Fvalid_specifier_locale_type_p, 1, 1, 0, /*
Given a specifier LOCALE-TYPE, return non-nil if it is valid.
Valid locale types are 'global, 'device, 'frame, 'window, and 'buffer.
\(Note, however, that in functions that accept either a locale or a locale
type, 'global is considered an individual locale.)
*/
     (locale_type))
{
  /* This cannot GC. */
  return (EQ (locale_type, Qglobal) ||
          EQ (locale_type, Qdevice) ||
          EQ (locale_type, Qframe)  ||
          EQ (locale_type, Qwindow) ||
          EQ (locale_type, Qbuffer)) ? Qt : Qnil;
}

static void
check_valid_locale_or_locale_type (Lisp_Object locale)
{
  /* This cannot GC. */
  if (EQ (locale, Qall) ||
      !NILP (Fvalid_specifier_locale_p (locale)) ||
      !NILP (Fvalid_specifier_locale_type_p (locale)))
    return;
  signal_simple_error ("Invalid specifier locale or locale type", locale);
}

DEFUN ("specifier-locale-type-from-locale", Fspecifier_locale_type_from_locale,
       1, 1, 0, /*
Given a specifier LOCALE, return its type.
*/
       (locale))
{
  /* This cannot GC. */
  if (NILP (Fvalid_specifier_locale_p (locale)))
    signal_simple_error ("Invalid specifier locale", locale);
  if (DEVICEP (locale)) return Qdevice;
  if (FRAMEP  (locale)) return Qframe;
  if (WINDOWP (locale)) return Qwindow;
  if (BUFFERP (locale)) return Qbuffer;
  assert (EQ (locale, Qglobal));
  return Qglobal;
}

static Lisp_Object
decode_locale (Lisp_Object locale)
{
  /* This cannot GC. */
  if (NILP (locale))
    return Qglobal;
  else if (!NILP (Fvalid_specifier_locale_p (locale)))
    return locale;
  else
    signal_simple_error ("Invalid specifier locale", locale);

  return Qnil;
}

static enum spec_locale_type
decode_locale_type (Lisp_Object locale_type)
{
  /* This cannot GC. */
  if (EQ (locale_type, Qglobal)) return LOCALE_GLOBAL;
  if (EQ (locale_type, Qdevice)) return LOCALE_DEVICE;
  if (EQ (locale_type, Qframe))  return LOCALE_FRAME;
  if (EQ (locale_type, Qwindow)) return LOCALE_WINDOW;
  if (EQ (locale_type, Qbuffer)) return LOCALE_BUFFER;

  signal_simple_error ("Invalid specifier locale type", locale_type);
  return LOCALE_GLOBAL; /* not reached */
}

Lisp_Object
decode_locale_list (Lisp_Object locale)
{
  /* This cannot GC. */
  /* The return value of this function must be GCPRO'd. */
  if (NILP (locale))
    locale = list1 (Qall);
  else
    {
      Lisp_Object rest;
      if (!CONSP (locale))
        locale = list1 (locale);
      EXTERNAL_LIST_LOOP (rest, locale)
        check_valid_locale_or_locale_type (XCAR (rest));
    }
  return locale;
}

static enum spec_locale_type
locale_type_from_locale (Lisp_Object locale)
{
  return decode_locale_type (Fspecifier_locale_type_from_locale (locale));
}

static void
check_valid_domain (Lisp_Object domain)
{
  if (NILP (Fvalid_specifier_domain_p (domain)))
    signal_simple_error ("Invalid specifier domain", domain);
}

static Lisp_Object
decode_domain (Lisp_Object domain)
{
  if (NILP (domain))
    return Fselected_window (Qnil);
  check_valid_domain (domain);
  return domain;
}

\f
/************************************************************************/
/*                                 Tags                                 */
/************************************************************************/

DEFUN ("valid-specifier-tag-p", Fvalid_specifier_tag_p, 1, 1, 0, /*
Return non-nil if TAG is a valid specifier tag.
See also `valid-specifier-tag-set-p'.
*/
       (tag))
{
  return (valid_console_type_p (tag) ||
          valid_device_class_p (tag) ||
          !NILP (assq_no_quit (tag, Vuser_defined_tags))) ? Qt : Qnil;
}

DEFUN ("valid-specifier-tag-set-p", Fvalid_specifier_tag_set_p, 1, 1, 0, /*
Return non-nil if TAG-SET is a valid specifier tag set.

A specifier tag set is an entity that is attached to an instantiator
and can be used to restrict the scope of that instantiator to a
particular device class or device type and/or to mark instantiators
added by a particular package so that they can be later removed.

A specifier tag set consists of a list of zero of more specifier tags,
each of which is a symbol that is recognized by XEmacs as a tag.
\(The valid device types and device classes are always tags, as are
any tags defined by `define-specifier-tag'.) It is called a "tag set"
\(as opposed to a list) because the order of the tags or the number of
times a particular tag occurs does not matter.

Each tag has a predicate associated with it, which specifies whether
that tag applies to a particular device.  The tags which are device types
and classes match devices of that type or class.  User-defined tags can
have any predicate, or none (meaning that all devices match).  When
attempting to instance a specifier, a particular instantiator is only
considered if the device of the domain being instanced over matches
all tags in the tag set attached to that instantiator.

Most of the time, a tag set is not specified, and the instantiator
gets a null tag set, which matches all devices.
*/
     (tag_set))
{
  Lisp_Object rest;

  for (rest = tag_set; !NILP (rest); rest = XCDR (rest))
    {
      if (!CONSP (rest))
        return Qnil;
      if (NILP (Fvalid_specifier_tag_p (XCAR (rest))))
        return Qnil;
      QUIT;
    }
  return Qt;
}

Lisp_Object
decode_specifier_tag_set (Lisp_Object tag_set)
{
  /* The return value of this function must be GCPRO'd. */
  if (!NILP (Fvalid_specifier_tag_p (tag_set)))
    return list1 (tag_set);
  if (NILP (Fvalid_specifier_tag_set_p (tag_set)))
    signal_simple_error ("Invalid specifier tag-set", tag_set);
  return tag_set;
}

static Lisp_Object
canonicalize_tag_set (Lisp_Object tag_set)
{
  int len = XINT (Flength (tag_set));
  Lisp_Object *tags, rest;
  int i, j;

  /* We assume in this function that the tag_set has already been
     validated, so there are no surprises. */

  if (len == 0 || len == 1)
    /* most common case */
    return tag_set;

  tags = alloca_array (Lisp_Object, len);

  i = 0;
  LIST_LOOP (rest, tag_set)
    tags[i++] = XCAR (rest);

  /* Sort the list of tags.  We use a bubble sort here (copied from
     extent_fragment_update()) -- reduces the function call overhead,
     and is the fastest sort for small numbers of items. */

  for (i = 1; i < len; i++)
    {
      j = i - 1;
      while (j >= 0 &&
             strcmp ((char *) string_data (XSYMBOL (tags[j])->name),
                     (char *) string_data (XSYMBOL (tags[j+1])->name)) > 0)
        {
          Lisp_Object tmp = tags[j];
          tags[j] = tags[j+1];
          tags[j+1] = tmp;
          j--;
        }
    }

  /* Now eliminate duplicates. */

  for (i = 1, j = 1; i < len; i++)
    {
      /* j holds the destination, i the source. */
      if (!EQ (tags[i], tags[i-1]))
        tags[j++] = tags[i];
    }

  return Flist (j, tags);
}

DEFUN ("canonicalize-tag-set", Fcanonicalize_tag_set, 1, 1, 0, /*
Canonicalize the given tag set.
Two canonicalized tag sets can be compared with `equal' to see if they
represent the same tag set. (Specifically, canonicalizing involves
sorting by symbol name and removing duplicates.)
*/
       (tag_set))
{
  if (NILP (Fvalid_specifier_tag_set_p (tag_set)))
    signal_simple_error ("Invalid tag set", tag_set);
  return canonicalize_tag_set (tag_set);
}

static int
device_matches_specifier_tag_set_p (Lisp_Object device, Lisp_Object tag_set)
{
  Lisp_Object devtype, devclass, rest;
  struct device *d = XDEVICE (device);

  devtype = DEVICE_TYPE (d);
  devclass = DEVICE_CLASS (d);

  LIST_LOOP (rest, tag_set)
    {
      Lisp_Object tag = XCAR (rest);
      Lisp_Object assoc;

      if (EQ (tag, devtype) || EQ (tag, devclass))
        continue;
      assoc = assq_no_quit (tag, DEVICE_USER_DEFINED_TAGS (d));
      /* other built-in tags (device types/classes) are not in
         the user-defined-tags list. */
      if (NILP (assoc) || NILP (XCDR (assoc)))
        return 0;
    }

  return 1;
}

DEFUN ("device-matches-specifier-tag-set-p", Fdevice_matches_specifier_tag_set_p, 2, 2, 0, /*
Return non-nil if DEVICE matches specifier tag set TAG-SET.
This means that DEVICE matches each tag in the tag set. (Every
tag recognized by XEmacs has a predicate associated with it that
specifies which devices match it.)
*/
       (device, tag_set))
{
  CHECK_LIVE_DEVICE (device);

  if (NILP (Fvalid_specifier_tag_set_p (tag_set)))
    signal_simple_error ("Invalid tag set", tag_set);

  return device_matches_specifier_tag_set_p (device, tag_set) ? Qt : Qnil;
}

DEFUN ("define-specifier-tag", Fdefine_specifier_tag, 1, 2, 0, /*
Define a new specifier tag.
If PREDICATE is specified, it should be a function of one argument
\(a device) that specifies whether the tag matches that particular
device.  If PREDICATE is omitted, the tag matches all devices.

You can redefine an existing user-defined specifier tag.  However,
you cannot redefine the built-in specifier tags (the device types
and classes) or the symbols nil, t, 'all, or 'global.
*/
       (tag, predicate))
{
  Lisp_Object assoc, devcons, concons;
  int recompute = 0;

  CHECK_SYMBOL (tag);
  if (valid_device_class_p (tag) ||
      valid_console_type_p (tag))
    signal_simple_error ("Cannot redefine built-in specifier tags", tag);
  /* Try to prevent common instantiators and locales from being
     redefined, to reduce ambiguity */
  if (NILP (tag) || EQ (tag, Qt) || EQ (tag, Qall) || EQ (tag, Qglobal))
    signal_simple_error ("Cannot define nil, t, 'all, or 'global",
                         tag);
  assoc = assq_no_quit (tag, Vuser_defined_tags);
  if (NILP (assoc))
    {
      recompute = 1;
      Vuser_defined_tags = Fcons (Fcons (tag, predicate), Vuser_defined_tags);
      DEVICE_LOOP_NO_BREAK (devcons, concons)
        {
          struct device *d = XDEVICE (XCAR (devcons));
          /* Initially set the value to t in case of error
             in predicate */
          DEVICE_USER_DEFINED_TAGS (d) =
            Fcons (Fcons (tag, Qt), DEVICE_USER_DEFINED_TAGS (d));
        }
    }
  else if (!NILP (predicate) && !NILP (XCDR (assoc)))
    {
      recompute = 1;
      XCDR (assoc) = predicate;
    }

  /* recompute the tag values for all devices.  However, in the special
     case where both the old and new predicates are nil, we know that
     we don't have to do this. (It's probably common for people to
     call (define-specifier-tag) more than once on the same tag,
     and the most common case is where PREDICATE is not specified.) */

  if (recompute)
    {
      DEVICE_LOOP_NO_BREAK (devcons, concons)
        {
          Lisp_Object device = XCAR (devcons);
          assoc = assq_no_quit (tag,
                                DEVICE_USER_DEFINED_TAGS (XDEVICE (device)));
          assert (CONSP (assoc));
          if (NILP (predicate))
            XCDR (assoc) = Qt;
          else
            XCDR (assoc) = !NILP (call1 (predicate, device)) ? Qt : Qnil;
        }
    }

  return Qnil;
}

/* Called at device-creation time to initialize the user-defined
   tag values for the newly-created device. */

void
setup_device_initial_specifier_tags (struct device *d)
{
  Lisp_Object rest, rest2;
  Lisp_Object device;

  XSETDEVICE (device, d);

  DEVICE_USER_DEFINED_TAGS (d) = Fcopy_alist (Vuser_defined_tags);

  /* Now set up the initial values */
  LIST_LOOP (rest, DEVICE_USER_DEFINED_TAGS (d))
    XCDR (XCAR (rest)) = Qt;

  for (rest = Vuser_defined_tags, rest2 = DEVICE_USER_DEFINED_TAGS (d);
       !NILP (rest); rest = XCDR (rest), rest2 = XCDR (rest2))
    {
      Lisp_Object predicate = XCDR (XCAR (rest));
      if (NILP (predicate))
        XCDR (XCAR (rest2)) = Qt;
      else
        XCDR (XCAR (rest2)) = !NILP (call1 (predicate, device)) ? Qt : Qnil;
    }
}

DEFUN ("device-matching-specifier-tag-list", Fdevice_matching_specifier_tag_list,
       0, 1, 0, /*
Return a list of all specifier tags matching DEVICE.
DEVICE defaults to the selected device if omitted.
*/
       (device))
{
  struct device *d = decode_device (device);
  Lisp_Object rest, list = Qnil;
  struct gcpro gcpro1;

  GCPRO1 (list);

  LIST_LOOP (rest, DEVICE_USER_DEFINED_TAGS (d))
    {
      if (!NILP (XCDR (XCAR (rest))))
        list = Fcons (XCAR (XCAR (rest)), list);
    }

  list = Fnreverse (list);
  list = Fcons (DEVICE_CLASS (d), list);
  list = Fcons (DEVICE_TYPE  (d), list);

  RETURN_UNGCPRO (list);
}

DEFUN ("specifier-tag-list", Fspecifier_tag_list, 0, 0, 0, /*
Return a list of all currently-defined specifier tags.
This includes the built-in ones (the device types and classes).
*/
       ())
{
  Lisp_Object list = Qnil, rest;
  struct gcpro gcpro1;

  GCPRO1 (list);

  LIST_LOOP (rest, Vuser_defined_tags)
    list = Fcons (XCAR (XCAR (rest)), list);

  list = Fnreverse (list);
  list = nconc2 (Fcopy_sequence (Vdevice_class_list), list);
  list = nconc2 (Fcopy_sequence (Vconsole_type_list), list);

  RETURN_UNGCPRO (list);
}

DEFUN ("specifier-tag-predicate", Fspecifier_tag_predicate, 1, 1, 0, /*
Return the predicate for the given specifier tag.
*/
       (tag))
{
  /* The return value of this function must be GCPRO'd. */
  CHECK_SYMBOL (tag);

  if (NILP (Fvalid_specifier_tag_p (tag)))
    signal_simple_error ("Invalid specifier tag", tag);

  /* Make up some predicates for the built-in types */

  if (valid_console_type_p (tag))
    return list3 (Qlambda, list1 (Qdevice),
                  list3 (Qeq, list2 (Qquote, tag),
                         list2 (Qconsole_type, Qdevice)));

  if (valid_device_class_p (tag))
    return list3 (Qlambda, list1 (Qdevice),
                  list3 (Qeq, list2 (Qquote, tag),
                         list2 (Qdevice_class, Qdevice)));

  return XCDR (assq_no_quit (tag, Vuser_defined_tags));
}

/* Return true if A "matches" B.  If EXACT_P is 0, A must be a subset of B.
  Otherwise, A must be `equal' to B.  The sets must be canonicalized. */
static int
tag_sets_match_p (Lisp_Object a, Lisp_Object b, int exact_p)
{
  if (!exact_p)
    {
      while (!NILP (a) && !NILP (b))
        {
          if (EQ (XCAR (a), XCAR (b)))
            a = XCDR (a);
          b = XCDR (b);
        }

      return NILP (a);
    }
  else
    {
      while (!NILP (a) && !NILP (b))
        {
          if (!EQ (XCAR (a), XCAR (b)))
            return 0;
          a = XCDR (a);
          b = XCDR (b);
        }

      return NILP (a) && NILP (b);
    }
}

\f
/************************************************************************/
/*                       Spec-lists and inst-lists                      */
/************************************************************************/

static Lisp_Object
call_validate_method (Lisp_Object boxed_method, Lisp_Object instantiator)
{
  ((void (*)(Lisp_Object)) get_opaque_ptr (boxed_method)) (instantiator);
  return Qt;
}

static Lisp_Object
check_valid_instantiator (Lisp_Object instantiator,
                          struct specifier_methods *meths,
                          Error_behavior errb)
{
  if (meths->validate_method)
    {
      Lisp_Object retval;

      if (ERRB_EQ (errb, ERROR_ME))
        {
          (meths->validate_method) (instantiator);
          retval = Qt;
        }
      else
        {
          Lisp_Object opaque = make_opaque_ptr ((void *)
                                                meths->validate_method);
          struct gcpro gcpro1;

          GCPRO1 (opaque);
          retval = call_with_suspended_errors
            ((lisp_fn_t) call_validate_method,
             Qnil, Qspecifier, errb, 2, opaque, instantiator);

          free_opaque_ptr (opaque);
          UNGCPRO;
        }

      return retval;
    }
  return Qt;
}

DEFUN ("check-valid-instantiator", Fcheck_valid_instantiator, 2, 2, 0, /*
Signal an error if INSTANTIATOR is invalid for SPECIFIER-TYPE.
*/
       (instantiator, specifier_type))
{
  struct specifier_methods *meths = decode_specifier_type (specifier_type,
                                                           ERROR_ME);

  return check_valid_instantiator (instantiator, meths, ERROR_ME);
}

DEFUN ("valid-instantiator-p", Fvalid_instantiator_p, 2, 2, 0, /*
Return non-nil if INSTANTIATOR is valid for SPECIFIER-TYPE.
*/
       (instantiator, specifier_type))
{
  struct specifier_methods *meths = decode_specifier_type (specifier_type,
                                                           ERROR_ME);

  return check_valid_instantiator (instantiator, meths, ERROR_ME_NOT);
}

static Lisp_Object
check_valid_inst_list (Lisp_Object inst_list, struct specifier_methods *meths,
                       Error_behavior errb)
{
  Lisp_Object rest;

  LIST_LOOP (rest, inst_list)
    {
      Lisp_Object inst_pair, tag_set;

      if (!CONSP (rest))
        {
          maybe_signal_simple_error ("Invalid instantiator list", inst_list,
                                     Qspecifier, errb);
          return Qnil;
        }
      if (!CONSP (inst_pair = XCAR (rest)))
        {
          maybe_signal_simple_error ("Invalid instantiator pair", inst_pair,
                                     Qspecifier, errb);
          return Qnil;
        }
      if (NILP (Fvalid_specifier_tag_set_p (tag_set = XCAR (inst_pair))))
        {
          maybe_signal_simple_error ("Invalid specifier tag", tag_set,
                                     Qspecifier, errb);
          return Qnil;
        }

      if (NILP (check_valid_instantiator (XCDR (inst_pair), meths, errb)))
        return Qnil;
    }

  return Qt;
}

DEFUN ("check-valid-inst-list", Fcheck_valid_inst_list, 2, 2, 0, /*
Signal an error if INST-LIST is invalid for specifier type TYPE.
*/
       (inst_list, type))
{
  struct specifier_methods *meths = decode_specifier_type (type, ERROR_ME);

  return check_valid_inst_list (inst_list, meths, ERROR_ME);
}

DEFUN ("valid-inst-list-p", Fvalid_inst_list_p, 2, 2, 0, /*
Return non-nil if INST-LIST is valid for specifier type TYPE.
*/
       (inst_list, type))
{
  struct specifier_methods *meths = decode_specifier_type (type, ERROR_ME);

  return check_valid_inst_list (inst_list, meths, ERROR_ME_NOT);
}

static Lisp_Object
check_valid_spec_list (Lisp_Object spec_list, struct specifier_methods *meths,
                       Error_behavior errb)
{
  Lisp_Object rest;

  LIST_LOOP (rest, spec_list)
    {
      Lisp_Object spec, locale;
      if (!CONSP (rest) || !CONSP (spec = XCAR (rest)))
        {
          maybe_signal_simple_error ("Invalid specification list", spec_list,
                                     Qspecifier, errb);
          return Qnil;
        }
      if (NILP (Fvalid_specifier_locale_p (locale = XCAR (spec))))
        {
          maybe_signal_simple_error ("Invalid specifier locale", locale,
                                     Qspecifier, errb);
          return Qnil;
        }

      if (NILP (check_valid_inst_list (XCDR (spec), meths, errb)))
        return Qnil;
    }

  return Qt;
}

DEFUN ("check-valid-spec-list", Fcheck_valid_spec_list, 2, 2, 0, /*
Signal an error if SPEC-LIST is invalid for specifier type TYPE.
*/
       (spec_list, type))
{
  struct specifier_methods *meths = decode_specifier_type (type, ERROR_ME);

  return check_valid_spec_list (spec_list, meths, ERROR_ME);
}

DEFUN ("valid-spec-list-p", Fvalid_spec_list_p, 2, 2, 0, /*
Return non-nil if SPEC-LIST is valid for specifier type TYPE.
*/
       (spec_list, type))
{
  struct specifier_methods *meths = decode_specifier_type (type, ERROR_ME);

  return check_valid_spec_list (spec_list, meths, ERROR_ME_NOT);
}

enum spec_add_meth
decode_how_to_add_specification (Lisp_Object how_to_add)
{
  if (NILP (how_to_add) || EQ (Qremove_tag_set_prepend, how_to_add))
    return SPEC_REMOVE_TAG_SET_PREPEND;
  if (EQ (Qremove_tag_set_append, how_to_add))
    return SPEC_REMOVE_TAG_SET_APPEND;
  if (EQ (Qappend, how_to_add))
    return SPEC_APPEND;
  if (EQ (Qprepend, how_to_add))
    return SPEC_PREPEND;
  if (EQ (Qremove_locale, how_to_add))
    return SPEC_REMOVE_LOCALE;
  if (EQ (Qremove_locale_type, how_to_add))
    return SPEC_REMOVE_LOCALE_TYPE;
  if (EQ (Qremove_all, how_to_add))
    return SPEC_REMOVE_ALL;

  signal_simple_error ("Invalid `how-to-add' flag", how_to_add);

  return SPEC_PREPEND;          /* not reached */
}

/* Given a specifier object SPEC, return bodily specifier if SPEC is a
   ghost specifier, otherwise return the object itself
*/
static Lisp_Object
bodily_specifier (Lisp_Object spec)
{
  return (GHOST_SPECIFIER_P (XSPECIFIER (spec))
          ? XSPECIFIER(spec)->magic_parent : spec);
}

/* Signal error if (specifier SPEC is read-only.
   Read only are ghost specifiers unless Vunlock_ghost_specifiers is
   non-nil.  All other specifiers are read-write.
*/
static void
check_modifiable_specifier (Lisp_Object spec)
{
  if (NILP (Vunlock_ghost_specifiers)
      && GHOST_SPECIFIER_P (XSPECIFIER (spec)))
    signal_simple_error ("Attempt to modify read-only specifier",
                         list1 (spec));
}

/* Helper function which unwind protects the value of
   Vunlock_ghost_specifiers, then sets it to non-nil value */
static Lisp_Object
restore_unlock_value (Lisp_Object val)
{
  Vunlock_ghost_specifiers = val;
  return val;
}

int
unlock_ghost_specifiers_protected (void)
{
  int depth = specpdl_depth ();
  record_unwind_protect (restore_unlock_value,
                         Vunlock_ghost_specifiers);
  Vunlock_ghost_specifiers = Qt;
  return depth;
}

/* This gets hit so much that the function call overhead had a
   measurable impact (according to Quantify).  #### We should figure
   out the frequency with which this is called with the various types
   and reorder the check accordingly. */
#define SPECIFIER_GET_SPEC_LIST(specifier, type)                        \
(type == LOCALE_GLOBAL ? &(XSPECIFIER (specifier)->global_specs)   :    \
 type == LOCALE_DEVICE ? &(XSPECIFIER (specifier)->device_specs)   :    \
 type == LOCALE_FRAME  ? &(XSPECIFIER (specifier)->frame_specs)    :    \
 type == LOCALE_WINDOW ? &(XWEAK_LIST_LIST                              \
                           (XSPECIFIER (specifier)->window_specs)) :    \
 type == LOCALE_BUFFER ? &(XSPECIFIER (specifier)->buffer_specs)   :    \
 0)

static Lisp_Object *
specifier_get_inst_list (Lisp_Object specifier, Lisp_Object locale,
                         enum spec_locale_type type)
{
  Lisp_Object *spec_list = SPECIFIER_GET_SPEC_LIST (specifier, type);
  Lisp_Object specification;

  if (type == LOCALE_GLOBAL)
    return spec_list;
  /* Calling assq_no_quit when it is just going to return nil anyhow
     is extremely expensive.  So sayeth Quantify. */
  if (!CONSP (*spec_list))
    return 0;
  specification = assq_no_quit (locale, *spec_list);
  if (NILP (specification))
    return 0;
  return &XCDR (specification);
}

/* For the given INST_LIST, return a new INST_LIST containing all elements
   where TAG-SET matches the element's tag set.  EXACT_P indicates whether
   the match must be exact (as opposed to a subset).  SHORT_P indicates
   that the short form (for `specifier-specs') should be returned if
   possible.  If COPY_TREE_P, `copy-tree' is used to ensure that no
   elements of the new list are shared with the initial list.
*/

static Lisp_Object
specifier_process_inst_list (Lisp_Object inst_list,
                             Lisp_Object tag_set, int exact_p,
                             int short_p, int copy_tree_p)
{
  Lisp_Object retval = Qnil;
  Lisp_Object rest;
  struct gcpro gcpro1;

  GCPRO1 (retval);
  LIST_LOOP (rest, inst_list)
    {
      Lisp_Object tagged_inst = XCAR (rest);
      Lisp_Object tagged_inst_tag = XCAR (tagged_inst);
      if (tag_sets_match_p (tag_set, tagged_inst_tag, exact_p))
        {
          if (short_p && NILP (tagged_inst_tag))
            retval = Fcons (copy_tree_p ?
                            Fcopy_tree (XCDR (tagged_inst), Qt) :
                            XCDR (tagged_inst),
                            retval);
          else
            retval = Fcons (copy_tree_p ? Fcopy_tree (tagged_inst, Qt) :
                            tagged_inst, retval);
        }
    }
  retval = Fnreverse (retval);
  UNGCPRO;
  /* If there is a single instantiator and the short form is
     requested, return just the instantiator (rather than a one-element
     list of it) unless it is nil (so that it can be distinguished from
     no instantiators at all). */
  if (short_p && CONSP (retval) && !NILP (XCAR (retval)) &&
      NILP (XCDR (retval)))
    return XCAR (retval);
  else
    return retval;
}

static Lisp_Object
specifier_get_external_inst_list (Lisp_Object specifier, Lisp_Object locale,
                                  enum spec_locale_type type,
                                  Lisp_Object tag_set, int exact_p,
                                  int short_p, int copy_tree_p)
{
  Lisp_Object *inst_list = specifier_get_inst_list (specifier, locale,
                                                    type);
  if (!inst_list || NILP (*inst_list))
    {
      /* nil for *inst_list should only occur in 'global */
      assert (!inst_list || EQ (locale, Qglobal));
      return Qnil;
    }

  return specifier_process_inst_list (*inst_list, tag_set, exact_p,
                                      short_p, copy_tree_p);
}

static Lisp_Object
specifier_get_external_spec_list (Lisp_Object specifier,
                                  enum spec_locale_type type,
                                  Lisp_Object tag_set, int exact_p)
{
  Lisp_Object *spec_list = SPECIFIER_GET_SPEC_LIST (specifier, type);
  Lisp_Object retval = Qnil;
  Lisp_Object rest;
  struct gcpro gcpro1;

  assert (type != LOCALE_GLOBAL);
  /* We're about to let stuff go external; make sure there aren't
     any dead objects */
  *spec_list = cleanup_assoc_list (*spec_list);

  GCPRO1 (retval);
  LIST_LOOP (rest, *spec_list)
    {
      Lisp_Object spec = XCAR (rest);
      Lisp_Object inst_list =
        specifier_process_inst_list (XCDR (spec), tag_set, exact_p, 0, 1);
      if (!NILP (inst_list))
        retval = Fcons (Fcons (XCAR (spec), inst_list), retval);
    }
  RETURN_UNGCPRO (Fnreverse (retval));
}

static Lisp_Object *
specifier_new_spec (Lisp_Object specifier, Lisp_Object locale,
                    enum spec_locale_type type)
{
  Lisp_Object *spec_list = SPECIFIER_GET_SPEC_LIST (specifier, type);
  Lisp_Object new_spec = Fcons (locale, Qnil);
  assert (type != LOCALE_GLOBAL);
  *spec_list = Fcons (new_spec, *spec_list);
  return &XCDR (new_spec);
}

/* For the given INST_LIST, return a new list comprised of elements
   where TAG_SET does not match the element's tag set.  This operation
   is destructive. */

static Lisp_Object
specifier_process_remove_inst_list (Lisp_Object inst_list,
                                    Lisp_Object tag_set, int exact_p,
                                    int *was_removed)
{
  Lisp_Object prev = Qnil, rest;

  *was_removed = 0;

  LIST_LOOP (rest, inst_list)
    {
      if (tag_sets_match_p (tag_set, XCAR (XCAR (rest)), exact_p))
        {
          /* time to remove. */
          *was_removed = 1;
          if (NILP (prev))
            inst_list = XCDR (rest);
          else
            XCDR (prev) = XCDR (rest);
        }
      else
        prev = rest;
    }

  return inst_list;
}

static void
specifier_remove_spec (Lisp_Object specifier, Lisp_Object locale,
                       enum spec_locale_type type,
                       Lisp_Object tag_set, int exact_p)
{
  Lisp_Object *spec_list = SPECIFIER_GET_SPEC_LIST (specifier, type);
  Lisp_Object assoc;
  int was_removed;

  if (type == LOCALE_GLOBAL)
    *spec_list = specifier_process_remove_inst_list (*spec_list, tag_set,
                                                     exact_p, &was_removed);
  else
    {
      assoc = assq_no_quit (locale, *spec_list);
      if (NILP (assoc))
        /* this locale is not found. */
        return;
      XCDR (assoc) = specifier_process_remove_inst_list (XCDR (assoc),
                                                         tag_set, exact_p,
                                                         &was_removed);
      if (NILP (XCDR (assoc)))
        /* no inst-pairs left; remove this locale entirely. */
        *spec_list = remassq_no_quit (locale, *spec_list);
    }

  if (was_removed)
    MAYBE_SPECMETH (XSPECIFIER (specifier), after_change,
                    (bodily_specifier (specifier), locale));
}

static void
specifier_remove_locale_type (Lisp_Object specifier,
                              enum spec_locale_type type,
                              Lisp_Object tag_set, int exact_p)
{
  Lisp_Object *spec_list = SPECIFIER_GET_SPEC_LIST (specifier, type);
  Lisp_Object prev = Qnil, rest;

  assert (type != LOCALE_GLOBAL);
  LIST_LOOP (rest, *spec_list)
    {
      int was_removed;
      int remove_spec = 0;
      Lisp_Object spec = XCAR (rest);

      /* There may be dead objects floating around */
      /* remember, dead windows can become alive again. */
      if (!WINDOWP (XCAR (spec)) && object_dead_p (XCAR (spec)))
        {
          remove_spec = 1;
          was_removed = 0;
        }
      else
        {
          XCDR (spec) = specifier_process_remove_inst_list (XCDR (spec),
                                                            tag_set, exact_p,
                                                            &was_removed);
          if (NILP (XCDR (spec)))
            remove_spec = 1;
        }

      if (remove_spec)
        {
          if (NILP (prev))
            *spec_list = XCDR (rest);
          else
            XCDR (prev) = XCDR (rest);
        }
      else
        prev = rest;

      if (was_removed)
        MAYBE_SPECMETH (XSPECIFIER (specifier), after_change,
                        (bodily_specifier (specifier), XCAR (spec)));
    }
}

/* NEW_LIST is going to be added to INST_LIST, with add method ADD_METH.
   Frob INST_LIST according to ADD_METH.  No need to call an after-change
   function; the calling function will do this.  Return either SPEC_PREPEND
   or SPEC_APPEND, indicating whether to prepend or append the NEW_LIST. */

static enum spec_add_meth
handle_multiple_add_insts (Lisp_Object *inst_list,
                           Lisp_Object new_list,
                           enum spec_add_meth add_meth)
{
  switch (add_meth)
    {
    case SPEC_REMOVE_TAG_SET_APPEND:
      add_meth = SPEC_APPEND;
      goto remove_tag_set;
    case SPEC_REMOVE_TAG_SET_PREPEND:
      add_meth = SPEC_PREPEND;
    remove_tag_set:
      {
        Lisp_Object rest;

        LIST_LOOP (rest, new_list)
          {
            Lisp_Object canontag = canonicalize_tag_set (XCAR (XCAR (rest)));
            struct gcpro gcpro1;

            GCPRO1 (canontag);
            /* pull out all elements from the existing list with the
               same tag as any tags in NEW_LIST. */
            *inst_list = remassoc_no_quit (canontag, *inst_list);
            UNGCPRO;
          }
      }
      return add_meth;
    case SPEC_REMOVE_LOCALE:
      *inst_list = Qnil;
      return SPEC_PREPEND;
    case SPEC_APPEND:
      return add_meth;
    default:
      return SPEC_PREPEND;
    }
}

/* Given a LOCALE and INST_LIST that is going to be added to SPECIFIER,
   copy, canonicalize, and call the going_to_add methods as necessary
   to produce a new list that is the one that really will be added
   to the specifier. */

static Lisp_Object
build_up_processed_list (Lisp_Object specifier, Lisp_Object locale,
                         Lisp_Object inst_list)
{
  /* The return value of this function must be GCPRO'd. */
  Lisp_Object rest, list_to_build_up = Qnil;
  struct Lisp_Specifier *sp = XSPECIFIER (specifier);
  struct gcpro gcpro1;

  GCPRO1 (list_to_build_up);
  LIST_LOOP (rest, inst_list)
    {
      Lisp_Object tag_set = XCAR (XCAR (rest));
      Lisp_Object instantiator = Fcopy_tree (XCDR (XCAR (rest)), Qt);
      Lisp_Object sub_inst_list = Qnil;
      struct gcpro ngcpro1, ngcpro2;

      NGCPRO2 (instantiator, sub_inst_list);
      /* call the will-add method; it may GC */
      sub_inst_list = HAS_SPECMETH_P (sp, going_to_add) ?
        SPECMETH (sp, going_to_add,
                  (bodily_specifier (specifier), locale,
                   tag_set, instantiator)) :
        Qt;
      if (EQ (sub_inst_list, Qt))
        /* no change here. */
        sub_inst_list = list1 (Fcons (canonicalize_tag_set (tag_set),
                                      instantiator));
      else
        {
          /* now canonicalize all the tag sets in the new objects */
          Lisp_Object rest2;
          LIST_LOOP (rest2, sub_inst_list)
            XCAR (XCAR (rest2)) = canonicalize_tag_set (XCAR (XCAR (rest2)));
        }

      list_to_build_up = nconc2 (sub_inst_list, list_to_build_up);
      NUNGCPRO;
    }

  RETURN_UNGCPRO (Fnreverse (list_to_build_up));
}

/* Add a specification (locale and instantiator list) to a specifier.
   ADD_METH specifies what to do with existing specifications in the
   specifier, and is an enum that corresponds to the values in
   `add-spec-to-specifier'.  The calling routine is responsible for
   validating LOCALE and INST-LIST, but the tag-sets in INST-LIST
   do not need to be canonicalized. */

  /* #### I really need to rethink the after-change
     functions to make them easier to use and more efficient. */

static void
specifier_add_spec (Lisp_Object specifier, Lisp_Object locale,
                    Lisp_Object inst_list, enum spec_add_meth add_meth)
{
  struct Lisp_Specifier *sp = XSPECIFIER (specifier);
  enum spec_locale_type type = locale_type_from_locale (locale);
  Lisp_Object *orig_inst_list, tem;
  Lisp_Object list_to_build_up = Qnil;
  struct gcpro gcpro1;

  GCPRO1 (list_to_build_up);
  list_to_build_up = build_up_processed_list (specifier, locale, inst_list);
  /* Now handle REMOVE_LOCALE_TYPE and REMOVE_ALL.  These are the
     add-meth types that affect locales other than this one. */
  if (add_meth == SPEC_REMOVE_LOCALE_TYPE)
    specifier_remove_locale_type (specifier, type, Qnil, 0);
  else if (add_meth == SPEC_REMOVE_ALL)
    {
      specifier_remove_locale_type (specifier, LOCALE_BUFFER, Qnil, 0);
      specifier_remove_locale_type (specifier, LOCALE_WINDOW, Qnil, 0);
      specifier_remove_locale_type (specifier, LOCALE_FRAME,  Qnil, 0);
      specifier_remove_locale_type (specifier, LOCALE_DEVICE, Qnil, 0);
      specifier_remove_spec (specifier, Qglobal, LOCALE_GLOBAL, Qnil, 0);
    }

  orig_inst_list = specifier_get_inst_list (specifier, locale, type);
  if (!orig_inst_list)
    orig_inst_list = specifier_new_spec (specifier, locale, type);
  add_meth = handle_multiple_add_insts (orig_inst_list, list_to_build_up,
                                        add_meth);

  if (add_meth == SPEC_PREPEND)
    tem = nconc2 (list_to_build_up, *orig_inst_list);
  else if (add_meth == SPEC_APPEND)
    tem = nconc2 (*orig_inst_list, list_to_build_up);
  else
    abort ();

  *orig_inst_list = tem;

  UNGCPRO;

  /* call the after-change method */
  MAYBE_SPECMETH (sp, after_change,
                  (bodily_specifier (specifier), locale));
}

static void
specifier_copy_spec (Lisp_Object specifier, Lisp_Object dest,
                     Lisp_Object locale, enum spec_locale_type type,
                     Lisp_Object tag_set, int exact_p,
                     enum spec_add_meth add_meth)
{
  Lisp_Object inst_list =
    specifier_get_external_inst_list (specifier, locale, type, tag_set,
                                      exact_p, 0, 0);
  specifier_add_spec (dest, locale, inst_list, add_meth);
}

static void
specifier_copy_locale_type (Lisp_Object specifier, Lisp_Object dest,
                            enum spec_locale_type type,
                            Lisp_Object tag_set, int exact_p,
                            enum spec_add_meth add_meth)
{
  Lisp_Object *src_list = SPECIFIER_GET_SPEC_LIST (specifier, type);
  Lisp_Object rest;

  /* This algorithm is O(n^2) in running time.
     It's certainly possible to implement an O(n log n) algorithm,
     but I doubt there's any need to. */

  LIST_LOOP (rest, *src_list)
    {
      Lisp_Object spec = XCAR (rest);
      /* There may be dead objects floating around */
      /* remember, dead windows can become alive again. */
      if (WINDOWP (XCAR (spec)) || !object_dead_p (XCAR (spec)))
        specifier_add_spec
          (dest, XCAR (spec),
           specifier_process_inst_list (XCDR (spec), tag_set, exact_p, 0, 0),
           add_meth);
    }
}

/* map MAPFUN over the locales in SPECIFIER that are given in LOCALE.
   CLOSURE is passed unchanged to MAPFUN.  LOCALE can be one of

     -- nil (same as 'all)
     -- a single locale, locale type, or 'all
     -- a list of locales, locale types, and/or 'all

   MAPFUN is called for each locale and locale type given; for 'all,
   it is called for the locale 'global and for the four possible
   locale types.  In each invocation, either LOCALE will be a locale
   and LOCALE_TYPE will be the locale type of this locale,
   or LOCALE will be nil and LOCALE_TYPE will be a locale type.
   If MAPFUN ever returns non-zero, the mapping is halted and the
   value returned is returned from map_specifier().  Otherwise, the
   mapping proceeds to the end and map_specifier() returns 0.
 */

static int
map_specifier (Lisp_Object specifier, Lisp_Object locale,
               int (*mapfun) (Lisp_Object specifier,
                              Lisp_Object locale,
                              enum spec_locale_type locale_type,
                              Lisp_Object tag_set,
                              int exact_p,
                              void *closure),
               Lisp_Object tag_set, Lisp_Object exact_p,
               void *closure)
{
  int retval = 0;
  Lisp_Object rest;
  struct gcpro gcpro1, gcpro2;

  GCPRO2 (tag_set, locale);
  locale = decode_locale_list (locale);
  tag_set = decode_specifier_tag_set (tag_set);
  tag_set = canonicalize_tag_set (tag_set);

  LIST_LOOP (rest, locale)
    {
      Lisp_Object theloc = XCAR (rest);
      if (!NILP (Fvalid_specifier_locale_p (theloc)))
        {
          retval = (*mapfun) (specifier, theloc,
                              locale_type_from_locale (theloc),
                              tag_set, !NILP (exact_p), closure);
          if (retval)
            break;
        }
      else if (!NILP (Fvalid_specifier_locale_type_p (theloc)))
        {
          retval = (*mapfun) (specifier, Qnil,
                              decode_locale_type (theloc), tag_set,
                              !NILP (exact_p), closure);
          if (retval)
            break;
        }
      else
        {
          assert (EQ (theloc, Qall));
          retval = (*mapfun) (specifier, Qnil, LOCALE_BUFFER, tag_set,
                              !NILP (exact_p), closure);
          if (retval)
            break;
          retval = (*mapfun) (specifier, Qnil, LOCALE_WINDOW, tag_set,
                              !NILP (exact_p), closure);
          if (retval)
            break;
          retval = (*mapfun) (specifier, Qnil, LOCALE_FRAME, tag_set,
                              !NILP (exact_p), closure);
          if (retval)
            break;
          retval = (*mapfun) (specifier, Qnil, LOCALE_DEVICE, tag_set,
                              !NILP (exact_p), closure);
          if (retval)
            break;
          retval = (*mapfun) (specifier, Qglobal, LOCALE_GLOBAL, tag_set,
                              !NILP (exact_p), closure);
          if (retval)
            break;
        }
    }

  UNGCPRO;
  return retval;
}

DEFUN ("add-spec-to-specifier", Fadd_spec_to_specifier, 2, 5, 0, /*
Add a specification to SPECIFIER.
The specification maps from LOCALE (which should be a window, buffer,
frame, device, or 'global, and defaults to 'global) to INSTANTIATOR,
whose allowed values depend on the type of the specifier.  Optional
argument TAG-SET limits the instantiator to apply only to the specified
tag set, which should be a list of tags all of which must match the
device being instantiated over (tags are a device type, a device class,
or tags defined with `define-specifier-tag').  Specifying a single
symbol for TAG-SET is equivalent to specifying a one-element list
containing that symbol.  Optional argument HOW-TO-ADD specifies what to
do if there are already specifications in the specifier.
It should be one of

  'prepend              Put at the beginning of the current list of
                        instantiators for LOCALE.
  'append               Add to the end of the current list of
                        instantiators for LOCALE.
  'remove-tag-set-prepend (this is the default)
                        Remove any existing instantiators whose tag set is
                        the same as TAG-SET; then put the new instantiator
                        at the beginning of the current list. ("Same tag
                        set" means that they contain the same elements.
                        The order may be different.)
  'remove-tag-set-append
                        Remove any existing instantiators whose tag set is
                        the same as TAG-SET; then put the new instantiator
                        at the end of the current list.
  'remove-locale        Remove all previous instantiators for this locale
                        before adding the new spec.
  'remove-locale-type   Remove all specifications for all locales of the
                        same type as LOCALE (this includes LOCALE itself)
                        before adding the new spec.
  'remove-all           Remove all specifications from the specifier
                        before adding the new spec.

You can retrieve the specifications for a particular locale or locale type
with the function `specifier-spec-list' or `specifier-specs'.
*/
       (specifier, instantiator, locale, tag_set, how_to_add))
{
  enum spec_add_meth add_meth;
  Lisp_Object inst_list;
  struct gcpro gcpro1;

  CHECK_SPECIFIER (specifier);
  check_modifiable_specifier (specifier);
  
  locale = decode_locale (locale);
  check_valid_instantiator (instantiator,
                            decode_specifier_type
                            (Fspecifier_type (specifier), ERROR_ME),
                            ERROR_ME);
  /* tag_set might be newly-created material, but it's part of inst_list
     so is properly GC-protected. */
  tag_set = decode_specifier_tag_set (tag_set);
  add_meth = decode_how_to_add_specification (how_to_add);

  inst_list = list1 (Fcons (tag_set, instantiator));
  GCPRO1 (inst_list);
  specifier_add_spec (specifier, locale, inst_list, add_meth);
  recompute_cached_specifier_everywhere (specifier);
  RETURN_UNGCPRO (Qnil);
}

DEFUN ("add-spec-list-to-specifier", Fadd_spec_list_to_specifier, 2, 3, 0, /*
Add a spec-list (a list of specifications) to SPECIFIER.
The format of a spec-list is

  ((LOCALE (TAG-SET . INSTANTIATOR) ...) ...)

where
  LOCALE := a window, a buffer, a frame, a device, or 'global
  TAG-SET := an unordered list of zero or more TAGS, each of which
             is a symbol
  TAG := a device class (see `valid-device-class-p'), a device type
         (see `valid-console-type-p'), or a tag defined with
         `define-specifier-tag'
  INSTANTIATOR := format determined by the type of specifier

The pair (TAG-SET . INSTANTIATOR) is called an `inst-pair'.
A list of inst-pairs is called an `inst-list'.
The pair (LOCALE . INST-LIST) is called a `specification' or `spec'.
A spec-list, then, can be viewed as a list of specifications.

HOW-TO-ADD specifies how to combine the new specifications with
the existing ones, and has the same semantics as for
`add-spec-to-specifier'.

In many circumstances, the higher-level function `set-specifier' is
more convenient and should be used instead.
*/
       (specifier, spec_list, how_to_add))
{
  enum spec_add_meth add_meth;
  Lisp_Object rest;

  CHECK_SPECIFIER (specifier);
  check_modifiable_specifier (specifier);

  check_valid_spec_list (spec_list,
                         decode_specifier_type
                         (Fspecifier_type (specifier), ERROR_ME),
                         ERROR_ME);
  add_meth = decode_how_to_add_specification (how_to_add);

  LIST_LOOP (rest, spec_list)
    {
      /* Placating the GCC god. */
      Lisp_Object specification = XCAR (rest);
      Lisp_Object locale    = XCAR (specification);
      Lisp_Object inst_list = XCDR (specification);

      specifier_add_spec (specifier, locale, inst_list, add_meth);
    }
  recompute_cached_specifier_everywhere (specifier);
  return Qnil;
}

void
add_spec_to_ghost_specifier (Lisp_Object specifier, Lisp_Object instantiator,
                             Lisp_Object locale, Lisp_Object tag_set,
                             Lisp_Object how_to_add)
{
  int depth = unlock_ghost_specifiers_protected ();
  Fadd_spec_to_specifier (XSPECIFIER(specifier)->fallback,
                          instantiator, locale, tag_set, how_to_add);
  unbind_to (depth, Qnil);
}

struct specifier_spec_list_closure
{
  Lisp_Object head, tail;
};

static int
specifier_spec_list_mapfun (Lisp_Object specifier,
                            Lisp_Object locale,
                            enum spec_locale_type locale_type,
                            Lisp_Object tag_set,
                            int exact_p,
                            void *closure)
{
  struct specifier_spec_list_closure *cl =
    (struct specifier_spec_list_closure *) closure;
  Lisp_Object partial;

  if (NILP (locale))
    partial = specifier_get_external_spec_list (specifier,
                                                locale_type,
                                                tag_set, exact_p);
  else
    {
      partial = specifier_get_external_inst_list (specifier, locale,
                                                  locale_type, tag_set,
                                                  exact_p, 0, 1);
      if (!NILP (partial))
        partial = list1 (Fcons (locale, partial));
    }
  if (NILP (partial))
    return 0;

  /* tack on the new list */
  if (NILP (cl->tail))
    cl->head = cl->tail = partial;
  else
    XCDR (cl->tail) = partial;
  /* find the new tail */
  while (CONSP (XCDR (cl->tail)))
    cl->tail = XCDR (cl->tail);
  return 0;
}

/* For the given SPECIFIER create and return a list of all specs
   contained within it, subject to LOCALE.  If LOCALE is a locale, only
   specs in that locale will be returned.  If LOCALE is a locale type,
   all specs in all locales of that type will be returned.  If LOCALE is
   nil, all specs will be returned.  This always copies lists and never
   returns the actual lists, because we do not want someone manipulating
   the actual objects.  This may cause a slight loss of potential
   functionality but if we were to allow it then a user could manage to
   violate our assertion that the specs contained in the actual
   specifier lists are all valid. */

DEFUN ("specifier-spec-list", Fspecifier_spec_list, 1, 4, 0, /*
Return the spec-list of specifications for SPECIFIER in LOCALE.

If LOCALE is a particular locale (a buffer, window, frame, device,
or 'global), a spec-list consisting of the specification for that
locale will be returned.

If LOCALE is a locale type (i.e. 'buffer, 'window, 'frame, or 'device),
a spec-list of the specifications for all locales of that type will be
returned.

If LOCALE is nil or 'all, a spec-list of all specifications in SPECIFIER
will be returned.

LOCALE can also be a list of locales, locale types, and/or 'all; the
result is as if `specifier-spec-list' were called on each element of the
list and the results concatenated together.

Only instantiators where TAG-SET (a list of zero or more tags) is a
subset of (or possibly equal to) the instantiator's tag set are returned.
\(The default value of nil is a subset of all tag sets, so in this case
no instantiators will be screened out.) If EXACT-P is non-nil, however,
TAG-SET must be equal to an instantiator's tag set for the instantiator
to be returned.
*/
     (specifier, locale, tag_set, exact_p))
{
  struct specifier_spec_list_closure cl;
  struct gcpro gcpro1, gcpro2;

  CHECK_SPECIFIER (specifier);
  cl.head = cl.tail = Qnil;
  GCPRO2 (cl.head, cl.tail);
  map_specifier (specifier, locale, specifier_spec_list_mapfun,
                 tag_set, exact_p, &cl);
  UNGCPRO;
  return cl.head;
}


DEFUN ("specifier-specs", Fspecifier_specs, 1, 4, 0, /*
Return the specification(s) for SPECIFIER in LOCALE.

If LOCALE is a single locale or is a list of one element containing a
single locale, then a "short form" of the instantiators for that locale
will be returned.  Otherwise, this function is identical to
`specifier-spec-list'.

The "short form" is designed for readability and not for ease of use
in Lisp programs, and is as follows:

1. If there is only one instantiator, then an inst-pair (i.e. cons of
   tag and instantiator) will be returned; otherwise a list of
   inst-pairs will be returned.
2. For each inst-pair returned, if the instantiator's tag is 'any,
   the tag will be removed and the instantiator itself will be returned
   instead of the inst-pair.
3. If there is only one instantiator, its value is nil, and its tag is
   'any, a one-element list containing nil will be returned rather
   than just nil, to distinguish this case from there being no
   instantiators at all.
*/
       (specifier, locale, tag_set, exact_p))
{
  if (!NILP (Fvalid_specifier_locale_p (locale)) ||
      (CONSP (locale) && !NILP (Fvalid_specifier_locale_p (XCAR (locale))) &&
       NILP (XCDR (locale))))
    {
      struct gcpro gcpro1;

      CHECK_SPECIFIER (specifier);
      if (CONSP (locale))
        locale = XCAR (locale);
      GCPRO1 (tag_set);
      tag_set = decode_specifier_tag_set (tag_set);
      tag_set = canonicalize_tag_set (tag_set);
      RETURN_UNGCPRO
        (specifier_get_external_inst_list (specifier, locale,
                                           locale_type_from_locale (locale),
                                           tag_set, !NILP (exact_p), 1, 1));
    }
  else
    return Fspecifier_spec_list (specifier, locale, tag_set, exact_p);
}

static int
remove_specifier_mapfun (Lisp_Object specifier,
                         Lisp_Object locale,
                         enum spec_locale_type locale_type,
                         Lisp_Object tag_set,
                         int exact_p,
                         void *ignored_closure)
{
  if (NILP (locale))
    specifier_remove_locale_type (specifier, locale_type, tag_set, exact_p);
  else
    specifier_remove_spec (specifier, locale, locale_type, tag_set, exact_p);
  return 0;
}

DEFUN ("remove-specifier", Fremove_specifier, 1, 4, 0, /*
Remove specification(s) for SPECIFIER.

If LOCALE is a particular locale (a window, buffer, frame, device,
or 'global), the specification for that locale will be removed.

If instead, LOCALE is a locale type (i.e. 'window, 'buffer, 'frame,
or 'device), the specifications for all locales of that type will be
removed.

If LOCALE is nil or 'all, all specifications will be removed.

LOCALE can also be a list of locales, locale types, and/or 'all; this
is equivalent to calling `remove-specifier' for each of the elements
in the list.

Only instantiators where TAG-SET (a list of zero or more tags) is a
subset of (or possibly equal to) the instantiator's tag set are removed.
The default value of nil is a subset of all tag sets, so in this case
no instantiators will be screened out. If EXACT-P is non-nil, however,
TAG-SET must be equal to an instantiator's tag set for the instantiator
to be removed.
*/
       (specifier, locale, tag_set, exact_p))
{
  CHECK_SPECIFIER (specifier);
  check_modifiable_specifier (specifier);

  map_specifier (specifier, locale, remove_specifier_mapfun,
                 tag_set, exact_p, 0);
  recompute_cached_specifier_everywhere (specifier);
  return Qnil;
}

void
remove_ghost_specifier (Lisp_Object specifier, Lisp_Object locale,
                        Lisp_Object tag_set, Lisp_Object exact_p)
{
  int depth = unlock_ghost_specifiers_protected ();
  Fremove_specifier (XSPECIFIER(specifier)->fallback,
                     locale, tag_set, exact_p);
  unbind_to (depth, Qnil);
}

struct copy_specifier_closure
{
  Lisp_Object dest;
  enum spec_add_meth add_meth;
  int add_meth_is_nil;
};

static int
copy_specifier_mapfun (Lisp_Object specifier,
                       Lisp_Object locale,
                       enum spec_locale_type locale_type,
                       Lisp_Object tag_set,
                       int exact_p,
                       void *closure)
{
  struct copy_specifier_closure *cl =
    (struct copy_specifier_closure *) closure;

  if (NILP (locale))
    specifier_copy_locale_type (specifier, cl->dest, locale_type,
                                tag_set, exact_p,
                                cl->add_meth_is_nil ?
                                SPEC_REMOVE_LOCALE_TYPE :
                                cl->add_meth);
  else
    specifier_copy_spec (specifier, cl->dest, locale, locale_type,
                         tag_set, exact_p,
                         cl->add_meth_is_nil ? SPEC_REMOVE_LOCALE :
                         cl->add_meth);
  return 0;
}

DEFUN ("copy-specifier", Fcopy_specifier, 1, 6, 0, /*
Copy SPECIFIER to DEST, or create a new one if DEST is nil.

If DEST is nil or omitted, a new specifier will be created and the
specifications copied into it.  Otherwise, the specifications will be
copied into the existing specifier in DEST.

If LOCALE is nil or 'all, all specifications will be copied.  If LOCALE
is a particular locale, the specification for that particular locale will
be copied.  If LOCALE is a locale type, the specifications for all locales
of that type will be copied.  LOCALE can also be a list of locales,
locale types, and/or 'all; this is equivalent to calling `copy-specifier'
for each of the elements of the list.  See `specifier-spec-list' for more
information about LOCALE.

Only instantiators where TAG-SET (a list of zero or more tags) is a
subset of (or possibly equal to) the instantiator's tag set are copied.
The default value of nil is a subset of all tag sets, so in this case
no instantiators will be screened out. If EXACT-P is non-nil, however,
TAG-SET must be equal to an instantiator's tag set for the instantiator
to be copied.

Optional argument HOW-TO-ADD specifies what to do with existing
specifications in DEST.  If nil, then whichever locales or locale types
are copied will first be completely erased in DEST.  Otherwise, it is
the same as in `add-spec-to-specifier'.
*/
       (specifier, dest, locale, tag_set, exact_p, how_to_add))
{
  struct gcpro gcpro1;
  struct copy_specifier_closure cl;

  CHECK_SPECIFIER (specifier);
  if (NILP (how_to_add))
    cl.add_meth_is_nil = 1;
  else
    cl.add_meth_is_nil = 0;
  cl.add_meth = decode_how_to_add_specification (how_to_add);
  if (NILP (dest))
    {
      /* #### What about copying the extra data? */
      dest = make_specifier (XSPECIFIER (specifier)->methods);
    }
  else
    {
      CHECK_SPECIFIER (dest);
      check_modifiable_specifier (dest);
      if (XSPECIFIER (dest)->methods != XSPECIFIER (specifier)->methods)
        error ("Specifiers not of same type");
    }

  cl.dest = dest;
  GCPRO1 (dest);
  map_specifier (specifier, locale, copy_specifier_mapfun,
                 tag_set, exact_p, &cl);
  UNGCPRO;
  recompute_cached_specifier_everywhere (dest);
  return dest;
}

\f
/************************************************************************/
/*                              Instancing                              */
/************************************************************************/

static Lisp_Object
call_validate_matchspec_method (Lisp_Object boxed_method,
                                Lisp_Object matchspec)
{
  ((void (*)(Lisp_Object)) get_opaque_ptr (boxed_method)) (matchspec);
  return Qt;
}

static Lisp_Object
check_valid_specifier_matchspec (Lisp_Object matchspec,
                                 struct specifier_methods *meths,
                                 Error_behavior errb)
{
  if (meths->validate_matchspec_method)
    {
      Lisp_Object retval;

      if (ERRB_EQ (errb, ERROR_ME))
        {
          (meths->validate_matchspec_method) (matchspec);
          retval = Qt;
        }
      else
        {
          Lisp_Object opaque =
            make_opaque_ptr ((void *) meths->validate_matchspec_method);
          struct gcpro gcpro1;

          GCPRO1 (opaque);
          retval = call_with_suspended_errors
            ((lisp_fn_t) call_validate_matchspec_method,
             Qnil, Qspecifier, errb, 2, opaque, matchspec);

          free_opaque_ptr (opaque);
          UNGCPRO;
        }

      return retval;
    }
  else
    {
      maybe_signal_simple_error
        ("Matchspecs not allowed for this specifier type",
         intern (meths->name), Qspecifier, errb);
      return Qnil;
    }
}

DEFUN ("check-valid-specifier-matchspec", Fcheck_valid_specifier_matchspec, 2, 2, 0, /*
Signal an error if MATCHSPEC is invalid for SPECIFIER-TYPE.
See `specifier-matching-instance' for a description of matchspecs.
*/
       (matchspec, specifier_type))
{
  struct specifier_methods *meths = decode_specifier_type (specifier_type,
                                                           ERROR_ME);

  return check_valid_specifier_matchspec (matchspec, meths, ERROR_ME);
}

DEFUN ("valid-specifier-matchspec-p", Fvalid_specifier_matchspec_p, 2, 2, 0, /*
Return non-nil if MATCHSPEC is valid for SPECIFIER-TYPE.
See `specifier-matching-instance' for a description of matchspecs.
*/
       (matchspec, specifier_type))
{
  struct specifier_methods *meths = decode_specifier_type (specifier_type,
                                                           ERROR_ME);

  return check_valid_specifier_matchspec (matchspec, meths, ERROR_ME_NOT);
}

/* This function is purposely not callable from Lisp.  If a Lisp
   caller wants to set a fallback, they should just set the
   global value. */

void
set_specifier_fallback (Lisp_Object specifier, Lisp_Object fallback)
{
  struct Lisp_Specifier *sp = XSPECIFIER (specifier);
  assert (SPECIFIERP (fallback) ||
          !NILP (Fvalid_inst_list_p (fallback, Fspecifier_type (specifier))));
  if (SPECIFIERP (fallback))
    assert (EQ (Fspecifier_type (specifier), Fspecifier_type (fallback)));
  if (BODILY_SPECIFIER_P (sp))
    GHOST_SPECIFIER(sp)->fallback = fallback;
  else
    sp->fallback = fallback;
  /* call the after-change method */
  MAYBE_SPECMETH (sp, after_change,
                  (bodily_specifier (specifier), Qfallback));
  recompute_cached_specifier_everywhere (specifier);
}

DEFUN ("specifier-fallback", Fspecifier_fallback, 1, 1, 0, /*
Return the fallback value for SPECIFIER.
Fallback values are provided by the C code for certain built-in
specifiers to make sure that instancing won't fail even if all
specs are removed from the specifier, or to implement simple
inheritance behavior (e.g. this method is used to ensure that
faces other than 'default inherit their attributes from 'default).
By design, you cannot change the fallback value, and specifiers
created with `make-specifier' will never have a fallback (although
a similar, Lisp-accessible capability may be provided in the future
to allow for inheritance).

The fallback value will be an inst-list that is instanced like
any other inst-list, a specifier of the same type as SPECIFIER
\(results in inheritance), or nil for no fallback.

When you instance a specifier, you can explicitly request that the
fallback not be consulted. (The C code does this, for example, when
merging faces.) See `specifier-instance'.
*/
       (specifier))
{
  CHECK_SPECIFIER (specifier);
  return Fcopy_tree (XSPECIFIER (specifier)->fallback, Qt);
}

static Lisp_Object
specifier_instance_from_inst_list (Lisp_Object specifier,
                                   Lisp_Object matchspec,
                                   Lisp_Object domain,
                                   Lisp_Object inst_list,
                                   Error_behavior errb, int no_quit,
                                   Lisp_Object depth)
{
  /* This function can GC */
  struct Lisp_Specifier *sp;
  Lisp_Object device;
  Lisp_Object rest;
  int count = specpdl_depth ();
  struct gcpro gcpro1, gcpro2;

  GCPRO2 (specifier, inst_list);

  sp = XSPECIFIER (specifier);
  device = DFW_DEVICE (domain);

  if (no_quit)
  /* The instantiate method is allowed to call eval.  Since it
     is quite common for this function to get called from somewhere in
     redisplay we need to make sure that quits are ignored.  Otherwise
     Fsignal will abort. */
    specbind (Qinhibit_quit, Qt);

  LIST_LOOP (rest, inst_list)
    {
      Lisp_Object tagged_inst = XCAR (rest);
      Lisp_Object tag_set = XCAR (tagged_inst);

      if (device_matches_specifier_tag_set_p (device, tag_set))
        {
          Lisp_Object val = XCDR (tagged_inst);

          if (HAS_SPECMETH_P (sp, instantiate))
            val = call_with_suspended_errors
              ((lisp_fn_t) RAW_SPECMETH (sp, instantiate),
               Qunbound, Qspecifier, errb, 5, specifier,
               matchspec, domain, val, depth);

          if (!UNBOUNDP (val))
            {
              unbind_to (count, Qnil);
              UNGCPRO;
              return val;
            }
        }
    }

  unbind_to (count, Qnil);
  UNGCPRO;
  return Qunbound;
}

/* Given a SPECIFIER and a DOMAIN, return a specific instance for that
   specifier. Try to find one by checking the specifier types from most
   specific (buffer) to most general (global).  If we find an instance,
   return it.  Otherwise return Qunbound. */

#define CHECK_INSTANCE_ENTRY(key, matchspec, type)                      \
do {                                                                    \
  Lisp_Object *__inst_list =                                            \
    specifier_get_inst_list (specifier, key, type);                     \
  if (__inst_list)                                                      \
    {                                                                   \
      Lisp_Object __val__ =                                             \
        specifier_instance_from_inst_list (specifier, matchspec,        \
                                           domain, *__inst_list,        \
                                           errb, no_quit, depth);       \
      if (!UNBOUNDP (__val__))                                          \
        return __val__;                                                 \
    }                                                                   \
} while (0)

/* We accept any window, frame or device domain and do our checking
   starting from as specific a locale type as we can determine from the
   domain we are passed and going on up through as many other locale types
   as we can determine.  In practice, when called from redisplay the
   arg will usually be a window and occasionally a frame.  If
   triggered by a user call, who knows what it will usually be. */
Lisp_Object
specifier_instance (Lisp_Object specifier, Lisp_Object matchspec,
                    Lisp_Object domain, Error_behavior errb, int no_quit,
                    int no_fallback, Lisp_Object depth)
{
  Lisp_Object buffer = Qnil;
  Lisp_Object window = Qnil;
  Lisp_Object frame = Qnil;
  Lisp_Object device = Qnil;
  Lisp_Object tag = Qnil;
  struct device *d;
  struct Lisp_Specifier *sp;

  sp = XSPECIFIER (specifier);

  /* Attempt to determine buffer, window, frame, and device from the
     domain. */
  if (WINDOWP (domain))
    window = domain;
  else if (FRAMEP (domain))
    frame = domain;
  else if (DEVICEP (domain))
    device = domain;
  else
    /* #### dmoore - dammit, this should just signal an error or something
       shouldn't it?
       #### No. Errors are handled in Lisp primitives implementation.
       Invalid domain is a design error here - kkm. */
    abort ();

  if (NILP (buffer) && !NILP (window))
    buffer = XWINDOW (window)->buffer;
  if (NILP (frame) && !NILP (window))
    frame = XWINDOW (window)->frame;
  if (NILP (device))
    /* frame had better exist; if device is undeterminable, something
       really went wrong. */
    device = XFRAME (frame)->device;

  /* device had better be determined by now; abort if not. */
  d = XDEVICE (device);
  tag = DEVICE_CLASS (d);

  depth = make_int (1 + XINT (depth));
  if (XINT (depth) > 20)
    {
      maybe_error (Qspecifier, errb, "Apparent loop in specifier inheritance");
      /* The specification is fucked; at least try the fallback
         (which better not be fucked, because it's not changeable
         from Lisp). */
      depth = Qzero;
      goto do_fallback;
    }

try_again:
  /* First see if we can generate one from the window specifiers. */
  if (!NILP (window))
    CHECK_INSTANCE_ENTRY (window, matchspec, LOCALE_WINDOW);

  /* Next see if we can generate one from the buffer specifiers. */
  if (!NILP (buffer))
    CHECK_INSTANCE_ENTRY (buffer, matchspec, LOCALE_BUFFER);

  /* Next see if we can generate one from the frame specifiers. */
  if (!NILP (frame))
    CHECK_INSTANCE_ENTRY (frame, matchspec, LOCALE_FRAME);

  /* If we still haven't succeeded try with the device specifiers. */
  CHECK_INSTANCE_ENTRY (device, matchspec, LOCALE_DEVICE);

  /* Last and least try the global specifiers. */
  CHECK_INSTANCE_ENTRY (Qglobal, matchspec, LOCALE_GLOBAL);

do_fallback:
  /* We're out of specifiers and we still haven't generated an
     instance.  At least try the fallback ...  If this fails,
     then we just return Qunbound. */

  if (no_fallback || NILP (sp->fallback))
    /* I said, I don't want the fallbacks. */
    return Qunbound;

  if (SPECIFIERP (sp->fallback))
    {
      /* If you introduced loops in the default specifier chain,
         then you're fucked, so you better not do this. */
      specifier = sp->fallback;
      sp = XSPECIFIER (specifier);
      goto try_again;
    }

  assert (CONSP (sp->fallback));
  return specifier_instance_from_inst_list (specifier, matchspec, domain,
                                            sp->fallback, errb, no_quit,
                                            depth);
}
#undef CHECK_INSTANCE_ENTRY

Lisp_Object
specifier_instance_no_quit (Lisp_Object specifier, Lisp_Object matchspec,
                            Lisp_Object domain, Error_behavior errb,
                            int no_fallback, Lisp_Object depth)
{
  return specifier_instance (specifier, matchspec, domain, errb,
                             1, no_fallback, depth);
}

DEFUN ("specifier-instance", Fspecifier_instance, 1, 4, 0, /*
Instantiate SPECIFIER (return its value) in DOMAIN.
If no instance can be generated for this domain, return DEFAULT.

DOMAIN should be a window, frame, or device.  Other values that are legal
as a locale (e.g. a buffer) are not valid as a domain because they do not
provide enough information to identify a particular device (see
`valid-specifier-domain-p').  DOMAIN defaults to the selected window
if omitted.

"Instantiating" a specifier in a particular domain means determining
the specifier's "value" in that domain.  This is accomplished by
searching through the specifications in the specifier that correspond
to all locales that can be derived from the given domain, from specific
to general.  In most cases, the domain is an Emacs window.  In that case
specifications are searched for as follows:

1. A specification whose locale is the window itself;
2. A specification whose locale is the window's buffer;
3. A specification whose locale is the window's frame;
4. A specification whose locale is the window's frame's device;
5. A specification whose locale is 'global.

If all of those fail, then the C-code-provided fallback value for
this specifier is consulted (see `specifier-fallback').  If it is
an inst-list, then this function attempts to instantiate that list
just as when a specification is located in the first five steps above.
If the fallback is a specifier, `specifier-instance' is called
recursively on this specifier and the return value used.  Note,
however, that if the optional argument NO-FALLBACK is non-nil,
the fallback value will not be consulted.

Note that there may be more than one specification matching a particular
locale; all such specifications are considered before looking for any
specifications for more general locales.  Any particular specification
that is found may be rejected because its tag set does not match the
device being instantiated over, or because the specification is not
valid for the device of the given domain (e.g. the font or color name
does not exist for this particular X server).

The returned value is dependent on the type of specifier.  For example,
for a font specifier (as returned by the `face-font' function), the returned
value will be a font-instance object.  For glyphs, the returned value
will be a string, pixmap, or subwindow.

See also `specifier-matching-instance'.
*/
       (specifier, domain, default_, no_fallback))
{
  Lisp_Object instance;

  CHECK_SPECIFIER (specifier);
  domain = decode_domain (domain);

  instance = specifier_instance (specifier, Qunbound, domain, ERROR_ME, 0,
                                 !NILP (no_fallback), Qzero);
  return UNBOUNDP (instance) ? default_ : instance;
}

DEFUN ("specifier-matching-instance", Fspecifier_matching_instance, 2, 5, 0, /*
Return an instance for SPECIFIER in DOMAIN that matches MATCHSPEC.
If no instance can be generated for this domain, return DEFAULT.

This function is identical to `specifier-instance' except that a
specification will only be considered if it matches MATCHSPEC.
The definition of "match", and allowed values for MATCHSPEC, are
dependent on the particular type of specifier.  Here are some examples:

-- For chartable (e.g. display table) specifiers, MATCHSPEC should be a
   character, and the specification (a chartable) must give a value for
   that character in order to be considered.  This allows you to specify,
   e.g., a buffer-local display table that only gives values for particular
   characters.  All other characters are handled as if the buffer-local
   display table is not there. (Chartable specifiers are not yet
   implemented.)

-- For font specifiers, MATCHSPEC should be a charset, and the specification
   (a font string) must have a registry that matches the charset's registry.
   (This only makes sense with Mule support.) This makes it easy to choose a
   font that can display a particular character. (This is what redisplay
   does, in fact.)
*/
       (specifier, matchspec, domain, default_, no_fallback))
{
  Lisp_Object instance;

  CHECK_SPECIFIER (specifier);
  check_valid_specifier_matchspec (matchspec, XSPECIFIER (specifier)->methods,
                                   ERROR_ME);
  domain = decode_domain (domain);

  instance = specifier_instance (specifier, matchspec, domain, ERROR_ME,
                                 0, !NILP (no_fallback), Qzero);
  return UNBOUNDP (instance) ? default_ : instance;
}

DEFUN ("specifier-instance-from-inst-list", Fspecifier_instance_from_inst_list,
       3, 4, 0, /*
Attempt to convert a particular inst-list into an instance.
This attempts to instantiate INST-LIST in the given DOMAIN,
as if INST-LIST existed in a specification in SPECIFIER.  If
the instantiation fails, DEFAULT is returned.  In most circumstances,
you should not use this function; use `specifier-instance' instead.
*/
       (specifier, domain, inst_list, default_))
{
  Lisp_Object val = Qunbound;
  struct Lisp_Specifier *sp = XSPECIFIER (specifier);
  struct gcpro gcpro1;
  Lisp_Object built_up_list = Qnil;

  CHECK_SPECIFIER (specifier);
  check_valid_domain (domain);
  check_valid_inst_list (inst_list, sp->methods, ERROR_ME);
  GCPRO1 (built_up_list);
  built_up_list = build_up_processed_list (specifier, domain, inst_list);
  if (!NILP (built_up_list))
    val = specifier_instance_from_inst_list (specifier, Qunbound, domain,
                                             built_up_list, ERROR_ME,
                                             0, Qzero);
  UNGCPRO;
  return UNBOUNDP (val) ? default_ : val;
}

DEFUN ("specifier-matching-instance-from-inst-list", Fspecifier_matching_instance_from_inst_list,
       4, 5, 0, /*
Attempt to convert a particular inst-list into an instance.
This attempts to instantiate INST-LIST in the given DOMAIN
\(as if INST-LIST existed in a specification in SPECIFIER),
matching the specifications against MATCHSPEC.

This function is analogous to `specifier-instance-from-inst-list'
but allows for specification-matching as in `specifier-matching-instance'.
See that function for a description of exactly how the matching process
works.
*/
       (specifier, matchspec, domain, inst_list, default_))
{
  Lisp_Object val = Qunbound;
  struct Lisp_Specifier *sp = XSPECIFIER (specifier);
  struct gcpro gcpro1;
  Lisp_Object built_up_list = Qnil;

  CHECK_SPECIFIER (specifier);
  check_valid_specifier_matchspec (matchspec, XSPECIFIER (specifier)->methods,
                                   ERROR_ME);
  check_valid_domain (domain);
  check_valid_inst_list (inst_list, sp->methods, ERROR_ME);
  GCPRO1 (built_up_list);
  built_up_list = build_up_processed_list (specifier, domain, inst_list);
  if (!NILP (built_up_list))
    val = specifier_instance_from_inst_list (specifier, matchspec, domain,
                                             built_up_list, ERROR_ME,
                                             0, Qzero);
  UNGCPRO;
  return UNBOUNDP (val) ? default_ : val;
}

\f
/************************************************************************/
/*                 Caching in the struct window or frame                */
/************************************************************************/

/* Either STRUCT_WINDOW_OFFSET or STRUCT_FRAME_OFFSET can be 0 to indicate
   no caching in that sort of object. */

/* #### It would be nice if the specifier caching automatically knew
   about specifier fallbacks, so we didn't have to do it ourselves. */

void
set_specifier_caching (Lisp_Object specifier, int struct_window_offset,
                       void (*value_changed_in_window)
                       (Lisp_Object specifier, struct window *w,
                        Lisp_Object oldval),
                       int struct_frame_offset,
                       void (*value_changed_in_frame)
                       (Lisp_Object specifier, struct frame *f,
                        Lisp_Object oldval))
{
  struct Lisp_Specifier *sp = XSPECIFIER (specifier);
  assert (!GHOST_SPECIFIER_P (sp));

  if (!sp->caching)
    sp->caching = xnew_and_zero (struct specifier_caching);
  sp->caching->offset_into_struct_window = struct_window_offset;
  sp->caching->value_changed_in_window = value_changed_in_window;
  sp->caching->offset_into_struct_frame = struct_frame_offset;
  sp->caching->value_changed_in_frame = value_changed_in_frame;
  Vcached_specifiers = Fcons (specifier, Vcached_specifiers);
  if (BODILY_SPECIFIER_P (sp))
    GHOST_SPECIFIER(sp)->caching = sp->caching;
  recompute_cached_specifier_everywhere (specifier);
}

static void
recompute_one_cached_specifier_in_window (Lisp_Object specifier,
                                          struct window *w)
{
  Lisp_Object window;
  Lisp_Object newval, *location;

  assert (!GHOST_SPECIFIER_P (XSPECIFIER (specifier)));

  XSETWINDOW (window, w);

  newval = specifier_instance (specifier, Qunbound, window, ERROR_ME_WARN,
                               0, 0, Qzero);
  /* If newval ended up Qunbound, then the calling functions
     better be able to deal.  If not, set a default so this
     never happens or correct it in the value_changed_in_window
     method. */
  location = (Lisp_Object *)
    ((char *) w + XSPECIFIER (specifier)->caching->offset_into_struct_window);
  if (!EQ (newval, *location))
    {
      Lisp_Object oldval = *location;
      *location = newval;
      (XSPECIFIER (specifier)->caching->value_changed_in_window)
        (specifier, w, oldval);
    }
}

static void
recompute_one_cached_specifier_in_frame (Lisp_Object specifier,
                                         struct frame *f)
{
  Lisp_Object frame;
  Lisp_Object newval, *location;

  assert (!GHOST_SPECIFIER_P (XSPECIFIER (specifier)));

  XSETFRAME (frame, f);

  newval = specifier_instance (specifier, Qunbound, frame, ERROR_ME_WARN,
                               0, 0, Qzero);
  /* If newval ended up Qunbound, then the calling functions
     better be able to deal.  If not, set a default so this
     never happens or correct it in the value_changed_in_frame
     method. */
  location = (Lisp_Object *)
    ((char *) f + XSPECIFIER (specifier)->caching->offset_into_struct_frame);
  if (!EQ (newval, *location))
    {
      Lisp_Object oldval = *location;
      *location = newval;
      (XSPECIFIER (specifier)->caching->value_changed_in_frame)
        (specifier, f, oldval);
    }
}

void
recompute_all_cached_specifiers_in_window (struct window *w)
{
  Lisp_Object rest;

  LIST_LOOP (rest, Vcached_specifiers)
    {
      Lisp_Object specifier = XCAR (rest);
      if (XSPECIFIER (specifier)->caching->offset_into_struct_window)
        recompute_one_cached_specifier_in_window (specifier, w);
    }
}

void
recompute_all_cached_specifiers_in_frame (struct frame *f)
{
  Lisp_Object rest;

  LIST_LOOP (rest, Vcached_specifiers)
    {
      Lisp_Object specifier = XCAR (rest);
      if (XSPECIFIER (specifier)->caching->offset_into_struct_frame)
        recompute_one_cached_specifier_in_frame (specifier, f);
    }
}

static int
recompute_cached_specifier_everywhere_mapfun (struct window *w,
                                              void *closure)
{
  Lisp_Object specifier = Qnil;

  VOID_TO_LISP (specifier, closure);
  recompute_one_cached_specifier_in_window (specifier, w);
  return 0;
}

static void
recompute_cached_specifier_everywhere (Lisp_Object specifier)
{
  Lisp_Object frmcons, devcons, concons;

  specifier = bodily_specifier (specifier);

  if (!XSPECIFIER (specifier)->caching)
    return;

  if (XSPECIFIER (specifier)->caching->offset_into_struct_window)
    {
      FRAME_LOOP_NO_BREAK (frmcons, devcons, concons)
        map_windows (XFRAME (XCAR (frmcons)),
                     recompute_cached_specifier_everywhere_mapfun,
                     LISP_TO_VOID (specifier));
    }

  if (XSPECIFIER (specifier)->caching->offset_into_struct_frame)
    {
      FRAME_LOOP_NO_BREAK (frmcons, devcons, concons)
        recompute_one_cached_specifier_in_frame (specifier,
                                                 XFRAME (XCAR (frmcons)));
    }
}

DEFUN ("set-specifier-dirty-flag", Fset_specifier_dirty_flag, 1, 1, 0, /*
Force recomputation of any caches associated with SPECIFIER.
Note that this automatically happens whenever you change a specification
 in SPECIFIER; you do not have to call this function then.
One example of where this function is useful is when you have a
 toolbar button whose `active-p' field is an expression to be
 evaluated.  Calling `set-specifier-dirty-flag' on the
 toolbar specifier will force the `active-p' fields to be
 recomputed.
*/
       (specifier))
{
  CHECK_SPECIFIER (specifier);
  recompute_cached_specifier_everywhere (specifier);
  return Qnil;
}

\f
/************************************************************************/
/*                        Generic specifier type                        */
/************************************************************************/

DEFINE_SPECIFIER_TYPE (generic);

#if 0

/* This is the string that used to be in `generic-specifier-p'.
   The idea is good, but it doesn't quite work in the form it's
   in. (One major problem is that validating an instantiator
   is supposed to require only that the specifier type is passed,
   while with this approach the actual specifier is needed.)

   What really needs to be done is to write a function
   `make-specifier-type' that creates new specifier types.
   #### I'll look into this for 19.14.
 */

"A generic specifier is a generalized kind of specifier with user-defined\n"
"semantics.  The instantiator can be any kind of Lisp object, and the\n"
"instance computed from it is likewise any kind of Lisp object.  The\n"
"SPECIFIER-DATA should be an alist of methods governing how the specifier\n"
"works.  All methods are optional, and reasonable default methods will be\n"
"provided.  Currently there are two defined methods: 'instantiate and\n"
"'validate.\n"
"\n"
"'instantiate specifies how to do the instantiation; if omitted, the\n"
"instantiator itself is simply returned as the instance.  The method\n"
"should be a function that accepts three parameters (a specifier, the\n"
"instantiator that matched the domain being instantiated over, and that\n"
"domain), and should return a one-element list containing the instance,\n"
"or nil if no instance exists.  Note that the domain passed to this function\n"
"is the domain being instantiated over, which may not be the same as the\n"
"locale contained in the specification corresponding to the instantiator\n"
"(for example, the domain being instantiated over could be a window, but\n"
"the locale corresponding to the passed instantiator could be the window's\n"
"buffer or frame).\n"
"\n"
"'validate specifies whether a given instantiator is valid; if omitted,\n"
"all instantiators are considered valid.  It should be a function of\n"
"two arguments: an instantiator and a flag CAN-SIGNAL-ERROR.  If this\n"
"flag is false, the function must simply return t or nil indicating\n"
"whether the instantiator is valid.  If this flag is true, the function\n"
"is free to signal an error if it encounters an invalid instantiator\n"
"(this can be useful for issuing a specific error about exactly why the\n"
"instantiator is valid).  It can also return nil to indicate an invalid\n"
"instantiator; in this case, a general error will be signalled."

#endif /* 0 */

DEFUN ("generic-specifier-p", Fgeneric_specifier_p, 1, 1, 0, /*
Return non-nil if OBJECT is a generic specifier.

A generic specifier allows any kind of Lisp object as an instantiator,
and returns back the Lisp object unchanged when it is instantiated.
*/
       (object))
{
  return GENERIC_SPECIFIERP (object) ? Qt : Qnil;
}


/************************************************************************/
/*                        Integer specifier type                        */
/************************************************************************/

DEFINE_SPECIFIER_TYPE (integer);

static void
integer_validate (Lisp_Object instantiator)
{
  CHECK_INT (instantiator);
}

DEFUN ("integer-specifier-p", Finteger_specifier_p, 1, 1, 0, /*
Return non-nil if OBJECT is an integer specifier.
*/
       (object))
{
  return INTEGER_SPECIFIERP (object) ? Qt : Qnil;
}

/************************************************************************/
/*                   Non-negative-integer specifier type                */
/************************************************************************/

DEFINE_SPECIFIER_TYPE (natnum);

static void
natnum_validate (Lisp_Object instantiator)
{
  CHECK_NATNUM (instantiator);
}

DEFUN ("natnum-specifier-p", Fnatnum_specifier_p, 1, 1, 0, /*
Return non-nil if OBJECT is a natnum (non-negative-integer) specifier.
*/
       (object))
{
  return NATNUM_SPECIFIERP (object) ? Qt : Qnil;
}

/************************************************************************/
/*                        Boolean specifier type                        */
/************************************************************************/

DEFINE_SPECIFIER_TYPE (boolean);

static void
boolean_validate (Lisp_Object instantiator)
{
  if (!EQ (instantiator, Qt) && !EQ (instantiator, Qnil))
    signal_simple_error ("Must be t or nil", instantiator);
}

DEFUN ("boolean-specifier-p", Fboolean_specifier_p, 1, 1, 0, /*
Return non-nil if OBJECT is a boolean specifier.
*/
       (object))
{
  return BOOLEAN_SPECIFIERP (object) ? Qt : Qnil;
}

/************************************************************************/
/*                        Display table specifier type                  */
/************************************************************************/

DEFINE_SPECIFIER_TYPE (display_table);

static void
display_table_validate (Lisp_Object instantiator)
{
  if (!NILP(instantiator) &&
      (!VECTORP (instantiator) ||
       XVECTOR_LENGTH (instantiator) != DISP_TABLE_SIZE))
    dead_wrong_type_argument (display_table_specifier_methods->predicate_symbol,
                              instantiator);
}

DEFUN ("display-table-specifier-p", Fdisplay_table_specifier_p, 1, 1, 0, /*
Return non-nil if OBJECT is a display-table specifier.
*/
       (object))
{
  return DISPLAYTABLE_SPECIFIERP (object) ? Qt : Qnil;
}

\f
/************************************************************************/
/*                           Initialization                             */
/************************************************************************/

void
syms_of_specifier (void)
{
  defsymbol (&Qspecifierp, "specifierp");

  defsymbol (&Qconsole_type, "console-type");
  defsymbol (&Qdevice_class, "device-class");

  /* Qinteger, Qboolean, Qgeneric defined in general.c */
  defsymbol (&Qnatnum, "natnum");

  DEFSUBR (Fvalid_specifier_type_p);
  DEFSUBR (Fspecifier_type_list);
  DEFSUBR (Fmake_specifier);
  DEFSUBR (Fspecifierp);
  DEFSUBR (Fspecifier_type);

  DEFSUBR (Fvalid_specifier_locale_p);
  DEFSUBR (Fvalid_specifier_domain_p);
  DEFSUBR (Fvalid_specifier_locale_type_p);
  DEFSUBR (Fspecifier_locale_type_from_locale);

  DEFSUBR (Fvalid_specifier_tag_p);
  DEFSUBR (Fvalid_specifier_tag_set_p);
  DEFSUBR (Fcanonicalize_tag_set);
  DEFSUBR (Fdevice_matches_specifier_tag_set_p);
  DEFSUBR (Fdefine_specifier_tag);
  DEFSUBR (Fdevice_matching_specifier_tag_list);
  DEFSUBR (Fspecifier_tag_list);
  DEFSUBR (Fspecifier_tag_predicate);

  DEFSUBR (Fcheck_valid_instantiator);
  DEFSUBR (Fvalid_instantiator_p);
  DEFSUBR (Fcheck_valid_inst_list);
  DEFSUBR (Fvalid_inst_list_p);
  DEFSUBR (Fcheck_valid_spec_list);
  DEFSUBR (Fvalid_spec_list_p);
  DEFSUBR (Fadd_spec_to_specifier);
  DEFSUBR (Fadd_spec_list_to_specifier);
  DEFSUBR (Fspecifier_spec_list);
  DEFSUBR (Fspecifier_specs);
  DEFSUBR (Fremove_specifier);
  DEFSUBR (Fcopy_specifier);

  DEFSUBR (Fcheck_valid_specifier_matchspec);
  DEFSUBR (Fvalid_specifier_matchspec_p);
  DEFSUBR (Fspecifier_fallback);
  DEFSUBR (Fspecifier_instance);
  DEFSUBR (Fspecifier_matching_instance);
  DEFSUBR (Fspecifier_instance_from_inst_list);
  DEFSUBR (Fspecifier_matching_instance_from_inst_list);
  DEFSUBR (Fset_specifier_dirty_flag);

  DEFSUBR (Fgeneric_specifier_p);
  DEFSUBR (Finteger_specifier_p);
  DEFSUBR (Fnatnum_specifier_p);
  DEFSUBR (Fboolean_specifier_p);
  DEFSUBR (Fdisplay_table_specifier_p);

  /* Symbols pertaining to specifier creation.  Specifiers are created
     in the syms_of() functions. */

  /* locales are defined in general.c. */

  defsymbol (&Qprepend, "prepend");
  defsymbol (&Qappend, "append");
  defsymbol (&Qremove_tag_set_prepend, "remove-tag-set-prepend");
  defsymbol (&Qremove_tag_set_append, "remove-tag-set-append");
  defsymbol (&Qremove_locale, "remove-locale");
  defsymbol (&Qremove_locale_type, "remove-locale-type");
  defsymbol (&Qremove_all, "remove-all");

  defsymbol (&Qfallback, "fallback");
}

void
specifier_type_create (void)
{
  the_specifier_type_entry_dynarr = Dynarr_new (specifier_type_entry);

  Vspecifier_type_list = Qnil;
  staticpro (&Vspecifier_type_list);

  INITIALIZE_SPECIFIER_TYPE (generic, "generic", "generic-specifier-p");

  INITIALIZE_SPECIFIER_TYPE (integer, "integer", "integer-specifier-p");

  SPECIFIER_HAS_METHOD (integer, validate);

  INITIALIZE_SPECIFIER_TYPE (natnum, "natnum", "natnum-specifier-p");

  SPECIFIER_HAS_METHOD (natnum, validate);

  INITIALIZE_SPECIFIER_TYPE (boolean, "boolean", "boolean-specifier-p");

  SPECIFIER_HAS_METHOD (boolean, validate);

  INITIALIZE_SPECIFIER_TYPE (display_table, "display-table", "display-table-p");

  SPECIFIER_HAS_METHOD (display_table, validate);
}

void
vars_of_specifier (void)
{
  Vcached_specifiers = Qnil;
  staticpro (&Vcached_specifiers);

  /* Do NOT mark through this, or specifiers will never be GC'd.
     This is the same deal as for weak hashtables. */
  Vall_specifiers = Qnil;

  Vuser_defined_tags = Qnil;
  staticpro (&Vuser_defined_tags);

  Vunlock_ghost_specifiers = Qnil;
  staticpro (&Vunlock_ghost_specifiers);
}