xemacs-beta: src/specifier.c comparison

comparison src/specifier.c @ 428:3ecd8885ac67 r21-2-22

Import from CVS: tag r21-2-22

author	cvs
date	Mon, 13 Aug 2007 11:28:15 +0200
parents
children	9d177e8d4150

comparison

equal deleted inserted replaced

-:0a0253eac470
+:3ecd8885ac67
+/* 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 "chartab.h"
+#include "rangetab.h"
+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;
+static specifier_type_entry_dynarr *the_specifier_type_entry_dynarr;
+static const struct lrecord_description ste_description_1[] = {
+{ XD_LISP_OBJECT, offsetof(specifier_type_entry, symbol), 1 },
+{ XD_STRUCT_PTR,  offsetof(specifier_type_entry, meths), 1, &specifier_methods_description },
+{ XD_END }
+};
+static const struct struct_description ste_description = {
+sizeof(specifier_type_entry),
+ste_description_1
+};
+static const struct lrecord_description sted_description_1[] = {
+XD_DYNARR_DESC(specifier_type_entry_dynarr, &ste_description),
+{ XD_END }
+};
+static const struct struct_description sted_description = {
+sizeof(specifier_type_entry_dynarr),
+sted_description_1
+};
+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);
+/************************************************************************/
+/*                       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)
+{
+struct Lisp_Specifier *specifier = XSPECIFIER (obj);
+mark_object (specifier->global_specs);
+mark_object (specifier->device_specs);
+mark_object (specifier->frame_specs);
+mark_object (specifier->window_specs);
+mark_object (specifier->buffer_specs);
+mark_object (specifier->magic_parent);
+mark_object (specifier->fallback);
+if (!GHOST_SPECIFIER_P (XSPECIFIER (obj)))
+MAYBE_SPECMETH (specifier, mark, (obj));
+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 (void)
+{
+Lisp_Object rest, prev = Qnil;
+for (rest = Vall_specifiers;
+!NILP (rest);
+rest = XSPECIFIER (rest)->next_specifier)
+{
+if (! 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 (!MAGIC_SPECIFIER_P(sp)
+		  || (BODILY_SPECIFIER_P(sp) && marked_p (sp->fallback))
+		  || (GHOST_SPECIFIER_P(sp) && marked_p (sp->magic_parent)));
+	  /* This specifier is garbage.  Remove it from the list. */
+	  if (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 && !GHOST_SPECIFIER_P(sp) && sp->caching)
+{
+xfree (sp->caching);
+sp->caching = 0;
+}
+}
+static int
+specifier_equal (Lisp_Object obj1, Lisp_Object obj2, int depth)
+{
+struct Lisp_Specifier *s1 = XSPECIFIER (obj1);
+struct Lisp_Specifier *s2 = XSPECIFIER (obj2);
+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, (obj1, obj2, 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 offsetof (struct Lisp_Specifier, data);
+else
+{
+CONST struct Lisp_Specifier *p = (CONST struct Lisp_Specifier *) header;
+return offsetof (struct Lisp_Specifier, data) + p->methods->extra_data_size;
+}
+}
+static const struct lrecord_description specifier_methods_description_1[] = {
+{ XD_LISP_OBJECT, offsetof(struct specifier_methods, predicate_symbol), 1 },
+{ XD_END }
+};
+const struct struct_description specifier_methods_description = {
+sizeof(struct specifier_methods),
+specifier_methods_description_1
+};
+static const struct lrecord_description specifier_caching_description_1[] = {
+{ XD_END }
+};
+static const struct struct_description specifier_caching_description = {
+sizeof(struct specifier_caching),
+specifier_caching_description_1
+};
+static const struct lrecord_description specifier_description[] = {
+{ XD_STRUCT_PTR,  offsetof(struct Lisp_Specifier, methods), 1, &specifier_methods_description },
+{ XD_LO_LINK,     offsetof(struct Lisp_Specifier, next_specifier) },
+{ XD_LISP_OBJECT, offsetof(struct Lisp_Specifier, global_specs), 5 },
+{ XD_STRUCT_PTR,  offsetof(struct Lisp_Specifier, caching), 1, &specifier_caching_description },
+{ XD_LISP_OBJECT, offsetof(struct Lisp_Specifier, magic_parent), 2 },
+{ XD_SPECIFIER_END }
+};
+const struct lrecord_description specifier_empty_extra_description[] = {
+{ XD_END }
+};
+DEFINE_LRECORD_SEQUENCE_IMPLEMENTATION ("specifier", specifier,
+					mark_specifier, print_specifier,
+					finalize_specifier,
+					specifier_equal, specifier_hash,
+					specifier_description,
+					sizeof_specifier,
+					struct Lisp_Specifier);
+/************************************************************************/
+/*                       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 (offsetof (struct Lisp_Specifier, data) +
+		    data_size, &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);
+}
+/************************************************************************/
+/*                       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))
+{
+return list1 (Qall);
+}
+else if (CONSP (locale))
+{
+Lisp_Object elt;
+EXTERNAL_LIST_LOOP_2 (elt, locale)
+	check_valid_locale_or_locale_type (elt);
+return locale;
+}
+else
+{
+check_valid_locale_or_locale_type (locale);
+return list1 (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;
+}
+/************************************************************************/
+/*                                 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);
+}
+}
+/************************************************************************/
+/*                       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;
+}
+/************************************************************************/
+/*                              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 *CIE_inst_list =						\
+specifier_get_inst_list (specifier, key, type);			\
+if (CIE_inst_list)							\
+{									\
+Lisp_Object CIE_val =						\
+	specifier_instance_from_inst_list (specifier, matchspec,	\
+					   domain, *CIE_inst_list,	\
+					   errb, no_quit, depth);	\
+if (!UNBOUNDP (CIE_val))						\
+	return CIE_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;
+}
+retry:
+/* 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 retry;
+}
+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;
+}
+/************************************************************************/
+/*                 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;
+}
+/************************************************************************/
+/*                        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);
+#define VALID_SINGLE_DISPTABLE_INSTANTIATOR_P(instantiator)			\
+(VECTORP (instantiator)							\
+|| (CHAR_TABLEP (instantiator)						\
+&& (XCHAR_TABLE_TYPE (instantiator) == CHAR_TABLE_TYPE_CHAR		\
+	   || XCHAR_TABLE_TYPE (instantiator) == CHAR_TABLE_TYPE_GENERIC))	\
+|| RANGE_TABLEP (instantiator))
+static void
+display_table_validate (Lisp_Object instantiator)
+{
+if (NILP (instantiator))
+/* OK */
+;
+else if (CONSP (instantiator))
+{
+Lisp_Object tail;
+EXTERNAL_LIST_LOOP (tail, instantiator)
+	{
+	  Lisp_Object car = XCAR (tail);
+	  if (!VALID_SINGLE_DISPTABLE_INSTANTIATOR_P (car))
+	    goto lose;
+	}
+}
+else
+{
+if (!VALID_SINGLE_DISPTABLE_INSTANTIATOR_P (instantiator))
+	{
+	lose:
+	  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;
+}
+/************************************************************************/
+/*                           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);
+dumpstruct (&the_specifier_type_entry_dynarr, &sted_description);
+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
+reinit_specifier_type_create (void)
+{
+REINITIALIZE_SPECIFIER_TYPE (generic);
+REINITIALIZE_SPECIFIER_TYPE (integer);
+REINITIALIZE_SPECIFIER_TYPE (natnum);
+REINITIALIZE_SPECIFIER_TYPE (boolean);
+REINITIALIZE_SPECIFIER_TYPE (display_table);
+}
+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 hash tables. */
+Vall_specifiers = Qnil;
+pdump_wire_list (&Vall_specifiers);
+Vuser_defined_tags = Qnil;
+staticpro (&Vuser_defined_tags);
+Vunlock_ghost_specifiers = Qnil;
+staticpro (&Vunlock_ghost_specifiers);
+}

Mercurial > hg > xemacs-beta

comparison src/specifier.c @ 428:3ecd8885ac67 r21-2-22