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