Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with
or
.
Download ZIP
Tree: 422281c0da
Fetching contributors…

Cannot retrieve contributors at this time

7154 lines (6008 sloc) 213.178 kB
/* xfaces.c -- "Face" primitives.
Copyright (C) 1993, 1994, 1998, 1999, 2000, 2001, 2002, 2003, 2004,
2005, 2006, 2007, 2008, 2009, 2010, 2011, 2012 Free Software Foundation, Inc.
This file is part of GNU Emacs.
GNU Emacs 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 3 of the License, or
(at your option) any later version.
GNU Emacs 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 GNU Emacs. If not, see <http://www.gnu.org/licenses/>. */
/* New face implementation by Gerd Moellmann <gerd@gnu.org>. */
/* Faces.
When using Emacs with X, the display style of characters can be
changed by defining `faces'. Each face can specify the following
display attributes:
1. Font family name.
2. Font foundary name.
3. Relative proportionate width, aka character set width or set
width (swidth), e.g. `semi-compressed'.
4. Font height in 1/10pt.
5. Font weight, e.g. `bold'.
6. Font slant, e.g. `italic'.
7. Foreground color.
8. Background color.
9. Whether or not characters should be underlined, and in what color.
10. Whether or not characters should be displayed in inverse video.
11. A background stipple, a bitmap.
12. Whether or not characters should be overlined, and in what color.
13. Whether or not characters should be strike-through, and in what
color.
14. Whether or not a box should be drawn around characters, the box
type, and, for simple boxes, in what color.
15. Font-spec, or nil. This is a special attribute.
A font-spec is a collection of font attributes (specs).
When this attribute is specified, the face uses a font matching
with the specs as is except for what overwritten by the specs in
the fontset (see below). In addition, the other font-related
attributes (1st thru 5th) are updated from the spec.
On the other hand, if one of the other font-related attributes are
specified, the correspoinding specs in this attribute is set to nil.
15. A face name or list of face names from which to inherit attributes.
16. A specified average font width, which is invisible from Lisp,
and is used to ensure that a font specified on the command line,
for example, can be matched exactly.
17. A fontset name. This is another special attribute.
A fontset is a mappings from characters to font-specs, and the
specs overwrite the font-spec in the 14th attribute.
Faces are frame-local by nature because Emacs allows to define the
same named face (face names are symbols) differently for different
frames. Each frame has an alist of face definitions for all named
faces. The value of a named face in such an alist is a Lisp vector
with the symbol `face' in slot 0, and a slot for each of the face
attributes mentioned above.
There is also a global face alist `Vface_new_frame_defaults'. Face
definitions from this list are used to initialize faces of newly
created frames.
A face doesn't have to specify all attributes. Those not specified
have a value of `unspecified'. Faces specifying all attributes but
the 14th are called `fully-specified'.
Face merging.
The display style of a given character in the text is determined by
combining several faces. This process is called `face merging'.
Any aspect of the display style that isn't specified by overlays or
text properties is taken from the `default' face. Since it is made
sure that the default face is always fully-specified, face merging
always results in a fully-specified face.
Face realization.
After all face attributes for a character have been determined by
merging faces of that character, that face is `realized'. The
realization process maps face attributes to what is physically
available on the system where Emacs runs. The result is a
`realized face' in form of a struct face which is stored in the
face cache of the frame on which it was realized.
Face realization is done in the context of the character to display
because different fonts may be used for different characters. In
other words, for characters that have different font
specifications, different realized faces are needed to display
them.
Font specification is done by fontsets. See the comment in
fontset.c for the details. In the current implementation, all ASCII
characters share the same font in a fontset.
Faces are at first realized for ASCII characters, and, at that
time, assigned a specific realized fontset. Hereafter, we call
such a face as `ASCII face'. When a face for a multibyte character
is realized, it inherits (thus shares) a fontset of an ASCII face
that has the same attributes other than font-related ones.
Thus, all realized faces have a realized fontset.
Unibyte text.
Unibyte text (i.e. raw 8-bit characters) is displayed with the same
font as ASCII characters. That is because it is expected that
unibyte text users specify a font that is suitable both for ASCII
and raw 8-bit characters.
Font selection.
Font selection tries to find the best available matching font for a
given (character, face) combination.
If the face specifies a fontset name, that fontset determines a
pattern for fonts of the given character. If the face specifies a
font name or the other font-related attributes, a fontset is
realized from the default fontset. In that case, that
specification determines a pattern for ASCII characters and the
default fontset determines a pattern for multibyte characters.
Available fonts on the system on which Emacs runs are then matched
against the font pattern. The result of font selection is the best
match for the given face attributes in this font list.
Font selection can be influenced by the user.
1. The user can specify the relative importance he gives the face
attributes width, height, weight, and slant by setting
face-font-selection-order (faces.el) to a list of face attribute
names. The default is '(:width :height :weight :slant), and means
that font selection first tries to find a good match for the font
width specified by a face, then---within fonts with that
width---tries to find a best match for the specified font height,
etc.
2. Setting face-font-family-alternatives allows the user to
specify alternative font families to try if a family specified by a
face doesn't exist.
3. Setting face-font-registry-alternatives allows the user to
specify all alternative font registries to try for a face
specifying a registry.
4. Setting face-ignored-fonts allows the user to ignore specific
fonts.
Character composition.
Usually, the realization process is already finished when Emacs
actually reflects the desired glyph matrix on the screen. However,
on displaying a composition (sequence of characters to be composed
on the screen), a suitable font for the components of the
composition is selected and realized while drawing them on the
screen, i.e. the realization process is delayed but in principle
the same.
Initialization of basic faces.
The faces `default', `modeline' are considered `basic faces'.
When redisplay happens the first time for a newly created frame,
basic faces are realized for CHARSET_ASCII. Frame parameters are
used to fill in unspecified attributes of the default face. */
#include <config.h>
#include <stdio.h>
#include <sys/types.h>
#include <sys/stat.h>
#include <stdio.h> /* This needs to be before termchar.h */
#include <setjmp.h>
#include "lisp.h"
#include "character.h"
#include "charset.h"
#include "keyboard.h"
#include "frame.h"
#include "termhooks.h"
#ifdef HAVE_X_WINDOWS
#include "xterm.h"
#ifdef USE_MOTIF
#include <Xm/Xm.h>
#include <Xm/XmStrDefs.h>
#endif /* USE_MOTIF */
#endif /* HAVE_X_WINDOWS */
#ifdef MSDOS
#include "dosfns.h"
#endif
#ifdef WINDOWSNT
#include "w32term.h"
#include "fontset.h"
/* Redefine X specifics to W32 equivalents to avoid cluttering the
code with #ifdef blocks. */
#undef FRAME_X_DISPLAY_INFO
#define FRAME_X_DISPLAY_INFO FRAME_W32_DISPLAY_INFO
#define x_display_info w32_display_info
#define FRAME_X_FONT_TABLE FRAME_W32_FONT_TABLE
#define check_x check_w32
#define GCGraphicsExposures 0
#endif /* WINDOWSNT */
#ifdef HAVE_NS
#include "nsterm.h"
#undef FRAME_X_DISPLAY_INFO
#define FRAME_X_DISPLAY_INFO FRAME_NS_DISPLAY_INFO
#define x_display_info ns_display_info
#define FRAME_X_FONT_TABLE FRAME_NS_FONT_TABLE
#define check_x check_ns
#define GCGraphicsExposures 0
#endif /* HAVE_NS */
#include "buffer.h"
#include "dispextern.h"
#include "blockinput.h"
#include "window.h"
#include "intervals.h"
#include "termchar.h"
#include "font.h"
#ifdef HAVE_WINDOW_SYSTEM
#include "fontset.h"
#endif /* HAVE_WINDOW_SYSTEM */
#ifdef HAVE_X_WINDOWS
/* Compensate for a bug in Xos.h on some systems, on which it requires
time.h. On some such systems, Xos.h tries to redefine struct
timeval and struct timezone if USG is #defined while it is
#included. */
#ifdef XOS_NEEDS_TIME_H
#include <time.h>
#undef USG
#include <X11/Xos.h>
#define USG
#define __TIMEVAL__
#else /* not XOS_NEEDS_TIME_H */
#include <X11/Xos.h>
#endif /* not XOS_NEEDS_TIME_H */
#endif /* HAVE_X_WINDOWS */
#include <ctype.h>
/* Number of pt per inch (from the TeXbook). */
#define PT_PER_INCH 72.27
/* Non-zero if face attribute ATTR is unspecified. */
#define UNSPECIFIEDP(ATTR) EQ ((ATTR), Qunspecified)
/* Non-zero if face attribute ATTR is `ignore-defface'. */
#define IGNORE_DEFFACE_P(ATTR) EQ ((ATTR), Qignore_defface)
/* Value is the number of elements of VECTOR. */
#define DIM(VECTOR) (sizeof (VECTOR) / sizeof *(VECTOR))
/* Make a copy of string S on the stack using alloca. Value is a pointer
to the copy. */
#define STRDUPA(S) strcpy ((char *) alloca (strlen ((S)) + 1), (S))
/* Make a copy of the contents of Lisp string S on the stack using
alloca. Value is a pointer to the copy. */
#define LSTRDUPA(S) STRDUPA (SDATA ((S)))
/* Size of hash table of realized faces in face caches (should be a
prime number). */
#define FACE_CACHE_BUCKETS_SIZE 1001
/* Keyword symbols used for face attribute names. */
Lisp_Object QCfamily, QCheight, QCweight, QCslant, QCunderline;
Lisp_Object QCinverse_video, QCforeground, QCbackground, QCstipple;
Lisp_Object QCwidth, QCfont, QCbold, QCitalic;
Lisp_Object QCreverse_video;
Lisp_Object QCoverline, QCstrike_through, QCbox, QCinherit;
Lisp_Object QCfontset;
/* Keywords symbols used for font properties. */
extern Lisp_Object QCfoundry, QCadstyle, QCregistry;
extern Lisp_Object QCspacing, QCsize, QCavgwidth;
extern Lisp_Object Qp;
/* Symbols used for attribute values. */
Lisp_Object Qnormal, Qbold, Qultra_light, Qextra_light, Qlight;
Lisp_Object Qsemi_light, Qsemi_bold, Qextra_bold, Qultra_bold;
Lisp_Object Qoblique, Qitalic, Qreverse_oblique, Qreverse_italic;
Lisp_Object Qultra_condensed, Qextra_condensed, Qcondensed;
Lisp_Object Qsemi_condensed, Qsemi_expanded, Qexpanded, Qextra_expanded;
Lisp_Object Qultra_expanded;
Lisp_Object Qreleased_button, Qpressed_button;
Lisp_Object QCstyle, QCcolor, QCline_width;
Lisp_Object Qunspecified;
Lisp_Object Qignore_defface;
char unspecified_fg[] = "unspecified-fg", unspecified_bg[] = "unspecified-bg";
/* The name of the function to call when the background of the frame
has changed, frame_set_background_mode. */
Lisp_Object Qframe_set_background_mode;
/* Names of basic faces. */
Lisp_Object Qdefault, Qtool_bar, Qregion, Qfringe;
Lisp_Object Qheader_line, Qscroll_bar, Qcursor, Qborder, Qmouse, Qmenu;
Lisp_Object Qmode_line_inactive, Qvertical_border;
extern Lisp_Object Qmode_line;
/* The symbol `face-alias'. A symbols having that property is an
alias for another face. Value of the property is the name of
the aliased face. */
Lisp_Object Qface_alias;
extern Lisp_Object Qcircular_list;
/* Default stipple pattern used on monochrome displays. This stipple
pattern is used on monochrome displays instead of shades of gray
for a face background color. See `set-face-stipple' for possible
values for this variable. */
Lisp_Object Vface_default_stipple;
/* Alist of alternative font families. Each element is of the form
(FAMILY FAMILY1 FAMILY2 ...). If fonts of FAMILY can't be loaded,
try FAMILY1, then FAMILY2, ... */
Lisp_Object Vface_alternative_font_family_alist;
/* Alist of alternative font registries. Each element is of the form
(REGISTRY REGISTRY1 REGISTRY2...). If fonts of REGISTRY can't be
loaded, try REGISTRY1, then REGISTRY2, ... */
Lisp_Object Vface_alternative_font_registry_alist;
/* Allowed scalable fonts. A value of nil means don't allow any
scalable fonts. A value of t means allow the use of any scalable
font. Otherwise, value must be a list of regular expressions. A
font may be scaled if its name matches a regular expression in the
list. */
Lisp_Object Vscalable_fonts_allowed, Qscalable_fonts_allowed;
/* List of regular expressions that matches names of fonts to ignore. */
Lisp_Object Vface_ignored_fonts;
/* Alist of font name patterns vs the rescaling factor. */
Lisp_Object Vface_font_rescale_alist;
/* Maximum number of fonts to consider in font_list. If not an
integer > 0, DEFAULT_FONT_LIST_LIMIT is used instead. */
Lisp_Object Vfont_list_limit;
#define DEFAULT_FONT_LIST_LIMIT 100
/* The symbols `foreground-color' and `background-color' which can be
used as part of a `face' property. This is for compatibility with
Emacs 20.2. */
Lisp_Object Qforeground_color, Qbackground_color;
/* The symbols `face' and `mouse-face' used as text properties. */
Lisp_Object Qface;
extern Lisp_Object Qmouse_face;
/* Property for basic faces which other faces cannot inherit. */
Lisp_Object Qface_no_inherit;
/* Error symbol for wrong_type_argument in load_pixmap. */
Lisp_Object Qbitmap_spec_p;
/* Alist of global face definitions. Each element is of the form
(FACE . LFACE) where FACE is a symbol naming a face and LFACE
is a Lisp vector of face attributes. These faces are used
to initialize faces for new frames. */
Lisp_Object Vface_new_frame_defaults;
/* Alist of face remappings. Each element is of the form:
(FACE REPLACEMENT...) which causes display of the face FACE to use
REPLACEMENT... instead. REPLACEMENT... is interpreted the same way
the value of a `face' text property is: it may be (1) A face name,
(2) A list of face names, (3) A property-list of face attribute/value
pairs, or (4) A list of face names intermixed with lists containing
face attribute/value pairs.
Multiple entries in REPLACEMENT... are merged together to form the final
result, with faces or attributes earlier in the list taking precedence
over those that are later.
Face-name remapping cycles are suppressed; recursive references use
the underlying face instead of the remapped face. */
Lisp_Object Vface_remapping_alist;
/* Alist of face remappings. Each element is of the form:
(FACE REPLACEMENT...) which causes display of the face FACE to use
REPLACEMENT... instead. REPLACEMENT... is interpreted the same way
the value of a `face' text property is: it may be (1) A face name,
(2) A list of face names, (3) A property-list of face attribute/value
pairs, or (4) A list of face names intermixed with lists containing
face attribute/value pairs.
Multiple entries in REPLACEMENT... are merged together to form the final
result, with faces or attributes earlier in the list taking precedence
over those that are later.
Face-name remapping cycles are suppressed; recursive references use
the underlying face instead of the remapped face. */
Lisp_Object Vface_remapping_alist;
/* The next ID to assign to Lisp faces. */
static int next_lface_id;
/* A vector mapping Lisp face Id's to face names. */
static Lisp_Object *lface_id_to_name;
static int lface_id_to_name_size;
/* TTY color-related functions (defined in tty-colors.el). */
Lisp_Object Qtty_color_desc, Qtty_color_by_index, Qtty_color_standard_values;
/* The name of the function used to compute colors on TTYs. */
Lisp_Object Qtty_color_alist;
/* An alist of defined terminal colors and their RGB values. */
Lisp_Object Vtty_defined_color_alist;
/* Counter for calls to clear_face_cache. If this counter reaches
CLEAR_FONT_TABLE_COUNT, and a frame has more than
CLEAR_FONT_TABLE_NFONTS load, unused fonts are freed. */
static int clear_font_table_count;
#define CLEAR_FONT_TABLE_COUNT 100
#define CLEAR_FONT_TABLE_NFONTS 10
/* Non-zero means face attributes have been changed since the last
redisplay. Used in redisplay_internal. */
int face_change_count;
/* Non-zero means don't display bold text if a face's foreground
and background colors are the inverse of the default colors of the
display. This is a kluge to suppress `bold black' foreground text
which is hard to read on an LCD monitor. */
int tty_suppress_bold_inverse_default_colors_p;
/* A list of the form `((x . y))' used to avoid consing in
Finternal_set_lisp_face_attribute. */
static Lisp_Object Vparam_value_alist;
/* The total number of colors currently allocated. */
#if GLYPH_DEBUG
static int ncolors_allocated;
static int npixmaps_allocated;
static int ngcs;
#endif
/* Non-zero means the definition of the `menu' face for new frames has
been changed. */
int menu_face_changed_default;
/* Function prototypes. */
struct table_entry;
struct named_merge_point;
static void map_tty_color P_ ((struct frame *, struct face *,
enum lface_attribute_index, int *));
static Lisp_Object resolve_face_name P_ ((Lisp_Object, int));
static int may_use_scalable_font_p P_ ((const char *));
static void set_font_frame_param P_ ((Lisp_Object, Lisp_Object));
static int get_lface_attributes P_ ((struct frame *, Lisp_Object, Lisp_Object *,
int, struct named_merge_point *));
static int load_pixmap P_ ((struct frame *, Lisp_Object, unsigned *, unsigned *));
static struct frame *frame_or_selected_frame P_ ((Lisp_Object, int));
static void load_face_colors P_ ((struct frame *, struct face *, Lisp_Object *));
static void free_face_colors P_ ((struct frame *, struct face *));
static int face_color_gray_p P_ ((struct frame *, char *));
static struct face *realize_face P_ ((struct face_cache *, Lisp_Object *,
int));
static struct face *realize_non_ascii_face P_ ((struct frame *, Lisp_Object,
struct face *));
static struct face *realize_x_face P_ ((struct face_cache *, Lisp_Object *));
static struct face *realize_tty_face P_ ((struct face_cache *, Lisp_Object *));
static int realize_basic_faces P_ ((struct frame *));
static int realize_default_face P_ ((struct frame *));
static void realize_named_face P_ ((struct frame *, Lisp_Object, int));
static int lface_fully_specified_p P_ ((Lisp_Object *));
static int lface_equal_p P_ ((Lisp_Object *, Lisp_Object *));
static unsigned hash_string_case_insensitive P_ ((Lisp_Object));
static unsigned lface_hash P_ ((Lisp_Object *));
static int lface_same_font_attributes_p P_ ((Lisp_Object *, Lisp_Object *));
static struct face_cache *make_face_cache P_ ((struct frame *));
static void clear_face_gcs P_ ((struct face_cache *));
static void free_face_cache P_ ((struct face_cache *));
static int face_fontset P_ ((Lisp_Object *));
static void merge_face_vectors P_ ((struct frame *, Lisp_Object *, Lisp_Object*,
struct named_merge_point *));
static int merge_face_ref P_ ((struct frame *, Lisp_Object, Lisp_Object *,
int, struct named_merge_point *));
static int set_lface_from_font P_ ((struct frame *, Lisp_Object, Lisp_Object,
int));
static Lisp_Object lface_from_face_name P_ ((struct frame *, Lisp_Object, int));
static struct face *make_realized_face P_ ((Lisp_Object *));
static void cache_face P_ ((struct face_cache *, struct face *, unsigned));
static void uncache_face P_ ((struct face_cache *, struct face *));
#ifdef HAVE_WINDOW_SYSTEM
static GC x_create_gc P_ ((struct frame *, unsigned long, XGCValues *));
static void x_free_gc P_ ((struct frame *, GC));
#ifdef USE_X_TOOLKIT
static void x_update_menu_appearance P_ ((struct frame *));
extern void free_frame_menubar P_ ((struct frame *));
#endif /* USE_X_TOOLKIT */
#endif /* HAVE_WINDOW_SYSTEM */
/***********************************************************************
Utilities
***********************************************************************/
#ifdef HAVE_X_WINDOWS
#ifdef DEBUG_X_COLORS
/* The following is a poor mans infrastructure for debugging X color
allocation problems on displays with PseudoColor-8. Some X servers
like 3.3.5 XF86_SVGA with Matrox cards apparently don't implement
color reference counts completely so that they don't signal an
error when a color is freed whose reference count is already 0.
Other X servers do. To help me debug this, the following code
implements a simple reference counting schema of its own, for a
single display/screen. --gerd. */
/* Reference counts for pixel colors. */
int color_count[256];
/* Register color PIXEL as allocated. */
void
register_color (pixel)
unsigned long pixel;
{
xassert (pixel < 256);
++color_count[pixel];
}
/* Register color PIXEL as deallocated. */
void
unregister_color (pixel)
unsigned long pixel;
{
xassert (pixel < 256);
if (color_count[pixel] > 0)
--color_count[pixel];
else
abort ();
}
/* Register N colors from PIXELS as deallocated. */
void
unregister_colors (pixels, n)
unsigned long *pixels;
int n;
{
int i;
for (i = 0; i < n; ++i)
unregister_color (pixels[i]);
}
DEFUN ("dump-colors", Fdump_colors, Sdump_colors, 0, 0, 0,
doc: /* Dump currently allocated colors to stderr. */)
()
{
int i, n;
fputc ('\n', stderr);
for (i = n = 0; i < sizeof color_count / sizeof color_count[0]; ++i)
if (color_count[i])
{
fprintf (stderr, "%3d: %5d", i, color_count[i]);
++n;
if (n % 5 == 0)
fputc ('\n', stderr);
else
fputc ('\t', stderr);
}
if (n % 5 != 0)
fputc ('\n', stderr);
return Qnil;
}
#endif /* DEBUG_X_COLORS */
/* Free colors used on frame F. PIXELS is an array of NPIXELS pixel
color values. Interrupt input must be blocked when this function
is called. */
void
x_free_colors (f, pixels, npixels)
struct frame *f;
unsigned long *pixels;
int npixels;
{
int class = FRAME_X_DISPLAY_INFO (f)->visual->class;
/* If display has an immutable color map, freeing colors is not
necessary and some servers don't allow it. So don't do it. */
if (class != StaticColor && class != StaticGray && class != TrueColor)
{
#ifdef DEBUG_X_COLORS
unregister_colors (pixels, npixels);
#endif
XFreeColors (FRAME_X_DISPLAY (f), FRAME_X_COLORMAP (f),
pixels, npixels, 0);
}
}
/* Free colors used on frame F. PIXELS is an array of NPIXELS pixel
color values. Interrupt input must be blocked when this function
is called. */
void
x_free_dpy_colors (dpy, screen, cmap, pixels, npixels)
Display *dpy;
Screen *screen;
Colormap cmap;
unsigned long *pixels;
int npixels;
{
struct x_display_info *dpyinfo = x_display_info_for_display (dpy);
int class = dpyinfo->visual->class;
/* If display has an immutable color map, freeing colors is not
necessary and some servers don't allow it. So don't do it. */
if (class != StaticColor && class != StaticGray && class != TrueColor)
{
#ifdef DEBUG_X_COLORS
unregister_colors (pixels, npixels);
#endif
XFreeColors (dpy, cmap, pixels, npixels, 0);
}
}
/* Create and return a GC for use on frame F. GC values and mask
are given by XGCV and MASK. */
static INLINE GC
x_create_gc (f, mask, xgcv)
struct frame *f;
unsigned long mask;
XGCValues *xgcv;
{
GC gc;
BLOCK_INPUT;
gc = XCreateGC (FRAME_X_DISPLAY (f), FRAME_X_WINDOW (f), mask, xgcv);
UNBLOCK_INPUT;
IF_DEBUG (++ngcs);
return gc;
}
/* Free GC which was used on frame F. */
static INLINE void
x_free_gc (f, gc)
struct frame *f;
GC gc;
{
eassert (interrupt_input_blocked);
IF_DEBUG (xassert (--ngcs >= 0));
XFreeGC (FRAME_X_DISPLAY (f), gc);
}
#endif /* HAVE_X_WINDOWS */
#ifdef WINDOWSNT
/* W32 emulation of GCs */
static INLINE GC
x_create_gc (f, mask, xgcv)
struct frame *f;
unsigned long mask;
XGCValues *xgcv;
{
GC gc;
BLOCK_INPUT;
gc = XCreateGC (NULL, FRAME_W32_WINDOW (f), mask, xgcv);
UNBLOCK_INPUT;
IF_DEBUG (++ngcs);
return gc;
}
/* Free GC which was used on frame F. */
static INLINE void
x_free_gc (f, gc)
struct frame *f;
GC gc;
{
IF_DEBUG (xassert (--ngcs >= 0));
xfree (gc);
}
#endif /* WINDOWSNT */
#ifdef HAVE_NS
/* NS emulation of GCs */
static INLINE GC
x_create_gc (f, mask, xgcv)
struct frame *f;
unsigned long mask;
XGCValues *xgcv;
{
GC gc = xmalloc (sizeof (*gc));
if (gc)
bcopy(xgcv, gc, sizeof(XGCValues));
return gc;
}
static INLINE void
x_free_gc (f, gc)
struct frame *f;
GC gc;
{
xfree (gc);
}
#endif /* HAVE_NS */
/* Like strcasecmp/stricmp. Used to compare parts of font names which
are in ISO8859-1. */
int
xstrcasecmp (s1, s2)
const unsigned char *s1, *s2;
{
while (*s1 && *s2)
{
unsigned char c1 = tolower (*s1);
unsigned char c2 = tolower (*s2);
if (c1 != c2)
return c1 < c2 ? -1 : 1;
++s1, ++s2;
}
if (*s1 == 0)
return *s2 == 0 ? 0 : -1;
return 1;
}
/* If FRAME is nil, return a pointer to the selected frame.
Otherwise, check that FRAME is a live frame, and return a pointer
to it. NPARAM is the parameter number of FRAME, for
CHECK_LIVE_FRAME. This is here because it's a frequent pattern in
Lisp function definitions. */
static INLINE struct frame *
frame_or_selected_frame (frame, nparam)
Lisp_Object frame;
int nparam;
{
if (NILP (frame))
frame = selected_frame;
CHECK_LIVE_FRAME (frame);
return XFRAME (frame);
}
/***********************************************************************
Frames and faces
***********************************************************************/
/* Initialize face cache and basic faces for frame F. */
void
init_frame_faces (f)
struct frame *f;
{
/* Make a face cache, if F doesn't have one. */
if (FRAME_FACE_CACHE (f) == NULL)
FRAME_FACE_CACHE (f) = make_face_cache (f);
#ifdef HAVE_WINDOW_SYSTEM
/* Make the image cache. */
if (FRAME_WINDOW_P (f))
{
/* We initialize the image cache when creating the first frame
on a terminal, and not during terminal creation. This way,
`x-open-connection' on a tty won't create an image cache. */
if (FRAME_IMAGE_CACHE (f) == NULL)
FRAME_IMAGE_CACHE (f) = make_image_cache ();
++FRAME_IMAGE_CACHE (f)->refcount;
}
#endif /* HAVE_WINDOW_SYSTEM */
/* Realize basic faces. Must have enough information in frame
parameters to realize basic faces at this point. */
#ifdef HAVE_X_WINDOWS
if (!FRAME_X_P (f) || FRAME_X_WINDOW (f))
#endif
#ifdef WINDOWSNT
if (!FRAME_WINDOW_P (f) || FRAME_W32_WINDOW (f))
#endif
#ifdef HAVE_NS
if (!FRAME_NS_P (f) || FRAME_NS_WINDOW (f))
#endif
if (!realize_basic_faces (f))
abort ();
}
/* Free face cache of frame F. Called from delete_frame. */
void
free_frame_faces (f)
struct frame *f;
{
struct face_cache *face_cache = FRAME_FACE_CACHE (f);
if (face_cache)
{
free_face_cache (face_cache);
FRAME_FACE_CACHE (f) = NULL;
}
#ifdef HAVE_WINDOW_SYSTEM
if (FRAME_WINDOW_P (f))
{
struct image_cache *image_cache = FRAME_IMAGE_CACHE (f);
if (image_cache)
{
--image_cache->refcount;
if (image_cache->refcount == 0)
free_image_cache (f);
}
}
#endif /* HAVE_WINDOW_SYSTEM */
}
/* Clear face caches, and recompute basic faces for frame F. Call
this after changing frame parameters on which those faces depend,
or when realized faces have been freed due to changing attributes
of named faces. */
void
recompute_basic_faces (f)
struct frame *f;
{
if (FRAME_FACE_CACHE (f))
{
clear_face_cache (0);
if (!realize_basic_faces (f))
abort ();
}
}
/* Clear the face caches of all frames. CLEAR_FONTS_P non-zero means
try to free unused fonts, too. */
void
clear_face_cache (clear_fonts_p)
int clear_fonts_p;
{
#ifdef HAVE_WINDOW_SYSTEM
Lisp_Object tail, frame;
struct frame *f;
if (clear_fonts_p
|| ++clear_font_table_count == CLEAR_FONT_TABLE_COUNT)
{
#if 0
/* Not yet implemented. */
clear_font_cache (frame);
#endif
/* From time to time see if we can unload some fonts. This also
frees all realized faces on all frames. Fonts needed by
faces will be loaded again when faces are realized again. */
clear_font_table_count = 0;
FOR_EACH_FRAME (tail, frame)
{
struct frame *f = XFRAME (frame);
if (FRAME_WINDOW_P (f)
&& FRAME_X_DISPLAY_INFO (f)->n_fonts > CLEAR_FONT_TABLE_NFONTS)
free_all_realized_faces (frame);
}
}
else
{
/* Clear GCs of realized faces. */
FOR_EACH_FRAME (tail, frame)
{
f = XFRAME (frame);
if (FRAME_WINDOW_P (f))
clear_face_gcs (FRAME_FACE_CACHE (f));
}
clear_image_caches (Qnil);
}
#endif /* HAVE_WINDOW_SYSTEM */
}
DEFUN ("clear-face-cache", Fclear_face_cache, Sclear_face_cache, 0, 1, 0,
doc: /* Clear face caches on all frames.
Optional THOROUGHLY non-nil means try to free unused fonts, too. */)
(thoroughly)
Lisp_Object thoroughly;
{
clear_face_cache (!NILP (thoroughly));
++face_change_count;
++windows_or_buffers_changed;
return Qnil;
}
/***********************************************************************
X Pixmaps
***********************************************************************/
#ifdef HAVE_WINDOW_SYSTEM
DEFUN ("bitmap-spec-p", Fbitmap_spec_p, Sbitmap_spec_p, 1, 1, 0,
doc: /* Value is non-nil if OBJECT is a valid bitmap specification.
A bitmap specification is either a string, a file name, or a list
\(WIDTH HEIGHT DATA) where WIDTH is the pixel width of the bitmap,
HEIGHT is its height, and DATA is a string containing the bits of
the pixmap. Bits are stored row by row, each row occupies
\(WIDTH + 7)/8 bytes. */)
(object)
Lisp_Object object;
{
int pixmap_p = 0;
if (STRINGP (object))
/* If OBJECT is a string, it's a file name. */
pixmap_p = 1;
else if (CONSP (object))
{
/* Otherwise OBJECT must be (WIDTH HEIGHT DATA), WIDTH and
HEIGHT must be integers > 0, and DATA must be string large
enough to hold a bitmap of the specified size. */
Lisp_Object width, height, data;
height = width = data = Qnil;
if (CONSP (object))
{
width = XCAR (object);
object = XCDR (object);
if (CONSP (object))
{
height = XCAR (object);
object = XCDR (object);
if (CONSP (object))
data = XCAR (object);
}
}
if (NATNUMP (width) && NATNUMP (height) && STRINGP (data))
{
int bytes_per_row = ((XFASTINT (width) + BITS_PER_CHAR - 1)
/ BITS_PER_CHAR);
if (SBYTES (data) >= bytes_per_row * XINT (height))
pixmap_p = 1;
}
}
return pixmap_p ? Qt : Qnil;
}
/* Load a bitmap according to NAME (which is either a file name or a
pixmap spec) for use on frame F. Value is the bitmap_id (see
xfns.c). If NAME is nil, return with a bitmap id of zero. If
bitmap cannot be loaded, display a message saying so, and return
zero. Store the bitmap width in *W_PTR and its height in *H_PTR,
if these pointers are not null. */
static int
load_pixmap (f, name, w_ptr, h_ptr)
FRAME_PTR f;
Lisp_Object name;
unsigned int *w_ptr, *h_ptr;
{
int bitmap_id;
if (NILP (name))
return 0;
CHECK_TYPE (!NILP (Fbitmap_spec_p (name)), Qbitmap_spec_p, name);
BLOCK_INPUT;
if (CONSP (name))
{
/* Decode a bitmap spec into a bitmap. */
int h, w;
Lisp_Object bits;
w = XINT (Fcar (name));
h = XINT (Fcar (Fcdr (name)));
bits = Fcar (Fcdr (Fcdr (name)));
bitmap_id = x_create_bitmap_from_data (f, SDATA (bits),
w, h);
}
else
{
/* It must be a string -- a file name. */
bitmap_id = x_create_bitmap_from_file (f, name);
}
UNBLOCK_INPUT;
if (bitmap_id < 0)
{
add_to_log ("Invalid or undefined bitmap `%s'", name, Qnil);
bitmap_id = 0;
if (w_ptr)
*w_ptr = 0;
if (h_ptr)
*h_ptr = 0;
}
else
{
#if GLYPH_DEBUG
++npixmaps_allocated;
#endif
if (w_ptr)
*w_ptr = x_bitmap_width (f, bitmap_id);
if (h_ptr)
*h_ptr = x_bitmap_height (f, bitmap_id);
}
return bitmap_id;
}
#endif /* HAVE_WINDOW_SYSTEM */
/***********************************************************************
X Colors
***********************************************************************/
/* Parse RGB_LIST, and fill in the RGB fields of COLOR.
RGB_LIST should contain (at least) 3 lisp integers.
Return 0 if there's a problem with RGB_LIST, otherwise return 1. */
static int
parse_rgb_list (rgb_list, color)
Lisp_Object rgb_list;
XColor *color;
{
#define PARSE_RGB_LIST_FIELD(field) \
if (CONSP (rgb_list) && INTEGERP (XCAR (rgb_list))) \
{ \
color->field = XINT (XCAR (rgb_list)); \
rgb_list = XCDR (rgb_list); \
} \
else \
return 0;
PARSE_RGB_LIST_FIELD (red);
PARSE_RGB_LIST_FIELD (green);
PARSE_RGB_LIST_FIELD (blue);
return 1;
}
/* Lookup on frame F the color described by the lisp string COLOR.
The resulting tty color is returned in TTY_COLOR; if STD_COLOR is
non-zero, then the `standard' definition of the same color is
returned in it. */
static int
tty_lookup_color (f, color, tty_color, std_color)
struct frame *f;
Lisp_Object color;
XColor *tty_color, *std_color;
{
Lisp_Object frame, color_desc;
if (!STRINGP (color) || NILP (Ffboundp (Qtty_color_desc)))
return 0;
XSETFRAME (frame, f);
color_desc = call2 (Qtty_color_desc, color, frame);
if (CONSP (color_desc) && CONSP (XCDR (color_desc)))
{
Lisp_Object rgb;
if (! INTEGERP (XCAR (XCDR (color_desc))))
return 0;
tty_color->pixel = XINT (XCAR (XCDR (color_desc)));
rgb = XCDR (XCDR (color_desc));
if (! parse_rgb_list (rgb, tty_color))
return 0;
/* Should we fill in STD_COLOR too? */
if (std_color)
{
/* Default STD_COLOR to the same as TTY_COLOR. */
*std_color = *tty_color;
/* Do a quick check to see if the returned descriptor is
actually _exactly_ equal to COLOR, otherwise we have to
lookup STD_COLOR separately. If it's impossible to lookup
a standard color, we just give up and use TTY_COLOR. */
if ((!STRINGP (XCAR (color_desc))
|| NILP (Fstring_equal (color, XCAR (color_desc))))
&& !NILP (Ffboundp (Qtty_color_standard_values)))
{
/* Look up STD_COLOR separately. */
rgb = call1 (Qtty_color_standard_values, color);
if (! parse_rgb_list (rgb, std_color))
return 0;
}
}
return 1;
}
else if (NILP (Fsymbol_value (intern ("tty-defined-color-alist"))))
/* We were called early during startup, and the colors are not
yet set up in tty-defined-color-alist. Don't return a failure
indication, since this produces the annoying "Unable to
load color" messages in the *Messages* buffer. */
return 1;
else
/* tty-color-desc seems to have returned a bad value. */
return 0;
}
/* A version of defined_color for non-X frames. */
int
tty_defined_color (f, color_name, color_def, alloc)
struct frame *f;
char *color_name;
XColor *color_def;
int alloc;
{
int status = 1;
/* Defaults. */
color_def->pixel = FACE_TTY_DEFAULT_COLOR;
color_def->red = 0;
color_def->blue = 0;
color_def->green = 0;
if (*color_name)
status = tty_lookup_color (f, build_string (color_name), color_def, NULL);
if (color_def->pixel == FACE_TTY_DEFAULT_COLOR && *color_name)
{
if (strcmp (color_name, "unspecified-fg") == 0)
color_def->pixel = FACE_TTY_DEFAULT_FG_COLOR;
else if (strcmp (color_name, "unspecified-bg") == 0)
color_def->pixel = FACE_TTY_DEFAULT_BG_COLOR;
}
if (color_def->pixel != FACE_TTY_DEFAULT_COLOR)
status = 1;
return status;
}
/* Decide if color named COLOR_NAME is valid for the display
associated with the frame F; if so, return the rgb values in
COLOR_DEF. If ALLOC is nonzero, allocate a new colormap cell.
This does the right thing for any type of frame. */
int
defined_color (f, color_name, color_def, alloc)
struct frame *f;
char *color_name;
XColor *color_def;
int alloc;
{
if (!FRAME_WINDOW_P (f))
return tty_defined_color (f, color_name, color_def, alloc);
#ifdef HAVE_X_WINDOWS
else if (FRAME_X_P (f))
return x_defined_color (f, color_name, color_def, alloc);
#endif
#ifdef WINDOWSNT
else if (FRAME_W32_P (f))
return w32_defined_color (f, color_name, color_def, alloc);
#endif
#ifdef HAVE_NS
else if (FRAME_NS_P (f))
return ns_defined_color (f, color_name, color_def, alloc, 1);
#endif
else
abort ();
}
/* Given the index IDX of a tty color on frame F, return its name, a
Lisp string. */
Lisp_Object
tty_color_name (f, idx)
struct frame *f;
int idx;
{
if (idx >= 0 && !NILP (Ffboundp (Qtty_color_by_index)))
{
Lisp_Object frame;
Lisp_Object coldesc;
XSETFRAME (frame, f);
coldesc = call2 (Qtty_color_by_index, make_number (idx), frame);
if (!NILP (coldesc))
return XCAR (coldesc);
}
#ifdef MSDOS
/* We can have an MSDOG frame under -nw for a short window of
opportunity before internal_terminal_init is called. DTRT. */
if (FRAME_MSDOS_P (f) && !inhibit_window_system)
return msdos_stdcolor_name (idx);
#endif
if (idx == FACE_TTY_DEFAULT_FG_COLOR)
return build_string (unspecified_fg);
if (idx == FACE_TTY_DEFAULT_BG_COLOR)
return build_string (unspecified_bg);
return Qunspecified;
}
/* Return non-zero if COLOR_NAME is a shade of gray (or white or
black) on frame F.
The criterion implemented here is not a terribly sophisticated one. */
static int
face_color_gray_p (f, color_name)
struct frame *f;
char *color_name;
{
XColor color;
int gray_p;
if (defined_color (f, color_name, &color, 0))
gray_p = (/* Any color sufficiently close to black counts as grey. */
(color.red < 5000 && color.green < 5000 && color.blue < 5000)
||
((eabs (color.red - color.green)
< max (color.red, color.green) / 20)
&& (eabs (color.green - color.blue)
< max (color.green, color.blue) / 20)
&& (eabs (color.blue - color.red)
< max (color.blue, color.red) / 20)));
else
gray_p = 0;
return gray_p;
}
/* Return non-zero if color COLOR_NAME can be displayed on frame F.
BACKGROUND_P non-zero means the color will be used as background
color. */
static int
face_color_supported_p (f, color_name, background_p)
struct frame *f;
char *color_name;
int background_p;
{
Lisp_Object frame;
XColor not_used;
XSETFRAME (frame, f);
return
#ifdef HAVE_WINDOW_SYSTEM
FRAME_WINDOW_P (f)
? (!NILP (Fxw_display_color_p (frame))
|| xstrcasecmp (color_name, "black") == 0
|| xstrcasecmp (color_name, "white") == 0
|| (background_p
&& face_color_gray_p (f, color_name))
|| (!NILP (Fx_display_grayscale_p (frame))
&& face_color_gray_p (f, color_name)))
:
#endif
tty_defined_color (f, color_name, &not_used, 0);
}
DEFUN ("color-gray-p", Fcolor_gray_p, Scolor_gray_p, 1, 2, 0,
doc: /* Return non-nil if COLOR is a shade of gray (or white or black).
FRAME specifies the frame and thus the display for interpreting COLOR.
If FRAME is nil or omitted, use the selected frame. */)
(color, frame)
Lisp_Object color, frame;
{
struct frame *f;
CHECK_STRING (color);
if (NILP (frame))
frame = selected_frame;
else
CHECK_FRAME (frame);
f = XFRAME (frame);
return face_color_gray_p (f, SDATA (color)) ? Qt : Qnil;
}
DEFUN ("color-supported-p", Fcolor_supported_p,
Scolor_supported_p, 1, 3, 0,
doc: /* Return non-nil if COLOR can be displayed on FRAME.
BACKGROUND-P non-nil means COLOR is used as a background.
Otherwise, this function tells whether it can be used as a foreground.
If FRAME is nil or omitted, use the selected frame.
COLOR must be a valid color name. */)
(color, frame, background_p)
Lisp_Object frame, color, background_p;
{
struct frame *f;
CHECK_STRING (color);
if (NILP (frame))
frame = selected_frame;
else
CHECK_FRAME (frame);
f = XFRAME (frame);
if (face_color_supported_p (f, SDATA (color), !NILP (background_p)))
return Qt;
return Qnil;
}
/* Load color with name NAME for use by face FACE on frame F.
TARGET_INDEX must be one of LFACE_FOREGROUND_INDEX,
LFACE_BACKGROUND_INDEX, LFACE_UNDERLINE_INDEX, LFACE_OVERLINE_INDEX,
LFACE_STRIKE_THROUGH_INDEX, or LFACE_BOX_INDEX. Value is the
pixel color. If color cannot be loaded, display a message, and
return the foreground, background or underline color of F, but
record that fact in flags of the face so that we don't try to free
these colors. */
unsigned long
load_color (f, face, name, target_index)
struct frame *f;
struct face *face;
Lisp_Object name;
enum lface_attribute_index target_index;
{
XColor color;
xassert (STRINGP (name));
xassert (target_index == LFACE_FOREGROUND_INDEX
|| target_index == LFACE_BACKGROUND_INDEX
|| target_index == LFACE_UNDERLINE_INDEX
|| target_index == LFACE_OVERLINE_INDEX
|| target_index == LFACE_STRIKE_THROUGH_INDEX
|| target_index == LFACE_BOX_INDEX);
/* if the color map is full, defined_color will return a best match
to the values in an existing cell. */
if (!defined_color (f, SDATA (name), &color, 1))
{
add_to_log ("Unable to load color \"%s\"", name, Qnil);
switch (target_index)
{
case LFACE_FOREGROUND_INDEX:
face->foreground_defaulted_p = 1;
color.pixel = FRAME_FOREGROUND_PIXEL (f);
break;
case LFACE_BACKGROUND_INDEX:
face->background_defaulted_p = 1;
color.pixel = FRAME_BACKGROUND_PIXEL (f);
break;
case LFACE_UNDERLINE_INDEX:
face->underline_defaulted_p = 1;
color.pixel = FRAME_FOREGROUND_PIXEL (f);
break;
case LFACE_OVERLINE_INDEX:
face->overline_color_defaulted_p = 1;
color.pixel = FRAME_FOREGROUND_PIXEL (f);
break;
case LFACE_STRIKE_THROUGH_INDEX:
face->strike_through_color_defaulted_p = 1;
color.pixel = FRAME_FOREGROUND_PIXEL (f);
break;
case LFACE_BOX_INDEX:
face->box_color_defaulted_p = 1;
color.pixel = FRAME_FOREGROUND_PIXEL (f);
break;
default:
abort ();
}
}
#if GLYPH_DEBUG
else
++ncolors_allocated;
#endif
return color.pixel;
}
#ifdef HAVE_WINDOW_SYSTEM
/* Load colors for face FACE which is used on frame F. Colors are
specified by slots LFACE_BACKGROUND_INDEX and LFACE_FOREGROUND_INDEX
of ATTRS. If the background color specified is not supported on F,
try to emulate gray colors with a stipple from Vface_default_stipple. */
static void
load_face_colors (f, face, attrs)
struct frame *f;
struct face *face;
Lisp_Object *attrs;
{
Lisp_Object fg, bg;
bg = attrs[LFACE_BACKGROUND_INDEX];
fg = attrs[LFACE_FOREGROUND_INDEX];
/* Swap colors if face is inverse-video. */
if (EQ (attrs[LFACE_INVERSE_INDEX], Qt))
{
Lisp_Object tmp;
tmp = fg;
fg = bg;
bg = tmp;
}
/* Check for support for foreground, not for background because
face_color_supported_p is smart enough to know that grays are
"supported" as background because we are supposed to use stipple
for them. */
if (!face_color_supported_p (f, SDATA (bg), 0)
&& !NILP (Fbitmap_spec_p (Vface_default_stipple)))
{
x_destroy_bitmap (f, face->stipple);
face->stipple = load_pixmap (f, Vface_default_stipple,
&face->pixmap_w, &face->pixmap_h);
}
face->background = load_color (f, face, bg, LFACE_BACKGROUND_INDEX);
face->foreground = load_color (f, face, fg, LFACE_FOREGROUND_INDEX);
}
/* Free color PIXEL on frame F. */
void
unload_color (f, pixel)
struct frame *f;
unsigned long pixel;
{
#ifdef HAVE_X_WINDOWS
if (pixel != -1)
{
BLOCK_INPUT;
x_free_colors (f, &pixel, 1);
UNBLOCK_INPUT;
}
#endif
}
/* Free colors allocated for FACE. */
static void
free_face_colors (f, face)
struct frame *f;
struct face *face;
{
/* PENDING(NS): need to do something here? */
#ifdef HAVE_X_WINDOWS
if (face->colors_copied_bitwise_p)
return;
BLOCK_INPUT;
if (!face->foreground_defaulted_p)
{
x_free_colors (f, &face->foreground, 1);
IF_DEBUG (--ncolors_allocated);
}
if (!face->background_defaulted_p)
{
x_free_colors (f, &face->background, 1);
IF_DEBUG (--ncolors_allocated);
}
if (face->underline_p
&& !face->underline_defaulted_p)
{
x_free_colors (f, &face->underline_color, 1);
IF_DEBUG (--ncolors_allocated);
}
if (face->overline_p
&& !face->overline_color_defaulted_p)
{
x_free_colors (f, &face->overline_color, 1);
IF_DEBUG (--ncolors_allocated);
}
if (face->strike_through_p
&& !face->strike_through_color_defaulted_p)
{
x_free_colors (f, &face->strike_through_color, 1);
IF_DEBUG (--ncolors_allocated);
}
if (face->box != FACE_NO_BOX
&& !face->box_color_defaulted_p)
{
x_free_colors (f, &face->box_color, 1);
IF_DEBUG (--ncolors_allocated);
}
UNBLOCK_INPUT;
#endif /* HAVE_X_WINDOWS */
}
#endif /* HAVE_WINDOW_SYSTEM */
/***********************************************************************
XLFD Font Names
***********************************************************************/
/* An enumerator for each field of an XLFD font name. */
enum xlfd_field
{
XLFD_FOUNDRY,
XLFD_FAMILY,
XLFD_WEIGHT,
XLFD_SLANT,
XLFD_SWIDTH,
XLFD_ADSTYLE,
XLFD_PIXEL_SIZE,
XLFD_POINT_SIZE,
XLFD_RESX,
XLFD_RESY,
XLFD_SPACING,
XLFD_AVGWIDTH,
XLFD_REGISTRY,
XLFD_ENCODING,
XLFD_LAST
};
/* An enumerator for each possible slant value of a font. Taken from
the XLFD specification. */
enum xlfd_slant
{
XLFD_SLANT_UNKNOWN,
XLFD_SLANT_ROMAN,
XLFD_SLANT_ITALIC,
XLFD_SLANT_OBLIQUE,
XLFD_SLANT_REVERSE_ITALIC,
XLFD_SLANT_REVERSE_OBLIQUE,
XLFD_SLANT_OTHER
};
/* Relative font weight according to XLFD documentation. */
enum xlfd_weight
{
XLFD_WEIGHT_UNKNOWN,
XLFD_WEIGHT_ULTRA_LIGHT, /* 10 */
XLFD_WEIGHT_EXTRA_LIGHT, /* 20 */
XLFD_WEIGHT_LIGHT, /* 30 */
XLFD_WEIGHT_SEMI_LIGHT, /* 40: SemiLight, Book, ... */
XLFD_WEIGHT_MEDIUM, /* 50: Medium, Normal, Regular, ... */
XLFD_WEIGHT_SEMI_BOLD, /* 60: SemiBold, DemiBold, ... */
XLFD_WEIGHT_BOLD, /* 70: Bold, ... */
XLFD_WEIGHT_EXTRA_BOLD, /* 80: ExtraBold, Heavy, ... */
XLFD_WEIGHT_ULTRA_BOLD /* 90: UltraBold, Black, ... */
};
/* Relative proportionate width. */
enum xlfd_swidth
{
XLFD_SWIDTH_UNKNOWN,
XLFD_SWIDTH_ULTRA_CONDENSED, /* 10 */
XLFD_SWIDTH_EXTRA_CONDENSED, /* 20 */
XLFD_SWIDTH_CONDENSED, /* 30: Condensed, Narrow, Compressed, ... */
XLFD_SWIDTH_SEMI_CONDENSED, /* 40: semicondensed */
XLFD_SWIDTH_MEDIUM, /* 50: Medium, Normal, Regular, ... */
XLFD_SWIDTH_SEMI_EXPANDED, /* 60: SemiExpanded, DemiExpanded, ... */
XLFD_SWIDTH_EXPANDED, /* 70: Expanded... */
XLFD_SWIDTH_EXTRA_EXPANDED, /* 80: ExtraExpanded, Wide... */
XLFD_SWIDTH_ULTRA_EXPANDED /* 90: UltraExpanded... */
};
/* Order by which font selection chooses fonts. The default values
mean `first, find a best match for the font width, then for the
font height, then for weight, then for slant.' This variable can be
set via set-face-font-sort-order. */
static int font_sort_order[4];
#ifdef HAVE_WINDOW_SYSTEM
static enum font_property_index font_props_for_sorting[FONT_SIZE_INDEX];
static int
compare_fonts_by_sort_order (v1, v2)
const void *v1, *v2;
{
Lisp_Object font1 = *(Lisp_Object *) v1;
Lisp_Object font2 = *(Lisp_Object *) v2;
int i;
for (i = 0; i < FONT_SIZE_INDEX; i++)
{
enum font_property_index idx = font_props_for_sorting[i];
Lisp_Object val1 = AREF (font1, idx), val2 = AREF (font2, idx);
int result;
if (idx <= FONT_REGISTRY_INDEX)
{
if (STRINGP (val1))
result = STRINGP (val2) ? strcmp (SDATA (val1), SDATA (val2)) : -1;
else
result = STRINGP (val2) ? 1 : 0;
}
else
{
if (INTEGERP (val1))
result = INTEGERP (val2) ? XINT (val1) - XINT (val2) : -1;
else
result = INTEGERP (val2) ? 1 : 0;
}
if (result)
return result;
}
return 0;
}
DEFUN ("x-family-fonts", Fx_family_fonts, Sx_family_fonts, 0, 2, 0,
doc: /* Return a list of available fonts of family FAMILY on FRAME.
If FAMILY is omitted or nil, list all families.
Otherwise, FAMILY must be a string, possibly containing wildcards
`?' and `*'.
If FRAME is omitted or nil, use the selected frame.
Each element of the result is a vector [FAMILY WIDTH POINT-SIZE WEIGHT
SLANT FIXED-P FULL REGISTRY-AND-ENCODING].
FAMILY is the font family name. POINT-SIZE is the size of the
font in 1/10 pt. WIDTH, WEIGHT, and SLANT are symbols describing the
width, weight and slant of the font. These symbols are the same as for
face attributes. FIXED-P is non-nil if the font is fixed-pitch.
FULL is the full name of the font, and REGISTRY-AND-ENCODING is a string
giving the registry and encoding of the font.
The result list is sorted according to the current setting of
the face font sort order. */)
(family, frame)
Lisp_Object family, frame;
{
Lisp_Object font_spec, list, *drivers, vec;
int i, nfonts, ndrivers;
Lisp_Object result;
if (NILP (frame))
frame = selected_frame;
CHECK_LIVE_FRAME (frame);
font_spec = Ffont_spec (0, NULL);
if (!NILP (family))
{
CHECK_STRING (family);
font_parse_family_registry (family, Qnil, font_spec);
}
list = font_list_entities (frame, font_spec);
if (NILP (list))
return Qnil;
/* Sort the font entities. */
for (i = 0; i < 4; i++)
switch (font_sort_order[i])
{
case XLFD_SWIDTH:
font_props_for_sorting[i] = FONT_WIDTH_INDEX; break;
case XLFD_POINT_SIZE:
font_props_for_sorting[i] = FONT_SIZE_INDEX; break;
case XLFD_WEIGHT:
font_props_for_sorting[i] = FONT_WEIGHT_INDEX; break;
default:
font_props_for_sorting[i] = FONT_SLANT_INDEX; break;
}
font_props_for_sorting[i++] = FONT_FAMILY_INDEX;
font_props_for_sorting[i++] = FONT_FOUNDRY_INDEX;
font_props_for_sorting[i++] = FONT_ADSTYLE_INDEX;
font_props_for_sorting[i++] = FONT_REGISTRY_INDEX;
ndrivers = XINT (Flength (list));
drivers = alloca (sizeof (Lisp_Object) * ndrivers);
for (i = 0; i < ndrivers; i++, list = XCDR (list))
drivers[i] = XCAR (list);
vec = Fvconcat (ndrivers, drivers);
nfonts = ASIZE (vec);
qsort (XVECTOR (vec)->contents, nfonts, sizeof (Lisp_Object),
compare_fonts_by_sort_order);
result = Qnil;
for (i = nfonts - 1; i >= 0; --i)
{
Lisp_Object font = AREF (vec, i);
Lisp_Object v = Fmake_vector (make_number (8), Qnil);
int point;
Lisp_Object spacing;
ASET (v, 0, AREF (font, FONT_FAMILY_INDEX));
ASET (v, 1, FONT_WIDTH_SYMBOLIC (font));
point = PIXEL_TO_POINT (XINT (AREF (font, FONT_SIZE_INDEX)) * 10,
XFRAME (frame)->resy);
ASET (v, 2, make_number (point));
ASET (v, 3, FONT_WEIGHT_SYMBOLIC (font));
ASET (v, 4, FONT_SLANT_SYMBOLIC (font));
spacing = Ffont_get (font, QCspacing);
ASET (v, 5, (NILP (spacing) || EQ (spacing, Qp)) ? Qnil : Qt);
ASET (v, 6, Ffont_xlfd_name (font, Qnil));
ASET (v, 7, AREF (font, FONT_REGISTRY_INDEX));
result = Fcons (v, result);
}
return result;
}
DEFUN ("x-list-fonts", Fx_list_fonts, Sx_list_fonts, 1, 5, 0,
doc: /* Return a list of the names of available fonts matching PATTERN.
If optional arguments FACE and FRAME are specified, return only fonts
the same size as FACE on FRAME.
PATTERN should be a string containing a font name in the XLFD,
Fontconfig, or GTK format. A font name given in the XLFD format may
contain wildcard characters:
the * character matches any substring, and
the ? character matches any single character.
PATTERN is case-insensitive.
The return value is a list of strings, suitable as arguments to
`set-face-font'.
Fonts Emacs can't use may or may not be excluded
even if they match PATTERN and FACE.
The optional fourth argument MAXIMUM sets a limit on how many
fonts to match. The first MAXIMUM fonts are reported.
The optional fifth argument WIDTH, if specified, is a number of columns
occupied by a character of a font. In that case, return only fonts
the WIDTH times as wide as FACE on FRAME. */)
(pattern, face, frame, maximum, width)
Lisp_Object pattern, face, frame, maximum, width;
{
struct frame *f;
int size, avgwidth;
check_x ();
CHECK_STRING (pattern);
if (! NILP (maximum))
CHECK_NATNUM (maximum);
if (!NILP (width))
CHECK_NUMBER (width);
/* We can't simply call check_x_frame because this function may be
called before any frame is created. */
if (NILP (frame))
frame = selected_frame;
f = frame_or_selected_frame (frame, 2);
if (! FRAME_WINDOW_P (f))
{
/* Perhaps we have not yet created any frame. */
f = NULL;
frame = Qnil;
face = Qnil;
}
/* Determine the width standard for comparison with the fonts we find. */
if (NILP (face))
size = 0;
else
{
/* This is of limited utility since it works with character
widths. Keep it for compatibility. --gerd. */
int face_id = lookup_named_face (f, face, 0);
struct face *face = (face_id < 0
? NULL
: FACE_FROM_ID (f, face_id));
if (face && face->font)
{
size = face->font->pixel_size;
avgwidth = face->font->average_width;
}
else
{
size = FRAME_FONT (f)->pixel_size;
avgwidth = FRAME_FONT (f)->average_width;
}
if (!NILP (width))
avgwidth *= XINT (width);
}
{
Lisp_Object font_spec;
Lisp_Object args[2], tail;
font_spec = font_spec_from_name (pattern);
if (!FONTP (font_spec))
signal_error ("Invalid font name", pattern);
if (size)
{
Ffont_put (font_spec, QCsize, make_number (size));
Ffont_put (font_spec, QCavgwidth, make_number (avgwidth));
}
args[0] = Flist_fonts (font_spec, frame, maximum, font_spec);
for (tail = args[0]; CONSP (tail); tail = XCDR (tail))
{
Lisp_Object font_entity;
font_entity = XCAR (tail);
if ((NILP (AREF (font_entity, FONT_SIZE_INDEX))
|| XINT (AREF (font_entity, FONT_SIZE_INDEX)) == 0)
&& ! NILP (AREF (font_spec, FONT_SIZE_INDEX)))
{
/* This is a scalable font. For backward compatibility,
we set the specified size. */
font_entity = Fcopy_font_spec (font_entity);
ASET (font_entity, FONT_SIZE_INDEX,
AREF (font_spec, FONT_SIZE_INDEX));
}
XSETCAR (tail, Ffont_xlfd_name (font_entity, Qnil));
}
if (NILP (frame))
/* We don't have to check fontsets. */
return args[0];
args[1] = list_fontsets (f, pattern, size);
return Fnconc (2, args);
}
}
#endif /* HAVE_WINDOW_SYSTEM */
/***********************************************************************
Lisp Faces
***********************************************************************/
/* Access face attributes of face LFACE, a Lisp vector. */
#define LFACE_FAMILY(LFACE) AREF ((LFACE), LFACE_FAMILY_INDEX)
#define LFACE_FOUNDRY(LFACE) AREF ((LFACE), LFACE_FOUNDRY_INDEX)
#define LFACE_HEIGHT(LFACE) AREF ((LFACE), LFACE_HEIGHT_INDEX)
#define LFACE_WEIGHT(LFACE) AREF ((LFACE), LFACE_WEIGHT_INDEX)
#define LFACE_SLANT(LFACE) AREF ((LFACE), LFACE_SLANT_INDEX)
#define LFACE_UNDERLINE(LFACE) AREF ((LFACE), LFACE_UNDERLINE_INDEX)
#define LFACE_INVERSE(LFACE) AREF ((LFACE), LFACE_INVERSE_INDEX)
#define LFACE_FOREGROUND(LFACE) AREF ((LFACE), LFACE_FOREGROUND_INDEX)
#define LFACE_BACKGROUND(LFACE) AREF ((LFACE), LFACE_BACKGROUND_INDEX)
#define LFACE_STIPPLE(LFACE) AREF ((LFACE), LFACE_STIPPLE_INDEX)
#define LFACE_SWIDTH(LFACE) AREF ((LFACE), LFACE_SWIDTH_INDEX)
#define LFACE_OVERLINE(LFACE) AREF ((LFACE), LFACE_OVERLINE_INDEX)
#define LFACE_STRIKE_THROUGH(LFACE) AREF ((LFACE), LFACE_STRIKE_THROUGH_INDEX)
#define LFACE_BOX(LFACE) AREF ((LFACE), LFACE_BOX_INDEX)
#define LFACE_FONT(LFACE) AREF ((LFACE), LFACE_FONT_INDEX)
#define LFACE_INHERIT(LFACE) AREF ((LFACE), LFACE_INHERIT_INDEX)
#define LFACE_FONTSET(LFACE) AREF ((LFACE), LFACE_FONTSET_INDEX)
/* Non-zero if LFACE is a Lisp face. A Lisp face is a vector of size
LFACE_VECTOR_SIZE which has the symbol `face' in slot 0. */
#define LFACEP(LFACE) \
(VECTORP (LFACE) \
&& XVECTOR_SIZE (LFACE) == LFACE_VECTOR_SIZE \
&& EQ (AREF (LFACE, 0), Qface))
#if GLYPH_DEBUG
/* Check consistency of Lisp face attribute vector ATTRS. */
static void
check_lface_attrs (attrs)
Lisp_Object *attrs;
{
xassert (UNSPECIFIEDP (attrs[LFACE_FAMILY_INDEX])
|| IGNORE_DEFFACE_P (attrs[LFACE_FAMILY_INDEX])
|| STRINGP (attrs[LFACE_FAMILY_INDEX]));
xassert (UNSPECIFIEDP (attrs[LFACE_FOUNDRY_INDEX])
|| IGNORE_DEFFACE_P (attrs[LFACE_FOUNDRY_INDEX])
|| STRINGP (attrs[LFACE_FOUNDRY_INDEX]));
xassert (UNSPECIFIEDP (attrs[LFACE_SWIDTH_INDEX])
|| IGNORE_DEFFACE_P (attrs[LFACE_SWIDTH_INDEX])
|| SYMBOLP (attrs[LFACE_SWIDTH_INDEX]));
xassert (UNSPECIFIEDP (attrs[LFACE_HEIGHT_INDEX])
|| IGNORE_DEFFACE_P (attrs[LFACE_HEIGHT_INDEX])
|| INTEGERP (attrs[LFACE_HEIGHT_INDEX])
|| FLOATP (attrs[LFACE_HEIGHT_INDEX])
|| FUNCTIONP (attrs[LFACE_HEIGHT_INDEX]));
xassert (UNSPECIFIEDP (attrs[LFACE_WEIGHT_INDEX])
|| IGNORE_DEFFACE_P (attrs[LFACE_WEIGHT_INDEX])
|| SYMBOLP (attrs[LFACE_WEIGHT_INDEX]));
xassert (UNSPECIFIEDP (attrs[LFACE_SLANT_INDEX])
|| IGNORE_DEFFACE_P (attrs[LFACE_SLANT_INDEX])
|| SYMBOLP (attrs[LFACE_SLANT_INDEX]));
xassert (UNSPECIFIEDP (attrs[LFACE_UNDERLINE_INDEX])
|| IGNORE_DEFFACE_P (attrs[LFACE_UNDERLINE_INDEX])
|| SYMBOLP (attrs[LFACE_UNDERLINE_INDEX])
|| STRINGP (attrs[LFACE_UNDERLINE_INDEX]));
xassert (UNSPECIFIEDP (attrs[LFACE_OVERLINE_INDEX])
|| IGNORE_DEFFACE_P (attrs[LFACE_OVERLINE_INDEX])
|| SYMBOLP (attrs[LFACE_OVERLINE_INDEX])
|| STRINGP (attrs[LFACE_OVERLINE_INDEX]));
xassert (UNSPECIFIEDP (attrs[LFACE_STRIKE_THROUGH_INDEX])
|| IGNORE_DEFFACE_P (attrs[LFACE_STRIKE_THROUGH_INDEX])
|| SYMBOLP (attrs[LFACE_STRIKE_THROUGH_INDEX])
|| STRINGP (attrs[LFACE_STRIKE_THROUGH_INDEX]));
xassert (UNSPECIFIEDP (attrs[LFACE_BOX_INDEX])
|| IGNORE_DEFFACE_P (attrs[LFACE_BOX_INDEX])
|| SYMBOLP (attrs[LFACE_BOX_INDEX])
|| STRINGP (attrs[LFACE_BOX_INDEX])
|| INTEGERP (attrs[LFACE_BOX_INDEX])
|| CONSP (attrs[LFACE_BOX_INDEX]));
xassert (UNSPECIFIEDP (attrs[LFACE_INVERSE_INDEX])
|| IGNORE_DEFFACE_P (attrs[LFACE_INVERSE_INDEX])
|| SYMBOLP (attrs[LFACE_INVERSE_INDEX]));
xassert (UNSPECIFIEDP (attrs[LFACE_FOREGROUND_INDEX])
|| IGNORE_DEFFACE_P (attrs[LFACE_FOREGROUND_INDEX])
|| STRINGP (attrs[LFACE_FOREGROUND_INDEX]));
xassert (UNSPECIFIEDP (attrs[LFACE_BACKGROUND_INDEX])
|| IGNORE_DEFFACE_P (attrs[LFACE_BACKGROUND_INDEX])
|| STRINGP (attrs[LFACE_BACKGROUND_INDEX]));
xassert (UNSPECIFIEDP (attrs[LFACE_INHERIT_INDEX])
|| IGNORE_DEFFACE_P (attrs[LFACE_INHERIT_INDEX])
|| NILP (attrs[LFACE_INHERIT_INDEX])
|| SYMBOLP (attrs[LFACE_INHERIT_INDEX])
|| CONSP (attrs[LFACE_INHERIT_INDEX]));
#ifdef HAVE_WINDOW_SYSTEM
xassert (UNSPECIFIEDP (attrs[LFACE_STIPPLE_INDEX])
|| IGNORE_DEFFACE_P (attrs[LFACE_STIPPLE_INDEX])
|| SYMBOLP (attrs[LFACE_STIPPLE_INDEX])
|| !NILP (Fbitmap_spec_p (attrs[LFACE_STIPPLE_INDEX])));
xassert (UNSPECIFIEDP (attrs[LFACE_FONT_INDEX])
|| IGNORE_DEFFACE_P (attrs[LFACE_FONT_INDEX])
|| FONTP (attrs[LFACE_FONT_INDEX]));
xassert (UNSPECIFIEDP (attrs[LFACE_FONTSET_INDEX])
|| STRINGP (attrs[LFACE_FONTSET_INDEX]));
#endif
}
/* Check consistency of attributes of Lisp face LFACE (a Lisp vector). */
static void
check_lface (lface)
Lisp_Object lface;
{
if (!NILP (lface))
{
xassert (LFACEP (lface));
check_lface_attrs (XVECTOR (lface)->contents);
}
}
#else /* GLYPH_DEBUG == 0 */
#define check_lface_attrs(attrs) (void) 0
#define check_lface(lface) (void) 0
#endif /* GLYPH_DEBUG == 0 */
/* Face-merge cycle checking. */
enum named_merge_point_kind
{
NAMED_MERGE_POINT_NORMAL,
NAMED_MERGE_POINT_REMAP
};
/* A `named merge point' is simply a point during face-merging where we
look up a face by name. We keep a stack of which named lookups we're
currently processing so that we can easily detect cycles, using a
linked- list of struct named_merge_point structures, typically
allocated on the stack frame of the named lookup functions which are
active (so no consing is required). */
struct named_merge_point
{
Lisp_Object face_name;
enum named_merge_point_kind named_merge_point_kind;
struct named_merge_point *prev;
};
/* If a face merging cycle is detected for FACE_NAME, return 0,
otherwise add NEW_NAMED_MERGE_POINT, which is initialized using
FACE_NAME and NAMED_MERGE_POINT_KIND, as the head of the linked list
pointed to by NAMED_MERGE_POINTS, and return 1. */
static INLINE int
push_named_merge_point (struct named_merge_point *new_named_merge_point,
Lisp_Object face_name,
enum named_merge_point_kind named_merge_point_kind,
struct named_merge_point **named_merge_points)
{
struct named_merge_point *prev;
for (prev = *named_merge_points; prev; prev = prev->prev)
if (EQ (face_name, prev->face_name))
{
if (prev->named_merge_point_kind == named_merge_point_kind)
/* A cycle, so fail. */
return 0;
else if (prev->named_merge_point_kind == NAMED_MERGE_POINT_REMAP)
/* A remap `hides ' any previous normal merge points
(because the remap means that it's actually different face),
so as we know the current merge point must be normal, we
can just assume it's OK. */
break;
}
new_named_merge_point->face_name = face_name;
new_named_merge_point->named_merge_point_kind = named_merge_point_kind;
new_named_merge_point->prev = *named_merge_points;
*named_merge_points = new_named_merge_point;
return 1;
}
#if 0 /* Seems to be unused. */
static Lisp_Object
internal_resolve_face_name (nargs, args)
int nargs;
Lisp_Object *args;
{
return Fget (args[0], args[1]);
}
static Lisp_Object
resolve_face_name_error (ignore)
Lisp_Object ignore;
{
return Qnil;
}
#endif
/* Resolve face name FACE_NAME. If FACE_NAME is a string, intern it
to make it a symbol. If FACE_NAME is an alias for another face,
return that face's name.
Return default face in case of errors. */
static Lisp_Object
resolve_face_name (face_name, signal_p)
Lisp_Object face_name;
int signal_p;
{
Lisp_Object orig_face;
Lisp_Object tortoise, hare;
if (STRINGP (face_name))
face_name = intern (SDATA (face_name));
if (NILP (face_name) || !SYMBOLP (face_name))
return face_name;
orig_face = face_name;
tortoise = hare = face_name;
while (1)
{
face_name = hare;
hare = Fget (hare, Qface_alias);
if (NILP (hare) || !SYMBOLP (hare))
break;
face_name = hare;
hare = Fget (hare, Qface_alias);
if (NILP (hare) || !SYMBOLP (hare))
break;
tortoise = Fget (tortoise, Qface_alias);
if (EQ (hare, tortoise))
{
if (signal_p)
xsignal1 (Qcircular_list, orig_face);
return Qdefault;
}
}
return face_name;
}
/* Return the face definition of FACE_NAME on frame F. F null means
return the definition for new frames. FACE_NAME may be a string or
a symbol (apparently Emacs 20.2 allowed strings as face names in
face text properties; Ediff uses that). If SIGNAL_P is non-zero,
signal an error if FACE_NAME is not a valid face name. If SIGNAL_P
is zero, value is nil if FACE_NAME is not a valid face name. */
static INLINE Lisp_Object
lface_from_face_name_no_resolve (f, face_name, signal_p)
struct frame *f;
Lisp_Object face_name;
int signal_p;
{
Lisp_Object lface;
if (f)
lface = assq_no_quit (face_name, f->face_alist);
else
lface = assq_no_quit (face_name, Vface_new_frame_defaults);
if (CONSP (lface))
lface = XCDR (lface);
else if (signal_p)
signal_error ("Invalid face", face_name);
check_lface (lface);
return lface;
}
/* Return the face definition of FACE_NAME on frame F. F null means
return the definition for new frames. FACE_NAME may be a string or
a symbol (apparently Emacs 20.2 allowed strings as face names in
face text properties; Ediff uses that). If FACE_NAME is an alias
for another face, return that face's definition. If SIGNAL_P is
non-zero, signal an error if FACE_NAME is not a valid face name.
If SIGNAL_P is zero, value is nil if FACE_NAME is not a valid face
name. */
static INLINE Lisp_Object
lface_from_face_name (f, face_name, signal_p)
struct frame *f;
Lisp_Object face_name;
int signal_p;
{
face_name = resolve_face_name (face_name, signal_p);
return lface_from_face_name_no_resolve (f, face_name, signal_p);
}
/* Get face attributes of face FACE_NAME from frame-local faces on
frame F. Store the resulting attributes in ATTRS which must point
to a vector of Lisp_Objects of size LFACE_VECTOR_SIZE. If SIGNAL_P
is non-zero, signal an error if FACE_NAME does not name a face.
Otherwise, value is zero if FACE_NAME is not a face. */
static INLINE int
get_lface_attributes_no_remap (f, face_name, attrs, signal_p)
struct frame *f;
Lisp_Object face_name;
Lisp_Object *attrs;
int signal_p;
{
Lisp_Object lface;
lface = lface_from_face_name_no_resolve (f, face_name, signal_p);
if (! NILP (lface))
bcopy (XVECTOR (lface)->contents, attrs,
LFACE_VECTOR_SIZE * sizeof *attrs);
return !NILP (lface);
}
/* Get face attributes of face FACE_NAME from frame-local faces on frame
F. Store the resulting attributes in ATTRS which must point to a
vector of Lisp_Objects of size LFACE_VECTOR_SIZE. If FACE_NAME is an
alias for another face, use that face's definition. If SIGNAL_P is
non-zero, signal an error if FACE_NAME does not name a face.
Otherwise, value is zero if FACE_NAME is not a face. */
static INLINE int
get_lface_attributes (f, face_name, attrs, signal_p, named_merge_points)
struct frame *f;
Lisp_Object face_name;
Lisp_Object *attrs;
int signal_p;
struct named_merge_point *named_merge_points;
{
Lisp_Object face_remapping;
face_name = resolve_face_name (face_name, signal_p);
/* See if SYMBOL has been remapped to some other face (usually this
is done buffer-locally). */
face_remapping = assq_no_quit (face_name, Vface_remapping_alist);
if (CONSP (face_remapping))
{
struct named_merge_point named_merge_point;
if (push_named_merge_point (&named_merge_point,
face_name, NAMED_MERGE_POINT_REMAP,
&named_merge_points))
{
int i;
for (i = 1; i < LFACE_VECTOR_SIZE; ++i)
attrs[i] = Qunspecified;
return merge_face_ref (f, XCDR (face_remapping), attrs,
signal_p, named_merge_points);
}
}
/* Default case, no remapping. */
return get_lface_attributes_no_remap (f, face_name, attrs, signal_p);
}
/* Non-zero if all attributes in face attribute vector ATTRS are
specified, i.e. are non-nil. */
static int
lface_fully_specified_p (attrs)
Lisp_Object *attrs;
{
int i;
for (i = 1; i < LFACE_VECTOR_SIZE; ++i)
if (i != LFACE_FONT_INDEX && i != LFACE_INHERIT_INDEX)
if ((UNSPECIFIEDP (attrs[i]) || IGNORE_DEFFACE_P (attrs[i])))
break;
return i == LFACE_VECTOR_SIZE;
}
#ifdef HAVE_WINDOW_SYSTEM
/* Set font-related attributes of Lisp face LFACE from FONT-OBJECT.
If FORCE_P is zero, set only unspecified attributes of LFACE. The
exception is `font' attribute. It is set to FONT_OBJECT regardless
of FORCE_P. */
static int
set_lface_from_font (f, lface, font_object, force_p)
struct frame *f;
Lisp_Object lface, font_object;
int force_p;
{
Lisp_Object val;
struct font *font = XFONT_OBJECT (font_object);
/* Set attributes only if unspecified, otherwise face defaults for
new frames would never take effect. If the font doesn't have a
specific property, set a normal value for that. */
if (force_p || UNSPECIFIEDP (LFACE_FAMILY (lface)))
{
Lisp_Object family = AREF (font_object, FONT_FAMILY_INDEX);
LFACE_FAMILY (lface) = SYMBOL_NAME (family);
}
if (force_p || UNSPECIFIEDP (LFACE_FOUNDRY (lface)))
{
Lisp_Object foundry = AREF (font_object, FONT_FOUNDRY_INDEX);
LFACE_FOUNDRY (lface) = SYMBOL_NAME (foundry);
}
if (force_p || UNSPECIFIEDP (LFACE_HEIGHT (lface)))
{
int pt = PIXEL_TO_POINT (font->pixel_size * 10, f->resy);
xassert (pt > 0);
LFACE_HEIGHT (lface) = make_number (pt);
}
if (force_p || UNSPECIFIEDP (LFACE_WEIGHT (lface)))
{
val = FONT_WEIGHT_FOR_FACE (font_object);
LFACE_WEIGHT (lface) = ! NILP (val) ? val :Qnormal;
}
if (force_p || UNSPECIFIEDP (LFACE_SLANT (lface)))
{
val = FONT_SLANT_FOR_FACE (font_object);
LFACE_SLANT (lface) = ! NILP (val) ? val : Qnormal;
}
if (force_p || UNSPECIFIEDP (LFACE_SWIDTH (lface)))
{
val = FONT_WIDTH_FOR_FACE (font_object);
LFACE_SWIDTH (lface) = ! NILP (val) ? val : Qnormal;
}
LFACE_FONT (lface) = font_object;
return 1;
}
#endif /* HAVE_WINDOW_SYSTEM */
/* Merges the face height FROM with the face height TO, and returns the
merged height. If FROM is an invalid height, then INVALID is
returned instead. FROM and TO may be either absolute face heights or
`relative' heights; the returned value is always an absolute height
unless both FROM and TO are relative. */
Lisp_Object
merge_face_heights (from, to, invalid)
Lisp_Object from, to, invalid;
{
Lisp_Object result = invalid;
if (INTEGERP (from))
/* FROM is absolute, just use it as is. */
result = from;
else if (FLOATP (from))
/* FROM is a scale, use it to adjust TO. */
{
if (INTEGERP (to))
/* relative X absolute => absolute */
result = make_number ((EMACS_INT)(XFLOAT_DATA (from) * XINT (to)));
else if (FLOATP (to))
/* relative X relative => relative */
result = make_float (XFLOAT_DATA (from) * XFLOAT_DATA (to));
else if (UNSPECIFIEDP (to))
result = from;
}
else if (FUNCTIONP (from))
/* FROM is a function, which use to adjust TO. */
{
/* Call function with current height as argument.
From is the new height. */
Lisp_Object args[2];
args[0] = from;
args[1] = to;
result = safe_call (2, args);
/* Ensure that if TO was absolute, so is the result. */
if (INTEGERP (to) && !INTEGERP (result))
result = invalid;
}
return result;
}
/* Merge two Lisp face attribute vectors on frame F, FROM and TO, and
store the resulting attributes in TO, which must be already be
completely specified and contain only absolute attributes. Every
specified attribute of FROM overrides the corresponding attribute of
TO; relative attributes in FROM are merged with the absolute value in
TO and replace it. NAMED_MERGE_POINTS is used internally to detect
loops in face inheritance/remapping; it should be 0 when called from
other places. */
static INLINE void
merge_face_vectors (f, from, to, named_merge_points)
struct frame *f;
Lisp_Object *from, *to;
struct named_merge_point *named_merge_points;
{
int i;
/* If FROM inherits from some other faces, merge their attributes into
TO before merging FROM's direct attributes. Note that an :inherit
attribute of `unspecified' is the same as one of nil; we never
merge :inherit attributes, so nil is more correct, but lots of
other code uses `unspecified' as a generic value for face attributes. */
if (!UNSPECIFIEDP (from[LFACE_INHERIT_INDEX])
&& !NILP (from[LFACE_INHERIT_INDEX]))
merge_face_ref (f, from[LFACE_INHERIT_INDEX], to, 0, named_merge_points);
i = LFACE_FONT_INDEX;
if (!UNSPECIFIEDP (from[i]))
{
if (!UNSPECIFIEDP (to[i]))
to[i] = Fmerge_font_spec (from[i], to[i]);
else
to[i] = Fcopy_font_spec (from[i]);
if (! NILP (AREF (to[i], FONT_FOUNDRY_INDEX)))
to[LFACE_FOUNDRY_INDEX] = SYMBOL_NAME (AREF (to[i], FONT_FOUNDRY_INDEX));
if (! NILP (AREF (to[i], FONT_FAMILY_INDEX)))
to[LFACE_FAMILY_INDEX] = SYMBOL_NAME (AREF (to[i], FONT_FAMILY_INDEX));
if (! NILP (AREF (to[i], FONT_WEIGHT_INDEX)))
to[LFACE_WEIGHT_INDEX] = FONT_WEIGHT_FOR_FACE (to[i]);
if (! NILP (AREF (to[i], FONT_SLANT_INDEX)))
to[LFACE_SLANT_INDEX] = FONT_SLANT_FOR_FACE (to[i]);
if (! NILP (AREF (to[i], FONT_WIDTH_INDEX)))
to[LFACE_SWIDTH_INDEX] = FONT_WIDTH_FOR_FACE (to[i]);
ASET (to[i], FONT_SIZE_INDEX, Qnil);
}
for (i = 1; i < LFACE_VECTOR_SIZE; ++i)
if (!UNSPECIFIEDP (from[i]))
{
if (i == LFACE_HEIGHT_INDEX && !INTEGERP (from[i]))
{
to[i] = merge_face_heights (from[i], to[i], to[i]);
font_clear_prop (to, FONT_SIZE_INDEX);
}
else if (i != LFACE_FONT_INDEX
&& ! EQ (to[i], from[i]))
{
to[i] = from[i];
if (i >= LFACE_FAMILY_INDEX && i <=LFACE_SLANT_INDEX)
font_clear_prop (to,
(i == LFACE_FAMILY_INDEX ? FONT_FAMILY_INDEX
: i == LFACE_FOUNDRY_INDEX ? FONT_FOUNDRY_INDEX
: i == LFACE_SWIDTH_INDEX ? FONT_WIDTH_INDEX
: i == LFACE_HEIGHT_INDEX ? FONT_SIZE_INDEX
: i == LFACE_WEIGHT_INDEX ? FONT_WEIGHT_INDEX
: FONT_SLANT_INDEX));
}
}
/* TO is always an absolute face, which should inherit from nothing.
We blindly copy the :inherit attribute above and fix it up here. */
to[LFACE_INHERIT_INDEX] = Qnil;
}
/* Merge the named face FACE_NAME on frame F, into the vector of face
attributes TO. NAMED_MERGE_POINTS is used to detect loops in face
inheritance. Returns true if FACE_NAME is a valid face name and
merging succeeded. */
static int
merge_named_face (f, face_name, to, named_merge_points)
struct frame *f;
Lisp_Object face_name;
Lisp_Object *to;
struct named_merge_point *named_merge_points;
{
struct named_merge_point named_merge_point;
if (push_named_merge_point (&named_merge_point,
face_name, NAMED_MERGE_POINT_NORMAL,
&named_merge_points))
{
struct gcpro gcpro1;
Lisp_Object from[LFACE_VECTOR_SIZE];
int ok = get_lface_attributes (f, face_name, from, 0, named_merge_points);
if (ok)
{
GCPRO1 (named_merge_point.face_name);
merge_face_vectors (f, from, to, named_merge_points);
UNGCPRO;
}
return ok;
}
else
return 0;
}
/* Merge face attributes from the lisp `face reference' FACE_REF on
frame F into the face attribute vector TO. If ERR_MSGS is non-zero,
problems with FACE_REF cause an error message to be shown. Return
non-zero if no errors occurred (regardless of the value of ERR_MSGS).
NAMED_MERGE_POINTS is used to detect loops in face inheritance or
list structure; it may be 0 for most callers.
FACE_REF may be a single face specification or a list of such
specifications. Each face specification can be:
1. A symbol or string naming a Lisp face.
2. A property list of the form (KEYWORD VALUE ...) where each
KEYWORD is a face attribute name, and value is an appropriate value
for that attribute.
3. Conses or the form (FOREGROUND-COLOR . COLOR) or
(BACKGROUND-COLOR . COLOR) where COLOR is a color name. This is
for compatibility with 20.2.
Face specifications earlier in lists take precedence over later
specifications. */
static int
merge_face_ref (f, face_ref, to, err_msgs, named_merge_points)
struct frame *f;
Lisp_Object face_ref;
Lisp_Object *to;
int err_msgs;
struct named_merge_point *named_merge_points;
{
int ok = 1; /* Succeed without an error? */
if (CONSP (face_ref))
{
Lisp_Object first = XCAR (face_ref);
if (EQ (first, Qforeground_color)
|| EQ (first, Qbackground_color))
{
/* One of (FOREGROUND-COLOR . COLOR) or (BACKGROUND-COLOR
. COLOR). COLOR must be a string. */
Lisp_Object color_name = XCDR (face_ref);
Lisp_Object color = first;
if (STRINGP (color_name))
{
if (EQ (color, Qforeground_color))
to[LFACE_FOREGROUND_INDEX] = color_name;
else
to[LFACE_BACKGROUND_INDEX] = color_name;
}
else
{
if (err_msgs)
add_to_log ("Invalid face color", color_name, Qnil);
ok = 0;
}
}
else if (SYMBOLP (first)
&& *SDATA (SYMBOL_NAME (first)) == ':')
{
/* Assume this is the property list form. */
while (CONSP (face_ref) && CONSP (XCDR (face_ref)))
{
Lisp_Object keyword = XCAR (face_ref);
Lisp_Object value = XCAR (XCDR (face_ref));
int err = 0;
/* Specifying `unspecified' is a no-op. */
if (EQ (value, Qunspecified))
;
else if (EQ (keyword, QCfamily))
{
if (STRINGP (value))
{
to[LFACE_FAMILY_INDEX] = value;
font_clear_prop (to, FONT_FAMILY_INDEX);
}
else
err = 1;
}
else if (EQ (keyword, QCfoundry))
{
if (STRINGP (value))
{
to[LFACE_FOUNDRY_INDEX] = value;
font_clear_prop (to, FONT_FOUNDRY_INDEX);
}
else
err = 1;
}
else if (EQ (keyword, QCheight))
{
Lisp_Object new_height =
merge_face_heights (value, to[LFACE_HEIGHT_INDEX], Qnil);
if (! NILP (new_height))
{
to[LFACE_HEIGHT_INDEX] = new_height;
font_clear_prop (to, FONT_SIZE_INDEX);
}
else
err = 1;
}
else if (EQ (keyword, QCweight))
{
if (SYMBOLP (value) && FONT_WEIGHT_NAME_NUMERIC (value) >= 0)
{
to[LFACE_WEIGHT_INDEX] = value;
font_clear_prop (to, FONT_WEIGHT_INDEX);
}
else
err = 1;
}
else if (EQ (keyword, QCslant))
{
if (SYMBOLP (value) && FONT_SLANT_NAME_NUMERIC (value) >= 0)
{
to[LFACE_SLANT_INDEX] = value;
font_clear_prop (to, FONT_SLANT_INDEX);
}
else
err = 1;
}
else if (EQ (keyword, QCunderline))
{
if (EQ (value, Qt)
|| NILP (value)
|| STRINGP (value))
to[LFACE_UNDERLINE_INDEX] = value;
else
err = 1;
}
else if (EQ (keyword, QCoverline))
{
if (EQ (value, Qt)
|| NILP (value)
|| STRINGP (value))
to[LFACE_OVERLINE_INDEX] = value;
else
err = 1;
}
else if (EQ (keyword, QCstrike_through))
{
if (EQ (value, Qt)
|| NILP (value)
|| STRINGP (value))
to[LFACE_STRIKE_THROUGH_INDEX] = value;
else
err = 1;
}
else if (EQ (keyword, QCbox))
{
if (EQ (value, Qt))
value = make_number (1);
if (INTEGERP (value)
|| STRINGP (value)
|| CONSP (value)
|| NILP (value))
to[LFACE_BOX_INDEX] = value;
else
err = 1;
}
else if (EQ (keyword, QCinverse_video)
|| EQ (keyword, QCreverse_video))
{
if (EQ (value, Qt) || NILP (value))
to[LFACE_INVERSE_INDEX] = value;
else
err = 1;
}
else if (EQ (keyword, QCforeground))
{
if (STRINGP (value))
to[LFACE_FOREGROUND_INDEX] = value;
else
err = 1;
}
else if (EQ (keyword, QCbackground))
{
if (STRINGP (value))
to[LFACE_BACKGROUND_INDEX] = value;
else
err = 1;
}
else if (EQ (keyword, QCstipple))
{
#if defined(HAVE_X_WINDOWS) || defined(HAVE_NS)
Lisp_Object pixmap_p = Fbitmap_spec_p (value);
if (!NILP (pixmap_p))
to[LFACE_STIPPLE_INDEX] = value;
else
err = 1;
#endif
}
else if (EQ (keyword, QCwidth))
{
if (SYMBOLP (value) && FONT_WIDTH_NAME_NUMERIC (value) >= 0)
{
to[LFACE_SWIDTH_INDEX] = value;
font_clear_prop (to, FONT_WIDTH_INDEX);
}
else
err = 1;
}
else if (EQ (keyword, QCinherit))
{
/* This is not really very useful; it's just like a
normal face reference. */
if (! merge_face_ref (f, value, to,
err_msgs, named_merge_points))
err = 1;
}
else
err = 1;
if (err)
{
add_to_log ("Invalid face attribute %S %S", keyword, value);
ok = 0;
}
face_ref = XCDR (XCDR (face_ref));
}
}
else
{
/* This is a list of face refs. Those at the beginning of the
list take precedence over what follows, so we have to merge
from the end backwards. */
Lisp_Object next = XCDR (face_ref);
if (! NILP (next))
ok = merge_face_ref (f, next, to, err_msgs, named_merge_points);
if (! merge_face_ref (f, first, to, err_msgs, named_merge_points))
ok = 0;
}
}
else
{
/* FACE_REF ought to be a face name. */
ok = merge_named_face (f, face_ref, to, named_merge_points);
if (!ok && err_msgs)
add_to_log ("Invalid face reference: %s", face_ref, Qnil);
}
return ok;
}
DEFUN ("internal-make-lisp-face", Finternal_make_lisp_face,
Sinternal_make_lisp_face, 1, 2, 0,
doc: /* Make FACE, a symbol, a Lisp face with all attributes nil.
If FACE was not known as a face before, create a new one.
If optional argument FRAME is specified, make a frame-local face
for that frame. Otherwise operate on the global face definition.
Value is a vector of face attributes. */)
(face, frame)
Lisp_Object face, frame;
{
Lisp_Object global_lface, lface;
struct frame *f;
int i;
CHECK_SYMBOL (face);
global_lface = lface_from_face_name (NULL, face, 0);
if (!NILP (frame))
{
CHECK_LIVE_FRAME (frame);
f = XFRAME (frame);
lface = lface_from_face_name (f, face, 0);
}
else
f = NULL, lface = Qnil;
/* Add a global definition if there is none. */
if (NILP (global_lface))
{
global_lface = Fmake_vector (make_number (LFACE_VECTOR_SIZE),
Qunspecified);
ASET (global_lface, 0, Qface);
Vface_new_frame_defaults = Fcons (Fcons (face, global_lface),
Vface_new_frame_defaults);
/* Assign the new Lisp face a unique ID. The mapping from Lisp
face id to Lisp face is given by the vector lface_id_to_name.
The mapping from Lisp face to Lisp face id is given by the
property `face' of the Lisp face name. */
if (next_lface_id == lface_id_to_name_size)
{
int new_size = max (50, 2 * lface_id_to_name_size);
int sz = new_size * sizeof *lface_id_to_name;
lface_id_to_name = (Lisp_Object *) xrealloc (lface_id_to_name, sz);
lface_id_to_name_size = new_size;
}
lface_id_to_name[next_lface_id] = face;
Fput (face, Qface, make_number (next_lface_id));
++next_lface_id;
}
else if (f == NULL)
for (i = 1; i < LFACE_VECTOR_SIZE; ++i)
ASET (global_lface, i, Qunspecified);
/* Add a frame-local definition. */
if (f)
{
if (NILP (lface))
{
lface = Fmake_vector (make_number (LFACE_VECTOR_SIZE),
Qunspecified);
ASET (lface, 0, Qface);
f->face_alist = Fcons (Fcons (face, lface), f->face_alist);
}
else
for (i = 1; i < LFACE_VECTOR_SIZE; ++i)
ASET (lface, i, Qunspecified);
}
else
lface = global_lface;
/* Changing a named face means that all realized faces depending on
that face are invalid. Since we cannot tell which realized faces
depend on the face, make sure they are all removed. This is done
by incrementing face_change_count. The next call to
init_iterator will then free realized faces. */
if (NILP (Fget (face, Qface_no_inherit)))
{
++face_change_count;
++windows_or_buffers_changed;
}
xassert (LFACEP (lface));
check_lface (lface);
return lface;
}
DEFUN ("internal-lisp-face-p", Finternal_lisp_face_p,
Sinternal_lisp_face_p, 1, 2, 0,
doc: /* Return non-nil if FACE names a face.
FACE should be a symbol or string.
If optional second argument FRAME is non-nil, check for the
existence of a frame-local face with name FACE on that frame.
Otherwise check for the existence of a global face. */)
(face, frame)
Lisp_Object face, frame;
{
Lisp_Object lface;
face = resolve_face_name (face, 1);
if (!NILP (frame))
{
CHECK_LIVE_FRAME (frame);
lface = lface_from_face_name (XFRAME (frame), face, 0);
}
else
lface = lface_from_face_name (NULL, face, 0);
return lface;
}
DEFUN ("internal-copy-lisp-face", Finternal_copy_lisp_face,
Sinternal_copy_lisp_face, 4, 4, 0,
doc: /* Copy face FROM to TO.
If FRAME is t, copy the global face definition of FROM.
Otherwise, copy the frame-local definition of FROM on FRAME.
If NEW-FRAME is a frame, copy that data into the frame-local
definition of TO on NEW-FRAME. If NEW-FRAME is nil,
FRAME controls where the data is copied to.
The value is TO. */)
(from, to, frame, new_frame)
Lisp_Object from, to, frame, new_frame;
{
Lisp_Object lface, copy;
CHECK_SYMBOL (from);
CHECK_SYMBOL (to);
if (EQ (frame, Qt))
{
/* Copy global definition of FROM. We don't make copies of
strings etc. because 20.2 didn't do it either. */
lface = lface_from_face_name (NULL, from, 1);
copy = Finternal_make_lisp_face (to, Qnil);
}
else
{
/* Copy frame-local definition of FROM. */
if (NILP (new_frame))
new_frame = frame;
CHECK_LIVE_FRAME (frame);
CHECK_LIVE_FRAME (new_frame);
lface = lface_from_face_name (XFRAME (frame), from, 1);
copy = Finternal_make_lisp_face (to, new_frame);
}
bcopy (XVECTOR (lface)->contents, XVECTOR (copy)->contents,
LFACE_VECTOR_SIZE * sizeof (Lisp_Object));
/* Changing a named face means that all realized faces depending on
that face are invalid. Since we cannot tell which realized faces
depend on the face, make sure they are all removed. This is done
by incrementing face_change_count. The next call to
init_iterator will then free realized faces. */
if (NILP (Fget (to, Qface_no_inherit)))
{
++face_change_count;
++windows_or_buffers_changed;
}
return to;
}
DEFUN ("internal-set-lisp-face-attribute", Finternal_set_lisp_face_attribute,
Sinternal_set_lisp_face_attribute, 3, 4, 0,
doc: /* Set attribute ATTR of FACE to VALUE.
FRAME being a frame means change the face on that frame.
FRAME nil means change the face of the selected frame.
FRAME t means change the default for new frames.
FRAME 0 means change the face on all frames, and change the default
for new frames. */)
(face, attr, value, frame)
Lisp_Object face, attr, value, frame;
{
Lisp_Object lface;
Lisp_Object old_value = Qnil;
/* Set one of enum font_property_index (> 0) if ATTR is one of
font-related attributes other than QCfont and QCfontset. */
enum font_property_index prop_index = 0;
CHECK_SYMBOL (face);
CHECK_SYMBOL (attr);
face = resolve_face_name (face, 1);
/* If FRAME is 0, change face on all frames, and change the
default for new frames. */
if (INTEGERP (frame) && XINT (frame) == 0)
{
Lisp_Object tail;
Finternal_set_lisp_face_attribute (face, attr, value, Qt);
FOR_EACH_FRAME (tail, frame)
Finternal_set_lisp_face_attribute (face, attr, value, frame);
return face;
}
/* Set lface to the Lisp attribute vector of FACE. */
if (EQ (frame, Qt))
{
lface = lface_from_face_name (NULL, face, 1);
/* When updating face-new-frame-defaults, we put :ignore-defface
where the caller wants `unspecified'. This forces the frame
defaults to ignore the defface value. Otherwise, the defface
will take effect, which is generally not what is intended.
The value of that attribute will be inherited from some other
face during face merging. See internal_merge_in_global_face. */
if (UNSPECIFIEDP (value))
value = Qignore_defface;
}
else
{
if (NILP (frame))
frame = selected_frame;
CHECK_LIVE_FRAME (frame);
lface = lface_from_face_name (XFRAME (frame), face, 0);
/* If a frame-local face doesn't exist yet, create one. */
if (NILP (lface))
lface = Finternal_make_lisp_face (face, frame);
}
if (EQ (attr, QCfamily))
{
if (!UNSPECIFIEDP (value) && !IGNORE_DEFFACE_P (value))
{
CHECK_STRING (value);
if (SCHARS (value) == 0)
signal_error ("Invalid face family", value);
}
old_value = LFACE_FAMILY (lface);
LFACE_FAMILY (lface) = value;
prop_index = FONT_FAMILY_INDEX;
}
else if (EQ (attr, QCfoundry))
{
if (!UNSPECIFIEDP (value) && !IGNORE_DEFFACE_P (value))
{
CHECK_STRING (value);
if (SCHARS (value) == 0)
signal_error ("Invalid face foundry", value);
}
old_value = LFACE_FOUNDRY (lface);
LFACE_FOUNDRY (lface) = value;
prop_index = FONT_FOUNDRY_INDEX;
}
else if (EQ (attr, QCheight))
{
if (!UNSPECIFIEDP (value) && !IGNORE_DEFFACE_P (value))
{
if (EQ (face, Qdefault))
{
/* The default face must have an absolute size. */
if (!INTEGERP (value) || XINT (value) <= 0)
signal_error ("Default face height not absolute and positive", value);
}
else
{
/* For non-default faces, do a test merge with a random
height to see if VALUE's ok. */
Lisp_Object test = merge_face_heights (value,
make_number (10),
Qnil);
if (!INTEGERP (test) || XINT (test) <= 0)
signal_error ("Face height does not produce a positive integer", value);
}
}
old_value = LFACE_HEIGHT (lface);
LFACE_HEIGHT (lface) = value;
prop_index = FONT_SIZE_INDEX;
}
else if (EQ (attr, QCweight))
{
if (!UNSPECIFIEDP (value) && !IGNORE_DEFFACE_P (value))
{
CHECK_SYMBOL (value);
if (FONT_WEIGHT_NAME_NUMERIC (value) < 0)
signal_error ("Invalid face weight", value);
}
old_value = LFACE_WEIGHT (lface);
LFACE_WEIGHT (lface) = value;
prop_index = FONT_WEIGHT_INDEX;
}
else if (EQ (attr, QCslant))
{
if (!UNSPECIFIEDP (value) && !IGNORE_DEFFACE_P (value))
{
CHECK_SYMBOL (value);
if (FONT_SLANT_NAME_NUMERIC (value) < 0)
signal_error ("Invalid face slant", value);
}
old_value = LFACE_SLANT (lface);
LFACE_SLANT (lface) = value;
prop_index = FONT_SLANT_INDEX;
}
else if (EQ (attr, QCunderline))
{
if (!UNSPECIFIEDP (value) && !IGNORE_DEFFACE_P (value))
if ((SYMBOLP (value)
&& !EQ (value, Qt)
&& !EQ (value, Qnil))
/* Underline color. */
|| (STRINGP (value)
&& SCHARS (value) == 0))
signal_error ("Invalid face underline", value);
old_value = LFACE_UNDERLINE (lface);
LFACE_UNDERLINE (lface) = value;
}
else if (EQ (attr, QCoverline))
{
if (!UNSPECIFIEDP (value) && !IGNORE_DEFFACE_P (value))
if ((SYMBOLP (value)
&& !EQ (value, Qt)
&& !EQ (value, Qnil))
/* Overline color. */
|| (STRINGP (value)
&& SCHARS (value) == 0))
signal_error ("Invalid face overline", value);
old_value = LFACE_OVERLINE (lface);
LFACE_OVERLINE (lface) = value;
}
else if (EQ (attr, QCstrike_through))
{
if (!UNSPECIFIEDP (value) && !IGNORE_DEFFACE_P (value))
if ((SYMBOLP (value)
&& !EQ (value, Qt)
&& !EQ (value, Qnil))
/* Strike-through color. */
|| (STRINGP (value)
&& SCHARS (value) == 0))
signal_error ("Invalid face strike-through", value);
old_value = LFACE_STRIKE_THROUGH (lface);
LFACE_STRIKE_THROUGH (lface) = value;
}
else if (EQ (attr, QCbox))
{
int valid_p;
/* Allow t meaning a simple box of width 1 in foreground color
of the face. */
if (EQ (value, Qt))
value = make_number (1);
if (UNSPECIFIEDP (value) || IGNORE_DEFFACE_P (value))
valid_p = 1;
else if (NILP (value))
valid_p = 1;
else if (INTEGERP (value))
valid_p = XINT (value) != 0;
else if (STRINGP (value))
valid_p = SCHARS (value) > 0;
else if (CONSP (value))
{
Lisp_Object tem;
tem = value;
while (CONSP (tem))
{
Lisp_Object k, v;
k = XCAR (tem);
tem = XCDR (tem);
if (!CONSP (tem))
break;
v = XCAR (tem);
tem = XCDR (tem);
if (EQ (k, QCline_width))
{
if (!INTEGERP (v) || XINT (v) == 0)
break;
}
else if (EQ (k, QCcolor))
{
if (!NILP (v) && (!STRINGP (v) || SCHARS (v) == 0))
break;
}
else if (EQ (k, QCstyle))
{
if (!EQ (v, Qpressed_button) && !EQ (v, Qreleased_button))
break;
}
else
break;
}
valid_p = NILP (tem);
}
else
valid_p = 0;
if (!valid_p)
signal_error ("Invalid face box", value);
old_value = LFACE_BOX (lface);
LFACE_BOX (lface) = value;
}
else if (EQ (attr, QCinverse_video)
|| EQ (attr, QCreverse_video))
{
if (!UNSPECIFIEDP (value) && !IGNORE_DEFFACE_P (value))
{
CHECK_SYMBOL (value);
if (!EQ (value, Qt) && !NILP (value))
signal_error ("Invalid inverse-video face attribute value", value);
}
old_value = LFACE_INVERSE (lface);
LFACE_INVERSE (lface) = value;
}
else if (EQ (attr, QCforeground))
{
/* Compatibility with 20.x. */
if (NILP (value))
value = Qunspecified;
if (!UNSPECIFIEDP (value) && !IGNORE_DEFFACE_P (value))
{
/* Don't check for valid color names here because it depends
on the frame (display) whether the color will be valid
when the face is realized. */
CHECK_STRING (value);
if (SCHARS (value) == 0)
signal_error ("Empty foreground color value", value);
}
old_value = LFACE_FOREGROUND (lface);
LFACE_FOREGROUND (lface) = value;
}
else if (EQ (attr, QCbackground))
{
/* Compatibility with 20.x. */
if (NILP (value))
value = Qunspecified;
if (!UNSPECIFIEDP (value) && !IGNORE_DEFFACE_P (value))
{
/* Don't check for valid color names here because it depends
on the frame (display) whether the color will be valid
when the face is realized. */
CHECK_STRING (value);
if (SCHARS (value) == 0)
signal_error ("Empty background color value", value);
}
old_value = LFACE_BACKGROUND (lface);
LFACE_BACKGROUND (lface) = value;
}
else if (EQ (attr, QCstipple))
{
#if defined(HAVE_X_WINDOWS) || defined(HAVE_NS)
if (!UNSPECIFIEDP (value) && !IGNORE_DEFFACE_P (value)
&& !NILP (value)
&& NILP (Fbitmap_spec_p (value)))
signal_error ("Invalid stipple attribute", value);
old_value = LFACE_STIPPLE (lface);
LFACE_STIPPLE (lface) = value;
#endif /* HAVE_X_WINDOWS || HAVE_NS */
}
else if (EQ (attr, QCwidth))
{
if (!UNSPECIFIEDP (value) && !IGNORE_DEFFACE_P (value))
{
CHECK_SYMBOL (value);
if (FONT_WIDTH_NAME_NUMERIC (value) < 0)
signal_error ("Invalid face width", value);
}
old_value = LFACE_SWIDTH (lface);
LFACE_SWIDTH (lface) = value;
prop_index = FONT_WIDTH_INDEX;
}
else if (EQ (attr, QCfont))
{
#ifdef HAVE_WINDOW_SYSTEM
if (EQ (frame, Qt) || FRAME_WINDOW_P (XFRAME (frame)))
{
if (!UNSPECIFIEDP (value) && !IGNORE_DEFFACE_P (value))
{
FRAME_PTR f;
old_value = LFACE_FONT (lface);
if (! FONTP (value))
{
if (STRINGP (value))
{
Lisp_Object name = value;
int fontset = fs_query_fontset (name, 0);
if (fontset >= 0)
name = fontset_ascii (fontset);
value = font_spec_from_name (name);
if (!FONTP (value))
signal_error ("Invalid font name", name);
}
else
signal_error ("Invalid font or font-spec", value);
}
if (EQ (frame, Qt))
f = XFRAME (selected_frame);
else
f = XFRAME (frame);
if (! FONT_OBJECT_P (value))
{
Lisp_Object *attrs = XVECTOR (lface)->contents;
Lisp_Object font_object;
font_object = font_load_for_lface (f, attrs, value);
if (NILP (font_object))
signal_error ("Font not available", value);
value = font_object;
}
set_lface_from_font (f, lface, value, 1);
}
else
LFACE_FONT (lface) = value;
}
#endif /* HAVE_WINDOW_SYSTEM */
}
else if (EQ (attr, QCfontset))
{
#ifdef HAVE_WINDOW_SYSTEM
if (EQ (frame, Qt) || FRAME_WINDOW_P (XFRAME (frame)))
{
Lisp_Object tmp;
old_value = LFACE_FONTSET (lface);
tmp = Fquery_fontset (value, Qnil);
if (NILP (tmp))
signal_error ("Invalid fontset name", value);
LFACE_FONTSET (lface) = value = tmp;
}
#endif /* HAVE_WINDOW_SYSTEM */
}
else if (EQ (attr, QCinherit))
{
Lisp_Object tail;
if (SYMBOLP (value))
tail = Qnil;
else
for (tail = value; CONSP (tail); tail = XCDR (tail))
if (!SYMBOLP (XCAR (tail)))
break;
if (NILP (tail))
LFACE_INHERIT (lface) = value;
else
signal_error ("Invalid face inheritance", value);
}
else if (EQ (attr, QCbold))
{
old_value = LFACE_WEIGHT (lface);
LFACE_WEIGHT (lface) = NILP (value) ? Qnormal : Qbold;
prop_index = FONT_WEIGHT_INDEX;
}
else if (EQ (attr, QCitalic))
{
attr = QCslant;
old_value = LFACE_SLANT (lface);
LFACE_SLANT (lface) = NILP (value) ? Qnormal : Qitalic;
prop_index = FONT_SLANT_INDEX;
}
else
signal_error ("Invalid face attribute name", attr);
if (prop_index)
{
/* If a font-related attribute other than QCfont and QCfontset
is specified, and if the original QCfont attribute has a font
(font-spec or font-object), set the corresponding property in
the font to nil so that the font selector doesn't think that
the attribute is mandatory. Also, clear the average
width. */
font_clear_prop (XVECTOR (lface)->contents, prop_index);
}
/* Changing a named face means that all realized faces depending on
that face are invalid. Since we cannot tell which realized faces
depend on the face, make sure they are all removed. This is done
by incrementing face_change_count. The next call to
init_iterator will then free realized faces. */
if (!EQ (frame, Qt)
&& NILP (Fget (face, Qface_no_inherit))
&& NILP (Fequal (old_value, value)))
{
++face_change_count;
++windows_or_buffers_changed;
}
if (!UNSPECIFIEDP (value) && !IGNORE_DEFFACE_P (value)
&& NILP (Fequal (old_value, value)))
{
Lisp_Object param;
param = Qnil;
if (EQ (face, Qdefault))
{
#ifdef HAVE_WINDOW_SYSTEM
/* Changed font-related attributes of the `default' face are
reflected in changed `font' frame parameters. */
if (FRAMEP (frame)
&& (prop_index || EQ (attr, QCfont))
&& lface_fully_specified_p (XVECTOR (lface)->contents))
set_font_frame_param (frame, lface);
else
#endif /* HAVE_WINDOW_SYSTEM */
if (EQ (attr, QCforeground))
param = Qforeground_color;
else if (EQ (attr, QCbackground))
param = Qbackground_color;
}
#ifdef HAVE_WINDOW_SYSTEM
#ifndef WINDOWSNT
else if (EQ (face, Qscroll_bar))
{
/* Changing the colors of `scroll-bar' sets frame parameters
`scroll-bar-foreground' and `scroll-bar-background'. */
if (EQ (attr, QCforeground))
param = Qscroll_bar_foreground;
else if (EQ (attr, QCbackground))
param = Qscroll_bar_background;
}
#endif /* not WINDOWSNT */
else if (EQ (face, Qborder))
{
/* Changing background color of `border' sets frame parameter
`border-color'. */
if (EQ (attr, QCbackground))
param = Qborder_color;
}
else if (EQ (face, Qcursor))
{
/* Changing background color of `cursor' sets frame parameter
`cursor-color'. */
if (EQ (attr, QCbackground))
param = Qcursor_color;
}
else if (EQ (face, Qmouse))
{
/* Changing background color of `mouse' sets frame parameter
`mouse-color'. */
if (EQ (attr, QCbackground))
param = Qmouse_color;
}
#endif /* HAVE_WINDOW_SYSTEM */
else if (EQ (face, Qmenu))
{
/* Indicate that we have to update the menu bar when
realizing faces on FRAME. FRAME t change the
default for new frames. We do this by setting
setting the flag in new face caches */
if (FRAMEP (frame))
{
struct frame *f = XFRAME (frame);
if (FRAME_FACE_CACHE (f) == NULL)
FRAME_FACE_CACHE (f) = make_face_cache (f);
FRAME_FACE_CACHE (f)->menu_face_changed_p = 1;
}
else
menu_face_changed_default = 1;
}
if (!NILP (param))
{
if (EQ (frame, Qt))
/* Update `default-frame-alist', which is used for new frames. */
{
store_in_alist (&Vdefault_frame_alist, param, value);
}
else
/* Update the current frame's parameters. */
{
Lisp_Object cons;
cons = XCAR (Vparam_value_alist);
XSETCAR (cons, param);
XSETCDR (cons, value);
Fmodify_frame_parameters (frame, Vparam_value_alist);
}
}
}
return face;
}
/* Update the corresponding face when frame parameter PARAM on frame F
has been assigned the value NEW_VALUE. */
void
update_face_from_frame_parameter (f, param, new_value)
struct frame *f;
Lisp_Object param, new_value;
{
Lisp_Object face = Qnil;
Lisp_Object lface;
/* If there are no faces yet, give up. This is the case when called
from Fx_create_frame, and we do the necessary things later in
face-set-after-frame-defaults. */
if (NILP (f->face_alist))
return;
if (EQ (param, Qforeground_color))
{
face = Qdefault;
lface = lface_from_face_name (f, face, 1);
LFACE_FOREGROUND (lface) = (STRINGP (new_value)
? new_value : Qunspecified);
realize_basic_faces (f);
}
else if (EQ (param, Qbackground_color))
{
Lisp_Object frame;
/* Changing the background color might change the background
mode, so that we have to load new defface specs.
Call frame-update-face-colors to do that. */
XSETFRAME (frame, f);
call1 (Qframe_set_background_mode, frame);
face = Qdefault;
lface = lface_from_face_name (f, face, 1);
LFACE_BACKGROUND (lface) = (STRINGP (new_value)
? new_value : Qunspecified);
realize_basic_faces (f);
}
#ifdef HAVE_WINDOW_SYSTEM
else if (EQ (param, Qborder_color))
{
face = Qborder;
lface = lface_from_face_name (f, face, 1);
LFACE_BACKGROUND (lface) = (STRINGP (new_value)
? new_value : Qunspecified);
}
else if (EQ (param, Qcursor_color))
{
face = Qcursor;
lface = lface_from_face_name (f, face, 1);
LFACE_BACKGROUND (lface) = (STRINGP (new_value)
? new_value : Qunspecified);
}
else if (EQ (param, Qmouse_color))
{
face = Qmouse;
lface = lface_from_face_name (f, face, 1);
LFACE_BACKGROUND (lface) = (STRINGP (new_value)
? new_value : Qunspecified);
}
#endif
/* Changing a named face means that all realized faces depending on
that face are invalid. Since we cannot tell which realized faces
depend on the face, make sure they are all removed. This is done
by incrementing face_change_count. The next call to
init_iterator will then free realized faces. */
if (!NILP (face)
&& NILP (Fget (face, Qface_no_inherit)))
{
++face_change_count;
++windows_or_buffers_changed;
}
}
#ifdef HAVE_WINDOW_SYSTEM
/* Set the `font' frame parameter of FRAME determined from the
font-object set in `default' face attributes LFACE. */
static void
set_font_frame_param (frame, lface)
Lisp_Object frame, lface;
{
struct frame *f = XFRAME (frame);
Lisp_Object font;
if (FRAME_WINDOW_P (f)
/* Don't do anything if the font is `unspecified'. This can
happen during frame creation. */
&& (font = LFACE_FONT (lface),
! UNSPECIFIEDP (font)))
{
if (FONT_SPEC_P (font))
{
font = font_load_for_lface (f, XVECTOR (lface)->contents, font);
if (NILP (font))
return;
LFACE_FONT (lface) = font;
}
f->default_face_done_p = 0;
Fmodify_frame_parameters (frame, Fcons (Fcons (Qfont, font), Qnil));
}
}
/* Get the value of X resource RESOURCE, class CLASS for the display
of frame FRAME. This is here because ordinary `x-get-resource'
doesn't take a frame argument. */
DEFUN ("internal-face-x-get-resource", Finternal_face_x_get_resource,
Sinternal_face_x_get_resource, 3, 3, 0, doc: /* */)
(resource, class, frame)
Lisp_Object resource, class, frame;
{
Lisp_Object value = Qnil;
CHECK_STRING (resource);
CHECK_STRING (class);
CHECK_LIVE_FRAME (frame);
BLOCK_INPUT;
value = display_x_get_resource (FRAME_X_DISPLAY_INFO (XFRAME (frame)),
resource, class, Qnil, Qnil);
UNBLOCK_INPUT;
return value;
}
/* Return resource string VALUE as a boolean value, i.e. nil, or t.
If VALUE is "on" or "true", return t. If VALUE is "off" or
"false", return nil. Otherwise, if SIGNAL_P is non-zero, signal an
error; if SIGNAL_P is zero, return 0. */
static Lisp_Object
face_boolean_x_resource_value (value, signal_p)
Lisp_Object value;
int signal_p;
{
Lisp_Object result = make_number (0);
xassert (STRINGP (value));
if (xstrcasecmp (SDATA (value), "on") == 0
|| xstrcasecmp (SDATA (value), "true") == 0)
result = Qt;
else if (xstrcasecmp (SDATA (value), "off") == 0
|| xstrcasecmp (SDATA (value), "false") == 0)
result = Qnil;
else if (xstrcasecmp (SDATA (value), "unspecified") == 0)
result = Qunspecified;
else if (signal_p)
signal_error ("Invalid face attribute value from X resource", value);
return result;
}
DEFUN ("internal-set-lisp-face-attribute-from-resource",
Finternal_set_lisp_face_attribute_from_resource,
Sinternal_set_lisp_face_attribute_from_resource,
3, 4, 0, doc: /* */)
(face, attr, value, frame)
Lisp_Object face, attr, value, frame;
{
CHECK_SYMBOL (face);
CHECK_SYMBOL (attr);
CHECK_STRING (value);
if (xstrcasecmp (SDATA (value), "unspecified") == 0)
value = Qunspecified;
else if (EQ (attr, QCheight))
{
value = Fstring_to_number (value, make_number (10));
if (XINT (value) <= 0)
signal_error ("Invalid face height from X resource", value);
}
else if (EQ (attr, QCbold) || EQ (attr, QCitalic))
value = face_boolean_x_resource_value (value, 1);
else if (EQ (attr, QCweight) || EQ (attr, QCslant) || EQ (attr, QCwidth))
value = intern (SDATA (value));
else if (EQ (attr, QCreverse_video) || EQ (attr, QCinverse_video))
value = face_boolean_x_resource_value (value, 1);
else if (EQ (attr, QCunderline)
|| EQ (attr, QCoverline)
|| EQ (attr, QCstrike_through))
{
Lisp_Object boolean_value;
/* If the result of face_boolean_x_resource_value is t or nil,
VALUE does NOT specify a color. */
boolean_value = face_boolean_x_resource_value (value, 0);
if (SYMBOLP (boolean_value))
value = boolean_value;
}
else if (EQ (attr, QCbox) || EQ (attr, QCinherit))
value = Fcar (Fread_from_string (value, Qnil, Qnil));
return Finternal_set_lisp_face_attribute (face, attr, value, frame);
}
#endif /* HAVE_WINDOW_SYSTEM */
/***********************************************************************
Menu face
***********************************************************************/
#if defined HAVE_X_WINDOWS && defined USE_X_TOOLKIT
/* Make menus on frame F appear as specified by the `menu' face. */
static void
x_update_menu_appearance (f)
struct frame *f;
{
struct x_display_info *dpyinfo = FRAME_X_DISPLAY_INFO (f);
XrmDatabase rdb;
if (dpyinfo
&& (rdb = XrmGetDatabase (FRAME_X_DISPLAY (f)),
rdb != NULL))
{
char line[512];
Lisp_Object lface = lface_from_face_name (f, Qmenu, 1);
struct face *face = FACE_FROM_ID (f, MENU_FACE_ID);
const char *myname = SDATA (Vx_resource_name);
int changed_p = 0;
#ifdef USE_MOTIF
const char *popup_path = "popup_menu";
#else
const char *popup_path = "menu.popup";
#endif
if (STRINGP (LFACE_FOREGROUND (lface)))
{
sprintf (line, "%s.%s*foreground: %s",
myname, popup_path,
SDATA (LFACE_FOREGROUND (lface)));
XrmPutLineResource (&rdb, line);
sprintf (line, "%s.pane.menubar*foreground: %s",
myname, SDATA (LFACE_FOREGROUND (lface)));
XrmPutLineResource (&rdb, line);
changed_p = 1;
}
if (STRINGP (LFACE_BACKGROUND (lface)))
{
sprintf (line, "%s.%s*background: %s",
myname, popup_path,
SDATA (LFACE_BACKGROUND (lface)));
XrmPutLineResource (&rdb, line);
sprintf (line, "%s.pane.menubar*background: %s",
myname, SDATA (LFACE_BACKGROUND (lface)));
XrmPutLineResource (&rdb, line);
changed_p = 1;
}
if (face->font
/* On Solaris 5.8, it's been reported that the `menu' face
can be unspecified here, during startup. Why this
happens remains unknown. -- cyd */
&& FONTP (LFACE_FONT (lface))
&& (!UNSPECIFIEDP (LFACE_FAMILY (lface))
|| !UNSPECIFIEDP (LFACE_FOUNDRY (lface))
|| !UNSPECIFIEDP (LFACE_SWIDTH (lface))
|| !UNSPECIFIEDP (LFACE_WEIGHT (lface))
|| !UNSPECIFIEDP (LFACE_SLANT (lface))
|| !UNSPECIFIEDP (LFACE_HEIGHT (lface))))
{
Lisp_Object xlfd = Ffont_xlfd_name (LFACE_FONT (lface), Qnil);
#ifdef USE_MOTIF
const char *suffix = "List";
Bool motif = True;
#else
#if defined HAVE_X_I18N
const char *suffix = "Set";
#else
const char *suffix = "";
#endif
Bool motif = False;
#endif
if (! NILP (xlfd))
{
#if defined HAVE_X_I18N
extern char *xic_create_fontsetname
P_ ((char *base_fontname, Bool motif));
char *fontsetname = xic_create_fontsetname (SDATA (xlfd), motif);
#else
char *fontsetname = (char *) SDATA (xlfd);
#endif
sprintf (line, "%s.pane.menubar*font%s: %s",
myname, suffix, fontsetname);
XrmPutLineResource (&rdb, line);
sprintf (line, "%s.%s*font%s: %s",
myname, popup_path, suffix, fontsetname);
XrmPutLineResource (&rdb, line);
changed_p = 1;
if (fontsetname != (char *) SDATA (xlfd))
xfree (fontsetname);
}
}
if (changed_p && f->output_data.x->menubar_widget)
free_frame_menubar (f);
}
}
#endif /* HAVE_X_WINDOWS && USE_X_TOOLKIT */
DEFUN ("face-attribute-relative-p", Fface_attribute_relative_p,
Sface_attribute_relative_p,
2, 2, 0,
doc: /* Check whether a face attribute value is relative.
Specifically, this function returns t if the attribute ATTRIBUTE
with the value VALUE is relative.
A relative value is one that doesn't entirely override whatever is
inherited from another face. For most possible attributes,
the only relative value that users see is `unspecified'.
However, for :height, floating point values are also relative. */)
(attribute, value)
Lisp_Object attribute, value;
{
if (EQ (value, Qunspecified) || (EQ (value, Qignore_defface)))
return Qt;
else if (EQ (attribute, QCheight))
return INTEGERP (value) ? Qnil : Qt;
else
return Qnil;
}
DEFUN ("merge-face-attribute", Fmerge_face_attribute, Smerge_face_attribute,
3, 3, 0,
doc: /* Return face ATTRIBUTE VALUE1 merged with VALUE2.
If VALUE1 or VALUE2 are absolute (see `face-attribute-relative-p'), then
the result will be absolute, otherwise it will be relative. */)
(attribute, value1, value2)
Lisp_Object attribute, value1, value2;
{
if (EQ (value1, Qunspecified) || EQ (value1, Qignore_defface))
return value2;
else if (EQ (attribute, QCheight))
return merge_face_heights (value1, value2, value1);
else
return value1;
}
DEFUN ("internal-get-lisp-face-attribute", Finternal_get_lisp_face_attribute,
Sinternal_get_lisp_face_attribute,
2, 3, 0,
doc: /* Return face attribute KEYWORD of face SYMBOL.
If SYMBOL does not name a valid Lisp face or KEYWORD isn't a valid
face attribute name, signal an error.
If the optional argument FRAME is given, report on face SYMBOL in that
frame. If FRAME is t, report on the defaults for face SYMBOL (for new
frames). If FRAME is omitted or nil, use the selected frame. */)
(symbol, keyword, frame)
Lisp_Object symbol, keyword, frame;
{
Lisp_Object lface, value = Qnil;
CHECK_SYMBOL (symbol);
CHECK_SYMBOL (keyword);
if (EQ (frame, Qt))
lface = lface_from_face_name (NULL, symbol, 1);
else
{
if (NILP (frame))
frame = selected_frame;
CHECK_LIVE_FRAME (frame);
lface = lface_from_face_name (XFRAME (frame), symbol, 1);
}
if (EQ (keyword, QCfamily))
value = LFACE_FAMILY (lface);
else if (EQ (keyword, QCfoundry))
value = LFACE_FOUNDRY (lface);
else if (EQ (keyword, QCheight))
value = LFACE_HEIGHT (lface);
else if (EQ (keyword, QCweight))
value = LFACE_WEIGHT (lface);
else if (EQ (keyword, QCslant))
value = LFACE_SLANT (lface);
else if (EQ (keyword, QCunderline))
value = LFACE_UNDERLINE (lface);
else if (EQ (keyword, QCoverline))
value = LFACE_OVERLINE (lface);
else if (EQ (keyword, QCstrike_through))
value = LFACE_STRIKE_THROUGH (lface);
else if (EQ (keyword, QCbox))
value = LFACE_BOX (lface);
else if (EQ (keyword, QCinverse_video)
|| EQ (keyword, QCreverse_video))
value = LFACE_INVERSE (lface);
else if (EQ (keyword, QCforeground))
value = LFACE_FOREGROUND (lface);
else if (EQ (keyword, QCbackground))
value = LFACE_BACKGROUND (lface);
else if (EQ (keyword, QCstipple))
value = LFACE_STIPPLE (lface);
else if (EQ (keyword, QCwidth))
value = LFACE_SWIDTH (lface);
else if (EQ (keyword, QCinherit))
value = LFACE_INHERIT (lface);
else if (EQ (keyword, QCfont))
value = LFACE_FONT (lface);
else if (EQ (keyword, QCfontset))
value = LFACE_FONTSET (lface);
else
signal_error ("Invalid face attribute name", keyword);
if (IGNORE_DEFFACE_P (value))
return Qunspecified;
return value;
}
DEFUN ("internal-lisp-face-attribute-values",
Finternal_lisp_face_attribute_values,
Sinternal_lisp_face_attribute_values, 1, 1, 0,
doc: /* Return a list of valid discrete values for face attribute ATTR.
Value is nil if ATTR doesn't have a discrete set of valid values. */)
(attr)
Lisp_Object attr;
{
Lisp_Object result = Qnil;
CHECK_SYMBOL (attr);
if (EQ (attr, QCunderline))
result = Fcons (Qt, Fcons (Qnil, Qnil));
else if (EQ (attr, QCoverline))
result = Fcons (Qt, Fcons (Qnil, Qnil));
else if (EQ (attr, QCstrike_through))
result = Fcons (Qt, Fcons (Qnil, Qnil));
else if (EQ (attr, QCinverse_video) || EQ (attr, QCreverse_video))
result = Fcons (Qt, Fcons (Qnil, Qnil));
return result;
}
DEFUN ("internal-merge-in-global-face", Finternal_merge_in_global_face,
Sinternal_merge_in_global_face, 2, 2, 0,