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