1 /* xfaces.c -- "Face" primitives.
2 Copyright (C) 1993, 1994, 1998, 1999 Free Software Foundation.
4 This file is part of GNU Emacs.
6 GNU Emacs is free software; you can redistribute it and/or modify
7 it under the terms of the GNU General Public License as published by
8 the Free Software Foundation; either version 2, or (at your option)
11 GNU Emacs is distributed in the hope that it will be useful,
12 but WITHOUT ANY WARRANTY; without even the implied warranty of
13 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
14 GNU General Public License for more details.
16 You should have received a copy of the GNU General Public License
17 along with GNU Emacs; see the file COPYING. If not, write to
18 the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
19 Boston, MA 02111-1307, USA. */
21 /* New face implementation by Gerd Moellmann <gerd@gnu.org>. */
25 When using Emacs with X, the display style of characters can be
26 changed by defining `faces'. Each face can specify the following
29 1. Font family or fontset alias name.
31 2. Relative proportionate width, aka character set width or set
32 width (swidth), e.g. `semi-compressed'.
34 3. Font height in 1/10pt
36 4. Font weight, e.g. `bold'.
38 5. Font slant, e.g. `italic'.
44 8. Whether or not characters should be underlined, and in what color.
46 9. Whether or not characters should be displayed in inverse video.
48 10. A background stipple, a bitmap.
50 11. Whether or not characters should be overlined, and in what color.
52 12. Whether or not characters should be strike-through, and in what
55 13. Whether or not a box should be drawn around characters, the box
56 type, and, for simple boxes, in what color.
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.
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
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'.
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.
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.
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
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.
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.
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
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.
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.
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.
138 Font selection can be influenced by the user.
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,
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
154 Composite characters.
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.
163 Initialization of basic faces.
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. */
170 /* Define SCALABLE_FONTS to a non-zero value to enable scalable
171 font use. Define it to zero to disable scalable font use.
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
177 #define SCALABLE_FONTS 1
180 #include <sys/types.h>
181 #include <sys/stat.h>
186 #ifdef HAVE_X_WINDOWS
191 #include <Xm/XmStrDefs.h>
192 #endif /* USE_MOTIF */
205 #include "dispextern.h"
206 #include "blockinput.h"
208 #include "intervals.h"
210 #ifdef HAVE_X_WINDOWS
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
217 #ifdef XOS_NEEDS_TIME_H
223 #else /* not XOS_NEEDS_TIME_H */
225 #endif /* not XOS_NEEDS_TIME_H */
227 #endif /* HAVE_X_WINDOWS */
231 #include "keyboard.h"
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))
239 /* Non-zero if face attribute ATTR is unspecified. */
241 #define UNSPECIFIEDP(ATTR) EQ ((ATTR), Qunspecified)
243 /* Value is the number of elements of VECTOR. */
245 #define DIM(VECTOR) (sizeof (VECTOR) / sizeof *(VECTOR))
247 /* Make a copy of string S on the stack using alloca. Value is a pointer
250 #define STRDUPA(S) strcpy ((char *) alloca (strlen ((S)) + 1), (S))
252 /* Make a copy of the contents of Lisp string S on the stack using
253 alloca. Value is a pointer to the copy. */
255 #define LSTRDUPA(S) STRDUPA (XSTRING ((S))->data)
257 /* Size of hash table of realized faces in face caches (should be a
260 #define FACE_CACHE_BUCKETS_SIZE 1001
262 /* A definition of XColor for non-X frames. */
263 #ifndef HAVE_X_WINDOWS
266 unsigned short red
, green
, blue
;
272 /* Keyword symbols used for face attribute names. */
274 Lisp_Object QCfamily
, QCheight
, QCweight
, QCslant
, QCunderline
;
275 Lisp_Object QCinverse_video
, QCforeground
, QCbackground
, QCstipple
;
276 Lisp_Object QCwidth
, QCfont
, QCbold
, QCitalic
;
277 Lisp_Object QCreverse_video
;
278 Lisp_Object QCoverline
, QCstrike_through
, QCbox
;
280 /* Symbols used for attribute values. */
282 Lisp_Object Qnormal
, Qbold
, Qultra_light
, Qextra_light
, Qlight
;
283 Lisp_Object Qsemi_light
, Qsemi_bold
, Qextra_bold
, Qultra_bold
;
284 Lisp_Object Qoblique
, Qitalic
, Qreverse_oblique
, Qreverse_italic
;
285 Lisp_Object Qultra_condensed
, Qextra_condensed
, Qcondensed
;
286 Lisp_Object Qsemi_condensed
, Qsemi_expanded
, Qexpanded
, Qextra_expanded
;
287 Lisp_Object Qultra_expanded
;
288 Lisp_Object Qreleased_button
, Qpressed_button
;
289 Lisp_Object QCstyle
, QCcolor
, QCline_width
;
290 Lisp_Object Qunspecified
;
292 char unspecified_fg
[] = "unspecified-fg", unspecified_bg
[] = "unspecified-bg";
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. */
298 Lisp_Object Qx_charset_registry
;
300 /* The name of the function to call when the background of the frame
301 has changed, frame_update_face_colors. */
303 Lisp_Object Qframe_update_face_colors
;
305 /* Names of basic faces. */
307 Lisp_Object Qdefault
, Qtool_bar
, Qregion
, Qfringe
;
308 Lisp_Object Qheader_line
, Qscroll_bar
, Qcursor
, Qborder
, Qmouse
, Qmenu
;
309 extern Lisp_Object Qmode_line
;
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
315 Lisp_Object Qface_alias
;
317 /* Names of frame parameters related to faces. */
319 extern Lisp_Object Qscroll_bar_foreground
, Qscroll_bar_background
;
320 extern Lisp_Object Qborder_color
, Qcursor_color
, Qmouse_color
;
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. */
327 Lisp_Object Vface_default_stipple
;
329 /* Default registry and encoding to use for charsets whose charset
330 symbols don't specify one. */
332 Lisp_Object Vface_default_registry
;
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, ... */
338 Lisp_Object Vface_alternative_font_family_alist
;
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
347 Lisp_Object Vscalable_fonts_allowed
;
350 /* Maximum number of fonts to consider in font_list. If not an
351 integer > 0, DEFAULT_FONT_LIST_LIMIT is used instead. */
353 Lisp_Object Vfont_list_limit
;
354 #define DEFAULT_FONT_LIST_LIMIT 100
356 /* The symbols `foreground-color' and `background-color' which can be
357 used as part of a `face' property. This is for compatibility with
360 Lisp_Object Qforeground_color
, Qbackground_color
;
362 /* The symbols `face' and `mouse-face' used as text properties. */
365 extern Lisp_Object Qmouse_face
;
367 /* Error symbol for wrong_type_argument in load_pixmap. */
369 Lisp_Object Qbitmap_spec_p
;
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. */
376 Lisp_Object Vface_new_frame_defaults
;
378 /* The next ID to assign to Lisp faces. */
380 static int next_lface_id
;
382 /* A vector mapping Lisp face Id's to face names. */
384 static Lisp_Object
*lface_id_to_name
;
385 static int lface_id_to_name_size
;
387 /* tty color-related functions (defined on lisp/term/tty-colors.el). */
388 Lisp_Object Qtty_color_desc
, Qtty_color_by_index
;
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. */
394 static int clear_font_table_count
;
395 #define CLEAR_FONT_TABLE_COUNT 100
396 #define CLEAR_FONT_TABLE_NFONTS 10
398 /* Non-zero means face attributes have been changed since the last
399 redisplay. Used in redisplay_internal. */
401 int face_change_count
;
403 /* The total number of colors currently allocated. */
406 static int ncolors_allocated
;
407 static int npixmaps_allocated
;
413 /* Function prototypes. */
418 static Lisp_Object resolve_face_name
P_ ((Lisp_Object
));
419 static int may_use_scalable_font_p
P_ ((struct font_name
*, char *));
420 static void set_font_frame_param
P_ ((Lisp_Object
, Lisp_Object
));
421 static int better_font_p
P_ ((int *, struct font_name
*, struct font_name
*,
423 static int first_font_matching
P_ ((struct frame
*f
, char *,
424 struct font_name
*));
425 static int x_face_list_fonts
P_ ((struct frame
*, char *,
426 struct font_name
*, int, int, int));
427 static int font_scalable_p
P_ ((struct font_name
*));
428 static Lisp_Object deduce_unibyte_registry
P_ ((struct frame
*, char *));
429 static int get_lface_attributes
P_ ((struct frame
*, Lisp_Object
, Lisp_Object
*, int));
430 static int load_pixmap
P_ ((struct frame
*, Lisp_Object
, unsigned *, unsigned *));
431 static char *xstrdup
P_ ((char *));
432 static unsigned char *xstrlwr
P_ ((unsigned char *));
433 static void signal_error
P_ ((char *, Lisp_Object
));
434 static struct frame
*frame_or_selected_frame
P_ ((Lisp_Object
, int));
435 static void load_face_font_or_fontset
P_ ((struct frame
*, struct face
*, char *, int));
436 static void load_face_colors
P_ ((struct frame
*, struct face
*, Lisp_Object
*));
437 static void free_face_colors
P_ ((struct frame
*, struct face
*));
438 static int face_color_gray_p
P_ ((struct frame
*, char *));
439 static char *build_font_name
P_ ((struct font_name
*));
440 static void free_font_names
P_ ((struct font_name
*, int));
441 static int sorted_font_list
P_ ((struct frame
*, char *,
442 int (*cmpfn
) P_ ((const void *, const void *)),
443 struct font_name
**));
444 static int font_list
P_ ((struct frame
*, char *, char *, char *, struct font_name
**));
445 static int try_font_list
P_ ((struct frame
*, Lisp_Object
*, char *, char *, char *,
446 struct font_name
**));
447 static int cmp_font_names
P_ ((const void *, const void *));
448 static struct face
*realize_face
P_ ((struct face_cache
*,
449 Lisp_Object
*, int));
450 static struct face
*realize_x_face
P_ ((struct face_cache
*,
451 Lisp_Object
*, int));
452 static struct face
*realize_tty_face
P_ ((struct face_cache
*,
453 Lisp_Object
*, int));
454 static int realize_basic_faces
P_ ((struct frame
*));
455 static int realize_default_face
P_ ((struct frame
*));
456 static void realize_named_face
P_ ((struct frame
*, Lisp_Object
, int));
457 static int lface_fully_specified_p
P_ ((Lisp_Object
*));
458 static int lface_equal_p
P_ ((Lisp_Object
*, Lisp_Object
*));
459 static unsigned hash_string_case_insensitive
P_ ((Lisp_Object
));
460 static unsigned lface_hash
P_ ((Lisp_Object
*));
461 static int lface_same_font_attributes_p
P_ ((Lisp_Object
*, Lisp_Object
*));
462 static struct face_cache
*make_face_cache
P_ ((struct frame
*));
463 static void free_realized_face
P_ ((struct frame
*, struct face
*));
464 static void clear_face_gcs
P_ ((struct face_cache
*));
465 static void free_face_cache
P_ ((struct face_cache
*));
466 static int face_numeric_weight
P_ ((Lisp_Object
));
467 static int face_numeric_slant
P_ ((Lisp_Object
));
468 static int face_numeric_swidth
P_ ((Lisp_Object
));
469 static int face_fontset
P_ ((struct frame
*, Lisp_Object
*));
470 static char *choose_face_font
P_ ((struct frame
*, Lisp_Object
*, int,
472 static char *choose_face_fontset_font
P_ ((struct frame
*, Lisp_Object
*,
474 static void merge_face_vectors
P_ ((Lisp_Object
*from
, Lisp_Object
*));
475 static void merge_face_vector_with_property
P_ ((struct frame
*, Lisp_Object
*,
477 static int set_lface_from_font_name
P_ ((struct frame
*, Lisp_Object
, char *,
479 static Lisp_Object lface_from_face_name
P_ ((struct frame
*, Lisp_Object
, int));
480 static struct face
*make_realized_face
P_ ((Lisp_Object
*, int, Lisp_Object
));
481 static void free_realized_faces
P_ ((struct face_cache
*));
482 static char *best_matching_font
P_ ((struct frame
*, Lisp_Object
*,
483 struct font_name
*, int));
484 static void cache_face
P_ ((struct face_cache
*, struct face
*, unsigned));
485 static void uncache_face
P_ ((struct face_cache
*, struct face
*));
486 static int xlfd_numeric_slant
P_ ((struct font_name
*));
487 static int xlfd_numeric_weight
P_ ((struct font_name
*));
488 static int xlfd_numeric_swidth
P_ ((struct font_name
*));
489 static Lisp_Object xlfd_symbolic_slant
P_ ((struct font_name
*));
490 static Lisp_Object xlfd_symbolic_weight
P_ ((struct font_name
*));
491 static Lisp_Object xlfd_symbolic_swidth
P_ ((struct font_name
*));
492 static int xlfd_fixed_p
P_ ((struct font_name
*));
493 static int xlfd_numeric_value
P_ ((struct table_entry
*, int, struct font_name
*,
495 static Lisp_Object xlfd_symbolic_value
P_ ((struct table_entry
*, int,
496 struct font_name
*, int, int));
497 static struct table_entry
*xlfd_lookup_field_contents
P_ ((struct table_entry
*, int,
498 struct font_name
*, int));
500 #ifdef HAVE_WINDOW_SYSTEM
502 static int split_font_name
P_ ((struct frame
*, struct font_name
*, int));
503 static int xlfd_point_size
P_ ((struct frame
*, struct font_name
*));
504 static void sort_fonts
P_ ((struct frame
*, struct font_name
*, int,
505 int (*cmpfn
) P_ ((const void *, const void *))));
506 static GC x_create_gc
P_ ((struct frame
*, unsigned long, XGCValues
*));
507 static void x_free_gc
P_ ((struct frame
*, GC
));
508 static void clear_font_table
P_ ((struct frame
*));
511 extern Lisp_Object w32_list_fonts
P_ ((struct frame
*, Lisp_Object
, int, int));
512 #endif /* WINDOWSNT */
514 #endif /* HAVE_WINDOW_SYSTEM */
517 /***********************************************************************
519 ***********************************************************************/
521 /* Create and return a GC for use on frame F. GC values and mask
522 are given by XGCV and MASK. */
525 x_create_gc (f
, mask
, xgcv
)
532 gc
= XCreateGC (NULL
, FRAME_W32_WINDOW (f
), mask
, xgcv
);
539 /* Free GC which was used on frame F. */
547 xassert (--ngcs
>= 0);
553 /* Like strdup, but uses xmalloc. */
559 int len
= strlen (s
) + 1;
560 char *p
= (char *) xmalloc (len
);
566 /* Like stricmp. Used to compare parts of font names which are in
571 unsigned char *s1
, *s2
;
575 unsigned char c1
= tolower (*s1
);
576 unsigned char c2
= tolower (*s2
);
578 return c1
< c2
? -1 : 1;
583 return *s2
== 0 ? 0 : -1;
588 /* Like strlwr, which might not always be available. */
590 static unsigned char *
594 unsigned char *p
= s
;
603 /* Signal `error' with message S, and additional argument ARG. */
606 signal_error (s
, arg
)
610 Fsignal (Qerror
, Fcons (build_string (s
), Fcons (arg
, Qnil
)));
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. */
620 static INLINE
struct frame
*
621 frame_or_selected_frame (frame
, nparam
)
626 frame
= selected_frame
;
628 CHECK_LIVE_FRAME (frame
, nparam
);
629 return XFRAME (frame
);
633 /***********************************************************************
635 ***********************************************************************/
637 /* Initialize face cache and basic faces for frame F. */
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
);
647 #ifdef HAVE_WINDOW_SYSTEM
648 /* Make the image cache. */
649 if (FRAME_WINDOW_P (f
))
651 if (FRAME_X_IMAGE_CACHE (f
) == NULL
)
652 FRAME_X_IMAGE_CACHE (f
) = make_image_cache ();
653 ++FRAME_X_IMAGE_CACHE (f
)->refcount
;
655 #endif /* HAVE_WINDOW_SYSTEM */
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
))
663 if (!FRAME_WINDOW_P (f
) || FRAME_W32_WINDOW (f
))
665 if (!realize_basic_faces (f
))
670 /* Free face cache of frame F. Called from Fdelete_frame. */
676 struct face_cache
*face_cache
= FRAME_FACE_CACHE (f
);
680 free_face_cache (face_cache
);
681 FRAME_FACE_CACHE (f
) = NULL
;
684 #ifdef HAVE_WINDOW_SYSTEM
685 if (FRAME_WINDOW_P (f
))
687 struct image_cache
*image_cache
= FRAME_X_IMAGE_CACHE (f
);
690 --image_cache
->refcount
;
691 if (image_cache
->refcount
== 0)
692 free_image_cache (f
);
695 #endif /* HAVE_WINDOW_SYSTEM */
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
705 recompute_basic_faces (f
)
708 if (FRAME_FACE_CACHE (f
))
710 clear_face_cache (0);
711 if (!realize_basic_faces (f
))
717 /* Clear the face caches of all frames. CLEAR_FONTS_P non-zero means
718 try to free unused fonts, too. */
721 clear_face_cache (clear_fonts_p
)
724 #ifdef HAVE_WINDOW_SYSTEM
725 Lisp_Object tail
, frame
;
729 || ++clear_font_table_count
== CLEAR_FONT_TABLE_COUNT
)
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;
736 FOR_EACH_FRAME (tail
, frame
)
739 if (FRAME_WINDOW_P (f
)
740 && FRAME_W32_DISPLAY_INFO (f
)->n_fonts
> CLEAR_FONT_TABLE_NFONTS
)
742 free_all_realized_faces (frame
);
743 clear_font_table (f
);
749 /* Clear GCs of realized faces. */
750 FOR_EACH_FRAME (tail
, frame
)
753 if (FRAME_WINDOW_P (f
))
755 clear_face_gcs (FRAME_FACE_CACHE (f
));
756 clear_image_cache (f
, 0);
760 #endif /* HAVE_WINDOW_SYSTEM */
764 DEFUN ("clear-face-cache", Fclear_face_cache
, Sclear_face_cache
, 0, 1, 0,
765 "Clear face caches on all frames.\n\
766 Optional THOROUGHLY non-nil means try to free unused fonts, too.")
768 Lisp_Object thorougly
;
770 clear_face_cache (!NILP (thorougly
));
776 #ifdef HAVE_WINDOW_SYSTEM
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. */
786 struct w32_display_info
*dpyinfo
= FRAME_W32_DISPLAY_INFO (f
);
788 Lisp_Object rest
, frame
;
791 xassert (FRAME_WINDOW_P (f
));
793 used
= (char *) alloca (dpyinfo
->n_fonts
* sizeof *used
);
794 bzero (used
, dpyinfo
->n_fonts
* sizeof *used
);
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
)
801 struct frame
*f
= XFRAME (frame
);
802 struct fontset_data
*fontset_data
= FRAME_FONTSET_DATA (f
);
804 for (i
= 0; i
< fontset_data
->n_fontsets
; ++i
)
806 struct fontset_info
*info
= fontset_data
->fontset_table
[i
];
809 for (j
= 0; j
<= MAX_CHARSET
; ++j
)
811 int idx
= info
->font_indexes
[j
];
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
)
822 struct font_info
*font_info
= dpyinfo
->font_table
+ i
;
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
831 if (font_info
->full_name
!= font_info
->name
)
832 xfree (font_info
->full_name
);
833 xfree (font_info
->name
);
837 w32_unload_font (dpyinfo
, font_info
->font
);
840 /* Mark font table slot free. */
841 font_info
->font
= NULL
;
842 font_info
->name
= font_info
->full_name
= NULL
;
847 #endif /* HAVE_WINDOW_SYSTEM */
851 /***********************************************************************
853 ***********************************************************************/
855 #ifdef HAVE_WINDOW_SYSTEM
857 DEFUN ("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\
859 A 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\
861 HEIGHT is its height, and DATA is a string containing the bits of the\n\
862 bitmap. Bits are stored row by row, each row occupies\n\
863 (WIDTH + 7) / 8 bytes.")
869 if (STRINGP (object
))
870 /* If OBJECT is a string, it's a file name. */
872 else if (CONSP (object
))
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
;
879 height
= width
= data
= Qnil
;
883 width
= XCAR (object
);
884 object
= XCDR (object
);
887 height
= XCAR (object
);
888 object
= XCDR (object
);
890 data
= XCAR (object
);
894 if (NATNUMP (width
) && NATNUMP (height
) && STRINGP (data
))
896 int bytes_per_row
= ((XFASTINT (width
) + BITS_PER_CHAR
- 1)
898 if (STRING_BYTES (XSTRING (data
)) >= bytes_per_row
* height
)
903 return pixmap_p
? Qt
: Qnil
;
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. */
915 load_pixmap (f
, name
, w_ptr
, h_ptr
)
918 unsigned int *w_ptr
, *h_ptr
;
926 tem
= Fbitmap_spec_p (name
);
928 wrong_type_argument (Qbitmap_spec_p
, name
);
933 /* Decode a bitmap spec into a bitmap. */
938 w
= XINT (Fcar (name
));
939 h
= XINT (Fcar (Fcdr (name
)));
940 bits
= Fcar (Fcdr (Fcdr (name
)));
942 bitmap_id
= x_create_bitmap_from_data (f
, XSTRING (bits
)->data
,
947 /* It must be a string -- a file name. */
948 bitmap_id
= x_create_bitmap_from_file (f
, name
);
954 add_to_log ("Invalid or undefined bitmap %s", name
, Qnil
);
965 ++npixmaps_allocated
;
968 *w_ptr
= x_bitmap_width (f
, bitmap_id
);
971 *h_ptr
= x_bitmap_height (f
, bitmap_id
);
977 #endif /* HAVE_WINDOW_SYSTEM */
981 /***********************************************************************
983 ***********************************************************************/
985 #ifdef HAVE_WINDOW_SYSTEM
987 /* Update the line_height of frame F. Return non-zero if line height
991 frame_update_line_height (f
)
994 int fontset
, line_height
, changed_p
;
996 fontset
= FRAME_FONTSET (f
);
998 line_height
= FRAME_FONTSET_DATA (f
)->fontset_table
[fontset
]->height
;
1000 line_height
= FONT_HEIGHT (FRAME_FONT (f
));
1002 changed_p
= line_height
!= FRAME_LINE_HEIGHT (f
);
1003 FRAME_LINE_HEIGHT (f
) = line_height
;
1007 #endif /* HAVE_WINDOW_SYSTEM */
1010 /***********************************************************************
1012 ***********************************************************************/
1014 #ifdef HAVE_WINDOW_SYSTEM
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
1023 load_face_font_or_fontset (f
, face
, font_name
, fontset
)
1029 struct font_info
*font_info
= NULL
;
1031 face
->font_info_id
= -1;
1032 face
->fontset
= fontset
;
1037 font_info
= FS_LOAD_FONT (f
, FRAME_W32_FONT_TABLE (f
), CHARSET_ASCII
,
1040 font_info
= FS_LOAD_FONT (f
, FRAME_W32_FONT_TABLE (f
), face
->charset
,
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
;
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
);
1057 while (i
< 2 && --s
>= font_info
->full_name
)
1061 if (!STRINGP (face
->registry
)
1062 || xstricmp (XSTRING (face
->registry
)->data
, s
+ 1) != 0)
1064 if (STRINGP (Vface_default_registry
)
1065 && !xstricmp (XSTRING (Vface_default_registry
)->data
, s
+ 1))
1066 face
->registry
= Vface_default_registry
;
1068 face
->registry
= build_string (s
+ 1);
1071 else if (fontset
>= 0)
1072 add_to_log ("Unable to load ASCII font of fontset %d",
1073 make_number (fontset
), Qnil
);
1075 add_to_log ("Unable to load font %s",
1076 build_string (font_name
), Qnil
);
1079 #endif /* HAVE_WINDOW_SYSTEM */
1083 /***********************************************************************
1085 ***********************************************************************/
1087 /* A version of defined_color for non-X frames. */
1089 tty_defined_color (f
, color_name
, color_def
, alloc
)
1095 Lisp_Object color_desc
;
1096 unsigned long color_idx
= FACE_TTY_DEFAULT_COLOR
;
1097 unsigned long red
= 0, green
= 0, blue
= 0;
1100 if (*color_name
&& !NILP (Ffboundp (Qtty_color_desc
)))
1104 XSETFRAME (frame
, f
);
1106 color_desc
= call2 (Qtty_color_desc
, build_string (color_name
), frame
);
1107 if (CONSP (color_desc
) && CONSP (XCDR (color_desc
)))
1109 color_idx
= XINT (XCAR (XCDR (color_desc
)));
1110 if (CONSP (XCDR (XCDR (color_desc
))))
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
))))));
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. */
1125 if (color_idx
== FACE_TTY_DEFAULT_COLOR
&& *color_name
)
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
;
1133 if (color_idx
!= FACE_TTY_DEFAULT_COLOR
)
1136 color_def
->pixel
= color_idx
;
1137 color_def
->red
= red
;
1138 color_def
->green
= green
;
1139 color_def
->blue
= blue
;
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.
1148 This does the right thing for any type of frame. */
1150 defined_color (f
, color_name
, color_def
, alloc
)
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
);
1163 else if (FRAME_W32_P (f
))
1164 return w32_defined_color (f
, color_name
, color_def
, alloc
);
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
);
1175 /* Given the index of the tty color, return its name, a Lisp string. */
1178 tty_color_name (f
, idx
)
1184 if (idx
>= 0 && !NILP (Ffboundp (Qtty_color_by_index
)))
1187 Lisp_Object coldesc
;
1189 XSETFRAME (frame
, f
);
1190 coldesc
= call2 (Qtty_color_by_index
, make_number (idx
), frame
);
1192 if (!NILP (coldesc
))
1193 return XCAR (coldesc
);
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
);
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
);
1208 return vga_stdcolor_name (idx
);
1211 return Qunspecified
;
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. */
1218 face_color_gray_p (f
, color_name
)
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));
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
1244 face_color_supported_p (f
, color_name
, background_p
)
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
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
, ¬_used
, 0));
1265 DEFUN ("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\
1267 FRAME specifies the frame and thus the display for interpreting COLOR.\n\
1268 If FRAME is nil or omitted, use the selected frame.")
1270 Lisp_Object color
, frame
;
1274 CHECK_FRAME (frame
, 0);
1275 CHECK_STRING (color
, 0);
1277 return face_color_gray_p (f
, XSTRING (color
)->data
) ? Qt
: Qnil
;
1281 DEFUN ("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\
1284 BACKGROUND-P non-nil means COLOR is used as a background.\n\
1285 If FRAME is nil or omitted, use the selected frame.\n\
1286 COLOR must be a valid color name.")
1287 (color
, frame
, background_p
)
1288 Lisp_Object frame
, color
, background_p
;
1292 CHECK_FRAME (frame
, 0);
1293 CHECK_STRING (color
, 0);
1295 if (face_color_supported_p (f
, XSTRING (color
)->data
, !NILP (background_p
)))
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
1310 load_color (f
, face
, name
, target_index
)
1314 enum lface_attribute_index target_index
;
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
);
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))
1330 add_to_log ("Unable to load color \"%s\"", name
, Qnil
);
1332 switch (target_index
)
1334 case LFACE_FOREGROUND_INDEX
:
1335 face
->foreground_defaulted_p
= 1;
1336 color
.pixel
= FRAME_FOREGROUND_PIXEL (f
);
1339 case LFACE_BACKGROUND_INDEX
:
1340 face
->background_defaulted_p
= 1;
1341 color
.pixel
= FRAME_BACKGROUND_PIXEL (f
);
1344 case LFACE_UNDERLINE_INDEX
:
1345 face
->underline_defaulted_p
= 1;
1346 color
.pixel
= FRAME_FOREGROUND_PIXEL (f
);
1349 case LFACE_OVERLINE_INDEX
:
1350 face
->overline_color_defaulted_p
= 1;
1351 color
.pixel
= FRAME_FOREGROUND_PIXEL (f
);
1354 case LFACE_STRIKE_THROUGH_INDEX
:
1355 face
->strike_through_color_defaulted_p
= 1;
1356 color
.pixel
= FRAME_FOREGROUND_PIXEL (f
);
1359 case LFACE_BOX_INDEX
:
1360 face
->box_color_defaulted_p
= 1;
1361 color
.pixel
= FRAME_FOREGROUND_PIXEL (f
);
1370 ++ncolors_allocated
;
1376 #ifdef HAVE_WINDOW_SYSTEM
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. */
1384 load_face_colors (f
, face
, attrs
)
1391 bg
= attrs
[LFACE_BACKGROUND_INDEX
];
1392 fg
= attrs
[LFACE_FOREGROUND_INDEX
];
1394 /* Swap colors if face is inverse-video. */
1395 if (EQ (attrs
[LFACE_INVERSE_INDEX
], Qt
))
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
1407 if (!face_color_supported_p (f
, XSTRING (bg
)->data
, 0)
1408 && !NILP (Fbitmap_spec_p (Vface_default_stipple
)))
1410 x_destroy_bitmap (f
, face
->stipple
);
1411 face
->stipple
= load_pixmap (f
, Vface_default_stipple
,
1412 &face
->pixmap_w
, &face
->pixmap_h
);
1415 face
->background
= load_color (f
, face
, bg
, LFACE_BACKGROUND_INDEX
);
1416 face
->foreground
= load_color (f
, face
, fg
, LFACE_FOREGROUND_INDEX
);
1420 /* Free color PIXEL on frame F. */
1423 unload_color (f
, pixel
)
1425 unsigned long pixel
;
1427 /* Nothing to do on W32 */
1431 /* Free colors allocated for FACE. */
1434 free_face_colors (f
, face
)
1438 /* Nothing to do on W32 */
1440 #endif /* HAVE_WINDOW_SYSTEM */
1444 /***********************************************************************
1446 ***********************************************************************/
1448 /* An enumerator for each field of an XLFD font name. */
1469 /* An enumerator for each possible slant value of a font. Taken from
1470 the XLFD specification. */
1478 XLFD_SLANT_REVERSE_ITALIC
,
1479 XLFD_SLANT_REVERSE_OBLIQUE
,
1483 /* Relative font weight according to XLFD documentation. */
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, ... */
1499 /* Relative proportionate width. */
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... */
1515 /* Structure used for tables mapping XLFD weight, slant, and width
1516 names to numeric and symbolic values. */
1522 Lisp_Object
*symbol
;
1525 /* Table of XLFD slant names and their numeric and symbolic
1526 representations. This table must be sorted by slant names in
1529 static struct table_entry slant_table
[] =
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
}
1539 /* Table of XLFD weight names. This table must be sorted by weight
1540 names in ascending order. */
1542 static struct table_entry weight_table
[] =
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
}
1561 /* Table of XLFD width names. This table must be sorted by width
1562 names in ascending order. */
1564 static struct table_entry swidth_table
[] =
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
}
1583 /* Structure used to hold the result of splitting font names in XLFD
1584 format into their fields. */
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. */
1593 /* Font name fields. Each vector element points into `name' above.
1594 Fields are NUL-terminated. */
1595 char *fields
[XLFD_LAST
];
1597 /* Numeric values for those fields that interest us. See
1598 split_font_name for which these are. */
1599 int numeric
[XLFD_LAST
];
1602 /* The frame in effect when sorting font names. Set temporarily in
1603 sort_fonts so that it is available in font comparison functions. */
1605 static struct frame
*font_frame
;
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. */
1612 static int font_sort_order
[4];
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
1620 static struct table_entry
*
1621 xlfd_lookup_field_contents (table
, dim
, font
, field_index
)
1622 struct table_entry
*table
;
1624 struct font_name
*font
;
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
;
1637 mid
= (low
+ high
) / 2;
1638 cmp
= strcmp (table
[mid
].name
, s
);
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. */
1659 xlfd_numeric_value (table
, dim
, font
, field_index
, dflt
)
1660 struct table_entry
*table
;
1662 struct font_name
*font
;
1666 struct table_entry
*p
;
1667 p
= xlfd_lookup_field_contents (table
, dim
, font
, field_index
);
1668 return p
? p
->numeric
: dflt
;
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. */
1678 static INLINE Lisp_Object
1679 xlfd_symbolic_value (table
, dim
, font
, field_index
, dflt
)
1680 struct table_entry
*table
;
1682 struct font_name
*font
;
1686 struct table_entry
*p
;
1687 p
= xlfd_lookup_field_contents (table
, dim
, font
, field_index
);
1688 return p
? *p
->symbol
: dflt
;
1692 /* Return a numeric value for the slant of the font given by FONT. */
1695 xlfd_numeric_slant (font
)
1696 struct font_name
*font
;
1698 return xlfd_numeric_value (slant_table
, DIM (slant_table
),
1699 font
, XLFD_SLANT
, XLFD_SLANT_ROMAN
);
1703 /* Return a symbol representing the weight of the font given by FONT. */
1705 static INLINE Lisp_Object
1706 xlfd_symbolic_slant (font
)
1707 struct font_name
*font
;
1709 return xlfd_symbolic_value (slant_table
, DIM (slant_table
),
1710 font
, XLFD_SLANT
, Qnormal
);
1714 /* Return a numeric value for the weight of the font given by FONT. */
1717 xlfd_numeric_weight (font
)
1718 struct font_name
*font
;
1720 return xlfd_numeric_value (weight_table
, DIM (weight_table
),
1721 font
, XLFD_WEIGHT
, XLFD_WEIGHT_MEDIUM
);
1725 /* Return a symbol representing the slant of the font given by FONT. */
1727 static INLINE Lisp_Object
1728 xlfd_symbolic_weight (font
)
1729 struct font_name
*font
;
1731 return xlfd_symbolic_value (weight_table
, DIM (weight_table
),
1732 font
, XLFD_WEIGHT
, Qnormal
);
1736 /* Return a numeric value for the swidth of the font whose XLFD font
1737 name fields are found in FONT. */
1740 xlfd_numeric_swidth (font
)
1741 struct font_name
*font
;
1743 return xlfd_numeric_value (swidth_table
, DIM (swidth_table
),
1744 font
, XLFD_SWIDTH
, XLFD_SWIDTH_MEDIUM
);
1748 /* Return a symbolic value for the swidth of FONT. */
1750 static INLINE Lisp_Object
1751 xlfd_symbolic_swidth (font
)
1752 struct font_name
*font
;
1754 return xlfd_symbolic_value (swidth_table
, DIM (swidth_table
),
1755 font
, XLFD_SWIDTH
, Qnormal
);
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. */
1763 static struct table_entry
*
1764 face_value (table
, dim
, symbol
)
1765 struct table_entry
*table
;
1771 xassert (SYMBOLP (symbol
));
1773 for (i
= 0; i
< dim
; ++i
)
1774 if (EQ (*table
[i
].symbol
, symbol
))
1777 return i
< dim
? table
+ i
: NULL
;
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. */
1785 face_numeric_value (table
, dim
, symbol
)
1786 struct table_entry
*table
;
1790 struct table_entry
*p
= face_value (table
, dim
, symbol
);
1791 return p
? p
->numeric
: -1;
1795 /* Return a numeric value representing the weight specified by Lisp
1796 symbol WEIGHT. Value is one of the enumerators of enum
1800 face_numeric_weight (weight
)
1803 return face_numeric_value (weight_table
, DIM (weight_table
), weight
);
1807 /* Return a numeric value representing the slant specified by Lisp
1808 symbol SLANT. Value is one of the enumerators of enum xlfd_slant. */
1811 face_numeric_slant (slant
)
1814 return face_numeric_value (slant_table
, DIM (slant_table
), slant
);
1818 /* Return a numeric value representing the swidth specified by Lisp
1819 symbol WIDTH. Value is one of the enumerators of enum xlfd_swidth. */
1822 face_numeric_swidth (width
)
1825 return face_numeric_value (swidth_table
, DIM (swidth_table
), width
);
1829 #ifdef HAVE_WINDOW_SYSTEM
1831 /* Return non-zero if FONT is the name of a fixed-pitch font. */
1835 struct font_name
*font
;
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';
1843 /* Return the point size of FONT on frame F, measured in 1/10 pt.
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.)
1852 Value is the real point size of FONT on frame F, or 0 if it cannot
1856 xlfd_point_size (f
, font
)
1858 struct font_name
*font
;
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
]);
1865 if (font_resy
== 0 || font_pt
== 0)
1868 real_pt
= (font_resy
/ resy
) * font_pt
+ 0.5;
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. */
1885 split_font_name (f
, font
, numeric_p
)
1887 struct font_name
*font
;
1893 if (*font
->name
== '-')
1895 char *p
= xstrlwr (font
->name
) + 1;
1897 while (i
< XLFD_LAST
)
1899 font
->fields
[i
] = p
;
1902 while (*p
&& *p
!= '-')
1912 success_p
= i
== XLFD_LAST
;
1914 /* If requested, and font name was in the expected format,
1915 compute numeric values for some fields. */
1916 if (numeric_p
&& success_p
)
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
);
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. */
1933 build_font_name (font
)
1934 struct font_name
*font
;
1938 char *font_name
= (char *) xmalloc (size
);
1939 int total_length
= 0;
1941 for (i
= 0; i
< XLFD_LAST
; ++i
)
1943 /* Add 1 because of the leading `-'. */
1944 int len
= strlen (font
->fields
[i
]) + 1;
1946 /* Reallocate font_name if necessary. Add 1 for the final
1948 if (total_length
+ len
+ 1 >= size
)
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
);
1956 font_name
[total_length
] = '-';
1957 bcopy (font
->fields
[i
], font_name
+ total_length
+ 1, len
- 1);
1958 total_length
+= len
;
1961 font_name
[total_length
] = 0;
1966 /* Free an array FONTS of N font_name structures. This frees FONTS
1967 itself and all `name' fields in its elements. */
1970 free_font_names (fonts
, n
)
1971 struct font_name
*fonts
;
1975 xfree (fonts
[--n
].name
);
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. */
1986 sort_fonts (f
, fonts
, nfonts
, cmpfn
)
1988 struct font_name
*fonts
;
1990 int (*cmpfn
) P_ ((const void *, const void *));
1993 qsort (fonts
, nfonts
, sizeof *fonts
, cmpfn
);
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
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.
2009 This is similar to x_list_fonts. The differences are:
2011 1. It avoids consing.
2012 2. It never calls XLoadQueryFont. */
2015 x_face_list_fonts (f
, pattern
, fonts
, nfonts
, try_alternatives_p
,
2019 struct font_name
*fonts
;
2020 int nfonts
, try_alternatives_p
;
2021 int scalable_fonts_p
;
2023 /* NTEMACS_TODO : currently this uses w32_list_fonts, but it may be
2024 better to do it the other way around. */
2026 char **names
= NULL
;
2028 Lisp_Object lpattern
, tem
;
2030 lpattern
= build_string (pattern
);
2032 /* Get the list of fonts matching PATTERN. */
2034 lfonts
= w32_list_fonts (f
, lpattern
, 0, nfonts
);
2037 /* Count fonts returned */
2038 for (tem
= lfonts
; CONSP (tem
); tem
= XCDR (tem
))
2041 /* Allocate array. */
2043 names
= (char **) xmalloc (n
* sizeof (char *));
2045 /* Extract font names into char * array. */
2047 for (i
= 0; i
< n
; i
++)
2049 names
[i
] = XSTRING (XCAR (tem
))->data
;
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
)
2059 /* Make a copy of the font name. */
2060 fonts
[j
].name
= xstrdup (names
[i
]);
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
))
2068 if (!scalable_fonts_p
2069 || !may_use_scalable_font_p (fonts
+ j
, names
[i
]))
2070 xfree (fonts
[j
].name
);
2073 #else /* !SCALABLE_FONTS */
2074 /* Always ignore scalable fonts. */
2075 xfree (fonts
[j
].name
);
2076 #endif /* !SCALABLE_FONTS */
2084 /* Free font names. */
2085 #if 0 /* NTEMACS_TODO : W32 equivalent? */
2087 XFreeFontNames (names
);
2089 #endif /* NTEMACS_TODO */
2093 /* If no fonts found, try patterns from Valternate_fontname_alist. */
2094 if (n
== 0 && try_alternatives_p
)
2096 Lisp_Object list
= Valternate_fontname_alist
;
2098 while (CONSP (list
))
2100 Lisp_Object entry
= XCAR (list
);
2102 && STRINGP (XCAR (entry
))
2103 && strcmp (XSTRING (XCAR (entry
))->data
, pattern
) == 0)
2110 Lisp_Object patterns
= XCAR (list
);
2113 while (CONSP (patterns
)
2114 /* If list is screwed up, give up. */
2115 && (name
= XCAR (patterns
),
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
,
2124 patterns
= XCDR (patterns
);
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. */
2137 first_font_matching (f
, pattern
, font
)
2140 struct font_name
*font
;
2143 struct font_name
*fonts
;
2145 fonts
= (struct font_name
*) xmalloc (nfonts
* sizeof *fonts
);
2146 nfonts
= x_face_list_fonts (f
, pattern
, fonts
, nfonts
, 1, 0);
2150 bcopy (&fonts
[0], font
, sizeof *font
);
2152 fonts
[0].name
= NULL
;
2153 free_font_names (fonts
, nfonts
);
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. */
2169 sorted_font_list (f
, pattern
, cmpfn
, fonts
)
2172 int (*cmpfn
) P_ ((const void *, const void *));
2173 struct font_name
**fonts
;
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
);
2182 *fonts
= (struct font_name
*) xmalloc (nfonts
* sizeof **fonts
);
2184 nfonts
= x_face_list_fonts (f
, pattern
, *fonts
, nfonts
, 1, 1);
2186 nfonts
= x_face_list_fonts (f
, pattern
, *fonts
, nfonts
, 1, 0);
2189 /* Sort the resulting array and return it in *FONTS. If no
2190 fonts were found, make sure to set *FONTS to null. */
2192 sort_fonts (f
, *fonts
, nfonts
, cmpfn
);
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. */
2211 cmp_font_names (a
, b
)
2214 struct font_name
*x
= (struct font_name
*) a
;
2215 struct font_name
*y
= (struct font_name
*) b
;
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
]);
2225 for (i
= 0; i
< DIM (font_sort_order
) && cmp
== 0; ++i
)
2227 int j
= font_sort_order
[i
];
2228 cmp
= x
->numeric
[j
] - y
->numeric
[j
];
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
);
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
2255 font_list (f
, pattern
, family
, registry_and_encoding
, fonts
)
2259 char *registry_and_encoding
;
2260 struct font_name
**fonts
;
2262 if (pattern
== NULL
)
2267 if (registry_and_encoding
== NULL
)
2268 registry_and_encoding
= "*";
2270 pattern
= (char *) alloca (strlen (family
)
2271 + strlen (registry_and_encoding
)
2273 if (index (family
, '-'))
2274 sprintf (pattern
, "-%s-*-%s", family
, registry_and_encoding
);
2276 sprintf (pattern
, "-*-%s-*-%s", family
, registry_and_encoding
);
2279 return sorted_font_list (f
, pattern
, cmp_font_names
, fonts
);
2283 /* Remove elements from LIST whose cars are `equal'. Called from
2284 x-family-fonts and x-font-family-list to remove duplicate font
2288 remove_duplicates (list
)
2291 Lisp_Object tail
= list
;
2293 while (!NILP (tail
) && !NILP (XCDR (tail
)))
2295 Lisp_Object next
= XCDR (tail
);
2296 if (!NILP (Fequal (XCAR (next
), XCAR (tail
))))
2297 XCDR (tail
) = XCDR (next
);
2304 DEFUN ("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\
2306 If FAMILY is omitted or nil, list all families.\n\
2307 Otherwise, FAMILY must be a string, possibly containing wildcards\n\
2309 If FRAME is omitted or nil, use the selected frame.\n\
2310 Each element of the result is a vector [FAMILY WIDTH POINT-SIZE WEIGHT\n\
2311 SLANT FIXED-P FULL REGISTRY-AND-ENCODING].\n\
2312 FAMILY is the font family name. POINT-SIZE is the size of the\n\
2313 font in 1/10 pt. WIDTH, WEIGHT, and SLANT are symbols describing the\n\
2314 width, weight and slant of the font. These symbols are the same as for\n\
2315 face attributes. FIXED-P is non-nil if the font is fixed-pitch.\n\
2316 FULL is the full name of the font, and REGISTRY-AND-ENCODING is a string\n\
2317 giving the registry and encoding of the font.\n\
2318 The result list is sorted according to the current setting of\n\
2319 the face font sort order.")
2321 Lisp_Object family
, frame
;
2323 struct frame
*f
= check_x_frame (frame
);
2324 struct font_name
*fonts
;
2327 struct gcpro gcpro1
;
2328 char *family_pattern
;
2331 family_pattern
= "*";
2334 CHECK_STRING (family
, 1);
2335 family_pattern
= LSTRDUPA (family
);
2340 nfonts
= font_list (f
, NULL
, family_pattern
, NULL
, &fonts
);
2341 for (i
= nfonts
- 1; i
>= 0; --i
)
2343 Lisp_Object v
= Fmake_vector (make_number (8), Qnil
);
2346 #define ASET(VECTOR, IDX, VAL) (XVECTOR (VECTOR)->contents[IDX] = (VAL))
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
));
2361 result
= Fcons (v
, result
);
2366 remove_duplicates (result
);
2367 free_font_names (fonts
, nfonts
);
2373 DEFUN ("x-font-family-list", Fx_font_family_list
, Sx_font_family_list
,
2375 "Return a list of available font families on FRAME.\n\
2376 If FRAME is omitted or nil, use the selected frame.\n\
2377 Value is a list of conses (FAMILY . FIXED-P) where FAMILY\n\
2378 is a font family, and FIXED-P is non-nil if fonts of that family\n\
2383 struct frame
*f
= check_x_frame (frame
);
2385 struct font_name
*fonts
;
2387 struct gcpro gcpro1
;
2388 int count
= specpdl_ptr
- specpdl
;
2391 /* Let's consider all fonts. Increase the limit for matching
2392 fonts until we have them all. */
2395 specbind (intern ("font-list-limit"), make_number (limit
));
2396 nfonts
= font_list (f
, NULL
, "*", NULL
, &fonts
);
2398 if (nfonts
== limit
)
2400 free_font_names (fonts
, nfonts
);
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
),
2414 remove_duplicates (result
);
2415 free_font_names (fonts
, nfonts
);
2417 return unbind_to (count
, result
);
2421 DEFUN ("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\
2423 If optional arguments FACE and FRAME are specified, return only fonts\n\
2424 the same size as FACE on FRAME.\n\
2425 PATTERN 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\
2429 FACE is a face name--a symbol.\n\
2431 The return value is a list of strings, suitable as arguments to\n\
2434 Fonts Emacs can't use may or may not be excluded\n\
2435 even if they match PATTERN and FACE.\n\
2436 The optional fourth argument MAXIMUM sets a limit on how many\n\
2437 fonts to match. The first MAXIMUM fonts are reported.\n\
2438 The optional fifth argument WIDTH, if specified, is a number of columns\n\
2439 occupied by a character of a font. In that case, return only fonts\n\
2440 the WIDTH times as wide as FACE on FRAME.")
2441 (pattern
, face
, frame
, maximum
, width
)
2442 Lisp_Object pattern
, face
, frame
, maximum
, width
;
2449 CHECK_STRING (pattern
, 0);
2455 CHECK_NATNUM (maximum
, 0);
2456 maxnames
= XINT (maximum
);
2460 CHECK_NUMBER (width
, 4);
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
))
2467 /* Perhaps we have not yet created any frame. */
2472 /* Determine the width standard for comparison with the fonts we find. */
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
);
2484 size
= FONT_MAX_WIDTH (face
->font
);
2486 size
= FONT_MAX_WIDTH (FRAME_FONT (f
));
2489 size
*= XINT (width
);
2493 Lisp_Object args
[2];
2495 args
[0] = w32_list_fonts (f
, pattern
, size
, maxnames
);
2497 /* We don't have to check fontsets. */
2499 args
[1] = list_fontsets (f
, pattern
, size
);
2500 return Fnconc (2, args
);
2504 #endif /* HAVE_WINDOW_SYSTEM */
2508 /***********************************************************************
2510 ***********************************************************************/
2512 /* Access face attributes of face FACE, a Lisp vector. */
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]
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. */
2544 #define LFACEP(LFACE) \
2546 && XVECTOR (LFACE)->size == LFACE_VECTOR_SIZE \
2547 && EQ (XVECTOR (LFACE)->contents[0], Qface))
2552 /* Check consistency of Lisp face attribute vector ATTRS. */
2555 check_lface_attrs (attrs
)
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
])));
2596 /* Check consistency of attributes of Lisp face LFACE (a Lisp vector). */
2604 xassert (LFACEP (lface
));
2605 check_lface_attrs (XVECTOR (lface
)->contents
);
2609 #else /* GLYPH_DEBUG == 0 */
2611 #define check_lface_attrs(attrs) (void) 0
2612 #define check_lface(lface) (void) 0
2614 #endif /* GLYPH_DEBUG == 0 */
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. */
2622 resolve_face_name (face_name
)
2623 Lisp_Object face_name
;
2625 Lisp_Object aliased
;
2627 if (STRINGP (face_name
))
2628 face_name
= intern (XSTRING (face_name
)->data
);
2632 aliased
= Fget (face_name
, Qface_alias
);
2636 face_name
= aliased
;
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
2652 static INLINE Lisp_Object
2653 lface_from_face_name (f
, face_name
, signal_p
)
2655 Lisp_Object face_name
;
2660 face_name
= resolve_face_name (face_name
);
2663 lface
= assq_no_quit (face_name
, f
->face_alist
);
2665 lface
= assq_no_quit (face_name
, Vface_new_frame_defaults
);
2668 lface
= XCDR (lface
);
2670 signal_error ("Invalid face", face_name
);
2672 check_lface (lface
);
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. */
2684 get_lface_attributes (f
, face_name
, attrs
, signal_p
)
2686 Lisp_Object face_name
;
2693 lface
= lface_from_face_name (f
, face_name
, signal_p
);
2696 bcopy (XVECTOR (lface
)->contents
, attrs
,
2697 LFACE_VECTOR_SIZE
* sizeof *attrs
);
2707 /* Non-zero if all attributes in face attribute vector ATTRS are
2708 specified, i.e. are non-nil. */
2711 lface_fully_specified_p (attrs
)
2716 for (i
= 1; i
< LFACE_VECTOR_SIZE
; ++i
)
2717 if (UNSPECIFIEDP (attrs
[i
]))
2720 return i
== LFACE_VECTOR_SIZE
;
2723 #ifdef HAVE_WINDOW_SYSTEM
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
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. */
2737 set_lface_from_font_name (f
, lface
, font_name
, force_p
, may_fail_p
)
2741 int force_p
, may_fail_p
;
2743 struct font_name font
;
2746 int free_font_name_p
= 0;
2747 int have_font_p
= 0;
2749 /* If FONT_NAME contains wildcards, use the first matching font. */
2750 if (index (font_name
, '*') || index (font_name
, '?'))
2752 if (first_font_matching (f
, font_name
, &font
))
2753 free_font_name_p
= have_font_p
= 1;
2757 font
.name
= STRDUPA (font_name
);
2758 if (split_font_name (f
, &font
, 1))
2762 /* The font name may be something like `6x13'. Make
2763 sure we use the full name. */
2764 struct font_info
*font_info
;
2767 font_info
= fs_load_font (f
, FRAME_W32_FONT_TABLE (f
),
2768 CHARSET_ASCII
, font_name
, -1);
2771 font
.name
= STRDUPA (font_info
->full_name
);
2772 split_font_name (f
, &font
, 1);
2779 /* If FONT_NAME is completely bogus try to use something reasonable
2780 if this function must succeed. Otherwise, give up. */
2785 else if (first_font_matching (f
, "-*-Courier New-normal-r-*-*-13-*-*-*-c-*-iso8859-1",
2787 || first_font_matching (f
, "-*-Courier-normal-r-*-*-13-*-*-*-c-*-iso8859-1",
2789 || first_font_matching (f
, "-*-FixedSys-normal-r-*-*-12-*-*-*-c-*-iso8859-1",
2791 || first_font_matching (f
, "-*-*-normal-r-*-*-*-*-*-*-c-*-iso8859-1",
2793 || first_font_matching (f
, "FixedSys",
2795 free_font_name_p
= 1;
2801 /* Set attributes only if unspecified, otherwise face defaults for
2802 new frames would never take effect. */
2804 if (force_p
|| UNSPECIFIEDP (LFACE_FAMILY (lface
)))
2806 buffer
= (char *) alloca (strlen (font
.fields
[XLFD_FAMILY
])
2807 + strlen (font
.fields
[XLFD_FOUNDRY
])
2809 sprintf (buffer
, "%s-%s", font
.fields
[XLFD_FOUNDRY
],
2810 font
.fields
[XLFD_FAMILY
]);
2811 LFACE_FAMILY (lface
) = build_string (buffer
);
2814 if (force_p
|| UNSPECIFIEDP (LFACE_HEIGHT (lface
)))
2816 pt
= xlfd_point_size (f
, &font
);
2818 LFACE_HEIGHT (lface
) = make_number (pt
);
2821 if (force_p
|| UNSPECIFIEDP (LFACE_SWIDTH (lface
)))
2822 LFACE_SWIDTH (lface
) = xlfd_symbolic_swidth (&font
);
2824 if (force_p
|| UNSPECIFIEDP (LFACE_WEIGHT (lface
)))
2825 LFACE_WEIGHT (lface
) = xlfd_symbolic_weight (&font
);
2827 if (force_p
|| UNSPECIFIEDP (LFACE_SLANT (lface
)))
2828 LFACE_SLANT (lface
) = xlfd_symbolic_slant (&font
);
2830 if (free_font_name_p
)
2835 #endif /* HAVE_WINDOW_SYSTEM */
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. */
2843 merge_face_vectors (from
, to
)
2844 Lisp_Object
*from
, *to
;
2847 for (i
= 1; i
< LFACE_VECTOR_SIZE
; ++i
)
2848 if (!UNSPECIFIEDP (from
[i
]))
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
2859 1. A symbol or string naming a Lisp face.
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
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.
2869 Face specifications earlier in lists take precedence over later
2873 merge_face_vector_with_property (f
, to
, prop
)
2880 Lisp_Object first
= XCAR (prop
);
2882 if (EQ (first
, Qforeground_color
)
2883 || EQ (first
, Qbackground_color
))
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
;
2890 if (STRINGP (color_name
))
2892 if (EQ (color
, Qforeground_color
))
2893 to
[LFACE_FOREGROUND_INDEX
] = color_name
;
2895 to
[LFACE_BACKGROUND_INDEX
] = color_name
;
2898 add_to_log ("Invalid face color", color_name
, Qnil
);
2900 else if (SYMBOLP (first
)
2901 && *XSYMBOL (first
)->name
->data
== ':')
2903 /* Assume this is the property list form. */
2904 while (CONSP (prop
) && CONSP (XCDR (prop
)))
2906 Lisp_Object keyword
= XCAR (prop
);
2907 Lisp_Object value
= XCAR (XCDR (prop
));
2909 if (EQ (keyword
, QCfamily
))
2911 if (STRINGP (value
))
2912 to
[LFACE_FAMILY_INDEX
] = value
;
2914 add_to_log ("Illegal face font family", value
, Qnil
);
2916 else if (EQ (keyword
, QCheight
))
2918 if (INTEGERP (value
))
2919 to
[LFACE_HEIGHT_INDEX
] = value
;
2921 add_to_log ("Illegal face font height", value
, Qnil
);
2923 else if (EQ (keyword
, QCweight
))
2926 && face_numeric_weight (value
) >= 0)
2927 to
[LFACE_WEIGHT_INDEX
] = value
;
2929 add_to_log ("Illegal face weight", value
, Qnil
);
2931 else if (EQ (keyword
, QCslant
))
2934 && face_numeric_slant (value
) >= 0)
2935 to
[LFACE_SLANT_INDEX
] = value
;
2937 add_to_log ("Illegal face slant", value
, Qnil
);
2939 else if (EQ (keyword
, QCunderline
))
2944 to
[LFACE_UNDERLINE_INDEX
] = value
;
2946 add_to_log ("Illegal face underline", value
, Qnil
);
2948 else if (EQ (keyword
, QCoverline
))
2953 to
[LFACE_OVERLINE_INDEX
] = value
;
2955 add_to_log ("Illegal face overline", value
, Qnil
);
2957 else if (EQ (keyword
, QCstrike_through
))
2962 to
[LFACE_STRIKE_THROUGH_INDEX
] = value
;
2964 add_to_log ("Illegal face strike-through", value
, Qnil
);
2966 else if (EQ (keyword
, QCbox
))
2969 value
= make_number (1);
2970 if (INTEGERP (value
)
2974 to
[LFACE_BOX_INDEX
] = value
;
2976 add_to_log ("Illegal face box", value
, Qnil
);
2978 else if (EQ (keyword
, QCinverse_video
)
2979 || EQ (keyword
, QCreverse_video
))
2981 if (EQ (value
, Qt
) || NILP (value
))
2982 to
[LFACE_INVERSE_INDEX
] = value
;
2984 add_to_log ("Illegal face inverse-video", value
, Qnil
);
2986 else if (EQ (keyword
, QCforeground
))
2988 if (STRINGP (value
))
2989 to
[LFACE_FOREGROUND_INDEX
] = value
;
2991 add_to_log ("Illegal face foreground", value
, Qnil
);
2993 else if (EQ (keyword
, QCbackground
))
2995 if (STRINGP (value
))
2996 to
[LFACE_BACKGROUND_INDEX
] = value
;
2998 add_to_log ("Illegal face background", value
, Qnil
);
3000 else if (EQ (keyword
, QCstipple
))
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
;
3007 add_to_log ("Illegal face stipple", value
, Qnil
);
3010 else if (EQ (keyword
, QCwidth
))
3013 && face_numeric_swidth (value
) >= 0)
3014 to
[LFACE_SWIDTH_INDEX
] = value
;
3016 add_to_log ("Illegal face width", value
, Qnil
);
3019 add_to_log ("Invalid attribute %s in face property",
3022 prop
= XCDR (XCDR (prop
));
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
);
3033 merge_face_vector_with_property (f
, to
, next
);
3034 merge_face_vector_with_property (f
, to
, first
);
3039 /* PROP ought to be a face name. */
3040 Lisp_Object lface
= lface_from_face_name (f
, prop
, 0);
3042 add_to_log ("Invalid face text property value: %s", prop
, Qnil
);
3044 merge_face_vectors (XVECTOR (lface
)->contents
, to
);
3049 DEFUN ("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\
3052 If FACE was not known as a face before, create a new one.\n\
3053 If optional argument FRAME is specified, make a frame-local face\n\
3054 for that frame. Otherwise operate on the global face definition.\n\
3055 Value is a vector of face attributes.")
3057 Lisp_Object face
, frame
;
3059 Lisp_Object global_lface
, lface
;
3063 CHECK_SYMBOL (face
, 0);
3064 global_lface
= lface_from_face_name (NULL
, face
, 0);
3068 CHECK_LIVE_FRAME (frame
, 1);
3070 lface
= lface_from_face_name (f
, face
, 0);
3073 f
= NULL
, lface
= Qnil
;
3075 /* Add a global definition if there is none. */
3076 if (NILP (global_lface
))
3078 global_lface
= Fmake_vector (make_number (LFACE_VECTOR_SIZE
),
3080 XVECTOR (global_lface
)->contents
[0] = Qface
;
3081 Vface_new_frame_defaults
= Fcons (Fcons (face
, global_lface
),
3082 Vface_new_frame_defaults
);
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
)
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
;
3096 lface_id_to_name
[next_lface_id
] = face
;
3097 Fput (face
, Qface
, make_number (next_lface_id
));
3101 for (i
= 1; i
< LFACE_VECTOR_SIZE
; ++i
)
3102 XVECTOR (global_lface
)->contents
[i
] = Qunspecified
;
3104 /* Add a frame-local definition. */
3109 lface
= Fmake_vector (make_number (LFACE_VECTOR_SIZE
),
3111 XVECTOR (lface
)->contents
[0] = Qface
;
3112 f
->face_alist
= Fcons (Fcons (face
, lface
), f
->face_alist
);
3115 for (i
= 1; i
< LFACE_VECTOR_SIZE
; ++i
)
3116 XVECTOR (lface
)->contents
[i
] = Qunspecified
;
3119 lface
= global_lface
;
3121 xassert (LFACEP (lface
));
3122 check_lface (lface
);
3127 DEFUN ("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\
3130 If optional second parameter FRAME is non-nil, check for the\n\
3131 existence of a frame-local face with name FACE on that frame.\n\
3132 Otherwise check for the existence of a global face.")
3134 Lisp_Object face
, frame
;
3140 CHECK_LIVE_FRAME (frame
, 1);
3141 lface
= lface_from_face_name (XFRAME (frame
), face
, 0);
3144 lface
= lface_from_face_name (NULL
, face
, 0);
3150 DEFUN ("internal-copy-lisp-face", Finternal_copy_lisp_face
,
3151 Sinternal_copy_lisp_face
, 4, 4, 0,
3152 "Copy face FROM to TO.\n\
3153 If FRAME it t, copy the global face definition of FROM to the\n\
3154 global face definition of TO. Otherwise, copy the frame-local\n\
3155 definition of FROM on FRAME to the frame-local definition of TO\n\
3156 on NEW-FRAME, or FRAME if NEW-FRAME is nil.\n\
3159 (from
, to
, frame
, new_frame
)
3160 Lisp_Object from
, to
, frame
, new_frame
;
3162 Lisp_Object lface
, copy
;
3164 CHECK_SYMBOL (from
, 0);
3165 CHECK_SYMBOL (to
, 1);
3166 if (NILP (new_frame
))
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
);
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
);
3185 bcopy (XVECTOR (lface
)->contents
, XVECTOR (copy
)->contents
,
3186 LFACE_VECTOR_SIZE
* sizeof (Lisp_Object
));
3192 DEFUN ("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\
3195 If optional argument FRAME is given, set the face attribute of face FACE\n\
3196 on that frame. If FRAME is t, set the attribute of the default for face\n\
3197 FACE (for new frames). If FRAME is omitted or nil, use the selected\n\
3199 (face
, attr
, value
, frame
)
3200 Lisp_Object face
, attr
, value
, frame
;
3203 Lisp_Object old_value
= Qnil
;
3204 int font_related_attr_p
= 0;
3206 CHECK_SYMBOL (face
, 0);
3207 CHECK_SYMBOL (attr
, 1);
3209 face
= resolve_face_name (face
);
3211 /* Set lface to the Lisp attribute vector of FACE. */
3213 lface
= lface_from_face_name (NULL
, face
, 1);
3217 frame
= selected_frame
;
3219 CHECK_LIVE_FRAME (frame
, 3);
3220 lface
= lface_from_face_name (XFRAME (frame
), face
, 0);
3222 /* If a frame-local face doesn't exist yet, create one. */
3224 lface
= Finternal_make_lisp_face (face
, frame
);
3227 if (EQ (attr
, QCfamily
))
3229 if (!UNSPECIFIEDP (value
))
3231 CHECK_STRING (value
, 3);
3232 if (XSTRING (value
)->size
== 0)
3233 signal_error ("Invalid face family", value
);
3235 old_value
= LFACE_FAMILY (lface
);
3236 LFACE_FAMILY (lface
) = value
;
3237 font_related_attr_p
= 1;
3239 else if (EQ (attr
, QCheight
))
3241 if (!UNSPECIFIEDP (value
))
3243 CHECK_NUMBER (value
, 3);
3244 if (XINT (value
) <= 0)
3245 signal_error ("Invalid face height", value
);
3247 old_value
= LFACE_HEIGHT (lface
);
3248 LFACE_HEIGHT (lface
) = value
;
3249 font_related_attr_p
= 1;
3251 else if (EQ (attr
, QCweight
))
3253 if (!UNSPECIFIEDP (value
))
3255 CHECK_SYMBOL (value
, 3);
3256 if (face_numeric_weight (value
) < 0)
3257 signal_error ("Invalid face weight", value
);
3259 old_value
= LFACE_WEIGHT (lface
);
3260 LFACE_WEIGHT (lface
) = value
;
3261 font_related_attr_p
= 1;
3263 else if (EQ (attr
, QCslant
))
3265 if (!UNSPECIFIEDP (value
))
3267 CHECK_SYMBOL (value
, 3);
3268 if (face_numeric_slant (value
) < 0)
3269 signal_error ("Invalid face slant", value
);
3271 old_value
= LFACE_SLANT (lface
);
3272 LFACE_SLANT (lface
) = value
;
3273 font_related_attr_p
= 1;
3275 else if (EQ (attr
, QCunderline
))
3277 if (!UNSPECIFIEDP (value
))
3278 if ((SYMBOLP (value
)
3280 && !EQ (value
, Qnil
))
3281 /* Underline color. */
3283 && XSTRING (value
)->size
== 0))
3284 signal_error ("Invalid face underline", value
);
3286 old_value
= LFACE_UNDERLINE (lface
);
3287 LFACE_UNDERLINE (lface
) = value
;
3289 else if (EQ (attr
, QCoverline
))
3291 if (!UNSPECIFIEDP (value
))
3292 if ((SYMBOLP (value
)
3294 && !EQ (value
, Qnil
))
3295 /* Overline color. */
3297 && XSTRING (value
)->size
== 0))
3298 signal_error ("Invalid face overline", value
);
3300 old_value
= LFACE_OVERLINE (lface
);
3301 LFACE_OVERLINE (lface
) = value
;
3303 else if (EQ (attr
, QCstrike_through
))
3305 if (!UNSPECIFIEDP (value
))
3306 if ((SYMBOLP (value
)
3308 && !EQ (value
, Qnil
))
3309 /* Strike-through color. */
3311 && XSTRING (value
)->size
== 0))
3312 signal_error ("Invalid face strike-through", value
);
3314 old_value
= LFACE_STRIKE_THROUGH (lface
);
3315 LFACE_STRIKE_THROUGH (lface
) = value
;
3317 else if (EQ (attr
, QCbox
))
3321 /* Allow t meaning a simple box of width 1 in foreground color
3324 value
= make_number (1);
3326 if (UNSPECIFIEDP (value
))
3328 else if (NILP (value
))
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
))
3350 if (EQ (k
, QCline_width
))
3352 if (!INTEGERP (v
) || XINT (v
) <= 0)
3355 else if (EQ (k
, QCcolor
))
3357 if (!STRINGP (v
) || XSTRING (v
)->size
== 0)
3360 else if (EQ (k
, QCstyle
))
3362 if (!EQ (v
, Qpressed_button
) && !EQ (v
, Qreleased_button
))
3369 valid_p
= NILP (tem
);
3375 signal_error ("Invalid face box", value
);
3377 old_value
= LFACE_BOX (lface
);
3378 LFACE_BOX (lface
) = value
;
3380 else if (EQ (attr
, QCinverse_video
)
3381 || EQ (attr
, QCreverse_video
))
3383 if (!UNSPECIFIEDP (value
))
3385 CHECK_SYMBOL (value
, 3);
3386 if (!EQ (value
, Qt
) && !NILP (value
))
3387 signal_error ("Invalid inverse-video face attribute value", value
);
3389 old_value
= LFACE_INVERSE (lface
);
3390 LFACE_INVERSE (lface
) = value
;
3392 else if (EQ (attr
, QCforeground
))
3394 if (!UNSPECIFIEDP (value
))
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
);
3403 old_value
= LFACE_FOREGROUND (lface
);
3404 LFACE_FOREGROUND (lface
) = value
;
3406 else if (EQ (attr
, QCbackground
))
3408 if (!UNSPECIFIEDP (value
))
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
);
3417 old_value
= LFACE_BACKGROUND (lface
);
3418 LFACE_BACKGROUND (lface
) = value
;
3420 else if (EQ (attr
, QCstipple
))
3422 #ifdef HAVE_X_WINDOWS
3423 if (!UNSPECIFIEDP (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 */
3431 else if (EQ (attr
, QCwidth
))
3433 if (!UNSPECIFIEDP (value
))
3435 CHECK_SYMBOL (value
, 3);
3436 if (face_numeric_swidth (value
) < 0)
3437 signal_error ("Invalid face width", value
);
3439 old_value
= LFACE_SWIDTH (lface
);
3440 LFACE_SWIDTH (lface
) = value
;
3441 font_related_attr_p
= 1;
3443 else if (EQ (attr
, QCfont
))
3445 #ifdef HAVE_WINDOW_SYSTEM
3446 /* Set font-related attributes of the Lisp face from an
3450 CHECK_STRING (value
, 3);
3452 f
= SELECTED_FRAME ();
3454 f
= check_x_frame (frame
);
3456 if (!set_lface_from_font_name (f
, lface
, XSTRING (value
)->data
, 1, 1))
3457 signal_error ("Invalid font name", value
);
3459 font_related_attr_p
= 1;
3460 #endif /* HAVE_WINDOW_SYSTEM */
3462 else if (EQ (attr
, QCbold
))
3464 old_value
= LFACE_WEIGHT (lface
);
3465 LFACE_WEIGHT (lface
) = NILP (value
) ? Qnormal
: Qbold
;
3466 font_related_attr_p
= 1;
3468 else if (EQ (attr
, QCitalic
))
3470 old_value
= LFACE_SLANT (lface
);
3471 LFACE_SLANT (lface
) = NILP (value
) ? Qnormal
: Qitalic
;
3472 font_related_attr_p
= 1;
3475 signal_error ("Invalid face attribute name", attr
);
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. */
3483 && (EQ (attr
, QCfont
)
3484 || NILP (Fequal (old_value
, value
))))
3486 ++face_change_count
;
3487 ++windows_or_buffers_changed
;
3490 #ifdef HAVE_WINDOW_SYSTEM
3493 && !UNSPECIFIEDP (value
)
3494 && NILP (Fequal (old_value
, value
)))
3500 if (EQ (face
, Qdefault
))
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
;
3512 #if 0 /* NTEMACS_TODO : Scroll bar colors on W32? */
3513 else if (EQ (face
, Qscroll_bar
))
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
;
3522 #endif /* NTEMACS_TODO */
3523 else if (EQ (face
, Qborder
))
3525 /* Changing background color of `border' sets frame parameter
3527 if (EQ (attr
, QCbackground
))
3528 param
= Qborder_color
;
3530 else if (EQ (face
, Qcursor
))
3532 /* Changing background color of `cursor' sets frame parameter
3534 if (EQ (attr
, QCbackground
))
3535 param
= Qcursor_color
;
3537 else if (EQ (face
, Qmouse
))
3539 /* Changing background color of `mouse' sets frame parameter
3541 if (EQ (attr
, QCbackground
))
3542 param
= Qmouse_color
;
3545 if (SYMBOLP (param
))
3546 Fmodify_frame_parameters (frame
, Fcons (Fcons (param
, value
), Qnil
));
3549 #endif /* HAVE_WINDOW_SYSTEM */
3555 #ifdef HAVE_WINDOW_SYSTEM
3557 /* Set the `font' frame parameter of FRAME according to `default' face
3558 attributes LFACE. */
3561 set_font_frame_param (frame
, lface
)
3562 Lisp_Object frame
, lface
;
3564 struct frame
*f
= XFRAME (frame
);
3565 Lisp_Object frame_font
;
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
);
3574 fontset
= fs_query_fontset (f
, XSTRING (frame_font
)->data
);
3577 /* Frame parameter is a fontset name. Modify the fontset so
3578 that all its fonts reflect face attributes LFACE. */
3580 struct fontset_info
*fontset_info
;
3582 fontset_info
= FRAME_FONTSET_DATA (f
)->fontset_table
[fontset
];
3584 for (charset
= 0; charset
< MAX_CHARSET
; ++charset
)
3585 if (fontset_info
->fontname
[charset
])
3587 font
= choose_face_fontset_font (f
, XVECTOR (lface
)->contents
,
3589 Fset_fontset_font (frame_font
, CHARSET_SYMBOL (charset
),
3590 build_string (font
), frame
);
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
);
3602 store_frame_param (f
, Qfont
, build_string (font
));
3609 /* Update the corresponding face when frame parameter PARAM on frame F
3610 has been assigned the value NEW_VALUE. */
3613 update_face_from_frame_parameter (f
, param
, new_value
)
3615 Lisp_Object param
, new_value
;
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
))
3625 if (EQ (param
, Qforeground_color
))
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
);
3632 else if (EQ (param
, Qbackground_color
))
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
);
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
);
3647 if (EQ (param
, Qborder_color
))
3649 lface
= lface_from_face_name (f
, Qborder
, 1);
3650 LFACE_BACKGROUND (lface
) = (STRINGP (new_value
)
3651 ? new_value
: Qunspecified
);
3653 else if (EQ (param
, Qcursor_color
))
3655 lface
= lface_from_face_name (f
, Qcursor
, 1);
3656 LFACE_BACKGROUND (lface
) = (STRINGP (new_value
)
3657 ? new_value
: Qunspecified
);
3659 else if (EQ (param
, Qmouse_color
))
3661 lface
= lface_from_face_name (f
, Qmouse
, 1);
3662 LFACE_BACKGROUND (lface
) = (STRINGP (new_value
)
3663 ? new_value
: Qunspecified
);
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. */
3672 DEFUN ("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
;
3677 #if 0 /* NTEMACS_TODO : W32 resources */
3679 CHECK_STRING (resource
, 0);
3680 CHECK_STRING (class, 1);
3681 CHECK_LIVE_FRAME (frame
, 2);
3683 value
= display_x_get_resource (FRAME_W32_DISPLAY_INFO (XFRAME (frame
)),
3684 resource
, class, Qnil
, Qnil
);
3687 #endif /* NTEMACS_TODO */
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. */
3698 face_boolean_x_resource_value (value
, signal_p
)
3702 Lisp_Object result
= make_number (0);
3704 xassert (STRINGP (value
));
3706 if (xstricmp (XSTRING (value
)->data
, "on") == 0
3707 || xstricmp (XSTRING (value
)->data
, "true") == 0)
3709 else if (xstricmp (XSTRING (value
)->data
, "off") == 0
3710 || xstricmp (XSTRING (value
)->data
, "false") == 0)
3712 else if (xstricmp (XSTRING (value
)->data
, "unspecified") == 0)
3713 result
= Qunspecified
;
3715 signal_error ("Invalid face attribute value from X resource", value
);
3721 DEFUN ("internal-set-lisp-face-attribute-from-resource",
3722 Finternal_set_lisp_face_attribute_from_resource
,
3723 Sinternal_set_lisp_face_attribute_from_resource
,
3725 (face
, attr
, value
, frame
)
3726 Lisp_Object face
, attr
, value
, frame
;
3728 CHECK_SYMBOL (face
, 0);
3729 CHECK_SYMBOL (attr
, 1);
3730 CHECK_STRING (value
, 2);
3732 if (xstricmp (XSTRING (value
)->data
, "unspecified") == 0)
3733 value
= Qunspecified
;
3734 else if (EQ (attr
, QCheight
))
3736 value
= Fstring_to_number (value
, make_number (10));
3737 if (XINT (value
) <= 0)
3738 signal_error ("Invalid face height from X resource", value
);
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
))
3751 Lisp_Object boolean_value
;
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
;
3760 return Finternal_set_lisp_face_attribute (face
, attr
, value
, frame
);
3763 #endif /* HAVE_WINDOW_SYSTEM */
3766 DEFUN ("internal-get-lisp-face-attribute", Finternal_get_lisp_face_attribute
,
3767 Sinternal_get_lisp_face_attribute
,
3769 "Return face attribute KEYWORD of face SYMBOL.\n\
3770 If SYMBOL does not name a valid Lisp face or KEYWORD isn't a valid\n\
3771 face attribute name, signal an error.\n\
3772 If the optional argument FRAME is given, report on face FACE in that\n\
3773 frame. If FRAME is t, report on the defaults for face FACE (for new\n\
3774 frames). If FRAME is omitted or nil, use the selected frame.")
3775 (symbol
, keyword
, frame
)
3776 Lisp_Object symbol
, keyword
, frame
;
3778 Lisp_Object lface
, value
= Qnil
;
3780 CHECK_SYMBOL (symbol
, 0);
3781 CHECK_SYMBOL (keyword
, 1);
3784 lface
= lface_from_face_name (NULL
, symbol
, 1);
3788 frame
= selected_frame
;
3789 CHECK_LIVE_FRAME (frame
, 2);
3790 lface
= lface_from_face_name (XFRAME (frame
), symbol
, 1);
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
);
3821 signal_error ("Invalid face attribute name", keyword
);
3827 DEFUN ("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\
3831 Value is nil if ATTR doesn't have a discrete set of valid values.")
3835 Lisp_Object result
= Qnil
;
3837 CHECK_SYMBOL (attr
, 0);
3839 if (EQ (attr
, QCweight
)
3840 || EQ (attr
, QCslant
)
3841 || EQ (attr
, QCwidth
))
3843 /* Extract permissible symbols from tables. */
3844 struct table_entry
*table
;
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
);
3852 table
= swidth_table
, dim
= DIM (swidth_table
);
3854 for (i
= 0; i
< dim
; ++i
)
3856 Lisp_Object symbol
= *table
[i
].symbol
;
3857 Lisp_Object tail
= result
;
3860 && !EQ (XCAR (tail
), symbol
))
3864 result
= Fcons (symbol
, result
);
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
));
3880 DEFUN ("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.")
3884 Lisp_Object face
, frame
;
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
);
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. */
3903 DEFUN ("face-font", Fface_font
, Sface_font
, 1, 2, 0,
3904 "Return the font name of face FACE, or nil if it is unspecified.\n\
3905 If the optional argument FRAME is given, report on face FACE in that frame.\n\
3906 If 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\
3909 If FRAME is omitted or nil, use the selected frame.")
3911 Lisp_Object face
, frame
;
3915 Lisp_Object result
= Qnil
;
3916 Lisp_Object lface
= lface_from_face_name (NULL
, face
, 1);
3918 if (!UNSPECIFIEDP (LFACE_WEIGHT (lface
))
3919 && !EQ (LFACE_WEIGHT (lface
), Qnormal
))
3920 result
= Fcons (Qbold
, result
);
3922 if (!NILP (LFACE_SLANT (lface
))
3923 && !EQ (LFACE_SLANT (lface
), Qnormal
))
3924 result
= Fcons (Qitalic
, result
);
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
);
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. */
3943 lface_equal_p (v1
, v2
)
3944 Lisp_Object
*v1
, *v2
;
3948 for (i
= 1; i
< LFACE_VECTOR_SIZE
&& equal_p
; ++i
)
3950 Lisp_Object a
= v1
[i
];
3951 Lisp_Object b
= v2
[i
];
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
);
3964 equal_p
= (XSTRING (a
)->size
== XSTRING (b
)->size
3965 && bcmp (XSTRING (a
)->data
, XSTRING (b
)->data
,
3966 XSTRING (a
)->size
) == 0);
3975 equal_p
= !NILP (Fequal (a
, b
));
3985 DEFUN ("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\
3988 If the optional argument FRAME is given, report on face FACE in that frame.\n\
3989 If FRAME is t, report on the defaults for face FACE (for new frames).\n\
3990 If FRAME is omitted or nil, use the selected frame.")
3991 (face1
, face2
, frame
)
3992 Lisp_Object face1
, face2
, frame
;
3996 Lisp_Object lface1
, lface2
;
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);
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
;
4015 DEFUN ("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\
4018 If the optional argument FRAME is given, report on face FACE in that frame.\n\
4019 If FRAME is t, report on the defaults for face FACE (for new frames).\n\
4020 If FRAME is omitted or nil, use the selected frame.")
4022 Lisp_Object face
, frame
;
4029 frame
= selected_frame
;
4030 CHECK_LIVE_FRAME (frame
, 0);
4034 lface
= lface_from_face_name (NULL
, face
, 1);
4036 lface
= lface_from_face_name (f
, face
, 1);
4038 for (i
= 1; i
< LFACE_VECTOR_SIZE
; ++i
)
4039 if (!UNSPECIFIEDP (XVECTOR (lface
)->contents
[i
]))
4042 return i
== LFACE_VECTOR_SIZE
? Qt
: Qnil
;
4046 DEFUN ("frame-face-alist", Fframe_face_alist
, Sframe_face_alist
,
4048 "Return an alist of frame-local faces defined on FRAME.\n\
4049 For internal use only.")
4053 struct frame
*f
= frame_or_selected_frame (frame
, 0);
4054 return f
->face_alist
;
4058 /* Return a hash code for Lisp string STRING with case ignored. Used
4059 below in computing a hash value for a Lisp face. */
4061 static INLINE
unsigned
4062 hash_string_case_insensitive (string
)
4067 xassert (STRINGP (string
));
4068 for (s
= XSTRING (string
)->data
; *s
; ++s
)
4069 hash
= (hash
<< 1) ^ tolower (*s
);
4074 /* Return a hash code for face attribute vector V. */
4076 static INLINE
unsigned
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
]));
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. */
4096 lface_same_font_attributes_p (lface1
, lface2
)
4097 Lisp_Object
*lface1
, *lface2
;
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
]));
4112 /***********************************************************************
4114 ***********************************************************************/
4116 /* Allocate and return a new realized face for Lisp face attribute
4117 vector ATTR, charset CHARSET, and registry REGISTRY. */
4119 static struct face
*
4120 make_realized_face (attr
, charset
, registry
)
4123 Lisp_Object registry
;
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
);
4134 /* Free realized face FACE, including its X resources. FACE may
4138 free_realized_face (f
, face
)
4144 #ifdef HAVE_WINDOW_SYSTEM
4145 if (FRAME_WINDOW_P (f
))
4149 x_free_gc (f
, face
->gc
);
4153 free_face_colors (f
, face
);
4154 x_destroy_bitmap (f
, face
->stipple
);
4156 #endif /* HAVE_WINDOW_SYSTEM */
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. */
4168 prepare_face_for_display (f
, face
)
4172 #ifdef HAVE_WINDOW_SYSTEM
4173 xassert (FRAME_WINDOW_P (f
));
4178 unsigned long mask
= GCForeground
| GCBackground
;
4180 xgcv
.foreground
= face
->foreground
;
4181 xgcv
.background
= face
->background
;
4183 /* The font of FACE may be null if we couldn't load it. */
4186 xgcv
.font
= face
->font
;
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 */
4200 face
->gc
= x_create_gc (f
, mask
, &xgcv
);
4203 #endif /* HAVE_WINDOW_SYSTEM */
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. */
4212 face_suitable_for_iso8859_1_p (face
)
4215 int len
= strlen (face
->font_name
);
4216 return len
>= 9 && xstricmp (face
->font_name
+ len
- 9, "iso8859-1") == 0;
4220 /* Value is non-zero if FACE is suitable for displaying characters
4221 of CHARSET. CHARSET < 0 means unibyte text. */
4224 face_suitable_for_charset_p (face
, charset
)
4232 if (EQ (face
->registry
, Vface_default_registry
)
4233 || !NILP (Fequal (face
->registry
, Vface_default_registry
)))
4236 else if (face
->charset
== charset
)
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
)
4250 /***********************************************************************
4252 ***********************************************************************/
4254 /* Return a new face cache for frame F. */
4256 static struct face_cache
*
4260 struct face_cache
*c
;
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
);
4269 c
->faces_by_id
= (struct face
**) xmalloc (c
->size
* sizeof *c
->faces_by_id
);
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. */
4281 struct face_cache
*c
;
4283 if (c
&& FRAME_WINDOW_P (c
->f
))
4285 #ifdef HAVE_WINDOW_SYSTEM
4287 for (i
= BASIC_FACE_ID_SENTINEL
; i
< c
->used
; ++i
)
4289 struct face
*face
= c
->faces_by_id
[i
];
4290 if (face
&& face
->gc
)
4292 x_free_gc (c
->f
, face
->gc
);
4296 #endif /* HAVE_WINDOW_SYSTEM */
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. */
4307 free_realized_faces (c
)
4308 struct face_cache
*c
;
4313 struct frame
*f
= c
->f
;
4315 for (i
= 0; i
< c
->used
; ++i
)
4317 free_realized_face (f
, c
->faces_by_id
[i
]);
4318 c
->faces_by_id
[i
] = NULL
;
4322 size
= FACE_CACHE_BUCKETS_SIZE
* sizeof *c
->buckets
;
4323 bzero (c
->buckets
, size
);
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
))
4331 clear_current_matrices (f
);
4332 ++windows_or_buffers_changed
;
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. */
4343 free_all_realized_faces (frame
)
4349 FOR_EACH_FRAME (rest
, frame
)
4350 free_realized_faces (FRAME_FACE_CACHE (XFRAME (frame
)));
4353 free_realized_faces (FRAME_FACE_CACHE (XFRAME (frame
)));
4357 /* Free face cache C and faces in it, including their X resources. */
4361 struct face_cache
*c
;
4365 free_realized_faces (c
);
4367 xfree (c
->faces_by_id
);
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. */
4380 cache_face (c
, face
, hash
)
4381 struct face_cache
*c
;
4385 int i
= hash
% FACE_CACHE_BUCKETS_SIZE
;
4389 if (face
->fontset
>= 0)
4391 struct face
*last
= c
->buckets
[i
];
4402 c
->buckets
[i
] = face
;
4403 face
->prev
= face
->next
= NULL
;
4409 face
->next
= c
->buckets
[i
];
4411 face
->next
->prev
= face
;
4412 c
->buckets
[i
] = face
;
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
)
4422 /* Maybe enlarge C->faces_by_id. */
4423 if (i
== c
->used
&& c
->used
== c
->size
)
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
);
4432 /* Check that FACE got a unique id. */
4437 for (j
= n
= 0; j
< FACE_CACHE_BUCKETS_SIZE
; ++j
)
4438 for (face
= c
->buckets
[j
]; face
; face
= face
->next
)
4444 #endif /* GLYPH_DEBUG */
4446 c
->faces_by_id
[i
] = face
;
4452 /* Remove face FACE from cache C. */
4455 uncache_face (c
, face
)
4456 struct face_cache
*c
;
4459 int i
= face
->hash
% FACE_CACHE_BUCKETS_SIZE
;
4462 face
->prev
->next
= face
->next
;
4464 c
->buckets
[i
] = face
->next
;
4467 face
->next
->prev
= face
->prev
;
4469 c
->faces_by_id
[face
->id
] = NULL
;
4470 if (face
->id
== c
->used
)
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. */
4483 lookup_face (f
, attr
, charset
)
4488 struct face_cache
*c
= FRAME_FACE_CACHE (f
);
4493 xassert (c
!= NULL
);
4494 check_lface_attrs (attr
);
4496 /* Look up ATTR in the face cache. */
4497 hash
= lface_hash (attr
);
4498 i
= hash
% FACE_CACHE_BUCKETS_SIZE
;
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
))
4507 /* If not found, realize a new face. */
4510 face
= realize_face (c
, attr
, charset
);
4511 cache_face (c
, face
, hash
);
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 */
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. */
4529 lookup_named_face (f
, symbol
, charset
)
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
);
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
);
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. */
4549 ascii_face_of_lisp_face (f
, lface_id
)
4555 if (lface_id
>= 0 && lface_id
< lface_id_to_name_size
)
4557 Lisp_Object face_name
= lface_id_to_name
[lface_id
];
4558 face_id
= lookup_named_face (f
, face_name
, CHARSET_ASCII
);
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. */
4572 smaller_face (f
, face_id
, steps
)
4576 #ifdef HAVE_WINDOW_SYSTEM
4578 Lisp_Object attrs
[LFACE_VECTOR_SIZE
];
4579 int pt
, last_pt
, last_height
;
4582 struct face
*new_face
;
4584 /* If not called for an X frame, just return the original face. */
4585 if (FRAME_TERMCAP_P (f
))
4588 /* Try in increments of 1/2 pt. */
4589 delta
= steps
< 0 ? 5 : -5;
4590 steps
= abs (steps
);
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
);
4600 /* Give up if we cannot find a font within 10pt. */
4601 && abs (last_pt
- pt
) < 100)
4603 /* Look up a face for a slightly smaller/larger font. */
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
);
4609 /* If height changes, count that as one step. */
4610 if (FONT_HEIGHT (new_face
->font
) != last_height
)
4613 last_height
= FONT_HEIGHT (new_face
->font
);
4620 #else /* not HAVE_WINDOW_SYSTEM */
4624 #endif /* not HAVE_WINDOW_SYSTEM */
4628 /* Return a face for charset ASCII that is like the face with id
4629 FACE_ID on frame F, but has height HEIGHT. */
4632 face_with_height (f
, face_id
, height
)
4637 #ifdef HAVE_WINDOW_SYSTEM
4639 Lisp_Object attrs
[LFACE_VECTOR_SIZE
];
4641 if (FRAME_TERMCAP_P (f
)
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 */
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. */
4663 lookup_derived_face (f
, symbol
, charset
, face_id
)
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
);
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
);
4684 /***********************************************************************
4686 ***********************************************************************/
4688 DEFUN ("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\
4692 ORDER must be a list of length 4 containing the symbols `:width',\n\
4693 `:height', `:weight', and `:slant'. Face attributes appearing\n\
4694 first 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\
4696 a suitable height, and then tries to match the font weight.\n\
4705 CHECK_LIST (order
, 0);
4706 bzero (indices
, sizeof indices
);
4710 CONSP (list
) && i
< DIM (indices
);
4711 list
= XCDR (list
), ++i
)
4713 Lisp_Object attr
= XCAR (list
);
4716 if (EQ (attr
, QCwidth
))
4718 else if (EQ (attr
, QCheight
))
4719 xlfd
= XLFD_POINT_SIZE
;
4720 else if (EQ (attr
, QCweight
))
4722 else if (EQ (attr
, QCslant
))
4727 if (indices
[i
] != 0)
4733 || i
!= DIM (indices
)
4738 signal_error ("Invalid font sort order", order
);
4740 if (bcmp (indices
, font_sort_order
, sizeof indices
) != 0)
4742 bcopy (indices
, font_sort_order
, sizeof font_sort_order
);
4743 free_all_realized_faces (Qnil
);
4750 DEFUN ("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\
4754 ALIST is an alist of (FAMILY ALTERNATIVE1 ALTERNATIVE2 ...) entries.\n\
4755 Each ALTERNATIVE is tried in order if no fonts of font family FAMILY can\n\
4756 be found. Value is ALIST.")
4760 CHECK_LIST (alist
, 0);
4761 Vface_alternative_font_family_alist
= alist
;
4762 free_all_realized_faces (Qnil
);
4767 #ifdef HAVE_WINDOW_SYSTEM
4769 /* Return the X registry and encoding of font name FONT_NAME on frame F.
4770 Value is nil if not successful. */
4773 deduce_unibyte_registry (f
, font_name
)
4777 struct font_name font
;
4778 Lisp_Object registry
= Qnil
;
4780 font
.name
= STRDUPA (font_name
);
4781 if (split_font_name (f
, &font
, 0))
4785 /* Extract registry and encoding. */
4786 buffer
= (char *) alloca (strlen (font
.fields
[XLFD_REGISTRY
])
4787 + strlen (font
.fields
[XLFD_ENCODING
])
4789 strcpy (buffer
, font
.fields
[XLFD_REGISTRY
]);
4790 strcat (buffer
, "-");
4791 strcat (buffer
, font
.fields
[XLFD_ENCODING
]);
4792 registry
= build_string (buffer
);
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. */
4808 font_scalable_p (font
)
4809 struct font_name
*font
;
4811 char *s
= font
->fields
[XLFD_AVGWIDTH
];
4812 return (*s
== '0' && *(s
+ 1) == '\0') || *s
== '*';
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
4822 better_font_p (values
, font1
, font2
, compare_pt_p
)
4824 struct font_name
*font1
, *font2
;
4829 for (i
= 0; i
< 4; ++i
)
4831 int xlfd_idx
= font_sort_order
[i
];
4833 if (compare_pt_p
|| xlfd_idx
!= XLFD_POINT_SIZE
)
4835 int delta1
= abs (values
[i
] - font1
->numeric
[xlfd_idx
]);
4836 int delta2
= abs (values
[i
] - font2
->numeric
[xlfd_idx
]);
4838 if (delta1
> delta2
)
4840 else if (delta1
< delta2
)
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
])
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
4866 exact_face_match_p (specified
, font
)
4868 struct font_name
*font
;
4872 for (i
= 0; i
< 4; ++i
)
4873 if (specified
[i
] != font
->numeric
[font_sort_order
[i
]])
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. */
4885 build_scalable_font_name (f
, font
, specified_pt
)
4887 struct font_name
*font
;
4890 char point_size
[20], pixel_size
[20];
4892 double resy
= FRAME_W32_DISPLAY_INFO (f
)->resy
;
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)
4900 pt
= resy
/ font
->numeric
[XLFD_RESY
] * specified_pt
+ 0.5;
4901 pixel_value
= font
->numeric
[XLFD_RESY
] / 720.0 * pt
;
4906 pixel_value
= resy
/ 720.0 * pt
;
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
;
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
;
4919 /* If font doesn't specify its resolution, use the
4920 resolution of the display. */
4921 if (font
->numeric
[XLFD_RESY
] == 0)
4924 sprintf (buffer
, "%d", (int) resy
);
4925 font
->fields
[XLFD_RESY
] = buffer
;
4926 font
->numeric
[XLFD_RESY
] = resy
;
4929 if (strcmp (font
->fields
[XLFD_RESX
], "0") == 0)
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
;
4938 return build_font_name (font
);
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. */
4947 may_use_scalable_font_p (font
, name
)
4948 struct font_name
*font
;
4951 if (EQ (Vscalable_fonts_allowed
, Qt
))
4953 else if (CONSP (Vscalable_fonts_allowed
))
4955 Lisp_Object tail
, regexp
;
4957 for (tail
= Vscalable_fonts_allowed
; CONSP (tail
); tail
= XCDR (tail
))
4959 regexp
= XCAR (tail
);
4960 if (STRINGP (regexp
)
4961 && fast_c_string_match_ignore_case (regexp
, name
) >= 0)
4969 #endif /* SCALABLE_FONTS != 0 */
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. */
4978 best_matching_font (f
, attrs
, fonts
, nfonts
)
4981 struct font_name
*fonts
;
4985 struct font_name
*best
;
4993 /* Make specified font attributes available in `specified',
4994 indexed by sort order. */
4995 for (i
= 0; i
< DIM (font_sort_order
); ++i
)
4997 int xlfd_idx
= font_sort_order
[i
];
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
]);
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
))
5021 /* Find the best match among the non-scalable fonts. */
5026 for (i
= 1; i
< nfonts
; ++i
)
5027 if (!font_scalable_p (fonts
+ i
)
5028 && better_font_p (specified
, fonts
+ i
, best
, 1))
5032 exact_p
= exact_face_match_p (specified
, best
);
5041 /* Unless we found an exact match among non-scalable fonts, see if
5042 we can find a better match among scalable fonts. */
5045 /* A scalable font is better if
5047 1. its weight, slant, swidth attributes are better, or.
5049 2. the best non-scalable font doesn't have the required
5050 point size, and the scalable fonts weight, slant, swidth
5053 int non_scalable_has_exact_height_p
;
5055 if (best
&& best
->numeric
[XLFD_POINT_SIZE
] == pt
)
5056 non_scalable_has_exact_height_p
= 1;
5058 non_scalable_has_exact_height_p
= 0;
5060 for (i
= 0; i
< nfonts
; ++i
)
5061 if (font_scalable_p (fonts
+ i
))
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)))
5071 if (font_scalable_p (best
))
5072 font_name
= build_scalable_font_name (f
, best
, pt
);
5074 font_name
= build_font_name (best
);
5076 #else /* !SCALABLE_FONTS */
5078 /* Find the best non-scalable font. */
5081 for (i
= 1; i
< nfonts
; ++i
)
5083 xassert (!font_scalable_p (fonts
+ i
));
5084 if (better_font_p (specified
, fonts
+ i
, best
, 1))
5088 font_name
= build_font_name (best
);
5090 #endif /* !SCALABLE_FONTS */
5092 /* Free font_name structures. */
5093 free_font_names (fonts
, nfonts
);
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
5105 try_font_list (f
, attrs
, pattern
, family
, registry
, fonts
)
5108 char *pattern
, *family
, *registry
;
5109 struct font_name
**fonts
;
5114 family
= LSTRDUPA (attrs
[LFACE_FAMILY_INDEX
]);
5116 nfonts
= font_list (f
, pattern
, family
, registry
, fonts
);
5122 /* Try alternative font families from
5123 Vface_alternative_font_family_alist. */
5124 alter
= Fassoc (build_string (family
),
5125 Vface_alternative_font_family_alist
);
5127 for (alter
= XCDR (alter
);
5128 CONSP (alter
) && nfonts
== 0;
5129 alter
= XCDR (alter
))
5131 if (STRINGP (XCAR (alter
)))
5133 family
= LSTRDUPA (XCAR (alter
));
5134 nfonts
= font_list (f
, NULL
, family
, registry
, fonts
);
5138 /* Try font family of the default face or "fixed". */
5141 struct face
*dflt
= FACE_FROM_ID (f
, DEFAULT_FACE_ID
);
5143 family
= LSTRDUPA (dflt
->lface
[LFACE_FAMILY_INDEX
]);
5146 nfonts
= font_list (f
, NULL
, family
, registry
, fonts
);
5149 /* Try any family with the given registry. */
5151 nfonts
= font_list (f
, NULL
, "*", registry
, fonts
);
5158 /* Return the registry and encoding pattern that fonts for CHARSET
5159 should match. Value is allocated from the heap. */
5162 x_charset_registry (charset
)
5165 Lisp_Object prop
, charset_plist
;
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
);
5174 if (index (XSTRING (prop
)->data
, '-'))
5175 registry
= xstrdup (XSTRING (prop
)->data
);
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
, "*-*");
5184 else if (STRINGP (Vface_default_registry
))
5185 registry
= xstrdup (XSTRING (Vface_default_registry
)->data
);
5187 registry
= xstrdup ("iso8859-1");
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. */
5198 face_fontset (f
, attrs
)
5202 Lisp_Object name
= attrs
[LFACE_FAMILY_INDEX
];
5205 name
= Fquery_fontset (name
, Qnil
);
5209 fontset
= fs_query_fontset (f
, XSTRING (name
)->data
);
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). */
5222 choose_face_font (f
, attrs
, charset
, unibyte_registry
)
5226 Lisp_Object unibyte_registry
;
5228 struct font_name
*fonts
;
5232 /* ATTRS must be fully-specified. */
5233 xassert (lface_fully_specified_p (attrs
));
5235 if (STRINGP (unibyte_registry
))
5236 registry
= xstrdup (XSTRING (unibyte_registry
)->data
);
5238 registry
= x_charset_registry (charset
);
5240 nfonts
= try_font_list (f
, attrs
, NULL
, NULL
, registry
, &fonts
);
5242 return best_matching_font (f
, attrs
, fonts
, nfonts
);
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. */
5254 choose_face_fontset_font (f
, attrs
, fontset
, charset
)
5257 int fontset
, charset
;
5260 char *font_name
= NULL
;
5261 struct fontset_info
*fontset_info
;
5262 struct font_name
*fonts
;
5265 xassert (fontset
>= 0 && fontset
< FRAME_FONTSET_DATA (f
)->n_fontsets
);
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
5271 charset
= CHARSET_ASCII
;
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
];
5277 pattern
= fontset_info
->fontname
[CHARSET_ASCII
];
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
);
5287 #endif /* HAVE_WINDOW_SYSTEM */
5291 /***********************************************************************
5293 ***********************************************************************/
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
5300 realize_basic_faces (f
)
5305 if (realize_default_face (f
))
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
);
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. */
5328 realize_default_face (f
)
5331 struct face_cache
*c
= FRAME_FACE_CACHE (f
);
5333 Lisp_Object attrs
[LFACE_VECTOR_SIZE
];
5334 Lisp_Object unibyte_registry
;
5335 Lisp_Object frame_font
;
5339 /* If the `default' face is not yet known, create it. */
5340 lface
= lface_from_face_name (f
, Qdefault
, 0);
5344 XSETFRAME (frame
, f
);
5345 lface
= Finternal_make_lisp_face (Qdefault
, frame
);
5348 #ifdef HAVE_WINDOW_SYSTEM
5349 if (FRAME_WINDOW_P (f
))
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
);
5356 fontset
= fs_query_fontset (f
, XSTRING (frame_font
)->data
);
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
;
5367 font_info
= FS_LOAD_FONT (f
, FRAME_W32_FONT_TABLE (f
), CHARSET_ASCII
,
5371 /* Set weight etc. from the ASCII font. */
5372 if (!set_lface_from_font_name (f
, lface
, font_info
->full_name
, 0, 0))
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
;
5380 Vface_default_registry
= build_string ("iso8859-1");
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
);
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
;
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))
5403 /* Remember registry and encoding of the frame font. */
5405 = deduce_unibyte_registry (f
, XSTRING (frame_font
)->data
);
5406 if (STRINGP (unibyte_registry
))
5407 Vface_default_registry
= unibyte_registry
;
5409 Vface_default_registry
= build_string ("iso8859-1");
5412 #endif /* HAVE_WINDOW_SYSTEM */
5414 if (!FRAME_WINDOW_P (f
))
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
;
5423 if (UNSPECIFIEDP (LFACE_UNDERLINE (lface
)))
5424 LFACE_UNDERLINE (lface
) = Qnil
;
5426 if (UNSPECIFIEDP (LFACE_OVERLINE (lface
)))
5427 LFACE_OVERLINE (lface
) = Qnil
;
5429 if (UNSPECIFIEDP (LFACE_STRIKE_THROUGH (lface
)))
5430 LFACE_STRIKE_THROUGH (lface
) = Qnil
;
5432 if (UNSPECIFIEDP (LFACE_BOX (lface
)))
5433 LFACE_BOX (lface
) = Qnil
;
5435 if (UNSPECIFIEDP (LFACE_INVERSE (lface
)))
5436 LFACE_INVERSE (lface
) = Qnil
;
5438 if (UNSPECIFIEDP (LFACE_FOREGROUND (lface
)))
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
);
5444 if (CONSP (color
) && STRINGP (XCDR (color
)))
5445 LFACE_FOREGROUND (lface
) = XCDR (color
);
5446 else if (FRAME_WINDOW_P (f
))
5448 else if (FRAME_TERMCAP_P (f
) || FRAME_MSDOS_P (f
))
5449 LFACE_FOREGROUND (lface
) = build_string (unspecified_fg
);
5454 if (UNSPECIFIEDP (LFACE_BACKGROUND (lface
)))
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
))
5463 else if (FRAME_TERMCAP_P (f
) || FRAME_MSDOS_P (f
))
5464 LFACE_BACKGROUND (lface
) = build_string (unspecified_bg
);
5469 if (UNSPECIFIEDP (LFACE_STIPPLE (lface
)))
5470 LFACE_STIPPLE (lface
) = Qnil
;
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
);
5478 /* Remove the former default face. */
5479 if (c
->used
> DEFAULT_FACE_ID
)
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
);
5486 /* Insert the new default face. */
5487 cache_face (c
, face
, lface_hash (attrs
));
5488 xassert (face
->id
== DEFAULT_FACE_ID
);
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. */
5498 realize_named_face (f
, symbol
, id
)
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
;
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
));
5514 /* If SYMBOL isn't know as a face, create it. */
5518 XSETFRAME (frame
, f
);
5519 lface
= Finternal_make_lisp_face (symbol
, frame
);
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
);
5526 /* Realize the face. */
5527 new_face
= realize_face (c
, attrs
, CHARSET_ASCII
);
5529 /* Remove the former face. */
5532 struct face
*old_face
= c
->faces_by_id
[id
];
5533 uncache_face (c
, old_face
);
5534 free_realized_face (f
, old_face
);
5537 /* Insert the new face. */
5538 cache_face (c
, new_face
, lface_hash (attrs
));
5539 xassert (new_face
->id
== id
);
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. */
5547 static struct face
*
5548 realize_face (c
, attrs
, charset
)
5549 struct face_cache
*c
;
5555 /* LFACE must be fully specified. */
5556 xassert (c
!= NULL
);
5557 check_lface_attrs (attrs
);
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
);
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. */
5575 static struct face
*
5576 realize_x_face (c
, attrs
, charset
)
5577 struct face_cache
*c
;
5581 #ifdef HAVE_WINDOW_SYSTEM
5582 struct face
*face
, *default_face
;
5584 Lisp_Object stipple
, overline
, strike_through
, box
;
5585 Lisp_Object unibyte_registry
;
5586 struct gcpro gcpro1
;
5588 xassert (FRAME_WINDOW_P (c
->f
));
5590 /* If realizing a face for use in unibyte text, get the X registry
5591 and encoding to use from Vface_default_registry. */
5593 unibyte_registry
= (STRINGP (Vface_default_registry
)
5594 ? Vface_default_registry
5595 : build_string ("iso8859-1"));
5597 unibyte_registry
= Qnil
;
5598 GCPRO1 (unibyte_registry
);
5600 /* Allocate a new realized face. */
5601 face
= make_realized_face (attrs
, charset
, unibyte_registry
);
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
);
5608 && FACE_SUITABLE_FOR_CHARSET_P (default_face
, charset
)
5609 && lface_same_font_attributes_p (default_face
->lface
, attrs
))
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
;
5617 else if (charset
>= 0)
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. */
5625 char *font_name
= NULL
;
5626 int fontset
= face_fontset (f
, attrs
);
5629 font_name
= choose_face_font (f
, attrs
, charset
, Qnil
);
5632 font_name
= choose_face_fontset_font (f
, attrs
, fontset
, charset
);
5636 load_face_font_or_fontset (f
, face
, font_name
, fontset
);
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
5649 char *font_name
= NULL
;
5650 int fontset
= face_fontset (f
, attrs
);
5653 font_name
= choose_face_font (f
, attrs
, charset
, unibyte_registry
);
5655 font_name
= choose_face_fontset_font (f
, attrs
, fontset
, charset
);
5657 load_face_font_or_fontset (f
, face
, font_name
, -1);
5661 /* Load colors, and set remaining attributes. */
5663 load_face_colors (f
, face
, attrs
);
5666 box
= attrs
[LFACE_BOX_INDEX
];
5669 /* A simple box of line width 1 drawn in color given by
5671 face
->box_color
= load_color (f
, face
, attrs
[LFACE_BOX_INDEX
],
5673 face
->box
= FACE_SIMPLE_BOX
;
5674 face
->box_line_width
= 1;
5676 else if (INTEGERP (box
))
5678 /* Simple box of specified line width in foreground color of the
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;
5686 else if (CONSP (box
))
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;
5697 Lisp_Object keyword
, value
;
5699 keyword
= XCAR (box
);
5707 if (EQ (keyword
, QCline_width
))
5709 if (INTEGERP (value
) && XINT (value
) > 0)
5710 face
->box_line_width
= XFASTINT (value
);
5712 else if (EQ (keyword
, QCcolor
))
5714 if (STRINGP (value
))
5716 face
->box_color
= load_color (f
, face
, value
,
5718 face
->use_box_color_for_shadows_p
= 1;
5721 else if (EQ (keyword
, QCstyle
))
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
;
5731 /* Text underline, overline, strike-through. */
5733 if (EQ (attrs
[LFACE_UNDERLINE_INDEX
], Qt
))
5735 /* Use default color (same as foreground color). */
5736 face
->underline_p
= 1;
5737 face
->underline_defaulted_p
= 1;
5738 face
->underline_color
= 0;
5740 else if (STRINGP (attrs
[LFACE_UNDERLINE_INDEX
]))
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
);
5749 else if (NILP (attrs
[LFACE_UNDERLINE_INDEX
]))
5751 face
->underline_p
= 0;
5752 face
->underline_defaulted_p
= 0;
5753 face
->underline_color
= 0;
5756 overline
= attrs
[LFACE_OVERLINE_INDEX
];
5757 if (STRINGP (overline
))
5759 face
->overline_color
5760 = load_color (f
, face
, attrs
[LFACE_OVERLINE_INDEX
],
5761 LFACE_OVERLINE_INDEX
);
5762 face
->overline_p
= 1;
5764 else if (EQ (overline
, Qt
))
5766 face
->overline_color
= face
->foreground
;
5767 face
->overline_color_defaulted_p
= 1;
5768 face
->overline_p
= 1;
5771 strike_through
= attrs
[LFACE_STRIKE_THROUGH_INDEX
];
5772 if (STRINGP (strike_through
))
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;
5779 else if (EQ (strike_through
, Qt
))
5781 face
->strike_through_color
= face
->foreground
;
5782 face
->strike_through_color_defaulted_p
= 1;
5783 face
->strike_through_p
= 1;
5786 stipple
= attrs
[LFACE_STIPPLE_INDEX
];
5787 if (!NILP (stipple
))
5788 face
->stipple
= load_pixmap (f
, stipple
, &face
->pixmap_w
, &face
->pixmap_h
);
5791 xassert (face
->fontset
< 0);
5792 xassert (FACE_SUITABLE_FOR_CHARSET_P (face
, charset
));
5794 #endif /* HAVE_WINDOW_SYSTEM */
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. */
5803 static struct face
*
5804 realize_tty_face (c
, attrs
, charset
)
5805 struct face_cache
*c
;
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");
5816 int face_colors_defaulted
= 0;
5818 /* Frame must be a termcap frame. */
5819 xassert (FRAME_TERMCAP_P (c
->f
) || FRAME_MSDOS_P (c
->f
));
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";
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
]);
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;
5840 /* Map color names to color indices. */
5841 face
->foreground
= FACE_TTY_DEFAULT_FG_COLOR
;
5842 face
->background
= FACE_TTY_DEFAULT_BG_COLOR
;
5844 XSETFRAME (frame
, c
->f
);
5845 color
= attrs
[LFACE_FOREGROUND_INDEX
];
5847 && XSTRING (color
)->size
5848 && !NILP (tty_defined_color_alist
)
5849 && (color
= Fassoc (color
, call1 (tty_color_alist
, frame
)),
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
)));
5855 if (face
->foreground
== FACE_TTY_DEFAULT_FG_COLOR
5856 && STRINGP (attrs
[LFACE_FOREGROUND_INDEX
]))
5858 face
->foreground
= load_color (c
->f
, face
,
5859 attrs
[LFACE_FOREGROUND_INDEX
],
5860 LFACE_FOREGROUND_INDEX
);
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. */
5866 if (FRAME_MSDOS_P (c
->f
))
5870 if (face
->foreground
== FACE_TTY_DEFAULT_FG_COLOR
5871 || face
->foreground
== FACE_TTY_DEFAULT_COLOR
)
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;
5878 else if (face
->foreground
== FACE_TTY_DEFAULT_BG_COLOR
)
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;
5888 #endif /* MSDOS or WINDOWSNT */
5891 color
= attrs
[LFACE_BACKGROUND_INDEX
];
5893 && XSTRING (color
)->size
5894 && !NILP (tty_defined_color_alist
)
5895 && (color
= Fassoc (color
, call1 (tty_color_alist
, frame
)),
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
)));
5901 if (face
->background
== FACE_TTY_DEFAULT_BG_COLOR
5902 && STRINGP (attrs
[LFACE_BACKGROUND_INDEX
]))
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. */
5911 if (FRAME_MSDOS_P (c
->f
))
5915 if (face
->background
== FACE_TTY_DEFAULT_BG_COLOR
5916 || face
->background
== FACE_TTY_DEFAULT_COLOR
)
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;
5923 else if (face
->background
== FACE_TTY_DEFAULT_FG_COLOR
)
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;
5933 #endif /* MSDOS or WINDOWSNT */
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
)
5941 unsigned long tem
= face
->foreground
;
5943 face
->foreground
= face
->background
;
5944 face
->background
= tem
;
5952 /***********************************************************************
5954 ***********************************************************************/
5956 /* Return the ID of the face to use to display character CH with face
5957 property PROP on frame F in current_buffer. */
5960 compute_char_face (f
, ch
, prop
)
5966 int charset
= (NILP (current_buffer
->enable_multibyte_characters
)
5968 : CHAR_CHARSET (ch
));
5971 face_id
= FACE_FOR_CHARSET (f
, DEFAULT_FACE_ID
, charset
);
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
);
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.
5990 REGION_BEG, REGION_END delimit the region, so it can be
5993 LIMIT is a position not to scan beyond. That is to limit the time
5994 this function can take.
5996 If MOUSE is non-zero, use the character's mouse-face, not its face.
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. */
6003 face_at_buffer_position (w
, pos
, region_beg
, region_end
,
6004 endptr
, limit
, mouse
)
6007 int region_beg
, region_end
;
6012 struct frame
*f
= XFRAME (w
->frame
);
6013 Lisp_Object attrs
[LFACE_VECTOR_SIZE
];
6014 Lisp_Object prop
, position
;
6016 Lisp_Object
*overlay_vec
;
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
);
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); */
6028 XSETFRAME (frame
, f
);
6029 XSETFASTINT (position
, pos
);
6032 if (pos
< region_beg
&& region_beg
< endpos
)
6033 endpos
= region_beg
;
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
);
6041 endpos
= XINT (end
);
6043 /* Look at properties from overlays. */
6048 /* First try with room for 40 overlays. */
6050 overlay_vec
= (Lisp_Object
*) alloca (len
* sizeof (Lisp_Object
));
6051 noverlays
= overlays_at (pos
, 0, &overlay_vec
, &len
,
6052 &next_overlay
, NULL
);
6054 /* If there are more than 40, make enough space for all, and try
6056 if (noverlays
> len
)
6059 overlay_vec
= (Lisp_Object
*) alloca (len
* sizeof (Lisp_Object
));
6060 noverlays
= overlays_at (pos
, 0, &overlay_vec
, &len
,
6061 &next_overlay
, NULL
);
6064 if (next_overlay
< endpos
)
6065 endpos
= next_overlay
;
6070 default_face
= FACE_FROM_ID (f
, DEFAULT_FACE_ID
);
6072 /* Optimize common cases where we can use the default face. */
6075 && !(pos
>= region_beg
&& pos
< region_end
)
6077 || !FRAME_WINDOW_P (f
)
6078 || FACE_SUITABLE_FOR_CHARSET_P (default_face
, -1)))
6079 return DEFAULT_FACE_ID
;
6081 /* Begin with attributes from the default face. */
6082 bcopy (default_face
->lface
, attrs
, sizeof attrs
);
6084 /* Merge in attributes specified via text properties. */
6086 merge_face_vector_with_property (f
, attrs
, prop
);
6088 /* Now merge the overlay data. */
6089 noverlays
= sort_overlays (overlay_vec
, noverlays
, w
);
6090 for (i
= 0; i
< noverlays
; i
++)
6095 prop
= Foverlay_get (overlay_vec
[i
], propname
);
6097 merge_face_vector_with_property (f
, attrs
, prop
);
6099 oend
= OVERLAY_END (overlay_vec
[i
]);
6100 oendpos
= OVERLAY_POSITION (oend
);
6101 if (oendpos
< endpos
)
6105 /* If in the region, merge in the region face. */
6106 if (pos
>= region_beg
&& pos
< region_end
)
6108 Lisp_Object region_face
= lface_from_face_name (f
, Qregion
, 0);
6109 merge_face_vectors (XVECTOR (region_face
)->contents
, attrs
);
6111 if (region_end
< endpos
)
6112 endpos
= region_end
;
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);
6123 /* Compute the face at character position POS in Lisp string STRING on
6124 window W, for charset CHARSET_ASCII.
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.
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
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. */
6144 face_at_string_position (w
, string
, pos
, bufpos
, region_beg
,
6145 region_end
, endptr
, base_face_id
)
6149 int region_beg
, region_end
;
6151 enum face_id base_face_id
;
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
);
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
);
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
);
6173 *endptr
= XFASTINT (end
);
6177 base_face
= FACE_FROM_ID (f
, base_face_id
);
6178 xassert (base_face
);
6180 /* Optimize the default case that there is no face property and we
6181 are not in the region. */
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. */
6187 || bufpos
< region_beg
6188 || bufpos
>= region_end
)
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
;
6197 /* Begin with attributes from the base face. */
6198 bcopy (base_face
->lface
, attrs
, sizeof attrs
);
6200 /* Merge in attributes specified via text properties. */
6202 merge_face_vector_with_property (f
, attrs
, prop
);
6204 /* If in the region, merge in the region face. */
6206 && bufpos
>= region_beg
6207 && bufpos
< region_end
)
6209 Lisp_Object region_face
= lface_from_face_name (f
, Qregion
, 0);
6210 merge_face_vectors (XVECTOR (region_face
)->contents
, attrs
);
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);
6220 /***********************************************************************
6222 ***********************************************************************/
6226 /* Print the contents of the realized face FACE to stderr. */
6229 dump_realized_face (face
)
6232 fprintf (stderr
, "ID: %d\n", face
->id
);
6233 #ifdef HAVE_WINDOW_SYSTEM
6234 fprintf (stderr
, "gc: %d\n", (int) face
->gc
);
6236 fprintf (stderr
, "foreground: 0x%lx (%s)\n",
6238 XSTRING (face
->lface
[LFACE_FOREGROUND_INDEX
])->data
);
6239 fprintf (stderr
, "background: 0x%lx (%s)\n",
6241 XSTRING (face
->lface
[LFACE_BACKGROUND_INDEX
])->data
);
6242 fprintf (stderr
, "font_name: %s (%s)\n",
6244 XSTRING (face
->lface
[LFACE_FAMILY_INDEX
])->data
);
6245 #ifdef HAVE_WINDOW_SYSTEM
6246 fprintf (stderr
, "font = %p\n", face
->font
);
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",
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
);
6258 DEFUN ("dump-face", Fdump_face
, Sdump_face
, 0, 1, 0, "")
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");
6271 fprintf (stderr
, "alternative fonts: ");
6272 debug_print (Vface_alternative_font_family_alist
);
6273 fprintf (stderr
, "\n");
6275 for (i
= 0; i
< FRAME_FACE_CACHE (SELECTED_FRAME ())->used
; ++i
)
6276 Fdump_face (make_number (i
));
6281 CHECK_NUMBER (n
, 0);
6282 face
= FACE_FROM_ID (SELECTED_FRAME (), XINT (n
));
6284 error ("Not a valid face");
6285 dump_realized_face (face
);
6292 DEFUN ("show-face-resources", Fshow_face_resources
, Sshow_face_resources
,
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
);
6302 #endif /* GLYPH_DEBUG != 0 */
6306 /***********************************************************************
6308 ***********************************************************************/
6313 Qface
= intern ("face");
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
);
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");
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");
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
);
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");
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
);
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
);
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
);
6464 defsubr (&Sdump_face
);
6465 defsubr (&Sshow_face_resources
);
6466 #endif /* GLYPH_DEBUG */
6467 defsubr (&Sclear_face_cache
);
6469 DEFVAR_LISP ("font-list-limit", &Vfont_list_limit
,
6470 "*Limit for font matching.\n\
6471 If an integer > 0, font matching functions won't load more than\n\
6472 that number of fonts when searching for a matching font.");
6473 Vfont_list_limit
= make_number (DEFAULT_FONT_LIST_LIMIT
);
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
;
6479 DEFVAR_LISP ("face-default-stipple", &Vface_default_stipple
,
6480 "*Default stipple pattern used on monochrome displays.\n\
6481 This stipple pattern is used on monochrome displays\n\
6482 instead of shades of gray for a face background color.\n\
6483 See `set-face-stipple' for possible values for this variable.");
6484 Vface_default_stipple
= build_string ("gray3");
6486 DEFVAR_LISP ("face-default-registry", &Vface_default_registry
,
6487 "Default registry and encoding to use.\n\
6488 This registry and encoding is used for unibyte text. It is set up\n\
6489 from the specified frame font when Emacs starts. (For internal use only.)");
6490 Vface_default_registry
= Qnil
;
6492 DEFVAR_LISP ("face-alternative-font-family-alist",
6493 &Vface_alternative_font_family_alist
, "");
6494 Vface_alternative_font_family_alist
= Qnil
;
6498 DEFVAR_LISP ("scalable-fonts-allowed", &Vscalable_fonts_allowed
,
6499 "Allowed scalable fonts.\n\
6500 A value of nil means don't allow any scalable fonts.\n\
6501 A value of t means allow any scalable font.\n\
6502 Otherwise, value must be a list of regular expressions. A font may be\n\
6503 scaled if its name matches a regular expression in the list.");
6504 Vscalable_fonts_allowed
= Qt
;
6506 #endif /* SCALABLE_FONTS */
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 */