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