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