1 /* font.c -- "Font" primitives.
2 Copyright (C) 2006, 2007, 2008 Free Software Foundation, Inc.
3 Copyright (C) 2006, 2007, 2008
4 National Institute of Advanced Industrial Science and Technology (AIST)
5 Registration Number H13PRO009
7 This file is part of GNU Emacs.
9 GNU Emacs is free software; you can redistribute it and/or modify
10 it under the terms of the GNU General Public License as published by
11 the Free Software Foundation; either version 3, or (at your option)
14 GNU Emacs is distributed in the hope that it will be useful,
15 but WITHOUT ANY WARRANTY; without even the implied warranty of
16 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
17 GNU General Public License for more details.
19 You should have received a copy of the GNU General Public License
20 along with GNU Emacs; see the file COPYING. If not, write to
21 the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
22 Boston, MA 02110-1301, USA. */
36 #include "dispextern.h"
38 #include "character.h"
39 #include "composite.h"
49 #define xassert(X) do {if (!(X)) abort ();} while (0)
51 #define xassert(X) (void) 0
54 int enable_font_backend
;
56 Lisp_Object Qopentype
;
58 /* Important character set symbols. */
59 Lisp_Object Qiso8859_1
, Qiso10646_1
, Qunicode_bmp
, Qunicode_sip
;
61 /* Like CHECK_FONT_SPEC but also validate properties of the font-spec,
62 and set X to the validated result. */
64 #define CHECK_VALIDATE_FONT_SPEC(x) \
66 if (! FONT_SPEC_P (x)) x = wrong_type_argument (Qfont, x); \
67 x = font_prop_validate (x); \
70 /* Number of pt per inch (from the TeXbook). */
71 #define PT_PER_INCH 72.27
73 /* Return a pixel size (integer) corresponding to POINT size (double)
75 #define POINT_TO_PIXEL(POINT, DPI) ((POINT) * (DPI) / PT_PER_INCH + 0.5)
77 /* Return a point size (double) corresponding to POINT size (integer)
79 #define PIXEL_TO_POINT(PIXEL, DPI) ((PIXEL) * PT_PER_INCH * 10 / (DPI) + 0.5)
81 /* Special string of zero length. It is used to specify a NULL name
82 in a font properties (e.g. adstyle). We don't use the symbol of
83 NULL name because it's confusing (Lisp printer prints nothing for
85 Lisp_Object null_string
;
87 /* Special vector of zero length. This is repeatedly used by (struct
88 font_driver *)->list when a specified font is not found. */
89 Lisp_Object null_vector
;
91 /* Vector of 3 elements. Each element is an alist for one of font
92 style properties (weight, slant, width). Each alist contains a
93 mapping between symbolic property values (e.g. `medium' for weight)
94 and numeric property values (e.g. 100). So, it looks like this:
95 [((thin . 0) ... (heavy . 210))
96 ((ro . 0) ... (ot . 210))
97 ((ultracondensed . 50) ... (wide . 200))] */
98 static Lisp_Object font_style_table
;
100 /* Alist of font family vs the corresponding aliases.
101 Each element has this form:
102 (FAMILY ALIAS1 ALIAS2 ...) */
104 static Lisp_Object font_family_alist
;
106 /* Symbols representing keys of normal font properties. */
107 extern Lisp_Object QCtype
, QCfamily
, QCweight
, QCslant
, QCwidth
, QCsize
, QCname
;
108 Lisp_Object QCfoundry
, QCadstyle
, QCregistry
, QCextra
;
109 /* Symbols representing keys of font extra info. */
110 Lisp_Object QCspacing
, QCdpi
, QCscalable
, QCotf
, QClanguage
, QCscript
;
111 Lisp_Object QCantialias
;
112 /* Symbols representing values of font spacing property. */
113 Lisp_Object Qc
, Qm
, Qp
, Qd
;
115 /* Alist of font registry symbol and the corresponding charsets
116 information. The information is retrieved from
117 Vfont_encoding_alist on demand.
119 Eash element has the form:
120 (REGISTRY . (ENCODING-CHARSET-ID . REPERTORY-CHARSET-ID))
124 In the former form, ENCODING-CHARSET-ID is an ID of a charset that
125 encodes a character code to a glyph code of a font, and
126 REPERTORY-CHARSET-ID is an ID of a charset that tells if a
127 character is supported by a font.
129 The latter form means that the information for REGISTRY couldn't be
131 static Lisp_Object font_charset_alist
;
133 /* List of all font drivers. Each font-backend (XXXfont.c) calls
134 register_font_driver in syms_of_XXXfont to register its font-driver
136 static struct font_driver_list
*font_driver_list
;
138 static int font_pixel_size
P_ ((FRAME_PTR f
, Lisp_Object
));
139 static Lisp_Object prop_name_to_numeric
P_ ((enum font_property_index
,
141 static Lisp_Object prop_numeric_to_name
P_ ((enum font_property_index
, int));
142 static Lisp_Object font_open_entity
P_ ((FRAME_PTR
, Lisp_Object
, int));
143 static void build_font_family_alist
P_ ((void));
145 /* Number of registered font drivers. */
146 static int num_font_drivers
;
148 /* Return a pixel size of font-spec SPEC on frame F. */
151 font_pixel_size (f
, spec
)
155 Lisp_Object size
= AREF (spec
, FONT_SIZE_INDEX
);
158 Lisp_Object extra
, val
;
164 point_size
= XFLOAT_DATA (size
);
165 extra
= AREF (spec
, FONT_EXTRA_INDEX
);
166 val
= assq_no_quit (QCdpi
, extra
);
169 if (INTEGERP (XCDR (val
)))
170 dpi
= XINT (XCDR (val
));
172 dpi
= XFLOAT_DATA (XCDR (val
)) + 0.5;
176 pixel_size
= POINT_TO_PIXEL (point_size
, dpi
);
180 /* Return a numeric value corresponding to PROP's NAME (symbol). If
181 NAME is not registered in font_style_table, return Qnil. PROP must
182 be one of FONT_{WEIGHT|SLANT|SWIDTH}_INDEX. */
185 prop_name_to_numeric (prop
, name
)
186 enum font_property_index prop
;
189 int table_index
= prop
- FONT_WEIGHT_INDEX
;
192 val
= assq_no_quit (name
, AREF (font_style_table
, table_index
));
193 return (NILP (val
) ? Qnil
: XCDR (val
));
197 /* Return a name (symbol) corresponding to PROP's NUMERIC value. If
198 no name is registered for NUMERIC in font_style_table, return a
199 symbol of integer name (e.g. `123'). PROP must be one of
200 FONT_{WEIGHT|SLANT|SWIDTH}_INDEX. */
203 prop_numeric_to_name (prop
, numeric
)
204 enum font_property_index prop
;
207 int table_index
= prop
- FONT_WEIGHT_INDEX
;
208 Lisp_Object table
= AREF (font_style_table
, table_index
);
211 while (! NILP (table
))
213 if (XINT (XCDR (XCAR (table
))) >= numeric
)
215 if (XINT (XCDR (XCAR (table
))) == numeric
)
216 return XCAR (XCAR (table
));
220 table
= XCDR (table
);
222 sprintf (buf
, "%d", numeric
);
227 /* Return a symbol whose name is STR (length LEN). If STR contains
228 uppercase letters, downcase them in advance. */
231 intern_downcase (str
, len
)
238 for (i
= 0; i
< len
; i
++)
239 if (isupper (str
[i
]))
242 return Fintern (make_unibyte_string (str
, len
), Qnil
);
245 return Fintern (null_string
, Qnil
);
246 bcopy (str
, buf
, len
);
248 if (isascii (buf
[i
]))
249 buf
[i
] = tolower (buf
[i
]);
250 return Fintern (make_unibyte_string (buf
, len
), Qnil
);
253 extern Lisp_Object Vface_alternative_font_family_alist
;
255 /* Setup font_family_alist of the form:
256 ((FAMILY-SYMBOL ALIAS-SYMBOL ...) ...)
257 from Vface_alternative_font_family_alist of the form:
258 ((FAMILY-STRING ALIAS-STRING ...) ...) */
261 build_font_family_alist ()
263 Lisp_Object alist
= Vface_alternative_font_family_alist
;
265 for (; CONSP (alist
); alist
= XCDR (alist
))
267 Lisp_Object tail
, elt
;
269 for (tail
= XCAR (alist
), elt
= Qnil
; CONSP (tail
); tail
= XCDR (tail
))
270 elt
= nconc2 (elt
, Fcons (Fintern (XCAR (tail
), Qnil
), Qnil
));
271 font_family_alist
= Fcons (elt
, font_family_alist
);
275 extern Lisp_Object find_font_encoding
P_ ((Lisp_Object
));
277 /* Return encoding charset and repertory charset for REGISTRY in
278 ENCODING and REPERTORY correspondingly. If correct information for
279 REGISTRY is available, return 0. Otherwise return -1. */
282 font_registry_charsets (registry
, encoding
, repertory
)
283 Lisp_Object registry
;
284 struct charset
**encoding
, **repertory
;
287 int encoding_id
, repertory_id
;
289 val
= assq_no_quit (registry
, font_charset_alist
);
295 encoding_id
= XINT (XCAR (val
));
296 repertory_id
= XINT (XCDR (val
));
300 val
= find_font_encoding (SYMBOL_NAME (registry
));
301 if (SYMBOLP (val
) && CHARSETP (val
))
303 encoding_id
= repertory_id
= XINT (CHARSET_SYMBOL_ID (val
));
305 else if (CONSP (val
))
307 if (! CHARSETP (XCAR (val
)))
309 encoding_id
= XINT (CHARSET_SYMBOL_ID (XCAR (val
)));
310 if (NILP (XCDR (val
)))
314 if (! CHARSETP (XCDR (val
)))
316 repertory_id
= XINT (CHARSET_SYMBOL_ID (XCDR (val
)));
321 val
= Fcons (make_number (encoding_id
), make_number (repertory_id
));
323 = nconc2 (font_charset_alist
, Fcons (Fcons (registry
, val
), Qnil
));
327 *encoding
= CHARSET_FROM_ID (encoding_id
);
329 *repertory
= repertory_id
>= 0 ? CHARSET_FROM_ID (repertory_id
) : NULL
;
334 = nconc2 (font_charset_alist
, Fcons (Fcons (registry
, Qnil
), Qnil
));
339 /* Font property value validaters. See the comment of
340 font_property_table for the meaning of the arguments. */
342 static Lisp_Object font_prop_validate_symbol
P_ ((Lisp_Object
, Lisp_Object
));
343 static Lisp_Object font_prop_validate_style
P_ ((Lisp_Object
, Lisp_Object
));
344 static Lisp_Object font_prop_validate_non_neg
P_ ((Lisp_Object
, Lisp_Object
));
345 static Lisp_Object font_prop_validate_spacing
P_ ((Lisp_Object
, Lisp_Object
));
346 static int get_font_prop_index
P_ ((Lisp_Object
, int));
347 static Lisp_Object font_prop_validate
P_ ((Lisp_Object
));
350 font_prop_validate_symbol (prop
, val
)
351 Lisp_Object prop
, val
;
353 if (EQ (prop
, QCotf
))
354 return (SYMBOLP (val
) ? val
: Qerror
);
356 val
= (SCHARS (val
) == 0 ? null_string
357 : intern_downcase ((char *) SDATA (val
), SBYTES (val
)));
358 else if (SYMBOLP (val
))
360 if (SCHARS (SYMBOL_NAME (val
)) == 0)
369 font_prop_validate_style (prop
, val
)
370 Lisp_Object prop
, val
;
372 if (! INTEGERP (val
))
375 val
= intern_downcase ((char *) SDATA (val
), SBYTES (val
));
380 enum font_property_index prop_index
381 = (EQ (prop
, QCweight
) ? FONT_WEIGHT_INDEX
382 : EQ (prop
, QCslant
) ? FONT_SLANT_INDEX
385 val
= prop_name_to_numeric (prop_index
, val
);
394 font_prop_validate_non_neg (prop
, val
)
395 Lisp_Object prop
, val
;
397 return (NATNUMP (val
) || (FLOATP (val
) && XFLOAT_DATA (val
) >= 0)
402 font_prop_validate_spacing (prop
, val
)
403 Lisp_Object prop
, val
;
405 if (NILP (val
) || (NATNUMP (val
) && XINT (val
) <= FONT_SPACING_CHARCELL
))
408 return make_number (FONT_SPACING_CHARCELL
);
410 return make_number (FONT_SPACING_MONO
);
412 return make_number (FONT_SPACING_PROPORTIONAL
);
417 font_prop_validate_otf (prop
, val
)
418 Lisp_Object prop
, val
;
420 Lisp_Object tail
, tmp
;
423 /* VAL = (SCRIPT [ LANGSYS [ GSUB-FEATURES [ GPOS-FEATURES ]]])
424 GSUB-FEATURES = (FEATURE ... [ nil FEATURE ... ]) | nil
425 GPOS-FEATURES = (FEATURE ... [ nil FEATURE ... ]) | nil */
428 if (! SYMBOLP (XCAR (val
)))
433 if (! CONSP (tail
) || ! SYMBOLP (XCAR (val
)))
435 for (i
= 0; i
< 2; i
++)
442 for (tmp
= XCAR (tail
); CONSP (tmp
); tmp
= XCDR (tmp
))
443 if (! SYMBOLP (XCAR (tmp
)))
451 /* Structure of known font property keys and validater of the
455 /* Pointer to the key symbol. */
457 /* Function to validate PROP's value VAL, or NULL if any value is
458 ok. The value is VAL or its regularized value if VAL is valid,
459 and Qerror if not. */
460 Lisp_Object (*validater
) P_ ((Lisp_Object prop
, Lisp_Object val
));
461 } font_property_table
[] =
462 { { &QCtype
, font_prop_validate_symbol
},
463 { &QCfoundry
, font_prop_validate_symbol
},
464 { &QCfamily
, font_prop_validate_symbol
},
465 { &QCadstyle
, font_prop_validate_symbol
},
466 { &QCregistry
, font_prop_validate_symbol
},
467 { &QCweight
, font_prop_validate_style
},
468 { &QCslant
, font_prop_validate_style
},
469 { &QCwidth
, font_prop_validate_style
},
470 { &QCsize
, font_prop_validate_non_neg
},
471 { &QClanguage
, font_prop_validate_symbol
},
472 { &QCscript
, font_prop_validate_symbol
},
473 { &QCdpi
, font_prop_validate_non_neg
},
474 { &QCspacing
, font_prop_validate_spacing
},
475 { &QCscalable
, NULL
},
476 { &QCotf
, font_prop_validate_otf
},
477 { &QCantialias
, font_prop_validate_symbol
}
480 /* Size (number of elements) of the above table. */
481 #define FONT_PROPERTY_TABLE_SIZE \
482 ((sizeof font_property_table) / (sizeof *font_property_table))
484 /* Return an index number of font property KEY or -1 if KEY is not an
485 already known property. Start searching font_property_table from
486 index FROM (which is 0 or FONT_EXTRA_INDEX). */
489 get_font_prop_index (key
, from
)
493 for (; from
< FONT_PROPERTY_TABLE_SIZE
; from
++)
494 if (EQ (key
, *font_property_table
[from
].key
))
499 /* Validate font properties in SPEC (vector) while updating elements
500 to regularized values. Signal an error if an invalid property is
504 font_prop_validate (spec
)
508 Lisp_Object prop
, val
, extra
;
510 for (i
= FONT_TYPE_INDEX
; i
< FONT_EXTRA_INDEX
; i
++)
512 if (! NILP (AREF (spec
, i
)))
514 prop
= *font_property_table
[i
].key
;
515 val
= (font_property_table
[i
].validater
) (prop
, AREF (spec
, i
));
516 if (EQ (val
, Qerror
))
517 Fsignal (Qfont
, list2 (build_string ("invalid font property"),
518 Fcons (prop
, AREF (spec
, i
))));
522 for (extra
= AREF (spec
, FONT_EXTRA_INDEX
);
523 CONSP (extra
); extra
= XCDR (extra
))
525 Lisp_Object elt
= XCAR (extra
);
528 i
= get_font_prop_index (prop
, FONT_EXTRA_INDEX
);
530 && font_property_table
[i
].validater
)
532 val
= (font_property_table
[i
].validater
) (prop
, XCDR (elt
));
533 if (EQ (val
, Qerror
))
534 Fsignal (Qfont
, list2 (build_string ("invalid font property"),
542 /* Store VAL as a value of extra font property PROP in FONT. */
545 font_put_extra (font
, prop
, val
)
546 Lisp_Object font
, prop
, val
;
548 Lisp_Object extra
= AREF (font
, FONT_EXTRA_INDEX
);
549 Lisp_Object slot
= (NILP (extra
) ? Qnil
: assq_no_quit (prop
, extra
));
553 extra
= Fcons (Fcons (prop
, val
), extra
);
554 ASET (font
, FONT_EXTRA_INDEX
, extra
);
562 /* Font name parser and unparser */
564 static Lisp_Object intern_font_field
P_ ((char *, int));
565 static int parse_matrix
P_ ((char *));
566 static int font_expand_wildcards
P_ ((Lisp_Object
*, int));
567 static int font_parse_name
P_ ((char *, Lisp_Object
));
569 /* An enumerator for each field of an XLFD font name. */
570 enum xlfd_field_index
589 /* An enumerator for mask bit corresponding to each XLFD field. */
592 XLFD_FOUNDRY_MASK
= 0x0001,
593 XLFD_FAMILY_MASK
= 0x0002,
594 XLFD_WEIGHT_MASK
= 0x0004,
595 XLFD_SLANT_MASK
= 0x0008,
596 XLFD_SWIDTH_MASK
= 0x0010,
597 XLFD_ADSTYLE_MASK
= 0x0020,
598 XLFD_PIXEL_MASK
= 0x0040,
599 XLFD_POINT_MASK
= 0x0080,
600 XLFD_RESX_MASK
= 0x0100,
601 XLFD_RESY_MASK
= 0x0200,
602 XLFD_SPACING_MASK
= 0x0400,
603 XLFD_AVGWIDTH_MASK
= 0x0800,
604 XLFD_REGISTRY_MASK
= 0x1000,
605 XLFD_ENCODING_MASK
= 0x2000
609 /* Return a Lispy value of a XLFD font field at STR and LEN bytes.
610 If LEN is zero, it returns `null_string'.
611 If STR is "*", it returns nil.
612 If all characters in STR are digits, it returns an integer.
613 Otherwise, it returns a symbol interned from downcased STR. */
616 intern_font_field (str
, len
)
624 if (*str
== '*' && len
== 1)
628 for (i
= 1; i
< len
; i
++)
629 if (! isdigit (str
[i
]))
632 return make_number (atoi (str
));
634 return intern_downcase (str
, len
);
637 /* Parse P pointing the pixel/point size field of the form
638 `[A B C D]' which specifies a transformation matrix:
644 by which all glyphs of the font are transformed. The spec says
645 that scalar value N for the pixel/point size is equivalent to:
646 A = N * resx/resy, B = C = 0, D = N.
648 Return the scalar value N if the form is valid. Otherwise return
659 for (i
= 0, p
++; i
< 4 && *p
&& *p
!= ']'; i
++)
662 matrix
[i
] = - strtod (p
+ 1, &end
);
664 matrix
[i
] = strtod (p
, &end
);
667 return (i
== 4 ? (int) matrix
[3] : -1);
670 /* Expand a wildcard field in FIELD (the first N fields are filled) to
671 multiple fields to fill in all 14 XLFD fields while restring a
672 field position by its contents. */
675 font_expand_wildcards (field
, n
)
676 Lisp_Object field
[XLFD_LAST_INDEX
];
680 Lisp_Object tmp
[XLFD_LAST_INDEX
];
681 /* Array of information about where this element can go. Nth
682 element is for Nth element of FIELD. */
684 /* Minimum possible field. */
686 /* Maxinum possible field. */
688 /* Bit mask of possible field. Nth bit corresponds to Nth field. */
690 } range
[XLFD_LAST_INDEX
];
692 int range_from
, range_to
;
695 #define XLFD_SYMBOL_MASK (XLFD_FOUNDRY_MASK | XLFD_FAMILY_MASK \
696 | XLFD_ADSTYLE_MASK | XLFD_REGISTRY_MASK)
697 #define XLFD_NULL_MASK (XLFD_FOUNDRY_MASK | XLFD_ADSTYLE_MASK)
698 #define XLFD_LARGENUM_MASK (XLFD_POINT_MASK | XLFD_RESX_MASK | XLFD_RESY_MASK \
699 | XLFD_AVGWIDTH_MASK)
700 #define XLFD_REGENC_MASK (XLFD_REGISTRY_MASK | XLFD_ENCODING_MASK)
702 /* Initialize RANGE_MASK for FIELD[0] which can be 0th to (14 - N)th
703 field. The value is shifted to left one bit by one in the
705 for (i
= 0, range_mask
= 0; i
<= 14 - n
; i
++)
706 range_mask
= (range_mask
<< 1) | 1;
708 /* The triplet RANGE_FROM, RANGE_TO, and RANGE_MASK is a
709 position-based retriction for FIELD[I]. */
710 for (i
= 0, range_from
= 0, range_to
= 14 - n
; i
< n
;
711 i
++, range_from
++, range_to
++, range_mask
<<= 1)
713 Lisp_Object val
= field
[i
];
719 range
[i
].from
= range_from
;
720 range
[i
].to
= range_to
;
721 range
[i
].mask
= range_mask
;
725 /* The triplet FROM, TO, and MASK is a value-based
726 retriction for FIELD[I]. */
732 int numeric
= XINT (val
);
735 from
= to
= XLFD_ENCODING_INDEX
,
736 mask
= XLFD_ENCODING_MASK
;
737 else if (numeric
== 0)
738 from
= XLFD_PIXEL_INDEX
, to
= XLFD_AVGWIDTH_INDEX
,
739 mask
= XLFD_PIXEL_MASK
| XLFD_LARGENUM_MASK
;
740 else if (numeric
<= 48)
741 from
= to
= XLFD_PIXEL_INDEX
,
742 mask
= XLFD_PIXEL_MASK
;
744 from
= XLFD_POINT_INDEX
, to
= XLFD_AVGWIDTH_INDEX
,
745 mask
= XLFD_LARGENUM_MASK
;
747 else if (EQ (val
, null_string
))
748 from
= XLFD_FOUNDRY_INDEX
, to
= XLFD_ADSTYLE_INDEX
,
749 mask
= XLFD_NULL_MASK
;
751 from
= to
= XLFD_FOUNDRY_INDEX
, mask
= XLFD_FOUNDRY_MASK
;
754 Lisp_Object name
= SYMBOL_NAME (val
);
756 if (SDATA (name
)[SBYTES (name
) - 1] == '*')
757 from
= XLFD_REGISTRY_INDEX
, to
= XLFD_ENCODING_INDEX
,
758 mask
= XLFD_REGENC_MASK
;
760 from
= to
= XLFD_ENCODING_INDEX
,
761 mask
= XLFD_ENCODING_MASK
;
763 else if (range_from
<= XLFD_WEIGHT_INDEX
764 && range_to
>= XLFD_WEIGHT_INDEX
765 && !NILP (prop_name_to_numeric (FONT_WEIGHT_INDEX
, val
)))
766 from
= to
= XLFD_WEIGHT_INDEX
, mask
= XLFD_WEIGHT_MASK
;
767 else if (range_from
<= XLFD_SLANT_INDEX
768 && range_to
>= XLFD_SLANT_INDEX
769 && !NILP (prop_name_to_numeric (FONT_SLANT_INDEX
, val
)))
770 from
= to
= XLFD_SLANT_INDEX
, mask
= XLFD_SLANT_MASK
;
771 else if (range_from
<= XLFD_SWIDTH_INDEX
772 && range_to
>= XLFD_SWIDTH_INDEX
773 && !NILP (prop_name_to_numeric (FONT_WIDTH_INDEX
, val
)))
774 from
= to
= XLFD_SWIDTH_INDEX
, mask
= XLFD_SWIDTH_MASK
;
777 if (EQ (val
, Qc
) || EQ (val
, Qm
) || EQ (val
, Qp
) || EQ (val
, Qd
))
778 from
= to
= XLFD_SPACING_INDEX
, mask
= XLFD_SPACING_MASK
;
780 from
= XLFD_FOUNDRY_INDEX
, to
= XLFD_ENCODING_INDEX
,
781 mask
= XLFD_SYMBOL_MASK
;
784 /* Merge position-based and value-based restrictions. */
786 while (from
< range_from
)
787 mask
&= ~(1 << from
++);
788 while (from
< 14 && ! (mask
& (1 << from
)))
790 while (to
> range_to
)
791 mask
&= ~(1 << to
--);
792 while (to
>= 0 && ! (mask
& (1 << to
)))
796 range
[i
].from
= from
;
798 range
[i
].mask
= mask
;
800 if (from
> range_from
|| to
< range_to
)
802 /* The range is narrowed by value-based restrictions.
803 Reflect it to the other fields. */
805 /* Following fields should be after FROM. */
807 /* Preceding fields should be before TO. */
808 for (j
= i
- 1, from
--, to
--; j
>= 0; j
--, from
--, to
--)
810 /* Check FROM for non-wildcard field. */
811 if (! NILP (tmp
[j
]) && range
[j
].from
< from
)
813 while (range
[j
].from
< from
)
814 range
[j
].mask
&= ~(1 << range
[j
].from
++);
815 while (from
< 14 && ! (range
[j
].mask
& (1 << from
)))
817 range
[j
].from
= from
;
820 from
= range
[j
].from
;
821 if (range
[j
].to
> to
)
823 while (range
[j
].to
> to
)
824 range
[j
].mask
&= ~(1 << range
[j
].to
--);
825 while (to
>= 0 && ! (range
[j
].mask
& (1 << to
)))
838 /* Decide all fileds from restrictions in RANGE. */
839 for (i
= j
= 0; i
< n
; i
++)
841 if (j
< range
[i
].from
)
843 if (i
== 0 || ! NILP (tmp
[i
- 1]))
844 /* None of TMP[X] corresponds to Jth field. */
846 for (; j
< range
[i
].from
; j
++)
851 if (! NILP (tmp
[n
- 1]) && j
< XLFD_REGISTRY_INDEX
)
853 for (; j
< XLFD_LAST_INDEX
; j
++)
855 if (INTEGERP (field
[XLFD_ENCODING_INDEX
]))
856 field
[XLFD_ENCODING_INDEX
]
857 = Fintern (Fnumber_to_string (field
[XLFD_ENCODING_INDEX
]), Qnil
);
861 /* Parse NAME (null terminated) as XLFD and store information in FONT
862 (font-spec or font-entity). Size property of FONT is set as
864 specified XLFD fields FONT property
865 --------------------- -------------
866 PIXEL_SIZE PIXEL_SIZE (Lisp integer)
867 POINT_SIZE and RESY calculated pixel size (Lisp integer)
868 POINT_SIZE POINT_SIZE/10 (Lisp float)
870 If NAME is successfully parsed, return 0. Otherwise return -1.
872 FONT is usually a font-spec, but when this function is called from
873 X font backend driver, it is a font-entity. In that case, NAME is
874 a fully specified XLFD, and we set FONT_EXTRA_INDEX of FONT to a
875 symbol RESX-RESY-SPACING-AVGWIDTH.
879 font_parse_xlfd (name
, font
)
883 int len
= strlen (name
);
885 Lisp_Object dpi
, spacing
;
887 char *f
[XLFD_LAST_INDEX
+ 1];
892 /* Maximum XLFD name length is 255. */
894 /* Accept "*-.." as a fully specified XLFD. */
895 if (name
[0] == '*' && name
[1] == '-')
896 i
= 1, f
[XLFD_FOUNDRY_INDEX
] = name
;
899 for (p
= name
+ i
; *p
; p
++)
900 if (*p
== '-' && i
< XLFD_LAST_INDEX
)
904 dpi
= spacing
= Qnil
;
907 if (i
== XLFD_LAST_INDEX
)
911 /* Fully specified XLFD. */
912 for (i
= 0, j
= FONT_FOUNDRY_INDEX
; i
< XLFD_WEIGHT_INDEX
; i
++, j
++)
914 val
= intern_font_field (f
[i
], f
[i
+ 1] - 1 - f
[i
]);
918 for (j
= FONT_WEIGHT_INDEX
; i
< XLFD_ADSTYLE_INDEX
; i
++, j
++)
920 val
= intern_font_field (f
[i
], f
[i
+ 1] - 1 - f
[i
]);
923 Lisp_Object numeric
= prop_name_to_numeric (j
, val
);
925 if (INTEGERP (numeric
))
930 val
= intern_font_field (f
[i
], f
[i
+ 1] - 1 - f
[i
]);
932 ASET (font
, FONT_ADSTYLE_INDEX
, val
);
933 i
= XLFD_REGISTRY_INDEX
;
934 val
= intern_font_field (f
[i
], f
[i
+ 2] - f
[i
]);
936 ASET (font
, FONT_REGISTRY_INDEX
, val
);
938 p
= f
[XLFD_PIXEL_INDEX
];
939 if (*p
== '[' && (pixel_size
= parse_matrix (p
)) >= 0)
940 ASET (font
, FONT_SIZE_INDEX
, make_number (pixel_size
));
943 i
= XLFD_PIXEL_INDEX
;
944 val
= intern_font_field (f
[i
], f
[i
+ 1] - 1 - f
[i
]);
946 ASET (font
, FONT_SIZE_INDEX
, val
);
949 double point_size
= -1;
951 xassert (FONT_SPEC_P (font
));
952 p
= f
[XLFD_POINT_INDEX
];
954 point_size
= parse_matrix (p
);
955 else if (isdigit (*p
))
956 point_size
= atoi (p
), point_size
/= 10;
958 ASET (font
, FONT_SIZE_INDEX
, make_float (point_size
));
961 i
= XLFD_PIXEL_INDEX
;
962 val
= intern_font_field (f
[i
], f
[i
+ 1] - 1 - f
[i
]);
964 ASET (font
, FONT_SIZE_INDEX
, val
);
969 /* Parse RESX, RESY, SPACING, and AVGWIDTH. */
970 if (FONT_ENTITY_P (font
))
973 ASET (font
, FONT_EXTRA_INDEX
,
974 intern_font_field (f
[i
], f
[XLFD_REGISTRY_INDEX
] - 1 - f
[i
]));
978 /* Here we just setup DPI, SPACING, and AVGWIDTH. They are set
979 in FONT_EXTRA_INDEX later. */
981 dpi
= intern_font_field (f
[i
], f
[i
+ 1] - 1 - f
[i
]);
982 i
= XLFD_SPACING_INDEX
;
983 spacing
= intern_font_field (f
[i
], f
[i
+ 1] - 1 - f
[i
]);
984 p
= f
[XLFD_AVGWIDTH_INDEX
];
992 int wild_card_found
= 0;
993 Lisp_Object prop
[XLFD_LAST_INDEX
];
995 for (j
= 0; j
< i
; j
++)
999 if (f
[j
][1] && f
[j
][1] != '-')
1002 wild_card_found
= 1;
1004 else if (isdigit (*f
[j
]))
1006 for (p
= f
[j
] + 1; isdigit (*p
); p
++);
1007 if (*p
&& *p
!= '-')
1008 prop
[j
] = intern_downcase (f
[j
], p
- f
[j
]);
1010 prop
[j
] = make_number (atoi (f
[j
]));
1013 prop
[j
] = intern_font_field (f
[j
], f
[j
+ 1] - 1 - f
[j
]);
1015 prop
[j
] = intern_font_field (f
[j
], f
[i
] - f
[j
]);
1017 if (! wild_card_found
)
1019 if (font_expand_wildcards (prop
, i
) < 0)
1022 for (i
= 0, j
= FONT_FOUNDRY_INDEX
; i
< XLFD_WEIGHT_INDEX
; i
++, j
++)
1023 if (! NILP (prop
[i
]))
1024 ASET (font
, j
, prop
[i
]);
1025 for (j
= FONT_WEIGHT_INDEX
; i
< XLFD_ADSTYLE_INDEX
; i
++, j
++)
1026 if (! NILP (prop
[i
]))
1027 ASET (font
, j
, prop
[i
]);
1028 if (! NILP (prop
[XLFD_ADSTYLE_INDEX
]))
1029 ASET (font
, FONT_ADSTYLE_INDEX
, prop
[XLFD_ADSTYLE_INDEX
]);
1030 val
= prop
[XLFD_REGISTRY_INDEX
];
1033 val
= prop
[XLFD_ENCODING_INDEX
];
1035 val
= Fintern (concat2 (build_string ("*-"), SYMBOL_NAME (val
)),
1038 else if (NILP (prop
[XLFD_ENCODING_INDEX
]))
1039 val
= Fintern (concat2 (SYMBOL_NAME (val
), build_string ("-*")),
1042 val
= Fintern (concat3 (SYMBOL_NAME (val
), build_string ("-"),
1043 SYMBOL_NAME (prop
[XLFD_ENCODING_INDEX
])),
1046 ASET (font
, FONT_REGISTRY_INDEX
, val
);
1048 if (INTEGERP (prop
[XLFD_PIXEL_INDEX
]))
1049 ASET (font
, FONT_SIZE_INDEX
, prop
[XLFD_PIXEL_INDEX
]);
1050 else if (INTEGERP (prop
[XLFD_POINT_INDEX
]))
1052 double point_size
= XINT (prop
[XLFD_POINT_INDEX
]);
1054 ASET (font
, FONT_SIZE_INDEX
, make_float (point_size
/ 10));
1057 dpi
= prop
[XLFD_RESX_INDEX
];
1058 spacing
= prop
[XLFD_SPACING_INDEX
];
1059 if (INTEGERP (prop
[XLFD_AVGWIDTH_INDEX
]))
1060 avgwidth
= XINT (prop
[XLFD_AVGWIDTH_INDEX
]);
1064 font_put_extra (font
, QCdpi
, dpi
);
1065 if (! NILP (spacing
))
1066 font_put_extra (font
, QCspacing
, spacing
);
1068 font_put_extra (font
, QCscalable
, avgwidth
== 0 ? Qt
: Qnil
);
1073 /* Store XLFD name of FONT (font-spec or font-entity) in NAME (NBYTES
1074 length), and return the name length. If FONT_SIZE_INDEX of FONT is
1075 0, use PIXEL_SIZE instead. */
1078 font_unparse_xlfd (font
, pixel_size
, name
, nbytes
)
1084 char *f
[XLFD_REGISTRY_INDEX
+ 1];
1088 xassert (FONTP (font
));
1090 for (i
= FONT_FOUNDRY_INDEX
, j
= XLFD_FOUNDRY_INDEX
; i
<= FONT_REGISTRY_INDEX
;
1093 if (i
== FONT_ADSTYLE_INDEX
)
1094 j
= XLFD_ADSTYLE_INDEX
;
1095 else if (i
== FONT_REGISTRY_INDEX
)
1096 j
= XLFD_REGISTRY_INDEX
;
1097 val
= AREF (font
, i
);
1100 if (j
== XLFD_REGISTRY_INDEX
)
1101 f
[j
] = "*-*", len
+= 4;
1103 f
[j
] = "*", len
+= 2;
1108 val
= SYMBOL_NAME (val
);
1109 if (j
== XLFD_REGISTRY_INDEX
1110 && ! strchr ((char *) SDATA (val
), '-'))
1112 /* Change "jisx0208*" and "jisx0208" to "jisx0208*-*". */
1113 if (SDATA (val
)[SBYTES (val
) - 1] == '*')
1115 f
[j
] = alloca (SBYTES (val
) + 3);
1116 sprintf (f
[j
], "%s-*", SDATA (val
));
1117 len
+= SBYTES (val
) + 3;
1121 f
[j
] = alloca (SBYTES (val
) + 4);
1122 sprintf (f
[j
], "%s*-*", SDATA (val
));
1123 len
+= SBYTES (val
) + 4;
1127 f
[j
] = (char *) SDATA (val
), len
+= SBYTES (val
) + 1;
1131 for (i
= FONT_WEIGHT_INDEX
, j
= XLFD_WEIGHT_INDEX
; i
<= FONT_WIDTH_INDEX
;
1134 val
= AREF (font
, i
);
1136 f
[j
] = "*", len
+= 2;
1140 val
= prop_numeric_to_name (i
, XINT (val
));
1142 val
= SYMBOL_NAME (val
);
1143 xassert (STRINGP (val
));
1144 f
[j
] = (char *) SDATA (val
), len
+= SBYTES (val
) + 1;
1148 val
= AREF (font
, FONT_SIZE_INDEX
);
1149 xassert (NUMBERP (val
) || NILP (val
));
1152 f
[XLFD_PIXEL_INDEX
] = alloca (22);
1155 len
+= sprintf (f
[XLFD_PIXEL_INDEX
], "%d-*", i
) + 1;
1156 else if (pixel_size
> 0)
1157 len
+= sprintf (f
[XLFD_PIXEL_INDEX
], "%d-*", pixel_size
) + 1;
1158 f
[XLFD_PIXEL_INDEX
] = "*-*", len
+= 4;
1160 else if (FLOATP (val
))
1162 f
[XLFD_PIXEL_INDEX
] = alloca (12);
1163 i
= XFLOAT_DATA (val
) * 10;
1164 len
+= sprintf (f
[XLFD_PIXEL_INDEX
], "*-%d", i
) + 1;
1167 f
[XLFD_PIXEL_INDEX
] = "*-*", len
+= 4;
1169 val
= AREF (font
, FONT_EXTRA_INDEX
);
1171 if (FONT_ENTITY_P (font
)
1172 && EQ (AREF (font
, FONT_TYPE_INDEX
), Qx
))
1174 /* Setup names for RESX-RESY-SPACING-AVWIDTH. */
1175 if (SYMBOLP (val
) && ! NILP (val
))
1177 val
= SYMBOL_NAME (val
);
1178 f
[XLFD_RESX_INDEX
] = (char *) SDATA (val
), len
+= SBYTES (val
) + 1;
1181 f
[XLFD_RESX_INDEX
] = "*-*-*-*", len
+= 6;
1185 Lisp_Object dpi
= assq_no_quit (QCdpi
, val
);
1186 Lisp_Object spacing
= assq_no_quit (QCspacing
, val
);
1187 Lisp_Object scalable
= assq_no_quit (QCscalable
, val
);
1189 if (CONSP (dpi
) || CONSP (spacing
) || CONSP (scalable
))
1191 char *str
= alloca (24);
1194 if (CONSP (dpi
) && INTEGERP (XCDR (dpi
)))
1195 this_len
= sprintf (str
, "%d-%d",
1196 XINT (XCDR (dpi
)), XINT (XCDR (dpi
)));
1198 this_len
= sprintf (str
, "*-*");
1199 if (CONSP (spacing
) && ! NILP (XCDR (spacing
)))
1201 val
= XCDR (spacing
);
1204 if (XINT (val
) < FONT_SPACING_MONO
)
1206 else if (XINT (val
) < FONT_SPACING_CHARCELL
)
1211 xassert (SYMBOLP (val
));
1212 this_len
+= sprintf (str
+ this_len
, "-%c",
1213 SDATA (SYMBOL_NAME (val
))[0]);
1216 this_len
+= sprintf (str
+ this_len
, "-*");
1217 if (CONSP (scalable
) && ! NILP (XCDR (spacing
)))
1218 this_len
+= sprintf (str
+ this_len
, "-0");
1220 this_len
+= sprintf (str
+ this_len
, "-*");
1221 f
[XLFD_RESX_INDEX
] = str
;
1225 f
[XLFD_RESX_INDEX
] = "*-*-*-*", len
+= 8;
1228 len
++; /* for terminating '\0'. */
1231 return sprintf (name
, "-%s-%s-%s-%s-%s-%s-%s-%s-%s",
1232 f
[XLFD_FOUNDRY_INDEX
], f
[XLFD_FAMILY_INDEX
],
1233 f
[XLFD_WEIGHT_INDEX
], f
[XLFD_SLANT_INDEX
],
1234 f
[XLFD_SWIDTH_INDEX
],
1235 f
[XLFD_ADSTYLE_INDEX
], f
[XLFD_PIXEL_INDEX
],
1236 f
[XLFD_RESX_INDEX
], f
[XLFD_REGISTRY_INDEX
]);
1239 /* Parse NAME (null terminated) as Fonconfig's name format and store
1240 information in FONT (font-spec or font-entity). If NAME is
1241 successfully parsed, return 0. Otherwise return -1. */
1244 font_parse_fcname (name
, font
)
1249 int len
= strlen (name
);
1256 /* It is assured that (name[0] && name[0] != '-'). */
1264 for (p0
= name
+ 1; *p0
&& (*p0
!= '-' && *p0
!= ':'); p0
++)
1265 if (*p0
== '\\' && p0
[1])
1267 family
= intern_font_field (name
, p0
- name
);
1270 if (! isdigit (p0
[1]))
1272 point_size
= strtod (p0
+ 1, &p1
);
1273 if (*p1
&& *p1
!= ':')
1275 ASET (font
, FONT_SIZE_INDEX
, make_float (point_size
));
1278 ASET (font
, FONT_FAMILY_INDEX
, family
);
1282 copy
= alloca (len
+ 1);
1287 /* Now parse ":KEY=VAL" patterns. Store known keys and values in
1288 extra, copy unknown ones to COPY. */
1291 Lisp_Object key
, val
;
1294 for (p1
= p0
+ 1; *p1
&& *p1
!= '=' && *p1
!= ':'; p1
++);
1297 /* Must be an enumerated value. */
1298 val
= intern_font_field (p0
+ 1, p1
- p0
- 1);
1299 if (memcmp (p0
+ 1, "light", 5) == 0
1300 || memcmp (p0
+ 1, "medium", 6) == 0
1301 || memcmp (p0
+ 1, "demibold", 8) == 0
1302 || memcmp (p0
+ 1, "bold", 4) == 0
1303 || memcmp (p0
+ 1, "black", 5) == 0)
1305 ASET (font
, FONT_WEIGHT_INDEX
, val
);
1308 else if (memcmp (p0
+ 1, "roman", 5) == 0
1309 || memcmp (p0
+ 1, "italic", 6) == 0
1310 || memcmp (p0
+ 1, "oblique", 7) == 0)
1312 ASET (font
, FONT_SLANT_INDEX
, val
);
1315 else if (memcmp (p0
+ 1, "charcell", 8) == 0
1316 || memcmp (p0
+ 1, "mono", 4) == 0
1317 || memcmp (p0
+ 1, "proportional", 12) == 0)
1319 font_put_extra (font
, QCspacing
,
1320 (p0
[1] == 'c' ? Qc
: p0
[1] == 'm' ? Qm
: Qp
));
1325 bcopy (p0
, copy
, p1
- p0
);
1331 if (memcmp (p0
+ 1, "pixelsize=", 10) == 0)
1332 prop
= FONT_SIZE_INDEX
;
1335 key
= intern_font_field (p0
, p1
- p0
);
1336 prop
= get_font_prop_index (key
, 0);
1339 for (p1
= p0
; *p1
&& *p1
!= ':'; p1
++);
1340 val
= intern_font_field (p0
, p1
- p0
);
1343 if (prop
>= 0 && prop
< FONT_EXTRA_INDEX
)
1345 if (prop
== FONT_WEIGHT_INDEX
)
1347 else if (prop
== FONT_SLANT_INDEX
)
1350 ASET (font
, prop
, val
);
1353 font_put_extra (font
, key
, val
);
1360 ASET (font
, FONT_WEIGHT_INDEX
, build_string ("normal"));
1362 ASET (font
, FONT_SLANT_INDEX
, build_string ("normal"));
1367 /* Store fontconfig's font name of FONT (font-spec or font-entity) in
1368 NAME (NBYTES length), and return the name length. If
1369 FONT_SIZE_INDEX of FONT is 0, use PIXEL_SIZE instead. */
1372 font_unparse_fcname (font
, pixel_size
, name
, nbytes
)
1380 int dpi
, spacing
, scalable
;
1383 Lisp_Object styles
[3];
1384 char *style_names
[3] = { "weight", "slant", "width" };
1386 val
= AREF (font
, FONT_FAMILY_INDEX
);
1387 if (SYMBOLP (val
) && ! NILP (val
))
1388 len
+= SBYTES (SYMBOL_NAME (val
));
1390 val
= AREF (font
, FONT_SIZE_INDEX
);
1393 if (XINT (val
) != 0)
1394 pixel_size
= XINT (val
);
1396 len
+= 21; /* for ":pixelsize=NUM" */
1398 else if (FLOATP (val
))
1401 point_size
= (int) XFLOAT_DATA (val
);
1402 len
+= 11; /* for "-NUM" */
1405 val
= AREF (font
, FONT_FOUNDRY_INDEX
);
1406 if (SYMBOLP (val
) && ! NILP (val
))
1407 /* ":foundry=NAME" */
1408 len
+= 9 + SBYTES (SYMBOL_NAME (val
));
1410 for (i
= FONT_WEIGHT_INDEX
; i
<= FONT_WIDTH_INDEX
; i
++)
1412 val
= AREF (font
, i
);
1415 val
= prop_numeric_to_name (i
, XINT (val
));
1416 len
+= (strlen (style_names
[i
- FONT_WEIGHT_INDEX
])
1417 + 2 + SBYTES (SYMBOL_NAME (val
))); /* :xxx=NAME */
1419 styles
[i
- FONT_WEIGHT_INDEX
] = val
;
1422 val
= AREF (font
, FONT_EXTRA_INDEX
);
1423 if (FONT_ENTITY_P (font
)
1424 && EQ (AREF (font
, FONT_TYPE_INDEX
), Qx
))
1428 /* VAL is a symbol of name `RESX-RESY-SPACING-AVWIDTH'. */
1429 p
= (char *) SDATA (SYMBOL_NAME (val
));
1431 for (p
++; *p
!= '-'; p
++); /* skip RESX */
1432 for (p
++; *p
!= '-'; p
++); /* skip RESY */
1433 spacing
= (*p
== 'c' ? FONT_SPACING_CHARCELL
1434 : *p
== 'm' ? FONT_SPACING_MONO
1435 : FONT_SPACING_PROPORTIONAL
);
1436 for (p
++; *p
!= '-'; p
++); /* skip SPACING */
1437 scalable
= (atoi (p
) == 0);
1438 /* The longest pattern is ":dpi=NUM:scalable=False:spacing=100" */
1445 dpi
= spacing
= scalable
= -1;
1446 elt
= assq_no_quit (QCdpi
, val
);
1448 dpi
= XINT (XCDR (elt
)), len
+= 15; /* for ":dpi=NUM" */
1449 elt
= assq_no_quit (QCspacing
, val
);
1451 spacing
= XINT (XCDR (elt
)), len
+= 12; /* for ":spacing=100" */
1452 elt
= assq_no_quit (QCscalable
, val
);
1454 scalable
= ! NILP (XCDR (elt
)), len
+= 15; /* for ":scalable=False" */
1460 if (! NILP (AREF (font
, FONT_FAMILY_INDEX
)))
1461 p
+= sprintf(p
, "%s",
1462 SDATA (SYMBOL_NAME (AREF (font
, FONT_FAMILY_INDEX
))));
1466 p
+= sprintf (p
, "%d", point_size
);
1468 p
+= sprintf (p
, "-%d", point_size
);
1470 else if (pixel_size
> 0)
1471 p
+= sprintf (p
, ":pixelsize=%d", pixel_size
);
1472 if (SYMBOLP (AREF (font
, FONT_FOUNDRY_INDEX
))
1473 && ! NILP (AREF (font
, FONT_FOUNDRY_INDEX
)))
1474 p
+= sprintf (p
, ":foundry=%s",
1475 SDATA (SYMBOL_NAME (AREF (font
, FONT_FOUNDRY_INDEX
))));
1476 for (i
= 0; i
< 3; i
++)
1477 if (SYMBOLP (styles
[i
]) && ! NILP (styles
[i
]))
1478 p
+= sprintf (p
, ":%s=%s", style_names
[i
],
1479 SDATA (SYMBOL_NAME (styles
[i
])));
1481 p
+= sprintf (p
, ":dpi=%d", dpi
);
1483 p
+= sprintf (p
, ":spacing=%d", spacing
);
1485 p
+= sprintf (p
, ":scalable=True");
1486 else if (scalable
== 0)
1487 p
+= sprintf (p
, ":scalable=False");
1491 /* Parse NAME (null terminated) and store information in FONT
1492 (font-spec or font-entity). If NAME is successfully parsed, return
1493 0. Otherwise return -1.
1495 If NAME is XLFD and FONT is a font-entity, store
1496 RESX-RESY-SPACING-AVWIDTH information as a symbol in
1497 FONT_EXTRA_INDEX. */
1500 font_parse_name (name
, font
)
1504 if (name
[0] == '-' || index (name
, '*'))
1505 return font_parse_xlfd (name
, font
);
1506 return font_parse_fcname (name
, font
);
1509 /* Merge old style font specification (either a font name NAME or a
1510 combination of a family name FAMILY and a registry name REGISTRY
1511 into the font specification SPEC. */
1514 font_merge_old_spec (name
, family
, registry
, spec
)
1515 Lisp_Object name
, family
, registry
, spec
;
1519 if (font_parse_xlfd ((char *) SDATA (name
), spec
) < 0)
1521 Lisp_Object extra
= Fcons (Fcons (QCname
, name
), Qnil
);
1523 ASET (spec
, FONT_EXTRA_INDEX
, extra
);
1528 if (! NILP (family
))
1533 xassert (STRINGP (family
));
1534 len
= SBYTES (family
);
1535 p0
= (char *) SDATA (family
);
1536 p1
= index (p0
, '-');
1539 if ((*p0
!= '*' || p1
- p0
> 1)
1540 && NILP (AREF (spec
, FONT_FOUNDRY_INDEX
)))
1541 ASET (spec
, FONT_FOUNDRY_INDEX
,
1542 intern_downcase (p0
, p1
- p0
));
1543 if (NILP (AREF (spec
, FONT_FAMILY_INDEX
)))
1544 ASET (spec
, FONT_FAMILY_INDEX
,
1545 intern_downcase (p1
+ 1, len
- (p1
+ 1 - p0
)));
1547 else if (NILP (AREF (spec
, FONT_FAMILY_INDEX
)))
1548 ASET (spec
, FONT_FAMILY_INDEX
, intern_downcase (p0
, len
));
1550 if (! NILP (registry
)
1551 && NILP (AREF (spec
, FONT_REGISTRY_INDEX
)))
1552 ASET (spec
, FONT_REGISTRY_INDEX
,
1553 intern_downcase ((char *) SDATA (registry
), SBYTES (registry
)));
1558 /* This part (through the next ^L) is still experimental and never
1559 tested. We may drastically change codes. */
1563 #define LGSTRING_HEADER_SIZE 6
1564 #define LGSTRING_GLYPH_SIZE 8
1567 check_gstring (gstring
)
1568 Lisp_Object gstring
;
1573 CHECK_VECTOR (gstring
);
1574 val
= AREF (gstring
, 0);
1576 if (ASIZE (val
) < LGSTRING_HEADER_SIZE
)
1578 CHECK_FONT_OBJECT (LGSTRING_FONT (gstring
));
1579 if (!NILP (LGSTRING_SLOT (gstring
, LGSTRING_IX_LBEARING
)))
1580 CHECK_NUMBER (LGSTRING_SLOT (gstring
, LGSTRING_IX_LBEARING
));
1581 if (!NILP (LGSTRING_SLOT (gstring
, LGSTRING_IX_RBEARING
)))
1582 CHECK_NUMBER (LGSTRING_SLOT (gstring
, LGSTRING_IX_RBEARING
));
1583 if (!NILP (LGSTRING_SLOT (gstring
, LGSTRING_IX_WIDTH
)))
1584 CHECK_NATNUM (LGSTRING_SLOT (gstring
, LGSTRING_IX_WIDTH
));
1585 if (!NILP (LGSTRING_SLOT (gstring
, LGSTRING_IX_ASCENT
)))
1586 CHECK_NUMBER (LGSTRING_SLOT (gstring
, LGSTRING_IX_ASCENT
));
1587 if (!NILP (LGSTRING_SLOT (gstring
, LGSTRING_IX_ASCENT
)))
1588 CHECK_NUMBER (LGSTRING_SLOT (gstring
, LGSTRING_IX_ASCENT
));
1590 for (i
= 0; i
< LGSTRING_LENGTH (gstring
); i
++)
1592 val
= LGSTRING_GLYPH (gstring
, i
);
1594 if (ASIZE (val
) < LGSTRING_GLYPH_SIZE
)
1596 if (NILP (AREF (val
, LGLYPH_IX_CHAR
)))
1598 CHECK_NATNUM (AREF (val
, LGLYPH_IX_FROM
));
1599 CHECK_NATNUM (AREF (val
, LGLYPH_IX_TO
));
1600 CHECK_CHARACTER (AREF (val
, LGLYPH_IX_CHAR
));
1601 if (!NILP (AREF (val
, LGLYPH_IX_CODE
)))
1602 CHECK_NATNUM (AREF (val
, LGLYPH_IX_CODE
));
1603 if (!NILP (AREF (val
, LGLYPH_IX_WIDTH
)))
1604 CHECK_NATNUM (AREF (val
, LGLYPH_IX_WIDTH
));
1605 if (!NILP (AREF (val
, LGLYPH_IX_ADJUSTMENT
)))
1607 val
= AREF (val
, LGLYPH_IX_ADJUSTMENT
);
1609 if (ASIZE (val
) < 3)
1611 for (j
= 0; j
< 3; j
++)
1612 CHECK_NUMBER (AREF (val
, j
));
1617 error ("Invalid glyph-string format");
1622 check_otf_features (otf_features
)
1623 Lisp_Object otf_features
;
1625 Lisp_Object val
, elt
;
1627 CHECK_CONS (otf_features
);
1628 CHECK_SYMBOL (XCAR (otf_features
));
1629 otf_features
= XCDR (otf_features
);
1630 CHECK_CONS (otf_features
);
1631 CHECK_SYMBOL (XCAR (otf_features
));
1632 otf_features
= XCDR (otf_features
);
1633 for (val
= Fcar (otf_features
); ! NILP (val
); val
= Fcdr (val
))
1635 CHECK_SYMBOL (Fcar (val
));
1636 if (SBYTES (SYMBOL_NAME (XCAR (val
))) > 4)
1637 error ("Invalid OTF GSUB feature: %s", SYMBOL_NAME (XCAR (val
)));
1639 otf_features
= XCDR (otf_features
);
1640 for (val
= Fcar (otf_features
); ! NILP (val
); val
= Fcdr (val
))
1642 CHECK_SYMBOL (Fcar (val
));
1643 if (SBYTES (SYMBOL_NAME (XCAR (val
))) > 4)
1644 error ("Invalid OTF GPOS feature: %s", SYMBOL_NAME (XCAR (val
)));
1651 Lisp_Object otf_list
;
1654 otf_tag_symbol (tag
)
1659 OTF_tag_name (tag
, name
);
1660 return Fintern (make_unibyte_string (name
, 4), Qnil
);
1664 otf_open (entity
, file
)
1668 Lisp_Object val
= Fassoc (entity
, otf_list
);
1672 otf
= XSAVE_VALUE (XCDR (val
))->pointer
;
1675 otf
= file
? OTF_open (file
) : NULL
;
1676 val
= make_save_value (otf
, 0);
1677 otf_list
= Fcons (Fcons (entity
, val
), otf_list
);
1683 /* Return a list describing which scripts/languages FONT supports by
1684 which GSUB/GPOS features of OpenType tables. See the comment of
1685 (sturct font_driver).otf_capability. */
1688 font_otf_capability (font
)
1692 Lisp_Object capability
= Fcons (Qnil
, Qnil
);
1695 otf
= otf_open (font
->entity
, font
->file_name
);
1698 for (i
= 0; i
< 2; i
++)
1700 OTF_GSUB_GPOS
*gsub_gpos
;
1701 Lisp_Object script_list
= Qnil
;
1704 if (OTF_get_features (otf
, i
== 0) < 0)
1706 gsub_gpos
= i
== 0 ? otf
->gsub
: otf
->gpos
;
1707 for (j
= gsub_gpos
->ScriptList
.ScriptCount
- 1; j
>= 0; j
--)
1709 OTF_Script
*script
= gsub_gpos
->ScriptList
.Script
+ j
;
1710 Lisp_Object langsys_list
= Qnil
;
1711 Lisp_Object script_tag
= otf_tag_symbol (script
->ScriptTag
);
1714 for (k
= script
->LangSysCount
; k
>= 0; k
--)
1716 OTF_LangSys
*langsys
;
1717 Lisp_Object feature_list
= Qnil
;
1718 Lisp_Object langsys_tag
;
1721 if (k
== script
->LangSysCount
)
1723 langsys
= &script
->DefaultLangSys
;
1728 langsys
= script
->LangSys
+ k
;
1730 = otf_tag_symbol (script
->LangSysRecord
[k
].LangSysTag
);
1732 for (l
= langsys
->FeatureCount
- 1; l
>= 0; l
--)
1734 OTF_Feature
*feature
1735 = gsub_gpos
->FeatureList
.Feature
+ langsys
->FeatureIndex
[l
];
1736 Lisp_Object feature_tag
1737 = otf_tag_symbol (feature
->FeatureTag
);
1739 feature_list
= Fcons (feature_tag
, feature_list
);
1741 langsys_list
= Fcons (Fcons (langsys_tag
, feature_list
),
1744 script_list
= Fcons (Fcons (script_tag
, langsys_list
),
1749 XSETCAR (capability
, script_list
);
1751 XSETCDR (capability
, script_list
);
1757 /* Parse OTF features in SPEC and write a proper features spec string
1758 in FEATURES for the call of OTF_drive_gsub/gpos (of libotf). It is
1759 assured that the sufficient memory has already allocated for
1763 generate_otf_features (spec
, features
)
1773 for (asterisk
= 0; CONSP (spec
); spec
= XCDR (spec
))
1779 if (SREF (SYMBOL_NAME (val
), 0) == '*')
1784 else if (! asterisk
)
1786 val
= SYMBOL_NAME (val
);
1787 p
+= sprintf (p
, "%s", SDATA (val
));
1791 val
= SYMBOL_NAME (val
);
1792 p
+= sprintf (p
, "~%s", SDATA (val
));
1796 error ("OTF spec too long");
1801 font_otf_DeviceTable (device_table
)
1802 OTF_DeviceTable
*device_table
;
1804 int len
= device_table
->StartSize
- device_table
->EndSize
+ 1;
1806 return Fcons (make_number (len
),
1807 make_unibyte_string (device_table
->DeltaValue
, len
));
1811 font_otf_ValueRecord (value_format
, value_record
)
1813 OTF_ValueRecord
*value_record
;
1815 Lisp_Object val
= Fmake_vector (make_number (8), Qnil
);
1817 if (value_format
& OTF_XPlacement
)
1818 ASET (val
, 0, value_record
->XPlacement
);
1819 if (value_format
& OTF_YPlacement
)
1820 ASET (val
, 1, value_record
->YPlacement
);
1821 if (value_format
& OTF_XAdvance
)
1822 ASET (val
, 2, value_record
->XAdvance
);
1823 if (value_format
& OTF_YAdvance
)
1824 ASET (val
, 3, value_record
->YAdvance
);
1825 if (value_format
& OTF_XPlaDevice
)
1826 ASET (val
, 4, font_otf_DeviceTable (&value_record
->XPlaDevice
));
1827 if (value_format
& OTF_YPlaDevice
)
1828 ASET (val
, 4, font_otf_DeviceTable (&value_record
->YPlaDevice
));
1829 if (value_format
& OTF_XAdvDevice
)
1830 ASET (val
, 4, font_otf_DeviceTable (&value_record
->XAdvDevice
));
1831 if (value_format
& OTF_YAdvDevice
)
1832 ASET (val
, 4, font_otf_DeviceTable (&value_record
->YAdvDevice
));
1837 font_otf_Anchor (anchor
)
1842 val
= Fmake_vector (make_number (anchor
->AnchorFormat
+ 1), Qnil
);
1843 ASET (val
, 0, make_number (anchor
->XCoordinate
));
1844 ASET (val
, 1, make_number (anchor
->YCoordinate
));
1845 if (anchor
->AnchorFormat
== 2)
1846 ASET (val
, 2, make_number (anchor
->f
.f1
.AnchorPoint
));
1849 ASET (val
, 3, font_otf_DeviceTable (&anchor
->f
.f2
.XDeviceTable
));
1850 ASET (val
, 4, font_otf_DeviceTable (&anchor
->f
.f2
.YDeviceTable
));
1855 #endif /* HAVE_LIBOTF */
1857 /* G-string (glyph string) handler */
1859 /* G-string is a vector of the form [HEADER GLYPH ...].
1860 See the docstring of `font-make-gstring' for more detail. */
1863 font_prepare_composition (cmp
, f
)
1864 struct composition
*cmp
;
1868 = AREF (XHASH_TABLE (composition_hash_table
)->key_and_value
,
1869 cmp
->hash_index
* 2);
1871 cmp
->font
= XSAVE_VALUE (LGSTRING_FONT (gstring
))->pointer
;
1872 cmp
->glyph_len
= LGSTRING_LENGTH (gstring
);
1873 cmp
->pixel_width
= LGSTRING_WIDTH (gstring
);
1874 cmp
->lbearing
= LGSTRING_LBEARING (gstring
);
1875 cmp
->rbearing
= LGSTRING_RBEARING (gstring
);
1876 cmp
->ascent
= LGSTRING_ASCENT (gstring
);
1877 cmp
->descent
= LGSTRING_DESCENT (gstring
);
1878 cmp
->width
= cmp
->pixel_width
/ FRAME_COLUMN_WIDTH (f
);
1879 if (cmp
->width
== 0)
1888 static unsigned font_score
P_ ((Lisp_Object
, Lisp_Object
*));
1889 static int font_compare
P_ ((const void *, const void *));
1890 static Lisp_Object font_sort_entites
P_ ((Lisp_Object
, Lisp_Object
,
1891 Lisp_Object
, Lisp_Object
));
1893 /* We sort fonts by scoring each of them against a specified
1894 font-spec. The score value is 32 bit (`unsigned'), and the smaller
1895 the value is, the closer the font is to the font-spec.
1897 Each 1-bit of the highest 4 bits of the score is used for atomic
1898 properties FOUNDRY, FAMILY, ADSTYLE, and REGISTRY.
1900 Each 7-bit in the lowest 28 bits are used for numeric properties
1901 WEIGHT, SLANT, WIDTH, and SIZE. */
1903 /* How many bits to shift to store the difference value of each font
1904 property in a score. */
1905 static int sort_shift_bits
[FONT_SIZE_INDEX
+ 1];
1907 /* Score font-entity ENTITY against properties of font-spec SPEC_PROP.
1908 The return value indicates how different ENTITY is compared with
1912 font_score (entity
, spec_prop
)
1913 Lisp_Object entity
, *spec_prop
;
1917 /* Score four atomic fields. Maximum difference is 1. */
1918 for (i
= FONT_FOUNDRY_INDEX
; i
<= FONT_REGISTRY_INDEX
; i
++)
1919 if (! NILP (spec_prop
[i
])
1920 && ! EQ (spec_prop
[i
], AREF (entity
, i
)))
1921 score
|= 1 << sort_shift_bits
[i
];
1923 /* Score four numeric fields. Maximum difference is 127. */
1924 for (i
= FONT_WEIGHT_INDEX
; i
<= FONT_SIZE_INDEX
; i
++)
1926 Lisp_Object entity_val
= AREF (entity
, i
);
1927 Lisp_Object spec_val
= spec_prop
[i
];
1929 /* If weight and slant are unspecified, score normal lower (low wins). */
1930 if (NILP (spec_val
))
1932 if (i
== FONT_WEIGHT_INDEX
|| i
== FONT_SLANT_INDEX
)
1933 spec_val
= prop_name_to_numeric (i
, build_string ("normal"));
1936 if (! NILP (spec_val
) && ! EQ (spec_val
, entity_val
))
1938 if (! INTEGERP (entity_val
))
1939 score
|= 127 << sort_shift_bits
[i
];
1942 int diff
= XINT (entity_val
) - XINT (spec_val
);
1946 if (i
== FONT_SIZE_INDEX
)
1948 if (XINT (entity_val
) > 0
1949 && diff
> FONT_PIXEL_SIZE_QUANTUM
)
1950 score
|= min (diff
, 127) << sort_shift_bits
[i
];
1953 else if (i
== FONT_WEIGHT_INDEX
)
1955 /* Windows uses a much wider range for weight (100-900)
1956 compared with freetype (0-210), so scale down the
1957 difference. A more general way of doing this
1958 would be to look up the values of regular and bold
1959 and/or light and calculate the scale factor from them,
1960 but the lookup would be expensive, and if only Windows
1961 needs it, not worth the effort. */
1962 score
|= min (diff
/ 4, 127) << sort_shift_bits
[i
];
1966 score
|= min (diff
, 127) << sort_shift_bits
[i
];
1975 /* The comparison function for qsort. */
1978 font_compare (d1
, d2
)
1979 const void *d1
, *d2
;
1981 return (*(unsigned *) d1
< *(unsigned *) d2
1982 ? -1 : *(unsigned *) d1
> *(unsigned *) d2
);
1986 /* The structure for elements being sorted by qsort. */
1987 struct font_sort_data
1994 /* Sort font-entities in vector VEC by closeness to font-spec PREFER.
1995 If PREFER specifies a point-size, calculate the corresponding
1996 pixel-size from QCdpi property of PREFER or from the Y-resolution
1997 of FRAME before sorting. If SPEC is not nil, it is a font-spec to
1998 get the font-entities in VEC. */
2001 font_sort_entites (vec
, prefer
, frame
, spec
)
2002 Lisp_Object vec
, prefer
, frame
, spec
;
2004 Lisp_Object prefer_prop
[FONT_SPEC_MAX
];
2006 struct font_sort_data
*data
;
2013 for (i
= FONT_FOUNDRY_INDEX
; i
<= FONT_SIZE_INDEX
; i
++)
2014 prefer_prop
[i
] = AREF (prefer
, i
);
2018 /* As it is assured that all fonts in VEC match with SPEC, we
2019 should ignore properties specified in SPEC. So, set the
2020 corresponding properties in PREFER_PROP to nil. */
2021 for (i
= FONT_WEIGHT_INDEX
; i
<= FONT_SIZE_INDEX
; i
++)
2022 if (! NILP (AREF (spec
, i
)))
2023 prefer_prop
[i
++] = Qnil
;
2026 if (FLOATP (prefer_prop
[FONT_SIZE_INDEX
]))
2027 prefer_prop
[FONT_SIZE_INDEX
]
2028 = make_number (font_pixel_size (XFRAME (frame
), prefer
));
2030 /* Scoring and sorting. */
2031 SAFE_ALLOCA (data
, struct font_sort_data
*, (sizeof *data
) * len
);
2032 for (i
= 0; i
< len
; i
++)
2034 data
[i
].entity
= AREF (vec
, i
);
2035 data
[i
].score
= font_score (data
[i
].entity
, prefer_prop
);
2037 qsort (data
, len
, sizeof *data
, font_compare
);
2038 for (i
= 0; i
< len
; i
++)
2039 ASET (vec
, i
, data
[i
].entity
);
2046 /* API of Font Service Layer. */
2048 /* Reflect ORDER (see the variable font_sort_order in xfaces.c) to
2049 sort_shift_bits. Finternal_set_font_selection_order calls this
2050 function with font_sort_order after setting up it. */
2053 font_update_sort_order (order
)
2056 int i
, shift_bits
= 21;
2058 for (i
= 0; i
< 4; i
++, shift_bits
-= 7)
2060 int xlfd_idx
= order
[i
];
2062 if (xlfd_idx
== XLFD_WEIGHT_INDEX
)
2063 sort_shift_bits
[FONT_WEIGHT_INDEX
] = shift_bits
;
2064 else if (xlfd_idx
== XLFD_SLANT_INDEX
)
2065 sort_shift_bits
[FONT_SLANT_INDEX
] = shift_bits
;
2066 else if (xlfd_idx
== XLFD_SWIDTH_INDEX
)
2067 sort_shift_bits
[FONT_WIDTH_INDEX
] = shift_bits
;
2069 sort_shift_bits
[FONT_SIZE_INDEX
] = shift_bits
;
2074 /* Return weight property of FONT as symbol. */
2077 font_symbolic_weight (font
)
2080 Lisp_Object weight
= AREF (font
, FONT_WEIGHT_INDEX
);
2082 if (INTEGERP (weight
))
2083 weight
= prop_numeric_to_name (FONT_WEIGHT_INDEX
, XINT (weight
));
2088 /* Return slant property of FONT as symbol. */
2091 font_symbolic_slant (font
)
2094 Lisp_Object slant
= AREF (font
, FONT_SLANT_INDEX
);
2096 if (INTEGERP (slant
))
2097 slant
= prop_numeric_to_name (FONT_SLANT_INDEX
, XINT (slant
));
2102 /* Return width property of FONT as symbol. */
2105 font_symbolic_width (font
)
2108 Lisp_Object width
= AREF (font
, FONT_WIDTH_INDEX
);
2110 if (INTEGERP (width
))
2111 width
= prop_numeric_to_name (FONT_WIDTH_INDEX
, XINT (width
));
2116 /* Check if ENTITY matches with the font specification SPEC. */
2119 font_match_p (spec
, entity
)
2120 Lisp_Object spec
, entity
;
2124 for (i
= FONT_FOUNDRY_INDEX
; i
< FONT_SIZE_INDEX
; i
++)
2125 if (! NILP (AREF (spec
, i
))
2126 && ! EQ (AREF (spec
, i
), AREF (entity
, i
)))
2128 if (INTEGERP (AREF (spec
, FONT_SIZE_INDEX
))
2129 && XINT (AREF (entity
, FONT_SIZE_INDEX
)) > 0
2130 && (XINT (AREF (spec
, FONT_SIZE_INDEX
))
2131 != XINT (AREF (entity
, FONT_SIZE_INDEX
))))
2137 /* Return a lispy font object corresponding to FONT. */
2140 font_find_object (font
)
2143 Lisp_Object tail
, elt
;
2145 for (tail
= AREF (font
->entity
, FONT_OBJLIST_INDEX
); CONSP (tail
);
2149 if (font
== XSAVE_VALUE (elt
)->pointer
2150 && XSAVE_VALUE (elt
)->integer
> 0)
2160 Each font backend has the callback function get_cache, and it
2161 returns a cons cell of which cdr part can be freely used for
2162 caching fonts. The cons cell may be shared by multiple frames
2163 and/or multiple font drivers. So, we arrange the cdr part as this:
2165 ((DRIVER-TYPE NUM-FRAMES FONT-CACHE-DATA ...) ...)
2167 where DRIVER-TYPE is a symbol such as `x', `xft', etc., NUM-FRAMES
2168 is a number frames sharing this cache, and FONT-CACHE-DATA is a
2169 cons (FONT-SPEC FONT-ENTITY ...). */
2171 static void font_prepare_cache
P_ ((FRAME_PTR
, struct font_driver
*));
2172 static void font_finish_cache
P_ ((FRAME_PTR
, struct font_driver
*));
2173 static Lisp_Object font_get_cache
P_ ((FRAME_PTR
, struct font_driver
*));
2174 static void font_clear_cache
P_ ((FRAME_PTR
, Lisp_Object
,
2175 struct font_driver
*));
2178 font_prepare_cache (f
, driver
)
2180 struct font_driver
*driver
;
2182 Lisp_Object cache
, val
;
2184 cache
= driver
->get_cache (f
);
2186 while (CONSP (val
) && ! EQ (XCAR (XCAR (val
)), driver
->type
))
2190 val
= Fcons (driver
->type
, Fcons (make_number (1), Qnil
));
2191 XSETCDR (cache
, Fcons (val
, XCDR (cache
)));
2195 val
= XCDR (XCAR (val
));
2196 XSETCAR (val
, make_number (XINT (XCAR (val
)) + 1));
2201 font_finish_cache (f
, driver
)
2203 struct font_driver
*driver
;
2205 Lisp_Object cache
, val
, tmp
;
2208 cache
= driver
->get_cache (f
);
2210 while (CONSP (val
) && ! EQ (XCAR (XCAR (val
)), driver
->type
))
2211 cache
= val
, val
= XCDR (val
);
2212 xassert (! NILP (val
));
2213 tmp
= XCDR (XCAR (val
));
2214 if (XINT (XCAR (tmp
)) == 0)
2216 font_clear_cache (f
, XCAR (val
), driver
);
2217 XSETCDR (cache
, XCDR (val
));
2221 XSETCAR (tmp
, make_number (XINT (XCAR (tmp
)) - 1));
2226 font_get_cache (f
, driver
)
2228 struct font_driver
*driver
;
2230 Lisp_Object val
= driver
->get_cache (f
);
2231 Lisp_Object type
= driver
->type
;
2233 xassert (CONSP (val
));
2234 for (val
= XCDR (val
); ! EQ (XCAR (XCAR (val
)), type
); val
= XCDR (val
));
2235 xassert (CONSP (val
));
2236 /* VAL = ((DRIVER-TYPE NUM-FRAMES FONT-CACHE-DATA ...) ...) */
2237 val
= XCDR (XCAR (val
));
2242 font_clear_cache (f
, cache
, driver
)
2245 struct font_driver
*driver
;
2247 Lisp_Object tail
, elt
;
2249 /* CACHE = (DRIVER-TYPE NUM-FRAMES FONT-CACHE-DATA ...) */
2250 for (tail
= XCDR (XCDR (cache
)); CONSP (tail
); tail
= XCDR (tail
))
2253 if (CONSP (elt
) && FONT_SPEC_P (XCAR (elt
)))
2255 Lisp_Object vec
= XCDR (elt
);
2258 for (i
= 0; i
< ASIZE (vec
); i
++)
2260 Lisp_Object entity
= AREF (vec
, i
);
2262 if (EQ (driver
->type
, AREF (entity
, FONT_TYPE_INDEX
)))
2264 Lisp_Object objlist
= AREF (entity
, FONT_OBJLIST_INDEX
);
2266 for (; CONSP (objlist
); objlist
= XCDR (objlist
))
2268 Lisp_Object val
= XCAR (objlist
);
2269 struct Lisp_Save_Value
*p
= XSAVE_VALUE (val
);
2270 struct font
*font
= p
->pointer
;
2272 xassert (font
&& driver
== font
->driver
);
2273 driver
->close (f
, font
);
2277 if (driver
->free_entity
)
2278 driver
->free_entity (entity
);
2283 XSETCDR (cache
, Qnil
);
2287 static Lisp_Object scratch_font_spec
, scratch_font_prefer
;
2290 /* Return a vector of font-entities matching with SPEC on frame F. */
2293 font_list_entities (frame
, spec
)
2294 Lisp_Object frame
, spec
;
2296 FRAME_PTR f
= XFRAME (frame
);
2297 struct font_driver_list
*driver_list
= f
->font_driver_list
;
2298 Lisp_Object ftype
, family
, size
, alternate_familes
;
2299 Lisp_Object
*vec
= alloca (sizeof (Lisp_Object
) * num_font_drivers
);
2305 family
= AREF (spec
, FONT_FAMILY_INDEX
);
2307 alternate_familes
= Qnil
;
2310 if (NILP (font_family_alist
)
2311 && !NILP (Vface_alternative_font_family_alist
))
2312 build_font_family_alist ();
2313 alternate_familes
= assq_no_quit (family
, font_family_alist
);
2314 if (! NILP (alternate_familes
))
2315 alternate_familes
= XCDR (alternate_familes
);
2317 size
= AREF (spec
, FONT_SIZE_INDEX
);
2319 ASET (spec
, FONT_SIZE_INDEX
, make_number (font_pixel_size (f
, spec
)));
2321 xassert (ASIZE (spec
) == FONT_SPEC_MAX
);
2322 ftype
= AREF (spec
, FONT_TYPE_INDEX
);
2324 for (i
= 0; driver_list
; driver_list
= driver_list
->next
)
2326 && (NILP (ftype
) || EQ (driver_list
->driver
->type
, ftype
)))
2328 Lisp_Object cache
= font_get_cache (f
, driver_list
->driver
);
2329 Lisp_Object tail
= alternate_familes
;
2331 ASET (spec
, FONT_TYPE_INDEX
, driver_list
->driver
->type
);
2332 ASET (spec
, FONT_FAMILY_INDEX
, family
);
2336 Lisp_Object val
= assoc_no_quit (spec
, XCDR (cache
));
2342 val
= driver_list
->driver
->list (frame
, spec
);
2344 XSETCDR (cache
, Fcons (Fcons (Fcopy_sequence (spec
), val
),
2347 if (VECTORP (val
) && ASIZE (val
) > 0)
2354 ASET (spec
, FONT_FAMILY_INDEX
, XCAR (tail
));
2358 ASET (spec
, FONT_TYPE_INDEX
, ftype
);
2359 ASET (spec
, FONT_FAMILY_INDEX
, family
);
2360 ASET (spec
, FONT_SIZE_INDEX
, size
);
2361 return (i
> 0 ? Fvconcat (i
, vec
) : null_vector
);
2365 /* Return a font entity matching with SPEC on FRAME. */
2368 font_matching_entity (frame
, spec
)
2369 Lisp_Object frame
, spec
;
2371 FRAME_PTR f
= XFRAME (frame
);
2372 struct font_driver_list
*driver_list
= f
->font_driver_list
;
2373 Lisp_Object ftype
, size
, entity
;
2375 ftype
= AREF (spec
, FONT_TYPE_INDEX
);
2376 size
= AREF (spec
, FONT_SIZE_INDEX
);
2378 ASET (spec
, FONT_SIZE_INDEX
, make_number (font_pixel_size (f
, spec
)));
2380 for (; driver_list
; driver_list
= driver_list
->next
)
2382 && (NILP (ftype
) || EQ (driver_list
->driver
->type
, ftype
)))
2384 Lisp_Object cache
= font_get_cache (f
, driver_list
->driver
);
2387 ASET (spec
, FONT_TYPE_INDEX
, driver_list
->driver
->type
);
2388 key
= Fcons (spec
, Qnil
);
2389 entity
= assoc_no_quit (key
, XCDR (cache
));
2391 entity
= XCDR (entity
);
2394 entity
= driver_list
->driver
->match (frame
, spec
);
2395 if (! NILP (entity
))
2397 XSETCAR (key
, Fcopy_sequence (spec
));
2398 XSETCDR (cache
, Fcons (Fcons (key
, entity
), XCDR (cache
)));
2401 if (! NILP (entity
))
2404 ASET (spec
, FONT_TYPE_INDEX
, ftype
);
2405 ASET (spec
, FONT_SIZE_INDEX
, size
);
2409 static int num_fonts
;
2412 /* Open a font of ENTITY and PIXEL_SIZE on frame F, and return the
2413 opened font object. */
2416 font_open_entity (f
, entity
, pixel_size
)
2421 struct font_driver_list
*driver_list
;
2422 Lisp_Object objlist
, size
, val
;
2425 size
= AREF (entity
, FONT_SIZE_INDEX
);
2426 xassert (NATNUMP (size
));
2427 if (XINT (size
) != 0)
2428 pixel_size
= XINT (size
);
2430 for (objlist
= AREF (entity
, FONT_OBJLIST_INDEX
); CONSP (objlist
);
2431 objlist
= XCDR (objlist
))
2433 font
= XSAVE_VALUE (XCAR (objlist
))->pointer
;
2434 if (font
->pixel_size
== pixel_size
)
2436 XSAVE_VALUE (XCAR (objlist
))->integer
++;
2437 return XCAR (objlist
);
2441 xassert (FONT_ENTITY_P (entity
));
2442 val
= AREF (entity
, FONT_TYPE_INDEX
);
2443 for (driver_list
= f
->font_driver_list
;
2444 driver_list
&& ! EQ (driver_list
->driver
->type
, val
);
2445 driver_list
= driver_list
->next
);
2449 font
= driver_list
->driver
->open (f
, entity
, pixel_size
);
2452 font
->scalable
= XINT (size
) == 0;
2454 val
= make_save_value (font
, 1);
2455 ASET (entity
, FONT_OBJLIST_INDEX
,
2456 Fcons (val
, AREF (entity
, FONT_OBJLIST_INDEX
)));
2462 /* Close FONT_OBJECT that is opened on frame F. */
2465 font_close_object (f
, font_object
)
2467 Lisp_Object font_object
;
2469 struct font
*font
= XSAVE_VALUE (font_object
)->pointer
;
2470 Lisp_Object objlist
;
2471 Lisp_Object tail
, prev
= Qnil
;
2473 XSAVE_VALUE (font_object
)->integer
--;
2474 xassert (XSAVE_VALUE (font_object
)->integer
>= 0);
2475 if (XSAVE_VALUE (font_object
)->integer
> 0)
2478 objlist
= AREF (font
->entity
, FONT_OBJLIST_INDEX
);
2479 for (prev
= Qnil
, tail
= objlist
; CONSP (tail
);
2480 prev
= tail
, tail
= XCDR (tail
))
2481 if (EQ (font_object
, XCAR (tail
)))
2483 if (font
->driver
->close
)
2484 font
->driver
->close (f
, font
);
2485 XSAVE_VALUE (font_object
)->pointer
= NULL
;
2487 ASET (font
->entity
, FONT_OBJLIST_INDEX
, XCDR (objlist
));
2489 XSETCDR (prev
, XCDR (objlist
));
2496 /* Return 1 if FONT on F has a glyph for character C, 0 if not, -1 if
2497 FONT is a font-entity and it must be opened to check. */
2500 font_has_char (f
, font
, c
)
2507 if (FONT_ENTITY_P (font
))
2509 Lisp_Object type
= AREF (font
, FONT_TYPE_INDEX
);
2510 struct font_driver_list
*driver_list
;
2512 for (driver_list
= f
->font_driver_list
;
2513 driver_list
&& ! EQ (driver_list
->driver
->type
, type
);
2514 driver_list
= driver_list
->next
);
2517 if (! driver_list
->driver
->has_char
)
2519 return driver_list
->driver
->has_char (font
, c
);
2522 xassert (FONT_OBJECT_P (font
));
2523 fontp
= XSAVE_VALUE (font
)->pointer
;
2525 if (fontp
->driver
->has_char
)
2527 int result
= fontp
->driver
->has_char (fontp
->entity
, c
);
2532 return (fontp
->driver
->encode_char (fontp
, c
) != FONT_INVALID_CODE
);
2536 /* Return the glyph ID of FONT_OBJECT for character C. */
2539 font_encode_char (font_object
, c
)
2540 Lisp_Object font_object
;
2543 struct font
*font
= XSAVE_VALUE (font_object
)->pointer
;
2545 return font
->driver
->encode_char (font
, c
);
2549 /* Return the name of FONT_OBJECT. */
2552 font_get_name (font_object
)
2553 Lisp_Object font_object
;
2555 struct font
*font
= XSAVE_VALUE (font_object
)->pointer
;
2556 char *name
= (font
->font
.full_name
? font
->font
.full_name
2557 : font
->font
.name
? font
->font
.name
2560 return (name
? make_unibyte_string (name
, strlen (name
)) : null_string
);
2564 /* Return the specification of FONT_OBJECT. */
2567 font_get_spec (font_object
)
2568 Lisp_Object font_object
;
2570 struct font
*font
= XSAVE_VALUE (font_object
)->pointer
;
2571 Lisp_Object spec
= Ffont_spec (0, NULL
);
2574 for (i
= 0; i
< FONT_SIZE_INDEX
; i
++)
2575 ASET (spec
, i
, AREF (font
->entity
, i
));
2576 ASET (spec
, FONT_SIZE_INDEX
, make_number (font
->pixel_size
));
2581 /* Return the frame on which FONT exists. FONT is a font object or a
2585 font_get_frame (font
)
2588 if (FONT_OBJECT_P (font
))
2589 font
= ((struct font
*) XSAVE_VALUE (font
)->pointer
)->entity
;
2590 xassert (FONT_ENTITY_P (font
));
2591 return AREF (font
, FONT_FRAME_INDEX
);
2595 /* Find a font entity best matching with LFACE. If SPEC is non-nil,
2596 the font must exactly match with it. C, if not negative, is a
2597 character that the entity must support. */
2600 font_find_for_lface (f
, lface
, spec
, c
)
2606 Lisp_Object frame
, entities
, val
;
2609 XSETFRAME (frame
, f
);
2615 for (i
= 0; i
< FONT_SPEC_MAX
; i
++)
2616 ASET (scratch_font_spec
, i
, Qnil
);
2617 ASET (scratch_font_spec
, FONT_REGISTRY_INDEX
, Qiso8859_1
);
2619 if (! NILP (lface
[LFACE_FAMILY_INDEX
]))
2620 font_merge_old_spec (Qnil
, lface
[LFACE_FAMILY_INDEX
], Qnil
,
2622 entities
= font_list_entities (frame
, scratch_font_spec
);
2623 while (ASIZE (entities
) == 0)
2625 /* Try without FOUNDRY or FAMILY. */
2626 if (! NILP (AREF (scratch_font_spec
, FONT_FOUNDRY_INDEX
)))
2628 ASET (scratch_font_spec
, FONT_FOUNDRY_INDEX
, Qnil
);
2629 entities
= font_list_entities (frame
, scratch_font_spec
);
2631 else if (! NILP (AREF (scratch_font_spec
, FONT_FAMILY_INDEX
)))
2633 ASET (scratch_font_spec
, FONT_FAMILY_INDEX
, Qnil
);
2634 entities
= font_list_entities (frame
, scratch_font_spec
);
2642 Lisp_Object registry
= AREF (spec
, FONT_REGISTRY_INDEX
);
2644 if (NILP (registry
))
2645 registry
= Qiso8859_1
;
2649 struct charset
*encoding
, *repertory
;
2651 if (font_registry_charsets (registry
, &encoding
, &repertory
) < 0)
2655 if (ENCODE_CHAR (repertory
, c
)
2656 == CHARSET_INVALID_CODE (repertory
))
2658 /* Any font of this registry support C. So, let's
2659 suppress the further checking. */
2662 else if (c
> encoding
->max_char
)
2665 for (i
= 0; i
< FONT_SPEC_MAX
; i
++)
2666 ASET (scratch_font_spec
, i
, AREF (spec
, i
));
2667 ASET (scratch_font_spec
, FONT_REGISTRY_INDEX
, registry
);
2668 entities
= font_list_entities (frame
, scratch_font_spec
);
2671 if (ASIZE (entities
) == 0)
2673 if (ASIZE (entities
) > 1)
2675 /* Sort fonts by properties specified in LFACE. */
2676 Lisp_Object prefer
= scratch_font_prefer
;
2679 if (! NILP (lface
[LFACE_FAMILY_INDEX
]))
2680 font_merge_old_spec (Qnil
, lface
[LFACE_FAMILY_INDEX
], Qnil
, prefer
);
2681 ASET (prefer
, FONT_WEIGHT_INDEX
,
2682 font_prop_validate_style (QCweight
, lface
[LFACE_WEIGHT_INDEX
]));
2683 ASET (prefer
, FONT_SLANT_INDEX
,
2684 font_prop_validate_style (QCslant
, lface
[LFACE_SLANT_INDEX
]));
2685 ASET (prefer
, FONT_WIDTH_INDEX
,
2686 font_prop_validate_style (QCwidth
, lface
[LFACE_SWIDTH_INDEX
]));
2687 pt
= XINT (lface
[LFACE_HEIGHT_INDEX
]);
2688 ASET (prefer
, FONT_SIZE_INDEX
, make_float (pt
/ 10));
2690 font_sort_entites (entities
, prefer
, frame
, spec
);
2694 return AREF (entities
, 0);
2696 val
= AREF (entities
, 0);
2697 result
= font_has_char (f
, val
, c
);
2702 val
= font_open_for_lface (f
, val
, lface
, spec
);
2705 result
= font_has_char (f
, val
, c
);
2706 font_close_object (f
, val
);
2714 font_open_for_lface (f
, entity
, lface
, spec
)
2722 if (FONT_SPEC_P (spec
) && INTEGERP (AREF (spec
, FONT_SIZE_INDEX
)))
2723 size
= XINT (AREF (spec
, FONT_SIZE_INDEX
));
2726 double pt
= XINT (lface
[LFACE_HEIGHT_INDEX
]);
2729 size
= POINT_TO_PIXEL (pt
, f
->resy
);
2731 return font_open_entity (f
, entity
, size
);
2735 /* Load a font best matching with FACE's font-related properties into
2736 FACE on frame F. If no proper font is found, record that FACE has
2740 font_load_for_face (f
, face
)
2744 Lisp_Object font_object
= face
->lface
[LFACE_FONT_INDEX
];
2746 if (NILP (font_object
))
2748 Lisp_Object entity
= font_find_for_lface (f
, face
->lface
, Qnil
, -1);
2750 if (! NILP (entity
))
2751 font_object
= font_open_for_lface (f
, entity
, face
->lface
, Qnil
);
2753 else if (STRINGP (font_object
))
2755 font_object
= font_open_by_name (f
, SDATA (font_object
));
2758 if (! NILP (font_object
))
2760 struct font
*font
= XSAVE_VALUE (font_object
)->pointer
;
2762 face
->font
= font
->font
.font
;
2763 face
->font_info
= (struct font_info
*) font
;
2764 face
->font_info_id
= 0;
2765 face
->font_name
= font
->font
.full_name
;
2770 face
->font_info
= NULL
;
2771 face
->font_info_id
= -1;
2772 face
->font_name
= NULL
;
2773 add_to_log ("Unable to load font for a face%s", null_string
, Qnil
);
2778 /* Make FACE on frame F ready to use the font opened for FACE. */
2781 font_prepare_for_face (f
, face
)
2785 struct font
*font
= (struct font
*) face
->font_info
;
2787 if (font
->driver
->prepare_face
)
2788 font
->driver
->prepare_face (f
, face
);
2792 /* Make FACE on frame F stop using the font opened for FACE. */
2795 font_done_for_face (f
, face
)
2799 struct font
*font
= (struct font
*) face
->font_info
;
2801 if (font
->driver
->done_face
)
2802 font
->driver
->done_face (f
, face
);
2807 /* Open a font best matching with NAME on frame F. If no proper font
2808 is found, return Qnil. */
2811 font_open_by_name (f
, name
)
2815 Lisp_Object args
[2];
2816 Lisp_Object spec
, prefer
, size
, entity
, entity_list
;
2821 XSETFRAME (frame
, f
);
2824 args
[1] = make_unibyte_string (name
, strlen (name
));
2825 spec
= Ffont_spec (2, args
);
2826 prefer
= scratch_font_prefer
;
2827 for (i
= FONT_WEIGHT_INDEX
; i
< FONT_SIZE_INDEX
; i
++)
2828 if (NILP (AREF (spec
, i
)))
2829 ASET (prefer
, i
, make_number (100));
2830 size
= AREF (spec
, FONT_SIZE_INDEX
);
2833 else if (INTEGERP (size
))
2834 pixel_size
= XINT (size
);
2835 else /* FLOATP (size) */
2837 double pt
= XFLOAT_DATA (size
);
2839 pixel_size
= POINT_TO_PIXEL (pt
, f
->resy
);
2840 size
= make_number (pixel_size
);
2841 ASET (spec
, FONT_SIZE_INDEX
, size
);
2843 if (pixel_size
== 0)
2845 pixel_size
= POINT_TO_PIXEL (12.0, f
->resy
);
2846 size
= make_number (pixel_size
);
2848 ASET (prefer
, FONT_SIZE_INDEX
, size
);
2849 if (NILP (AREF (spec
, FONT_REGISTRY_INDEX
)))
2850 ASET (spec
, FONT_REGISTRY_INDEX
, Qiso8859_1
);
2852 entity_list
= Flist_fonts (spec
, frame
, make_number (1), prefer
);
2853 if (NILP (entity_list
))
2854 entity
= font_matching_entity (frame
, spec
);
2856 entity
= XCAR (entity_list
);
2857 return (NILP (entity
)
2859 : font_open_entity (f
, entity
, pixel_size
));
2863 /* Register font-driver DRIVER. This function is used in two ways.
2865 The first is with frame F non-NULL. In this case, make DRIVER
2866 available (but not yet activated) on F. All frame creaters
2867 (e.g. Fx_create_frame) must call this function at least once with
2868 an available font-driver.
2870 The second is with frame F NULL. In this case, DRIVER is globally
2871 registered in the variable `font_driver_list'. All font-driver
2872 implementations must call this function in its syms_of_XXXX
2873 (e.g. syms_of_xfont). */
2876 register_font_driver (driver
, f
)
2877 struct font_driver
*driver
;
2880 struct font_driver_list
*root
= f
? f
->font_driver_list
: font_driver_list
;
2881 struct font_driver_list
*prev
, *list
;
2883 if (f
&& ! driver
->draw
)
2884 error ("Unsable font driver for a frame: %s",
2885 SDATA (SYMBOL_NAME (driver
->type
)));
2887 for (prev
= NULL
, list
= root
; list
; prev
= list
, list
= list
->next
)
2888 if (EQ (list
->driver
->type
, driver
->type
))
2889 error ("Duplicated font driver: %s", SDATA (SYMBOL_NAME (driver
->type
)));
2891 list
= malloc (sizeof (struct font_driver_list
));
2893 list
->driver
= driver
;
2898 f
->font_driver_list
= list
;
2900 font_driver_list
= list
;
2905 /* Free font-driver list on frame F. It doesn't free font-drivers
2909 free_font_driver_list (f
)
2912 while (f
->font_driver_list
)
2914 struct font_driver_list
*next
= f
->font_driver_list
->next
;
2916 free (f
->font_driver_list
);
2917 f
->font_driver_list
= next
;
2922 /* Make the frame F use font backends listed in NEW_DRIVERS (list of
2923 symbols, e.g. xft, x). If NEW_DRIVERS is t, make F use all
2924 available font drivers. If NEW_DRIVERS is nil, finalize all drivers.
2926 A caller must free all realized faces if any in advance. The
2927 return value is a list of font backends actually made used on
2931 font_update_drivers (f
, new_drivers
)
2933 Lisp_Object new_drivers
;
2935 Lisp_Object active_drivers
= Qnil
;
2936 struct font_driver_list
*list
;
2938 for (list
= f
->font_driver_list
; list
; list
= list
->next
)
2941 if (! EQ (new_drivers
, Qt
)
2942 && NILP (Fmemq (list
->driver
->type
, new_drivers
)))
2944 if (list
->driver
->end_for_frame
)
2945 list
->driver
->end_for_frame (f
);
2946 font_finish_cache (f
, list
->driver
);
2952 if (EQ (new_drivers
, Qt
)
2953 || ! NILP (Fmemq (list
->driver
->type
, new_drivers
)))
2955 if (! list
->driver
->start_for_frame
2956 || list
->driver
->start_for_frame (f
) == 0)
2958 font_prepare_cache (f
, list
->driver
);
2960 active_drivers
= nconc2 (active_drivers
,
2961 Fcons (list
->driver
->type
, Qnil
));
2966 return active_drivers
;
2970 font_put_frame_data (f
, driver
, data
)
2972 struct font_driver
*driver
;
2975 struct font_data_list
*list
, *prev
;
2977 for (prev
= NULL
, list
= f
->font_data_list
; list
;
2978 prev
= list
, list
= list
->next
)
2979 if (list
->driver
== driver
)
2986 prev
->next
= list
->next
;
2988 f
->font_data_list
= list
->next
;
2996 list
= malloc (sizeof (struct font_data_list
));
2999 list
->driver
= driver
;
3000 list
->next
= f
->font_data_list
;
3001 f
->font_data_list
= list
;
3009 font_get_frame_data (f
, driver
)
3011 struct font_driver
*driver
;
3013 struct font_data_list
*list
;
3015 for (list
= f
->font_data_list
; list
; list
= list
->next
)
3016 if (list
->driver
== driver
)
3024 /* Return the font used to draw character C by FACE at buffer position
3025 POS in window W. If STRING is non-nil, it is a string containing C
3026 at index POS. If C is negative, get C from the current buffer or
3030 font_at (c
, pos
, face
, w
, string
)
3044 multibyte
= ! NILP (current_buffer
->enable_multibyte_characters
);
3047 EMACS_INT pos_byte
= CHAR_TO_BYTE (pos
);
3049 c
= FETCH_CHAR (pos_byte
);
3052 c
= FETCH_BYTE (pos
);
3058 multibyte
= STRING_MULTIBYTE (string
);
3061 EMACS_INT pos_byte
= string_char_to_byte (string
, pos
);
3063 str
= SDATA (string
) + pos_byte
;
3064 c
= STRING_CHAR (str
, 0);
3067 c
= SDATA (string
)[pos
];
3071 f
= XFRAME (w
->frame
);
3072 if (! FRAME_WINDOW_P (f
))
3079 if (STRINGP (string
))
3080 face_id
= face_at_string_position (w
, string
, pos
, 0, -1, -1, &endptr
,
3081 DEFAULT_FACE_ID
, 0);
3083 face_id
= face_at_buffer_position (w
, pos
, -1, -1, &endptr
,
3085 face
= FACE_FROM_ID (f
, face_id
);
3089 int face_id
= FACE_FOR_CHAR (f
, face
, c
, pos
, string
);
3090 face
= FACE_FROM_ID (f
, face_id
);
3092 if (! face
->font_info
)
3094 return font_find_object ((struct font
*) face
->font_info
);
3100 DEFUN ("fontp", Ffontp
, Sfontp
, 1, 1, 0,
3101 doc
: /* Return t if OBJECT is a font-spec, font-entity, or font-object.
3102 Return nil otherwise. */)
3106 return (FONTP (object
) ? Qt
: Qnil
);
3109 DEFUN ("font-spec", Ffont_spec
, Sfont_spec
, 0, MANY
, 0,
3110 doc
: /* Return a newly created font-spec with arguments as properties.
3112 ARGS must come in pairs KEY VALUE of font properties. KEY must be a
3113 valid font property name listed below:
3115 `:family', `:weight', `:slant', `:width'
3117 They are the same as face attributes of the same name. See
3118 `set-face-attribute.
3122 VALUE must be a string or a symbol specifying the font foundry, e.g. ``misc''.
3126 VALUE must be a string or a symbol specifying the additional
3127 typographic style information of a font, e.g. ``sans''. Usually null.
3131 VALUE must be a string or a symbol specifying the charset registry and
3132 encoding of a font, e.g. ``iso8859-1''.
3136 VALUE must be a non-negative integer or a floating point number
3137 specifying the font size. It specifies the font size in 1/10 pixels
3138 (if VALUE is an integer), or in points (if VALUE is a float).
3139 usage: (font-spec ARGS ...) */)
3144 Lisp_Object spec
= Fmake_vector (make_number (FONT_SPEC_MAX
), Qnil
);
3147 for (i
= 0; i
< nargs
; i
+= 2)
3149 enum font_property_index prop
;
3150 Lisp_Object key
= args
[i
], val
= args
[i
+ 1];
3152 prop
= get_font_prop_index (key
, 0);
3153 if (prop
< FONT_EXTRA_INDEX
)
3154 ASET (spec
, prop
, val
);
3157 if (EQ (key
, QCname
))
3160 font_parse_name ((char *) SDATA (val
), spec
);
3162 font_put_extra (spec
, key
, val
);
3165 CHECK_VALIDATE_FONT_SPEC (spec
);
3170 DEFUN ("font-get", Ffont_get
, Sfont_get
, 2, 2, 0,
3171 doc
: /* Return the value of FONT's property KEY.
3172 FONT is a font-spec, a font-entity, or a font-object. */)
3174 Lisp_Object font
, key
;
3176 enum font_property_index idx
;
3178 if (FONT_OBJECT_P (font
))
3180 struct font
*fontp
= XSAVE_VALUE (font
)->pointer
;
3182 if (EQ (key
, QCotf
))
3184 if (fontp
->driver
->otf_capability
)
3185 return fontp
->driver
->otf_capability (fontp
);
3189 font
= fontp
->entity
;
3193 idx
= get_font_prop_index (key
, 0);
3194 if (idx
< FONT_EXTRA_INDEX
)
3195 return AREF (font
, idx
);
3196 if (FONT_ENTITY_P (font
))
3198 return Fcdr (Fassoc (key
, AREF (font
, FONT_EXTRA_INDEX
)));
3202 DEFUN ("font-put", Ffont_put
, Sfont_put
, 3, 3, 0,
3203 doc
: /* Set one property of FONT-SPEC: give property KEY value VALUE. */)
3204 (font_spec
, prop
, val
)
3205 Lisp_Object font_spec
, prop
, val
;
3207 enum font_property_index idx
;
3208 Lisp_Object extra
, slot
;
3210 CHECK_FONT_SPEC (font_spec
);
3211 idx
= get_font_prop_index (prop
, 0);
3212 if (idx
< FONT_EXTRA_INDEX
)
3213 return ASET (font_spec
, idx
, val
);
3214 extra
= AREF (font_spec
, FONT_EXTRA_INDEX
);
3215 slot
= Fassoc (extra
, prop
);
3217 extra
= Fcons (Fcons (prop
, val
), extra
);
3219 Fsetcdr (slot
, val
);
3223 DEFUN ("list-fonts", Flist_fonts
, Slist_fonts
, 1, 4, 0,
3224 doc
: /* List available fonts matching FONT-SPEC on the current frame.
3225 Optional 2nd argument FRAME specifies the target frame.
3226 Optional 3rd argument NUM, if non-nil, limits the number of returned fonts.
3227 Optional 4th argument PREFER, if non-nil, is a font-spec to
3228 control the order of the returned list. Fonts are sorted by
3229 how they are close to PREFER. */)
3230 (font_spec
, frame
, num
, prefer
)
3231 Lisp_Object font_spec
, frame
, num
, prefer
;
3233 Lisp_Object vec
, list
, tail
;
3237 frame
= selected_frame
;
3238 CHECK_LIVE_FRAME (frame
);
3239 CHECK_VALIDATE_FONT_SPEC (font_spec
);
3247 if (! NILP (prefer
))
3248 CHECK_FONT (prefer
);
3250 vec
= font_list_entities (frame
, font_spec
);
3255 return Fcons (AREF (vec
, 0), Qnil
);
3257 if (! NILP (prefer
))
3258 vec
= font_sort_entites (vec
, prefer
, frame
, font_spec
);
3260 list
= tail
= Fcons (AREF (vec
, 0), Qnil
);
3261 if (n
== 0 || n
> len
)
3263 for (i
= 1; i
< n
; i
++)
3265 Lisp_Object val
= Fcons (AREF (vec
, i
), Qnil
);
3267 XSETCDR (tail
, val
);
3273 DEFUN ("list-families", Flist_families
, Slist_families
, 0, 1, 0,
3274 doc
: /* List available font families on the current frame.
3275 Optional 2nd argument FRAME specifies the target frame. */)
3280 struct font_driver_list
*driver_list
;
3284 frame
= selected_frame
;
3285 CHECK_LIVE_FRAME (frame
);
3288 for (driver_list
= f
->font_driver_list
; driver_list
;
3289 driver_list
= driver_list
->next
)
3290 if (driver_list
->driver
->list_family
)
3292 Lisp_Object val
= driver_list
->driver
->list_family (frame
);
3298 Lisp_Object tail
= list
;
3300 for (; CONSP (val
); val
= XCDR (val
))
3301 if (NILP (Fmemq (XCAR (val
), tail
)))
3302 list
= Fcons (XCAR (val
), list
);
3308 DEFUN ("find-font", Ffind_font
, Sfind_font
, 1, 2, 0,
3309 doc
: /* Return a font-entity matching with FONT-SPEC on the current frame.
3310 Optional 2nd argument FRAME, if non-nil, specifies the target frame. */)
3312 Lisp_Object font_spec
, frame
;
3314 Lisp_Object val
= Flist_fonts (font_spec
, frame
, make_number (1), Qnil
);
3321 DEFUN ("font-xlfd-name", Ffont_xlfd_name
, Sfont_xlfd_name
, 1, 1, 0,
3322 doc
: /* Return XLFD name of FONT.
3323 FONT is a font-spec, font-entity, or font-object.
3324 If the name is too long for XLFD (maximum 255 chars), return nil. */)
3331 if (FONT_SPEC_P (font
))
3332 CHECK_VALIDATE_FONT_SPEC (font
);
3333 else if (FONT_ENTITY_P (font
))
3339 CHECK_FONT_GET_OBJECT (font
, fontp
);
3340 font
= fontp
->entity
;
3341 pixel_size
= fontp
->pixel_size
;
3344 if (font_unparse_xlfd (font
, pixel_size
, name
, 256) < 0)
3346 return build_string (name
);
3349 DEFUN ("clear-font-cache", Fclear_font_cache
, Sclear_font_cache
, 0, 0, 0,
3350 doc
: /* Clear font cache. */)
3353 Lisp_Object list
, frame
;
3355 FOR_EACH_FRAME (list
, frame
)
3357 FRAME_PTR f
= XFRAME (frame
);
3358 struct font_driver_list
*driver_list
= f
->font_driver_list
;
3360 for (; driver_list
; driver_list
= driver_list
->next
)
3361 if (driver_list
->on
)
3363 Lisp_Object cache
= driver_list
->driver
->get_cache (f
);
3367 while (! EQ (XCAR (val
), driver_list
->driver
->type
))
3369 val
= XCDR (XCAR (val
));
3370 if (XINT (XCAR (val
)) == 0)
3372 font_clear_cache (f
, XCAR (val
), driver_list
->driver
);
3373 XSETCDR (cache
, XCDR (val
));
3381 DEFUN ("internal-set-font-style-table", Finternal_set_font_style_table
,
3382 Sinternal_set_font_style_table
, 2, 2, 0,
3383 doc
: /* Set font style table for PROP to TABLE.
3384 PROP must be `:weight', `:slant', or `:width'.
3385 TABLE must be an alist of symbols vs the corresponding numeric values
3386 sorted by numeric values. */)
3388 Lisp_Object prop
, table
;
3392 Lisp_Object tail
, val
;
3394 CHECK_SYMBOL (prop
);
3395 table_index
= (EQ (prop
, QCweight
) ? 0
3396 : EQ (prop
, QCslant
) ? 1
3397 : EQ (prop
, QCwidth
) ? 2
3399 if (table_index
>= ASIZE (font_style_table
))
3400 error ("Invalid font style property: %s", SDATA (SYMBOL_NAME (prop
)));
3401 table
= Fcopy_sequence (table
);
3403 for (tail
= table
; ! NILP (tail
); tail
= Fcdr (tail
))
3405 prop
= Fcar (Fcar (tail
));
3406 val
= Fcdr (Fcar (tail
));
3407 CHECK_SYMBOL (prop
);
3409 if (numeric
> XINT (val
))
3410 error ("Numeric values not sorted for %s", SDATA (SYMBOL_NAME (prop
)));
3411 numeric
= XINT (val
);
3412 XSETCAR (tail
, Fcons (prop
, val
));
3414 ASET (font_style_table
, table_index
, table
);
3418 /* The following three functions are still expremental. */
3420 DEFUN ("font-make-gstring", Ffont_make_gstring
, Sfont_make_gstring
, 2, 2, 0,
3421 doc
: /* Return a newly created g-string for FONT-OBJECT with NUM glyphs.
3422 FONT-OBJECT may be nil if it is not yet known.
3424 G-string is sequence of glyphs of a specific font,
3425 and is a vector of this form:
3426 [ HEADER GLYPH ... ]
3427 HEADER is a vector of this form:
3428 [FONT-OBJECT WIDTH LBEARING RBEARING ASCENT DESCENT]
3430 FONT-OBJECT is a font-object for all glyphs in the g-string,
3431 WIDTH thry DESCENT are the metrics (in pixels) of the whole G-string.
3432 GLYPH is a vector of this form:
3433 [ FROM-IDX TO-IDX C CODE WIDTH LBEARING RBEARING ASCENT DESCENT
3434 [ [X-OFF Y-OFF WADJUST] | nil] ]
3436 FROM-IDX and TO-IDX are used internally and should not be touched.
3437 C is the character of the glyph.
3438 CODE is the glyph-code of C in FONT-OBJECT.
3439 WIDTH thry DESCENT are the metrics (in pixels) of the glyph.
3440 X-OFF and Y-OFF are offests to the base position for the glyph.
3441 WADJUST is the adjustment to the normal width of the glyph. */)
3443 Lisp_Object font_object
, num
;
3445 Lisp_Object gstring
, g
;
3449 if (! NILP (font_object
))
3450 CHECK_FONT_OBJECT (font_object
);
3453 len
= XINT (num
) + 1;
3454 gstring
= Fmake_vector (make_number (len
), Qnil
);
3455 g
= Fmake_vector (make_number (6), Qnil
);
3456 ASET (g
, 0, font_object
);
3457 ASET (gstring
, 0, g
);
3458 for (i
= 1; i
< len
; i
++)
3459 ASET (gstring
, i
, Fmake_vector (make_number (10), Qnil
));
3463 DEFUN ("font-fill-gstring", Ffont_fill_gstring
, Sfont_fill_gstring
, 4, 5, 0,
3464 doc
: /* Fillin glyph-string GSTRING by characters for FONT-OBJECT.
3465 START and END specifies the region to extract characters.
3466 If optional 3rd argument OBJECT is non-nil, it is a buffer or a string from
3467 where to extract characters.
3468 FONT-OBJECT may be nil if GSTRING already already contains one. */)
3469 (gstring
, font_object
, start
, end
, object
)
3470 Lisp_Object gstring
, font_object
, start
, end
, object
;
3476 CHECK_VECTOR (gstring
);
3477 if (NILP (font_object
))
3478 font_object
= LGSTRING_FONT (gstring
);
3479 CHECK_FONT_GET_OBJECT (font_object
, font
);
3481 if (STRINGP (object
))
3483 const unsigned char *p
;
3485 CHECK_NATNUM (start
);
3487 if (XINT (start
) > XINT (end
)
3488 || XINT (end
) > ASIZE (object
)
3489 || XINT (end
) - XINT (start
) > LGSTRING_LENGTH (gstring
))
3490 args_out_of_range_3 (object
, start
, end
);
3492 len
= XINT (end
) - XINT (start
);
3493 p
= SDATA (object
) + string_char_to_byte (object
, XINT (start
));
3494 for (i
= 0; i
< len
; i
++)
3496 Lisp_Object g
= LGSTRING_GLYPH (gstring
, i
);
3498 c
= STRING_CHAR_ADVANCE (p
);
3499 code
= font
->driver
->encode_char (font
, c
);
3500 if (code
> MOST_POSITIVE_FIXNUM
|| code
== FONT_INVALID_CODE
)
3502 LGLYPH_SET_FROM (g
, i
);
3503 LGLYPH_SET_TO (g
, i
);
3504 LGLYPH_SET_CHAR (g
, c
);
3505 LGLYPH_SET_CODE (g
, code
);
3512 if (! NILP (object
))
3513 Fset_buffer (object
);
3514 validate_region (&start
, &end
);
3515 if (XINT (end
) - XINT (start
) > LGSTRING_LENGTH (gstring
))
3516 args_out_of_range (start
, end
);
3517 len
= XINT (end
) - XINT (start
);
3519 pos_byte
= CHAR_TO_BYTE (pos
);
3520 for (i
= 0; i
< len
; i
++)
3522 Lisp_Object g
= LGSTRING_GLYPH (gstring
, i
);
3524 FETCH_CHAR_ADVANCE (c
, pos
, pos_byte
);
3525 code
= font
->driver
->encode_char (font
, c
);
3526 if (code
> MOST_POSITIVE_FIXNUM
|| code
== FONT_INVALID_CODE
)
3528 LGLYPH_SET_FROM (g
, i
);
3529 LGLYPH_SET_TO (g
, i
);
3530 LGLYPH_SET_CHAR (g
, c
);
3531 LGLYPH_SET_CODE (g
, code
);
3534 for (; i
< LGSTRING_LENGTH (gstring
); i
++)
3535 LGSTRING_SET_GLYPH (gstring
, i
, Qnil
);
3539 DEFUN ("font-shape-text", Ffont_shape_text
, Sfont_shape_text
, 3, 4, 0,
3540 doc
: /* Shape text between FROM and TO by FONT-OBJECT.
3541 If optional 4th argument STRING is non-nil, it is a string to shape,
3542 and FROM and TO are indices to the string.
3543 The value is the end position of the text that can be shaped by
3545 (from
, to
, font_object
, string
)
3546 Lisp_Object from
, to
, font_object
, string
;
3549 struct font_metrics metrics
;
3550 EMACS_INT start
, end
;
3551 Lisp_Object gstring
, n
;
3556 validate_region (&from
, &to
);
3557 start
= XFASTINT (from
);
3558 end
= XFASTINT (to
);
3559 modify_region (current_buffer
, start
, end
, 0);
3563 CHECK_STRING (string
);
3564 start
= XINT (from
);
3566 if (start
< 0 || start
> end
|| end
> SCHARS (string
))
3567 args_out_of_range_3 (string
, from
, to
);
3570 if (! FONT_OBJECT_P (font_object
))
3573 CHECK_FONT_GET_OBJECT (font_object
, font
);
3575 gstring
= Ffont_make_gstring (font_object
, make_number (len
));
3576 Ffont_fill_gstring (gstring
, font_object
, from
, to
, string
);
3577 if (! font
->driver
->shape
)
3579 /* Make zero-width glyphs to have one pixel width to make the
3580 display routine not lose the cursor. */
3581 for (i
= 0; i
< len
; i
++)
3583 Lisp_Object g
= LGSTRING_GLYPH (gstring
, i
);
3585 struct font_metrics metrics
;
3589 code
= LGLYPH_CODE (g
);
3590 if (font
->driver
->text_extents (font
, &code
, 1, &metrics
) == 0)
3592 Lisp_Object gstr
= Ffont_make_gstring (font_object
,
3594 LGSTRING_SET_WIDTH (gstr
, 1);
3595 LGSTRING_SET_LBEARING (gstr
, metrics
.lbearing
);
3596 LGSTRING_SET_RBEARING (gstr
, metrics
.rbearing
+ 1);
3597 LGSTRING_SET_ASCENT (gstr
, metrics
.ascent
);
3598 LGSTRING_SET_DESCENT (gstr
, metrics
.descent
);
3599 LGLYPH_SET_FROM (g
, 0);
3600 LGLYPH_SET_TO (g
, 1);
3601 LGSTRING_SET_GLYPH (gstr
, 0, g
);
3602 from
= make_number (start
+ i
);
3603 to
= make_number (start
+ i
+ 1);
3605 Fcompose_region_internal (from
, to
, gstr
, Qnil
);
3607 Fcompose_string_internal (string
, from
, to
, gstr
, Qnil
);
3610 return make_number (end
);
3614 /* Try at most three times with larger gstring each time. */
3615 for (i
= 0; i
< 3; i
++)
3617 Lisp_Object args
[2];
3619 n
= font
->driver
->shape (gstring
);
3623 args
[1] = Fmake_vector (make_number (len
), Qnil
);
3624 gstring
= Fvconcat (2, args
);
3626 if (! INTEGERP (n
) || XINT (n
) == 0)
3630 for (i
= 0; i
< len
;)
3633 Lisp_Object g
= LGSTRING_GLYPH (gstring
, i
);
3634 EMACS_INT this_from
= LGLYPH_FROM (g
);
3635 EMACS_INT this_to
= LGLYPH_TO (g
) + 1;
3637 int need_composition
= 0;
3639 metrics
.lbearing
= LGLYPH_LBEARING (g
);
3640 metrics
.rbearing
= LGLYPH_RBEARING (g
);
3641 metrics
.ascent
= LGLYPH_ASCENT (g
);
3642 metrics
.descent
= LGLYPH_DESCENT (g
);
3643 if (NILP (LGLYPH_ADJUSTMENT (g
)))
3645 metrics
.width
= LGLYPH_WIDTH (g
);
3646 if (LGLYPH_CHAR (g
) == 0 || metrics
.width
== 0)
3647 need_composition
= 1;
3651 metrics
.width
= LGLYPH_WADJUST (g
);
3652 metrics
.lbearing
+= LGLYPH_XOFF (g
);
3653 metrics
.rbearing
+= LGLYPH_XOFF (g
);
3654 metrics
.ascent
-= LGLYPH_YOFF (g
);
3655 metrics
.descent
+= LGLYPH_YOFF (g
);
3656 need_composition
= 1;
3658 for (j
= i
+ 1; j
< len
; j
++)
3662 g
= LGSTRING_GLYPH (gstring
, j
);
3663 if (this_from
!= LGLYPH_FROM (g
))
3665 need_composition
= 1;
3666 x
= metrics
.width
+ LGLYPH_LBEARING (g
) + LGLYPH_XOFF (g
);
3667 if (metrics
.lbearing
> x
)
3668 metrics
.lbearing
= x
;
3669 x
= metrics
.width
+ LGLYPH_RBEARING (g
) + LGLYPH_XOFF (g
);
3670 if (metrics
.rbearing
< x
)
3671 metrics
.rbearing
= x
;
3672 x
= LGLYPH_ASCENT (g
) - LGLYPH_YOFF (g
);
3673 if (metrics
.ascent
< x
)
3675 x
= LGLYPH_DESCENT (g
) - LGLYPH_YOFF (g
);
3676 if (metrics
.descent
< x
)
3677 metrics
.descent
= x
;
3678 if (NILP (LGLYPH_ADJUSTMENT (g
)))
3679 metrics
.width
+= LGLYPH_WIDTH (g
);
3681 metrics
.width
+= LGLYPH_WADJUST (g
);
3684 if (need_composition
)
3686 gstr
= Ffont_make_gstring (font_object
, make_number (j
- i
));
3687 LGSTRING_SET_WIDTH (gstr
, metrics
.width
);
3688 LGSTRING_SET_LBEARING (gstr
, metrics
.lbearing
);
3689 LGSTRING_SET_RBEARING (gstr
, metrics
.rbearing
);
3690 LGSTRING_SET_ASCENT (gstr
, metrics
.ascent
);
3691 LGSTRING_SET_DESCENT (gstr
, metrics
.descent
);
3692 for (k
= i
; i
< j
; i
++)
3694 Lisp_Object g
= LGSTRING_GLYPH (gstring
, i
);
3696 LGLYPH_SET_FROM (g
, LGLYPH_FROM (g
) - this_from
);
3697 LGLYPH_SET_TO (g
, LGLYPH_TO (g
) - this_from
);
3698 LGSTRING_SET_GLYPH (gstr
, i
- k
, LGSTRING_GLYPH (gstring
, i
));
3700 from
= make_number (start
+ this_from
);
3701 to
= make_number (start
+ this_to
);
3703 Fcompose_region_internal (from
, to
, gstr
, Qnil
);
3705 Fcompose_string_internal (string
, from
, to
, gstr
, Qnil
);
3714 DEFUN ("font-drive-otf", Ffont_drive_otf
, Sfont_drive_otf
, 6, 6, 0,
3715 doc
: /* Apply OpenType features on glyph-string GSTRING-IN.
3716 OTF-SPEC specifies which featuress to apply in this format:
3717 (SCRIPT LANGSYS GSUB GPOS)
3719 SCRIPT is a symbol specifying a script tag of OpenType,
3720 LANGSYS is a symbol specifying a langsys tag of OpenType,
3721 GSUB and GPOS, if non-nil, are lists of symbols specifying feature tags.
3723 If LANGYS is nil, the default langsys is selected.
3725 The features are applied in the order appeared in the list. The
3726 symbol `*' means to apply all available features not appeared in this
3727 list, and the remaining features are ignored. For instance, (vatu
3728 pstf * haln) is to apply vatu and pstf in this order, then to apply
3729 all available features other than vatu, pstf, and haln.
3731 The features are applied to the glyphs in the range FROM and TO of
3732 the glyph-string GSTRING-IN.
3734 If some of a feature is actually applicable, the resulting glyphs are
3735 produced in the glyph-string GSTRING-OUT from the index INDEX. In
3736 this case, the value is the number of produced glyphs.
3738 If no feature is applicable, no glyph is produced in GSTRING-OUT, and
3741 If GSTRING-OUT is too short to hold produced glyphs, no glyphs is
3742 produced in GSTRING-OUT, and the value is nil.
3744 See the documentation of `font-make-gstring' for the format of
3746 (otf_features
, gstring_in
, from
, to
, gstring_out
, index
)
3747 Lisp_Object otf_features
, gstring_in
, from
, to
, gstring_out
, index
;
3749 Lisp_Object font_object
= LGSTRING_FONT (gstring_in
);
3754 check_otf_features (otf_features
);
3755 CHECK_FONT_GET_OBJECT (font_object
, font
);
3756 if (! font
->driver
->otf_drive
)
3757 error ("Font backend %s can't drive OpenType GSUB table",
3758 SDATA (SYMBOL_NAME (font
->driver
->type
)));
3759 CHECK_CONS (otf_features
);
3760 CHECK_SYMBOL (XCAR (otf_features
));
3761 val
= XCDR (otf_features
);
3762 CHECK_SYMBOL (XCAR (val
));
3763 val
= XCDR (otf_features
);
3766 len
= check_gstring (gstring_in
);
3767 CHECK_VECTOR (gstring_out
);
3768 CHECK_NATNUM (from
);
3770 CHECK_NATNUM (index
);
3772 if (XINT (from
) >= XINT (to
) || XINT (to
) > len
)
3773 args_out_of_range_3 (from
, to
, make_number (len
));
3774 if (XINT (index
) >= ASIZE (gstring_out
))
3775 args_out_of_range (index
, make_number (ASIZE (gstring_out
)));
3776 num
= font
->driver
->otf_drive (font
, otf_features
,
3777 gstring_in
, XINT (from
), XINT (to
),
3778 gstring_out
, XINT (index
), 0);
3781 return make_number (num
);
3784 DEFUN ("font-otf-alternates", Ffont_otf_alternates
, Sfont_otf_alternates
,
3786 doc
: /* Return a list of alternate glyphs of CHARACTER in FONT-OBJECT.
3787 FEATURE-SPEC specifies which features of the font FONT-OBJECT to apply
3789 (SCRIPT LANGSYS FEATURE ...)
3790 See the documentation of `font-otf-gsub' for more detail.
3792 The value is a list of cons cells of the format (GLYPH-ID . CHARACTER),
3793 where GLYPH-ID is a glyph index of the font, and CHARACTER is a
3794 character code corresponding to the glyph or nil if there's no
3795 corresponding character. */)
3796 (font_object
, character
, otf_features
)
3797 Lisp_Object font_object
, character
, otf_features
;
3800 Lisp_Object gstring_in
, gstring_out
, g
;
3801 Lisp_Object alternates
;
3804 CHECK_FONT_GET_OBJECT (font_object
, font
);
3805 if (! font
->driver
->otf_drive
)
3806 error ("Font backend %s can't drive OpenType GSUB table",
3807 SDATA (SYMBOL_NAME (font
->driver
->type
)));
3808 CHECK_CHARACTER (character
);
3809 CHECK_CONS (otf_features
);
3811 gstring_in
= Ffont_make_gstring (font_object
, make_number (1));
3812 g
= LGSTRING_GLYPH (gstring_in
, 0);
3813 LGLYPH_SET_CHAR (g
, XINT (character
));
3814 gstring_out
= Ffont_make_gstring (font_object
, make_number (10));
3815 while ((num
= font
->driver
->otf_drive (font
, otf_features
, gstring_in
, 0, 1,
3816 gstring_out
, 0, 1)) < 0)
3817 gstring_out
= Ffont_make_gstring (font_object
,
3818 make_number (ASIZE (gstring_out
) * 2));
3820 for (i
= 0; i
< num
; i
++)
3822 Lisp_Object g
= LGSTRING_GLYPH (gstring_out
, i
);
3823 int c
= LGLYPH_CHAR (g
);
3824 unsigned code
= LGLYPH_CODE (g
);
3826 alternates
= Fcons (Fcons (make_number (code
),
3827 c
> 0 ? make_number (c
) : Qnil
),
3830 return Fnreverse (alternates
);
3836 DEFUN ("open-font", Fopen_font
, Sopen_font
, 1, 3, 0,
3837 doc
: /* Open FONT-ENTITY. */)
3838 (font_entity
, size
, frame
)
3839 Lisp_Object font_entity
;
3845 CHECK_FONT_ENTITY (font_entity
);
3847 size
= AREF (font_entity
, FONT_SIZE_INDEX
);
3848 CHECK_NUMBER (size
);
3850 frame
= selected_frame
;
3851 CHECK_LIVE_FRAME (frame
);
3853 isize
= XINT (size
);
3857 isize
= POINT_TO_PIXEL (- isize
, XFRAME (frame
)->resy
);
3859 return font_open_entity (XFRAME (frame
), font_entity
, isize
);
3862 DEFUN ("close-font", Fclose_font
, Sclose_font
, 1, 2, 0,
3863 doc
: /* Close FONT-OBJECT. */)
3864 (font_object
, frame
)
3865 Lisp_Object font_object
, frame
;
3867 CHECK_FONT_OBJECT (font_object
);
3869 frame
= selected_frame
;
3870 CHECK_LIVE_FRAME (frame
);
3871 font_close_object (XFRAME (frame
), font_object
);
3875 DEFUN ("query-font", Fquery_font
, Squery_font
, 1, 1, 0,
3876 doc
: /* Return information about FONT-OBJECT.
3877 The value is a vector:
3878 [ NAME FILENAME PIXEL-SIZE SIZE ASCENT DESCENT SPACE-WIDTH AVERAGE-WIDTH
3881 NAME is a string of the font name (or nil if the font backend doesn't
3884 FILENAME is a string of the font file (or nil if the font backend
3885 doesn't provide a file name).
3887 PIXEL-SIZE is a pixel size by which the font is opened.
3889 SIZE is a maximum advance width of the font in pixel.
3891 ASCENT, DESCENT, SPACE-WIDTH, AVERAGE-WIDTH are metrics of the font in
3894 CAPABILITY is a list whose first element is a symbol representing the
3895 font format \(x, opentype, truetype, type1, pcf, or bdf) and the
3896 remaining elements describes a detail of the font capability.
3898 If the font is OpenType font, the form of the list is
3899 \(opentype GSUB GPOS)
3900 where GSUB shows which "GSUB" features the font supports, and GPOS
3901 shows which "GPOS" features the font supports. Both GSUB and GPOS are
3902 lists of the format:
3903 \((SCRIPT (LANGSYS FEATURE ...) ...) ...)
3905 If the font is not OpenType font, currently the length of the form is
3908 SCRIPT is a symbol representing OpenType script tag.
3910 LANGSYS is a symbol representing OpenType langsys tag, or nil
3911 representing the default langsys.
3913 FEATURE is a symbol representing OpenType feature tag.
3915 If the font is not OpenType font, OTF-CAPABILITY is nil. */)
3917 Lisp_Object font_object
;
3922 CHECK_FONT_GET_OBJECT (font_object
, font
);
3924 val
= Fmake_vector (make_number (9), Qnil
);
3925 if (font
->font
.full_name
)
3926 ASET (val
, 0, make_unibyte_string (font
->font
.full_name
,
3927 strlen (font
->font
.full_name
)));
3928 if (font
->file_name
)
3929 ASET (val
, 1, make_unibyte_string (font
->file_name
,
3930 strlen (font
->file_name
)));
3931 ASET (val
, 2, make_number (font
->pixel_size
));
3932 ASET (val
, 3, make_number (font
->font
.size
));
3933 ASET (val
, 4, make_number (font
->ascent
));
3934 ASET (val
, 5, make_number (font
->descent
));
3935 ASET (val
, 6, make_number (font
->font
.space_width
));
3936 ASET (val
, 7, make_number (font
->font
.average_width
));
3937 if (font
->driver
->otf_capability
)
3938 ASET (val
, 8, Fcons (Qopentype
, font
->driver
->otf_capability (font
)));
3940 ASET (val
, 8, Fcons (font
->format
, Qnil
));
3944 DEFUN ("get-font-glyphs", Fget_font_glyphs
, Sget_font_glyphs
, 2, 2, 0,
3945 doc
: /* Return a vector of glyphs of FONT-OBJECT for drawing STRING.
3946 Each element is a vector [GLYPH-CODE LBEARING RBEARING WIDTH ASCENT DESCENT]. */)
3947 (font_object
, string
)
3948 Lisp_Object font_object
, string
;
3954 CHECK_FONT_GET_OBJECT (font_object
, font
);
3955 CHECK_STRING (string
);
3956 len
= SCHARS (string
);
3957 vec
= Fmake_vector (make_number (len
), Qnil
);
3958 for (i
= 0; i
< len
; i
++)
3960 Lisp_Object ch
= Faref (string
, make_number (i
));
3964 struct font_metrics metrics
;
3966 code
= font
->driver
->encode_char (font
, c
);
3967 if (code
== FONT_INVALID_CODE
)
3969 val
= Fmake_vector (make_number (6), Qnil
);
3970 if (code
<= MOST_POSITIVE_FIXNUM
)
3971 ASET (val
, 0, make_number (code
));
3973 ASET (val
, 0, Fcons (make_number (code
>> 16),
3974 make_number (code
& 0xFFFF)));
3975 font
->driver
->text_extents (font
, &code
, 1, &metrics
);
3976 ASET (val
, 1, make_number (metrics
.lbearing
));
3977 ASET (val
, 2, make_number (metrics
.rbearing
));
3978 ASET (val
, 3, make_number (metrics
.width
));
3979 ASET (val
, 4, make_number (metrics
.ascent
));
3980 ASET (val
, 5, make_number (metrics
.descent
));
3986 DEFUN ("font-match-p", Ffont_match_p
, Sfont_match_p
, 2, 2, 0,
3987 doc
: /* Return t iff font-spec SPEC matches with FONT.
3988 FONT is a font-spec, font-entity, or font-object. */)
3990 Lisp_Object spec
, font
;
3992 CHECK_FONT_SPEC (spec
);
3993 if (FONT_OBJECT_P (font
))
3994 font
= ((struct font
*) XSAVE_VALUE (font
)->pointer
)->entity
;
3995 else if (! FONT_ENTITY_P (font
))
3996 CHECK_FONT_SPEC (font
);
3998 return (font_match_p (spec
, font
) ? Qt
: Qnil
);
4001 DEFUN ("font-at", Ffont_at
, Sfont_at
, 1, 3, 0,
4002 doc
: /* Return a font-object for displaying a character at POSISTION.
4003 Optional second arg WINDOW, if non-nil, is a window displaying
4004 the current buffer. It defaults to the currently selected window. */)
4005 (position
, window
, string
)
4006 Lisp_Object position
, window
, string
;
4013 CHECK_NUMBER_COERCE_MARKER (position
);
4014 pos
= XINT (position
);
4015 if (pos
< BEGV
|| pos
>= ZV
)
4016 args_out_of_range_3 (position
, make_number (BEGV
), make_number (ZV
));
4023 CHECK_NUMBER (position
);
4024 CHECK_STRING (string
);
4025 pos
= XINT (position
);
4026 if (pos
< 0 || pos
>= SCHARS (string
))
4027 args_out_of_range (string
, position
);
4030 window
= selected_window
;
4031 CHECK_LIVE_WINDOW (window
);
4032 w
= XWINDOW (window
);
4034 return font_at (-1, pos
, NULL
, w
, string
);
4038 DEFUN ("draw-string", Fdraw_string
, Sdraw_string
, 2, 2, 0,
4039 doc
: /* Draw STRING by FONT-OBJECT on the top left corner of the current frame.
4040 The value is a number of glyphs drawn.
4041 Type C-l to recover what previously shown. */)
4042 (font_object
, string
)
4043 Lisp_Object font_object
, string
;
4045 Lisp_Object frame
= selected_frame
;
4046 FRAME_PTR f
= XFRAME (frame
);
4052 CHECK_FONT_GET_OBJECT (font_object
, font
);
4053 CHECK_STRING (string
);
4054 len
= SCHARS (string
);
4055 code
= alloca (sizeof (unsigned) * len
);
4056 for (i
= 0; i
< len
; i
++)
4058 Lisp_Object ch
= Faref (string
, make_number (i
));
4062 code
[i
] = font
->driver
->encode_char (font
, c
);
4063 if (code
[i
] == FONT_INVALID_CODE
)
4066 face
= FACE_FROM_ID (f
, DEFAULT_FACE_ID
);
4068 if (font
->driver
->prepare_face
)
4069 font
->driver
->prepare_face (f
, face
);
4070 width
= font
->driver
->text_extents (font
, code
, i
, NULL
);
4071 len
= font
->driver
->draw_text (f
, face
, 0, font
->ascent
, code
, i
, width
);
4072 if (font
->driver
->done_face
)
4073 font
->driver
->done_face (f
, face
);
4075 return make_number (len
);
4079 #endif /* FONT_DEBUG */
4082 extern void syms_of_ftfont
P_ (());
4083 extern void syms_of_xfont
P_ (());
4084 extern void syms_of_xftfont
P_ (());
4085 extern void syms_of_ftxfont
P_ (());
4086 extern void syms_of_bdffont
P_ (());
4087 extern void syms_of_w32font
P_ (());
4088 extern void syms_of_atmfont
P_ (());
4093 sort_shift_bits
[FONT_SLANT_INDEX
] = 0;
4094 sort_shift_bits
[FONT_WEIGHT_INDEX
] = 7;
4095 sort_shift_bits
[FONT_SIZE_INDEX
] = 14;
4096 sort_shift_bits
[FONT_WIDTH_INDEX
] = 21;
4097 sort_shift_bits
[FONT_ADSTYLE_INDEX
] = 28;
4098 sort_shift_bits
[FONT_FOUNDRY_INDEX
] = 29;
4099 sort_shift_bits
[FONT_FAMILY_INDEX
] = 30;
4100 sort_shift_bits
[FONT_REGISTRY_INDEX
] = 31;
4101 /* Note that sort_shift_bits[FONT_TYPE_INDEX] is never used. */
4103 staticpro (&font_style_table
);
4104 font_style_table
= Fmake_vector (make_number (3), Qnil
);
4106 staticpro (&font_family_alist
);
4107 font_family_alist
= Qnil
;
4109 staticpro (&font_charset_alist
);
4110 font_charset_alist
= Qnil
;
4112 DEFSYM (Qopentype
, "opentype");
4114 DEFSYM (Qiso8859_1
, "iso8859-1");
4115 DEFSYM (Qiso10646_1
, "iso10646-1");
4116 DEFSYM (Qunicode_bmp
, "unicode-bmp");
4117 DEFSYM (Qunicode_sip
, "unicode-sip");
4119 DEFSYM (QCotf
, ":otf");
4120 DEFSYM (QClanguage
, ":language");
4121 DEFSYM (QCscript
, ":script");
4122 DEFSYM (QCantialias
, ":antialias");
4124 DEFSYM (QCfoundry
, ":foundry");
4125 DEFSYM (QCadstyle
, ":adstyle");
4126 DEFSYM (QCregistry
, ":registry");
4127 DEFSYM (QCspacing
, ":spacing");
4128 DEFSYM (QCdpi
, ":dpi");
4129 DEFSYM (QCscalable
, ":scalable");
4130 DEFSYM (QCextra
, ":extra");
4137 staticpro (&null_string
);
4138 null_string
= build_string ("");
4139 staticpro (&null_vector
);
4140 null_vector
= Fmake_vector (make_number (0), Qnil
);
4142 staticpro (&scratch_font_spec
);
4143 scratch_font_spec
= Ffont_spec (0, NULL
);
4144 staticpro (&scratch_font_prefer
);
4145 scratch_font_prefer
= Ffont_spec (0, NULL
);
4148 staticpro (&otf_list
);
4153 defsubr (&Sfont_spec
);
4154 defsubr (&Sfont_get
);
4155 defsubr (&Sfont_put
);
4156 defsubr (&Slist_fonts
);
4157 defsubr (&Slist_families
);
4158 defsubr (&Sfind_font
);
4159 defsubr (&Sfont_xlfd_name
);
4160 defsubr (&Sclear_font_cache
);
4161 defsubr (&Sinternal_set_font_style_table
);
4162 defsubr (&Sfont_make_gstring
);
4163 defsubr (&Sfont_fill_gstring
);
4164 defsubr (&Sfont_shape_text
);
4165 defsubr (&Sfont_drive_otf
);
4166 defsubr (&Sfont_otf_alternates
);
4169 defsubr (&Sopen_font
);
4170 defsubr (&Sclose_font
);
4171 defsubr (&Squery_font
);
4172 defsubr (&Sget_font_glyphs
);
4173 defsubr (&Sfont_match_p
);
4174 defsubr (&Sfont_at
);
4176 defsubr (&Sdraw_string
);
4178 #endif /* FONT_DEBUG */
4180 #ifdef USE_FONT_BACKEND
4181 if (enable_font_backend
)
4183 #ifdef HAVE_FREETYPE
4185 #ifdef HAVE_X_WINDOWS
4190 #endif /* HAVE_XFT */
4191 #endif /* HAVE_X_WINDOWS */
4192 #else /* not HAVE_FREETYPE */
4193 #ifdef HAVE_X_WINDOWS
4195 #endif /* HAVE_X_WINDOWS */
4196 #endif /* not HAVE_FREETYPE */
4199 #endif /* HAVE_BDFFONT */
4202 #endif /* WINDOWSNT */
4207 #endif /* USE_FONT_BACKEND */
4210 /* arch-tag: 74c9475d-5976-4c93-a327-942ae3072846
4211 (do not change this comment) */