This is specifier.c in view mode; [Download] [Up]
/* Specifier implementation
Copyright (C) 1994, 1995 Board of Trustees, University of Illinois.
Copyright (C) 1995 Ben Wing.
Copyright (C) 1995 Sun Microsystems.
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, 675 Mass Ave, Cambridge, MA 02139, USA. */
/* Synched up with: Not in FSF. */
/* Design by Ben Wing;
Original version by Chuck Thompson;
rewritten by Ben Wing */
#include <config.h>
#include "lisp.h"
#include "buffer.h"
#include "device.h"
#include "frame.h"
#include "specifier.h"
#include "window.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 defined in general.c. */
Lisp_Object Qgeneric, Qnatnum;
Lisp_Object Qdevice_type, Qdevice_class;
Lisp_Object Vuser_defined_tags;
MAC_DEFINE (struct Lisp_Specifier *, mactemp_specmeth_or_given);
MAC_DEFINE (struct Lisp_Specifier *, mactemp_specifier_data);
struct specifier_type_entry
{
Lisp_Object symbol;
struct specifier_methods *meths;
};
typedef struct specifier_type_entry_dynarr_type
{
Dynarr_declare (struct specifier_type_entry);
} specifier_type_entry_dynarr;
specifier_type_entry_dynarr *the_specifier_type_entry_dynarr;
Lisp_Object Vspecifier_type_list;
Lisp_Object Vcached_specifiers;
/* Do NOT mark through this, or specifiers will never be GC'd. */
Lisp_Object Vall_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.13. */
lisp_dynarr current_specifiers;
static void recompute_cached_specifier_everywhere (Lisp_Object specifier);
/************************************************************************/
/* Specifier object methods */
/************************************************************************/
static Lisp_Object mark_specifier (Lisp_Object, void (*) (Lisp_Object));
static void print_specifier (Lisp_Object, Lisp_Object, int);
static int specifier_equal (Lisp_Object, Lisp_Object, int depth);
static unsigned long specifier_hash (Lisp_Object obj, int depth);
static unsigned int sizeof_specifier (CONST void *header);
static void finalize_specifier (void *header, int for_disksave);
DEFINE_LRECORD_SEQUENCE_IMPLEMENTATION ("specifier", specifier,
mark_specifier, print_specifier,
finalize_specifier,
specifier_equal, specifier_hash,
sizeof_specifier,
struct Lisp_Specifier);
/* Remove dead objects from the specified assoc list. */
static int
object_dead_p (Lisp_Object obj)
{
/* We do not include dead windows in this list because
dead windows can become live again through restoring
a window configuration. */
return ((BUFFERP (obj) && !BUFFER_LIVE_P (XBUFFER (obj))) ||
(FRAMEP (obj) && !FRAME_LIVE_P (XFRAME (obj))) ||
(DEVICEP (obj) && !DEVICE_LIVE_P (XDEVICE (obj))));
}
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);
if (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 */
}
}
static Lisp_Object
mark_specifier (Lisp_Object obj, void (*markobj) (Lisp_Object))
{
struct Lisp_Specifier *specifier = XSPECIFIER (obj);
((markobj) (specifier->global_specs));
((markobj) (specifier->device_specs));
((markobj) (specifier->frame_specs));
/* DO NOT mark the window_specs. They behave like key-weak
hashtables and need to be handled specially, at the end
of the mark phase of GC. */
((markobj) (specifier->buffer_specs));
((markobj) (specifier->fallback));
MAYBE_SPECMETH (specifier, mark, (obj, markobj));
return Qnil;
}
int
finish_marking_specifiers (int (*obj_marked_p) (Lisp_Object),
void (*markobj) (Lisp_Object))
{
Lisp_Object rest;
int did_mark = 0;
for (rest = Vall_specifiers;
/* This should never be marked, so no need to unmark. */
!NILP (rest);
rest = XSPECIFIER (rest)->next_specifier)
{
Lisp_Object rest2;
if (! ((*obj_marked_p) (rest)))
/* The specifier is probably garbage. Ignore it. */
continue;
for (rest2 = XSPECIFIER (rest)->window_specs;
/* We need to be trickier since we're inside of GC */
/* Actually, this is not currently necessary since
markobj() marks the car and not the cdr, but it's
safer in case markobj() ever gets changed */
XUNMARK (rest2), !NILP (rest2);
rest2 = XCDR (rest2))
{
Lisp_Object assoc = XCAR (rest2);
/* Only mark the specs for a window if the window itself
is marked. All live windows will be marked (if not,
something is majorly screwed). Dead windows will
not be marked if they're dangling. Any dead windows
that could be resurrected will be in a window config
and thus will be marked. */
if ((*obj_marked_p) (XCAR (assoc)))
{
/* We need to mark both the CDR of the assoc and
the assoc-pair cons itself. Marking the
assoc-pair will mark both. */
if (! (*obj_marked_p) (assoc))
{
(*markobj) (assoc);
did_mark = 1;
}
/* We also need to mark the cons that holds the assoc-pair.
We do *not* want to call (markobj) here because that
will mark the entire assoc-list; we just want to mark
the cons itself.
#### If alloc.c mark_object() changes, this must change
too. */
{
struct Lisp_Cons *ptr = XCONS (rest2);
if (!XMARKBIT (ptr->car))
{
XMARK (ptr->car);
did_mark = 1;
}
}
}
}
}
return did_mark;
}
void
prune_specifiers (int (*obj_marked_p) (Lisp_Object))
{
Lisp_Object rest, prev = Qnil;
for (rest = Vall_specifiers;
/* This should never be marked, so no need to unmark. */
!NILP (rest);
rest = XSPECIFIER (rest)->next_specifier)
{
if (! ((*obj_marked_p) (rest)))
{
/* This specifier itself is garbage. Remove it from the list. */
if (NILP (prev))
Vall_specifiers = XSPECIFIER (rest)->next_specifier;
else
XSPECIFIER (prev)->next_specifier =
XSPECIFIER (rest)->next_specifier;
}
else
{
Lisp_Object rest2, prev2 = Qnil;
for (rest2 = XSPECIFIER (rest)->window_specs;
/* We need to be trickier since we're inside of GC */
/* Actually, this is not currently necessary since
markobj() marks the car and not the cdr, but it's
safer in case markobj() ever gets changed */
XUNMARK (rest2), !NILP (rest2);
rest2 = XCDR (rest2))
{
Lisp_Object assoc = XCAR (rest2);
if (!(*obj_marked_p) (XCAR (assoc)))
{
/* bye bye :-( */
if (NILP (prev2))
XSPECIFIER (rest)->window_specs = XCDR (rest2);
else
XCDR (prev2) = XCDR (rest2);
}
else
prev2 = rest2;
}
}
}
}
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_number (100));
specbind (Qprint_length, make_number (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 && sp->caching)
{
xfree (sp->caching);
sp->caching = 0;
}
}
static int
specifier_equal (Lisp_Object o1, Lisp_Object o2, int depth)
{
struct Lisp_Specifier *s1 = XSPECIFIER (o1);
struct Lisp_Specifier *s2 = XSPECIFIER (o2);
int retval;
Lisp_Object old_inhibit_quit = Vinhibit_quit;
/* This function can be called from within redisplay.
internal_equal can trigger a quit. That leads to Bad Things. */
Vinhibit_quit = Qt;
depth++;
if (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) ||
!SPECMETH_OR_GIVEN (s1, equal, (o1, o2, depth - 1), 1))
retval = 0;
else
retval = 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 (SPECMETH_OR_GIVEN (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 unsigned int
sizeof_specifier (CONST void *header)
{
struct Lisp_Specifier *p = (struct Lisp_Specifier *) header;
return sizeof (*p) + p->methods->extra_data_size - 1;
}
/************************************************************************/
/* Creating specifiers */
/************************************************************************/
static struct specifier_methods *
decode_specifier_type (Lisp_Object type, int no_error)
{
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;
}
if (!no_error)
signal_simple_error ("Invalid specifier type", type);
return 0;
}
static int
valid_specifier_type_p (Lisp_Object type)
{
if (decode_specifier_type (type, 1))
return 1;
return 0;
}
DEFUN ("valid-specifier-type-p", Fvalid_specifier_type_p,
Svalid_specifier_type_p, 1, 1, 0,
"Given a SPECIFIER-TYPE, return non-nil if it is valid.\n\
Valid types are 'generic, 'integer, boolean, 'color, 'font, 'image,\n\
'face-boolean, and 'toolbar.")
(specifier_type)
Lisp_Object specifier_type;
{
if (valid_specifier_type_p (specifier_type))
return Qt;
else
return Qnil;
}
DEFUN ("specifier-type-list", Fspecifier_type_list, Sspecifier_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 (struct specifier_methods *spec_meths)
{
struct Lisp_Specifier *sp;
Lisp_Object specifier = Qnil;
struct gcpro gcpro1;
sp = alloc_lcrecord (sizeof (struct Lisp_Specifier) +
spec_meths->extra_data_size - 1, lrecord_specifier);
sp->methods = spec_meths;
sp->global_specs = Qnil;
sp->device_specs = Qnil;
sp->frame_specs = Qnil;
sp->window_specs = Qnil;
sp->buffer_specs = Qnil;
sp->fallback = Qnil;
sp->caching = 0;
sp->next_specifier = Vall_specifiers;
XSETSPECIFIER (specifier, sp);
Vall_specifiers = specifier;
GCPRO1 (specifier);
MAYBE_SPECMETH (XSPECIFIER (specifier), create, (specifier));
UNGCPRO;
return specifier;
}
DEFUN ("make-specifier", Fmake_specifier, Smake_specifier, 1, 1, 0,
"Create a new specifier.\n\
\n\
A specifier is an object that can be used to keep track of a property\n\
whose value can be per-buffer, per-window, per-frame, or per-device,\n\
and can further be restricted to a particular device-type or device-class.\n\
Specifiers are used, for example, for the various built-in properties of a\n\
face; this allows a face to have different values in different frames,\n\
buffers, etc. For more information, see `specifier-instance',\n\
`specifier-specs', and `add-spec-to-specifier'; or, for a detailed\n\
description of specifiers, including how they are instantiated over a\n\
particular domain (i.e. how their value in that domain is determined),\n\
see the chapter on specifiers in the XEmacs Lisp Reference Manual.\n\
\n\
TYPE specifies the particular type of specifier, and should be one of\n\
the symbols 'generic, 'integer, 'boolean, 'color, 'font, 'image,\n\
'face-boolean, or 'toolbar.\n\
\n\
For more information on particular types of specifiers, see the functions\n\
`generic-specifier-p', `integer-specifier-p', `boolean-specifier-p',\n\
`color-specifier-p', `font-specifier-p', `image-specifier-p',\n\
`face-boolean-specifier-p', and `toolbar-specifier-p'.")
(type)
Lisp_Object type;
{
/* This function can GC */
struct specifier_methods *meths = decode_specifier_type (type, 0);
return make_specifier (meths);
}
DEFUN ("specifierp", Fspecifierp, Sspecifierp, 1, 1, 0,
"Return non-nil if OBJECT is a specifier.\n\
\n\
A specifier is an object that can be used to keep track of a property\n\
whose value can be per-buffer, per-window, per-frame, or per-device,\n\
and can further be restricted to a particular device-type or device-class.\n\
See `make-specifier'.")
(object)
Lisp_Object object;
{
if (!SPECIFIERP (object))
return Qnil;
return Qt;
}
DEFUN ("specifier-type", Fspecifier_type, Sspecifier_type, 1, 1, 0,
"Return the type of SPECIFIER.")
(specifier)
Lisp_Object specifier;
{
CHECK_SPECIFIER (specifier, 0);
return intern (XSPECIFIER (specifier)->methods->name);
}
/************************************************************************/
/* Locales and domains */
/************************************************************************/
DEFUN ("valid-specifier-locale-p", Fvalid_specifier_locale_p,
Svalid_specifier_locale_p, 1, 1, 0,
"Return non-nil if LOCALE is a valid specifier locale.\n\
Valid locales are a device, a frame, a window, a buffer, and 'global.\n\
(nil is not valid.)")
(locale)
Lisp_Object locale;
{
/* This cannot GC. */
if ((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))
return Qt;
else
return Qnil;
}
DEFUN ("valid-specifier-domain-p",
Fvalid_specifier_domain_p,
Svalid_specifier_domain_p, 1, 1, 0,
"Return non-nil if DOMAIN is a valid specifier domain.\n\
A domain is used to instance a specifier (i.e. determine the specifier's\n\
value in that domain). Valid domains are a window, frame, or device.\n\
(nil is not valid.)")
(domain)
Lisp_Object domain;
{
/* This cannot GC. */
if ((DEVICEP (domain) && DEVICE_LIVE_P (XDEVICE (domain))) ||
(FRAMEP (domain) && FRAME_LIVE_P (XFRAME (domain))) ||
(WINDOWP (domain) && WINDOW_LIVE_P (XWINDOW (domain))))
return Qt;
else
return Qnil;
}
DEFUN ("valid-specifier-locale-type-p",
Fvalid_specifier_locale_type_p,
Svalid_specifier_locale_type_p, 1, 1, 0,
"Given a specifier LOCALE-TYPE, return non-nil if it is valid.\n\
Valid locale types are 'global, 'device, 'frame, 'window, and 'buffer.\n\
(Note, however, that in functions that accept either a locale or a locale\n\
type, 'global is considered an individual locale.)")
(locale_type)
Lisp_Object locale_type;
{
/* This cannot GC. */
if (EQ (locale_type, Qglobal) ||
EQ (locale_type, Qdevice) ||
EQ (locale_type, Qframe) ||
EQ (locale_type, Qwindow) ||
EQ (locale_type, Qbuffer))
return Qt;
else
return 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,
Sspecifier_locale_type_from_locale, 1, 1, 0,
"Given a specifier LOCALE, return its type.")
(locale)
Lisp_Object 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;
}
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 0;
}
Lisp_Object
decode_locale_list (Lisp_Object locale)
{
/* This cannot GC. */
/* The return value of this function must be GCPRO'd. */
if (NILP (locale))
locale = list1 (Qall);
else
{
Lisp_Object rest;
if (!CONSP (locale))
locale = list1 (locale);
EXTERNAL_LIST_LOOP (rest, locale)
check_valid_locale_or_locale_type (XCAR (rest));
}
return locale;
}
static enum spec_locale_type
locale_type_from_locale (Lisp_Object locale)
{
return decode_locale_type (Fspecifier_locale_type_from_locale (locale));
}
static void
check_valid_domain (Lisp_Object domain)
{
if (NILP (Fvalid_specifier_domain_p (domain)))
signal_simple_error ("Invalid specifier domain", domain);
}
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,
Svalid_specifier_tag_p,
1, 1, 0,
"Return non-nil if TAG is a valid specifier tag.\n\
See also `valid-specifier-tag-set-p'.")
(tag)
Lisp_Object tag;
{
if (valid_device_type_p (tag) ||
valid_device_class_p (tag) ||
!NILP (assq_no_quit (tag, Vuser_defined_tags)))
return Qt;
return Qnil;
}
DEFUN ("valid-specifier-tag-set-p", Fvalid_specifier_tag_set_p,
Svalid_specifier_tag_set_p,
1, 1, 0,
"Return non-nil if TAG-SET is a valid specifier tag set.\n\
\n\
A specifier tag set is an entity that is attached to an instantiator\n\
and can be used to restrict the scope of that instantiator to a\n\
particular device class or device type and/or to mark instantiators\n\
added by a particular package so that they can be later removed.\n\
\n\
A specifier tag set consists of a list of zero of more specifier tags,\n\
each of which is a symbol that is recognized by XEmacs as a tag.\n\
(The valid device types and device classes are always tags, as are\n\
any tags defined by `define-specifier-tag'.) It is called a \"tag set\"\n\
(as opposed to a list) because the order of the tags or the number of\n\
times a particular tag occurs does not matter.\n\
\n\
Each tag has a predicate associated with it, which specifies whether\n\
that tag applies to a particular device. The tags which are device types\n\
and classes match devices of that type or class. User-defined tags can\n\
have any predicate, or none (meaning that all devices match). When\n\
attempting to instance a specifier, a particular instantiator is only\n\
considered if the device of the domain being instanced over matches\n\
all tags in the tag set attached to that instantiator.\n\
\n\
Most of the time, a tag set is not specified, and the instantiator\n\
gets a null tag set, which matches all devices.")
(tag_set)
Lisp_Object 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 = (Lisp_Object *) alloca (len * sizeof (Lisp_Object));
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,
Scanonicalize_tag_set, 1, 1, 0,
"Canonicalize the given tag set.\n\
Two canonicalized tag sets can be compared with `equal' to see if they\n\
represent the same tag set. (Specifically, canonicalizing involves\n\
sorting by symbol name and removing duplicates.)")
(tag_set)
Lisp_Object 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,
Sdevice_matches_specifier_tag_set_p,
2, 2, 0,
"Return non-nil if DEVICE matches specifier tag set TAG-SET.\n\
This means that DEVICE matches each tag in the tag set. (Every\n\
tag recognized by XEmacs has a predicate associated with it that\n\
specifies which devices match it.)")
(device, tag_set)
Lisp_Object device, tag_set;
{
CHECK_LIVE_DEVICE (device, 0);
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, Sdefine_specifier_tag,
1, 2, 0,
"Define a new specifier tag.\n\
If PREDICATE is specified, it should be a function of one argument\n\
(a device) that specifies whether the tag matches that particular\n\
device. If PREDICATE is omitted, the tag matches all devices.\n\
\n\
You can redefine an existing user-defined specifier tag. However,\n\
you cannot redefine the built-in specifier tags (the device types\n\
and classes) or the symbols nil, t, 'all, or 'global.")
(tag, predicate)
Lisp_Object tag, predicate;
{
Lisp_Object assoc, rest;
int recompute = 0;
CHECK_SYMBOL (tag, 0);
if (valid_device_class_p (tag) ||
valid_device_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 (rest)
{
struct device *d = XDEVICE (XCAR (rest));
/* 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 (rest)
{
Lisp_Object device = XCAR (rest);
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 = Qnil;
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,
Sdevice_matching_specifier_tag_list,
0, 1, 0,
"Return a list of all specifier tags matching DEVICE.\n\
DEVICE defaults to the selected device if omitted.")
(device)
Lisp_Object device;
{
struct device *d = get_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, Sspecifier_tag_list,
0, 0, 0,
"Return a list of all currently-defined specifier tags.\n\
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 (Vdevice_type_list), list);
RETURN_UNGCPRO (list);
}
DEFUN ("specifier-tag-predicate", Fspecifier_tag_predicate,
Sspecifier_tag_predicate,
1, 1, 0,
"Return the predicate for the given specifier tag.")
(tag)
Lisp_Object tag;
{
/* The return value of this function must be GCPRO'd. */
CHECK_SYMBOL (tag, 0);
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_device_type_p (tag))
return list3 (Qlambda, list1 (Qdevice),
list3 (Qeq, list2 (Qquote, tag),
list2 (Qdevice_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
check_valid_instantiator (Lisp_Object instantiator,
struct specifier_methods *meths,
int no_error)
{
if (meths->validate_method &&
! (meths->validate_method) (instantiator, no_error))
{
if (no_error)
return Qnil;
else
signal_simple_error ("Invalid instantiator", instantiator);
}
return Qt;
}
DEFUN ("check-valid-instantiator", Fcheck_valid_instantiator,
Scheck_valid_instantiator,
2, 2, 0,
"Signal an error if INSTANTIATOR is invalid for SPECIFIER-TYPE.")
(instantiator, specifier_type)
Lisp_Object instantiator, specifier_type;
{
struct specifier_methods *meths = decode_specifier_type (specifier_type, 0);
return check_valid_instantiator (instantiator, meths, 0);
}
DEFUN ("valid-instantiator-p", Fvalid_instantiator_p, Svalid_instantiator_p,
2, 2, 0,
"Return non-nil if INSTANTIATOR is valid for SPECIFIER-TYPE.")
(instantiator, specifier_type)
Lisp_Object instantiator, specifier_type;
{
struct specifier_methods *meths = decode_specifier_type (specifier_type, 0);
return check_valid_instantiator (instantiator, meths, 1);
}
static Lisp_Object
check_valid_inst_list (Lisp_Object inst_list, struct specifier_methods *meths,
int no_error)
{
Lisp_Object rest;
LIST_LOOP (rest, inst_list)
{
if (!CONSP (rest) || !CONSP (XCAR (rest)))
{
if (no_error)
return Qnil;
else
signal_simple_error ("Invalid instantiator list", inst_list);
}
if (NILP (Fvalid_specifier_tag_set_p (XCAR (XCAR (rest)))))
{
if (no_error)
return Qnil;
else
signal_simple_error ("Invalid specifier tag", XCAR (XCAR (rest)));
}
if (NILP (check_valid_instantiator (XCDR (XCAR (rest)), meths,
no_error)))
return Qnil;
}
return Qt;
}
DEFUN ("check-valid-inst-list", Fcheck_valid_inst_list, Scheck_valid_inst_list,
2, 2, 0,
"Signal an error if INST-LIST is invalid for specifier type TYPE.")
(inst_list, type)
Lisp_Object inst_list, type;
{
struct specifier_methods *meths = decode_specifier_type (type, 0);
return check_valid_inst_list (inst_list, meths, 0);
}
DEFUN ("valid-inst-list-p", Fvalid_inst_list_p, Svalid_inst_list_p,
2, 2, 0,
"Return non-nil if INST-LIST is valid for specifier type TYPE.")
(inst_list, type)
Lisp_Object inst_list, type;
{
struct specifier_methods *meths = decode_specifier_type (type, 0);
return check_valid_inst_list (inst_list, meths, 1);
}
static Lisp_Object
check_valid_spec_list (Lisp_Object spec_list, struct specifier_methods *meths,
int no_error)
{
Lisp_Object rest;
LIST_LOOP (rest, spec_list)
{
if (!CONSP (rest) || !CONSP (XCAR (rest)))
{
if (no_error)
return Qnil;
else
signal_simple_error ("Invalid specification list", spec_list);
}
if (NILP (Fvalid_specifier_locale_p (XCAR (XCAR (rest)))))
{
if (no_error)
return Qnil;
else
signal_simple_error ("Invalid specifier locale",
XCAR (XCAR (rest)));
}
if (NILP (check_valid_inst_list (XCDR (XCAR (rest)), meths, no_error)))
return Qnil;
}
return Qt;
}
DEFUN ("check-valid-spec-list", Fcheck_valid_spec_list, Scheck_valid_spec_list,
2, 2, 0,
"Signal an error if SPEC-LIST is invalid for specifier type TYPE.")
(spec_list, type)
Lisp_Object spec_list, type;
{
struct specifier_methods *meths = decode_specifier_type (type, 0);
return check_valid_spec_list (spec_list, meths, 0);
}
DEFUN ("valid-spec-list-p", Fvalid_spec_list_p, Svalid_spec_list_p,
2, 2, 0,
"Return non-nil if SPEC-LIST is valid for specifier type TYPE.")
(spec_list, type)
Lisp_Object spec_list, type;
{
struct specifier_methods *meths = decode_specifier_type (type, 0);
return check_valid_spec_list (spec_list, meths, 1);
}
enum spec_add_meth
decode_how_to_add_specification (Lisp_Object how_to_add)
{
enum spec_add_meth add_meth = 0;
if (NILP (how_to_add) || EQ (Qremove_tag_set_prepend, how_to_add))
add_meth = SPEC_REMOVE_TAG_SET_PREPEND;
else if (EQ (Qremove_tag_set_append, how_to_add))
add_meth = SPEC_REMOVE_TAG_SET_APPEND;
else if (EQ (Qappend, how_to_add))
add_meth = SPEC_APPEND;
else if (EQ (Qprepend, how_to_add))
add_meth = SPEC_PREPEND;
else if (EQ (Qremove_locale, how_to_add))
add_meth = SPEC_REMOVE_LOCALE;
else if (EQ (Qremove_locale_type, how_to_add))
add_meth = SPEC_REMOVE_LOCALE_TYPE;
else if (EQ (Qremove_all, how_to_add))
add_meth = SPEC_REMOVE_ALL;
else
signal_simple_error ("Invalid `how-to-add' flag", how_to_add);
return add_meth;
}
/* 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 \
? &(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, (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 */
if (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,
(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)
{
if (add_meth == SPEC_REMOVE_TAG_SET_PREPEND ||
add_meth == SPEC_REMOVE_TAG_SET_APPEND)
{
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;
}
if (add_meth == SPEC_REMOVE_TAG_SET_PREPEND)
return SPEC_PREPEND;
else
return SPEC_APPEND;
}
else if (add_meth == SPEC_REMOVE_LOCALE)
{
*inst_list = Qnil;
return SPEC_PREPEND;
}
if (add_meth == SPEC_APPEND)
return add_meth;
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 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 gcpro1, gcpro2;
GCPRO2 (instantiator, sub_inst_list);
/* call the will-add method; it may GC */
sub_inst_list = SPECMETH_OR_GIVEN (XSPECIFIER (specifier), going_to_add,
(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);
UNGCPRO;
}
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;
Lisp_Object *orig_inst_list;
Lisp_Object list_to_build_up = Qnil;
struct gcpro gcpro1;
type = locale_type_from_locale (locale);
/* 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, inst_list, add_meth);
GCPRO1 (list_to_build_up);
list_to_build_up = build_up_processed_list (specifier, locale, inst_list);
if (add_meth == SPEC_PREPEND)
{
*orig_inst_list = nconc2 (list_to_build_up, *orig_inst_list);
}
else if (add_meth == SPEC_APPEND)
{
*orig_inst_list = nconc2 (*orig_inst_list, list_to_build_up);
}
else
abort ();
UNGCPRO;
/* call the after-change method */
MAYBE_SPECMETH (sp, after_change, (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 */
if (!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, Sadd_spec_to_specifier,
2, 5, 0,
"Add a specification to SPECIFIER.\n\
The specification maps from LOCALE (which should be a buffer, window,\n\
frame, device, or 'global, and defaults to 'global) to INSTANTIATOR,\n\
whose allowed values depend on the type of the specifier. Optional\n\
argument TAG-SET limits the instantiator to apply only to the specified\n\
tag set, which should be a list of tags all of which must match the\n\
device being instantiated over (tags are a device type, a device class,\n\
or tags defined with `define-specifier-tag'). Specifying a single\n\
symbol for TAG-SET is equivalent to specifying a one-element list\n\
containing that symbol. Optional argument HOW-TO-ADD specifies what to\n\
do if there are already specifications in the specifier.\n\
It should be one of\n\
\n\
'prepend Put at the beginning of the current list of\n\
instantiators for LOCALE.\n\
'append Add to the end of the current list of\n\
instantiators for LOCALE.\n\
'remove-tag-set-prepend (this is the default)\n\
Remove any existing instantiators whose tag set is\n\
the same as TAG-SET; then put the new instantiator\n\
at the beginning of the current list. (\"Same tag\n\
set\" means that they contain the same elements.\n\
The order may be different.)\n\
'remove-tag-set-append\n\
Remove any existing instantiators whose tag set is\n\
the same as TAG-SET; then put the new instantiator\n\
at the end of the current list.\n\
'remove-locale Remove all previous instantiators for this locale\n\
before adding the new spec.\n\
'remove-locale-type Remove all specifications for all locales of the\n\
same type as LOCALE (this includes LOCALE itself)\n\
before adding the new spec.\n\
'remove-all Remove all specifications from the specifier\n\
before adding the new spec.\n\
\n\
You can retrieve the specifications for a particular locale or locale type\n\
with the function `specifier-spec-list' or `specifier-specs'.")
(specifier, instantiator, locale, tag_set, how_to_add)
Lisp_Object specifier, instantiator, locale, tag_set, how_to_add;
{
enum spec_add_meth add_meth;
Lisp_Object inst_list;
struct gcpro gcpro1;
CHECK_SPECIFIER (specifier, 0);
locale = decode_locale (locale);
check_valid_instantiator (instantiator,
decode_specifier_type
(Fspecifier_type (specifier), 0),
0);
/* 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,
Sadd_spec_list_to_specifier, 2, 3, 0,
"Add a spec-list (a list of specifications) to SPECIFIER.\n\
The format of a spec-list is\n\
\n\
((LOCALE (TAG-SET . INSTANTIATOR) ...) ...)\n\
\n\
where\n\
LOCALE := a buffer, a window, a frame, a device, or 'global\n\
TAG-SET := an unordered list of zero or more TAGS, each of which\n\
is a symbol\n\
TAG := a device class (see `valid-device-class-p'), a device type\n\
(see `valid-device-type-p'), or a tag defined with\n\
`define-specifier-tag'\n\
INSTANTIATOR := format determined by the type of specifier\n\
\n\
The pair (TAG-SET . INSTANTIATOR) is called an `inst-pair'.\n\
A list of inst-pairs is called an `inst-list'.\n\
The pair (LOCALE . INST-LIST) is called a `specification' or `spec'.\n\
A spec-list, then, can be viewed as a list of specifications.\n\
\n\
HOW-TO-ADD specifies how to combine the new specifications with\n\
the existing ones, and has the same semantics as for\n\
`add-spec-to-specifier'.\n\
\n\
In many circumstances, the higher-level function `set-specifier' is\n\
more convenient and should be used instead.")
(specifier, spec_list, how_to_add)
Lisp_Object specifier, spec_list, how_to_add;
{
enum spec_add_meth add_meth;
Lisp_Object rest;
CHECK_SPECIFIER (specifier, 0);
check_valid_spec_list (spec_list,
decode_specifier_type
(Fspecifier_type (specifier), 0),
0);
add_meth = decode_how_to_add_specification (how_to_add);
LIST_LOOP (rest, spec_list)
{
/* Placating the GCC god. */
Lisp_Object crock1 = specifier;
Lisp_Object crock2 = XCAR (XCAR (rest));
Lisp_Object crock3 = XCDR (XCAR (rest));
specifier_add_spec (crock1, crock2, crock3, add_meth);
}
recompute_cached_specifier_everywhere (specifier);
return 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, Sspecifier_spec_list,
1, 4, 0,
"Return the spec-list of specifications for SPECIFIER in LOCALE.\n\
\n\
If LOCALE is a particular locale (a buffer, window, frame, device,\n\
or 'global), a spec-list consisting of the specification for that\n\
locale will be returned.\n\
\n\
If LOCALE is a locale type (i.e. 'buffer, 'window, 'frame, or 'device),\n\
a spec-list of the specifications for all locales of that type will be\n\
returned.\n\
\n\
If LOCALE is nil or 'all, a spec-list of all specifications in SPECIFIER\n\
will be returned.\n\
\n\
LOCALE can also be a list of locales, locale types, and/or 'all; the\n\
result is as if `specifier-spec-list' were called on each element of the\n\
list and the results concatenated together.\n\
\n\
Only instantiators where TAG-SET (a list of zero or more tags) is a\n\
subset of (or possibly equal to) the instantiator's tag set are returned.\n\
(The default value of nil is a subset of all tag sets, so in this case\n\
no instantiators will be screened out.) If EXACT-P is non-nil, however,\n\
TAG-SET must be equal to an instantiator's tag set for the instantiator\n\
to be returned.")
(specifier, locale, tag_set, exact_p)
Lisp_Object specifier, locale, tag_set, exact_p;
{
struct specifier_spec_list_closure cl;
struct gcpro gcpro1, gcpro2;
CHECK_SPECIFIER (specifier, 0);
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, Sspecifier_specs,
1, 4, 0,
"Return the specification(s) for SPECIFIER in LOCALE.\n\
\n\
If LOCALE is a single locale or is a list of one element containing a\n\
single locale, then a \"short form\" of the instantiators for that locale\n\
will be returned. Otherwise, this function is identical to\n\
`specifier-spec-list'.\n\
\n\
The \"short form\" is designed for readability and not for ease of use\n\
in Lisp programs, and is as follows:\n\
\n\
1. If there is only one instantiator, then an inst-pair (i.e. cons of\n\
tag and instantiator) will be returned; otherwise a list of\n\
inst-pairs will be returned.\n\
2. For each inst-pair returned, if the instantiator's tag is 'any,\n\
the tag will be removed and the instantiator itself will be returned\n\
instead of the inst-pair.\n\
3. If there is only one instantiator, its value is nil, and its tag is\n\
'any, a one-element list containing nil will be returned rather\n\
than just nil, to distinguish this case from there being no\n\
instantiators at all.")
(specifier, locale, tag_set, exact_p)
Lisp_Object 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, 0);
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,
Sremove_specifier, 1, 4, 0,
"Remove specification(s) for SPECIFIER.\n\
\n\
If LOCALE is a particular locale (a buffer, window, frame, device,\n\
or 'global), the specification for that locale will be removed.\n\
\n\
If instead, LOCALE is a locale type (i.e. 'buffer, 'window, 'frame,\n\
or 'device), the specifications for all locales of that type will be\n\
removed.\n\
\n\
If LOCALE is nil or 'all, all specifications will be removed.\n\
\n\
LOCALE can also be a list of locales, locale types, and/or 'all; this\n\
is equivalent to calling `remove-specifier' for each of the elements\n\
in the list.\n\
\n\
Only instantiators where TAG-SET (a list of zero or more tags) is a\n\
subset of (or possibly equal to) the instantiator's tag set are removed.\n\
(The default value of nil is a subset of all tag sets, so in this case\n\
no instantiators will be screened out.) If EXACT-P is non-nil, however,\n\
TAG-SET must be equal to an instantiator's tag set for the instantiator\n\
to be removed.")
(specifier, locale, tag_set, exact_p)
Lisp_Object specifier, locale, tag_set, exact_p;
{
CHECK_SPECIFIER (specifier, 0);
map_specifier (specifier, locale, remove_specifier_mapfun, tag_set,
exact_p, 0);
recompute_cached_specifier_everywhere (specifier);
return 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, Scopy_specifier,
1, 6, 0,
"Copy SPECIFIER to DEST, or create a new one if DEST is nil.\n\
\n\
If DEST is nil or omitted, a new specifier will be created and the\n\
specifications copied into it. Otherwise, the specifications will be\n\
copied into the existing specifier in DEST.\n\
\n\
If LOCALE is nil or 'all, all specifications will be copied. If LOCALE\n\
is a particular locale, the specification for that particular locale will\n\
be copied. If LOCALE is a locale type, the specifications for all locales\n\
of that type will be copied. LOCALE can also be a list of locales,\n\
locale types, and/or 'all; this is equivalent to calling `copy-specifier'\n\
for each of the elements of the list. See `specifier-spec-list' for more\n\
information about LOCALE.\n\
\n\
Only instantiators where TAG-SET (a list of zero or more tags) is a\n\
subset of (or possibly equal to) the instantiator's tag set are copied.\n\
(The default value of nil is a subset of all tag sets, so in this case\n\
no instantiators will be screened out.) If EXACT-P is non-nil, however,\n\
TAG-SET must be equal to an instantiator's tag set for the instantiator\n\
to be copied.\n\
\n\
Optional argument HOW-TO-ADD specifies what to do with existing\n\
specifications in DEST. If nil, then whichever locales or locale types\n\
are copied will first be completely erased in DEST. Otherwise, it is\n\
the same as in `add-spec-to-specifier'.")
(specifier, dest, locale, tag_set, exact_p, how_to_add)
Lisp_Object specifier, dest, locale, tag_set, exact_p, how_to_add;
{
struct gcpro gcpro1;
struct copy_specifier_closure cl;
CHECK_SPECIFIER (specifier, 0);
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, 1);
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 (specifier);
return dest;
}
/************************************************************************/
/* Instancing */
/************************************************************************/
/* 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))));
sp->fallback = fallback;
/* call the after-change method */
MAYBE_SPECMETH (sp, after_change, (specifier, Qfallback));
recompute_cached_specifier_everywhere (specifier);
}
DEFUN ("specifier-fallback", Fspecifier_fallback, Sspecifier_fallback,
1, 1, 0,
"Return the fallback value for SPECIFIER.\n\
Fallback values are provided by the C code for certain built-in\n\
specifiers to make sure that instancing won't fail even if all\n\
specs are removed from the specifier, or to implement simple\n\
inheritance behavior (e.g. this method is used to ensure that\n\
faces other than 'default inherit their attributes from 'default).\n\
By design, you cannot change the fallback value, and specifiers\n\
created with `make-specifier' will never have a fallback (although\n\
a similar, Lisp-accessible capability may be provided in the future\n\
to allow for inheritance).\n\
\n\
The fallback value will be an inst-list that is instanced like\n\
any other inst-list, a specifier of the same type as SPECIFIER\n\
(results in inheritance), or nil for no fallback.\n\
\n\
When you instance a specifier, you can explicitly request that the\n\
fallback not be consulted. (The C code does this, for example, when\n\
merging faces.) See `specifier-instance'.")
(specifier)
Lisp_Object specifier;
{
CHECK_SPECIFIER (specifier, 0);
return Fcopy_tree (XSPECIFIER (specifier)->fallback, Qt);
}
static Lisp_Object
specifier_instance_from_inst_list (Lisp_Object specifier, Lisp_Object domain,
Lisp_Object inst_list,
int no_error_or_quit)
{
/* 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);
/* 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;
val = SPECMETH_OR_GIVEN (sp, instantiate,
(specifier, domain, XCDR (tagged_inst),
no_error_or_quit),
XCDR (tagged_inst));
if (!EQ (val, Qunbound))
{
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, type) \
do { \
Lisp_Object *__inst_list = \
specifier_get_inst_list (specifier, key, type); \
if (__inst_list) \
{ \
Lisp_Object __val__ = \
specifier_instance_from_inst_list (specifier, domain, \
*__inst_list, \
no_error_or_quit); \
if (!EQ (__val__, Qunbound)) \
return __val__; \
} \
} while (0)
/* We accept any window, frame or device domain and do our checking
starting from as specific a locale type as we can determine from the
domain we are passed and going on up through as many other locale types
as we can determine. In practice, when called from redisplay the
arg will usually be a window and occasionally a frame. If
triggered by a user call, who knows what it will usually be. */
Lisp_Object
specifier_instance (Lisp_Object specifier, Lisp_Object domain,
int no_error_or_quit, int no_fallback)
{
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
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);
try_again:
/* First see if we can generate one from the buffer specifiers. */
if (!NILP (buffer))
CHECK_INSTANCE_ENTRY (buffer, LOCALE_BUFFER);
/* Next see if we can generate one from the window specifiers. */
if (!NILP (window))
CHECK_INSTANCE_ENTRY (window, LOCALE_WINDOW);
/* Next see if we can generate one from the frame specifiers. */
if (!NILP (frame))
CHECK_INSTANCE_ENTRY (frame, LOCALE_FRAME);
/* If we still haven't succeeded try with the device specifiers. */
CHECK_INSTANCE_ENTRY (device, LOCALE_DEVICE);
/* Last and least try the global specifiers. */
CHECK_INSTANCE_ENTRY (Qglobal, LOCALE_GLOBAL);
/* We're out of specifiers and we still haven't generated an
instance. At least try the fallback ... If this fails,
then we just return Qunbound. */
if (no_fallback || NILP (sp->fallback))
/* I said, I don't want the fallbacks. */
return Qunbound;
if (SPECIFIERP (sp->fallback))
{
/* If you introduced loops in the default specifier chain,
then you're fucked, so you better not do this. */
specifier = sp->fallback;
sp = XSPECIFIER (specifier);
goto try_again;
}
assert (CONSP (sp->fallback));
return specifier_instance_from_inst_list (specifier, domain, sp->fallback,
no_error_or_quit);
}
#undef CHECK_INSTANCE_ENTRY
Lisp_Object
specifier_instance_no_quit (Lisp_Object specifier, Lisp_Object domain,
int no_fallback)
{
return specifier_instance (specifier, domain, 1, no_fallback);
}
DEFUN ("specifier-instance", Fspecifier_instance, Sspecifier_instance,
1, 4, 0,
"Instantiate SPECIFIER (return its value) in DOMAIN.\n\
If no instance can be generated for this domain, return DEFAULT.\n\
\n\
DOMAIN should be a window, frame, or device. Other values that are legal\n\
as a locale (e.g. a buffer) are not valid as a domain because they do not\n\
provide enough information to identify a particular device (see\n\
`valid-specifier-domain-p'). DOMAIN defaults to the selected window\n\
if omitted.\n\
\n\
\"Instantiating\" a specifier in a particular domain means determining\n\
the specifier's \"value\" in that domain. This is accomplished by\n\
searching through the specifications in the specifier that correspond\n\
to all locales that can be derived from the given domain, from specific\n\
to general. In most cases, the domain is an Emacs window. In that case\n\
specifications are searched for as follows:\n\
\n\
1. A specification whose locale is the window's buffer;\n\
2. A specification whose locale is the window itself;\n\
3. A specification whose locale is the window's frame;\n\
4. A specification whose locale is the window's frame's device;\n\
5. A specification whose locale is 'global.\n\
\n\
If all of those fail, then the C-code-provided fallback value for\n\
this specifier is consulted (see `specifier-fallback'). If it is\n\
an inst-list, then this function attempts to instantiate that list\n\
just as when a specification is located in the first five steps above.\n\
If the fallback is a specifier, `specifier-instance' is called\n\
recursively on this specifier and the return value used. Note,\n\
however, that if the optional argument NO-FALLBACK is non-nil,\n\
the fallback value will not be consulted.\n\
\n\
Note that there may be more than one specification matching a particular\n\
locale; all such specifications are considered before looking for any\n\
specifications for more general locales. Any particular specification\n\
that is found may be rejected because its tag set does not match the\n\
device being instantiated over, or because the specification is not\n\
valid for the device of the given domain (e.g. the font or color name\n\
does not exist for this particular X server).\n\
\n\
The returned value is dependent on the type of specifier. For example,\n\
for a font specifier (as returned by the `face-font' function), the returned\n\
value will be a font-instance object. For glyphs, the returned value\n\
will be a string, pixmap, or subwindow.")
(specifier, domain, defalt, no_fallback)
Lisp_Object specifier, domain, defalt, no_fallback;
{
Lisp_Object instance;
CHECK_SPECIFIER (specifier, 0);
domain = decode_domain (domain);
instance = specifier_instance (specifier, domain, 0, !NILP (no_fallback));
if (EQ (instance, Qunbound))
return defalt;
return instance;
}
DEFUN ("specifier-instance-from-inst-list", Fspecifier_instance_from_inst_list,
Sspecifier_instance_from_inst_list, 3, 4, 0,
"Attempt to convert a particular inst-list into an instance.\n\
This attempts to instantiate INST-LIST in the given DOMAIN,\n\
as if INST-LIST existed in a specification in SPECIFIER. If\n\
the instantiation fails, DEFAULT is returned. In most circumstances,\n\
you should not use this function; use `specifier-instance' instead.")
(specifier, domain, inst_list, defalt)
Lisp_Object specifier, domain, inst_list, defalt;
{
Lisp_Object val = Qunbound;
struct Lisp_Specifier *sp = XSPECIFIER (specifier);
struct gcpro gcpro1;
Lisp_Object built_up_list = Qnil;
CHECK_SPECIFIER (specifier, 0);
check_valid_domain (domain);
check_valid_inst_list (inst_list, sp->methods, 0);
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, domain,
built_up_list, 0);
UNGCPRO;
if (EQ (val, Qunbound))
return defalt;
return val;
}
/************************************************************************/
/* Caching in the struct window or frame */
/************************************************************************/
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);
if (!sp->caching)
sp->caching = malloc_type_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);
recompute_cached_specifier_everywhere (specifier);
}
static void
recompute_one_cached_specifier_in_window (Lisp_Object specifier,
struct window *w)
{
Lisp_Object window = Qnil;
Lisp_Object newval, *location;
XSETWINDOW (window, w);
newval = specifier_instance (specifier, window, 0, 0);
/* 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 = Qnil;
Lisp_Object newval, *location;
XSETFRAME (frame, f);
newval = specifier_instance (specifier, frame, 0, 0);
/* 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 devcons, frmcons;
if (!XSPECIFIER (specifier)->caching)
return;
if (XSPECIFIER (specifier)->caching->offset_into_struct_window)
{
DEVICE_AND_FRAME_LOOP (devcons, frmcons)
map_windows (XFRAME (XCAR (frmcons)),
recompute_cached_specifier_everywhere_mapfun,
LISP_TO_VOID (specifier));
}
if (XSPECIFIER (specifier)->caching->offset_into_struct_frame)
{
DEVICE_AND_FRAME_LOOP (devcons, frmcons)
recompute_one_cached_specifier_in_frame (specifier,
XFRAME (XCAR (frmcons)));
}
}
/************************************************************************/
/* 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.13.
*/
"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,
Sgeneric_specifier_p, 1, 1, 0,
"Return non-nil if OBJECT is a generic specifier.\n\
\n\
A generic specifier allows any kind of Lisp object as an instantiator,\n\
and returns back the Lisp object unchanged when it is instantiated.")
(object)
Lisp_Object object;
{
return (GENERIC_SPECIFIERP (object) ? Qt : Qnil);
}
/************************************************************************/
/* Integer specifier type */
/************************************************************************/
DEFINE_SPECIFIER_TYPE (integer);
static int
integer_validate (Lisp_Object instantiator, int no_error)
{
if (!no_error)
CHECK_INT (instantiator, 0);
return INTP (instantiator);
}
DEFUN ("integer-specifier-p", Finteger_specifier_p,
Sinteger_specifier_p, 1, 1, 0,
"Return non-nil if OBJECT is an integer specifier.")
(object)
Lisp_Object object;
{
return (INTEGER_SPECIFIERP (object) ? Qt : Qnil);
}
/************************************************************************/
/* Non-negative-integer specifier type */
/************************************************************************/
DEFINE_SPECIFIER_TYPE (natnum);
static int
natnum_validate (Lisp_Object instantiator, int no_error)
{
if (!no_error)
CHECK_NATNUM (instantiator, 0);
return NATNUMP (instantiator);
}
DEFUN ("natnum-specifier-p", Fnatnum_specifier_p,
Snatnum_specifier_p, 1, 1, 0,
"Return non-nil if OBJECT is a natnum (non-negative-integer) specifier.")
(object)
Lisp_Object object;
{
return (NATNUM_SPECIFIERP (object) ? Qt : Qnil);
}
/************************************************************************/
/* Boolean specifier type */
/************************************************************************/
DEFINE_SPECIFIER_TYPE (boolean);
static int
boolean_validate (Lisp_Object instantiator, int no_error)
{
int retval = EQ (instantiator, Qt) || EQ (instantiator, Qnil);
if (!retval && !no_error)
signal_simple_error ("Must be t or nil", instantiator);
return retval;
}
DEFUN ("boolean-specifier-p", Fboolean_specifier_p,
Sboolean_specifier_p, 1, 1, 0,
"Return non-nil if OBJECT is an boolean specifier.")
(object)
Lisp_Object object;
{
return (BOOLEAN_SPECIFIERP (object) ? Qt : Qnil);
}
/************************************************************************/
/* Initialization */
/************************************************************************/
void
syms_of_specifier (void)
{
defsymbol (&Qspecifierp, "specifierp");
defsymbol (&Qdevice_type, "device-type");
defsymbol (&Qdevice_class, "device-class");
defsymbol (&Qgeneric, "generic");
/* Qinteger, Qboolean defined in general.c */
defsymbol (&Qnatnum, "natnum");
defsubr (&Svalid_specifier_type_p);
defsubr (&Sspecifier_type_list);
defsubr (&Smake_specifier);
defsubr (&Sspecifierp);
defsubr (&Sspecifier_type);
defsubr (&Svalid_specifier_locale_p);
defsubr (&Svalid_specifier_domain_p);
defsubr (&Svalid_specifier_locale_type_p);
defsubr (&Sspecifier_locale_type_from_locale);
defsubr (&Svalid_specifier_tag_p);
defsubr (&Svalid_specifier_tag_set_p);
defsubr (&Scanonicalize_tag_set);
defsubr (&Sdevice_matches_specifier_tag_set_p);
defsubr (&Sdefine_specifier_tag);
defsubr (&Sdevice_matching_specifier_tag_list);
defsubr (&Sspecifier_tag_list);
defsubr (&Sspecifier_tag_predicate);
defsubr (&Scheck_valid_instantiator);
defsubr (&Svalid_instantiator_p);
defsubr (&Scheck_valid_inst_list);
defsubr (&Svalid_inst_list_p);
defsubr (&Scheck_valid_spec_list);
defsubr (&Svalid_spec_list_p);
defsubr (&Sadd_spec_to_specifier);
defsubr (&Sadd_spec_list_to_specifier);
defsubr (&Sspecifier_spec_list);
defsubr (&Sspecifier_specs);
defsubr (&Sremove_specifier);
defsubr (&Scopy_specifier);
defsubr (&Sspecifier_fallback);
defsubr (&Sspecifier_instance);
defsubr (&Sspecifier_instance_from_inst_list);
defsubr (&Sgeneric_specifier_p);
defsubr (&Sinteger_specifier_p);
defsubr (&Snatnum_specifier_p);
defsubr (&Sboolean_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 (struct specifier_type_entry);
Vspecifier_type_list = Qnil;
staticpro (&Vspecifier_type_list);
INITIALIZE_SPECIFIER_TYPE (generic, "generic", "generic-specifier-p");
INITIALIZE_SPECIFIER_TYPE (integer, "integer", "integer-specifier-p");
SPECIFIER_HAS_METHOD (integer, validate);
INITIALIZE_SPECIFIER_TYPE (natnum, "natnum", "natnum-specifier-p");
SPECIFIER_HAS_METHOD (natnum, validate);
INITIALIZE_SPECIFIER_TYPE (boolean, "boolean", "boolean-specifier-p");
SPECIFIER_HAS_METHOD (boolean, validate);
}
void
vars_of_specifier (void)
{
Vcached_specifiers = Qnil;
staticpro (&Vcached_specifiers);
/* Do NOT mark through this, or specifiers will never be GC'd.
This is the same deal as for weak hashtables. */
Vall_specifiers = Qnil;
Vuser_defined_tags = Qnil;
staticpro (&Vuser_defined_tags);
}
These are the contents of the former NiCE NeXT User Group NeXTSTEP/OpenStep software archive, currently hosted by Netfuture.ch.