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