1 /* xfaces.c -- "Face" primitives.
   2    Copyright (C) 1993, 1994, 1998, 1999, 2000, 2001, 2002, 2003, 2004,
   3                  2005, 2006, 2007, 2008, 2009, 2010 Free Software Foundation, Inc.
   4 
   5 This file is part of GNU Emacs.
   6 
   7 GNU Emacs is free software: you can redistribute it and/or modify
   8 it under the terms of the GNU General Public License as published by
   9 the Free Software Foundation, either version 3 of the License, or
  10 (at your option) any later version.
  11 
  12 GNU Emacs is distributed in the hope that it will be useful,
  13 but WITHOUT ANY WARRANTY; without even the implied warranty of
  14 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  15 GNU General Public License for more details.
  16 
  17 You should have received a copy of the GNU General Public License
  18 along with GNU Emacs.  If not, see <http://www.gnu.org/licenses/>.  */
  19 
  20 /* New face implementation by Gerd Moellmann <gerd@gnu.org>.  */
  21 
  22 /* Faces.
  23 
  24    When using Emacs with X, the display style of characters can be
  25    changed by defining `faces'.  Each face can specify the following
  26    display attributes:
  27 
  28    1. Font family name.
  29 
  30    2. Font foundary name.
  31 
  32    3. Relative proportionate width, aka character set width or set
  33    width (swidth), e.g. `semi-compressed'.
  34 
  35    4. Font height in 1/10pt.
  36 
  37    5. Font weight, e.g. `bold'.
  38 
  39    6. Font slant, e.g. `italic'.
  40 
  41    7. Foreground color.
  42 
  43    8. Background color.
  44 
  45    9. Whether or not characters should be underlined, and in what color.
  46 
  47    10. Whether or not characters should be displayed in inverse video.
  48 
  49    11. A background stipple, a bitmap.
  50 
  51    12. Whether or not characters should be overlined, and in what color.
  52 
  53    13. Whether or not characters should be strike-through, and in what
  54    color.
  55 
  56    14. Whether or not a box should be drawn around characters, the box
  57    type, and, for simple boxes, in what color.
  58 
  59    15. Font-spec, or nil.  This is a special attribute.
  60 
  61    A font-spec is a collection of font attributes (specs).
  62 
  63    When this attribute is specified, the face uses a font matching
  64    with the specs as is except for what overwritten by the specs in
  65    the fontset (see below).  In addition, the other font-related
  66    attributes (1st thru 5th) are updated from the spec.
  67 
  68    On the other hand, if one of the other font-related attributes are
  69    specified, the correspoinding specs in this attribute is set to nil.
  70 
  71    15. A face name or list of face names from which to inherit attributes.
  72 
  73    16. A specified average font width, which is invisible from Lisp,
  74    and is used to ensure that a font specified on the command line,
  75    for example, can be matched exactly.
  76 
  77    17. A fontset name.  This is another special attribute.
  78 
  79    A fontset is a mappings from characters to font-specs, and the
  80    specs overwrite the font-spec in the 14th attribute.
  81 
  82 
  83    Faces are frame-local by nature because Emacs allows to define the
  84    same named face (face names are symbols) differently for different
  85    frames.  Each frame has an alist of face definitions for all named
  86    faces.  The value of a named face in such an alist is a Lisp vector
  87    with the symbol `face' in slot 0, and a slot for each of the face
  88    attributes mentioned above.
  89 
  90    There is also a global face alist `Vface_new_frame_defaults'.  Face
  91    definitions from this list are used to initialize faces of newly
  92    created frames.
  93 
  94    A face doesn't have to specify all attributes.  Those not specified
  95    have a value of `unspecified'.  Faces specifying all attributes but
  96    the 14th are called `fully-specified'.
  97 
  98 
  99    Face merging.
 100 
 101    The display style of a given character in the text is determined by
 102    combining several faces.  This process is called `face merging'.
 103    Any aspect of the display style that isn't specified by overlays or
 104    text properties is taken from the `default' face.  Since it is made
 105    sure that the default face is always fully-specified, face merging
 106    always results in a fully-specified face.
 107 
 108 
 109    Face realization.
 110 
 111    After all face attributes for a character have been determined by
 112    merging faces of that character, that face is `realized'.  The
 113    realization process maps face attributes to what is physically
 114    available on the system where Emacs runs.  The result is a
 115    `realized face' in form of a struct face which is stored in the
 116    face cache of the frame on which it was realized.
 117 
 118    Face realization is done in the context of the character to display
 119    because different fonts may be used for different characters.  In
 120    other words, for characters that have different font
 121    specifications, different realized faces are needed to display
 122    them.
 123 
 124    Font specification is done by fontsets.  See the comment in
 125    fontset.c for the details.  In the current implementation, all ASCII
 126    characters share the same font in a fontset.
 127 
 128    Faces are at first realized for ASCII characters, and, at that
 129    time, assigned a specific realized fontset.  Hereafter, we call
 130    such a face as `ASCII face'.  When a face for a multibyte character
 131    is realized, it inherits (thus shares) a fontset of an ASCII face
 132    that has the same attributes other than font-related ones.
 133 
 134    Thus, all realized faces have a realized fontset.
 135 
 136 
 137    Unibyte text.
 138 
 139    Unibyte text (i.e. raw 8-bit characters) is displayed with the same
 140    font as ASCII characters.  That is because it is expected that
 141    unibyte text users specify a font that is suitable both for ASCII
 142    and raw 8-bit characters.
 143 
 144 
 145    Font selection.
 146 
 147    Font selection tries to find the best available matching font for a
 148    given (character, face) combination.
 149 
 150    If the face specifies a fontset name, that fontset determines a
 151    pattern for fonts of the given character.  If the face specifies a
 152    font name or the other font-related attributes, a fontset is
 153    realized from the default fontset.  In that case, that
 154    specification determines a pattern for ASCII characters and the
 155    default fontset determines a pattern for multibyte characters.
 156 
 157    Available fonts on the system on which Emacs runs are then matched
 158    against the font pattern.  The result of font selection is the best
 159    match for the given face attributes in this font list.
 160 
 161    Font selection can be influenced by the user.
 162 
 163    1. The user can specify the relative importance he gives the face
 164    attributes width, height, weight, and slant by setting
 165    face-font-selection-order (faces.el) to a list of face attribute
 166    names.  The default is '(:width :height :weight :slant), and means
 167    that font selection first tries to find a good match for the font
 168    width specified by a face, then---within fonts with that
 169    width---tries to find a best match for the specified font height,
 170    etc.
 171 
 172    2. Setting face-font-family-alternatives allows the user to
 173    specify alternative font families to try if a family specified by a
 174    face doesn't exist.
 175 
 176    3. Setting face-font-registry-alternatives allows the user to
 177    specify all alternative font registries to try for a face
 178    specifying a registry.
 179 
 180    4. Setting face-ignored-fonts allows the user to ignore specific
 181    fonts.
 182 
 183 
 184    Character composition.
 185 
 186    Usually, the realization process is already finished when Emacs
 187    actually reflects the desired glyph matrix on the screen.  However,
 188    on displaying a composition (sequence of characters to be composed
 189    on the screen), a suitable font for the components of the
 190    composition is selected and realized while drawing them on the
 191    screen, i.e.  the realization process is delayed but in principle
 192    the same.
 193 
 194 
 195    Initialization of basic faces.
 196 
 197    The faces `default', `modeline' are considered `basic faces'.
 198    When redisplay happens the first time for a newly created frame,
 199    basic faces are realized for CHARSET_ASCII.  Frame parameters are
 200    used to fill in unspecified attributes of the default face.  */
 201 
 202 #include <config.h>
 203 #include <stdio.h>
 204 #include <sys/types.h>
 205 #include <sys/stat.h>
 206 #include <stdio.h>              /* This needs to be before termchar.h */
 207 #include <setjmp.h>
 208 
 209 #include "lisp.h"
 210 #include "character.h"
 211 #include "charset.h"
 212 #include "keyboard.h"
 213 #include "frame.h"
 214 #include "termhooks.h"
 215 
 216 #ifdef HAVE_X_WINDOWS
 217 #include "xterm.h"
 218 #ifdef USE_MOTIF
 219 #include <Xm/Xm.h>
 220 #include <Xm/XmStrDefs.h>
 221 #endif /* USE_MOTIF */
 222 #endif /* HAVE_X_WINDOWS */
 223 
 224 #ifdef MSDOS
 225 #include "dosfns.h"
 226 #endif
 227 
 228 #ifdef WINDOWSNT
 229 #include "w32term.h"
 230 #include "fontset.h"
 231 /* Redefine X specifics to W32 equivalents to avoid cluttering the
 232    code with #ifdef blocks. */
 233 #undef FRAME_X_DISPLAY_INFO
 234 #define FRAME_X_DISPLAY_INFO FRAME_W32_DISPLAY_INFO
 235 #define x_display_info w32_display_info
 236 #define FRAME_X_FONT_TABLE FRAME_W32_FONT_TABLE
 237 #define check_x check_w32
 238 #define GCGraphicsExposures 0
 239 #endif /* WINDOWSNT */
 240 
 241 #ifdef HAVE_NS
 242 #include "nsterm.h"
 243 #undef FRAME_X_DISPLAY_INFO
 244 #define FRAME_X_DISPLAY_INFO FRAME_NS_DISPLAY_INFO
 245 #define x_display_info ns_display_info
 246 #define FRAME_X_FONT_TABLE FRAME_NS_FONT_TABLE
 247 #define check_x check_ns
 248 #define GCGraphicsExposures 0
 249 #endif /* HAVE_NS */
 250 
 251 #include "buffer.h"
 252 #include "dispextern.h"
 253 #include "blockinput.h"
 254 #include "window.h"
 255 #include "intervals.h"
 256 #include "termchar.h"
 257 
 258 #include "font.h"
 259 #ifdef HAVE_WINDOW_SYSTEM
 260 #include "fontset.h"
 261 #endif /* HAVE_WINDOW_SYSTEM */
 262 
 263 #ifdef HAVE_X_WINDOWS
 264 
 265 /* Compensate for a bug in Xos.h on some systems, on which it requires
 266    time.h.  On some such systems, Xos.h tries to redefine struct
 267    timeval and struct timezone if USG is #defined while it is
 268    #included.  */
 269 
 270 #ifdef XOS_NEEDS_TIME_H
 271 #include <time.h>
 272 #undef USG
 273 #include <X11/Xos.h>
 274 #define USG
 275 #define __TIMEVAL__
 276 #else /* not XOS_NEEDS_TIME_H */
 277 #include <X11/Xos.h>
 278 #endif /* not XOS_NEEDS_TIME_H */
 279 
 280 #endif /* HAVE_X_WINDOWS */
 281 
 282 #include <ctype.h>
 283 
 284 /* Number of pt per inch (from the TeXbook).  */
 285 
 286 #define PT_PER_INCH 72.27
 287 
 288 /* Non-zero if face attribute ATTR is unspecified.  */
 289 
 290 #define UNSPECIFIEDP(ATTR) EQ ((ATTR), Qunspecified)
 291 
 292 /* Non-zero if face attribute ATTR is `ignore-defface'.  */
 293 
 294 #define IGNORE_DEFFACE_P(ATTR) EQ ((ATTR), Qignore_defface)
 295 
 296 /* Value is the number of elements of VECTOR.  */
 297 
 298 #define DIM(VECTOR) (sizeof (VECTOR) / sizeof *(VECTOR))
 299 
 300 /* Make a copy of string S on the stack using alloca.  Value is a pointer
 301    to the copy.  */
 302 
 303 #define STRDUPA(S) strcpy ((char *) alloca (strlen ((S)) + 1), (S))
 304 
 305 /* Make a copy of the contents of Lisp string S on the stack using
 306    alloca.  Value is a pointer to the copy.  */
 307 
 308 #define LSTRDUPA(S) STRDUPA (SDATA ((S)))
 309 
 310 /* Size of hash table of realized faces in face caches (should be a
 311    prime number).  */
 312 
 313 #define FACE_CACHE_BUCKETS_SIZE 1001
 314 
 315 /* Keyword symbols used for face attribute names.  */
 316 
 317 Lisp_Object QCfamily, QCheight, QCweight, QCslant, QCunderline;
 318 Lisp_Object QCinverse_video, QCforeground, QCbackground, QCstipple;
 319 Lisp_Object QCwidth, QCfont, QCbold, QCitalic;
 320 Lisp_Object QCreverse_video;
 321 Lisp_Object QCoverline, QCstrike_through, QCbox, QCinherit;
 322 Lisp_Object QCfontset;
 323 
 324 /* Keywords symbols used for font properties.  */
 325 extern Lisp_Object QCfoundry, QCadstyle, QCregistry;
 326 extern Lisp_Object QCspacing, QCsize, QCavgwidth;
 327 extern Lisp_Object Qp;
 328 
 329 /* Symbols used for attribute values.  */
 330 
 331 Lisp_Object Qnormal, Qbold, Qultra_light, Qextra_light, Qlight;
 332 Lisp_Object Qsemi_light, Qsemi_bold, Qextra_bold, Qultra_bold;
 333 Lisp_Object Qoblique, Qitalic, Qreverse_oblique, Qreverse_italic;
 334 Lisp_Object Qultra_condensed, Qextra_condensed, Qcondensed;
 335 Lisp_Object Qsemi_condensed, Qsemi_expanded, Qexpanded, Qextra_expanded;
 336 Lisp_Object Qultra_expanded;
 337 Lisp_Object Qreleased_button, Qpressed_button;
 338 Lisp_Object QCstyle, QCcolor, QCline_width;
 339 Lisp_Object Qunspecified;
 340 Lisp_Object Qignore_defface;
 341 
 342 char unspecified_fg[] = "unspecified-fg", unspecified_bg[] = "unspecified-bg";
 343 
 344 /* The name of the function to call when the background of the frame
 345    has changed, frame_set_background_mode.  */
 346 
 347 Lisp_Object Qframe_set_background_mode;
 348 
 349 /* Names of basic faces.  */
 350 
 351 Lisp_Object Qdefault, Qtool_bar, Qregion, Qfringe;
 352 Lisp_Object Qheader_line, Qscroll_bar, Qcursor, Qborder, Qmouse, Qmenu;
 353 Lisp_Object Qmode_line_inactive, Qvertical_border;
 354 extern Lisp_Object Qmode_line;
 355 
 356 /* The symbol `face-alias'.  A symbols having that property is an
 357    alias for another face.  Value of the property is the name of
 358    the aliased face.  */
 359 
 360 Lisp_Object Qface_alias;
 361 
 362 extern Lisp_Object Qcircular_list;
 363 
 364 /* Default stipple pattern used on monochrome displays.  This stipple
 365    pattern is used on monochrome displays instead of shades of gray
 366    for a face background color.  See `set-face-stipple' for possible
 367    values for this variable.  */
 368 
 369 Lisp_Object Vface_default_stipple;
 370 
 371 /* Alist of alternative font families.  Each element is of the form
 372    (FAMILY FAMILY1 FAMILY2 ...).  If fonts of FAMILY can't be loaded,
 373    try FAMILY1, then FAMILY2, ...  */
 374 
 375 Lisp_Object Vface_alternative_font_family_alist;
 376 
 377 /* Alist of alternative font registries.  Each element is of the form
 378    (REGISTRY REGISTRY1 REGISTRY2...).  If fonts of REGISTRY can't be
 379    loaded, try REGISTRY1, then REGISTRY2, ...  */
 380 
 381 Lisp_Object Vface_alternative_font_registry_alist;
 382 
 383 /* Allowed scalable fonts.  A value of nil means don't allow any
 384    scalable fonts.  A value of t means allow the use of any scalable
 385    font.  Otherwise, value must be a list of regular expressions.  A
 386    font may be scaled if its name matches a regular expression in the
 387    list.  */
 388 
 389 Lisp_Object Vscalable_fonts_allowed, Qscalable_fonts_allowed;
 390 
 391 /* List of regular expressions that matches names of fonts to ignore. */
 392 
 393 Lisp_Object Vface_ignored_fonts;
 394 
 395 /* Alist of font name patterns vs the rescaling factor.  */
 396 
 397 Lisp_Object Vface_font_rescale_alist;
 398 
 399 /* Maximum number of fonts to consider in font_list.  If not an
 400    integer > 0, DEFAULT_FONT_LIST_LIMIT is used instead.  */
 401 
 402 Lisp_Object Vfont_list_limit;
 403 #define DEFAULT_FONT_LIST_LIMIT 100
 404 
 405 /* The symbols `foreground-color' and `background-color' which can be
 406    used as part of a `face' property.  This is for compatibility with
 407    Emacs 20.2.  */
 408 
 409 Lisp_Object Qforeground_color, Qbackground_color;
 410 
 411 /* The symbols `face' and `mouse-face' used as text properties.  */
 412 
 413 Lisp_Object Qface;
 414 extern Lisp_Object Qmouse_face;
 415 
 416 /* Property for basic faces which other faces cannot inherit.  */
 417 
 418 Lisp_Object Qface_no_inherit;
 419 
 420 /* Error symbol for wrong_type_argument in load_pixmap.  */
 421 
 422 Lisp_Object Qbitmap_spec_p;
 423 
 424 /* Alist of global face definitions.  Each element is of the form
 425    (FACE . LFACE) where FACE is a symbol naming a face and LFACE
 426    is a Lisp vector of face attributes.  These faces are used
 427    to initialize faces for new frames.  */
 428 
 429 Lisp_Object Vface_new_frame_defaults;
 430 
 431 /* Alist of face remappings.  Each element is of the form:
 432    (FACE REPLACEMENT...) which causes display of the face FACE to use
 433    REPLACEMENT... instead.  REPLACEMENT... is interpreted the same way
 434    the value of a `face' text property is: it may be (1) A face name,
 435    (2) A list of face names, (3) A property-list of face attribute/value
 436    pairs, or (4) A list of face names intermixed with lists containing
 437    face attribute/value pairs.
 438 
 439    Multiple entries in REPLACEMENT... are merged together to form the final
 440    result, with faces or attributes earlier in the list taking precedence
 441    over those that are later.
 442 
 443    Face-name remapping cycles are suppressed; recursive references use
 444    the underlying face instead of the remapped face.  */
 445 
 446 Lisp_Object Vface_remapping_alist;
 447 
 448 /* The next ID to assign to Lisp faces.  */
 449 
 450 static int next_lface_id;
 451 
 452 /* A vector mapping Lisp face Id's to face names.  */
 453 
 454 static Lisp_Object *lface_id_to_name;
 455 static int lface_id_to_name_size;
 456 
 457 /* TTY color-related functions (defined in tty-colors.el).  */
 458 
 459 Lisp_Object Qtty_color_desc, Qtty_color_by_index, Qtty_color_standard_values;
 460 
 461 /* The name of the function used to compute colors on TTYs.  */
 462 
 463 Lisp_Object Qtty_color_alist;
 464 
 465 /* An alist of defined terminal colors and their RGB values.  */
 466 
 467 Lisp_Object Vtty_defined_color_alist;
 468 
 469 /* Counter for calls to clear_face_cache.  If this counter reaches
 470    CLEAR_FONT_TABLE_COUNT, and a frame has more than
 471    CLEAR_FONT_TABLE_NFONTS load, unused fonts are freed.  */
 472 
 473 static int clear_font_table_count;
 474 #define CLEAR_FONT_TABLE_COUNT  100
 475 #define CLEAR_FONT_TABLE_NFONTS 10
 476 
 477 /* Non-zero means face attributes have been changed since the last
 478    redisplay.  Used in redisplay_internal.  */
 479 
 480 int face_change_count;
 481 
 482 /* Non-zero means don't display bold text if a face's foreground
 483    and background colors are the inverse of the default colors of the
 484    display.   This is a kluge to suppress `bold black' foreground text
 485    which is hard to read on an LCD monitor.  */
 486 
 487 int tty_suppress_bold_inverse_default_colors_p;
 488 
 489 /* A list of the form `((x . y))' used to avoid consing in
 490    Finternal_set_lisp_face_attribute.  */
 491 
 492 static Lisp_Object Vparam_value_alist;
 493 
 494 /* The total number of colors currently allocated.  */
 495 
 496 #if GLYPH_DEBUG
 497 static int ncolors_allocated;
 498 static int npixmaps_allocated;
 499 static int ngcs;
 500 #endif
 501 
 502 /* Non-zero means the definition of the `menu' face for new frames has
 503    been changed.  */
 504 
 505 int menu_face_changed_default;
 506 
 507 
 508 /* Function prototypes.  */
 509 
 510 struct table_entry;
 511 struct named_merge_point;
 512 
 513 static void map_tty_color P_ ((struct frame *, struct face *,
 514                                enum lface_attribute_index, int *));
 515 static Lisp_Object resolve_face_name P_ ((Lisp_Object, int));
 516 static int may_use_scalable_font_p P_ ((const char *));
 517 static void set_font_frame_param P_ ((Lisp_Object, Lisp_Object));
 518 static int get_lface_attributes P_ ((struct frame *, Lisp_Object, Lisp_Object *,
 519                                      int, struct named_merge_point *));
 520 static int load_pixmap P_ ((struct frame *, Lisp_Object, unsigned *, unsigned *));
 521 static struct frame *frame_or_selected_frame P_ ((Lisp_Object, int));
 522 static void load_face_colors P_ ((struct frame *, struct face *, Lisp_Object *));
 523 static void free_face_colors P_ ((struct frame *, struct face *));
 524 static int face_color_gray_p P_ ((struct frame *, char *));
 525 static struct face *realize_face P_ ((struct face_cache *, Lisp_Object *,
 526                                       int));
 527 static struct face *realize_non_ascii_face P_ ((struct frame *, Lisp_Object,
 528                                                 struct face *));
 529 static struct face *realize_x_face P_ ((struct face_cache *, Lisp_Object *));
 530 static struct face *realize_tty_face P_ ((struct face_cache *, Lisp_Object *));
 531 static int realize_basic_faces P_ ((struct frame *));
 532 static int realize_default_face P_ ((struct frame *));
 533 static void realize_named_face P_ ((struct frame *, Lisp_Object, int));
 534 static int lface_fully_specified_p P_ ((Lisp_Object *));
 535 static int lface_equal_p P_ ((Lisp_Object *, Lisp_Object *));
 536 static unsigned hash_string_case_insensitive P_ ((Lisp_Object));
 537 static unsigned lface_hash P_ ((Lisp_Object *));
 538 static int lface_same_font_attributes_p P_ ((Lisp_Object *, Lisp_Object *));
 539 static struct face_cache *make_face_cache P_ ((struct frame *));
 540 static void clear_face_gcs P_ ((struct face_cache *));
 541 static void free_face_cache P_ ((struct face_cache *));
 542 static int face_fontset P_ ((Lisp_Object *));
 543 static void merge_face_vectors P_ ((struct frame *, Lisp_Object *, Lisp_Object*,
 544                                     struct named_merge_point *));
 545 static int merge_face_ref P_ ((struct frame *, Lisp_Object, Lisp_Object *,
 546                                int, struct named_merge_point *));
 547 static int set_lface_from_font P_ ((struct frame *, Lisp_Object, Lisp_Object,
 548                                     int));
 549 static Lisp_Object lface_from_face_name P_ ((struct frame *, Lisp_Object, int));
 550 static struct face *make_realized_face P_ ((Lisp_Object *));
 551 static void cache_face P_ ((struct face_cache *, struct face *, unsigned));
 552 static void uncache_face P_ ((struct face_cache *, struct face *));
 553 
 554 #ifdef HAVE_WINDOW_SYSTEM
 555 
 556 static GC x_create_gc P_ ((struct frame *, unsigned long, XGCValues *));
 557 static void x_free_gc P_ ((struct frame *, GC));
 558 
 559 #ifdef USE_X_TOOLKIT
 560 static void x_update_menu_appearance P_ ((struct frame *));
 561 
 562 extern void free_frame_menubar P_ ((struct frame *));
 563 #endif /* USE_X_TOOLKIT */
 564 
 565 #endif /* HAVE_WINDOW_SYSTEM */
 566 
 567 
 568 /***********************************************************************
 569                               Utilities
 570  ***********************************************************************/
 571 
 572 #ifdef HAVE_X_WINDOWS
 573 
 574 #ifdef DEBUG_X_COLORS
 575 
 576 /* The following is a poor mans infrastructure for debugging X color
 577    allocation problems on displays with PseudoColor-8.  Some X servers
 578    like 3.3.5 XF86_SVGA with Matrox cards apparently don't implement
 579    color reference counts completely so that they don't signal an
 580    error when a color is freed whose reference count is already 0.
 581    Other X servers do.  To help me debug this, the following code
 582    implements a simple reference counting schema of its own, for a
 583    single display/screen.  --gerd.  */
 584 
 585 /* Reference counts for pixel colors.  */
 586 
 587 int color_count[256];
 588 
 589 /* Register color PIXEL as allocated.  */
 590 
 591 void
 592 register_color (pixel)
 593      unsigned long pixel;
 594 {
 595   xassert (pixel < 256);
 596   ++color_count[pixel];
 597 }
 598 
 599 
 600 /* Register color PIXEL as deallocated.  */
 601 
 602 void
 603 unregister_color (pixel)
 604      unsigned long pixel;
 605 {
 606   xassert (pixel < 256);
 607   if (color_count[pixel] > 0)
 608     --color_count[pixel];
 609   else
 610     abort ();
 611 }
 612 
 613 
 614 /* Register N colors from PIXELS as deallocated.  */
 615 
 616 void
 617 unregister_colors (pixels, n)
 618      unsigned long *pixels;
 619      int n;
 620 {
 621   int i;
 622   for (i = 0; i < n; ++i)
 623     unregister_color (pixels[i]);
 624 }
 625 
 626 
 627 DEFUN ("dump-colors", Fdump_colors, Sdump_colors, 0, 0, 0,
 628        doc: /* Dump currently allocated colors to stderr.  */)
 629      ()
 630 {
 631   int i, n;
 632 
 633   fputc ('\n', stderr);
 634 
 635   for (i = n = 0; i < sizeof color_count / sizeof color_count[0]; ++i)
 636     if (color_count[i])
 637       {
 638         fprintf (stderr, "%3d: %5d", i, color_count[i]);
 639         ++n;
 640         if (n % 5 == 0)
 641           fputc ('\n', stderr);
 642         else
 643           fputc ('\t', stderr);
 644       }
 645 
 646   if (n % 5 != 0)
 647     fputc ('\n', stderr);
 648   return Qnil;
 649 }
 650 
 651 #endif /* DEBUG_X_COLORS */
 652 
 653 
 654 /* Free colors used on frame F.  PIXELS is an array of NPIXELS pixel
 655    color values.  Interrupt input must be blocked when this function
 656    is called.  */
 657 
 658 void
 659 x_free_colors (f, pixels, npixels)
 660      struct frame *f;
 661      unsigned long *pixels;
 662      int npixels;
 663 {
 664   int class = FRAME_X_DISPLAY_INFO (f)->visual->class;
 665 
 666   /* If display has an immutable color map, freeing colors is not
 667      necessary and some servers don't allow it.  So don't do it.  */
 668   if (class != StaticColor && class != StaticGray && class != TrueColor)
 669     {
 670 #ifdef DEBUG_X_COLORS
 671       unregister_colors (pixels, npixels);
 672 #endif
 673       XFreeColors (FRAME_X_DISPLAY (f), FRAME_X_COLORMAP (f),
 674                    pixels, npixels, 0);
 675     }
 676 }
 677 
 678 
 679 /* Free colors used on frame F.  PIXELS is an array of NPIXELS pixel
 680    color values.  Interrupt input must be blocked when this function
 681    is called.  */
 682 
 683 void
 684 x_free_dpy_colors (dpy, screen, cmap, pixels, npixels)
 685      Display *dpy;
 686      Screen *screen;
 687      Colormap cmap;
 688      unsigned long *pixels;
 689      int npixels;
 690 {
 691   struct x_display_info *dpyinfo = x_display_info_for_display (dpy);
 692   int class = dpyinfo->visual->class;
 693 
 694   /* If display has an immutable color map, freeing colors is not
 695      necessary and some servers don't allow it.  So don't do it.  */
 696   if (class != StaticColor && class != StaticGray && class != TrueColor)
 697     {
 698 #ifdef DEBUG_X_COLORS
 699       unregister_colors (pixels, npixels);
 700 #endif
 701       XFreeColors (dpy, cmap, pixels, npixels, 0);
 702     }
 703 }
 704 
 705 
 706 /* Create and return a GC for use on frame F.  GC values and mask
 707    are given by XGCV and MASK.  */
 708 
 709 static INLINE GC
 710 x_create_gc (f, mask, xgcv)
 711      struct frame *f;
 712      unsigned long mask;
 713      XGCValues *xgcv;
 714 {
 715   GC gc;
 716   BLOCK_INPUT;
 717   gc = XCreateGC (FRAME_X_DISPLAY (f), FRAME_X_WINDOW (f), mask, xgcv);
 718   UNBLOCK_INPUT;
 719   IF_DEBUG (++ngcs);
 720   return gc;
 721 }
 722 
 723 
 724 /* Free GC which was used on frame F.  */
 725 
 726 static INLINE void
 727 x_free_gc (f, gc)
 728      struct frame *f;
 729      GC gc;
 730 {
 731   eassert (interrupt_input_blocked);
 732   IF_DEBUG (xassert (--ngcs >= 0));
 733   XFreeGC (FRAME_X_DISPLAY (f), gc);
 734 }
 735 
 736 #endif /* HAVE_X_WINDOWS */
 737 
 738 #ifdef WINDOWSNT
 739 /* W32 emulation of GCs */
 740 
 741 static INLINE GC
 742 x_create_gc (f, mask, xgcv)
 743      struct frame *f;
 744      unsigned long mask;
 745      XGCValues *xgcv;
 746 {
 747   GC gc;
 748   BLOCK_INPUT;
 749   gc = XCreateGC (NULL, FRAME_W32_WINDOW (f), mask, xgcv);
 750   UNBLOCK_INPUT;
 751   IF_DEBUG (++ngcs);
 752   return gc;
 753 }
 754 
 755 
 756 /* Free GC which was used on frame F.  */
 757 
 758 static INLINE void
 759 x_free_gc (f, gc)
 760      struct frame *f;
 761      GC gc;
 762 {
 763   IF_DEBUG (xassert (--ngcs >= 0));
 764   xfree (gc);
 765 }
 766 
 767 #endif  /* WINDOWSNT */
 768 
 769 #ifdef HAVE_NS
 770 /* NS emulation of GCs */
 771 
 772 static INLINE GC
 773 x_create_gc (f, mask, xgcv)
 774      struct frame *f;
 775      unsigned long mask;
 776      XGCValues *xgcv;
 777 {
 778   GC gc = xmalloc (sizeof (*gc));
 779   if (gc)
 780       bcopy(xgcv, gc, sizeof(XGCValues));
 781   return gc;
 782 }
 783 
 784 static INLINE void
 785 x_free_gc (f, gc)
 786      struct frame *f;
 787      GC gc;
 788 {
 789   xfree (gc);
 790 }
 791 #endif  /* HAVE_NS */
 792 
 793 /* Like strcasecmp/stricmp.  Used to compare parts of font names which
 794    are in ISO8859-1.  */
 795 
 796 int
 797 xstrcasecmp (s1, s2)
 798      const unsigned char *s1, *s2;
 799 {
 800   while (*s1 && *s2)
 801     {
 802       unsigned char c1 = tolower (*s1);
 803       unsigned char c2 = tolower (*s2);
 804       if (c1 != c2)
 805         return c1 < c2 ? -1 : 1;
 806       ++s1, ++s2;
 807     }
 808 
 809   if (*s1 == 0)
 810     return *s2 == 0 ? 0 : -1;
 811   return 1;
 812 }
 813 
 814 
 815 /* If FRAME is nil, return a pointer to the selected frame.
 816    Otherwise, check that FRAME is a live frame, and return a pointer
 817    to it.  NPARAM is the parameter number of FRAME, for
 818    CHECK_LIVE_FRAME.  This is here because it's a frequent pattern in
 819    Lisp function definitions.  */
 820 
 821 static INLINE struct frame *
 822 frame_or_selected_frame (frame, nparam)
 823      Lisp_Object frame;
 824      int nparam;
 825 {
 826   if (NILP (frame))
 827     frame = selected_frame;
 828 
 829   CHECK_LIVE_FRAME (frame);
 830   return XFRAME (frame);
 831 }
 832 
 833 
 834 /***********************************************************************
 835                            Frames and faces
 836  ***********************************************************************/
 837 
 838 /* Initialize face cache and basic faces for frame F.  */
 839 
 840 void
 841 init_frame_faces (f)
 842      struct frame *f;
 843 {
 844   /* Make a face cache, if F doesn't have one.  */
 845   if (FRAME_FACE_CACHE (f) == NULL)
 846     FRAME_FACE_CACHE (f) = make_face_cache (f);
 847 
 848 #ifdef HAVE_WINDOW_SYSTEM
 849   /* Make the image cache.  */
 850   if (FRAME_WINDOW_P (f))
 851     {
 852       /* We initialize the image cache when creating the first frame
 853          on a terminal, and not during terminal creation.  This way,
 854          `x-open-connection' on a tty won't create an image cache.  */
 855       if (FRAME_IMAGE_CACHE (f) == NULL)
 856         FRAME_IMAGE_CACHE (f) = make_image_cache ();
 857       ++FRAME_IMAGE_CACHE (f)->refcount;
 858     }
 859 #endif /* HAVE_WINDOW_SYSTEM */
 860 
 861   /* Realize basic faces.  Must have enough information in frame
 862      parameters to realize basic faces at this point.  */
 863 #ifdef HAVE_X_WINDOWS
 864   if (!FRAME_X_P (f) || FRAME_X_WINDOW (f))
 865 #endif
 866 #ifdef WINDOWSNT
 867   if (!FRAME_WINDOW_P (f) || FRAME_W32_WINDOW (f))
 868 #endif
 869 #ifdef HAVE_NS
 870   if (!FRAME_NS_P (f) || FRAME_NS_WINDOW (f))
 871 #endif
 872     if (!realize_basic_faces (f))
 873         abort ();
 874 }
 875 
 876 
 877 /* Free face cache of frame F.  Called from delete_frame.  */
 878 
 879 void
 880 free_frame_faces (f)
 881      struct frame *f;
 882 {
 883   struct face_cache *face_cache = FRAME_FACE_CACHE (f);
 884 
 885   if (face_cache)
 886     {
 887       free_face_cache (face_cache);
 888       FRAME_FACE_CACHE (f) = NULL;
 889     }
 890 
 891 #ifdef HAVE_WINDOW_SYSTEM
 892   if (FRAME_WINDOW_P (f))
 893     {
 894       struct image_cache *image_cache = FRAME_IMAGE_CACHE (f);
 895       if (image_cache)
 896         {
 897           --image_cache->refcount;
 898           if (image_cache->refcount == 0)
 899             free_image_cache (f);
 900         }
 901     }
 902 #endif /* HAVE_WINDOW_SYSTEM */
 903 }
 904 
 905 
 906 /* Clear face caches, and recompute basic faces for frame F.  Call
 907    this after changing frame parameters on which those faces depend,
 908    or when realized faces have been freed due to changing attributes
 909    of named faces. */
 910 
 911 void
 912 recompute_basic_faces (f)
 913      struct frame *f;
 914 {
 915   if (FRAME_FACE_CACHE (f))
 916     {
 917       clear_face_cache (0);
 918       if (!realize_basic_faces (f))
 919         abort ();
 920     }
 921 }
 922 
 923 
 924 /* Clear the face caches of all frames.  CLEAR_FONTS_P non-zero means
 925    try to free unused fonts, too.  */
 926 
 927 void
 928 clear_face_cache (clear_fonts_p)
 929      int clear_fonts_p;
 930 {
 931 #ifdef HAVE_WINDOW_SYSTEM
 932   Lisp_Object tail, frame;
 933   struct frame *f;
 934 
 935   if (clear_fonts_p
 936       || ++clear_font_table_count == CLEAR_FONT_TABLE_COUNT)
 937     {
 938 #if 0
 939       /* Not yet implemented.  */
 940       clear_font_cache (frame);
 941 #endif
 942 
 943       /* From time to time see if we can unload some fonts.  This also
 944          frees all realized faces on all frames.  Fonts needed by
 945          faces will be loaded again when faces are realized again.  */
 946       clear_font_table_count = 0;
 947 
 948       FOR_EACH_FRAME (tail, frame)
 949         {
 950           struct frame *f = XFRAME (frame);
 951           if (FRAME_WINDOW_P (f)
 952               && FRAME_X_DISPLAY_INFO (f)->n_fonts > CLEAR_FONT_TABLE_NFONTS)
 953             free_all_realized_faces (frame);
 954         }
 955     }
 956   else
 957     {
 958       /* Clear GCs of realized faces.  */
 959       FOR_EACH_FRAME (tail, frame)
 960         {
 961           f = XFRAME (frame);
 962           if (FRAME_WINDOW_P (f))
 963               clear_face_gcs (FRAME_FACE_CACHE (f));
 964         }
 965       clear_image_caches (Qnil);
 966     }
 967 #endif /* HAVE_WINDOW_SYSTEM */
 968 }
 969 
 970 
 971 DEFUN ("clear-face-cache", Fclear_face_cache, Sclear_face_cache, 0, 1, 0,
 972        doc: /* Clear face caches on all frames.
 973 Optional THOROUGHLY non-nil means try to free unused fonts, too.  */)
 974      (thoroughly)
 975      Lisp_Object thoroughly;
 976 {
 977   clear_face_cache (!NILP (thoroughly));
 978   ++face_change_count;
 979   ++windows_or_buffers_changed;
 980   return Qnil;
 981 }
 982 
 983 
 984 /***********************************************************************
 985                               X Pixmaps
 986  ***********************************************************************/
 987 
 988 #ifdef HAVE_WINDOW_SYSTEM
 989 
 990 DEFUN ("bitmap-spec-p", Fbitmap_spec_p, Sbitmap_spec_p, 1, 1, 0,
 991        doc: /* Value is non-nil if OBJECT is a valid bitmap specification.
 992 A bitmap specification is either a string, a file name, or a list
 993 \(WIDTH HEIGHT DATA) where WIDTH is the pixel width of the bitmap,
 994 HEIGHT is its height, and DATA is a string containing the bits of
 995 the pixmap.  Bits are stored row by row, each row occupies
 996 \(WIDTH + 7)/8 bytes.  */)
 997      (object)
 998      Lisp_Object object;
 999 {
1000   int pixmap_p = 0;
1001 
1002   if (STRINGP (object))
1003     /* If OBJECT is a string, it's a file name.  */
1004     pixmap_p = 1;
1005   else if (CONSP (object))
1006     {
1007       /* Otherwise OBJECT must be (WIDTH HEIGHT DATA), WIDTH and
1008          HEIGHT must be integers > 0, and DATA must be string large
1009          enough to hold a bitmap of the specified size.  */
1010       Lisp_Object width, height, data;
1011 
1012       height = width = data = Qnil;
1013 
1014       if (CONSP (object))
1015         {
1016           width = XCAR (object);
1017           object = XCDR (object);
1018           if (CONSP (object))
1019             {
1020               height = XCAR (object);
1021               object = XCDR (object);
1022               if (CONSP (object))
1023                 data = XCAR (object);
1024             }
1025         }
1026 
1027       if (NATNUMP (width) && NATNUMP (height) && STRINGP (data))
1028         {
1029           int bytes_per_row = ((XFASTINT (width) + BITS_PER_CHAR - 1)
1030                                / BITS_PER_CHAR);
1031           if (SBYTES (data) >= bytes_per_row * XINT (height))
1032             pixmap_p = 1;
1033         }
1034     }
1035 
1036   return pixmap_p ? Qt : Qnil;
1037 }
1038 
1039 
1040 /* Load a bitmap according to NAME (which is either a file name or a
1041    pixmap spec) for use on frame F.  Value is the bitmap_id (see
1042    xfns.c).  If NAME is nil, return with a bitmap id of zero.  If
1043    bitmap cannot be loaded, display a message saying so, and return
1044    zero.  Store the bitmap width in *W_PTR and its height in *H_PTR,
1045    if these pointers are not null.  */
1046 
1047 static int
1048 load_pixmap (f, name, w_ptr, h_ptr)
1049      FRAME_PTR f;
1050      Lisp_Object name;
1051      unsigned int *w_ptr, *h_ptr;
1052 {
1053   int bitmap_id;
1054 
1055   if (NILP (name))
1056     return 0;
1057 
1058   CHECK_TYPE (!NILP (Fbitmap_spec_p (name)), Qbitmap_spec_p, name);
1059 
1060   BLOCK_INPUT;
1061   if (CONSP (name))
1062     {
1063       /* Decode a bitmap spec into a bitmap.  */
1064 
1065       int h, w;
1066       Lisp_Object bits;
1067 
1068       w = XINT (Fcar (name));
1069       h = XINT (Fcar (Fcdr (name)));
1070       bits = Fcar (Fcdr (Fcdr (name)));
1071 
1072       bitmap_id = x_create_bitmap_from_data (f, SDATA (bits),
1073                                              w, h);
1074     }
1075   else
1076     {
1077       /* It must be a string -- a file name.  */
1078       bitmap_id = x_create_bitmap_from_file (f, name);
1079     }
1080   UNBLOCK_INPUT;
1081 
1082   if (bitmap_id < 0)
1083     {
1084       add_to_log ("Invalid or undefined bitmap `%s'", name, Qnil);
1085       bitmap_id = 0;
1086 
1087       if (w_ptr)
1088         *w_ptr = 0;
1089       if (h_ptr)
1090         *h_ptr = 0;
1091     }
1092   else
1093     {
1094 #if GLYPH_DEBUG
1095       ++npixmaps_allocated;
1096 #endif
1097       if (w_ptr)
1098         *w_ptr = x_bitmap_width (f, bitmap_id);
1099 
1100       if (h_ptr)
1101         *h_ptr = x_bitmap_height (f, bitmap_id);
1102     }
1103 
1104   return bitmap_id;
1105 }
1106 
1107 #endif /* HAVE_WINDOW_SYSTEM */
1108 
1109 
1110 
1111 /***********************************************************************
1112                                 X Colors
1113  ***********************************************************************/
1114 
1115 /* Parse RGB_LIST, and fill in the RGB fields of COLOR.
1116    RGB_LIST should contain (at least) 3 lisp integers.
1117    Return 0 if there's a problem with RGB_LIST, otherwise return 1.  */
1118 
1119 static int
1120 parse_rgb_list (rgb_list, color)
1121      Lisp_Object rgb_list;
1122      XColor *color;
1123 {
1124 #define PARSE_RGB_LIST_FIELD(field)                                     \
1125   if (CONSP (rgb_list) && INTEGERP (XCAR (rgb_list)))                   \
1126     {                                                                   \
1127       color->field = XINT (XCAR (rgb_list));                            \
1128       rgb_list = XCDR (rgb_list);                                       \
1129     }                                                                   \
1130   else                                                                  \
1131     return 0;
1132 
1133   PARSE_RGB_LIST_FIELD (red);
1134   PARSE_RGB_LIST_FIELD (green);
1135   PARSE_RGB_LIST_FIELD (blue);
1136 
1137   return 1;
1138 }
1139 
1140 
1141 /* Lookup on frame F the color described by the lisp string COLOR.
1142    The resulting tty color is returned in TTY_COLOR; if STD_COLOR is
1143    non-zero, then the `standard' definition of the same color is
1144    returned in it.  */
1145 
1146 static int
1147 tty_lookup_color (f, color, tty_color, std_color)
1148      struct frame *f;
1149      Lisp_Object color;
1150      XColor *tty_color, *std_color;
1151 {
1152   Lisp_Object frame, color_desc;
1153 
1154   if (!STRINGP (color) || NILP (Ffboundp (Qtty_color_desc)))
1155     return 0;
1156 
1157   XSETFRAME (frame, f);
1158 
1159   color_desc = call2 (Qtty_color_desc, color, frame);
1160   if (CONSP (color_desc) && CONSP (XCDR (color_desc)))
1161     {
1162       Lisp_Object rgb;
1163 
1164       if (! INTEGERP (XCAR (XCDR (color_desc))))
1165         return 0;
1166 
1167       tty_color->pixel = XINT (XCAR (XCDR (color_desc)));
1168 
1169       rgb = XCDR (XCDR (color_desc));
1170       if (! parse_rgb_list (rgb, tty_color))
1171         return 0;
1172 
1173       /* Should we fill in STD_COLOR too?  */
1174       if (std_color)
1175         {
1176           /* Default STD_COLOR to the same as TTY_COLOR.  */
1177           *std_color = *tty_color;
1178 
1179           /* Do a quick check to see if the returned descriptor is
1180              actually _exactly_ equal to COLOR, otherwise we have to
1181              lookup STD_COLOR separately.  If it's impossible to lookup
1182              a standard color, we just give up and use TTY_COLOR.  */
1183           if ((!STRINGP (XCAR (color_desc))
1184                || NILP (Fstring_equal (color, XCAR (color_desc))))
1185               && !NILP (Ffboundp (Qtty_color_standard_values)))
1186             {
1187               /* Look up STD_COLOR separately.  */
1188               rgb = call1 (Qtty_color_standard_values, color);
1189               if (! parse_rgb_list (rgb, std_color))
1190                 return 0;
1191             }
1192         }
1193 
1194       return 1;
1195     }
1196   else if (NILP (Fsymbol_value (intern ("tty-defined-color-alist"))))
1197     /* We were called early during startup, and the colors are not
1198        yet set up in tty-defined-color-alist.  Don't return a failure
1199        indication, since this produces the annoying "Unable to
1200        load color" messages in the *Messages* buffer.  */
1201     return 1;
1202   else
1203     /* tty-color-desc seems to have returned a bad value.  */
1204     return 0;
1205 }
1206 
1207 /* A version of defined_color for non-X frames.  */
1208 
1209 int
1210 tty_defined_color (f, color_name, color_def, alloc)
1211      struct frame *f;
1212      char *color_name;
1213      XColor *color_def;
1214      int alloc;
1215 {
1216   int status = 1;
1217 
1218   /* Defaults.  */
1219   color_def->pixel = FACE_TTY_DEFAULT_COLOR;
1220   color_def->red = 0;
1221   color_def->blue = 0;
1222   color_def->green = 0;
1223 
1224   if (*color_name)
1225     status = tty_lookup_color (f, build_string (color_name), color_def, NULL);
1226 
1227   if (color_def->pixel == FACE_TTY_DEFAULT_COLOR && *color_name)
1228     {
1229       if (strcmp (color_name, "unspecified-fg") == 0)
1230         color_def->pixel = FACE_TTY_DEFAULT_FG_COLOR;
1231       else if (strcmp (color_name, "unspecified-bg") == 0)
1232         color_def->pixel = FACE_TTY_DEFAULT_BG_COLOR;
1233     }
1234 
1235   if (color_def->pixel != FACE_TTY_DEFAULT_COLOR)
1236     status = 1;
1237 
1238   return status;
1239 }
1240 
1241 
1242 /* Decide if color named COLOR_NAME is valid for the display
1243    associated with the frame F; if so, return the rgb values in
1244    COLOR_DEF.  If ALLOC is nonzero, allocate a new colormap cell.
1245 
1246    This does the right thing for any type of frame.  */
1247 
1248 int
1249 defined_color (f, color_name, color_def, alloc)
1250      struct frame *f;
1251      char *color_name;
1252      XColor *color_def;
1253      int alloc;
1254 {
1255   if (!FRAME_WINDOW_P (f))
1256     return tty_defined_color (f, color_name, color_def, alloc);
1257 #ifdef HAVE_X_WINDOWS
1258   else if (FRAME_X_P (f))
1259     return x_defined_color (f, color_name, color_def, alloc);
1260 #endif
1261 #ifdef WINDOWSNT
1262   else if (FRAME_W32_P (f))
1263     return w32_defined_color (f, color_name, color_def, alloc);
1264 #endif
1265 #ifdef HAVE_NS
1266   else if (FRAME_NS_P (f))
1267     return ns_defined_color (f, color_name, color_def, alloc, 1);
1268 #endif
1269   else
1270     abort ();
1271 }
1272 
1273 
1274 /* Given the index IDX of a tty color on frame F, return its name, a
1275    Lisp string.  */
1276 
1277 Lisp_Object
1278 tty_color_name (f, idx)
1279      struct frame *f;
1280      int idx;
1281 {
1282   if (idx >= 0 && !NILP (Ffboundp (Qtty_color_by_index)))
1283     {
1284       Lisp_Object frame;
1285       Lisp_Object coldesc;
1286 
1287       XSETFRAME (frame, f);
1288       coldesc = call2 (Qtty_color_by_index, make_number (idx), frame);
1289 
1290       if (!NILP (coldesc))
1291         return XCAR (coldesc);
1292     }
1293 #ifdef MSDOS
1294   /* We can have an MSDOG frame under -nw for a short window of
1295      opportunity before internal_terminal_init is called.  DTRT.  */
1296   if (FRAME_MSDOS_P (f) && !inhibit_window_system)
1297     return msdos_stdcolor_name (idx);
1298 #endif
1299 
1300   if (idx == FACE_TTY_DEFAULT_FG_COLOR)
1301     return build_string (unspecified_fg);
1302   if (idx == FACE_TTY_DEFAULT_BG_COLOR)
1303     return build_string (unspecified_bg);
1304 
1305   return Qunspecified;
1306 }
1307 
1308 
1309 /* Return non-zero if COLOR_NAME is a shade of gray (or white or
1310    black) on frame F.
1311 
1312    The criterion implemented here is not a terribly sophisticated one.  */
1313 
1314 static int
1315 face_color_gray_p (f, color_name)
1316      struct frame *f;
1317      char *color_name;
1318 {
1319   XColor color;
1320   int gray_p;
1321 
1322   if (defined_color (f, color_name, &color, 0))
1323     gray_p = (/* Any color sufficiently close to black counts as grey.  */
1324               (color.red < 5000 && color.green < 5000 && color.blue < 5000)
1325               ||
1326               ((eabs (color.red - color.green)
1327                 < max (color.red, color.green) / 20)
1328                && (eabs (color.green - color.blue)
1329                    < max (color.green, color.blue) / 20)
1330                && (eabs (color.blue - color.red)
1331                    < max (color.blue, color.red) / 20)));
1332   else
1333     gray_p = 0;
1334 
1335   return gray_p;
1336 }
1337 
1338 
1339 /* Return non-zero if color COLOR_NAME can be displayed on frame F.
1340    BACKGROUND_P non-zero means the color will be used as background
1341    color.  */
1342 
1343 static int
1344 face_color_supported_p (f, color_name, background_p)
1345      struct frame *f;
1346      char *color_name;
1347      int background_p;
1348 {
1349   Lisp_Object frame;
1350   XColor not_used;
1351 
1352   XSETFRAME (frame, f);
1353   return
1354 #ifdef HAVE_WINDOW_SYSTEM
1355     FRAME_WINDOW_P (f)
1356     ? (!NILP (Fxw_display_color_p (frame))
1357        || xstrcasecmp (color_name, "black") == 0
1358        || xstrcasecmp (color_name, "white") == 0
1359        || (background_p
1360            && face_color_gray_p (f, color_name))
1361        || (!NILP (Fx_display_grayscale_p (frame))
1362            && face_color_gray_p (f, color_name)))
1363     :
1364 #endif
1365     tty_defined_color (f, color_name, &not_used, 0);
1366 }
1367 
1368 
1369 DEFUN ("color-gray-p", Fcolor_gray_p, Scolor_gray_p, 1, 2, 0,
1370        doc: /* Return non-nil if COLOR is a shade of gray (or white or black).
1371 FRAME specifies the frame and thus the display for interpreting COLOR.
1372 If FRAME is nil or omitted, use the selected frame.  */)
1373      (color, frame)
1374      Lisp_Object color, frame;
1375 {
1376   struct frame *f;
1377 
1378   CHECK_STRING (color);
1379   if (NILP (frame))
1380     frame = selected_frame;
1381   else
1382     CHECK_FRAME (frame);
1383   f = XFRAME (frame);
1384   return face_color_gray_p (f, SDATA (color)) ? Qt : Qnil;
1385 }
1386 
1387 
1388 DEFUN ("color-supported-p", Fcolor_supported_p,
1389        Scolor_supported_p, 1, 3, 0,
1390        doc: /* Return non-nil if COLOR can be displayed on FRAME.
1391 BACKGROUND-P non-nil means COLOR is used as a background.
1392 Otherwise, this function tells whether it can be used as a foreground.
1393 If FRAME is nil or omitted, use the selected frame.
1394 COLOR must be a valid color name.  */)
1395      (color, frame, background_p)
1396      Lisp_Object frame, color, background_p;
1397 {
1398   struct frame *f;
1399 
1400   CHECK_STRING (color);
1401   if (NILP (frame))
1402     frame = selected_frame;
1403   else
1404     CHECK_FRAME (frame);
1405   f = XFRAME (frame);
1406   if (face_color_supported_p (f, SDATA (color), !NILP (background_p)))
1407     return Qt;
1408   return Qnil;
1409 }
1410 
1411 
1412 /* Load color with name NAME for use by face FACE on frame F.
1413    TARGET_INDEX must be one of LFACE_FOREGROUND_INDEX,
1414    LFACE_BACKGROUND_INDEX, LFACE_UNDERLINE_INDEX, LFACE_OVERLINE_INDEX,
1415    LFACE_STRIKE_THROUGH_INDEX, or LFACE_BOX_INDEX.  Value is the
1416    pixel color.  If color cannot be loaded, display a message, and
1417    return the foreground, background or underline color of F, but
1418    record that fact in flags of the face so that we don't try to free
1419    these colors.  */
1420 
1421 unsigned long
1422 load_color (f, face, name, target_index)
1423      struct frame *f;
1424      struct face *face;
1425      Lisp_Object name;
1426      enum lface_attribute_index target_index;
1427 {
1428   XColor color;
1429 
1430   xassert (STRINGP (name));
1431   xassert (target_index == LFACE_FOREGROUND_INDEX
1432            || target_index == LFACE_BACKGROUND_INDEX
1433            || target_index == LFACE_UNDERLINE_INDEX
1434            || target_index == LFACE_OVERLINE_INDEX
1435            || target_index == LFACE_STRIKE_THROUGH_INDEX
1436            || target_index == LFACE_BOX_INDEX);
1437 
1438   /* if the color map is full, defined_color will return a best match
1439      to the values in an existing cell. */
1440   if (!defined_color (f, SDATA (name), &color, 1))
1441     {
1442       add_to_log ("Unable to load color \"%s\"", name, Qnil);
1443 
1444       switch (target_index)
1445         {
1446         case LFACE_FOREGROUND_INDEX:
1447           face->foreground_defaulted_p = 1;
1448           color.pixel = FRAME_FOREGROUND_PIXEL (f);
1449           break;
1450 
1451         case LFACE_BACKGROUND_INDEX:
1452           face->background_defaulted_p = 1;
1453           color.pixel = FRAME_BACKGROUND_PIXEL (f);
1454           break;
1455 
1456         case LFACE_UNDERLINE_INDEX:
1457           face->underline_defaulted_p = 1;
1458           color.pixel = FRAME_FOREGROUND_PIXEL (f);
1459           break;
1460 
1461         case LFACE_OVERLINE_INDEX:
1462           face->overline_color_defaulted_p = 1;
1463           color.pixel = FRAME_FOREGROUND_PIXEL (f);
1464           break;
1465 
1466         case LFACE_STRIKE_THROUGH_INDEX:
1467           face->strike_through_color_defaulted_p = 1;
1468           color.pixel = FRAME_FOREGROUND_PIXEL (f);
1469           break;
1470 
1471         case LFACE_BOX_INDEX:
1472           face->box_color_defaulted_p = 1;
1473           color.pixel = FRAME_FOREGROUND_PIXEL (f);
1474           break;
1475 
1476         default:
1477           abort ();
1478         }
1479     }
1480 #if GLYPH_DEBUG
1481   else
1482     ++ncolors_allocated;
1483 #endif
1484 
1485   return color.pixel;
1486 }
1487 
1488 
1489 #ifdef HAVE_WINDOW_SYSTEM
1490 
1491 /* Load colors for face FACE which is used on frame F.  Colors are
1492    specified by slots LFACE_BACKGROUND_INDEX and LFACE_FOREGROUND_INDEX
1493    of ATTRS.  If the background color specified is not supported on F,
1494    try to emulate gray colors with a stipple from Vface_default_stipple.  */
1495 
1496 static void
1497 load_face_colors (f, face, attrs)
1498      struct frame *f;
1499      struct face *face;
1500      Lisp_Object *attrs;
1501 {
1502   Lisp_Object fg, bg;
1503 
1504   bg = attrs[LFACE_BACKGROUND_INDEX];
1505   fg = attrs[LFACE_FOREGROUND_INDEX];
1506 
1507   /* Swap colors if face is inverse-video.  */
1508   if (EQ (attrs[LFACE_INVERSE_INDEX], Qt))
1509     {
1510       Lisp_Object tmp;
1511       tmp = fg;
1512       fg = bg;
1513       bg = tmp;
1514     }
1515 
1516   /* Check for support for foreground, not for background because
1517      face_color_supported_p is smart enough to know that grays are
1518      "supported" as background because we are supposed to use stipple
1519      for them.  */
1520   if (!face_color_supported_p (f, SDATA (bg), 0)
1521       && !NILP (Fbitmap_spec_p (Vface_default_stipple)))
1522     {
1523       x_destroy_bitmap (f, face->stipple);
1524       face->stipple = load_pixmap (f, Vface_default_stipple,
1525                                    &face->pixmap_w, &face->pixmap_h);
1526     }
1527 
1528   face->background = load_color (f, face, bg, LFACE_BACKGROUND_INDEX);
1529   face->foreground = load_color (f, face, fg, LFACE_FOREGROUND_INDEX);
1530 }
1531 
1532 
1533 /* Free color PIXEL on frame F.  */
1534 
1535 void
1536 unload_color (f, pixel)
1537      struct frame *f;
1538      unsigned long pixel;
1539 {
1540 #ifdef HAVE_X_WINDOWS
1541   if (pixel != -1)
1542     {
1543       BLOCK_INPUT;
1544       x_free_colors (f, &pixel, 1);
1545       UNBLOCK_INPUT;
1546     }
1547 #endif
1548 }
1549 
1550 
1551 /* Free colors allocated for FACE.  */
1552 
1553 static void
1554 free_face_colors (f, face)
1555      struct frame *f;
1556      struct face *face;
1557 {
1558 /* PENDING(NS): need to do something here? */
1559 #ifdef HAVE_X_WINDOWS
1560   if (face->colors_copied_bitwise_p)
1561     return;
1562 
1563   BLOCK_INPUT;
1564 
1565   if (!face->foreground_defaulted_p)
1566     {
1567       x_free_colors (f, &face->foreground, 1);
1568       IF_DEBUG (--ncolors_allocated);
1569     }
1570 
1571   if (!face->background_defaulted_p)
1572     {
1573       x_free_colors (f, &face->background, 1);
1574       IF_DEBUG (--ncolors_allocated);
1575     }
1576 
1577   if (face->underline_p
1578       && !face->underline_defaulted_p)
1579     {
1580       x_free_colors (f, &face->underline_color, 1);
1581       IF_DEBUG (--ncolors_allocated);
1582     }
1583 
1584   if (face->overline_p
1585       && !face->overline_color_defaulted_p)
1586     {
1587       x_free_colors (f, &face->overline_color, 1);
1588       IF_DEBUG (--ncolors_allocated);
1589     }
1590 
1591   if (face->strike_through_p
1592       && !face->strike_through_color_defaulted_p)
1593     {
1594       x_free_colors (f, &face->strike_through_color, 1);
1595       IF_DEBUG (--ncolors_allocated);
1596     }
1597 
1598   if (face->box != FACE_NO_BOX
1599       && !face->box_color_defaulted_p)
1600     {
1601       x_free_colors (f, &face->box_color, 1);
1602       IF_DEBUG (--ncolors_allocated);
1603     }
1604 
1605   UNBLOCK_INPUT;
1606 #endif /* HAVE_X_WINDOWS */
1607 }
1608 
1609 #endif /* HAVE_WINDOW_SYSTEM */
1610 
1611 
1612 
1613 /***********************************************************************
1614                            XLFD Font Names
1615  ***********************************************************************/
1616 
1617 /* An enumerator for each field of an XLFD font name.  */
1618 
1619 enum xlfd_field
1620 {
1621   XLFD_FOUNDRY,
1622   XLFD_FAMILY,
1623   XLFD_WEIGHT,
1624   XLFD_SLANT,
1625   XLFD_SWIDTH,
1626   XLFD_ADSTYLE,
1627   XLFD_PIXEL_SIZE,
1628   XLFD_POINT_SIZE,
1629   XLFD_RESX,
1630   XLFD_RESY,
1631   XLFD_SPACING,
1632   XLFD_AVGWIDTH,
1633   XLFD_REGISTRY,
1634   XLFD_ENCODING,
1635   XLFD_LAST
1636 };
1637 
1638 /* An enumerator for each possible slant value of a font.  Taken from
1639    the XLFD specification.  */
1640 
1641 enum xlfd_slant
1642 {
1643   XLFD_SLANT_UNKNOWN,
1644   XLFD_SLANT_ROMAN,
1645   XLFD_SLANT_ITALIC,
1646   XLFD_SLANT_OBLIQUE,
1647   XLFD_SLANT_REVERSE_ITALIC,
1648   XLFD_SLANT_REVERSE_OBLIQUE,
1649   XLFD_SLANT_OTHER
1650 };
1651 
1652 /* Relative font weight according to XLFD documentation.  */
1653 
1654 enum xlfd_weight
1655 {
1656   XLFD_WEIGHT_UNKNOWN,
1657   XLFD_WEIGHT_ULTRA_LIGHT,      /* 10 */
1658   XLFD_WEIGHT_EXTRA_LIGHT,      /* 20 */
1659   XLFD_WEIGHT_LIGHT,            /* 30 */
1660   XLFD_WEIGHT_SEMI_LIGHT,       /* 40: SemiLight, Book, ...  */
1661   XLFD_WEIGHT_MEDIUM,           /* 50: Medium, Normal, Regular, ...  */
1662   XLFD_WEIGHT_SEMI_BOLD,        /* 60: SemiBold, DemiBold, ...  */
1663   XLFD_WEIGHT_BOLD,             /* 70: Bold, ... */
1664   XLFD_WEIGHT_EXTRA_BOLD,       /* 80: ExtraBold, Heavy, ...  */
1665   XLFD_WEIGHT_ULTRA_BOLD        /* 90: UltraBold, Black, ...  */
1666 };
1667 
1668 /* Relative proportionate width.  */
1669 
1670 enum xlfd_swidth
1671 {
1672   XLFD_SWIDTH_UNKNOWN,
1673   XLFD_SWIDTH_ULTRA_CONDENSED,  /* 10 */
1674   XLFD_SWIDTH_EXTRA_CONDENSED,  /* 20 */
1675   XLFD_SWIDTH_CONDENSED,        /* 30: Condensed, Narrow, Compressed, ... */
1676   XLFD_SWIDTH_SEMI_CONDENSED,   /* 40: semicondensed */
1677   XLFD_SWIDTH_MEDIUM,           /* 50: Medium, Normal, Regular, ... */
1678   XLFD_SWIDTH_SEMI_EXPANDED,    /* 60: SemiExpanded, DemiExpanded, ... */
1679   XLFD_SWIDTH_EXPANDED,         /* 70: Expanded... */
1680   XLFD_SWIDTH_EXTRA_EXPANDED,   /* 80: ExtraExpanded, Wide...  */
1681   XLFD_SWIDTH_ULTRA_EXPANDED    /* 90: UltraExpanded... */
1682 };
1683 
1684 /* Order by which font selection chooses fonts.  The default values
1685    mean `first, find a best match for the font width, then for the
1686    font height, then for weight, then for slant.'  This variable can be
1687    set via set-face-font-sort-order.  */
1688 
1689 static int font_sort_order[4];
1690 
1691 #ifdef HAVE_WINDOW_SYSTEM
1692 
1693 static enum font_property_index font_props_for_sorting[FONT_SIZE_INDEX];
1694 
1695 static int
1696 compare_fonts_by_sort_order (v1, v2)
1697      const void *v1, *v2;
1698 {
1699   Lisp_Object font1 = *(Lisp_Object *) v1;
1700   Lisp_Object font2 = *(Lisp_Object *) v2;
1701   int i;
1702 
1703   for (i = 0; i < FONT_SIZE_INDEX; i++)
1704     {
1705       enum font_property_index idx = font_props_for_sorting[i];
1706       Lisp_Object val1 = AREF (font1, idx), val2 = AREF (font2, idx);
1707       int result;
1708 
1709       if (idx <= FONT_REGISTRY_INDEX)
1710         {
1711           if (STRINGP (val1))
1712             result = STRINGP (val2) ? strcmp (SDATA (val1), SDATA (val2)) : -1;
1713           else
1714             result = STRINGP (val2) ? 1 : 0;
1715         }
1716       else
1717         {
1718           if (INTEGERP (val1))
1719             result = INTEGERP (val2) ? XINT (val1) - XINT (val2) : -1;
1720           else
1721             result = INTEGERP (val2) ? 1 : 0;
1722         }
1723       if (result)
1724         return result;
1725     }
1726   return 0;
1727 }
1728 
1729 DEFUN ("x-family-fonts", Fx_family_fonts, Sx_family_fonts, 0, 2, 0,
1730        doc: /* Return a list of available fonts of family FAMILY on FRAME.
1731 If FAMILY is omitted or nil, list all families.
1732 Otherwise, FAMILY must be a string, possibly containing wildcards
1733 `?' and `*'.
1734 If FRAME is omitted or nil, use the selected frame.
1735 Each element of the result is a vector [FAMILY WIDTH POINT-SIZE WEIGHT
1736 SLANT FIXED-P FULL REGISTRY-AND-ENCODING].
1737 FAMILY is the font family name.  POINT-SIZE is the size of the
1738 font in 1/10 pt.  WIDTH, WEIGHT, and SLANT are symbols describing the
1739 width, weight and slant of the font.  These symbols are the same as for
1740 face attributes.  FIXED-P is non-nil if the font is fixed-pitch.
1741 FULL is the full name of the font, and REGISTRY-AND-ENCODING is a string
1742 giving the registry and encoding of the font.
1743 The result list is sorted according to the current setting of
1744 the face font sort order.  */)
1745      (family, frame)
1746      Lisp_Object family, frame;
1747 {
1748   Lisp_Object font_spec, list, *drivers, vec;
1749   int i, nfonts, ndrivers;
1750   Lisp_Object result;
1751 
1752   if (NILP (frame))
1753     frame = selected_frame;
1754   CHECK_LIVE_FRAME (frame);
1755 
1756   font_spec = Ffont_spec (0, NULL);
1757   if (!NILP (family))
1758     {
1759       CHECK_STRING (family);
1760       font_parse_family_registry (family, Qnil, font_spec);
1761     }
1762 
1763   list = font_list_entities (frame, font_spec);
1764   if (NILP (list))
1765     return Qnil;
1766 
1767   /* Sort the font entities.  */
1768   for (i = 0; i < 4; i++)
1769     switch (font_sort_order[i])
1770       {
1771       case XLFD_SWIDTH:
1772         font_props_for_sorting[i] = FONT_WIDTH_INDEX; break;
1773       case XLFD_POINT_SIZE:
1774         font_props_for_sorting[i] = FONT_SIZE_INDEX; break;
1775       case XLFD_WEIGHT:
1776         font_props_for_sorting[i] = FONT_WEIGHT_INDEX; break;
1777       default:
1778         font_props_for_sorting[i] = FONT_SLANT_INDEX; break;
1779       }
1780   font_props_for_sorting[i++] = FONT_FAMILY_INDEX;
1781   font_props_for_sorting[i++] = FONT_FOUNDRY_INDEX;
1782   font_props_for_sorting[i++] = FONT_ADSTYLE_INDEX;
1783   font_props_for_sorting[i++] = FONT_REGISTRY_INDEX;
1784 
1785   ndrivers = XINT (Flength (list));
1786   drivers  = alloca (sizeof (Lisp_Object) * ndrivers);
1787   for (i = 0; i < ndrivers; i++, list = XCDR (list))
1788     drivers[i] = XCAR (list);
1789   vec = Fvconcat (ndrivers, drivers);
1790   nfonts = ASIZE (vec);
1791 
1792   qsort (XVECTOR (vec)->contents, nfonts, sizeof (Lisp_Object),
1793          compare_fonts_by_sort_order);
1794 
1795   result = Qnil;
1796   for (i = nfonts - 1; i >= 0; --i)
1797     {
1798       Lisp_Object font = AREF (vec, i);
1799       Lisp_Object v = Fmake_vector (make_number (8), Qnil);
1800       int point;
1801       Lisp_Object spacing;
1802 
1803       ASET (v, 0, AREF (font, FONT_FAMILY_INDEX));
1804       ASET (v, 1, FONT_WIDTH_SYMBOLIC (font));
1805       point = PIXEL_TO_POINT (XINT (AREF (font, FONT_SIZE_INDEX)) * 10,
1806                               XFRAME (frame)->resy);
1807       ASET (v, 2, make_number (point));
1808       ASET (v, 3, FONT_WEIGHT_SYMBOLIC (font));
1809       ASET (v, 4, FONT_SLANT_SYMBOLIC (font));
1810       spacing = Ffont_get (font, QCspacing);
1811       ASET (v, 5, (NILP (spacing) || EQ (spacing, Qp)) ? Qnil : Qt);
1812       ASET (v, 6, Ffont_xlfd_name (font, Qnil));
1813       ASET (v, 7, AREF (font, FONT_REGISTRY_INDEX));
1814 
1815       result = Fcons (v, result);
1816     }
1817 
1818   return result;
1819 }
1820 
1821 DEFUN ("x-list-fonts", Fx_list_fonts, Sx_list_fonts, 1, 5, 0,
1822        doc: /* Return a list of the names of available fonts matching PATTERN.
1823 If optional arguments FACE and FRAME are specified, return only fonts
1824 the same size as FACE on FRAME.
1825 
1826 PATTERN should be a string containing a font name in the XLFD,
1827 Fontconfig, or GTK format.  A font name given in the XLFD format may
1828 contain wildcard characters:
1829   the * character matches any substring, and
1830   the ? character matches any single character.
1831   PATTERN is case-insensitive.
1832 
1833 The return value is a list of strings, suitable as arguments to
1834 `set-face-font'.
1835 
1836 Fonts Emacs can't use may or may not be excluded
1837 even if they match PATTERN and FACE.
1838 The optional fourth argument MAXIMUM sets a limit on how many
1839 fonts to match.  The first MAXIMUM fonts are reported.
1840 The optional fifth argument WIDTH, if specified, is a number of columns
1841 occupied by a character of a font.  In that case, return only fonts
1842 the WIDTH times as wide as FACE on FRAME.  */)
1843      (pattern, face, frame, maximum, width)
1844     Lisp_Object pattern, face, frame, maximum, width;
1845 {
1846   struct frame *f;
1847   int size, avgwidth;
1848 
1849   check_x ();
1850   CHECK_STRING (pattern);
1851 
1852   if (! NILP (maximum))
1853     CHECK_NATNUM (maximum);
1854 
1855   if (!NILP (width))
1856     CHECK_NUMBER (width);
1857 
1858   /* We can't simply call check_x_frame because this function may be
1859      called before any frame is created.  */
1860   if (NILP (frame))
1861     frame = selected_frame;
1862   f = frame_or_selected_frame (frame, 2);
1863   if (! FRAME_WINDOW_P (f))
1864     {
1865       /* Perhaps we have not yet created any frame.  */
1866       f = NULL;
1867       frame = Qnil;
1868       face = Qnil;
1869     }
1870 
1871   /* Determine the width standard for comparison with the fonts we find.  */
1872 
1873   if (NILP (face))
1874     size = 0;
1875   else
1876     {
1877       /* This is of limited utility since it works with character
1878          widths.  Keep it for compatibility.  --gerd.  */
1879       int face_id = lookup_named_face (f, face, 0);
1880       struct face *face = (face_id < 0
1881                            ? NULL
1882                            : FACE_FROM_ID (f, face_id));
1883 
1884       if (face && face->font)
1885         {
1886           size = face->font->pixel_size;
1887           avgwidth = face->font->average_width;
1888         }
1889       else
1890         {
1891           size = FRAME_FONT (f)->pixel_size;
1892           avgwidth = FRAME_FONT (f)->average_width;
1893         }
1894       if (!NILP (width))
1895         avgwidth *= XINT (width);
1896     }
1897 
1898   {
1899     Lisp_Object font_spec;
1900     Lisp_Object args[2], tail;
1901 
1902     font_spec = font_spec_from_name (pattern);
1903     if (!FONTP (font_spec))
1904       signal_error ("Invalid font name", pattern);
1905 
1906     if (size)
1907       {
1908         Ffont_put (font_spec, QCsize, make_number (size));
1909         Ffont_put (font_spec, QCavgwidth, make_number (avgwidth));
1910       }
1911     args[0] = Flist_fonts (font_spec, frame, maximum, font_spec);
1912     for (tail = args[0]; CONSP (tail); tail = XCDR (tail))
1913       {
1914         Lisp_Object font_entity;
1915 
1916         font_entity = XCAR (tail);
1917         if ((NILP (AREF (font_entity, FONT_SIZE_INDEX))
1918              || XINT (AREF (font_entity, FONT_SIZE_INDEX)) == 0)
1919             && ! NILP (AREF (font_spec, FONT_SIZE_INDEX)))
1920           {
1921             /* This is a scalable font.  For backward compatibility,
1922                we set the specified size. */
1923             font_entity = Fcopy_font_spec (font_entity);
1924             ASET (font_entity, FONT_SIZE_INDEX,
1925                   AREF (font_spec, FONT_SIZE_INDEX));
1926           }
1927         XSETCAR (tail, Ffont_xlfd_name (font_entity, Qnil));
1928       }
1929     if (NILP (frame))
1930       /* We don't have to check fontsets.  */
1931       return args[0];
1932     args[1] = list_fontsets (f, pattern, size);
1933     return Fnconc (2, args);
1934   }
1935 }
1936 
1937 #endif /* HAVE_WINDOW_SYSTEM */
1938 
1939 
1940 /***********************************************************************
1941                               Lisp Faces
1942  ***********************************************************************/
1943 
1944 /* Access face attributes of face LFACE, a Lisp vector.  */
1945 
1946 #define LFACE_FAMILY(LFACE)         AREF ((LFACE), LFACE_FAMILY_INDEX)
1947 #define LFACE_FOUNDRY(LFACE)        AREF ((LFACE), LFACE_FOUNDRY_INDEX)
1948 #define LFACE_HEIGHT(LFACE)         AREF ((LFACE), LFACE_HEIGHT_INDEX)
1949 #define LFACE_WEIGHT(LFACE)         AREF ((LFACE), LFACE_WEIGHT_INDEX)
1950 #define LFACE_SLANT(LFACE)          AREF ((LFACE), LFACE_SLANT_INDEX)
1951 #define LFACE_UNDERLINE(LFACE)      AREF ((LFACE), LFACE_UNDERLINE_INDEX)
1952 #define LFACE_INVERSE(LFACE)        AREF ((LFACE), LFACE_INVERSE_INDEX)
1953 #define LFACE_FOREGROUND(LFACE)     AREF ((LFACE), LFACE_FOREGROUND_INDEX)
1954 #define LFACE_BACKGROUND(LFACE)     AREF ((LFACE), LFACE_BACKGROUND_INDEX)
1955 #define LFACE_STIPPLE(LFACE)        AREF ((LFACE), LFACE_STIPPLE_INDEX)
1956 #define LFACE_SWIDTH(LFACE)         AREF ((LFACE), LFACE_SWIDTH_INDEX)
1957 #define LFACE_OVERLINE(LFACE)       AREF ((LFACE), LFACE_OVERLINE_INDEX)
1958 #define LFACE_STRIKE_THROUGH(LFACE) AREF ((LFACE), LFACE_STRIKE_THROUGH_INDEX)
1959 #define LFACE_BOX(LFACE)            AREF ((LFACE), LFACE_BOX_INDEX)
1960 #define LFACE_FONT(LFACE)           AREF ((LFACE), LFACE_FONT_INDEX)
1961 #define LFACE_INHERIT(LFACE)        AREF ((LFACE), LFACE_INHERIT_INDEX)
1962 #define LFACE_FONTSET(LFACE)        AREF ((LFACE), LFACE_FONTSET_INDEX)
1963 
1964 /* Non-zero if LFACE is a Lisp face.  A Lisp face is a vector of size
1965    LFACE_VECTOR_SIZE which has the symbol `face' in slot 0.  */
1966 
1967 #define LFACEP(LFACE)                                   \
1968      (VECTORP (LFACE)                                   \
1969       && XVECTOR (LFACE)->size == LFACE_VECTOR_SIZE     \
1970       && EQ (AREF (LFACE, 0), Qface))
1971 
1972 
1973 #if GLYPH_DEBUG
1974 
1975 /* Check consistency of Lisp face attribute vector ATTRS.  */
1976 
1977 static void
1978 check_lface_attrs (attrs)
1979      Lisp_Object *attrs;
1980 {
1981   xassert (UNSPECIFIEDP (attrs[LFACE_FAMILY_INDEX])
1982            || IGNORE_DEFFACE_P (attrs[LFACE_FAMILY_INDEX])
1983            || STRINGP (attrs[LFACE_FAMILY_INDEX]));
1984   xassert (UNSPECIFIEDP (attrs[LFACE_FOUNDRY_INDEX])
1985            || IGNORE_DEFFACE_P (attrs[LFACE_FOUNDRY_INDEX])
1986            || STRINGP (attrs[LFACE_FOUNDRY_INDEX]));
1987   xassert (UNSPECIFIEDP (attrs[LFACE_SWIDTH_INDEX])
1988            || IGNORE_DEFFACE_P (attrs[LFACE_SWIDTH_INDEX])
1989            || SYMBOLP (attrs[LFACE_SWIDTH_INDEX]));
1990   xassert (UNSPECIFIEDP (attrs[LFACE_HEIGHT_INDEX])
1991            || IGNORE_DEFFACE_P (attrs[LFACE_HEIGHT_INDEX])
1992            || INTEGERP (attrs[LFACE_HEIGHT_INDEX])
1993            || FLOATP (attrs[LFACE_HEIGHT_INDEX])
1994            || FUNCTIONP (attrs[LFACE_HEIGHT_INDEX]));
1995   xassert (UNSPECIFIEDP (attrs[LFACE_WEIGHT_INDEX])
1996            || IGNORE_DEFFACE_P (attrs[LFACE_WEIGHT_INDEX])
1997            || SYMBOLP (attrs[LFACE_WEIGHT_INDEX]));
1998   xassert (UNSPECIFIEDP (attrs[LFACE_SLANT_INDEX])
1999            || IGNORE_DEFFACE_P (attrs[LFACE_SLANT_INDEX])
2000            || SYMBOLP (attrs[LFACE_SLANT_INDEX]));
2001   xassert (UNSPECIFIEDP (attrs[LFACE_UNDERLINE_INDEX])
2002            || IGNORE_DEFFACE_P (attrs[LFACE_UNDERLINE_INDEX])
2003            || SYMBOLP (attrs[LFACE_UNDERLINE_INDEX])
2004            || STRINGP (attrs[LFACE_UNDERLINE_INDEX]));
2005   xassert (UNSPECIFIEDP (attrs[LFACE_OVERLINE_INDEX])
2006            || IGNORE_DEFFACE_P (attrs[LFACE_OVERLINE_INDEX])
2007            || SYMBOLP (attrs[LFACE_OVERLINE_INDEX])
2008            || STRINGP (attrs[LFACE_OVERLINE_INDEX]));
2009   xassert (UNSPECIFIEDP (attrs[LFACE_STRIKE_THROUGH_INDEX])
2010            || IGNORE_DEFFACE_P (attrs[LFACE_STRIKE_THROUGH_INDEX])
2011            || SYMBOLP (attrs[LFACE_STRIKE_THROUGH_INDEX])
2012            || STRINGP (attrs[LFACE_STRIKE_THROUGH_INDEX]));
2013   xassert (UNSPECIFIEDP (attrs[LFACE_BOX_INDEX])
2014            || IGNORE_DEFFACE_P (attrs[LFACE_BOX_INDEX])
2015            || SYMBOLP (attrs[LFACE_BOX_INDEX])
2016            || STRINGP (attrs[LFACE_BOX_INDEX])
2017            || INTEGERP (attrs[LFACE_BOX_INDEX])
2018            || CONSP (attrs[LFACE_BOX_INDEX]));
2019   xassert (UNSPECIFIEDP (attrs[LFACE_INVERSE_INDEX])
2020            || IGNORE_DEFFACE_P (attrs[LFACE_INVERSE_INDEX])
2021            || SYMBOLP (attrs[LFACE_INVERSE_INDEX]));
2022   xassert (UNSPECIFIEDP (attrs[LFACE_FOREGROUND_INDEX])
2023            || IGNORE_DEFFACE_P (attrs[LFACE_FOREGROUND_INDEX])
2024            || STRINGP (attrs[LFACE_FOREGROUND_INDEX]));
2025   xassert (UNSPECIFIEDP (attrs[LFACE_BACKGROUND_INDEX])
2026            || IGNORE_DEFFACE_P (attrs[LFACE_BACKGROUND_INDEX])
2027            || STRINGP (attrs[LFACE_BACKGROUND_INDEX]));
2028   xassert (UNSPECIFIEDP (attrs[LFACE_INHERIT_INDEX])
2029            || IGNORE_DEFFACE_P (attrs[LFACE_INHERIT_INDEX])
2030            || NILP (attrs[LFACE_INHERIT_INDEX])
2031            || SYMBOLP (attrs[LFACE_INHERIT_INDEX])
2032            || CONSP (attrs[LFACE_INHERIT_INDEX]));
2033 #ifdef HAVE_WINDOW_SYSTEM
2034   xassert (UNSPECIFIEDP (attrs[LFACE_STIPPLE_INDEX])
2035            || IGNORE_DEFFACE_P (attrs[LFACE_STIPPLE_INDEX])
2036            || SYMBOLP (attrs[LFACE_STIPPLE_INDEX])
2037            || !NILP (Fbitmap_spec_p (attrs[LFACE_STIPPLE_INDEX])));
2038   xassert (UNSPECIFIEDP (attrs[LFACE_FONT_INDEX])
2039            || IGNORE_DEFFACE_P (attrs[LFACE_FONT_INDEX])
2040            || FONTP (attrs[LFACE_FONT_INDEX]));
2041   xassert (UNSPECIFIEDP (attrs[LFACE_FONTSET_INDEX])
2042            || STRINGP (attrs[LFACE_FONTSET_INDEX]));
2043 #endif
2044 }
2045 
2046 
2047 /* Check consistency of attributes of Lisp face LFACE (a Lisp vector).  */
2048 
2049 static void
2050 check_lface (lface)
2051      Lisp_Object lface;
2052 {
2053   if (!NILP (lface))
2054     {
2055       xassert (LFACEP (lface));
2056       check_lface_attrs (XVECTOR (lface)->contents);
2057     }
2058 }
2059 
2060 #else /* GLYPH_DEBUG == 0 */
2061 
2062 #define check_lface_attrs(attrs)        (void) 0
2063 #define check_lface(lface)              (void) 0
2064 
2065 #endif /* GLYPH_DEBUG == 0 */
2066 
2067 
2068 
2069 /* Face-merge cycle checking.  */
2070 
2071 enum named_merge_point_kind
2072 {
2073   NAMED_MERGE_POINT_NORMAL,
2074   NAMED_MERGE_POINT_REMAP
2075 };
2076 
2077 /* A `named merge point' is simply a point during face-merging where we
2078    look up a face by name.  We keep a stack of which named lookups we're
2079    currently processing so that we can easily detect cycles, using a
2080    linked- list of struct named_merge_point structures, typically
2081    allocated on the stack frame of the named lookup functions which are
2082    active (so no consing is required).  */
2083 struct named_merge_point
2084 {
2085   Lisp_Object face_name;
2086   enum named_merge_point_kind named_merge_point_kind;
2087   struct named_merge_point *prev;
2088 };
2089 
2090 
2091 /* If a face merging cycle is detected for FACE_NAME, return 0,
2092    otherwise add NEW_NAMED_MERGE_POINT, which is initialized using
2093    FACE_NAME and NAMED_MERGE_POINT_KIND, as the head of the linked list
2094    pointed to by NAMED_MERGE_POINTS, and return 1.  */
2095 
2096 static INLINE int
2097 push_named_merge_point (struct named_merge_point *new_named_merge_point,
2098                         Lisp_Object face_name,
2099                         enum named_merge_point_kind named_merge_point_kind,
2100                         struct named_merge_point **named_merge_points)
2101 {
2102   struct named_merge_point *prev;
2103 
2104   for (prev = *named_merge_points; prev; prev = prev->prev)
2105     if (EQ (face_name, prev->face_name))
2106       {
2107         if (prev->named_merge_point_kind == named_merge_point_kind)
2108           /* A cycle, so fail.  */
2109           return 0;
2110         else if (prev->named_merge_point_kind == NAMED_MERGE_POINT_REMAP)
2111           /* A remap `hides ' any previous normal merge points
2112              (because the remap means that it's actually different face),
2113              so as we know the current merge point must be normal, we
2114              can just assume it's OK.  */
2115           break;
2116       }
2117 
2118   new_named_merge_point->face_name = face_name;
2119   new_named_merge_point->named_merge_point_kind = named_merge_point_kind;
2120   new_named_merge_point->prev = *named_merge_points;
2121 
2122   *named_merge_points = new_named_merge_point;
2123 
2124   return 1;
2125 }
2126 
2127 
2128 
2129 #if 0                           /* Seems to be unused.  */
2130 static Lisp_Object
2131 internal_resolve_face_name (nargs, args)
2132      int nargs;
2133      Lisp_Object *args;
2134 {
2135   return Fget (args[0], args[1]);
2136 }
2137 
2138 static Lisp_Object
2139 resolve_face_name_error (ignore)
2140      Lisp_Object ignore;
2141 {
2142   return Qnil;
2143 }
2144 #endif
2145 
2146 /* Resolve face name FACE_NAME.  If FACE_NAME is a string, intern it
2147    to make it a symbol.  If FACE_NAME is an alias for another face,
2148    return that face's name.
2149 
2150    Return default face in case of errors.  */
2151 
2152 static Lisp_Object
2153 resolve_face_name (face_name, signal_p)
2154      Lisp_Object face_name;
2155      int signal_p;
2156 {
2157   Lisp_Object orig_face;
2158   Lisp_Object tortoise, hare;
2159 
2160   if (STRINGP (face_name))
2161     face_name = intern (SDATA (face_name));
2162 
2163   if (NILP (face_name) || !SYMBOLP (face_name))
2164     return face_name;
2165 
2166   orig_face = face_name;
2167   tortoise = hare = face_name;
2168 
2169   while (1)
2170     {
2171       face_name = hare;
2172       hare = Fget (hare, Qface_alias);
2173       if (NILP (hare) || !SYMBOLP (hare))
2174         break;
2175 
2176       face_name = hare;
2177       hare = Fget (hare, Qface_alias);
2178       if (NILP (hare) || !SYMBOLP (hare))
2179         break;
2180 
2181       tortoise = Fget (tortoise, Qface_alias);
2182       if (EQ (hare, tortoise))
2183         {
2184           if (signal_p)
2185             xsignal1 (Qcircular_list, orig_face);
2186           return Qdefault;
2187         }
2188     }
2189 
2190   return face_name;
2191 }
2192 
2193 
2194 /* Return the face definition of FACE_NAME on frame F.  F null means
2195    return the definition for new frames.  FACE_NAME may be a string or
2196    a symbol (apparently Emacs 20.2 allowed strings as face names in
2197    face text properties; Ediff uses that).  If SIGNAL_P is non-zero,
2198    signal an error if FACE_NAME is not a valid face name.  If SIGNAL_P
2199    is zero, value is nil if FACE_NAME is not a valid face name.  */
2200 static INLINE Lisp_Object
2201 lface_from_face_name_no_resolve (f, face_name, signal_p)
2202      struct frame *f;
2203      Lisp_Object face_name;
2204      int signal_p;
2205 {
2206   Lisp_Object lface;
2207 
2208   if (f)
2209     lface = assq_no_quit (face_name, f->face_alist);
2210   else
2211     lface = assq_no_quit (face_name, Vface_new_frame_defaults);
2212 
2213   if (CONSP (lface))
2214     lface = XCDR (lface);
2215   else if (signal_p)
2216     signal_error ("Invalid face", face_name);
2217 
2218   check_lface (lface);
2219 
2220   return lface;
2221 }
2222 
2223 /* Return the face definition of FACE_NAME on frame F.  F null means
2224    return the definition for new frames.  FACE_NAME may be a string or
2225    a symbol (apparently Emacs 20.2 allowed strings as face names in
2226    face text properties; Ediff uses that).  If FACE_NAME is an alias
2227    for another face, return that face's definition.  If SIGNAL_P is
2228    non-zero, signal an error if FACE_NAME is not a valid face name.
2229    If SIGNAL_P is zero, value is nil if FACE_NAME is not a valid face
2230    name.  */
2231 static INLINE Lisp_Object
2232 lface_from_face_name (f, face_name, signal_p)
2233      struct frame *f;
2234      Lisp_Object face_name;
2235      int signal_p;
2236 {
2237   face_name = resolve_face_name (face_name, signal_p);
2238   return lface_from_face_name_no_resolve (f, face_name, signal_p);
2239 }
2240 
2241 
2242 /* Get face attributes of face FACE_NAME from frame-local faces on
2243    frame F.  Store the resulting attributes in ATTRS which must point
2244    to a vector of Lisp_Objects of size LFACE_VECTOR_SIZE.  If SIGNAL_P
2245    is non-zero, signal an error if FACE_NAME does not name a face.
2246    Otherwise, value is zero if FACE_NAME is not a face.  */
2247 
2248 static INLINE int
2249 get_lface_attributes_no_remap (f, face_name, attrs, signal_p)
2250      struct frame *f;
2251      Lisp_Object face_name;
2252      Lisp_Object *attrs;
2253      int signal_p;
2254 {
2255   Lisp_Object lface;
2256 
2257   lface = lface_from_face_name_no_resolve (f, face_name, signal_p);
2258 
2259   if (! NILP (lface))
2260     bcopy (XVECTOR (lface)->contents, attrs,
2261            LFACE_VECTOR_SIZE * sizeof *attrs);
2262 
2263   return !NILP (lface);
2264 }
2265 
2266 /* Get face attributes of face FACE_NAME from frame-local faces on frame
2267    F.  Store the resulting attributes in ATTRS which must point to a
2268    vector of Lisp_Objects of size LFACE_VECTOR_SIZE.  If FACE_NAME is an
2269    alias for another face, use that face's definition.  If SIGNAL_P is
2270    non-zero, signal an error if FACE_NAME does not name a face.
2271    Otherwise, value is zero if FACE_NAME is not a face.  */
2272 
2273 static INLINE int
2274 get_lface_attributes (f, face_name, attrs, signal_p, named_merge_points)
2275      struct frame *f;
2276      Lisp_Object face_name;
2277      Lisp_Object *attrs;
2278      int signal_p;
2279      struct named_merge_point *named_merge_points;
2280 {
2281   Lisp_Object face_remapping;
2282 
2283   face_name = resolve_face_name (face_name, signal_p);
2284 
2285   /* See if SYMBOL has been remapped to some other face (usually this
2286      is done buffer-locally).  */
2287   face_remapping = assq_no_quit (face_name, Vface_remapping_alist);
2288   if (CONSP (face_remapping))
2289     {
2290       struct named_merge_point named_merge_point;
2291 
2292       if (push_named_merge_point (&named_merge_point,
2293                                   face_name, NAMED_MERGE_POINT_REMAP,
2294                                   &named_merge_points))
2295         {
2296           int i;
2297 
2298           for (i = 1; i < LFACE_VECTOR_SIZE; ++i)
2299             attrs[i] = Qunspecified;
2300 
2301           return merge_face_ref (f, XCDR (face_remapping), attrs,
2302                                  signal_p, named_merge_points);
2303         }
2304     }
2305 
2306   /* Default case, no remapping.  */
2307   return get_lface_attributes_no_remap (f, face_name, attrs, signal_p);
2308 }
2309 
2310 
2311 /* Non-zero if all attributes in face attribute vector ATTRS are
2312    specified, i.e. are non-nil.  */
2313 
2314 static int
2315 lface_fully_specified_p (attrs)
2316      Lisp_Object *attrs;
2317 {
2318   int i;
2319 
2320   for (i = 1; i < LFACE_VECTOR_SIZE; ++i)
2321     if (i != LFACE_FONT_INDEX && i != LFACE_INHERIT_INDEX)
2322       if ((UNSPECIFIEDP (attrs[i]) || IGNORE_DEFFACE_P (attrs[i])))
2323         break;
2324 
2325   return i == LFACE_VECTOR_SIZE;
2326 }
2327 
2328 #ifdef HAVE_WINDOW_SYSTEM
2329 
2330 /* Set font-related attributes of Lisp face LFACE from FONT-OBJECT.
2331    If FORCE_P is zero, set only unspecified attributes of LFACE.  The
2332    exception is `font' attribute.  It is set to FONT_OBJECT regardless
2333    of FORCE_P.  */
2334 
2335 static int
2336 set_lface_from_font (f, lface, font_object, force_p)
2337      struct frame *f;
2338      Lisp_Object lface, font_object;
2339      int force_p;
2340 {
2341   Lisp_Object val;
2342   struct font *font = XFONT_OBJECT (font_object);
2343 
2344   /* Set attributes only if unspecified, otherwise face defaults for
2345      new frames would never take effect.  If the font doesn't have a
2346      specific property, set a normal value for that.  */
2347 
2348   if (force_p || UNSPECIFIEDP (LFACE_FAMILY (lface)))
2349     {
2350       Lisp_Object family = AREF (font_object, FONT_FAMILY_INDEX);
2351 
2352       LFACE_FAMILY (lface) = SYMBOL_NAME (family);
2353     }
2354 
2355   if (force_p || UNSPECIFIEDP (LFACE_FOUNDRY (lface)))
2356     {
2357       Lisp_Object foundry = AREF (font_object, FONT_FOUNDRY_INDEX);
2358 
2359       LFACE_FOUNDRY (lface) = SYMBOL_NAME (foundry);
2360     }
2361 
2362   if (force_p || UNSPECIFIEDP (LFACE_HEIGHT (lface)))
2363     {
2364       int pt = PIXEL_TO_POINT (font->pixel_size * 10, f->resy);
2365 
2366       xassert (pt > 0);
2367       LFACE_HEIGHT (lface) = make_number (pt);
2368     }
2369 
2370   if (force_p || UNSPECIFIEDP (LFACE_WEIGHT (lface)))
2371     {
2372       val = FONT_WEIGHT_FOR_FACE (font_object);
2373       LFACE_WEIGHT (lface) = ! NILP (val) ? val :Qnormal;
2374     }
2375   if (force_p || UNSPECIFIEDP (LFACE_SLANT (lface)))
2376     {
2377       val = FONT_SLANT_FOR_FACE (font_object);
2378       LFACE_SLANT (lface) = ! NILP (val) ? val : Qnormal;
2379     }
2380   if (force_p || UNSPECIFIEDP (LFACE_SWIDTH (lface)))
2381     {
2382       val = FONT_WIDTH_FOR_FACE (font_object);
2383       LFACE_SWIDTH (lface) = ! NILP (val) ? val : Qnormal;
2384     }
2385 
2386   LFACE_FONT (lface) = font_object;
2387   return 1;
2388 }
2389 
2390 #endif /* HAVE_WINDOW_SYSTEM */
2391 
2392 
2393 /* Merges the face height FROM with the face height TO, and returns the
2394    merged height.  If FROM is an invalid height, then INVALID is
2395    returned instead.  FROM and TO may be either absolute face heights or
2396    `relative' heights; the returned value is always an absolute height
2397    unless both FROM and TO are relative.  */
2398 
2399 Lisp_Object
2400 merge_face_heights (from, to, invalid)
2401      Lisp_Object from, to, invalid;
2402 {
2403   Lisp_Object result = invalid;
2404 
2405   if (INTEGERP (from))
2406     /* FROM is absolute, just use it as is.  */
2407     result = from;
2408   else if (FLOATP (from))
2409     /* FROM is a scale, use it to adjust TO.  */
2410     {
2411       if (INTEGERP (to))
2412         /* relative X absolute => absolute */
2413         result = make_number ((EMACS_INT)(XFLOAT_DATA (from) * XINT (to)));
2414       else if (FLOATP (to))
2415         /* relative X relative => relative */
2416         result = make_float (XFLOAT_DATA (from) * XFLOAT_DATA (to));
2417       else if (UNSPECIFIEDP (to))
2418         result = from;
2419     }
2420   else if (FUNCTIONP (from))
2421     /* FROM is a function, which use to adjust TO.  */
2422     {
2423       /* Call function with current height as argument.
2424          From is the new height.  */
2425       Lisp_Object args[2];
2426 
2427       args[0] = from;
2428       args[1] = to;
2429       result = safe_call (2, args);
2430 
2431       /* Ensure that if TO was absolute, so is the result.  */
2432       if (INTEGERP (to) && !INTEGERP (result))
2433         result = invalid;
2434     }
2435 
2436   return result;
2437 }
2438 
2439 
2440 /* Merge two Lisp face attribute vectors on frame F, FROM and TO, and
2441    store the resulting attributes in TO, which must be already be
2442    completely specified and contain only absolute attributes.  Every
2443    specified attribute of FROM overrides the corresponding attribute of
2444    TO; relative attributes in FROM are merged with the absolute value in
2445    TO and replace it.  NAMED_MERGE_POINTS is used internally to detect
2446    loops in face inheritance/remapping; it should be 0 when called from
2447    other places.  */
2448 
2449 static INLINE void
2450 merge_face_vectors (f, from, to, named_merge_points)
2451      struct frame *f;
2452      Lisp_Object *from, *to;
2453      struct named_merge_point *named_merge_points;
2454 {
2455   int i;
2456 
2457   /* If FROM inherits from some other faces, merge their attributes into
2458      TO before merging FROM's direct attributes.  Note that an :inherit
2459      attribute of `unspecified' is the same as one of nil; we never
2460      merge :inherit attributes, so nil is more correct, but lots of
2461      other code uses `unspecified' as a generic value for face attributes. */
2462   if (!UNSPECIFIEDP (from[LFACE_INHERIT_INDEX])
2463       && !NILP (from[LFACE_INHERIT_INDEX]))
2464     merge_face_ref (f, from[LFACE_INHERIT_INDEX], to, 0, named_merge_points);
2465 
2466   i = LFACE_FONT_INDEX;
2467   if (!UNSPECIFIEDP (from[i]))
2468     {
2469       if (!UNSPECIFIEDP (to[i]))
2470         to[i] = Fmerge_font_spec (from[i], to[i]);
2471       else
2472         to[i] = Fcopy_font_spec (from[i]);
2473       if (! NILP (AREF (to[i], FONT_FOUNDRY_INDEX)))
2474         to[LFACE_FOUNDRY_INDEX] = SYMBOL_NAME (AREF (to[i], FONT_FOUNDRY_INDEX));
2475       if (! NILP (AREF (to[i], FONT_FAMILY_INDEX)))
2476         to[LFACE_FAMILY_INDEX] = SYMBOL_NAME (AREF (to[i], FONT_FAMILY_INDEX));
2477       if (! NILP (AREF (to[i], FONT_WEIGHT_INDEX)))
2478         to[LFACE_WEIGHT_INDEX] = FONT_WEIGHT_FOR_FACE (to[i]);
2479       if (! NILP (AREF (to[i], FONT_SLANT_INDEX)))
2480         to[LFACE_SLANT_INDEX] = FONT_SLANT_FOR_FACE (to[i]);
2481       if (! NILP (AREF (to[i], FONT_WIDTH_INDEX)))
2482         to[LFACE_SWIDTH_INDEX] = FONT_WIDTH_FOR_FACE (to[i]);
2483       ASET (to[i], FONT_SIZE_INDEX, Qnil);
2484     }
2485 
2486   for (i = 1; i < LFACE_VECTOR_SIZE; ++i)
2487     if (!UNSPECIFIEDP (from[i]))
2488       {
2489         if (i == LFACE_HEIGHT_INDEX && !INTEGERP (from[i]))
2490           {
2491             to[i] = merge_face_heights (from[i], to[i], to[i]);
2492             font_clear_prop (to, FONT_SIZE_INDEX);
2493           }
2494         else if (i != LFACE_FONT_INDEX
2495                  && ! EQ (to[i], from[i]))
2496           {
2497             to[i] = from[i];
2498             if (i >= LFACE_FAMILY_INDEX && i <=LFACE_SLANT_INDEX)
2499               font_clear_prop (to,
2500                                (i == LFACE_FAMILY_INDEX ? FONT_FAMILY_INDEX
2501                                 : i == LFACE_FOUNDRY_INDEX ? FONT_FOUNDRY_INDEX
2502                                 : i == LFACE_SWIDTH_INDEX ? FONT_WIDTH_INDEX
2503                                 : i == LFACE_HEIGHT_INDEX ? FONT_SIZE_INDEX
2504                                 : i == LFACE_WEIGHT_INDEX ? FONT_WEIGHT_INDEX
2505                                 : FONT_SLANT_INDEX));
2506           }
2507       }
2508 
2509   /* TO is always an absolute face, which should inherit from nothing.
2510      We blindly copy the :inherit attribute above and fix it up here.  */
2511   to[LFACE_INHERIT_INDEX] = Qnil;
2512 }
2513 
2514 /* Merge the named face FACE_NAME on frame F, into the vector of face
2515    attributes TO.  NAMED_MERGE_POINTS is used to detect loops in face
2516    inheritance.  Returns true if FACE_NAME is a valid face name and
2517    merging succeeded.  */
2518 
2519 static int
2520 merge_named_face (f, face_name, to, named_merge_points)
2521      struct frame *f;
2522      Lisp_Object face_name;
2523      Lisp_Object *to;
2524      struct named_merge_point *named_merge_points;
2525 {
2526   struct named_merge_point named_merge_point;
2527 
2528   if (push_named_merge_point (&named_merge_point,
2529                               face_name, NAMED_MERGE_POINT_NORMAL,
2530                               &named_merge_points))
2531     {
2532       struct gcpro gcpro1;
2533       Lisp_Object from[LFACE_VECTOR_SIZE];
2534       int ok = get_lface_attributes (f, face_name, from, 0, named_merge_points);
2535 
2536       if (ok)
2537         {
2538           GCPRO1 (named_merge_point.face_name);
2539           merge_face_vectors (f, from, to, named_merge_points);
2540           UNGCPRO;
2541         }
2542 
2543       return ok;
2544     }
2545   else
2546     return 0;
2547 }
2548 
2549 
2550 /* Merge face attributes from the lisp `face reference' FACE_REF on
2551    frame F into the face attribute vector TO.  If ERR_MSGS is non-zero,
2552    problems with FACE_REF cause an error message to be shown.  Return
2553    non-zero if no errors occurred (regardless of the value of ERR_MSGS).
2554    NAMED_MERGE_POINTS is used to detect loops in face inheritance or
2555    list structure; it may be 0 for most callers.
2556 
2557    FACE_REF may be a single face specification or a list of such
2558    specifications.  Each face specification can be:
2559 
2560    1. A symbol or string naming a Lisp face.
2561 
2562    2. A property list of the form (KEYWORD VALUE ...) where each
2563    KEYWORD is a face attribute name, and value is an appropriate value
2564    for that attribute.
2565 
2566    3. Conses or the form (FOREGROUND-COLOR . COLOR) or
2567    (BACKGROUND-COLOR . COLOR) where COLOR is a color name.  This is
2568    for compatibility with 20.2.
2569 
2570    Face specifications earlier in lists take precedence over later
2571    specifications.  */
2572 
2573 static int
2574 merge_face_ref (f, face_ref, to, err_msgs, named_merge_points)
2575      struct frame *f;
2576      Lisp_Object face_ref;
2577      Lisp_Object *to;
2578      int err_msgs;
2579      struct named_merge_point *named_merge_points;
2580 {
2581   int ok = 1;                   /* Succeed without an error? */
2582 
2583   if (CONSP (face_ref))
2584     {
2585       Lisp_Object first = XCAR (face_ref);
2586 
2587       if (EQ (first, Qforeground_color)
2588           || EQ (first, Qbackground_color))
2589         {
2590           /* One of (FOREGROUND-COLOR . COLOR) or (BACKGROUND-COLOR
2591              . COLOR).  COLOR must be a string.  */
2592           Lisp_Object color_name = XCDR (face_ref);
2593           Lisp_Object color = first;
2594 
2595           if (STRINGP (color_name))
2596             {
2597               if (EQ (color, Qforeground_color))
2598                 to[LFACE_FOREGROUND_INDEX] = color_name;
2599               else
2600                 to[LFACE_BACKGROUND_INDEX] = color_name;
2601             }
2602           else
2603             {
2604               if (err_msgs)
2605                 add_to_log ("Invalid face color", color_name, Qnil);
2606               ok = 0;
2607             }
2608         }
2609       else if (SYMBOLP (first)
2610                && *SDATA (SYMBOL_NAME (first)) == ':')
2611         {
2612           /* Assume this is the property list form.  */
2613           while (CONSP (face_ref) && CONSP (XCDR (face_ref)))
2614             {
2615               Lisp_Object keyword = XCAR (face_ref);
2616               Lisp_Object value = XCAR (XCDR (face_ref));
2617               int err = 0;
2618 
2619               /* Specifying `unspecified' is a no-op.  */
2620               if (EQ (value, Qunspecified))
2621                 ;
2622               else if (EQ (keyword, QCfamily))
2623                 {
2624                   if (STRINGP (value))
2625                     {
2626                       to[LFACE_FAMILY_INDEX] = value;
2627                       font_clear_prop (to, FONT_FAMILY_INDEX);
2628                     }
2629                   else
2630                     err = 1;
2631                 }
2632               else if (EQ (keyword, QCfoundry))
2633                 {
2634                   if (STRINGP (value))
2635                     {
2636                       to[LFACE_FOUNDRY_INDEX] = value;
2637                       font_clear_prop (to, FONT_FOUNDRY_INDEX);
2638                     }
2639                   else
2640                     err = 1;
2641                 }
2642               else if (EQ (keyword, QCheight))
2643                 {
2644                   Lisp_Object new_height =
2645                     merge_face_heights (value, to[LFACE_HEIGHT_INDEX], Qnil);
2646 
2647                   if (! NILP (new_height))
2648                     {
2649                       to[LFACE_HEIGHT_INDEX] = new_height;
2650                       font_clear_prop (to, FONT_SIZE_INDEX);
2651                     }
2652                   else
2653                     err = 1;
2654                 }
2655               else if (EQ (keyword, QCweight))
2656                 {
2657                   if (SYMBOLP (value) && FONT_WEIGHT_NAME_NUMERIC (value) >= 0)
2658                     {
2659                       to[LFACE_WEIGHT_INDEX] = value;
2660                       font_clear_prop (to, FONT_WEIGHT_INDEX);
2661                     }
2662                   else
2663                     err = 1;
2664                 }
2665               else if (EQ (keyword, QCslant))
2666                 {
2667                   if (SYMBOLP (value) && FONT_SLANT_NAME_NUMERIC (value) >= 0)
2668                     {
2669                       to[LFACE_SLANT_INDEX] = value;
2670                       font_clear_prop (to, FONT_SLANT_INDEX);
2671                     }
2672                   else
2673                     err = 1;
2674                 }
2675               else if (EQ (keyword, QCunderline))
2676                 {
2677                   if (EQ (value, Qt)
2678                       || NILP (value)
2679                       || STRINGP (value))
2680                     to[LFACE_UNDERLINE_INDEX] = value;
2681                   else
2682                     err = 1;
2683                 }
2684               else if (EQ (keyword, QCoverline))
2685                 {
2686                   if (EQ (value, Qt)
2687                       || NILP (value)
2688                       || STRINGP (value))
2689                     to[LFACE_OVERLINE_INDEX] = value;
2690                   else
2691                     err = 1;
2692                 }
2693               else if (EQ (keyword, QCstrike_through))
2694                 {
2695                   if (EQ (value, Qt)
2696                       || NILP (value)
2697                       || STRINGP (value))
2698                     to[LFACE_STRIKE_THROUGH_INDEX] = value;
2699                   else
2700                     err = 1;
2701                 }
2702               else if (EQ (keyword, QCbox))
2703                 {
2704                   if (EQ (value, Qt))
2705                     value = make_number (1);
2706                   if (INTEGERP (value)
2707                       || STRINGP (value)
2708                       || CONSP (value)
2709                       || NILP (value))
2710                     to[LFACE_BOX_INDEX] = value;
2711                   else
2712                     err = 1;
2713                 }
2714               else if (EQ (keyword, QCinverse_video)
2715                        || EQ (keyword, QCreverse_video))
2716                 {
2717                   if (EQ (value, Qt) || NILP (value))
2718                     to[LFACE_INVERSE_INDEX] = value;
2719                   else
2720                     err = 1;
2721                 }
2722               else if (EQ (keyword, QCforeground))
2723                 {
2724                   if (STRINGP (value))
2725                     to[LFACE_FOREGROUND_INDEX] = value;
2726                   else
2727                     err = 1;
2728                 }
2729               else if (EQ (keyword, QCbackground))
2730                 {
2731                   if (STRINGP (value))
2732                     to[LFACE_BACKGROUND_INDEX] = value;
2733                   else
2734                     err = 1;
2735                 }
2736               else if (EQ (keyword, QCstipple))
2737                 {
2738 #if defined(HAVE_X_WINDOWS) || defined(HAVE_NS)
2739                   Lisp_Object pixmap_p = Fbitmap_spec_p (value);
2740                   if (!NILP (pixmap_p))
2741                     to[LFACE_STIPPLE_INDEX] = value;
2742                   else
2743                     err = 1;
2744 #endif
2745                 }
2746               else if (EQ (keyword, QCwidth))
2747                 {
2748                   if (SYMBOLP (value) && FONT_WIDTH_NAME_NUMERIC (value) >= 0)
2749                     {
2750                       to[LFACE_SWIDTH_INDEX] = value;
2751                       font_clear_prop (to, FONT_WIDTH_INDEX);
2752                     }
2753                   else
2754                     err = 1;
2755                 }
2756               else if (EQ (keyword, QCinherit))
2757                 {
2758                   /* This is not really very useful; it's just like a
2759                      normal face reference.  */
2760                   if (! merge_face_ref (f, value, to,
2761                                         err_msgs, named_merge_points))
2762                     err = 1;
2763                 }
2764               else
2765                 err = 1;
2766 
2767               if (err)
2768                 {
2769                   add_to_log ("Invalid face attribute %S %S", keyword, value);
2770                   ok = 0;
2771                 }
2772 
2773               face_ref = XCDR (XCDR (face_ref));
2774             }
2775         }
2776       else
2777         {
2778           /* This is a list of face refs.  Those at the beginning of the
2779              list take precedence over what follows, so we have to merge
2780              from the end backwards.  */
2781           Lisp_Object next = XCDR (face_ref);
2782 
2783           if (! NILP (next))
2784             ok = merge_face_ref (f, next, to, err_msgs, named_merge_points);
2785 
2786           if (! merge_face_ref (f, first, to, err_msgs, named_merge_points))
2787             ok = 0;
2788         }
2789     }
2790   else
2791     {
2792       /* FACE_REF ought to be a face name.  */
2793       ok = merge_named_face (f, face_ref, to, named_merge_points);
2794       if (!ok && err_msgs)
2795         add_to_log ("Invalid face reference: %s", face_ref, Qnil);
2796     }
2797 
2798   return ok;
2799 }
2800 
2801 
2802 DEFUN ("internal-make-lisp-face", Finternal_make_lisp_face,
2803        Sinternal_make_lisp_face, 1, 2, 0,
2804        doc: /* Make FACE, a symbol, a Lisp face with all attributes nil.
2805 If FACE was not known as a face before, create a new one.
2806 If optional argument FRAME is specified, make a frame-local face
2807 for that frame.  Otherwise operate on the global face definition.
2808 Value is a vector of face attributes.  */)
2809      (face, frame)
2810      Lisp_Object face, frame;
2811 {
2812   Lisp_Object global_lface, lface;
2813   struct frame *f;
2814   int i;
2815 
2816   CHECK_SYMBOL (face);
2817   global_lface = lface_from_face_name (NULL, face, 0);
2818 
2819   if (!NILP (frame))
2820     {
2821       CHECK_LIVE_FRAME (frame);
2822       f = XFRAME (frame);
2823       lface = lface_from_face_name (f, face, 0);
2824     }
2825   else
2826     f = NULL, lface = Qnil;
2827 
2828   /* Add a global definition if there is none.  */
2829   if (NILP (global_lface))
2830     {
2831       global_lface = Fmake_vector (make_number (LFACE_VECTOR_SIZE),
2832                                    Qunspecified);
2833       ASET (global_lface, 0, Qface);
2834       Vface_new_frame_defaults = Fcons (Fcons (face, global_lface),
2835                                         Vface_new_frame_defaults);
2836 
2837       /* Assign the new Lisp face a unique ID.  The mapping from Lisp
2838          face id to Lisp face is given by the vector lface_id_to_name.
2839          The mapping from Lisp face to Lisp face id is given by the
2840          property `face' of the Lisp face name.  */
2841       if (next_lface_id == lface_id_to_name_size)
2842         {
2843           int new_size = max (50, 2 * lface_id_to_name_size);
2844           int sz = new_size * sizeof *lface_id_to_name;
2845           lface_id_to_name = (Lisp_Object *) xrealloc (lface_id_to_name, sz);
2846           lface_id_to_name_size = new_size;
2847         }
2848 
2849       lface_id_to_name[next_lface_id] = face;
2850       Fput (face, Qface, make_number (next_lface_id));
2851       ++next_lface_id;
2852     }
2853   else if (f == NULL)
2854     for (i = 1; i < LFACE_VECTOR_SIZE; ++i)
2855       ASET (global_lface, i, Qunspecified);
2856 
2857   /* Add a frame-local definition.  */
2858   if (f)
2859     {
2860       if (NILP (lface))
2861         {
2862           lface = Fmake_vector (make_number (LFACE_VECTOR_SIZE),
2863                                 Qunspecified);
2864           ASET (lface, 0, Qface);
2865           f->face_alist = Fcons (Fcons (face, lface), f->face_alist);
2866         }
2867       else
2868         for (i = 1; i < LFACE_VECTOR_SIZE; ++i)
2869           ASET (lface, i, Qunspecified);
2870     }
2871   else
2872     lface = global_lface;
2873 
2874   /* Changing a named face means that all realized faces depending on
2875      that face are invalid.  Since we cannot tell which realized faces
2876      depend on the face, make sure they are all removed.  This is done
2877      by incrementing face_change_count.  The next call to
2878      init_iterator will then free realized faces.  */
2879   if (NILP (Fget (face, Qface_no_inherit)))
2880     {
2881       ++face_change_count;
2882       ++windows_or_buffers_changed;
2883     }
2884 
2885   xassert (LFACEP (lface));
2886   check_lface (lface);
2887   return lface;
2888 }
2889 
2890 
2891 DEFUN ("internal-lisp-face-p", Finternal_lisp_face_p,
2892        Sinternal_lisp_face_p, 1, 2, 0,
2893        doc: /* Return non-nil if FACE names a face.
2894 FACE should be a symbol or string.
2895 If optional second argument FRAME is non-nil, check for the
2896 existence of a frame-local face with name FACE on that frame.
2897 Otherwise check for the existence of a global face.  */)
2898      (face, frame)
2899      Lisp_Object face, frame;
2900 {
2901   Lisp_Object lface;
2902 
2903   face = resolve_face_name (face, 1);
2904 
2905   if (!NILP (frame))
2906     {
2907       CHECK_LIVE_FRAME (frame);
2908       lface = lface_from_face_name (XFRAME (frame), face, 0);
2909     }
2910   else
2911     lface = lface_from_face_name (NULL, face, 0);
2912 
2913   return lface;
2914 }
2915 
2916 
2917 DEFUN ("internal-copy-lisp-face", Finternal_copy_lisp_face,
2918        Sinternal_copy_lisp_face, 4, 4, 0,
2919        doc: /* Copy face FROM to TO.
2920 If FRAME is t, copy the global face definition of FROM.
2921 Otherwise, copy the frame-local definition of FROM on FRAME.
2922 If NEW-FRAME is a frame, copy that data into the frame-local
2923 definition of TO on NEW-FRAME.  If NEW-FRAME is nil,
2924 FRAME controls where the data is copied to.
2925 
2926 The value is TO.  */)
2927      (from, to, frame, new_frame)
2928      Lisp_Object from, to, frame, new_frame;
2929 {
2930   Lisp_Object lface, copy;
2931 
2932   CHECK_SYMBOL (from);
2933   CHECK_SYMBOL (to);
2934 
2935   if (EQ (frame, Qt))
2936     {
2937       /* Copy global definition of FROM.  We don't make copies of
2938          strings etc. because 20.2 didn't do it either.  */
2939       lface = lface_from_face_name (NULL, from, 1);
2940       copy = Finternal_make_lisp_face (to, Qnil);
2941     }
2942   else
2943     {
2944       /* Copy frame-local definition of FROM.  */
2945       if (NILP (new_frame))
2946         new_frame = frame;
2947       CHECK_LIVE_FRAME (frame);
2948       CHECK_LIVE_FRAME (new_frame);
2949       lface = lface_from_face_name (XFRAME (frame), from, 1);
2950       copy = Finternal_make_lisp_face (to, new_frame);
2951     }
2952 
2953   bcopy (XVECTOR (lface)->contents, XVECTOR (copy)->contents,
2954          LFACE_VECTOR_SIZE * sizeof (Lisp_Object));
2955 
2956   /* Changing a named face means that all realized faces depending on
2957      that face are invalid.  Since we cannot tell which realized faces
2958      depend on the face, make sure they are all removed.  This is done
2959      by incrementing face_change_count.  The next call to
2960      init_iterator will then free realized faces.  */
2961   if (NILP (Fget (to, Qface_no_inherit)))
2962     {
2963       ++face_change_count;
2964       ++windows_or_buffers_changed;
2965     }
2966 
2967   return to;
2968 }
2969 
2970 
2971 DEFUN ("internal-set-lisp-face-attribute", Finternal_set_lisp_face_attribute,
2972        Sinternal_set_lisp_face_attribute, 3, 4, 0,
2973        doc: /* Set attribute ATTR of FACE to VALUE.
2974 FRAME being a frame means change the face on that frame.
2975 FRAME nil means change the face of the selected frame.
2976 FRAME t means change the default for new frames.
2977 FRAME 0 means change the face on all frames, and change the default
2978   for new frames.  */)
2979      (face, attr, value, frame)
2980      Lisp_Object face, attr, value, frame;
2981 {
2982   Lisp_Object lface;
2983   Lisp_Object old_value = Qnil;
2984   /* Set one of enum font_property_index (> 0) if ATTR is one of
2985      font-related attributes other than QCfont and QCfontset.  */
2986   enum font_property_index prop_index = 0;
2987 
2988   CHECK_SYMBOL (face);
2989   CHECK_SYMBOL (attr);
2990 
2991   face = resolve_face_name (face, 1);
2992 
2993   /* If FRAME is 0, change face on all frames, and change the
2994      default for new frames.  */
2995   if (INTEGERP (frame) && XINT (frame) == 0)
2996     {
2997       Lisp_Object tail;
2998       Finternal_set_lisp_face_attribute (face, attr, value, Qt);
2999       FOR_EACH_FRAME (tail, frame)
3000         Finternal_set_lisp_face_attribute (face, attr, value, frame);
3001       return face;
3002     }
3003 
3004   /* Set lface to the Lisp attribute vector of FACE.  */
3005   if (EQ (frame, Qt))
3006     {
3007       lface = lface_from_face_name (NULL, face, 1);
3008 
3009       /* When updating face-new-frame-defaults, we put :ignore-defface
3010          where the caller wants `unspecified'.  This forces the frame
3011          defaults to ignore the defface value.  Otherwise, the defface
3012          will take effect, which is generally not what is intended.
3013          The value of that attribute will be inherited from some other
3014          face during face merging.  See internal_merge_in_global_face. */
3015       if (UNSPECIFIEDP (value))
3016         value = Qignore_defface;
3017     }
3018   else
3019     {
3020       if (NILP (frame))
3021         frame = selected_frame;
3022 
3023       CHECK_LIVE_FRAME (frame);
3024       lface = lface_from_face_name (XFRAME (frame), face, 0);
3025 
3026       /* If a frame-local face doesn't exist yet, create one.  */
3027       if (NILP (lface))
3028         lface = Finternal_make_lisp_face (face, frame);
3029     }
3030 
3031   if (EQ (attr, QCfamily))
3032     {
3033       if (!UNSPECIFIEDP (value) && !IGNORE_DEFFACE_P (value))
3034         {
3035           CHECK_STRING (value);
3036           if (SCHARS (value) == 0)
3037             signal_error ("Invalid face family", value);
3038         }
3039       old_value = LFACE_FAMILY (lface);
3040       LFACE_FAMILY (lface) = value;
3041       prop_index = FONT_FAMILY_INDEX;
3042     }
3043   else if (EQ (attr, QCfoundry))
3044     {
3045       if (!UNSPECIFIEDP (value) && !IGNORE_DEFFACE_P (value))
3046         {
3047           CHECK_STRING (value);
3048           if (SCHARS (value) == 0)
3049             signal_error ("Invalid face foundry", value);
3050         }
3051       old_value = LFACE_FOUNDRY (lface);
3052       LFACE_FOUNDRY (lface) = value;
3053       prop_index = FONT_FOUNDRY_INDEX;
3054     }
3055   else if (EQ (attr, QCheight))
3056     {
3057       if (!UNSPECIFIEDP (value) && !IGNORE_DEFFACE_P (value))
3058         {
3059           if (EQ (face, Qdefault))
3060             {
3061               /* The default face must have an absolute size.  */
3062               if (!INTEGERP (value) || XINT (value) <= 0)
3063                 signal_error ("Invalid default face height", value);
3064             }
3065           else
3066             {
3067               /* For non-default faces, do a test merge with a random
3068                  height to see if VALUE's ok. */
3069               Lisp_Object test = merge_face_heights (value,
3070                                                      make_number (10),
3071                                                      Qnil);
3072               if (!INTEGERP (test) || XINT (test) <= 0)
3073                 signal_error ("Invalid face height", value);
3074             }
3075         }
3076 
3077       old_value = LFACE_HEIGHT (lface);
3078       LFACE_HEIGHT (lface) = value;
3079       prop_index = FONT_SIZE_INDEX;
3080     }
3081   else if (EQ (attr, QCweight))
3082     {
3083       if (!UNSPECIFIEDP (value) && !IGNORE_DEFFACE_P (value))
3084         {
3085           CHECK_SYMBOL (value);
3086           if (FONT_WEIGHT_NAME_NUMERIC (value) < 0)
3087             signal_error ("Invalid face weight", value);
3088         }
3089       old_value = LFACE_WEIGHT (lface);
3090       LFACE_WEIGHT (lface) = value;
3091       prop_index = FONT_WEIGHT_INDEX;
3092     }
3093   else if (EQ (attr, QCslant))
3094     {
3095       if (!UNSPECIFIEDP (value) && !IGNORE_DEFFACE_P (value))
3096         {
3097           CHECK_SYMBOL (value);
3098           if (FONT_SLANT_NAME_NUMERIC (value) < 0)
3099             signal_error ("Invalid face slant", value);
3100         }
3101       old_value = LFACE_SLANT (lface);
3102       LFACE_SLANT (lface) = value;
3103       prop_index = FONT_SLANT_INDEX;
3104     }
3105   else if (EQ (attr, QCunderline))
3106     {
3107       if (!UNSPECIFIEDP (value) && !IGNORE_DEFFACE_P (value))
3108         if ((SYMBOLP (value)
3109              && !EQ (value, Qt)
3110              && !EQ (value, Qnil))
3111             /* Underline color.  */
3112             || (STRINGP (value)
3113                 && SCHARS (value) == 0))
3114           signal_error ("Invalid face underline", value);
3115 
3116       old_value = LFACE_UNDERLINE (lface);
3117       LFACE_UNDERLINE (lface) = value;
3118     }
3119   else if (EQ (attr, QCoverline))
3120     {
3121       if (!UNSPECIFIEDP (value) && !IGNORE_DEFFACE_P (value))
3122         if ((SYMBOLP (value)
3123              && !EQ (value, Qt)
3124              && !EQ (value, Qnil))
3125             /* Overline color.  */
3126             || (STRINGP (value)
3127                 && SCHARS (value) == 0))
3128           signal_error ("Invalid face overline", value);
3129 
3130       old_value = LFACE_OVERLINE (lface);
3131       LFACE_OVERLINE (lface) = value;
3132     }
3133   else if (EQ (attr, QCstrike_through))
3134     {
3135       if (!UNSPECIFIEDP (value) && !IGNORE_DEFFACE_P (value))
3136         if ((SYMBOLP (value)
3137              && !EQ (value, Qt)
3138              && !EQ (value, Qnil))
3139             /* Strike-through color.  */
3140             || (STRINGP (value)
3141                 && SCHARS (value) == 0))
3142           signal_error ("Invalid face strike-through", value);
3143 
3144       old_value = LFACE_STRIKE_THROUGH (lface);
3145       LFACE_STRIKE_THROUGH (lface) = value;
3146     }
3147   else if (EQ (attr, QCbox))
3148     {
3149       int valid_p;
3150 
3151       /* Allow t meaning a simple box of width 1 in foreground color
3152          of the face.  */
3153       if (EQ (value, Qt))
3154         value = make_number (1);
3155 
3156       if (UNSPECIFIEDP (value) || IGNORE_DEFFACE_P (value))
3157         valid_p = 1;
3158       else if (NILP (value))
3159         valid_p = 1;
3160       else if (INTEGERP (value))
3161         valid_p = XINT (value) != 0;
3162       else if (STRINGP (value))
3163         valid_p = SCHARS (value) > 0;
3164       else if (CONSP (value))
3165         {
3166           Lisp_Object tem;
3167 
3168           tem = value;
3169           while (CONSP (tem))
3170             {
3171               Lisp_Object k, v;
3172 
3173               k = XCAR (tem);
3174               tem = XCDR (tem);
3175               if (!CONSP (tem))
3176                 break;
3177               v = XCAR (tem);
3178               tem = XCDR (tem);
3179 
3180               if (EQ (k, QCline_width))
3181                 {
3182                   if (!INTEGERP (v) || XINT (v) == 0)
3183                     break;
3184                 }
3185               else if (EQ (k, QCcolor))
3186                 {
3187                   if (!NILP (v) && (!STRINGP (v) || SCHARS (v) == 0))
3188                     break;
3189                 }
3190               else if (EQ (k, QCstyle))
3191                 {
3192                   if (!EQ (v, Qpressed_button) && !EQ (v, Qreleased_button))
3193                     break;
3194                 }
3195               else
3196                 break;
3197             }
3198 
3199           valid_p = NILP (tem);
3200         }
3201       else
3202         valid_p = 0;
3203 
3204       if (!valid_p)
3205         signal_error ("Invalid face box", value);
3206 
3207       old_value = LFACE_BOX (lface);
3208       LFACE_BOX (lface) = value;
3209     }
3210   else if (EQ (attr, QCinverse_video)
3211            || EQ (attr, QCreverse_video))
3212     {
3213       if (!UNSPECIFIEDP (value) && !IGNORE_DEFFACE_P (value))
3214         {
3215           CHECK_SYMBOL (value);
3216           if (!EQ (value, Qt) && !NILP (value))
3217             signal_error ("Invalid inverse-video face attribute value", value);
3218         }
3219       old_value = LFACE_INVERSE (lface);
3220       LFACE_INVERSE (lface) = value;
3221     }
3222   else if (EQ (attr, QCforeground))
3223     {
3224       /* Compatibility with 20.x.  */
3225       if (NILP (value))
3226         value = Qunspecified;
3227       if (!UNSPECIFIEDP (value) && !IGNORE_DEFFACE_P (value))
3228         {
3229           /* Don't check for valid color names here because it depends
3230              on the frame (display) whether the color will be valid
3231              when the face is realized.  */
3232           CHECK_STRING (value);
3233           if (SCHARS (value) == 0)
3234             signal_error ("Empty foreground color value", value);
3235         }
3236       old_value = LFACE_FOREGROUND (lface);
3237       LFACE_FOREGROUND (lface) = value;
3238     }
3239   else if (EQ (attr, QCbackground))
3240     {
3241       /* Compatibility with 20.x.  */
3242       if (NILP (value))
3243         value = Qunspecified;
3244       if (!UNSPECIFIEDP (value) && !IGNORE_DEFFACE_P (value))
3245         {
3246           /* Don't check for valid color names here because it depends
3247              on the frame (display) whether the color will be valid
3248              when the face is realized.  */
3249           CHECK_STRING (value);
3250           if (SCHARS (value) == 0)
3251             signal_error ("Empty background color value", value);
3252         }
3253       old_value = LFACE_BACKGROUND (lface);
3254       LFACE_BACKGROUND (lface) = value;
3255     }
3256   else if (EQ (attr, QCstipple))
3257     {
3258 #if defined(HAVE_X_WINDOWS) || defined(HAVE_NS)
3259       if (!UNSPECIFIEDP (value) && !IGNORE_DEFFACE_P (value)
3260           && !NILP (value)
3261           && NILP (Fbitmap_spec_p (value)))
3262         signal_error ("Invalid stipple attribute", value);
3263       old_value = LFACE_STIPPLE (lface);
3264       LFACE_STIPPLE (lface) = value;
3265 #endif /* HAVE_X_WINDOWS || HAVE_NS */
3266     }
3267   else if (EQ (attr, QCwidth))
3268     {
3269       if (!UNSPECIFIEDP (value) && !IGNORE_DEFFACE_P (value))
3270         {
3271           CHECK_SYMBOL (value);
3272           if (FONT_WIDTH_NAME_NUMERIC (value) < 0)
3273             signal_error ("Invalid face width", value);
3274         }
3275       old_value = LFACE_SWIDTH (lface);
3276       LFACE_SWIDTH (lface) = value;
3277       prop_index = FONT_WIDTH_INDEX;
3278     }
3279   else if (EQ (attr, QCfont))
3280     {
3281 #ifdef HAVE_WINDOW_SYSTEM
3282       if (EQ (frame, Qt) || FRAME_WINDOW_P (XFRAME (frame)))
3283         {
3284           if (!UNSPECIFIEDP (value) && !IGNORE_DEFFACE_P (value))
3285             {
3286               FRAME_PTR f;
3287 
3288               old_value = LFACE_FONT (lface);
3289               if (! FONTP (value))
3290                 {
3291                   if (STRINGP (value))
3292                     {
3293                       Lisp_Object name = value;
3294                       int fontset = fs_query_fontset (name, 0);
3295 
3296                       if (fontset >= 0)
3297                         name = fontset_ascii (fontset);
3298                       value = font_spec_from_name (name);
3299                       if (!FONTP (value))
3300                         signal_error ("Invalid font name", name);
3301                     }
3302                   else
3303                     signal_error ("Invalid font or font-spec", value);
3304                 }
3305               if (EQ (frame, Qt))
3306                 f = XFRAME (selected_frame);
3307               else
3308                 f = XFRAME (frame);
3309               if (! FONT_OBJECT_P (value))
3310                 {
3311                   Lisp_Object *attrs = XVECTOR (lface)->contents;
3312                   Lisp_Object font_object;
3313 
3314                   font_object = font_load_for_lface (f, attrs, value);
3315                   if (NILP (font_object))
3316                     signal_error ("Font not available", value);
3317                   value = font_object;
3318                 }
3319               set_lface_from_font (f, lface, value, 1);
3320             }
3321           else
3322             LFACE_FONT (lface) = value;
3323         }
3324 #endif /* HAVE_WINDOW_SYSTEM */
3325     }
3326   else if (EQ (attr, QCfontset))
3327     {
3328 #ifdef HAVE_WINDOW_SYSTEM
3329       if (EQ (frame, Qt) || FRAME_WINDOW_P (XFRAME (frame)))
3330         {
3331           Lisp_Object tmp;
3332 
3333           old_value = LFACE_FONTSET (lface);
3334           tmp = Fquery_fontset (value, Qnil);
3335           if (NILP (tmp))
3336             signal_error ("Invalid fontset name", value);
3337           LFACE_FONTSET (lface) = value = tmp;
3338         }
3339 #endif /* HAVE_WINDOW_SYSTEM */
3340     }
3341   else if (EQ (attr, QCinherit))
3342     {
3343       Lisp_Object tail;
3344       if (SYMBOLP (value))
3345         tail = Qnil;
3346       else
3347         for (tail = value; CONSP (tail); tail = XCDR (tail))
3348           if (!SYMBOLP (XCAR (tail)))
3349             break;
3350       if (NILP (tail))
3351         LFACE_INHERIT (lface) = value;
3352       else
3353         signal_error ("Invalid face inheritance", value);
3354     }
3355   else if (EQ (attr, QCbold))
3356     {
3357       old_value = LFACE_WEIGHT (lface);
3358       LFACE_WEIGHT (lface) = NILP (value) ? Qnormal : Qbold;
3359       prop_index = FONT_WEIGHT_INDEX;
3360     }
3361   else if (EQ (attr, QCitalic))
3362     {
3363       attr = QCslant;
3364       old_value = LFACE_SLANT (lface);
3365       LFACE_SLANT (lface) = NILP (value) ? Qnormal : Qitalic;
3366       prop_index = FONT_SLANT_INDEX;
3367     }
3368   else
3369     signal_error ("Invalid face attribute name", attr);
3370 
3371   if (prop_index)
3372     {
3373       /* If a font-related attribute other than QCfont and QCfontset
3374          is specified, and if the original QCfont attribute has a font
3375          (font-spec or font-object), set the corresponding property in
3376          the font to nil so that the font selector doesn't think that
3377          the attribute is mandatory.  Also, clear the average
3378          width.  */
3379       font_clear_prop (XVECTOR (lface)->contents, prop_index);
3380     }
3381 
3382   /* Changing a named face means that all realized faces depending on
3383      that face are invalid.  Since we cannot tell which realized faces
3384      depend on the face, make sure they are all removed.  This is done
3385      by incrementing face_change_count.  The next call to
3386      init_iterator will then free realized faces.  */
3387   if (!EQ (frame, Qt)
3388       && NILP (Fget (face, Qface_no_inherit))
3389       && NILP (Fequal (old_value, value)))
3390     {
3391       ++face_change_count;
3392       ++windows_or_buffers_changed;
3393     }
3394 
3395   if (!UNSPECIFIEDP (value) && !IGNORE_DEFFACE_P (value)
3396       && NILP (Fequal (old_value, value)))
3397     {
3398       Lisp_Object param;
3399 
3400       param = Qnil;
3401 
3402       if (EQ (face, Qdefault))
3403         {
3404 #ifdef HAVE_WINDOW_SYSTEM
3405           /* Changed font-related attributes of the `default' face are
3406              reflected in changed `font' frame parameters. */
3407           if (FRAMEP (frame)
3408               && (prop_index || EQ (attr, QCfont))
3409               && lface_fully_specified_p (XVECTOR (lface)->contents))
3410             set_font_frame_param (frame, lface);
3411           else
3412 #endif /* HAVE_WINDOW_SYSTEM */
3413 
3414           if (EQ (attr, QCforeground))
3415             param = Qforeground_color;
3416           else if (EQ (attr, QCbackground))
3417             param = Qbackground_color;
3418         }
3419 #ifdef HAVE_WINDOW_SYSTEM
3420 #ifndef WINDOWSNT
3421       else if (EQ (face, Qscroll_bar))
3422         {
3423           /* Changing the colors of `scroll-bar' sets frame parameters
3424              `scroll-bar-foreground' and `scroll-bar-background'. */
3425           if (EQ (attr, QCforeground))
3426             param = Qscroll_bar_foreground;
3427           else if (EQ (attr, QCbackground))
3428             param = Qscroll_bar_background;
3429         }
3430 #endif /* not WINDOWSNT */
3431       else if (EQ (face, Qborder))
3432         {
3433           /* Changing background color of `border' sets frame parameter
3434              `border-color'.  */
3435           if (EQ (attr, QCbackground))
3436             param = Qborder_color;
3437         }
3438       else if (EQ (face, Qcursor))
3439         {
3440           /* Changing background color of `cursor' sets frame parameter
3441              `cursor-color'.  */
3442           if (EQ (attr, QCbackground))
3443             param = Qcursor_color;
3444         }
3445       else if (EQ (face, Qmouse))
3446         {
3447           /* Changing background color of `mouse' sets frame parameter
3448              `mouse-color'.  */
3449           if (EQ (attr, QCbackground))
3450             param = Qmouse_color;
3451         }
3452 #endif /* HAVE_WINDOW_SYSTEM */
3453       else if (EQ (face, Qmenu))
3454         {
3455           /* Indicate that we have to update the menu bar when
3456              realizing faces on FRAME.  FRAME t change the
3457              default for new frames.  We do this by setting
3458              setting the flag in new face caches   */
3459           if (FRAMEP (frame))
3460             {
3461               struct frame *f = XFRAME (frame);
3462               if (FRAME_FACE_CACHE (f) == NULL)
3463                 FRAME_FACE_CACHE (f) = make_face_cache (f);
3464               FRAME_FACE_CACHE (f)->menu_face_changed_p = 1;
3465             }
3466           else
3467             menu_face_changed_default = 1;
3468         }
3469 
3470       if (!NILP (param))
3471         {
3472           if (EQ (frame, Qt))
3473             /* Update `default-frame-alist', which is used for new frames.  */
3474             {
3475               store_in_alist (&Vdefault_frame_alist, param, value);
3476             }
3477           else
3478             /* Update the current frame's parameters.  */
3479             {
3480               Lisp_Object cons;
3481               cons = XCAR (Vparam_value_alist);
3482               XSETCAR (cons, param);
3483               XSETCDR (cons, value);
3484               Fmodify_frame_parameters (frame, Vparam_value_alist);
3485             }
3486         }
3487     }
3488 
3489   return face;
3490 }
3491 
3492 
3493 #ifdef HAVE_WINDOW_SYSTEM
3494 
3495 /* Set the `font' frame parameter of FRAME determined from the
3496    font-object set in `default' face attributes LFACE.  */
3497 
3498 static void
3499 set_font_frame_param (frame, lface)
3500      Lisp_Object frame, lface;
3501 {
3502   struct frame *f = XFRAME (frame);
3503   Lisp_Object font;
3504 
3505   if (FRAME_WINDOW_P (f)
3506       /* Don't do anything if the font is `unspecified'.  This can
3507          happen during frame creation.  */
3508       && (font = LFACE_FONT (lface),
3509           ! UNSPECIFIEDP (font)))
3510     {
3511       if (FONT_SPEC_P (font))
3512         {
3513           font = font_load_for_lface (f, XVECTOR (lface)->contents, font);
3514           if (NILP (font))
3515             return;
3516           LFACE_FONT (lface) = font;
3517         }
3518       f->default_face_done_p = 0;
3519       Fmodify_frame_parameters (frame, Fcons (Fcons (Qfont, font), Qnil));
3520     }
3521 }
3522 
3523 
3524 /* Update the corresponding face when frame parameter PARAM on frame F
3525    has been assigned the value NEW_VALUE.  */
3526 
3527 void
3528 update_face_from_frame_parameter (f, param, new_value)
3529      struct frame *f;
3530      Lisp_Object param, new_value;
3531 {
3532   Lisp_Object face = Qnil;
3533   Lisp_Object lface;
3534 
3535   /* If there are no faces yet, give up.  This is the case when called
3536      from Fx_create_frame, and we do the necessary things later in
3537      face-set-after-frame-defaults.  */
3538   if (NILP (f->face_alist))
3539     return;
3540 
3541   if (EQ (param, Qforeground_color))
3542     {
3543       face = Qdefault;
3544       lface = lface_from_face_name (f, face, 1);
3545       LFACE_FOREGROUND (lface) = (STRINGP (new_value)
3546                                   ? new_value : Qunspecified);
3547       realize_basic_faces (f);
3548     }
3549   else if (EQ (param, Qbackground_color))
3550     {
3551       Lisp_Object frame;
3552 
3553       /* Changing the background color might change the background
3554          mode, so that we have to load new defface specs.
3555          Call frame-update-face-colors to do that.  */
3556       XSETFRAME (frame, f);
3557       call1 (Qframe_set_background_mode, frame);
3558 
3559       face = Qdefault;
3560       lface = lface_from_face_name (f, face, 1);
3561       LFACE_BACKGROUND (lface) = (STRINGP (new_value)
3562                                   ? new_value : Qunspecified);
3563       realize_basic_faces (f);
3564     }
3565   else if (EQ (param, Qborder_color))
3566     {
3567       face = Qborder;
3568       lface = lface_from_face_name (f, face, 1);
3569       LFACE_BACKGROUND (lface) = (STRINGP (new_value)
3570                                   ? new_value : Qunspecified);
3571     }
3572   else if (EQ (param, Qcursor_color))
3573     {
3574       face = Qcursor;
3575       lface = lface_from_face_name (f, face, 1);
3576       LFACE_BACKGROUND (lface) = (STRINGP (new_value)
3577                                   ? new_value : Qunspecified);
3578     }
3579   else if (EQ (param, Qmouse_color))
3580     {
3581       face = Qmouse;
3582       lface = lface_from_face_name (f, face, 1);
3583       LFACE_BACKGROUND (lface) = (STRINGP (new_value)
3584                                   ? new_value : Qunspecified);
3585     }
3586 
3587   /* Changing a named face means that all realized faces depending on
3588      that face are invalid.  Since we cannot tell which realized faces
3589      depend on the face, make sure they are all removed.  This is done
3590      by incrementing face_change_count.  The next call to
3591      init_iterator will then free realized faces.  */
3592   if (!NILP (face)
3593       && NILP (Fget (face, Qface_no_inherit)))
3594     {
3595       ++face_change_count;
3596       ++windows_or_buffers_changed;
3597     }
3598 }
3599 
3600 
3601 /* Get the value of X resource RESOURCE, class CLASS for the display
3602    of frame FRAME.  This is here because ordinary `x-get-resource'
3603    doesn't take a frame argument.  */
3604 
3605 DEFUN ("internal-face-x-get-resource", Finternal_face_x_get_resource,
3606        Sinternal_face_x_get_resource, 3, 3, 0, doc: /* */)
3607      (resource, class, frame)
3608      Lisp_Object resource, class, frame;
3609 {
3610   Lisp_Object value = Qnil;
3611   CHECK_STRING (resource);
3612   CHECK_STRING (class);
3613   CHECK_LIVE_FRAME (frame);
3614   BLOCK_INPUT;
3615   value = display_x_get_resource (FRAME_X_DISPLAY_INFO (XFRAME (frame)),
3616                                   resource, class, Qnil, Qnil);
3617   UNBLOCK_INPUT;
3618   return value;
3619 }
3620 
3621 
3622 /* Return resource string VALUE as a boolean value, i.e. nil, or t.
3623    If VALUE is "on" or "true", return t.  If VALUE is "off" or
3624    "false", return nil.  Otherwise, if SIGNAL_P is non-zero, signal an
3625    error; if SIGNAL_P is zero, return 0.  */
3626 
3627 static Lisp_Object
3628 face_boolean_x_resource_value (value, signal_p)
3629      Lisp_Object value;
3630      int signal_p;
3631 {
3632   Lisp_Object result = make_number (0);
3633 
3634   xassert (STRINGP (value));
3635 
3636   if (xstrcasecmp (SDATA (value), "on") == 0
3637       || xstrcasecmp (SDATA (value), "true") == 0)
3638     result = Qt;
3639   else if (xstrcasecmp (SDATA (value), "off") == 0
3640            || xstrcasecmp (SDATA (value), "false") == 0)
3641     result = Qnil;
3642   else if (xstrcasecmp (SDATA (value), "unspecified") == 0)
3643     result = Qunspecified;
3644   else if (signal_p)
3645     signal_error ("Invalid face attribute value from X resource", value);
3646 
3647   return result;
3648 }
3649 
3650 
3651 DEFUN ("internal-set-lisp-face-attribute-from-resource",
3652        Finternal_set_lisp_face_attribute_from_resource,
3653        Sinternal_set_lisp_face_attribute_from_resource,
3654        3, 4, 0, doc: /* */)
3655      (face, attr, value, frame)
3656      Lisp_Object face, attr, value, frame;
3657 {
3658   CHECK_SYMBOL (face);
3659   CHECK_SYMBOL (attr);
3660   CHECK_STRING (value);
3661 
3662   if (xstrcasecmp (SDATA (value), "unspecified") == 0)
3663     value = Qunspecified;
3664   else if (EQ (attr, QCheight))
3665     {
3666       value = Fstring_to_number (value, make_number (10));
3667       if (XINT (value) <= 0)
3668         signal_error ("Invalid face height from X resource", value);
3669     }
3670   else if (EQ (attr, QCbold) || EQ (attr, QCitalic))
3671     value = face_boolean_x_resource_value (value, 1);
3672   else if (EQ (attr, QCweight) || EQ (attr, QCslant) || EQ (attr, QCwidth))
3673     value = intern (SDATA (value));
3674   else if (EQ (attr, QCreverse_video) || EQ (attr, QCinverse_video))
3675     value = face_boolean_x_resource_value (value, 1);
3676   else if (EQ (attr, QCunderline)
3677            || EQ (attr, QCoverline)
3678            || EQ (attr, QCstrike_through))
3679     {
3680       Lisp_Object boolean_value;
3681 
3682       /* If the result of face_boolean_x_resource_value is t or nil,
3683          VALUE does NOT specify a color. */
3684       boolean_value = face_boolean_x_resource_value (value, 0);
3685       if (SYMBOLP (boolean_value))
3686         value = boolean_value;
3687     }
3688   else if (EQ (attr, QCbox) || EQ (attr, QCinherit))
3689     value = Fcar (Fread_from_string (value, Qnil, Qnil));
3690 
3691   return Finternal_set_lisp_face_attribute (face, attr, value, frame);
3692 }
3693 
3694 #endif /* HAVE_WINDOW_SYSTEM */
3695 
3696 
3697 /***********************************************************************
3698                               Menu face
3699  ***********************************************************************/
3700 
3701 #if defined HAVE_X_WINDOWS && defined USE_X_TOOLKIT
3702 
3703 /* Make menus on frame F appear as specified by the `menu' face.  */
3704 
3705 static void
3706 x_update_menu_appearance (f)
3707      struct frame *f;
3708 {
3709   struct x_display_info *dpyinfo = FRAME_X_DISPLAY_INFO (f);
3710   XrmDatabase rdb;
3711 
3712   if (dpyinfo
3713       && (rdb = XrmGetDatabase (FRAME_X_DISPLAY (f)),
3714           rdb != NULL))
3715     {
3716       char line[512];
3717       Lisp_Object lface = lface_from_face_name (f, Qmenu, 1);
3718       struct face *face = FACE_FROM_ID (f, MENU_FACE_ID);
3719       const char *myname = SDATA (Vx_resource_name);
3720       int changed_p = 0;
3721 #ifdef USE_MOTIF
3722       const char *popup_path = "popup_menu";
3723 #else
3724       const char *popup_path = "menu.popup";
3725 #endif
3726 
3727       if (STRINGP (LFACE_FOREGROUND (lface)))
3728         {
3729           sprintf (line, "%s.%s*foreground: %s",
3730                    myname, popup_path,
3731                    SDATA (LFACE_FOREGROUND (lface)));
3732           XrmPutLineResource (&rdb, line);
3733           sprintf (line, "%s.pane.menubar*foreground: %s",
3734                    myname, SDATA (LFACE_FOREGROUND (lface)));
3735           XrmPutLineResource (&rdb, line);
3736           changed_p = 1;
3737         }
3738 
3739       if (STRINGP (LFACE_BACKGROUND (lface)))
3740         {
3741           sprintf (line, "%s.%s*background: %s",
3742                    myname, popup_path,
3743                    SDATA (LFACE_BACKGROUND (lface)));
3744           XrmPutLineResource (&rdb, line);
3745           sprintf (line, "%s.pane.menubar*background: %s",
3746                    myname, SDATA (LFACE_BACKGROUND (lface)));
3747           XrmPutLineResource (&rdb, line);
3748           changed_p = 1;
3749         }
3750 
3751       if (face->font
3752           /* On Solaris 5.8, it's been reported that the `menu' face
3753              can be unspecified here, during startup.  Why this
3754              happens remains unknown.  -- cyd  */
3755           && FONTP (LFACE_FONT (lface))
3756           && (!UNSPECIFIEDP (LFACE_FAMILY (lface))
3757               || !UNSPECIFIEDP (LFACE_FOUNDRY (lface))
3758               || !UNSPECIFIEDP (LFACE_SWIDTH (lface))
3759               || !UNSPECIFIEDP (LFACE_WEIGHT (lface))
3760               || !UNSPECIFIEDP (LFACE_SLANT (lface))
3761               || !UNSPECIFIEDP (LFACE_HEIGHT (lface))))
3762         {
3763           Lisp_Object xlfd = Ffont_xlfd_name (LFACE_FONT (lface), Qnil);
3764 #ifdef USE_MOTIF
3765           const char *suffix = "List";
3766           Bool motif = True;
3767 #else
3768 #if defined HAVE_X_I18N
3769 
3770           const char *suffix = "Set";
3771 #else
3772           const char *suffix = "";
3773 #endif
3774           Bool motif = False;
3775 #endif
3776 
3777           if (! NILP (xlfd))
3778             {
3779 #if defined HAVE_X_I18N
3780               extern char *xic_create_fontsetname
3781                 P_ ((char *base_fontname, Bool motif));
3782               char *fontsetname = xic_create_fontsetname (SDATA (xlfd), motif);
3783 #else
3784               char *fontsetname = (char *) SDATA (xlfd);
3785 #endif
3786               sprintf (line, "%s.pane.menubar*font%s: %s",
3787                        myname, suffix, fontsetname);
3788               XrmPutLineResource (&rdb, line);
3789               sprintf (line, "%s.%s*font%s: %s",
3790                        myname, popup_path, suffix, fontsetname);
3791               XrmPutLineResource (&rdb, line);
3792               changed_p = 1;
3793               if (fontsetname != (char *) SDATA (xlfd))
3794                 xfree (fontsetname);
3795             }
3796         }
3797 
3798       if (changed_p && f->output_data.x->menubar_widget)
3799         free_frame_menubar (f);
3800     }
3801 }
3802 
3803 #endif /* HAVE_X_WINDOWS && USE_X_TOOLKIT */
3804 
3805 
3806 DEFUN ("face-attribute-relative-p", Fface_attribute_relative_p,
3807        Sface_attribute_relative_p,
3808        2, 2, 0,
3809        doc: /* Check whether a face attribute value is relative.
3810 Specifically, this function returns t if the attribute ATTRIBUTE
3811 with the value VALUE is relative.
3812 
3813 A relative value is one that doesn't entirely override whatever is
3814 inherited from another face.  For most possible attributes,
3815 the only relative value that users see is `unspecified'.
3816 However, for :height, floating point values are also relative.  */)
3817      (attribute, value)
3818      Lisp_Object attribute, value;
3819 {
3820   if (EQ (value, Qunspecified) || (EQ (value, Qignore_defface)))
3821     return Qt;
3822   else if (EQ (attribute, QCheight))
3823     return INTEGERP (value) ? Qnil : Qt;
3824   else
3825     return Qnil;
3826 }
3827 
3828 DEFUN ("merge-face-attribute", Fmerge_face_attribute, Smerge_face_attribute,
3829        3, 3, 0,
3830        doc: /* Return face ATTRIBUTE VALUE1 merged with VALUE2.
3831 If VALUE1 or VALUE2 are absolute (see `face-attribute-relative-p'), then
3832 the result will be absolute, otherwise it will be relative.  */)
3833      (attribute, value1, value2)
3834      Lisp_Object attribute, value1, value2;
3835 {
3836   if (EQ (value1, Qunspecified) || EQ (value1, Qignore_defface))
3837     return value2;
3838   else if (EQ (attribute, QCheight))
3839     return merge_face_heights (value1, value2, value1);
3840   else
3841     return value1;
3842 }
3843 
3844 
3845 DEFUN ("internal-get-lisp-face-attribute", Finternal_get_lisp_face_attribute,
3846        Sinternal_get_lisp_face_attribute,
3847        2, 3, 0,
3848        doc: /* Return face attribute KEYWORD of face SYMBOL.
3849 If SYMBOL does not name a valid Lisp face or KEYWORD isn't a valid
3850 face attribute name, signal an error.
3851 If the optional argument FRAME is given, report on face SYMBOL in that
3852 frame.  If FRAME is t, report on the defaults for face SYMBOL (for new
3853 frames).  If FRAME is omitted or nil, use the selected frame.  */)
3854      (symbol, keyword, frame)
3855      Lisp_Object symbol, keyword, frame;
3856 {
3857   Lisp_Object lface, value = Qnil;
3858 
3859   CHECK_SYMBOL (symbol);
3860   CHECK_SYMBOL (keyword);
3861 
3862   if (EQ (frame, Qt))
3863     lface = lface_from_face_name (NULL, symbol, 1);
3864   else
3865     {
3866       if (NILP (frame))
3867         frame = selected_frame;
3868       CHECK_LIVE_FRAME (frame);
3869       lface = lface_from_face_name (XFRAME (frame), symbol, 1);
3870     }
3871 
3872   if (EQ (keyword, QCfamily))
3873     value = LFACE_FAMILY (lface);
3874   else if (EQ (keyword, QCfoundry))
3875     value = LFACE_FOUNDRY (lface);
3876   else if (EQ (keyword, QCheight))
3877     value = LFACE_HEIGHT (lface);
3878   else if (EQ (keyword, QCweight))
3879     value = LFACE_WEIGHT (lface);
3880   else if (EQ (keyword, QCslant))
3881     value = LFACE_SLANT (lface);
3882   else if (EQ (keyword, QCunderline))
3883     value = LFACE_UNDERLINE (lface);
3884   else if (EQ (keyword, QCoverline))
3885     value = LFACE_OVERLINE (lface);
3886   else if (EQ (keyword, QCstrike_through))
3887     value = LFACE_STRIKE_THROUGH (lface);
3888   else if (EQ (keyword, QCbox))
3889     value = LFACE_BOX (lface);
3890   else if (EQ (keyword, QCinverse_video)
3891            || EQ (keyword, QCreverse_video))
3892     value = LFACE_INVERSE (lface);
3893   else if (EQ (keyword, QCforeground))
3894     value = LFACE_FOREGROUND (lface);
3895   else if (EQ (keyword, QCbackground))
3896     value = LFACE_BACKGROUND (lface);
3897   else if (EQ (keyword, QCstipple))
3898     value = LFACE_STIPPLE (lface);
3899   else if (EQ (keyword, QCwidth))
3900     value = LFACE_SWIDTH (lface);
3901   else if (EQ (keyword, QCinherit))
3902     value = LFACE_INHERIT (lface);
3903   else if (EQ (keyword, QCfont))
3904     value = LFACE_FONT (lface);
3905   else if (EQ (keyword, QCfontset))
3906     value = LFACE_FONTSET (lface);
3907   else
3908     signal_error ("Invalid face attribute name", keyword);
3909 
3910   if (IGNORE_DEFFACE_P (value))
3911     return Qunspecified;
3912 
3913   return value;
3914 }
3915 
3916 
3917 DEFUN ("internal-lisp-face-attribute-values",
3918        Finternal_lisp_face_attribute_values,
3919        Sinternal_lisp_face_attribute_values, 1, 1, 0,
3920        doc: /* Return a list of valid discrete values for face attribute ATTR.
3921 Value is nil if ATTR doesn't have a discrete set of valid values.  */)
3922      (attr)
3923      Lisp_Object attr;
3924 {
3925   Lisp_Object result = Qnil;
3926 
3927   CHECK_SYMBOL (attr);
3928 
3929   if (EQ (attr, QCunderline))
3930     result = Fcons (Qt, Fcons (Qnil, Qnil));
3931   else if (EQ (attr, QCoverline))
3932     result = Fcons (Qt, Fcons (Qnil, Qnil));
3933   else if (EQ (attr, QCstrike_through))
3934     result = Fcons (Qt, Fcons (Qnil, Qnil));
3935   else if (EQ (attr, QCinverse_video) || EQ (attr, QCreverse_video))
3936     result = Fcons (Qt, Fcons (Qnil, Qnil));
3937 
3938   return result;
3939 }
3940 
3941 
3942 DEFUN ("internal-merge-in-global-face", Finternal_merge_in_global_face,
3943        Sinternal_merge_in_global_face, 2, 2, 0,
3944        doc: /* Add attributes from frame-default definition of FACE to FACE on FRAME.
3945 Default face attributes override any local face attributes.  */)
3946      (face, frame)
3947      Lisp_Object face, frame;
3948 {
3949   int i;
3950   Lisp_Object global_lface, local_lface, *gvec, *lvec;
3951   struct frame *f = XFRAME (frame);
3952 
3953   CHECK_LIVE_FRAME (frame);
3954   global_lface = lface_from_face_name (NULL, face, 1);
3955   local_lface = lface_from_face_name (f, face, 0);
3956   if (NILP (local_lface))
3957     local_lface = Finternal_make_lisp_face (face, frame);
3958 
3959   /* Make every specified global attribute override the local one.
3960      BEWARE!! This is only used from `face-set-after-frame-default' where
3961      the local frame is defined from default specs in `face-defface-spec'
3962      and those should be overridden by global settings.  Hence the strange
3963      "global before local" priority.  */
3964   lvec = XVECTOR (local_lface)->contents;
3965   gvec = XVECTOR (global_lface)->contents;
3966   for (i = 1; i < LFACE_VECTOR_SIZE; ++i)
3967     if (IGNORE_DEFFACE_P (gvec[i]))
3968       lvec[i] = Qunspecified;
3969     else if (! UNSPECIFIEDP (gvec[i]))
3970       lvec[i] = gvec[i];
3971 
3972   /* If the default face was changed, update the face cache and the
3973      `font' frame parameter.  */
3974   if (EQ (face, Qdefault))
3975     {
3976       struct face_cache *c = FRAME_FACE_CACHE (f);
3977       struct face *newface, *oldface = FACE_FROM_ID (f, DEFAULT_FACE_ID);
3978       Lisp_Object attrs[LFACE_VECTOR_SIZE];
3979 
3980       /* This can be NULL (e.g., in batch mode).  */
3981       if (oldface)
3982         {
3983           /* Ensure that the face vector is fully specified by merging
3984              the previously-cached vector.  */
3985           bcopy (oldface->lface, attrs, sizeof attrs);
3986           merge_face_vectors (f, lvec, attrs, 0);
3987           bcopy (attrs, lvec, sizeof attrs);
3988           newface = realize_face (c, lvec, DEFAULT_FACE_ID);
3989 
3990           if ((! UNSPECIFIEDP (gvec[LFACE_FAMILY_INDEX])
3991                || ! UNSPECIFIEDP (gvec[LFACE_FOUNDRY_INDEX])
3992                || ! UNSPECIFIEDP (gvec[LFACE_HEIGHT_INDEX])
3993                || ! UNSPECIFIEDP (gvec[LFACE_WEIGHT_INDEX])
3994                || ! UNSPECIFIEDP (gvec[LFACE_SLANT_INDEX])
3995                || ! UNSPECIFIEDP (gvec[LFACE_SWIDTH_INDEX])
3996                || ! UNSPECIFIEDP (gvec[LFACE_FONT_INDEX]))
3997               && newface->font)
3998             {
3999               Lisp_Object name = newface->font->props[FONT_NAME_INDEX];
4000               Fmodify_frame_parameters (frame, Fcons (Fcons (Qfont, name),
4001                                                       Qnil));
4002             }
4003         }
4004     }
4005 
4006   return Qnil;
4007 }
4008 
4009 
4010 /* The following function is implemented for compatibility with 20.2.
4011    The function is used in x-resolve-fonts when it is asked to
4012    return fonts with the same size as the font of a face.  This is
4013    done in fontset.el.  */
4014 
4015 DEFUN ("face-font", Fface_font, Sface_font, 1, 3, 0,
4016        doc: /* Return the font name of face FACE, or nil if it is unspecified.
4017 The font name is, by default, for ASCII characters.
4018 If the optional argument FRAME is given, report on face FACE in that frame.
4019 If FRAME is t, report on the defaults for face FACE (for new frames).
4020   The font default for a face is either nil, or a list
4021   of the form (bold), (italic) or (bold italic).
4022 If FRAME is omitted or nil, use the selected frame.  And, in this case,
4023 if the optional third argument CHARACTER is given,
4024 return the font name used for CHARACTER.  */)
4025      (face, frame, character)
4026      Lisp_Object face, frame, character;
4027 {
4028   if (EQ (frame, Qt))
4029     {
4030       Lisp_Object result = Qnil;
4031       Lisp_Object lface = lface_from_face_name (NULL, face, 1);
4032 
4033       if (!UNSPECIFIEDP (LFACE_WEIGHT (lface))
4034           && !EQ (LFACE_WEIGHT (lface), Qnormal))
4035         result = Fcons (Qbold, result);
4036 
4037       if (!UNSPECIFIEDP (LFACE_SLANT (lface))
4038           && !EQ (LFACE_SLANT (lface), Qnormal))
4039         result = Fcons (Qitalic, result);
4040 
4041       return result;
4042     }
4043   else
4044     {
4045       struct frame *f = frame_or_selected_frame (frame, 1);
4046       int face_id = lookup_named_face (f, face, 1);
4047       struct face *face = FACE_FROM_ID (f, face_id);
4048 
4049       if (! face)
4050         return Qnil;
4051 #ifdef HAVE_WINDOW_SYSTEM
4052       if (FRAME_WINDOW_P (f) && !NILP (character))
4053         {
4054           CHECK_CHARACTER (character);
4055           face_id = FACE_FOR_CHAR (f, face, XINT (character), -1, Qnil);
4056           face = FACE_FROM_ID (f, face_id);
4057         }
4058       return (face->font
4059               ? face->font->props[FONT_NAME_INDEX]
4060               : Qnil);
4061 #else  /* !HAVE_WINDOW_SYSTEM */
4062       return build_string (FRAME_MSDOS_P (f)
4063                            ? "ms-dos"
4064                            : FRAME_W32_P (f) ? "w32term"
4065                            :"tty");
4066 #endif
4067     }
4068 }
4069 
4070 
4071 /* Compare face-attribute values v1 and v2 for equality.  Value is non-zero if
4072    all attributes are `equal'.  Tries to be fast because this function
4073    is called quite often.  */
4074 
4075 static INLINE int
4076 face_attr_equal_p (v1, v2)
4077      Lisp_Object v1, v2;
4078 {
4079   /* Type can differ, e.g. when one attribute is unspecified, i.e. nil,
4080      and the other is specified.  */
4081   if (XTYPE (v1) != XTYPE (v2))
4082     return 0;
4083 
4084   if (EQ (v1, v2))
4085     return 1;
4086 
4087   switch (XTYPE (v1))
4088     {
4089     case Lisp_String:
4090       if (SBYTES (v1) != SBYTES (v2))
4091         return 0;
4092 
4093       return bcmp (SDATA (v1), SDATA (v2), SBYTES (v1)) == 0;
4094 
4095     case_Lisp_Int:
4096     case Lisp_Symbol:
4097       return 0;
4098 
4099     default:
4100       return !NILP (Fequal (v1, v2));
4101     }
4102 }
4103 
4104 
4105 /* Compare face vectors V1 and V2 for equality.  Value is non-zero if
4106    all attributes are `equal'.  Tries to be fast because this function
4107    is called quite often.  */
4108 
4109 static INLINE int
4110 lface_equal_p (v1, v2)
4111      Lisp_Object *v1, *v2;
4112 {
4113   int i, equal_p = 1;
4114 
4115   for (i = 1; i < LFACE_VECTOR_SIZE && equal_p; ++i)
4116     equal_p = face_attr_equal_p (v1[i], v2[i]);
4117 
4118   return equal_p;
4119 }
4120 
4121 
4122 DEFUN ("internal-lisp-face-equal-p", Finternal_lisp_face_equal_p,
4123        Sinternal_lisp_face_equal_p, 2, 3, 0,
4124        doc: /* True if FACE1 and FACE2 are equal.
4125 If the optional argument FRAME is given, report on FACE1 and FACE2 in that frame.
4126 If FRAME is t, report on the defaults for FACE1 and FACE2 (for new frames).
4127 If FRAME is omitted or nil, use the selected frame.  */)
4128      (face1, face2, frame)
4129      Lisp_Object face1, face2, frame;
4130 {
4131   int equal_p;
4132   struct frame *f;
4133   Lisp_Object lface1, lface2;
4134 
4135   if (EQ (frame, Qt))
4136     f = NULL;
4137   else
4138     /* Don't use check_x_frame here because this function is called
4139        before X frames exist.  At that time, if FRAME is nil,
4140        selected_frame will be used which is the frame dumped with
4141        Emacs.  That frame is not an X frame.  */
4142     f = frame_or_selected_frame (frame, 2);
4143 
4144   lface1 = lface_from_face_name (f, face1, 1);
4145   lface2 = lface_from_face_name (f, face2, 1);
4146   equal_p = lface_equal_p (XVECTOR (lface1)->contents,
4147                            XVECTOR (lface2)->contents);
4148   return equal_p ? Qt : Qnil;
4149 }
4150 
4151 
4152 DEFUN ("internal-lisp-face-empty-p", Finternal_lisp_face_empty_p,
4153        Sinternal_lisp_face_empty_p, 1, 2, 0,
4154        doc: /* True if FACE has no attribute specified.
4155 If the optional argument FRAME is given, report on face FACE in that frame.
4156 If FRAME is t, report on the defaults for face FACE (for new frames).
4157 If FRAME is omitted or nil, use the selected frame.  */)
4158      (face, frame)
4159      Lisp_Object face, frame;
4160 {
4161   struct frame *f;
4162   Lisp_Object lface;
4163   int i;
4164 
4165   if (NILP (frame))
4166     frame = selected_frame;
4167   CHECK_LIVE_FRAME (frame);
4168   f = XFRAME (frame);
4169 
4170   if (EQ (frame, Qt))
4171     lface = lface_from_face_name (NULL, face, 1);
4172   else
4173     lface = lface_from_face_name (f, face, 1);
4174 
4175   for (i = 1; i < LFACE_VECTOR_SIZE; ++i)
4176     if (!UNSPECIFIEDP (AREF (lface, i)))
4177       break;
4178 
4179   return i == LFACE_VECTOR_SIZE ? Qt : Qnil;
4180 }
4181 
4182 
4183 DEFUN ("frame-face-alist", Fframe_face_alist, Sframe_face_alist,
4184        0, 1, 0,
4185        doc: /* Return an alist of frame-local faces defined on FRAME.
4186 For internal use only.  */)
4187      (frame)
4188      Lisp_Object frame;
4189 {
4190   struct frame *f = frame_or_selected_frame (frame, 0);
4191   return f->face_alist;
4192 }
4193 
4194 
4195 /* Return a hash code for Lisp string STRING with case ignored.  Used
4196    below in computing a hash value for a Lisp face.  */
4197 
4198 static INLINE unsigned
4199 hash_string_case_insensitive (string)
4200      Lisp_Object string;
4201 {
4202   const unsigned char *s;
4203   unsigned hash = 0;
4204   xassert (STRINGP (string));
4205   for (s = SDATA (string); *s; ++s)
4206     hash = (hash << 1) ^ tolower (*s);
4207   return hash;
4208 }
4209 
4210 
4211 /* Return a hash code for face attribute vector V.  */
4212 
4213 static INLINE unsigned
4214 lface_hash (v)
4215      Lisp_Object *v;
4216 {
4217   return (hash_string_case_insensitive (v[LFACE_FAMILY_INDEX])
4218           ^ hash_string_case_insensitive (v[LFACE_FOUNDRY_INDEX])
4219           ^ hash_string_case_insensitive (v[LFACE_FOREGROUND_INDEX])
4220           ^ hash_string_case_insensitive (v[LFACE_BACKGROUND_INDEX])
4221           ^ XHASH (v[LFACE_WEIGHT_INDEX])
4222           ^ XHASH (v[LFACE_SLANT_INDEX])
4223           ^ XHASH (v[LFACE_SWIDTH_INDEX])
4224           ^ XHASH (v[LFACE_HEIGHT_INDEX]));
4225 }
4226 
4227 
4228 /* Return non-zero if LFACE1 and LFACE2 specify the same font (without
4229    considering charsets/registries).  They do if they specify the same
4230    family, point size, weight, width, slant, and font.  Both
4231    LFACE1 and LFACE2 must be fully-specified.  */
4232 
4233 static INLINE int
4234 lface_same_font_attributes_p (lface1, lface2)
4235      Lisp_Object *lface1, *lface2;
4236 {
4237   xassert (lface_fully_specified_p (lface1)
4238            && lface_fully_specified_p (lface2));
4239   return (xstrcasecmp (SDATA (lface1[LFACE_FAMILY_INDEX]),
4240                        SDATA (lface2[LFACE_FAMILY_INDEX])) == 0
4241           && xstrcasecmp (SDATA (lface1[LFACE_FOUNDRY_INDEX]),
4242                           SDATA (lface2[LFACE_FOUNDRY_INDEX])) == 0
4243           && EQ (lface1[LFACE_HEIGHT_INDEX], lface2[LFACE_HEIGHT_INDEX])
4244           && EQ (lface1[LFACE_SWIDTH_INDEX], lface2[LFACE_SWIDTH_INDEX])
4245           && EQ (lface1[LFACE_WEIGHT_INDEX], lface2[LFACE_WEIGHT_INDEX])
4246           && EQ (lface1[LFACE_SLANT_INDEX], lface2[LFACE_SLANT_INDEX])
4247           && EQ (lface1[LFACE_FONT_INDEX], lface2[LFACE_FONT_INDEX])
4248           && (EQ (lface1[LFACE_FONTSET_INDEX], lface2[LFACE_FONTSET_INDEX])
4249               || (STRINGP (lface1[LFACE_FONTSET_INDEX])
4250                   && STRINGP (lface2[LFACE_FONTSET_INDEX])
4251                   && ! xstrcasecmp (SDATA (lface1[LFACE_FONTSET_INDEX]),
4252                                     SDATA (lface2[LFACE_FONTSET_INDEX]))))
4253           );
4254 }
4255 
4256 
4257 
4258 /***********************************************************************
4259                             Realized Faces
4260  ***********************************************************************/
4261 
4262 /* Allocate and return a new realized face for Lisp face attribute
4263    vector ATTR.  */
4264 
4265 static struct face *
4266 make_realized_face (attr)
4267      Lisp_Object *attr;
4268 {
4269   struct face *face = (struct face *) xmalloc (sizeof *face);
4270   bzero (face, sizeof *face);
4271   face->ascii_face = face;
4272   bcopy (attr, face->lface, sizeof face->lface);
4273   return face;
4274 }
4275 
4276 
4277 /* Free realized face FACE, including its X resources.  FACE may
4278    be null.  */
4279 
4280 void
4281 free_realized_face (f, face)
4282      struct frame *f;
4283      struct face *face;
4284 {
4285   if (face)
4286     {
4287 #ifdef HAVE_WINDOW_SYSTEM
4288       if (FRAME_WINDOW_P (f))
4289         {
4290           /* Free fontset of FACE if it is ASCII face.  */
4291           if (face->fontset >= 0 && face == face->ascii_face)
4292             free_face_fontset (f, face);
4293           if (face->gc)
4294             {
4295               BLOCK_INPUT;
4296               if (face->font)
4297                 font_done_for_face (f, face);
4298               x_free_gc (f, face->gc);
4299               face->gc = 0;
4300               UNBLOCK_INPUT;
4301             }
4302 
4303           free_face_colors (f, face);
4304           x_destroy_bitmap (f, face->stipple);
4305         }
4306 #endif /* HAVE_WINDOW_SYSTEM */
4307 
4308       xfree (face);
4309     }
4310 }
4311 
4312 
4313 /* Prepare face FACE for subsequent display on frame F.  This
4314    allocated GCs if they haven't been allocated yet or have been freed
4315    by clearing the face cache.  */
4316 
4317 void
4318 prepare_face_for_display (f, face)
4319      struct frame *f;
4320      struct face *face;
4321 {
4322 #ifdef HAVE_WINDOW_SYSTEM
4323   xassert (FRAME_WINDOW_P (f));
4324 
4325   if (face->gc == 0)
4326     {
4327       XGCValues xgcv;
4328       unsigned long mask = GCForeground | GCBackground | GCGraphicsExposures;
4329 
4330       xgcv.foreground = face->foreground;
4331       xgcv.background = face->background;
4332 #ifdef HAVE_X_WINDOWS
4333       xgcv.graphics_exposures = False;
4334 #endif
4335 
4336       BLOCK_INPUT;
4337 #ifdef HAVE_X_WINDOWS
4338       if (face->stipple)
4339         {
4340           xgcv.fill_style = FillOpaqueStippled;
4341           xgcv.stipple = x_bitmap_pixmap (f, face->stipple);
4342           mask |= GCFillStyle | GCStipple;
4343         }
4344 #endif
4345       face->gc = x_create_gc (f, mask, &xgcv);
4346       if (face->font)
4347         font_prepare_for_face (f, face);
4348       UNBLOCK_INPUT;
4349     }
4350 #endif /* HAVE_WINDOW_SYSTEM */
4351 }
4352 
4353 
4354 /* Returns the `distance' between the colors X and Y.  */
4355 
4356 static int
4357 color_distance (x, y)
4358      XColor *x, *y;
4359 {
4360   /* This formula is from a paper title `Colour metric' by Thiadmer Riemersma.
4361      Quoting from that paper:
4362 
4363          This formula has results that are very close to L*u*v* (with the
4364          modified lightness curve) and, more importantly, it is a more even
4365          algorithm: it does not have a range of colours where it suddenly
4366          gives far from optimal results.
4367 
4368      See <http://www.compuphase.com/cmetric.htm> for more info.  */
4369 
4370   long r = (x->red   - y->red)   >> 8;
4371   long g = (x->green - y->green) >> 8;
4372   long b = (x->blue  - y->blue)  >> 8;
4373   long r_mean = (x->red + y->red) >> 9;
4374 
4375   return
4376     (((512 + r_mean) * r * r) >> 8)
4377     + 4 * g * g
4378     + (((767 - r_mean) * b * b) >> 8);
4379 }
4380 
4381 
4382 DEFUN ("color-distance", Fcolor_distance, Scolor_distance, 2, 3, 0,
4383        doc: /* Return an integer distance between COLOR1 and COLOR2 on FRAME.
4384 COLOR1 and COLOR2 may be either strings containing the color name,
4385 or lists of the form (RED GREEN BLUE).
4386 If FRAME is unspecified or nil, the current frame is used.  */)
4387      (color1, color2, frame)
4388      Lisp_Object color1, color2, frame;
4389 {
4390   struct frame *f;
4391   XColor cdef1, cdef2;
4392 
4393   if (NILP (frame))
4394     frame = selected_frame;
4395   CHECK_LIVE_FRAME (frame);
4396   f = XFRAME (frame);
4397 
4398   if (!(CONSP (color1) && parse_rgb_list (color1, &cdef1))
4399       && !(STRINGP (color1) && defined_color (f, SDATA (color1), &cdef1, 0)))
4400     signal_error ("Invalid color", color1);
4401   if (!(CONSP (color2) && parse_rgb_list (color2, &cdef2))
4402       && !(STRINGP (color2) && defined_color (f, SDATA (color2), &cdef2, 0)))
4403     signal_error ("Invalid color", color2);
4404 
4405   return make_number (color_distance (&cdef1, &cdef2));
4406 }
4407 
4408 
4409 /***********************************************************************
4410                               Face Cache
4411  ***********************************************************************/
4412 
4413 /* Return a new face cache for frame F.  */
4414 
4415 static struct face_cache *
4416 make_face_cache (f)
4417      struct frame *f;
4418 {
4419   struct face_cache *c;
4420   int size;
4421 
4422   c = (struct face_cache *) xmalloc (sizeof *c);
4423   bzero (c, sizeof *c);
4424   size = FACE_CACHE_BUCKETS_SIZE * sizeof *c->buckets;
4425   c->buckets = (struct face **) xmalloc (size);
4426   bzero (c->buckets, size);
4427   c->size = 50;
4428   c->faces_by_id = (struct face **) xmalloc (c->size * sizeof *c->faces_by_id);
4429   c->f = f;
4430   c->menu_face_changed_p = menu_face_changed_default;
4431   return c;
4432 }
4433 
4434 
4435 /* Clear out all graphics contexts for all realized faces, except for
4436    the basic faces.  This should be done from time to time just to avoid
4437    keeping too many graphics contexts that are no longer needed.  */
4438 
4439 static void
4440 clear_face_gcs (c)
4441      struct face_cache *c;
4442 {
4443   if (c && FRAME_WINDOW_P (c->f))
4444     {
4445 #ifdef HAVE_WINDOW_SYSTEM
4446       int i;
4447       for (i = BASIC_FACE_ID_SENTINEL; i < c->used; ++i)
4448         {
4449           struct face *face = c->faces_by_id[i];
4450           if (face && face->gc)
4451             {
4452               BLOCK_INPUT;
4453               if (face->font)
4454                 font_done_for_face (c->f, face);
4455               x_free_gc (c->f, face->gc);
4456               face->gc = 0;
4457               UNBLOCK_INPUT;
4458             }
4459         }
4460 #endif /* HAVE_WINDOW_SYSTEM */
4461     }
4462 }
4463 
4464 
4465 /* Free all realized faces in face cache C, including basic faces.
4466    C may be null.  If faces are freed, make sure the frame's current
4467    matrix is marked invalid, so that a display caused by an expose
4468    event doesn't try to use faces we destroyed.  */
4469 
4470 static void
4471 free_realized_faces (c)
4472      struct face_cache *c;
4473 {
4474   if (c && c->used)
4475     {
4476       int i, size;
4477       struct frame *f = c->f;
4478 
4479       /* We must block input here because we can't process X events
4480          safely while only some faces are freed, or when the frame's
4481          current matrix still references freed faces.  */
4482       BLOCK_INPUT;
4483 
4484       for (i = 0; i < c->used; ++i)
4485         {
4486           free_realized_face (f, c->faces_by_id[i]);
4487           c->faces_by_id[i] = NULL;
4488         }
4489 
4490       c->used = 0;
4491       size = FACE_CACHE_BUCKETS_SIZE * sizeof *c->buckets;
4492       bzero (c->buckets, size);
4493 
4494       /* Must do a thorough redisplay the next time.  Mark current
4495          matrices as invalid because they will reference faces freed
4496          above.  This function is also called when a frame is
4497          destroyed.  In this case, the root window of F is nil.  */
4498       if (WINDOWP (f->root_window))
4499         {
4500           clear_current_matrices (f);
4501           ++windows_or_buffers_changed;
4502         }
4503 
4504       UNBLOCK_INPUT;
4505     }
4506 }
4507 
4508 
4509 /* Free all realized faces that are using FONTSET on frame F.  */
4510 
4511 void
4512 free_realized_faces_for_fontset (f, fontset)
4513      struct frame *f;
4514      int fontset;
4515 {
4516   struct face_cache *cache = FRAME_FACE_CACHE (f);
4517   struct face *face;
4518   int i;
4519 
4520   /* We must block input here because we can't process X events safely
4521      while only some faces are freed, or when the frame's current
4522      matrix still references freed faces.  */
4523   BLOCK_INPUT;
4524 
4525   for (i = 0; i < cache->used; i++)
4526     {
4527       face = cache->faces_by_id[i];
4528       if (face
4529           && face->fontset == fontset)
4530         {
4531           uncache_face (cache, face);
4532           free_realized_face (f, face);
4533         }
4534     }
4535 
4536   /* Must do a thorough redisplay the next time.  Mark current
4537      matrices as invalid because they will reference faces freed
4538      above.  This function is also called when a frame is destroyed.
4539      In this case, the root window of F is nil.  */
4540   if (WINDOWP (f->root_window))
4541     {
4542       clear_current_matrices (f);
4543       ++windows_or_buffers_changed;
4544     }
4545 
4546   UNBLOCK_INPUT;
4547 }
4548 
4549 
4550 /* Free all realized faces on FRAME or on all frames if FRAME is nil.
4551    This is done after attributes of a named face have been changed,
4552    because we can't tell which realized faces depend on that face.  */
4553 
4554 void
4555 free_all_realized_faces (frame)
4556      Lisp_Object frame;
4557 {
4558   if (NILP (frame))
4559     {
4560       Lisp_Object rest;
4561       FOR_EACH_FRAME (rest, frame)
4562         free_realized_faces (FRAME_FACE_CACHE (XFRAME (frame)));
4563     }
4564   else
4565     free_realized_faces (FRAME_FACE_CACHE (XFRAME (frame)));
4566 }
4567 
4568 
4569 /* Free face cache C and faces in it, including their X resources.  */
4570 
4571 static void
4572 free_face_cache (c)
4573      struct face_cache *c;
4574 {
4575   if (c)
4576     {
4577       free_realized_faces (c);
4578       xfree (c->buckets);
4579       xfree (c->faces_by_id);
4580       xfree (c);
4581     }
4582 }
4583 
4584 
4585 /* Cache realized face FACE in face cache C.  HASH is the hash value
4586    of FACE.  If FACE is for ASCII characters (i.e. FACE->ascii_face ==
4587    FACE), insert the new face to the beginning of the collision list
4588    of the face hash table of C.  Otherwise, add the new face to the
4589    end of the collision list.  This way, lookup_face can quickly find
4590    that a requested face is not cached.  */
4591 
4592 static void
4593 cache_face (c, face, hash)
4594      struct face_cache *c;
4595      struct face *face;
4596      unsigned hash;
4597 {
4598   int i = hash % FACE_CACHE_BUCKETS_SIZE;
4599 
4600   face->hash = hash;
4601 
4602   if (face->ascii_face != face)
4603     {
4604       struct face *last = c->buckets[i];
4605       if (last)
4606         {
4607           while (last->next)
4608             last = last->next;
4609           last->next = face;
4610           face->prev = last;
4611           face->next = NULL;
4612         }
4613       else
4614         {
4615           c->buckets[i] = face;
4616           face->prev = face->next = NULL;
4617         }
4618     }
4619   else
4620     {
4621       face->prev = NULL;
4622       face->next = c->buckets[i];
4623       if (face->next)
4624         face->next->prev = face;
4625       c->buckets[i] = face;
4626     }
4627 
4628   /* Find a free slot in C->faces_by_id and use the index of the free
4629      slot as FACE->id.  */
4630   for (i = 0; i < c->used; ++i)
4631     if (c->faces_by_id[i] == NULL)
4632       break;
4633   face->id = i;
4634 
4635   /* Maybe enlarge C->faces_by_id.  */
4636   if (i == c->used)
4637     {
4638       if (c->used == c->size)
4639         {
4640           int new_size, sz;
4641           new_size = min (2 * c->size, MAX_FACE_ID);
4642           if (new_size == c->size)
4643             abort ();  /* Alternatives?  ++kfs */
4644           sz = new_size * sizeof *c->faces_by_id;
4645           c->faces_by_id = (struct face **) xrealloc (c->faces_by_id, sz);
4646           c->size = new_size;
4647         }
4648       c->used++;
4649     }
4650 
4651 #if GLYPH_DEBUG
4652   /* Check that FACE got a unique id.  */
4653   {
4654     int j, n;
4655     struct face *face;
4656 
4657     for (j = n = 0; j < FACE_CACHE_BUCKETS_SIZE; ++j)
4658       for (face = c->buckets[j]; face; face = face->next)
4659         if (face->id == i)
4660           ++n;
4661 
4662     xassert (n == 1);
4663   }
4664 #endif /* GLYPH_DEBUG */
4665 
4666   c->faces_by_id[i] = face;
4667 }
4668 
4669 
4670 /* Remove face FACE from cache C.  */
4671 
4672 static void
4673 uncache_face (c, face)
4674      struct face_cache *c;
4675      struct face *face;
4676 {
4677   int i = face->hash % FACE_CACHE_BUCKETS_SIZE;
4678 
4679   if (face->prev)
4680     face->prev->next = face->next;
4681   else
4682     c->buckets[i] = face->next;
4683 
4684   if (face->next)
4685     face->next->prev = face->prev;
4686 
4687   c->faces_by_id[face->id] = NULL;
4688   if (face->id == c->used)
4689     --c->used;
4690 }
4691 
4692 
4693 /* Look up a realized face with face attributes ATTR in the face cache
4694    of frame F.  The face will be used to display ASCII characters.
4695    Value is the ID of the face found.  If no suitable face is found,
4696    realize a new one.  */
4697 
4698 INLINE int
4699 lookup_face (f, attr)
4700      struct frame *f;
4701      Lisp_Object *attr;
4702 {
4703   struct face_cache *cache = FRAME_FACE_CACHE (f);
4704   unsigned hash;
4705   int i;
4706   struct face *face;
4707 
4708   xassert (cache != NULL);
4709   check_lface_attrs (attr);
4710 
4711   /* Look up ATTR in the face cache.  */
4712   hash = lface_hash (attr);
4713   i = hash % FACE_CACHE_BUCKETS_SIZE;
4714 
4715   for (face = cache->buckets[i]; face; face = face->next)
4716     {
4717       if (face->ascii_face != face)
4718         {
4719           /* There's no more ASCII face.  */
4720           face = NULL;
4721           break;
4722         }
4723       if (face->hash == hash
4724           && lface_equal_p (face->lface, attr))
4725         break;
4726     }
4727 
4728   /* If not found, realize a new face.  */
4729   if (face == NULL)
4730     face = realize_face (cache, attr, -1);
4731 
4732 #if GLYPH_DEBUG
4733   xassert (face == FACE_FROM_ID (f, face->id));
4734 #endif /* GLYPH_DEBUG */
4735 
4736   return face->id;
4737 }
4738 
4739 #ifdef HAVE_WINDOW_SYSTEM
4740 /* Look up a realized face that has the same attributes as BASE_FACE
4741    except for the font in the face cache of frame F.  If FONT-OBJECT
4742    is not nil, it is an already opened font.  If FONT-OBJECT is nil,
4743    the face has no font.  Value is the ID of the face found.  If no
4744    suitable face is found, realize a new one.  */
4745 
4746 int
4747 face_for_font (f, font_object, base_face)
4748      struct frame *f;
4749      Lisp_Object font_object;
4750      struct face *base_face;
4751 {
4752   struct face_cache *cache = FRAME_FACE_CACHE (f);
4753   unsigned hash;
4754   int i;
4755   struct face *face;
4756 
4757   xassert (cache != NULL);
4758   base_face = base_face->ascii_face;
4759   hash = lface_hash (base_face->lface);
4760   i = hash % FACE_CACHE_BUCKETS_SIZE;
4761 
4762   for (face = cache->buckets[i]; face; face = face->next)
4763     {
4764       if (face->ascii_face == face)
4765         continue;
4766       if (face->ascii_face == base_face
4767           && face->font == (NILP (font_object) ? NULL
4768                             : XFONT_OBJECT (font_object))
4769           && lface_equal_p (face->lface, base_face->lface))
4770         return face->id;
4771     }
4772 
4773   /* If not found, realize a new face.  */
4774   face = realize_non_ascii_face (f, font_object, base_face);
4775   return face->id;
4776 }
4777 #endif  /* HAVE_WINDOW_SYSTEM */
4778 
4779 /* Return the face id of the realized face for named face SYMBOL on
4780    frame F suitable for displaying ASCII characters.  Value is -1 if
4781    the face couldn't be determined, which might happen if the default
4782    face isn't realized and cannot be realized.  */
4783 
4784 int
4785 lookup_named_face (f, symbol, signal_p)
4786      struct frame *f;
4787      Lisp_Object symbol;
4788      int signal_p;
4789 {
4790   Lisp_Object attrs[LFACE_VECTOR_SIZE];
4791   Lisp_Object symbol_attrs[LFACE_VECTOR_SIZE];
4792   struct face *default_face = FACE_FROM_ID (f, DEFAULT_FACE_ID);
4793 
4794   if (default_face == NULL)
4795     {
4796       if (!realize_basic_faces (f))
4797         return -1;
4798       default_face = FACE_FROM_ID (f, DEFAULT_FACE_ID);
4799       if (default_face == NULL)
4800         abort ();  /* realize_basic_faces must have set it up  */
4801     }
4802 
4803   if (! get_lface_attributes (f, symbol, symbol_attrs, signal_p, 0))
4804     return -1;
4805 
4806   bcopy (default_face->lface, attrs, sizeof attrs);
4807   merge_face_vectors (f, symbol_attrs, attrs, 0);
4808 
4809   return lookup_face (f, attrs);
4810 }
4811 
4812 
4813 /* Return the display face-id of the basic face who's canonical face-id
4814    is FACE_ID.  The return value will usually simply be FACE_ID, unless that
4815    basic face has bee remapped via Vface_remapping_alist.  This function is
4816    conservative: if something goes wrong, it will simply return FACE_ID
4817    rather than signal an error.   */
4818 
4819 int
4820 lookup_basic_face (f, face_id)
4821      struct frame *f;
4822      int face_id;
4823 {
4824   Lisp_Object name, mapping;
4825   int remapped_face_id;
4826 
4827   if (NILP (Vface_remapping_alist))
4828     return face_id;             /* Nothing to do.  */
4829 
4830   switch (face_id)
4831     {
4832     case DEFAULT_FACE_ID:               name = Qdefault;                break;
4833     case MODE_LINE_FACE_ID:             name = Qmode_line;              break;
4834     case MODE_LINE_INACTIVE_FACE_ID:    name = Qmode_line_inactive;     break;
4835     case HEADER_LINE_FACE_ID:           name = Qheader_line;            break;
4836     case TOOL_BAR_FACE_ID:              name = Qtool_bar;               break;
4837     case FRINGE_FACE_ID:                name = Qfringe;                 break;
4838     case SCROLL_BAR_FACE_ID:            name = Qscroll_bar;             break;
4839     case BORDER_FACE_ID:                name = Qborder;                 break;
4840     case CURSOR_FACE_ID:                name = Qcursor;                 break;
4841     case MOUSE_FACE_ID:                 name = Qmouse;                  break;
4842     case MENU_FACE_ID:                  name = Qmenu;                   break;
4843 
4844     default:
4845       abort ();     /* the caller is supposed to pass us a basic face id */
4846     }
4847 
4848   /* Do a quick scan through Vface_remapping_alist, and return immediately
4849      if there is no remapping for face NAME.  This is just an optimization
4850      for the very common no-remapping case.  */
4851   mapping = assq_no_quit (name, Vface_remapping_alist);
4852   if (NILP (mapping))
4853     return face_id;             /* Give up.  */
4854 
4855   /* If there is a remapping entry, lookup the face using NAME, which will
4856      handle the remapping too.  */
4857   remapped_face_id = lookup_named_face (f, name, 0);
4858   if (remapped_face_id < 0)
4859     return face_id;             /* Give up. */
4860 
4861   return remapped_face_id;
4862 }
4863 
4864 
4865 /* Return the ID of the realized ASCII face of Lisp face with ID
4866    LFACE_ID on frame F.  Value is -1 if LFACE_ID isn't valid.  */
4867 
4868 int
4869 ascii_face_of_lisp_face (f, lface_id)
4870      struct frame *f;
4871      int lface_id;
4872 {
4873   int face_id;
4874 
4875   if (lface_id >= 0 && lface_id < lface_id_to_name_size)
4876     {
4877       Lisp_Object face_name = lface_id_to_name[lface_id];
4878       face_id = lookup_named_face (f, face_name, 1);
4879     }
4880   else
4881     face_id = -1;
4882 
4883   return face_id;
4884 }
4885 
4886 
4887 /* Return a face for charset ASCII that is like the face with id
4888    FACE_ID on frame F, but has a font that is STEPS steps smaller.
4889    STEPS < 0 means larger.  Value is the id of the face.  */
4890 
4891 int
4892 smaller_face (f, face_id, steps)
4893      struct frame *f;
4894      int face_id, steps;
4895 {
4896 #ifdef HAVE_WINDOW_SYSTEM
4897   struct face *face;
4898   Lisp_Object attrs[LFACE_VECTOR_SIZE];
4899   int pt, last_pt, last_height;
4900   int delta;
4901   int new_face_id;
4902   struct face *new_face;
4903 
4904   /* If not called for an X frame, just return the original face.  */
4905   if (FRAME_TERMCAP_P (f))
4906     return face_id;
4907 
4908   /* Try in increments of 1/2 pt.  */
4909   delta = steps < 0 ? 5 : -5;
4910   steps = eabs (steps);
4911 
4912   face = FACE_FROM_ID (f, face_id);
4913   bcopy (face->lface, attrs, sizeof attrs);
4914   pt = last_pt = XFASTINT (attrs[LFACE_HEIGHT_INDEX]);
4915   new_face_id = face_id;
4916   last_height = FONT_HEIGHT (face->font);
4917 
4918   while (steps
4919          && pt + delta > 0
4920          /* Give up if we cannot find a font within 10pt.  */
4921          && eabs (last_pt - pt) < 100)
4922     {
4923       /* Look up a face for a slightly smaller/larger font.  */
4924       pt += delta;
4925       attrs[LFACE_HEIGHT_INDEX] = make_number (pt);
4926       new_face_id = lookup_face (f, attrs);
4927       new_face = FACE_FROM_ID (f, new_face_id);
4928 
4929       /* If height changes, count that as one step.  */
4930       if ((delta < 0 && FONT_HEIGHT (new_face->font) < last_height)
4931           || (delta > 0 && FONT_HEIGHT (new_face->font) > last_height))
4932         {
4933           --steps;
4934           last_height = FONT_HEIGHT (new_face->font);
4935           last_pt = pt;
4936         }
4937     }
4938 
4939   return new_face_id;
4940 
4941 #else /* not HAVE_WINDOW_SYSTEM */
4942 
4943   return face_id;
4944 
4945 #endif /* not HAVE_WINDOW_SYSTEM */
4946 }
4947 
4948 
4949 /* Return a face for charset ASCII that is like the face with id
4950    FACE_ID on frame F, but has height HEIGHT.  */
4951 
4952 int
4953 face_with_height (f, face_id, height)
4954      struct frame *f;
4955      int face_id;
4956      int height;
4957 {
4958 #ifdef HAVE_WINDOW_SYSTEM
4959   struct face *face;
4960   Lisp_Object attrs[LFACE_VECTOR_SIZE];
4961 
4962   if (FRAME_TERMCAP_P (f)
4963       || height <= 0)
4964     return face_id;
4965 
4966   face = FACE_FROM_ID (f, face_id);
4967   bcopy (face->lface, attrs, sizeof attrs);
4968   attrs[LFACE_HEIGHT_INDEX] = make_number (height);
4969   font_clear_prop (attrs, FONT_SIZE_INDEX);
4970   face_id = lookup_face (f, attrs);
4971 #endif /* HAVE_WINDOW_SYSTEM */
4972 
4973   return face_id;
4974 }
4975 
4976 
4977 /* Return the face id of the realized face for named face SYMBOL on
4978    frame F suitable for displaying ASCII characters, and use
4979    attributes of the face FACE_ID for attributes that aren't
4980    completely specified by SYMBOL.  This is like lookup_named_face,
4981    except that the default attributes come from FACE_ID, not from the
4982    default face.  FACE_ID is assumed to be already realized.  */
4983 
4984 int
4985 lookup_derived_face (f, symbol, face_id, signal_p)
4986      struct frame *f;
4987      Lisp_Object symbol;
4988      int face_id;
4989      int signal_p;
4990 {
4991   Lisp_Object attrs[LFACE_VECTOR_SIZE];
4992   Lisp_Object symbol_attrs[LFACE_VECTOR_SIZE];
4993   struct face *default_face = FACE_FROM_ID (f, face_id);
4994 
4995   if (!default_face)
4996     abort ();
4997 
4998   if (!get_lface_attributes (f, symbol, symbol_attrs, signal_p, 0))
4999     return -1;
5000 
5001   bcopy (default_face->lface, attrs, sizeof attrs);
5002   merge_face_vectors (f, symbol_attrs, attrs, 0);
5003   return lookup_face (f, attrs);
5004 }
5005 
5006 DEFUN ("face-attributes-as-vector", Fface_attributes_as_vector,
5007        Sface_attributes_as_vector, 1, 1, 0,
5008        doc: /* Return a vector of face attributes corresponding to PLIST.  */)
5009      (plist)
5010      Lisp_Object plist;
5011 {
5012   Lisp_Object lface;
5013   lface = Fmake_vector (make_number (LFACE_VECTOR_SIZE),
5014                         Qunspecified);
5015   merge_face_ref (XFRAME (selected_frame), plist, XVECTOR (lface)->contents,
5016                   1, 0);
5017   return lface;
5018 }
5019 
5020 
5021 
5022 /***********************************************************************
5023                         Face capability testing
5024  ***********************************************************************/
5025 
5026 
5027 /* If the distance (as returned by color_distance) between two colors is
5028    less than this, then they are considered the same, for determining
5029    whether a color is supported or not.  The range of values is 0-65535.  */
5030 
5031 #define TTY_SAME_COLOR_THRESHOLD  10000
5032 
5033 #ifdef HAVE_WINDOW_SYSTEM
5034 
5035 /* Return non-zero if all the face attributes in ATTRS are supported
5036    on the window-system frame F.
5037 
5038    The definition of `supported' is somewhat heuristic, but basically means
5039    that a face containing all the attributes in ATTRS, when merged with the
5040    default face for display, can be represented in a way that's
5041 
5042     \(1) different in appearance than the default face, and
5043     \(2) `close in spirit' to what the attributes specify, if not exact.  */
5044 
5045 static int
5046 x_supports_face_attributes_p (f, attrs, def_face)
5047      struct frame *f;
5048      Lisp_Object *attrs;
5049      struct face *def_face;
5050 {
5051   Lisp_Object *def_attrs = def_face->lface;
5052 
5053   /* Check that other specified attributes are different that the default
5054      face.  */
5055   if ((!UNSPECIFIEDP (attrs[LFACE_UNDERLINE_INDEX])
5056        && face_attr_equal_p (attrs[LFACE_UNDERLINE_INDEX],
5057                              def_attrs[LFACE_UNDERLINE_INDEX]))
5058       || (!UNSPECIFIEDP (attrs[LFACE_INVERSE_INDEX])
5059           && face_attr_equal_p (attrs[LFACE_INVERSE_INDEX],
5060                                 def_attrs[LFACE_INVERSE_INDEX]))
5061       || (!UNSPECIFIEDP (attrs[LFACE_FOREGROUND_INDEX])
5062           && face_attr_equal_p (attrs[LFACE_FOREGROUND_INDEX],
5063                                 def_attrs[LFACE_FOREGROUND_INDEX]))
5064       || (!UNSPECIFIEDP (attrs[LFACE_BACKGROUND_INDEX])
5065           && face_attr_equal_p (attrs[LFACE_BACKGROUND_INDEX],
5066                                 def_attrs[LFACE_BACKGROUND_INDEX]))
5067       || (!UNSPECIFIEDP (attrs[LFACE_STIPPLE_INDEX])
5068           && face_attr_equal_p (attrs[LFACE_STIPPLE_INDEX],
5069                                 def_attrs[LFACE_STIPPLE_INDEX]))
5070       || (!UNSPECIFIEDP (attrs[LFACE_OVERLINE_INDEX])
5071           && face_attr_equal_p (attrs[LFACE_OVERLINE_INDEX],
5072                                 def_attrs[LFACE_OVERLINE_INDEX]))
5073       || (!UNSPECIFIEDP (attrs[LFACE_STRIKE_THROUGH_INDEX])
5074           && face_attr_equal_p (attrs[LFACE_STRIKE_THROUGH_INDEX],
5075                                 def_attrs[LFACE_STRIKE_THROUGH_INDEX]))
5076       || (!UNSPECIFIEDP (attrs[LFACE_BOX_INDEX])
5077           && face_attr_equal_p (attrs[LFACE_BOX_INDEX],
5078                                 def_attrs[LFACE_BOX_INDEX])))
5079     return 0;
5080 
5081   /* Check font-related attributes, as those are the most commonly
5082      "unsupported" on a window-system (because of missing fonts).  */
5083   if (!UNSPECIFIEDP (attrs[LFACE_FAMILY_INDEX])
5084       || !UNSPECIFIEDP (attrs[LFACE_FOUNDRY_INDEX])
5085       || !UNSPECIFIEDP (attrs[LFACE_HEIGHT_INDEX])
5086       || !UNSPECIFIEDP (attrs[LFACE_WEIGHT_INDEX])
5087       || !UNSPECIFIEDP (attrs[LFACE_SLANT_INDEX])
5088       || !UNSPECIFIEDP (attrs[LFACE_SWIDTH_INDEX]))
5089     {
5090       int face_id;
5091       struct face *face;
5092       Lisp_Object merged_attrs[LFACE_VECTOR_SIZE];
5093       int i;
5094 
5095       bcopy (def_attrs, merged_attrs, sizeof merged_attrs);
5096 
5097       merge_face_vectors (f, attrs, merged_attrs, 0);
5098 
5099       face_id = lookup_face (f, merged_attrs);
5100       face = FACE_FROM_ID (f, face_id);
5101 
5102       if (! face)
5103         error ("Cannot make face");
5104 
5105       /* If the font is the same, or no font is found, then not
5106          supported.  */
5107       if (face->font == def_face->font
5108           || ! face->font)
5109         return 0;
5110       for (i = FONT_TYPE_INDEX; i <= FONT_SIZE_INDEX; i++)
5111         if (! EQ (face->font->props[i], def_face->font->props[i]))
5112           {
5113             Lisp_Object s1, s2;
5114 
5115             if (i < FONT_FOUNDRY_INDEX || i > FONT_REGISTRY_INDEX
5116                 || face->font->driver->case_sensitive)
5117               return 1;
5118             s1 = SYMBOL_NAME (face->font->props[i]);
5119             s2 = SYMBOL_NAME (def_face->font->props[i]);
5120             if (! EQ (Fcompare_strings (s1, make_number (0), Qnil,
5121                                         s2, make_number (0), Qnil, Qt), Qt))
5122               return 1;
5123           }
5124       return 0;
5125     }
5126 
5127   /* Everything checks out, this face is supported.  */
5128   return 1;
5129 }
5130 
5131 #endif  /* HAVE_WINDOW_SYSTEM */
5132 
5133 /* Return non-zero if all the face attributes in ATTRS are supported
5134    on the tty frame F.
5135 
5136    The definition of `supported' is somewhat heuristic, but basically means
5137    that a face containing all the attributes in ATTRS, when merged
5138    with the default face for display, can be represented in a way that's
5139 
5140     \(1) different in appearance than the default face, and
5141     \(2) `close in spirit' to what the attributes specify, if not exact.
5142 
5143    Point (2) implies that a `:weight black' attribute will be satisfied
5144    by any terminal that can display bold, and a `:foreground "yellow"' as
5145    long as the terminal can display a yellowish color, but `:slant italic'
5146    will _not_ be satisfied by the tty display code's automatic
5147    substitution of a `dim' face for italic.  */
5148 
5149 static int
5150 tty_supports_face_attributes_p (f, attrs, def_face)
5151      struct frame *f;
5152      Lisp_Object *attrs;
5153      struct face *def_face;
5154 {
5155   int weight;
5156   Lisp_Object val, fg, bg;
5157   XColor fg_tty_color, fg_std_color;
5158   XColor bg_tty_color, bg_std_color;
5159   unsigned test_caps = 0;
5160   Lisp_Object *def_attrs = def_face->lface;
5161 
5162 
5163   /* First check some easy-to-check stuff; ttys support none of the
5164      following attributes, so we can just return false if any are requested
5165      (even if `nominal' values are specified, we should still return false,
5166      as that will be the same value that the default face uses).  We
5167      consider :slant unsupportable on ttys, even though the face code
5168      actually `fakes' them using a dim attribute if possible.  This is
5169      because the faked result is too different from what the face
5170      specifies.  */
5171   if (!UNSPECIFIEDP (attrs[LFACE_FAMILY_INDEX])
5172       || !UNSPECIFIEDP (attrs[LFACE_FOUNDRY_INDEX])
5173       || !UNSPECIFIEDP (attrs[LFACE_STIPPLE_INDEX])
5174       || !UNSPECIFIEDP (attrs[LFACE_HEIGHT_INDEX])
5175       || !UNSPECIFIEDP (attrs[LFACE_SWIDTH_INDEX])
5176       || !UNSPECIFIEDP (attrs[LFACE_OVERLINE_INDEX])
5177       || !UNSPECIFIEDP (attrs[LFACE_STRIKE_THROUGH_INDEX])
5178       || !UNSPECIFIEDP (attrs[LFACE_BOX_INDEX])
5179       || !UNSPECIFIEDP (attrs[LFACE_SLANT_INDEX]))
5180     return 0;
5181 
5182 
5183   /* Test for terminal `capabilities' (non-color character attributes).  */
5184 
5185   /* font weight (bold/dim) */
5186   val = attrs[LFACE_WEIGHT_INDEX];
5187   if (!UNSPECIFIEDP (val)
5188       && (weight = FONT_WEIGHT_NAME_NUMERIC (val), weight >= 0))
5189     {
5190       int def_weight = FONT_WEIGHT_NAME_NUMERIC (def_attrs[LFACE_WEIGHT_INDEX]);
5191 
5192       if (weight > 100)
5193         {
5194           if (def_weight > 100)
5195             return 0;           /* same as default */
5196           test_caps = TTY_CAP_BOLD;
5197         }
5198       else if (weight < 100)
5199         {
5200           if (def_weight < 100)
5201             return 0;           /* same as default */
5202           test_caps = TTY_CAP_DIM;
5203         }
5204       else if (def_weight == 100)
5205         return 0;               /* same as default */
5206     }
5207 
5208   /* underlining */
5209   val = attrs[LFACE_UNDERLINE_INDEX];
5210   if (!UNSPECIFIEDP (val))
5211     {
5212       if (STRINGP (val))
5213         return 0;               /* ttys can't use colored underlines */
5214       else if (face_attr_equal_p (val, def_attrs[LFACE_UNDERLINE_INDEX]))
5215         return 0;               /* same as default */
5216       else
5217         test_caps |= TTY_CAP_UNDERLINE;
5218     }
5219 
5220   /* inverse video */
5221   val = attrs[LFACE_INVERSE_INDEX];
5222   if (!UNSPECIFIEDP (val))
5223     {
5224       if (face_attr_equal_p (val, def_attrs[LFACE_INVERSE_INDEX]))
5225         return 0;               /* same as default */
5226       else
5227         test_caps |= TTY_CAP_INVERSE;
5228     }
5229 
5230 
5231   /* Color testing.  */
5232 
5233   /* Default the color indices in FG_TTY_COLOR and BG_TTY_COLOR, since
5234      we use them when calling `tty_capable_p' below, even if the face
5235      specifies no colors.  */
5236   fg_tty_color.pixel = FACE_TTY_DEFAULT_FG_COLOR;
5237   bg_tty_color.pixel = FACE_TTY_DEFAULT_BG_COLOR;
5238 
5239   /* Check if foreground color is close enough.  */
5240   fg = attrs[LFACE_FOREGROUND_INDEX];
5241   if (STRINGP (fg))
5242     {
5243       Lisp_Object def_fg = def_attrs[LFACE_FOREGROUND_INDEX];
5244 
5245       if (face_attr_equal_p (fg, def_fg))
5246         return 0;               /* same as default */
5247       else if (! tty_lookup_color (f, fg, &fg_tty_color, &fg_std_color))
5248         return 0;               /* not a valid color */
5249       else if (color_distance (&fg_tty_color, &fg_std_color)
5250                > TTY_SAME_COLOR_THRESHOLD)
5251         return 0;               /* displayed color is too different */
5252       else
5253         /* Make sure the color is really different than the default.  */
5254         {
5255           XColor def_fg_color;
5256           if (tty_lookup_color (f, def_fg, &def_fg_color, 0)
5257               && (color_distance (&fg_tty_color, &def_fg_color)
5258                   <= TTY_SAME_COLOR_THRESHOLD))
5259             return 0;
5260         }
5261     }
5262 
5263   /* Check if background color is close enough.  */
5264   bg = attrs[LFACE_BACKGROUND_INDEX];
5265   if (STRINGP (bg))
5266     {
5267       Lisp_Object def_bg = def_attrs[LFACE_BACKGROUND_INDEX];
5268 
5269       if (face_attr_equal_p (bg, def_bg))
5270         return 0;               /* same as default */
5271       else if (! tty_lookup_color (f, bg, &bg_tty_color, &bg_std_color))
5272         return 0;               /* not a valid color */
5273       else if (color_distance (&bg_tty_color, &bg_std_color)
5274                > TTY_SAME_COLOR_THRESHOLD)
5275         return 0;               /* displayed color is too different */
5276       else
5277         /* Make sure the color is really different than the default.  */
5278         {
5279           XColor def_bg_color;
5280           if (tty_lookup_color (f, def_bg, &def_bg_color, 0)
5281               && (color_distance (&bg_tty_color, &def_bg_color)
5282                   <= TTY_SAME_COLOR_THRESHOLD))
5283             return 0;
5284         }
5285     }
5286 
5287   /* If both foreground and background are requested, see if the
5288      distance between them is OK.  We just check to see if the distance
5289      between the tty's foreground and background is close enough to the
5290      distance between the standard foreground and background.  */
5291   if (STRINGP (fg) && STRINGP (bg))
5292     {
5293       int delta_delta
5294         = (color_distance (&fg_std_color, &bg_std_color)
5295            - color_distance (&fg_tty_color, &bg_tty_color));
5296       if (delta_delta > TTY_SAME_COLOR_THRESHOLD
5297           || delta_delta < -TTY_SAME_COLOR_THRESHOLD)
5298         return 0;
5299     }
5300 
5301 
5302   /* See if the capabilities we selected above are supported, with the
5303      given colors.  */
5304   if (test_caps != 0 &&
5305       ! tty_capable_p (FRAME_TTY (f), test_caps, fg_tty_color.pixel, bg_tty_color.pixel))
5306     return 0;
5307 
5308 
5309   /* Hmmm, everything checks out, this terminal must support this face.  */
5310   return 1;
5311 }
5312 
5313 
5314 DEFUN ("display-supports-face-attributes-p",
5315        Fdisplay_supports_face_attributes_p, Sdisplay_supports_face_attributes_p,
5316        1, 2, 0,
5317        doc: /* Return non-nil if all the face attributes in ATTRIBUTES are supported.
5318 The optional argument DISPLAY can be a display name, a frame, or
5319 nil (meaning the selected frame's display).
5320 
5321 The definition of `supported' is somewhat heuristic, but basically means
5322 that a face containing all the attributes in ATTRIBUTES, when merged
5323 with the default face for display, can be represented in a way that's
5324 
5325  \(1) different in appearance than the default face, and
5326  \(2) `close in spirit' to what the attributes specify, if not exact.
5327 
5328 Point (2) implies that a `:weight black' attribute will be satisfied by
5329 any display that can display bold, and a `:foreground \"yellow\"' as long
5330 as it can display a yellowish color, but `:slant italic' will _not_ be
5331 satisfied by the tty display code's automatic substitution of a `dim'
5332 face for italic.  */)
5333   (attributes, display)
5334      Lisp_Object attributes, display;
5335 {
5336   int supports = 0, i;
5337   Lisp_Object frame;
5338   struct frame *f;
5339   struct face *def_face;
5340   Lisp_Object attrs[LFACE_VECTOR_SIZE];
5341 
5342   if (noninteractive || !initialized)
5343     /* We may not be able to access low-level face information in batch
5344        mode, or before being dumped, and this function is not going to
5345        be very useful in those cases anyway, so just give up.  */
5346     return Qnil;
5347 
5348   if (NILP (display))
5349     frame = selected_frame;
5350   else if (FRAMEP (display))
5351     frame = display;
5352   else
5353     {
5354       /* Find any frame on DISPLAY.  */
5355       Lisp_Object fl_tail;
5356 
5357       frame = Qnil;
5358       for (fl_tail = Vframe_list; CONSP (fl_tail); fl_tail = XCDR (fl_tail))
5359         {
5360           frame = XCAR (fl_tail);
5361           if (!NILP (Fequal (Fcdr (Fassq (Qdisplay,
5362                                           XFRAME (frame)->param_alist)),
5363                              display)))
5364             break;
5365         }
5366     }
5367 
5368   CHECK_LIVE_FRAME (frame);
5369   f = XFRAME (frame);
5370 
5371   for (i = 0; i < LFACE_VECTOR_SIZE; i++)
5372     attrs[i] = Qunspecified;
5373   merge_face_ref (f, attributes, attrs, 1, 0);
5374 
5375   def_face = FACE_FROM_ID (f, DEFAULT_FACE_ID);
5376   if (def_face == NULL)
5377     {
5378       if (! realize_basic_faces (f))
5379         error ("Cannot realize default face");
5380       def_face = FACE_FROM_ID (f, DEFAULT_FACE_ID);
5381       if (def_face == NULL)
5382         abort ();  /* realize_basic_faces must have set it up  */
5383     }
5384 
5385   /* Dispatch to the appropriate handler.  */
5386   if (FRAME_TERMCAP_P (f) || FRAME_MSDOS_P (f))
5387     supports = tty_supports_face_attributes_p (f, attrs, def_face);
5388 #ifdef HAVE_WINDOW_SYSTEM
5389   else
5390     supports = x_supports_face_attributes_p (f, attrs, def_face);
5391 #endif
5392 
5393   return supports ? Qt : Qnil;
5394 }
5395 
5396 
5397 /***********************************************************************
5398                             Font selection
5399  ***********************************************************************/
5400 
5401 DEFUN ("internal-set-font-selection-order",
5402        Finternal_set_font_selection_order,
5403        Sinternal_set_font_selection_order, 1, 1, 0,
5404        doc: /* Set font selection order for face font selection to ORDER.
5405 ORDER must be a list of length 4 containing the symbols `:width',
5406 `:height', `:weight', and `:slant'.  Face attributes appearing
5407 first in ORDER are matched first, e.g. if `:height' appears before
5408 `:weight' in ORDER, font selection first tries to find a font with
5409 a suitable height, and then tries to match the font weight.
5410 Value is ORDER.  */)
5411      (order)
5412      Lisp_Object order;
5413 {
5414   Lisp_Object list;
5415   int i;
5416   int indices[DIM (font_sort_order)];
5417 
5418   CHECK_LIST (order);
5419   bzero (indices, sizeof indices);
5420   i = 0;
5421 
5422   for (list = order;
5423        CONSP (list) && i < DIM (indices);
5424        list = XCDR (list), ++i)
5425     {
5426       Lisp_Object attr = XCAR (list);
5427       int xlfd;
5428 
5429       if (EQ (attr, QCwidth))
5430         xlfd = XLFD_SWIDTH;
5431       else if (EQ (attr, QCheight))
5432         xlfd = XLFD_POINT_SIZE;
5433       else if (EQ (attr, QCweight))
5434         xlfd = XLFD_WEIGHT;
5435       else if (EQ (attr, QCslant))
5436         xlfd = XLFD_SLANT;
5437       else
5438         break;
5439 
5440       if (indices[i] != 0)
5441         break;
5442       indices[i] = xlfd;
5443     }
5444 
5445   if (!NILP (list) || i != DIM (indices))
5446     signal_error ("Invalid font sort order", order);
5447   for (i = 0; i < DIM (font_sort_order); ++i)
5448     if (indices[i] == 0)
5449       signal_error ("Invalid font sort order", order);
5450 
5451   if (bcmp (indices, font_sort_order, sizeof indices) != 0)
5452     {
5453       bcopy (indices, font_sort_order, sizeof font_sort_order);
5454       free_all_realized_faces (Qnil);
5455     }
5456 
5457   font_update_sort_order (font_sort_order);
5458 
5459   return Qnil;
5460 }
5461 
5462 
5463 DEFUN ("internal-set-alternative-font-family-alist",
5464        Finternal_set_alternative_font_family_alist,
5465        Sinternal_set_alternative_font_family_alist, 1, 1, 0,
5466        doc: /* Define alternative font families to try in face font selection.
5467 ALIST is an alist of (FAMILY ALTERNATIVE1 ALTERNATIVE2 ...) entries.
5468 Each ALTERNATIVE is tried in order if no fonts of font family FAMILY can
5469 be found.  Value is ALIST.  */)
5470      (alist)
5471      Lisp_Object alist;
5472 {
5473   Lisp_Object entry, tail, tail2;
5474 
5475   CHECK_LIST (alist);
5476   alist = Fcopy_sequence (alist);
5477   for (tail = alist; CONSP (tail); tail = XCDR (tail))
5478     {
5479       entry = XCAR (tail);
5480       CHECK_LIST (entry);
5481       entry = Fcopy_sequence (entry);
5482       XSETCAR (tail, entry);
5483       for (tail2 = entry; CONSP (tail2); tail2 = XCDR (tail2))
5484         XSETCAR (tail2, Fintern (XCAR (tail2), Qnil));
5485     }
5486 
5487   Vface_alternative_font_family_alist = alist;
5488   free_all_realized_faces (Qnil);
5489   return alist;
5490 }
5491 
5492 
5493 DEFUN ("internal-set-alternative-font-registry-alist",
5494        Finternal_set_alternative_font_registry_alist,
5495        Sinternal_set_alternative_font_registry_alist, 1, 1, 0,
5496        doc: /* Define alternative font registries to try in face font selection.
5497 ALIST is an alist of (REGISTRY ALTERNATIVE1 ALTERNATIVE2 ...) entries.
5498 Each ALTERNATIVE is tried in order if no fonts of font registry REGISTRY can
5499 be found.  Value is ALIST.  */)
5500      (alist)
5501      Lisp_Object alist;
5502 {
5503   Lisp_Object entry, tail, tail2;
5504 
5505   CHECK_LIST (alist);
5506   alist = Fcopy_sequence (alist);
5507   for (tail = alist; CONSP (tail); tail = XCDR (tail))
5508     {
5509       entry = XCAR (tail);
5510       CHECK_LIST (entry);
5511       entry = Fcopy_sequence (entry);
5512       XSETCAR (tail, entry);
5513       for (tail2 = entry; CONSP (tail2); tail2 = XCDR (tail2))
5514         XSETCAR (tail2, Fdowncase (XCAR (tail2)));
5515     }
5516   Vface_alternative_font_registry_alist = alist;
5517   free_all_realized_faces (Qnil);
5518   return alist;
5519 }
5520 
5521 
5522 #ifdef HAVE_WINDOW_SYSTEM
5523 
5524 /* Ignore the difference of font point size less than this value.  */
5525 
5526 #define FONT_POINT_SIZE_QUANTUM 5
5527 
5528 /* Return the fontset id of the base fontset name or alias name given
5529    by the fontset attribute of ATTRS.  Value is -1 if the fontset
5530    attribute of ATTRS doesn't name a fontset.  */
5531 
5532 static int
5533 face_fontset (attrs)
5534      Lisp_Object *attrs;
5535 {
5536   Lisp_Object name;
5537 
5538   name = attrs[LFACE_FONTSET_INDEX];
5539   if (!STRINGP (name))
5540     return -1;
5541   return fs_query_fontset (name, 0);
5542 }
5543 
5544 #endif /* HAVE_WINDOW_SYSTEM */
5545 
5546 
5547 
5548 /***********************************************************************
5549                            Face Realization
5550  ***********************************************************************/
5551 
5552 /* Realize basic faces on frame F.  Value is zero if frame parameters
5553    of F don't contain enough information needed to realize the default
5554    face.  */
5555 
5556 static int
5557 realize_basic_faces (f)
5558      struct frame *f;
5559 {
5560   int success_p = 0;
5561   int count = SPECPDL_INDEX ();
5562 
5563   /* Block input here so that we won't be surprised by an X expose
5564      event, for instance, without having the faces set up.  */
5565   BLOCK_INPUT;
5566   specbind (Qscalable_fonts_allowed, Qt);
5567 
5568   if (realize_default_face (f))
5569     {
5570       realize_named_face (f, Qmode_line, MODE_LINE_FACE_ID);
5571       realize_named_face (f, Qmode_line_inactive, MODE_LINE_INACTIVE_FACE_ID);
5572       realize_named_face (f, Qtool_bar, TOOL_BAR_FACE_ID);
5573       realize_named_face (f, Qfringe, FRINGE_FACE_ID);
5574       realize_named_face (f, Qheader_line, HEADER_LINE_FACE_ID);
5575       realize_named_face (f, Qscroll_bar, SCROLL_BAR_FACE_ID);
5576       realize_named_face (f, Qborder, BORDER_FACE_ID);
5577       realize_named_face (f, Qcursor, CURSOR_FACE_ID);
5578       realize_named_face (f, Qmouse, MOUSE_FACE_ID);
5579       realize_named_face (f, Qmenu, MENU_FACE_ID);
5580       realize_named_face (f, Qvertical_border, VERTICAL_BORDER_FACE_ID);
5581 
5582       /* Reflect changes in the `menu' face in menu bars.  */
5583       if (FRAME_FACE_CACHE (f)->menu_face_changed_p)
5584         {
5585           FRAME_FACE_CACHE (f)->menu_face_changed_p = 0;
5586 #ifdef USE_X_TOOLKIT
5587           if (FRAME_WINDOW_P (f))
5588             x_update_menu_appearance (f);
5589 #endif
5590         }
5591 
5592       success_p = 1;
5593     }
5594 
5595   unbind_to (count, Qnil);
5596   UNBLOCK_INPUT;
5597   return success_p;
5598 }
5599 
5600 
5601 /* Realize the default face on frame F.  If the face is not fully
5602    specified, make it fully-specified.  Attributes of the default face
5603    that are not explicitly specified are taken from frame parameters.  */
5604 
5605 static int
5606 realize_default_face (f)
5607      struct frame *f;
5608 {
5609   struct face_cache *c = FRAME_FACE_CACHE (f);
5610   Lisp_Object lface;
5611   Lisp_Object attrs[LFACE_VECTOR_SIZE];
5612   struct face *face;
5613 
5614   /* If the `default' face is not yet known, create it.  */
5615   lface = lface_from_face_name (f, Qdefault, 0);
5616   if (NILP (lface))
5617   {
5618        Lisp_Object frame;
5619        XSETFRAME (frame, f);
5620        lface = Finternal_make_lisp_face (Qdefault, frame);
5621   }
5622 
5623 #ifdef HAVE_WINDOW_SYSTEM
5624   if (FRAME_WINDOW_P (f))
5625     {
5626       Lisp_Object font_object;
5627 
5628       XSETFONT (font_object, FRAME_FONT (f));
5629       set_lface_from_font (f, lface, font_object, f->default_face_done_p);
5630       LFACE_FONTSET (lface) = fontset_name (FRAME_FONTSET (f));
5631       f->default_face_done_p = 1;
5632     }
5633 #endif /* HAVE_WINDOW_SYSTEM */
5634 
5635   if (!FRAME_WINDOW_P (f))
5636     {
5637       LFACE_FAMILY (lface) = build_string ("default");
5638       LFACE_FOUNDRY (lface) = LFACE_FAMILY (lface);
5639       LFACE_SWIDTH (lface) = Qnormal;
5640       LFACE_HEIGHT (lface) = make_number (1);
5641       if (UNSPECIFIEDP (LFACE_WEIGHT (lface)))
5642         LFACE_WEIGHT (lface) = Qnormal;
5643       if (UNSPECIFIEDP (LFACE_SLANT (lface)))
5644         LFACE_SLANT (lface) = Qnormal;
5645       if (UNSPECIFIEDP (LFACE_FONTSET (lface)))
5646         LFACE_FONTSET (lface) = Qnil;
5647     }
5648 
5649   if (UNSPECIFIEDP (LFACE_UNDERLINE (lface)))
5650     LFACE_UNDERLINE (lface) = Qnil;
5651 
5652   if (UNSPECIFIEDP (LFACE_OVERLINE (lface)))
5653     LFACE_OVERLINE (lface) = Qnil;
5654 
5655   if (UNSPECIFIEDP (LFACE_STRIKE_THROUGH (lface)))
5656     LFACE_STRIKE_THROUGH (lface) = Qnil;
5657 
5658   if (UNSPECIFIEDP (LFACE_BOX (lface)))
5659     LFACE_BOX (lface) = Qnil;
5660 
5661   if (UNSPECIFIEDP (LFACE_INVERSE (lface)))
5662     LFACE_INVERSE (lface) = Qnil;
5663 
5664   if (UNSPECIFIEDP (LFACE_FOREGROUND (lface)))
5665     {
5666       /* This function is called so early that colors are not yet
5667          set in the frame parameter list.  */
5668       Lisp_Object color = Fassq (Qforeground_color, f->param_alist);
5669 
5670       if (CONSP (color) && STRINGP (XCDR (color)))
5671         LFACE_FOREGROUND (lface) = XCDR (color);
5672       else if (FRAME_WINDOW_P (f))
5673         return 0;
5674       else if (FRAME_INITIAL_P (f) || FRAME_TERMCAP_P (f) || FRAME_MSDOS_P (f))
5675         LFACE_FOREGROUND (lface) = build_string (unspecified_fg);
5676       else
5677         abort ();
5678     }
5679 
5680   if (UNSPECIFIEDP (LFACE_BACKGROUND (lface)))
5681     {
5682       /* This function is called so early that colors are not yet
5683          set in the frame parameter list.  */
5684       Lisp_Object color = Fassq (Qbackground_color, f->param_alist);
5685       if (CONSP (color) && STRINGP (XCDR (color)))
5686         LFACE_BACKGROUND (lface) = XCDR (color);
5687       else if (FRAME_WINDOW_P (f))
5688         return 0;
5689       else if (FRAME_INITIAL_P (f) || FRAME_TERMCAP_P (f) || FRAME_MSDOS_P (f))
5690         LFACE_BACKGROUND (lface) = build_string (unspecified_bg);
5691       else
5692         abort ();
5693     }
5694 
5695   if (UNSPECIFIEDP (LFACE_STIPPLE (lface)))
5696     LFACE_STIPPLE (lface) = Qnil;
5697 
5698   /* Realize the face; it must be fully-specified now.  */
5699   xassert (lface_fully_specified_p (XVECTOR (lface)->contents));
5700   check_lface (lface);
5701   bcopy (XVECTOR (lface)->contents, attrs, sizeof attrs);
5702   face = realize_face (c, attrs, DEFAULT_FACE_ID);
5703 
5704 #ifdef HAVE_WINDOW_SYSTEM
5705 #ifdef HAVE_X_WINDOWS
5706   if (FRAME_X_P (f) && face->font != FRAME_FONT (f))
5707     {
5708       /* This can happen when making a frame on a display that does
5709          not support the default font.  */
5710       if (!face->font)
5711         return 0;
5712 
5713       /* Otherwise, the font specified for the frame was not
5714          acceptable as a font for the default face (perhaps because
5715          auto-scaled fonts are rejected), so we must adjust the frame
5716          font.  */
5717       x_set_font (f, LFACE_FONT (lface), Qnil);
5718     }
5719 #endif  /* HAVE_X_WINDOWS */
5720 #endif  /* HAVE_WINDOW_SYSTEM */
5721   return 1;
5722 }
5723 
5724 
5725 /* Realize basic faces other than the default face in face cache C.
5726    SYMBOL is the face name, ID is the face id the realized face must
5727    have.  The default face must have been realized already.  */
5728 
5729 static void
5730 realize_named_face (f, symbol, id)
5731      struct frame *f;
5732      Lisp_Object symbol;
5733      int id;
5734 {
5735   struct face_cache *c = FRAME_FACE_CACHE (f);
5736   Lisp_Object lface = lface_from_face_name (f, symbol, 0);
5737   Lisp_Object attrs[LFACE_VECTOR_SIZE];
5738   Lisp_Object symbol_attrs[LFACE_VECTOR_SIZE];
5739   struct face *new_face;
5740 
5741   /* The default face must exist and be fully specified.  */
5742   get_lface_attributes_no_remap (f, Qdefault, attrs, 1);
5743   check_lface_attrs (attrs);
5744   xassert (lface_fully_specified_p (attrs));
5745 
5746   /* If SYMBOL isn't know as a face, create it.  */
5747   if (NILP (lface))
5748     {
5749       Lisp_Object frame;
5750       XSETFRAME (frame, f);
5751       lface = Finternal_make_lisp_face (symbol, frame);
5752     }
5753 
5754   /* Merge SYMBOL's face with the default face.  */
5755   get_lface_attributes_no_remap (f, symbol, symbol_attrs, 1);
5756   merge_face_vectors (f, symbol_attrs, attrs, 0);
5757 
5758   /* Realize the face.  */
5759   new_face = realize_face (c, attrs, id);
5760 }
5761 
5762 
5763 /* Realize the fully-specified face with attributes ATTRS in face
5764    cache CACHE for ASCII characters.  If FORMER_FACE_ID is
5765    non-negative, it is an ID of face to remove before caching the new
5766    face.  Value is a pointer to the newly created realized face.  */
5767 
5768 static struct face *
5769 realize_face (cache, attrs, former_face_id)
5770      struct face_cache *cache;
5771      Lisp_Object *attrs;
5772      int former_face_id;
5773 {
5774   struct face *face;
5775 
5776   /* LFACE must be fully specified.  */
5777   xassert (cache != NULL);
5778   check_lface_attrs (attrs);
5779 
5780   if (former_face_id >= 0 && cache->used > former_face_id)
5781     {
5782       /* Remove the former face.  */
5783       struct face *former_face = cache->faces_by_id[former_face_id];
5784       uncache_face (cache, former_face);
5785       free_realized_face (cache->f, former_face);
5786     }
5787 
5788   if (FRAME_WINDOW_P (cache->f))
5789     face = realize_x_face (cache, attrs);
5790   else if (FRAME_TERMCAP_P (cache->f) || FRAME_MSDOS_P (cache->f))
5791     face = realize_tty_face (cache, attrs);
5792   else if (FRAME_INITIAL_P (cache->f))
5793     {
5794       /* Create a dummy face. */
5795       face = make_realized_face (attrs);
5796     }
5797   else
5798     abort ();
5799 
5800   /* Insert the new face.  */
5801   cache_face (cache, face, lface_hash (attrs));
5802   return face;
5803 }
5804 
5805 
5806 #ifdef HAVE_WINDOW_SYSTEM
5807 /* Realize the fully-specified face that uses FONT-OBJECT and has the
5808    same attributes as BASE_FACE except for the font on frame F.
5809    FONT-OBJECT may be nil, in which case, realized a face of
5810    no-font.  */
5811 
5812 static struct face *
5813 realize_non_ascii_face (f, font_object, base_face)
5814      struct frame *f;
5815      Lisp_Object font_object;
5816      struct face *base_face;
5817 {
5818   struct face_cache *cache = FRAME_FACE_CACHE (f);
5819   struct face *face;
5820 
5821   face = (struct face *) xmalloc (sizeof *face);
5822   *face = *base_face;
5823   face->gc = 0;
5824   face->extra = NULL;
5825   face->overstrike
5826     = (! NILP (font_object)
5827        && FONT_WEIGHT_NAME_NUMERIC (face->lface[LFACE_WEIGHT_INDEX]) > 100
5828        && FONT_WEIGHT_NUMERIC (font_object) <= 100);
5829 
5830   /* Don't try to free the colors copied bitwise from BASE_FACE.  */
5831   face->colors_copied_bitwise_p = 1;
5832   face->font = NILP (font_object) ? NULL : XFONT_OBJECT (font_object);
5833   face->gc = 0;
5834 
5835   cache_face (cache, face, face->hash);
5836 
5837   return face;
5838 }
5839 #endif  /* HAVE_WINDOW_SYSTEM */
5840 
5841 
5842 /* Realize the fully-specified face with attributes ATTRS in face
5843    cache CACHE for ASCII characters.  Do it for X frame CACHE->f.  If
5844    the new face doesn't share font with the default face, a fontname
5845    is allocated from the heap and set in `font_name' of the new face,
5846    but it is not yet loaded here.  Value is a pointer to the newly
5847    created realized face.  */
5848 
5849 static struct face *
5850 realize_x_face (cache, attrs)
5851      struct face_cache *cache;
5852      Lisp_Object *attrs;
5853 {
5854   struct face *face = NULL;
5855 #ifdef HAVE_WINDOW_SYSTEM
5856   struct face *default_face;
5857   struct frame *f;
5858   Lisp_Object stipple, overline, strike_through, box;
5859 
5860   xassert (FRAME_WINDOW_P (cache->f));
5861 
5862   /* Allocate a new realized face.  */
5863   face = make_realized_face (attrs);
5864   face->ascii_face = face;
5865 
5866   f = cache->f;
5867 
5868   /* Determine the font to use.  Most of the time, the font will be
5869      the same as the font of the default face, so try that first.  */
5870   default_face = FACE_FROM_ID (f, DEFAULT_FACE_ID);
5871   if (default_face
5872       && lface_same_font_attributes_p (default_face->lface, attrs))
5873     {
5874       face->font = default_face->font;
5875       face->fontset
5876         = make_fontset_for_ascii_face (f, default_face->fontset, face);
5877     }
5878   else
5879     {
5880       /* If the face attribute ATTRS specifies a fontset, use it as
5881          the base of a new realized fontset.  Otherwise, use the same
5882          base fontset as of the default face.  The base determines
5883          registry and encoding of a font.  It may also determine
5884          foundry and family.  The other fields of font name pattern
5885          are constructed from ATTRS.  */
5886       int fontset = face_fontset (attrs);
5887 
5888       /* If we are realizing the default face, ATTRS should specify a
5889          fontset.  In other words, if FONTSET is -1, we are not
5890          realizing the default face, thus the default face should have
5891          already been realized.  */
5892       if (fontset == -1)
5893         {
5894           if (default_face)
5895             fontset = default_face->fontset;
5896           if (fontset == -1)
5897             abort ();
5898         }
5899       if (! FONT_OBJECT_P (attrs[LFACE_FONT_INDEX]))
5900         attrs[LFACE_FONT_INDEX]
5901           = font_load_for_lface (f, attrs, attrs[LFACE_FONT_INDEX]);
5902       if (FONT_OBJECT_P (attrs[LFACE_FONT_INDEX]))
5903         {
5904           face->font = XFONT_OBJECT (attrs[LFACE_FONT_INDEX]);
5905           face->fontset = make_fontset_for_ascii_face (f, fontset, face);
5906         }
5907       else
5908         {
5909           face->font = NULL;
5910           face->fontset = -1;
5911         }
5912     }
5913 
5914   if (face->font
5915       && FONT_WEIGHT_NAME_NUMERIC (attrs[LFACE_WEIGHT_INDEX]) > 100
5916       && FONT_WEIGHT_NUMERIC (attrs[LFACE_FONT_INDEX]) <= 100)
5917     face->overstrike = 1;
5918 
5919   /* Load colors, and set remaining attributes.  */
5920 
5921   load_face_colors (f, face, attrs);
5922 
5923   /* Set up box.  */
5924   box = attrs[LFACE_BOX_INDEX];
5925   if (STRINGP (box))
5926     {
5927       /* A simple box of line width 1 drawn in color given by
5928          the string.  */
5929       face->box_color = load_color (f, face, attrs[LFACE_BOX_INDEX],
5930                                     LFACE_BOX_INDEX);
5931       face->box = FACE_SIMPLE_BOX;
5932       face->box_line_width = 1;
5933     }
5934   else if (INTEGERP (box))
5935     {
5936       /* Simple box of specified line width in foreground color of the
5937          face.  */
5938       xassert (XINT (box) != 0);
5939       face->box = FACE_SIMPLE_BOX;
5940       face->box_line_width = XINT (box);
5941       face->box_color = face->foreground;
5942       face->box_color_defaulted_p = 1;
5943     }
5944   else if (CONSP (box))
5945     {
5946       /* `(:width WIDTH :color COLOR :shadow SHADOW)'.  SHADOW
5947          being one of `raised' or `sunken'.  */
5948       face->box = FACE_SIMPLE_BOX;
5949       face->box_color = face->foreground;
5950       face->box_color_defaulted_p = 1;
5951       face->box_line_width = 1;
5952 
5953       while (CONSP (box))
5954         {
5955           Lisp_Object keyword, value;
5956 
5957           keyword = XCAR (box);
5958           box = XCDR (box);
5959 
5960           if (!CONSP (box))
5961             break;
5962           value = XCAR (box);
5963           box = XCDR (box);
5964 
5965           if (EQ (keyword, QCline_width))
5966             {
5967               if (INTEGERP (value) && XINT (value) != 0)
5968                 face->box_line_width = XINT (value);
5969             }
5970           else if (EQ (keyword, QCcolor))
5971             {
5972               if (STRINGP (value))
5973                 {
5974                   face->box_color = load_color (f, face, value,
5975                                                 LFACE_BOX_INDEX);
5976                   face->use_box_color_for_shadows_p = 1;
5977                 }
5978             }
5979           else if (EQ (keyword, QCstyle))
5980             {
5981               if (EQ (value, Qreleased_button))
5982                 face->box = FACE_RAISED_BOX;
5983               else if (EQ (value, Qpressed_button))
5984                 face->box = FACE_SUNKEN_BOX;
5985             }
5986         }
5987     }
5988 
5989   /* Text underline, overline, strike-through.  */
5990 
5991   if (EQ (attrs[LFACE_UNDERLINE_INDEX], Qt))
5992     {
5993       /* Use default color (same as foreground color).  */
5994       face->underline_p = 1;
5995       face->underline_defaulted_p = 1;
5996       face->underline_color = 0;
5997     }
5998   else if (STRINGP (attrs[LFACE_UNDERLINE_INDEX]))
5999     {
6000       /* Use specified color.  */
6001       face->underline_p = 1;
6002       face->underline_defaulted_p = 0;
6003       face->underline_color
6004         = load_color (f, face, attrs[LFACE_UNDERLINE_INDEX],
6005                       LFACE_UNDERLINE_INDEX);
6006     }
6007   else if (NILP (attrs[LFACE_UNDERLINE_INDEX]))
6008     {
6009       face->underline_p = 0;
6010       face->underline_defaulted_p = 0;
6011       face->underline_color = 0;
6012     }
6013 
6014   overline = attrs[LFACE_OVERLINE_INDEX];
6015   if (STRINGP (overline))
6016     {
6017       face->overline_color
6018         = load_color (f, face, attrs[LFACE_OVERLINE_INDEX],
6019                       LFACE_OVERLINE_INDEX);
6020       face->overline_p = 1;
6021     }
6022   else if (EQ (overline, Qt))
6023     {
6024       face->overline_color = face->foreground;
6025       face->overline_color_defaulted_p = 1;
6026       face->overline_p = 1;
6027     }
6028 
6029   strike_through = attrs[LFACE_STRIKE_THROUGH_INDEX];
6030   if (STRINGP (strike_through))
6031     {
6032       face->strike_through_color
6033         = load_color (f, face, attrs[LFACE_STRIKE_THROUGH_INDEX],
6034                       LFACE_STRIKE_THROUGH_INDEX);
6035       face->strike_through_p = 1;
6036     }
6037   else if (EQ (strike_through, Qt))
6038     {
6039       face->strike_through_color = face->foreground;
6040       face->strike_through_color_defaulted_p = 1;
6041       face->strike_through_p = 1;
6042     }
6043 
6044   stipple = attrs[LFACE_STIPPLE_INDEX];
6045   if (!NILP (stipple))
6046     face->stipple = load_pixmap (f, stipple, &face->pixmap_w, &face->pixmap_h);
6047 #endif /* HAVE_WINDOW_SYSTEM */
6048 
6049   return face;
6050 }
6051 
6052 
6053 /* Map a specified color of face FACE on frame F to a tty color index.
6054    IDX is either LFACE_FOREGROUND_INDEX or LFACE_BACKGROUND_INDEX, and
6055    specifies which color to map.  Set *DEFAULTED to 1 if mapping to the
6056    default foreground/background colors.  */
6057 
6058 static void
6059 map_tty_color (f, face, idx, defaulted)
6060      struct frame *f;
6061      struct face *face;
6062      enum lface_attribute_index idx;
6063      int *defaulted;
6064 {
6065   Lisp_Object frame, color, def;
6066   int foreground_p = idx == LFACE_FOREGROUND_INDEX;
6067   unsigned long default_pixel, default_other_pixel, pixel;
6068 
6069   xassert (idx == LFACE_FOREGROUND_INDEX || idx == LFACE_BACKGROUND_INDEX);
6070 
6071   if (foreground_p)
6072     {
6073       pixel = default_pixel = FACE_TTY_DEFAULT_FG_COLOR;
6074       default_other_pixel = FACE_TTY_DEFAULT_BG_COLOR;
6075     }
6076   else
6077     {
6078       pixel = default_pixel = FACE_TTY_DEFAULT_BG_COLOR;
6079       default_other_pixel = FACE_TTY_DEFAULT_FG_COLOR;
6080     }
6081 
6082   XSETFRAME (frame, f);
6083   color = face->lface[idx];
6084 
6085   if (STRINGP (color)
6086       && SCHARS (color)
6087       && CONSP (Vtty_defined_color_alist)
6088       && (def = assq_no_quit (color, call1 (Qtty_color_alist, frame)),
6089           CONSP (def)))
6090     {
6091       /* Associations in tty-defined-color-alist are of the form
6092          (NAME INDEX R G B).  We need the INDEX part.  */
6093       pixel = XINT (XCAR (XCDR (def)));
6094     }
6095 
6096   if (pixel == default_pixel && STRINGP (color))
6097     {
6098       pixel = load_color (f, face, color, idx);
6099 
6100 #ifdef MSDOS
6101       /* If the foreground of the default face is the default color,
6102          use the foreground color defined by the frame.  */
6103       if (FRAME_MSDOS_P (f))
6104         {
6105           if (pixel == default_pixel
6106               || pixel == FACE_TTY_DEFAULT_COLOR)
6107             {
6108               if (foreground_p)
6109                 pixel = FRAME_FOREGROUND_PIXEL (f);
6110               else
6111                 pixel = FRAME_BACKGROUND_PIXEL (f);
6112               face->lface[idx] = tty_color_name (f, pixel);
6113               *defaulted = 1;
6114             }
6115           else if (pixel == default_other_pixel)
6116             {
6117               if (foreground_p)
6118                 pixel = FRAME_BACKGROUND_PIXEL (f);
6119               else
6120                 pixel = FRAME_FOREGROUND_PIXEL (f);
6121               face->lface[idx] = tty_color_name (f, pixel);
6122               *defaulted = 1;
6123             }
6124         }
6125 #endif /* MSDOS */
6126     }
6127 
6128   if (foreground_p)
6129     face->foreground = pixel;
6130   else
6131     face->background = pixel;
6132 }
6133 
6134 
6135 /* Realize the fully-specified face with attributes ATTRS in face
6136    cache CACHE for ASCII characters.  Do it for TTY frame CACHE->f.
6137    Value is a pointer to the newly created realized face.  */
6138 
6139 static struct face *
6140 realize_tty_face (cache, attrs)
6141      struct face_cache *cache;
6142      Lisp_Object *attrs;
6143 {
6144   struct face *face;
6145   int weight, slant;
6146   int face_colors_defaulted = 0;
6147   struct frame *f = cache->f;
6148 
6149   /* Frame must be a termcap frame.  */
6150   xassert (FRAME_TERMCAP_P (cache->f) || FRAME_MSDOS_P (cache->f));
6151 
6152   /* Allocate a new realized face.  */
6153   face = make_realized_face (attrs);
6154 #if 0
6155   face->font_name = FRAME_MSDOS_P (cache->f) ? "ms-dos" : "tty";
6156 #endif
6157 
6158   /* Map face attributes to TTY appearances.  We map slant to
6159      dimmed text because we want italic text to appear differently
6160      and because dimmed text is probably used infrequently.  */
6161   weight = FONT_WEIGHT_NAME_NUMERIC (attrs[LFACE_WEIGHT_INDEX]);
6162   slant = FONT_SLANT_NAME_NUMERIC (attrs[LFACE_SLANT_INDEX]);
6163   if (weight > 100)
6164     face->tty_bold_p = 1;
6165   if (weight < 100 || slant != 100)
6166     face->tty_dim_p = 1;
6167   if (!NILP (attrs[LFACE_UNDERLINE_INDEX]))
6168     face->tty_underline_p = 1;
6169   if (!NILP (attrs[LFACE_INVERSE_INDEX]))
6170     face->tty_reverse_p = 1;
6171 
6172   /* Map color names to color indices.  */
6173   map_tty_color (f, face, LFACE_FOREGROUND_INDEX, &face_colors_defaulted);
6174   map_tty_color (f, face, LFACE_BACKGROUND_INDEX, &face_colors_defaulted);
6175 
6176   /* Swap colors if face is inverse-video.  If the colors are taken
6177      from the frame colors, they are already inverted, since the
6178      frame-creation function calls x-handle-reverse-video.  */
6179   if (face->tty_reverse_p && !face_colors_defaulted)
6180     {
6181       unsigned long tem = face->foreground;
6182       face->foreground = face->background;
6183       face->background = tem;
6184     }
6185 
6186   if (tty_suppress_bold_inverse_default_colors_p
6187       && face->tty_bold_p
6188       && face->background == FACE_TTY_DEFAULT_FG_COLOR
6189       && face->foreground == FACE_TTY_DEFAULT_BG_COLOR)
6190     face->tty_bold_p = 0;
6191 
6192   return face;
6193 }
6194 
6195 
6196 DEFUN ("tty-suppress-bold-inverse-default-colors",
6197        Ftty_suppress_bold_inverse_default_colors,
6198        Stty_suppress_bold_inverse_default_colors, 1, 1, 0,
6199        doc: /* Suppress/allow boldness of faces with inverse default colors.
6200 SUPPRESS non-nil means suppress it.
6201 This affects bold faces on TTYs whose foreground is the default background
6202 color of the display and whose background is the default foreground color.
6203 For such faces, the bold face attribute is ignored if this variable
6204 is non-nil.  */)
6205      (suppress)
6206      Lisp_Object suppress;
6207 {
6208   tty_suppress_bold_inverse_default_colors_p = !NILP (suppress);
6209   ++face_change_count;
6210   return suppress;
6211 }
6212 
6213 
6214 
6215 /***********************************************************************
6216                            Computing Faces
6217  ***********************************************************************/
6218 
6219 /* Return the ID of the face to use to display character CH with face
6220    property PROP on frame F in current_buffer.  */
6221 
6222 int
6223 compute_char_face (f, ch, prop)
6224      struct frame *f;
6225      int ch;
6226      Lisp_Object prop;
6227 {
6228   int face_id;
6229 
6230   if (NILP (current_buffer->enable_multibyte_characters))
6231     ch = 0;
6232 
6233   if (NILP (prop))
6234     {
6235       struct face *face = FACE_FROM_ID (f, DEFAULT_FACE_ID);
6236       face_id = FACE_FOR_CHAR (f, face, ch, -1, Qnil);
6237     }
6238   else
6239     {
6240       Lisp_Object attrs[LFACE_VECTOR_SIZE];
6241       struct face *default_face = FACE_FROM_ID (f, DEFAULT_FACE_ID);
6242       bcopy (default_face->lface, attrs, sizeof attrs);
6243       merge_face_ref (f, prop, attrs, 1, 0);
6244       face_id = lookup_face (f, attrs);
6245     }
6246 
6247   return face_id;
6248 }
6249 
6250 /* Return the face ID associated with buffer position POS for
6251    displaying ASCII characters.  Return in *ENDPTR the position at
6252    which a different face is needed, as far as text properties and
6253    overlays are concerned.  W is a window displaying current_buffer.
6254 
6255    REGION_BEG, REGION_END delimit the region, so it can be
6256    highlighted.
6257 
6258    LIMIT is a position not to scan beyond.  That is to limit the time
6259    this function can take.
6260 
6261    If MOUSE is non-zero, use the character's mouse-face, not its face.
6262 
6263    BASE_FACE_ID, if non-negative, specifies a base face id to use
6264    instead of DEFAULT_FACE_ID.
6265 
6266    The face returned is suitable for displaying ASCII characters.  */
6267 
6268 int
6269 face_at_buffer_position (w, pos, region_beg, region_end,
6270                          endptr, limit, mouse, base_face_id)
6271      struct window *w;
6272      EMACS_INT pos;
6273      EMACS_INT region_beg, region_end;
6274      EMACS_INT *endptr;
6275      EMACS_INT limit;
6276      int mouse;
6277      int base_face_id;
6278 {
6279   struct frame *f = XFRAME (w->frame);
6280   Lisp_Object attrs[LFACE_VECTOR_SIZE];
6281   Lisp_Object prop, position;
6282   int i, noverlays;
6283   Lisp_Object *overlay_vec;
6284   Lisp_Object frame;
6285   EMACS_INT endpos;
6286   Lisp_Object propname = mouse ? Qmouse_face : Qface;
6287   Lisp_Object limit1, end;
6288   struct face *default_face;
6289 
6290   /* W must display the current buffer.  We could write this function
6291      to use the frame and buffer of W, but right now it doesn't.  */
6292   /* xassert (XBUFFER (w->buffer) == current_buffer); */
6293 
6294   XSETFRAME (frame, f);
6295   XSETFASTINT (position, pos);
6296 
6297   endpos = ZV;
6298   if (pos < region_beg && region_beg < endpos)
6299     endpos = region_beg;
6300 
6301   /* Get the `face' or `mouse_face' text property at POS, and
6302      determine the next position at which the property changes.  */
6303   prop = Fget_text_property (position, propname, w->buffer);
6304   XSETFASTINT (limit1, (limit < endpos ? limit : endpos));
6305   end = Fnext_single_property_change (position, propname, w->buffer, limit1);
6306   if (INTEGERP (end))
6307     endpos = XINT (end);
6308 
6309   /* Look at properties from overlays.  */
6310   {
6311     EMACS_INT next_overlay;
6312 
6313     GET_OVERLAYS_AT (pos, overlay_vec, noverlays, &next_overlay, 0);
6314     if (next_overlay < endpos)
6315       endpos = next_overlay;
6316   }
6317 
6318   *endptr = endpos;
6319 
6320   default_face = FACE_FROM_ID (f, base_face_id >= 0 ? base_face_id
6321                                : NILP (Vface_remapping_alist) ? DEFAULT_FACE_ID
6322                                : lookup_basic_face (f, DEFAULT_FACE_ID));
6323 
6324   /* Optimize common cases where we can use the default face.  */
6325   if (noverlays == 0
6326       && NILP (prop)
6327       && !(pos >= region_beg && pos < region_end))
6328     return default_face->id;
6329 
6330   /* Begin with attributes from the default face.  */
6331   bcopy (default_face->lface, attrs, sizeof attrs);
6332 
6333   /* Merge in attributes specified via text properties.  */
6334   if (!NILP (prop))
6335     merge_face_ref (f, prop, attrs, 1, 0);
6336 
6337   /* Now merge the overlay data.  */
6338   noverlays = sort_overlays (overlay_vec, noverlays, w);
6339   for (i = 0; i < noverlays; i++)
6340     {
6341       Lisp_Object oend;
6342       int oendpos;
6343 
6344       prop = Foverlay_get (overlay_vec[i], propname);
6345       if (!NILP (prop))
6346         merge_face_ref (f, prop, attrs, 1, 0);
6347 
6348       oend = OVERLAY_END (overlay_vec[i]);
6349       oendpos = OVERLAY_POSITION (oend);
6350       if (oendpos < endpos)
6351         endpos = oendpos;
6352     }
6353 
6354   /* If in the region, merge in the region face.  */
6355   if (pos >= region_beg && pos < region_end)
6356     {
6357       merge_named_face (f, Qregion, attrs, 0);
6358 
6359       if (region_end < endpos)
6360         endpos = region_end;
6361     }
6362 
6363   *endptr = endpos;
6364 
6365   /* Look up a realized face with the given face attributes,
6366      or realize a new one for ASCII characters.  */
6367   return lookup_face (f, attrs);
6368 }
6369 
6370 /* Return the face ID at buffer position POS for displaying ASCII
6371    characters associated with overlay strings for overlay OVERLAY.
6372 
6373    Like face_at_buffer_position except for OVERLAY.  Currently it
6374    simply disregards the `face' properties of all overlays.  */
6375 
6376 int
6377 face_for_overlay_string (w, pos, region_beg, region_end,
6378                          endptr, limit, mouse, overlay)
6379      struct window *w;
6380      EMACS_INT pos;
6381      EMACS_INT region_beg, region_end;
6382      EMACS_INT *endptr;
6383      EMACS_INT limit;
6384      int mouse;
6385      Lisp_Object overlay;
6386 {
6387   struct frame *f = XFRAME (w->frame);
6388   Lisp_Object attrs[LFACE_VECTOR_SIZE];
6389   Lisp_Object prop, position;
6390   Lisp_Object frame;
6391   int endpos;
6392   Lisp_Object propname = mouse ? Qmouse_face : Qface;
6393   Lisp_Object limit1, end;
6394   struct face *default_face;
6395 
6396   /* W must display the current buffer.  We could write this function
6397      to use the frame and buffer of W, but right now it doesn't.  */
6398   /* xassert (XBUFFER (w->buffer) == current_buffer); */
6399 
6400   XSETFRAME (frame, f);
6401   XSETFASTINT (position, pos);
6402 
6403   endpos = ZV;
6404   if (pos < region_beg && region_beg < endpos)
6405     endpos = region_beg;
6406 
6407   /* Get the `face' or `mouse_face' text property at POS, and
6408      determine the next position at which the property changes.  */
6409   prop = Fget_text_property (position, propname, w->buffer);
6410   XSETFASTINT (limit1, (limit < endpos ? limit : endpos));
6411   end = Fnext_single_property_change (position, propname, w->buffer, limit1);
6412   if (INTEGERP (end))
6413     endpos = XINT (end);
6414 
6415   *endptr = endpos;
6416 
6417   default_face = FACE_FROM_ID (f, DEFAULT_FACE_ID);
6418 
6419   /* Optimize common cases where we can use the default face.  */
6420   if (NILP (prop)
6421       && !(pos >= region_beg && pos < region_end))
6422     return DEFAULT_FACE_ID;
6423 
6424   /* Begin with attributes from the default face.  */
6425   bcopy (default_face->lface, attrs, sizeof attrs);
6426 
6427   /* Merge in attributes specified via text properties.  */
6428   if (!NILP (prop))
6429     merge_face_ref (f, prop, attrs, 1, 0);
6430 
6431   /* If in the region, merge in the region face.  */
6432   if (pos >= region_beg && pos < region_end)
6433     {
6434       merge_named_face (f, Qregion, attrs, 0);
6435 
6436       if (region_end < endpos)
6437         endpos = region_end;
6438     }
6439 
6440   *endptr = endpos;
6441 
6442   /* Look up a realized face with the given face attributes,
6443      or realize a new one for ASCII characters.  */
6444   return lookup_face (f, attrs);
6445 }
6446 
6447 
6448 /* Compute the face at character position POS in Lisp string STRING on
6449    window W, for ASCII characters.
6450 
6451    If STRING is an overlay string, it comes from position BUFPOS in
6452    current_buffer, otherwise BUFPOS is zero to indicate that STRING is
6453    not an overlay string.  W must display the current buffer.
6454    REGION_BEG and REGION_END give the start and end positions of the
6455    region; both are -1 if no region is visible.
6456 
6457    BASE_FACE_ID is the id of a face to merge with.  For strings coming
6458    from overlays or the `display' property it is the face at BUFPOS.
6459 
6460    If MOUSE_P is non-zero, use the character's mouse-face, not its face.
6461 
6462    Set *ENDPTR to the next position where to check for faces in
6463    STRING; -1 if the face is constant from POS to the end of the
6464    string.
6465 
6466    Value is the id of the face to use.  The face returned is suitable
6467    for displaying ASCII characters.  */
6468 
6469 int
6470 face_at_string_position (w, string, pos, bufpos, region_beg,
6471                          region_end, endptr, base_face_id, mouse_p)
6472      struct window *w;
6473      Lisp_Object string;
6474      EMACS_INT pos, bufpos;
6475      EMACS_INT region_beg, region_end;
6476      EMACS_INT *endptr;
6477      enum face_id base_face_id;
6478      int mouse_p;
6479 {
6480   Lisp_Object prop, position, end, limit;
6481   struct frame *f = XFRAME (WINDOW_FRAME (w));
6482   Lisp_Object attrs[LFACE_VECTOR_SIZE];
6483   struct face *base_face;
6484   int multibyte_p = STRING_MULTIBYTE (string);
6485   Lisp_Object prop_name = mouse_p ? Qmouse_face : Qface;
6486 
6487   /* Get the value of the face property at the current position within
6488      STRING.  Value is nil if there is no face property.  */
6489   XSETFASTINT (position, pos);
6490   prop = Fget_text_property (position, prop_name, string);
6491 
6492   /* Get the next position at which to check for faces.  Value of end
6493      is nil if face is constant all the way to the end of the string.
6494      Otherwise it is a string position where to check faces next.
6495      Limit is the maximum position up to which to check for property
6496      changes in Fnext_single_property_change.  Strings are usually
6497      short, so set the limit to the end of the string.  */
6498   XSETFASTINT (limit, SCHARS (string));
6499   end = Fnext_single_property_change (position, prop_name, string, limit);
6500   if (INTEGERP (end))
6501     *endptr = XFASTINT (end);
6502   else
6503     *endptr = -1;
6504 
6505   base_face = FACE_FROM_ID (f, base_face_id);
6506   xassert (base_face);
6507 
6508   /* Optimize the default case that there is no face property and we
6509      are not in the region.  */
6510   if (NILP (prop)
6511       && (base_face_id != DEFAULT_FACE_ID
6512           /* BUFPOS <= 0 means STRING is not an overlay string, so
6513              that the region doesn't have to be taken into account.  */
6514           || bufpos <= 0
6515           || bufpos < region_beg
6516           || bufpos >= region_end)
6517       && (multibyte_p
6518           /* We can't realize faces for different charsets differently
6519              if we don't have fonts, so we can stop here if not working
6520              on a window-system frame.  */
6521           || !FRAME_WINDOW_P (f)
6522           || FACE_SUITABLE_FOR_CHAR_P (base_face, 0)))
6523     return base_face->id;
6524 
6525   /* Begin with attributes from the base face.  */
6526   bcopy (base_face->lface, attrs, sizeof attrs);
6527 
6528   /* Merge in attributes specified via text properties.  */
6529   if (!NILP (prop))
6530     merge_face_ref (f, prop, attrs, 1, 0);
6531 
6532   /* If in the region, merge in the region face.  */
6533   if (bufpos
6534       && bufpos >= region_beg
6535       && bufpos < region_end)
6536     merge_named_face (f, Qregion, attrs, 0);
6537 
6538   /* Look up a realized face with the given face attributes,
6539      or realize a new one for ASCII characters.  */
6540   return lookup_face (f, attrs);
6541 }
6542 
6543 
6544 /* Merge a face into a realized face.
6545 
6546    F is frame where faces are (to be) realized.
6547 
6548    FACE_NAME is named face to merge.
6549 
6550    If FACE_NAME is nil, FACE_ID is face_id of realized face to merge.
6551 
6552    If FACE_NAME is t, FACE_ID is lface_id of face to merge.
6553 
6554    BASE_FACE_ID is realized face to merge into.
6555 
6556    Return new face id.
6557 */
6558 
6559 int
6560 merge_faces (f, face_name, face_id, base_face_id)
6561      struct frame *f;
6562      Lisp_Object face_name;
6563      int face_id, base_face_id;
6564 {
6565   Lisp_Object attrs[LFACE_VECTOR_SIZE];
6566   struct face *base_face;
6567 
6568   base_face = FACE_FROM_ID (f, base_face_id);
6569   if (!base_face)
6570     return base_face_id;
6571 
6572   if (EQ (face_name, Qt))
6573     {
6574       if (face_id < 0 || face_id >= lface_id_to_name_size)
6575         return base_face_id;
6576       face_name = lface_id_to_name[face_id];
6577       /* When called during make-frame, lookup_derived_face may fail
6578          if the faces are uninitialized.  Don't signal an error.  */
6579       face_id = lookup_derived_face (f, face_name, base_face_id, 0);
6580       return (face_id >= 0 ? face_id : base_face_id);
6581     }
6582 
6583   /* Begin with attributes from the base face.  */
6584   bcopy (base_face->lface, attrs, sizeof attrs);
6585 
6586   if (!NILP (face_name))
6587     {
6588       if (!merge_named_face (f, face_name, attrs, 0))
6589         return base_face_id;
6590     }
6591   else
6592     {
6593       struct face *face;
6594       if (face_id < 0)
6595         return base_face_id;
6596       face = FACE_FROM_ID (f, face_id);
6597       if (!face)
6598         return base_face_id;
6599       merge_face_vectors (f, face->lface, attrs, 0);
6600     }
6601 
6602   /* Look up a realized face with the given face attributes,
6603      or realize a new one for ASCII characters.  */
6604   return lookup_face (f, attrs);
6605 }
6606 
6607 
6608 
6609 #ifndef HAVE_X_WINDOWS
6610 DEFUN ("x-load-color-file", Fx_load_color_file,
6611        Sx_load_color_file, 1, 1, 0,
6612        doc: /* Create an alist of color entries from an external file.
6613 
6614 The file should define one named RGB color per line like so:
6615   R G B   name
6616 where R,G,B are numbers between 0 and 255 and name is an arbitrary string.  */)
6617     (filename)
6618     Lisp_Object filename;
6619 {
6620   FILE *fp;
6621   Lisp_Object cmap = Qnil;
6622   Lisp_Object abspath;
6623 
6624   CHECK_STRING (filename);
6625   abspath = Fexpand_file_name (filename, Qnil);
6626 
6627   fp = fopen (SDATA (filename), "rt");
6628   if (fp)
6629     {
6630       char buf[512];
6631       int red, green, blue;
6632       int num;
6633 
6634       BLOCK_INPUT;
6635 
6636       while (fgets (buf, sizeof (buf), fp) != NULL) {
6637         if (sscanf (buf, "%u %u %u %n", &red, &green, &blue, &num) == 3)
6638           {
6639             char *name = buf + num;
6640             num = strlen (name) - 1;
6641             if (num >= 0 && name[num] == '\n')
6642               name[num] = 0;
6643             cmap = Fcons (Fcons (build_string (name),
6644 #ifdef WINDOWSNT
6645                                  make_number (RGB (red, green, blue))),
6646 #else
6647                                  make_number ((red << 16) | (green << 8) | blue)),
6648 #endif
6649                           cmap);
6650           }
6651       }
6652       fclose (fp);
6653 
6654       UNBLOCK_INPUT;
6655     }
6656 
6657   return cmap;
6658 }
6659 #endif
6660 
6661 
6662 /***********************************************************************
6663                                 Tests
6664  ***********************************************************************/
6665 
6666 #if GLYPH_DEBUG
6667 
6668 /* Print the contents of the realized face FACE to stderr.  */
6669 
6670 static void
6671 dump_realized_face (face)
6672      struct face *face;
6673 {
6674   fprintf (stderr, "ID: %d\n", face->id);
6675 #ifdef HAVE_X_WINDOWS
6676   fprintf (stderr, "gc: %ld\n", (long) face->gc);
6677 #endif
6678   fprintf (stderr, "foreground: 0x%lx (%s)\n",
6679            face->foreground,
6680            SDATA (face->lface[LFACE_FOREGROUND_INDEX]));
6681   fprintf (stderr, "background: 0x%lx (%s)\n",
6682            face->background,
6683            SDATA (face->lface[LFACE_BACKGROUND_INDEX]));
6684   if (face->font)
6685     fprintf (stderr, "font_name: %s (%s)\n",
6686              SDATA (face->font->props[FONT_NAME_INDEX]),
6687              SDATA (face->lface[LFACE_FAMILY_INDEX]));
6688 #ifdef HAVE_X_WINDOWS
6689   fprintf (stderr, "font = %p\n", face->font);
6690 #endif
6691   fprintf (stderr, "fontset: %d\n", face->fontset);
6692   fprintf (stderr, "underline: %d (%s)\n",
6693            face->underline_p,
6694            SDATA (Fsymbol_name (face->lface[LFACE_UNDERLINE_INDEX])));
6695   fprintf (stderr, "hash: %d\n", face->hash);
6696 }
6697 
6698 
6699 DEFUN ("dump-face", Fdump_face, Sdump_face, 0, 1, 0, doc: /* */)
6700      (n)
6701      Lisp_Object n;
6702 {
6703   if (NILP (n))
6704     {
6705       int i;
6706 
6707       fprintf (stderr, "font selection order: ");
6708       for (i = 0; i < DIM (font_sort_order); ++i)
6709         fprintf (stderr, "%d ", font_sort_order[i]);
6710       fprintf (stderr, "\n");
6711 
6712       fprintf (stderr, "alternative fonts: ");
6713       debug_print (Vface_alternative_font_family_alist);
6714       fprintf (stderr, "\n");
6715 
6716       for (i = 0; i < FRAME_FACE_CACHE (SELECTED_FRAME ())->used; ++i)
6717         Fdump_face (make_number (i));
6718     }
6719   else
6720     {
6721       struct face *face;
6722       CHECK_NUMBER (n);
6723       face = FACE_FROM_ID (SELECTED_FRAME (), XINT (n));
6724       if (face == NULL)
6725         error ("Not a valid face");
6726       dump_realized_face (face);
6727     }
6728 
6729   return Qnil;
6730 }
6731 
6732 
6733 DEFUN ("show-face-resources", Fshow_face_resources, Sshow_face_resources,
6734        0, 0, 0, doc: /* */)
6735      ()
6736 {
6737   fprintf (stderr, "number of colors = %d\n", ncolors_allocated);
6738   fprintf (stderr, "number of pixmaps = %d\n", npixmaps_allocated);
6739   fprintf (stderr, "number of GCs = %d\n", ngcs);
6740   return Qnil;
6741 }
6742 
6743 #endif /* GLYPH_DEBUG != 0 */
6744 
6745 
6746 
6747 /***********************************************************************
6748                             Initialization
6749  ***********************************************************************/
6750 
6751 void
6752 syms_of_xfaces ()
6753 {
6754   Qface = intern_c_string ("face");
6755   staticpro (&Qface);
6756   Qface_no_inherit = intern_c_string ("face-no-inherit");
6757   staticpro (&Qface_no_inherit);
6758   Qbitmap_spec_p = intern_c_string ("bitmap-spec-p");
6759   staticpro (&Qbitmap_spec_p);
6760   Qframe_set_background_mode = intern_c_string ("frame-set-background-mode");
6761   staticpro (&Qframe_set_background_mode);
6762 
6763   /* Lisp face attribute keywords.  */
6764   QCfamily = intern_c_string (":family");
6765   staticpro (&QCfamily);
6766   QCheight = intern_c_string (":height");
6767   staticpro (&QCheight);
6768   QCweight = intern_c_string (":weight");
6769   staticpro (&QCweight);
6770   QCslant = intern_c_string (":slant");
6771   staticpro (&QCslant);
6772   QCunderline = intern_c_string (":underline");
6773   staticpro (&QCunderline);
6774   QCinverse_video = intern_c_string (":inverse-video");
6775   staticpro (&QCinverse_video);
6776   QCreverse_video = intern_c_string (":reverse-video");
6777   staticpro (&QCreverse_video);
6778   QCforeground = intern_c_string (":foreground");
6779   staticpro (&QCforeground);
6780   QCbackground = intern_c_string (":background");
6781   staticpro (&QCbackground);
6782   QCstipple = intern_c_string (":stipple");
6783   staticpro (&QCstipple);
6784   QCwidth = intern_c_string (":width");
6785   staticpro (&QCwidth);
6786   QCfont = intern_c_string (":font");
6787   staticpro (&QCfont);
6788   QCfontset = intern_c_string (":fontset");
6789   staticpro (&QCfontset);
6790   QCbold = intern_c_string (":bold");
6791   staticpro (&QCbold);
6792   QCitalic = intern_c_string (":italic");
6793   staticpro (&QCitalic);
6794   QCoverline = intern_c_string (":overline");
6795   staticpro (&QCoverline);
6796   QCstrike_through = intern_c_string (":strike-through");
6797   staticpro (&QCstrike_through);
6798   QCbox = intern_c_string (":box");
6799   staticpro (&QCbox);
6800   QCinherit = intern_c_string (":inherit");
6801   staticpro (&QCinherit);
6802 
6803   /* Symbols used for Lisp face attribute values.  */
6804   QCcolor = intern_c_string (":color");
6805   staticpro (&QCcolor);
6806   QCline_width = intern_c_string (":line-width");
6807   staticpro (&QCline_width);
6808   QCstyle = intern_c_string (":style");
6809   staticpro (&QCstyle);
6810   Qreleased_button = intern_c_string ("released-button");
6811   staticpro (&Qreleased_button);
6812   Qpressed_button = intern_c_string ("pressed-button");
6813   staticpro (&Qpressed_button);
6814   Qnormal = intern_c_string ("normal");
6815   staticpro (&Qnormal);
6816   Qultra_light = intern_c_string ("ultra-light");
6817   staticpro (&Qultra_light);
6818   Qextra_light = intern_c_string ("extra-light");
6819   staticpro (&Qextra_light);
6820   Qlight = intern_c_string ("light");
6821   staticpro (&Qlight);
6822   Qsemi_light = intern_c_string ("semi-light");
6823   staticpro (&Qsemi_light);
6824   Qsemi_bold = intern_c_string ("semi-bold");
6825   staticpro (&Qsemi_bold);
6826   Qbold = intern_c_string ("bold");
6827   staticpro (&Qbold);
6828   Qextra_bold = intern_c_string ("extra-bold");
6829   staticpro (&Qextra_bold);
6830   Qultra_bold = intern_c_string ("ultra-bold");
6831   staticpro (&Qultra_bold);
6832   Qoblique = intern_c_string ("oblique");
6833   staticpro (&Qoblique);
6834   Qitalic = intern_c_string ("italic");
6835   staticpro (&Qitalic);
6836   Qreverse_oblique = intern_c_string ("reverse-oblique");
6837   staticpro (&Qreverse_oblique);
6838   Qreverse_italic = intern_c_string ("reverse-italic");
6839   staticpro (&Qreverse_italic);
6840   Qultra_condensed = intern_c_string ("ultra-condensed");
6841   staticpro (&Qultra_condensed);
6842   Qextra_condensed = intern_c_string ("extra-condensed");
6843   staticpro (&Qextra_condensed);
6844   Qcondensed = intern_c_string ("condensed");
6845   staticpro (&Qcondensed);
6846   Qsemi_condensed = intern_c_string ("semi-condensed");
6847   staticpro (&Qsemi_condensed);
6848   Qsemi_expanded = intern_c_string ("semi-expanded");
6849   staticpro (&Qsemi_expanded);
6850   Qexpanded = intern_c_string ("expanded");
6851   staticpro (&Qexpanded);
6852   Qextra_expanded = intern_c_string ("extra-expanded");
6853   staticpro (&Qextra_expanded);
6854   Qultra_expanded = intern_c_string ("ultra-expanded");
6855   staticpro (&Qultra_expanded);
6856   Qbackground_color = intern_c_string ("background-color");
6857   staticpro (&Qbackground_color);
6858   Qforeground_color = intern_c_string ("foreground-color");
6859   staticpro (&Qforeground_color);
6860   Qunspecified = intern_c_string ("unspecified");
6861   staticpro (&Qunspecified);
6862   Qignore_defface = intern_c_string (":ignore-defface");
6863   staticpro (&Qignore_defface);
6864 
6865   Qface_alias = intern_c_string ("face-alias");
6866   staticpro (&Qface_alias);
6867   Qdefault = intern_c_string ("default");
6868   staticpro (&Qdefault);
6869   Qtool_bar = intern_c_string ("tool-bar");
6870   staticpro (&Qtool_bar);
6871   Qregion = intern_c_string ("region");
6872   staticpro (&Qregion);
6873   Qfringe = intern_c_string ("fringe");
6874   staticpro (&Qfringe);
6875   Qheader_line = intern_c_string ("header-line");
6876   staticpro (&Qheader_line);
6877   Qscroll_bar = intern_c_string ("scroll-bar");
6878   staticpro (&Qscroll_bar);
6879   Qmenu = intern_c_string ("menu");
6880   staticpro (&Qmenu);
6881   Qcursor = intern_c_string ("cursor");
6882   staticpro (&Qcursor);
6883   Qborder = intern_c_string ("border");
6884   staticpro (&Qborder);
6885   Qmouse = intern_c_string ("mouse");
6886   staticpro (&Qmouse);
6887   Qmode_line_inactive = intern_c_string ("mode-line-inactive");
6888   staticpro (&Qmode_line_inactive);
6889   Qvertical_border = intern_c_string ("vertical-border");
6890   staticpro (&Qvertical_border);
6891   Qtty_color_desc = intern_c_string ("tty-color-desc");
6892   staticpro (&Qtty_color_desc);
6893   Qtty_color_standard_values = intern_c_string ("tty-color-standard-values");
6894   staticpro (&Qtty_color_standard_values);
6895   Qtty_color_by_index = intern_c_string ("tty-color-by-index");
6896   staticpro (&Qtty_color_by_index);
6897   Qtty_color_alist = intern_c_string ("tty-color-alist");
6898   staticpro (&Qtty_color_alist);
6899   Qscalable_fonts_allowed = intern_c_string ("scalable-fonts-allowed");
6900   staticpro (&Qscalable_fonts_allowed);
6901 
6902   Vparam_value_alist = Fcons (Fcons (Qnil, Qnil), Qnil);
6903   staticpro (&Vparam_value_alist);
6904   Vface_alternative_font_family_alist = Qnil;
6905   staticpro (&Vface_alternative_font_family_alist);
6906   Vface_alternative_font_registry_alist = Qnil;
6907   staticpro (&Vface_alternative_font_registry_alist);
6908 
6909   defsubr (&Sinternal_make_lisp_face);
6910   defsubr (&Sinternal_lisp_face_p);
6911   defsubr (&Sinternal_set_lisp_face_attribute);
6912 #ifdef HAVE_WINDOW_SYSTEM
6913   defsubr (&Sinternal_set_lisp_face_attribute_from_resource);
6914 #endif
6915   defsubr (&Scolor_gray_p);
6916   defsubr (&Scolor_supported_p);
6917 #ifndef HAVE_X_WINDOWS
6918   defsubr (&Sx_load_color_file);
6919 #endif
6920   defsubr (&Sface_attribute_relative_p);
6921   defsubr (&Smerge_face_attribute);
6922   defsubr (&Sinternal_get_lisp_face_attribute);
6923   defsubr (&Sinternal_lisp_face_attribute_values);
6924   defsubr (&Sinternal_lisp_face_equal_p);
6925   defsubr (&Sinternal_lisp_face_empty_p);
6926   defsubr (&Sinternal_copy_lisp_face);
6927   defsubr (&Sinternal_merge_in_global_face);
6928   defsubr (&Sface_font);
6929   defsubr (&Sframe_face_alist);
6930   defsubr (&Sdisplay_supports_face_attributes_p);
6931   defsubr (&Scolor_distance);
6932   defsubr (&Sinternal_set_font_selection_order);
6933   defsubr (&Sinternal_set_alternative_font_family_alist);
6934   defsubr (&Sinternal_set_alternative_font_registry_alist);
6935   defsubr (&Sface_attributes_as_vector);
6936 #if GLYPH_DEBUG
6937   defsubr (&Sdump_face);
6938   defsubr (&Sshow_face_resources);
6939 #endif /* GLYPH_DEBUG */
6940   defsubr (&Sclear_face_cache);
6941   defsubr (&Stty_suppress_bold_inverse_default_colors);
6942 
6943 #if defined DEBUG_X_COLORS && defined HAVE_X_WINDOWS
6944   defsubr (&Sdump_colors);
6945 #endif
6946 
6947   DEFVAR_LISP ("font-list-limit", &Vfont_list_limit,
6948                doc: /* *Limit for font matching.
6949 If an integer > 0, font matching functions won't load more than
6950 that number of fonts when searching for a matching font.  */);
6951   Vfont_list_limit = make_number (DEFAULT_FONT_LIST_LIMIT);
6952 
6953   DEFVAR_LISP ("face-new-frame-defaults", &Vface_new_frame_defaults,
6954     doc: /* List of global face definitions (for internal use only.)  */);
6955   Vface_new_frame_defaults = Qnil;
6956 
6957   DEFVAR_LISP ("face-default-stipple", &Vface_default_stipple,
6958     doc: /* *Default stipple pattern used on monochrome displays.
6959 This stipple pattern is used on monochrome displays
6960 instead of shades of gray for a face background color.
6961 See `set-face-stipple' for possible values for this variable.  */);
6962   Vface_default_stipple = make_pure_c_string ("gray3");
6963 
6964   DEFVAR_LISP ("tty-defined-color-alist", &Vtty_defined_color_alist,
6965    doc: /* An alist of defined terminal colors and their RGB values.  */);
6966   Vtty_defined_color_alist = Qnil;
6967 
6968   DEFVAR_LISP ("scalable-fonts-allowed", &Vscalable_fonts_allowed,
6969                doc: /* Allowed scalable fonts.
6970 A value of nil means don't allow any scalable fonts.
6971 A value of t means allow any scalable font.
6972 Otherwise, value must be a list of regular expressions.  A font may be
6973 scaled if its name matches a regular expression in the list.
6974 Note that if value is nil, a scalable font might still be used, if no
6975 other font of the appropriate family and registry is available.  */);
6976   Vscalable_fonts_allowed = Qnil;
6977 
6978   DEFVAR_LISP ("face-ignored-fonts", &Vface_ignored_fonts,
6979                doc: /* List of ignored fonts.
6980 Each element is a regular expression that matches names of fonts to
6981 ignore.  */);
6982   Vface_ignored_fonts = Qnil;
6983 
6984   DEFVAR_LISP ("face-remapping-alist", &Vface_remapping_alist,
6985                doc: /* Alist of face remappings.
6986 Each element is of the form:
6987 
6988    (FACE REPLACEMENT...),
6989 
6990 which causes display of the face FACE to use REPLACEMENT... instead.
6991 REPLACEMENT... is interpreted the same way the value of a `face' text
6992 property is: it may be (1) A face name, (2) A list of face names, (3) A
6993 property-list of face attribute/value pairs, or (4) A list of face names
6994 intermixed with lists containing face attribute/value pairs.
6995 
6996 Multiple entries in REPLACEMENT... are merged together to form the final
6997 result, with faces or attributes earlier in the list taking precedence
6998 over those that are later.
6999 
7000 Face-name remapping cycles are suppressed; recursive references use the
7001 underlying face instead of the remapped face.  So a remapping of the form:
7002 
7003    (FACE EXTRA-FACE... FACE)
7004 
7005 or:
7006 
7007    (FACE (FACE-ATTR VAL ...) FACE)
7008 
7009 will cause EXTRA-FACE... or (FACE-ATTR VAL ...) to be _merged_ with the
7010 existing definition of FACE.  Note that for the default face, this isn't
7011 necessary, as every face inherits from the default face.
7012 
7013 Making this variable buffer-local is a good way to allow buffer-specific
7014 face definitions.  For instance, the mode my-mode could define a face
7015 `my-mode-default', and then in the mode setup function, do:
7016 
7017    (set (make-local-variable 'face-remapping-alist)
7018         '((default my-mode-default)))).  */);
7019   Vface_remapping_alist = Qnil;
7020 
7021   DEFVAR_LISP ("face-font-rescale-alist", &Vface_font_rescale_alist,
7022                doc: /* Alist of fonts vs the rescaling factors.
7023 Each element is a cons (FONT-PATTERN . RESCALE-RATIO), where
7024 FONT-PATTERN is a font-spec or a regular expression matching a font name, and
7025 RESCALE-RATIO is a floating point number to specify how much larger
7026 \(or smaller) font we should use.  For instance, if a face requests
7027 a font of 10 point, we actually use a font of 10 * RESCALE-RATIO point.  */);
7028   Vface_font_rescale_alist = Qnil;
7029 
7030 #ifdef HAVE_WINDOW_SYSTEM
7031   defsubr (&Sbitmap_spec_p);
7032   defsubr (&Sx_list_fonts);
7033   defsubr (&Sinternal_face_x_get_resource);
7034   defsubr (&Sx_family_fonts);
7035 #endif
7036 }
7037 
7038 /* arch-tag: 8a0f7598-5517-408d-9ab3-1da6fcd4c749
7039    (do not change this comment) */