return csl;
}
-/* if two common sequences are separated by only an add or remove,
+/* If two common sequences are separated by only an add or remove,
* and the first common ends the same as the middle text,
* extend the second and contract the first in the hope that the
* first might become empty. This ameliorates against the greedyness
* of the 'diff' algorithm.
+ * We treat the final zero-length 'csl' as a common sequence which
+ * can be extended so we much make sure to add a new zero-length csl
+ * to the end.
* Once this is done, repeat the process but extend the first
- * in favour of the second. The acknowledges that semantic units
- * more often end with common text ("return 0;\n}\n", "\n") than
- * start with it.
+ * in favour of the second but only up to the last newline. This
+ * acknowledges that semantic units more often end with common
+ * text ("return 0;\n}\n", "\n") than start with it.
*/
static void fixup(struct file *a, struct file *b, struct csl *list)
{
struct csl *list1, *orig;
int lasteol = -1;
+ int found_end = 0;
if (!list) return;
orig = list;
list1 = list+1;
- while (list->len && list1->len) {
+ while (list->len) {
+ if (list1->len == 0)
+ found_end = 1;
+
if ((list->a+list->len == list1->a &&
+ list->b+list->len != list1->b &&
/* text at b inserted */
match(&b->list[list->b+list->len-1],
&b->list[list1->b-1])
- )
+ )
||
(list->b+list->len == list1->b &&
+ list->a+list->len != list1->a &&
/* text at a deleted */
match(&a->list[list->a+list->len-1],
&a->list[list1->a-1])
)
) {
-/* printword(a->list[list1->a-1]);
+#if 0
+ printword(stderr, a->list[list1->a-1]);
printf("fixup %d,%d %d : %d,%d %d\n",
list->a,list->b,list->len,
list1->a,list1->b,list1->len);
-*/ if (ends_line(a->list[list->a+list->len-1])
+#endif
+ if (ends_line(a->list[list->a+list->len-1])
&& a->list[list->a+list->len-1].len==1
&& lasteol == -1
) {
-/* printf("E\n");*/
+#if 0
+ printf("E\n");
+#endif
lasteol = list1->a-1;
}
list1->a--;
list->len--;
if (list->len == 0) {
lasteol = -1;
- if (list > orig)
+ if (found_end) {
+ *list = *list1;
+ list1->a += list1->len;
+ list1->b += list1->len;
+ list1->len = 0;
+ } else if (list > orig)
list--;
else {
*list = *list1++;
} else {
if (lasteol >= 0) {
/* printf("seek %d\n", lasteol);*/
- while (list1->a <= lasteol && list1->len>1) {
+ while (list1->a <= lasteol && (list1->len>1 ||
+ (found_end && list1->len > 0))) {
list1->a++;
list1->b++;
list1->len--;
}
lasteol=-1;
}
- *++list = *list1++;
+ *++list = *list1;
+ if (found_end) {
+ list1->a += list1->len;
+ list1->b += list1->len;
+ list1->len = 0;
+ } else
+ list1++;
}
+ if (list->len && list1 == list) abort();
}
- list[1] = list1[0];
+ // list[1] = list1[0];
}
struct csl *diff(struct file a, struct file b)
--- /dev/null
+/* xfaces.c -- "Face" primitives.
+ Copyright (C) 1993, 1994, 1998, 1999, 2000, 2001
+ Free Software Foundation.
+
+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 2, 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; see the file COPYING. If not, write to
+the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
+Boston, MA 02111-1307, USA. */
+
+/* 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. Relative proportionate width, aka character set width or set
+ width (swidth), e.g. `semi-compressed'.
+
+ 3. Font height in 1/10pt.
+
+ 4. Font weight, e.g. `bold'.
+
+ 5. Font slant, e.g. `italic'.
+
+ 6. Foreground color.
+
+ 7. Background color.
+
+ 8. Whether or not characters should be underlined, and in what color.
+
+ 9. Whether or not characters should be displayed in inverse video.
+
+ 10. A background stipple, a bitmap.
+
+ 11. Whether or not characters should be overlined, and in what color.
+
+ 12. Whether or not characters should be strike-through, and in what
+ color.
+
+ 13. Whether or not a box should be drawn around characters, the box
+ type, and, for simple boxes, in what color.
+
+ 14. Font or fontset pattern, or nil. This is a special attribute.
+ When this attribute is specified, the face uses a font opened by
+ that pattern as is. In addition, all the other font-related
+ attributes (1st thru 5th) are generated from the opened font name.
+ On the other hand, if one of the other font-related attributes are
+ specified, this attribute is set to nil. In that case, the face
+ doesn't inherit this attribute from the `default' face, and uses a
+ font determined by the other attributes (those may be inherited
+ from the `default' face).
+
+ 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.
+
+ 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 face 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 <sys/types.h>
+#include <sys/stat.h>
+#include "lisp.h"
+#include "charset.h"
+#include "keyboard.h"
+#include "frame.h"
+
+#ifdef HAVE_WINDOW_SYSTEM
+#include "fontset.h"
+#endif /* HAVE_WINDOW_SYSTEM */
+
+#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 x_list_fonts w32_list_fonts
+#define GCGraphicsExposures 0
+/* For historic reasons, FONT_WIDTH refers to average width on W32,
+ not maximum as on X. Redefine here. */
+#undef FONT_WIDTH
+#define FONT_WIDTH FONT_MAX_WIDTH
+#endif /* WINDOWSNT */
+
+#ifdef macintosh
+#include "macterm.h"
+#define x_display_info mac_display_info
+#define check_x check_mac
+
+extern XGCValues *XCreateGC (void *, WindowPtr, unsigned long, XGCValues *);
+
+static INLINE GC
+x_create_gc (f, mask, xgcv)
+ struct frame *f;
+ unsigned long mask;
+ XGCValues *xgcv;
+{
+ GC gc;
+ gc = XCreateGC (FRAME_MAC_DISPLAY (f), FRAME_MAC_WINDOW (f), mask, xgcv);
+ return gc;
+}
+
+static INLINE void
+x_free_gc (f, gc)
+ struct frame *f;
+ GC gc;
+{
+ XFreeGC (FRAME_MAC_DISPLAY (f), gc);
+}
+#endif
+
+#include "buffer.h"
+#include "dispextern.h"
+#include "blockinput.h"
+#include "window.h"
+#include "intervals.h"
+
+#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 <stdio.h>
+#include <ctype.h>
+
+#ifndef max
+#define max(A, B) ((A) > (B) ? (A) : (B))
+#define min(A, B) ((A) < (B) ? (A) : (B))
+#define abs(X) ((X) < 0 ? -(X) : (X))
+#endif
+
+/* 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)
+
+/* 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 (XSTRING ((S))->data)
+
+/* Size of hash table of realized faces in face caches (should be a
+ prime number). */
+
+#define FACE_CACHE_BUCKETS_SIZE 1001
+
+/* A definition of XColor for non-X frames. */
+
+#ifndef HAVE_X_WINDOWS
+
+typedef struct
+{
+ unsigned long pixel;
+ unsigned short red, green, blue;
+ char flags;
+ char pad;
+}
+XColor;
+
+#endif /* not HAVE_X_WINDOWS */
+
+/* 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;
+
+/* 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;
+
+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_update_face_colors. */
+
+Lisp_Object Qframe_update_face_colors;
+
+/* Names of basic faces. */
+
+Lisp_Object Qdefault, Qtool_bar, Qregion, Qfringe;
+Lisp_Object Qheader_line, Qscroll_bar, Qcursor, Qborder, Qmouse, Qmenu;
+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;
+
+/* Names of frame parameters related to faces. */
+
+extern Lisp_Object Qscroll_bar_foreground, Qscroll_bar_background;
+extern Lisp_Object Qborder_color, Qcursor_color, Qmouse_color;
+
+/* 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;
+
+/* 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;
+
+/* 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;
+
+/* 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;
+
+/* 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;
+
+\f
+/* Function prototypes. */
+
+struct font_name;
+struct table_entry;
+
+static void map_tty_color P_ ((struct frame *, struct face *,
+ enum lface_attribute_index, int *));
+static Lisp_Object resolve_face_name P_ ((Lisp_Object));
+static int may_use_scalable_font_p P_ ((char *));
+static void set_font_frame_param P_ ((Lisp_Object, Lisp_Object));
+static int better_font_p P_ ((int *, struct font_name *, struct font_name *,
+ int, int));
+static int x_face_list_fonts P_ ((struct frame *, char *,
+ struct font_name *, int, int));
+static int font_scalable_p P_ ((struct font_name *));
+static int get_lface_attributes P_ ((struct frame *, Lisp_Object, Lisp_Object *, int));
+static int load_pixmap P_ ((struct frame *, Lisp_Object, unsigned *, unsigned *));
+static unsigned char *xstrlwr P_ ((unsigned char *));
+static void signal_error P_ ((char *, Lisp_Object));
+static struct frame *frame_or_selected_frame P_ ((Lisp_Object, int));
+static void load_face_font P_ ((struct frame *, struct face *, 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 char *build_font_name P_ ((struct font_name *));
+static void free_font_names P_ ((struct font_name *, int));
+static int sorted_font_list P_ ((struct frame *, char *,
+ int (*cmpfn) P_ ((const void *, const void *)),
+ struct font_name **));
+static int font_list_1 P_ ((struct frame *, Lisp_Object, Lisp_Object,
+ Lisp_Object, struct font_name **));
+static int font_list P_ ((struct frame *, Lisp_Object, Lisp_Object,
+ Lisp_Object, struct font_name **));
+static int try_font_list P_ ((struct frame *, Lisp_Object *,
+ Lisp_Object, Lisp_Object, struct font_name **));
+static int try_alternative_families P_ ((struct frame *f, Lisp_Object,
+ Lisp_Object, struct font_name **));
+static int cmp_font_names P_ ((const void *, const void *));
+static struct face *realize_face P_ ((struct face_cache *, Lisp_Object *, int,
+ struct face *, int));
+static struct face *realize_x_face P_ ((struct face_cache *,
+ Lisp_Object *, int, struct face *));
+static struct face *realize_tty_face P_ ((struct face_cache *,
+ Lisp_Object *, int));
+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 free_realized_face P_ ((struct frame *, struct face *));
+static void clear_face_gcs P_ ((struct face_cache *));
+static void free_face_cache P_ ((struct face_cache *));
+static int face_numeric_weight P_ ((Lisp_Object));
+static int face_numeric_slant P_ ((Lisp_Object));
+static int face_numeric_swidth P_ ((Lisp_Object));
+static int face_fontset P_ ((Lisp_Object *));
+static char *choose_face_font P_ ((struct frame *, Lisp_Object *, int, int));
+static void merge_face_vectors P_ ((struct frame *, Lisp_Object *, Lisp_Object*, Lisp_Object));
+static void merge_face_inheritance P_ ((struct frame *f, Lisp_Object,
+ Lisp_Object *, Lisp_Object));
+static void merge_face_vector_with_property P_ ((struct frame *, Lisp_Object *,
+ Lisp_Object));
+static int set_lface_from_font_name P_ ((struct frame *, Lisp_Object,
+ Lisp_Object, int, 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 free_realized_faces P_ ((struct face_cache *));
+static char *best_matching_font P_ ((struct frame *, Lisp_Object *,
+ struct font_name *, int, int));
+static void cache_face P_ ((struct face_cache *, struct face *, unsigned));
+static void uncache_face P_ ((struct face_cache *, struct face *));
+static int xlfd_numeric_slant P_ ((struct font_name *));
+static int xlfd_numeric_weight P_ ((struct font_name *));
+static int xlfd_numeric_swidth P_ ((struct font_name *));
+static Lisp_Object xlfd_symbolic_slant P_ ((struct font_name *));
+static Lisp_Object xlfd_symbolic_weight P_ ((struct font_name *));
+static Lisp_Object xlfd_symbolic_swidth P_ ((struct font_name *));
+static int xlfd_fixed_p P_ ((struct font_name *));
+static int xlfd_numeric_value P_ ((struct table_entry *, int, struct font_name *,
+ int, int));
+static Lisp_Object xlfd_symbolic_value P_ ((struct table_entry *, int,
+ struct font_name *, int,
+ Lisp_Object));
+static struct table_entry *xlfd_lookup_field_contents P_ ((struct table_entry *, int,
+ struct font_name *, int));
+
+#ifdef HAVE_WINDOW_SYSTEM
+
+static int split_font_name P_ ((struct frame *, struct font_name *, int));
+static int xlfd_point_size P_ ((struct frame *, struct font_name *));
+static void sort_fonts P_ ((struct frame *, struct font_name *, int,
+ int (*cmpfn) P_ ((const void *, const void *))));
+static GC x_create_gc P_ ((struct frame *, unsigned long, XGCValues *));
+static void x_free_gc P_ ((struct frame *, GC));
+static void clear_font_table P_ ((struct x_display_info *));
+
+#ifdef WINDOWSNT
+extern Lisp_Object w32_list_fonts P_ ((struct frame *, Lisp_Object, int, int));
+#endif /* WINDOWSNT */
+
+#ifdef USE_X_TOOLKIT
+static void x_update_menu_appearance P_ ((struct frame *));
+#endif /* USE_X_TOOLKIT */
+
+#endif /* HAVE_WINDOW_SYSTEM */
+
+\f
+/***********************************************************************
+ 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,
+ "Dump currently allocated colors and their reference counts 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;
+{
+ BLOCK_INPUT;
+ xassert (--ngcs >= 0);
+ XFreeGC (FRAME_X_DISPLAY (f), gc);
+ UNBLOCK_INPUT;
+}
+
+#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;
+{
+ BLOCK_INPUT;
+ xassert (--ngcs >= 0);
+ xfree (gc);
+ UNBLOCK_INPUT;
+}
+
+#endif /* WINDOWSNT */
+
+/* Like stricmp. Used to compare parts of font names which are in
+ ISO8859-1. */
+
+int
+xstricmp (s1, s2)
+ 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;
+}
+
+
+/* Like strlwr, which might not always be available. */
+
+static unsigned char *
+xstrlwr (s)
+ unsigned char *s;
+{
+ unsigned char *p = s;
+
+ for (p = s; *p; ++p)
+ *p = tolower (*p);
+
+ return s;
+}
+
+
+/* Signal `error' with message S, and additional argument ARG. */
+
+static void
+signal_error (s, arg)
+ char *s;
+ Lisp_Object arg;
+{
+ Fsignal (Qerror, Fcons (build_string (s), Fcons (arg, Qnil)));
+}
+
+
+/* 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, nparam);
+ return XFRAME (frame);
+}
+
+\f
+/***********************************************************************
+ 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))
+ {
+ if (FRAME_X_IMAGE_CACHE (f) == NULL)
+ FRAME_X_IMAGE_CACHE (f) = make_image_cache ();
+ ++FRAME_X_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
+ if (!realize_basic_faces (f))
+ abort ();
+}
+
+
+/* Free face cache of frame F. Called from Fdelete_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_X_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)
+ {
+ struct x_display_info *dpyinfo;
+
+ /* Fonts are common for frames on one display, i.e. on
+ one X screen. */
+ for (dpyinfo = x_display_list; dpyinfo; dpyinfo = dpyinfo->next)
+ if (dpyinfo->n_fonts > CLEAR_FONT_TABLE_NFONTS)
+ clear_font_table (dpyinfo);
+
+ /* 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_cache (f, 0);
+ }
+ }
+ }
+#endif /* HAVE_WINDOW_SYSTEM */
+}
+
+
+DEFUN ("clear-face-cache", Fclear_face_cache, Sclear_face_cache, 0, 1, 0,
+ "Clear face caches on all frames.\n\
+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;
+}
+
+
+
+#ifdef HAVE_WINDOW_SYSTEM
+
+
+/* Remove fonts from the font table of DPYINFO except for the default
+ ASCII fonts of frames on that display. Called from clear_face_cache
+ from time to time. */
+
+static void
+clear_font_table (dpyinfo)
+ struct x_display_info *dpyinfo;
+{
+ int i;
+
+ /* Free those fonts that are not used by frames on DPYINFO. */
+ for (i = 0; i < dpyinfo->n_fonts; ++i)
+ {
+ struct font_info *font_info = dpyinfo->font_table + i;
+ Lisp_Object tail, frame;
+
+ /* Check if slot is already free. */
+ if (font_info->name == NULL)
+ continue;
+
+ /* Don't free a default font of some frame on this display. */
+ FOR_EACH_FRAME (tail, frame)
+ {
+ struct frame *f = XFRAME (frame);
+ if (FRAME_WINDOW_P (f)
+ && FRAME_X_DISPLAY_INFO (f) == dpyinfo
+ && font_info->font == FRAME_FONT (f))
+ break;
+ }
+
+ if (!NILP (tail))
+ continue;
+
+ /* Free names. */
+ if (font_info->full_name != font_info->name)
+ xfree (font_info->full_name);
+ xfree (font_info->name);
+
+ /* Free the font. */
+ BLOCK_INPUT;
+#ifdef HAVE_X_WINDOWS
+ XFreeFont (dpyinfo->display, font_info->font);
+#endif
+#ifdef WINDOWSNT
+ w32_unload_font (dpyinfo, font_info->font);
+#endif
+ UNBLOCK_INPUT;
+
+ /* Mark font table slot free. */
+ font_info->font = NULL;
+ font_info->name = font_info->full_name = NULL;
+ }
+}
+
+#endif /* HAVE_WINDOW_SYSTEM */
+
+
+\f
+/***********************************************************************
+ X Pixmaps
+ ***********************************************************************/
+
+#ifdef HAVE_WINDOW_SYSTEM
+
+DEFUN ("bitmap-spec-p", Fbitmap_spec_p, Sbitmap_spec_p, 1, 1, 0,
+ "Value is non-nil if OBJECT is a valid bitmap specification.\n\
+A bitmap specification is either a string, a file name, or a list\n\
+(WIDTH HEIGHT DATA) where WIDTH is the pixel width of the bitmap,\n\
+HEIGHT is its height, and DATA is a string containing the bits of\n\
+the pixmap. Bits are stored row by row, each row occupies\n\
+(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 (STRING_BYTES (XSTRING (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;
+ Lisp_Object tem;
+
+ if (NILP (name))
+ return 0;
+
+ tem = Fbitmap_spec_p (name);
+ if (NILP (tem))
+ wrong_type_argument (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, XSTRING (bits)->data,
+ 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 */
+
+
+\f
+/***********************************************************************
+ Minimum font bounds
+ ***********************************************************************/
+
+#ifdef HAVE_WINDOW_SYSTEM
+
+/* Update the line_height of frame F. Return non-zero if line height
+ changes. */
+
+int
+frame_update_line_height (f)
+ struct frame *f;
+{
+ int line_height, changed_p;
+
+ line_height = FONT_HEIGHT (FRAME_FONT (f));
+ changed_p = line_height != FRAME_LINE_HEIGHT (f);
+ FRAME_LINE_HEIGHT (f) = line_height;
+ return changed_p;
+}
+
+#endif /* HAVE_WINDOW_SYSTEM */
+
+\f
+/***********************************************************************
+ Fonts
+ ***********************************************************************/
+
+#ifdef HAVE_WINDOW_SYSTEM
+
+/* Load font of face FACE which is used on frame F to display
+ character C. The name of the font to load is determined by lface
+ and fontset of FACE. */
+
+static void
+load_face_font (f, face, c)
+ struct frame *f;
+ struct face *face;
+ int c;
+{
+ struct font_info *font_info = NULL;
+ char *font_name;
+
+ face->font_info_id = -1;
+ face->font = NULL;
+
+ font_name = choose_face_font (f, face->lface, face->fontset, c);
+ if (!font_name)
+ return;
+
+ BLOCK_INPUT;
+ font_info = FS_LOAD_FACE_FONT (f, c, font_name, face);
+ UNBLOCK_INPUT;
+
+ if (font_info)
+ {
+ face->font_info_id = font_info->font_idx;
+ face->font = font_info->font;
+ face->font_name = font_info->full_name;
+ if (face->gc)
+ {
+ x_free_gc (f, face->gc);
+ face->gc = 0;
+ }
+ }
+ else
+ add_to_log ("Unable to load font %s",
+ build_string (font_name), Qnil);
+ xfree (font_name);
+}
+
+#endif /* HAVE_WINDOW_SYSTEM */
+
+
+\f
+/***********************************************************************
+ X Colors
+ ***********************************************************************/
+
+/* 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;
+{
+ Lisp_Object color_desc;
+ unsigned long color_idx = FACE_TTY_DEFAULT_COLOR;
+ unsigned long red = 0, green = 0, blue = 0;
+ int status = 1;
+
+ if (*color_name && !NILP (Ffboundp (Qtty_color_desc)))
+ {
+ Lisp_Object frame;
+
+ XSETFRAME (frame, f);
+ status = 0;
+ color_desc = call2 (Qtty_color_desc, build_string (color_name), frame);
+ if (CONSP (color_desc) && CONSP (XCDR (color_desc)))
+ {
+ color_idx = XINT (XCAR (XCDR (color_desc)));
+ if (CONSP (XCDR (XCDR (color_desc))))
+ {
+ red = XINT (XCAR (XCDR (XCDR (color_desc))));
+ green = XINT (XCAR (XCDR (XCDR (XCDR (color_desc)))));
+ blue = XINT (XCAR (XCDR (XCDR (XCDR (XCDR (color_desc))))));
+ }
+ status = 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. */
+ status = 1;
+ }
+ if (color_idx == FACE_TTY_DEFAULT_COLOR && *color_name)
+ {
+ if (strcmp (color_name, "unspecified-fg") == 0)
+ color_idx = FACE_TTY_DEFAULT_FG_COLOR;
+ else if (strcmp (color_name, "unspecified-bg") == 0)
+ color_idx = FACE_TTY_DEFAULT_BG_COLOR;
+ }
+
+ if (color_idx != FACE_TTY_DEFAULT_COLOR)
+ status = 1;
+
+ color_def->pixel = color_idx;
+ color_def->red = red;
+ color_def->green = green;
+ color_def->blue = blue;
+
+ 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 macintosh
+ else if (FRAME_MAC_P (f))
+ return mac_defined_color (f, color_name, color_def, alloc);
+#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);
+
+#ifdef WINDOWSNT
+ return vga_stdcolor_name (idx);
+#endif
+
+ return Qunspecified;
+}
+
+
+/* Return non-zero if COLOR_NAME is a shade of gray (or white or
+ black) on frame F. The algorithm is taken from 20.2 faces.el. */
+
+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 = ((abs (color.red - color.green)
+ < max (color.red, color.green) / 20)
+ && (abs (color.green - color.blue)
+ < max (color.green, color.blue) / 20)
+ && (abs (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 (FRAME_WINDOW_P (f)
+ ? (!NILP (Fxw_display_color_p (frame))
+ || xstricmp (color_name, "black") == 0
+ || xstricmp (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)))
+ : tty_defined_color (f, color_name, ¬_used, 0));
+}
+
+
+DEFUN ("color-gray-p", Fcolor_gray_p, Scolor_gray_p, 1, 2, 0,
+ "Return non-nil if COLOR is a shade of gray (or white or black).\n\
+FRAME specifies the frame and thus the display for interpreting COLOR.\n\
+If FRAME is nil or omitted, use the selected frame.")
+ (color, frame)
+ Lisp_Object color, frame;
+{
+ struct frame *f;
+
+ CHECK_FRAME (frame, 0);
+ CHECK_STRING (color, 0);
+ f = XFRAME (frame);
+ return face_color_gray_p (f, XSTRING (color)->data) ? Qt : Qnil;
+}
+
+
+DEFUN ("color-supported-p", Fcolor_supported_p,
+ Scolor_supported_p, 2, 3, 0,
+ "Return non-nil if COLOR can be displayed on FRAME.\n\
+BACKGROUND-P non-nil means COLOR is used as a background.\n\
+If FRAME is nil or omitted, use the selected frame.\n\
+COLOR must be a valid color name.")
+ (color, frame, background_p)
+ Lisp_Object frame, color, background_p;
+{
+ struct frame *f;
+
+ CHECK_FRAME (frame, 0);
+ CHECK_STRING (color, 0);
+ f = XFRAME (frame);
+ if (face_color_supported_p (f, XSTRING (color)->data, !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, XSTRING (name)->data, &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, XSTRING (bg)->data, 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;
+{
+#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 */
+
+
+\f
+/***********************************************************************
+ 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... */
+};
+
+/* Structure used for tables mapping XLFD weight, slant, and width
+ names to numeric and symbolic values. */
+
+struct table_entry
+{
+ char *name;
+ int numeric;
+ Lisp_Object *symbol;
+};
+
+/* Table of XLFD slant names and their numeric and symbolic
+ representations. This table must be sorted by slant names in
+ ascending order. */
+
+static struct table_entry slant_table[] =
+{
+ {"i", XLFD_SLANT_ITALIC, &Qitalic},
+ {"o", XLFD_SLANT_OBLIQUE, &Qoblique},
+ {"ot", XLFD_SLANT_OTHER, &Qitalic},
+ {"r", XLFD_SLANT_ROMAN, &Qnormal},
+ {"ri", XLFD_SLANT_REVERSE_ITALIC, &Qreverse_italic},
+ {"ro", XLFD_SLANT_REVERSE_OBLIQUE, &Qreverse_oblique}
+};
+
+/* Table of XLFD weight names. This table must be sorted by weight
+ names in ascending order. */
+
+static struct table_entry weight_table[] =
+{
+ {"black", XLFD_WEIGHT_ULTRA_BOLD, &Qultra_bold},
+ {"bold", XLFD_WEIGHT_BOLD, &Qbold},
+ {"book", XLFD_WEIGHT_SEMI_LIGHT, &Qsemi_light},
+ {"demi", XLFD_WEIGHT_SEMI_BOLD, &Qsemi_bold},
+ {"demibold", XLFD_WEIGHT_SEMI_BOLD, &Qsemi_bold},
+ {"extralight", XLFD_WEIGHT_EXTRA_LIGHT, &Qextra_light},
+ {"extrabold", XLFD_WEIGHT_EXTRA_BOLD, &Qextra_bold},
+ {"heavy", XLFD_WEIGHT_EXTRA_BOLD, &Qextra_bold},
+ {"light", XLFD_WEIGHT_LIGHT, &Qlight},
+ {"medium", XLFD_WEIGHT_MEDIUM, &Qnormal},
+ {"normal", XLFD_WEIGHT_MEDIUM, &Qnormal},
+ {"regular", XLFD_WEIGHT_MEDIUM, &Qnormal},
+ {"semibold", XLFD_WEIGHT_SEMI_BOLD, &Qsemi_bold},
+ {"semilight", XLFD_WEIGHT_SEMI_LIGHT, &Qsemi_light},
+ {"ultralight", XLFD_WEIGHT_ULTRA_LIGHT, &Qultra_light},
+ {"ultrabold", XLFD_WEIGHT_ULTRA_BOLD, &Qultra_bold}
+};
+
+/* Table of XLFD width names. This table must be sorted by width
+ names in ascending order. */
+
+static struct table_entry swidth_table[] =
+{
+ {"compressed", XLFD_SWIDTH_CONDENSED, &Qcondensed},
+ {"condensed", XLFD_SWIDTH_CONDENSED, &Qcondensed},
+ {"demiexpanded", XLFD_SWIDTH_SEMI_EXPANDED, &Qsemi_expanded},
+ {"expanded", XLFD_SWIDTH_EXPANDED, &Qexpanded},
+ {"extracondensed", XLFD_SWIDTH_EXTRA_CONDENSED, &Qextra_condensed},
+ {"extraexpanded", XLFD_SWIDTH_EXTRA_EXPANDED, &Qextra_expanded},
+ {"medium", XLFD_SWIDTH_MEDIUM, &Qnormal},
+ {"narrow", XLFD_SWIDTH_CONDENSED, &Qcondensed},
+ {"normal", XLFD_SWIDTH_MEDIUM, &Qnormal},
+ {"regular", XLFD_SWIDTH_MEDIUM, &Qnormal},
+ {"semicondensed", XLFD_SWIDTH_SEMI_CONDENSED, &Qsemi_condensed},
+ {"semiexpanded", XLFD_SWIDTH_SEMI_EXPANDED, &Qsemi_expanded},
+ {"ultracondensed", XLFD_SWIDTH_ULTRA_CONDENSED, &Qultra_condensed},
+ {"ultraexpanded", XLFD_SWIDTH_ULTRA_EXPANDED, &Qultra_expanded},
+ {"wide", XLFD_SWIDTH_EXTRA_EXPANDED, &Qextra_expanded}
+};
+
+/* Structure used to hold the result of splitting font names in XLFD
+ format into their fields. */
+
+struct font_name
+{
+ /* The original name which is modified destructively by
+ split_font_name. The pointer is kept here to be able to free it
+ if it was allocated from the heap. */
+ char *name;
+
+ /* Font name fields. Each vector element points into `name' above.
+ Fields are NUL-terminated. */
+ char *fields[XLFD_LAST];
+
+ /* Numeric values for those fields that interest us. See
+ split_font_name for which these are. */
+ int numeric[XLFD_LAST];
+
+ /* Lower value mean higher priority. */
+ int registry_priority;
+};
+
+/* The frame in effect when sorting font names. Set temporarily in
+ sort_fonts so that it is available in font comparison functions. */
+
+static struct frame *font_frame;
+
+/* 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. */
+
+#ifdef macintosh
+static int font_sort_order[4] = {
+ XLFD_SWIDTH, XLFD_POINT_SIZE, XLFD_WEIGHT, XLFD_SLANT
+};
+#else
+static int font_sort_order[4];
+#endif
+
+/* Look up FONT.fields[FIELD_INDEX] in TABLE which has DIM entries.
+ TABLE must be sorted by TABLE[i]->name in ascending order. Value
+ is a pointer to the matching table entry or null if no table entry
+ matches. */
+
+static struct table_entry *
+xlfd_lookup_field_contents (table, dim, font, field_index)
+ struct table_entry *table;
+ int dim;
+ struct font_name *font;
+ int field_index;
+{
+ /* Function split_font_name converts fields to lower-case, so there
+ is no need to use xstrlwr or xstricmp here. */
+ char *s = font->fields[field_index];
+ int low, mid, high, cmp;
+
+ low = 0;
+ high = dim - 1;
+
+ while (low <= high)
+ {
+ mid = (low + high) / 2;
+ cmp = strcmp (table[mid].name, s);
+
+ if (cmp < 0)
+ low = mid + 1;
+ else if (cmp > 0)
+ high = mid - 1;
+ else
+ return table + mid;
+ }
+
+ return NULL;
+}
+
+
+/* Return a numeric representation for font name field
+ FONT.fields[FIELD_INDEX]. The field is looked up in TABLE which
+ has DIM entries. Value is the numeric value found or DFLT if no
+ table entry matches. This function is used to translate weight,
+ slant, and swidth names of XLFD font names to numeric values. */
+
+static INLINE int
+xlfd_numeric_value (table, dim, font, field_index, dflt)
+ struct table_entry *table;
+ int dim;
+ struct font_name *font;
+ int field_index;
+ int dflt;
+{
+ struct table_entry *p;
+ p = xlfd_lookup_field_contents (table, dim, font, field_index);
+ return p ? p->numeric : dflt;
+}
+
+
+/* Return a symbolic representation for font name field
+ FONT.fields[FIELD_INDEX]. The field is looked up in TABLE which
+ has DIM entries. Value is the symbolic value found or DFLT if no
+ table entry matches. This function is used to translate weight,
+ slant, and swidth names of XLFD font names to symbols. */
+
+static INLINE Lisp_Object
+xlfd_symbolic_value (table, dim, font, field_index, dflt)
+ struct table_entry *table;
+ int dim;
+ struct font_name *font;
+ int field_index;
+ Lisp_Object dflt;
+{
+ struct table_entry *p;
+ p = xlfd_lookup_field_contents (table, dim, font, field_index);
+ return p ? *p->symbol : dflt;
+}
+
+
+/* Return a numeric value for the slant of the font given by FONT. */
+
+static INLINE int
+xlfd_numeric_slant (font)
+ struct font_name *font;
+{
+ return xlfd_numeric_value (slant_table, DIM (slant_table),
+ font, XLFD_SLANT, XLFD_SLANT_ROMAN);
+}
+
+
+/* Return a symbol representing the weight of the font given by FONT. */
+
+static INLINE Lisp_Object
+xlfd_symbolic_slant (font)
+ struct font_name *font;
+{
+ return xlfd_symbolic_value (slant_table, DIM (slant_table),
+ font, XLFD_SLANT, Qnormal);
+}
+
+
+/* Return a numeric value for the weight of the font given by FONT. */
+
+static INLINE int
+xlfd_numeric_weight (font)
+ struct font_name *font;
+{
+ return xlfd_numeric_value (weight_table, DIM (weight_table),
+ font, XLFD_WEIGHT, XLFD_WEIGHT_MEDIUM);
+}
+
+
+/* Return a symbol representing the slant of the font given by FONT. */
+
+static INLINE Lisp_Object
+xlfd_symbolic_weight (font)
+ struct font_name *font;
+{
+ return xlfd_symbolic_value (weight_table, DIM (weight_table),
+ font, XLFD_WEIGHT, Qnormal);
+}
+
+
+/* Return a numeric value for the swidth of the font whose XLFD font
+ name fields are found in FONT. */
+
+static INLINE int
+xlfd_numeric_swidth (font)
+ struct font_name *font;
+{
+ return xlfd_numeric_value (swidth_table, DIM (swidth_table),
+ font, XLFD_SWIDTH, XLFD_SWIDTH_MEDIUM);
+}
+
+
+/* Return a symbolic value for the swidth of FONT. */
+
+static INLINE Lisp_Object
+xlfd_symbolic_swidth (font)
+ struct font_name *font;
+{
+ return xlfd_symbolic_value (swidth_table, DIM (swidth_table),
+ font, XLFD_SWIDTH, Qnormal);
+}
+
+
+/* Look up the entry of SYMBOL in the vector TABLE which has DIM
+ entries. Value is a pointer to the matching table entry or null if
+ no element of TABLE contains SYMBOL. */
+
+static struct table_entry *
+face_value (table, dim, symbol)
+ struct table_entry *table;
+ int dim;
+ Lisp_Object symbol;
+{
+ int i;
+
+ xassert (SYMBOLP (symbol));
+
+ for (i = 0; i < dim; ++i)
+ if (EQ (*table[i].symbol, symbol))
+ break;
+
+ return i < dim ? table + i : NULL;
+}
+
+
+/* Return a numeric value for SYMBOL in the vector TABLE which has DIM
+ entries. Value is -1 if SYMBOL is not found in TABLE. */
+
+static INLINE int
+face_numeric_value (table, dim, symbol)
+ struct table_entry *table;
+ int dim;
+ Lisp_Object symbol;
+{
+ struct table_entry *p = face_value (table, dim, symbol);
+ return p ? p->numeric : -1;
+}
+
+
+/* Return a numeric value representing the weight specified by Lisp
+ symbol WEIGHT. Value is one of the enumerators of enum
+ xlfd_weight. */
+
+static INLINE int
+face_numeric_weight (weight)
+ Lisp_Object weight;
+{
+ return face_numeric_value (weight_table, DIM (weight_table), weight);
+}
+
+
+/* Return a numeric value representing the slant specified by Lisp
+ symbol SLANT. Value is one of the enumerators of enum xlfd_slant. */
+
+static INLINE int
+face_numeric_slant (slant)
+ Lisp_Object slant;
+{
+ return face_numeric_value (slant_table, DIM (slant_table), slant);
+}
+
+
+/* Return a numeric value representing the swidth specified by Lisp
+ symbol WIDTH. Value is one of the enumerators of enum xlfd_swidth. */
+
+static int
+face_numeric_swidth (width)
+ Lisp_Object width;
+{
+ return face_numeric_value (swidth_table, DIM (swidth_table), width);
+}
+
+
+#ifdef HAVE_WINDOW_SYSTEM
+
+/* Return non-zero if FONT is the name of a fixed-pitch font. */
+
+static INLINE int
+xlfd_fixed_p (font)
+ struct font_name *font;
+{
+ /* Function split_font_name converts fields to lower-case, so there
+ is no need to use tolower here. */
+ return *font->fields[XLFD_SPACING] != 'p';
+}
+
+
+/* Return the point size of FONT on frame F, measured in 1/10 pt.
+
+ The actual height of the font when displayed on F depends on the
+ resolution of both the font and frame. For example, a 10pt font
+ designed for a 100dpi display will display larger than 10pt on a
+ 75dpi display. (It's not unusual to use fonts not designed for the
+ display one is using. For example, some intlfonts are available in
+ 72dpi versions, only.)
+
+ Value is the real point size of FONT on frame F, or 0 if it cannot
+ be determined. */
+
+static INLINE int
+xlfd_point_size (f, font)
+ struct frame *f;
+ struct font_name *font;
+{
+ double resy = FRAME_X_DISPLAY_INFO (f)->resy;
+ char *pixel_field = font->fields[XLFD_PIXEL_SIZE];
+ double pixel;
+ int real_pt;
+
+ if (*pixel_field == '[')
+ {
+ /* The pixel size field is `[A B C D]' which specifies
+ a transformation matrix.
+
+ A B 0
+ C D 0
+ 0 0 1
+
+ by which all glyphs of the font are transformed. The spec
+ says that s scalar value N for the pixel size is equivalent
+ to A = N * resx/resy, B = C = 0, D = N. */
+ char *start = pixel_field + 1, *end;
+ double matrix[4];
+ int i;
+
+ for (i = 0; i < 4; ++i)
+ {
+ matrix[i] = strtod (start, &end);
+ start = end;
+ }
+
+ pixel = matrix[3];
+ }
+ else
+ pixel = atoi (pixel_field);
+
+ if (pixel == 0)
+ real_pt = 0;
+ else
+ real_pt = PT_PER_INCH * 10.0 * pixel / resy + 0.5;
+
+ return real_pt;
+}
+
+
+/* Return point size of PIXEL dots while considering Y-resultion (DPI)
+ of frame F. This function is used to guess a point size of font
+ when only the pixel height of the font is available. */
+
+static INLINE int
+pixel_point_size (f, pixel)
+ struct frame *f;
+ int pixel;
+{
+ double resy = FRAME_X_DISPLAY_INFO (f)->resy;
+ double real_pt;
+ int int_pt;
+
+ /* As one inch is PT_PER_INCH points, PT_PER_INCH/RESY gives the
+ point size of one dot. */
+ real_pt = pixel * PT_PER_INCH / resy;
+ int_pt = real_pt + 0.5;
+
+ return int_pt;
+}
+
+
+/* Split XLFD font name FONT->name destructively into NUL-terminated,
+ lower-case fields in FONT->fields. NUMERIC_P non-zero means
+ compute numeric values for fields XLFD_POINT_SIZE, XLFD_SWIDTH,
+ XLFD_RESY, XLFD_SLANT, and XLFD_WEIGHT in FONT->numeric. Value is
+ zero if the font name doesn't have the format we expect. The
+ expected format is a font name that starts with a `-' and has
+ XLFD_LAST fields separated by `-'. */
+
+static int
+split_font_name (f, font, numeric_p)
+ struct frame *f;
+ struct font_name *font;
+ int numeric_p;
+{
+ int i = 0;
+ int success_p;
+
+ if (*font->name == '-')
+ {
+ char *p = xstrlwr (font->name) + 1;
+
+ while (i < XLFD_LAST)
+ {
+ font->fields[i] = p;
+ ++i;
+
+ /* Pixel and point size may be of the form `[....]'. For
+ BNF, see XLFD spec, chapter 4. Negative values are
+ indicated by tilde characters which we replace with
+ `-' characters, here. */
+ if (*p == '['
+ && (i - 1 == XLFD_PIXEL_SIZE
+ || i - 1 == XLFD_POINT_SIZE))
+ {
+ char *start, *end;
+ int j;
+
+ for (++p; *p && *p != ']'; ++p)
+ if (*p == '~')
+ *p = '-';
+
+ /* Check that the matrix contains 4 floating point
+ numbers. */
+ for (j = 0, start = font->fields[i - 1] + 1;
+ j < 4;
+ ++j, start = end)
+ if (strtod (start, &end) == 0 && start == end)
+ break;
+
+ if (j < 4)
+ break;
+ }
+
+ while (*p && *p != '-')
+ ++p;
+
+ if (*p != '-')
+ break;
+
+ *p++ = 0;
+ }
+ }
+
+ success_p = i == XLFD_LAST;
+
+ /* If requested, and font name was in the expected format,
+ compute numeric values for some fields. */
+ if (numeric_p && success_p)
+ {
+ font->numeric[XLFD_POINT_SIZE] = xlfd_point_size (f, font);
+ font->numeric[XLFD_RESY] = atoi (font->fields[XLFD_RESY]);
+ font->numeric[XLFD_SLANT] = xlfd_numeric_slant (font);
+ font->numeric[XLFD_WEIGHT] = xlfd_numeric_weight (font);
+ font->numeric[XLFD_SWIDTH] = xlfd_numeric_swidth (font);
+ font->numeric[XLFD_AVGWIDTH] = atoi (font->fields[XLFD_AVGWIDTH]);
+ }
+
+ /* Initialize it to zero. It will be overridden by font_list while
+ trying alternate registries. */
+ font->registry_priority = 0;
+
+ return success_p;
+}
+
+
+/* Build an XLFD font name from font name fields in FONT. Value is a
+ pointer to the font name, which is allocated via xmalloc. */
+
+static char *
+build_font_name (font)
+ struct font_name *font;
+{
+ int i;
+ int size = 100;
+ char *font_name = (char *) xmalloc (size);
+ int total_length = 0;
+
+ for (i = 0; i < XLFD_LAST; ++i)
+ {
+ /* Add 1 because of the leading `-'. */
+ int len = strlen (font->fields[i]) + 1;
+
+ /* Reallocate font_name if necessary. Add 1 for the final
+ NUL-byte. */
+ if (total_length + len + 1 >= size)
+ {
+ int new_size = max (2 * size, size + len + 1);
+ int sz = new_size * sizeof *font_name;
+ font_name = (char *) xrealloc (font_name, sz);
+ size = new_size;
+ }
+
+ font_name[total_length] = '-';
+ bcopy (font->fields[i], font_name + total_length + 1, len - 1);
+ total_length += len;
+ }
+
+ font_name[total_length] = 0;
+ return font_name;
+}
+
+
+/* Free an array FONTS of N font_name structures. This frees FONTS
+ itself and all `name' fields in its elements. */
+
+static INLINE void
+free_font_names (fonts, n)
+ struct font_name *fonts;
+ int n;
+{
+ while (n)
+ xfree (fonts[--n].name);
+ xfree (fonts);
+}
+
+
+/* Sort vector FONTS of font_name structures which contains NFONTS
+ elements using qsort and comparison function CMPFN. F is the frame
+ on which the fonts will be used. The global variable font_frame
+ is temporarily set to F to make it available in CMPFN. */
+
+static INLINE void
+sort_fonts (f, fonts, nfonts, cmpfn)
+ struct frame *f;
+ struct font_name *fonts;
+ int nfonts;
+ int (*cmpfn) P_ ((const void *, const void *));
+{
+ font_frame = f;
+ qsort (fonts, nfonts, sizeof *fonts, cmpfn);
+ font_frame = NULL;
+}
+
+
+/* Get fonts matching PATTERN on frame F. If F is null, use the first
+ display in x_display_list. FONTS is a pointer to a vector of
+ NFONTS font_name structures. TRY_ALTERNATIVES_P non-zero means try
+ alternative patterns from Valternate_fontname_alist if no fonts are
+ found matching PATTERN.
+
+ For all fonts found, set FONTS[i].name to the name of the font,
+ allocated via xmalloc, and split font names into fields. Ignore
+ fonts that we can't parse. Value is the number of fonts found. */
+
+static int
+x_face_list_fonts (f, pattern, fonts, nfonts, try_alternatives_p)
+ struct frame *f;
+ char *pattern;
+ struct font_name *fonts;
+ int nfonts, try_alternatives_p;
+{
+ int n, nignored;
+
+ /* NTEMACS_TODO : currently this uses w32_list_fonts, but it may be
+ better to do it the other way around. */
+ Lisp_Object lfonts;
+ Lisp_Object lpattern, tem;
+
+ lpattern = build_string (pattern);
+
+ /* Get the list of fonts matching PATTERN. */
+#ifdef WINDOWSNT
+ BLOCK_INPUT;
+ lfonts = w32_list_fonts (f, lpattern, 0, nfonts);
+ UNBLOCK_INPUT;
+#else
+ lfonts = x_list_fonts (f, lpattern, -1, nfonts);
+#endif
+
+ /* Make a copy of the font names we got from X, and
+ split them into fields. */
+ n = nignored = 0;
+ for (tem = lfonts; CONSP (tem) && n < nfonts; tem = XCDR (tem))
+ {
+ Lisp_Object elt, tail;
+ char *name = XSTRING (XCAR (tem))->data;
+
+ /* Ignore fonts matching a pattern from face-ignored-fonts. */
+ for (tail = Vface_ignored_fonts; CONSP (tail); tail = XCDR (tail))
+ {
+ elt = XCAR (tail);
+ if (STRINGP (elt)
+ && fast_c_string_match_ignore_case (elt, name) >= 0)
+ break;
+ }
+ if (!NILP (tail))
+ {
+ ++nignored;
+ continue;
+ }
+
+ /* Make a copy of the font name. */
+ fonts[n].name = xstrdup (name);
+
+ if (split_font_name (f, fonts + n, 1))
+ {
+ if (font_scalable_p (fonts + n)
+ && !may_use_scalable_font_p (name))
+ {
+ ++nignored;
+ xfree (fonts[n].name);
+ }
+ else
+ ++n;
+ }
+ else
+ xfree (fonts[n].name);
+ }
+
+ /* If no fonts found, try patterns from Valternate_fontname_alist. */
+ if (n == 0 && try_alternatives_p)
+ {
+ Lisp_Object list = Valternate_fontname_alist;
+
+ while (CONSP (list))
+ {
+ Lisp_Object entry = XCAR (list);
+ if (CONSP (entry)
+ && STRINGP (XCAR (entry))
+ && strcmp (XSTRING (XCAR (entry))->data, pattern) == 0)
+ break;
+ list = XCDR (list);
+ }
+
+ if (CONSP (list))
+ {
+ Lisp_Object patterns = XCAR (list);
+ Lisp_Object name;
+
+ while (CONSP (patterns)
+ /* If list is screwed up, give up. */
+ && (name = XCAR (patterns),
+ STRINGP (name))
+ /* Ignore patterns equal to PATTERN because we tried that
+ already with no success. */
+ && (strcmp (XSTRING (name)->data, pattern) == 0
+ || (n = x_face_list_fonts (f, XSTRING (name)->data,
+ fonts, nfonts, 0),
+ n == 0)))
+ patterns = XCDR (patterns);
+ }
+ }
+
+ return n;
+}
+
+
+/* Determine fonts matching PATTERN on frame F. Sort resulting fonts
+ using comparison function CMPFN. Value is the number of fonts
+ found. If value is non-zero, *FONTS is set to a vector of
+ font_name structures allocated from the heap containing matching
+ fonts. Each element of *FONTS contains a name member that is also
+ allocated from the heap. Font names in these structures are split
+ into fields. Use free_font_names to free such an array. */
+
+static int
+sorted_font_list (f, pattern, cmpfn, fonts)
+ struct frame *f;
+ char *pattern;
+ int (*cmpfn) P_ ((const void *, const void *));
+ struct font_name **fonts;
+{
+ int nfonts;
+
+ /* Get the list of fonts matching pattern. 100 should suffice. */
+ nfonts = DEFAULT_FONT_LIST_LIMIT;
+ if (INTEGERP (Vfont_list_limit) && XINT (Vfont_list_limit) > 0)
+ nfonts = XFASTINT (Vfont_list_limit);
+
+ *fonts = (struct font_name *) xmalloc (nfonts * sizeof **fonts);
+ nfonts = x_face_list_fonts (f, pattern, *fonts, nfonts, 1);
+
+ /* Sort the resulting array and return it in *FONTS. If no
+ fonts were found, make sure to set *FONTS to null. */
+ if (nfonts)
+ sort_fonts (f, *fonts, nfonts, cmpfn);
+ else
+ {
+ xfree (*fonts);
+ *fonts = NULL;
+ }
+
+ return nfonts;
+}
+
+
+/* Compare two font_name structures *A and *B. Value is analogous to
+ strcmp. Sort order is given by the global variable
+ font_sort_order. Font names are sorted so that, everything else
+ being equal, fonts with a resolution closer to that of the frame on
+ which they are used are listed first. The global variable
+ font_frame is the frame on which we operate. */
+
+static int
+cmp_font_names (a, b)
+ const void *a, *b;
+{
+ struct font_name *x = (struct font_name *) a;
+ struct font_name *y = (struct font_name *) b;
+ int cmp;
+
+ /* All strings have been converted to lower-case by split_font_name,
+ so we can use strcmp here. */
+ cmp = strcmp (x->fields[XLFD_FAMILY], y->fields[XLFD_FAMILY]);
+ if (cmp == 0)
+ {
+ int i;
+
+ for (i = 0; i < DIM (font_sort_order) && cmp == 0; ++i)
+ {
+ int j = font_sort_order[i];
+ cmp = x->numeric[j] - y->numeric[j];
+ }
+
+ if (cmp == 0)
+ {
+ /* Everything else being equal, we prefer fonts with an
+ y-resolution closer to that of the frame. */
+ int resy = FRAME_X_DISPLAY_INFO (font_frame)->resy;
+ int x_resy = x->numeric[XLFD_RESY];
+ int y_resy = y->numeric[XLFD_RESY];
+ cmp = abs (resy - x_resy) - abs (resy - y_resy);
+ }
+ }
+
+ return cmp;
+}
+
+
+/* Get a sorted list of fonts of family FAMILY on frame F. If PATTERN
+ is non-nil list fonts matching that pattern. Otherwise, if
+ REGISTRY is non-nil return only fonts with that registry, otherwise
+ return fonts of any registry. Set *FONTS to a vector of font_name
+ structures allocated from the heap containing the fonts found.
+ Value is the number of fonts found. */
+
+static int
+font_list_1 (f, pattern, family, registry, fonts)
+ struct frame *f;
+ Lisp_Object pattern, family, registry;
+ struct font_name **fonts;
+{
+ char *pattern_str, *family_str, *registry_str;
+
+ if (NILP (pattern))
+ {
+ family_str = (NILP (family) ? "*" : (char *) XSTRING (family)->data);
+ registry_str = (NILP (registry) ? "*" : (char *) XSTRING (registry)->data);
+
+ pattern_str = (char *) alloca (strlen (family_str)
+ + strlen (registry_str)
+ + 10);
+ strcpy (pattern_str, index (family_str, '-') ? "-" : "-*-");
+ strcat (pattern_str, family_str);
+ strcat (pattern_str, "-*-");
+ strcat (pattern_str, registry_str);
+ if (!index (registry_str, '-'))
+ {
+ if (registry_str[strlen (registry_str) - 1] == '*')
+ strcat (pattern_str, "-*");
+ else
+ strcat (pattern_str, "*-*");
+ }
+ }
+ else
+ pattern_str = (char *) XSTRING (pattern)->data;
+
+ return sorted_font_list (f, pattern_str, cmp_font_names, fonts);
+}
+
+
+/* Concatenate font list FONTS1 and FONTS2. FONTS1 and FONTS2
+ contains NFONTS1 fonts and NFONTS2 fonts respectively. Return a
+ pointer to a newly allocated font list. FONTS1 and FONTS2 are
+ freed. */
+
+static struct font_name *
+concat_font_list (fonts1, nfonts1, fonts2, nfonts2)
+ struct font_name *fonts1, *fonts2;
+ int nfonts1, nfonts2;
+{
+ int new_nfonts = nfonts1 + nfonts2;
+ struct font_name *new_fonts;
+
+ new_fonts = (struct font_name *) xmalloc (sizeof *new_fonts * new_nfonts);
+ bcopy (fonts1, new_fonts, sizeof *new_fonts * nfonts1);
+ bcopy (fonts2, new_fonts + nfonts1, sizeof *new_fonts * nfonts2);
+ xfree (fonts1);
+ xfree (fonts2);
+ return new_fonts;
+}
+
+
+/* Get a sorted list of fonts of family FAMILY on frame F.
+
+ If PATTERN is non-nil list fonts matching that pattern.
+
+ If REGISTRY is non-nil, return fonts with that registry and the
+ alternative registries from Vface_alternative_font_registry_alist.
+
+ If REGISTRY is nil return fonts of any registry.
+
+ Set *FONTS to a vector of font_name structures allocated from the
+ heap containing the fonts found. Value is the number of fonts
+ found. */
+
+static int
+font_list (f, pattern, family, registry, fonts)
+ struct frame *f;
+ Lisp_Object pattern, family, registry;
+ struct font_name **fonts;
+{
+ int nfonts = font_list_1 (f, pattern, family, registry, fonts);
+
+ if (!NILP (registry)
+ && CONSP (Vface_alternative_font_registry_alist))
+ {
+ Lisp_Object alter;
+
+ alter = Fassoc (registry, Vface_alternative_font_registry_alist);
+ if (CONSP (alter))
+ {
+ int reg_prio, i;
+
+ for (alter = XCDR (alter), reg_prio = 1;
+ CONSP (alter);
+ alter = XCDR (alter), reg_prio++)
+ if (STRINGP (XCAR (alter)))
+ {
+ int nfonts2;
+ struct font_name *fonts2;
+
+ nfonts2 = font_list_1 (f, pattern, family, XCAR (alter),
+ &fonts2);
+ for (i = 0; i < nfonts2; i++)
+ fonts2[i].registry_priority = reg_prio;
+ *fonts = (nfonts > 0
+ ? concat_font_list (*fonts, nfonts, fonts2, nfonts2)
+ : fonts2);
+ nfonts += nfonts2;
+ }
+ }
+ }
+
+ return nfonts;
+}
+
+
+/* Remove elements from LIST whose cars are `equal'. Called from
+ x-family-fonts and x-font-family-list to remove duplicate font
+ entries. */
+
+static void
+remove_duplicates (list)
+ Lisp_Object list;
+{
+ Lisp_Object tail = list;
+
+ while (!NILP (tail) && !NILP (XCDR (tail)))
+ {
+ Lisp_Object next = XCDR (tail);
+ if (!NILP (Fequal (XCAR (next), XCAR (tail))))
+ XCDR (tail) = XCDR (next);
+ else
+ tail = XCDR (tail);
+ }
+}
+
+
+DEFUN ("x-family-fonts", Fx_family_fonts, Sx_family_fonts, 0, 2, 0,
+ "Return a list of available fonts of family FAMILY on FRAME.\n\
+If FAMILY is omitted or nil, list all families.\n\
+Otherwise, FAMILY must be a string, possibly containing wildcards\n\
+`?' and `*'.\n\
+If FRAME is omitted or nil, use the selected frame.\n\
+Each element of the result is a vector [FAMILY WIDTH POINT-SIZE WEIGHT\n\
+SLANT FIXED-P FULL REGISTRY-AND-ENCODING].\n\
+FAMILY is the font family name. POINT-SIZE is the size of the\n\
+font in 1/10 pt. WIDTH, WEIGHT, and SLANT are symbols describing the\n\
+width, weight and slant of the font. These symbols are the same as for\n\
+face attributes. FIXED-P is non-nil if the font is fixed-pitch.\n\
+FULL is the full name of the font, and REGISTRY-AND-ENCODING is a string\n\
+giving the registry and encoding of the font.\n\
+The result list is sorted according to the current setting of\n\
+the face font sort order.")
+ (family, frame)
+ Lisp_Object family, frame;
+{
+ struct frame *f = check_x_frame (frame);
+ struct font_name *fonts;
+ int i, nfonts;
+ Lisp_Object result;
+ struct gcpro gcpro1;
+
+ if (!NILP (family))
+ CHECK_STRING (family, 1);
+
+ result = Qnil;
+ GCPRO1 (result);
+ nfonts = font_list (f, Qnil, family, Qnil, &fonts);
+ for (i = nfonts - 1; i >= 0; --i)
+ {
+ Lisp_Object v = Fmake_vector (make_number (8), Qnil);
+ char *tem;
+
+ ASET (v, 0, build_string (fonts[i].fields[XLFD_FAMILY]));
+ ASET (v, 1, xlfd_symbolic_swidth (fonts + i));
+ ASET (v, 2, make_number (xlfd_point_size (f, fonts + i)));
+ ASET (v, 3, xlfd_symbolic_weight (fonts + i));
+ ASET (v, 4, xlfd_symbolic_slant (fonts + i));
+ ASET (v, 5, xlfd_fixed_p (fonts + i) ? Qt : Qnil);
+ tem = build_font_name (fonts + i);
+ ASET (v, 6, build_string (tem));
+ sprintf (tem, "%s-%s", fonts[i].fields[XLFD_REGISTRY],
+ fonts[i].fields[XLFD_ENCODING]);
+ ASET (v, 7, build_string (tem));
+ xfree (tem);
+
+ result = Fcons (v, result);
+ }
+
+ remove_duplicates (result);
+ free_font_names (fonts, nfonts);
+ UNGCPRO;
+ return result;
+}
+
+
+DEFUN ("x-font-family-list", Fx_font_family_list, Sx_font_family_list,
+ 0, 1, 0,
+ "Return a list of available font families on FRAME.\n\
+If FRAME is omitted or nil, use the selected frame.\n\
+Value is a list of conses (FAMILY . FIXED-P) where FAMILY\n\
+is a font family, and FIXED-P is non-nil if fonts of that family\n\
+are fixed-pitch.")
+ (frame)
+ Lisp_Object frame;
+{
+ struct frame *f = check_x_frame (frame);
+ int nfonts, i;
+ struct font_name *fonts;
+ Lisp_Object result;
+ struct gcpro gcpro1;
+ int count = specpdl_ptr - specpdl;
+ int limit;
+
+ /* Let's consider all fonts. Increase the limit for matching
+ fonts until we have them all. */
+ for (limit = 500;;)
+ {
+ specbind (intern ("font-list-limit"), make_number (limit));
+ nfonts = font_list (f, Qnil, Qnil, Qnil, &fonts);
+
+ if (nfonts == limit)
+ {
+ free_font_names (fonts, nfonts);
+ limit *= 2;
+ }
+ else
+ break;
+ }
+
+ result = Qnil;
+ GCPRO1 (result);
+ for (i = nfonts - 1; i >= 0; --i)
+ result = Fcons (Fcons (build_string (fonts[i].fields[XLFD_FAMILY]),
+ xlfd_fixed_p (fonts + i) ? Qt : Qnil),
+ result);
+
+ remove_duplicates (result);
+ free_font_names (fonts, nfonts);
+ UNGCPRO;
+ return unbind_to (count, result);
+}
+
+
+DEFUN ("x-list-fonts", Fx_list_fonts, Sx_list_fonts, 1, 5, 0,
+ "Return a list of the names of available fonts matching PATTERN.\n\
+If optional arguments FACE and FRAME are specified, return only fonts\n\
+the same size as FACE on FRAME.\n\
+PATTERN is a string, perhaps with wildcard characters;\n\
+ the * character matches any substring, and\n\
+ the ? character matches any single character.\n\
+ PATTERN is case-insensitive.\n\
+FACE is a face name--a symbol.\n\
+\n\
+The return value is a list of strings, suitable as arguments to\n\
+set-face-font.\n\
+\n\
+Fonts Emacs can't use may or may not be excluded\n\
+even if they match PATTERN and FACE.\n\
+The optional fourth argument MAXIMUM sets a limit on how many\n\
+fonts to match. The first MAXIMUM fonts are reported.\n\
+The optional fifth argument WIDTH, if specified, is a number of columns\n\
+occupied by a character of a font. In that case, return only fonts\n\
+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;
+ int maxnames;
+
+ check_x ();
+ CHECK_STRING (pattern, 0);
+
+ if (NILP (maximum))
+ maxnames = 2000;
+ else
+ {
+ CHECK_NATNUM (maximum, 0);
+ maxnames = XINT (maximum);
+ }
+
+ if (!NILP (width))
+ CHECK_NUMBER (width, 4);
+
+ /* We can't simply call check_x_frame because this function may be
+ called before any frame is created. */
+ f = frame_or_selected_frame (frame, 2);
+ if (!FRAME_WINDOW_P (f))
+ {
+ /* Perhaps we have not yet created any frame. */
+ f = NULL;
+ 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 = FONT_WIDTH (face->font);
+ else
+ size = FONT_WIDTH (FRAME_FONT (f));
+
+ if (!NILP (width))
+ size *= XINT (width);
+ }
+
+ {
+ Lisp_Object args[2];
+
+ args[0] = x_list_fonts (f, pattern, size, maxnames);
+ if (f == NULL)
+ /* 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 */
+
+
+\f
+/***********************************************************************
+ Lisp Faces
+ ***********************************************************************/
+
+/* Access face attributes of face LFACE, a Lisp vector. */
+
+#define LFACE_FAMILY(LFACE) AREF ((LFACE), LFACE_FAMILY_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_AVGWIDTH(LFACE) AREF ((LFACE), LFACE_AVGWIDTH_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 (LFACE)->size == 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])
+ || STRINGP (attrs[LFACE_FAMILY_INDEX]));
+ xassert (UNSPECIFIEDP (attrs[LFACE_SWIDTH_INDEX])
+ || SYMBOLP (attrs[LFACE_SWIDTH_INDEX]));
+ xassert (UNSPECIFIEDP (attrs[LFACE_AVGWIDTH_INDEX])
+ || INTEGERP (attrs[LFACE_AVGWIDTH_INDEX]));
+ xassert (UNSPECIFIEDP (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])
+ || SYMBOLP (attrs[LFACE_WEIGHT_INDEX]));
+ xassert (UNSPECIFIEDP (attrs[LFACE_SLANT_INDEX])
+ || SYMBOLP (attrs[LFACE_SLANT_INDEX]));
+ xassert (UNSPECIFIEDP (attrs[LFACE_UNDERLINE_INDEX])
+ || SYMBOLP (attrs[LFACE_UNDERLINE_INDEX])
+ || STRINGP (attrs[LFACE_UNDERLINE_INDEX]));
+ xassert (UNSPECIFIEDP (attrs[LFACE_OVERLINE_INDEX])
+ || SYMBOLP (attrs[LFACE_OVERLINE_INDEX])
+ || STRINGP (attrs[LFACE_OVERLINE_INDEX]));
+ xassert (UNSPECIFIEDP (attrs[LFACE_STRIKE_THROUGH_INDEX])
+ || SYMBOLP (attrs[LFACE_STRIKE_THROUGH_INDEX])
+ || STRINGP (attrs[LFACE_STRIKE_THROUGH_INDEX]));
+ xassert (UNSPECIFIEDP (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])
+ || SYMBOLP (attrs[LFACE_INVERSE_INDEX]));
+ xassert (UNSPECIFIEDP (attrs[LFACE_FOREGROUND_INDEX])
+ || STRINGP (attrs[LFACE_FOREGROUND_INDEX]));
+ xassert (UNSPECIFIEDP (attrs[LFACE_BACKGROUND_INDEX])
+ || STRINGP (attrs[LFACE_BACKGROUND_INDEX]));
+ xassert (UNSPECIFIEDP (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])
+ || SYMBOLP (attrs[LFACE_STIPPLE_INDEX])
+ || !NILP (Fbitmap_spec_p (attrs[LFACE_STIPPLE_INDEX])));
+ xassert (UNSPECIFIEDP (attrs[LFACE_FONT_INDEX])
+ || NILP (attrs[LFACE_FONT_INDEX])
+ || STRINGP (attrs[LFACE_FONT_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 */
+
+
+/* Resolve face name FACE_NAME. If FACE_NAME is a string, intern it
+ to make it a symvol. If FACE_NAME is an alias for another face,
+ return that face's name. */
+
+static Lisp_Object
+resolve_face_name (face_name)
+ Lisp_Object face_name;
+{
+ Lisp_Object aliased;
+
+ if (STRINGP (face_name))
+ face_name = intern (XSTRING (face_name)->data);
+
+ while (SYMBOLP (face_name))
+ {
+ aliased = Fget (face_name, Qface_alias);
+ if (NILP (aliased))
+ break;
+ else
+ face_name = aliased;
+ }
+
+ 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 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;
+{
+ Lisp_Object lface;
+
+ face_name = resolve_face_name (face_name);
+
+ 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;
+}
+
+
+/* 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 (f, face_name, attrs, signal_p)
+ struct frame *f;
+ Lisp_Object face_name;
+ Lisp_Object *attrs;
+ int signal_p;
+{
+ Lisp_Object lface;
+ int success_p;
+
+ lface = lface_from_face_name (f, face_name, signal_p);
+ if (!NILP (lface))
+ {
+ bcopy (XVECTOR (lface)->contents, attrs,
+ LFACE_VECTOR_SIZE * sizeof *attrs);
+ success_p = 1;
+ }
+ else
+ success_p = 0;
+
+ return success_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
+ && i != LFACE_AVGWIDTH_INDEX)
+ if (UNSPECIFIEDP (attrs[i]))
+ break;
+
+ return i == LFACE_VECTOR_SIZE;
+}
+
+#ifdef HAVE_WINDOW_SYSTEM
+
+/* Set font-related attributes of Lisp face LFACE from the fullname of
+ the font opened by FONTNAME. If FORCE_P is zero, set only
+ unspecified attributes of LFACE. The exception is `font'
+ attribute. It is set to FONTNAME as is regardless of FORCE_P.
+
+ If FONTNAME is not available on frame F,
+ return 0 if MAY_FAIL_P is non-zero, otherwise abort.
+ If the fullname is not in a valid XLFD format,
+ return 0 if MAY_FAIL_P is non-zero, otherwise set normal values
+ in LFACE and return 1.
+ Otherwise, return 1. */
+
+static int
+set_lface_from_font_name (f, lface, fontname, force_p, may_fail_p)
+ struct frame *f;
+ Lisp_Object lface;
+ Lisp_Object fontname;
+ int force_p, may_fail_p;
+{
+ struct font_name font;
+ char *buffer;
+ int pt;
+ int have_xlfd_p;
+ int fontset;
+ char *font_name = XSTRING (fontname)->data;
+ struct font_info *font_info;
+
+ /* If FONTNAME is actually a fontset name, get ASCII font name of it. */
+ fontset = fs_query_fontset (fontname, 0);
+ if (fontset >= 0)
+ font_name = XSTRING (fontset_ascii (fontset))->data;
+
+ /* Check if FONT_NAME is surely available on the system. Usually
+ FONT_NAME is already cached for the frame F and FS_LOAD_FONT
+ returns quickly. But, even if FONT_NAME is not yet cached,
+ caching it now is not futail because we anyway load the font
+ later. */
+ BLOCK_INPUT;
+ font_info = FS_LOAD_FONT (f, 0, font_name, -1);
+ UNBLOCK_INPUT;
+
+ if (!font_info)
+ {
+ if (may_fail_p)
+ return 0;
+ abort ();
+ }
+
+ font.name = STRDUPA (font_info->full_name);
+ have_xlfd_p = split_font_name (f, &font, 1);
+
+ /* Set attributes only if unspecified, otherwise face defaults for
+ new frames would never take effect. If we couldn't get a font
+ name conforming to XLFD, set normal values. */
+
+ if (force_p || UNSPECIFIEDP (LFACE_FAMILY (lface)))
+ {
+ Lisp_Object val;
+ if (have_xlfd_p)
+ {
+ buffer = (char *) alloca (strlen (font.fields[XLFD_FAMILY])
+ + strlen (font.fields[XLFD_FOUNDRY])
+ + 2);
+ sprintf (buffer, "%s-%s", font.fields[XLFD_FOUNDRY],
+ font.fields[XLFD_FAMILY]);
+ val = build_string (buffer);
+ }
+ else
+ val = build_string ("*");
+ LFACE_FAMILY (lface) = val;
+ }
+
+ if (force_p || UNSPECIFIEDP (LFACE_HEIGHT (lface)))
+ {
+ if (have_xlfd_p)
+ pt = xlfd_point_size (f, &font);
+ else
+ pt = pixel_point_size (f, font_info->height * 10);
+ xassert (pt > 0);
+ LFACE_HEIGHT (lface) = make_number (pt);
+ }
+
+ if (force_p || UNSPECIFIEDP (LFACE_SWIDTH (lface)))
+ LFACE_SWIDTH (lface)
+ = have_xlfd_p ? xlfd_symbolic_swidth (&font) : Qnormal;
+
+ if (force_p || UNSPECIFIEDP (LFACE_AVGWIDTH (lface)))
+ LFACE_AVGWIDTH (lface)
+ = (have_xlfd_p
+ ? make_number (font.numeric[XLFD_AVGWIDTH])
+ : Qunspecified);
+
+ if (force_p || UNSPECIFIEDP (LFACE_WEIGHT (lface)))
+ LFACE_WEIGHT (lface)
+ = have_xlfd_p ? xlfd_symbolic_weight (&font) : Qnormal;
+
+ if (force_p || UNSPECIFIEDP (LFACE_SLANT (lface)))
+ LFACE_SLANT (lface)
+ = have_xlfd_p ? xlfd_symbolic_slant (&font) : Qnormal;
+
+ LFACE_FONT (lface) = fontname;
+
+ 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 may be a either an absolute face height or a
+ `relative' height, and TO must be an absolute height. The returned
+ value is always an absolute height. GCPRO is a lisp value that will
+ be protected from garbage-collection if this function makes a call
+ into lisp. */
+
+Lisp_Object
+merge_face_heights (from, to, invalid, gcpro)
+ Lisp_Object from, to, invalid, gcpro;
+{
+ int result = 0;
+
+ if (INTEGERP (from))
+ result = XINT (from);
+ else if (NUMBERP (from))
+ result = XFLOATINT (from) * XINT (to);
+#if 0 /* Probably not so useful. */
+ else if (CONSP (from) && CONSP (XCDR (from)))
+ {
+ if (EQ (XCAR(from), Qplus) || EQ (XCAR(from), Qminus))
+ {
+ if (INTEGERP (XCAR (XCDR (from))))
+ {
+ int inc = XINT (XCAR (XCDR (from)));
+ if (EQ (XCAR (from), Qminus))
+ inc = -inc;
+
+ result = XFASTINT (to);
+ if (result + inc > 0)
+ /* Note that `underflows' don't mean FROM is invalid, so
+ we just pin the result at TO if it would otherwise be
+ negative or 0. */
+ result += inc;
+ }
+ }
+ }
+#endif
+ else if (FUNCTIONP (from))
+ {
+ /* Call function with current height as argument.
+ From is the new height. */
+ Lisp_Object args[2], height;
+ struct gcpro gcpro1;
+
+ GCPRO1 (gcpro);
+
+ args[0] = from;
+ args[1] = to;
+ height = safe_call (2, args);
+
+ UNGCPRO;
+
+ if (NUMBERP (height))
+ result = XFLOATINT (height);
+ }
+
+ if (result > 0)
+ return make_number (result);
+ else
+ return invalid;
+}
+
+
+/* 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. CYCLE_CHECK is used internally to detect loops in
+ face inheritance; it should be Qnil when called from other places. */
+
+static INLINE void
+merge_face_vectors (f, from, to, cycle_check)
+ struct frame *f;
+ Lisp_Object *from, *to;
+ Lisp_Object cycle_check;
+{
+ 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_inheritance (f, from[LFACE_INHERIT_INDEX], to, cycle_check);
+
+ /* If TO specifies a :font attribute, and FROM specifies some
+ font-related attribute, we need to clear TO's :font attribute
+ (because it will be inconsistent with whatever FROM specifies, and
+ FROM takes precedence). */
+ if (!NILP (to[LFACE_FONT_INDEX])
+ && (!UNSPECIFIEDP (from[LFACE_FAMILY_INDEX])
+ || !UNSPECIFIEDP (from[LFACE_HEIGHT_INDEX])
+ || !UNSPECIFIEDP (from[LFACE_WEIGHT_INDEX])
+ || !UNSPECIFIEDP (from[LFACE_SLANT_INDEX])
+ || !UNSPECIFIEDP (from[LFACE_SWIDTH_INDEX])
+ || !UNSPECIFIEDP (from[LFACE_AVGWIDTH_INDEX])))
+ to[LFACE_FONT_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], cycle_check);
+ else
+ to[i] = from[i];
+
+ /* 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;
+}
+
+
+/* Checks the `cycle check' variable CHECK to see if it indicates that
+ EL is part of a cycle; CHECK must be either Qnil or a value returned
+ by an earlier use of CYCLE_CHECK. SUSPICIOUS is the number of
+ elements after which a cycle might be suspected; after that many
+ elements, this macro begins consing in order to keep more precise
+ track of elements.
+
+ Returns NIL if a cycle was detected, otherwise a new value for CHECK
+ that includes EL.
+
+ CHECK is evaluated multiple times, EL and SUSPICIOUS 0 or 1 times, so
+ the caller should make sure that's ok. */
+
+#define CYCLE_CHECK(check, el, suspicious) \
+ (NILP (check) \
+ ? make_number (0) \
+ : (INTEGERP (check) \
+ ? (XFASTINT (check) < (suspicious) \
+ ? make_number (XFASTINT (check) + 1) \
+ : Fcons (el, Qnil)) \
+ : (!NILP (Fmemq ((el), (check))) \
+ ? Qnil \
+ : Fcons ((el), (check)))))
+
+
+/* Merge face attributes from the face on frame F whose name is
+ INHERITS, into the vector of face attributes TO; INHERITS may also be
+ a list of face names, in which case they are applied in order.
+ CYCLE_CHECK is used to detect loops in face inheritance.
+ Returns true if any of the inherited attributes are `font-related'. */
+
+static void
+merge_face_inheritance (f, inherit, to, cycle_check)
+ struct frame *f;
+ Lisp_Object inherit;
+ Lisp_Object *to;
+ Lisp_Object cycle_check;
+{
+ if (SYMBOLP (inherit) && !EQ (inherit, Qunspecified))
+ /* Inherit from the named face INHERIT. */
+ {
+ Lisp_Object lface;
+
+ /* Make sure we're not in an inheritance loop. */
+ cycle_check = CYCLE_CHECK (cycle_check, inherit, 15);
+ if (NILP (cycle_check))
+ /* Cycle detected, ignore any further inheritance. */
+ return;
+
+ lface = lface_from_face_name (f, inherit, 0);
+ if (!NILP (lface))
+ merge_face_vectors (f, XVECTOR (lface)->contents, to, cycle_check);
+ }
+ else if (CONSP (inherit))
+ /* Handle a list of inherited faces by calling ourselves recursively
+ on each element. Note that we only do so for symbol elements, so
+ it's not possible to infinitely recurse. */
+ {
+ while (CONSP (inherit))
+ {
+ if (SYMBOLP (XCAR (inherit)))
+ merge_face_inheritance (f, XCAR (inherit), to, cycle_check);
+
+ /* Check for a circular inheritance list. */
+ cycle_check = CYCLE_CHECK (cycle_check, inherit, 15);
+ if (NILP (cycle_check))
+ /* Cycle detected. */
+ break;
+
+ inherit = XCDR (inherit);
+ }
+ }
+}
+
+
+/* Given a Lisp face attribute vector TO and a Lisp object PROP that
+ is a face property, determine the resulting face attributes on
+ frame F, and store them in TO. PROP 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 void
+merge_face_vector_with_property (f, to, prop)
+ struct frame *f;
+ Lisp_Object *to;
+ Lisp_Object prop;
+{
+ if (CONSP (prop))
+ {
+ Lisp_Object first = XCAR (prop);
+
+ 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 (prop);
+ 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
+ add_to_log ("Invalid face color", color_name, Qnil);
+ }
+ else if (SYMBOLP (first)
+ && *XSYMBOL (first)->name->data == ':')
+ {
+ /* Assume this is the property list form. */
+ while (CONSP (prop) && CONSP (XCDR (prop)))
+ {
+ Lisp_Object keyword = XCAR (prop);
+ Lisp_Object value = XCAR (XCDR (prop));
+
+ if (EQ (keyword, QCfamily))
+ {
+ if (STRINGP (value))
+ to[LFACE_FAMILY_INDEX] = value;
+ else
+ add_to_log ("Invalid face font family", value, Qnil);
+ }
+ else if (EQ (keyword, QCheight))
+ {
+ Lisp_Object new_height =
+ merge_face_heights (value, to[LFACE_HEIGHT_INDEX],
+ Qnil, Qnil);
+
+ if (NILP (new_height))
+ add_to_log ("Invalid face font height", value, Qnil);
+ else
+ to[LFACE_HEIGHT_INDEX] = new_height;
+ }
+ else if (EQ (keyword, QCweight))
+ {
+ if (SYMBOLP (value)
+ && face_numeric_weight (value) >= 0)
+ to[LFACE_WEIGHT_INDEX] = value;
+ else
+ add_to_log ("Invalid face weight", value, Qnil);
+ }
+ else if (EQ (keyword, QCslant))
+ {
+ if (SYMBOLP (value)
+ && face_numeric_slant (value) >= 0)
+ to[LFACE_SLANT_INDEX] = value;
+ else
+ add_to_log ("Invalid face slant", value, Qnil);
+ }
+ else if (EQ (keyword, QCunderline))
+ {
+ if (EQ (value, Qt)
+ || NILP (value)
+ || STRINGP (value))
+ to[LFACE_UNDERLINE_INDEX] = value;
+ else
+ add_to_log ("Invalid face underline", value, Qnil);
+ }
+ else if (EQ (keyword, QCoverline))
+ {
+ if (EQ (value, Qt)
+ || NILP (value)
+ || STRINGP (value))
+ to[LFACE_OVERLINE_INDEX] = value;
+ else
+ add_to_log ("Invalid face overline", value, Qnil);
+ }
+ else if (EQ (keyword, QCstrike_through))
+ {
+ if (EQ (value, Qt)
+ || NILP (value)
+ || STRINGP (value))
+ to[LFACE_STRIKE_THROUGH_INDEX] = value;
+ else
+ add_to_log ("Invalid face strike-through", value, Qnil);
+ }
+ 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
+ add_to_log ("Invalid face box", value, Qnil);
+ }
+ else if (EQ (keyword, QCinverse_video)
+ || EQ (keyword, QCreverse_video))
+ {
+ if (EQ (value, Qt) || NILP (value))
+ to[LFACE_INVERSE_INDEX] = value;
+ else
+ add_to_log ("Invalid face inverse-video", value, Qnil);
+ }
+ else if (EQ (keyword, QCforeground))
+ {
+ if (STRINGP (value))
+ to[LFACE_FOREGROUND_INDEX] = value;
+ else
+ add_to_log ("Invalid face foreground", value, Qnil);
+ }
+ else if (EQ (keyword, QCbackground))
+ {
+ if (STRINGP (value))
+ to[LFACE_BACKGROUND_INDEX] = value;
+ else
+ add_to_log ("Invalid face background", value, Qnil);
+ }
+ else if (EQ (keyword, QCstipple))
+ {
+#ifdef HAVE_X_WINDOWS
+ Lisp_Object pixmap_p = Fbitmap_spec_p (value);
+ if (!NILP (pixmap_p))
+ to[LFACE_STIPPLE_INDEX] = value;
+ else
+ add_to_log ("Invalid face stipple", value, Qnil);
+#endif
+ }
+ else if (EQ (keyword, QCwidth))
+ {
+ if (SYMBOLP (value)
+ && face_numeric_swidth (value) >= 0)
+ to[LFACE_SWIDTH_INDEX] = value;
+ else
+ add_to_log ("Invalid face width", value, Qnil);
+ }
+ else if (EQ (keyword, QCinherit))
+ {
+ if (SYMBOLP (value))
+ to[LFACE_INHERIT_INDEX] = value;
+ else
+ {
+ Lisp_Object tail;
+ for (tail = value; CONSP (tail); tail = XCDR (tail))
+ if (!SYMBOLP (XCAR (tail)))
+ break;
+ if (NILP (tail))
+ to[LFACE_INHERIT_INDEX] = value;
+ else
+ add_to_log ("Invalid face inherit", value, Qnil);
+ }
+ }
+ else
+ add_to_log ("Invalid attribute %s in face property",
+ keyword, Qnil);
+
+ prop = XCDR (XCDR (prop));
+ }
+ }
+ else
+ {
+ /* This is a list of face specs. Specifications at the
+ beginning of the list take precedence over later
+ specifications, so we have to merge starting with the
+ last specification. */
+ Lisp_Object next = XCDR (prop);
+ if (!NILP (next))
+ merge_face_vector_with_property (f, to, next);
+ merge_face_vector_with_property (f, to, first);
+ }
+ }
+ else
+ {
+ /* PROP ought to be a face name. */
+ Lisp_Object lface = lface_from_face_name (f, prop, 0);
+ if (NILP (lface))
+ add_to_log ("Invalid face text property value: %s", prop, Qnil);
+ else
+ merge_face_vectors (f, XVECTOR (lface)->contents, to, Qnil);
+ }
+}
+
+
+DEFUN ("internal-make-lisp-face", Finternal_make_lisp_face,
+ Sinternal_make_lisp_face, 1, 2, 0,
+ "Make FACE, a symbol, a Lisp face with all attributes nil.\n\
+If FACE was not known as a face before, create a new one.\n\
+If optional argument FRAME is specified, make a frame-local face\n\
+for that frame. Otherwise operate on the global face definition.\n\
+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, 0);
+ global_lface = lface_from_face_name (NULL, face, 0);
+
+ if (!NILP (frame))
+ {
+ CHECK_LIVE_FRAME (frame, 1);
+ 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);
+ AREF (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)
+ AREF (global_lface, i) = Qunspecified;
+
+ /* Add a frame-local definition. */
+ if (f)
+ {
+ if (NILP (lface))
+ {
+ lface = Fmake_vector (make_number (LFACE_VECTOR_SIZE),
+ Qunspecified);
+ AREF (lface, 0) = Qface;
+ f->face_alist = Fcons (Fcons (face, lface), f->face_alist);
+ }
+ else
+ for (i = 1; i < LFACE_VECTOR_SIZE; ++i)
+ AREF (lface, i) = Qunspecified;
+ }
+ else
+ lface = global_lface;
+
+ xassert (LFACEP (lface));
+ check_lface (lface);
+ return lface;
+}
+
+
+DEFUN ("internal-lisp-face-p", Finternal_lisp_face_p,
+ Sinternal_lisp_face_p, 1, 2, 0,
+ "Return non-nil if FACE names a face.\n\
+If optional second parameter FRAME is non-nil, check for the\n\
+existence of a frame-local face with name FACE on that frame.\n\
+Otherwise check for the existence of a global face.")
+ (face, frame)
+ Lisp_Object face, frame;
+{
+ Lisp_Object lface;
+
+ if (!NILP (frame))
+ {
+ CHECK_LIVE_FRAME (frame, 1);
+ 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,
+ "Copy face FROM to TO.\n\
+If FRAME it t, copy the global face definition of FROM to the\n\
+global face definition of TO. Otherwise, copy the frame-local\n\
+definition of FROM on FRAME to the frame-local definition of TO\n\
+on NEW-FRAME, or FRAME if NEW-FRAME is nil.\n\
+\n\
+Value is TO.")
+ (from, to, frame, new_frame)
+ Lisp_Object from, to, frame, new_frame;
+{
+ Lisp_Object lface, copy;
+
+ CHECK_SYMBOL (from, 0);
+ CHECK_SYMBOL (to, 1);
+ if (NILP (new_frame))
+ new_frame = frame;
+
+ 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. */
+ CHECK_LIVE_FRAME (frame, 2);
+ CHECK_LIVE_FRAME (new_frame, 3);
+ 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));
+
+ return to;
+}
+
+
+DEFUN ("internal-set-lisp-face-attribute", Finternal_set_lisp_face_attribute,
+ Sinternal_set_lisp_face_attribute, 3, 4, 0,
+ "Set attribute ATTR of FACE to VALUE.\n\
+FRAME being a frame means change the face on that frame.\n\
+FRAME nil means change the face of the selected frame.\n\
+FRAME t means change the default for new frames.\n\
+FRAME 0 means change the face on all frames, and change the default\n\
+ for new frames.")
+ (face, attr, value, frame)
+ Lisp_Object face, attr, value, frame;
+{
+ Lisp_Object lface;
+ Lisp_Object old_value = Qnil;
+ /* Set 1 if ATTR is QCfont. */
+ int font_attr_p = 0;
+ /* Set 1 if ATTR is one of font-related attributes other than QCfont. */
+ int font_related_attr_p = 0;
+
+ CHECK_SYMBOL (face, 0);
+ CHECK_SYMBOL (attr, 1);
+
+ face = resolve_face_name (face);
+
+ /* 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);
+ else
+ {
+ if (NILP (frame))
+ frame = selected_frame;
+
+ CHECK_LIVE_FRAME (frame, 3);
+ 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))
+ {
+ CHECK_STRING (value, 3);
+ if (XSTRING (value)->size == 0)
+ signal_error ("Invalid face family", value);
+ }
+ old_value = LFACE_FAMILY (lface);
+ LFACE_FAMILY (lface) = value;
+ font_related_attr_p = 1;
+ }
+ else if (EQ (attr, QCheight))
+ {
+ if (!UNSPECIFIEDP (value))
+ {
+ Lisp_Object test =
+ (EQ (face, Qdefault) ? value :
+ /* The default face must have an absolute size, otherwise, we do
+ a test merge with a random height to see if VALUE's ok. */
+ merge_face_heights (value, make_number(10), Qnil, Qnil));
+
+ if (!INTEGERP(test) || XINT(test) <= 0)
+ signal_error ("Invalid face height", value);
+ }
+
+ old_value = LFACE_HEIGHT (lface);
+ LFACE_HEIGHT (lface) = value;
+ font_related_attr_p = 1;
+ }
+ else if (EQ (attr, QCweight))
+ {
+ if (!UNSPECIFIEDP (value))
+ {
+ CHECK_SYMBOL (value, 3);
+ if (face_numeric_weight (value) < 0)
+ signal_error ("Invalid face weight", value);
+ }
+ old_value = LFACE_WEIGHT (lface);
+ LFACE_WEIGHT (lface) = value;
+ font_related_attr_p = 1;
+ }
+ else if (EQ (attr, QCslant))
+ {
+ if (!UNSPECIFIEDP (value))
+ {
+ CHECK_SYMBOL (value, 3);
+ if (face_numeric_slant (value) < 0)
+ signal_error ("Invalid face slant", value);
+ }
+ old_value = LFACE_SLANT (lface);
+ LFACE_SLANT (lface) = value;
+ font_related_attr_p = 1;
+ }
+ else if (EQ (attr, QCunderline))
+ {
+ if (!UNSPECIFIEDP (value))
+ if ((SYMBOLP (value)
+ && !EQ (value, Qt)
+ && !EQ (value, Qnil))
+ /* Underline color. */
+ || (STRINGP (value)
+ && XSTRING (value)->size == 0))
+ signal_error ("Invalid face underline", value);
+
+ old_value = LFACE_UNDERLINE (lface);
+ LFACE_UNDERLINE (lface) = value;
+ }
+ else if (EQ (attr, QCoverline))
+ {
+ if (!UNSPECIFIEDP (value))
+ if ((SYMBOLP (value)
+ && !EQ (value, Qt)
+ && !EQ (value, Qnil))
+ /* Overline color. */
+ || (STRINGP (value)
+ && XSTRING (value)->size == 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))
+ if ((SYMBOLP (value)
+ && !EQ (value, Qt)
+ && !EQ (value, Qnil))
+ /* Strike-through color. */
+ || (STRINGP (value)
+ && XSTRING (value)->size == 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))
+ 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 = XSTRING (value)->size > 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 (!STRINGP (v) || XSTRING (v)->size == 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))
+ {
+ CHECK_SYMBOL (value, 3);
+ 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))
+ {
+ if (!UNSPECIFIEDP (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, 3);
+ if (XSTRING (value)->size == 0)
+ signal_error ("Empty foreground color value", value);
+ }
+ old_value = LFACE_FOREGROUND (lface);
+ LFACE_FOREGROUND (lface) = value;
+ }
+ else if (EQ (attr, QCbackground))
+ {
+ if (!UNSPECIFIEDP (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, 3);
+ if (XSTRING (value)->size == 0)
+ signal_error ("Empty background color value", value);
+ }
+ old_value = LFACE_BACKGROUND (lface);
+ LFACE_BACKGROUND (lface) = value;
+ }
+ else if (EQ (attr, QCstipple))
+ {
+#ifdef HAVE_X_WINDOWS
+ if (!UNSPECIFIEDP (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 */
+ }
+ else if (EQ (attr, QCwidth))
+ {
+ if (!UNSPECIFIEDP (value))
+ {
+ CHECK_SYMBOL (value, 3);
+ if (face_numeric_swidth (value) < 0)
+ signal_error ("Invalid face width", value);
+ }
+ old_value = LFACE_SWIDTH (lface);
+ LFACE_SWIDTH (lface) = value;
+ font_related_attr_p = 1;
+ }
+ else if (EQ (attr, QCfont))
+ {
+#ifdef HAVE_WINDOW_SYSTEM
+ /* Set font-related attributes of the Lisp face from an
+ XLFD font name. */
+ struct frame *f;
+ Lisp_Object tmp;
+
+ CHECK_STRING (value, 3);
+ if (EQ (frame, Qt))
+ f = SELECTED_FRAME ();
+ else
+ f = check_x_frame (frame);
+
+ /* VALUE may be a fontset name or an alias of fontset. In such
+ a case, use the base fontset name. */
+ tmp = Fquery_fontset (value, Qnil);
+ if (!NILP (tmp))
+ value = tmp;
+
+ if (!set_lface_from_font_name (f, lface, value, 1, 1))
+ signal_error ("Invalid font or fontset name", value);
+
+ font_attr_p = 1;
+#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;
+ font_related_attr_p = 1;
+ }
+ else if (EQ (attr, QCitalic))
+ {
+ old_value = LFACE_SLANT (lface);
+ LFACE_SLANT (lface) = NILP (value) ? Qnormal : Qitalic;
+ font_related_attr_p = 1;
+ }
+ else
+ signal_error ("Invalid face attribute name", attr);
+
+ if (font_related_attr_p
+ && !UNSPECIFIEDP (value))
+ /* If a font-related attribute other than QCfont is specified, the
+ original `font' attribute nor that of default face is useless
+ to determine a new font. Thus, we set it to nil so that font
+ selection mechanism doesn't use it. */
+ LFACE_FONT (lface) = Qnil;
+
+ /* 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)
+ && (EQ (attr, QCfont)
+ || NILP (Fequal (old_value, value))))
+ {
+ ++face_change_count;
+ ++windows_or_buffers_changed;
+ }
+
+ if (!UNSPECIFIEDP (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)
+ && (font_related_attr_p || font_attr_p)
+ && 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);
+ XCAR (cons) = param;
+ XCDR (cons) = value;
+ Fmodify_frame_parameters (frame, Vparam_value_alist);
+ }
+ }
+
+ return face;
+}
+
+
+#ifdef HAVE_WINDOW_SYSTEM
+
+/* Set the `font' frame parameter of FRAME determined from `default'
+ face attributes LFACE. If a face or fontset name is explicitely
+ specfied in LFACE, use it as is. Otherwise, determine a font name
+ from the other font-related atrributes of LFACE. In that case, if
+ there's no matching font, signals an error. */
+
+static void
+set_font_frame_param (frame, lface)
+ Lisp_Object frame, lface;
+{
+ struct frame *f = XFRAME (frame);
+
+ if (FRAME_WINDOW_P (f))
+ {
+ Lisp_Object font_name;
+ char *font;
+
+ if (STRINGP (LFACE_FONT (lface)))
+ font_name = LFACE_FONT (lface);
+ else
+ {
+ /* Choose a font name that reflects LFACE's attributes and has
+ the registry and encoding pattern specified in the default
+ fontset (3rd arg: -1) for ASCII characters (4th arg: 0). */
+ font = choose_face_font (f, XVECTOR (lface)->contents, -1, 0);
+ if (!font)
+ error ("No font matches the specified attribute");
+ font_name = build_string (font);
+ xfree (font);
+ }
+
+ Fmodify_frame_parameters (frame, Fcons (Fcons (Qfont, font_name), Qnil));
+ }
+}
+
+
+/* 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 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))
+ {
+ lface = lface_from_face_name (f, Qdefault, 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_update_face_colors, frame);
+
+ face = Qdefault;
+ lface = lface_from_face_name (f, face, 1);
+ LFACE_BACKGROUND (lface) = (STRINGP (new_value)
+ ? new_value : Qunspecified);
+ realize_basic_faces (f);
+ }
+ 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);
+ }
+
+ /* 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;
+ }
+}
+
+
+/* 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, "")
+ (resource, class, frame)
+ Lisp_Object resource, class, frame;
+{
+ Lisp_Object value = Qnil;
+#ifndef WINDOWSNT
+#ifndef macintosh
+ CHECK_STRING (resource, 0);
+ CHECK_STRING (class, 1);
+ CHECK_LIVE_FRAME (frame, 2);
+ BLOCK_INPUT;
+ value = display_x_get_resource (FRAME_X_DISPLAY_INFO (XFRAME (frame)),
+ resource, class, Qnil, Qnil);
+ UNBLOCK_INPUT;
+#endif /* not macintosh */
+#endif /* not WINDOWSNT */
+ 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 (xstricmp (XSTRING (value)->data, "on") == 0
+ || xstricmp (XSTRING (value)->data, "true") == 0)
+ result = Qt;
+ else if (xstricmp (XSTRING (value)->data, "off") == 0
+ || xstricmp (XSTRING (value)->data, "false") == 0)
+ result = Qnil;
+ else if (xstricmp (XSTRING (value)->data, "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, "")
+ (face, attr, value, frame)
+ Lisp_Object face, attr, value, frame;
+{
+ CHECK_SYMBOL (face, 0);
+ CHECK_SYMBOL (attr, 1);
+ CHECK_STRING (value, 2);
+
+ if (xstricmp (XSTRING (value)->data, "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 (XSTRING (value)->data);
+ 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))
+ value = Fcar (Fread_from_string (value, Qnil, Qnil));
+
+ return Finternal_set_lisp_face_attribute (face, attr, value, frame);
+}
+
+#endif /* HAVE_WINDOW_SYSTEM */
+
+\f
+/***********************************************************************
+ 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);
+ char *myname = XSTRING (Vx_resource_name)->data;
+ 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,
+ XSTRING (LFACE_FOREGROUND (lface))->data);
+ XrmPutLineResource (&rdb, line);
+ sprintf (line, "%s.pane.menubar*foreground: %s",
+ myname, XSTRING (LFACE_FOREGROUND (lface))->data);
+ XrmPutLineResource (&rdb, line);
+ changed_p = 1;
+ }
+
+ if (STRINGP (LFACE_BACKGROUND (lface)))
+ {
+ sprintf (line, "%s.%s*background: %s",
+ myname, popup_path,
+ XSTRING (LFACE_BACKGROUND (lface))->data);
+ XrmPutLineResource (&rdb, line);
+ sprintf (line, "%s.pane.menubar*background: %s",
+ myname, XSTRING (LFACE_BACKGROUND (lface))->data);
+ XrmPutLineResource (&rdb, line);
+ changed_p = 1;
+ }
+
+ if (face->font_name
+ && (!UNSPECIFIEDP (LFACE_FAMILY (lface))
+ || !UNSPECIFIEDP (LFACE_SWIDTH (lface))
+ || !UNSPECIFIEDP (LFACE_AVGWIDTH (lface))
+ || !UNSPECIFIEDP (LFACE_WEIGHT (lface))
+ || !UNSPECIFIEDP (LFACE_SLANT (lface))
+ || !UNSPECIFIEDP (LFACE_HEIGHT (lface))))
+ {
+#ifdef USE_MOTIF
+ const char *suffix = "List";
+#else
+ const char *suffix = "";
+#endif
+ sprintf (line, "%s.pane.menubar*font%s: %s",
+ myname, suffix, face->font_name);
+ XrmPutLineResource (&rdb, line);
+ sprintf (line, "%s.%s*font%s: %s",
+ myname, popup_path, suffix, face->font_name);
+ XrmPutLineResource (&rdb, line);
+ changed_p = 1;
+ }
+
+ if (changed_p && f->output_data.x->menubar_widget)
+ free_frame_menubar (f);
+ }
+}
+
+#endif /* HAVE_X_WINDOWS && USE_X_TOOLKIT */
+
+
+
+DEFUN ("internal-get-lisp-face-attribute", Finternal_get_lisp_face_attribute,
+ Sinternal_get_lisp_face_attribute,
+ 2, 3, 0,
+ "Return face attribute KEYWORD of face SYMBOL.\n\
+If SYMBOL does not name a valid Lisp face or KEYWORD isn't a valid\n\
+face attribute name, signal an error.\n\
+If the optional argument FRAME is given, report on face FACE in that\n\
+frame. If FRAME is t, report on the defaults for face FACE (for new\n\
+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, 0);
+ CHECK_SYMBOL (keyword, 1);
+
+ if (EQ (frame, Qt))
+ lface = lface_from_face_name (NULL, symbol, 1);
+ else
+ {
+ if (NILP (frame))
+ frame = selected_frame;
+ CHECK_LIVE_FRAME (frame, 2);
+ lface = lface_from_face_name (XFRAME (frame), symbol, 1);
+ }
+
+ if (EQ (keyword, QCfamily))
+ value = LFACE_FAMILY (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
+ signal_error ("Invalid face attribute name", keyword);
+
+ return value;
+}
+
+
+DEFUN ("internal-lisp-face-attribute-values",
+ Finternal_lisp_face_attribute_values,
+ Sinternal_lisp_face_attribute_values, 1, 1, 0,
+ "Return a list of valid discrete values for face attribute ATTR.\n\
+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, 0);
+
+ if (EQ (attr, QCweight)
+ || EQ (attr, QCslant)
+ || EQ (attr, QCwidth))
+ {
+ /* Extract permissible symbols from tables. */
+ struct table_entry *table;
+ int i, dim;
+
+ if (EQ (attr, QCweight))
+ table = weight_table, dim = DIM (weight_table);
+ else if (EQ (attr, QCslant))
+ table = slant_table, dim = DIM (slant_table);
+ else
+ table = swidth_table, dim = DIM (swidth_table);
+
+ for (i = 0; i < dim; ++i)
+ {
+ Lisp_Object symbol = *table[i].symbol;
+ Lisp_Object tail = result;
+
+ while (!NILP (tail)
+ && !EQ (XCAR (tail), symbol))
+ tail = XCDR (tail);
+
+ if (NILP (tail))
+ result = Fcons (symbol, result);
+ }
+ }
+ else 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,
+ "Add attributes from frame-default definition of FACE to FACE on FRAME.\n\
+Default face attributes override any local face attributes.")
+ (face, frame)
+ Lisp_Object face, frame;
+{
+ int i;
+ Lisp_Object global_lface, local_lface, *gvec, *lvec;
+
+ CHECK_LIVE_FRAME (frame, 1);
+ global_lface = lface_from_face_name (NULL, face, 1);
+ local_lface = lface_from_face_name (XFRAME (frame), face, 0);
+ if (NILP (local_lface))
+ local_lface = Finternal_make_lisp_face (face, frame);
+
+ /* Make every specified global attribute override the local one.
+ BEWARE!! This is only used from `face-set-after-frame-default' where
+ the local frame is defined from default specs in `face-defface-spec'
+ and those should be overridden by global settings. Hence the strange
+ "global before local" priority. */
+ lvec = XVECTOR (local_lface)->contents;
+ gvec = XVECTOR (global_lface)->contents;
+ for (i = 1; i < LFACE_VECTOR_SIZE; ++i)
+ if (! UNSPECIFIEDP (gvec[i]))
+ lvec[i] = gvec[i];
+
+ return Qnil;
+}
+
+
+/* The following function is implemented for compatibility with 20.2.
+ The function is used in x-resolve-fonts when it is asked to
+ return fonts with the same size as the font of a face. This is
+ done in fontset.el. */
+
+DEFUN ("face-font", Fface_font, Sface_font, 1, 2, 0,
+ "Return the font name of face FACE, or nil if it is unspecified.\n\
+If the optional argument FRAME is given, report on face FACE in that frame.\n\
+If FRAME is t, report on the defaults for face FACE (for new frames).\n\
+ The font default for a face is either nil, or a list\n\
+ of the form (bold), (italic) or (bold italic).\n\
+If FRAME is omitted or nil, use the selected frame.")
+ (face, frame)
+ Lisp_Object face, frame;
+{
+ if (EQ (frame, Qt))
+ {
+ Lisp_Object result = Qnil;
+ Lisp_Object lface = lface_from_face_name (NULL, face, 1);
+
+ if (!UNSPECIFIEDP (LFACE_WEIGHT (lface))
+ && !EQ (LFACE_WEIGHT (lface), Qnormal))
+ result = Fcons (Qbold, result);
+
+ if (!UNSPECIFIEDP (LFACE_SLANT (lface))
+ && !EQ (LFACE_SLANT (lface), Qnormal))
+ result = Fcons (Qitalic, result);
+
+ return result;
+ }
+ else
+ {
+ struct frame *f = frame_or_selected_frame (frame, 1);
+ int face_id = lookup_named_face (f, face, 0);
+ struct face *face = FACE_FROM_ID (f, face_id);
+ return face ? build_string (face->font_name) : Qnil;
+ }
+}
+
+
+/* Compare face vectors V1 and V2 for equality. Value is non-zero if
+ all attributes are `equal'. Tries to be fast because this function
+ is called quite often. */
+
+static INLINE int
+lface_equal_p (v1, v2)
+ Lisp_Object *v1, *v2;
+{
+ int i, equal_p = 1;
+
+ for (i = 1; i < LFACE_VECTOR_SIZE && equal_p; ++i)
+ {
+ Lisp_Object a = v1[i];
+ Lisp_Object b = v2[i];
+
+ /* Type can differ, e.g. when one attribute is unspecified, i.e. nil,
+ and the other is specified. */
+ equal_p = XTYPE (a) == XTYPE (b);
+ if (!equal_p)
+ break;
+
+ if (!EQ (a, b))
+ {
+ switch (XTYPE (a))
+ {
+ case Lisp_String:
+ equal_p = ((STRING_BYTES (XSTRING (a))
+ == STRING_BYTES (XSTRING (b)))
+ && bcmp (XSTRING (a)->data, XSTRING (b)->data,
+ STRING_BYTES (XSTRING (a))) == 0);
+ break;
+
+ case Lisp_Int:
+ case Lisp_Symbol:
+ equal_p = 0;
+ break;
+
+ default:
+ equal_p = !NILP (Fequal (a, b));
+ break;
+ }
+ }
+ }
+
+ return equal_p;
+}
+
+
+DEFUN ("internal-lisp-face-equal-p", Finternal_lisp_face_equal_p,
+ Sinternal_lisp_face_equal_p, 2, 3, 0,
+ "True if FACE1 and FACE2 are equal.\n\
+If the optional argument FRAME is given, report on face FACE in that frame.\n\
+If FRAME is t, report on the defaults for face FACE (for new frames).\n\
+If FRAME is omitted or nil, use the selected frame.")
+ (face1, face2, frame)
+ Lisp_Object face1, face2, frame;
+{
+ int equal_p;
+ struct frame *f;
+ Lisp_Object lface1, lface2;
+
+ if (EQ (frame, Qt))
+ f = NULL;
+ else
+ /* Don't use check_x_frame here because this function is called
+ before X frames exist. At that time, if FRAME is nil,
+ selected_frame will be used which is the frame dumped with
+ Emacs. That frame is not an X frame. */
+ f = frame_or_selected_frame (frame, 2);
+
+ lface1 = lface_from_face_name (NULL, face1, 1);
+ lface2 = lface_from_face_name (NULL, face2, 1);
+ equal_p = lface_equal_p (XVECTOR (lface1)->contents,
+ XVECTOR (lface2)->contents);
+ return equal_p ? Qt : Qnil;
+}
+
+
+DEFUN ("internal-lisp-face-empty-p", Finternal_lisp_face_empty_p,
+ Sinternal_lisp_face_empty_p, 1, 2, 0,
+ "True if FACE has no attribute specified.\n\
+If the optional argument FRAME is given, report on face FACE in that frame.\n\
+If FRAME is t, report on the defaults for face FACE (for new frames).\n\
+If FRAME is omitted or nil, use the selected frame.")
+ (face, frame)
+ Lisp_Object face, frame;
+{
+ struct frame *f;
+ Lisp_Object lface;
+ int i;
+
+ if (NILP (frame))
+ frame = selected_frame;
+ CHECK_LIVE_FRAME (frame, 0);
+ f = XFRAME (frame);
+
+ if (EQ (frame, Qt))
+ lface = lface_from_face_name (NULL, face, 1);
+ else
+ lface = lface_from_face_name (f, face, 1);
+
+ for (i = 1; i < LFACE_VECTOR_SIZE; ++i)
+ if (!UNSPECIFIEDP (AREF (lface, i)))
+ break;
+
+ return i == LFACE_VECTOR_SIZE ? Qt : Qnil;
+}
+
+
+DEFUN ("frame-face-alist", Fframe_face_alist, Sframe_face_alist,
+ 0, 1, 0,
+ "Return an alist of frame-local faces defined on FRAME.\n\
+For internal use only.")
+ (frame)
+ Lisp_Object frame;
+{
+ struct frame *f = frame_or_selected_frame (frame, 0);
+ return f->face_alist;
+}
+
+
+/* Return a hash code for Lisp string STRING with case ignored. Used
+ below in computing a hash value for a Lisp face. */
+
+static INLINE unsigned
+hash_string_case_insensitive (string)
+ Lisp_Object string;
+{
+ unsigned char *s;
+ unsigned hash = 0;
+ xassert (STRINGP (string));
+ for (s = XSTRING (string)->data; *s; ++s)
+ hash = (hash << 1) ^ tolower (*s);
+ return hash;
+}
+
+
+/* Return a hash code for face attribute vector V. */
+
+static INLINE unsigned
+lface_hash (v)
+ Lisp_Object *v;
+{
+ return (hash_string_case_insensitive (v[LFACE_FAMILY_INDEX])
+ ^ hash_string_case_insensitive (v[LFACE_FOREGROUND_INDEX])
+ ^ hash_string_case_insensitive (v[LFACE_BACKGROUND_INDEX])
+ ^ XFASTINT (v[LFACE_WEIGHT_INDEX])
+ ^ XFASTINT (v[LFACE_SLANT_INDEX])
+ ^ XFASTINT (v[LFACE_SWIDTH_INDEX])
+ ^ XFASTINT (v[LFACE_HEIGHT_INDEX]));
+}
+
+
+/* Return non-zero if LFACE1 and LFACE2 specify the same font (without
+ considering charsets/registries). They do if they specify the same
+ family, point size, weight, width, slant, and fontset. Both LFACE1
+ and LFACE2 must be fully-specified. */
+
+static INLINE int
+lface_same_font_attributes_p (lface1, lface2)
+ Lisp_Object *lface1, *lface2;
+{
+ xassert (lface_fully_specified_p (lface1)
+ && lface_fully_specified_p (lface2));
+ return (xstricmp (XSTRING (lface1[LFACE_FAMILY_INDEX])->data,
+ XSTRING (lface2[LFACE_FAMILY_INDEX])->data) == 0
+ && EQ (lface1[LFACE_HEIGHT_INDEX], lface2[LFACE_HEIGHT_INDEX])
+ && EQ (lface1[LFACE_SWIDTH_INDEX], lface2[LFACE_SWIDTH_INDEX])
+ && EQ (lface1[LFACE_AVGWIDTH_INDEX], lface2[LFACE_AVGWIDTH_INDEX])
+ && EQ (lface1[LFACE_WEIGHT_INDEX], lface2[LFACE_WEIGHT_INDEX])
+ && EQ (lface1[LFACE_SLANT_INDEX], lface2[LFACE_SLANT_INDEX])
+ && (EQ (lface1[LFACE_FONT_INDEX], lface2[LFACE_FONT_INDEX])
+ || (STRINGP (lface1[LFACE_FONT_INDEX])
+ && STRINGP (lface2[LFACE_FONT_INDEX])
+ && xstricmp (XSTRING (lface1[LFACE_FONT_INDEX])->data,
+ XSTRING (lface2[LFACE_FONT_INDEX])->data))));
+}
+
+
+\f
+/***********************************************************************
+ Realized Faces
+ ***********************************************************************/
+
+/* Allocate and return a new realized face for Lisp face attribute
+ vector ATTR. */
+
+static struct face *
+make_realized_face (attr)
+ Lisp_Object *attr;
+{
+ struct face *face = (struct face *) xmalloc (sizeof *face);
+ bzero (face, sizeof *face);
+ face->ascii_face = face;
+ bcopy (attr, face->lface, sizeof face->lface);
+ return face;
+}
+
+
+/* Free realized face FACE, including its X resources. FACE may
+ be null. */
+
+static void
+free_realized_face (f, face)
+ struct frame *f;
+ struct face *face;
+{
+ if (face)
+ {
+#ifdef HAVE_WINDOW_SYSTEM
+ if (FRAME_WINDOW_P (f))
+ {
+ /* Free fontset of FACE if it is ASCII face. */
+ if (face->fontset >= 0 && face == face->ascii_face)
+ free_face_fontset (f, face);
+ if (face->gc)
+ {
+ x_free_gc (f, face->gc);
+ face->gc = 0;
+ }
+
+ free_face_colors (f, face);
+ x_destroy_bitmap (f, face->stipple);
+ }
+#endif /* HAVE_WINDOW_SYSTEM */
+
+ xfree (face);
+ }
+}
+
+
+/* Prepare face FACE for subsequent display on frame F. This
+ allocated GCs if they haven't been allocated yet or have been freed
+ by clearing the face cache. */
+
+void
+prepare_face_for_display (f, face)
+ struct frame *f;
+ struct face *face;
+{
+#ifdef HAVE_WINDOW_SYSTEM
+ xassert (FRAME_WINDOW_P (f));
+
+ if (face->gc == 0)
+ {
+ XGCValues xgcv;
+ unsigned long mask = GCForeground | GCBackground | GCGraphicsExposures;
+
+ xgcv.foreground = face->foreground;
+ xgcv.background = face->background;
+#ifdef HAVE_X_WINDOWS
+ xgcv.graphics_exposures = False;
+#endif
+ /* The font of FACE may be null if we couldn't load it. */
+ if (face->font)
+ {
+#ifdef HAVE_X_WINDOWS
+ xgcv.font = face->font->fid;
+#endif
+#ifdef WINDOWSNT
+ xgcv.font = face->font;
+#endif
+#ifdef macintosh
+ xgcv.font = face->font;
+#endif
+ mask |= GCFont;
+ }
+
+ BLOCK_INPUT;
+#ifdef HAVE_X_WINDOWS
+ if (face->stipple)
+ {
+ xgcv.fill_style = FillOpaqueStippled;
+ xgcv.stipple = x_bitmap_pixmap (f, face->stipple);
+ mask |= GCFillStyle | GCStipple;
+ }
+#endif
+ face->gc = x_create_gc (f, mask, &xgcv);
+ UNBLOCK_INPUT;
+ }
+#endif /* HAVE_WINDOW_SYSTEM */
+}
+
+\f
+/***********************************************************************
+ Face Cache
+ ***********************************************************************/
+
+/* Return a new face cache for frame F. */
+
+static struct face_cache *
+make_face_cache (f)
+ struct frame *f;
+{
+ struct face_cache *c;
+ int size;
+
+ c = (struct face_cache *) xmalloc (sizeof *c);
+ bzero (c, sizeof *c);
+ size = FACE_CACHE_BUCKETS_SIZE * sizeof *c->buckets;
+ c->buckets = (struct face **) xmalloc (size);
+ bzero (c->buckets, size);
+ c->size = 50;
+ c->faces_by_id = (struct face **) xmalloc (c->size * sizeof *c->faces_by_id);
+ c->f = f;
+ c->menu_face_changed_p = menu_face_changed_default;
+ return c;
+}
+
+
+/* Clear out all graphics contexts for all realized faces, except for
+ the basic faces. This should be done from time to time just to avoid
+ keeping too many graphics contexts that are no longer needed. */
+
+static void
+clear_face_gcs (c)
+ struct face_cache *c;
+{
+ if (c && FRAME_WINDOW_P (c->f))
+ {
+#ifdef HAVE_WINDOW_SYSTEM
+ int i;
+ for (i = BASIC_FACE_ID_SENTINEL; i < c->used; ++i)
+ {
+ struct face *face = c->faces_by_id[i];
+ if (face && face->gc)
+ {
+ x_free_gc (c->f, face->gc);
+ face->gc = 0;
+ }
+ }
+#endif /* HAVE_WINDOW_SYSTEM */
+ }
+}
+
+
+/* Free all realized faces in face cache C, including basic faces. C
+ may be null. If faces are freed, make sure the frame's current
+ matrix is marked invalid, so that a display caused by an expose
+ event doesn't try to use faces we destroyed. */
+
+static void
+free_realized_faces (c)
+ struct face_cache *c;
+{
+ if (c && c->used)
+ {
+ int i, size;
+ struct frame *f = c->f;
+
+ /* We must block input here because we can't process X events
+ safely while only some faces are freed, or when the frame's
+ current matrix still references freed faces. */
+ BLOCK_INPUT;
+
+ for (i = 0; i < c->used; ++i)
+ {
+ free_realized_face (f, c->faces_by_id[i]);
+ c->faces_by_id[i] = NULL;
+ }
+
+ c->used = 0;
+ size = FACE_CACHE_BUCKETS_SIZE * sizeof *c->buckets;
+ bzero (c->buckets, size);
+
+ /* Must do a thorough redisplay the next time. Mark current
+ matrices as invalid because they will reference faces freed
+ above. This function is also called when a frame is
+ destroyed. In this case, the root window of F is nil. */
+ if (WINDOWP (f->root_window))
+ {
+ clear_current_matrices (f);
+ ++windows_or_buffers_changed;
+ }
+
+ UNBLOCK_INPUT;
+ }
+}
+
+
+/* Free all faces realized for multibyte characters on frame F that
+ has FONTSET. */
+
+void
+free_realized_multibyte_face (f, fontset)
+ struct frame *f;
+ int fontset;
+{
+ struct face_cache *cache = FRAME_FACE_CACHE (f);
+ struct face *face;
+ int i;
+
+ /* We must block input here because we can't process X events safely
+ while only some faces are freed, or when the frame's current
+ matrix still references freed faces. */
+ BLOCK_INPUT;
+
+ for (i = 0; i < cache->used; i++)
+ {
+ face = cache->faces_by_id[i];
+ if (face
+ && face != face->ascii_face
+ && face->fontset == fontset)
+ {
+ uncache_face (cache, face);
+ free_realized_face (f, face);
+ }
+ }
+
+ /* Must do a thorough redisplay the next time. Mark current
+ matrices as invalid because they will reference faces freed
+ above. This function is also called when a frame is destroyed.
+ In this case, the root window of F is nil. */
+ if (WINDOWP (f->root_window))
+ {
+ clear_current_matrices (f);
+ ++windows_or_buffers_changed;
+ }
+
+ UNBLOCK_INPUT;
+}
+
+
+/* Free all realized faces on FRAME or on all frames if FRAME is nil.
+ This is done after attributes of a named face have been changed,
+ because we can't tell which realized faces depend on that face. */
+
+void
+free_all_realized_faces (frame)
+ Lisp_Object frame;
+{
+ if (NILP (frame))
+ {
+ Lisp_Object rest;
+ FOR_EACH_FRAME (rest, frame)
+ free_realized_faces (FRAME_FACE_CACHE (XFRAME (frame)));
+ }
+ else
+ free_realized_faces (FRAME_FACE_CACHE (XFRAME (frame)));
+}
+
+
+/* Free face cache C and faces in it, including their X resources. */
+
+static void
+free_face_cache (c)
+ struct face_cache *c;
+{
+ if (c)
+ {
+ free_realized_faces (c);
+ xfree (c->buckets);
+ xfree (c->faces_by_id);
+ xfree (c);
+ }
+}
+
+
+/* Cache realized face FACE in face cache C. HASH is the hash value
+ of FACE. If FACE->fontset >= 0, add the new face to the end of the
+ collision list of the face hash table of C. This is done because
+ otherwise lookup_face would find FACE for every character, even if
+ faces with the same attributes but for specific characters exist. */
+
+static void
+cache_face (c, face, hash)
+ struct face_cache *c;
+ struct face *face;
+ unsigned hash;
+{
+ int i = hash % FACE_CACHE_BUCKETS_SIZE;
+
+ face->hash = hash;
+
+ if (face->fontset >= 0)
+ {
+ struct face *last = c->buckets[i];
+ if (last)
+ {
+ while (last->next)
+ last = last->next;
+ last->next = face;
+ face->prev = last;
+ face->next = NULL;
+ }
+ else
+ {
+ c->buckets[i] = face;
+ face->prev = face->next = NULL;
+ }
+ }
+ else
+ {
+ face->prev = NULL;
+ face->next = c->buckets[i];
+ if (face->next)
+ face->next->prev = face;
+ c->buckets[i] = face;
+ }
+
+ /* Find a free slot in C->faces_by_id and use the index of the free
+ slot as FACE->id. */
+ for (i = 0; i < c->used; ++i)
+ if (c->faces_by_id[i] == NULL)
+ break;
+ face->id = i;
+
+ /* Maybe enlarge C->faces_by_id. */
+ if (i == c->used && c->used == c->size)
+ {
+ int new_size = 2 * c->size;
+ int sz = new_size * sizeof *c->faces_by_id;
+ c->faces_by_id = (struct face **) xrealloc (c->faces_by_id, sz);
+ c->size = new_size;
+ }
+
+#if GLYPH_DEBUG
+ /* Check that FACE got a unique id. */
+ {
+ int j, n;
+ struct face *face;
+
+ for (j = n = 0; j < FACE_CACHE_BUCKETS_SIZE; ++j)
+ for (face = c->buckets[j]; face; face = face->next)
+ if (face->id == i)
+ ++n;
+
+ xassert (n == 1);
+ }
+#endif /* GLYPH_DEBUG */
+
+ c->faces_by_id[i] = face;
+ if (i == c->used)
+ ++c->used;
+}
+
+
+/* Remove face FACE from cache C. */
+
+static void
+uncache_face (c, face)
+ struct face_cache *c;
+ struct face *face;
+{
+ int i = face->hash % FACE_CACHE_BUCKETS_SIZE;
+
+ if (face->prev)
+ face->prev->next = face->next;
+ else
+ c->buckets[i] = face->next;
+
+ if (face->next)
+ face->next->prev = face->prev;
+
+ c->faces_by_id[face->id] = NULL;
+ if (face->id == c->used)
+ --c->used;
+}
+
+
+/* Look up a realized face with face attributes ATTR in the face cache
+ of frame F. The face will be used to display character C. Value
+ is the ID of the face found. If no suitable face is found, realize
+ a new one. In that case, if C is a multibyte character, BASE_FACE
+ is a face that has the same attributes. */
+
+INLINE int
+lookup_face (f, attr, c, base_face)
+ struct frame *f;
+ Lisp_Object *attr;
+ int c;
+ struct face *base_face;
+{
+ struct face_cache *cache = FRAME_FACE_CACHE (f);
+ unsigned hash;
+ int i;
+ struct face *face;
+
+ xassert (cache != NULL);
+ check_lface_attrs (attr);
+
+ /* Look up ATTR in the face cache. */
+ hash = lface_hash (attr);
+ i = hash % FACE_CACHE_BUCKETS_SIZE;
+
+ for (face = cache->buckets[i]; face; face = face->next)
+ if (face->hash == hash
+ && (!FRAME_WINDOW_P (f)
+ || FACE_SUITABLE_FOR_CHAR_P (face, c))
+ && lface_equal_p (face->lface, attr))
+ break;
+
+ /* If not found, realize a new face. */
+ if (face == NULL)
+ face = realize_face (cache, attr, c, base_face, -1);
+
+#if GLYPH_DEBUG
+ xassert (face == FACE_FROM_ID (f, face->id));
+
+/* When this function is called from face_for_char (in this case, C is
+ a multibyte character), a fontset of a face returned by
+ realize_face is not yet set, i.e. FACE_SUITABLE_FOR_CHAR_P (FACE,
+ C) is not sutisfied. The fontset is set for this face by
+ face_for_char later. */
+#if 0
+ if (FRAME_WINDOW_P (f))
+ xassert (FACE_SUITABLE_FOR_CHAR_P (face, c));
+#endif
+#endif /* GLYPH_DEBUG */
+
+ return face->id;
+}
+
+
+/* Return the face id of the realized face for named face SYMBOL on
+ frame F suitable for displaying character C. Value is -1 if the
+ face couldn't be determined, which might happen if the default face
+ isn't realized and cannot be realized. */
+
+int
+lookup_named_face (f, symbol, c)
+ struct frame *f;
+ Lisp_Object symbol;
+ int c;
+{
+ Lisp_Object attrs[LFACE_VECTOR_SIZE];
+ Lisp_Object symbol_attrs[LFACE_VECTOR_SIZE];
+ struct face *default_face = FACE_FROM_ID (f, DEFAULT_FACE_ID);
+
+ if (default_face == NULL)
+ {
+ if (!realize_basic_faces (f))
+ return -1;
+ default_face = FACE_FROM_ID (f, DEFAULT_FACE_ID);
+ }
+
+ get_lface_attributes (f, symbol, symbol_attrs, 1);
+ bcopy (default_face->lface, attrs, sizeof attrs);
+ merge_face_vectors (f, symbol_attrs, attrs, Qnil);
+ return lookup_face (f, attrs, c, NULL);
+}
+
+
+/* Return the ID of the realized ASCII face of Lisp face with ID
+ LFACE_ID on frame F. Value is -1 if LFACE_ID isn't valid. */
+
+int
+ascii_face_of_lisp_face (f, lface_id)
+ struct frame *f;
+ int lface_id;
+{
+ int face_id;
+
+ if (lface_id >= 0 && lface_id < lface_id_to_name_size)
+ {
+ Lisp_Object face_name = lface_id_to_name[lface_id];
+ face_id = lookup_named_face (f, face_name, 0);
+ }
+ else
+ face_id = -1;
+
+ return face_id;
+}
+
+
+/* Return a face for charset ASCII that is like the face with id
+ FACE_ID on frame F, but has a font that is STEPS steps smaller.
+ STEPS < 0 means larger. Value is the id of the face. */
+
+int
+smaller_face (f, face_id, steps)
+ struct frame *f;
+ int face_id, steps;
+{
+#ifdef HAVE_WINDOW_SYSTEM
+ struct face *face;
+ Lisp_Object attrs[LFACE_VECTOR_SIZE];
+ int pt, last_pt, last_height;
+ int delta;
+ int new_face_id;
+ struct face *new_face;
+
+ /* If not called for an X frame, just return the original face. */
+ if (FRAME_TERMCAP_P (f))
+ return face_id;
+
+ /* Try in increments of 1/2 pt. */
+ delta = steps < 0 ? 5 : -5;
+ steps = abs (steps);
+
+ face = FACE_FROM_ID (f, face_id);
+ bcopy (face->lface, attrs, sizeof attrs);
+ pt = last_pt = XFASTINT (attrs[LFACE_HEIGHT_INDEX]);
+ new_face_id = face_id;
+ last_height = FONT_HEIGHT (face->font);
+
+ while (steps
+ && pt + delta > 0
+ /* Give up if we cannot find a font within 10pt. */
+ && abs (last_pt - pt) < 100)
+ {
+ /* Look up a face for a slightly smaller/larger font. */
+ pt += delta;
+ attrs[LFACE_HEIGHT_INDEX] = make_number (pt);
+ new_face_id = lookup_face (f, attrs, 0, NULL);
+ new_face = FACE_FROM_ID (f, new_face_id);
+
+ /* If height changes, count that as one step. */
+ if ((delta < 0 && FONT_HEIGHT (new_face->font) < last_height)
+ || (delta > 0 && FONT_HEIGHT (new_face->font) > last_height))
+ {
+ --steps;
+ last_height = FONT_HEIGHT (new_face->font);
+ last_pt = pt;
+ }
+ }
+
+ return new_face_id;
+
+#else /* not HAVE_WINDOW_SYSTEM */
+
+ return face_id;
+
+#endif /* not HAVE_WINDOW_SYSTEM */
+}
+
+
+/* Return a face for charset ASCII that is like the face with id
+ FACE_ID on frame F, but has height HEIGHT. */
+
+int
+face_with_height (f, face_id, height)
+ struct frame *f;
+ int face_id;
+ int height;
+{
+#ifdef HAVE_WINDOW_SYSTEM
+ struct face *face;
+ Lisp_Object attrs[LFACE_VECTOR_SIZE];
+
+ if (FRAME_TERMCAP_P (f)
+ || height <= 0)
+ return face_id;
+
+ face = FACE_FROM_ID (f, face_id);
+ bcopy (face->lface, attrs, sizeof attrs);
+ attrs[LFACE_HEIGHT_INDEX] = make_number (height);
+ face_id = lookup_face (f, attrs, 0, NULL);
+#endif /* HAVE_WINDOW_SYSTEM */
+
+ return face_id;
+}
+
+
+/* Return the face id of the realized face for named face SYMBOL on
+ frame F suitable for displaying character C, and use attributes of
+ the face FACE_ID for attributes that aren't completely specified by
+ SYMBOL. This is like lookup_named_face, except that the default
+ attributes come from FACE_ID, not from the default face. FACE_ID
+ is assumed to be already realized. */
+
+int
+lookup_derived_face (f, symbol, c, face_id)
+ struct frame *f;
+ Lisp_Object symbol;
+ int c;
+ int face_id;
+{
+ Lisp_Object attrs[LFACE_VECTOR_SIZE];
+ Lisp_Object symbol_attrs[LFACE_VECTOR_SIZE];
+ struct face *default_face = FACE_FROM_ID (f, face_id);
+
+ if (!default_face)
+ abort ();
+
+ get_lface_attributes (f, symbol, symbol_attrs, 1);
+ bcopy (default_face->lface, attrs, sizeof attrs);
+ merge_face_vectors (f, symbol_attrs, attrs, Qnil);
+ return lookup_face (f, attrs, c, default_face);
+}
+
+
+\f
+/***********************************************************************
+ Font selection
+ ***********************************************************************/
+
+DEFUN ("internal-set-font-selection-order",
+ Finternal_set_font_selection_order,
+ Sinternal_set_font_selection_order, 1, 1, 0,
+ "Set font selection order for face font selection to ORDER.\n\
+ORDER must be a list of length 4 containing the symbols `:width',\n\
+`:height', `:weight', and `:slant'. Face attributes appearing\n\
+first in ORDER are matched first, e.g. if `:height' appears before\n\
+`:weight' in ORDER, font selection first tries to find a font with\n\
+a suitable height, and then tries to match the font weight.\n\
+Value is ORDER.")
+ (order)
+ Lisp_Object order;
+{
+ Lisp_Object list;
+ int i;
+ int indices[DIM (font_sort_order)];
+
+ CHECK_LIST (order, 0);
+ bzero (indices, sizeof indices);
+ i = 0;
+
+ for (list = order;
+ CONSP (list) && i < DIM (indices);
+ list = XCDR (list), ++i)
+ {
+ Lisp_Object attr = XCAR (list);
+ int xlfd;
+
+ if (EQ (attr, QCwidth))
+ xlfd = XLFD_SWIDTH;
+ else if (EQ (attr, QCheight))
+ xlfd = XLFD_POINT_SIZE;
+ else if (EQ (attr, QCweight))
+ xlfd = XLFD_WEIGHT;
+ else if (EQ (attr, QCslant))
+ xlfd = XLFD_SLANT;
+ else
+ break;
+
+ if (indices[i] != 0)
+ break;
+ indices[i] = xlfd;
+ }
+
+ if (!NILP (list) || i != DIM (indices))
+ signal_error ("Invalid font sort order", order);
+ for (i = 0; i < DIM (font_sort_order); ++i)
+ if (indices[i] == 0)
+ signal_error ("Invalid font sort order", order);
+
+ if (bcmp (indices, font_sort_order, sizeof indices) != 0)
+ {
+ bcopy (indices, font_sort_order, sizeof font_sort_order);
+ free_all_realized_faces (Qnil);
+ }
+
+ return Qnil;
+}
+
+
+DEFUN ("internal-set-alternative-font-family-alist",
+ Finternal_set_alternative_font_family_alist,
+ Sinternal_set_alternative_font_family_alist, 1, 1, 0,
+ "Define alternative font families to try in face font selection.\n\
+ALIST is an alist of (FAMILY ALTERNATIVE1 ALTERNATIVE2 ...) entries.\n\
+Each ALTERNATIVE is tried in order if no fonts of font family FAMILY can\n\
+be found. Value is ALIST.")
+ (alist)
+ Lisp_Object alist;
+{
+ CHECK_LIST (alist, 0);
+ Vface_alternative_font_family_alist = alist;
+ free_all_realized_faces (Qnil);
+ return alist;
+}
+
+
+DEFUN ("internal-set-alternative-font-registry-alist",
+ Finternal_set_alternative_font_registry_alist,
+ Sinternal_set_alternative_font_registry_alist, 1, 1, 0,
+ "Define alternative font registries to try in face font selection.\n\
+ALIST is an alist of (REGISTRY ALTERNATIVE1 ALTERNATIVE2 ...) entries.\n\
+Each ALTERNATIVE is tried in order if no fonts of font registry REGISTRY can\n\
+be found. Value is ALIST.")
+ (alist)
+ Lisp_Object alist;
+{
+ CHECK_LIST (alist, 0);
+ Vface_alternative_font_registry_alist = alist;
+ free_all_realized_faces (Qnil);
+ return alist;
+}
+
+
+#ifdef HAVE_WINDOW_SYSTEM
+
+/* Value is non-zero if FONT is the name of a scalable font. The
+ X11R6 XLFD spec says that point size, pixel size, and average width
+ are zero for scalable fonts. Intlfonts contain at least one
+ scalable font ("*-muleindian-1") for which this isn't true, so we
+ just test average width. */
+
+static int
+font_scalable_p (font)
+ struct font_name *font;
+{
+ char *s = font->fields[XLFD_AVGWIDTH];
+ return (*s == '0' && *(s + 1) == '\0')
+#ifdef WINDOWSNT
+ /* Windows implementation of XLFD is slightly broken for backward
+ compatibility with previous broken versions, so test for
+ wildcards as well as 0. */
+ || *s == '*'
+#endif
+ ;
+}
+
+
+/* Ignore the difference of font point size less than this value. */
+
+#define FONT_POINT_SIZE_QUANTUM 5
+
+/* Value is non-zero if FONT1 is a better match for font attributes
+ VALUES than FONT2. VALUES is an array of face attribute values in
+ font sort order. COMPARE_PT_P zero means don't compare point
+ sizes. AVGWIDTH, if not zero, is a specified font average width
+ to compare with. */
+
+static int
+better_font_p (values, font1, font2, compare_pt_p, avgwidth)
+ int *values;
+ struct font_name *font1, *font2;
+ int compare_pt_p, avgwidth;
+{
+ int i;
+
+ for (i = 0; i < DIM (font_sort_order); ++i)
+ {
+ int xlfd_idx = font_sort_order[i];
+
+ if (compare_pt_p || xlfd_idx != XLFD_POINT_SIZE)
+ {
+ int delta1 = abs (values[i] - font1->numeric[xlfd_idx]);
+ int delta2 = abs (values[i] - font2->numeric[xlfd_idx]);
+
+ if (xlfd_idx == XLFD_POINT_SIZE
+ && abs (delta1 - delta2) < FONT_POINT_SIZE_QUANTUM)
+ continue;
+ if (delta1 > delta2)
+ return 0;
+ else if (delta1 < delta2)
+ return 1;
+ else
+ {
+ /* The difference may be equal because, e.g., the face
+ specifies `italic' but we have only `regular' and
+ `oblique'. Prefer `oblique' in this case. */
+ if ((xlfd_idx == XLFD_WEIGHT || xlfd_idx == XLFD_SLANT)
+ && font1->numeric[xlfd_idx] > values[i]
+ && font2->numeric[xlfd_idx] < values[i])
+ return 1;
+ }
+ }
+ }
+
+ if (avgwidth)
+ {
+ int delta1 = abs (avgwidth - font1->numeric[XLFD_AVGWIDTH]);
+ int delta2 = abs (avgwidth - font2->numeric[XLFD_AVGWIDTH]);
+ if (delta1 > delta2)
+ return 0;
+ else if (delta1 < delta2)
+ return 1;
+ }
+
+ return font1->registry_priority < font2->registry_priority;
+}
+
+
+/* Value is non-zero if FONT is an exact match for face attributes in
+ SPECIFIED. SPECIFIED is an array of face attribute values in font
+ sort order. AVGWIDTH, if non-zero, is an average width to compare
+ with. */
+
+static int
+exact_face_match_p (specified, font, avgwidth)
+ int *specified;
+ struct font_name *font;
+ int avgwidth;
+{
+ int i;
+
+ for (i = 0; i < DIM (font_sort_order); ++i)
+ if (specified[i] != font->numeric[font_sort_order[i]])
+ break;
+
+ return (i == DIM (font_sort_order)
+ && (avgwidth <= 0
+ || avgwidth == font->numeric[XLFD_AVGWIDTH]));
+}
+
+
+/* Value is the name of a scaled font, generated from scalable font
+ FONT on frame F. SPECIFIED_PT is the point-size to scale FONT to.
+ Value is allocated from heap. */
+
+static char *
+build_scalable_font_name (f, font, specified_pt)
+ struct frame *f;
+ struct font_name *font;
+ int specified_pt;
+{
+ char point_size[20], pixel_size[20];
+ int pixel_value;
+ double resy = FRAME_X_DISPLAY_INFO (f)->resy;
+ double pt;
+
+ /* If scalable font is for a specific resolution, compute
+ the point size we must specify from the resolution of
+ the display and the specified resolution of the font. */
+ if (font->numeric[XLFD_RESY] != 0)
+ {
+ pt = resy / font->numeric[XLFD_RESY] * specified_pt + 0.5;
+ pixel_value = font->numeric[XLFD_RESY] / (PT_PER_INCH * 10.0) * pt;
+ }
+ else
+ {
+ pt = specified_pt;
+ pixel_value = resy / (PT_PER_INCH * 10.0) * pt;
+ }
+
+ /* Set point size of the font. */
+ sprintf (point_size, "%d", (int) pt);
+ font->fields[XLFD_POINT_SIZE] = point_size;
+ font->numeric[XLFD_POINT_SIZE] = pt;
+
+ /* Set pixel size. */
+ sprintf (pixel_size, "%d", pixel_value);
+ font->fields[XLFD_PIXEL_SIZE] = pixel_size;
+ font->numeric[XLFD_PIXEL_SIZE] = pixel_value;
+
+ /* If font doesn't specify its resolution, use the
+ resolution of the display. */
+ if (font->numeric[XLFD_RESY] == 0)
+ {
+ char buffer[20];
+ sprintf (buffer, "%d", (int) resy);
+ font->fields[XLFD_RESY] = buffer;
+ font->numeric[XLFD_RESY] = resy;
+ }
+
+ if (strcmp (font->fields[XLFD_RESX], "0") == 0)
+ {
+ char buffer[20];
+ int resx = FRAME_X_DISPLAY_INFO (f)->resx;
+ sprintf (buffer, "%d", resx);
+ font->fields[XLFD_RESX] = buffer;
+ font->numeric[XLFD_RESX] = resx;
+ }
+
+ return build_font_name (font);
+}
+
+
+/* Value is non-zero if we are allowed to use scalable font FONT. We
+ can't run a Lisp function here since this function may be called
+ with input blocked. */
+
+static int
+may_use_scalable_font_p (font)
+ char *font;
+{
+ if (EQ (Vscalable_fonts_allowed, Qt))
+ return 1;
+ else if (CONSP (Vscalable_fonts_allowed))
+ {
+ Lisp_Object tail, regexp;
+
+ for (tail = Vscalable_fonts_allowed; CONSP (tail); tail = XCDR (tail))
+ {
+ regexp = XCAR (tail);
+ if (STRINGP (regexp)
+ && fast_c_string_match_ignore_case (regexp, font) >= 0)
+ return 1;
+ }
+ }
+
+ return 0;
+}
+
+
+
+/* Return the name of the best matching font for face attributes ATTRS
+ in the array of font_name structures FONTS which contains NFONTS
+ elements. WIDTH_RATIO is a factor with which to multiply average
+ widths if ATTRS specifies such a width.
+
+ Value is a font name which is allocated from the heap. FONTS is
+ freed by this function. */
+
+static char *
+best_matching_font (f, attrs, fonts, nfonts, width_ratio)
+ struct frame *f;
+ Lisp_Object *attrs;
+ struct font_name *fonts;
+ int nfonts;
+ int width_ratio;
+{
+ char *font_name;
+ struct font_name *best;
+ int i, pt = 0;
+ int specified[5];
+ int exact_p, avgwidth;
+
+ if (nfonts == 0)
+ return NULL;
+
+ /* Make specified font attributes available in `specified',
+ indexed by sort order. */
+ for (i = 0; i < DIM (font_sort_order); ++i)
+ {
+ int xlfd_idx = font_sort_order[i];
+
+ if (xlfd_idx == XLFD_SWIDTH)
+ specified[i] = face_numeric_swidth (attrs[LFACE_SWIDTH_INDEX]);
+ else if (xlfd_idx == XLFD_POINT_SIZE)
+ specified[i] = pt = XFASTINT (attrs[LFACE_HEIGHT_INDEX]);
+ else if (xlfd_idx == XLFD_WEIGHT)
+ specified[i] = face_numeric_weight (attrs[LFACE_WEIGHT_INDEX]);
+ else if (xlfd_idx == XLFD_SLANT)
+ specified[i] = face_numeric_slant (attrs[LFACE_SLANT_INDEX]);
+ else
+ abort ();
+ }
+
+ avgwidth = (UNSPECIFIEDP (attrs[LFACE_AVGWIDTH_INDEX])
+ ? 0
+ : XFASTINT (attrs[LFACE_AVGWIDTH_INDEX]) * width_ratio);
+
+ exact_p = 0;
+
+ /* Start with the first non-scalable font in the list. */
+ for (i = 0; i < nfonts; ++i)
+ if (!font_scalable_p (fonts + i))
+ break;
+
+ /* Find the best match among the non-scalable fonts. */
+ if (i < nfonts)
+ {
+ best = fonts + i;
+
+ for (i = 1; i < nfonts; ++i)
+ if (!font_scalable_p (fonts + i)
+ && better_font_p (specified, fonts + i, best, 1, avgwidth))
+ {
+ best = fonts + i;
+
+ exact_p = exact_face_match_p (specified, best, avgwidth);
+ if (exact_p)
+ break;
+ }
+
+ }
+ else
+ best = NULL;
+
+ /* Unless we found an exact match among non-scalable fonts, see if
+ we can find a better match among scalable fonts. */
+ if (!exact_p)
+ {
+ /* A scalable font is better if
+
+ 1. its weight, slant, swidth attributes are better, or.
+
+ 2. the best non-scalable font doesn't have the required
+ point size, and the scalable fonts weight, slant, swidth
+ isn't worse. */
+
+ int non_scalable_has_exact_height_p;
+
+ if (best && best->numeric[XLFD_POINT_SIZE] == pt)
+ non_scalable_has_exact_height_p = 1;
+ else
+ non_scalable_has_exact_height_p = 0;
+
+ for (i = 0; i < nfonts; ++i)
+ if (font_scalable_p (fonts + i))
+ {
+ if (best == NULL
+ || better_font_p (specified, fonts + i, best, 0, 0)
+ || (!non_scalable_has_exact_height_p
+ && !better_font_p (specified, best, fonts + i, 0, 0)))
+ best = fonts + i;
+ }
+ }
+
+ if (font_scalable_p (best))
+ font_name = build_scalable_font_name (f, best, pt);
+ else
+ font_name = build_font_name (best);
+
+ /* Free font_name structures. */
+ free_font_names (fonts, nfonts);
+
+ return font_name;
+}
+
+
+/* Get a list of matching fonts on frame F, considering FAMILY
+ and alternative font families from Vface_alternative_font_registry_alist.
+
+ FAMILY is the font family whose alternatives are considered.
+
+ REGISTRY, if a string, specifies a font registry and encoding to
+ match. A value of nil means include fonts of any registry and
+ encoding.
+
+ Return in *FONTS a pointer to a vector of font_name structures for
+ the fonts matched. Value is the number of fonts found. */
+
+static int
+try_alternative_families (f, family, registry, fonts)
+ struct frame *f;
+ Lisp_Object family, registry;
+ struct font_name **fonts;
+{
+ Lisp_Object alter;
+ int nfonts = 0;
+
+ nfonts = font_list (f, Qnil, family, registry, fonts);
+ if (nfonts == 0)
+ {
+ /* Try alternative font families. */
+ alter = Fassoc (family, Vface_alternative_font_family_alist);
+ if (CONSP (alter))
+ {
+ for (alter = XCDR (alter);
+ CONSP (alter) && nfonts == 0;
+ alter = XCDR (alter))
+ {
+ if (STRINGP (XCAR (alter)))
+ nfonts = font_list (f, Qnil, XCAR (alter), registry, fonts);
+ }
+ }
+
+ /* Try scalable fonts before giving up. */
+ if (nfonts == 0 && NILP (Vscalable_fonts_allowed))
+ {
+ int count = BINDING_STACK_SIZE ();
+ specbind (Qscalable_fonts_allowed, Qt);
+ nfonts = try_alternative_families (f, family, registry, fonts);
+ unbind_to (count, Qnil);
+ }
+ }
+ return nfonts;
+}
+
+
+/* Get a list of matching fonts on frame F.
+
+ FAMILY, if a string, specifies a font family derived from the fontset.
+ It is only used if the face does not specify any family in ATTRS or
+ if we cannot find any font of the face's family.
+
+ REGISTRY, if a string, specifies a font registry and encoding to
+ match. A value of nil means include fonts of any registry and
+ encoding.
+
+ Return in *FONTS a pointer to a vector of font_name structures for
+ the fonts matched. Value is the number of fonts found. */
+
+static int
+try_font_list (f, attrs, family, registry, fonts)
+ struct frame *f;
+ Lisp_Object *attrs;
+ Lisp_Object family, registry;
+ struct font_name **fonts;
+{
+ int nfonts = 0;
+ Lisp_Object face_family = attrs[LFACE_FAMILY_INDEX];
+
+ if (STRINGP (face_family))
+ nfonts = try_alternative_families (f, face_family, registry, fonts);
+
+ if (nfonts == 0 && !NILP (family))
+ nfonts = try_alternative_families (f, family, registry, fonts);
+
+ /* Try font family of the default face or "fixed". */
+ if (nfonts == 0)
+ {
+ struct face *default_face = FACE_FROM_ID (f, DEFAULT_FACE_ID);
+ if (default_face)
+ family = default_face->lface[LFACE_FAMILY_INDEX];
+ else
+ family = build_string ("fixed");
+ nfonts = font_list (f, Qnil, family, registry, fonts);
+ }
+
+ /* Try any family with the given registry. */
+ if (nfonts == 0)
+ nfonts = font_list (f, Qnil, Qnil, registry, fonts);
+
+ return nfonts;
+}
+
+
+/* Return the fontset id of the base fontset name or alias name given
+ by the fontset attribute of ATTRS. Value is -1 if the fontset
+ attribute of ATTRS doesn't name a fontset. */
+
+static int
+face_fontset (attrs)
+ Lisp_Object *attrs;
+{
+ Lisp_Object name;
+
+ name = attrs[LFACE_FONT_INDEX];
+ if (!STRINGP (name))
+ return -1;
+ return fs_query_fontset (name, 0);
+}
+
+
+/* Choose a name of font to use on frame F to display character C with
+ Lisp face attributes specified by ATTRS. The font name is
+ determined by the font-related attributes in ATTRS and the name
+ pattern for C in FONTSET. Value is the font name which is
+ allocated from the heap and must be freed by the caller, or NULL if
+ we can get no information about the font name of C. It is assured
+ that we always get some information for a single byte
+ character. */
+
+static char *
+choose_face_font (f, attrs, fontset, c)
+ struct frame *f;
+ Lisp_Object *attrs;
+ int fontset, c;
+{
+ Lisp_Object pattern;
+ char *font_name = NULL;
+ struct font_name *fonts;
+ int nfonts, width_ratio;
+
+ /* Get (foundry and) family name and registry (and encoding) name of
+ a font for C. */
+ pattern = fontset_font_pattern (f, fontset, c);
+ if (NILP (pattern))
+ {
+ xassert (!SINGLE_BYTE_CHAR_P (c));
+ return NULL;
+ }
+
+ /* If what we got is a name pattern, return it. */
+ if (STRINGP (pattern))
+ return xstrdup (XSTRING (pattern)->data);
+
+ /* Get a list of fonts matching that pattern and choose the
+ best match for the specified face attributes from it. */
+ nfonts = try_font_list (f, attrs, XCAR (pattern), XCDR (pattern), &fonts);
+ width_ratio = (SINGLE_BYTE_CHAR_P (c)
+ ? 1
+ : CHARSET_WIDTH (CHAR_CHARSET (c)));
+ font_name = best_matching_font (f, attrs, fonts, nfonts, width_ratio);
+ return font_name;
+}
+
+#endif /* HAVE_WINDOW_SYSTEM */
+
+
+\f
+/***********************************************************************
+ Face Realization
+ ***********************************************************************/
+
+/* Realize basic faces on frame F. Value is zero if frame parameters
+ of F don't contain enough information needed to realize the default
+ face. */
+
+static int
+realize_basic_faces (f)
+ struct frame *f;
+{
+ int success_p = 0;
+ int count = BINDING_STACK_SIZE ();
+
+ /* Block input here so that we won't be surprised by an X expose
+ event, for instance, without having the faces set up. */
+ BLOCK_INPUT;
+ specbind (Qscalable_fonts_allowed, Qt);
+
+ if (realize_default_face (f))
+ {
+ realize_named_face (f, Qmode_line, MODE_LINE_FACE_ID);
+ realize_named_face (f, Qtool_bar, TOOL_BAR_FACE_ID);
+ realize_named_face (f, Qfringe, BITMAP_AREA_FACE_ID);
+ realize_named_face (f, Qheader_line, HEADER_LINE_FACE_ID);
+ realize_named_face (f, Qscroll_bar, SCROLL_BAR_FACE_ID);
+ realize_named_face (f, Qborder, BORDER_FACE_ID);
+ realize_named_face (f, Qcursor, CURSOR_FACE_ID);
+ realize_named_face (f, Qmouse, MOUSE_FACE_ID);
+ realize_named_face (f, Qmenu, MENU_FACE_ID);
+
+ /* Reflect changes in the `menu' face in menu bars. */
+ if (FRAME_FACE_CACHE (f)->menu_face_changed_p)
+ {
+ FRAME_FACE_CACHE (f)->menu_face_changed_p = 0;
+#ifdef USE_X_TOOLKIT
+ x_update_menu_appearance (f);
+#endif
+ }
+
+ success_p = 1;
+ }
+
+ unbind_to (count, Qnil);
+ UNBLOCK_INPUT;
+ return success_p;
+}
+
+
+/* Realize the default face on frame F. If the face is not fully
+ specified, make it fully-specified. Attributes of the default face
+ that are not explicitly specified are taken from frame parameters. */
+
+static int
+realize_default_face (f)
+ struct frame *f;
+{
+ struct face_cache *c = FRAME_FACE_CACHE (f);
+ Lisp_Object lface;
+ Lisp_Object attrs[LFACE_VECTOR_SIZE];
+ Lisp_Object frame_font;
+ struct face *face;
+
+ /* If the `default' face is not yet known, create it. */
+ lface = lface_from_face_name (f, Qdefault, 0);
+ if (NILP (lface))
+ {
+ Lisp_Object frame;
+ XSETFRAME (frame, f);
+ lface = Finternal_make_lisp_face (Qdefault, frame);
+ }
+
+#ifdef HAVE_WINDOW_SYSTEM
+ if (FRAME_WINDOW_P (f))
+ {
+ /* Set frame_font to the value of the `font' frame parameter. */
+ frame_font = Fassq (Qfont, f->param_alist);
+ xassert (CONSP (frame_font) && STRINGP (XCDR (frame_font)));
+ frame_font = XCDR (frame_font);
+ set_lface_from_font_name (f, lface, frame_font, 1, 1);
+ }
+#endif /* HAVE_WINDOW_SYSTEM */
+
+ if (!FRAME_WINDOW_P (f))
+ {
+ LFACE_FAMILY (lface) = build_string ("default");
+ LFACE_SWIDTH (lface) = Qnormal;
+ LFACE_HEIGHT (lface) = make_number (1);
+ LFACE_WEIGHT (lface) = Qnormal;
+ LFACE_SLANT (lface) = Qnormal;
+ LFACE_AVGWIDTH (lface) = Qunspecified;
+ }
+
+ if (UNSPECIFIEDP (LFACE_UNDERLINE (lface)))
+ LFACE_UNDERLINE (lface) = Qnil;
+
+ if (UNSPECIFIEDP (LFACE_OVERLINE (lface)))
+ LFACE_OVERLINE (lface) = Qnil;
+
+ if (UNSPECIFIEDP (LFACE_STRIKE_THROUGH (lface)))
+ LFACE_STRIKE_THROUGH (lface) = Qnil;
+
+ if (UNSPECIFIEDP (LFACE_BOX (lface)))
+ LFACE_BOX (lface) = Qnil;
+
+ if (UNSPECIFIEDP (LFACE_INVERSE (lface)))
+ LFACE_INVERSE (lface) = Qnil;
+
+ if (UNSPECIFIEDP (LFACE_FOREGROUND (lface)))
+ {
+ /* This function is called so early that colors are not yet
+ set in the frame parameter list. */
+ Lisp_Object color = Fassq (Qforeground_color, f->param_alist);
+
+ if (CONSP (color) && STRINGP (XCDR (color)))
+ LFACE_FOREGROUND (lface) = XCDR (color);
+ else if (FRAME_WINDOW_P (f))
+ return 0;
+ else if (FRAME_TERMCAP_P (f) || FRAME_MSDOS_P (f))
+ LFACE_FOREGROUND (lface) = build_string (unspecified_fg);
+ else
+ abort ();
+ }
+
+ if (UNSPECIFIEDP (LFACE_BACKGROUND (lface)))
+ {
+ /* This function is called so early that colors are not yet
+ set in the frame parameter list. */
+ Lisp_Object color = Fassq (Qbackground_color, f->param_alist);
+ if (CONSP (color) && STRINGP (XCDR (color)))
+ LFACE_BACKGROUND (lface) = XCDR (color);
+ else if (FRAME_WINDOW_P (f))
+ return 0;
+ else if (FRAME_TERMCAP_P (f) || FRAME_MSDOS_P (f))
+ LFACE_BACKGROUND (lface) = build_string (unspecified_bg);
+ else
+ abort ();
+ }
+
+ if (UNSPECIFIEDP (LFACE_STIPPLE (lface)))
+ LFACE_STIPPLE (lface) = Qnil;
+
+ /* Realize the face; it must be fully-specified now. */
+ xassert (lface_fully_specified_p (XVECTOR (lface)->contents));
+ check_lface (lface);
+ bcopy (XVECTOR (lface)->contents, attrs, sizeof attrs);
+ face = realize_face (c, attrs, 0, NULL, DEFAULT_FACE_ID);
+ return 1;
+}
+
+
+/* Realize basic faces other than the default face in face cache C.
+ SYMBOL is the face name, ID is the face id the realized face must
+ have. The default face must have been realized already. */
+
+static void
+realize_named_face (f, symbol, id)
+ struct frame *f;
+ Lisp_Object symbol;
+ int id;
+{
+ struct face_cache *c = FRAME_FACE_CACHE (f);
+ Lisp_Object lface = lface_from_face_name (f, symbol, 0);
+ Lisp_Object attrs[LFACE_VECTOR_SIZE];
+ Lisp_Object symbol_attrs[LFACE_VECTOR_SIZE];
+ struct face *new_face;
+
+ /* The default face must exist and be fully specified. */
+ get_lface_attributes (f, Qdefault, attrs, 1);
+ check_lface_attrs (attrs);
+ xassert (lface_fully_specified_p (attrs));
+
+ /* If SYMBOL isn't know as a face, create it. */
+ if (NILP (lface))
+ {
+ Lisp_Object frame;
+ XSETFRAME (frame, f);
+ lface = Finternal_make_lisp_face (symbol, frame);
+ }
+
+ /* Merge SYMBOL's face with the default face. */
+ get_lface_attributes (f, symbol, symbol_attrs, 1);
+ merge_face_vectors (f, symbol_attrs, attrs, Qnil);
+
+ /* Realize the face. */
+ new_face = realize_face (c, attrs, 0, NULL, id);
+}
+
+
+/* Realize the fully-specified face with attributes ATTRS in face
+ cache CACHE for character C. If C is a multibyte character,
+ BASE_FACE is a face that has the same attributes. Otherwise,
+ BASE_FACE is ignored. If FORMER_FACE_ID is non-negative, it is an
+ ID of face to remove before caching the new face. Value is a
+ pointer to the newly created realized face. */
+
+static struct face *
+realize_face (cache, attrs, c, base_face, former_face_id)
+ struct face_cache *cache;
+ Lisp_Object *attrs;
+ int c;
+ struct face *base_face;
+ int former_face_id;
+{
+ struct face *face;
+
+ /* LFACE must be fully specified. */
+ xassert (cache != NULL);
+ check_lface_attrs (attrs);
+
+ if (former_face_id >= 0 && cache->used > former_face_id)
+ {
+ /* Remove the former face. */
+ struct face *former_face = cache->faces_by_id[former_face_id];
+ uncache_face (cache, former_face);
+ free_realized_face (cache->f, former_face);
+ }
+
+ if (FRAME_WINDOW_P (cache->f))
+ face = realize_x_face (cache, attrs, c, base_face);
+ else if (FRAME_TERMCAP_P (cache->f) || FRAME_MSDOS_P (cache->f))
+ face = realize_tty_face (cache, attrs, c);
+ else
+ abort ();
+
+ /* Insert the new face. */
+ cache_face (cache, face, lface_hash (attrs));
+#ifdef HAVE_WINDOW_SYSTEM
+ if (FRAME_WINDOW_P (cache->f) && face->font == NULL)
+ load_face_font (cache->f, face, c);
+#endif /* HAVE_WINDOW_SYSTEM */
+ return face;
+}
+
+
+/* Realize the fully-specified face with attributes ATTRS in face
+ cache CACHE for character C. Do it for X frame CACHE->f. If C is
+ a multibyte character, BASE_FACE is a face that has the same
+ attributes. Otherwise, BASE_FACE is ignored. If the new face
+ doesn't share font with the default face, a fontname is allocated
+ from the heap and set in `font_name' of the new face, but it is not
+ yet loaded here. Value is a pointer to the newly created realized
+ face. */
+
+static struct face *
+realize_x_face (cache, attrs, c, base_face)
+ struct face_cache *cache;
+ Lisp_Object *attrs;
+ int c;
+ struct face *base_face;
+{
+#ifdef HAVE_WINDOW_SYSTEM
+ struct face *face, *default_face;
+ struct frame *f;
+ Lisp_Object stipple, overline, strike_through, box;
+
+ xassert (FRAME_WINDOW_P (cache->f));
+ xassert (SINGLE_BYTE_CHAR_P (c)
+ || base_face);
+
+ /* Allocate a new realized face. */
+ face = make_realized_face (attrs);
+
+ f = cache->f;
+
+ /* If C is a multibyte character, we share all face attirbutes with
+ BASE_FACE including the realized fontset. But, we must load a
+ different font. */
+ if (!SINGLE_BYTE_CHAR_P (c))
+ {
+ bcopy (base_face, face, sizeof *face);
+ face->gc = 0;
+
+ /* Don't try to free the colors copied bitwise from BASE_FACE. */
+ face->colors_copied_bitwise_p = 1;
+
+ /* to force realize_face to load font */
+ face->font = NULL;
+ return face;
+ }
+
+ /* Now we are realizing a face for ASCII (and unibyte) characters. */
+
+ /* Determine the font to use. Most of the time, the font will be
+ the same as the font of the default face, so try that first. */
+ default_face = FACE_FROM_ID (f, DEFAULT_FACE_ID);
+ if (default_face
+ && FACE_SUITABLE_FOR_CHAR_P (default_face, c)
+ && lface_same_font_attributes_p (default_face->lface, attrs))
+ {
+ face->font = default_face->font;
+ face->fontset = default_face->fontset;
+ face->font_info_id = default_face->font_info_id;
+ face->font_name = default_face->font_name;
+ face->ascii_face = face;
+
+ /* But, as we can't share the fontset, make a new realized
+ fontset that has the same base fontset as of the default
+ face. */
+ face->fontset
+ = make_fontset_for_ascii_face (f, default_face->fontset);
+ }
+ else
+ {
+ /* If the face attribute ATTRS specifies a fontset, use it as
+ the base of a new realized fontset. Otherwise, use the same
+ base fontset as of the default face. The base determines
+ registry and encoding of a font. It may also determine
+ foundry and family. The other fields of font name pattern
+ are constructed from ATTRS. */
+ int fontset = face_fontset (attrs);
+
+ if ((fontset == -1) && default_face)
+ fontset = default_face->fontset;
+ face->fontset = make_fontset_for_ascii_face (f, fontset);
+ face->font = NULL; /* to force realize_face to load font */
+
+#ifdef macintosh
+ /* Load the font if it is specified in ATTRS. This fixes
+ changing frame font on the Mac. */
+ if (STRINGP (attrs[LFACE_FONT_INDEX]))
+ {
+ struct font_info *font_info =
+ FS_LOAD_FONT (f, 0, XSTRING (attrs[LFACE_FONT_INDEX])->data, -1);
+ if (font_info)
+ face->font = font_info->font;
+ }
+#endif
+ }
+
+ /* Load colors, and set remaining attributes. */
+
+ load_face_colors (f, face, attrs);
+
+ /* Set up box. */
+ box = attrs[LFACE_BOX_INDEX];
+ if (STRINGP (box))
+ {
+ /* A simple box of line width 1 drawn in color given by
+ the string. */
+ face->box_color = load_color (f, face, attrs[LFACE_BOX_INDEX],
+ LFACE_BOX_INDEX);
+ face->box = FACE_SIMPLE_BOX;
+ face->box_line_width = 1;
+ }
+ else if (INTEGERP (box))
+ {
+ /* Simple box of specified line width in foreground color of the
+ face. */
+ xassert (XINT (box) != 0);
+ face->box = FACE_SIMPLE_BOX;
+ face->box_line_width = XINT (box);
+ face->box_color = face->foreground;
+ face->box_color_defaulted_p = 1;
+ }
+ else if (CONSP (box))
+ {
+ /* `(:width WIDTH :color COLOR :shadow SHADOW)'. SHADOW
+ being one of `raised' or `sunken'. */
+ face->box = FACE_SIMPLE_BOX;
+ face->box_color = face->foreground;
+ face->box_color_defaulted_p = 1;
+ face->box_line_width = 1;
+
+ while (CONSP (box))
+ {
+ Lisp_Object keyword, value;
+
+ keyword = XCAR (box);
+ box = XCDR (box);
+
+ if (!CONSP (box))
+ break;
+ value = XCAR (box);
+ box = XCDR (box);
+
+ if (EQ (keyword, QCline_width))
+ {
+ if (INTEGERP (value) && XINT (value) != 0)
+ face->box_line_width = XINT (value);
+ }
+ else if (EQ (keyword, QCcolor))
+ {
+ if (STRINGP (value))
+ {
+ face->box_color = load_color (f, face, value,
+ LFACE_BOX_INDEX);
+ face->use_box_color_for_shadows_p = 1;
+ }
+ }
+ else if (EQ (keyword, QCstyle))
+ {
+ if (EQ (value, Qreleased_button))
+ face->box = FACE_RAISED_BOX;
+ else if (EQ (value, Qpressed_button))
+ face->box = FACE_SUNKEN_BOX;
+ }
+ }
+ }
+
+ /* Text underline, overline, strike-through. */
+
+ if (EQ (attrs[LFACE_UNDERLINE_INDEX], Qt))
+ {
+ /* Use default color (same as foreground color). */
+ face->underline_p = 1;
+ face->underline_defaulted_p = 1;
+ face->underline_color = 0;
+ }
+ else if (STRINGP (attrs[LFACE_UNDERLINE_INDEX]))
+ {
+ /* Use specified color. */
+ face->underline_p = 1;
+ face->underline_defaulted_p = 0;
+ face->underline_color
+ = load_color (f, face, attrs[LFACE_UNDERLINE_INDEX],
+ LFACE_UNDERLINE_INDEX);
+ }
+ else if (NILP (attrs[LFACE_UNDERLINE_INDEX]))
+ {
+ face->underline_p = 0;
+ face->underline_defaulted_p = 0;
+ face->underline_color = 0;
+ }
+
+ overline = attrs[LFACE_OVERLINE_INDEX];
+ if (STRINGP (overline))
+ {
+ face->overline_color
+ = load_color (f, face, attrs[LFACE_OVERLINE_INDEX],
+ LFACE_OVERLINE_INDEX);
+ face->overline_p = 1;
+ }
+ else if (EQ (overline, Qt))
+ {
+ face->overline_color = face->foreground;
+ face->overline_color_defaulted_p = 1;
+ face->overline_p = 1;
+ }
+
+ strike_through = attrs[LFACE_STRIKE_THROUGH_INDEX];
+ if (STRINGP (strike_through))
+ {
+ face->strike_through_color
+ = load_color (f, face, attrs[LFACE_STRIKE_THROUGH_INDEX],
+ LFACE_STRIKE_THROUGH_INDEX);
+ face->strike_through_p = 1;
+ }
+ else if (EQ (strike_through, Qt))
+ {
+ face->strike_through_color = face->foreground;
+ face->strike_through_color_defaulted_p = 1;
+ face->strike_through_p = 1;
+ }
+
+ stipple = attrs[LFACE_STIPPLE_INDEX];
+ if (!NILP (stipple))
+ face->stipple = load_pixmap (f, stipple, &face->pixmap_w, &face->pixmap_h);
+
+ xassert (FACE_SUITABLE_FOR_CHAR_P (face, c));
+ return face;
+#endif /* HAVE_WINDOW_SYSTEM */
+}
+
+
+/* Map a specified color of face FACE on frame F to a tty color index.
+ IDX is either LFACE_FOREGROUND_INDEX or LFACE_BACKGROUND_INDEX, and
+ specifies which color to map. Set *DEFAULTED to 1 if mapping to the
+ default foreground/background colors. */
+
+static void
+map_tty_color (f, face, idx, defaulted)
+ struct frame *f;
+ struct face *face;
+ enum lface_attribute_index idx;
+ int *defaulted;
+{
+ Lisp_Object frame, color, def;
+ int foreground_p = idx == LFACE_FOREGROUND_INDEX;
+ unsigned long default_pixel, default_other_pixel, pixel;
+
+ xassert (idx == LFACE_FOREGROUND_INDEX || idx == LFACE_BACKGROUND_INDEX);
+
+ if (foreground_p)
+ {
+ pixel = default_pixel = FACE_TTY_DEFAULT_FG_COLOR;
+ default_other_pixel = FACE_TTY_DEFAULT_BG_COLOR;
+ }
+ else
+ {
+ pixel = default_pixel = FACE_TTY_DEFAULT_BG_COLOR;
+ default_other_pixel = FACE_TTY_DEFAULT_FG_COLOR;
+ }
+
+ XSETFRAME (frame, f);
+ color = face->lface[idx];
+
+ if (STRINGP (color)
+ && XSTRING (color)->size
+ && CONSP (Vtty_defined_color_alist)
+ && (def = assq_no_quit (color, call1 (Qtty_color_alist, frame)),
+ CONSP (def)))
+ {
+ /* Associations in tty-defined-color-alist are of the form
+ (NAME INDEX R G B). We need the INDEX part. */
+ pixel = XINT (XCAR (XCDR (def)));
+ }
+
+ if (pixel == default_pixel && STRINGP (color))
+ {
+ pixel = load_color (f, face, color, idx);
+
+#if defined (MSDOS) || defined (WINDOWSNT)
+ /* If the foreground of the default face is the default color,
+ use the foreground color defined by the frame. */
+#ifdef MSDOS
+ if (FRAME_MSDOS_P (f))
+ {
+#endif /* MSDOS */
+ if (pixel == default_pixel
+ || pixel == FACE_TTY_DEFAULT_COLOR)
+ {
+ if (foreground_p)
+ pixel = FRAME_FOREGROUND_PIXEL (f);
+ else
+ pixel = FRAME_BACKGROUND_PIXEL (f);
+ face->lface[idx] = tty_color_name (f, pixel);
+ *defaulted = 1;
+ }
+ else if (pixel == default_other_pixel)
+ {
+ if (foreground_p)
+ pixel = FRAME_BACKGROUND_PIXEL (f);
+ else
+ pixel = FRAME_FOREGROUND_PIXEL (f);
+ face->lface[idx] = tty_color_name (f, pixel);
+ *defaulted = 1;
+ }
+#ifdef MSDOS
+ }
+#endif
+#endif /* MSDOS or WINDOWSNT */
+ }
+
+ if (foreground_p)
+ face->foreground = pixel;
+ else
+ face->background = pixel;
+}
+
+
+/* Realize the fully-specified face with attributes ATTRS in face
+ cache CACHE for character C. Do it for TTY frame CACHE->f. Value is a
+ pointer to the newly created realized face. */
+
+static struct face *
+realize_tty_face (cache, attrs, c)
+ struct face_cache *cache;
+ Lisp_Object *attrs;
+ int c;
+{
+ struct face *face;
+ int weight, slant;
+ int face_colors_defaulted = 0;
+ struct frame *f = cache->f;
+
+ /* Frame must be a termcap frame. */
+ xassert (FRAME_TERMCAP_P (cache->f) || FRAME_MSDOS_P (cache->f));
+
+ /* Allocate a new realized face. */
+ face = make_realized_face (attrs);
+ face->font_name = FRAME_MSDOS_P (cache->f) ? "ms-dos" : "tty";
+
+ /* Map face attributes to TTY appearances. We map slant to
+ dimmed text because we want italic text to appear differently
+ and because dimmed text is probably used infrequently. */
+ weight = face_numeric_weight (attrs[LFACE_WEIGHT_INDEX]);
+ slant = face_numeric_slant (attrs[LFACE_SLANT_INDEX]);
+
+ if (weight > XLFD_WEIGHT_MEDIUM)
+ face->tty_bold_p = 1;
+ if (weight < XLFD_WEIGHT_MEDIUM || slant != XLFD_SLANT_ROMAN)
+ face->tty_dim_p = 1;
+ if (!NILP (attrs[LFACE_UNDERLINE_INDEX]))
+ face->tty_underline_p = 1;
+ if (!NILP (attrs[LFACE_INVERSE_INDEX]))
+ face->tty_reverse_p = 1;
+
+ /* Map color names to color indices. */
+ map_tty_color (f, face, LFACE_FOREGROUND_INDEX, &face_colors_defaulted);
+ map_tty_color (f, face, LFACE_BACKGROUND_INDEX, &face_colors_defaulted);
+
+ /* Swap colors if face is inverse-video. If the colors are taken
+ from the frame colors, they are already inverted, since the
+ frame-creation function calls x-handle-reverse-video. */
+ if (face->tty_reverse_p && !face_colors_defaulted)
+ {
+ unsigned long tem = face->foreground;
+ face->foreground = face->background;
+ face->background = tem;
+ }
+
+ if (tty_suppress_bold_inverse_default_colors_p
+ && face->tty_bold_p
+ && face->background == FACE_TTY_DEFAULT_FG_COLOR
+ && face->foreground == FACE_TTY_DEFAULT_BG_COLOR)
+ face->tty_bold_p = 0;
+
+ return face;
+}
+
+
+DEFUN ("tty-suppress-bold-inverse-default-colors",
+ Ftty_suppress_bold_inverse_default_colors,
+ Stty_suppress_bold_inverse_default_colors, 1, 1, 0,
+ "Suppress/allow boldness of faces with inverse default colors.\n\
+SUPPRESS non-nil means suppress it.\n\
+This affects bold faces on TTYs whose foreground is the default background\n\
+color of the display and whose background is the default foreground color.\n\
+For such faces, the bold face attribute is ignored if this variable\n\
+is non-nil.")
+ (suppress)
+ Lisp_Object suppress;
+{
+ tty_suppress_bold_inverse_default_colors_p = !NILP (suppress);
+ ++face_change_count;
+ return suppress;
+}
+
+
+\f
+/***********************************************************************
+ Computing Faces
+ ***********************************************************************/
+
+/* Return the ID of the face to use to display character CH with face
+ property PROP on frame F in current_buffer. */
+
+int
+compute_char_face (f, ch, prop)
+ struct frame *f;
+ int ch;
+ Lisp_Object prop;
+{
+ int face_id;
+
+ if (NILP (current_buffer->enable_multibyte_characters))
+ ch = 0;
+
+ if (NILP (prop))
+ {
+ struct face *face = FACE_FROM_ID (f, DEFAULT_FACE_ID);
+ face_id = FACE_FOR_CHAR (f, face, ch);
+ }
+ else
+ {
+ Lisp_Object attrs[LFACE_VECTOR_SIZE];
+ struct face *default_face = FACE_FROM_ID (f, DEFAULT_FACE_ID);
+ bcopy (default_face->lface, attrs, sizeof attrs);
+ merge_face_vector_with_property (f, attrs, prop);
+ face_id = lookup_face (f, attrs, ch, NULL);
+ }
+
+ return face_id;
+}
+
+
+/* Return the face ID associated with buffer position POS for
+ displaying ASCII characters. Return in *ENDPTR the position at
+ which a different face is needed, as far as text properties and
+ overlays are concerned. W is a window displaying current_buffer.
+
+ REGION_BEG, REGION_END delimit the region, so it can be
+ highlighted.
+
+ LIMIT is a position not to scan beyond. That is to limit the time
+ this function can take.
+
+ If MOUSE is non-zero, use the character's mouse-face, not its face.
+
+ The face returned is suitable for displaying ASCII characters. */
+
+int
+face_at_buffer_position (w, pos, region_beg, region_end,
+ endptr, limit, mouse)
+ struct window *w;
+ int pos;
+ int region_beg, region_end;
+ int *endptr;
+ int limit;
+ int mouse;
+{
+ struct frame *f = XFRAME (w->frame);
+ Lisp_Object attrs[LFACE_VECTOR_SIZE];
+ Lisp_Object prop, position;
+ int i, noverlays;
+ Lisp_Object *overlay_vec;
+ Lisp_Object frame;
+ int endpos;
+ Lisp_Object propname = mouse ? Qmouse_face : Qface;
+ Lisp_Object limit1, end;
+ struct face *default_face;
+
+ /* W must display the current buffer. We could write this function
+ to use the frame and buffer of W, but right now it doesn't. */
+ /* xassert (XBUFFER (w->buffer) == current_buffer); */
+
+ XSETFRAME (frame, f);
+ XSETFASTINT (position, pos);
+
+ endpos = ZV;
+ if (pos < region_beg && region_beg < endpos)
+ endpos = region_beg;
+
+ /* Get the `face' or `mouse_face' text property at POS, and
+ determine the next position at which the property changes. */
+ prop = Fget_text_property (position, propname, w->buffer);
+ XSETFASTINT (limit1, (limit < endpos ? limit : endpos));
+ end = Fnext_single_property_change (position, propname, w->buffer, limit1);
+ if (INTEGERP (end))
+ endpos = XINT (end);
+
+ /* Look at properties from overlays. */
+ {
+ int next_overlay;
+ int len;
+
+ /* First try with room for 40 overlays. */
+ len = 40;
+ overlay_vec = (Lisp_Object *) alloca (len * sizeof (Lisp_Object));
+ noverlays = overlays_at (pos, 0, &overlay_vec, &len,
+ &next_overlay, NULL, 0);
+
+ /* If there are more than 40, make enough space for all, and try
+ again. */
+ if (noverlays > len)
+ {
+ len = noverlays;
+ overlay_vec = (Lisp_Object *) alloca (len * sizeof (Lisp_Object));
+ noverlays = overlays_at (pos, 0, &overlay_vec, &len,
+ &next_overlay, NULL, 0);
+ }
+
+ if (next_overlay < endpos)
+ endpos = next_overlay;
+ }
+
+ *endptr = endpos;
+
+ default_face = FACE_FROM_ID (f, DEFAULT_FACE_ID);
+
+ /* Optimize common cases where we can use the default face. */
+ if (noverlays == 0
+ && NILP (prop)
+ && !(pos >= region_beg && pos < region_end))
+ return DEFAULT_FACE_ID;
+
+ /* Begin with attributes from the default face. */
+ bcopy (default_face->lface, attrs, sizeof attrs);
+
+ /* Merge in attributes specified via text properties. */
+ if (!NILP (prop))
+ merge_face_vector_with_property (f, attrs, prop);
+
+ /* Now merge the overlay data. */
+ noverlays = sort_overlays (overlay_vec, noverlays, w);
+ for (i = 0; i < noverlays; i++)
+ {
+ Lisp_Object oend;
+ int oendpos;
+
+ prop = Foverlay_get (overlay_vec[i], propname);
+ if (!NILP (prop))
+ merge_face_vector_with_property (f, attrs, prop);
+
+ oend = OVERLAY_END (overlay_vec[i]);
+ oendpos = OVERLAY_POSITION (oend);
+ if (oendpos < endpos)
+ endpos = oendpos;
+ }
+
+ /* If in the region, merge in the region face. */
+ if (pos >= region_beg && pos < region_end)
+ {
+ Lisp_Object region_face = lface_from_face_name (f, Qregion, 0);
+ merge_face_vectors (f, XVECTOR (region_face)->contents, attrs, Qnil);
+
+ if (region_end < endpos)
+ endpos = region_end;
+ }
+
+ *endptr = endpos;
+
+ /* Look up a realized face with the given face attributes,
+ or realize a new one for ASCII characters. */
+ return lookup_face (f, attrs, 0, NULL);
+}
+
+
+/* Compute the face at character position POS in Lisp string STRING on
+ window W, for ASCII characters.
+
+ If STRING is an overlay string, it comes from position BUFPOS in
+ current_buffer, otherwise BUFPOS is zero to indicate that STRING is
+ not an overlay string. W must display the current buffer.
+ REGION_BEG and REGION_END give the start and end positions of the
+ region; both are -1 if no region is visible.
+
+ BASE_FACE_ID is the id of a face to merge with. For strings coming
+ from overlays or the `display' property it is the face at BUFPOS.
+
+ If MOUSE_P is non-zero, use the character's mouse-face, not its face.
+
+ Set *ENDPTR to the next position where to check for faces in
+ STRING; -1 if the face is constant from POS to the end of the
+ string.
+
+ Value is the id of the face to use. The face returned is suitable
+ for displaying ASCII characters. */
+
+int
+face_at_string_position (w, string, pos, bufpos, region_beg,
+ region_end, endptr, base_face_id, mouse_p)
+ struct window *w;
+ Lisp_Object string;
+ int pos, bufpos;
+ int region_beg, region_end;
+ int *endptr;
+ enum face_id base_face_id;
+ int mouse_p;
+{
+ Lisp_Object prop, position, end, limit;
+ struct frame *f = XFRAME (WINDOW_FRAME (w));
+ Lisp_Object attrs[LFACE_VECTOR_SIZE];
+ struct face *base_face;
+ int multibyte_p = STRING_MULTIBYTE (string);
+ Lisp_Object prop_name = mouse_p ? Qmouse_face : Qface;
+
+ /* Get the value of the face property at the current position within
+ STRING. Value is nil if there is no face property. */
+ XSETFASTINT (position, pos);
+ prop = Fget_text_property (position, prop_name, string);
+
+ /* Get the next position at which to check for faces. Value of end
+ is nil if face is constant all the way to the end of the string.
+ Otherwise it is a string position where to check faces next.
+ Limit is the maximum position up to which to check for property
+ changes in Fnext_single_property_change. Strings are usually
+ short, so set the limit to the end of the string. */
+ XSETFASTINT (limit, XSTRING (string)->size);
+ end = Fnext_single_property_change (position, prop_name, string, limit);
+ if (INTEGERP (end))
+ *endptr = XFASTINT (end);
+ else
+ *endptr = -1;
+
+ base_face = FACE_FROM_ID (f, base_face_id);
+ xassert (base_face);
+
+ /* Optimize the default case that there is no face property and we
+ are not in the region. */
+ if (NILP (prop)
+ && (base_face_id != DEFAULT_FACE_ID
+ /* BUFPOS <= 0 means STRING is not an overlay string, so
+ that the region doesn't have to be taken into account. */
+ || bufpos <= 0
+ || bufpos < region_beg
+ || bufpos >= region_end)
+ && (multibyte_p
+ /* We can't realize faces for different charsets differently
+ if we don't have fonts, so we can stop here if not working
+ on a window-system frame. */
+ || !FRAME_WINDOW_P (f)
+ || FACE_SUITABLE_FOR_CHAR_P (base_face, 0)))
+ return base_face->id;
+
+ /* Begin with attributes from the base face. */
+ bcopy (base_face->lface, attrs, sizeof attrs);
+
+ /* Merge in attributes specified via text properties. */
+ if (!NILP (prop))
+ merge_face_vector_with_property (f, attrs, prop);
+
+ /* If in the region, merge in the region face. */
+ if (bufpos
+ && bufpos >= region_beg
+ && bufpos < region_end)
+ {
+ Lisp_Object region_face = lface_from_face_name (f, Qregion, 0);
+ merge_face_vectors (f, XVECTOR (region_face)->contents, attrs, Qnil);
+ }
+
+ /* Look up a realized face with the given face attributes,
+ or realize a new one for ASCII characters. */
+ return lookup_face (f, attrs, 0, NULL);
+}
+
+
+\f
+/***********************************************************************
+ Tests
+ ***********************************************************************/
+
+#if GLYPH_DEBUG
+
+/* Print the contents of the realized face FACE to stderr. */
+
+static void
+dump_realized_face (face)
+ struct face *face;
+{
+ fprintf (stderr, "ID: %d\n", face->id);
+#ifdef HAVE_X_WINDOWS
+ fprintf (stderr, "gc: %d\n", (int) face->gc);
+#endif
+ fprintf (stderr, "foreground: 0x%lx (%s)\n",
+ face->foreground,
+ XSTRING (face->lface[LFACE_FOREGROUND_INDEX])->data);
+ fprintf (stderr, "background: 0x%lx (%s)\n",
+ face->background,
+ XSTRING (face->lface[LFACE_BACKGROUND_INDEX])->data);
+ fprintf (stderr, "font_name: %s (%s)\n",
+ face->font_name,
+ XSTRING (face->lface[LFACE_FAMILY_INDEX])->data);
+#ifdef HAVE_X_WINDOWS
+ fprintf (stderr, "font = %p\n", face->font);
+#endif
+ fprintf (stderr, "font_info_id = %d\n", face->font_info_id);
+ fprintf (stderr, "fontset: %d\n", face->fontset);
+ fprintf (stderr, "underline: %d (%s)\n",
+ face->underline_p,
+ XSTRING (Fsymbol_name (face->lface[LFACE_UNDERLINE_INDEX]))->data);
+ fprintf (stderr, "hash: %d\n", face->hash);
+ fprintf (stderr, "charset: %d\n", face->charset);
+}
+
+
+DEFUN ("dump-face", Fdump_face, Sdump_face, 0, 1, 0, "")
+ (n)
+ Lisp_Object n;
+{
+ if (NILP (n))
+ {
+ int i;
+
+ fprintf (stderr, "font selection order: ");
+ for (i = 0; i < DIM (font_sort_order); ++i)
+ fprintf (stderr, "%d ", font_sort_order[i]);
+ fprintf (stderr, "\n");
+
+ fprintf (stderr, "alternative fonts: ");
+ debug_print (Vface_alternative_font_family_alist);
+ fprintf (stderr, "\n");
+
+ for (i = 0; i < FRAME_FACE_CACHE (SELECTED_FRAME ())->used; ++i)
+ Fdump_face (make_number (i));
+ }
+ else
+ {
+ struct face *face;
+ CHECK_NUMBER (n, 0);
+ face = FACE_FROM_ID (SELECTED_FRAME (), XINT (n));
+ if (face == NULL)
+ error ("Not a valid face");
+ dump_realized_face (face);
+ }
+
+ return Qnil;
+}
+
+
+DEFUN ("show-face-resources", Fshow_face_resources, Sshow_face_resources,
+ 0, 0, 0, "")
+ ()
+{
+ fprintf (stderr, "number of colors = %d\n", ncolors_allocated);
+ fprintf (stderr, "number of pixmaps = %d\n", npixmaps_allocated);
+ fprintf (stderr, "number of GCs = %d\n", ngcs);
+ return Qnil;
+}
+
+#endif /* GLYPH_DEBUG != 0 */
+
+
+\f
+/***********************************************************************
+ Initialization
+ ***********************************************************************/
+
+void
+syms_of_xfaces ()
+{
+ Qface = intern ("face");
+ staticpro (&Qface);
+ Qbitmap_spec_p = intern ("bitmap-spec-p");
+ staticpro (&Qbitmap_spec_p);
+ Qframe_update_face_colors = intern ("frame-update-face-colors");
+ staticpro (&Qframe_update_face_colors);
+
+ /* Lisp face attribute keywords. */
+ QCfamily = intern (":family");
+ staticpro (&QCfamily);
+ QCheight = intern (":height");
+ staticpro (&QCheight);
+ QCweight = intern (":weight");
+ staticpro (&QCweight);
+ QCslant = intern (":slant");
+ staticpro (&QCslant);
+ QCunderline = intern (":underline");
+ staticpro (&QCunderline);
+ QCinverse_video = intern (":inverse-video");
+ staticpro (&QCinverse_video);
+ QCreverse_video = intern (":reverse-video");
+ staticpro (&QCreverse_video);
+ QCforeground = intern (":foreground");
+ staticpro (&QCforeground);
+ QCbackground = intern (":background");
+ staticpro (&QCbackground);
+ QCstipple = intern (":stipple");;
+ staticpro (&QCstipple);
+ QCwidth = intern (":width");
+ staticpro (&QCwidth);
+ QCfont = intern (":font");
+ staticpro (&QCfont);
+ QCbold = intern (":bold");
+ staticpro (&QCbold);
+ QCitalic = intern (":italic");
+ staticpro (&QCitalic);
+ QCoverline = intern (":overline");
+ staticpro (&QCoverline);
+ QCstrike_through = intern (":strike-through");
+ staticpro (&QCstrike_through);
+ QCbox = intern (":box");
+ staticpro (&QCbox);
+ QCinherit = intern (":inherit");
+ staticpro (&QCinherit);
+
+ /* Symbols used for Lisp face attribute values. */
+ QCcolor = intern (":color");
+ staticpro (&QCcolor);
+ QCline_width = intern (":line-width");
+ staticpro (&QCline_width);
+ QCstyle = intern (":style");
+ staticpro (&QCstyle);
+ Qreleased_button = intern ("released-button");
+ staticpro (&Qreleased_button);
+ Qpressed_button = intern ("pressed-button");
+ staticpro (&Qpressed_button);
+ Qnormal = intern ("normal");
+ staticpro (&Qnormal);
+ Qultra_light = intern ("ultra-light");
+ staticpro (&Qultra_light);
+ Qextra_light = intern ("extra-light");
+ staticpro (&Qextra_light);
+ Qlight = intern ("light");
+ staticpro (&Qlight);
+ Qsemi_light = intern ("semi-light");
+ staticpro (&Qsemi_light);
+ Qsemi_bold = intern ("semi-bold");
+ staticpro (&Qsemi_bold);
+ Qbold = intern ("bold");
+ staticpro (&Qbold);
+ Qextra_bold = intern ("extra-bold");
+ staticpro (&Qextra_bold);
+ Qultra_bold = intern ("ultra-bold");
+ staticpro (&Qultra_bold);
+ Qoblique = intern ("oblique");
+ staticpro (&Qoblique);
+ Qitalic = intern ("italic");
+ staticpro (&Qitalic);
+ Qreverse_oblique = intern ("reverse-oblique");
+ staticpro (&Qreverse_oblique);
+ Qreverse_italic = intern ("reverse-italic");
+ staticpro (&Qreverse_italic);
+ Qultra_condensed = intern ("ultra-condensed");
+ staticpro (&Qultra_condensed);
+ Qextra_condensed = intern ("extra-condensed");
+ staticpro (&Qextra_condensed);
+ Qcondensed = intern ("condensed");
+ staticpro (&Qcondensed);
+ Qsemi_condensed = intern ("semi-condensed");
+ staticpro (&Qsemi_condensed);
+ Qsemi_expanded = intern ("semi-expanded");
+ staticpro (&Qsemi_expanded);
+ Qexpanded = intern ("expanded");
+ staticpro (&Qexpanded);
+ Qextra_expanded = intern ("extra-expanded");
+ staticpro (&Qextra_expanded);
+ Qultra_expanded = intern ("ultra-expanded");
+ staticpro (&Qultra_expanded);
+ Qbackground_color = intern ("background-color");
+ staticpro (&Qbackground_color);
+ Qforeground_color = intern ("foreground-color");
+ staticpro (&Qforeground_color);
+ Qunspecified = intern ("unspecified");
+ staticpro (&Qunspecified);
+
+ Qface_alias = intern ("face-alias");
+ staticpro (&Qface_alias);
+ Qdefault = intern ("default");
+ staticpro (&Qdefault);
+ Qtool_bar = intern ("tool-bar");
+ staticpro (&Qtool_bar);
+ Qregion = intern ("region");
+ staticpro (&Qregion);
+ Qfringe = intern ("fringe");
+ staticpro (&Qfringe);
+ Qheader_line = intern ("header-line");
+ staticpro (&Qheader_line);
+ Qscroll_bar = intern ("scroll-bar");
+ staticpro (&Qscroll_bar);
+ Qmenu = intern ("menu");
+ staticpro (&Qmenu);
+ Qcursor = intern ("cursor");
+ staticpro (&Qcursor);
+ Qborder = intern ("border");
+ staticpro (&Qborder);
+ Qmouse = intern ("mouse");
+ staticpro (&Qmouse);
+ Qtty_color_desc = intern ("tty-color-desc");
+ staticpro (&Qtty_color_desc);
+ Qtty_color_by_index = intern ("tty-color-by-index");
+ staticpro (&Qtty_color_by_index);
+ Qtty_color_alist = intern ("tty-color-alist");
+ staticpro (&Qtty_color_alist);
+ Qscalable_fonts_allowed = intern ("scalable-fonts-allowed");
+ staticpro (&Qscalable_fonts_allowed);
+
+ Vparam_value_alist = Fcons (Fcons (Qnil, Qnil), Qnil);
+ staticpro (&Vparam_value_alist);
+ Vface_alternative_font_family_alist = Qnil;
+ staticpro (&Vface_alternative_font_family_alist);
+ Vface_alternative_font_registry_alist = Qnil;
+ staticpro (&Vface_alternative_font_registry_alist);
+
+ defsubr (&Sinternal_make_lisp_face);
+ defsubr (&Sinternal_lisp_face_p);
+ defsubr (&Sinternal_set_lisp_face_attribute);
+#ifdef HAVE_WINDOW_SYSTEM
+ defsubr (&Sinternal_set_lisp_face_attribute_from_resource);
+#endif
+ defsubr (&Scolor_gray_p);
+ defsubr (&Scolor_supported_p);
+ defsubr (&Sinternal_get_lisp_face_attribute);
+ defsubr (&Sinternal_lisp_face_attribute_values);
+ defsubr (&Sinternal_lisp_face_equal_p);
+ defsubr (&Sinternal_lisp_face_empty_p);
+ defsubr (&Sinternal_copy_lisp_face);
+ defsubr (&Sinternal_merge_in_global_face);
+ defsubr (&Sface_font);
+ defsubr (&Sframe_face_alist);
+ defsubr (&Sinternal_set_font_selection_order);
+ defsubr (&Sinternal_set_alternative_font_family_alist);
+ defsubr (&Sinternal_set_alternative_font_registry_alist);
+#if GLYPH_DEBUG
+ defsubr (&Sdump_face);
+ defsubr (&Sshow_face_resources);
+#endif /* GLYPH_DEBUG */
+ defsubr (&Sclear_face_cache);
+ defsubr (&Stty_suppress_bold_inverse_default_colors);
+
+#if defined DEBUG_X_COLORS && defined HAVE_X_WINDOWS
+ defsubr (&Sdump_colors);
+#endif
+
+ DEFVAR_LISP ("font-list-limit", &Vfont_list_limit,
+ "*Limit for font matching.\n\
+If an integer > 0, font matching functions won't load more than\n\
+that number of fonts when searching for a matching font.");
+ Vfont_list_limit = make_number (DEFAULT_FONT_LIST_LIMIT);
+
+ DEFVAR_LISP ("face-new-frame-defaults", &Vface_new_frame_defaults,
+ "List of global face definitions (for internal use only.)");
+ Vface_new_frame_defaults = Qnil;
+
+ DEFVAR_LISP ("face-default-stipple", &Vface_default_stipple,
+ "*Default stipple pattern used on monochrome displays.\n\
+This stipple pattern is used on monochrome displays\n\
+instead of shades of gray for a face background color.\n\
+See `set-face-stipple' for possible values for this variable.");
+ Vface_default_stipple = build_string ("gray3");
+
+ DEFVAR_LISP ("tty-defined-color-alist", &Vtty_defined_color_alist,
+ "An alist of defined terminal colors and their RGB values.");
+ Vtty_defined_color_alist = Qnil;
+
+ DEFVAR_LISP ("scalable-fonts-allowed", &Vscalable_fonts_allowed,
+ "Allowed scalable fonts.\n\
+A value of nil means don't allow any scalable fonts.\n\
+A value of t means allow any scalable font.\n\
+Otherwise, value must be a list of regular expressions. A font may be\n\
+scaled if its name matches a regular expression in the list.\n\
+Note that if value is nil, a scalable font might still be used, if no\n\
+other font of the appropriate family and registry is available.");
+ Vscalable_fonts_allowed = Qnil;
+
+ DEFVAR_LISP ("face-ignored-fonts", &Vface_ignored_fonts,
+ "List of ignored fonts.\n\
+Each element is a regular expression that matches names of fonts to ignore.");
+ Vface_ignored_fonts = Qnil;
+
+#ifdef HAVE_WINDOW_SYSTEM
+ defsubr (&Sbitmap_spec_p);
+ defsubr (&Sx_list_fonts);
+ defsubr (&Sinternal_face_x_get_resource);
+ defsubr (&Sx_family_fonts);
+ defsubr (&Sx_font_family_list);
+#endif /* HAVE_WINDOW_SYSTEM */
+}
--- /dev/null
+/* xfaces.c -- "Face" primitives.
+ Copyright (C) 1993, 1994, 1998, 1999, 2000, 2001
+ Free Software Foundation.
+
+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 2, 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; see the file COPYING. If not, write to
+the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
+Boston, MA 02111-1307, USA. */
+
+/* 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. Relative proportionate width, aka character set width or set
+ width (swidth), e.g. `semi-compressed'.
+
+ 3. Font height in 1/10pt.
+
+ 4. Font weight, e.g. `bold'.
+
+ 5. Font slant, e.g. `italic'.
+
+ 6. Foreground color.
+
+ 7. Background color.
+
+ 8. Whether or not characters should be underlined, and in what color.
+
+ 9. Whether or not characters should be displayed in inverse video.
+
+ 10. A background stipple, a bitmap.
+
+ 11. Whether or not characters should be overlined, and in what color.
+
+ 12. Whether or not characters should be strike-through, and in what
+ color.
+
+ 13. Whether or not a box should be drawn around characters, the box
+ type, and, for simple boxes, in what color.
+
+ 14. Font or fontset pattern, or nil. This is a special attribute.
+ When this attribute is specified, the face uses a font opened by
+ that pattern as is. In addition, all the other font-related
+ attributes (1st thru 5th) are generated from the opened font name.
+ On the other hand, if one of the other font-related attributes are
+ specified, this attribute is set to nil. In that case, the face
+ doesn't inherit this attribute from the `default' face, and uses a
+ font determined by the other attributes (those may be inherited
+ from the `default' face).
+
+ 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.
+
+ 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 face 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 <sys/types.h>
+#include <sys/stat.h>
+#include "lisp.h"
+#include "charset.h"
+#include "keyboard.h"
+#include "frame.h"
+
+#ifdef HAVE_WINDOW_SYSTEM
+#include "fontset.h"
+#endif /* HAVE_WINDOW_SYSTEM */
+
+#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 x_list_fonts w32_list_fonts
+#define GCGraphicsExposures 0
+/* For historic reasons, FONT_WIDTH refers to average width on W32,
+ not maximum as on X. Redefine here. */
+#undef FONT_WIDTH
+#define FONT_WIDTH FONT_MAX_WIDTH
+#endif /* WINDOWSNT */
+
+#ifdef macintosh
+#include "macterm.h"
+#define x_display_info mac_display_info
+#define check_x check_mac
+
+extern XGCValues *XCreateGC (void *, WindowPtr, unsigned long, XGCValues *);
+
+static INLINE GC
+x_create_gc (f, mask, xgcv)
+ struct frame *f;
+ unsigned long mask;
+ XGCValues *xgcv;
+{
+ GC gc;
+ gc = XCreateGC (FRAME_MAC_DISPLAY (f), FRAME_MAC_WINDOW (f), mask, xgcv);
+ return gc;
+}
+
+static INLINE void
+x_free_gc (f, gc)
+ struct frame *f;
+ GC gc;
+{
+ XFreeGC (FRAME_MAC_DISPLAY (f), gc);
+}
+#endif
+
+#include "buffer.h"
+#include "dispextern.h"
+#include "blockinput.h"
+#include "window.h"
+#include "intervals.h"
+
+#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 <stdio.h>
+#include <ctype.h>
+
+#ifndef max
+#define max(A, B) ((A) > (B) ? (A) : (B))
+#define min(A, B) ((A) < (B) ? (A) : (B))
+#define abs(X) ((X) < 0 ? -(X) : (X))
+#endif
+
+/* 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)
+
+/* 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 (XSTRING ((S))->data)
+
+/* Size of hash table of realized faces in face caches (should be a
+ prime number). */
+
+#define FACE_CACHE_BUCKETS_SIZE 1001
+
+/* A definition of XColor for non-X frames. */
+
+#ifndef HAVE_X_WINDOWS
+
+typedef struct
+{
+ unsigned long pixel;
+ unsigned short red, green, blue;
+ char flags;
+ char pad;
+}
+XColor;
+
+#endif /* not HAVE_X_WINDOWS */
+
+/* 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;
+
+/* 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;
+
+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_update_face_colors. */
+
+Lisp_Object Qframe_update_face_colors;
+
+/* Names of basic faces. */
+
+Lisp_Object Qdefault, Qtool_bar, Qregion, Qfringe;
+Lisp_Object Qheader_line, Qscroll_bar, Qcursor, Qborder, Qmouse, Qmenu;
+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;
+
+/* Names of frame parameters related to faces. */
+
+extern Lisp_Object Qscroll_bar_foreground, Qscroll_bar_background;
+extern Lisp_Object Qborder_color, Qcursor_color, Qmouse_color;
+
+/* 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;
+
+/* 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;
+
+/* 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;
+
+/* 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;
+
+/* 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;
+
+\f
+/* Function prototypes. */
+
+struct font_name;
+struct table_entry;
+
+static void map_tty_color P_ ((struct frame *, struct face *,
+ enum lface_attribute_index, int *));
+static Lisp_Object resolve_face_name P_ ((Lisp_Object));
+static int may_use_scalable_font_p P_ ((char *));
+static void set_font_frame_param P_ ((Lisp_Object, Lisp_Object));
+static int better_font_p P_ ((int *, struct font_name *, struct font_name *,
+ int, int));
+static int x_face_list_fonts P_ ((struct frame *, char *,
+ struct font_name *, int, int));
+static int font_scalable_p P_ ((struct font_name *));
+static int get_lface_attributes P_ ((struct frame *, Lisp_Object, Lisp_Object *, int));
+static int load_pixmap P_ ((struct frame *, Lisp_Object, unsigned *, unsigned *));
+static unsigned char *xstrlwr P_ ((unsigned char *));
+static void signal_error P_ ((char *, Lisp_Object));
+static struct frame *frame_or_selected_frame P_ ((Lisp_Object, int));
+static void load_face_font P_ ((struct frame *, struct face *, 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 char *build_font_name P_ ((struct font_name *));
+static void free_font_names P_ ((struct font_name *, int));
+static int sorted_font_list P_ ((struct frame *, char *,
+ int (*cmpfn) P_ ((const void *, const void *)),
+ struct font_name **));
+static int font_list_1 P_ ((struct frame *, Lisp_Object, Lisp_Object,
+ Lisp_Object, struct font_name **));
+static int font_list P_ ((struct frame *, Lisp_Object, Lisp_Object,
+ Lisp_Object, struct font_name **));
+static int try_font_list P_ ((struct frame *, Lisp_Object *,
+ Lisp_Object, Lisp_Object, struct font_name **));
+static int try_alternative_families P_ ((struct frame *f, Lisp_Object,
+ Lisp_Object, struct font_name **));
+static int cmp_font_names P_ ((const void *, const void *));
+static struct face *realize_face P_ ((struct face_cache *, Lisp_Object *, int,
+ struct face *, int));
+static struct face *realize_x_face P_ ((struct face_cache *,
+ Lisp_Object *, int, struct face *));
+static struct face *realize_tty_face P_ ((struct face_cache *,
+ Lisp_Object *, int));
+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 free_realized_face P_ ((struct frame *, struct face *));
+static void clear_face_gcs P_ ((struct face_cache *));
+static void free_face_cache P_ ((struct face_cache *));
+static int face_numeric_weight P_ ((Lisp_Object));
+static int face_numeric_slant P_ ((Lisp_Object));
+static int face_numeric_swidth P_ ((Lisp_Object));
+static int face_fontset P_ ((Lisp_Object *));
+static char *choose_face_font P_ ((struct frame *, Lisp_Object *, int, int));
+static void merge_face_vectors P_ ((struct frame *, Lisp_Object *, Lisp_Object*, Lisp_Object));
+static void merge_face_inheritance P_ ((struct frame *f, Lisp_Object,
+ Lisp_Object *, Lisp_Object));
+static void merge_face_vector_with_property P_ ((struct frame *, Lisp_Object *,
+ Lisp_Object));
+static int set_lface_from_font_name P_ ((struct frame *, Lisp_Object,
+ Lisp_Object, int, 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 free_realized_faces P_ ((struct face_cache *));
+static char *best_matching_font P_ ((struct frame *, Lisp_Object *,
+ struct font_name *, int, int));
+static void cache_face P_ ((struct face_cache *, struct face *, unsigned));
+static void uncache_face P_ ((struct face_cache *, struct face *));
+static int xlfd_numeric_slant P_ ((struct font_name *));
+static int xlfd_numeric_weight P_ ((struct font_name *));
+static int xlfd_numeric_swidth P_ ((struct font_name *));
+static Lisp_Object xlfd_symbolic_slant P_ ((struct font_name *));
+static Lisp_Object xlfd_symbolic_weight P_ ((struct font_name *));
+static Lisp_Object xlfd_symbolic_swidth P_ ((struct font_name *));
+static int xlfd_fixed_p P_ ((struct font_name *));
+static int xlfd_numeric_value P_ ((struct table_entry *, int, struct font_name *,
+ int, int));
+static Lisp_Object xlfd_symbolic_value P_ ((struct table_entry *, int,
+ struct font_name *, int,
+ Lisp_Object));
+static struct table_entry *xlfd_lookup_field_contents P_ ((struct table_entry *, int,
+ struct font_name *, int));
+
+#ifdef HAVE_WINDOW_SYSTEM
+
+static int split_font_name P_ ((struct frame *, struct font_name *, int));
+static int xlfd_point_size P_ ((struct frame *, struct font_name *));
+static void sort_fonts P_ ((struct frame *, struct font_name *, int,
+ int (*cmpfn) P_ ((const void *, const void *))));
+static GC x_create_gc P_ ((struct frame *, unsigned long, XGCValues *));
+static void x_free_gc P_ ((struct frame *, GC));
+static void clear_font_table P_ ((struct x_display_info *));
+
+#ifdef WINDOWSNT
+extern Lisp_Object w32_list_fonts P_ ((struct frame *, Lisp_Object, int, int));
+#endif /* WINDOWSNT */
+
+#ifdef USE_X_TOOLKIT
+static void x_update_menu_appearance P_ ((struct frame *));
+#endif /* USE_X_TOOLKIT */
+
+#endif /* HAVE_WINDOW_SYSTEM */
+
+\f
+/***********************************************************************
+ 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,
+ "Dump currently allocated colors and their reference counts 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;
+{
+ BLOCK_INPUT;
+ xassert (--ngcs >= 0);
+ XFreeGC (FRAME_X_DISPLAY (f), gc);
+ UNBLOCK_INPUT;
+}
+
+#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;
+{
+ BLOCK_INPUT;
+ xassert (--ngcs >= 0);
+ xfree (gc);
+ UNBLOCK_INPUT;
+}
+
+#endif /* WINDOWSNT */
+
+/* Like stricmp. Used to compare parts of font names which are in
+ ISO8859-1. */
+
+int
+xstricmp (s1, s2)
+ 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;
+}
+
+
+/* Like strlwr, which might not always be available. */
+
+static unsigned char *
+xstrlwr (s)
+ unsigned char *s;
+{
+ unsigned char *p = s;
+
+ for (p = s; *p; ++p)
+ *p = tolower (*p);
+
+ return s;
+}
+
+
+/* Signal `error' with message S, and additional argument ARG. */
+
+static void
+signal_error (s, arg)
+ char *s;
+ Lisp_Object arg;
+{
+ Fsignal (Qerror, Fcons (build_string (s), Fcons (arg, Qnil)));
+}
+
+
+/* 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, nparam);
+ return XFRAME (frame);
+}
+
+\f
+/***********************************************************************
+ 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))
+ {
+ if (FRAME_X_IMAGE_CACHE (f) == NULL)
+ FRAME_X_IMAGE_CACHE (f) = make_image_cache ();
+ ++FRAME_X_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
+ if (!realize_basic_faces (f))
+ abort ();
+}
+
+
+/* Free face cache of frame F. Called from Fdelete_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_X_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)
+ {
+ struct x_display_info *dpyinfo;
+
+ /* Fonts are common for frames on one display, i.e. on
+ one X screen. */
+ for (dpyinfo = x_display_list; dpyinfo; dpyinfo = dpyinfo->next)
+ if (dpyinfo->n_fonts > CLEAR_FONT_TABLE_NFONTS)
+ clear_font_table (dpyinfo);
+
+ /* 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_cache (f, 0);
+ }
+ }
+ }
+#endif /* HAVE_WINDOW_SYSTEM */
+}
+
+
+DEFUN ("clear-face-cache", Fclear_face_cache, Sclear_face_cache, 0, 1, 0,
+ "Clear face caches on all frames.\n\
+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;
+}
+
+
+
+#ifdef HAVE_WINDOW_SYSTEM
+
+
+/* Remove fonts from the font table of DPYINFO except for the default
+ ASCII fonts of frames on that display. Called from clear_face_cache
+ from time to time. */
+
+static void
+clear_font_table (dpyinfo)
+ struct x_display_info *dpyinfo;
+{
+ int i;
+
+ /* Free those fonts that are not used by frames on DPYINFO. */
+ for (i = 0; i < dpyinfo->n_fonts; ++i)
+ {
+ struct font_info *font_info = dpyinfo->font_table + i;
+ Lisp_Object tail, frame;
+
+ /* Check if slot is already free. */
+ if (font_info->name == NULL)
+ continue;
+
+ /* Don't free a default font of some frame on this display. */
+ FOR_EACH_FRAME (tail, frame)
+ {
+ struct frame *f = XFRAME (frame);
+ if (FRAME_WINDOW_P (f)
+ && FRAME_X_DISPLAY_INFO (f) == dpyinfo
+ && font_info->font == FRAME_FONT (f))
+ break;
+ }
+
+ if (!NILP (tail))
+ continue;
+
+ /* Free names. */
+ if (font_info->full_name != font_info->name)
+ xfree (font_info->full_name);
+ xfree (font_info->name);
+
+ /* Free the font. */
+ BLOCK_INPUT;
+#ifdef HAVE_X_WINDOWS
+ XFreeFont (dpyinfo->display, font_info->font);
+#endif
+#ifdef WINDOWSNT
+ w32_unload_font (dpyinfo, font_info->font);
+#endif
+ UNBLOCK_INPUT;
+
+ /* Mark font table slot free. */
+ font_info->font = NULL;
+ font_info->name = font_info->full_name = NULL;
+ }
+}
+
+#endif /* HAVE_WINDOW_SYSTEM */
+
+
+\f
+/***********************************************************************
+ X Pixmaps
+ ***********************************************************************/
+
+#ifdef HAVE_WINDOW_SYSTEM
+
+DEFUN ("bitmap-spec-p", Fbitmap_spec_p, Sbitmap_spec_p, 1, 1, 0,
+ "Value is non-nil if OBJECT is a valid bitmap specification.\n\
+A bitmap specification is either a string, a file name, or a list\n\
+(WIDTH HEIGHT DATA) where WIDTH is the pixel width of the bitmap,\n\
+HEIGHT is its height, and DATA is a string containing the bits of\n\
+the pixmap. Bits are stored row by row, each row occupies\n\
+(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 (STRING_BYTES (XSTRING (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;
+ Lisp_Object tem;
+
+ if (NILP (name))
+ return 0;
+
+ tem = Fbitmap_spec_p (name);
+ if (NILP (tem))
+ wrong_type_argument (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, XSTRING (bits)->data,
+ 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 */
+
+
+\f
+/***********************************************************************
+ Minimum font bounds
+ ***********************************************************************/
+
+#ifdef HAVE_WINDOW_SYSTEM
+
+/* Update the line_height of frame F. Return non-zero if line height
+ changes. */
+
+int
+frame_update_line_height (f)
+ struct frame *f;
+{
+ int line_height, changed_p;
+
+ line_height = FONT_HEIGHT (FRAME_FONT (f));
+ changed_p = line_height != FRAME_LINE_HEIGHT (f);
+ FRAME_LINE_HEIGHT (f) = line_height;
+ return changed_p;
+}
+
+#endif /* HAVE_WINDOW_SYSTEM */
+
+\f
+/***********************************************************************
+ Fonts
+ ***********************************************************************/
+
+#ifdef HAVE_WINDOW_SYSTEM
+
+/* Load font of face FACE which is used on frame F to display
+ character C. The name of the font to load is determined by lface
+ and fontset of FACE. */
+
+static void
+load_face_font (f, face, c)
+ struct frame *f;
+ struct face *face;
+ int c;
+{
+ struct font_info *font_info = NULL;
+ char *font_name;
+
+ face->font_info_id = -1;
+ face->font = NULL;
+
+ font_name = choose_face_font (f, face->lface, face->fontset, c);
+ if (!font_name)
+ return;
+
+ BLOCK_INPUT;
+ font_info = FS_LOAD_FACE_FONT (f, c, font_name, face);
+ UNBLOCK_INPUT;
+
+ if (font_info)
+ {
+ face->font_info_id = font_info->font_idx;
+ face->font = font_info->font;
+ face->font_name = font_info->full_name;
+ if (face->gc)
+ {
+ x_free_gc (f, face->gc);
+ face->gc = 0;
+ }
+ }
+ else
+ add_to_log ("Unable to load font %s",
+ build_string (font_name), Qnil);
+ xfree (font_name);
+}
+
+#endif /* HAVE_WINDOW_SYSTEM */
+
+
+\f
+/***********************************************************************
+ X Colors
+ ***********************************************************************/
+
+/* 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;
+{
+ Lisp_Object color_desc;
+ unsigned long color_idx = FACE_TTY_DEFAULT_COLOR;
+ unsigned long red = 0, green = 0, blue = 0;
+ int status = 1;
+
+ if (*color_name && !NILP (Ffboundp (Qtty_color_desc)))
+ {
+ Lisp_Object frame;
+
+ XSETFRAME (frame, f);
+ status = 0;
+ color_desc = call2 (Qtty_color_desc, build_string (color_name), frame);
+ if (CONSP (color_desc) && CONSP (XCDR (color_desc)))
+ {
+ color_idx = XINT (XCAR (XCDR (color_desc)));
+ if (CONSP (XCDR (XCDR (color_desc))))
+ {
+ red = XINT (XCAR (XCDR (XCDR (color_desc))));
+ green = XINT (XCAR (XCDR (XCDR (XCDR (color_desc)))));
+ blue = XINT (XCAR (XCDR (XCDR (XCDR (XCDR (color_desc))))));
+ }
+ status = 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. */
+ status = 1;
+ }
+ if (color_idx == FACE_TTY_DEFAULT_COLOR && *color_name)
+ {
+ if (strcmp (color_name, "unspecified-fg") == 0)
+ color_idx = FACE_TTY_DEFAULT_FG_COLOR;
+ else if (strcmp (color_name, "unspecified-bg") == 0)
+ color_idx = FACE_TTY_DEFAULT_BG_COLOR;
+ }
+
+ if (color_idx != FACE_TTY_DEFAULT_COLOR)
+ status = 1;
+
+ color_def->pixel = color_idx;
+ color_def->red = red;
+ color_def->green = green;
+ color_def->blue = blue;
+
+ 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 macintosh
+ else if (FRAME_MAC_P (f))
+ return mac_defined_color (f, color_name, color_def, alloc);
+#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);
+
+#ifdef WINDOWSNT
+ return vga_stdcolor_name (idx);
+#endif
+
+ return Qunspecified;
+}
+
+
+/* Return non-zero if COLOR_NAME is a shade of gray (or white or
+ black) on frame F. The algorithm is taken from 20.2 faces.el. */
+
+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 = ((abs (color.red - color.green)
+ < max (color.red, color.green) / 20)
+ && (abs (color.green - color.blue)
+ < max (color.green, color.blue) / 20)
+ && (abs (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 (FRAME_WINDOW_P (f)
+ ? (!NILP (Fxw_display_color_p (frame))
+ || xstricmp (color_name, "black") == 0
+ || xstricmp (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)))
+ : tty_defined_color (f, color_name, ¬_used, 0));
+}
+
+
+DEFUN ("color-gray-p", Fcolor_gray_p, Scolor_gray_p, 1, 2, 0,
+ "Return non-nil if COLOR is a shade of gray (or white or black).\n\
+FRAME specifies the frame and thus the display for interpreting COLOR.\n\
+If FRAME is nil or omitted, use the selected frame.")
+ (color, frame)
+ Lisp_Object color, frame;
+{
+ struct frame *f;
+
+ CHECK_FRAME (frame, 0);
+ CHECK_STRING (color, 0);
+ f = XFRAME (frame);
+ return face_color_gray_p (f, XSTRING (color)->data) ? Qt : Qnil;
+}
+
+
+DEFUN ("color-supported-p", Fcolor_supported_p,
+ Scolor_supported_p, 2, 3, 0,
+ "Return non-nil if COLOR can be displayed on FRAME.\n\
+BACKGROUND-P non-nil means COLOR is used as a background.\n\
+If FRAME is nil or omitted, use the selected frame.\n\
+COLOR must be a valid color name.")
+ (color, frame, background_p)
+ Lisp_Object frame, color, background_p;
+{
+ struct frame *f;
+
+ CHECK_FRAME (frame, 0);
+ CHECK_STRING (color, 0);
+ f = XFRAME (frame);
+ if (face_color_supported_p (f, XSTRING (color)->data, !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, XSTRING (name)->data, &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, XSTRING (bg)->data, 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;
+{
+#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 */
+
+
+\f
+/***********************************************************************
+ 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... */
+};
+
+/* Structure used for tables mapping XLFD weight, slant, and width
+ names to numeric and symbolic values. */
+
+struct table_entry
+{
+ char *name;
+ int numeric;
+ Lisp_Object *symbol;
+};
+
+/* Table of XLFD slant names and their numeric and symbolic
+ representations. This table must be sorted by slant names in
+ ascending order. */
+
+static struct table_entry slant_table[] =
+{
+ {"i", XLFD_SLANT_ITALIC, &Qitalic},
+ {"o", XLFD_SLANT_OBLIQUE, &Qoblique},
+ {"ot", XLFD_SLANT_OTHER, &Qitalic},
+ {"r", XLFD_SLANT_ROMAN, &Qnormal},
+ {"ri", XLFD_SLANT_REVERSE_ITALIC, &Qreverse_italic},
+ {"ro", XLFD_SLANT_REVERSE_OBLIQUE, &Qreverse_oblique}
+};
+
+/* Table of XLFD weight names. This table must be sorted by weight
+ names in ascending order. */
+
+static struct table_entry weight_table[] =
+{
+ {"black", XLFD_WEIGHT_ULTRA_BOLD, &Qultra_bold},
+ {"bold", XLFD_WEIGHT_BOLD, &Qbold},
+ {"book", XLFD_WEIGHT_SEMI_LIGHT, &Qsemi_light},
+ {"demi", XLFD_WEIGHT_SEMI_BOLD, &Qsemi_bold},
+ {"demibold", XLFD_WEIGHT_SEMI_BOLD, &Qsemi_bold},
+ {"extralight", XLFD_WEIGHT_EXTRA_LIGHT, &Qextra_light},
+ {"extrabold", XLFD_WEIGHT_EXTRA_BOLD, &Qextra_bold},
+ {"heavy", XLFD_WEIGHT_EXTRA_BOLD, &Qextra_bold},
+ {"light", XLFD_WEIGHT_LIGHT, &Qlight},
+ {"medium", XLFD_WEIGHT_MEDIUM, &Qnormal},
+ {"normal", XLFD_WEIGHT_MEDIUM, &Qnormal},
+ {"regular", XLFD_WEIGHT_MEDIUM, &Qnormal},
+ {"semibold", XLFD_WEIGHT_SEMI_BOLD, &Qsemi_bold},
+ {"semilight", XLFD_WEIGHT_SEMI_LIGHT, &Qsemi_light},
+ {"ultralight", XLFD_WEIGHT_ULTRA_LIGHT, &Qultra_light},
+ {"ultrabold", XLFD_WEIGHT_ULTRA_BOLD, &Qultra_bold}
+};
+
+/* Table of XLFD width names. This table must be sorted by width
+ names in ascending order. */
+
+static struct table_entry swidth_table[] =
+{
+ {"compressed", XLFD_SWIDTH_CONDENSED, &Qcondensed},
+ {"condensed", XLFD_SWIDTH_CONDENSED, &Qcondensed},
+ {"demiexpanded", XLFD_SWIDTH_SEMI_EXPANDED, &Qsemi_expanded},
+ {"expanded", XLFD_SWIDTH_EXPANDED, &Qexpanded},
+ {"extracondensed", XLFD_SWIDTH_EXTRA_CONDENSED, &Qextra_condensed},
+ {"extraexpanded", XLFD_SWIDTH_EXTRA_EXPANDED, &Qextra_expanded},
+ {"medium", XLFD_SWIDTH_MEDIUM, &Qnormal},
+ {"narrow", XLFD_SWIDTH_CONDENSED, &Qcondensed},
+ {"normal", XLFD_SWIDTH_MEDIUM, &Qnormal},
+ {"regular", XLFD_SWIDTH_MEDIUM, &Qnormal},
+ {"semicondensed", XLFD_SWIDTH_SEMI_CONDENSED, &Qsemi_condensed},
+ {"semiexpanded", XLFD_SWIDTH_SEMI_EXPANDED, &Qsemi_expanded},
+ {"ultracondensed", XLFD_SWIDTH_ULTRA_CONDENSED, &Qultra_condensed},
+ {"ultraexpanded", XLFD_SWIDTH_ULTRA_EXPANDED, &Qultra_expanded},
+ {"wide", XLFD_SWIDTH_EXTRA_EXPANDED, &Qextra_expanded}
+};
+
+/* Structure used to hold the result of splitting font names in XLFD
+ format into their fields. */
+
+struct font_name
+{
+ /* The original name which is modified destructively by
+ split_font_name. The pointer is kept here to be able to free it
+ if it was allocated from the heap. */
+ char *name;
+
+ /* Font name fields. Each vector element points into `name' above.
+ Fields are NUL-terminated. */
+ char *fields[XLFD_LAST];
+
+ /* Numeric values for those fields that interest us. See
+ split_font_name for which these are. */
+ int numeric[XLFD_LAST];
+
+ /* Lower value mean higher priority. */
+ int registry_priority;
+};
+
+/* The frame in effect when sorting font names. Set temporarily in
+ sort_fonts so that it is available in font comparison functions. */
+
+static struct frame *font_frame;
+
+/* 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. */
+
+#ifdef macintosh
+static int font_sort_order[4] = {
+ XLFD_SWIDTH, XLFD_POINT_SIZE, XLFD_WEIGHT, XLFD_SLANT
+};
+#else
+static int font_sort_order[4];
+#endif
+
+/* Look up FONT.fields[FIELD_INDEX] in TABLE which has DIM entries.
+ TABLE must be sorted by TABLE[i]->name in ascending order. Value
+ is a pointer to the matching table entry or null if no table entry
+ matches. */
+
+static struct table_entry *
+xlfd_lookup_field_contents (table, dim, font, field_index)
+ struct table_entry *table;
+ int dim;
+ struct font_name *font;
+ int field_index;
+{
+ /* Function split_font_name converts fields to lower-case, so there
+ is no need to use xstrlwr or xstricmp here. */
+ char *s = font->fields[field_index];
+ int low, mid, high, cmp;
+
+ low = 0;
+ high = dim - 1;
+
+ while (low <= high)
+ {
+ mid = (low + high) / 2;
+ cmp = strcmp (table[mid].name, s);
+
+ if (cmp < 0)
+ low = mid + 1;
+ else if (cmp > 0)
+ high = mid - 1;
+ else
+ return table + mid;
+ }
+
+ return NULL;
+}
+
+
+/* Return a numeric representation for font name field
+ FONT.fields[FIELD_INDEX]. The field is looked up in TABLE which
+ has DIM entries. Value is the numeric value found or DFLT if no
+ table entry matches. This function is used to translate weight,
+ slant, and swidth names of XLFD font names to numeric values. */
+
+static INLINE int
+xlfd_numeric_value (table, dim, font, field_index, dflt)
+ struct table_entry *table;
+ int dim;
+ struct font_name *font;
+ int field_index;
+ int dflt;
+{
+ struct table_entry *p;
+ p = xlfd_lookup_field_contents (table, dim, font, field_index);
+ return p ? p->numeric : dflt;
+}
+
+
+/* Return a symbolic representation for font name field
+ FONT.fields[FIELD_INDEX]. The field is looked up in TABLE which
+ has DIM entries. Value is the symbolic value found or DFLT if no
+ table entry matches. This function is used to translate weight,
+ slant, and swidth names of XLFD font names to symbols. */
+
+static INLINE Lisp_Object
+xlfd_symbolic_value (table, dim, font, field_index, dflt)
+ struct table_entry *table;
+ int dim;
+ struct font_name *font;
+ int field_index;
+ Lisp_Object dflt;
+{
+ struct table_entry *p;
+ p = xlfd_lookup_field_contents (table, dim, font, field_index);
+ return p ? *p->symbol : dflt;
+}
+
+
+/* Return a numeric value for the slant of the font given by FONT. */
+
+static INLINE int
+xlfd_numeric_slant (font)
+ struct font_name *font;
+{
+ return xlfd_numeric_value (slant_table, DIM (slant_table),
+ font, XLFD_SLANT, XLFD_SLANT_ROMAN);
+}
+
+
+/* Return a symbol representing the weight of the font given by FONT. */
+
+static INLINE Lisp_Object
+xlfd_symbolic_slant (font)
+ struct font_name *font;
+{
+ return xlfd_symbolic_value (slant_table, DIM (slant_table),
+ font, XLFD_SLANT, Qnormal);
+}
+
+
+/* Return a numeric value for the weight of the font given by FONT. */
+
+static INLINE int
+xlfd_numeric_weight (font)
+ struct font_name *font;
+{
+ return xlfd_numeric_value (weight_table, DIM (weight_table),
+ font, XLFD_WEIGHT, XLFD_WEIGHT_MEDIUM);
+}
+
+
+/* Return a symbol representing the slant of the font given by FONT. */
+
+static INLINE Lisp_Object
+xlfd_symbolic_weight (font)
+ struct font_name *font;
+{
+ return xlfd_symbolic_value (weight_table, DIM (weight_table),
+ font, XLFD_WEIGHT, Qnormal);
+}
+
+
+/* Return a numeric value for the swidth of the font whose XLFD font
+ name fields are found in FONT. */
+
+static INLINE int
+xlfd_numeric_swidth (font)
+ struct font_name *font;
+{
+ return xlfd_numeric_value (swidth_table, DIM (swidth_table),
+ font, XLFD_SWIDTH, XLFD_SWIDTH_MEDIUM);
+}
+
+
+/* Return a symbolic value for the swidth of FONT. */
+
+static INLINE Lisp_Object
+xlfd_symbolic_swidth (font)
+ struct font_name *font;
+{
+ return xlfd_symbolic_value (swidth_table, DIM (swidth_table),
+ font, XLFD_SWIDTH, Qnormal);
+}
+
+
+/* Look up the entry of SYMBOL in the vector TABLE which has DIM
+ entries. Value is a pointer to the matching table entry or null if
+ no element of TABLE contains SYMBOL. */
+
+static struct table_entry *
+face_value (table, dim, symbol)
+ struct table_entry *table;
+ int dim;
+ Lisp_Object symbol;
+{
+ int i;
+
+ xassert (SYMBOLP (symbol));
+
+ for (i = 0; i < dim; ++i)
+ if (EQ (*table[i].symbol, symbol))
+ break;
+
+ return i < dim ? table + i : NULL;
+}
+
+
+/* Return a numeric value for SYMBOL in the vector TABLE which has DIM
+ entries. Value is -1 if SYMBOL is not found in TABLE. */
+
+static INLINE int
+face_numeric_value (table, dim, symbol)
+ struct table_entry *table;
+ int dim;
+ Lisp_Object symbol;
+{
+ struct table_entry *p = face_value (table, dim, symbol);
+ return p ? p->numeric : -1;
+}
+
+
+/* Return a numeric value representing the weight specified by Lisp
+ symbol WEIGHT. Value is one of the enumerators of enum
+ xlfd_weight. */
+
+static INLINE int
+face_numeric_weight (weight)
+ Lisp_Object weight;
+{
+ return face_numeric_value (weight_table, DIM (weight_table), weight);
+}
+
+
+/* Return a numeric value representing the slant specified by Lisp
+ symbol SLANT. Value is one of the enumerators of enum xlfd_slant. */
+
+static INLINE int
+face_numeric_slant (slant)
+ Lisp_Object slant;
+{
+ return face_numeric_value (slant_table, DIM (slant_table), slant);
+}
+
+
+/* Return a numeric value representing the swidth specified by Lisp
+ symbol WIDTH. Value is one of the enumerators of enum xlfd_swidth. */
+
+static int
+face_numeric_swidth (width)
+ Lisp_Object width;
+{
+ return face_numeric_value (swidth_table, DIM (swidth_table), width);
+}
+
+
+#ifdef HAVE_WINDOW_SYSTEM
+
+/* Return non-zero if FONT is the name of a fixed-pitch font. */
+
+static INLINE int
+xlfd_fixed_p (font)
+ struct font_name *font;
+{
+ /* Function split_font_name converts fields to lower-case, so there
+ is no need to use tolower here. */
+ return *font->fields[XLFD_SPACING] != 'p';
+}
+
+
+/* Return the point size of FONT on frame F, measured in 1/10 pt.
+
+ The actual height of the font when displayed on F depends on the
+ resolution of both the font and frame. For example, a 10pt font
+ designed for a 100dpi display will display larger than 10pt on a
+ 75dpi display. (It's not unusual to use fonts not designed for the
+ display one is using. For example, some intlfonts are available in
+ 72dpi versions, only.)
+
+ Value is the real point size of FONT on frame F, or 0 if it cannot
+ be determined. */
+
+static INLINE int
+xlfd_point_size (f, font)
+ struct frame *f;
+ struct font_name *font;
+{
+ double resy = FRAME_X_DISPLAY_INFO (f)->resy;
+ char *pixel_field = font->fields[XLFD_PIXEL_SIZE];
+ double pixel;
+ int real_pt;
+
+ if (*pixel_field == '[')
+ {
+ /* The pixel size field is `[A B C D]' which specifies
+ a transformation matrix.
+
+ A B 0
+ C D 0
+ 0 0 1
+
+ by which all glyphs of the font are transformed. The spec
+ says that s scalar value N for the pixel size is equivalent
+ to A = N * resx/resy, B = C = 0, D = N. */
+ char *start = pixel_field + 1, *end;
+ double matrix[4];
+ int i;
+
+ for (i = 0; i < 4; ++i)
+ {
+ matrix[i] = strtod (start, &end);
+ start = end;
+ }
+
+ pixel = matrix[3];
+ }
+ else
+ pixel = atoi (pixel_field);
+
+ if (pixel == 0)
+ real_pt = 0;
+ else
+ real_pt = PT_PER_INCH * 10.0 * pixel / resy + 0.5;
+
+ return real_pt;
+}
+
+
+/* Return point size of PIXEL dots while considering Y-resultion (DPI)
+ of frame F. This function is used to guess a point size of font
+ when only the pixel height of the font is available. */
+
+static INLINE int
+pixel_point_size (f, pixel)
+ struct frame *f;
+ int pixel;
+{
+ double resy = FRAME_X_DISPLAY_INFO (f)->resy;
+ double real_pt;
+ int int_pt;
+
+ /* As one inch is PT_PER_INCH points, PT_PER_INCH/RESY gives the
+ point size of one dot. */
+ real_pt = pixel * PT_PER_INCH / resy;
+ int_pt = real_pt + 0.5;
+
+ return int_pt;
+}
+
+
+/* Split XLFD font name FONT->name destructively into NUL-terminated,
+ lower-case fields in FONT->fields. NUMERIC_P non-zero means
+ compute numeric values for fields XLFD_POINT_SIZE, XLFD_SWIDTH,
+ XLFD_RESY, XLFD_SLANT, and XLFD_WEIGHT in FONT->numeric. Value is
+ zero if the font name doesn't have the format we expect. The
+ expected format is a font name that starts with a `-' and has
+ XLFD_LAST fields separated by `-'. */
+
+static int
+split_font_name (f, font, numeric_p)
+ struct frame *f;
+ struct font_name *font;
+ int numeric_p;
+{
+ int i = 0;
+ int success_p;
+
+ if (*font->name == '-')
+ {
+ char *p = xstrlwr (font->name) + 1;
+
+ while (i < XLFD_LAST)
+ {
+ font->fields[i] = p;
+ ++i;
+
+ /* Pixel and point size may be of the form `[....]'. For
+ BNF, see XLFD spec, chapter 4. Negative values are
+ indicated by tilde characters which we replace with
+ `-' characters, here. */
+ if (*p == '['
+ && (i - 1 == XLFD_PIXEL_SIZE
+ || i - 1 == XLFD_POINT_SIZE))
+ {
+ char *start, *end;
+ int j;
+
+ for (++p; *p && *p != ']'; ++p)
+ if (*p == '~')
+ *p = '-';
+
+ /* Check that the matrix contains 4 floating point
+ numbers. */
+ for (j = 0, start = font->fields[i - 1] + 1;
+ j < 4;
+ ++j, start = end)
+ if (strtod (start, &end) == 0 && start == end)
+ break;
+
+ if (j < 4)
+ break;
+ }
+
+ while (*p && *p != '-')
+ ++p;
+
+ if (*p != '-')
+ break;
+
+ *p++ = 0;
+ }
+ }
+
+ success_p = i == XLFD_LAST;
+
+ /* If requested, and font name was in the expected format,
+ compute numeric values for some fields. */
+ if (numeric_p && success_p)
+ {
+ font->numeric[XLFD_POINT_SIZE] = xlfd_point_size (f, font);
+ font->numeric[XLFD_RESY] = atoi (font->fields[XLFD_RESY]);
+ font->numeric[XLFD_SLANT] = xlfd_numeric_slant (font);
+ font->numeric[XLFD_WEIGHT] = xlfd_numeric_weight (font);
+ font->numeric[XLFD_SWIDTH] = xlfd_numeric_swidth (font);
+ font->numeric[XLFD_AVGWIDTH] = atoi (font->fields[XLFD_AVGWIDTH]);
+ }
+
+ /* Initialize it to zero. It will be overridden by font_list while
+ trying alternate registries. */
+ font->registry_priority = 0;
+
+ return success_p;
+}
+
+
+/* Build an XLFD font name from font name fields in FONT. Value is a
+ pointer to the font name, which is allocated via xmalloc. */
+
+static char *
+build_font_name (font)
+ struct font_name *font;
+{
+ int i;
+ int size = 100;
+ char *font_name = (char *) xmalloc (size);
+ int total_length = 0;
+
+ for (i = 0; i < XLFD_LAST; ++i)
+ {
+ /* Add 1 because of the leading `-'. */
+ int len = strlen (font->fields[i]) + 1;
+
+ /* Reallocate font_name if necessary. Add 1 for the final
+ NUL-byte. */
+ if (total_length + len + 1 >= size)
+ {
+ int new_size = max (2 * size, size + len + 1);
+ int sz = new_size * sizeof *font_name;
+ font_name = (char *) xrealloc (font_name, sz);
+ size = new_size;
+ }
+
+ font_name[total_length] = '-';
+ bcopy (font->fields[i], font_name + total_length + 1, len - 1);
+ total_length += len;
+ }
+
+ font_name[total_length] = 0;
+ return font_name;
+}
+
+
+/* Free an array FONTS of N font_name structures. This frees FONTS
+ itself and all `name' fields in its elements. */
+
+static INLINE void
+free_font_names (fonts, n)
+ struct font_name *fonts;
+ int n;
+{
+ while (n)
+ xfree (fonts[--n].name);
+ xfree (fonts);
+}
+
+
+/* Sort vector FONTS of font_name structures which contains NFONTS
+ elements using qsort and comparison function CMPFN. F is the frame
+ on which the fonts will be used. The global variable font_frame
+ is temporarily set to F to make it available in CMPFN. */
+
+static INLINE void
+sort_fonts (f, fonts, nfonts, cmpfn)
+ struct frame *f;
+ struct font_name *fonts;
+ int nfonts;
+ int (*cmpfn) P_ ((const void *, const void *));
+{
+ font_frame = f;
+ qsort (fonts, nfonts, sizeof *fonts, cmpfn);
+ font_frame = NULL;
+}
+
+
+/* Get fonts matching PATTERN on frame F. If F is null, use the first
+ display in x_display_list. FONTS is a pointer to a vector of
+ NFONTS font_name structures. TRY_ALTERNATIVES_P non-zero means try
+ alternative patterns from Valternate_fontname_alist if no fonts are
+ found matching PATTERN.
+
+ For all fonts found, set FONTS[i].name to the name of the font,
+ allocated via xmalloc, and split font names into fields. Ignore
+ fonts that we can't parse. Value is the number of fonts found. */
+
+static int
+x_face_list_fonts (f, pattern, fonts, nfonts, try_alternatives_p)
+ struct frame *f;
+ char *pattern;
+ struct font_name *fonts;
+ int nfonts, try_alternatives_p;
+{
+ int n, nignored;
+
+ /* NTEMACS_TODO : currently this uses w32_list_fonts, but it may be
+ better to do it the other way around. */
+ Lisp_Object lfonts;
+ Lisp_Object lpattern, tem;
+
+ lpattern = build_string (pattern);
+
+ /* Get the list of fonts matching PATTERN. */
+#ifdef WINDOWSNT
+ BLOCK_INPUT;
+ lfonts = w32_list_fonts (f, lpattern, 0, nfonts);
+ UNBLOCK_INPUT;
+#else
+ lfonts = x_list_fonts (f, lpattern, -1, nfonts);
+#endif
+
+ /* Make a copy of the font names we got from X, and
+ split them into fields. */
+ n = nignored = 0;
+ for (tem = lfonts; CONSP (tem) && n < nfonts; tem = XCDR (tem))
+ {
+ Lisp_Object elt, tail;
+ char *name = XSTRING (XCAR (tem))->data;
+
+ /* Ignore fonts matching a pattern from face-ignored-fonts. */
+ for (tail = Vface_ignored_fonts; CONSP (tail); tail = XCDR (tail))
+ {
+ elt = XCAR (tail);
+ if (STRINGP (elt)
+ && fast_c_string_match_ignore_case (elt, name) >= 0)
+ break;
+ }
+ if (!NILP (tail))
+ {
+ ++nignored;
+ continue;
+ }
+
+ /* Make a copy of the font name. */
+ fonts[n].name = xstrdup (name);
+
+ if (split_font_name (f, fonts + n, 1))
+ {
+ if (font_scalable_p (fonts + n)
+ && !may_use_scalable_font_p (name))
+ {
+ ++nignored;
+ xfree (fonts[n].name);
+ }
+ else
+ ++n;
+ }
+ else
+ xfree (fonts[n].name);
+ }
+
+ /* If no fonts found, try patterns from Valternate_fontname_alist. */
+ if (n == 0 && try_alternatives_p)
+ {
+ Lisp_Object list = Valternate_fontname_alist;
+
+ while (CONSP (list))
+ {
+ Lisp_Object entry = XCAR (list);
+ if (CONSP (entry)
+ && STRINGP (XCAR (entry))
+ && strcmp (XSTRING (XCAR (entry))->data, pattern) == 0)
+ break;
+ list = XCDR (list);
+ }
+
+ if (CONSP (list))
+ {
+ Lisp_Object patterns = XCAR (list);
+ Lisp_Object name;
+
+ while (CONSP (patterns)
+ /* If list is screwed up, give up. */
+ && (name = XCAR (patterns),
+ STRINGP (name))
+ /* Ignore patterns equal to PATTERN because we tried that
+ already with no success. */
+ && (strcmp (XSTRING (name)->data, pattern) == 0
+ || (n = x_face_list_fonts (f, XSTRING (name)->data,
+ fonts, nfonts, 0),
+ n == 0)))
+ patterns = XCDR (patterns);
+ }
+ }
+
+ return n;
+}
+
+
+/* Determine fonts matching PATTERN on frame F. Sort resulting fonts
+ using comparison function CMPFN. Value is the number of fonts
+ found. If value is non-zero, *FONTS is set to a vector of
+ font_name structures allocated from the heap containing matching
+ fonts. Each element of *FONTS contains a name member that is also
+ allocated from the heap. Font names in these structures are split
+ into fields. Use free_font_names to free such an array. */
+
+static int
+sorted_font_list (f, pattern, cmpfn, fonts)
+ struct frame *f;
+ char *pattern;
+ int (*cmpfn) P_ ((const void *, const void *));
+ struct font_name **fonts;
+{
+ int nfonts;
+
+ /* Get the list of fonts matching pattern. 100 should suffice. */
+ nfonts = DEFAULT_FONT_LIST_LIMIT;
+ if (INTEGERP (Vfont_list_limit) && XINT (Vfont_list_limit) > 0)
+ nfonts = XFASTINT (Vfont_list_limit);
+
+ *fonts = (struct font_name *) xmalloc (nfonts * sizeof **fonts);
+ nfonts = x_face_list_fonts (f, pattern, *fonts, nfonts, 1);
+
+ /* Sort the resulting array and return it in *FONTS. If no
+ fonts were found, make sure to set *FONTS to null. */
+ if (nfonts)
+ sort_fonts (f, *fonts, nfonts, cmpfn);
+ else
+ {
+ xfree (*fonts);
+ *fonts = NULL;
+ }
+
+ return nfonts;
+}
+
+
+/* Compare two font_name structures *A and *B. Value is analogous to
+ strcmp. Sort order is given by the global variable
+ font_sort_order. Font names are sorted so that, everything else
+ being equal, fonts with a resolution closer to that of the frame on
+ which they are used are listed first. The global variable
+ font_frame is the frame on which we operate. */
+
+static int
+cmp_font_names (a, b)
+ const void *a, *b;
+{
+ struct font_name *x = (struct font_name *) a;
+ struct font_name *y = (struct font_name *) b;
+ int cmp;
+
+ /* All strings have been converted to lower-case by split_font_name,
+ so we can use strcmp here. */
+ cmp = strcmp (x->fields[XLFD_FAMILY], y->fields[XLFD_FAMILY]);
+ if (cmp == 0)
+ {
+ int i;
+
+ for (i = 0; i < DIM (font_sort_order) && cmp == 0; ++i)
+ {
+ int j = font_sort_order[i];
+ cmp = x->numeric[j] - y->numeric[j];
+ }
+
+ if (cmp == 0)
+ {
+ /* Everything else being equal, we prefer fonts with an
+ y-resolution closer to that of the frame. */
+ int resy = FRAME_X_DISPLAY_INFO (font_frame)->resy;
+ int x_resy = x->numeric[XLFD_RESY];
+ int y_resy = y->numeric[XLFD_RESY];
+ cmp = abs (resy - x_resy) - abs (resy - y_resy);
+ }
+ }
+
+ return cmp;
+}
+
+
+/* Get a sorted list of fonts of family FAMILY on frame F. If PATTERN
+ is non-nil list fonts matching that pattern. Otherwise, if
+ REGISTRY is non-nil return only fonts with that registry, otherwise
+ return fonts of any registry. Set *FONTS to a vector of font_name
+ structures allocated from the heap containing the fonts found.
+ Value is the number of fonts found. */
+
+static int
+font_list_1 (f, pattern, family, registry, fonts)
+ struct frame *f;
+ Lisp_Object pattern, family, registry;
+ struct font_name **fonts;
+{
+ char *pattern_str, *family_str, *registry_str;
+
+ if (NILP (pattern))
+ {
+ family_str = (NILP (family) ? "*" : (char *) XSTRING (family)->data);
+ registry_str = (NILP (registry) ? "*" : (char *) XSTRING (registry)->data);
+
+ pattern_str = (char *) alloca (strlen (family_str)
+ + strlen (registry_str)
+ + 10);
+ strcpy (pattern_str, index (family_str, '-') ? "-" : "-*-");
+ strcat (pattern_str, family_str);
+ strcat (pattern_str, "-*-");
+ strcat (pattern_str, registry_str);
+ if (!index (registry_str, '-'))
+ {
+ if (registry_str[strlen (registry_str) - 1] == '*')
+ strcat (pattern_str, "-*");
+ else
+ strcat (pattern_str, "*-*");
+ }
+ }
+ else
+ pattern_str = (char *) XSTRING (pattern)->data;
+
+ return sorted_font_list (f, pattern_str, cmp_font_names, fonts);
+}
+
+
+/* Concatenate font list FONTS1 and FONTS2. FONTS1 and FONTS2
+ contains NFONTS1 fonts and NFONTS2 fonts respectively. Return a
+ pointer to a newly allocated font list. FONTS1 and FONTS2 are
+ freed. */
+
+static struct font_name *
+concat_font_list (fonts1, nfonts1, fonts2, nfonts2)
+ struct font_name *fonts1, *fonts2;
+ int nfonts1, nfonts2;
+{
+ int new_nfonts = nfonts1 + nfonts2;
+ struct font_name *new_fonts;
+
+ new_fonts = (struct font_name *) xmalloc (sizeof *new_fonts * new_nfonts);
+ bcopy (fonts1, new_fonts, sizeof *new_fonts * nfonts1);
+ bcopy (fonts2, new_fonts + nfonts1, sizeof *new_fonts * nfonts2);
+ xfree (fonts1);
+ xfree (fonts2);
+ return new_fonts;
+}
+
+
+/* Get a sorted list of fonts of family FAMILY on frame F.
+
+ If PATTERN is non-nil list fonts matching that pattern.
+
+ If REGISTRY is non-nil, return fonts with that registry and the
+ alternative registries from Vface_alternative_font_registry_alist.
+
+ If REGISTRY is nil return fonts of any registry.
+
+ Set *FONTS to a vector of font_name structures allocated from the
+ heap containing the fonts found. Value is the number of fonts
+ found. */
+
+static int
+font_list (f, pattern, family, registry, fonts)
+ struct frame *f;
+ Lisp_Object pattern, family, registry;
+ struct font_name **fonts;
+{
+ int nfonts = font_list_1 (f, pattern, family, registry, fonts);
+
+ if (!NILP (registry)
+ && CONSP (Vface_alternative_font_registry_alist))
+ {
+ Lisp_Object alter;
+
+ alter = Fassoc (registry, Vface_alternative_font_registry_alist);
+ if (CONSP (alter))
+ {
+ int reg_prio, i;
+
+ for (alter = XCDR (alter), reg_prio = 1;
+ CONSP (alter);
+ alter = XCDR (alter), reg_prio++)
+ if (STRINGP (XCAR (alter)))
+ {
+ int nfonts2;
+ struct font_name *fonts2;
+
+ nfonts2 = font_list_1 (f, pattern, family, XCAR (alter),
+ &fonts2);
+ for (i = 0; i < nfonts2; i++)
+ fonts2[i].registry_priority = reg_prio;
+ *fonts = (nfonts > 0
+ ? concat_font_list (*fonts, nfonts, fonts2, nfonts2)
+ : fonts2);
+ nfonts += nfonts2;
+ }
+ }
+ }
+
+ return nfonts;
+}
+
+
+/* Remove elements from LIST whose cars are `equal'. Called from
+ x-family-fonts and x-font-family-list to remove duplicate font
+ entries. */
+
+static void
+remove_duplicates (list)
+ Lisp_Object list;
+{
+ Lisp_Object tail = list;
+
+ while (!NILP (tail) && !NILP (XCDR (tail)))
+ {
+ Lisp_Object next = XCDR (tail);
+ if (!NILP (Fequal (XCAR (next), XCAR (tail))))
+ XCDR (tail) = XCDR (next);
+ else
+ tail = XCDR (tail);
+ }
+}
+
+
+DEFUN ("x-family-fonts", Fx_family_fonts, Sx_family_fonts, 0, 2, 0,
+ "Return a list of available fonts of family FAMILY on FRAME.\n\
+If FAMILY is omitted or nil, list all families.\n\
+Otherwise, FAMILY must be a string, possibly containing wildcards\n\
+`?' and `*'.\n\
+If FRAME is omitted or nil, use the selected frame.\n\
+Each element of the result is a vector [FAMILY WIDTH POINT-SIZE WEIGHT\n\
+SLANT FIXED-P FULL REGISTRY-AND-ENCODING].\n\
+FAMILY is the font family name. POINT-SIZE is the size of the\n\
+font in 1/10 pt. WIDTH, WEIGHT, and SLANT are symbols describing the\n\
+width, weight and slant of the font. These symbols are the same as for\n\
+face attributes. FIXED-P is non-nil if the font is fixed-pitch.\n\
+FULL is the full name of the font, and REGISTRY-AND-ENCODING is a string\n\
+giving the registry and encoding of the font.\n\
+The result list is sorted according to the current setting of\n\
+the face font sort order.")
+ (family, frame)
+ Lisp_Object family, frame;
+{
+ struct frame *f = check_x_frame (frame);
+ struct font_name *fonts;
+ int i, nfonts;
+ Lisp_Object result;
+ struct gcpro gcpro1;
+
+ if (!NILP (family))
+ CHECK_STRING (family, 1);
+
+ result = Qnil;
+ GCPRO1 (result);
+ nfonts = font_list (f, Qnil, family, Qnil, &fonts);
+ for (i = nfonts - 1; i >= 0; --i)
+ {
+ Lisp_Object v = Fmake_vector (make_number (8), Qnil);
+ char *tem;
+
+ ASET (v, 0, build_string (fonts[i].fields[XLFD_FAMILY]));
+ ASET (v, 1, xlfd_symbolic_swidth (fonts + i));
+ ASET (v, 2, make_number (xlfd_point_size (f, fonts + i)));
+ ASET (v, 3, xlfd_symbolic_weight (fonts + i));
+ ASET (v, 4, xlfd_symbolic_slant (fonts + i));
+ ASET (v, 5, xlfd_fixed_p (fonts + i) ? Qt : Qnil);
+ tem = build_font_name (fonts + i);
+ ASET (v, 6, build_string (tem));
+ sprintf (tem, "%s-%s", fonts[i].fields[XLFD_REGISTRY],
+ fonts[i].fields[XLFD_ENCODING]);
+ ASET (v, 7, build_string (tem));
+ xfree (tem);
+
+ result = Fcons (v, result);
+ }
+
+ remove_duplicates (result);
+ free_font_names (fonts, nfonts);
+ UNGCPRO;
+ return result;
+}
+
+
+DEFUN ("x-font-family-list", Fx_font_family_list, Sx_font_family_list,
+ 0, 1, 0,
+ "Return a list of available font families on FRAME.\n\
+If FRAME is omitted or nil, use the selected frame.\n\
+Value is a list of conses (FAMILY . FIXED-P) where FAMILY\n\
+is a font family, and FIXED-P is non-nil if fonts of that family\n\
+are fixed-pitch.")
+ (frame)
+ Lisp_Object frame;
+{
+ struct frame *f = check_x_frame (frame);
+ int nfonts, i;
+ struct font_name *fonts;
+ Lisp_Object result;
+ struct gcpro gcpro1;
+ int count = specpdl_ptr - specpdl;
+ int limit;
+
+ /* Let's consider all fonts. Increase the limit for matching
+ fonts until we have them all. */
+ for (limit = 500;;)
+ {
+ specbind (intern ("font-list-limit"), make_number (limit));
+ nfonts = font_list (f, Qnil, Qnil, Qnil, &fonts);
+
+ if (nfonts == limit)
+ {
+ free_font_names (fonts, nfonts);
+ limit *= 2;
+ }
+ else
+ break;
+ }
+
+ result = Qnil;
+ GCPRO1 (result);
+ for (i = nfonts - 1; i >= 0; --i)
+ result = Fcons (Fcons (build_string (fonts[i].fields[XLFD_FAMILY]),
+ xlfd_fixed_p (fonts + i) ? Qt : Qnil),
+ result);
+
+ remove_duplicates (result);
+ free_font_names (fonts, nfonts);
+ UNGCPRO;
+ return unbind_to (count, result);
+}
+
+
+DEFUN ("x-list-fonts", Fx_list_fonts, Sx_list_fonts, 1, 5, 0,
+ "Return a list of the names of available fonts matching PATTERN.\n\
+If optional arguments FACE and FRAME are specified, return only fonts\n\
+the same size as FACE on FRAME.\n\
+PATTERN is a string, perhaps with wildcard characters;\n\
+ the * character matches any substring, and\n\
+ the ? character matches any single character.\n\
+ PATTERN is case-insensitive.\n\
+FACE is a face name--a symbol.\n\
+\n\
+The return value is a list of strings, suitable as arguments to\n\
+set-face-font.\n\
+\n\
+Fonts Emacs can't use may or may not be excluded\n\
+even if they match PATTERN and FACE.\n\
+The optional fourth argument MAXIMUM sets a limit on how many\n\
+fonts to match. The first MAXIMUM fonts are reported.\n\
+The optional fifth argument WIDTH, if specified, is a number of columns\n\
+occupied by a character of a font. In that case, return only fonts\n\
+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;
+ int maxnames;
+
+ check_x ();
+ CHECK_STRING (pattern, 0);
+
+ if (NILP (maximum))
+ maxnames = 2000;
+ else
+ {
+ CHECK_NATNUM (maximum, 0);
+ maxnames = XINT (maximum);
+ }
+
+ if (!NILP (width))
+ CHECK_NUMBER (width, 4);
+
+ /* We can't simply call check_x_frame because this function may be
+ called before any frame is created. */
+ f = frame_or_selected_frame (frame, 2);
+ if (!FRAME_WINDOW_P (f))
+ {
+ /* Perhaps we have not yet created any frame. */
+ f = NULL;
+ 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 = FONT_WIDTH (face->font);
+ else
+ size = FONT_WIDTH (FRAME_FONT (f));
+
+ if (!NILP (width))
+ size *= XINT (width);
+ }
+
+ {
+ Lisp_Object args[2];
+
+ args[0] = x_list_fonts (f, pattern, size, maxnames);
+ if (f == NULL)
+ /* 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 */
+
+
+\f
+/***********************************************************************
+ Lisp Faces
+ ***********************************************************************/
+
+/* Access face attributes of face LFACE, a Lisp vector. */
+
+#define LFACE_FAMILY(LFACE) AREF ((LFACE), LFACE_FAMILY_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_AVGWIDTH(LFACE) AREF ((LFACE), LFACE_AVGWIDTH_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 (LFACE)->size == 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])
+ || STRINGP (attrs[LFACE_FAMILY_INDEX]));
+ xassert (UNSPECIFIEDP (attrs[LFACE_SWIDTH_INDEX])
+ || SYMBOLP (attrs[LFACE_SWIDTH_INDEX]));
+ xassert (UNSPECIFIEDP (attrs[LFACE_AVGWIDTH_INDEX])
+ || INTEGERP (attrs[LFACE_AVGWIDTH_INDEX]));
+ xassert (UNSPECIFIEDP (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])
+ || SYMBOLP (attrs[LFACE_WEIGHT_INDEX]));
+ xassert (UNSPECIFIEDP (attrs[LFACE_SLANT_INDEX])
+ || SYMBOLP (attrs[LFACE_SLANT_INDEX]));
+ xassert (UNSPECIFIEDP (attrs[LFACE_UNDERLINE_INDEX])
+ || SYMBOLP (attrs[LFACE_UNDERLINE_INDEX])
+ || STRINGP (attrs[LFACE_UNDERLINE_INDEX]));
+ xassert (UNSPECIFIEDP (attrs[LFACE_OVERLINE_INDEX])
+ || SYMBOLP (attrs[LFACE_OVERLINE_INDEX])
+ || STRINGP (attrs[LFACE_OVERLINE_INDEX]));
+ xassert (UNSPECIFIEDP (attrs[LFACE_STRIKE_THROUGH_INDEX])
+ || SYMBOLP (attrs[LFACE_STRIKE_THROUGH_INDEX])
+ || STRINGP (attrs[LFACE_STRIKE_THROUGH_INDEX]));
+ xassert (UNSPECIFIEDP (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])
+ || SYMBOLP (attrs[LFACE_INVERSE_INDEX]));
+ xassert (UNSPECIFIEDP (attrs[LFACE_FOREGROUND_INDEX])
+ || STRINGP (attrs[LFACE_FOREGROUND_INDEX]));
+ xassert (UNSPECIFIEDP (attrs[LFACE_BACKGROUND_INDEX])
+ || STRINGP (attrs[LFACE_BACKGROUND_INDEX]));
+ xassert (UNSPECIFIEDP (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])
+ || SYMBOLP (attrs[LFACE_STIPPLE_INDEX])
+ || !NILP (Fbitmap_spec_p (attrs[LFACE_STIPPLE_INDEX])));
+ xassert (UNSPECIFIEDP (attrs[LFACE_FONT_INDEX])
+ || NILP (attrs[LFACE_FONT_INDEX])
+ || STRINGP (attrs[LFACE_FONT_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 */
+
+
+/* Resolve face name FACE_NAME. If FACE_NAME is a string, intern it
+ to make it a symvol. If FACE_NAME is an alias for another face,
+ return that face's name. */
+
+static Lisp_Object
+resolve_face_name (face_name)
+ Lisp_Object face_name;
+{
+ Lisp_Object aliased;
+
+ if (STRINGP (face_name))
+ face_name = intern (XSTRING (face_name)->data);
+
+ while (SYMBOLP (face_name))
+ {
+ aliased = Fget (face_name, Qface_alias);
+ if (NILP (aliased))
+ break;
+ else
+ face_name = aliased;
+ }
+
+ 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 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;
+{
+ Lisp_Object lface;
+
+ face_name = resolve_face_name (face_name);
+
+ 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;
+}
+
+
+/* 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 (f, face_name, attrs, signal_p)
+ struct frame *f;
+ Lisp_Object face_name;
+ Lisp_Object *attrs;
+ int signal_p;
+{
+ Lisp_Object lface;
+ int success_p;
+
+ lface = lface_from_face_name (f, face_name, signal_p);
+ if (!NILP (lface))
+ {
+ bcopy (XVECTOR (lface)->contents, attrs,
+ LFACE_VECTOR_SIZE * sizeof *attrs);
+ success_p = 1;
+ }
+ else
+ success_p = 0;
+
+ return success_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
+ && i != LFACE_AVGWIDTH_INDEX)
+ if (UNSPECIFIEDP (attrs[i]))
+ break;
+
+ return i == LFACE_VECTOR_SIZE;
+}
+
+#ifdef HAVE_WINDOW_SYSTEM
+
+/* Set font-related attributes of Lisp face LFACE from the fullname of
+ the font opened by FONTNAME. If FORCE_P is zero, set only
+ unspecified attributes of LFACE. The exception is `font'
+ attribute. It is set to FONTNAME as is regardless of FORCE_P.
+
+ If FONTNAME is not available on frame F,
+ return 0 if MAY_FAIL_P is non-zero, otherwise abort.
+ If the fullname is not in a valid XLFD format,
+ return 0 if MAY_FAIL_P is non-zero, otherwise set normal values
+ in LFACE and return 1.
+ Otherwise, return 1. */
+
+static int
+set_lface_from_font_name (f, lface, fontname, force_p, may_fail_p)
+ struct frame *f;
+ Lisp_Object lface;
+ Lisp_Object fontname;
+ int force_p, may_fail_p;
+{
+ struct font_name font;
+ char *buffer;
+ int pt;
+ int have_xlfd_p;
+ int fontset;
+ char *font_name = XSTRING (fontname)->data;
+ struct font_info *font_info;
+
+ /* If FONTNAME is actually a fontset name, get ASCII font name of it. */
+ fontset = fs_query_fontset (fontname, 0);
+ if (fontset >= 0)
+ font_name = XSTRING (fontset_ascii (fontset))->data;
+
+ /* Check if FONT_NAME is surely available on the system. Usually
+ FONT_NAME is already cached for the frame F and FS_LOAD_FONT
+ returns quickly. But, even if FONT_NAME is not yet cached,
+ caching it now is not futail because we anyway load the font
+ later. */
+ BLOCK_INPUT;
+ font_info = FS_LOAD_FONT (f, 0, font_name, -1);
+ UNBLOCK_INPUT;
+
+ if (!font_info)
+ {
+ if (may_fail_p)
+ return 0;
+ abort ();
+ }
+
+ font.name = STRDUPA (font_info->full_name);
+ have_xlfd_p = split_font_name (f, &font, 1);
+
+ /* Set attributes only if unspecified, otherwise face defaults for
+ new frames would never take effect. If we couldn't get a font
+ name conforming to XLFD, set normal values. */
+
+ if (force_p || UNSPECIFIEDP (LFACE_FAMILY (lface)))
+ {
+ Lisp_Object val;
+ if (have_xlfd_p)
+ {
+ buffer = (char *) alloca (strlen (font.fields[XLFD_FAMILY])
+ + strlen (font.fields[XLFD_FOUNDRY])
+ + 2);
+ sprintf (buffer, "%s-%s", font.fields[XLFD_FOUNDRY],
+ font.fields[XLFD_FAMILY]);
+ val = build_string (buffer);
+ }
+ else
+ val = build_string ("*");
+ LFACE_FAMILY (lface) = val;
+ }
+
+ if (force_p || UNSPECIFIEDP (LFACE_HEIGHT (lface)))
+ {
+ if (have_xlfd_p)
+ pt = xlfd_point_size (f, &font);
+ else
+ pt = pixel_point_size (f, font_info->height * 10);
+ xassert (pt > 0);
+ LFACE_HEIGHT (lface) = make_number (pt);
+ }
+
+ if (force_p || UNSPECIFIEDP (LFACE_SWIDTH (lface)))
+ LFACE_SWIDTH (lface)
+ = have_xlfd_p ? xlfd_symbolic_swidth (&font) : Qnormal;
+
+ if (force_p || UNSPECIFIEDP (LFACE_AVGWIDTH (lface)))
+ LFACE_AVGWIDTH (lface)
+ = (have_xlfd_p
+ ? make_number (font.numeric[XLFD_AVGWIDTH])
+ : Qunspecified);
+
+ if (force_p || UNSPECIFIEDP (LFACE_WEIGHT (lface)))
+ LFACE_WEIGHT (lface)
+ = have_xlfd_p ? xlfd_symbolic_weight (&font) : Qnormal;
+
+ if (force_p || UNSPECIFIEDP (LFACE_SLANT (lface)))
+ LFACE_SLANT (lface)
+ = have_xlfd_p ? xlfd_symbolic_slant (&font) : Qnormal;
+
+ LFACE_FONT (lface) = fontname;
+
+ 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 may be a either an absolute face height or a
+ `relative' height, and TO must be an absolute height. The returned
+ value is always an absolute height. GCPRO is a lisp value that will
+ be protected from garbage-collection if this function makes a call
+ into lisp. */
+
+Lisp_Object
+merge_face_heights (from, to, invalid, gcpro)
+ Lisp_Object from, to, invalid, gcpro;
+{
+ int result = 0;
+
+ if (INTEGERP (from))
+ result = XINT (from);
+ else if (NUMBERP (from))
+ result = XFLOATINT (from) * XINT (to);
+#if 0 /* Probably not so useful. */
+ else if (CONSP (from) && CONSP (XCDR (from)))
+ {
+ if (EQ (XCAR(from), Qplus) || EQ (XCAR(from), Qminus))
+ {
+ if (INTEGERP (XCAR (XCDR (from))))
+ {
+ int inc = XINT (XCAR (XCDR (from)));
+ if (EQ (XCAR (from), Qminus))
+ inc = -inc;
+
+ result = XFASTINT (to);
+ if (result + inc > 0)
+ /* Note that `underflows' don't mean FROM is invalid, so
+ we just pin the result at TO if it would otherwise be
+ negative or 0. */
+ result += inc;
+ }
+ }
+ }
+#endif
+ else if (FUNCTIONP (from))
+ {
+ /* Call function with current height as argument.
+ From is the new height. */
+ Lisp_Object args[2], height;
+ struct gcpro gcpro1;
+
+ GCPRO1 (gcpro);
+
+ args[0] = from;
+ args[1] = to;
+ height = safe_call (2, args);
+
+ UNGCPRO;
+
+ if (NUMBERP (height))
+ result = XFLOATINT (height);
+ }
+
+ if (result > 0)
+ return make_number (result);
+ else
+ return invalid;
+}
+
+
+/* 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. CYCLE_CHECK is used internally to detect loops in
+ face inheritance; it should be Qnil when called from other places. */
+
+static INLINE void
+merge_face_vectors (f, from, to, cycle_check)
+ struct frame *f;
+ Lisp_Object *from, *to;
+ Lisp_Object cycle_check;
+{
+ 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_inheritance (f, from[LFACE_INHERIT_INDEX], to, cycle_check);
+
+ /* If TO specifies a :font attribute, and FROM specifies some
+ font-related attribute, we need to clear TO's :font attribute
+ (because it will be inconsistent with whatever FROM specifies, and
+ FROM takes precedence). */
+ if (!NILP (to[LFACE_FONT_INDEX])
+ && (!UNSPECIFIEDP (from[LFACE_FAMILY_INDEX])
+ || !UNSPECIFIEDP (from[LFACE_HEIGHT_INDEX])
+ || !UNSPECIFIEDP (from[LFACE_WEIGHT_INDEX])
+ || !UNSPECIFIEDP (from[LFACE_SLANT_INDEX])
+ || !UNSPECIFIEDP (from[LFACE_SWIDTH_INDEX])
+ || !UNSPECIFIEDP (from[LFACE_AVGWIDTH_INDEX])))
+ to[LFACE_FONT_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], cycle_check);
+ else
+ to[i] = from[i];
+
+ /* 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;
+}
+
+
+/* Checks the `cycle check' variable CHECK to see if it indicates that
+ EL is part of a cycle; CHECK must be either Qnil or a value returned
+ by an earlier use of CYCLE_CHECK. SUSPICIOUS is the number of
+ elements after which a cycle might be suspected; after that many
+ elements, this macro begins consing in order to keep more precise
+ track of elements.
+
+ Returns NIL if a cycle was detected, otherwise a new value for CHECK
+ that includes EL.
+
+ CHECK is evaluated multiple times, EL and SUSPICIOUS 0 or 1 times, so
+ the caller should make sure that's ok. */
+
+#define CYCLE_CHECK(check, el, suspicious) \
+ (NILP (check) \
+ ? make_number (0) \
+ : (INTEGERP (check) \
+ ? (XFASTINT (check) < (suspicious) \
+ ? make_number (XFASTINT (check) + 1) \
+ : Fcons (el, Qnil)) \
+ : (!NILP (Fmemq ((el), (check))) \
+ ? Qnil \
+ : Fcons ((el), (check)))))
+
+
+/* Merge face attributes from the face on frame F whose name is
+ INHERITS, into the vector of face attributes TO; INHERITS may also be
+ a list of face names, in which case they are applied in order.
+ CYCLE_CHECK is used to detect loops in face inheritance.
+ Returns true if any of the inherited attributes are `font-related'. */
+
+static void
+merge_face_inheritance (f, inherit, to, cycle_check)
+ struct frame *f;
+ Lisp_Object inherit;
+ Lisp_Object *to;
+ Lisp_Object cycle_check;
+{
+ if (SYMBOLP (inherit) && !EQ (inherit, Qunspecified))
+ /* Inherit from the named face INHERIT. */
+ {
+ Lisp_Object lface;
+
+ /* Make sure we're not in an inheritance loop. */
+ cycle_check = CYCLE_CHECK (cycle_check, inherit, 15);
+ if (NILP (cycle_check))
+ /* Cycle detected, ignore any further inheritance. */
+ return;
+
+ lface = lface_from_face_name (f, inherit, 0);
+ if (!NILP (lface))
+ merge_face_vectors (f, XVECTOR (lface)->contents, to, cycle_check);
+ }
+ else if (CONSP (inherit))
+ /* Handle a list of inherited faces by calling ourselves recursively
+ on each element. Note that we only do so for symbol elements, so
+ it's not possible to infinitely recurse. */
+ {
+ while (CONSP (inherit))
+ {
+ if (SYMBOLP (XCAR (inherit)))
+ merge_face_inheritance (f, XCAR (inherit), to, cycle_check);
+
+ /* Check for a circular inheritance list. */
+ cycle_check = CYCLE_CHECK (cycle_check, inherit, 15);
+ if (NILP (cycle_check))
+ /* Cycle detected. */
+ break;
+
+ inherit = XCDR (inherit);
+ }
+ }
+}
+
+
+/* Given a Lisp face attribute vector TO and a Lisp object PROP that
+ is a face property, determine the resulting face attributes on
+ frame F, and store them in TO. PROP 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 void
+merge_face_vector_with_property (f, to, prop)
+ struct frame *f;
+ Lisp_Object *to;
+ Lisp_Object prop;
+{
+ if (CONSP (prop))
+ {
+ Lisp_Object first = XCAR (prop);
+
+ 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 (prop);
+ 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
+ add_to_log ("Invalid face color", color_name, Qnil);
+ }
+ else if (SYMBOLP (first)
+ && *XSYMBOL (first)->name->data == ':')
+ {
+ /* Assume this is the property list form. */
+ while (CONSP (prop) && CONSP (XCDR (prop)))
+ {
+ Lisp_Object keyword = XCAR (prop);
+ Lisp_Object value = XCAR (XCDR (prop));
+
+ if (EQ (keyword, QCfamily))
+ {
+ if (STRINGP (value))
+ to[LFACE_FAMILY_INDEX] = value;
+ else
+ add_to_log ("Invalid face font family", value, Qnil);
+ }
+ else if (EQ (keyword, QCheight))
+ {
+ Lisp_Object new_height =
+ merge_face_heights (value, to[LFACE_HEIGHT_INDEX],
+ Qnil, Qnil);
+
+ if (NILP (new_height))
+ add_to_log ("Invalid face font height", value, Qnil);
+ else
+ to[LFACE_HEIGHT_INDEX] = new_height;
+ }
+ else if (EQ (keyword, QCweight))
+ {
+ if (SYMBOLP (value)
+ && face_numeric_weight (value) >= 0)
+ to[LFACE_WEIGHT_INDEX] = value;
+ else
+ add_to_log ("Invalid face weight", value, Qnil);
+ }
+ else if (EQ (keyword, QCslant))
+ {
+ if (SYMBOLP (value)
+ && face_numeric_slant (value) >= 0)
+ to[LFACE_SLANT_INDEX] = value;
+ else
+ add_to_log ("Invalid face slant", value, Qnil);
+ }
+ else if (EQ (keyword, QCunderline))
+ {
+ if (EQ (value, Qt)
+ || NILP (value)
+ || STRINGP (value))
+ to[LFACE_UNDERLINE_INDEX] = value;
+ else
+ add_to_log ("Invalid face underline", value, Qnil);
+ }
+ else if (EQ (keyword, QCoverline))
+ {
+ if (EQ (value, Qt)
+ || NILP (value)
+ || STRINGP (value))
+ to[LFACE_OVERLINE_INDEX] = value;
+ else
+ add_to_log ("Invalid face overline", value, Qnil);
+ }
+ else if (EQ (keyword, QCstrike_through))
+ {
+ if (EQ (value, Qt)
+ || NILP (value)
+ || STRINGP (value))
+ to[LFACE_STRIKE_THROUGH_INDEX] = value;
+ else
+ add_to_log ("Invalid face strike-through", value, Qnil);
+ }
+ 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
+ add_to_log ("Invalid face box", value, Qnil);
+ }
+ else if (EQ (keyword, QCinverse_video)
+ || EQ (keyword, QCreverse_video))
+ {
+ if (EQ (value, Qt) || NILP (value))
+ to[LFACE_INVERSE_INDEX] = value;
+ else
+ add_to_log ("Invalid face inverse-video", value, Qnil);
+ }
+ else if (EQ (keyword, QCforeground))
+ {
+ if (STRINGP (value))
+ to[LFACE_FOREGROUND_INDEX] = value;
+ else
+ add_to_log ("Invalid face foreground", value, Qnil);
+ }
+ else if (EQ (keyword, QCbackground))
+ {
+ if (STRINGP (value))
+ to[LFACE_BACKGROUND_INDEX] = value;
+ else
+ add_to_log ("Invalid face background", value, Qnil);
+ }
+ else if (EQ (keyword, QCstipple))
+ {
+#ifdef HAVE_X_WINDOWS
+ Lisp_Object pixmap_p = Fbitmap_spec_p (value);
+ if (!NILP (pixmap_p))
+ to[LFACE_STIPPLE_INDEX] = value;
+ else
+ add_to_log ("Invalid face stipple", value, Qnil);
+#endif
+ }
+ else if (EQ (keyword, QCwidth))
+ {
+ if (SYMBOLP (value)
+ && face_numeric_swidth (value) >= 0)
+ to[LFACE_SWIDTH_INDEX] = value;
+ else
+ add_to_log ("Invalid face width", value, Qnil);
+ }
+ else if (EQ (keyword, QCinherit))
+ {
+ if (SYMBOLP (value))
+ to[LFACE_INHERIT_INDEX] = value;
+ else
+ {
+ Lisp_Object tail;
+ for (tail = value; CONSP (tail); tail = XCDR (tail))
+ if (!SYMBOLP (XCAR (tail)))
+ break;
+ if (NILP (tail))
+ to[LFACE_INHERIT_INDEX] = value;
+ else
+ add_to_log ("Invalid face inherit", value, Qnil);
+ }
+ }
+ else
+ add_to_log ("Invalid attribute %s in face property",
+ keyword, Qnil);
+
+ prop = XCDR (XCDR (prop));
+ }
+ }
+ else
+ {
+ /* This is a list of face specs. Specifications at the
+ beginning of the list take precedence over later
+ specifications, so we have to merge starting with the
+ last specification. */
+ Lisp_Object next = XCDR (prop);
+ if (!NILP (next))
+ merge_face_vector_with_property (f, to, next);
+ merge_face_vector_with_property (f, to, first);
+ }
+ }
+ else
+ {
+ /* PROP ought to be a face name. */
+ Lisp_Object lface = lface_from_face_name (f, prop, 0);
+ if (NILP (lface))
+ add_to_log ("Invalid face text property value: %s", prop, Qnil);
+ else
+ merge_face_vectors (f, XVECTOR (lface)->contents, to, Qnil);
+ }
+}
+
+
+DEFUN ("internal-make-lisp-face", Finternal_make_lisp_face,
+ Sinternal_make_lisp_face, 1, 2, 0,
+ "Make FACE, a symbol, a Lisp face with all attributes nil.\n\
+If FACE was not known as a face before, create a new one.\n\
+If optional argument FRAME is specified, make a frame-local face\n\
+for that frame. Otherwise operate on the global face definition.\n\
+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, 0);
+ global_lface = lface_from_face_name (NULL, face, 0);
+
+ if (!NILP (frame))
+ {
+ CHECK_LIVE_FRAME (frame, 1);
+ 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);
+ AREF (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)
+ AREF (global_lface, i) = Qunspecified;
+
+ /* Add a frame-local definition. */
+ if (f)
+ {
+ if (NILP (lface))
+ {
+ lface = Fmake_vector (make_number (LFACE_VECTOR_SIZE),
+ Qunspecified);
+ AREF (lface, 0) = Qface;
+ f->face_alist = Fcons (Fcons (face, lface), f->face_alist);
+ }
+ else
+ for (i = 1; i < LFACE_VECTOR_SIZE; ++i)
+ AREF (lface, i) = Qunspecified;
+ }
+ else
+ lface = global_lface;
+
+ xassert (LFACEP (lface));
+ check_lface (lface);
+ return lface;
+}
+
+
+DEFUN ("internal-lisp-face-p", Finternal_lisp_face_p,
+ Sinternal_lisp_face_p, 1, 2, 0,
+ "Return non-nil if FACE names a face.\n\
+If optional second parameter FRAME is non-nil, check for the\n\
+existence of a frame-local face with name FACE on that frame.\n\
+Otherwise check for the existence of a global face.")
+ (face, frame)
+ Lisp_Object face, frame;
+{
+ Lisp_Object lface;
+
+ if (!NILP (frame))
+ {
+ CHECK_LIVE_FRAME (frame, 1);
+ 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,
+ "Copy face FROM to TO.\n\
+If FRAME it t, copy the global face definition of FROM to the\n\
+global face definition of TO. Otherwise, copy the frame-local\n\
+definition of FROM on FRAME to the frame-local definition of TO\n\
+on NEW-FRAME, or FRAME if NEW-FRAME is nil.\n\
+\n\
+Value is TO.")
+ (from, to, frame, new_frame)
+ Lisp_Object from, to, frame, new_frame;
+{
+ Lisp_Object lface, copy;
+
+ CHECK_SYMBOL (from, 0);
+ CHECK_SYMBOL (to, 1);
+ if (NILP (new_frame))
+ new_frame = frame;
+
+ 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. */
+ CHECK_LIVE_FRAME (frame, 2);
+ CHECK_LIVE_FRAME (new_frame, 3);
+ 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));
+
+ return to;
+}
+
+
+DEFUN ("internal-set-lisp-face-attribute", Finternal_set_lisp_face_attribute,
+ Sinternal_set_lisp_face_attribute, 3, 4, 0,
+ "Set attribute ATTR of FACE to VALUE.\n\
+FRAME being a frame means change the face on that frame.\n\
+FRAME nil means change the face of the selected frame.\n\
+FRAME t means change the default for new frames.\n\
+FRAME 0 means change the face on all frames, and change the default\n\
+ for new frames.")
+ (face, attr, value, frame)
+ Lisp_Object face, attr, value, frame;
+{
+ Lisp_Object lface;
+ Lisp_Object old_value = Qnil;
+ /* Set 1 if ATTR is QCfont. */
+ int font_attr_p = 0;
+ /* Set 1 if ATTR is one of font-related attributes other than QCfont. */
+ int font_related_attr_p = 0;
+
+ CHECK_SYMBOL (face, 0);
+ CHECK_SYMBOL (attr, 1);
+
+ face = resolve_face_name (face);
+
+ /* 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);
+ else
+ {
+ if (NILP (frame))
+ frame = selected_frame;
+
+ CHECK_LIVE_FRAME (frame, 3);
+ 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))
+ {
+ CHECK_STRING (value, 3);
+ if (XSTRING (value)->size == 0)
+ signal_error ("Invalid face family", value);
+ }
+ old_value = LFACE_FAMILY (lface);
+ LFACE_FAMILY (lface) = value;
+ font_related_attr_p = 1;
+ }
+ else if (EQ (attr, QCheight))
+ {
+ if (!UNSPECIFIEDP (value))
+ {
+ Lisp_Object test =
+ (EQ (face, Qdefault) ? value :
+ /* The default face must have an absolute size, otherwise, we do
+ a test merge with a random height to see if VALUE's ok. */
+ merge_face_heights (value, make_number(10), Qnil, Qnil));
+
+ if (!INTEGERP(test) || XINT(test) <= 0)
+ signal_error ("Invalid face height", value);
+ }
+
+ old_value = LFACE_HEIGHT (lface);
+ LFACE_HEIGHT (lface) = value;
+ font_related_attr_p = 1;
+ }
+ else if (EQ (attr, QCweight))
+ {
+ if (!UNSPECIFIEDP (value))
+ {
+ CHECK_SYMBOL (value, 3);
+ if (face_numeric_weight (value) < 0)
+ signal_error ("Invalid face weight", value);
+ }
+ old_value = LFACE_WEIGHT (lface);
+ LFACE_WEIGHT (lface) = value;
+ font_related_attr_p = 1;
+ }
+ else if (EQ (attr, QCslant))
+ {
+ if (!UNSPECIFIEDP (value))
+ {
+ CHECK_SYMBOL (value, 3);
+ if (face_numeric_slant (value) < 0)
+ signal_error ("Invalid face slant", value);
+ }
+ old_value = LFACE_SLANT (lface);
+ LFACE_SLANT (lface) = value;
+ font_related_attr_p = 1;
+ }
+ else if (EQ (attr, QCunderline))
+ {
+ if (!UNSPECIFIEDP (value))
+ if ((SYMBOLP (value)
+ && !EQ (value, Qt)
+ && !EQ (value, Qnil))
+ /* Underline color. */
+ || (STRINGP (value)
+ && XSTRING (value)->size == 0))
+ signal_error ("Invalid face underline", value);
+
+ old_value = LFACE_UNDERLINE (lface);
+ LFACE_UNDERLINE (lface) = value;
+ }
+ else if (EQ (attr, QCoverline))
+ {
+ if (!UNSPECIFIEDP (value))
+ if ((SYMBOLP (value)
+ && !EQ (value, Qt)
+ && !EQ (value, Qnil))
+ /* Overline color. */
+ || (STRINGP (value)
+ && XSTRING (value)->size == 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))
+ if ((SYMBOLP (value)
+ && !EQ (value, Qt)
+ && !EQ (value, Qnil))
+ /* Strike-through color. */
+ || (STRINGP (value)
+ && XSTRING (value)->size == 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))
+ 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 = XSTRING (value)->size > 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 (!STRINGP (v) || XSTRING (v)->size == 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))
+ {
+ CHECK_SYMBOL (value, 3);
+ 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))
+ {
+ if (!UNSPECIFIEDP (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, 3);
+ if (XSTRING (value)->size == 0)
+ signal_error ("Empty foreground color value", value);
+ }
+ old_value = LFACE_FOREGROUND (lface);
+ LFACE_FOREGROUND (lface) = value;
+ }
+ else if (EQ (attr, QCbackground))
+ {
+ if (!UNSPECIFIEDP (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, 3);
+ if (XSTRING (value)->size == 0)
+ signal_error ("Empty background color value", value);
+ }
+ old_value = LFACE_BACKGROUND (lface);
+ LFACE_BACKGROUND (lface) = value;
+ }
+ else if (EQ (attr, QCstipple))
+ {
+#ifdef HAVE_X_WINDOWS
+ if (!UNSPECIFIEDP (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 */
+ }
+ else if (EQ (attr, QCwidth))
+ {
+ if (!UNSPECIFIEDP (value))
+ {
+ CHECK_SYMBOL (value, 3);
+ if (face_numeric_swidth (value) < 0)
+ signal_error ("Invalid face width", value);
+ }
+ old_value = LFACE_SWIDTH (lface);
+ LFACE_SWIDTH (lface) = value;
+ font_related_attr_p = 1;
+ }
+ else if (EQ (attr, QCfont))
+ {
+#ifdef HAVE_WINDOW_SYSTEM
+ /* Set font-related attributes of the Lisp face from an
+ XLFD font name. */
+ struct frame *f;
+ Lisp_Object tmp;
+
+ CHECK_STRING (value, 3);
+ if (EQ (frame, Qt))
+ f = SELECTED_FRAME ();
+ else
+ f = check_x_frame (frame);
+
+ /* VALUE may be a fontset name or an alias of fontset. In such
+ a case, use the base fontset name. */
+ tmp = Fquery_fontset (value, Qnil);
+ if (!NILP (tmp))
+ value = tmp;
+
+ if (!set_lface_from_font_name (f, lface, value, 1, 1))
+ signal_error ("Invalid font or fontset name", value);
+
+ font_attr_p = 1;
+#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;
+ font_related_attr_p = 1;
+ }
+ else if (EQ (attr, QCitalic))
+ {
+ old_value = LFACE_SLANT (lface);
+ LFACE_SLANT (lface) = NILP (value) ? Qnormal : Qitalic;
+ font_related_attr_p = 1;
+ }
+ else
+ signal_error ("Invalid face attribute name", attr);
+
+ if (font_related_attr_p
+ && !UNSPECIFIEDP (value))
+ /* If a font-related attribute other than QCfont is specified, the
+ original `font' attribute nor that of default face is useless
+ to determine a new font. Thus, we set it to nil so that font
+ selection mechanism doesn't use it. */
+ LFACE_FONT (lface) = Qnil;
+
+ /* 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)
+ && (EQ (attr, QCfont)
+ || NILP (Fequal (old_value, value))))
+ {
+ ++face_change_count;
+ ++windows_or_buffers_changed;
+ }
+
+ if (!UNSPECIFIEDP (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)
+ && (font_related_attr_p || font_attr_p)
+ && 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);
+ XCAR (cons) = param;
+ XCDR (cons) = value;
+ Fmodify_frame_parameters (frame, Vparam_value_alist);
+ }
+ }
+
+ return face;
+}
+
+
+#ifdef HAVE_WINDOW_SYSTEM
+
+/* Set the `font' frame parameter of FRAME determined from `default'
+ face attributes LFACE. If a face or fontset name is explicitely
+ specfied in LFACE, use it as is. Otherwise, determine a font name
+ from the other font-related atrributes of LFACE. In that case, if
+ there's no matching font, signals an error. */
+
+static void
+set_font_frame_param (frame, lface)
+ Lisp_Object frame, lface;
+{
+ struct frame *f = XFRAME (frame);
+
+ if (FRAME_WINDOW_P (f))
+ {
+ Lisp_Object font_name;
+ char *font;
+
+ if (STRINGP (LFACE_FONT (lface)))
+ font_name = LFACE_FONT (lface);
+ else
+ {
+ /* Choose a font name that reflects LFACE's attributes and has
+ the registry and encoding pattern specified in the default
+ fontset (3rd arg: -1) for ASCII characters (4th arg: 0). */
+ font = choose_face_font (f, XVECTOR (lface)->contents, -1, 0);
+ if (!font)
+ error ("No font matches the specified attribute");
+ font_name = build_string (font);
+ xfree (font);
+ }
+
+ Fmodify_frame_parameters (frame, Fcons (Fcons (Qfont, font_name), Qnil));
+ }
+}
+
+
+/* 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 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))
+ {
+ lface = lface_from_face_name (f, Qdefault, 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_update_face_colors, frame);
+
+ lface = lface_from_face_name (f, Qdefault, 1);
+ LFACE_BACKGROUND (lface) = (STRINGP (new_value)
+ ? new_value : Qunspecified);
+ realize_basic_faces (f);
+ }
+ else if (EQ (param, Qborder_color))
+ {
+ lface = lface_from_face_name (f, Qborder, 1);
+ LFACE_BACKGROUND (lface) = (STRINGP (new_value)
+ ? new_value : Qunspecified);
+ }
+ else if (EQ (param, Qcursor_color))
+ {
+ lface = lface_from_face_name (f, Qcursor, 1);
+ LFACE_BACKGROUND (lface) = (STRINGP (new_value)
+ ? new_value : Qunspecified);
+ }
+ else if (EQ (param, Qmouse_color))
+ {
+ lface = lface_from_face_name (f, Qmouse, 1);
+ LFACE_BACKGROUND (lface) = (STRINGP (new_value)
+ ? new_value : Qunspecified);
+ }
+}
+
+
+/* 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, "")
+ (resource, class, frame)
+ Lisp_Object resource, class, frame;
+{
+ Lisp_Object value = Qnil;
+#ifndef WINDOWSNT
+#ifndef macintosh
+ CHECK_STRING (resource, 0);
+ CHECK_STRING (class, 1);
+ CHECK_LIVE_FRAME (frame, 2);
+ BLOCK_INPUT;
+ value = display_x_get_resource (FRAME_X_DISPLAY_INFO (XFRAME (frame)),
+ resource, class, Qnil, Qnil);
+ UNBLOCK_INPUT;
+#endif /* not macintosh */
+#endif /* not WINDOWSNT */
+ 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 (xstricmp (XSTRING (value)->data, "on") == 0
+ || xstricmp (XSTRING (value)->data, "true") == 0)
+ result = Qt;
+ else if (xstricmp (XSTRING (value)->data, "off") == 0
+ || xstricmp (XSTRING (value)->data, "false") == 0)
+ result = Qnil;
+ else if (xstricmp (XSTRING (value)->data, "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, "")
+ (face, attr, value, frame)
+ Lisp_Object face, attr, value, frame;
+{
+ CHECK_SYMBOL (face, 0);
+ CHECK_SYMBOL (attr, 1);
+ CHECK_STRING (value, 2);
+
+ if (xstricmp (XSTRING (value)->data, "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 (XSTRING (value)->data);
+ 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))
+ value = Fcar (Fread_from_string (value, Qnil, Qnil));
+
+ return Finternal_set_lisp_face_attribute (face, attr, value, frame);
+}
+
+#endif /* HAVE_WINDOW_SYSTEM */
+
+\f
+/***********************************************************************
+ 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);
+ char *myname = XSTRING (Vx_resource_name)->data;
+ 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,
+ XSTRING (LFACE_FOREGROUND (lface))->data);
+ XrmPutLineResource (&rdb, line);
+ sprintf (line, "%s.pane.menubar*foreground: %s",
+ myname, XSTRING (LFACE_FOREGROUND (lface))->data);
+ XrmPutLineResource (&rdb, line);
+ changed_p = 1;
+ }
+
+ if (STRINGP (LFACE_BACKGROUND (lface)))
+ {
+ sprintf (line, "%s.%s*background: %s",
+ myname, popup_path,
+ XSTRING (LFACE_BACKGROUND (lface))->data);
+ XrmPutLineResource (&rdb, line);
+ sprintf (line, "%s.pane.menubar*background: %s",
+ myname, XSTRING (LFACE_BACKGROUND (lface))->data);
+ XrmPutLineResource (&rdb, line);
+ changed_p = 1;
+ }
+
+ if (face->font_name
+ && (!UNSPECIFIEDP (LFACE_FAMILY (lface))
+ || !UNSPECIFIEDP (LFACE_SWIDTH (lface))
+ || !UNSPECIFIEDP (LFACE_AVGWIDTH (lface))
+ || !UNSPECIFIEDP (LFACE_WEIGHT (lface))
+ || !UNSPECIFIEDP (LFACE_SLANT (lface))
+ || !UNSPECIFIEDP (LFACE_HEIGHT (lface))))
+ {
+#ifdef USE_MOTIF
+ const char *suffix = "List";
+#else
+ const char *suffix = "";
+#endif
+ sprintf (line, "%s.pane.menubar*font%s: %s",
+ myname, suffix, face->font_name);
+ XrmPutLineResource (&rdb, line);
+ sprintf (line, "%s.%s*font%s: %s",
+ myname, popup_path, suffix, face->font_name);
+ XrmPutLineResource (&rdb, line);
+ changed_p = 1;
+ }
+
+ if (changed_p && f->output_data.x->menubar_widget)
+ free_frame_menubar (f);
+ }
+}
+
+#endif /* HAVE_X_WINDOWS && USE_X_TOOLKIT */
+
+
+
+DEFUN ("internal-get-lisp-face-attribute", Finternal_get_lisp_face_attribute,
+ Sinternal_get_lisp_face_attribute,
+ 2, 3, 0,
+ "Return face attribute KEYWORD of face SYMBOL.\n\
+If SYMBOL does not name a valid Lisp face or KEYWORD isn't a valid\n\
+face attribute name, signal an error.\n\
+If the optional argument FRAME is given, report on face FACE in that\n\
+frame. If FRAME is t, report on the defaults for face FACE (for new\n\
+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, 0);
+ CHECK_SYMBOL (keyword, 1);
+
+ if (EQ (frame, Qt))
+ lface = lface_from_face_name (NULL, symbol, 1);
+ else
+ {
+ if (NILP (frame))
+ frame = selected_frame;
+ CHECK_LIVE_FRAME (frame, 2);
+ lface = lface_from_face_name (XFRAME (frame), symbol, 1);
+ }
+
+ if (EQ (keyword, QCfamily))
+ value = LFACE_FAMILY (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
+ signal_error ("Invalid face attribute name", keyword);
+
+ return value;
+}
+
+
+DEFUN ("internal-lisp-face-attribute-values",
+ Finternal_lisp_face_attribute_values,
+ Sinternal_lisp_face_attribute_values, 1, 1, 0,
+ "Return a list of valid discrete values for face attribute ATTR.\n\
+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, 0);
+
+ if (EQ (attr, QCweight)
+ || EQ (attr, QCslant)
+ || EQ (attr, QCwidth))
+ {
+ /* Extract permissible symbols from tables. */
+ struct table_entry *table;
+ int i, dim;
+
+ if (EQ (attr, QCweight))
+ table = weight_table, dim = DIM (weight_table);
+ else if (EQ (attr, QCslant))
+ table = slant_table, dim = DIM (slant_table);
+ else
+ table = swidth_table, dim = DIM (swidth_table);
+
+ for (i = 0; i < dim; ++i)
+ {
+ Lisp_Object symbol = *table[i].symbol;
+ Lisp_Object tail = result;
+
+ while (!NILP (tail)
+ && !EQ (XCAR (tail), symbol))
+ tail = XCDR (tail);
+
+ if (NILP (tail))
+ result = Fcons (symbol, result);
+ }
+ }
+ else 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,
+ "Add attributes from frame-default definition of FACE to FACE on FRAME.\n\
+Default face attributes override any local face attributes.")
+ (face, frame)
+ Lisp_Object face, frame;
+{
+ int i;
+ Lisp_Object global_lface, local_lface, *gvec, *lvec;
+
+ CHECK_LIVE_FRAME (frame, 1);
+ global_lface = lface_from_face_name (NULL, face, 1);
+ local_lface = lface_from_face_name (XFRAME (frame), face, 0);
+ if (NILP (local_lface))
+ local_lface = Finternal_make_lisp_face (face, frame);
+
+ /* Make every specified global attribute override the local one.
+ BEWARE!! This is only used from `face-set-after-frame-default' where
+ the local frame is defined from default specs in `face-defface-spec'
+ and those should be overridden by global settings. Hence the strange
+ "global before local" priority. */
+ lvec = XVECTOR (local_lface)->contents;
+ gvec = XVECTOR (global_lface)->contents;
+ for (i = 1; i < LFACE_VECTOR_SIZE; ++i)
+ if (! UNSPECIFIEDP (gvec[i]))
+ lvec[i] = gvec[i];
+
+ return Qnil;
+}
+
+
+/* The following function is implemented for compatibility with 20.2.
+ The function is used in x-resolve-fonts when it is asked to
+ return fonts with the same size as the font of a face. This is
+ done in fontset.el. */
+
+DEFUN ("face-font", Fface_font, Sface_font, 1, 2, 0,
+ "Return the font name of face FACE, or nil if it is unspecified.\n\
+If the optional argument FRAME is given, report on face FACE in that frame.\n\
+If FRAME is t, report on the defaults for face FACE (for new frames).\n\
+ The font default for a face is either nil, or a list\n\
+ of the form (bold), (italic) or (bold italic).\n\
+If FRAME is omitted or nil, use the selected frame.")
+ (face, frame)
+ Lisp_Object face, frame;
+{
+ if (EQ (frame, Qt))
+ {
+ Lisp_Object result = Qnil;
+ Lisp_Object lface = lface_from_face_name (NULL, face, 1);
+
+ if (!UNSPECIFIEDP (LFACE_WEIGHT (lface))
+ && !EQ (LFACE_WEIGHT (lface), Qnormal))
+ result = Fcons (Qbold, result);
+
+ if (!UNSPECIFIEDP (LFACE_SLANT (lface))
+ && !EQ (LFACE_SLANT (lface), Qnormal))
+ result = Fcons (Qitalic, result);
+
+ return result;
+ }
+ else
+ {
+ struct frame *f = frame_or_selected_frame (frame, 1);
+ int face_id = lookup_named_face (f, face, 0);
+ struct face *face = FACE_FROM_ID (f, face_id);
+ return face ? build_string (face->font_name) : Qnil;
+ }
+}
+
+
+/* Compare face vectors V1 and V2 for equality. Value is non-zero if
+ all attributes are `equal'. Tries to be fast because this function
+ is called quite often. */
+
+static INLINE int
+lface_equal_p (v1, v2)
+ Lisp_Object *v1, *v2;
+{
+ int i, equal_p = 1;
+
+ for (i = 1; i < LFACE_VECTOR_SIZE && equal_p; ++i)
+ {
+ Lisp_Object a = v1[i];
+ Lisp_Object b = v2[i];
+
+ /* Type can differ, e.g. when one attribute is unspecified, i.e. nil,
+ and the other is specified. */
+ equal_p = XTYPE (a) == XTYPE (b);
+ if (!equal_p)
+ break;
+
+ if (!EQ (a, b))
+ {
+ switch (XTYPE (a))
+ {
+ case Lisp_String:
+ equal_p = ((STRING_BYTES (XSTRING (a))
+ == STRING_BYTES (XSTRING (b)))
+ && bcmp (XSTRING (a)->data, XSTRING (b)->data,
+ STRING_BYTES (XSTRING (a))) == 0);
+ break;
+
+ case Lisp_Int:
+ case Lisp_Symbol:
+ equal_p = 0;
+ break;
+
+ default:
+ equal_p = !NILP (Fequal (a, b));
+ break;
+ }
+ }
+ }
+
+ return equal_p;
+}
+
+
+DEFUN ("internal-lisp-face-equal-p", Finternal_lisp_face_equal_p,
+ Sinternal_lisp_face_equal_p, 2, 3, 0,
+ "True if FACE1 and FACE2 are equal.\n\
+If the optional argument FRAME is given, report on face FACE in that frame.\n\
+If FRAME is t, report on the defaults for face FACE (for new frames).\n\
+If FRAME is omitted or nil, use the selected frame.")
+ (face1, face2, frame)
+ Lisp_Object face1, face2, frame;
+{
+ int equal_p;
+ struct frame *f;
+ Lisp_Object lface1, lface2;
+
+ if (EQ (frame, Qt))
+ f = NULL;
+ else
+ /* Don't use check_x_frame here because this function is called
+ before X frames exist. At that time, if FRAME is nil,
+ selected_frame will be used which is the frame dumped with
+ Emacs. That frame is not an X frame. */
+ f = frame_or_selected_frame (frame, 2);
+
+ lface1 = lface_from_face_name (NULL, face1, 1);
+ lface2 = lface_from_face_name (NULL, face2, 1);
+ equal_p = lface_equal_p (XVECTOR (lface1)->contents,
+ XVECTOR (lface2)->contents);
+ return equal_p ? Qt : Qnil;
+}
+
+
+DEFUN ("internal-lisp-face-empty-p", Finternal_lisp_face_empty_p,
+ Sinternal_lisp_face_empty_p, 1, 2, 0,
+ "True if FACE has no attribute specified.\n\
+If the optional argument FRAME is given, report on face FACE in that frame.\n\
+If FRAME is t, report on the defaults for face FACE (for new frames).\n\
+If FRAME is omitted or nil, use the selected frame.")
+ (face, frame)
+ Lisp_Object face, frame;
+{
+ struct frame *f;
+ Lisp_Object lface;
+ int i;
+
+ if (NILP (frame))
+ frame = selected_frame;
+ CHECK_LIVE_FRAME (frame, 0);
+ f = XFRAME (frame);
+
+ if (EQ (frame, Qt))
+ lface = lface_from_face_name (NULL, face, 1);
+ else
+ lface = lface_from_face_name (f, face, 1);
+
+ for (i = 1; i < LFACE_VECTOR_SIZE; ++i)
+ if (!UNSPECIFIEDP (AREF (lface, i)))
+ break;
+
+ return i == LFACE_VECTOR_SIZE ? Qt : Qnil;
+}
+
+
+DEFUN ("frame-face-alist", Fframe_face_alist, Sframe_face_alist,
+ 0, 1, 0,
+ "Return an alist of frame-local faces defined on FRAME.\n\
+For internal use only.")
+ (frame)
+ Lisp_Object frame;
+{
+ struct frame *f = frame_or_selected_frame (frame, 0);
+ return f->face_alist;
+}
+
+
+/* Return a hash code for Lisp string STRING with case ignored. Used
+ below in computing a hash value for a Lisp face. */
+
+static INLINE unsigned
+hash_string_case_insensitive (string)
+ Lisp_Object string;
+{
+ unsigned char *s;
+ unsigned hash = 0;
+ xassert (STRINGP (string));
+ for (s = XSTRING (string)->data; *s; ++s)
+ hash = (hash << 1) ^ tolower (*s);
+ return hash;
+}
+
+
+/* Return a hash code for face attribute vector V. */
+
+static INLINE unsigned
+lface_hash (v)
+ Lisp_Object *v;
+{
+ return (hash_string_case_insensitive (v[LFACE_FAMILY_INDEX])
+ ^ hash_string_case_insensitive (v[LFACE_FOREGROUND_INDEX])
+ ^ hash_string_case_insensitive (v[LFACE_BACKGROUND_INDEX])
+ ^ XFASTINT (v[LFACE_WEIGHT_INDEX])
+ ^ XFASTINT (v[LFACE_SLANT_INDEX])
+ ^ XFASTINT (v[LFACE_SWIDTH_INDEX])
+ ^ XFASTINT (v[LFACE_HEIGHT_INDEX]));
+}
+
+
+/* Return non-zero if LFACE1 and LFACE2 specify the same font (without
+ considering charsets/registries). They do if they specify the same
+ family, point size, weight, width, slant, and fontset. Both LFACE1
+ and LFACE2 must be fully-specified. */
+
+static INLINE int
+lface_same_font_attributes_p (lface1, lface2)
+ Lisp_Object *lface1, *lface2;
+{
+ xassert (lface_fully_specified_p (lface1)
+ && lface_fully_specified_p (lface2));
+ return (xstricmp (XSTRING (lface1[LFACE_FAMILY_INDEX])->data,
+ XSTRING (lface2[LFACE_FAMILY_INDEX])->data) == 0
+ && EQ (lface1[LFACE_HEIGHT_INDEX], lface2[LFACE_HEIGHT_INDEX])
+ && EQ (lface1[LFACE_SWIDTH_INDEX], lface2[LFACE_SWIDTH_INDEX])
+ && EQ (lface1[LFACE_AVGWIDTH_INDEX], lface2[LFACE_AVGWIDTH_INDEX])
+ && EQ (lface1[LFACE_WEIGHT_INDEX], lface2[LFACE_WEIGHT_INDEX])
+ && EQ (lface1[LFACE_SLANT_INDEX], lface2[LFACE_SLANT_INDEX])
+ && (EQ (lface1[LFACE_FONT_INDEX], lface2[LFACE_FONT_INDEX])
+ || (STRINGP (lface1[LFACE_FONT_INDEX])
+ && STRINGP (lface2[LFACE_FONT_INDEX])
+ && xstricmp (XSTRING (lface1[LFACE_FONT_INDEX])->data,
+ XSTRING (lface2[LFACE_FONT_INDEX])->data))));
+}
+
+
+\f
+/***********************************************************************
+ Realized Faces
+ ***********************************************************************/
+
+/* Allocate and return a new realized face for Lisp face attribute
+ vector ATTR. */
+
+static struct face *
+make_realized_face (attr)
+ Lisp_Object *attr;
+{
+ struct face *face = (struct face *) xmalloc (sizeof *face);
+ bzero (face, sizeof *face);
+ face->ascii_face = face;
+ bcopy (attr, face->lface, sizeof face->lface);
+ return face;
+}
+
+
+/* Free realized face FACE, including its X resources. FACE may
+ be null. */
+
+static void
+free_realized_face (f, face)
+ struct frame *f;
+ struct face *face;
+{
+ if (face)
+ {
+#ifdef HAVE_WINDOW_SYSTEM
+ if (FRAME_WINDOW_P (f))
+ {
+ /* Free fontset of FACE if it is ASCII face. */
+ if (face->fontset >= 0 && face == face->ascii_face)
+ free_face_fontset (f, face);
+ if (face->gc)
+ {
+ x_free_gc (f, face->gc);
+ face->gc = 0;
+ }
+
+ free_face_colors (f, face);
+ x_destroy_bitmap (f, face->stipple);
+ }
+#endif /* HAVE_WINDOW_SYSTEM */
+
+ xfree (face);
+ }
+}
+
+
+/* Prepare face FACE for subsequent display on frame F. This
+ allocated GCs if they haven't been allocated yet or have been freed
+ by clearing the face cache. */
+
+void
+prepare_face_for_display (f, face)
+ struct frame *f;
+ struct face *face;
+{
+#ifdef HAVE_WINDOW_SYSTEM
+ xassert (FRAME_WINDOW_P (f));
+
+ if (face->gc == 0)
+ {
+ XGCValues xgcv;
+ unsigned long mask = GCForeground | GCBackground | GCGraphicsExposures;
+
+ xgcv.foreground = face->foreground;
+ xgcv.background = face->background;
+#ifdef HAVE_X_WINDOWS
+ xgcv.graphics_exposures = False;
+#endif
+ /* The font of FACE may be null if we couldn't load it. */
+ if (face->font)
+ {
+#ifdef HAVE_X_WINDOWS
+ xgcv.font = face->font->fid;
+#endif
+#ifdef WINDOWSNT
+ xgcv.font = face->font;
+#endif
+#ifdef macintosh
+ xgcv.font = face->font;
+#endif
+ mask |= GCFont;
+ }
+
+ BLOCK_INPUT;
+#ifdef HAVE_X_WINDOWS
+ if (face->stipple)
+ {
+ xgcv.fill_style = FillOpaqueStippled;
+ xgcv.stipple = x_bitmap_pixmap (f, face->stipple);
+ mask |= GCFillStyle | GCStipple;
+ }
+#endif
+ face->gc = x_create_gc (f, mask, &xgcv);
+ UNBLOCK_INPUT;
+ }
+#endif /* HAVE_WINDOW_SYSTEM */
+}
+
+\f
+/***********************************************************************
+ Face Cache
+ ***********************************************************************/
+
+/* Return a new face cache for frame F. */
+
+static struct face_cache *
+make_face_cache (f)
+ struct frame *f;
+{
+ struct face_cache *c;
+ int size;
+
+ c = (struct face_cache *) xmalloc (sizeof *c);
+ bzero (c, sizeof *c);
+ size = FACE_CACHE_BUCKETS_SIZE * sizeof *c->buckets;
+ c->buckets = (struct face **) xmalloc (size);
+ bzero (c->buckets, size);
+ c->size = 50;
+ c->faces_by_id = (struct face **) xmalloc (c->size * sizeof *c->faces_by_id);
+ c->f = f;
+ c->menu_face_changed_p = menu_face_changed_default;
+ return c;
+}
+
+
+/* Clear out all graphics contexts for all realized faces, except for
+ the basic faces. This should be done from time to time just to avoid
+ keeping too many graphics contexts that are no longer needed. */
+
+static void
+clear_face_gcs (c)
+ struct face_cache *c;
+{
+ if (c && FRAME_WINDOW_P (c->f))
+ {
+#ifdef HAVE_WINDOW_SYSTEM
+ int i;
+ for (i = BASIC_FACE_ID_SENTINEL; i < c->used; ++i)
+ {
+ struct face *face = c->faces_by_id[i];
+ if (face && face->gc)
+ {
+ x_free_gc (c->f, face->gc);
+ face->gc = 0;
+ }
+ }
+#endif /* HAVE_WINDOW_SYSTEM */
+ }
+}
+
+
+/* Free all realized faces in face cache C, including basic faces. C
+ may be null. If faces are freed, make sure the frame's current
+ matrix is marked invalid, so that a display caused by an expose
+ event doesn't try to use faces we destroyed. */
+
+static void
+free_realized_faces (c)
+ struct face_cache *c;
+{
+ if (c && c->used)
+ {
+ int i, size;
+ struct frame *f = c->f;
+
+ /* We must block input here because we can't process X events
+ safely while only some faces are freed, or when the frame's
+ current matrix still references freed faces. */
+ BLOCK_INPUT;
+
+ for (i = 0; i < c->used; ++i)
+ {
+ free_realized_face (f, c->faces_by_id[i]);
+ c->faces_by_id[i] = NULL;
+ }
+
+ c->used = 0;
+ size = FACE_CACHE_BUCKETS_SIZE * sizeof *c->buckets;
+ bzero (c->buckets, size);
+
+ /* Must do a thorough redisplay the next time. Mark current
+ matrices as invalid because they will reference faces freed
+ above. This function is also called when a frame is
+ destroyed. In this case, the root window of F is nil. */
+ if (WINDOWP (f->root_window))
+ {
+ clear_current_matrices (f);
+ ++windows_or_buffers_changed;
+ }
+
+ UNBLOCK_INPUT;
+ }
+}
+
+
+/* Free all faces realized for multibyte characters on frame F that
+ has FONTSET. */
+
+void
+free_realized_multibyte_face (f, fontset)
+ struct frame *f;
+ int fontset;
+{
+ struct face_cache *cache = FRAME_FACE_CACHE (f);
+ struct face *face;
+ int i;
+
+ /* We must block input here because we can't process X events safely
+ while only some faces are freed, or when the frame's current
+ matrix still references freed faces. */
+ BLOCK_INPUT;
+
+ for (i = 0; i < cache->used; i++)
+ {
+ face = cache->faces_by_id[i];
+ if (face
+ && face != face->ascii_face
+ && face->fontset == fontset)
+ {
+ uncache_face (cache, face);
+ free_realized_face (f, face);
+ }
+ }
+
+ /* Must do a thorough redisplay the next time. Mark current
+ matrices as invalid because they will reference faces freed
+ above. This function is also called when a frame is destroyed.
+ In this case, the root window of F is nil. */
+ if (WINDOWP (f->root_window))
+ {
+ clear_current_matrices (f);
+ ++windows_or_buffers_changed;
+ }
+
+ UNBLOCK_INPUT;
+}
+
+
+/* Free all realized faces on FRAME or on all frames if FRAME is nil.
+ This is done after attributes of a named face have been changed,
+ because we can't tell which realized faces depend on that face. */
+
+void
+free_all_realized_faces (frame)
+ Lisp_Object frame;
+{
+ if (NILP (frame))
+ {
+ Lisp_Object rest;
+ FOR_EACH_FRAME (rest, frame)
+ free_realized_faces (FRAME_FACE_CACHE (XFRAME (frame)));
+ }
+ else
+ free_realized_faces (FRAME_FACE_CACHE (XFRAME (frame)));
+}
+
+
+/* Free face cache C and faces in it, including their X resources. */
+
+static void
+free_face_cache (c)
+ struct face_cache *c;
+{
+ if (c)
+ {
+ free_realized_faces (c);
+ xfree (c->buckets);
+ xfree (c->faces_by_id);
+ xfree (c);
+ }
+}
+
+
+/* Cache realized face FACE in face cache C. HASH is the hash value
+ of FACE. If FACE->fontset >= 0, add the new face to the end of the
+ collision list of the face hash table of C. This is done because
+ otherwise lookup_face would find FACE for every character, even if
+ faces with the same attributes but for specific characters exist. */
+
+static void
+cache_face (c, face, hash)
+ struct face_cache *c;
+ struct face *face;
+ unsigned hash;
+{
+ int i = hash % FACE_CACHE_BUCKETS_SIZE;
+
+ face->hash = hash;
+
+ if (face->fontset >= 0)
+ {
+ struct face *last = c->buckets[i];
+ if (last)
+ {
+ while (last->next)
+ last = last->next;
+ last->next = face;
+ face->prev = last;
+ face->next = NULL;
+ }
+ else
+ {
+ c->buckets[i] = face;
+ face->prev = face->next = NULL;
+ }
+ }
+ else
+ {
+ face->prev = NULL;
+ face->next = c->buckets[i];
+ if (face->next)
+ face->next->prev = face;
+ c->buckets[i] = face;
+ }
+
+ /* Find a free slot in C->faces_by_id and use the index of the free
+ slot as FACE->id. */
+ for (i = 0; i < c->used; ++i)
+ if (c->faces_by_id[i] == NULL)
+ break;
+ face->id = i;
+
+ /* Maybe enlarge C->faces_by_id. */
+ if (i == c->used && c->used == c->size)
+ {
+ int new_size = 2 * c->size;
+ int sz = new_size * sizeof *c->faces_by_id;
+ c->faces_by_id = (struct face **) xrealloc (c->faces_by_id, sz);
+ c->size = new_size;
+ }
+
+#if GLYPH_DEBUG
+ /* Check that FACE got a unique id. */
+ {
+ int j, n;
+ struct face *face;
+
+ for (j = n = 0; j < FACE_CACHE_BUCKETS_SIZE; ++j)
+ for (face = c->buckets[j]; face; face = face->next)
+ if (face->id == i)
+ ++n;
+
+ xassert (n == 1);
+ }
+#endif /* GLYPH_DEBUG */
+
+ c->faces_by_id[i] = face;
+ if (i == c->used)
+ ++c->used;
+}
+
+
+/* Remove face FACE from cache C. */
+
+static void
+uncache_face (c, face)
+ struct face_cache *c;
+ struct face *face;
+{
+ int i = face->hash % FACE_CACHE_BUCKETS_SIZE;
+
+ if (face->prev)
+ face->prev->next = face->next;
+ else
+ c->buckets[i] = face->next;
+
+ if (face->next)
+ face->next->prev = face->prev;
+
+ c->faces_by_id[face->id] = NULL;
+ if (face->id == c->used)
+ --c->used;
+}
+
+
+/* Look up a realized face with face attributes ATTR in the face cache
+ of frame F. The face will be used to display character C. Value
+ is the ID of the face found. If no suitable face is found, realize
+ a new one. In that case, if C is a multibyte character, BASE_FACE
+ is a face that has the same attributes. */
+
+INLINE int
+lookup_face (f, attr, c, base_face)
+ struct frame *f;
+ Lisp_Object *attr;
+ int c;
+ struct face *base_face;
+{
+ struct face_cache *cache = FRAME_FACE_CACHE (f);
+ unsigned hash;
+ int i;
+ struct face *face;
+
+ xassert (cache != NULL);
+ check_lface_attrs (attr);
+
+ /* Look up ATTR in the face cache. */
+ hash = lface_hash (attr);
+ i = hash % FACE_CACHE_BUCKETS_SIZE;
+
+ for (face = cache->buckets[i]; face; face = face->next)
+ if (face->hash == hash
+ && (!FRAME_WINDOW_P (f)
+ || FACE_SUITABLE_FOR_CHAR_P (face, c))
+ && lface_equal_p (face->lface, attr))
+ break;
+
+ /* If not found, realize a new face. */
+ if (face == NULL)
+ face = realize_face (cache, attr, c, base_face, -1);
+
+#if GLYPH_DEBUG
+ xassert (face == FACE_FROM_ID (f, face->id));
+
+/* When this function is called from face_for_char (in this case, C is
+ a multibyte character), a fontset of a face returned by
+ realize_face is not yet set, i.e. FACE_SUITABLE_FOR_CHAR_P (FACE,
+ C) is not sutisfied. The fontset is set for this face by
+ face_for_char later. */
+#if 0
+ if (FRAME_WINDOW_P (f))
+ xassert (FACE_SUITABLE_FOR_CHAR_P (face, c));
+#endif
+#endif /* GLYPH_DEBUG */
+
+ return face->id;
+}
+
+
+/* Return the face id of the realized face for named face SYMBOL on
+ frame F suitable for displaying character C. Value is -1 if the
+ face couldn't be determined, which might happen if the default face
+ isn't realized and cannot be realized. */
+
+int
+lookup_named_face (f, symbol, c)
+ struct frame *f;
+ Lisp_Object symbol;
+ int c;
+{
+ Lisp_Object attrs[LFACE_VECTOR_SIZE];
+ Lisp_Object symbol_attrs[LFACE_VECTOR_SIZE];
+ struct face *default_face = FACE_FROM_ID (f, DEFAULT_FACE_ID);
+
+ if (default_face == NULL)
+ {
+ if (!realize_basic_faces (f))
+ return -1;
+ default_face = FACE_FROM_ID (f, DEFAULT_FACE_ID);
+ }
+
+ get_lface_attributes (f, symbol, symbol_attrs, 1);
+ bcopy (default_face->lface, attrs, sizeof attrs);
+ merge_face_vectors (f, symbol_attrs, attrs, Qnil);
+ return lookup_face (f, attrs, c, NULL);
+}
+
+
+/* Return the ID of the realized ASCII face of Lisp face with ID
+ LFACE_ID on frame F. Value is -1 if LFACE_ID isn't valid. */
+
+int
+ascii_face_of_lisp_face (f, lface_id)
+ struct frame *f;
+ int lface_id;
+{
+ int face_id;
+
+ if (lface_id >= 0 && lface_id < lface_id_to_name_size)
+ {
+ Lisp_Object face_name = lface_id_to_name[lface_id];
+ face_id = lookup_named_face (f, face_name, 0);
+ }
+ else
+ face_id = -1;
+
+ return face_id;
+}
+
+
+/* Return a face for charset ASCII that is like the face with id
+ FACE_ID on frame F, but has a font that is STEPS steps smaller.
+ STEPS < 0 means larger. Value is the id of the face. */
+
+int
+smaller_face (f, face_id, steps)
+ struct frame *f;
+ int face_id, steps;
+{
+#ifdef HAVE_WINDOW_SYSTEM
+ struct face *face;
+ Lisp_Object attrs[LFACE_VECTOR_SIZE];
+ int pt, last_pt, last_height;
+ int delta;
+ int new_face_id;
+ struct face *new_face;
+
+ /* If not called for an X frame, just return the original face. */
+ if (FRAME_TERMCAP_P (f))
+ return face_id;
+
+ /* Try in increments of 1/2 pt. */
+ delta = steps < 0 ? 5 : -5;
+ steps = abs (steps);
+
+ face = FACE_FROM_ID (f, face_id);
+ bcopy (face->lface, attrs, sizeof attrs);
+ pt = last_pt = XFASTINT (attrs[LFACE_HEIGHT_INDEX]);
+ new_face_id = face_id;
+ last_height = FONT_HEIGHT (face->font);
+
+ while (steps
+ && pt + delta > 0
+ /* Give up if we cannot find a font within 10pt. */
+ && abs (last_pt - pt) < 100)
+ {
+ /* Look up a face for a slightly smaller/larger font. */
+ pt += delta;
+ attrs[LFACE_HEIGHT_INDEX] = make_number (pt);
+ new_face_id = lookup_face (f, attrs, 0, NULL);
+ new_face = FACE_FROM_ID (f, new_face_id);
+
+ /* If height changes, count that as one step. */
+ if ((delta < 0 && FONT_HEIGHT (new_face->font) < last_height)
+ || (delta > 0 && FONT_HEIGHT (new_face->font) > last_height))
+ {
+ --steps;
+ last_height = FONT_HEIGHT (new_face->font);
+ last_pt = pt;
+ }
+ }
+
+ return new_face_id;
+
+#else /* not HAVE_WINDOW_SYSTEM */
+
+ return face_id;
+
+#endif /* not HAVE_WINDOW_SYSTEM */
+}
+
+
+/* Return a face for charset ASCII that is like the face with id
+ FACE_ID on frame F, but has height HEIGHT. */
+
+int
+face_with_height (f, face_id, height)
+ struct frame *f;
+ int face_id;
+ int height;
+{
+#ifdef HAVE_WINDOW_SYSTEM
+ struct face *face;
+ Lisp_Object attrs[LFACE_VECTOR_SIZE];
+
+ if (FRAME_TERMCAP_P (f)
+ || height <= 0)
+ return face_id;
+
+ face = FACE_FROM_ID (f, face_id);
+ bcopy (face->lface, attrs, sizeof attrs);
+ attrs[LFACE_HEIGHT_INDEX] = make_number (height);
+ face_id = lookup_face (f, attrs, 0, NULL);
+#endif /* HAVE_WINDOW_SYSTEM */
+
+ return face_id;
+}
+
+
+/* Return the face id of the realized face for named face SYMBOL on
+ frame F suitable for displaying character C, and use attributes of
+ the face FACE_ID for attributes that aren't completely specified by
+ SYMBOL. This is like lookup_named_face, except that the default
+ attributes come from FACE_ID, not from the default face. FACE_ID
+ is assumed to be already realized. */
+
+int
+lookup_derived_face (f, symbol, c, face_id)
+ struct frame *f;
+ Lisp_Object symbol;
+ int c;
+ int face_id;
+{
+ Lisp_Object attrs[LFACE_VECTOR_SIZE];
+ Lisp_Object symbol_attrs[LFACE_VECTOR_SIZE];
+ struct face *default_face = FACE_FROM_ID (f, face_id);
+
+ if (!default_face)
+ abort ();
+
+ get_lface_attributes (f, symbol, symbol_attrs, 1);
+ bcopy (default_face->lface, attrs, sizeof attrs);
+ merge_face_vectors (f, symbol_attrs, attrs, Qnil);
+ return lookup_face (f, attrs, c, default_face);
+}
+
+
+\f
+/***********************************************************************
+ Font selection
+ ***********************************************************************/
+
+DEFUN ("internal-set-font-selection-order",
+ Finternal_set_font_selection_order,
+ Sinternal_set_font_selection_order, 1, 1, 0,
+ "Set font selection order for face font selection to ORDER.\n\
+ORDER must be a list of length 4 containing the symbols `:width',\n\
+`:height', `:weight', and `:slant'. Face attributes appearing\n\
+first in ORDER are matched first, e.g. if `:height' appears before\n\
+`:weight' in ORDER, font selection first tries to find a font with\n\
+a suitable height, and then tries to match the font weight.\n\
+Value is ORDER.")
+ (order)
+ Lisp_Object order;
+{
+ Lisp_Object list;
+ int i;
+ int indices[DIM (font_sort_order)];
+
+ CHECK_LIST (order, 0);
+ bzero (indices, sizeof indices);
+ i = 0;
+
+ for (list = order;
+ CONSP (list) && i < DIM (indices);
+ list = XCDR (list), ++i)
+ {
+ Lisp_Object attr = XCAR (list);
+ int xlfd;
+
+ if (EQ (attr, QCwidth))
+ xlfd = XLFD_SWIDTH;
+ else if (EQ (attr, QCheight))
+ xlfd = XLFD_POINT_SIZE;
+ else if (EQ (attr, QCweight))
+ xlfd = XLFD_WEIGHT;
+ else if (EQ (attr, QCslant))
+ xlfd = XLFD_SLANT;
+ else
+ break;
+
+ if (indices[i] != 0)
+ break;
+ indices[i] = xlfd;
+ }
+
+ if (!NILP (list) || i != DIM (indices))
+ signal_error ("Invalid font sort order", order);
+ for (i = 0; i < DIM (font_sort_order); ++i)
+ if (indices[i] == 0)
+ signal_error ("Invalid font sort order", order);
+
+ if (bcmp (indices, font_sort_order, sizeof indices) != 0)
+ {
+ bcopy (indices, font_sort_order, sizeof font_sort_order);
+ free_all_realized_faces (Qnil);
+ }
+
+ return Qnil;
+}
+
+
+DEFUN ("internal-set-alternative-font-family-alist",
+ Finternal_set_alternative_font_family_alist,
+ Sinternal_set_alternative_font_family_alist, 1, 1, 0,
+ "Define alternative font families to try in face font selection.\n\
+ALIST is an alist of (FAMILY ALTERNATIVE1 ALTERNATIVE2 ...) entries.\n\
+Each ALTERNATIVE is tried in order if no fonts of font family FAMILY can\n\
+be found. Value is ALIST.")
+ (alist)
+ Lisp_Object alist;
+{
+ CHECK_LIST (alist, 0);
+ Vface_alternative_font_family_alist = alist;
+ free_all_realized_faces (Qnil);
+ return alist;
+}
+
+
+DEFUN ("internal-set-alternative-font-registry-alist",
+ Finternal_set_alternative_font_registry_alist,
+ Sinternal_set_alternative_font_registry_alist, 1, 1, 0,
+ "Define alternative font registries to try in face font selection.\n\
+ALIST is an alist of (REGISTRY ALTERNATIVE1 ALTERNATIVE2 ...) entries.\n\
+Each ALTERNATIVE is tried in order if no fonts of font registry REGISTRY can\n\
+be found. Value is ALIST.")
+ (alist)
+ Lisp_Object alist;
+{
+ CHECK_LIST (alist, 0);
+ Vface_alternative_font_registry_alist = alist;
+ free_all_realized_faces (Qnil);
+ return alist;
+}
+
+
+#ifdef HAVE_WINDOW_SYSTEM
+
+/* Value is non-zero if FONT is the name of a scalable font. The
+ X11R6 XLFD spec says that point size, pixel size, and average width
+ are zero for scalable fonts. Intlfonts contain at least one
+ scalable font ("*-muleindian-1") for which this isn't true, so we
+ just test average width. */
+
+static int
+font_scalable_p (font)
+ struct font_name *font;
+{
+ char *s = font->fields[XLFD_AVGWIDTH];
+ return (*s == '0' && *(s + 1) == '\0')
+#ifdef WINDOWSNT
+ /* Windows implementation of XLFD is slightly broken for backward
+ compatibility with previous broken versions, so test for
+ wildcards as well as 0. */
+ || *s == '*'
+#endif
+ ;
+}
+
+
+/* Ignore the difference of font point size less than this value. */
+
+#define FONT_POINT_SIZE_QUANTUM 5
+
+/* Value is non-zero if FONT1 is a better match for font attributes
+ VALUES than FONT2. VALUES is an array of face attribute values in
+ font sort order. COMPARE_PT_P zero means don't compare point
+ sizes. AVGWIDTH, if not zero, is a specified font average width
+ to compare with. */
+
+static int
+better_font_p (values, font1, font2, compare_pt_p, avgwidth)
+ int *values;
+ struct font_name *font1, *font2;
+ int compare_pt_p, avgwidth;
+{
+ int i;
+
+ for (i = 0; i < DIM (font_sort_order); ++i)
+ {
+ int xlfd_idx = font_sort_order[i];
+
+ if (compare_pt_p || xlfd_idx != XLFD_POINT_SIZE)
+ {
+ int delta1 = abs (values[i] - font1->numeric[xlfd_idx]);
+ int delta2 = abs (values[i] - font2->numeric[xlfd_idx]);
+
+ if (xlfd_idx == XLFD_POINT_SIZE
+ && abs (delta1 - delta2) < FONT_POINT_SIZE_QUANTUM)
+ continue;
+ if (delta1 > delta2)
+ return 0;
+ else if (delta1 < delta2)
+ return 1;
+ else
+ {
+ /* The difference may be equal because, e.g., the face
+ specifies `italic' but we have only `regular' and
+ `oblique'. Prefer `oblique' in this case. */
+ if ((xlfd_idx == XLFD_WEIGHT || xlfd_idx == XLFD_SLANT)
+ && font1->numeric[xlfd_idx] > values[i]
+ && font2->numeric[xlfd_idx] < values[i])
+ return 1;
+ }
+ }
+ }
+
+ if (avgwidth)
+ {
+ int delta1 = abs (avgwidth - font1->numeric[XLFD_AVGWIDTH]);
+ int delta2 = abs (avgwidth - font2->numeric[XLFD_AVGWIDTH]);
+ if (delta1 > delta2)
+ return 0;
+ else if (delta1 < delta2)
+ return 1;
+ }
+
+ return font1->registry_priority < font2->registry_priority;
+}
+
+
+/* Value is non-zero if FONT is an exact match for face attributes in
+ SPECIFIED. SPECIFIED is an array of face attribute values in font
+ sort order. AVGWIDTH, if non-zero, is an average width to compare
+ with. */
+
+static int
+exact_face_match_p (specified, font, avgwidth)
+ int *specified;
+ struct font_name *font;
+ int avgwidth;
+{
+ int i;
+
+ for (i = 0; i < DIM (font_sort_order); ++i)
+ if (specified[i] != font->numeric[font_sort_order[i]])
+ break;
+
+ return (i == DIM (font_sort_order)
+ && (avgwidth <= 0
+ || avgwidth == font->numeric[XLFD_AVGWIDTH]));
+}
+
+
+/* Value is the name of a scaled font, generated from scalable font
+ FONT on frame F. SPECIFIED_PT is the point-size to scale FONT to.
+ Value is allocated from heap. */
+
+static char *
+build_scalable_font_name (f, font, specified_pt)
+ struct frame *f;
+ struct font_name *font;
+ int specified_pt;
+{
+ char point_size[20], pixel_size[20];
+ int pixel_value;
+ double resy = FRAME_X_DISPLAY_INFO (f)->resy;
+ double pt;
+
+ /* If scalable font is for a specific resolution, compute
+ the point size we must specify from the resolution of
+ the display and the specified resolution of the font. */
+ if (font->numeric[XLFD_RESY] != 0)
+ {
+ pt = resy / font->numeric[XLFD_RESY] * specified_pt + 0.5;
+ pixel_value = font->numeric[XLFD_RESY] / (PT_PER_INCH * 10.0) * pt;
+ }
+ else
+ {
+ pt = specified_pt;
+ pixel_value = resy / (PT_PER_INCH * 10.0) * pt;
+ }
+
+ /* Set point size of the font. */
+ sprintf (point_size, "%d", (int) pt);
+ font->fields[XLFD_POINT_SIZE] = point_size;
+ font->numeric[XLFD_POINT_SIZE] = pt;
+
+ /* Set pixel size. */
+ sprintf (pixel_size, "%d", pixel_value);
+ font->fields[XLFD_PIXEL_SIZE] = pixel_size;
+ font->numeric[XLFD_PIXEL_SIZE] = pixel_value;
+
+ /* If font doesn't specify its resolution, use the
+ resolution of the display. */
+ if (font->numeric[XLFD_RESY] == 0)
+ {
+ char buffer[20];
+ sprintf (buffer, "%d", (int) resy);
+ font->fields[XLFD_RESY] = buffer;
+ font->numeric[XLFD_RESY] = resy;
+ }
+
+ if (strcmp (font->fields[XLFD_RESX], "0") == 0)
+ {
+ char buffer[20];
+ int resx = FRAME_X_DISPLAY_INFO (f)->resx;
+ sprintf (buffer, "%d", resx);
+ font->fields[XLFD_RESX] = buffer;
+ font->numeric[XLFD_RESX] = resx;
+ }
+
+ return build_font_name (font);
+}
+
+
+/* Value is non-zero if we are allowed to use scalable font FONT. We
+ can't run a Lisp function here since this function may be called
+ with input blocked. */
+
+static int
+may_use_scalable_font_p (font)
+ char *font;
+{
+ if (EQ (Vscalable_fonts_allowed, Qt))
+ return 1;
+ else if (CONSP (Vscalable_fonts_allowed))
+ {
+ Lisp_Object tail, regexp;
+
+ for (tail = Vscalable_fonts_allowed; CONSP (tail); tail = XCDR (tail))
+ {
+ regexp = XCAR (tail);
+ if (STRINGP (regexp)
+ && fast_c_string_match_ignore_case (regexp, font) >= 0)
+ return 1;
+ }
+ }
+
+ return 0;
+}
+
+
+
+/* Return the name of the best matching font for face attributes ATTRS
+ in the array of font_name structures FONTS which contains NFONTS
+ elements. WIDTH_RATIO is a factor with which to multiply average
+ widths if ATTRS specifies such a width.
+
+ Value is a font name which is allocated from the heap. FONTS is
+ freed by this function. */
+
+static char *
+best_matching_font (f, attrs, fonts, nfonts, width_ratio)
+ struct frame *f;
+ Lisp_Object *attrs;
+ struct font_name *fonts;
+ int nfonts;
+ int width_ratio;
+{
+ char *font_name;
+ struct font_name *best;
+ int i, pt = 0;
+ int specified[5];
+ int exact_p, avgwidth;
+
+ if (nfonts == 0)
+ return NULL;
+
+ /* Make specified font attributes available in `specified',
+ indexed by sort order. */
+ for (i = 0; i < DIM (font_sort_order); ++i)
+ {
+ int xlfd_idx = font_sort_order[i];
+
+ if (xlfd_idx == XLFD_SWIDTH)
+ specified[i] = face_numeric_swidth (attrs[LFACE_SWIDTH_INDEX]);
+ else if (xlfd_idx == XLFD_POINT_SIZE)
+ specified[i] = pt = XFASTINT (attrs[LFACE_HEIGHT_INDEX]);
+ else if (xlfd_idx == XLFD_WEIGHT)
+ specified[i] = face_numeric_weight (attrs[LFACE_WEIGHT_INDEX]);
+ else if (xlfd_idx == XLFD_SLANT)
+ specified[i] = face_numeric_slant (attrs[LFACE_SLANT_INDEX]);
+ else
+ abort ();
+ }
+
+ avgwidth = (UNSPECIFIEDP (attrs[LFACE_AVGWIDTH_INDEX])
+ ? 0
+ : XFASTINT (attrs[LFACE_AVGWIDTH_INDEX]) * width_ratio);
+
+ exact_p = 0;
+
+ /* Start with the first non-scalable font in the list. */
+ for (i = 0; i < nfonts; ++i)
+ if (!font_scalable_p (fonts + i))
+ break;
+
+ /* Find the best match among the non-scalable fonts. */
+ if (i < nfonts)
+ {
+ best = fonts + i;
+
+ for (i = 1; i < nfonts; ++i)
+ if (!font_scalable_p (fonts + i)
+ && better_font_p (specified, fonts + i, best, 1, avgwidth))
+ {
+ best = fonts + i;
+
+ exact_p = exact_face_match_p (specified, best, avgwidth);
+ if (exact_p)
+ break;
+ }
+
+ }
+ else
+ best = NULL;
+
+ /* Unless we found an exact match among non-scalable fonts, see if
+ we can find a better match among scalable fonts. */
+ if (!exact_p)
+ {
+ /* A scalable font is better if
+
+ 1. its weight, slant, swidth attributes are better, or.
+
+ 2. the best non-scalable font doesn't have the required
+ point size, and the scalable fonts weight, slant, swidth
+ isn't worse. */
+
+ int non_scalable_has_exact_height_p;
+
+ if (best && best->numeric[XLFD_POINT_SIZE] == pt)
+ non_scalable_has_exact_height_p = 1;
+ else
+ non_scalable_has_exact_height_p = 0;
+
+ for (i = 0; i < nfonts; ++i)
+ if (font_scalable_p (fonts + i))
+ {
+ if (best == NULL
+ || better_font_p (specified, fonts + i, best, 0, 0)
+ || (!non_scalable_has_exact_height_p
+ && !better_font_p (specified, best, fonts + i, 0, 0)))
+ best = fonts + i;
+ }
+ }
+
+ if (font_scalable_p (best))
+ font_name = build_scalable_font_name (f, best, pt);
+ else
+ font_name = build_font_name (best);
+
+ /* Free font_name structures. */
+ free_font_names (fonts, nfonts);
+
+ return font_name;
+}
+
+
+/* Get a list of matching fonts on frame F, considering FAMILY
+ and alternative font families from Vface_alternative_font_registry_alist.
+
+ FAMILY is the font family whose alternatives are considered.
+
+ REGISTRY, if a string, specifies a font registry and encoding to
+ match. A value of nil means include fonts of any registry and
+ encoding.
+
+ Return in *FONTS a pointer to a vector of font_name structures for
+ the fonts matched. Value is the number of fonts found. */
+
+static int
+try_alternative_families (f, family, registry, fonts)
+ struct frame *f;
+ Lisp_Object family, registry;
+ struct font_name **fonts;
+{
+ Lisp_Object alter;
+ int nfonts = 0;
+
+ nfonts = font_list (f, Qnil, family, registry, fonts);
+ if (nfonts == 0)
+ {
+ /* Try alternative font families. */
+ alter = Fassoc (family, Vface_alternative_font_family_alist);
+ if (CONSP (alter))
+ {
+ for (alter = XCDR (alter);
+ CONSP (alter) && nfonts == 0;
+ alter = XCDR (alter))
+ {
+ if (STRINGP (XCAR (alter)))
+ nfonts = font_list (f, Qnil, XCAR (alter), registry, fonts);
+ }
+ }
+
+ /* Try scalable fonts before giving up. */
+ if (nfonts == 0 && NILP (Vscalable_fonts_allowed))
+ {
+ int count = BINDING_STACK_SIZE ();
+ specbind (Qscalable_fonts_allowed, Qt);
+ nfonts = try_alternative_families (f, family, registry, fonts);
+ unbind_to (count, Qnil);
+ }
+ }
+ return nfonts;
+}
+
+
+/* Get a list of matching fonts on frame F.
+
+ FAMILY, if a string, specifies a font family derived from the fontset.
+ It is only used if the face does not specify any family in ATTRS or
+ if we cannot find any font of the face's family.
+
+ REGISTRY, if a string, specifies a font registry and encoding to
+ match. A value of nil means include fonts of any registry and
+ encoding.
+
+ Return in *FONTS a pointer to a vector of font_name structures for
+ the fonts matched. Value is the number of fonts found. */
+
+static int
+try_font_list (f, attrs, family, registry, fonts)
+ struct frame *f;
+ Lisp_Object *attrs;
+ Lisp_Object family, registry;
+ struct font_name **fonts;
+{
+ int nfonts = 0;
+ Lisp_Object face_family = attrs[LFACE_FAMILY_INDEX];
+
+ if (STRINGP (face_family))
+ nfonts = try_alternative_families (f, face_family, registry, fonts);
+
+ if (nfonts == 0 && !NILP (family))
+ nfonts = try_alternative_families (f, family, registry, fonts);
+
+ /* Try font family of the default face or "fixed". */
+ if (nfonts == 0)
+ {
+ struct face *default_face = FACE_FROM_ID (f, DEFAULT_FACE_ID);
+ if (default_face)
+ family = default_face->lface[LFACE_FAMILY_INDEX];
+ else
+ family = build_string ("fixed");
+ nfonts = font_list (f, Qnil, family, registry, fonts);
+ }
+
+ /* Try any family with the given registry. */
+ if (nfonts == 0)
+ nfonts = font_list (f, Qnil, Qnil, registry, fonts);
+
+ return nfonts;
+}
+
+
+/* Return the fontset id of the base fontset name or alias name given
+ by the fontset attribute of ATTRS. Value is -1 if the fontset
+ attribute of ATTRS doesn't name a fontset. */
+
+static int
+face_fontset (attrs)
+ Lisp_Object *attrs;
+{
+ Lisp_Object name;
+
+ name = attrs[LFACE_FONT_INDEX];
+ if (!STRINGP (name))
+ return -1;
+ return fs_query_fontset (name, 0);
+}
+
+
+/* Choose a name of font to use on frame F to display character C with
+ Lisp face attributes specified by ATTRS. The font name is
+ determined by the font-related attributes in ATTRS and the name
+ pattern for C in FONTSET. Value is the font name which is
+ allocated from the heap and must be freed by the caller, or NULL if
+ we can get no information about the font name of C. It is assured
+ that we always get some information for a single byte
+ character. */
+
+static char *
+choose_face_font (f, attrs, fontset, c)
+ struct frame *f;
+ Lisp_Object *attrs;
+ int fontset, c;
+{
+ Lisp_Object pattern;
+ char *font_name = NULL;
+ struct font_name *fonts;
+ int nfonts, width_ratio;
+
+ /* Get (foundry and) family name and registry (and encoding) name of
+ a font for C. */
+ pattern = fontset_font_pattern (f, fontset, c);
+ if (NILP (pattern))
+ {
+ xassert (!SINGLE_BYTE_CHAR_P (c));
+ return NULL;
+ }
+
+ /* If what we got is a name pattern, return it. */
+ if (STRINGP (pattern))
+ return xstrdup (XSTRING (pattern)->data);
+
+ /* Get a list of fonts matching that pattern and choose the
+ best match for the specified face attributes from it. */
+ nfonts = try_font_list (f, attrs, XCAR (pattern), XCDR (pattern), &fonts);
+ width_ratio = (SINGLE_BYTE_CHAR_P (c)
+ ? 1
+ : CHARSET_WIDTH (CHAR_CHARSET (c)));
+ font_name = best_matching_font (f, attrs, fonts, nfonts, width_ratio);
+ return font_name;
+}
+
+#endif /* HAVE_WINDOW_SYSTEM */
+
+
+\f
+/***********************************************************************
+ Face Realization
+ ***********************************************************************/
+
+/* Realize basic faces on frame F. Value is zero if frame parameters
+ of F don't contain enough information needed to realize the default
+ face. */
+
+static int
+realize_basic_faces (f)
+ struct frame *f;
+{
+ int success_p = 0;
+ int count = BINDING_STACK_SIZE ();
+
+ /* Block input here so that we won't be surprised by an X expose
+ event, for instance, without having the faces set up. */
+ BLOCK_INPUT;
+ specbind (Qscalable_fonts_allowed, Qt);
+
+ if (realize_default_face (f))
+ {
+ realize_named_face (f, Qmode_line, MODE_LINE_FACE_ID);
+ realize_named_face (f, Qtool_bar, TOOL_BAR_FACE_ID);
+ realize_named_face (f, Qfringe, BITMAP_AREA_FACE_ID);
+ realize_named_face (f, Qheader_line, HEADER_LINE_FACE_ID);
+ realize_named_face (f, Qscroll_bar, SCROLL_BAR_FACE_ID);
+ realize_named_face (f, Qborder, BORDER_FACE_ID);
+ realize_named_face (f, Qcursor, CURSOR_FACE_ID);
+ realize_named_face (f, Qmouse, MOUSE_FACE_ID);
+ realize_named_face (f, Qmenu, MENU_FACE_ID);
+
+ /* Reflect changes in the `menu' face in menu bars. */
+ if (FRAME_FACE_CACHE (f)->menu_face_changed_p)
+ {
+ FRAME_FACE_CACHE (f)->menu_face_changed_p = 0;
+#ifdef USE_X_TOOLKIT
+ x_update_menu_appearance (f);
+#endif
+ }
+
+ success_p = 1;
+ }
+
+ unbind_to (count, Qnil);
+ UNBLOCK_INPUT;
+ return success_p;
+}
+
+
+/* Realize the default face on frame F. If the face is not fully
+ specified, make it fully-specified. Attributes of the default face
+ that are not explicitly specified are taken from frame parameters. */
+
+static int
+realize_default_face (f)
+ struct frame *f;
+{
+ struct face_cache *c = FRAME_FACE_CACHE (f);
+ Lisp_Object lface;
+ Lisp_Object attrs[LFACE_VECTOR_SIZE];
+ Lisp_Object frame_font;
+ struct face *face;
+
+ /* If the `default' face is not yet known, create it. */
+ lface = lface_from_face_name (f, Qdefault, 0);
+ if (NILP (lface))
+ {
+ Lisp_Object frame;
+ XSETFRAME (frame, f);
+ lface = Finternal_make_lisp_face (Qdefault, frame);
+ }
+
+#ifdef HAVE_WINDOW_SYSTEM
+ if (FRAME_WINDOW_P (f))
+ {
+ /* Set frame_font to the value of the `font' frame parameter. */
+ frame_font = Fassq (Qfont, f->param_alist);
+ xassert (CONSP (frame_font) && STRINGP (XCDR (frame_font)));
+ frame_font = XCDR (frame_font);
+ set_lface_from_font_name (f, lface, frame_font, 1, 1);
+ }
+#endif /* HAVE_WINDOW_SYSTEM */
+
+ if (!FRAME_WINDOW_P (f))
+ {
+ LFACE_FAMILY (lface) = build_string ("default");
+ LFACE_SWIDTH (lface) = Qnormal;
+ LFACE_HEIGHT (lface) = make_number (1);
+ LFACE_WEIGHT (lface) = Qnormal;
+ LFACE_SLANT (lface) = Qnormal;
+ LFACE_AVGWIDTH (lface) = Qunspecified;
+ }
+
+ if (UNSPECIFIEDP (LFACE_UNDERLINE (lface)))
+ LFACE_UNDERLINE (lface) = Qnil;
+
+ if (UNSPECIFIEDP (LFACE_OVERLINE (lface)))
+ LFACE_OVERLINE (lface) = Qnil;
+
+ if (UNSPECIFIEDP (LFACE_STRIKE_THROUGH (lface)))
+ LFACE_STRIKE_THROUGH (lface) = Qnil;
+
+ if (UNSPECIFIEDP (LFACE_BOX (lface)))
+ LFACE_BOX (lface) = Qnil;
+
+ if (UNSPECIFIEDP (LFACE_INVERSE (lface)))
+ LFACE_INVERSE (lface) = Qnil;
+
+ if (UNSPECIFIEDP (LFACE_FOREGROUND (lface)))
+ {
+ /* This function is called so early that colors are not yet
+ set in the frame parameter list. */
+ Lisp_Object color = Fassq (Qforeground_color, f->param_alist);
+
+ if (CONSP (color) && STRINGP (XCDR (color)))
+ LFACE_FOREGROUND (lface) = XCDR (color);
+ else if (FRAME_WINDOW_P (f))
+ return 0;
+ else if (FRAME_TERMCAP_P (f) || FRAME_MSDOS_P (f))
+ LFACE_FOREGROUND (lface) = build_string (unspecified_fg);
+ else
+ abort ();
+ }
+
+ if (UNSPECIFIEDP (LFACE_BACKGROUND (lface)))
+ {
+ /* This function is called so early that colors are not yet
+ set in the frame parameter list. */
+ Lisp_Object color = Fassq (Qbackground_color, f->param_alist);
+ if (CONSP (color) && STRINGP (XCDR (color)))
+ LFACE_BACKGROUND (lface) = XCDR (color);
+ else if (FRAME_WINDOW_P (f))
+ return 0;
+ else if (FRAME_TERMCAP_P (f) || FRAME_MSDOS_P (f))
+ LFACE_BACKGROUND (lface) = build_string (unspecified_bg);
+ else
+ abort ();
+ }
+
+ if (UNSPECIFIEDP (LFACE_STIPPLE (lface)))
+ LFACE_STIPPLE (lface) = Qnil;
+
+ /* Realize the face; it must be fully-specified now. */
+ xassert (lface_fully_specified_p (XVECTOR (lface)->contents));
+ check_lface (lface);
+ bcopy (XVECTOR (lface)->contents, attrs, sizeof attrs);
+ face = realize_face (c, attrs, 0, NULL, DEFAULT_FACE_ID);
+ return 1;
+}
+
+
+/* Realize basic faces other than the default face in face cache C.
+ SYMBOL is the face name, ID is the face id the realized face must
+ have. The default face must have been realized already. */
+
+static void
+realize_named_face (f, symbol, id)
+ struct frame *f;
+ Lisp_Object symbol;
+ int id;
+{
+ struct face_cache *c = FRAME_FACE_CACHE (f);
+ Lisp_Object lface = lface_from_face_name (f, symbol, 0);
+ Lisp_Object attrs[LFACE_VECTOR_SIZE];
+ Lisp_Object symbol_attrs[LFACE_VECTOR_SIZE];
+ struct face *new_face;
+
+ /* The default face must exist and be fully specified. */
+ get_lface_attributes (f, Qdefault, attrs, 1);
+ check_lface_attrs (attrs);
+ xassert (lface_fully_specified_p (attrs));
+
+ /* If SYMBOL isn't know as a face, create it. */
+ if (NILP (lface))
+ {
+ Lisp_Object frame;
+ XSETFRAME (frame, f);
+ lface = Finternal_make_lisp_face (symbol, frame);
+ }
+
+ /* Merge SYMBOL's face with the default face. */
+ get_lface_attributes (f, symbol, symbol_attrs, 1);
+ merge_face_vectors (f, symbol_attrs, attrs, Qnil);
+
+ /* Realize the face. */
+ new_face = realize_face (c, attrs, 0, NULL, id);
+}
+
+
+/* Realize the fully-specified face with attributes ATTRS in face
+ cache CACHE for character C. If C is a multibyte character,
+ BASE_FACE is a face that has the same attributes. Otherwise,
+ BASE_FACE is ignored. If FORMER_FACE_ID is non-negative, it is an
+ ID of face to remove before caching the new face. Value is a
+ pointer to the newly created realized face. */
+
+static struct face *
+realize_face (cache, attrs, c, base_face, former_face_id)
+ struct face_cache *cache;
+ Lisp_Object *attrs;
+ int c;
+ struct face *base_face;
+ int former_face_id;
+{
+ struct face *face;
+
+ /* LFACE must be fully specified. */
+ xassert (cache != NULL);
+ check_lface_attrs (attrs);
+
+ if (former_face_id >= 0 && cache->used > former_face_id)
+ {
+ /* Remove the former face. */
+ struct face *former_face = cache->faces_by_id[former_face_id];
+ uncache_face (cache, former_face);
+ free_realized_face (cache->f, former_face);
+ }
+
+ if (FRAME_WINDOW_P (cache->f))
+ face = realize_x_face (cache, attrs, c, base_face);
+ else if (FRAME_TERMCAP_P (cache->f) || FRAME_MSDOS_P (cache->f))
+ face = realize_tty_face (cache, attrs, c);
+ else
+ abort ();
+
+ /* Insert the new face. */
+ cache_face (cache, face, lface_hash (attrs));
+#ifdef HAVE_WINDOW_SYSTEM
+ if (FRAME_WINDOW_P (cache->f) && face->font == NULL)
+ load_face_font (cache->f, face, c);
+#endif /* HAVE_WINDOW_SYSTEM */
+ return face;
+}
+
+
+/* Realize the fully-specified face with attributes ATTRS in face
+ cache CACHE for character C. Do it for X frame CACHE->f. If C is
+ a multibyte character, BASE_FACE is a face that has the same
+ attributes. Otherwise, BASE_FACE is ignored. If the new face
+ doesn't share font with the default face, a fontname is allocated
+ from the heap and set in `font_name' of the new face, but it is not
+ yet loaded here. Value is a pointer to the newly created realized
+ face. */
+
+static struct face *
+realize_x_face (cache, attrs, c, base_face)
+ struct face_cache *cache;
+ Lisp_Object *attrs;
+ int c;
+ struct face *base_face;
+{
+#ifdef HAVE_WINDOW_SYSTEM
+ struct face *face, *default_face;
+ struct frame *f;
+ Lisp_Object stipple, overline, strike_through, box;
+
+ xassert (FRAME_WINDOW_P (cache->f));
+ xassert (SINGLE_BYTE_CHAR_P (c)
+ || base_face);
+
+ /* Allocate a new realized face. */
+ face = make_realized_face (attrs);
+
+ f = cache->f;
+
+ /* If C is a multibyte character, we share all face attirbutes with
+ BASE_FACE including the realized fontset. But, we must load a
+ different font. */
+ if (!SINGLE_BYTE_CHAR_P (c))
+ {
+ bcopy (base_face, face, sizeof *face);
+ face->gc = 0;
+
+ /* Don't try to free the colors copied bitwise from BASE_FACE. */
+ face->colors_copied_bitwise_p = 1;
+
+ /* to force realize_face to load font */
+ face->font = NULL;
+ return face;
+ }
+
+ /* Now we are realizing a face for ASCII (and unibyte) characters. */
+
+ /* Determine the font to use. Most of the time, the font will be
+ the same as the font of the default face, so try that first. */
+ default_face = FACE_FROM_ID (f, DEFAULT_FACE_ID);
+ if (default_face
+ && FACE_SUITABLE_FOR_CHAR_P (default_face, c)
+ && lface_same_font_attributes_p (default_face->lface, attrs))
+ {
+ face->font = default_face->font;
+ face->fontset = default_face->fontset;
+ face->font_info_id = default_face->font_info_id;
+ face->font_name = default_face->font_name;
+ face->ascii_face = face;
+
+ /* But, as we can't share the fontset, make a new realized
+ fontset that has the same base fontset as of the default
+ face. */
+ face->fontset
+ = make_fontset_for_ascii_face (f, default_face->fontset);
+ }
+ else
+ {
+ /* If the face attribute ATTRS specifies a fontset, use it as
+ the base of a new realized fontset. Otherwise, use the same
+ base fontset as of the default face. The base determines
+ registry and encoding of a font. It may also determine
+ foundry and family. The other fields of font name pattern
+ are constructed from ATTRS. */
+ int fontset = face_fontset (attrs);
+
+ if ((fontset == -1) && default_face)
+ fontset = default_face->fontset;
+ face->fontset = make_fontset_for_ascii_face (f, fontset);
+ face->font = NULL; /* to force realize_face to load font */
+
+#ifdef macintosh
+ /* Load the font if it is specified in ATTRS. This fixes
+ changing frame font on the Mac. */
+ if (STRINGP (attrs[LFACE_FONT_INDEX]))
+ {
+ struct font_info *font_info =
+ FS_LOAD_FONT (f, 0, XSTRING (attrs[LFACE_FONT_INDEX])->data, -1);
+ if (font_info)
+ face->font = font_info->font;
+ }
+#endif
+ }
+
+ /* Load colors, and set remaining attributes. */
+
+ load_face_colors (f, face, attrs);
+
+ /* Set up box. */
+ box = attrs[LFACE_BOX_INDEX];
+ if (STRINGP (box))
+ {
+ /* A simple box of line width 1 drawn in color given by
+ the string. */
+ face->box_color = load_color (f, face, attrs[LFACE_BOX_INDEX],
+ LFACE_BOX_INDEX);
+ face->box = FACE_SIMPLE_BOX;
+ face->box_line_width = 1;
+ }
+ else if (INTEGERP (box))
+ {
+ /* Simple box of specified line width in foreground color of the
+ face. */
+ xassert (XINT (box) != 0);
+ face->box = FACE_SIMPLE_BOX;
+ face->box_line_width = XINT (box);
+ face->box_color = face->foreground;
+ face->box_color_defaulted_p = 1;
+ }
+ else if (CONSP (box))
+ {
+ /* `(:width WIDTH :color COLOR :shadow SHADOW)'. SHADOW
+ being one of `raised' or `sunken'. */
+ face->box = FACE_SIMPLE_BOX;
+ face->box_color = face->foreground;
+ face->box_color_defaulted_p = 1;
+ face->box_line_width = 1;
+
+ while (CONSP (box))
+ {
+ Lisp_Object keyword, value;
+
+ keyword = XCAR (box);
+ box = XCDR (box);
+
+ if (!CONSP (box))
+ break;
+ value = XCAR (box);
+ box = XCDR (box);
+
+ if (EQ (keyword, QCline_width))
+ {
+ if (INTEGERP (value) && XINT (value) != 0)
+ face->box_line_width = XINT (value);
+ }
+ else if (EQ (keyword, QCcolor))
+ {
+ if (STRINGP (value))
+ {
+ face->box_color = load_color (f, face, value,
+ LFACE_BOX_INDEX);
+ face->use_box_color_for_shadows_p = 1;
+ }
+ }
+ else if (EQ (keyword, QCstyle))
+ {
+ if (EQ (value, Qreleased_button))
+ face->box = FACE_RAISED_BOX;
+ else if (EQ (value, Qpressed_button))
+ face->box = FACE_SUNKEN_BOX;
+ }
+ }
+ }
+
+ /* Text underline, overline, strike-through. */
+
+ if (EQ (attrs[LFACE_UNDERLINE_INDEX], Qt))
+ {
+ /* Use default color (same as foreground color). */
+ face->underline_p = 1;
+ face->underline_defaulted_p = 1;
+ face->underline_color = 0;
+ }
+ else if (STRINGP (attrs[LFACE_UNDERLINE_INDEX]))
+ {
+ /* Use specified color. */
+ face->underline_p = 1;
+ face->underline_defaulted_p = 0;
+ face->underline_color
+ = load_color (f, face, attrs[LFACE_UNDERLINE_INDEX],
+ LFACE_UNDERLINE_INDEX);
+ }
+ else if (NILP (attrs[LFACE_UNDERLINE_INDEX]))
+ {
+ face->underline_p = 0;
+ face->underline_defaulted_p = 0;
+ face->underline_color = 0;
+ }
+
+ overline = attrs[LFACE_OVERLINE_INDEX];
+ if (STRINGP (overline))
+ {
+ face->overline_color
+ = load_color (f, face, attrs[LFACE_OVERLINE_INDEX],
+ LFACE_OVERLINE_INDEX);
+ face->overline_p = 1;
+ }
+ else if (EQ (overline, Qt))
+ {
+ face->overline_color = face->foreground;
+ face->overline_color_defaulted_p = 1;
+ face->overline_p = 1;
+ }
+
+ strike_through = attrs[LFACE_STRIKE_THROUGH_INDEX];
+ if (STRINGP (strike_through))
+ {
+ face->strike_through_color
+ = load_color (f, face, attrs[LFACE_STRIKE_THROUGH_INDEX],
+ LFACE_STRIKE_THROUGH_INDEX);
+ face->strike_through_p = 1;
+ }
+ else if (EQ (strike_through, Qt))
+ {
+ face->strike_through_color = face->foreground;
+ face->strike_through_color_defaulted_p = 1;
+ face->strike_through_p = 1;
+ }
+
+ stipple = attrs[LFACE_STIPPLE_INDEX];
+ if (!NILP (stipple))
+ face->stipple = load_pixmap (f, stipple, &face->pixmap_w, &face->pixmap_h);
+
+ xassert (FACE_SUITABLE_FOR_CHAR_P (face, c));
+ return face;
+#endif /* HAVE_WINDOW_SYSTEM */
+}
+
+
+/* Map a specified color of face FACE on frame F to a tty color index.
+ IDX is either LFACE_FOREGROUND_INDEX or LFACE_BACKGROUND_INDEX, and
+ specifies which color to map. Set *DEFAULTED to 1 if mapping to the
+ default foreground/background colors. */
+
+static void
+map_tty_color (f, face, idx, defaulted)
+ struct frame *f;
+ struct face *face;
+ enum lface_attribute_index idx;
+ int *defaulted;
+{
+ Lisp_Object frame, color, def;
+ int foreground_p = idx == LFACE_FOREGROUND_INDEX;
+ unsigned long default_pixel, default_other_pixel, pixel;
+
+ xassert (idx == LFACE_FOREGROUND_INDEX || idx == LFACE_BACKGROUND_INDEX);
+
+ if (foreground_p)
+ {
+ pixel = default_pixel = FACE_TTY_DEFAULT_FG_COLOR;
+ default_other_pixel = FACE_TTY_DEFAULT_BG_COLOR;
+ }
+ else
+ {
+ pixel = default_pixel = FACE_TTY_DEFAULT_BG_COLOR;
+ default_other_pixel = FACE_TTY_DEFAULT_FG_COLOR;
+ }
+
+ XSETFRAME (frame, f);
+ color = face->lface[idx];
+
+ if (STRINGP (color)
+ && XSTRING (color)->size
+ && CONSP (Vtty_defined_color_alist)
+ && (def = assq_no_quit (color, call1 (Qtty_color_alist, frame)),
+ CONSP (def)))
+ {
+ /* Associations in tty-defined-color-alist are of the form
+ (NAME INDEX R G B). We need the INDEX part. */
+ pixel = XINT (XCAR (XCDR (def)));
+ }
+
+ if (pixel == default_pixel && STRINGP (color))
+ {
+ pixel = load_color (f, face, color, idx);
+
+#if defined (MSDOS) || defined (WINDOWSNT)
+ /* If the foreground of the default face is the default color,
+ use the foreground color defined by the frame. */
+#ifdef MSDOS
+ if (FRAME_MSDOS_P (f))
+ {
+#endif /* MSDOS */
+ if (pixel == default_pixel
+ || pixel == FACE_TTY_DEFAULT_COLOR)
+ {
+ if (foreground_p)
+ pixel = FRAME_FOREGROUND_PIXEL (f);
+ else
+ pixel = FRAME_BACKGROUND_PIXEL (f);
+ face->lface[idx] = tty_color_name (f, pixel);
+ *defaulted = 1;
+ }
+ else if (pixel == default_other_pixel)
+ {
+ if (foreground_p)
+ pixel = FRAME_BACKGROUND_PIXEL (f);
+ else
+ pixel = FRAME_FOREGROUND_PIXEL (f);
+ face->lface[idx] = tty_color_name (f, pixel);
+ *defaulted = 1;
+ }
+#ifdef MSDOS
+ }
+#endif
+#endif /* MSDOS or WINDOWSNT */
+ }
+
+ if (foreground_p)
+ face->foreground = pixel;
+ else
+ face->background = pixel;
+}
+
+
+/* Realize the fully-specified face with attributes ATTRS in face
+ cache CACHE for character C. Do it for TTY frame CACHE->f. Value is a
+ pointer to the newly created realized face. */
+
+static struct face *
+realize_tty_face (cache, attrs, c)
+ struct face_cache *cache;
+ Lisp_Object *attrs;
+ int c;
+{
+ struct face *face;
+ int weight, slant;
+ int face_colors_defaulted = 0;
+ struct frame *f = cache->f;
+
+ /* Frame must be a termcap frame. */
+ xassert (FRAME_TERMCAP_P (cache->f) || FRAME_MSDOS_P (cache->f));
+
+ /* Allocate a new realized face. */
+ face = make_realized_face (attrs);
+ face->font_name = FRAME_MSDOS_P (cache->f) ? "ms-dos" : "tty";
+
+ /* Map face attributes to TTY appearances. We map slant to
+ dimmed text because we want italic text to appear differently
+ and because dimmed text is probably used infrequently. */
+ weight = face_numeric_weight (attrs[LFACE_WEIGHT_INDEX]);
+ slant = face_numeric_slant (attrs[LFACE_SLANT_INDEX]);
+
+ if (weight > XLFD_WEIGHT_MEDIUM)
+ face->tty_bold_p = 1;
+ if (weight < XLFD_WEIGHT_MEDIUM || slant != XLFD_SLANT_ROMAN)
+ face->tty_dim_p = 1;
+ if (!NILP (attrs[LFACE_UNDERLINE_INDEX]))
+ face->tty_underline_p = 1;
+ if (!NILP (attrs[LFACE_INVERSE_INDEX]))
+ face->tty_reverse_p = 1;
+
+ /* Map color names to color indices. */
+ map_tty_color (f, face, LFACE_FOREGROUND_INDEX, &face_colors_defaulted);
+ map_tty_color (f, face, LFACE_BACKGROUND_INDEX, &face_colors_defaulted);
+
+ /* Swap colors if face is inverse-video. If the colors are taken
+ from the frame colors, they are already inverted, since the
+ frame-creation function calls x-handle-reverse-video. */
+ if (face->tty_reverse_p && !face_colors_defaulted)
+ {
+ unsigned long tem = face->foreground;
+ face->foreground = face->background;
+ face->background = tem;
+ }
+
+ if (tty_suppress_bold_inverse_default_colors_p
+ && face->tty_bold_p
+ && face->background == FACE_TTY_DEFAULT_FG_COLOR
+ && face->foreground == FACE_TTY_DEFAULT_BG_COLOR)
+ face->tty_bold_p = 0;
+
+ return face;
+}
+
+
+DEFUN ("tty-suppress-bold-inverse-default-colors",
+ Ftty_suppress_bold_inverse_default_colors,
+ Stty_suppress_bold_inverse_default_colors, 1, 1, 0,
+ "Suppress/allow boldness of faces with inverse default colors.\n\
+SUPPRESS non-nil means suppress it.\n\
+This affects bold faces on TTYs whose foreground is the default background\n\
+color of the display and whose background is the default foreground color.\n\
+For such faces, the bold face attribute is ignored if this variable\n\
+is non-nil.")
+ (suppress)
+ Lisp_Object suppress;
+{
+ tty_suppress_bold_inverse_default_colors_p = !NILP (suppress);
+ ++face_change_count;
+ return suppress;
+}
+
+
+\f
+/***********************************************************************
+ Computing Faces
+ ***********************************************************************/
+
+/* Return the ID of the face to use to display character CH with face
+ property PROP on frame F in current_buffer. */
+
+int
+compute_char_face (f, ch, prop)
+ struct frame *f;
+ int ch;
+ Lisp_Object prop;
+{
+ int face_id;
+
+ if (NILP (current_buffer->enable_multibyte_characters))
+ ch = 0;
+
+ if (NILP (prop))
+ {
+ struct face *face = FACE_FROM_ID (f, DEFAULT_FACE_ID);
+ face_id = FACE_FOR_CHAR (f, face, ch);
+ }
+ else
+ {
+ Lisp_Object attrs[LFACE_VECTOR_SIZE];
+ struct face *default_face = FACE_FROM_ID (f, DEFAULT_FACE_ID);
+ bcopy (default_face->lface, attrs, sizeof attrs);
+ merge_face_vector_with_property (f, attrs, prop);
+ face_id = lookup_face (f, attrs, ch, NULL);
+ }
+
+ return face_id;
+}
+
+
+/* Return the face ID associated with buffer position POS for
+ displaying ASCII characters. Return in *ENDPTR the position at
+ which a different face is needed, as far as text properties and
+ overlays are concerned. W is a window displaying current_buffer.
+
+ REGION_BEG, REGION_END delimit the region, so it can be
+ highlighted.
+
+ LIMIT is a position not to scan beyond. That is to limit the time
+ this function can take.
+
+ If MOUSE is non-zero, use the character's mouse-face, not its face.
+
+ The face returned is suitable for displaying ASCII characters. */
+
+int
+face_at_buffer_position (w, pos, region_beg, region_end,
+ endptr, limit, mouse)
+ struct window *w;
+ int pos;
+ int region_beg, region_end;
+ int *endptr;
+ int limit;
+ int mouse;
+{
+ struct frame *f = XFRAME (w->frame);
+ Lisp_Object attrs[LFACE_VECTOR_SIZE];
+ Lisp_Object prop, position;
+ int i, noverlays;
+ Lisp_Object *overlay_vec;
+ Lisp_Object frame;
+ int endpos;
+ Lisp_Object propname = mouse ? Qmouse_face : Qface;
+ Lisp_Object limit1, end;
+ struct face *default_face;
+
+ /* W must display the current buffer. We could write this function
+ to use the frame and buffer of W, but right now it doesn't. */
+ /* xassert (XBUFFER (w->buffer) == current_buffer); */
+
+ XSETFRAME (frame, f);
+ XSETFASTINT (position, pos);
+
+ endpos = ZV;
+ if (pos < region_beg && region_beg < endpos)
+ endpos = region_beg;
+
+ /* Get the `face' or `mouse_face' text property at POS, and
+ determine the next position at which the property changes. */
+ prop = Fget_text_property (position, propname, w->buffer);
+ XSETFASTINT (limit1, (limit < endpos ? limit : endpos));
+ end = Fnext_single_property_change (position, propname, w->buffer, limit1);
+ if (INTEGERP (end))
+ endpos = XINT (end);
+
+ /* Look at properties from overlays. */
+ {
+ int next_overlay;
+ int len;
+
+ /* First try with room for 40 overlays. */
+ len = 40;
+ overlay_vec = (Lisp_Object *) alloca (len * sizeof (Lisp_Object));
+ noverlays = overlays_at (pos, 0, &overlay_vec, &len,
+ &next_overlay, NULL, 0);
+
+ /* If there are more than 40, make enough space for all, and try
+ again. */
+ if (noverlays > len)
+ {
+ len = noverlays;
+ overlay_vec = (Lisp_Object *) alloca (len * sizeof (Lisp_Object));
+ noverlays = overlays_at (pos, 0, &overlay_vec, &len,
+ &next_overlay, NULL, 0);
+ }
+
+ if (next_overlay < endpos)
+ endpos = next_overlay;
+ }
+
+ *endptr = endpos;
+
+ default_face = FACE_FROM_ID (f, DEFAULT_FACE_ID);
+
+ /* Optimize common cases where we can use the default face. */
+ if (noverlays == 0
+ && NILP (prop)
+ && !(pos >= region_beg && pos < region_end))
+ return DEFAULT_FACE_ID;
+
+ /* Begin with attributes from the default face. */
+ bcopy (default_face->lface, attrs, sizeof attrs);
+
+ /* Merge in attributes specified via text properties. */
+ if (!NILP (prop))
+ merge_face_vector_with_property (f, attrs, prop);
+
+ /* Now merge the overlay data. */
+ noverlays = sort_overlays (overlay_vec, noverlays, w);
+ for (i = 0; i < noverlays; i++)
+ {
+ Lisp_Object oend;
+ int oendpos;
+
+ prop = Foverlay_get (overlay_vec[i], propname);
+ if (!NILP (prop))
+ merge_face_vector_with_property (f, attrs, prop);
+
+ oend = OVERLAY_END (overlay_vec[i]);
+ oendpos = OVERLAY_POSITION (oend);
+ if (oendpos < endpos)
+ endpos = oendpos;
+ }
+
+ /* If in the region, merge in the region face. */
+ if (pos >= region_beg && pos < region_end)
+ {
+ Lisp_Object region_face = lface_from_face_name (f, Qregion, 0);
+ merge_face_vectors (f, XVECTOR (region_face)->contents, attrs, Qnil);
+
+ if (region_end < endpos)
+ endpos = region_end;
+ }
+
+ *endptr = endpos;
+
+ /* Look up a realized face with the given face attributes,
+ or realize a new one for ASCII characters. */
+ return lookup_face (f, attrs, 0, NULL);
+}
+
+
+/* Compute the face at character position POS in Lisp string STRING on
+ window W, for ASCII characters.
+
+ If STRING is an overlay string, it comes from position BUFPOS in
+ current_buffer, otherwise BUFPOS is zero to indicate that STRING is
+ not an overlay string. W must display the current buffer.
+ REGION_BEG and REGION_END give the start and end positions of the
+ region; both are -1 if no region is visible.
+
+ BASE_FACE_ID is the id of a face to merge with. For strings coming
+ from overlays or the `display' property it is the face at BUFPOS.
+
+ If MOUSE_P is non-zero, use the character's mouse-face, not its face.
+
+ Set *ENDPTR to the next position where to check for faces in
+ STRING; -1 if the face is constant from POS to the end of the
+ string.
+
+ Value is the id of the face to use. The face returned is suitable
+ for displaying ASCII characters. */
+
+int
+face_at_string_position (w, string, pos, bufpos, region_beg,
+ region_end, endptr, base_face_id, mouse_p)
+ struct window *w;
+ Lisp_Object string;
+ int pos, bufpos;
+ int region_beg, region_end;
+ int *endptr;
+ enum face_id base_face_id;
+ int mouse_p;
+{
+ Lisp_Object prop, position, end, limit;
+ struct frame *f = XFRAME (WINDOW_FRAME (w));
+ Lisp_Object attrs[LFACE_VECTOR_SIZE];
+ struct face *base_face;
+ int multibyte_p = STRING_MULTIBYTE (string);
+ Lisp_Object prop_name = mouse_p ? Qmouse_face : Qface;
+
+ /* Get the value of the face property at the current position within
+ STRING. Value is nil if there is no face property. */
+ XSETFASTINT (position, pos);
+ prop = Fget_text_property (position, prop_name, string);
+
+ /* Get the next position at which to check for faces. Value of end
+ is nil if face is constant all the way to the end of the string.
+ Otherwise it is a string position where to check faces next.
+ Limit is the maximum position up to which to check for property
+ changes in Fnext_single_property_change. Strings are usually
+ short, so set the limit to the end of the string. */
+ XSETFASTINT (limit, XSTRING (string)->size);
+ end = Fnext_single_property_change (position, prop_name, string, limit);
+ if (INTEGERP (end))
+ *endptr = XFASTINT (end);
+ else
+ *endptr = -1;
+
+ base_face = FACE_FROM_ID (f, base_face_id);
+ xassert (base_face);
+
+ /* Optimize the default case that there is no face property and we
+ are not in the region. */
+ if (NILP (prop)
+ && (base_face_id != DEFAULT_FACE_ID
+ /* BUFPOS <= 0 means STRING is not an overlay string, so
+ that the region doesn't have to be taken into account. */
+ || bufpos <= 0
+ || bufpos < region_beg
+ || bufpos >= region_end)
+ && (multibyte_p
+ /* We can't realize faces for different charsets differently
+ if we don't have fonts, so we can stop here if not working
+ on a window-system frame. */
+ || !FRAME_WINDOW_P (f)
+ || FACE_SUITABLE_FOR_CHAR_P (base_face, 0)))
+ return base_face->id;
+
+ /* Begin with attributes from the base face. */
+ bcopy (base_face->lface, attrs, sizeof attrs);
+
+ /* Merge in attributes specified via text properties. */
+ if (!NILP (prop))
+ merge_face_vector_with_property (f, attrs, prop);
+
+ /* If in the region, merge in the region face. */
+ if (bufpos
+ && bufpos >= region_beg
+ && bufpos < region_end)
+ {
+ Lisp_Object region_face = lface_from_face_name (f, Qregion, 0);
+ merge_face_vectors (f, XVECTOR (region_face)->contents, attrs, Qnil);
+ }
+
+ /* Look up a realized face with the given face attributes,
+ or realize a new one for ASCII characters. */
+ return lookup_face (f, attrs, 0, NULL);
+}
+
+
+\f
+/***********************************************************************
+ Tests
+ ***********************************************************************/
+
+#if GLYPH_DEBUG
+
+/* Print the contents of the realized face FACE to stderr. */
+
+static void
+dump_realized_face (face)
+ struct face *face;
+{
+ fprintf (stderr, "ID: %d\n", face->id);
+#ifdef HAVE_X_WINDOWS
+ fprintf (stderr, "gc: %d\n", (int) face->gc);
+#endif
+ fprintf (stderr, "foreground: 0x%lx (%s)\n",
+ face->foreground,
+ XSTRING (face->lface[LFACE_FOREGROUND_INDEX])->data);
+ fprintf (stderr, "background: 0x%lx (%s)\n",
+ face->background,
+ XSTRING (face->lface[LFACE_BACKGROUND_INDEX])->data);
+ fprintf (stderr, "font_name: %s (%s)\n",
+ face->font_name,
+ XSTRING (face->lface[LFACE_FAMILY_INDEX])->data);
+#ifdef HAVE_X_WINDOWS
+ fprintf (stderr, "font = %p\n", face->font);
+#endif
+ fprintf (stderr, "font_info_id = %d\n", face->font_info_id);
+ fprintf (stderr, "fontset: %d\n", face->fontset);
+ fprintf (stderr, "underline: %d (%s)\n",
+ face->underline_p,
+ XSTRING (Fsymbol_name (face->lface[LFACE_UNDERLINE_INDEX]))->data);
+ fprintf (stderr, "hash: %d\n", face->hash);
+ fprintf (stderr, "charset: %d\n", face->charset);
+}
+
+
+DEFUN ("dump-face", Fdump_face, Sdump_face, 0, 1, 0, "")
+ (n)
+ Lisp_Object n;
+{
+ if (NILP (n))
+ {
+ int i;
+
+ fprintf (stderr, "font selection order: ");
+ for (i = 0; i < DIM (font_sort_order); ++i)
+ fprintf (stderr, "%d ", font_sort_order[i]);
+ fprintf (stderr, "\n");
+
+ fprintf (stderr, "alternative fonts: ");
+ debug_print (Vface_alternative_font_family_alist);
+ fprintf (stderr, "\n");
+
+ for (i = 0; i < FRAME_FACE_CACHE (SELECTED_FRAME ())->used; ++i)
+ Fdump_face (make_number (i));
+ }
+ else
+ {
+ struct face *face;
+ CHECK_NUMBER (n, 0);
+ face = FACE_FROM_ID (SELECTED_FRAME (), XINT (n));
+ if (face == NULL)
+ error ("Not a valid face");
+ dump_realized_face (face);
+ }
+
+ return Qnil;
+}
+
+
+DEFUN ("show-face-resources", Fshow_face_resources, Sshow_face_resources,
+ 0, 0, 0, "")
+ ()
+{
+ fprintf (stderr, "number of colors = %d\n", ncolors_allocated);
+ fprintf (stderr, "number of pixmaps = %d\n", npixmaps_allocated);
+ fprintf (stderr, "number of GCs = %d\n", ngcs);
+ return Qnil;
+}
+
+#endif /* GLYPH_DEBUG != 0 */
+
+
+\f
+/***********************************************************************
+ Initialization
+ ***********************************************************************/
+
+void
+syms_of_xfaces ()
+{
+ Qface = intern ("face");
+ staticpro (&Qface);
+ Qbitmap_spec_p = intern ("bitmap-spec-p");
+ staticpro (&Qbitmap_spec_p);
+ Qframe_update_face_colors = intern ("frame-update-face-colors");
+ staticpro (&Qframe_update_face_colors);
+
+ /* Lisp face attribute keywords. */
+ QCfamily = intern (":family");
+ staticpro (&QCfamily);
+ QCheight = intern (":height");
+ staticpro (&QCheight);
+ QCweight = intern (":weight");
+ staticpro (&QCweight);
+ QCslant = intern (":slant");
+ staticpro (&QCslant);
+ QCunderline = intern (":underline");
+ staticpro (&QCunderline);
+ QCinverse_video = intern (":inverse-video");
+ staticpro (&QCinverse_video);
+ QCreverse_video = intern (":reverse-video");
+ staticpro (&QCreverse_video);
+ QCforeground = intern (":foreground");
+ staticpro (&QCforeground);
+ QCbackground = intern (":background");
+ staticpro (&QCbackground);
+ QCstipple = intern (":stipple");;
+ staticpro (&QCstipple);
+ QCwidth = intern (":width");
+ staticpro (&QCwidth);
+ QCfont = intern (":font");
+ staticpro (&QCfont);
+ QCbold = intern (":bold");
+ staticpro (&QCbold);
+ QCitalic = intern (":italic");
+ staticpro (&QCitalic);
+ QCoverline = intern (":overline");
+ staticpro (&QCoverline);
+ QCstrike_through = intern (":strike-through");
+ staticpro (&QCstrike_through);
+ QCbox = intern (":box");
+ staticpro (&QCbox);
+ QCinherit = intern (":inherit");
+ staticpro (&QCinherit);
+
+ /* Symbols used for Lisp face attribute values. */
+ QCcolor = intern (":color");
+ staticpro (&QCcolor);
+ QCline_width = intern (":line-width");
+ staticpro (&QCline_width);
+ QCstyle = intern (":style");
+ staticpro (&QCstyle);
+ Qreleased_button = intern ("released-button");
+ staticpro (&Qreleased_button);
+ Qpressed_button = intern ("pressed-button");
+ staticpro (&Qpressed_button);
+ Qnormal = intern ("normal");
+ staticpro (&Qnormal);
+ Qultra_light = intern ("ultra-light");
+ staticpro (&Qultra_light);
+ Qextra_light = intern ("extra-light");
+ staticpro (&Qextra_light);
+ Qlight = intern ("light");
+ staticpro (&Qlight);
+ Qsemi_light = intern ("semi-light");
+ staticpro (&Qsemi_light);
+ Qsemi_bold = intern ("semi-bold");
+ staticpro (&Qsemi_bold);
+ Qbold = intern ("bold");
+ staticpro (&Qbold);
+ Qextra_bold = intern ("extra-bold");
+ staticpro (&Qextra_bold);
+ Qultra_bold = intern ("ultra-bold");
+ staticpro (&Qultra_bold);
+ Qoblique = intern ("oblique");
+ staticpro (&Qoblique);
+ Qitalic = intern ("italic");
+ staticpro (&Qitalic);
+ Qreverse_oblique = intern ("reverse-oblique");
+ staticpro (&Qreverse_oblique);
+ Qreverse_italic = intern ("reverse-italic");
+ staticpro (&Qreverse_italic);
+ Qultra_condensed = intern ("ultra-condensed");
+ staticpro (&Qultra_condensed);
+ Qextra_condensed = intern ("extra-condensed");
+ staticpro (&Qextra_condensed);
+ Qcondensed = intern ("condensed");
+ staticpro (&Qcondensed);
+ Qsemi_condensed = intern ("semi-condensed");
+ staticpro (&Qsemi_condensed);
+ Qsemi_expanded = intern ("semi-expanded");
+ staticpro (&Qsemi_expanded);
+ Qexpanded = intern ("expanded");
+ staticpro (&Qexpanded);
+ Qextra_expanded = intern ("extra-expanded");
+ staticpro (&Qextra_expanded);
+ Qultra_expanded = intern ("ultra-expanded");
+ staticpro (&Qultra_expanded);
+ Qbackground_color = intern ("background-color");
+ staticpro (&Qbackground_color);
+ Qforeground_color = intern ("foreground-color");
+ staticpro (&Qforeground_color);
+ Qunspecified = intern ("unspecified");
+ staticpro (&Qunspecified);
+
+ Qface_alias = intern ("face-alias");
+ staticpro (&Qface_alias);
+ Qdefault = intern ("default");
+ staticpro (&Qdefault);
+ Qtool_bar = intern ("tool-bar");
+ staticpro (&Qtool_bar);
+ Qregion = intern ("region");
+ staticpro (&Qregion);
+ Qfringe = intern ("fringe");
+ staticpro (&Qfringe);
+ Qheader_line = intern ("header-line");
+ staticpro (&Qheader_line);
+ Qscroll_bar = intern ("scroll-bar");
+ staticpro (&Qscroll_bar);
+ Qmenu = intern ("menu");
+ staticpro (&Qmenu);
+ Qcursor = intern ("cursor");
+ staticpro (&Qcursor);
+ Qborder = intern ("border");
+ staticpro (&Qborder);
+ Qmouse = intern ("mouse");
+ staticpro (&Qmouse);
+ Qtty_color_desc = intern ("tty-color-desc");
+ staticpro (&Qtty_color_desc);
+ Qtty_color_by_index = intern ("tty-color-by-index");
+ staticpro (&Qtty_color_by_index);
+ Qtty_color_alist = intern ("tty-color-alist");
+ staticpro (&Qtty_color_alist);
+ Qscalable_fonts_allowed = intern ("scalable-fonts-allowed");
+ staticpro (&Qscalable_fonts_allowed);
+
+ Vparam_value_alist = Fcons (Fcons (Qnil, Qnil), Qnil);
+ staticpro (&Vparam_value_alist);
+ Vface_alternative_font_family_alist = Qnil;
+ staticpro (&Vface_alternative_font_family_alist);
+ Vface_alternative_font_registry_alist = Qnil;
+ staticpro (&Vface_alternative_font_registry_alist);
+
+ defsubr (&Sinternal_make_lisp_face);
+ defsubr (&Sinternal_lisp_face_p);
+ defsubr (&Sinternal_set_lisp_face_attribute);
+#ifdef HAVE_WINDOW_SYSTEM
+ defsubr (&Sinternal_set_lisp_face_attribute_from_resource);
+#endif
+ defsubr (&Scolor_gray_p);
+ defsubr (&Scolor_supported_p);
+ defsubr (&Sinternal_get_lisp_face_attribute);
+ defsubr (&Sinternal_lisp_face_attribute_values);
+ defsubr (&Sinternal_lisp_face_equal_p);
+ defsubr (&Sinternal_lisp_face_empty_p);
+ defsubr (&Sinternal_copy_lisp_face);
+ defsubr (&Sinternal_merge_in_global_face);
+ defsubr (&Sface_font);
+ defsubr (&Sframe_face_alist);
+ defsubr (&Sinternal_set_font_selection_order);
+ defsubr (&Sinternal_set_alternative_font_family_alist);
+ defsubr (&Sinternal_set_alternative_font_registry_alist);
+#if GLYPH_DEBUG
+ defsubr (&Sdump_face);
+ defsubr (&Sshow_face_resources);
+#endif /* GLYPH_DEBUG */
+ defsubr (&Sclear_face_cache);
+ defsubr (&Stty_suppress_bold_inverse_default_colors);
+
+#if defined DEBUG_X_COLORS && defined HAVE_X_WINDOWS
+ defsubr (&Sdump_colors);
+#endif
+
+ DEFVAR_LISP ("font-list-limit", &Vfont_list_limit,
+ "*Limit for font matching.\n\
+If an integer > 0, font matching functions won't load more than\n\
+that number of fonts when searching for a matching font.");
+ Vfont_list_limit = make_number (DEFAULT_FONT_LIST_LIMIT);
+
+ DEFVAR_LISP ("face-new-frame-defaults", &Vface_new_frame_defaults,
+ "List of global face definitions (for internal use only.)");
+ Vface_new_frame_defaults = Qnil;
+
+ DEFVAR_LISP ("face-default-stipple", &Vface_default_stipple,
+ "*Default stipple pattern used on monochrome displays.\n\
+This stipple pattern is used on monochrome displays\n\
+instead of shades of gray for a face background color.\n\
+See `set-face-stipple' for possible values for this variable.");
+ Vface_default_stipple = build_string ("gray3");
+
+ DEFVAR_LISP ("tty-defined-color-alist", &Vtty_defined_color_alist,
+ "An alist of defined terminal colors and their RGB values.");
+ Vtty_defined_color_alist = Qnil;
+
+ DEFVAR_LISP ("scalable-fonts-allowed", &Vscalable_fonts_allowed,
+ "Allowed scalable fonts.\n\
+A value of nil means don't allow any scalable fonts.\n\
+A value of t means allow any scalable font.\n\
+Otherwise, value must be a list of regular expressions. A font may be\n\
+scaled if its name matches a regular expression in the list.\n\
+Note that if value is nil, a scalable font might still be used, if no\n\
+other font of the appropriate family and registry is available.");
+ Vscalable_fonts_allowed = Qnil;
+
+ DEFVAR_LISP ("face-ignored-fonts", &Vface_ignored_fonts,
+ "List of ignored fonts.\n\
+Each element is a regular expression that matches names of fonts to ignore.");
+ Vface_ignored_fonts = Qnil;
+
+#ifdef HAVE_WINDOW_SYSTEM
+ defsubr (&Sbitmap_spec_p);
+ defsubr (&Sx_list_fonts);
+ defsubr (&Sinternal_face_x_get_resource);
+ defsubr (&Sx_family_fonts);
+ defsubr (&Sx_font_family_list);
+#endif /* HAVE_WINDOW_SYSTEM */
+}
--- /dev/null
+@@ -4503,29 +4508,45 @@
+ XSETFRAME (frame, f);
+ call1 (Qframe_update_face_colors, frame);
+
+- lface = lface_from_face_name (f, Qdefault, 1);
++ face = Qdefault;
++ lface = lface_from_face_name (f, face, 1);
+ LFACE_BACKGROUND (lface) = (STRINGP (new_value)
+ ? new_value : Qunspecified);
+ realize_basic_faces (f);
+ }
+- if (EQ (param, Qborder_color))
++ else if (EQ (param, Qborder_color))
+ {
+- lface = lface_from_face_name (f, Qborder, 1);
++ 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))
+ {
+- lface = lface_from_face_name (f, Qcursor, 1);
++ 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))
+ {
+- lface = lface_from_face_name (f, Qmouse, 1);
++ face = Qmouse;
++ lface = lface_from_face_name (f, face, 1);
+ LFACE_BACKGROUND (lface) = (STRINGP (new_value)
+ ? new_value : Qunspecified);
+ }
++
++ /* 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;
++ }
+ }
+
+
projects / wiggle.git / commitdiff