Merge from trunk.
[emacs.git] / src / font.c
blob5f8d22157d63271605ec635bdf372e517d813eb5
1 /* font.c -- "Font" primitives.
3 Copyright (C) 2006-2011 Free Software Foundation, Inc.
4 Copyright (C) 2006, 2007, 2008, 2009, 2010, 2011
5 National Institute of Advanced Industrial Science and Technology (AIST)
6 Registration Number H13PRO009
8 This file is part of GNU Emacs.
10 GNU Emacs is free software: you can redistribute it and/or modify
11 it under the terms of the GNU General Public License as published by
12 the Free Software Foundation, either version 3 of the License, or
13 (at your option) any later version.
15 GNU Emacs is distributed in the hope that it will be useful,
16 but WITHOUT ANY WARRANTY; without even the implied warranty of
17 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
18 GNU General Public License for more details.
20 You should have received a copy of the GNU General Public License
21 along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. */
23 #include <config.h>
24 #include <stdio.h>
25 #include <ctype.h>
26 #include <setjmp.h>
28 #include "lisp.h"
29 #include "buffer.h"
30 #include "frame.h"
31 #include "window.h"
32 #include "dispextern.h"
33 #include "charset.h"
34 #include "character.h"
35 #include "composite.h"
36 #include "fontset.h"
37 #include "font.h"
39 #ifdef HAVE_X_WINDOWS
40 #include "xterm.h"
41 #endif /* HAVE_X_WINDOWS */
43 #ifdef HAVE_NTGUI
44 #include "w32term.h"
45 #endif /* HAVE_NTGUI */
47 #ifdef HAVE_NS
48 #include "nsterm.h"
49 #endif /* HAVE_NS */
51 Lisp_Object Qopentype;
53 /* Important character set strings. */
54 Lisp_Object Qascii_0, Qiso8859_1, Qiso10646_1, Qunicode_bmp, Qunicode_sip;
56 #define DEFAULT_ENCODING Qiso8859_1
58 /* Unicode category `Cf'. */
59 static Lisp_Object QCf;
61 /* Special vector of zero length. This is repeatedly used by (struct
62 font_driver *)->list when a specified font is not found. */
63 static Lisp_Object null_vector;
65 /* Vector of Vfont_weight_table, Vfont_slant_table, and Vfont_width_table. */
66 static Lisp_Object font_style_table;
68 /* Structure used for tables mapping weight, slant, and width numeric
69 values and their names. */
71 struct table_entry
73 int numeric;
74 /* The first one is a valid name as a face attribute.
75 The second one (if any) is a typical name in XLFD field. */
76 const char *names[5];
79 /* Table of weight numeric values and their names. This table must be
80 sorted by numeric values in ascending order. */
82 static const struct table_entry weight_table[] =
84 { 0, { "thin" }},
85 { 20, { "ultra-light", "ultralight" }},
86 { 40, { "extra-light", "extralight" }},
87 { 50, { "light" }},
88 { 75, { "semi-light", "semilight", "demilight", "book" }},
89 { 100, { "normal", "medium", "regular", "unspecified" }},
90 { 180, { "semi-bold", "semibold", "demibold", "demi" }},
91 { 200, { "bold" }},
92 { 205, { "extra-bold", "extrabold" }},
93 { 210, { "ultra-bold", "ultrabold", "black" }}
96 /* Table of slant numeric values and their names. This table must be
97 sorted by numeric values in ascending order. */
99 static const struct table_entry slant_table[] =
101 { 0, { "reverse-oblique", "ro" }},
102 { 10, { "reverse-italic", "ri" }},
103 { 100, { "normal", "r", "unspecified" }},
104 { 200, { "italic" ,"i", "ot" }},
105 { 210, { "oblique", "o" }}
108 /* Table of width numeric values and their names. This table must be
109 sorted by numeric values in ascending order. */
111 static const struct table_entry width_table[] =
113 { 50, { "ultra-condensed", "ultracondensed" }},
114 { 63, { "extra-condensed", "extracondensed" }},
115 { 75, { "condensed", "compressed", "narrow" }},
116 { 87, { "semi-condensed", "semicondensed", "demicondensed" }},
117 { 100, { "normal", "medium", "regular", "unspecified" }},
118 { 113, { "semi-expanded", "semiexpanded", "demiexpanded" }},
119 { 125, { "expanded" }},
120 { 150, { "extra-expanded", "extraexpanded" }},
121 { 200, { "ultra-expanded", "ultraexpanded", "wide" }}
124 Lisp_Object QCfoundry;
125 static Lisp_Object QCadstyle, QCregistry;
126 /* Symbols representing keys of font extra info. */
127 Lisp_Object QCspacing, QCdpi, QCscalable, QCotf, QClang, QCscript, QCavgwidth;
128 Lisp_Object QCantialias, QCfont_entity;
129 static Lisp_Object QCfc_unknown_spec;
130 /* Symbols representing values of font spacing property. */
131 static Lisp_Object Qc, Qm, Qd;
132 Lisp_Object Qp;
133 /* Special ADSTYLE properties to avoid fonts used for Latin
134 characters; used in xfont.c and ftfont.c. */
135 Lisp_Object Qja, Qko;
137 static Lisp_Object QCuser_spec;
139 /* Alist of font registry symbols and the corresponding charset
140 information. The information is retrieved from
141 Vfont_encoding_alist on demand.
143 Eash element has the form:
144 (REGISTRY . (ENCODING-CHARSET-ID . REPERTORY-CHARSET-ID))
146 (REGISTRY . nil)
148 In the former form, ENCODING-CHARSET-ID is an ID of a charset that
149 encodes a character code to a glyph code of a font, and
150 REPERTORY-CHARSET-ID is an ID of a charset that tells if a
151 character is supported by a font.
153 The latter form means that the information for REGISTRY couldn't be
154 retrieved. */
155 static Lisp_Object font_charset_alist;
157 /* List of all font drivers. Each font-backend (XXXfont.c) calls
158 register_font_driver in syms_of_XXXfont to register its font-driver
159 here. */
160 static struct font_driver_list *font_driver_list;
164 /* Creaters of font-related Lisp object. */
166 static Lisp_Object
167 font_make_spec (void)
169 Lisp_Object font_spec;
170 struct font_spec *spec
171 = ((struct font_spec *)
172 allocate_pseudovector (VECSIZE (struct font_spec),
173 FONT_SPEC_MAX, PVEC_FONT));
174 XSETFONT (font_spec, spec);
175 return font_spec;
178 Lisp_Object
179 font_make_entity (void)
181 Lisp_Object font_entity;
182 struct font_entity *entity
183 = ((struct font_entity *)
184 allocate_pseudovector (VECSIZE (struct font_entity),
185 FONT_ENTITY_MAX, PVEC_FONT));
186 XSETFONT (font_entity, entity);
187 return font_entity;
190 /* Create a font-object whose structure size is SIZE. If ENTITY is
191 not nil, copy properties from ENTITY to the font-object. If
192 PIXELSIZE is positive, set the `size' property to PIXELSIZE. */
193 Lisp_Object
194 font_make_object (int size, Lisp_Object entity, int pixelsize)
196 Lisp_Object font_object;
197 struct font *font
198 = (struct font *) allocate_pseudovector (size, FONT_OBJECT_MAX, PVEC_FONT);
199 int i;
201 XSETFONT (font_object, font);
203 if (! NILP (entity))
205 for (i = 1; i < FONT_SPEC_MAX; i++)
206 font->props[i] = AREF (entity, i);
207 if (! NILP (AREF (entity, FONT_EXTRA_INDEX)))
208 font->props[FONT_EXTRA_INDEX]
209 = Fcopy_alist (AREF (entity, FONT_EXTRA_INDEX));
211 if (size > 0)
212 font->props[FONT_SIZE_INDEX] = make_number (pixelsize);
213 return font_object;
218 static int font_pixel_size (FRAME_PTR f, Lisp_Object);
219 static Lisp_Object font_open_entity (FRAME_PTR, Lisp_Object, int);
220 static Lisp_Object font_matching_entity (FRAME_PTR, Lisp_Object *,
221 Lisp_Object);
222 static unsigned font_encode_char (Lisp_Object, int);
224 /* Number of registered font drivers. */
225 static int num_font_drivers;
228 /* Return a Lispy value of a font property value at STR and LEN bytes.
229 If STR is "*", return nil.
230 If FORCE_SYMBOL is zero and all characters in STR are digits,
231 return an integer. Otherwise, return a symbol interned from
232 STR. */
234 Lisp_Object
235 font_intern_prop (const char *str, ptrdiff_t len, int force_symbol)
237 ptrdiff_t i;
238 Lisp_Object tem;
239 Lisp_Object obarray;
240 EMACS_INT nbytes, nchars;
242 if (len == 1 && *str == '*')
243 return Qnil;
244 if (!force_symbol && 0 < len && '0' <= *str && *str <= '9')
246 for (i = 1; i < len; i++)
247 if (! ('0' <= str[i] && str[i] <= '9'))
248 break;
249 if (i == len)
251 EMACS_INT n;
253 i = 0;
254 for (n = 0; (n += str[i++] - '0') <= MOST_POSITIVE_FIXNUM; n *= 10)
256 if (i == len)
257 return make_number (n);
258 if (MOST_POSITIVE_FIXNUM / 10 < n)
259 break;
262 xsignal1 (Qoverflow_error, make_string (str, len));
266 /* The following code is copied from the function intern (in
267 lread.c), and modified to suit our purpose. */
268 obarray = Vobarray;
269 if (!VECTORP (obarray) || ASIZE (obarray) == 0)
270 obarray = check_obarray (obarray);
271 parse_str_as_multibyte ((unsigned char *) str, len, &nchars, &nbytes);
272 if (len == nchars || len != nbytes)
273 /* CONTENTS contains no multibyte sequences or contains an invalid
274 multibyte sequence. We'll make a unibyte string. */
275 tem = oblookup (obarray, str, len, len);
276 else
277 tem = oblookup (obarray, str, nchars, len);
278 if (SYMBOLP (tem))
279 return tem;
280 if (len == nchars || len != nbytes)
281 tem = make_unibyte_string (str, len);
282 else
283 tem = make_multibyte_string (str, nchars, len);
284 return Fintern (tem, obarray);
287 /* Return a pixel size of font-spec SPEC on frame F. */
289 static int
290 font_pixel_size (FRAME_PTR f, Lisp_Object spec)
292 #ifdef HAVE_WINDOW_SYSTEM
293 Lisp_Object size = AREF (spec, FONT_SIZE_INDEX);
294 double point_size;
295 int dpi, pixel_size;
296 Lisp_Object val;
298 if (INTEGERP (size))
299 return XINT (size);
300 if (NILP (size))
301 return 0;
302 font_assert (FLOATP (size));
303 point_size = XFLOAT_DATA (size);
304 val = AREF (spec, FONT_DPI_INDEX);
305 if (INTEGERP (val))
306 dpi = XINT (val);
307 else
308 dpi = f->resy;
309 pixel_size = POINT_TO_PIXEL (point_size, dpi);
310 return pixel_size;
311 #else
312 return 1;
313 #endif
317 /* Return a value of PROP's VAL (symbol or integer) to be stored in a
318 font vector. If VAL is not valid (i.e. not registered in
319 font_style_table), return -1 if NOERROR is zero, and return a
320 proper index if NOERROR is nonzero. In that case, register VAL in
321 font_style_table if VAL is a symbol, and return the closest index if
322 VAL is an integer. */
325 font_style_to_value (enum font_property_index prop, Lisp_Object val, int noerror)
327 Lisp_Object table = AREF (font_style_table, prop - FONT_WEIGHT_INDEX);
328 int len = ASIZE (table);
330 if (SYMBOLP (val))
332 int i, j;
333 char *s;
334 Lisp_Object args[2], elt;
336 /* At first try exact match. */
337 for (i = 0; i < len; i++)
338 for (j = 1; j < ASIZE (AREF (table, i)); j++)
339 if (EQ (val, AREF (AREF (table, i), j)))
340 return ((XINT (AREF (AREF (table, i), 0)) << 8)
341 | (i << 4) | (j - 1));
342 /* Try also with case-folding match. */
343 s = SSDATA (SYMBOL_NAME (val));
344 for (i = 0; i < len; i++)
345 for (j = 1; j < ASIZE (AREF (table, i)); j++)
347 elt = AREF (AREF (table, i), j);
348 if (xstrcasecmp (s, SSDATA (SYMBOL_NAME (elt))) == 0)
349 return ((XINT (AREF (AREF (table, i), 0)) << 8)
350 | (i << 4) | (j - 1));
352 if (! noerror)
353 return -1;
354 if (len == 255)
355 abort ();
356 elt = Fmake_vector (make_number (2), make_number (100));
357 ASET (elt, 1, val);
358 args[0] = table;
359 args[1] = Fmake_vector (make_number (1), elt);
360 ASET (font_style_table, prop - FONT_WEIGHT_INDEX, Fvconcat (2, args));
361 return (100 << 8) | (i << 4);
363 else
365 int i, last_n;
366 int numeric = XINT (val);
368 for (i = 0, last_n = -1; i < len; i++)
370 int n = XINT (AREF (AREF (table, i), 0));
372 if (numeric == n)
373 return (n << 8) | (i << 4);
374 if (numeric < n)
376 if (! noerror)
377 return -1;
378 return ((i == 0 || n - numeric < numeric - last_n)
379 ? (n << 8) | (i << 4): (last_n << 8 | ((i - 1) << 4)));
381 last_n = n;
383 if (! noerror)
384 return -1;
385 return ((last_n << 8) | ((i - 1) << 4));
389 Lisp_Object
390 font_style_symbolic (Lisp_Object font, enum font_property_index prop, int for_face)
392 Lisp_Object val = AREF (font, prop);
393 Lisp_Object table, elt;
394 int i;
396 if (NILP (val))
397 return Qnil;
398 table = AREF (font_style_table, prop - FONT_WEIGHT_INDEX);
399 i = XINT (val) & 0xFF;
400 font_assert (((i >> 4) & 0xF) < ASIZE (table));
401 elt = AREF (table, ((i >> 4) & 0xF));
402 font_assert ((i & 0xF) + 1 < ASIZE (elt));
403 return (for_face ? AREF (elt, 1) : AREF (elt, (i & 0xF) + 1));
406 /* Return ENCODING or a cons of ENCODING and REPERTORY of the font
407 FONTNAME. ENCODING is a charset symbol that specifies the encoding
408 of the font. REPERTORY is a charset symbol or nil. */
410 Lisp_Object
411 find_font_encoding (Lisp_Object fontname)
413 Lisp_Object tail, elt;
415 for (tail = Vfont_encoding_alist; CONSP (tail); tail = XCDR (tail))
417 elt = XCAR (tail);
418 if (CONSP (elt)
419 && STRINGP (XCAR (elt))
420 && fast_string_match_ignore_case (XCAR (elt), fontname) >= 0
421 && (SYMBOLP (XCDR (elt))
422 ? CHARSETP (XCDR (elt))
423 : CONSP (XCDR (elt)) && CHARSETP (XCAR (XCDR (elt)))))
424 return (XCDR (elt));
426 return Qnil;
429 /* Return encoding charset and repertory charset for REGISTRY in
430 ENCODING and REPERTORY correspondingly. If correct information for
431 REGISTRY is available, return 0. Otherwise return -1. */
434 font_registry_charsets (Lisp_Object registry, struct charset **encoding, struct charset **repertory)
436 Lisp_Object val;
437 int encoding_id, repertory_id;
439 val = Fassoc_string (registry, font_charset_alist, Qt);
440 if (! NILP (val))
442 val = XCDR (val);
443 if (NILP (val))
444 return -1;
445 encoding_id = XINT (XCAR (val));
446 repertory_id = XINT (XCDR (val));
448 else
450 val = find_font_encoding (SYMBOL_NAME (registry));
451 if (SYMBOLP (val) && CHARSETP (val))
453 encoding_id = repertory_id = XINT (CHARSET_SYMBOL_ID (val));
455 else if (CONSP (val))
457 if (! CHARSETP (XCAR (val)))
458 goto invalid_entry;
459 encoding_id = XINT (CHARSET_SYMBOL_ID (XCAR (val)));
460 if (NILP (XCDR (val)))
461 repertory_id = -1;
462 else
464 if (! CHARSETP (XCDR (val)))
465 goto invalid_entry;
466 repertory_id = XINT (CHARSET_SYMBOL_ID (XCDR (val)));
469 else
470 goto invalid_entry;
471 val = Fcons (make_number (encoding_id), make_number (repertory_id));
472 font_charset_alist
473 = nconc2 (font_charset_alist, Fcons (Fcons (registry, val), Qnil));
476 if (encoding)
477 *encoding = CHARSET_FROM_ID (encoding_id);
478 if (repertory)
479 *repertory = repertory_id >= 0 ? CHARSET_FROM_ID (repertory_id) : NULL;
480 return 0;
482 invalid_entry:
483 font_charset_alist
484 = nconc2 (font_charset_alist, Fcons (Fcons (registry, Qnil), Qnil));
485 return -1;
489 /* Font property value validators. See the comment of
490 font_property_table for the meaning of the arguments. */
492 static Lisp_Object font_prop_validate (int, Lisp_Object, Lisp_Object);
493 static Lisp_Object font_prop_validate_symbol (Lisp_Object, Lisp_Object);
494 static Lisp_Object font_prop_validate_style (Lisp_Object, Lisp_Object);
495 static Lisp_Object font_prop_validate_non_neg (Lisp_Object, Lisp_Object);
496 static Lisp_Object font_prop_validate_spacing (Lisp_Object, Lisp_Object);
497 static int get_font_prop_index (Lisp_Object);
499 static Lisp_Object
500 font_prop_validate_symbol (Lisp_Object prop, Lisp_Object val)
502 if (STRINGP (val))
503 val = Fintern (val, Qnil);
504 if (! SYMBOLP (val))
505 val = Qerror;
506 else if (EQ (prop, QCregistry))
507 val = Fintern (Fdowncase (SYMBOL_NAME (val)), Qnil);
508 return val;
512 static Lisp_Object
513 font_prop_validate_style (Lisp_Object style, Lisp_Object val)
515 enum font_property_index prop = (EQ (style, QCweight) ? FONT_WEIGHT_INDEX
516 : EQ (style, QCslant) ? FONT_SLANT_INDEX
517 : FONT_WIDTH_INDEX);
518 if (INTEGERP (val))
520 int n = XINT (val);
521 if (((n >> 4) & 0xF)
522 >= ASIZE (AREF (font_style_table, prop - FONT_WEIGHT_INDEX)))
523 val = Qerror;
524 else
526 Lisp_Object elt = AREF (AREF (font_style_table, prop - FONT_WEIGHT_INDEX), (n >> 4) & 0xF);
528 if ((n & 0xF) + 1 >= ASIZE (elt))
529 val = Qerror;
530 else if (XINT (AREF (elt, 0)) != (n >> 8))
531 val = Qerror;
534 else if (SYMBOLP (val))
536 int n = font_style_to_value (prop, val, 0);
538 val = n >= 0 ? make_number (n) : Qerror;
540 else
541 val = Qerror;
542 return val;
545 static Lisp_Object
546 font_prop_validate_non_neg (Lisp_Object prop, Lisp_Object val)
548 return (NATNUMP (val) || (FLOATP (val) && XFLOAT_DATA (val) >= 0)
549 ? val : Qerror);
552 static Lisp_Object
553 font_prop_validate_spacing (Lisp_Object prop, Lisp_Object val)
555 if (NILP (val) || (NATNUMP (val) && XINT (val) <= FONT_SPACING_CHARCELL))
556 return val;
557 if (SYMBOLP (val) && SBYTES (SYMBOL_NAME (val)) == 1)
559 char spacing = SDATA (SYMBOL_NAME (val))[0];
561 if (spacing == 'c' || spacing == 'C')
562 return make_number (FONT_SPACING_CHARCELL);
563 if (spacing == 'm' || spacing == 'M')
564 return make_number (FONT_SPACING_MONO);
565 if (spacing == 'p' || spacing == 'P')
566 return make_number (FONT_SPACING_PROPORTIONAL);
567 if (spacing == 'd' || spacing == 'D')
568 return make_number (FONT_SPACING_DUAL);
570 return Qerror;
573 static Lisp_Object
574 font_prop_validate_otf (Lisp_Object prop, Lisp_Object val)
576 Lisp_Object tail, tmp;
577 int i;
579 /* VAL = (SCRIPT [ LANGSYS [ GSUB-FEATURES [ GPOS-FEATURES ]]])
580 GSUB-FEATURES = (FEATURE ... [ nil FEATURE ... ]) | nil
581 GPOS-FEATURES = (FEATURE ... [ nil FEATURE ... ]) | nil */
582 if (! CONSP (val))
583 return Qerror;
584 if (! SYMBOLP (XCAR (val)))
585 return Qerror;
586 tail = XCDR (val);
587 if (NILP (tail))
588 return val;
589 if (! CONSP (tail) || ! SYMBOLP (XCAR (val)))
590 return Qerror;
591 for (i = 0; i < 2; i++)
593 tail = XCDR (tail);
594 if (NILP (tail))
595 return val;
596 if (! CONSP (tail))
597 return Qerror;
598 for (tmp = XCAR (tail); CONSP (tmp); tmp = XCDR (tmp))
599 if (! SYMBOLP (XCAR (tmp)))
600 return Qerror;
601 if (! NILP (tmp))
602 return Qerror;
604 return val;
607 /* Structure of known font property keys and validator of the
608 values. */
609 static const struct
611 /* Pointer to the key symbol. */
612 Lisp_Object *key;
613 /* Function to validate PROP's value VAL, or NULL if any value is
614 ok. The value is VAL or its regularized value if VAL is valid,
615 and Qerror if not. */
616 Lisp_Object (*validater) (Lisp_Object prop, Lisp_Object val);
617 } font_property_table[] =
618 { { &QCtype, font_prop_validate_symbol },
619 { &QCfoundry, font_prop_validate_symbol },
620 { &QCfamily, font_prop_validate_symbol },
621 { &QCadstyle, font_prop_validate_symbol },
622 { &QCregistry, font_prop_validate_symbol },
623 { &QCweight, font_prop_validate_style },
624 { &QCslant, font_prop_validate_style },
625 { &QCwidth, font_prop_validate_style },
626 { &QCsize, font_prop_validate_non_neg },
627 { &QCdpi, font_prop_validate_non_neg },
628 { &QCspacing, font_prop_validate_spacing },
629 { &QCavgwidth, font_prop_validate_non_neg },
630 /* The order of the above entries must match with enum
631 font_property_index. */
632 { &QClang, font_prop_validate_symbol },
633 { &QCscript, font_prop_validate_symbol },
634 { &QCotf, font_prop_validate_otf }
637 /* Size (number of elements) of the above table. */
638 #define FONT_PROPERTY_TABLE_SIZE \
639 ((sizeof font_property_table) / (sizeof *font_property_table))
641 /* Return an index number of font property KEY or -1 if KEY is not an
642 already known property. */
644 static int
645 get_font_prop_index (Lisp_Object key)
647 int i;
649 for (i = 0; i < FONT_PROPERTY_TABLE_SIZE; i++)
650 if (EQ (key, *font_property_table[i].key))
651 return i;
652 return -1;
655 /* Validate the font property. The property key is specified by the
656 symbol PROP, or the index IDX (if PROP is nil). If VAL is invalid,
657 signal an error. The value is VAL or the regularized one. */
659 static Lisp_Object
660 font_prop_validate (int idx, Lisp_Object prop, Lisp_Object val)
662 Lisp_Object validated;
664 if (NILP (val))
665 return val;
666 if (NILP (prop))
667 prop = *font_property_table[idx].key;
668 else
670 idx = get_font_prop_index (prop);
671 if (idx < 0)
672 return val;
674 validated = (font_property_table[idx].validater) (prop, val);
675 if (EQ (validated, Qerror))
676 signal_error ("invalid font property", Fcons (prop, val));
677 return validated;
681 /* Store VAL as a value of extra font property PROP in FONT while
682 keeping the sorting order. Don't check the validity of VAL. */
684 Lisp_Object
685 font_put_extra (Lisp_Object font, Lisp_Object prop, Lisp_Object val)
687 Lisp_Object extra = AREF (font, FONT_EXTRA_INDEX);
688 Lisp_Object slot = (NILP (extra) ? Qnil : assq_no_quit (prop, extra));
690 if (NILP (slot))
692 Lisp_Object prev = Qnil;
694 while (CONSP (extra)
695 && NILP (Fstring_lessp (prop, XCAR (XCAR (extra)))))
696 prev = extra, extra = XCDR (extra);
698 if (NILP (prev))
699 ASET (font, FONT_EXTRA_INDEX, Fcons (Fcons (prop, val), extra));
700 else
701 XSETCDR (prev, Fcons (Fcons (prop, val), extra));
703 return val;
705 XSETCDR (slot, val);
706 if (NILP (val))
707 ASET (font, FONT_EXTRA_INDEX, Fdelq (slot, extra));
708 return val;
712 /* Font name parser and unparser */
714 static int parse_matrix (const char *);
715 static int font_expand_wildcards (Lisp_Object *, int);
716 static int font_parse_name (char *, Lisp_Object);
718 /* An enumerator for each field of an XLFD font name. */
719 enum xlfd_field_index
721 XLFD_FOUNDRY_INDEX,
722 XLFD_FAMILY_INDEX,
723 XLFD_WEIGHT_INDEX,
724 XLFD_SLANT_INDEX,
725 XLFD_SWIDTH_INDEX,
726 XLFD_ADSTYLE_INDEX,
727 XLFD_PIXEL_INDEX,
728 XLFD_POINT_INDEX,
729 XLFD_RESX_INDEX,
730 XLFD_RESY_INDEX,
731 XLFD_SPACING_INDEX,
732 XLFD_AVGWIDTH_INDEX,
733 XLFD_REGISTRY_INDEX,
734 XLFD_ENCODING_INDEX,
735 XLFD_LAST_INDEX
738 /* An enumerator for mask bit corresponding to each XLFD field. */
739 enum xlfd_field_mask
741 XLFD_FOUNDRY_MASK = 0x0001,
742 XLFD_FAMILY_MASK = 0x0002,
743 XLFD_WEIGHT_MASK = 0x0004,
744 XLFD_SLANT_MASK = 0x0008,
745 XLFD_SWIDTH_MASK = 0x0010,
746 XLFD_ADSTYLE_MASK = 0x0020,
747 XLFD_PIXEL_MASK = 0x0040,
748 XLFD_POINT_MASK = 0x0080,
749 XLFD_RESX_MASK = 0x0100,
750 XLFD_RESY_MASK = 0x0200,
751 XLFD_SPACING_MASK = 0x0400,
752 XLFD_AVGWIDTH_MASK = 0x0800,
753 XLFD_REGISTRY_MASK = 0x1000,
754 XLFD_ENCODING_MASK = 0x2000
758 /* Parse P pointing to the pixel/point size field of the form
759 `[A B C D]' which specifies a transformation matrix:
761 A B 0
762 C D 0
763 0 0 1
765 by which all glyphs of the font are transformed. The spec says
766 that scalar value N for the pixel/point size is equivalent to:
767 A = N * resx/resy, B = C = 0, D = N.
769 Return the scalar value N if the form is valid. Otherwise return
770 -1. */
772 static int
773 parse_matrix (const char *p)
775 double matrix[4];
776 char *end;
777 int i;
779 for (i = 0, p++; i < 4 && *p && *p != ']'; i++)
781 if (*p == '~')
782 matrix[i] = - strtod (p + 1, &end);
783 else
784 matrix[i] = strtod (p, &end);
785 p = end;
787 return (i == 4 ? (int) matrix[3] : -1);
790 /* Expand a wildcard field in FIELD (the first N fields are filled) to
791 multiple fields to fill in all 14 XLFD fields while restricting a
792 field position by its contents. */
794 static int
795 font_expand_wildcards (Lisp_Object *field, int n)
797 /* Copy of FIELD. */
798 Lisp_Object tmp[XLFD_LAST_INDEX];
799 /* Array of information about where this element can go. Nth
800 element is for Nth element of FIELD. */
801 struct {
802 /* Minimum possible field. */
803 int from;
804 /* Maxinum possible field. */
805 int to;
806 /* Bit mask of possible field. Nth bit corresponds to Nth field. */
807 int mask;
808 } range[XLFD_LAST_INDEX];
809 int i, j;
810 int range_from, range_to;
811 unsigned range_mask;
813 #define XLFD_SYMBOL_MASK (XLFD_FOUNDRY_MASK | XLFD_FAMILY_MASK \
814 | XLFD_ADSTYLE_MASK | XLFD_REGISTRY_MASK)
815 #define XLFD_NULL_MASK (XLFD_FOUNDRY_MASK | XLFD_ADSTYLE_MASK)
816 #define XLFD_LARGENUM_MASK (XLFD_POINT_MASK | XLFD_RESX_MASK | XLFD_RESY_MASK \
817 | XLFD_AVGWIDTH_MASK)
818 #define XLFD_REGENC_MASK (XLFD_REGISTRY_MASK | XLFD_ENCODING_MASK)
820 /* Initialize RANGE_MASK for FIELD[0] which can be 0th to (14 - N)th
821 field. The value is shifted to left one bit by one in the
822 following loop. */
823 for (i = 0, range_mask = 0; i <= 14 - n; i++)
824 range_mask = (range_mask << 1) | 1;
826 /* The triplet RANGE_FROM, RANGE_TO, and RANGE_MASK is a
827 position-based retriction for FIELD[I]. */
828 for (i = 0, range_from = 0, range_to = 14 - n; i < n;
829 i++, range_from++, range_to++, range_mask <<= 1)
831 Lisp_Object val = field[i];
833 tmp[i] = val;
834 if (NILP (val))
836 /* Wildcard. */
837 range[i].from = range_from;
838 range[i].to = range_to;
839 range[i].mask = range_mask;
841 else
843 /* The triplet FROM, TO, and MASK is a value-based
844 retriction for FIELD[I]. */
845 int from, to;
846 unsigned mask;
848 if (INTEGERP (val))
850 int numeric = XINT (val);
852 if (i + 1 == n)
853 from = to = XLFD_ENCODING_INDEX,
854 mask = XLFD_ENCODING_MASK;
855 else if (numeric == 0)
856 from = XLFD_PIXEL_INDEX, to = XLFD_AVGWIDTH_INDEX,
857 mask = XLFD_PIXEL_MASK | XLFD_LARGENUM_MASK;
858 else if (numeric <= 48)
859 from = to = XLFD_PIXEL_INDEX,
860 mask = XLFD_PIXEL_MASK;
861 else
862 from = XLFD_POINT_INDEX, to = XLFD_AVGWIDTH_INDEX,
863 mask = XLFD_LARGENUM_MASK;
865 else if (SBYTES (SYMBOL_NAME (val)) == 0)
866 from = XLFD_FOUNDRY_INDEX, to = XLFD_ADSTYLE_INDEX,
867 mask = XLFD_NULL_MASK;
868 else if (i == 0)
869 from = to = XLFD_FOUNDRY_INDEX, mask = XLFD_FOUNDRY_MASK;
870 else if (i + 1 == n)
872 Lisp_Object name = SYMBOL_NAME (val);
874 if (SDATA (name)[SBYTES (name) - 1] == '*')
875 from = XLFD_REGISTRY_INDEX, to = XLFD_ENCODING_INDEX,
876 mask = XLFD_REGENC_MASK;
877 else
878 from = to = XLFD_ENCODING_INDEX,
879 mask = XLFD_ENCODING_MASK;
881 else if (range_from <= XLFD_WEIGHT_INDEX
882 && range_to >= XLFD_WEIGHT_INDEX
883 && FONT_WEIGHT_NAME_NUMERIC (val) >= 0)
884 from = to = XLFD_WEIGHT_INDEX, mask = XLFD_WEIGHT_MASK;
885 else if (range_from <= XLFD_SLANT_INDEX
886 && range_to >= XLFD_SLANT_INDEX
887 && FONT_SLANT_NAME_NUMERIC (val) >= 0)
888 from = to = XLFD_SLANT_INDEX, mask = XLFD_SLANT_MASK;
889 else if (range_from <= XLFD_SWIDTH_INDEX
890 && range_to >= XLFD_SWIDTH_INDEX
891 && FONT_WIDTH_NAME_NUMERIC (val) >= 0)
892 from = to = XLFD_SWIDTH_INDEX, mask = XLFD_SWIDTH_MASK;
893 else
895 if (EQ (val, Qc) || EQ (val, Qm) || EQ (val, Qp) || EQ (val, Qd))
896 from = to = XLFD_SPACING_INDEX, mask = XLFD_SPACING_MASK;
897 else
898 from = XLFD_FOUNDRY_INDEX, to = XLFD_ENCODING_INDEX,
899 mask = XLFD_SYMBOL_MASK;
902 /* Merge position-based and value-based restrictions. */
903 mask &= range_mask;
904 while (from < range_from)
905 mask &= ~(1 << from++);
906 while (from < 14 && ! (mask & (1 << from)))
907 from++;
908 while (to > range_to)
909 mask &= ~(1 << to--);
910 while (to >= 0 && ! (mask & (1 << to)))
911 to--;
912 if (from > to)
913 return -1;
914 range[i].from = from;
915 range[i].to = to;
916 range[i].mask = mask;
918 if (from > range_from || to < range_to)
920 /* The range is narrowed by value-based restrictions.
921 Reflect it to the other fields. */
923 /* Following fields should be after FROM. */
924 range_from = from;
925 /* Preceding fields should be before TO. */
926 for (j = i - 1, from--, to--; j >= 0; j--, from--, to--)
928 /* Check FROM for non-wildcard field. */
929 if (! NILP (tmp[j]) && range[j].from < from)
931 while (range[j].from < from)
932 range[j].mask &= ~(1 << range[j].from++);
933 while (from < 14 && ! (range[j].mask & (1 << from)))
934 from++;
935 range[j].from = from;
937 else
938 from = range[j].from;
939 if (range[j].to > to)
941 while (range[j].to > to)
942 range[j].mask &= ~(1 << range[j].to--);
943 while (to >= 0 && ! (range[j].mask & (1 << to)))
944 to--;
945 range[j].to = to;
947 else
948 to = range[j].to;
949 if (from > to)
950 return -1;
956 /* Decide all fileds from restrictions in RANGE. */
957 for (i = j = 0; i < n ; i++)
959 if (j < range[i].from)
961 if (i == 0 || ! NILP (tmp[i - 1]))
962 /* None of TMP[X] corresponds to Jth field. */
963 return -1;
964 for (; j < range[i].from; j++)
965 field[j] = Qnil;
967 field[j++] = tmp[i];
969 if (! NILP (tmp[n - 1]) && j < XLFD_REGISTRY_INDEX)
970 return -1;
971 for (; j < XLFD_LAST_INDEX; j++)
972 field[j] = Qnil;
973 if (INTEGERP (field[XLFD_ENCODING_INDEX]))
974 field[XLFD_ENCODING_INDEX]
975 = Fintern (Fnumber_to_string (field[XLFD_ENCODING_INDEX]), Qnil);
976 return 0;
980 /* Parse NAME (null terminated) as XLFD and store information in FONT
981 (font-spec or font-entity). Size property of FONT is set as
982 follows:
983 specified XLFD fields FONT property
984 --------------------- -------------
985 PIXEL_SIZE PIXEL_SIZE (Lisp integer)
986 POINT_SIZE and RESY calculated pixel size (Lisp integer)
987 POINT_SIZE POINT_SIZE/10 (Lisp float)
989 If NAME is successfully parsed, return 0. Otherwise return -1.
991 FONT is usually a font-spec, but when this function is called from
992 X font backend driver, it is a font-entity. In that case, NAME is
993 a fully specified XLFD. */
996 font_parse_xlfd (char *name, Lisp_Object font)
998 ptrdiff_t len = strlen (name);
999 int i, j, n;
1000 char *f[XLFD_LAST_INDEX + 1];
1001 Lisp_Object val;
1002 char *p;
1004 if (len > 255 || !len)
1005 /* Maximum XLFD name length is 255. */
1006 return -1;
1007 /* Accept "*-.." as a fully specified XLFD. */
1008 if (name[0] == '*' && (len == 1 || name[1] == '-'))
1009 i = 1, f[XLFD_FOUNDRY_INDEX] = name;
1010 else
1011 i = 0;
1012 for (p = name + i; *p; p++)
1013 if (*p == '-')
1015 f[i++] = p + 1;
1016 if (i == XLFD_LAST_INDEX)
1017 break;
1019 f[i] = name + len;
1021 #define INTERN_FIELD(N) font_intern_prop (f[N], f[(N) + 1] - 1 - f[N], 0)
1022 #define INTERN_FIELD_SYM(N) font_intern_prop (f[N], f[(N) + 1] - 1 - f[N], 1)
1024 if (i == XLFD_LAST_INDEX)
1026 /* Fully specified XLFD. */
1027 int pixel_size;
1029 ASET (font, FONT_FOUNDRY_INDEX, INTERN_FIELD_SYM (XLFD_FOUNDRY_INDEX));
1030 ASET (font, FONT_FAMILY_INDEX, INTERN_FIELD_SYM (XLFD_FAMILY_INDEX));
1031 for (i = XLFD_WEIGHT_INDEX, j = FONT_WEIGHT_INDEX;
1032 i <= XLFD_SWIDTH_INDEX; i++, j++)
1034 val = INTERN_FIELD_SYM (i);
1035 if (! NILP (val))
1037 if ((n = font_style_to_value (j, INTERN_FIELD_SYM (i), 0)) < 0)
1038 return -1;
1039 ASET (font, j, make_number (n));
1042 ASET (font, FONT_ADSTYLE_INDEX, INTERN_FIELD_SYM (XLFD_ADSTYLE_INDEX));
1043 if (strcmp (f[XLFD_REGISTRY_INDEX], "*-*") == 0)
1044 ASET (font, FONT_REGISTRY_INDEX, Qnil);
1045 else
1046 ASET (font, FONT_REGISTRY_INDEX,
1047 font_intern_prop (f[XLFD_REGISTRY_INDEX],
1048 f[XLFD_LAST_INDEX] - f[XLFD_REGISTRY_INDEX],
1049 1));
1050 p = f[XLFD_PIXEL_INDEX];
1051 if (*p == '[' && (pixel_size = parse_matrix (p)) >= 0)
1052 ASET (font, FONT_SIZE_INDEX, make_number (pixel_size));
1053 else
1055 val = INTERN_FIELD (XLFD_PIXEL_INDEX);
1056 if (INTEGERP (val))
1057 ASET (font, FONT_SIZE_INDEX, val);
1058 else if (FONT_ENTITY_P (font))
1059 return -1;
1060 else
1062 double point_size = -1;
1064 font_assert (FONT_SPEC_P (font));
1065 p = f[XLFD_POINT_INDEX];
1066 if (*p == '[')
1067 point_size = parse_matrix (p);
1068 else if (isdigit (*p))
1069 point_size = atoi (p), point_size /= 10;
1070 if (point_size >= 0)
1071 ASET (font, FONT_SIZE_INDEX, make_float (point_size));
1075 val = INTERN_FIELD (XLFD_RESY_INDEX);
1076 if (! NILP (val) && ! INTEGERP (val))
1077 return -1;
1078 ASET (font, FONT_DPI_INDEX, val);
1079 val = INTERN_FIELD (XLFD_SPACING_INDEX);
1080 if (! NILP (val))
1082 val = font_prop_validate_spacing (QCspacing, val);
1083 if (! INTEGERP (val))
1084 return -1;
1085 ASET (font, FONT_SPACING_INDEX, val);
1087 p = f[XLFD_AVGWIDTH_INDEX];
1088 if (*p == '~')
1089 p++;
1090 val = font_intern_prop (p, f[XLFD_REGISTRY_INDEX] - 1 - p, 0);
1091 if (! NILP (val) && ! INTEGERP (val))
1092 return -1;
1093 ASET (font, FONT_AVGWIDTH_INDEX, val);
1095 else
1097 int wild_card_found = 0;
1098 Lisp_Object prop[XLFD_LAST_INDEX];
1100 if (FONT_ENTITY_P (font))
1101 return -1;
1102 for (j = 0; j < i; j++)
1104 if (*f[j] == '*')
1106 if (f[j][1] && f[j][1] != '-')
1107 return -1;
1108 prop[j] = Qnil;
1109 wild_card_found = 1;
1111 else if (j + 1 < i)
1112 prop[j] = INTERN_FIELD (j);
1113 else
1114 prop[j] = font_intern_prop (f[j], f[i] - f[j], 0);
1116 if (! wild_card_found)
1117 return -1;
1118 if (font_expand_wildcards (prop, i) < 0)
1119 return -1;
1121 ASET (font, FONT_FOUNDRY_INDEX, prop[XLFD_FOUNDRY_INDEX]);
1122 ASET (font, FONT_FAMILY_INDEX, prop[XLFD_FAMILY_INDEX]);
1123 for (i = XLFD_WEIGHT_INDEX, j = FONT_WEIGHT_INDEX;
1124 i <= XLFD_SWIDTH_INDEX; i++, j++)
1125 if (! NILP (prop[i]))
1127 if ((n = font_style_to_value (j, prop[i], 1)) < 0)
1128 return -1;
1129 ASET (font, j, make_number (n));
1131 ASET (font, FONT_ADSTYLE_INDEX, prop[XLFD_ADSTYLE_INDEX]);
1132 val = prop[XLFD_REGISTRY_INDEX];
1133 if (NILP (val))
1135 val = prop[XLFD_ENCODING_INDEX];
1136 if (! NILP (val))
1137 val = concat2 (build_string ("*-"), SYMBOL_NAME (val));
1139 else if (NILP (prop[XLFD_ENCODING_INDEX]))
1140 val = concat2 (SYMBOL_NAME (val), build_string ("-*"));
1141 else
1142 val = concat3 (SYMBOL_NAME (val), build_string ("-"),
1143 SYMBOL_NAME (prop[XLFD_ENCODING_INDEX]));
1144 if (! NILP (val))
1145 ASET (font, FONT_REGISTRY_INDEX, Fintern (val, Qnil));
1147 if (INTEGERP (prop[XLFD_PIXEL_INDEX]))
1148 ASET (font, FONT_SIZE_INDEX, prop[XLFD_PIXEL_INDEX]);
1149 else if (INTEGERP (prop[XLFD_POINT_INDEX]))
1151 double point_size = XINT (prop[XLFD_POINT_INDEX]);
1153 ASET (font, FONT_SIZE_INDEX, make_float (point_size / 10));
1156 if (INTEGERP (prop[XLFD_RESX_INDEX]))
1157 ASET (font, FONT_DPI_INDEX, prop[XLFD_RESY_INDEX]);
1158 if (! NILP (prop[XLFD_SPACING_INDEX]))
1160 val = font_prop_validate_spacing (QCspacing,
1161 prop[XLFD_SPACING_INDEX]);
1162 if (! INTEGERP (val))
1163 return -1;
1164 ASET (font, FONT_SPACING_INDEX, val);
1166 if (INTEGERP (prop[XLFD_AVGWIDTH_INDEX]))
1167 ASET (font, FONT_AVGWIDTH_INDEX, prop[XLFD_AVGWIDTH_INDEX]);
1170 return 0;
1173 /* Store XLFD name of FONT (font-spec or font-entity) in NAME (NBYTES
1174 length), and return the name length. If FONT_SIZE_INDEX of FONT is
1175 0, use PIXEL_SIZE instead. */
1178 font_unparse_xlfd (Lisp_Object font, int pixel_size, char *name, int nbytes)
1180 char *p;
1181 const char *f[XLFD_REGISTRY_INDEX + 1];
1182 Lisp_Object val;
1183 int i, j, len = 0;
1185 font_assert (FONTP (font));
1187 for (i = FONT_FOUNDRY_INDEX, j = XLFD_FOUNDRY_INDEX; i <= FONT_REGISTRY_INDEX;
1188 i++, j++)
1190 if (i == FONT_ADSTYLE_INDEX)
1191 j = XLFD_ADSTYLE_INDEX;
1192 else if (i == FONT_REGISTRY_INDEX)
1193 j = XLFD_REGISTRY_INDEX;
1194 val = AREF (font, i);
1195 if (NILP (val))
1197 if (j == XLFD_REGISTRY_INDEX)
1198 f[j] = "*-*", len += 4;
1199 else
1200 f[j] = "*", len += 2;
1202 else
1204 if (SYMBOLP (val))
1205 val = SYMBOL_NAME (val);
1206 if (j == XLFD_REGISTRY_INDEX
1207 && ! strchr (SSDATA (val), '-'))
1209 /* Change "jisx0208*" and "jisx0208" to "jisx0208*-*". */
1210 if (SDATA (val)[SBYTES (val) - 1] == '*')
1212 f[j] = p = alloca (SBYTES (val) + 3);
1213 sprintf (p, "%s-*", SDATA (val));
1214 len += SBYTES (val) + 3;
1216 else
1218 f[j] = p = alloca (SBYTES (val) + 4);
1219 sprintf (p, "%s*-*", SDATA (val));
1220 len += SBYTES (val) + 4;
1223 else
1224 f[j] = SSDATA (val), len += SBYTES (val) + 1;
1228 for (i = FONT_WEIGHT_INDEX, j = XLFD_WEIGHT_INDEX; i <= FONT_WIDTH_INDEX;
1229 i++, j++)
1231 val = font_style_symbolic (font, i, 0);
1232 if (NILP (val))
1233 f[j] = "*", len += 2;
1234 else
1236 val = SYMBOL_NAME (val);
1237 f[j] = SSDATA (val), len += SBYTES (val) + 1;
1241 val = AREF (font, FONT_SIZE_INDEX);
1242 font_assert (NUMBERP (val) || NILP (val));
1243 if (INTEGERP (val))
1245 i = XINT (val);
1246 if (i <= 0)
1247 i = pixel_size;
1248 if (i > 0)
1250 f[XLFD_PIXEL_INDEX] = p = alloca (22);
1251 len += sprintf (p, "%d-*", i) + 1;
1253 else
1254 f[XLFD_PIXEL_INDEX] = "*-*", len += 4;
1256 else if (FLOATP (val))
1258 i = XFLOAT_DATA (val) * 10;
1259 f[XLFD_PIXEL_INDEX] = p = alloca (12);
1260 len += sprintf (p, "*-%d", i) + 1;
1262 else
1263 f[XLFD_PIXEL_INDEX] = "*-*", len += 4;
1265 if (INTEGERP (AREF (font, FONT_DPI_INDEX)))
1267 i = XINT (AREF (font, FONT_DPI_INDEX));
1268 f[XLFD_RESX_INDEX] = p = alloca (22);
1269 len += sprintf (p, "%d-%d", i, i) + 1;
1271 else
1272 f[XLFD_RESX_INDEX] = "*-*", len += 4;
1273 if (INTEGERP (AREF (font, FONT_SPACING_INDEX)))
1275 int spacing = XINT (AREF (font, FONT_SPACING_INDEX));
1277 f[XLFD_SPACING_INDEX] = (spacing <= FONT_SPACING_PROPORTIONAL ? "p"
1278 : spacing <= FONT_SPACING_DUAL ? "d"
1279 : spacing <= FONT_SPACING_MONO ? "m"
1280 : "c");
1281 len += 2;
1283 else
1284 f[XLFD_SPACING_INDEX] = "*", len += 2;
1285 if (INTEGERP (AREF (font, FONT_AVGWIDTH_INDEX)))
1287 f[XLFD_AVGWIDTH_INDEX] = p = alloca (22);
1288 len += sprintf (p, "%"pI"d",
1289 XINT (AREF (font, FONT_AVGWIDTH_INDEX))) + 1;
1291 else
1292 f[XLFD_AVGWIDTH_INDEX] = "*", len += 2;
1293 len++; /* for terminating '\0'. */
1294 if (len >= nbytes)
1295 return -1;
1296 return sprintf (name, "-%s-%s-%s-%s-%s-%s-%s-%s-%s-%s-%s",
1297 f[XLFD_FOUNDRY_INDEX], f[XLFD_FAMILY_INDEX],
1298 f[XLFD_WEIGHT_INDEX], f[XLFD_SLANT_INDEX],
1299 f[XLFD_SWIDTH_INDEX], f[XLFD_ADSTYLE_INDEX],
1300 f[XLFD_PIXEL_INDEX], f[XLFD_RESX_INDEX],
1301 f[XLFD_SPACING_INDEX], f[XLFD_AVGWIDTH_INDEX],
1302 f[XLFD_REGISTRY_INDEX]);
1305 /* Parse NAME (null terminated) and store information in FONT
1306 (font-spec or font-entity). NAME is supplied in either the
1307 Fontconfig or GTK font name format. If NAME is successfully
1308 parsed, return 0. Otherwise return -1.
1310 The fontconfig format is
1312 FAMILY[-SIZE][:PROP1[=VAL1][:PROP2[=VAL2]...]]
1314 The GTK format is
1316 FAMILY [PROPS...] [SIZE]
1318 This function tries to guess which format it is. */
1320 static int
1321 font_parse_fcname (char *name, Lisp_Object font)
1323 char *p, *q;
1324 char *size_beg = NULL, *size_end = NULL;
1325 char *props_beg = NULL, *family_end = NULL;
1326 ptrdiff_t len = strlen (name);
1328 if (len == 0)
1329 return -1;
1331 for (p = name; *p; p++)
1333 if (*p == '\\' && p[1])
1334 p++;
1335 else if (*p == ':')
1337 props_beg = family_end = p;
1338 break;
1340 else if (*p == '-')
1342 int decimal = 0, size_found = 1;
1343 for (q = p + 1; *q && *q != ':'; q++)
1344 if (! isdigit(*q))
1346 if (*q != '.' || decimal)
1348 size_found = 0;
1349 break;
1351 decimal = 1;
1353 if (size_found)
1355 family_end = p;
1356 size_beg = p + 1;
1357 size_end = q;
1358 break;
1363 if (family_end)
1365 Lisp_Object extra_props = Qnil;
1367 /* A fontconfig name with size and/or property data. */
1368 if (family_end > name)
1370 Lisp_Object family;
1371 family = font_intern_prop (name, family_end - name, 1);
1372 ASET (font, FONT_FAMILY_INDEX, family);
1374 if (size_beg)
1376 double point_size = strtod (size_beg, &size_end);
1377 ASET (font, FONT_SIZE_INDEX, make_float (point_size));
1378 if (*size_end == ':' && size_end[1])
1379 props_beg = size_end;
1381 if (props_beg)
1383 /* Now parse ":KEY=VAL" patterns. */
1384 Lisp_Object val;
1386 for (p = props_beg; *p; p = q)
1388 for (q = p + 1; *q && *q != '=' && *q != ':'; q++);
1389 if (*q != '=')
1391 /* Must be an enumerated value. */
1392 ptrdiff_t word_len;
1393 p = p + 1;
1394 word_len = q - p;
1395 val = font_intern_prop (p, q - p, 1);
1397 #define PROP_MATCH(STR) (word_len == strlen (STR) \
1398 && memcmp (p, STR, strlen (STR)) == 0)
1400 if (PROP_MATCH ("light")
1401 || PROP_MATCH ("medium")
1402 || PROP_MATCH ("demibold")
1403 || PROP_MATCH ("bold")
1404 || PROP_MATCH ("black"))
1405 FONT_SET_STYLE (font, FONT_WEIGHT_INDEX, val);
1406 else if (PROP_MATCH ("roman")
1407 || PROP_MATCH ("italic")
1408 || PROP_MATCH ("oblique"))
1409 FONT_SET_STYLE (font, FONT_SLANT_INDEX, val);
1410 else if (PROP_MATCH ("charcell"))
1411 ASET (font, FONT_SPACING_INDEX,
1412 make_number (FONT_SPACING_CHARCELL));
1413 else if (PROP_MATCH ("mono"))
1414 ASET (font, FONT_SPACING_INDEX,
1415 make_number (FONT_SPACING_MONO));
1416 else if (PROP_MATCH ("proportional"))
1417 ASET (font, FONT_SPACING_INDEX,
1418 make_number (FONT_SPACING_PROPORTIONAL));
1419 #undef PROP_MATCH
1421 else
1423 /* KEY=VAL pairs */
1424 Lisp_Object key;
1425 int prop;
1427 if (q - p == 10 && memcmp (p + 1, "pixelsize", 9) == 0)
1428 prop = FONT_SIZE_INDEX;
1429 else
1431 key = font_intern_prop (p, q - p, 1);
1432 prop = get_font_prop_index (key);
1435 p = q + 1;
1436 for (q = p; *q && *q != ':'; q++);
1437 val = font_intern_prop (p, q - p, 0);
1439 if (prop >= FONT_FOUNDRY_INDEX
1440 && prop < FONT_EXTRA_INDEX)
1441 ASET (font, prop, font_prop_validate (prop, Qnil, val));
1442 else
1444 extra_props = nconc2 (extra_props,
1445 Fcons (Fcons (key, val), Qnil));
1448 p = q;
1452 if (! NILP (extra_props))
1454 struct font_driver_list *driver_list = font_driver_list;
1455 for ( ; driver_list; driver_list = driver_list->next)
1456 if (driver_list->driver->filter_properties)
1457 (*driver_list->driver->filter_properties) (font, extra_props);
1461 else
1463 /* Either a fontconfig-style name with no size and property
1464 data, or a GTK-style name. */
1465 Lisp_Object weight = Qnil, slant = Qnil;
1466 Lisp_Object width = Qnil, size = Qnil;
1467 char *word_start;
1468 ptrdiff_t word_len;
1470 /* Scan backwards from the end, looking for a size. */
1471 for (p = name + len - 1; p >= name; p--)
1472 if (!isdigit (*p))
1473 break;
1475 if ((p < name + len - 1) && ((p + 1 == name) || *p == ' '))
1476 /* Found a font size. */
1477 size = make_float (strtod (p + 1, NULL));
1478 else
1479 p = name + len;
1481 /* Now P points to the termination of the string, sans size.
1482 Scan backwards, looking for font properties. */
1483 for (; p > name; p = q)
1485 for (q = p - 1; q >= name; q--)
1487 if (q > name && *(q-1) == '\\')
1488 --q; /* Skip quoting backslashes. */
1489 else if (*q == ' ')
1490 break;
1493 word_start = q + 1;
1494 word_len = p - word_start;
1496 #define PROP_MATCH(STR) \
1497 (word_len == strlen (STR) \
1498 && memcmp (word_start, STR, strlen (STR)) == 0)
1499 #define PROP_SAVE(VAR, STR) \
1500 (VAR = NILP (VAR) ? font_intern_prop (STR, strlen (STR), 1) : VAR)
1502 if (PROP_MATCH ("Ultra-Light"))
1503 PROP_SAVE (weight, "ultra-light");
1504 else if (PROP_MATCH ("Light"))
1505 PROP_SAVE (weight, "light");
1506 else if (PROP_MATCH ("Book"))
1507 PROP_SAVE (weight, "book");
1508 else if (PROP_MATCH ("Medium"))
1509 PROP_SAVE (weight, "medium");
1510 else if (PROP_MATCH ("Semi-Bold"))
1511 PROP_SAVE (weight, "semi-bold");
1512 else if (PROP_MATCH ("Bold"))
1513 PROP_SAVE (weight, "bold");
1514 else if (PROP_MATCH ("Italic"))
1515 PROP_SAVE (slant, "italic");
1516 else if (PROP_MATCH ("Oblique"))
1517 PROP_SAVE (slant, "oblique");
1518 else if (PROP_MATCH ("Semi-Condensed"))
1519 PROP_SAVE (width, "semi-condensed");
1520 else if (PROP_MATCH ("Condensed"))
1521 PROP_SAVE (width, "condensed");
1522 /* An unknown word must be part of the font name. */
1523 else
1525 family_end = p;
1526 break;
1529 #undef PROP_MATCH
1530 #undef PROP_SAVE
1532 if (family_end)
1533 ASET (font, FONT_FAMILY_INDEX,
1534 font_intern_prop (name, family_end - name, 1));
1535 if (!NILP (size))
1536 ASET (font, FONT_SIZE_INDEX, size);
1537 if (!NILP (weight))
1538 FONT_SET_STYLE (font, FONT_WEIGHT_INDEX, weight);
1539 if (!NILP (slant))
1540 FONT_SET_STYLE (font, FONT_SLANT_INDEX, slant);
1541 if (!NILP (width))
1542 FONT_SET_STYLE (font, FONT_WIDTH_INDEX, width);
1545 return 0;
1548 /* Store fontconfig's font name of FONT (font-spec or font-entity) in
1549 NAME (NBYTES length), and return the name length. If
1550 FONT_SIZE_INDEX of FONT is 0, use PIXEL_SIZE instead. */
1553 font_unparse_fcname (Lisp_Object font, int pixel_size, char *name, int nbytes)
1555 Lisp_Object family, foundry;
1556 Lisp_Object tail, val;
1557 int point_size;
1558 int i;
1559 ptrdiff_t len = 1;
1560 char *p;
1561 Lisp_Object styles[3];
1562 const char *style_names[3] = { "weight", "slant", "width" };
1563 char work[256];
1565 family = AREF (font, FONT_FAMILY_INDEX);
1566 if (! NILP (family))
1568 if (SYMBOLP (family))
1570 family = SYMBOL_NAME (family);
1571 len += SBYTES (family);
1573 else
1574 family = Qnil;
1577 val = AREF (font, FONT_SIZE_INDEX);
1578 if (INTEGERP (val))
1580 if (XINT (val) != 0)
1581 pixel_size = XINT (val);
1582 point_size = -1;
1583 len += 21; /* for ":pixelsize=NUM" */
1585 else
1587 if (! FLOATP (val))
1588 abort ();
1589 pixel_size = -1;
1590 point_size = (int) XFLOAT_DATA (val);
1591 len += 11; /* for "-NUM" */
1594 foundry = AREF (font, FONT_FOUNDRY_INDEX);
1595 if (! NILP (foundry))
1597 if (SYMBOLP (foundry))
1599 foundry = SYMBOL_NAME (foundry);
1600 len += 9 + SBYTES (foundry); /* ":foundry=NAME" */
1602 else
1603 foundry = Qnil;
1606 for (i = 0; i < 3; i++)
1608 styles[i] = font_style_symbolic (font, FONT_WEIGHT_INDEX + i, 0);
1609 if (! NILP (styles[i]))
1610 len += sprintf (work, ":%s=%s", style_names[i],
1611 SDATA (SYMBOL_NAME (styles[i])));
1614 if (INTEGERP (AREF (font, FONT_DPI_INDEX)))
1615 len += sprintf (work, ":dpi=%"pI"d", XINT (AREF (font, FONT_DPI_INDEX)));
1616 if (INTEGERP (AREF (font, FONT_SPACING_INDEX)))
1617 len += strlen (":spacing=100");
1618 if (INTEGERP (AREF (font, FONT_AVGWIDTH_INDEX)))
1619 len += strlen (":scalable=false"); /* or ":scalable=true" */
1620 for (tail = AREF (font, FONT_EXTRA_INDEX); CONSP (tail); tail = XCDR (tail))
1622 Lisp_Object key = XCAR (XCAR (tail)), value = XCDR (XCAR (tail));
1624 len += SBYTES (SYMBOL_NAME (key)) + 1; /* for :KEY= */
1625 if (STRINGP (value))
1626 len += SBYTES (value);
1627 else if (INTEGERP (value))
1628 len += sprintf (work, "%"pI"d", XINT (value));
1629 else if (SYMBOLP (value))
1630 len += (NILP (value) ? 5 : 4); /* for "false" or "true" */
1633 if (len > nbytes)
1634 return -1;
1635 p = name;
1636 if (! NILP (family))
1637 p += sprintf (p, "%s", SDATA (family));
1638 if (point_size > 0)
1640 if (p == name)
1641 p += sprintf (p, "%d", point_size);
1642 else
1643 p += sprintf (p, "-%d", point_size);
1645 else if (pixel_size > 0)
1646 p += sprintf (p, ":pixelsize=%d", pixel_size);
1647 if (! NILP (AREF (font, FONT_FOUNDRY_INDEX)))
1648 p += sprintf (p, ":foundry=%s",
1649 SDATA (SYMBOL_NAME (AREF (font, FONT_FOUNDRY_INDEX))));
1650 for (i = 0; i < 3; i++)
1651 if (! NILP (styles[i]))
1652 p += sprintf (p, ":%s=%s", style_names[i],
1653 SDATA (SYMBOL_NAME (styles[i])));
1654 if (INTEGERP (AREF (font, FONT_DPI_INDEX)))
1655 p += sprintf (p, ":dpi=%"pI"d", XINT (AREF (font, FONT_DPI_INDEX)));
1656 if (INTEGERP (AREF (font, FONT_SPACING_INDEX)))
1657 p += sprintf (p, ":spacing=%"pI"d", XINT (AREF (font, FONT_SPACING_INDEX)));
1658 if (INTEGERP (AREF (font, FONT_AVGWIDTH_INDEX)))
1660 if (XINT (AREF (font, FONT_AVGWIDTH_INDEX)) == 0)
1661 p += sprintf (p, ":scalable=true");
1662 else
1663 p += sprintf (p, ":scalable=false");
1665 return (p - name);
1668 /* Parse NAME (null terminated) and store information in FONT
1669 (font-spec or font-entity). If NAME is successfully parsed, return
1670 0. Otherwise return -1. */
1672 static int
1673 font_parse_name (char *name, Lisp_Object font)
1675 if (name[0] == '-' || strchr (name, '*') || strchr (name, '?'))
1676 return font_parse_xlfd (name, font);
1677 return font_parse_fcname (name, font);
1681 /* Merge FAMILY and REGISTRY into FONT_SPEC. FAMILY may have the form
1682 "FAMILY-FOUNDRY". REGISTRY may not contain charset-encoding
1683 part. */
1685 void
1686 font_parse_family_registry (Lisp_Object family, Lisp_Object registry, Lisp_Object font_spec)
1688 int len;
1689 char *p0, *p1;
1691 if (! NILP (family)
1692 && NILP (AREF (font_spec, FONT_FAMILY_INDEX)))
1694 CHECK_STRING (family);
1695 len = SBYTES (family);
1696 p0 = SSDATA (family);
1697 p1 = strchr (p0, '-');
1698 if (p1)
1700 if ((*p0 != '*' && p1 - p0 > 0)
1701 && NILP (AREF (font_spec, FONT_FOUNDRY_INDEX)))
1702 Ffont_put (font_spec, QCfoundry, font_intern_prop (p0, p1 - p0, 1));
1703 p1++;
1704 len -= p1 - p0;
1705 Ffont_put (font_spec, QCfamily, font_intern_prop (p1, len, 1));
1707 else
1708 ASET (font_spec, FONT_FAMILY_INDEX, Fintern (family, Qnil));
1710 if (! NILP (registry))
1712 /* Convert "XXX" and "XXX*" to "XXX*-*". */
1713 CHECK_STRING (registry);
1714 len = SBYTES (registry);
1715 p0 = SSDATA (registry);
1716 p1 = strchr (p0, '-');
1717 if (! p1)
1719 if (SDATA (registry)[len - 1] == '*')
1720 registry = concat2 (registry, build_string ("-*"));
1721 else
1722 registry = concat2 (registry, build_string ("*-*"));
1724 registry = Fdowncase (registry);
1725 ASET (font_spec, FONT_REGISTRY_INDEX, Fintern (registry, Qnil));
1730 /* This part (through the next ^L) is still experimental and not
1731 tested much. We may drastically change codes. */
1733 /* OTF handler */
1735 #if 0
1737 #define LGSTRING_HEADER_SIZE 6
1738 #define LGSTRING_GLYPH_SIZE 8
1740 static int
1741 check_gstring (Lisp_Object gstring)
1743 Lisp_Object val;
1744 int i, j;
1746 CHECK_VECTOR (gstring);
1747 val = AREF (gstring, 0);
1748 CHECK_VECTOR (val);
1749 if (ASIZE (val) < LGSTRING_HEADER_SIZE)
1750 goto err;
1751 CHECK_FONT_OBJECT (LGSTRING_FONT (gstring));
1752 if (!NILP (LGSTRING_SLOT (gstring, LGSTRING_IX_LBEARING)))
1753 CHECK_NUMBER (LGSTRING_SLOT (gstring, LGSTRING_IX_LBEARING));
1754 if (!NILP (LGSTRING_SLOT (gstring, LGSTRING_IX_RBEARING)))
1755 CHECK_NUMBER (LGSTRING_SLOT (gstring, LGSTRING_IX_RBEARING));
1756 if (!NILP (LGSTRING_SLOT (gstring, LGSTRING_IX_WIDTH)))
1757 CHECK_NATNUM (LGSTRING_SLOT (gstring, LGSTRING_IX_WIDTH));
1758 if (!NILP (LGSTRING_SLOT (gstring, LGSTRING_IX_ASCENT)))
1759 CHECK_NUMBER (LGSTRING_SLOT (gstring, LGSTRING_IX_ASCENT));
1760 if (!NILP (LGSTRING_SLOT (gstring, LGSTRING_IX_ASCENT)))
1761 CHECK_NUMBER (LGSTRING_SLOT (gstring, LGSTRING_IX_ASCENT));
1763 for (i = 0; i < LGSTRING_GLYPH_LEN (gstring); i++)
1765 val = LGSTRING_GLYPH (gstring, i);
1766 CHECK_VECTOR (val);
1767 if (ASIZE (val) < LGSTRING_GLYPH_SIZE)
1768 goto err;
1769 if (NILP (AREF (val, LGLYPH_IX_CHAR)))
1770 break;
1771 CHECK_NATNUM (AREF (val, LGLYPH_IX_FROM));
1772 CHECK_NATNUM (AREF (val, LGLYPH_IX_TO));
1773 CHECK_CHARACTER (AREF (val, LGLYPH_IX_CHAR));
1774 if (!NILP (AREF (val, LGLYPH_IX_CODE)))
1775 CHECK_NATNUM (AREF (val, LGLYPH_IX_CODE));
1776 if (!NILP (AREF (val, LGLYPH_IX_WIDTH)))
1777 CHECK_NATNUM (AREF (val, LGLYPH_IX_WIDTH));
1778 if (!NILP (AREF (val, LGLYPH_IX_ADJUSTMENT)))
1780 val = AREF (val, LGLYPH_IX_ADJUSTMENT);
1781 CHECK_VECTOR (val);
1782 if (ASIZE (val) < 3)
1783 goto err;
1784 for (j = 0; j < 3; j++)
1785 CHECK_NUMBER (AREF (val, j));
1788 return i;
1789 err:
1790 error ("Invalid glyph-string format");
1791 return -1;
1794 static void
1795 check_otf_features (Lisp_Object otf_features)
1797 Lisp_Object val;
1799 CHECK_CONS (otf_features);
1800 CHECK_SYMBOL (XCAR (otf_features));
1801 otf_features = XCDR (otf_features);
1802 CHECK_CONS (otf_features);
1803 CHECK_SYMBOL (XCAR (otf_features));
1804 otf_features = XCDR (otf_features);
1805 for (val = Fcar (otf_features); ! NILP (val); val = Fcdr (val))
1807 CHECK_SYMBOL (Fcar (val));
1808 if (SBYTES (SYMBOL_NAME (XCAR (val))) > 4)
1809 error ("Invalid OTF GSUB feature: %s",
1810 SDATA (SYMBOL_NAME (XCAR (val))));
1812 otf_features = XCDR (otf_features);
1813 for (val = Fcar (otf_features); ! NILP (val); val = Fcdr (val))
1815 CHECK_SYMBOL (Fcar (val));
1816 if (SBYTES (SYMBOL_NAME (XCAR (val))) > 4)
1817 error ("Invalid OTF GPOS feature: %s",
1818 SDATA (SYMBOL_NAME (XCAR (val))));
1822 #ifdef HAVE_LIBOTF
1823 #include <otf.h>
1825 Lisp_Object otf_list;
1827 static Lisp_Object
1828 otf_tag_symbol (OTF_Tag tag)
1830 char name[5];
1832 OTF_tag_name (tag, name);
1833 return Fintern (make_unibyte_string (name, 4), Qnil);
1836 static OTF *
1837 otf_open (Lisp_Object file)
1839 Lisp_Object val = Fassoc (file, otf_list);
1840 OTF *otf;
1842 if (! NILP (val))
1843 otf = XSAVE_VALUE (XCDR (val))->pointer;
1844 else
1846 otf = STRINGP (file) ? OTF_open (SSDATA (file)) : NULL;
1847 val = make_save_value (otf, 0);
1848 otf_list = Fcons (Fcons (file, val), otf_list);
1850 return otf;
1854 /* Return a list describing which scripts/languages FONT supports by
1855 which GSUB/GPOS features of OpenType tables. See the comment of
1856 (struct font_driver).otf_capability. */
1858 Lisp_Object
1859 font_otf_capability (struct font *font)
1861 OTF *otf;
1862 Lisp_Object capability = Fcons (Qnil, Qnil);
1863 int i;
1865 otf = otf_open (font->props[FONT_FILE_INDEX]);
1866 if (! otf)
1867 return Qnil;
1868 for (i = 0; i < 2; i++)
1870 OTF_GSUB_GPOS *gsub_gpos;
1871 Lisp_Object script_list = Qnil;
1872 int j;
1874 if (OTF_get_features (otf, i == 0) < 0)
1875 continue;
1876 gsub_gpos = i == 0 ? otf->gsub : otf->gpos;
1877 for (j = gsub_gpos->ScriptList.ScriptCount - 1; j >= 0; j--)
1879 OTF_Script *script = gsub_gpos->ScriptList.Script + j;
1880 Lisp_Object langsys_list = Qnil;
1881 Lisp_Object script_tag = otf_tag_symbol (script->ScriptTag);
1882 int k;
1884 for (k = script->LangSysCount; k >= 0; k--)
1886 OTF_LangSys *langsys;
1887 Lisp_Object feature_list = Qnil;
1888 Lisp_Object langsys_tag;
1889 int l;
1891 if (k == script->LangSysCount)
1893 langsys = &script->DefaultLangSys;
1894 langsys_tag = Qnil;
1896 else
1898 langsys = script->LangSys + k;
1899 langsys_tag
1900 = otf_tag_symbol (script->LangSysRecord[k].LangSysTag);
1902 for (l = langsys->FeatureCount - 1; l >= 0; l--)
1904 OTF_Feature *feature
1905 = gsub_gpos->FeatureList.Feature + langsys->FeatureIndex[l];
1906 Lisp_Object feature_tag
1907 = otf_tag_symbol (feature->FeatureTag);
1909 feature_list = Fcons (feature_tag, feature_list);
1911 langsys_list = Fcons (Fcons (langsys_tag, feature_list),
1912 langsys_list);
1914 script_list = Fcons (Fcons (script_tag, langsys_list),
1915 script_list);
1918 if (i == 0)
1919 XSETCAR (capability, script_list);
1920 else
1921 XSETCDR (capability, script_list);
1924 return capability;
1927 /* Parse OTF features in SPEC and write a proper features spec string
1928 in FEATURES for the call of OTF_drive_gsub/gpos (of libotf). It is
1929 assured that the sufficient memory has already allocated for
1930 FEATURES. */
1932 static void
1933 generate_otf_features (Lisp_Object spec, char *features)
1935 Lisp_Object val;
1936 char *p;
1937 int asterisk;
1939 p = features;
1940 *p = '\0';
1941 for (asterisk = 0; CONSP (spec); spec = XCDR (spec))
1943 val = XCAR (spec);
1944 CHECK_SYMBOL (val);
1945 if (p > features)
1946 *p++ = ',';
1947 if (SREF (SYMBOL_NAME (val), 0) == '*')
1949 asterisk = 1;
1950 *p++ = '*';
1952 else if (! asterisk)
1954 val = SYMBOL_NAME (val);
1955 p += sprintf (p, "%s", SDATA (val));
1957 else
1959 val = SYMBOL_NAME (val);
1960 p += sprintf (p, "~%s", SDATA (val));
1963 if (CONSP (spec))
1964 error ("OTF spec too long");
1967 Lisp_Object
1968 font_otf_DeviceTable (OTF_DeviceTable *device_table)
1970 int len = device_table->StartSize - device_table->EndSize + 1;
1972 return Fcons (make_number (len),
1973 make_unibyte_string (device_table->DeltaValue, len));
1976 Lisp_Object
1977 font_otf_ValueRecord (int value_format, OTF_ValueRecord *value_record)
1979 Lisp_Object val = Fmake_vector (make_number (8), Qnil);
1981 if (value_format & OTF_XPlacement)
1982 ASET (val, 0, make_number (value_record->XPlacement));
1983 if (value_format & OTF_YPlacement)
1984 ASET (val, 1, make_number (value_record->YPlacement));
1985 if (value_format & OTF_XAdvance)
1986 ASET (val, 2, make_number (value_record->XAdvance));
1987 if (value_format & OTF_YAdvance)
1988 ASET (val, 3, make_number (value_record->YAdvance));
1989 if (value_format & OTF_XPlaDevice)
1990 ASET (val, 4, font_otf_DeviceTable (&value_record->XPlaDevice));
1991 if (value_format & OTF_YPlaDevice)
1992 ASET (val, 4, font_otf_DeviceTable (&value_record->YPlaDevice));
1993 if (value_format & OTF_XAdvDevice)
1994 ASET (val, 4, font_otf_DeviceTable (&value_record->XAdvDevice));
1995 if (value_format & OTF_YAdvDevice)
1996 ASET (val, 4, font_otf_DeviceTable (&value_record->YAdvDevice));
1997 return val;
2000 Lisp_Object
2001 font_otf_Anchor (OTF_Anchor *anchor)
2003 Lisp_Object val;
2005 val = Fmake_vector (make_number (anchor->AnchorFormat + 1), Qnil);
2006 ASET (val, 0, make_number (anchor->XCoordinate));
2007 ASET (val, 1, make_number (anchor->YCoordinate));
2008 if (anchor->AnchorFormat == 2)
2009 ASET (val, 2, make_number (anchor->f.f1.AnchorPoint));
2010 else
2012 ASET (val, 3, font_otf_DeviceTable (&anchor->f.f2.XDeviceTable));
2013 ASET (val, 4, font_otf_DeviceTable (&anchor->f.f2.YDeviceTable));
2015 return val;
2017 #endif /* HAVE_LIBOTF */
2018 #endif /* 0 */
2021 /* Font sorting */
2023 static unsigned font_score (Lisp_Object, Lisp_Object *);
2024 static int font_compare (const void *, const void *);
2025 static Lisp_Object font_sort_entities (Lisp_Object, Lisp_Object,
2026 Lisp_Object, int);
2028 static double
2029 font_rescale_ratio (Lisp_Object font_entity)
2031 Lisp_Object tail, elt;
2032 Lisp_Object name = Qnil;
2034 for (tail = Vface_font_rescale_alist; CONSP (tail); tail = XCDR (tail))
2036 elt = XCAR (tail);
2037 if (FLOATP (XCDR (elt)))
2039 if (STRINGP (XCAR (elt)))
2041 if (NILP (name))
2042 name = Ffont_xlfd_name (font_entity, Qnil);
2043 if (fast_string_match_ignore_case (XCAR (elt), name) >= 0)
2044 return XFLOAT_DATA (XCDR (elt));
2046 else if (FONT_SPEC_P (XCAR (elt)))
2048 if (font_match_p (XCAR (elt), font_entity))
2049 return XFLOAT_DATA (XCDR (elt));
2053 return 1.0;
2056 /* We sort fonts by scoring each of them against a specified
2057 font-spec. The score value is 32 bit (`unsigned'), and the smaller
2058 the value is, the closer the font is to the font-spec.
2060 The lowest 2 bits of the score are used for driver type. The font
2061 available by the most preferred font driver is 0.
2063 The 4 7-bit fields in the higher 28 bits are used for numeric properties
2064 WEIGHT, SLANT, WIDTH, and SIZE. */
2066 /* How many bits to shift to store the difference value of each font
2067 property in a score. Note that floats for FONT_TYPE_INDEX and
2068 FONT_REGISTRY_INDEX are not used. */
2069 static int sort_shift_bits[FONT_SIZE_INDEX + 1];
2071 /* Score font-entity ENTITY against properties of font-spec SPEC_PROP.
2072 The return value indicates how different ENTITY is compared with
2073 SPEC_PROP. */
2075 static unsigned
2076 font_score (Lisp_Object entity, Lisp_Object *spec_prop)
2078 unsigned score = 0;
2079 int i;
2081 /* Score three style numeric fields. Maximum difference is 127. */
2082 for (i = FONT_WEIGHT_INDEX; i <= FONT_WIDTH_INDEX; i++)
2083 if (! NILP (spec_prop[i]) && ! EQ (AREF (entity, i), spec_prop[i]))
2085 EMACS_INT diff = ((XINT (AREF (entity, i)) >> 8)
2086 - (XINT (spec_prop[i]) >> 8));
2087 if (diff < 0)
2088 diff = - diff;
2089 score |= min (diff, 127) << sort_shift_bits[i];
2092 /* Score the size. Maximum difference is 127. */
2093 i = FONT_SIZE_INDEX;
2094 if (! NILP (spec_prop[FONT_SIZE_INDEX])
2095 && XINT (AREF (entity, FONT_SIZE_INDEX)) > 0)
2097 /* We use the higher 6-bit for the actual size difference. The
2098 lowest bit is set if the DPI is different. */
2099 EMACS_INT diff;
2100 EMACS_INT pixel_size = XINT (spec_prop[FONT_SIZE_INDEX]);
2102 if (CONSP (Vface_font_rescale_alist))
2103 pixel_size *= font_rescale_ratio (entity);
2104 diff = pixel_size - XINT (AREF (entity, FONT_SIZE_INDEX));
2105 if (diff < 0)
2106 diff = - diff;
2107 diff <<= 1;
2108 if (! NILP (spec_prop[FONT_DPI_INDEX])
2109 && ! EQ (spec_prop[FONT_DPI_INDEX], AREF (entity, FONT_DPI_INDEX)))
2110 diff |= 1;
2111 if (! NILP (spec_prop[FONT_AVGWIDTH_INDEX])
2112 && ! EQ (spec_prop[FONT_AVGWIDTH_INDEX], AREF (entity, FONT_AVGWIDTH_INDEX)))
2113 diff |= 1;
2114 score |= min (diff, 127) << sort_shift_bits[FONT_SIZE_INDEX];
2117 return score;
2121 /* Concatenate all elements of LIST into one vector. LIST is a list
2122 of font-entity vectors. */
2124 static Lisp_Object
2125 font_vconcat_entity_vectors (Lisp_Object list)
2127 int nargs = XINT (Flength (list));
2128 Lisp_Object *args = alloca (sizeof (Lisp_Object) * nargs);
2129 int i;
2131 for (i = 0; i < nargs; i++, list = XCDR (list))
2132 args[i] = XCAR (list);
2133 return Fvconcat (nargs, args);
2137 /* The structure for elements being sorted by qsort. */
2138 struct font_sort_data
2140 unsigned score;
2141 int font_driver_preference;
2142 Lisp_Object entity;
2146 /* The comparison function for qsort. */
2148 static int
2149 font_compare (const void *d1, const void *d2)
2151 const struct font_sort_data *data1 = d1;
2152 const struct font_sort_data *data2 = d2;
2154 if (data1->score < data2->score)
2155 return -1;
2156 else if (data1->score > data2->score)
2157 return 1;
2158 return (data1->font_driver_preference - data2->font_driver_preference);
2162 /* Sort each font-entity vector in LIST by closeness to font-spec PREFER.
2163 If PREFER specifies a point-size, calculate the corresponding
2164 pixel-size from QCdpi property of PREFER or from the Y-resolution
2165 of FRAME before sorting.
2167 If BEST-ONLY is nonzero, return the best matching entity (that
2168 supports the character BEST-ONLY if BEST-ONLY is positive, or any
2169 if BEST-ONLY is negative). Otherwise, return the sorted result as
2170 a single vector of font-entities.
2172 This function does no optimization for the case that the total
2173 number of elements is 1. The caller should avoid calling this in
2174 such a case. */
2176 static Lisp_Object
2177 font_sort_entities (Lisp_Object list, Lisp_Object prefer, Lisp_Object frame, int best_only)
2179 Lisp_Object prefer_prop[FONT_SPEC_MAX];
2180 int len, maxlen, i;
2181 struct font_sort_data *data;
2182 unsigned best_score;
2183 Lisp_Object best_entity;
2184 struct frame *f = XFRAME (frame);
2185 Lisp_Object tail, vec IF_LINT (= Qnil);
2186 USE_SAFE_ALLOCA;
2188 for (i = FONT_WEIGHT_INDEX; i <= FONT_AVGWIDTH_INDEX; i++)
2189 prefer_prop[i] = AREF (prefer, i);
2190 if (FLOATP (prefer_prop[FONT_SIZE_INDEX]))
2191 prefer_prop[FONT_SIZE_INDEX]
2192 = make_number (font_pixel_size (XFRAME (frame), prefer));
2194 if (NILP (XCDR (list)))
2196 /* What we have to take care of is this single vector. */
2197 vec = XCAR (list);
2198 maxlen = ASIZE (vec);
2200 else if (best_only)
2202 /* We don't have to perform sort, so there's no need of creating
2203 a single vector. But, we must find the length of the longest
2204 vector. */
2205 maxlen = 0;
2206 for (tail = list; CONSP (tail); tail = XCDR (tail))
2207 if (maxlen < ASIZE (XCAR (tail)))
2208 maxlen = ASIZE (XCAR (tail));
2210 else
2212 /* We have to create a single vector to sort it. */
2213 vec = font_vconcat_entity_vectors (list);
2214 maxlen = ASIZE (vec);
2217 SAFE_ALLOCA (data, struct font_sort_data *, (sizeof *data) * maxlen);
2218 best_score = 0xFFFFFFFF;
2219 best_entity = Qnil;
2221 for (tail = list; CONSP (tail); tail = XCDR (tail))
2223 int font_driver_preference = 0;
2224 Lisp_Object current_font_driver;
2226 if (best_only)
2227 vec = XCAR (tail);
2228 len = ASIZE (vec);
2230 /* We are sure that the length of VEC > 0. */
2231 current_font_driver = AREF (AREF (vec, 0), FONT_TYPE_INDEX);
2232 /* Score the elements. */
2233 for (i = 0; i < len; i++)
2235 data[i].entity = AREF (vec, i);
2236 data[i].score
2237 = ((best_only <= 0 || font_has_char (f, data[i].entity, best_only)
2238 > 0)
2239 ? font_score (data[i].entity, prefer_prop)
2240 : 0xFFFFFFFF);
2241 if (best_only && best_score > data[i].score)
2243 best_score = data[i].score;
2244 best_entity = data[i].entity;
2245 if (best_score == 0)
2246 break;
2248 if (! EQ (current_font_driver, AREF (AREF (vec, i), FONT_TYPE_INDEX)))
2250 current_font_driver = AREF (AREF (vec, i), FONT_TYPE_INDEX);
2251 font_driver_preference++;
2253 data[i].font_driver_preference = font_driver_preference;
2256 /* Sort if necessary. */
2257 if (! best_only)
2259 qsort (data, len, sizeof *data, font_compare);
2260 for (i = 0; i < len; i++)
2261 ASET (vec, i, data[i].entity);
2262 break;
2264 else
2265 vec = best_entity;
2268 SAFE_FREE ();
2270 FONT_ADD_LOG ("sort-by", prefer, vec);
2271 return vec;
2275 /* API of Font Service Layer. */
2277 /* Reflect ORDER (see the variable font_sort_order in xfaces.c) to
2278 sort_shift_bits. Finternal_set_font_selection_order calls this
2279 function with font_sort_order after setting up it. */
2281 void
2282 font_update_sort_order (int *order)
2284 int i, shift_bits;
2286 for (i = 0, shift_bits = 23; i < 4; i++, shift_bits -= 7)
2288 int xlfd_idx = order[i];
2290 if (xlfd_idx == XLFD_WEIGHT_INDEX)
2291 sort_shift_bits[FONT_WEIGHT_INDEX] = shift_bits;
2292 else if (xlfd_idx == XLFD_SLANT_INDEX)
2293 sort_shift_bits[FONT_SLANT_INDEX] = shift_bits;
2294 else if (xlfd_idx == XLFD_SWIDTH_INDEX)
2295 sort_shift_bits[FONT_WIDTH_INDEX] = shift_bits;
2296 else
2297 sort_shift_bits[FONT_SIZE_INDEX] = shift_bits;
2301 static int
2302 font_check_otf_features (Lisp_Object script, Lisp_Object langsys, Lisp_Object features, Lisp_Object table)
2304 Lisp_Object val;
2305 int negative;
2307 table = assq_no_quit (script, table);
2308 if (NILP (table))
2309 return 0;
2310 table = XCDR (table);
2311 if (! NILP (langsys))
2313 table = assq_no_quit (langsys, table);
2314 if (NILP (table))
2315 return 0;
2317 else
2319 val = assq_no_quit (Qnil, table);
2320 if (NILP (val))
2321 table = XCAR (table);
2322 else
2323 table = val;
2325 table = XCDR (table);
2326 for (negative = 0; CONSP (features); features = XCDR (features))
2328 if (NILP (XCAR (features)))
2330 negative = 1;
2331 continue;
2333 if (NILP (Fmemq (XCAR (features), table)) != negative)
2334 return 0;
2336 return 1;
2339 /* Check if OTF_CAPABILITY satisfies SPEC (otf-spec). */
2341 static int
2342 font_check_otf (Lisp_Object spec, Lisp_Object otf_capability)
2344 Lisp_Object script, langsys = Qnil, gsub = Qnil, gpos = Qnil;
2346 script = XCAR (spec);
2347 spec = XCDR (spec);
2348 if (! NILP (spec))
2350 langsys = XCAR (spec);
2351 spec = XCDR (spec);
2352 if (! NILP (spec))
2354 gsub = XCAR (spec);
2355 spec = XCDR (spec);
2356 if (! NILP (spec))
2357 gpos = XCAR (spec);
2361 if (! NILP (gsub) && ! font_check_otf_features (script, langsys, gsub,
2362 XCAR (otf_capability)))
2363 return 0;
2364 if (! NILP (gpos) && ! font_check_otf_features (script, langsys, gpos,
2365 XCDR (otf_capability)))
2366 return 0;
2367 return 1;
2372 /* Check if FONT (font-entity or font-object) matches with the font
2373 specification SPEC. */
2376 font_match_p (Lisp_Object spec, Lisp_Object font)
2378 Lisp_Object prop[FONT_SPEC_MAX], *props;
2379 Lisp_Object extra, font_extra;
2380 int i;
2382 for (i = FONT_FOUNDRY_INDEX; i <= FONT_REGISTRY_INDEX; i++)
2383 if (! NILP (AREF (spec, i))
2384 && ! NILP (AREF (font, i))
2385 && ! EQ (AREF (spec, i), AREF (font, i)))
2386 return 0;
2387 props = XFONT_SPEC (spec)->props;
2388 if (FLOATP (props[FONT_SIZE_INDEX]))
2390 for (i = FONT_FOUNDRY_INDEX; i < FONT_SIZE_INDEX; i++)
2391 prop[i] = AREF (spec, i);
2392 prop[FONT_SIZE_INDEX]
2393 = make_number (font_pixel_size (XFRAME (selected_frame), spec));
2394 props = prop;
2397 if (font_score (font, props) > 0)
2398 return 0;
2399 extra = AREF (spec, FONT_EXTRA_INDEX);
2400 font_extra = AREF (font, FONT_EXTRA_INDEX);
2401 for (; CONSP (extra); extra = XCDR (extra))
2403 Lisp_Object key = XCAR (XCAR (extra));
2404 Lisp_Object val = XCDR (XCAR (extra)), val2;
2406 if (EQ (key, QClang))
2408 val2 = assq_no_quit (key, font_extra);
2409 if (NILP (val2))
2410 return 0;
2411 val2 = XCDR (val2);
2412 if (CONSP (val))
2414 if (! CONSP (val2))
2415 return 0;
2416 while (CONSP (val))
2417 if (NILP (Fmemq (val, val2)))
2418 return 0;
2420 else
2421 if (CONSP (val2)
2422 ? NILP (Fmemq (val, XCDR (val2)))
2423 : ! EQ (val, val2))
2424 return 0;
2426 else if (EQ (key, QCscript))
2428 val2 = assq_no_quit (val, Vscript_representative_chars);
2429 if (CONSP (val2))
2431 val2 = XCDR (val2);
2432 if (CONSP (val2))
2434 /* All characters in the list must be supported. */
2435 for (; CONSP (val2); val2 = XCDR (val2))
2437 if (! NATNUMP (XCAR (val2)))
2438 continue;
2439 if (font_encode_char (font, XFASTINT (XCAR (val2)))
2440 == FONT_INVALID_CODE)
2441 return 0;
2444 else if (VECTORP (val2))
2446 /* At most one character in the vector must be supported. */
2447 for (i = 0; i < ASIZE (val2); i++)
2449 if (! NATNUMP (AREF (val2, i)))
2450 continue;
2451 if (font_encode_char (font, XFASTINT (AREF (val2, i)))
2452 != FONT_INVALID_CODE)
2453 break;
2455 if (i == ASIZE (val2))
2456 return 0;
2460 else if (EQ (key, QCotf))
2462 struct font *fontp;
2464 if (! FONT_OBJECT_P (font))
2465 return 0;
2466 fontp = XFONT_OBJECT (font);
2467 if (! fontp->driver->otf_capability)
2468 return 0;
2469 val2 = fontp->driver->otf_capability (fontp);
2470 if (NILP (val2) || ! font_check_otf (val, val2))
2471 return 0;
2475 return 1;
2479 /* Font cache
2481 Each font backend has the callback function get_cache, and it
2482 returns a cons cell of which cdr part can be freely used for
2483 caching fonts. The cons cell may be shared by multiple frames
2484 and/or multiple font drivers. So, we arrange the cdr part as this:
2486 ((DRIVER-TYPE NUM-FRAMES FONT-CACHE-DATA ...) ...)
2488 where DRIVER-TYPE is a symbol such as `x', `xft', etc., NUM-FRAMES
2489 is a number frames sharing this cache, and FONT-CACHE-DATA is a
2490 cons (FONT-SPEC FONT-ENTITY ...). */
2492 static void font_prepare_cache (FRAME_PTR, struct font_driver *);
2493 static void font_finish_cache (FRAME_PTR, struct font_driver *);
2494 static Lisp_Object font_get_cache (FRAME_PTR, struct font_driver *);
2495 static void font_clear_cache (FRAME_PTR, Lisp_Object,
2496 struct font_driver *);
2498 static void
2499 font_prepare_cache (FRAME_PTR f, struct font_driver *driver)
2501 Lisp_Object cache, val;
2503 cache = driver->get_cache (f);
2504 val = XCDR (cache);
2505 while (CONSP (val) && ! EQ (XCAR (XCAR (val)), driver->type))
2506 val = XCDR (val);
2507 if (NILP (val))
2509 val = Fcons (driver->type, Fcons (make_number (1), Qnil));
2510 XSETCDR (cache, Fcons (val, XCDR (cache)));
2512 else
2514 val = XCDR (XCAR (val));
2515 XSETCAR (val, make_number (XINT (XCAR (val)) + 1));
2520 static void
2521 font_finish_cache (FRAME_PTR f, struct font_driver *driver)
2523 Lisp_Object cache, val, tmp;
2526 cache = driver->get_cache (f);
2527 val = XCDR (cache);
2528 while (CONSP (val) && ! EQ (XCAR (XCAR (val)), driver->type))
2529 cache = val, val = XCDR (val);
2530 font_assert (! NILP (val));
2531 tmp = XCDR (XCAR (val));
2532 XSETCAR (tmp, make_number (XINT (XCAR (tmp)) - 1));
2533 if (XINT (XCAR (tmp)) == 0)
2535 font_clear_cache (f, XCAR (val), driver);
2536 XSETCDR (cache, XCDR (val));
2541 static Lisp_Object
2542 font_get_cache (FRAME_PTR f, struct font_driver *driver)
2544 Lisp_Object val = driver->get_cache (f);
2545 Lisp_Object type = driver->type;
2547 font_assert (CONSP (val));
2548 for (val = XCDR (val); ! EQ (XCAR (XCAR (val)), type); val = XCDR (val));
2549 font_assert (CONSP (val));
2550 /* VAL = ((DRIVER-TYPE NUM-FRAMES FONT-CACHE-DATA ...) ...) */
2551 val = XCDR (XCAR (val));
2552 return val;
2555 static int num_fonts;
2557 static void
2558 font_clear_cache (FRAME_PTR f, Lisp_Object cache, struct font_driver *driver)
2560 Lisp_Object tail, elt;
2561 Lisp_Object tail2, entity;
2563 /* CACHE = (DRIVER-TYPE NUM-FRAMES FONT-CACHE-DATA ...) */
2564 for (tail = XCDR (XCDR (cache)); CONSP (tail); tail = XCDR (tail))
2566 elt = XCAR (tail);
2567 /* elt should have the form (FONT-SPEC FONT-ENTITY ...) */
2568 if (CONSP (elt) && FONT_SPEC_P (XCAR (elt)))
2570 for (tail2 = XCDR (elt); CONSP (tail2); tail2 = XCDR (tail2))
2572 entity = XCAR (tail2);
2574 if (FONT_ENTITY_P (entity)
2575 && EQ (driver->type, AREF (entity, FONT_TYPE_INDEX)))
2577 Lisp_Object objlist = AREF (entity, FONT_OBJLIST_INDEX);
2579 for (; CONSP (objlist); objlist = XCDR (objlist))
2581 Lisp_Object val = XCAR (objlist);
2582 struct font *font = XFONT_OBJECT (val);
2584 if (! NILP (AREF (val, FONT_TYPE_INDEX)))
2586 font_assert (font && driver == font->driver);
2587 driver->close (f, font);
2588 num_fonts--;
2591 if (driver->free_entity)
2592 driver->free_entity (entity);
2597 XSETCDR (cache, Qnil);
2601 static Lisp_Object scratch_font_spec, scratch_font_prefer;
2603 /* Check each font-entity in VEC, and return a list of font-entities
2604 that satisfy these conditions:
2605 (1) matches with SPEC and SIZE if SPEC is not nil, and
2606 (2) doesn't match with any regexps in Vface_ignored_fonts (if non-nil).
2609 static Lisp_Object
2610 font_delete_unmatched (Lisp_Object vec, Lisp_Object spec, int size)
2612 Lisp_Object entity, val;
2613 enum font_property_index prop;
2614 int i;
2616 for (val = Qnil, i = ASIZE (vec) - 1; i >= 0; i--)
2618 entity = AREF (vec, i);
2619 if (! NILP (Vface_ignored_fonts))
2621 char name[256];
2622 Lisp_Object tail, regexp;
2624 if (font_unparse_xlfd (entity, 0, name, 256) >= 0)
2626 for (tail = Vface_ignored_fonts; CONSP (tail); tail = XCDR (tail))
2628 regexp = XCAR (tail);
2629 if (STRINGP (regexp)
2630 && fast_c_string_match_ignore_case (regexp, name) >= 0)
2631 break;
2633 if (CONSP (tail))
2634 continue;
2637 if (NILP (spec))
2639 val = Fcons (entity, val);
2640 continue;
2642 for (prop = FONT_WEIGHT_INDEX; prop < FONT_SIZE_INDEX; prop++)
2643 if (INTEGERP (AREF (spec, prop))
2644 && ((XINT (AREF (spec, prop)) >> 8)
2645 != (XINT (AREF (entity, prop)) >> 8)))
2646 prop = FONT_SPEC_MAX;
2647 if (prop < FONT_SPEC_MAX
2648 && size
2649 && XINT (AREF (entity, FONT_SIZE_INDEX)) > 0)
2651 int diff = XINT (AREF (entity, FONT_SIZE_INDEX)) - size;
2653 if (diff != 0
2654 && (diff < 0 ? -diff > FONT_PIXEL_SIZE_QUANTUM
2655 : diff > FONT_PIXEL_SIZE_QUANTUM))
2656 prop = FONT_SPEC_MAX;
2658 if (prop < FONT_SPEC_MAX
2659 && INTEGERP (AREF (spec, FONT_DPI_INDEX))
2660 && INTEGERP (AREF (entity, FONT_DPI_INDEX))
2661 && XINT (AREF (entity, FONT_DPI_INDEX)) != 0
2662 && ! EQ (AREF (spec, FONT_DPI_INDEX), AREF (entity, FONT_DPI_INDEX)))
2663 prop = FONT_SPEC_MAX;
2664 if (prop < FONT_SPEC_MAX
2665 && INTEGERP (AREF (spec, FONT_AVGWIDTH_INDEX))
2666 && INTEGERP (AREF (entity, FONT_AVGWIDTH_INDEX))
2667 && XINT (AREF (entity, FONT_AVGWIDTH_INDEX)) != 0
2668 && ! EQ (AREF (spec, FONT_AVGWIDTH_INDEX),
2669 AREF (entity, FONT_AVGWIDTH_INDEX)))
2670 prop = FONT_SPEC_MAX;
2671 if (prop < FONT_SPEC_MAX)
2672 val = Fcons (entity, val);
2674 return (Fvconcat (1, &val));
2678 /* Return a list of vectors of font-entities matching with SPEC on
2679 FRAME. Each elements in the list is a vector of entities from the
2680 same font-driver. */
2682 Lisp_Object
2683 font_list_entities (Lisp_Object frame, Lisp_Object spec)
2685 FRAME_PTR f = XFRAME (frame);
2686 struct font_driver_list *driver_list = f->font_driver_list;
2687 Lisp_Object ftype, val;
2688 Lisp_Object list = Qnil;
2689 int size;
2690 int need_filtering = 0;
2691 int i;
2693 font_assert (FONT_SPEC_P (spec));
2695 if (INTEGERP (AREF (spec, FONT_SIZE_INDEX)))
2696 size = XINT (AREF (spec, FONT_SIZE_INDEX));
2697 else if (FLOATP (AREF (spec, FONT_SIZE_INDEX)))
2698 size = font_pixel_size (f, spec);
2699 else
2700 size = 0;
2702 ftype = AREF (spec, FONT_TYPE_INDEX);
2703 for (i = FONT_FOUNDRY_INDEX; i <= FONT_REGISTRY_INDEX; i++)
2704 ASET (scratch_font_spec, i, AREF (spec, i));
2705 for (i = FONT_WEIGHT_INDEX; i < FONT_EXTRA_INDEX; i++)
2706 if (i != FONT_SPACING_INDEX)
2708 ASET (scratch_font_spec, i, Qnil);
2709 if (! NILP (AREF (spec, i)))
2710 need_filtering = 1;
2712 ASET (scratch_font_spec, FONT_SPACING_INDEX, AREF (spec, FONT_SPACING_INDEX));
2713 ASET (scratch_font_spec, FONT_EXTRA_INDEX, AREF (spec, FONT_EXTRA_INDEX));
2715 for (i = 0; driver_list; driver_list = driver_list->next)
2716 if (driver_list->on
2717 && (NILP (ftype) || EQ (driver_list->driver->type, ftype)))
2719 Lisp_Object cache = font_get_cache (f, driver_list->driver);
2721 ASET (scratch_font_spec, FONT_TYPE_INDEX, driver_list->driver->type);
2722 val = assoc_no_quit (scratch_font_spec, XCDR (cache));
2723 if (CONSP (val))
2724 val = XCDR (val);
2725 else
2727 Lisp_Object copy;
2729 val = driver_list->driver->list (frame, scratch_font_spec);
2730 if (NILP (val))
2731 val = null_vector;
2732 else
2733 val = Fvconcat (1, &val);
2734 copy = copy_font_spec (scratch_font_spec);
2735 ASET (copy, FONT_TYPE_INDEX, driver_list->driver->type);
2736 XSETCDR (cache, Fcons (Fcons (copy, val), XCDR (cache)));
2738 if (ASIZE (val) > 0
2739 && (need_filtering
2740 || ! NILP (Vface_ignored_fonts)))
2741 val = font_delete_unmatched (val, need_filtering ? spec : Qnil, size);
2742 if (ASIZE (val) > 0)
2743 list = Fcons (val, list);
2746 list = Fnreverse (list);
2747 FONT_ADD_LOG ("list", spec, list);
2748 return list;
2752 /* Return a font entity matching with SPEC on FRAME. ATTRS, if non
2753 nil, is an array of face's attributes, which specifies preferred
2754 font-related attributes. */
2756 static Lisp_Object
2757 font_matching_entity (FRAME_PTR f, Lisp_Object *attrs, Lisp_Object spec)
2759 struct font_driver_list *driver_list = f->font_driver_list;
2760 Lisp_Object ftype, size, entity;
2761 Lisp_Object frame;
2762 Lisp_Object work = copy_font_spec (spec);
2764 XSETFRAME (frame, f);
2765 ftype = AREF (spec, FONT_TYPE_INDEX);
2766 size = AREF (spec, FONT_SIZE_INDEX);
2768 if (FLOATP (size))
2769 ASET (work, FONT_SIZE_INDEX, make_number (font_pixel_size (f, spec)));
2770 FONT_SET_STYLE (work, FONT_WEIGHT_INDEX, attrs[LFACE_WEIGHT_INDEX]);
2771 FONT_SET_STYLE (work, FONT_SLANT_INDEX, attrs[LFACE_SLANT_INDEX]);
2772 FONT_SET_STYLE (work, FONT_WIDTH_INDEX, attrs[LFACE_SWIDTH_INDEX]);
2774 entity = Qnil;
2775 for (; driver_list; driver_list = driver_list->next)
2776 if (driver_list->on
2777 && (NILP (ftype) || EQ (driver_list->driver->type, ftype)))
2779 Lisp_Object cache = font_get_cache (f, driver_list->driver);
2780 Lisp_Object copy;
2782 ASET (work, FONT_TYPE_INDEX, driver_list->driver->type);
2783 entity = assoc_no_quit (work, XCDR (cache));
2784 if (CONSP (entity))
2785 entity = XCDR (entity);
2786 else
2788 entity = driver_list->driver->match (frame, work);
2789 copy = copy_font_spec (work);
2790 ASET (copy, FONT_TYPE_INDEX, driver_list->driver->type);
2791 XSETCDR (cache, Fcons (Fcons (copy, entity), XCDR (cache)));
2793 if (! NILP (entity))
2794 break;
2796 FONT_ADD_LOG ("match", work, entity);
2797 return entity;
2801 /* Open a font of ENTITY and PIXEL_SIZE on frame F, and return the
2802 opened font object. */
2804 static Lisp_Object
2805 font_open_entity (FRAME_PTR f, Lisp_Object entity, int pixel_size)
2807 struct font_driver_list *driver_list;
2808 Lisp_Object objlist, size, val, font_object;
2809 struct font *font;
2810 int min_width, height;
2811 int scaled_pixel_size = pixel_size;
2813 font_assert (FONT_ENTITY_P (entity));
2814 size = AREF (entity, FONT_SIZE_INDEX);
2815 if (XINT (size) != 0)
2816 scaled_pixel_size = pixel_size = XINT (size);
2817 else if (CONSP (Vface_font_rescale_alist))
2818 scaled_pixel_size = pixel_size * font_rescale_ratio (entity);
2820 val = AREF (entity, FONT_TYPE_INDEX);
2821 for (driver_list = f->font_driver_list;
2822 driver_list && ! EQ (driver_list->driver->type, val);
2823 driver_list = driver_list->next);
2824 if (! driver_list)
2825 return Qnil;
2827 for (objlist = AREF (entity, FONT_OBJLIST_INDEX); CONSP (objlist);
2828 objlist = XCDR (objlist))
2830 Lisp_Object fn = XCAR (objlist);
2831 if (! NILP (AREF (fn, FONT_TYPE_INDEX))
2832 && XFONT_OBJECT (fn)->pixel_size == pixel_size)
2834 if (driver_list->driver->cached_font_ok == NULL
2835 || driver_list->driver->cached_font_ok (f, fn, entity))
2836 return fn;
2840 font_object = driver_list->driver->open (f, entity, scaled_pixel_size);
2841 if (!NILP (font_object))
2842 ASET (font_object, FONT_SIZE_INDEX, make_number (pixel_size));
2843 FONT_ADD_LOG ("open", entity, font_object);
2844 if (NILP (font_object))
2845 return Qnil;
2846 ASET (entity, FONT_OBJLIST_INDEX,
2847 Fcons (font_object, AREF (entity, FONT_OBJLIST_INDEX)));
2848 num_fonts++;
2850 font = XFONT_OBJECT (font_object);
2851 min_width = (font->min_width ? font->min_width
2852 : font->average_width ? font->average_width
2853 : font->space_width ? font->space_width
2854 : 1);
2855 height = (font->height ? font->height : 1);
2856 #ifdef HAVE_WINDOW_SYSTEM
2857 FRAME_X_DISPLAY_INFO (f)->n_fonts++;
2858 if (FRAME_X_DISPLAY_INFO (f)->n_fonts == 1)
2860 FRAME_SMALLEST_CHAR_WIDTH (f) = min_width;
2861 FRAME_SMALLEST_FONT_HEIGHT (f) = height;
2862 fonts_changed_p = 1;
2864 else
2866 if (FRAME_SMALLEST_CHAR_WIDTH (f) > min_width)
2867 FRAME_SMALLEST_CHAR_WIDTH (f) = min_width, fonts_changed_p = 1;
2868 if (FRAME_SMALLEST_FONT_HEIGHT (f) > height)
2869 FRAME_SMALLEST_FONT_HEIGHT (f) = height, fonts_changed_p = 1;
2871 #endif
2873 return font_object;
2877 /* Close FONT_OBJECT that is opened on frame F. */
2879 static void
2880 font_close_object (FRAME_PTR f, Lisp_Object font_object)
2882 struct font *font = XFONT_OBJECT (font_object);
2884 if (NILP (AREF (font_object, FONT_TYPE_INDEX)))
2885 /* Already closed. */
2886 return;
2887 FONT_ADD_LOG ("close", font_object, Qnil);
2888 font->driver->close (f, font);
2889 #ifdef HAVE_WINDOW_SYSTEM
2890 font_assert (FRAME_X_DISPLAY_INFO (f)->n_fonts);
2891 FRAME_X_DISPLAY_INFO (f)->n_fonts--;
2892 #endif
2893 num_fonts--;
2897 /* Return 1 if FONT on F has a glyph for character C, 0 if not, -1 if
2898 FONT is a font-entity and it must be opened to check. */
2901 font_has_char (FRAME_PTR f, Lisp_Object font, int c)
2903 struct font *fontp;
2905 if (FONT_ENTITY_P (font))
2907 Lisp_Object type = AREF (font, FONT_TYPE_INDEX);
2908 struct font_driver_list *driver_list;
2910 for (driver_list = f->font_driver_list;
2911 driver_list && ! EQ (driver_list->driver->type, type);
2912 driver_list = driver_list->next);
2913 if (! driver_list)
2914 return 0;
2915 if (! driver_list->driver->has_char)
2916 return -1;
2917 return driver_list->driver->has_char (font, c);
2920 font_assert (FONT_OBJECT_P (font));
2921 fontp = XFONT_OBJECT (font);
2922 if (fontp->driver->has_char)
2924 int result = fontp->driver->has_char (font, c);
2926 if (result >= 0)
2927 return result;
2929 return (fontp->driver->encode_char (fontp, c) != FONT_INVALID_CODE);
2933 /* Return the glyph ID of FONT_OBJECT for character C. */
2935 static unsigned
2936 font_encode_char (Lisp_Object font_object, int c)
2938 struct font *font;
2940 font_assert (FONT_OBJECT_P (font_object));
2941 font = XFONT_OBJECT (font_object);
2942 return font->driver->encode_char (font, c);
2946 /* Return the name of FONT_OBJECT. */
2948 Lisp_Object
2949 font_get_name (Lisp_Object font_object)
2951 font_assert (FONT_OBJECT_P (font_object));
2952 return AREF (font_object, FONT_NAME_INDEX);
2956 /* Create a new font spec from FONT_NAME, and return it. If FONT_NAME
2957 could not be parsed by font_parse_name, return Qnil. */
2959 Lisp_Object
2960 font_spec_from_name (Lisp_Object font_name)
2962 Lisp_Object spec = Ffont_spec (0, NULL);
2964 CHECK_STRING (font_name);
2965 if (font_parse_name (SSDATA (font_name), spec) == -1)
2966 return Qnil;
2967 font_put_extra (spec, QCname, font_name);
2968 font_put_extra (spec, QCuser_spec, font_name);
2969 return spec;
2973 void
2974 font_clear_prop (Lisp_Object *attrs, enum font_property_index prop)
2976 Lisp_Object font = attrs[LFACE_FONT_INDEX];
2978 if (! FONTP (font))
2979 return;
2981 if (! NILP (Ffont_get (font, QCname)))
2983 font = copy_font_spec (font);
2984 font_put_extra (font, QCname, Qnil);
2987 if (NILP (AREF (font, prop))
2988 && prop != FONT_FAMILY_INDEX
2989 && prop != FONT_FOUNDRY_INDEX
2990 && prop != FONT_WIDTH_INDEX
2991 && prop != FONT_SIZE_INDEX)
2992 return;
2993 if (EQ (font, attrs[LFACE_FONT_INDEX]))
2994 font = copy_font_spec (font);
2995 ASET (font, prop, Qnil);
2996 if (prop == FONT_FAMILY_INDEX || prop == FONT_FOUNDRY_INDEX)
2998 if (prop == FONT_FAMILY_INDEX)
3000 ASET (font, FONT_FOUNDRY_INDEX, Qnil);
3001 /* If we are setting the font family, we must also clear
3002 FONT_WIDTH_INDEX to avoid rejecting families that lack
3003 support for some widths. */
3004 ASET (font, FONT_WIDTH_INDEX, Qnil);
3006 ASET (font, FONT_ADSTYLE_INDEX, Qnil);
3007 ASET (font, FONT_REGISTRY_INDEX, Qnil);
3008 ASET (font, FONT_SIZE_INDEX, Qnil);
3009 ASET (font, FONT_DPI_INDEX, Qnil);
3010 ASET (font, FONT_SPACING_INDEX, Qnil);
3011 ASET (font, FONT_AVGWIDTH_INDEX, Qnil);
3013 else if (prop == FONT_SIZE_INDEX)
3015 ASET (font, FONT_DPI_INDEX, Qnil);
3016 ASET (font, FONT_SPACING_INDEX, Qnil);
3017 ASET (font, FONT_AVGWIDTH_INDEX, Qnil);
3019 else if (prop == FONT_WIDTH_INDEX)
3020 ASET (font, FONT_AVGWIDTH_INDEX, Qnil);
3021 attrs[LFACE_FONT_INDEX] = font;
3024 /* Select a font from ENTITIES (list of font-entity vectors) that
3025 supports C and is the best match for ATTRS and PIXEL_SIZE. */
3027 static Lisp_Object
3028 font_select_entity (Lisp_Object frame, Lisp_Object entities, Lisp_Object *attrs, int pixel_size, int c)
3030 Lisp_Object font_entity;
3031 Lisp_Object prefer;
3032 int result, i;
3033 FRAME_PTR f = XFRAME (frame);
3035 if (NILP (XCDR (entities))
3036 && ASIZE (XCAR (entities)) == 1)
3038 font_entity = AREF (XCAR (entities), 0);
3039 if (c < 0
3040 || (result = font_has_char (f, font_entity, c)) > 0)
3041 return font_entity;
3042 return Qnil;
3045 /* Sort fonts by properties specified in ATTRS. */
3046 prefer = scratch_font_prefer;
3048 for (i = FONT_WEIGHT_INDEX; i <= FONT_SIZE_INDEX; i++)
3049 ASET (prefer, i, Qnil);
3050 if (FONTP (attrs[LFACE_FONT_INDEX]))
3052 Lisp_Object face_font = attrs[LFACE_FONT_INDEX];
3054 for (i = FONT_WEIGHT_INDEX; i <= FONT_SIZE_INDEX; i++)
3055 ASET (prefer, i, AREF (face_font, i));
3057 if (NILP (AREF (prefer, FONT_WEIGHT_INDEX)))
3058 FONT_SET_STYLE (prefer, FONT_WEIGHT_INDEX, attrs[LFACE_WEIGHT_INDEX]);
3059 if (NILP (AREF (prefer, FONT_SLANT_INDEX)))
3060 FONT_SET_STYLE (prefer, FONT_SLANT_INDEX, attrs[LFACE_SLANT_INDEX]);
3061 if (NILP (AREF (prefer, FONT_WIDTH_INDEX)))
3062 FONT_SET_STYLE (prefer, FONT_WIDTH_INDEX, attrs[LFACE_SWIDTH_INDEX]);
3063 ASET (prefer, FONT_SIZE_INDEX, make_number (pixel_size));
3065 return font_sort_entities (entities, prefer, frame, c);
3068 /* Return a font-entity that satisfies SPEC and is the best match for
3069 face's font related attributes in ATTRS. C, if not negative, is a
3070 character that the entity must support. */
3072 Lisp_Object
3073 font_find_for_lface (FRAME_PTR f, Lisp_Object *attrs, Lisp_Object spec, int c)
3075 Lisp_Object work;
3076 Lisp_Object frame, entities, val;
3077 Lisp_Object foundry[3], *family, registry[3], adstyle[3];
3078 int pixel_size;
3079 int i, j, k, l;
3081 registry[0] = AREF (spec, FONT_REGISTRY_INDEX);
3082 if (NILP (registry[0]))
3084 registry[0] = DEFAULT_ENCODING;
3085 registry[1] = Qascii_0;
3086 registry[2] = null_vector;
3088 else
3089 registry[1] = null_vector;
3091 if (c >= 0 && ! NILP (AREF (spec, FONT_REGISTRY_INDEX)))
3093 struct charset *encoding, *repertory;
3095 if (font_registry_charsets (AREF (spec, FONT_REGISTRY_INDEX),
3096 &encoding, &repertory) < 0)
3097 return Qnil;
3098 if (repertory
3099 && ENCODE_CHAR (repertory, c) == CHARSET_INVALID_CODE (repertory))
3100 return Qnil;
3101 else if (c > encoding->max_char)
3102 return Qnil;
3105 work = copy_font_spec (spec);
3106 ASET (work, FONT_TYPE_INDEX, AREF (spec, FONT_TYPE_INDEX));
3107 XSETFRAME (frame, f);
3108 pixel_size = font_pixel_size (f, spec);
3109 if (pixel_size == 0 && INTEGERP (attrs[LFACE_HEIGHT_INDEX]))
3111 double pt = XINT (attrs[LFACE_HEIGHT_INDEX]);
3113 pixel_size = POINT_TO_PIXEL (pt / 10, f->resy);
3115 ASET (work, FONT_SIZE_INDEX, Qnil);
3116 foundry[0] = AREF (work, FONT_FOUNDRY_INDEX);
3117 if (! NILP (foundry[0]))
3118 foundry[1] = null_vector;
3119 else if (STRINGP (attrs[LFACE_FOUNDRY_INDEX]))
3121 val = attrs[LFACE_FOUNDRY_INDEX];
3122 foundry[0] = font_intern_prop (SSDATA (val), SBYTES (val), 1);
3123 foundry[1] = Qnil;
3124 foundry[2] = null_vector;
3126 else
3127 foundry[0] = Qnil, foundry[1] = null_vector;
3129 adstyle[0] = AREF (work, FONT_ADSTYLE_INDEX);
3130 if (! NILP (adstyle[0]))
3131 adstyle[1] = null_vector;
3132 else if (FONTP (attrs[LFACE_FONT_INDEX]))
3134 Lisp_Object face_font = attrs[LFACE_FONT_INDEX];
3136 if (! NILP (AREF (face_font, FONT_ADSTYLE_INDEX)))
3138 adstyle[0] = AREF (face_font, FONT_ADSTYLE_INDEX);
3139 adstyle[1] = Qnil;
3140 adstyle[2] = null_vector;
3142 else
3143 adstyle[0] = Qnil, adstyle[1] = null_vector;
3145 else
3146 adstyle[0] = Qnil, adstyle[1] = null_vector;
3149 val = AREF (work, FONT_FAMILY_INDEX);
3150 if (NILP (val) && STRINGP (attrs[LFACE_FAMILY_INDEX]))
3152 val = attrs[LFACE_FAMILY_INDEX];
3153 val = font_intern_prop (SSDATA (val), SBYTES (val), 1);
3155 if (NILP (val))
3157 family = alloca ((sizeof family[0]) * 2);
3158 family[0] = Qnil;
3159 family[1] = null_vector; /* terminator. */
3161 else
3163 Lisp_Object alters
3164 = Fassoc_string (val, Vface_alternative_font_family_alist,
3165 /* Font family names are case-sensitive under NS. */
3166 #ifndef HAVE_NS
3168 #else
3169 Qnil
3170 #endif
3173 if (! NILP (alters))
3175 family = alloca ((sizeof family[0]) * (XINT (Flength (alters)) + 2));
3176 for (i = 0; CONSP (alters); i++, alters = XCDR (alters))
3177 family[i] = XCAR (alters);
3178 if (NILP (AREF (spec, FONT_FAMILY_INDEX)))
3179 family[i++] = Qnil;
3180 family[i] = null_vector;
3182 else
3184 family = alloca ((sizeof family[0]) * 3);
3185 i = 0;
3186 family[i++] = val;
3187 if (NILP (AREF (spec, FONT_FAMILY_INDEX)))
3188 family[i++] = Qnil;
3189 family[i] = null_vector;
3193 for (i = 0; SYMBOLP (family[i]); i++)
3195 ASET (work, FONT_FAMILY_INDEX, family[i]);
3196 for (j = 0; SYMBOLP (foundry[j]); j++)
3198 ASET (work, FONT_FOUNDRY_INDEX, foundry[j]);
3199 for (k = 0; SYMBOLP (registry[k]); k++)
3201 ASET (work, FONT_REGISTRY_INDEX, registry[k]);
3202 for (l = 0; SYMBOLP (adstyle[l]); l++)
3204 ASET (work, FONT_ADSTYLE_INDEX, adstyle[l]);
3205 entities = font_list_entities (frame, work);
3206 if (! NILP (entities))
3208 val = font_select_entity (frame, entities,
3209 attrs, pixel_size, c);
3210 if (! NILP (val))
3211 return val;
3217 return Qnil;
3221 Lisp_Object
3222 font_open_for_lface (FRAME_PTR f, Lisp_Object entity, Lisp_Object *attrs, Lisp_Object spec)
3224 int size;
3226 if (INTEGERP (AREF (entity, FONT_SIZE_INDEX))
3227 && XINT (AREF (entity, FONT_SIZE_INDEX)) > 0)
3228 size = XINT (AREF (entity, FONT_SIZE_INDEX));
3229 else if (FONT_SPEC_P (spec) && ! NILP (AREF (spec, FONT_SIZE_INDEX)))
3230 size = font_pixel_size (f, spec);
3231 else
3233 double pt;
3234 if (INTEGERP (attrs[LFACE_HEIGHT_INDEX]))
3235 pt = XINT (attrs[LFACE_HEIGHT_INDEX]);
3236 else
3238 struct face *def = FACE_FROM_ID (f, DEFAULT_FACE_ID);
3239 Lisp_Object height = def->lface[LFACE_HEIGHT_INDEX];
3240 if (INTEGERP (height))
3241 pt = XINT (height);
3242 else
3243 abort(); /* We should never end up here. */
3246 pt /= 10;
3247 size = POINT_TO_PIXEL (pt, f->resy);
3248 #ifdef HAVE_NS
3249 if (size == 0)
3251 Lisp_Object ffsize = get_frame_param(f, Qfontsize);
3252 size = NUMBERP (ffsize) ? POINT_TO_PIXEL (XINT (ffsize), f->resy) : 0;
3254 #endif
3256 return font_open_entity (f, entity, size);
3260 /* Find a font that satisfies SPEC and is the best match for
3261 face's attributes in ATTRS on FRAME, and return the opened
3262 font-object. */
3264 Lisp_Object
3265 font_load_for_lface (FRAME_PTR f, Lisp_Object *attrs, Lisp_Object spec)
3267 Lisp_Object entity, name;
3269 entity = font_find_for_lface (f, attrs, spec, -1);
3270 if (NILP (entity))
3272 /* No font is listed for SPEC, but each font-backend may have
3273 different criteria about "font matching". So, try it. */
3274 entity = font_matching_entity (f, attrs, spec);
3275 if (NILP (entity))
3276 return Qnil;
3278 /* Don't lose the original name that was put in initially. We need
3279 it to re-apply the font when font parameters (like hinting or dpi) have
3280 changed. */
3281 entity = font_open_for_lface (f, entity, attrs, spec);
3282 if (!NILP (entity))
3284 name = Ffont_get (spec, QCuser_spec);
3285 if (STRINGP (name)) font_put_extra (entity, QCuser_spec, name);
3287 return entity;
3291 /* Make FACE on frame F ready to use the font opened for FACE. */
3293 void
3294 font_prepare_for_face (FRAME_PTR f, struct face *face)
3296 if (face->font->driver->prepare_face)
3297 face->font->driver->prepare_face (f, face);
3301 /* Make FACE on frame F stop using the font opened for FACE. */
3303 void
3304 font_done_for_face (FRAME_PTR f, struct face *face)
3306 if (face->font->driver->done_face)
3307 face->font->driver->done_face (f, face);
3308 face->extra = NULL;
3312 /* Open a font that is a match for font-spec SPEC on frame F. If no proper
3313 font is found, return Qnil. */
3315 Lisp_Object
3316 font_open_by_spec (FRAME_PTR f, Lisp_Object spec)
3318 Lisp_Object attrs[LFACE_VECTOR_SIZE];
3320 /* We set up the default font-related attributes of a face to prefer
3321 a moderate font. */
3322 attrs[LFACE_FAMILY_INDEX] = attrs[LFACE_FOUNDRY_INDEX] = Qnil;
3323 attrs[LFACE_SWIDTH_INDEX] = attrs[LFACE_WEIGHT_INDEX]
3324 = attrs[LFACE_SLANT_INDEX] = Qnormal;
3325 #ifndef HAVE_NS
3326 attrs[LFACE_HEIGHT_INDEX] = make_number (120);
3327 #else
3328 attrs[LFACE_HEIGHT_INDEX] = make_number (0);
3329 #endif
3330 attrs[LFACE_FONT_INDEX] = Qnil;
3332 return font_load_for_lface (f, attrs, spec);
3336 /* Open a font that matches NAME on frame F. If no proper font is
3337 found, return Qnil. */
3339 Lisp_Object
3340 font_open_by_name (FRAME_PTR f, const char *name)
3342 Lisp_Object args[2];
3343 Lisp_Object spec, ret;
3345 args[0] = QCname;
3346 args[1] = make_unibyte_string (name, strlen (name));
3347 spec = Ffont_spec (2, args);
3348 ret = font_open_by_spec (f, spec);
3349 /* Do not lose name originally put in. */
3350 if (!NILP (ret))
3351 font_put_extra (ret, QCuser_spec, args[1]);
3353 return ret;
3357 /* Register font-driver DRIVER. This function is used in two ways.
3359 The first is with frame F non-NULL. In this case, make DRIVER
3360 available (but not yet activated) on F. All frame creators
3361 (e.g. Fx_create_frame) must call this function at least once with
3362 an available font-driver.
3364 The second is with frame F NULL. In this case, DRIVER is globally
3365 registered in the variable `font_driver_list'. All font-driver
3366 implementations must call this function in its syms_of_XXXX
3367 (e.g. syms_of_xfont). */
3369 void
3370 register_font_driver (struct font_driver *driver, FRAME_PTR f)
3372 struct font_driver_list *root = f ? f->font_driver_list : font_driver_list;
3373 struct font_driver_list *prev, *list;
3375 if (f && ! driver->draw)
3376 error ("Unusable font driver for a frame: %s",
3377 SDATA (SYMBOL_NAME (driver->type)));
3379 for (prev = NULL, list = root; list; prev = list, list = list->next)
3380 if (EQ (list->driver->type, driver->type))
3381 error ("Duplicated font driver: %s", SDATA (SYMBOL_NAME (driver->type)));
3383 list = xmalloc (sizeof (struct font_driver_list));
3384 list->on = 0;
3385 list->driver = driver;
3386 list->next = NULL;
3387 if (prev)
3388 prev->next = list;
3389 else if (f)
3390 f->font_driver_list = list;
3391 else
3392 font_driver_list = list;
3393 if (! f)
3394 num_font_drivers++;
3397 void
3398 free_font_driver_list (FRAME_PTR f)
3400 struct font_driver_list *list, *next;
3402 for (list = f->font_driver_list; list; list = next)
3404 next = list->next;
3405 xfree (list);
3407 f->font_driver_list = NULL;
3411 /* Make the frame F use font backends listed in NEW_DRIVERS (list of
3412 symbols, e.g. xft, x). If NEW_DRIVERS is t, make F use all
3413 available font drivers. If NEW_DRIVERS is nil, finalize all drivers.
3415 A caller must free all realized faces if any in advance. The
3416 return value is a list of font backends actually made used on
3417 F. */
3419 Lisp_Object
3420 font_update_drivers (FRAME_PTR f, Lisp_Object new_drivers)
3422 Lisp_Object active_drivers = Qnil;
3423 struct font_driver_list *list;
3425 /* At first, turn off non-requested drivers, and turn on requested
3426 drivers. */
3427 for (list = f->font_driver_list; list; list = list->next)
3429 struct font_driver *driver = list->driver;
3430 if ((EQ (new_drivers, Qt) || ! NILP (Fmemq (driver->type, new_drivers)))
3431 != list->on)
3433 if (list->on)
3435 if (driver->end_for_frame)
3436 driver->end_for_frame (f);
3437 font_finish_cache (f, driver);
3438 list->on = 0;
3440 else
3442 if (! driver->start_for_frame
3443 || driver->start_for_frame (f) == 0)
3445 font_prepare_cache (f, driver);
3446 list->on = 1;
3452 if (NILP (new_drivers))
3453 return Qnil;
3455 if (! EQ (new_drivers, Qt))
3457 /* Re-order the driver list according to new_drivers. */
3458 struct font_driver_list **list_table, **next;
3459 Lisp_Object tail;
3460 int i;
3462 list_table = alloca (sizeof list_table[0] * (num_font_drivers + 1));
3463 for (i = 0, tail = new_drivers; ! NILP (tail); tail = XCDR (tail))
3465 for (list = f->font_driver_list; list; list = list->next)
3466 if (list->on && EQ (list->driver->type, XCAR (tail)))
3467 break;
3468 if (list)
3469 list_table[i++] = list;
3471 for (list = f->font_driver_list; list; list = list->next)
3472 if (! list->on)
3473 list_table[i++] = list;
3474 list_table[i] = NULL;
3476 next = &f->font_driver_list;
3477 for (i = 0; list_table[i]; i++)
3479 *next = list_table[i];
3480 next = &(*next)->next;
3482 *next = NULL;
3484 if (! f->font_driver_list->on)
3485 { /* None of the drivers is enabled: enable them all.
3486 Happens if you set the list of drivers to (xft x) in your .emacs
3487 and then use it under w32 or ns. */
3488 for (list = f->font_driver_list; list; list = list->next)
3490 struct font_driver *driver = list->driver;
3491 eassert (! list->on);
3492 if (! driver->start_for_frame
3493 || driver->start_for_frame (f) == 0)
3495 font_prepare_cache (f, driver);
3496 list->on = 1;
3502 for (list = f->font_driver_list; list; list = list->next)
3503 if (list->on)
3504 active_drivers = nconc2 (active_drivers,
3505 Fcons (list->driver->type, Qnil));
3506 return active_drivers;
3510 font_put_frame_data (FRAME_PTR f, struct font_driver *driver, void *data)
3512 struct font_data_list *list, *prev;
3514 for (prev = NULL, list = f->font_data_list; list;
3515 prev = list, list = list->next)
3516 if (list->driver == driver)
3517 break;
3518 if (! data)
3520 if (list)
3522 if (prev)
3523 prev->next = list->next;
3524 else
3525 f->font_data_list = list->next;
3526 xfree (list);
3528 return 0;
3531 if (! list)
3533 list = xmalloc (sizeof (struct font_data_list));
3534 list->driver = driver;
3535 list->next = f->font_data_list;
3536 f->font_data_list = list;
3538 list->data = data;
3539 return 0;
3543 void *
3544 font_get_frame_data (FRAME_PTR f, struct font_driver *driver)
3546 struct font_data_list *list;
3548 for (list = f->font_data_list; list; list = list->next)
3549 if (list->driver == driver)
3550 break;
3551 if (! list)
3552 return NULL;
3553 return list->data;
3557 /* Sets attributes on a font. Any properties that appear in ALIST and
3558 BOOLEAN_PROPERTIES or NON_BOOLEAN_PROPERTIES are set on the font.
3559 BOOLEAN_PROPERTIES and NON_BOOLEAN_PROPERTIES are NULL-terminated
3560 arrays of strings. This function is intended for use by the font
3561 drivers to implement their specific font_filter_properties. */
3562 void
3563 font_filter_properties (Lisp_Object font,
3564 Lisp_Object alist,
3565 const char *const boolean_properties[],
3566 const char *const non_boolean_properties[])
3568 Lisp_Object it;
3569 int i;
3571 /* Set boolean values to Qt or Qnil */
3572 for (i = 0; boolean_properties[i] != NULL; ++i)
3573 for (it = alist; ! NILP (it); it = XCDR (it))
3575 Lisp_Object key = XCAR (XCAR (it));
3576 Lisp_Object val = XCDR (XCAR (it));
3577 char *keystr = SSDATA (SYMBOL_NAME (key));
3579 if (strcmp (boolean_properties[i], keystr) == 0)
3581 const char *str = INTEGERP (val) ? (XINT (val) ? "true" : "false")
3582 : SYMBOLP (val) ? SSDATA (SYMBOL_NAME (val))
3583 : "true";
3585 if (strcmp ("false", str) == 0 || strcmp ("False", str) == 0
3586 || strcmp ("FALSE", str) == 0 || strcmp ("FcFalse", str) == 0
3587 || strcmp ("off", str) == 0 || strcmp ("OFF", str) == 0
3588 || strcmp ("Off", str) == 0)
3589 val = Qnil;
3590 else
3591 val = Qt;
3593 Ffont_put (font, key, val);
3597 for (i = 0; non_boolean_properties[i] != NULL; ++i)
3598 for (it = alist; ! NILP (it); it = XCDR (it))
3600 Lisp_Object key = XCAR (XCAR (it));
3601 Lisp_Object val = XCDR (XCAR (it));
3602 char *keystr = SSDATA (SYMBOL_NAME (key));
3603 if (strcmp (non_boolean_properties[i], keystr) == 0)
3604 Ffont_put (font, key, val);
3609 /* Return the font used to draw character C by FACE at buffer position
3610 POS in window W. If STRING is non-nil, it is a string containing C
3611 at index POS. If C is negative, get C from the current buffer or
3612 STRING. */
3614 static Lisp_Object
3615 font_at (int c, EMACS_INT pos, struct face *face, struct window *w,
3616 Lisp_Object string)
3618 FRAME_PTR f;
3619 int multibyte;
3620 Lisp_Object font_object;
3622 multibyte = (NILP (string)
3623 ? ! NILP (BVAR (current_buffer, enable_multibyte_characters))
3624 : STRING_MULTIBYTE (string));
3625 if (c < 0)
3627 if (NILP (string))
3629 if (multibyte)
3631 EMACS_INT pos_byte = CHAR_TO_BYTE (pos);
3633 c = FETCH_CHAR (pos_byte);
3635 else
3636 c = FETCH_BYTE (pos);
3638 else
3640 unsigned char *str;
3642 multibyte = STRING_MULTIBYTE (string);
3643 if (multibyte)
3645 EMACS_INT pos_byte = string_char_to_byte (string, pos);
3647 str = SDATA (string) + pos_byte;
3648 c = STRING_CHAR (str);
3650 else
3651 c = SDATA (string)[pos];
3655 f = XFRAME (w->frame);
3656 if (! FRAME_WINDOW_P (f))
3657 return Qnil;
3658 if (! face)
3660 int face_id;
3661 EMACS_INT endptr;
3663 if (STRINGP (string))
3664 face_id = face_at_string_position (w, string, pos, 0, -1, -1, &endptr,
3665 DEFAULT_FACE_ID, 0);
3666 else
3667 face_id = face_at_buffer_position (w, pos, -1, -1, &endptr,
3668 pos + 100, 0, -1);
3669 face = FACE_FROM_ID (f, face_id);
3671 if (multibyte)
3673 int face_id = FACE_FOR_CHAR (f, face, c, pos, string);
3674 face = FACE_FROM_ID (f, face_id);
3676 if (! face->font)
3677 return Qnil;
3679 XSETFONT (font_object, face->font);
3680 return font_object;
3684 #ifdef HAVE_WINDOW_SYSTEM
3686 /* Check how many characters after POS (at most to *LIMIT) can be
3687 displayed by the same font in the window W. FACE, if non-NULL, is
3688 the face selected for the character at POS. If STRING is not nil,
3689 it is the string to check instead of the current buffer. In that
3690 case, FACE must be not NULL.
3692 The return value is the font-object for the character at POS.
3693 *LIMIT is set to the position where that font can't be used.
3695 It is assured that the current buffer (or STRING) is multibyte. */
3697 Lisp_Object
3698 font_range (EMACS_INT pos, EMACS_INT *limit, struct window *w, struct face *face, Lisp_Object string)
3700 EMACS_INT pos_byte, ignore;
3701 int c;
3702 Lisp_Object font_object = Qnil;
3704 if (NILP (string))
3706 pos_byte = CHAR_TO_BYTE (pos);
3707 if (! face)
3709 int face_id;
3711 face_id = face_at_buffer_position (w, pos, 0, 0, &ignore,
3712 *limit, 0, -1);
3713 face = FACE_FROM_ID (XFRAME (w->frame), face_id);
3716 else
3718 font_assert (face);
3719 pos_byte = string_char_to_byte (string, pos);
3722 while (pos < *limit)
3724 Lisp_Object category;
3726 if (NILP (string))
3727 FETCH_CHAR_ADVANCE_NO_CHECK (c, pos, pos_byte);
3728 else
3729 FETCH_STRING_CHAR_ADVANCE_NO_CHECK (c, string, pos, pos_byte);
3730 category = CHAR_TABLE_REF (Vunicode_category_table, c);
3731 if (INTEGERP (category)
3732 && (XINT (category) == UNICODE_CATEGORY_Cf
3733 || CHAR_VARIATION_SELECTOR_P (c)))
3734 continue;
3735 if (NILP (font_object))
3737 font_object = font_for_char (face, c, pos - 1, string);
3738 if (NILP (font_object))
3739 return Qnil;
3740 continue;
3742 if (font_encode_char (font_object, c) == FONT_INVALID_CODE)
3743 *limit = pos - 1;
3745 return font_object;
3747 #endif
3750 /* Lisp API */
3752 DEFUN ("fontp", Ffontp, Sfontp, 1, 2, 0,
3753 doc: /* Return t if OBJECT is a font-spec, font-entity, or font-object.
3754 Return nil otherwise.
3755 Optional 2nd argument EXTRA-TYPE, if non-nil, specifies to check
3756 which kind of font it is. It must be one of `font-spec', `font-entity',
3757 `font-object'. */)
3758 (Lisp_Object object, Lisp_Object extra_type)
3760 if (NILP (extra_type))
3761 return (FONTP (object) ? Qt : Qnil);
3762 if (EQ (extra_type, Qfont_spec))
3763 return (FONT_SPEC_P (object) ? Qt : Qnil);
3764 if (EQ (extra_type, Qfont_entity))
3765 return (FONT_ENTITY_P (object) ? Qt : Qnil);
3766 if (EQ (extra_type, Qfont_object))
3767 return (FONT_OBJECT_P (object) ? Qt : Qnil);
3768 wrong_type_argument (intern ("font-extra-type"), extra_type);
3771 DEFUN ("font-spec", Ffont_spec, Sfont_spec, 0, MANY, 0,
3772 doc: /* Return a newly created font-spec with arguments as properties.
3774 ARGS must come in pairs KEY VALUE of font properties. KEY must be a
3775 valid font property name listed below:
3777 `:family', `:weight', `:slant', `:width'
3779 They are the same as face attributes of the same name. See
3780 `set-face-attribute'.
3782 `:foundry'
3784 VALUE must be a string or a symbol specifying the font foundry, e.g. ``misc''.
3786 `:adstyle'
3788 VALUE must be a string or a symbol specifying the additional
3789 typographic style information of a font, e.g. ``sans''.
3791 `:registry'
3793 VALUE must be a string or a symbol specifying the charset registry and
3794 encoding of a font, e.g. ``iso8859-1''.
3796 `:size'
3798 VALUE must be a non-negative integer or a floating point number
3799 specifying the font size. It specifies the font size in pixels (if
3800 VALUE is an integer), or in points (if VALUE is a float).
3802 `:name'
3804 VALUE must be a string of XLFD-style or fontconfig-style font name.
3806 `:script'
3808 VALUE must be a symbol representing a script that the font must
3809 support. It may be a symbol representing a subgroup of a script
3810 listed in the variable `script-representative-chars'.
3812 `:lang'
3814 VALUE must be a symbol of two-letter ISO-639 language names,
3815 e.g. `ja'.
3817 `:otf'
3819 VALUE must be a list (SCRIPT-TAG LANGSYS-TAG GSUB [ GPOS ]) to specify
3820 required OpenType features.
3822 SCRIPT-TAG: OpenType script tag symbol (e.g. `deva').
3823 LANGSYS-TAG: OpenType language system tag symbol,
3824 or nil for the default language system.
3825 GSUB: List of OpenType GSUB feature tag symbols, or nil if none required.
3826 GPOS: List of OpenType GPOS feature tag symbols, or nil if none required.
3828 GSUB and GPOS may contain `nil' element. In such a case, the font
3829 must not have any of the remaining elements.
3831 For instance, if the VALUE is `(thai nil nil (mark))', the font must
3832 be an OpenType font whose GPOS table of `thai' script's default
3833 language system must contain `mark' feature.
3835 usage: (font-spec ARGS...) */)
3836 (ptrdiff_t nargs, Lisp_Object *args)
3838 Lisp_Object spec = font_make_spec ();
3839 ptrdiff_t i;
3841 for (i = 0; i < nargs; i += 2)
3843 Lisp_Object key = args[i], val;
3845 CHECK_SYMBOL (key);
3846 if (i + 1 >= nargs)
3847 error ("No value for key `%s'", SDATA (SYMBOL_NAME (key)));
3848 val = args[i + 1];
3850 if (EQ (key, QCname))
3852 CHECK_STRING (val);
3853 font_parse_name (SSDATA (val), spec);
3854 font_put_extra (spec, key, val);
3856 else
3858 int idx = get_font_prop_index (key);
3860 if (idx >= 0)
3862 val = font_prop_validate (idx, Qnil, val);
3863 if (idx < FONT_EXTRA_INDEX)
3864 ASET (spec, idx, val);
3865 else
3866 font_put_extra (spec, key, val);
3868 else
3869 font_put_extra (spec, key, font_prop_validate (0, key, val));
3872 return spec;
3875 /* Return a copy of FONT as a font-spec. */
3876 Lisp_Object
3877 copy_font_spec (Lisp_Object font)
3879 Lisp_Object new_spec, tail, prev, extra;
3880 int i;
3882 CHECK_FONT (font);
3883 new_spec = font_make_spec ();
3884 for (i = 1; i < FONT_EXTRA_INDEX; i++)
3885 ASET (new_spec, i, AREF (font, i));
3886 extra = Fcopy_alist (AREF (font, FONT_EXTRA_INDEX));
3887 /* We must remove :font-entity property. */
3888 for (prev = Qnil, tail = extra; CONSP (tail); prev = tail, tail = XCDR (tail))
3889 if (EQ (XCAR (XCAR (tail)), QCfont_entity))
3891 if (NILP (prev))
3892 extra = XCDR (extra);
3893 else
3894 XSETCDR (prev, XCDR (tail));
3895 break;
3897 ASET (new_spec, FONT_EXTRA_INDEX, extra);
3898 return new_spec;
3901 /* Merge font-specs FROM and TO, and return a new font-spec.
3902 Every specified property in FROM overrides the corresponding
3903 property in TO. */
3904 Lisp_Object
3905 merge_font_spec (Lisp_Object from, Lisp_Object to)
3907 Lisp_Object extra, tail;
3908 int i;
3910 CHECK_FONT (from);
3911 CHECK_FONT (to);
3912 to = copy_font_spec (to);
3913 for (i = 0; i < FONT_EXTRA_INDEX; i++)
3914 ASET (to, i, AREF (from, i));
3915 extra = AREF (to, FONT_EXTRA_INDEX);
3916 for (tail = AREF (from, FONT_EXTRA_INDEX); CONSP (tail); tail = XCDR (tail))
3917 if (! EQ (XCAR (XCAR (tail)), Qfont_entity))
3919 Lisp_Object slot = assq_no_quit (XCAR (XCAR (tail)), extra);
3921 if (! NILP (slot))
3922 XSETCDR (slot, XCDR (XCAR (tail)));
3923 else
3924 extra = Fcons (Fcons (XCAR (XCAR (tail)), XCDR (XCAR (tail))), extra);
3926 ASET (to, FONT_EXTRA_INDEX, extra);
3927 return to;
3930 DEFUN ("font-get", Ffont_get, Sfont_get, 2, 2, 0,
3931 doc: /* Return the value of FONT's property KEY.
3932 FONT is a font-spec, a font-entity, or a font-object.
3933 KEY is any symbol, but these are reserved for specific meanings:
3934 :family, :weight, :slant, :width, :foundry, :adstyle, :registry,
3935 :size, :name, :script, :otf
3936 See the documentation of `font-spec' for their meanings.
3937 In addition, if FONT is a font-entity or a font-object, values of
3938 :script and :otf are different from those of a font-spec as below:
3940 The value of :script may be a list of scripts that are supported by the font.
3942 The value of :otf is a cons (GSUB . GPOS) where GSUB and GPOS are lists
3943 representing the OpenType features supported by the font by this form:
3944 ((SCRIPT (LANGSYS FEATURE ...) ...) ...)
3945 SCRIPT, LANGSYS, and FEATURE are all symbols representing OpenType
3946 Layout tags. */)
3947 (Lisp_Object font, Lisp_Object key)
3949 int idx;
3950 Lisp_Object val;
3952 CHECK_FONT (font);
3953 CHECK_SYMBOL (key);
3955 idx = get_font_prop_index (key);
3956 if (idx >= FONT_WEIGHT_INDEX && idx <= FONT_WIDTH_INDEX)
3957 return font_style_symbolic (font, idx, 0);
3958 if (idx >= 0 && idx < FONT_EXTRA_INDEX)
3959 return AREF (font, idx);
3960 val = Fassq (key, AREF (font, FONT_EXTRA_INDEX));
3961 if (NILP (val) && EQ (key, QCotf) && FONT_OBJECT_P (font))
3963 struct font *fontp = XFONT_OBJECT (font);
3965 if (fontp->driver->otf_capability)
3966 val = fontp->driver->otf_capability (fontp);
3967 else
3968 val = Fcons (Qnil, Qnil);
3970 else
3971 val = Fcdr (val);
3972 return val;
3975 #ifdef HAVE_WINDOW_SYSTEM
3977 DEFUN ("font-face-attributes", Ffont_face_attributes, Sfont_face_attributes, 1, 2, 0,
3978 doc: /* Return a plist of face attributes generated by FONT.
3979 FONT is a font name, a font-spec, a font-entity, or a font-object.
3980 The return value is a list of the form
3982 \(:family FAMILY :height HEIGHT :weight WEIGHT :slant SLANT :width WIDTH)
3984 where FAMILY, HEIGHT, WEIGHT, SLANT, and WIDTH are face attribute values
3985 compatible with `set-face-attribute'. Some of these key-attribute pairs
3986 may be omitted from the list if they are not specified by FONT.
3988 The optional argument FRAME specifies the frame that the face attributes
3989 are to be displayed on. If omitted, the selected frame is used. */)
3990 (Lisp_Object font, Lisp_Object frame)
3992 struct frame *f;
3993 Lisp_Object plist[10];
3994 Lisp_Object val;
3995 int n = 0;
3997 if (NILP (frame))
3998 frame = selected_frame;
3999 CHECK_LIVE_FRAME (frame);
4000 f = XFRAME (frame);
4002 if (STRINGP (font))
4004 int fontset = fs_query_fontset (font, 0);
4005 Lisp_Object name = font;
4006 if (fontset >= 0)
4007 font = fontset_ascii (fontset);
4008 font = font_spec_from_name (name);
4009 if (! FONTP (font))
4010 signal_error ("Invalid font name", name);
4012 else if (! FONTP (font))
4013 signal_error ("Invalid font object", font);
4015 val = AREF (font, FONT_FAMILY_INDEX);
4016 if (! NILP (val))
4018 plist[n++] = QCfamily;
4019 plist[n++] = SYMBOL_NAME (val);
4022 val = AREF (font, FONT_SIZE_INDEX);
4023 if (INTEGERP (val))
4025 Lisp_Object font_dpi = AREF (font, FONT_DPI_INDEX);
4026 int dpi = INTEGERP (font_dpi) ? XINT (font_dpi) : f->resy;
4027 plist[n++] = QCheight;
4028 plist[n++] = make_number (PIXEL_TO_POINT (XINT (val) * 10, dpi));
4030 else if (FLOATP (val))
4032 plist[n++] = QCheight;
4033 plist[n++] = make_number (10 * (int) XFLOAT_DATA (val));
4036 val = FONT_WEIGHT_FOR_FACE (font);
4037 if (! NILP (val))
4039 plist[n++] = QCweight;
4040 plist[n++] = val;
4043 val = FONT_SLANT_FOR_FACE (font);
4044 if (! NILP (val))
4046 plist[n++] = QCslant;
4047 plist[n++] = val;
4050 val = FONT_WIDTH_FOR_FACE (font);
4051 if (! NILP (val))
4053 plist[n++] = QCwidth;
4054 plist[n++] = val;
4057 return Flist (n, plist);
4060 #endif
4062 DEFUN ("font-put", Ffont_put, Sfont_put, 3, 3, 0,
4063 doc: /* Set one property of FONT: give property KEY value VAL.
4064 FONT is a font-spec, a font-entity, or a font-object.
4066 If FONT is a font-spec, KEY can be any symbol. But if KEY is the one
4067 accepted by the function `font-spec' (which see), VAL must be what
4068 allowed in `font-spec'.
4070 If FONT is a font-entity or a font-object, KEY must not be the one
4071 accepted by `font-spec'. */)
4072 (Lisp_Object font, Lisp_Object prop, Lisp_Object val)
4074 int idx;
4076 idx = get_font_prop_index (prop);
4077 if (idx >= 0 && idx < FONT_EXTRA_INDEX)
4079 CHECK_FONT_SPEC (font);
4080 ASET (font, idx, font_prop_validate (idx, Qnil, val));
4082 else
4084 if (EQ (prop, QCname)
4085 || EQ (prop, QCscript)
4086 || EQ (prop, QClang)
4087 || EQ (prop, QCotf))
4088 CHECK_FONT_SPEC (font);
4089 else
4090 CHECK_FONT (font);
4091 font_put_extra (font, prop, font_prop_validate (0, prop, val));
4093 return val;
4096 DEFUN ("list-fonts", Flist_fonts, Slist_fonts, 1, 4, 0,
4097 doc: /* List available fonts matching FONT-SPEC on the current frame.
4098 Optional 2nd argument FRAME specifies the target frame.
4099 Optional 3rd argument NUM, if non-nil, limits the number of returned fonts.
4100 Optional 4th argument PREFER, if non-nil, is a font-spec to
4101 control the order of the returned list. Fonts are sorted by
4102 how close they are to PREFER. */)
4103 (Lisp_Object font_spec, Lisp_Object frame, Lisp_Object num, Lisp_Object prefer)
4105 Lisp_Object vec, list;
4106 int n = 0;
4108 if (NILP (frame))
4109 frame = selected_frame;
4110 CHECK_LIVE_FRAME (frame);
4111 CHECK_FONT_SPEC (font_spec);
4112 if (! NILP (num))
4114 CHECK_NUMBER (num);
4115 n = XINT (num);
4116 if (n <= 0)
4117 return Qnil;
4119 if (! NILP (prefer))
4120 CHECK_FONT_SPEC (prefer);
4122 list = font_list_entities (frame, font_spec);
4123 if (NILP (list))
4124 return Qnil;
4125 if (NILP (XCDR (list))
4126 && ASIZE (XCAR (list)) == 1)
4127 return Fcons (AREF (XCAR (list), 0), Qnil);
4129 if (! NILP (prefer))
4130 vec = font_sort_entities (list, prefer, frame, 0);
4131 else
4132 vec = font_vconcat_entity_vectors (list);
4133 if (n == 0 || n >= ASIZE (vec))
4135 Lisp_Object args[2];
4137 args[0] = vec;
4138 args[1] = Qnil;
4139 list = Fappend (2, args);
4141 else
4143 for (list = Qnil, n--; n >= 0; n--)
4144 list = Fcons (AREF (vec, n), list);
4146 return list;
4149 DEFUN ("font-family-list", Ffont_family_list, Sfont_family_list, 0, 1, 0,
4150 doc: /* List available font families on the current frame.
4151 Optional argument FRAME, if non-nil, specifies the target frame. */)
4152 (Lisp_Object frame)
4154 FRAME_PTR f;
4155 struct font_driver_list *driver_list;
4156 Lisp_Object list;
4158 if (NILP (frame))
4159 frame = selected_frame;
4160 CHECK_LIVE_FRAME (frame);
4161 f = XFRAME (frame);
4162 list = Qnil;
4163 for (driver_list = f->font_driver_list; driver_list;
4164 driver_list = driver_list->next)
4165 if (driver_list->driver->list_family)
4167 Lisp_Object val = driver_list->driver->list_family (frame);
4168 Lisp_Object tail = list;
4170 for (; CONSP (val); val = XCDR (val))
4171 if (NILP (Fmemq (XCAR (val), tail))
4172 && SYMBOLP (XCAR (val)))
4173 list = Fcons (SYMBOL_NAME (XCAR (val)), list);
4175 return list;
4178 DEFUN ("find-font", Ffind_font, Sfind_font, 1, 2, 0,
4179 doc: /* Return a font-entity matching with FONT-SPEC on the current frame.
4180 Optional 2nd argument FRAME, if non-nil, specifies the target frame. */)
4181 (Lisp_Object font_spec, Lisp_Object frame)
4183 Lisp_Object val = Flist_fonts (font_spec, frame, make_number (1), Qnil);
4185 if (CONSP (val))
4186 val = XCAR (val);
4187 return val;
4190 DEFUN ("font-xlfd-name", Ffont_xlfd_name, Sfont_xlfd_name, 1, 2, 0,
4191 doc: /* Return XLFD name of FONT.
4192 FONT is a font-spec, font-entity, or font-object.
4193 If the name is too long for XLFD (maximum 255 chars), return nil.
4194 If the 2nd optional arg FOLD-WILDCARDS is non-nil,
4195 the consecutive wildcards are folded into one. */)
4196 (Lisp_Object font, Lisp_Object fold_wildcards)
4198 char name[256];
4199 int pixel_size = 0;
4201 CHECK_FONT (font);
4203 if (FONT_OBJECT_P (font))
4205 Lisp_Object font_name = AREF (font, FONT_NAME_INDEX);
4207 if (STRINGP (font_name)
4208 && SDATA (font_name)[0] == '-')
4210 if (NILP (fold_wildcards))
4211 return font_name;
4212 strcpy (name, SSDATA (font_name));
4213 goto done;
4215 pixel_size = XFONT_OBJECT (font)->pixel_size;
4217 if (font_unparse_xlfd (font, pixel_size, name, 256) < 0)
4218 return Qnil;
4219 done:
4220 if (! NILP (fold_wildcards))
4222 char *p0 = name, *p1;
4224 while ((p1 = strstr (p0, "-*-*")))
4226 strcpy (p1, p1 + 2);
4227 p0 = p1;
4231 return build_string (name);
4234 DEFUN ("clear-font-cache", Fclear_font_cache, Sclear_font_cache, 0, 0, 0,
4235 doc: /* Clear font cache. */)
4236 (void)
4238 Lisp_Object list, frame;
4240 FOR_EACH_FRAME (list, frame)
4242 FRAME_PTR f = XFRAME (frame);
4243 struct font_driver_list *driver_list = f->font_driver_list;
4245 for (; driver_list; driver_list = driver_list->next)
4246 if (driver_list->on)
4248 Lisp_Object cache = driver_list->driver->get_cache (f);
4249 Lisp_Object val, tmp;
4251 val = XCDR (cache);
4252 while (! NILP (val)
4253 && ! EQ (XCAR (XCAR (val)), driver_list->driver->type))
4254 val = XCDR (val);
4255 font_assert (! NILP (val));
4256 tmp = XCDR (XCAR (val));
4257 if (XINT (XCAR (tmp)) == 0)
4259 font_clear_cache (f, XCAR (val), driver_list->driver);
4260 XSETCDR (cache, XCDR (val));
4265 return Qnil;
4269 void
4270 font_fill_lglyph_metrics (Lisp_Object glyph, Lisp_Object font_object)
4272 struct font *font = XFONT_OBJECT (font_object);
4273 unsigned code;
4274 /* ecode used in LGLYPH_SET_CODE to avoid compiler warnings. */
4275 EMACS_INT ecode = font->driver->encode_char (font, LGLYPH_CHAR (glyph));
4276 struct font_metrics metrics;
4278 LGLYPH_SET_CODE (glyph, ecode);
4279 code = ecode;
4280 font->driver->text_extents (font, &code, 1, &metrics);
4281 LGLYPH_SET_LBEARING (glyph, metrics.lbearing);
4282 LGLYPH_SET_RBEARING (glyph, metrics.rbearing);
4283 LGLYPH_SET_WIDTH (glyph, metrics.width);
4284 LGLYPH_SET_ASCENT (glyph, metrics.ascent);
4285 LGLYPH_SET_DESCENT (glyph, metrics.descent);
4289 DEFUN ("font-shape-gstring", Ffont_shape_gstring, Sfont_shape_gstring, 1, 1, 0,
4290 doc: /* Shape the glyph-string GSTRING.
4291 Shaping means substituting glyphs and/or adjusting positions of glyphs
4292 to get the correct visual image of character sequences set in the
4293 header of the glyph-string.
4295 If the shaping was successful, the value is GSTRING itself or a newly
4296 created glyph-string. Otherwise, the value is nil. */)
4297 (Lisp_Object gstring)
4299 struct font *font;
4300 Lisp_Object font_object, n, glyph;
4301 EMACS_INT i, j, from, to;
4303 if (! composition_gstring_p (gstring))
4304 signal_error ("Invalid glyph-string: ", gstring);
4305 if (! NILP (LGSTRING_ID (gstring)))
4306 return gstring;
4307 font_object = LGSTRING_FONT (gstring);
4308 CHECK_FONT_OBJECT (font_object);
4309 font = XFONT_OBJECT (font_object);
4310 if (! font->driver->shape)
4311 return Qnil;
4313 /* Try at most three times with larger gstring each time. */
4314 for (i = 0; i < 3; i++)
4316 n = font->driver->shape (gstring);
4317 if (INTEGERP (n))
4318 break;
4319 gstring = larger_vector (gstring,
4320 ASIZE (gstring) + LGSTRING_GLYPH_LEN (gstring),
4321 Qnil);
4323 if (i == 3 || XINT (n) == 0)
4324 return Qnil;
4325 if (XINT (n) < LGSTRING_GLYPH_LEN (gstring))
4326 LGSTRING_SET_GLYPH (gstring, XINT (n), Qnil);
4328 glyph = LGSTRING_GLYPH (gstring, 0);
4329 from = LGLYPH_FROM (glyph);
4330 to = LGLYPH_TO (glyph);
4331 for (i = 1, j = 0; i < LGSTRING_GLYPH_LEN (gstring); i++)
4333 Lisp_Object this = LGSTRING_GLYPH (gstring, i);
4335 if (NILP (this))
4336 break;
4337 if (NILP (LGLYPH_ADJUSTMENT (this)))
4339 if (j < i - 1)
4340 for (; j < i; j++)
4342 glyph = LGSTRING_GLYPH (gstring, j);
4343 LGLYPH_SET_FROM (glyph, from);
4344 LGLYPH_SET_TO (glyph, to);
4346 from = LGLYPH_FROM (this);
4347 to = LGLYPH_TO (this);
4348 j = i;
4350 else
4352 if (from > LGLYPH_FROM (this))
4353 from = LGLYPH_FROM (this);
4354 if (to < LGLYPH_TO (this))
4355 to = LGLYPH_TO (this);
4358 if (j < i - 1)
4359 for (; j < i; j++)
4361 glyph = LGSTRING_GLYPH (gstring, j);
4362 LGLYPH_SET_FROM (glyph, from);
4363 LGLYPH_SET_TO (glyph, to);
4365 return composition_gstring_put_cache (gstring, XINT (n));
4368 DEFUN ("font-variation-glyphs", Ffont_variation_glyphs, Sfont_variation_glyphs,
4369 2, 2, 0,
4370 doc: /* Return a list of variation glyphs for CHAR in FONT-OBJECT.
4371 Each element of the value is a cons (VARIATION-SELECTOR . GLYPH-ID),
4372 where
4373 VARIATION-SELECTOR is a character code of variation selection
4374 (#xFE00..#xFE0F or #xE0100..#xE01EF)
4375 GLYPH-ID is a glyph code of the corresponding variation glyph. */)
4376 (Lisp_Object font_object, Lisp_Object character)
4378 unsigned variations[256];
4379 struct font *font;
4380 int i, n;
4381 Lisp_Object val;
4383 CHECK_FONT_OBJECT (font_object);
4384 CHECK_CHARACTER (character);
4385 font = XFONT_OBJECT (font_object);
4386 if (! font->driver->get_variation_glyphs)
4387 return Qnil;
4388 n = font->driver->get_variation_glyphs (font, XINT (character), variations);
4389 if (! n)
4390 return Qnil;
4391 val = Qnil;
4392 for (i = 0; i < 255; i++)
4393 if (variations[i])
4395 int vs = (i < 16 ? 0xFE00 + i : 0xE0100 + (i - 16));
4396 Lisp_Object code = INTEGER_TO_CONS (variations[i]);
4397 val = Fcons (Fcons (make_number (vs), code), val);
4399 return val;
4402 #if 0
4404 DEFUN ("font-drive-otf", Ffont_drive_otf, Sfont_drive_otf, 6, 6, 0,
4405 doc: /* Apply OpenType features on glyph-string GSTRING-IN.
4406 OTF-FEATURES specifies which features to apply in this format:
4407 (SCRIPT LANGSYS GSUB GPOS)
4408 where
4409 SCRIPT is a symbol specifying a script tag of OpenType,
4410 LANGSYS is a symbol specifying a langsys tag of OpenType,
4411 GSUB and GPOS, if non-nil, are lists of symbols specifying feature tags.
4413 If LANGYS is nil, the default langsys is selected.
4415 The features are applied in the order they appear in the list. The
4416 symbol `*' means to apply all available features not present in this
4417 list, and the remaining features are ignored. For instance, (vatu
4418 pstf * haln) is to apply vatu and pstf in this order, then to apply
4419 all available features other than vatu, pstf, and haln.
4421 The features are applied to the glyphs in the range FROM and TO of
4422 the glyph-string GSTRING-IN.
4424 If some feature is actually applicable, the resulting glyphs are
4425 produced in the glyph-string GSTRING-OUT from the index INDEX. In
4426 this case, the value is the number of produced glyphs.
4428 If no feature is applicable, no glyph is produced in GSTRING-OUT, and
4429 the value is 0.
4431 If GSTRING-OUT is too short to hold produced glyphs, no glyphs are
4432 produced in GSTRING-OUT, and the value is nil.
4434 See the documentation of `composition-get-gstring' for the format of
4435 glyph-string. */)
4436 (Lisp_Object otf_features, Lisp_Object gstring_in, Lisp_Object from, Lisp_Object to, Lisp_Object gstring_out, Lisp_Object index)
4438 Lisp_Object font_object = LGSTRING_FONT (gstring_in);
4439 Lisp_Object val;
4440 struct font *font;
4441 int len, num;
4443 check_otf_features (otf_features);
4444 CHECK_FONT_OBJECT (font_object);
4445 font = XFONT_OBJECT (font_object);
4446 if (! font->driver->otf_drive)
4447 error ("Font backend %s can't drive OpenType GSUB table",
4448 SDATA (SYMBOL_NAME (font->driver->type)));
4449 CHECK_CONS (otf_features);
4450 CHECK_SYMBOL (XCAR (otf_features));
4451 val = XCDR (otf_features);
4452 CHECK_SYMBOL (XCAR (val));
4453 val = XCDR (otf_features);
4454 if (! NILP (val))
4455 CHECK_CONS (val);
4456 len = check_gstring (gstring_in);
4457 CHECK_VECTOR (gstring_out);
4458 CHECK_NATNUM (from);
4459 CHECK_NATNUM (to);
4460 CHECK_NATNUM (index);
4462 if (XINT (from) >= XINT (to) || XINT (to) > len)
4463 args_out_of_range_3 (from, to, make_number (len));
4464 if (XINT (index) >= ASIZE (gstring_out))
4465 args_out_of_range (index, make_number (ASIZE (gstring_out)));
4466 num = font->driver->otf_drive (font, otf_features,
4467 gstring_in, XINT (from), XINT (to),
4468 gstring_out, XINT (index), 0);
4469 if (num < 0)
4470 return Qnil;
4471 return make_number (num);
4474 DEFUN ("font-otf-alternates", Ffont_otf_alternates, Sfont_otf_alternates,
4475 3, 3, 0,
4476 doc: /* Return a list of alternate glyphs of CHARACTER in FONT-OBJECT.
4477 OTF-FEATURES specifies which features of the font FONT-OBJECT to apply
4478 in this format:
4479 (SCRIPT LANGSYS FEATURE ...)
4480 See the documentation of `font-drive-otf' for more detail.
4482 The value is a list of cons cells of the format (GLYPH-ID . CHARACTER),
4483 where GLYPH-ID is a glyph index of the font, and CHARACTER is a
4484 character code corresponding to the glyph or nil if there's no
4485 corresponding character. */)
4486 (Lisp_Object font_object, Lisp_Object character, Lisp_Object otf_features)
4488 struct font *font;
4489 Lisp_Object gstring_in, gstring_out, g;
4490 Lisp_Object alternates;
4491 int i, num;
4493 CHECK_FONT_GET_OBJECT (font_object, font);
4494 if (! font->driver->otf_drive)
4495 error ("Font backend %s can't drive OpenType GSUB table",
4496 SDATA (SYMBOL_NAME (font->driver->type)));
4497 CHECK_CHARACTER (character);
4498 CHECK_CONS (otf_features);
4500 gstring_in = Ffont_make_gstring (font_object, make_number (1));
4501 g = LGSTRING_GLYPH (gstring_in, 0);
4502 LGLYPH_SET_CHAR (g, XINT (character));
4503 gstring_out = Ffont_make_gstring (font_object, make_number (10));
4504 while ((num = font->driver->otf_drive (font, otf_features, gstring_in, 0, 1,
4505 gstring_out, 0, 1)) < 0)
4506 gstring_out = Ffont_make_gstring (font_object,
4507 make_number (ASIZE (gstring_out) * 2));
4508 alternates = Qnil;
4509 for (i = 0; i < num; i++)
4511 Lisp_Object g = LGSTRING_GLYPH (gstring_out, i);
4512 int c = LGLYPH_CHAR (g);
4513 unsigned code = LGLYPH_CODE (g);
4515 alternates = Fcons (Fcons (make_number (code),
4516 c > 0 ? make_number (c) : Qnil),
4517 alternates);
4519 return Fnreverse (alternates);
4521 #endif /* 0 */
4523 #ifdef FONT_DEBUG
4525 DEFUN ("open-font", Fopen_font, Sopen_font, 1, 3, 0,
4526 doc: /* Open FONT-ENTITY. */)
4527 (Lisp_Object font_entity, Lisp_Object size, Lisp_Object frame)
4529 int isize;
4531 CHECK_FONT_ENTITY (font_entity);
4532 if (NILP (frame))
4533 frame = selected_frame;
4534 CHECK_LIVE_FRAME (frame);
4536 if (NILP (size))
4537 isize = XINT (AREF (font_entity, FONT_SIZE_INDEX));
4538 else
4540 CHECK_NUMBER_OR_FLOAT (size);
4541 if (FLOATP (size))
4542 isize = POINT_TO_PIXEL (XFLOAT_DATA (size), XFRAME (frame)->resy);
4543 else
4544 isize = XINT (size);
4545 if (isize == 0)
4546 isize = 120;
4548 return font_open_entity (XFRAME (frame), font_entity, isize);
4551 DEFUN ("close-font", Fclose_font, Sclose_font, 1, 2, 0,
4552 doc: /* Close FONT-OBJECT. */)
4553 (Lisp_Object font_object, Lisp_Object frame)
4555 CHECK_FONT_OBJECT (font_object);
4556 if (NILP (frame))
4557 frame = selected_frame;
4558 CHECK_LIVE_FRAME (frame);
4559 font_close_object (XFRAME (frame), font_object);
4560 return Qnil;
4563 DEFUN ("query-font", Fquery_font, Squery_font, 1, 1, 0,
4564 doc: /* Return information about FONT-OBJECT.
4565 The value is a vector:
4566 [ NAME FILENAME PIXEL-SIZE SIZE ASCENT DESCENT SPACE-WIDTH AVERAGE-WIDTH
4567 CAPABILITY ]
4569 NAME is the font name, a string (or nil if the font backend doesn't
4570 provide a name).
4572 FILENAME is the font file name, a string (or nil if the font backend
4573 doesn't provide a file name).
4575 PIXEL-SIZE is a pixel size by which the font is opened.
4577 SIZE is a maximum advance width of the font in pixels.
4579 ASCENT, DESCENT, SPACE-WIDTH, AVERAGE-WIDTH are metrics of the font in
4580 pixels.
4582 CAPABILITY is a list whose first element is a symbol representing the
4583 font format \(x, opentype, truetype, type1, pcf, or bdf) and the
4584 remaining elements describe the details of the font capability.
4586 If the font is OpenType font, the form of the list is
4587 \(opentype GSUB GPOS)
4588 where GSUB shows which "GSUB" features the font supports, and GPOS
4589 shows which "GPOS" features the font supports. Both GSUB and GPOS are
4590 lists of the format:
4591 \((SCRIPT (LANGSYS FEATURE ...) ...) ...)
4593 If the font is not OpenType font, currently the length of the form is
4594 one.
4596 SCRIPT is a symbol representing OpenType script tag.
4598 LANGSYS is a symbol representing OpenType langsys tag, or nil
4599 representing the default langsys.
4601 FEATURE is a symbol representing OpenType feature tag.
4603 If the font is not OpenType font, CAPABILITY is nil. */)
4604 (Lisp_Object font_object)
4606 struct font *font;
4607 Lisp_Object val;
4609 CHECK_FONT_GET_OBJECT (font_object, font);
4611 val = Fmake_vector (make_number (9), Qnil);
4612 ASET (val, 0, AREF (font_object, FONT_NAME_INDEX));
4613 ASET (val, 1, AREF (font_object, FONT_FILE_INDEX));
4614 ASET (val, 2, make_number (font->pixel_size));
4615 ASET (val, 3, make_number (font->max_width));
4616 ASET (val, 4, make_number (font->ascent));
4617 ASET (val, 5, make_number (font->descent));
4618 ASET (val, 6, make_number (font->space_width));
4619 ASET (val, 7, make_number (font->average_width));
4620 if (font->driver->otf_capability)
4621 ASET (val, 8, Fcons (Qopentype, font->driver->otf_capability (font)));
4622 return val;
4625 DEFUN ("font-get-glyphs", Ffont_get_glyphs, Sfont_get_glyphs, 3, 4, 0,
4626 doc:
4627 /* Return a vector of FONT-OBJECT's glyphs for the specified characters.
4628 FROM and TO are positions (integers or markers) specifying a region
4629 of the current buffer.
4630 If the optional fourth arg OBJECT is not nil, it is a string or a
4631 vector containing the target characters.
4633 Each element is a vector containing information of a glyph in this format:
4634 [FROM-IDX TO-IDX C CODE WIDTH LBEARING RBEARING ASCENT DESCENT ADJUSTMENT]
4635 where
4636 FROM is an index numbers of a character the glyph corresponds to.
4637 TO is the same as FROM.
4638 C is the character of the glyph.
4639 CODE is the glyph-code of C in FONT-OBJECT.
4640 WIDTH thru DESCENT are the metrics (in pixels) of the glyph.
4641 ADJUSTMENT is always nil.
4642 If FONT-OBJECT doesn't have a glyph for a character,
4643 the corresponding element is nil. */)
4644 (Lisp_Object font_object, Lisp_Object from, Lisp_Object to,
4645 Lisp_Object object)
4647 struct font *font;
4648 int i, len;
4649 Lisp_Object *chars, vec;
4650 USE_SAFE_ALLOCA;
4652 CHECK_FONT_GET_OBJECT (font_object, font);
4653 if (NILP (object))
4655 EMACS_INT charpos, bytepos;
4657 validate_region (&from, &to);
4658 if (EQ (from, to))
4659 return Qnil;
4660 len = XFASTINT (to) - XFASTINT (from);
4661 SAFE_ALLOCA_LISP (chars, len);
4662 charpos = XFASTINT (from);
4663 bytepos = CHAR_TO_BYTE (charpos);
4664 for (i = 0; charpos < XFASTINT (to); i++)
4666 int c;
4667 FETCH_CHAR_ADVANCE (c, charpos, bytepos);
4668 chars[i] = make_number (c);
4671 else if (STRINGP (object))
4673 const unsigned char *p;
4675 CHECK_NUMBER (from);
4676 CHECK_NUMBER (to);
4677 if (XINT (from) < 0 || XINT (from) > XINT (to)
4678 || XINT (to) > SCHARS (object))
4679 args_out_of_range_3 (object, from, to);
4680 if (EQ (from, to))
4681 return Qnil;
4682 len = XFASTINT (to) - XFASTINT (from);
4683 SAFE_ALLOCA_LISP (chars, len);
4684 p = SDATA (object);
4685 if (STRING_MULTIBYTE (object))
4686 for (i = 0; i < len; i++)
4688 int c = STRING_CHAR_ADVANCE (p);
4689 chars[i] = make_number (c);
4691 else
4692 for (i = 0; i < len; i++)
4693 chars[i] = make_number (p[i]);
4695 else
4697 CHECK_VECTOR (object);
4698 CHECK_NUMBER (from);
4699 CHECK_NUMBER (to);
4700 if (XINT (from) < 0 || XINT (from) > XINT (to)
4701 || XINT (to) > ASIZE (object))
4702 args_out_of_range_3 (object, from, to);
4703 if (EQ (from, to))
4704 return Qnil;
4705 len = XFASTINT (to) - XFASTINT (from);
4706 for (i = 0; i < len; i++)
4708 Lisp_Object elt = AREF (object, XFASTINT (from) + i);
4709 CHECK_CHARACTER (elt);
4711 chars = &(AREF (object, XFASTINT (from)));
4714 vec = Fmake_vector (make_number (len), Qnil);
4715 for (i = 0; i < len; i++)
4717 Lisp_Object g;
4718 int c = XFASTINT (chars[i]);
4719 unsigned code;
4720 struct font_metrics metrics;
4722 code = font->driver->encode_char (font, c);
4723 if (code == FONT_INVALID_CODE)
4724 continue;
4725 g = Fmake_vector (make_number (LGLYPH_SIZE), Qnil);
4726 LGLYPH_SET_FROM (g, i);
4727 LGLYPH_SET_TO (g, i);
4728 LGLYPH_SET_CHAR (g, c);
4729 LGLYPH_SET_CODE (g, code);
4730 font->driver->text_extents (font, &code, 1, &metrics);
4731 LGLYPH_SET_WIDTH (g, metrics.width);
4732 LGLYPH_SET_LBEARING (g, metrics.lbearing);
4733 LGLYPH_SET_RBEARING (g, metrics.rbearing);
4734 LGLYPH_SET_ASCENT (g, metrics.ascent);
4735 LGLYPH_SET_DESCENT (g, metrics.descent);
4736 ASET (vec, i, g);
4738 if (! VECTORP (object))
4739 SAFE_FREE ();
4740 return vec;
4743 DEFUN ("font-match-p", Ffont_match_p, Sfont_match_p, 2, 2, 0,
4744 doc: /* Return t if and only if font-spec SPEC matches with FONT.
4745 FONT is a font-spec, font-entity, or font-object. */)
4746 (Lisp_Object spec, Lisp_Object font)
4748 CHECK_FONT_SPEC (spec);
4749 CHECK_FONT (font);
4751 return (font_match_p (spec, font) ? Qt : Qnil);
4754 DEFUN ("font-at", Ffont_at, Sfont_at, 1, 3, 0,
4755 doc: /* Return a font-object for displaying a character at POSITION.
4756 Optional second arg WINDOW, if non-nil, is a window displaying
4757 the current buffer. It defaults to the currently selected window. */)
4758 (Lisp_Object position, Lisp_Object window, Lisp_Object string)
4760 struct window *w;
4761 EMACS_INT pos;
4763 if (NILP (string))
4765 CHECK_NUMBER_COERCE_MARKER (position);
4766 pos = XINT (position);
4767 if (pos < BEGV || pos >= ZV)
4768 args_out_of_range_3 (position, make_number (BEGV), make_number (ZV));
4770 else
4772 CHECK_NUMBER (position);
4773 CHECK_STRING (string);
4774 pos = XINT (position);
4775 if (pos < 0 || pos >= SCHARS (string))
4776 args_out_of_range (string, position);
4778 if (NILP (window))
4779 window = selected_window;
4780 CHECK_LIVE_WINDOW (window);
4781 w = XWINDOW (window);
4783 return font_at (-1, pos, NULL, w, string);
4786 #if 0
4787 DEFUN ("draw-string", Fdraw_string, Sdraw_string, 2, 2, 0,
4788 doc: /* Draw STRING by FONT-OBJECT on the top left corner of the current frame.
4789 The value is a number of glyphs drawn.
4790 Type C-l to recover what previously shown. */)
4791 (Lisp_Object font_object, Lisp_Object string)
4793 Lisp_Object frame = selected_frame;
4794 FRAME_PTR f = XFRAME (frame);
4795 struct font *font;
4796 struct face *face;
4797 int i, len, width;
4798 unsigned *code;
4800 CHECK_FONT_GET_OBJECT (font_object, font);
4801 CHECK_STRING (string);
4802 len = SCHARS (string);
4803 code = alloca (sizeof (unsigned) * len);
4804 for (i = 0; i < len; i++)
4806 Lisp_Object ch = Faref (string, make_number (i));
4807 Lisp_Object val;
4808 int c = XINT (ch);
4810 code[i] = font->driver->encode_char (font, c);
4811 if (code[i] == FONT_INVALID_CODE)
4812 break;
4814 face = FACE_FROM_ID (f, DEFAULT_FACE_ID);
4815 face->fontp = font;
4816 if (font->driver->prepare_face)
4817 font->driver->prepare_face (f, face);
4818 width = font->driver->text_extents (font, code, i, NULL);
4819 len = font->driver->draw_text (f, face, 0, font->ascent, code, i, width);
4820 if (font->driver->done_face)
4821 font->driver->done_face (f, face);
4822 face->fontp = NULL;
4823 return make_number (len);
4825 #endif
4827 #endif /* FONT_DEBUG */
4829 #ifdef HAVE_WINDOW_SYSTEM
4831 DEFUN ("font-info", Ffont_info, Sfont_info, 1, 2, 0,
4832 doc: /* Return information about a font named NAME on frame FRAME.
4833 If FRAME is omitted or nil, use the selected frame.
4834 The returned value is a vector of OPENED-NAME, FULL-NAME, SIZE,
4835 HEIGHT, BASELINE-OFFSET, RELATIVE-COMPOSE, and DEFAULT-ASCENT,
4836 where
4837 OPENED-NAME is the name used for opening the font,
4838 FULL-NAME is the full name of the font,
4839 SIZE is the pixelsize of the font,
4840 HEIGHT is the pixel-height of the font (i.e ascent + descent),
4841 BASELINE-OFFSET is the upward offset pixels from ASCII baseline,
4842 RELATIVE-COMPOSE and DEFAULT-ASCENT are the numbers controlling
4843 how to compose characters.
4844 If the named font is not yet loaded, return nil. */)
4845 (Lisp_Object name, Lisp_Object frame)
4847 FRAME_PTR f;
4848 struct font *font;
4849 Lisp_Object info;
4850 Lisp_Object font_object;
4852 (*check_window_system_func) ();
4854 if (! FONTP (name))
4855 CHECK_STRING (name);
4856 if (NILP (frame))
4857 frame = selected_frame;
4858 CHECK_LIVE_FRAME (frame);
4859 f = XFRAME (frame);
4861 if (STRINGP (name))
4863 int fontset = fs_query_fontset (name, 0);
4865 if (fontset >= 0)
4866 name = fontset_ascii (fontset);
4867 font_object = font_open_by_name (f, SSDATA (name));
4869 else if (FONT_OBJECT_P (name))
4870 font_object = name;
4871 else if (FONT_ENTITY_P (name))
4872 font_object = font_open_entity (f, name, 0);
4873 else
4875 struct face *face = FACE_FROM_ID (f, DEFAULT_FACE_ID);
4876 Lisp_Object entity = font_matching_entity (f, face->lface, name);
4878 font_object = ! NILP (entity) ? font_open_entity (f, entity, 0) : Qnil;
4880 if (NILP (font_object))
4881 return Qnil;
4882 font = XFONT_OBJECT (font_object);
4884 info = Fmake_vector (make_number (7), Qnil);
4885 XVECTOR (info)->contents[0] = AREF (font_object, FONT_NAME_INDEX);
4886 XVECTOR (info)->contents[1] = AREF (font_object, FONT_FULLNAME_INDEX);
4887 XVECTOR (info)->contents[2] = make_number (font->pixel_size);
4888 XVECTOR (info)->contents[3] = make_number (font->height);
4889 XVECTOR (info)->contents[4] = make_number (font->baseline_offset);
4890 XVECTOR (info)->contents[5] = make_number (font->relative_compose);
4891 XVECTOR (info)->contents[6] = make_number (font->default_ascent);
4893 #if 0
4894 /* As font_object is still in FONT_OBJLIST of the entity, we can't
4895 close it now. Perhaps, we should manage font-objects
4896 by `reference-count'. */
4897 font_close_object (f, font_object);
4898 #endif
4899 return info;
4901 #endif
4904 #define BUILD_STYLE_TABLE(TBL) \
4905 build_style_table ((TBL), sizeof TBL / sizeof (struct table_entry))
4907 static Lisp_Object
4908 build_style_table (const struct table_entry *entry, int nelement)
4910 int i, j;
4911 Lisp_Object table, elt;
4913 table = Fmake_vector (make_number (nelement), Qnil);
4914 for (i = 0; i < nelement; i++)
4916 for (j = 0; entry[i].names[j]; j++);
4917 elt = Fmake_vector (make_number (j + 1), Qnil);
4918 ASET (elt, 0, make_number (entry[i].numeric));
4919 for (j = 0; entry[i].names[j]; j++)
4920 ASET (elt, j + 1, intern_c_string (entry[i].names[j]));
4921 ASET (table, i, elt);
4923 return table;
4926 /* The deferred font-log data of the form [ACTION ARG RESULT].
4927 If ACTION is not nil, that is added to the log when font_add_log is
4928 called next time. At that time, ACTION is set back to nil. */
4929 static Lisp_Object Vfont_log_deferred;
4931 /* Prepend the font-related logging data in Vfont_log if it is not
4932 `t'. ACTION describes a kind of font-related action (e.g. listing,
4933 opening), ARG is the argument for the action, and RESULT is the
4934 result of the action. */
4935 void
4936 font_add_log (const char *action, Lisp_Object arg, Lisp_Object result)
4938 Lisp_Object val;
4939 int i;
4941 if (EQ (Vfont_log, Qt))
4942 return;
4943 if (STRINGP (AREF (Vfont_log_deferred, 0)))
4945 char *str = SSDATA (AREF (Vfont_log_deferred, 0));
4947 ASET (Vfont_log_deferred, 0, Qnil);
4948 font_add_log (str, AREF (Vfont_log_deferred, 1),
4949 AREF (Vfont_log_deferred, 2));
4952 if (FONTP (arg))
4954 Lisp_Object tail, elt;
4955 Lisp_Object equalstr = build_string ("=");
4957 val = Ffont_xlfd_name (arg, Qt);
4958 for (tail = AREF (arg, FONT_EXTRA_INDEX); CONSP (tail);
4959 tail = XCDR (tail))
4961 elt = XCAR (tail);
4962 if (EQ (XCAR (elt), QCscript)
4963 && SYMBOLP (XCDR (elt)))
4964 val = concat3 (val, SYMBOL_NAME (QCscript),
4965 concat2 (equalstr, SYMBOL_NAME (XCDR (elt))));
4966 else if (EQ (XCAR (elt), QClang)
4967 && SYMBOLP (XCDR (elt)))
4968 val = concat3 (val, SYMBOL_NAME (QClang),
4969 concat2 (equalstr, SYMBOL_NAME (XCDR (elt))));
4970 else if (EQ (XCAR (elt), QCotf)
4971 && CONSP (XCDR (elt)) && SYMBOLP (XCAR (XCDR (elt))))
4972 val = concat3 (val, SYMBOL_NAME (QCotf),
4973 concat2 (equalstr,
4974 SYMBOL_NAME (XCAR (XCDR (elt)))));
4976 arg = val;
4979 if (CONSP (result)
4980 && VECTORP (XCAR (result))
4981 && ASIZE (XCAR (result)) > 0
4982 && FONTP (AREF (XCAR (result), 0)))
4983 result = font_vconcat_entity_vectors (result);
4984 if (FONTP (result))
4986 val = Ffont_xlfd_name (result, Qt);
4987 if (! FONT_SPEC_P (result))
4988 val = concat3 (SYMBOL_NAME (AREF (result, FONT_TYPE_INDEX)),
4989 build_string (":"), val);
4990 result = val;
4992 else if (CONSP (result))
4994 Lisp_Object tail;
4995 result = Fcopy_sequence (result);
4996 for (tail = result; CONSP (tail); tail = XCDR (tail))
4998 val = XCAR (tail);
4999 if (FONTP (val))
5000 val = Ffont_xlfd_name (val, Qt);
5001 XSETCAR (tail, val);
5004 else if (VECTORP (result))
5006 result = Fcopy_sequence (result);
5007 for (i = 0; i < ASIZE (result); i++)
5009 val = AREF (result, i);
5010 if (FONTP (val))
5011 val = Ffont_xlfd_name (val, Qt);
5012 ASET (result, i, val);
5015 Vfont_log = Fcons (list3 (intern (action), arg, result), Vfont_log);
5018 /* Record a font-related logging data to be added to Vfont_log when
5019 font_add_log is called next time. ACTION, ARG, RESULT are the same
5020 as font_add_log. */
5022 void
5023 font_deferred_log (const char *action, Lisp_Object arg, Lisp_Object result)
5025 if (EQ (Vfont_log, Qt))
5026 return;
5027 ASET (Vfont_log_deferred, 0, build_string (action));
5028 ASET (Vfont_log_deferred, 1, arg);
5029 ASET (Vfont_log_deferred, 2, result);
5032 void
5033 syms_of_font (void)
5035 sort_shift_bits[FONT_TYPE_INDEX] = 0;
5036 sort_shift_bits[FONT_SLANT_INDEX] = 2;
5037 sort_shift_bits[FONT_WEIGHT_INDEX] = 9;
5038 sort_shift_bits[FONT_SIZE_INDEX] = 16;
5039 sort_shift_bits[FONT_WIDTH_INDEX] = 23;
5040 /* Note that the other elements in sort_shift_bits are not used. */
5042 staticpro (&font_charset_alist);
5043 font_charset_alist = Qnil;
5045 DEFSYM (Qopentype, "opentype");
5047 DEFSYM (Qascii_0, "ascii-0");
5048 DEFSYM (Qiso8859_1, "iso8859-1");
5049 DEFSYM (Qiso10646_1, "iso10646-1");
5050 DEFSYM (Qunicode_bmp, "unicode-bmp");
5051 DEFSYM (Qunicode_sip, "unicode-sip");
5053 DEFSYM (QCf, "Cf");
5055 DEFSYM (QCotf, ":otf");
5056 DEFSYM (QClang, ":lang");
5057 DEFSYM (QCscript, ":script");
5058 DEFSYM (QCantialias, ":antialias");
5060 DEFSYM (QCfoundry, ":foundry");
5061 DEFSYM (QCadstyle, ":adstyle");
5062 DEFSYM (QCregistry, ":registry");
5063 DEFSYM (QCspacing, ":spacing");
5064 DEFSYM (QCdpi, ":dpi");
5065 DEFSYM (QCscalable, ":scalable");
5066 DEFSYM (QCavgwidth, ":avgwidth");
5067 DEFSYM (QCfont_entity, ":font-entity");
5068 DEFSYM (QCfc_unknown_spec, ":fc-unknown-spec");
5070 DEFSYM (Qc, "c");
5071 DEFSYM (Qm, "m");
5072 DEFSYM (Qp, "p");
5073 DEFSYM (Qd, "d");
5075 DEFSYM (Qja, "ja");
5076 DEFSYM (Qko, "ko");
5078 DEFSYM (QCuser_spec, "user-spec");
5080 staticpro (&null_vector);
5081 null_vector = Fmake_vector (make_number (0), Qnil);
5083 staticpro (&scratch_font_spec);
5084 scratch_font_spec = Ffont_spec (0, NULL);
5085 staticpro (&scratch_font_prefer);
5086 scratch_font_prefer = Ffont_spec (0, NULL);
5088 staticpro (&Vfont_log_deferred);
5089 Vfont_log_deferred = Fmake_vector (make_number (3), Qnil);
5091 #if 0
5092 #ifdef HAVE_LIBOTF
5093 staticpro (&otf_list);
5094 otf_list = Qnil;
5095 #endif /* HAVE_LIBOTF */
5096 #endif /* 0 */
5098 defsubr (&Sfontp);
5099 defsubr (&Sfont_spec);
5100 defsubr (&Sfont_get);
5101 #ifdef HAVE_WINDOW_SYSTEM
5102 defsubr (&Sfont_face_attributes);
5103 #endif
5104 defsubr (&Sfont_put);
5105 defsubr (&Slist_fonts);
5106 defsubr (&Sfont_family_list);
5107 defsubr (&Sfind_font);
5108 defsubr (&Sfont_xlfd_name);
5109 defsubr (&Sclear_font_cache);
5110 defsubr (&Sfont_shape_gstring);
5111 defsubr (&Sfont_variation_glyphs);
5112 #if 0
5113 defsubr (&Sfont_drive_otf);
5114 defsubr (&Sfont_otf_alternates);
5115 #endif /* 0 */
5117 #ifdef FONT_DEBUG
5118 defsubr (&Sopen_font);
5119 defsubr (&Sclose_font);
5120 defsubr (&Squery_font);
5121 defsubr (&Sfont_get_glyphs);
5122 defsubr (&Sfont_match_p);
5123 defsubr (&Sfont_at);
5124 #if 0
5125 defsubr (&Sdraw_string);
5126 #endif
5127 #endif /* FONT_DEBUG */
5128 #ifdef HAVE_WINDOW_SYSTEM
5129 defsubr (&Sfont_info);
5130 #endif
5132 DEFVAR_LISP ("font-encoding-alist", Vfont_encoding_alist,
5133 doc: /*
5134 Alist of fontname patterns vs the corresponding encoding and repertory info.
5135 Each element looks like (REGEXP . (ENCODING . REPERTORY)),
5136 where ENCODING is a charset or a char-table,
5137 and REPERTORY is a charset, a char-table, or nil.
5139 If ENCODING and REPERTORY are the same, the element can have the form
5140 \(REGEXP . ENCODING).
5142 ENCODING is for converting a character to a glyph code of the font.
5143 If ENCODING is a charset, encoding a character by the charset gives
5144 the corresponding glyph code. If ENCODING is a char-table, looking up
5145 the table by a character gives the corresponding glyph code.
5147 REPERTORY specifies a repertory of characters supported by the font.
5148 If REPERTORY is a charset, all characters beloging to the charset are
5149 supported. If REPERTORY is a char-table, all characters who have a
5150 non-nil value in the table are supported. If REPERTORY is nil, Emacs
5151 gets the repertory information by an opened font and ENCODING. */);
5152 Vfont_encoding_alist = Qnil;
5154 /* FIXME: These 3 vars are not quite what they appear: setq on them
5155 won't have any effect other than disconnect them from the style
5156 table used by the font display code. So we make them read-only,
5157 to avoid this confusing situation. */
5159 DEFVAR_LISP_NOPRO ("font-weight-table", Vfont_weight_table,
5160 doc: /* Vector of valid font weight values.
5161 Each element has the form:
5162 [NUMERIC-VALUE SYMBOLIC-NAME ALIAS-NAME ...]
5163 NUMERIC-VALUE is an integer, and SYMBOLIC-NAME and ALIAS-NAME are symbols. */);
5164 Vfont_weight_table = BUILD_STYLE_TABLE (weight_table);
5165 XSYMBOL (intern_c_string ("font-weight-table"))->constant = 1;
5167 DEFVAR_LISP_NOPRO ("font-slant-table", Vfont_slant_table,
5168 doc: /* Vector of font slant symbols vs the corresponding numeric values.
5169 See `font-weight-table' for the format of the vector. */);
5170 Vfont_slant_table = BUILD_STYLE_TABLE (slant_table);
5171 XSYMBOL (intern_c_string ("font-slant-table"))->constant = 1;
5173 DEFVAR_LISP_NOPRO ("font-width-table", Vfont_width_table,
5174 doc: /* Alist of font width symbols vs the corresponding numeric values.
5175 See `font-weight-table' for the format of the vector. */);
5176 Vfont_width_table = BUILD_STYLE_TABLE (width_table);
5177 XSYMBOL (intern_c_string ("font-width-table"))->constant = 1;
5179 staticpro (&font_style_table);
5180 font_style_table = Fmake_vector (make_number (3), Qnil);
5181 ASET (font_style_table, 0, Vfont_weight_table);
5182 ASET (font_style_table, 1, Vfont_slant_table);
5183 ASET (font_style_table, 2, Vfont_width_table);
5185 DEFVAR_LISP ("font-log", Vfont_log, doc: /*
5186 *Logging list of font related actions and results.
5187 The value t means to suppress the logging.
5188 The initial value is set to nil if the environment variable
5189 EMACS_FONT_LOG is set. Otherwise, it is set to t. */);
5190 Vfont_log = Qnil;
5192 #ifdef HAVE_WINDOW_SYSTEM
5193 #ifdef HAVE_FREETYPE
5194 syms_of_ftfont ();
5195 #ifdef HAVE_X_WINDOWS
5196 syms_of_xfont ();
5197 syms_of_ftxfont ();
5198 #ifdef HAVE_XFT
5199 syms_of_xftfont ();
5200 #endif /* HAVE_XFT */
5201 #endif /* HAVE_X_WINDOWS */
5202 #else /* not HAVE_FREETYPE */
5203 #ifdef HAVE_X_WINDOWS
5204 syms_of_xfont ();
5205 #endif /* HAVE_X_WINDOWS */
5206 #endif /* not HAVE_FREETYPE */
5207 #ifdef HAVE_BDFFONT
5208 syms_of_bdffont ();
5209 #endif /* HAVE_BDFFONT */
5210 #ifdef WINDOWSNT
5211 syms_of_w32font ();
5212 #endif /* WINDOWSNT */
5213 #ifdef HAVE_NS
5214 syms_of_nsfont ();
5215 #endif /* HAVE_NS */
5216 #endif /* HAVE_WINDOW_SYSTEM */
5219 void
5220 init_font (void)
5222 Vfont_log = egetenv ("EMACS_FONT_LOG") ? Qnil : Qt;