Merge.
[emacs.git] / src / font.c
blob1a4742ba9599a7a9e36c6bf9d59ea8a16ea7f0de
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 <float.h>
25 #include <stdio.h>
26 #include <ctype.h>
27 #include <setjmp.h>
29 #include "lisp.h"
30 #include "buffer.h"
31 #include "frame.h"
32 #include "window.h"
33 #include "dispextern.h"
34 #include "charset.h"
35 #include "character.h"
36 #include "composite.h"
37 #include "fontset.h"
38 #include "font.h"
40 #ifdef HAVE_X_WINDOWS
41 #include "xterm.h"
42 #endif /* HAVE_X_WINDOWS */
44 #ifdef HAVE_NTGUI
45 #include "w32term.h"
46 #endif /* HAVE_NTGUI */
48 #ifdef HAVE_NS
49 #include "nsterm.h"
50 #endif /* HAVE_NS */
52 Lisp_Object Qopentype;
54 /* Important character set strings. */
55 Lisp_Object Qascii_0, Qiso8859_1, Qiso10646_1, Qunicode_bmp, Qunicode_sip;
57 #define DEFAULT_ENCODING Qiso8859_1
59 /* Unicode category `Cf'. */
60 static Lisp_Object QCf;
62 /* Special vector of zero length. This is repeatedly used by (struct
63 font_driver *)->list when a specified font is not found. */
64 static Lisp_Object null_vector;
66 /* Vector of Vfont_weight_table, Vfont_slant_table, and Vfont_width_table. */
67 static Lisp_Object font_style_table;
69 /* Structure used for tables mapping weight, slant, and width numeric
70 values and their names. */
72 struct table_entry
74 int numeric;
75 /* The first one is a valid name as a face attribute.
76 The second one (if any) is a typical name in XLFD field. */
77 const char *names[5];
80 /* Table of weight numeric values and their names. This table must be
81 sorted by numeric values in ascending order. */
83 static const struct table_entry weight_table[] =
85 { 0, { "thin" }},
86 { 20, { "ultra-light", "ultralight" }},
87 { 40, { "extra-light", "extralight" }},
88 { 50, { "light" }},
89 { 75, { "semi-light", "semilight", "demilight", "book" }},
90 { 100, { "normal", "medium", "regular", "unspecified" }},
91 { 180, { "semi-bold", "semibold", "demibold", "demi" }},
92 { 200, { "bold" }},
93 { 205, { "extra-bold", "extrabold" }},
94 { 210, { "ultra-bold", "ultrabold", "black" }}
97 /* Table of slant numeric values and their names. This table must be
98 sorted by numeric values in ascending order. */
100 static const struct table_entry slant_table[] =
102 { 0, { "reverse-oblique", "ro" }},
103 { 10, { "reverse-italic", "ri" }},
104 { 100, { "normal", "r", "unspecified" }},
105 { 200, { "italic" ,"i", "ot" }},
106 { 210, { "oblique", "o" }}
109 /* Table of width numeric values and their names. This table must be
110 sorted by numeric values in ascending order. */
112 static const struct table_entry width_table[] =
114 { 50, { "ultra-condensed", "ultracondensed" }},
115 { 63, { "extra-condensed", "extracondensed" }},
116 { 75, { "condensed", "compressed", "narrow" }},
117 { 87, { "semi-condensed", "semicondensed", "demicondensed" }},
118 { 100, { "normal", "medium", "regular", "unspecified" }},
119 { 113, { "semi-expanded", "semiexpanded", "demiexpanded" }},
120 { 125, { "expanded" }},
121 { 150, { "extra-expanded", "extraexpanded" }},
122 { 200, { "ultra-expanded", "ultraexpanded", "wide" }}
125 Lisp_Object QCfoundry;
126 static Lisp_Object QCadstyle, QCregistry;
127 /* Symbols representing keys of font extra info. */
128 Lisp_Object QCspacing, QCdpi, QCscalable, QCotf, QClang, QCscript, QCavgwidth;
129 Lisp_Object QCantialias, QCfont_entity;
130 static Lisp_Object QCfc_unknown_spec;
131 /* Symbols representing values of font spacing property. */
132 static Lisp_Object Qc, Qm, Qd;
133 Lisp_Object Qp;
134 /* Special ADSTYLE properties to avoid fonts used for Latin
135 characters; used in xfont.c and ftfont.c. */
136 Lisp_Object Qja, Qko;
138 static Lisp_Object QCuser_spec;
140 /* Alist of font registry symbols and the corresponding charset
141 information. The information is retrieved from
142 Vfont_encoding_alist on demand.
144 Eash element has the form:
145 (REGISTRY . (ENCODING-CHARSET-ID . REPERTORY-CHARSET-ID))
147 (REGISTRY . nil)
149 In the former form, ENCODING-CHARSET-ID is an ID of a charset that
150 encodes a character code to a glyph code of a font, and
151 REPERTORY-CHARSET-ID is an ID of a charset that tells if a
152 character is supported by a font.
154 The latter form means that the information for REGISTRY couldn't be
155 retrieved. */
156 static Lisp_Object font_charset_alist;
158 /* List of all font drivers. Each font-backend (XXXfont.c) calls
159 register_font_driver in syms_of_XXXfont to register its font-driver
160 here. */
161 static struct font_driver_list *font_driver_list;
165 /* Creaters of font-related Lisp object. */
167 static Lisp_Object
168 font_make_spec (void)
170 Lisp_Object font_spec;
171 struct font_spec *spec
172 = ((struct font_spec *)
173 allocate_pseudovector (VECSIZE (struct font_spec),
174 FONT_SPEC_MAX, PVEC_FONT));
175 XSETFONT (font_spec, spec);
176 return font_spec;
179 Lisp_Object
180 font_make_entity (void)
182 Lisp_Object font_entity;
183 struct font_entity *entity
184 = ((struct font_entity *)
185 allocate_pseudovector (VECSIZE (struct font_entity),
186 FONT_ENTITY_MAX, PVEC_FONT));
187 XSETFONT (font_entity, entity);
188 return font_entity;
191 /* Create a font-object whose structure size is SIZE. If ENTITY is
192 not nil, copy properties from ENTITY to the font-object. If
193 PIXELSIZE is positive, set the `size' property to PIXELSIZE. */
194 Lisp_Object
195 font_make_object (int size, Lisp_Object entity, int pixelsize)
197 Lisp_Object font_object;
198 struct font *font
199 = (struct font *) allocate_pseudovector (size, FONT_OBJECT_MAX, PVEC_FONT);
200 int i;
202 XSETFONT (font_object, font);
204 if (! NILP (entity))
206 for (i = 1; i < FONT_SPEC_MAX; i++)
207 font->props[i] = AREF (entity, i);
208 if (! NILP (AREF (entity, FONT_EXTRA_INDEX)))
209 font->props[FONT_EXTRA_INDEX]
210 = Fcopy_alist (AREF (entity, FONT_EXTRA_INDEX));
212 if (size > 0)
213 font->props[FONT_SIZE_INDEX] = make_number (pixelsize);
214 return font_object;
219 static int font_pixel_size (FRAME_PTR f, Lisp_Object);
220 static Lisp_Object font_open_entity (FRAME_PTR, Lisp_Object, int);
221 static Lisp_Object font_matching_entity (FRAME_PTR, Lisp_Object *,
222 Lisp_Object);
223 static unsigned font_encode_char (Lisp_Object, int);
225 /* Number of registered font drivers. */
226 static int num_font_drivers;
229 /* Return a Lispy value of a font property value at STR and LEN bytes.
230 If STR is "*", return nil.
231 If FORCE_SYMBOL is zero and all characters in STR are digits,
232 return an integer. Otherwise, return a symbol interned from
233 STR. */
235 Lisp_Object
236 font_intern_prop (const char *str, ptrdiff_t len, int force_symbol)
238 ptrdiff_t i;
239 Lisp_Object tem;
240 Lisp_Object obarray;
241 EMACS_INT nbytes, nchars;
243 if (len == 1 && *str == '*')
244 return Qnil;
245 if (!force_symbol && 0 < len && '0' <= *str && *str <= '9')
247 for (i = 1; i < len; i++)
248 if (! ('0' <= str[i] && str[i] <= '9'))
249 break;
250 if (i == len)
252 EMACS_INT n;
254 i = 0;
255 for (n = 0; (n += str[i++] - '0') <= MOST_POSITIVE_FIXNUM; n *= 10)
257 if (i == len)
258 return make_number (n);
259 if (MOST_POSITIVE_FIXNUM / 10 < n)
260 break;
263 xsignal1 (Qoverflow_error, make_string (str, len));
267 /* The following code is copied from the function intern (in
268 lread.c), and modified to suit our purpose. */
269 obarray = Vobarray;
270 if (!VECTORP (obarray) || ASIZE (obarray) == 0)
271 obarray = check_obarray (obarray);
272 parse_str_as_multibyte ((unsigned char *) str, len, &nchars, &nbytes);
273 if (len == nchars || len != nbytes)
274 /* CONTENTS contains no multibyte sequences or contains an invalid
275 multibyte sequence. We'll make a unibyte string. */
276 tem = oblookup (obarray, str, len, len);
277 else
278 tem = oblookup (obarray, str, nchars, len);
279 if (SYMBOLP (tem))
280 return tem;
281 if (len == nchars || len != nbytes)
282 tem = make_unibyte_string (str, len);
283 else
284 tem = make_multibyte_string (str, nchars, len);
285 return Fintern (tem, obarray);
288 /* Return a pixel size of font-spec SPEC on frame F. */
290 static int
291 font_pixel_size (FRAME_PTR f, Lisp_Object spec)
293 #ifdef HAVE_WINDOW_SYSTEM
294 Lisp_Object size = AREF (spec, FONT_SIZE_INDEX);
295 double point_size;
296 int dpi, pixel_size;
297 Lisp_Object val;
299 if (INTEGERP (size))
300 return XINT (size);
301 if (NILP (size))
302 return 0;
303 font_assert (FLOATP (size));
304 point_size = XFLOAT_DATA (size);
305 val = AREF (spec, FONT_DPI_INDEX);
306 if (INTEGERP (val))
307 dpi = XINT (val);
308 else
309 dpi = f->resy;
310 pixel_size = POINT_TO_PIXEL (point_size, dpi);
311 return pixel_size;
312 #else
313 return 1;
314 #endif
318 /* Return a value of PROP's VAL (symbol or integer) to be stored in a
319 font vector. If VAL is not valid (i.e. not registered in
320 font_style_table), return -1 if NOERROR is zero, and return a
321 proper index if NOERROR is nonzero. In that case, register VAL in
322 font_style_table if VAL is a symbol, and return the closest index if
323 VAL is an integer. */
326 font_style_to_value (enum font_property_index prop, Lisp_Object val, int noerror)
328 Lisp_Object table = AREF (font_style_table, prop - FONT_WEIGHT_INDEX);
329 int len = ASIZE (table);
331 if (SYMBOLP (val))
333 int i, j;
334 char *s;
335 Lisp_Object args[2], elt;
337 /* At first try exact match. */
338 for (i = 0; i < len; i++)
339 for (j = 1; j < ASIZE (AREF (table, i)); j++)
340 if (EQ (val, AREF (AREF (table, i), j)))
341 return ((XINT (AREF (AREF (table, i), 0)) << 8)
342 | (i << 4) | (j - 1));
343 /* Try also with case-folding match. */
344 s = SSDATA (SYMBOL_NAME (val));
345 for (i = 0; i < len; i++)
346 for (j = 1; j < ASIZE (AREF (table, i)); j++)
348 elt = AREF (AREF (table, i), j);
349 if (xstrcasecmp (s, SSDATA (SYMBOL_NAME (elt))) == 0)
350 return ((XINT (AREF (AREF (table, i), 0)) << 8)
351 | (i << 4) | (j - 1));
353 if (! noerror)
354 return -1;
355 if (len == 255)
356 abort ();
357 elt = Fmake_vector (make_number (2), make_number (100));
358 ASET (elt, 1, val);
359 args[0] = table;
360 args[1] = Fmake_vector (make_number (1), elt);
361 ASET (font_style_table, prop - FONT_WEIGHT_INDEX, Fvconcat (2, args));
362 return (100 << 8) | (i << 4);
364 else
366 int i, last_n;
367 int numeric = XINT (val);
369 for (i = 0, last_n = -1; i < len; i++)
371 int n = XINT (AREF (AREF (table, i), 0));
373 if (numeric == n)
374 return (n << 8) | (i << 4);
375 if (numeric < n)
377 if (! noerror)
378 return -1;
379 return ((i == 0 || n - numeric < numeric - last_n)
380 ? (n << 8) | (i << 4): (last_n << 8 | ((i - 1) << 4)));
382 last_n = n;
384 if (! noerror)
385 return -1;
386 return ((last_n << 8) | ((i - 1) << 4));
390 Lisp_Object
391 font_style_symbolic (Lisp_Object font, enum font_property_index prop, int for_face)
393 Lisp_Object val = AREF (font, prop);
394 Lisp_Object table, elt;
395 int i;
397 if (NILP (val))
398 return Qnil;
399 table = AREF (font_style_table, prop - FONT_WEIGHT_INDEX);
400 i = XINT (val) & 0xFF;
401 font_assert (((i >> 4) & 0xF) < ASIZE (table));
402 elt = AREF (table, ((i >> 4) & 0xF));
403 font_assert ((i & 0xF) + 1 < ASIZE (elt));
404 return (for_face ? AREF (elt, 1) : AREF (elt, (i & 0xF) + 1));
407 /* Return ENCODING or a cons of ENCODING and REPERTORY of the font
408 FONTNAME. ENCODING is a charset symbol that specifies the encoding
409 of the font. REPERTORY is a charset symbol or nil. */
411 Lisp_Object
412 find_font_encoding (Lisp_Object fontname)
414 Lisp_Object tail, elt;
416 for (tail = Vfont_encoding_alist; CONSP (tail); tail = XCDR (tail))
418 elt = XCAR (tail);
419 if (CONSP (elt)
420 && STRINGP (XCAR (elt))
421 && fast_string_match_ignore_case (XCAR (elt), fontname) >= 0
422 && (SYMBOLP (XCDR (elt))
423 ? CHARSETP (XCDR (elt))
424 : CONSP (XCDR (elt)) && CHARSETP (XCAR (XCDR (elt)))))
425 return (XCDR (elt));
427 return Qnil;
430 /* Return encoding charset and repertory charset for REGISTRY in
431 ENCODING and REPERTORY correspondingly. If correct information for
432 REGISTRY is available, return 0. Otherwise return -1. */
435 font_registry_charsets (Lisp_Object registry, struct charset **encoding, struct charset **repertory)
437 Lisp_Object val;
438 int encoding_id, repertory_id;
440 val = Fassoc_string (registry, font_charset_alist, Qt);
441 if (! NILP (val))
443 val = XCDR (val);
444 if (NILP (val))
445 return -1;
446 encoding_id = XINT (XCAR (val));
447 repertory_id = XINT (XCDR (val));
449 else
451 val = find_font_encoding (SYMBOL_NAME (registry));
452 if (SYMBOLP (val) && CHARSETP (val))
454 encoding_id = repertory_id = XINT (CHARSET_SYMBOL_ID (val));
456 else if (CONSP (val))
458 if (! CHARSETP (XCAR (val)))
459 goto invalid_entry;
460 encoding_id = XINT (CHARSET_SYMBOL_ID (XCAR (val)));
461 if (NILP (XCDR (val)))
462 repertory_id = -1;
463 else
465 if (! CHARSETP (XCDR (val)))
466 goto invalid_entry;
467 repertory_id = XINT (CHARSET_SYMBOL_ID (XCDR (val)));
470 else
471 goto invalid_entry;
472 val = Fcons (make_number (encoding_id), make_number (repertory_id));
473 font_charset_alist
474 = nconc2 (font_charset_alist, Fcons (Fcons (registry, val), Qnil));
477 if (encoding)
478 *encoding = CHARSET_FROM_ID (encoding_id);
479 if (repertory)
480 *repertory = repertory_id >= 0 ? CHARSET_FROM_ID (repertory_id) : NULL;
481 return 0;
483 invalid_entry:
484 font_charset_alist
485 = nconc2 (font_charset_alist, Fcons (Fcons (registry, Qnil), Qnil));
486 return -1;
490 /* Font property value validators. See the comment of
491 font_property_table for the meaning of the arguments. */
493 static Lisp_Object font_prop_validate (int, Lisp_Object, Lisp_Object);
494 static Lisp_Object font_prop_validate_symbol (Lisp_Object, Lisp_Object);
495 static Lisp_Object font_prop_validate_style (Lisp_Object, Lisp_Object);
496 static Lisp_Object font_prop_validate_non_neg (Lisp_Object, Lisp_Object);
497 static Lisp_Object font_prop_validate_spacing (Lisp_Object, Lisp_Object);
498 static int get_font_prop_index (Lisp_Object);
500 static Lisp_Object
501 font_prop_validate_symbol (Lisp_Object prop, Lisp_Object val)
503 if (STRINGP (val))
504 val = Fintern (val, Qnil);
505 if (! SYMBOLP (val))
506 val = Qerror;
507 else if (EQ (prop, QCregistry))
508 val = Fintern (Fdowncase (SYMBOL_NAME (val)), Qnil);
509 return val;
513 static Lisp_Object
514 font_prop_validate_style (Lisp_Object style, Lisp_Object val)
516 enum font_property_index prop = (EQ (style, QCweight) ? FONT_WEIGHT_INDEX
517 : EQ (style, QCslant) ? FONT_SLANT_INDEX
518 : FONT_WIDTH_INDEX);
519 if (INTEGERP (val))
521 int n = XINT (val);
522 if (((n >> 4) & 0xF)
523 >= ASIZE (AREF (font_style_table, prop - FONT_WEIGHT_INDEX)))
524 val = Qerror;
525 else
527 Lisp_Object elt = AREF (AREF (font_style_table, prop - FONT_WEIGHT_INDEX), (n >> 4) & 0xF);
529 if ((n & 0xF) + 1 >= ASIZE (elt))
530 val = Qerror;
531 else if (XINT (AREF (elt, 0)) != (n >> 8))
532 val = Qerror;
535 else if (SYMBOLP (val))
537 int n = font_style_to_value (prop, val, 0);
539 val = n >= 0 ? make_number (n) : Qerror;
541 else
542 val = Qerror;
543 return val;
546 static Lisp_Object
547 font_prop_validate_non_neg (Lisp_Object prop, Lisp_Object val)
549 return (NATNUMP (val) || (FLOATP (val) && XFLOAT_DATA (val) >= 0)
550 ? val : Qerror);
553 static Lisp_Object
554 font_prop_validate_spacing (Lisp_Object prop, Lisp_Object val)
556 if (NILP (val) || (NATNUMP (val) && XINT (val) <= FONT_SPACING_CHARCELL))
557 return val;
558 if (SYMBOLP (val) && SBYTES (SYMBOL_NAME (val)) == 1)
560 char spacing = SDATA (SYMBOL_NAME (val))[0];
562 if (spacing == 'c' || spacing == 'C')
563 return make_number (FONT_SPACING_CHARCELL);
564 if (spacing == 'm' || spacing == 'M')
565 return make_number (FONT_SPACING_MONO);
566 if (spacing == 'p' || spacing == 'P')
567 return make_number (FONT_SPACING_PROPORTIONAL);
568 if (spacing == 'd' || spacing == 'D')
569 return make_number (FONT_SPACING_DUAL);
571 return Qerror;
574 static Lisp_Object
575 font_prop_validate_otf (Lisp_Object prop, Lisp_Object val)
577 Lisp_Object tail, tmp;
578 int i;
580 /* VAL = (SCRIPT [ LANGSYS [ GSUB-FEATURES [ GPOS-FEATURES ]]])
581 GSUB-FEATURES = (FEATURE ... [ nil FEATURE ... ]) | nil
582 GPOS-FEATURES = (FEATURE ... [ nil FEATURE ... ]) | nil */
583 if (! CONSP (val))
584 return Qerror;
585 if (! SYMBOLP (XCAR (val)))
586 return Qerror;
587 tail = XCDR (val);
588 if (NILP (tail))
589 return val;
590 if (! CONSP (tail) || ! SYMBOLP (XCAR (val)))
591 return Qerror;
592 for (i = 0; i < 2; i++)
594 tail = XCDR (tail);
595 if (NILP (tail))
596 return val;
597 if (! CONSP (tail))
598 return Qerror;
599 for (tmp = XCAR (tail); CONSP (tmp); tmp = XCDR (tmp))
600 if (! SYMBOLP (XCAR (tmp)))
601 return Qerror;
602 if (! NILP (tmp))
603 return Qerror;
605 return val;
608 /* Structure of known font property keys and validator of the
609 values. */
610 static const struct
612 /* Pointer to the key symbol. */
613 Lisp_Object *key;
614 /* Function to validate PROP's value VAL, or NULL if any value is
615 ok. The value is VAL or its regularized value if VAL is valid,
616 and Qerror if not. */
617 Lisp_Object (*validater) (Lisp_Object prop, Lisp_Object val);
618 } font_property_table[] =
619 { { &QCtype, font_prop_validate_symbol },
620 { &QCfoundry, font_prop_validate_symbol },
621 { &QCfamily, font_prop_validate_symbol },
622 { &QCadstyle, font_prop_validate_symbol },
623 { &QCregistry, font_prop_validate_symbol },
624 { &QCweight, font_prop_validate_style },
625 { &QCslant, font_prop_validate_style },
626 { &QCwidth, font_prop_validate_style },
627 { &QCsize, font_prop_validate_non_neg },
628 { &QCdpi, font_prop_validate_non_neg },
629 { &QCspacing, font_prop_validate_spacing },
630 { &QCavgwidth, font_prop_validate_non_neg },
631 /* The order of the above entries must match with enum
632 font_property_index. */
633 { &QClang, font_prop_validate_symbol },
634 { &QCscript, font_prop_validate_symbol },
635 { &QCotf, font_prop_validate_otf }
638 /* Size (number of elements) of the above table. */
639 #define FONT_PROPERTY_TABLE_SIZE \
640 ((sizeof font_property_table) / (sizeof *font_property_table))
642 /* Return an index number of font property KEY or -1 if KEY is not an
643 already known property. */
645 static int
646 get_font_prop_index (Lisp_Object key)
648 int i;
650 for (i = 0; i < FONT_PROPERTY_TABLE_SIZE; i++)
651 if (EQ (key, *font_property_table[i].key))
652 return i;
653 return -1;
656 /* Validate the font property. The property key is specified by the
657 symbol PROP, or the index IDX (if PROP is nil). If VAL is invalid,
658 signal an error. The value is VAL or the regularized one. */
660 static Lisp_Object
661 font_prop_validate (int idx, Lisp_Object prop, Lisp_Object val)
663 Lisp_Object validated;
665 if (NILP (val))
666 return val;
667 if (NILP (prop))
668 prop = *font_property_table[idx].key;
669 else
671 idx = get_font_prop_index (prop);
672 if (idx < 0)
673 return val;
675 validated = (font_property_table[idx].validater) (prop, val);
676 if (EQ (validated, Qerror))
677 signal_error ("invalid font property", Fcons (prop, val));
678 return validated;
682 /* Store VAL as a value of extra font property PROP in FONT while
683 keeping the sorting order. Don't check the validity of VAL. */
685 Lisp_Object
686 font_put_extra (Lisp_Object font, Lisp_Object prop, Lisp_Object val)
688 Lisp_Object extra = AREF (font, FONT_EXTRA_INDEX);
689 Lisp_Object slot = (NILP (extra) ? Qnil : assq_no_quit (prop, extra));
691 if (NILP (slot))
693 Lisp_Object prev = Qnil;
695 while (CONSP (extra)
696 && NILP (Fstring_lessp (prop, XCAR (XCAR (extra)))))
697 prev = extra, extra = XCDR (extra);
699 if (NILP (prev))
700 ASET (font, FONT_EXTRA_INDEX, Fcons (Fcons (prop, val), extra));
701 else
702 XSETCDR (prev, Fcons (Fcons (prop, val), extra));
704 return val;
706 XSETCDR (slot, val);
707 if (NILP (val))
708 ASET (font, FONT_EXTRA_INDEX, Fdelq (slot, extra));
709 return val;
713 /* Font name parser and unparser */
715 static int parse_matrix (const char *);
716 static int font_expand_wildcards (Lisp_Object *, int);
717 static int font_parse_name (char *, Lisp_Object);
719 /* An enumerator for each field of an XLFD font name. */
720 enum xlfd_field_index
722 XLFD_FOUNDRY_INDEX,
723 XLFD_FAMILY_INDEX,
724 XLFD_WEIGHT_INDEX,
725 XLFD_SLANT_INDEX,
726 XLFD_SWIDTH_INDEX,
727 XLFD_ADSTYLE_INDEX,
728 XLFD_PIXEL_INDEX,
729 XLFD_POINT_INDEX,
730 XLFD_RESX_INDEX,
731 XLFD_RESY_INDEX,
732 XLFD_SPACING_INDEX,
733 XLFD_AVGWIDTH_INDEX,
734 XLFD_REGISTRY_INDEX,
735 XLFD_ENCODING_INDEX,
736 XLFD_LAST_INDEX
739 /* An enumerator for mask bit corresponding to each XLFD field. */
740 enum xlfd_field_mask
742 XLFD_FOUNDRY_MASK = 0x0001,
743 XLFD_FAMILY_MASK = 0x0002,
744 XLFD_WEIGHT_MASK = 0x0004,
745 XLFD_SLANT_MASK = 0x0008,
746 XLFD_SWIDTH_MASK = 0x0010,
747 XLFD_ADSTYLE_MASK = 0x0020,
748 XLFD_PIXEL_MASK = 0x0040,
749 XLFD_POINT_MASK = 0x0080,
750 XLFD_RESX_MASK = 0x0100,
751 XLFD_RESY_MASK = 0x0200,
752 XLFD_SPACING_MASK = 0x0400,
753 XLFD_AVGWIDTH_MASK = 0x0800,
754 XLFD_REGISTRY_MASK = 0x1000,
755 XLFD_ENCODING_MASK = 0x2000
759 /* Parse P pointing to the pixel/point size field of the form
760 `[A B C D]' which specifies a transformation matrix:
762 A B 0
763 C D 0
764 0 0 1
766 by which all glyphs of the font are transformed. The spec says
767 that scalar value N for the pixel/point size is equivalent to:
768 A = N * resx/resy, B = C = 0, D = N.
770 Return the scalar value N if the form is valid. Otherwise return
771 -1. */
773 static int
774 parse_matrix (const char *p)
776 double matrix[4];
777 char *end;
778 int i;
780 for (i = 0, p++; i < 4 && *p && *p != ']'; i++)
782 if (*p == '~')
783 matrix[i] = - strtod (p + 1, &end);
784 else
785 matrix[i] = strtod (p, &end);
786 p = end;
788 return (i == 4 ? (int) matrix[3] : -1);
791 /* Expand a wildcard field in FIELD (the first N fields are filled) to
792 multiple fields to fill in all 14 XLFD fields while restricting a
793 field position by its contents. */
795 static int
796 font_expand_wildcards (Lisp_Object *field, int n)
798 /* Copy of FIELD. */
799 Lisp_Object tmp[XLFD_LAST_INDEX];
800 /* Array of information about where this element can go. Nth
801 element is for Nth element of FIELD. */
802 struct {
803 /* Minimum possible field. */
804 int from;
805 /* Maxinum possible field. */
806 int to;
807 /* Bit mask of possible field. Nth bit corresponds to Nth field. */
808 int mask;
809 } range[XLFD_LAST_INDEX];
810 int i, j;
811 int range_from, range_to;
812 unsigned range_mask;
814 #define XLFD_SYMBOL_MASK (XLFD_FOUNDRY_MASK | XLFD_FAMILY_MASK \
815 | XLFD_ADSTYLE_MASK | XLFD_REGISTRY_MASK)
816 #define XLFD_NULL_MASK (XLFD_FOUNDRY_MASK | XLFD_ADSTYLE_MASK)
817 #define XLFD_LARGENUM_MASK (XLFD_POINT_MASK | XLFD_RESX_MASK | XLFD_RESY_MASK \
818 | XLFD_AVGWIDTH_MASK)
819 #define XLFD_REGENC_MASK (XLFD_REGISTRY_MASK | XLFD_ENCODING_MASK)
821 /* Initialize RANGE_MASK for FIELD[0] which can be 0th to (14 - N)th
822 field. The value is shifted to left one bit by one in the
823 following loop. */
824 for (i = 0, range_mask = 0; i <= 14 - n; i++)
825 range_mask = (range_mask << 1) | 1;
827 /* The triplet RANGE_FROM, RANGE_TO, and RANGE_MASK is a
828 position-based retriction for FIELD[I]. */
829 for (i = 0, range_from = 0, range_to = 14 - n; i < n;
830 i++, range_from++, range_to++, range_mask <<= 1)
832 Lisp_Object val = field[i];
834 tmp[i] = val;
835 if (NILP (val))
837 /* Wildcard. */
838 range[i].from = range_from;
839 range[i].to = range_to;
840 range[i].mask = range_mask;
842 else
844 /* The triplet FROM, TO, and MASK is a value-based
845 retriction for FIELD[I]. */
846 int from, to;
847 unsigned mask;
849 if (INTEGERP (val))
851 int numeric = XINT (val);
853 if (i + 1 == n)
854 from = to = XLFD_ENCODING_INDEX,
855 mask = XLFD_ENCODING_MASK;
856 else if (numeric == 0)
857 from = XLFD_PIXEL_INDEX, to = XLFD_AVGWIDTH_INDEX,
858 mask = XLFD_PIXEL_MASK | XLFD_LARGENUM_MASK;
859 else if (numeric <= 48)
860 from = to = XLFD_PIXEL_INDEX,
861 mask = XLFD_PIXEL_MASK;
862 else
863 from = XLFD_POINT_INDEX, to = XLFD_AVGWIDTH_INDEX,
864 mask = XLFD_LARGENUM_MASK;
866 else if (SBYTES (SYMBOL_NAME (val)) == 0)
867 from = XLFD_FOUNDRY_INDEX, to = XLFD_ADSTYLE_INDEX,
868 mask = XLFD_NULL_MASK;
869 else if (i == 0)
870 from = to = XLFD_FOUNDRY_INDEX, mask = XLFD_FOUNDRY_MASK;
871 else if (i + 1 == n)
873 Lisp_Object name = SYMBOL_NAME (val);
875 if (SDATA (name)[SBYTES (name) - 1] == '*')
876 from = XLFD_REGISTRY_INDEX, to = XLFD_ENCODING_INDEX,
877 mask = XLFD_REGENC_MASK;
878 else
879 from = to = XLFD_ENCODING_INDEX,
880 mask = XLFD_ENCODING_MASK;
882 else if (range_from <= XLFD_WEIGHT_INDEX
883 && range_to >= XLFD_WEIGHT_INDEX
884 && FONT_WEIGHT_NAME_NUMERIC (val) >= 0)
885 from = to = XLFD_WEIGHT_INDEX, mask = XLFD_WEIGHT_MASK;
886 else if (range_from <= XLFD_SLANT_INDEX
887 && range_to >= XLFD_SLANT_INDEX
888 && FONT_SLANT_NAME_NUMERIC (val) >= 0)
889 from = to = XLFD_SLANT_INDEX, mask = XLFD_SLANT_MASK;
890 else if (range_from <= XLFD_SWIDTH_INDEX
891 && range_to >= XLFD_SWIDTH_INDEX
892 && FONT_WIDTH_NAME_NUMERIC (val) >= 0)
893 from = to = XLFD_SWIDTH_INDEX, mask = XLFD_SWIDTH_MASK;
894 else
896 if (EQ (val, Qc) || EQ (val, Qm) || EQ (val, Qp) || EQ (val, Qd))
897 from = to = XLFD_SPACING_INDEX, mask = XLFD_SPACING_MASK;
898 else
899 from = XLFD_FOUNDRY_INDEX, to = XLFD_ENCODING_INDEX,
900 mask = XLFD_SYMBOL_MASK;
903 /* Merge position-based and value-based restrictions. */
904 mask &= range_mask;
905 while (from < range_from)
906 mask &= ~(1 << from++);
907 while (from < 14 && ! (mask & (1 << from)))
908 from++;
909 while (to > range_to)
910 mask &= ~(1 << to--);
911 while (to >= 0 && ! (mask & (1 << to)))
912 to--;
913 if (from > to)
914 return -1;
915 range[i].from = from;
916 range[i].to = to;
917 range[i].mask = mask;
919 if (from > range_from || to < range_to)
921 /* The range is narrowed by value-based restrictions.
922 Reflect it to the other fields. */
924 /* Following fields should be after FROM. */
925 range_from = from;
926 /* Preceding fields should be before TO. */
927 for (j = i - 1, from--, to--; j >= 0; j--, from--, to--)
929 /* Check FROM for non-wildcard field. */
930 if (! NILP (tmp[j]) && range[j].from < from)
932 while (range[j].from < from)
933 range[j].mask &= ~(1 << range[j].from++);
934 while (from < 14 && ! (range[j].mask & (1 << from)))
935 from++;
936 range[j].from = from;
938 else
939 from = range[j].from;
940 if (range[j].to > to)
942 while (range[j].to > to)
943 range[j].mask &= ~(1 << range[j].to--);
944 while (to >= 0 && ! (range[j].mask & (1 << to)))
945 to--;
946 range[j].to = to;
948 else
949 to = range[j].to;
950 if (from > to)
951 return -1;
957 /* Decide all fileds from restrictions in RANGE. */
958 for (i = j = 0; i < n ; i++)
960 if (j < range[i].from)
962 if (i == 0 || ! NILP (tmp[i - 1]))
963 /* None of TMP[X] corresponds to Jth field. */
964 return -1;
965 for (; j < range[i].from; j++)
966 field[j] = Qnil;
968 field[j++] = tmp[i];
970 if (! NILP (tmp[n - 1]) && j < XLFD_REGISTRY_INDEX)
971 return -1;
972 for (; j < XLFD_LAST_INDEX; j++)
973 field[j] = Qnil;
974 if (INTEGERP (field[XLFD_ENCODING_INDEX]))
975 field[XLFD_ENCODING_INDEX]
976 = Fintern (Fnumber_to_string (field[XLFD_ENCODING_INDEX]), Qnil);
977 return 0;
981 /* Parse NAME (null terminated) as XLFD and store information in FONT
982 (font-spec or font-entity). Size property of FONT is set as
983 follows:
984 specified XLFD fields FONT property
985 --------------------- -------------
986 PIXEL_SIZE PIXEL_SIZE (Lisp integer)
987 POINT_SIZE and RESY calculated pixel size (Lisp integer)
988 POINT_SIZE POINT_SIZE/10 (Lisp float)
990 If NAME is successfully parsed, return 0. Otherwise return -1.
992 FONT is usually a font-spec, but when this function is called from
993 X font backend driver, it is a font-entity. In that case, NAME is
994 a fully specified XLFD. */
997 font_parse_xlfd (char *name, Lisp_Object font)
999 ptrdiff_t len = strlen (name);
1000 int i, j, n;
1001 char *f[XLFD_LAST_INDEX + 1];
1002 Lisp_Object val;
1003 char *p;
1005 if (len > 255 || !len)
1006 /* Maximum XLFD name length is 255. */
1007 return -1;
1008 /* Accept "*-.." as a fully specified XLFD. */
1009 if (name[0] == '*' && (len == 1 || name[1] == '-'))
1010 i = 1, f[XLFD_FOUNDRY_INDEX] = name;
1011 else
1012 i = 0;
1013 for (p = name + i; *p; p++)
1014 if (*p == '-')
1016 f[i++] = p + 1;
1017 if (i == XLFD_LAST_INDEX)
1018 break;
1020 f[i] = name + len;
1022 #define INTERN_FIELD(N) font_intern_prop (f[N], f[(N) + 1] - 1 - f[N], 0)
1023 #define INTERN_FIELD_SYM(N) font_intern_prop (f[N], f[(N) + 1] - 1 - f[N], 1)
1025 if (i == XLFD_LAST_INDEX)
1027 /* Fully specified XLFD. */
1028 int pixel_size;
1030 ASET (font, FONT_FOUNDRY_INDEX, INTERN_FIELD_SYM (XLFD_FOUNDRY_INDEX));
1031 ASET (font, FONT_FAMILY_INDEX, INTERN_FIELD_SYM (XLFD_FAMILY_INDEX));
1032 for (i = XLFD_WEIGHT_INDEX, j = FONT_WEIGHT_INDEX;
1033 i <= XLFD_SWIDTH_INDEX; i++, j++)
1035 val = INTERN_FIELD_SYM (i);
1036 if (! NILP (val))
1038 if ((n = font_style_to_value (j, INTERN_FIELD_SYM (i), 0)) < 0)
1039 return -1;
1040 ASET (font, j, make_number (n));
1043 ASET (font, FONT_ADSTYLE_INDEX, INTERN_FIELD_SYM (XLFD_ADSTYLE_INDEX));
1044 if (strcmp (f[XLFD_REGISTRY_INDEX], "*-*") == 0)
1045 ASET (font, FONT_REGISTRY_INDEX, Qnil);
1046 else
1047 ASET (font, FONT_REGISTRY_INDEX,
1048 font_intern_prop (f[XLFD_REGISTRY_INDEX],
1049 f[XLFD_LAST_INDEX] - f[XLFD_REGISTRY_INDEX],
1050 1));
1051 p = f[XLFD_PIXEL_INDEX];
1052 if (*p == '[' && (pixel_size = parse_matrix (p)) >= 0)
1053 ASET (font, FONT_SIZE_INDEX, make_number (pixel_size));
1054 else
1056 val = INTERN_FIELD (XLFD_PIXEL_INDEX);
1057 if (INTEGERP (val))
1058 ASET (font, FONT_SIZE_INDEX, val);
1059 else if (FONT_ENTITY_P (font))
1060 return -1;
1061 else
1063 double point_size = -1;
1065 font_assert (FONT_SPEC_P (font));
1066 p = f[XLFD_POINT_INDEX];
1067 if (*p == '[')
1068 point_size = parse_matrix (p);
1069 else if (isdigit (*p))
1070 point_size = atoi (p), point_size /= 10;
1071 if (point_size >= 0)
1072 ASET (font, FONT_SIZE_INDEX, make_float (point_size));
1076 val = INTERN_FIELD (XLFD_RESY_INDEX);
1077 if (! NILP (val) && ! INTEGERP (val))
1078 return -1;
1079 ASET (font, FONT_DPI_INDEX, val);
1080 val = INTERN_FIELD (XLFD_SPACING_INDEX);
1081 if (! NILP (val))
1083 val = font_prop_validate_spacing (QCspacing, val);
1084 if (! INTEGERP (val))
1085 return -1;
1086 ASET (font, FONT_SPACING_INDEX, val);
1088 p = f[XLFD_AVGWIDTH_INDEX];
1089 if (*p == '~')
1090 p++;
1091 val = font_intern_prop (p, f[XLFD_REGISTRY_INDEX] - 1 - p, 0);
1092 if (! NILP (val) && ! INTEGERP (val))
1093 return -1;
1094 ASET (font, FONT_AVGWIDTH_INDEX, val);
1096 else
1098 int wild_card_found = 0;
1099 Lisp_Object prop[XLFD_LAST_INDEX];
1101 if (FONT_ENTITY_P (font))
1102 return -1;
1103 for (j = 0; j < i; j++)
1105 if (*f[j] == '*')
1107 if (f[j][1] && f[j][1] != '-')
1108 return -1;
1109 prop[j] = Qnil;
1110 wild_card_found = 1;
1112 else if (j + 1 < i)
1113 prop[j] = INTERN_FIELD (j);
1114 else
1115 prop[j] = font_intern_prop (f[j], f[i] - f[j], 0);
1117 if (! wild_card_found)
1118 return -1;
1119 if (font_expand_wildcards (prop, i) < 0)
1120 return -1;
1122 ASET (font, FONT_FOUNDRY_INDEX, prop[XLFD_FOUNDRY_INDEX]);
1123 ASET (font, FONT_FAMILY_INDEX, prop[XLFD_FAMILY_INDEX]);
1124 for (i = XLFD_WEIGHT_INDEX, j = FONT_WEIGHT_INDEX;
1125 i <= XLFD_SWIDTH_INDEX; i++, j++)
1126 if (! NILP (prop[i]))
1128 if ((n = font_style_to_value (j, prop[i], 1)) < 0)
1129 return -1;
1130 ASET (font, j, make_number (n));
1132 ASET (font, FONT_ADSTYLE_INDEX, prop[XLFD_ADSTYLE_INDEX]);
1133 val = prop[XLFD_REGISTRY_INDEX];
1134 if (NILP (val))
1136 val = prop[XLFD_ENCODING_INDEX];
1137 if (! NILP (val))
1138 val = concat2 (build_string ("*-"), SYMBOL_NAME (val));
1140 else if (NILP (prop[XLFD_ENCODING_INDEX]))
1141 val = concat2 (SYMBOL_NAME (val), build_string ("-*"));
1142 else
1143 val = concat3 (SYMBOL_NAME (val), build_string ("-"),
1144 SYMBOL_NAME (prop[XLFD_ENCODING_INDEX]));
1145 if (! NILP (val))
1146 ASET (font, FONT_REGISTRY_INDEX, Fintern (val, Qnil));
1148 if (INTEGERP (prop[XLFD_PIXEL_INDEX]))
1149 ASET (font, FONT_SIZE_INDEX, prop[XLFD_PIXEL_INDEX]);
1150 else if (INTEGERP (prop[XLFD_POINT_INDEX]))
1152 double point_size = XINT (prop[XLFD_POINT_INDEX]);
1154 ASET (font, FONT_SIZE_INDEX, make_float (point_size / 10));
1157 if (INTEGERP (prop[XLFD_RESX_INDEX]))
1158 ASET (font, FONT_DPI_INDEX, prop[XLFD_RESY_INDEX]);
1159 if (! NILP (prop[XLFD_SPACING_INDEX]))
1161 val = font_prop_validate_spacing (QCspacing,
1162 prop[XLFD_SPACING_INDEX]);
1163 if (! INTEGERP (val))
1164 return -1;
1165 ASET (font, FONT_SPACING_INDEX, val);
1167 if (INTEGERP (prop[XLFD_AVGWIDTH_INDEX]))
1168 ASET (font, FONT_AVGWIDTH_INDEX, prop[XLFD_AVGWIDTH_INDEX]);
1171 return 0;
1174 /* Store XLFD name of FONT (font-spec or font-entity) in NAME (NBYTES
1175 length), and return the name length. If FONT_SIZE_INDEX of FONT is
1176 0, use PIXEL_SIZE instead. */
1179 font_unparse_xlfd (Lisp_Object font, int pixel_size, char *name, int nbytes)
1181 char *p;
1182 const char *f[XLFD_REGISTRY_INDEX + 1];
1183 Lisp_Object val;
1184 int i, j, len;
1186 font_assert (FONTP (font));
1188 for (i = FONT_FOUNDRY_INDEX, j = XLFD_FOUNDRY_INDEX; i <= FONT_REGISTRY_INDEX;
1189 i++, j++)
1191 if (i == FONT_ADSTYLE_INDEX)
1192 j = XLFD_ADSTYLE_INDEX;
1193 else if (i == FONT_REGISTRY_INDEX)
1194 j = XLFD_REGISTRY_INDEX;
1195 val = AREF (font, i);
1196 if (NILP (val))
1198 if (j == XLFD_REGISTRY_INDEX)
1199 f[j] = "*-*";
1200 else
1201 f[j] = "*";
1203 else
1205 if (SYMBOLP (val))
1206 val = SYMBOL_NAME (val);
1207 if (j == XLFD_REGISTRY_INDEX
1208 && ! strchr (SSDATA (val), '-'))
1210 /* Change "jisx0208*" and "jisx0208" to "jisx0208*-*". */
1211 ptrdiff_t alloc = SBYTES (val) + 4;
1212 if (nbytes <= alloc)
1213 return -1;
1214 f[j] = p = alloca (alloc);
1215 sprintf (p, "%s%s-*", SDATA (val),
1216 "*" + (SDATA (val)[SBYTES (val) - 1] == '*'));
1218 else
1219 f[j] = SSDATA (val);
1223 for (i = FONT_WEIGHT_INDEX, j = XLFD_WEIGHT_INDEX; i <= FONT_WIDTH_INDEX;
1224 i++, j++)
1226 val = font_style_symbolic (font, i, 0);
1227 if (NILP (val))
1228 f[j] = "*";
1229 else
1231 val = SYMBOL_NAME (val);
1232 f[j] = SSDATA (val);
1236 val = AREF (font, FONT_SIZE_INDEX);
1237 font_assert (NUMBERP (val) || NILP (val));
1238 if (INTEGERP (val))
1240 EMACS_INT v = XINT (val);
1241 if (v <= 0)
1242 v = pixel_size;
1243 if (v > 0)
1245 f[XLFD_PIXEL_INDEX] = p =
1246 alloca (sizeof "-*" + INT_STRLEN_BOUND (EMACS_INT));
1247 sprintf (p, "%"pI"d-*", v);
1249 else
1250 f[XLFD_PIXEL_INDEX] = "*-*";
1252 else if (FLOATP (val))
1254 double v = XFLOAT_DATA (val) * 10;
1255 f[XLFD_PIXEL_INDEX] = p = alloca (sizeof "*-" + 1 + DBL_MAX_10_EXP + 1);
1256 sprintf (p, "*-%.0f", v);
1258 else
1259 f[XLFD_PIXEL_INDEX] = "*-*";
1261 if (INTEGERP (AREF (font, FONT_DPI_INDEX)))
1263 EMACS_INT v = XINT (AREF (font, FONT_DPI_INDEX));
1264 f[XLFD_RESX_INDEX] = p =
1265 alloca (sizeof "-" + 2 * INT_STRLEN_BOUND (EMACS_INT));
1266 sprintf (p, "%"pI"d-%"pI"d", v, v);
1268 else
1269 f[XLFD_RESX_INDEX] = "*-*";
1270 if (INTEGERP (AREF (font, FONT_SPACING_INDEX)))
1272 EMACS_INT spacing = XINT (AREF (font, FONT_SPACING_INDEX));
1274 f[XLFD_SPACING_INDEX] = (spacing <= FONT_SPACING_PROPORTIONAL ? "p"
1275 : spacing <= FONT_SPACING_DUAL ? "d"
1276 : spacing <= FONT_SPACING_MONO ? "m"
1277 : "c");
1279 else
1280 f[XLFD_SPACING_INDEX] = "*";
1281 if (INTEGERP (AREF (font, FONT_AVGWIDTH_INDEX)))
1283 f[XLFD_AVGWIDTH_INDEX] = p = alloca (INT_BUFSIZE_BOUND (EMACS_INT));
1284 sprintf (p, "%"pI"d", XINT (AREF (font, FONT_AVGWIDTH_INDEX)));
1286 else
1287 f[XLFD_AVGWIDTH_INDEX] = "*";
1288 len = snprintf (name, nbytes, "-%s-%s-%s-%s-%s-%s-%s-%s-%s-%s-%s",
1289 f[XLFD_FOUNDRY_INDEX], f[XLFD_FAMILY_INDEX],
1290 f[XLFD_WEIGHT_INDEX], f[XLFD_SLANT_INDEX],
1291 f[XLFD_SWIDTH_INDEX], f[XLFD_ADSTYLE_INDEX],
1292 f[XLFD_PIXEL_INDEX], f[XLFD_RESX_INDEX],
1293 f[XLFD_SPACING_INDEX], f[XLFD_AVGWIDTH_INDEX],
1294 f[XLFD_REGISTRY_INDEX]);
1295 return len < nbytes ? len : -1;
1298 /* Parse NAME (null terminated) and store information in FONT
1299 (font-spec or font-entity). NAME is supplied in either the
1300 Fontconfig or GTK font name format. If NAME is successfully
1301 parsed, return 0. Otherwise return -1.
1303 The fontconfig format is
1305 FAMILY[-SIZE][:PROP1[=VAL1][:PROP2[=VAL2]...]]
1307 The GTK format is
1309 FAMILY [PROPS...] [SIZE]
1311 This function tries to guess which format it is. */
1313 static int
1314 font_parse_fcname (char *name, Lisp_Object font)
1316 char *p, *q;
1317 char *size_beg = NULL, *size_end = NULL;
1318 char *props_beg = NULL, *family_end = NULL;
1319 ptrdiff_t len = strlen (name);
1321 if (len == 0)
1322 return -1;
1324 for (p = name; *p; p++)
1326 if (*p == '\\' && p[1])
1327 p++;
1328 else if (*p == ':')
1330 props_beg = family_end = p;
1331 break;
1333 else if (*p == '-')
1335 int decimal = 0, size_found = 1;
1336 for (q = p + 1; *q && *q != ':'; q++)
1337 if (! isdigit (*q))
1339 if (*q != '.' || decimal)
1341 size_found = 0;
1342 break;
1344 decimal = 1;
1346 if (size_found)
1348 family_end = p;
1349 size_beg = p + 1;
1350 size_end = q;
1351 break;
1356 if (family_end)
1358 Lisp_Object extra_props = Qnil;
1360 /* A fontconfig name with size and/or property data. */
1361 if (family_end > name)
1363 Lisp_Object family;
1364 family = font_intern_prop (name, family_end - name, 1);
1365 ASET (font, FONT_FAMILY_INDEX, family);
1367 if (size_beg)
1369 double point_size = strtod (size_beg, &size_end);
1370 ASET (font, FONT_SIZE_INDEX, make_float (point_size));
1371 if (*size_end == ':' && size_end[1])
1372 props_beg = size_end;
1374 if (props_beg)
1376 /* Now parse ":KEY=VAL" patterns. */
1377 Lisp_Object val;
1379 for (p = props_beg; *p; p = q)
1381 for (q = p + 1; *q && *q != '=' && *q != ':'; q++);
1382 if (*q != '=')
1384 /* Must be an enumerated value. */
1385 ptrdiff_t word_len;
1386 p = p + 1;
1387 word_len = q - p;
1388 val = font_intern_prop (p, q - p, 1);
1390 #define PROP_MATCH(STR) (word_len == strlen (STR) \
1391 && memcmp (p, STR, strlen (STR)) == 0)
1393 if (PROP_MATCH ("light")
1394 || PROP_MATCH ("medium")
1395 || PROP_MATCH ("demibold")
1396 || PROP_MATCH ("bold")
1397 || PROP_MATCH ("black"))
1398 FONT_SET_STYLE (font, FONT_WEIGHT_INDEX, val);
1399 else if (PROP_MATCH ("roman")
1400 || PROP_MATCH ("italic")
1401 || PROP_MATCH ("oblique"))
1402 FONT_SET_STYLE (font, FONT_SLANT_INDEX, val);
1403 else if (PROP_MATCH ("charcell"))
1404 ASET (font, FONT_SPACING_INDEX,
1405 make_number (FONT_SPACING_CHARCELL));
1406 else if (PROP_MATCH ("mono"))
1407 ASET (font, FONT_SPACING_INDEX,
1408 make_number (FONT_SPACING_MONO));
1409 else if (PROP_MATCH ("proportional"))
1410 ASET (font, FONT_SPACING_INDEX,
1411 make_number (FONT_SPACING_PROPORTIONAL));
1412 #undef PROP_MATCH
1414 else
1416 /* KEY=VAL pairs */
1417 Lisp_Object key;
1418 int prop;
1420 if (q - p == 10 && memcmp (p + 1, "pixelsize", 9) == 0)
1421 prop = FONT_SIZE_INDEX;
1422 else
1424 key = font_intern_prop (p, q - p, 1);
1425 prop = get_font_prop_index (key);
1428 p = q + 1;
1429 for (q = p; *q && *q != ':'; q++);
1430 val = font_intern_prop (p, q - p, 0);
1432 if (prop >= FONT_FOUNDRY_INDEX
1433 && prop < FONT_EXTRA_INDEX)
1434 ASET (font, prop, font_prop_validate (prop, Qnil, val));
1435 else
1437 extra_props = nconc2 (extra_props,
1438 Fcons (Fcons (key, val), Qnil));
1441 p = q;
1445 if (! NILP (extra_props))
1447 struct font_driver_list *driver_list = font_driver_list;
1448 for ( ; driver_list; driver_list = driver_list->next)
1449 if (driver_list->driver->filter_properties)
1450 (*driver_list->driver->filter_properties) (font, extra_props);
1454 else
1456 /* Either a fontconfig-style name with no size and property
1457 data, or a GTK-style name. */
1458 Lisp_Object weight = Qnil, slant = Qnil;
1459 Lisp_Object width = Qnil, size = Qnil;
1460 char *word_start;
1461 ptrdiff_t word_len;
1463 /* Scan backwards from the end, looking for a size. */
1464 for (p = name + len - 1; p >= name; p--)
1465 if (!isdigit (*p))
1466 break;
1468 if ((p < name + len - 1) && ((p + 1 == name) || *p == ' '))
1469 /* Found a font size. */
1470 size = make_float (strtod (p + 1, NULL));
1471 else
1472 p = name + len;
1474 /* Now P points to the termination of the string, sans size.
1475 Scan backwards, looking for font properties. */
1476 for (; p > name; p = q)
1478 for (q = p - 1; q >= name; q--)
1480 if (q > name && *(q-1) == '\\')
1481 --q; /* Skip quoting backslashes. */
1482 else if (*q == ' ')
1483 break;
1486 word_start = q + 1;
1487 word_len = p - word_start;
1489 #define PROP_MATCH(STR) \
1490 (word_len == strlen (STR) \
1491 && memcmp (word_start, STR, strlen (STR)) == 0)
1492 #define PROP_SAVE(VAR, STR) \
1493 (VAR = NILP (VAR) ? font_intern_prop (STR, strlen (STR), 1) : VAR)
1495 if (PROP_MATCH ("Ultra-Light"))
1496 PROP_SAVE (weight, "ultra-light");
1497 else if (PROP_MATCH ("Light"))
1498 PROP_SAVE (weight, "light");
1499 else if (PROP_MATCH ("Book"))
1500 PROP_SAVE (weight, "book");
1501 else if (PROP_MATCH ("Medium"))
1502 PROP_SAVE (weight, "medium");
1503 else if (PROP_MATCH ("Semi-Bold"))
1504 PROP_SAVE (weight, "semi-bold");
1505 else if (PROP_MATCH ("Bold"))
1506 PROP_SAVE (weight, "bold");
1507 else if (PROP_MATCH ("Italic"))
1508 PROP_SAVE (slant, "italic");
1509 else if (PROP_MATCH ("Oblique"))
1510 PROP_SAVE (slant, "oblique");
1511 else if (PROP_MATCH ("Semi-Condensed"))
1512 PROP_SAVE (width, "semi-condensed");
1513 else if (PROP_MATCH ("Condensed"))
1514 PROP_SAVE (width, "condensed");
1515 /* An unknown word must be part of the font name. */
1516 else
1518 family_end = p;
1519 break;
1522 #undef PROP_MATCH
1523 #undef PROP_SAVE
1525 if (family_end)
1526 ASET (font, FONT_FAMILY_INDEX,
1527 font_intern_prop (name, family_end - name, 1));
1528 if (!NILP (size))
1529 ASET (font, FONT_SIZE_INDEX, size);
1530 if (!NILP (weight))
1531 FONT_SET_STYLE (font, FONT_WEIGHT_INDEX, weight);
1532 if (!NILP (slant))
1533 FONT_SET_STYLE (font, FONT_SLANT_INDEX, slant);
1534 if (!NILP (width))
1535 FONT_SET_STYLE (font, FONT_WIDTH_INDEX, width);
1538 return 0;
1541 /* Store fontconfig's font name of FONT (font-spec or font-entity) in
1542 NAME (NBYTES length), and return the name length. If
1543 FONT_SIZE_INDEX of FONT is 0, use PIXEL_SIZE instead. */
1546 font_unparse_fcname (Lisp_Object font, int pixel_size, char *name, int nbytes)
1548 Lisp_Object family, foundry;
1549 Lisp_Object val;
1550 int point_size;
1551 int i;
1552 char *p;
1553 char *lim;
1554 Lisp_Object styles[3];
1555 const char *style_names[3] = { "weight", "slant", "width" };
1557 family = AREF (font, FONT_FAMILY_INDEX);
1558 if (! NILP (family))
1560 if (SYMBOLP (family))
1561 family = SYMBOL_NAME (family);
1562 else
1563 family = Qnil;
1566 val = AREF (font, FONT_SIZE_INDEX);
1567 if (INTEGERP (val))
1569 if (XINT (val) != 0)
1570 pixel_size = XINT (val);
1571 point_size = -1;
1573 else
1575 if (! FLOATP (val))
1576 abort ();
1577 pixel_size = -1;
1578 point_size = (int) XFLOAT_DATA (val);
1581 foundry = AREF (font, FONT_FOUNDRY_INDEX);
1582 if (! NILP (foundry))
1584 if (SYMBOLP (foundry))
1585 foundry = SYMBOL_NAME (foundry);
1586 else
1587 foundry = Qnil;
1590 for (i = 0; i < 3; i++)
1591 styles[i] = font_style_symbolic (font, FONT_WEIGHT_INDEX + i, 0);
1593 p = name;
1594 lim = name + nbytes;
1595 if (! NILP (family))
1597 int len = snprintf (p, lim - p, "%s", SSDATA (family));
1598 if (! (0 <= len && len < lim - p))
1599 return -1;
1600 p += len;
1602 if (point_size > 0)
1604 int len = snprintf (p, lim - p, "-%d" + (p == name), point_size);
1605 if (! (0 <= len && len < lim - p))
1606 return -1;
1607 p += len;
1609 else if (pixel_size > 0)
1611 int len = snprintf (p, lim - p, ":pixelsize=%d", pixel_size);
1612 if (! (0 <= len && len < lim - p))
1613 return -1;
1614 p += len;
1616 if (! NILP (AREF (font, FONT_FOUNDRY_INDEX)))
1618 int len = snprintf (p, lim - p, ":foundry=%s",
1619 SSDATA (SYMBOL_NAME (AREF (font,
1620 FONT_FOUNDRY_INDEX))));
1621 if (! (0 <= len && len < lim - p))
1622 return -1;
1623 p += len;
1625 for (i = 0; i < 3; i++)
1626 if (! NILP (styles[i]))
1628 int len = snprintf (p, lim - p, ":%s=%s", style_names[i],
1629 SSDATA (SYMBOL_NAME (styles[i])));
1630 if (! (0 <= len && len < lim - p))
1631 return -1;
1632 p += len;
1635 if (INTEGERP (AREF (font, FONT_DPI_INDEX)))
1637 int len = snprintf (p, lim - p, ":dpi=%"pI"d",
1638 XINT (AREF (font, FONT_DPI_INDEX)));
1639 if (! (0 <= len && len < lim - p))
1640 return -1;
1641 p += len;
1644 if (INTEGERP (AREF (font, FONT_SPACING_INDEX)))
1646 int len = snprintf (p, lim - p, ":spacing=%"pI"d",
1647 XINT (AREF (font, FONT_SPACING_INDEX)));
1648 if (! (0 <= len && len < lim - p))
1649 return -1;
1650 p += len;
1653 if (INTEGERP (AREF (font, FONT_AVGWIDTH_INDEX)))
1655 int len = snprintf (p, lim - p,
1656 (XINT (AREF (font, FONT_AVGWIDTH_INDEX)) == 0
1657 ? ":scalable=true"
1658 : ":scalable=false"));
1659 if (! (0 <= len && len < lim - p))
1660 return -1;
1661 p += len;
1664 return (p - name);
1667 /* Parse NAME (null terminated) and store information in FONT
1668 (font-spec or font-entity). If NAME is successfully parsed, return
1669 0. Otherwise return -1. */
1671 static int
1672 font_parse_name (char *name, Lisp_Object font)
1674 if (name[0] == '-' || strchr (name, '*') || strchr (name, '?'))
1675 return font_parse_xlfd (name, font);
1676 return font_parse_fcname (name, font);
1680 /* Merge FAMILY and REGISTRY into FONT_SPEC. FAMILY may have the form
1681 "FAMILY-FOUNDRY". REGISTRY may not contain charset-encoding
1682 part. */
1684 void
1685 font_parse_family_registry (Lisp_Object family, Lisp_Object registry, Lisp_Object font_spec)
1687 int len;
1688 char *p0, *p1;
1690 if (! NILP (family)
1691 && NILP (AREF (font_spec, FONT_FAMILY_INDEX)))
1693 CHECK_STRING (family);
1694 len = SBYTES (family);
1695 p0 = SSDATA (family);
1696 p1 = strchr (p0, '-');
1697 if (p1)
1699 if ((*p0 != '*' && p1 - p0 > 0)
1700 && NILP (AREF (font_spec, FONT_FOUNDRY_INDEX)))
1701 Ffont_put (font_spec, QCfoundry, font_intern_prop (p0, p1 - p0, 1));
1702 p1++;
1703 len -= p1 - p0;
1704 Ffont_put (font_spec, QCfamily, font_intern_prop (p1, len, 1));
1706 else
1707 ASET (font_spec, FONT_FAMILY_INDEX, Fintern (family, Qnil));
1709 if (! NILP (registry))
1711 /* Convert "XXX" and "XXX*" to "XXX*-*". */
1712 CHECK_STRING (registry);
1713 len = SBYTES (registry);
1714 p0 = SSDATA (registry);
1715 p1 = strchr (p0, '-');
1716 if (! p1)
1718 if (SDATA (registry)[len - 1] == '*')
1719 registry = concat2 (registry, build_string ("-*"));
1720 else
1721 registry = concat2 (registry, build_string ("*-*"));
1723 registry = Fdowncase (registry);
1724 ASET (font_spec, FONT_REGISTRY_INDEX, Fintern (registry, Qnil));
1729 /* This part (through the next ^L) is still experimental and not
1730 tested much. We may drastically change codes. */
1732 /* OTF handler */
1734 #if 0
1736 #define LGSTRING_HEADER_SIZE 6
1737 #define LGSTRING_GLYPH_SIZE 8
1739 static int
1740 check_gstring (Lisp_Object gstring)
1742 Lisp_Object val;
1743 int i, j;
1745 CHECK_VECTOR (gstring);
1746 val = AREF (gstring, 0);
1747 CHECK_VECTOR (val);
1748 if (ASIZE (val) < LGSTRING_HEADER_SIZE)
1749 goto err;
1750 CHECK_FONT_OBJECT (LGSTRING_FONT (gstring));
1751 if (!NILP (LGSTRING_SLOT (gstring, LGSTRING_IX_LBEARING)))
1752 CHECK_NUMBER (LGSTRING_SLOT (gstring, LGSTRING_IX_LBEARING));
1753 if (!NILP (LGSTRING_SLOT (gstring, LGSTRING_IX_RBEARING)))
1754 CHECK_NUMBER (LGSTRING_SLOT (gstring, LGSTRING_IX_RBEARING));
1755 if (!NILP (LGSTRING_SLOT (gstring, LGSTRING_IX_WIDTH)))
1756 CHECK_NATNUM (LGSTRING_SLOT (gstring, LGSTRING_IX_WIDTH));
1757 if (!NILP (LGSTRING_SLOT (gstring, LGSTRING_IX_ASCENT)))
1758 CHECK_NUMBER (LGSTRING_SLOT (gstring, LGSTRING_IX_ASCENT));
1759 if (!NILP (LGSTRING_SLOT (gstring, LGSTRING_IX_ASCENT)))
1760 CHECK_NUMBER (LGSTRING_SLOT (gstring, LGSTRING_IX_ASCENT));
1762 for (i = 0; i < LGSTRING_GLYPH_LEN (gstring); i++)
1764 val = LGSTRING_GLYPH (gstring, i);
1765 CHECK_VECTOR (val);
1766 if (ASIZE (val) < LGSTRING_GLYPH_SIZE)
1767 goto err;
1768 if (NILP (AREF (val, LGLYPH_IX_CHAR)))
1769 break;
1770 CHECK_NATNUM (AREF (val, LGLYPH_IX_FROM));
1771 CHECK_NATNUM (AREF (val, LGLYPH_IX_TO));
1772 CHECK_CHARACTER (AREF (val, LGLYPH_IX_CHAR));
1773 if (!NILP (AREF (val, LGLYPH_IX_CODE)))
1774 CHECK_NATNUM (AREF (val, LGLYPH_IX_CODE));
1775 if (!NILP (AREF (val, LGLYPH_IX_WIDTH)))
1776 CHECK_NATNUM (AREF (val, LGLYPH_IX_WIDTH));
1777 if (!NILP (AREF (val, LGLYPH_IX_ADJUSTMENT)))
1779 val = AREF (val, LGLYPH_IX_ADJUSTMENT);
1780 CHECK_VECTOR (val);
1781 if (ASIZE (val) < 3)
1782 goto err;
1783 for (j = 0; j < 3; j++)
1784 CHECK_NUMBER (AREF (val, j));
1787 return i;
1788 err:
1789 error ("Invalid glyph-string format");
1790 return -1;
1793 static void
1794 check_otf_features (Lisp_Object otf_features)
1796 Lisp_Object val;
1798 CHECK_CONS (otf_features);
1799 CHECK_SYMBOL (XCAR (otf_features));
1800 otf_features = XCDR (otf_features);
1801 CHECK_CONS (otf_features);
1802 CHECK_SYMBOL (XCAR (otf_features));
1803 otf_features = XCDR (otf_features);
1804 for (val = Fcar (otf_features); ! NILP (val); val = Fcdr (val))
1806 CHECK_SYMBOL (Fcar (val));
1807 if (SBYTES (SYMBOL_NAME (XCAR (val))) > 4)
1808 error ("Invalid OTF GSUB feature: %s",
1809 SDATA (SYMBOL_NAME (XCAR (val))));
1811 otf_features = XCDR (otf_features);
1812 for (val = Fcar (otf_features); ! NILP (val); val = Fcdr (val))
1814 CHECK_SYMBOL (Fcar (val));
1815 if (SBYTES (SYMBOL_NAME (XCAR (val))) > 4)
1816 error ("Invalid OTF GPOS feature: %s",
1817 SDATA (SYMBOL_NAME (XCAR (val))));
1821 #ifdef HAVE_LIBOTF
1822 #include <otf.h>
1824 Lisp_Object otf_list;
1826 static Lisp_Object
1827 otf_tag_symbol (OTF_Tag tag)
1829 char name[5];
1831 OTF_tag_name (tag, name);
1832 return Fintern (make_unibyte_string (name, 4), Qnil);
1835 static OTF *
1836 otf_open (Lisp_Object file)
1838 Lisp_Object val = Fassoc (file, otf_list);
1839 OTF *otf;
1841 if (! NILP (val))
1842 otf = XSAVE_VALUE (XCDR (val))->pointer;
1843 else
1845 otf = STRINGP (file) ? OTF_open (SSDATA (file)) : NULL;
1846 val = make_save_value (otf, 0);
1847 otf_list = Fcons (Fcons (file, val), otf_list);
1849 return otf;
1853 /* Return a list describing which scripts/languages FONT supports by
1854 which GSUB/GPOS features of OpenType tables. See the comment of
1855 (struct font_driver).otf_capability. */
1857 Lisp_Object
1858 font_otf_capability (struct font *font)
1860 OTF *otf;
1861 Lisp_Object capability = Fcons (Qnil, Qnil);
1862 int i;
1864 otf = otf_open (font->props[FONT_FILE_INDEX]);
1865 if (! otf)
1866 return Qnil;
1867 for (i = 0; i < 2; i++)
1869 OTF_GSUB_GPOS *gsub_gpos;
1870 Lisp_Object script_list = Qnil;
1871 int j;
1873 if (OTF_get_features (otf, i == 0) < 0)
1874 continue;
1875 gsub_gpos = i == 0 ? otf->gsub : otf->gpos;
1876 for (j = gsub_gpos->ScriptList.ScriptCount - 1; j >= 0; j--)
1878 OTF_Script *script = gsub_gpos->ScriptList.Script + j;
1879 Lisp_Object langsys_list = Qnil;
1880 Lisp_Object script_tag = otf_tag_symbol (script->ScriptTag);
1881 int k;
1883 for (k = script->LangSysCount; k >= 0; k--)
1885 OTF_LangSys *langsys;
1886 Lisp_Object feature_list = Qnil;
1887 Lisp_Object langsys_tag;
1888 int l;
1890 if (k == script->LangSysCount)
1892 langsys = &script->DefaultLangSys;
1893 langsys_tag = Qnil;
1895 else
1897 langsys = script->LangSys + k;
1898 langsys_tag
1899 = otf_tag_symbol (script->LangSysRecord[k].LangSysTag);
1901 for (l = langsys->FeatureCount - 1; l >= 0; l--)
1903 OTF_Feature *feature
1904 = gsub_gpos->FeatureList.Feature + langsys->FeatureIndex[l];
1905 Lisp_Object feature_tag
1906 = otf_tag_symbol (feature->FeatureTag);
1908 feature_list = Fcons (feature_tag, feature_list);
1910 langsys_list = Fcons (Fcons (langsys_tag, feature_list),
1911 langsys_list);
1913 script_list = Fcons (Fcons (script_tag, langsys_list),
1914 script_list);
1917 if (i == 0)
1918 XSETCAR (capability, script_list);
1919 else
1920 XSETCDR (capability, script_list);
1923 return capability;
1926 /* Parse OTF features in SPEC and write a proper features spec string
1927 in FEATURES for the call of OTF_drive_gsub/gpos (of libotf). It is
1928 assured that the sufficient memory has already allocated for
1929 FEATURES. */
1931 static void
1932 generate_otf_features (Lisp_Object spec, char *features)
1934 Lisp_Object val;
1935 char *p;
1936 int asterisk;
1938 p = features;
1939 *p = '\0';
1940 for (asterisk = 0; CONSP (spec); spec = XCDR (spec))
1942 val = XCAR (spec);
1943 CHECK_SYMBOL (val);
1944 if (p > features)
1945 *p++ = ',';
1946 if (SREF (SYMBOL_NAME (val), 0) == '*')
1948 asterisk = 1;
1949 *p++ = '*';
1951 else if (! asterisk)
1953 val = SYMBOL_NAME (val);
1954 p += esprintf (p, "%s", SDATA (val));
1956 else
1958 val = SYMBOL_NAME (val);
1959 p += esprintf (p, "~%s", SDATA (val));
1962 if (CONSP (spec))
1963 error ("OTF spec too long");
1966 Lisp_Object
1967 font_otf_DeviceTable (OTF_DeviceTable *device_table)
1969 int len = device_table->StartSize - device_table->EndSize + 1;
1971 return Fcons (make_number (len),
1972 make_unibyte_string (device_table->DeltaValue, len));
1975 Lisp_Object
1976 font_otf_ValueRecord (int value_format, OTF_ValueRecord *value_record)
1978 Lisp_Object val = Fmake_vector (make_number (8), Qnil);
1980 if (value_format & OTF_XPlacement)
1981 ASET (val, 0, make_number (value_record->XPlacement));
1982 if (value_format & OTF_YPlacement)
1983 ASET (val, 1, make_number (value_record->YPlacement));
1984 if (value_format & OTF_XAdvance)
1985 ASET (val, 2, make_number (value_record->XAdvance));
1986 if (value_format & OTF_YAdvance)
1987 ASET (val, 3, make_number (value_record->YAdvance));
1988 if (value_format & OTF_XPlaDevice)
1989 ASET (val, 4, font_otf_DeviceTable (&value_record->XPlaDevice));
1990 if (value_format & OTF_YPlaDevice)
1991 ASET (val, 4, font_otf_DeviceTable (&value_record->YPlaDevice));
1992 if (value_format & OTF_XAdvDevice)
1993 ASET (val, 4, font_otf_DeviceTable (&value_record->XAdvDevice));
1994 if (value_format & OTF_YAdvDevice)
1995 ASET (val, 4, font_otf_DeviceTable (&value_record->YAdvDevice));
1996 return val;
1999 Lisp_Object
2000 font_otf_Anchor (OTF_Anchor *anchor)
2002 Lisp_Object val;
2004 val = Fmake_vector (make_number (anchor->AnchorFormat + 1), Qnil);
2005 ASET (val, 0, make_number (anchor->XCoordinate));
2006 ASET (val, 1, make_number (anchor->YCoordinate));
2007 if (anchor->AnchorFormat == 2)
2008 ASET (val, 2, make_number (anchor->f.f1.AnchorPoint));
2009 else
2011 ASET (val, 3, font_otf_DeviceTable (&anchor->f.f2.XDeviceTable));
2012 ASET (val, 4, font_otf_DeviceTable (&anchor->f.f2.YDeviceTable));
2014 return val;
2016 #endif /* HAVE_LIBOTF */
2017 #endif /* 0 */
2020 /* Font sorting */
2022 static unsigned font_score (Lisp_Object, Lisp_Object *);
2023 static int font_compare (const void *, const void *);
2024 static Lisp_Object font_sort_entities (Lisp_Object, Lisp_Object,
2025 Lisp_Object, int);
2027 static double
2028 font_rescale_ratio (Lisp_Object font_entity)
2030 Lisp_Object tail, elt;
2031 Lisp_Object name = Qnil;
2033 for (tail = Vface_font_rescale_alist; CONSP (tail); tail = XCDR (tail))
2035 elt = XCAR (tail);
2036 if (FLOATP (XCDR (elt)))
2038 if (STRINGP (XCAR (elt)))
2040 if (NILP (name))
2041 name = Ffont_xlfd_name (font_entity, Qnil);
2042 if (fast_string_match_ignore_case (XCAR (elt), name) >= 0)
2043 return XFLOAT_DATA (XCDR (elt));
2045 else if (FONT_SPEC_P (XCAR (elt)))
2047 if (font_match_p (XCAR (elt), font_entity))
2048 return XFLOAT_DATA (XCDR (elt));
2052 return 1.0;
2055 /* We sort fonts by scoring each of them against a specified
2056 font-spec. The score value is 32 bit (`unsigned'), and the smaller
2057 the value is, the closer the font is to the font-spec.
2059 The lowest 2 bits of the score are used for driver type. The font
2060 available by the most preferred font driver is 0.
2062 The 4 7-bit fields in the higher 28 bits are used for numeric properties
2063 WEIGHT, SLANT, WIDTH, and SIZE. */
2065 /* How many bits to shift to store the difference value of each font
2066 property in a score. Note that floats for FONT_TYPE_INDEX and
2067 FONT_REGISTRY_INDEX are not used. */
2068 static int sort_shift_bits[FONT_SIZE_INDEX + 1];
2070 /* Score font-entity ENTITY against properties of font-spec SPEC_PROP.
2071 The return value indicates how different ENTITY is compared with
2072 SPEC_PROP. */
2074 static unsigned
2075 font_score (Lisp_Object entity, Lisp_Object *spec_prop)
2077 unsigned score = 0;
2078 int i;
2080 /* Score three style numeric fields. Maximum difference is 127. */
2081 for (i = FONT_WEIGHT_INDEX; i <= FONT_WIDTH_INDEX; i++)
2082 if (! NILP (spec_prop[i]) && ! EQ (AREF (entity, i), spec_prop[i]))
2084 EMACS_INT diff = ((XINT (AREF (entity, i)) >> 8)
2085 - (XINT (spec_prop[i]) >> 8));
2086 if (diff < 0)
2087 diff = - diff;
2088 score |= min (diff, 127) << sort_shift_bits[i];
2091 /* Score the size. Maximum difference is 127. */
2092 i = FONT_SIZE_INDEX;
2093 if (! NILP (spec_prop[FONT_SIZE_INDEX])
2094 && XINT (AREF (entity, FONT_SIZE_INDEX)) > 0)
2096 /* We use the higher 6-bit for the actual size difference. The
2097 lowest bit is set if the DPI is different. */
2098 EMACS_INT diff;
2099 EMACS_INT pixel_size = XINT (spec_prop[FONT_SIZE_INDEX]);
2101 if (CONSP (Vface_font_rescale_alist))
2102 pixel_size *= font_rescale_ratio (entity);
2103 diff = pixel_size - XINT (AREF (entity, FONT_SIZE_INDEX));
2104 if (diff < 0)
2105 diff = - diff;
2106 diff <<= 1;
2107 if (! NILP (spec_prop[FONT_DPI_INDEX])
2108 && ! EQ (spec_prop[FONT_DPI_INDEX], AREF (entity, FONT_DPI_INDEX)))
2109 diff |= 1;
2110 if (! NILP (spec_prop[FONT_AVGWIDTH_INDEX])
2111 && ! EQ (spec_prop[FONT_AVGWIDTH_INDEX], AREF (entity, FONT_AVGWIDTH_INDEX)))
2112 diff |= 1;
2113 score |= min (diff, 127) << sort_shift_bits[FONT_SIZE_INDEX];
2116 return score;
2120 /* Concatenate all elements of LIST into one vector. LIST is a list
2121 of font-entity vectors. */
2123 static Lisp_Object
2124 font_vconcat_entity_vectors (Lisp_Object list)
2126 int nargs = XINT (Flength (list));
2127 Lisp_Object *args = alloca (sizeof (Lisp_Object) * nargs);
2128 int i;
2130 for (i = 0; i < nargs; i++, list = XCDR (list))
2131 args[i] = XCAR (list);
2132 return Fvconcat (nargs, args);
2136 /* The structure for elements being sorted by qsort. */
2137 struct font_sort_data
2139 unsigned score;
2140 int font_driver_preference;
2141 Lisp_Object entity;
2145 /* The comparison function for qsort. */
2147 static int
2148 font_compare (const void *d1, const void *d2)
2150 const struct font_sort_data *data1 = d1;
2151 const struct font_sort_data *data2 = d2;
2153 if (data1->score < data2->score)
2154 return -1;
2155 else if (data1->score > data2->score)
2156 return 1;
2157 return (data1->font_driver_preference - data2->font_driver_preference);
2161 /* Sort each font-entity vector in LIST by closeness to font-spec PREFER.
2162 If PREFER specifies a point-size, calculate the corresponding
2163 pixel-size from QCdpi property of PREFER or from the Y-resolution
2164 of FRAME before sorting.
2166 If BEST-ONLY is nonzero, return the best matching entity (that
2167 supports the character BEST-ONLY if BEST-ONLY is positive, or any
2168 if BEST-ONLY is negative). Otherwise, return the sorted result as
2169 a single vector of font-entities.
2171 This function does no optimization for the case that the total
2172 number of elements is 1. The caller should avoid calling this in
2173 such a case. */
2175 static Lisp_Object
2176 font_sort_entities (Lisp_Object list, Lisp_Object prefer, Lisp_Object frame, int best_only)
2178 Lisp_Object prefer_prop[FONT_SPEC_MAX];
2179 int len, maxlen, i;
2180 struct font_sort_data *data;
2181 unsigned best_score;
2182 Lisp_Object best_entity;
2183 struct frame *f = XFRAME (frame);
2184 Lisp_Object tail, vec IF_LINT (= Qnil);
2185 USE_SAFE_ALLOCA;
2187 for (i = FONT_WEIGHT_INDEX; i <= FONT_AVGWIDTH_INDEX; i++)
2188 prefer_prop[i] = AREF (prefer, i);
2189 if (FLOATP (prefer_prop[FONT_SIZE_INDEX]))
2190 prefer_prop[FONT_SIZE_INDEX]
2191 = make_number (font_pixel_size (XFRAME (frame), prefer));
2193 if (NILP (XCDR (list)))
2195 /* What we have to take care of is this single vector. */
2196 vec = XCAR (list);
2197 maxlen = ASIZE (vec);
2199 else if (best_only)
2201 /* We don't have to perform sort, so there's no need of creating
2202 a single vector. But, we must find the length of the longest
2203 vector. */
2204 maxlen = 0;
2205 for (tail = list; CONSP (tail); tail = XCDR (tail))
2206 if (maxlen < ASIZE (XCAR (tail)))
2207 maxlen = ASIZE (XCAR (tail));
2209 else
2211 /* We have to create a single vector to sort it. */
2212 vec = font_vconcat_entity_vectors (list);
2213 maxlen = ASIZE (vec);
2216 SAFE_ALLOCA (data, struct font_sort_data *, (sizeof *data) * maxlen);
2217 best_score = 0xFFFFFFFF;
2218 best_entity = Qnil;
2220 for (tail = list; CONSP (tail); tail = XCDR (tail))
2222 int font_driver_preference = 0;
2223 Lisp_Object current_font_driver;
2225 if (best_only)
2226 vec = XCAR (tail);
2227 len = ASIZE (vec);
2229 /* We are sure that the length of VEC > 0. */
2230 current_font_driver = AREF (AREF (vec, 0), FONT_TYPE_INDEX);
2231 /* Score the elements. */
2232 for (i = 0; i < len; i++)
2234 data[i].entity = AREF (vec, i);
2235 data[i].score
2236 = ((best_only <= 0 || font_has_char (f, data[i].entity, best_only)
2237 > 0)
2238 ? font_score (data[i].entity, prefer_prop)
2239 : 0xFFFFFFFF);
2240 if (best_only && best_score > data[i].score)
2242 best_score = data[i].score;
2243 best_entity = data[i].entity;
2244 if (best_score == 0)
2245 break;
2247 if (! EQ (current_font_driver, AREF (AREF (vec, i), FONT_TYPE_INDEX)))
2249 current_font_driver = AREF (AREF (vec, i), FONT_TYPE_INDEX);
2250 font_driver_preference++;
2252 data[i].font_driver_preference = font_driver_preference;
2255 /* Sort if necessary. */
2256 if (! best_only)
2258 qsort (data, len, sizeof *data, font_compare);
2259 for (i = 0; i < len; i++)
2260 ASET (vec, i, data[i].entity);
2261 break;
2263 else
2264 vec = best_entity;
2267 SAFE_FREE ();
2269 FONT_ADD_LOG ("sort-by", prefer, vec);
2270 return vec;
2274 /* API of Font Service Layer. */
2276 /* Reflect ORDER (see the variable font_sort_order in xfaces.c) to
2277 sort_shift_bits. Finternal_set_font_selection_order calls this
2278 function with font_sort_order after setting up it. */
2280 void
2281 font_update_sort_order (int *order)
2283 int i, shift_bits;
2285 for (i = 0, shift_bits = 23; i < 4; i++, shift_bits -= 7)
2287 int xlfd_idx = order[i];
2289 if (xlfd_idx == XLFD_WEIGHT_INDEX)
2290 sort_shift_bits[FONT_WEIGHT_INDEX] = shift_bits;
2291 else if (xlfd_idx == XLFD_SLANT_INDEX)
2292 sort_shift_bits[FONT_SLANT_INDEX] = shift_bits;
2293 else if (xlfd_idx == XLFD_SWIDTH_INDEX)
2294 sort_shift_bits[FONT_WIDTH_INDEX] = shift_bits;
2295 else
2296 sort_shift_bits[FONT_SIZE_INDEX] = shift_bits;
2300 static int
2301 font_check_otf_features (Lisp_Object script, Lisp_Object langsys, Lisp_Object features, Lisp_Object table)
2303 Lisp_Object val;
2304 int negative;
2306 table = assq_no_quit (script, table);
2307 if (NILP (table))
2308 return 0;
2309 table = XCDR (table);
2310 if (! NILP (langsys))
2312 table = assq_no_quit (langsys, table);
2313 if (NILP (table))
2314 return 0;
2316 else
2318 val = assq_no_quit (Qnil, table);
2319 if (NILP (val))
2320 table = XCAR (table);
2321 else
2322 table = val;
2324 table = XCDR (table);
2325 for (negative = 0; CONSP (features); features = XCDR (features))
2327 if (NILP (XCAR (features)))
2329 negative = 1;
2330 continue;
2332 if (NILP (Fmemq (XCAR (features), table)) != negative)
2333 return 0;
2335 return 1;
2338 /* Check if OTF_CAPABILITY satisfies SPEC (otf-spec). */
2340 static int
2341 font_check_otf (Lisp_Object spec, Lisp_Object otf_capability)
2343 Lisp_Object script, langsys = Qnil, gsub = Qnil, gpos = Qnil;
2345 script = XCAR (spec);
2346 spec = XCDR (spec);
2347 if (! NILP (spec))
2349 langsys = XCAR (spec);
2350 spec = XCDR (spec);
2351 if (! NILP (spec))
2353 gsub = XCAR (spec);
2354 spec = XCDR (spec);
2355 if (! NILP (spec))
2356 gpos = XCAR (spec);
2360 if (! NILP (gsub) && ! font_check_otf_features (script, langsys, gsub,
2361 XCAR (otf_capability)))
2362 return 0;
2363 if (! NILP (gpos) && ! font_check_otf_features (script, langsys, gpos,
2364 XCDR (otf_capability)))
2365 return 0;
2366 return 1;
2371 /* Check if FONT (font-entity or font-object) matches with the font
2372 specification SPEC. */
2375 font_match_p (Lisp_Object spec, Lisp_Object font)
2377 Lisp_Object prop[FONT_SPEC_MAX], *props;
2378 Lisp_Object extra, font_extra;
2379 int i;
2381 for (i = FONT_FOUNDRY_INDEX; i <= FONT_REGISTRY_INDEX; i++)
2382 if (! NILP (AREF (spec, i))
2383 && ! NILP (AREF (font, i))
2384 && ! EQ (AREF (spec, i), AREF (font, i)))
2385 return 0;
2386 props = XFONT_SPEC (spec)->props;
2387 if (FLOATP (props[FONT_SIZE_INDEX]))
2389 for (i = FONT_FOUNDRY_INDEX; i < FONT_SIZE_INDEX; i++)
2390 prop[i] = AREF (spec, i);
2391 prop[FONT_SIZE_INDEX]
2392 = make_number (font_pixel_size (XFRAME (selected_frame), spec));
2393 props = prop;
2396 if (font_score (font, props) > 0)
2397 return 0;
2398 extra = AREF (spec, FONT_EXTRA_INDEX);
2399 font_extra = AREF (font, FONT_EXTRA_INDEX);
2400 for (; CONSP (extra); extra = XCDR (extra))
2402 Lisp_Object key = XCAR (XCAR (extra));
2403 Lisp_Object val = XCDR (XCAR (extra)), val2;
2405 if (EQ (key, QClang))
2407 val2 = assq_no_quit (key, font_extra);
2408 if (NILP (val2))
2409 return 0;
2410 val2 = XCDR (val2);
2411 if (CONSP (val))
2413 if (! CONSP (val2))
2414 return 0;
2415 while (CONSP (val))
2416 if (NILP (Fmemq (val, val2)))
2417 return 0;
2419 else
2420 if (CONSP (val2)
2421 ? NILP (Fmemq (val, XCDR (val2)))
2422 : ! EQ (val, val2))
2423 return 0;
2425 else if (EQ (key, QCscript))
2427 val2 = assq_no_quit (val, Vscript_representative_chars);
2428 if (CONSP (val2))
2430 val2 = XCDR (val2);
2431 if (CONSP (val2))
2433 /* All characters in the list must be supported. */
2434 for (; CONSP (val2); val2 = XCDR (val2))
2436 if (! NATNUMP (XCAR (val2)))
2437 continue;
2438 if (font_encode_char (font, XFASTINT (XCAR (val2)))
2439 == FONT_INVALID_CODE)
2440 return 0;
2443 else if (VECTORP (val2))
2445 /* At most one character in the vector must be supported. */
2446 for (i = 0; i < ASIZE (val2); i++)
2448 if (! NATNUMP (AREF (val2, i)))
2449 continue;
2450 if (font_encode_char (font, XFASTINT (AREF (val2, i)))
2451 != FONT_INVALID_CODE)
2452 break;
2454 if (i == ASIZE (val2))
2455 return 0;
2459 else if (EQ (key, QCotf))
2461 struct font *fontp;
2463 if (! FONT_OBJECT_P (font))
2464 return 0;
2465 fontp = XFONT_OBJECT (font);
2466 if (! fontp->driver->otf_capability)
2467 return 0;
2468 val2 = fontp->driver->otf_capability (fontp);
2469 if (NILP (val2) || ! font_check_otf (val, val2))
2470 return 0;
2474 return 1;
2478 /* Font cache
2480 Each font backend has the callback function get_cache, and it
2481 returns a cons cell of which cdr part can be freely used for
2482 caching fonts. The cons cell may be shared by multiple frames
2483 and/or multiple font drivers. So, we arrange the cdr part as this:
2485 ((DRIVER-TYPE NUM-FRAMES FONT-CACHE-DATA ...) ...)
2487 where DRIVER-TYPE is a symbol such as `x', `xft', etc., NUM-FRAMES
2488 is a number frames sharing this cache, and FONT-CACHE-DATA is a
2489 cons (FONT-SPEC FONT-ENTITY ...). */
2491 static void font_prepare_cache (FRAME_PTR, struct font_driver *);
2492 static void font_finish_cache (FRAME_PTR, struct font_driver *);
2493 static Lisp_Object font_get_cache (FRAME_PTR, struct font_driver *);
2494 static void font_clear_cache (FRAME_PTR, Lisp_Object,
2495 struct font_driver *);
2497 static void
2498 font_prepare_cache (FRAME_PTR f, struct font_driver *driver)
2500 Lisp_Object cache, val;
2502 cache = driver->get_cache (f);
2503 val = XCDR (cache);
2504 while (CONSP (val) && ! EQ (XCAR (XCAR (val)), driver->type))
2505 val = XCDR (val);
2506 if (NILP (val))
2508 val = Fcons (driver->type, Fcons (make_number (1), Qnil));
2509 XSETCDR (cache, Fcons (val, XCDR (cache)));
2511 else
2513 val = XCDR (XCAR (val));
2514 XSETCAR (val, make_number (XINT (XCAR (val)) + 1));
2519 static void
2520 font_finish_cache (FRAME_PTR f, struct font_driver *driver)
2522 Lisp_Object cache, val, tmp;
2525 cache = driver->get_cache (f);
2526 val = XCDR (cache);
2527 while (CONSP (val) && ! EQ (XCAR (XCAR (val)), driver->type))
2528 cache = val, val = XCDR (val);
2529 font_assert (! NILP (val));
2530 tmp = XCDR (XCAR (val));
2531 XSETCAR (tmp, make_number (XINT (XCAR (tmp)) - 1));
2532 if (XINT (XCAR (tmp)) == 0)
2534 font_clear_cache (f, XCAR (val), driver);
2535 XSETCDR (cache, XCDR (val));
2540 static Lisp_Object
2541 font_get_cache (FRAME_PTR f, struct font_driver *driver)
2543 Lisp_Object val = driver->get_cache (f);
2544 Lisp_Object type = driver->type;
2546 font_assert (CONSP (val));
2547 for (val = XCDR (val); ! EQ (XCAR (XCAR (val)), type); val = XCDR (val));
2548 font_assert (CONSP (val));
2549 /* VAL = ((DRIVER-TYPE NUM-FRAMES FONT-CACHE-DATA ...) ...) */
2550 val = XCDR (XCAR (val));
2551 return val;
2554 static int num_fonts;
2556 static void
2557 font_clear_cache (FRAME_PTR f, Lisp_Object cache, struct font_driver *driver)
2559 Lisp_Object tail, elt;
2560 Lisp_Object tail2, entity;
2562 /* CACHE = (DRIVER-TYPE NUM-FRAMES FONT-CACHE-DATA ...) */
2563 for (tail = XCDR (XCDR (cache)); CONSP (tail); tail = XCDR (tail))
2565 elt = XCAR (tail);
2566 /* elt should have the form (FONT-SPEC FONT-ENTITY ...) */
2567 if (CONSP (elt) && FONT_SPEC_P (XCAR (elt)))
2569 for (tail2 = XCDR (elt); CONSP (tail2); tail2 = XCDR (tail2))
2571 entity = XCAR (tail2);
2573 if (FONT_ENTITY_P (entity)
2574 && EQ (driver->type, AREF (entity, FONT_TYPE_INDEX)))
2576 Lisp_Object objlist = AREF (entity, FONT_OBJLIST_INDEX);
2578 for (; CONSP (objlist); objlist = XCDR (objlist))
2580 Lisp_Object val = XCAR (objlist);
2581 struct font *font = XFONT_OBJECT (val);
2583 if (! NILP (AREF (val, FONT_TYPE_INDEX)))
2585 font_assert (font && driver == font->driver);
2586 driver->close (f, font);
2587 num_fonts--;
2590 if (driver->free_entity)
2591 driver->free_entity (entity);
2596 XSETCDR (cache, Qnil);
2600 static Lisp_Object scratch_font_spec, scratch_font_prefer;
2602 /* Check each font-entity in VEC, and return a list of font-entities
2603 that satisfy these conditions:
2604 (1) matches with SPEC and SIZE if SPEC is not nil, and
2605 (2) doesn't match with any regexps in Vface_ignored_fonts (if non-nil).
2608 static Lisp_Object
2609 font_delete_unmatched (Lisp_Object vec, Lisp_Object spec, int size)
2611 Lisp_Object entity, val;
2612 enum font_property_index prop;
2613 int i;
2615 for (val = Qnil, i = ASIZE (vec) - 1; i >= 0; i--)
2617 entity = AREF (vec, i);
2618 if (! NILP (Vface_ignored_fonts))
2620 char name[256];
2621 Lisp_Object tail, regexp;
2623 if (font_unparse_xlfd (entity, 0, name, 256) >= 0)
2625 for (tail = Vface_ignored_fonts; CONSP (tail); tail = XCDR (tail))
2627 regexp = XCAR (tail);
2628 if (STRINGP (regexp)
2629 && fast_c_string_match_ignore_case (regexp, name) >= 0)
2630 break;
2632 if (CONSP (tail))
2633 continue;
2636 if (NILP (spec))
2638 val = Fcons (entity, val);
2639 continue;
2641 for (prop = FONT_WEIGHT_INDEX; prop < FONT_SIZE_INDEX; prop++)
2642 if (INTEGERP (AREF (spec, prop))
2643 && ((XINT (AREF (spec, prop)) >> 8)
2644 != (XINT (AREF (entity, prop)) >> 8)))
2645 prop = FONT_SPEC_MAX;
2646 if (prop < FONT_SPEC_MAX
2647 && size
2648 && XINT (AREF (entity, FONT_SIZE_INDEX)) > 0)
2650 int diff = XINT (AREF (entity, FONT_SIZE_INDEX)) - size;
2652 if (diff != 0
2653 && (diff < 0 ? -diff > FONT_PIXEL_SIZE_QUANTUM
2654 : diff > FONT_PIXEL_SIZE_QUANTUM))
2655 prop = FONT_SPEC_MAX;
2657 if (prop < FONT_SPEC_MAX
2658 && INTEGERP (AREF (spec, FONT_DPI_INDEX))
2659 && INTEGERP (AREF (entity, FONT_DPI_INDEX))
2660 && XINT (AREF (entity, FONT_DPI_INDEX)) != 0
2661 && ! EQ (AREF (spec, FONT_DPI_INDEX), AREF (entity, FONT_DPI_INDEX)))
2662 prop = FONT_SPEC_MAX;
2663 if (prop < FONT_SPEC_MAX
2664 && INTEGERP (AREF (spec, FONT_AVGWIDTH_INDEX))
2665 && INTEGERP (AREF (entity, FONT_AVGWIDTH_INDEX))
2666 && XINT (AREF (entity, FONT_AVGWIDTH_INDEX)) != 0
2667 && ! EQ (AREF (spec, FONT_AVGWIDTH_INDEX),
2668 AREF (entity, FONT_AVGWIDTH_INDEX)))
2669 prop = FONT_SPEC_MAX;
2670 if (prop < FONT_SPEC_MAX)
2671 val = Fcons (entity, val);
2673 return (Fvconcat (1, &val));
2677 /* Return a list of vectors of font-entities matching with SPEC on
2678 FRAME. Each elements in the list is a vector of entities from the
2679 same font-driver. */
2681 Lisp_Object
2682 font_list_entities (Lisp_Object frame, Lisp_Object spec)
2684 FRAME_PTR f = XFRAME (frame);
2685 struct font_driver_list *driver_list = f->font_driver_list;
2686 Lisp_Object ftype, val;
2687 Lisp_Object list = Qnil;
2688 int size;
2689 int need_filtering = 0;
2690 int i;
2692 font_assert (FONT_SPEC_P (spec));
2694 if (INTEGERP (AREF (spec, FONT_SIZE_INDEX)))
2695 size = XINT (AREF (spec, FONT_SIZE_INDEX));
2696 else if (FLOATP (AREF (spec, FONT_SIZE_INDEX)))
2697 size = font_pixel_size (f, spec);
2698 else
2699 size = 0;
2701 ftype = AREF (spec, FONT_TYPE_INDEX);
2702 for (i = FONT_FOUNDRY_INDEX; i <= FONT_REGISTRY_INDEX; i++)
2703 ASET (scratch_font_spec, i, AREF (spec, i));
2704 for (i = FONT_WEIGHT_INDEX; i < FONT_EXTRA_INDEX; i++)
2705 if (i != FONT_SPACING_INDEX)
2707 ASET (scratch_font_spec, i, Qnil);
2708 if (! NILP (AREF (spec, i)))
2709 need_filtering = 1;
2711 ASET (scratch_font_spec, FONT_SPACING_INDEX, AREF (spec, FONT_SPACING_INDEX));
2712 ASET (scratch_font_spec, FONT_EXTRA_INDEX, AREF (spec, FONT_EXTRA_INDEX));
2714 for (i = 0; driver_list; driver_list = driver_list->next)
2715 if (driver_list->on
2716 && (NILP (ftype) || EQ (driver_list->driver->type, ftype)))
2718 Lisp_Object cache = font_get_cache (f, driver_list->driver);
2720 ASET (scratch_font_spec, FONT_TYPE_INDEX, driver_list->driver->type);
2721 val = assoc_no_quit (scratch_font_spec, XCDR (cache));
2722 if (CONSP (val))
2723 val = XCDR (val);
2724 else
2726 Lisp_Object copy;
2728 val = driver_list->driver->list (frame, scratch_font_spec);
2729 if (NILP (val))
2730 val = null_vector;
2731 else
2732 val = Fvconcat (1, &val);
2733 copy = copy_font_spec (scratch_font_spec);
2734 ASET (copy, FONT_TYPE_INDEX, driver_list->driver->type);
2735 XSETCDR (cache, Fcons (Fcons (copy, val), XCDR (cache)));
2737 if (ASIZE (val) > 0
2738 && (need_filtering
2739 || ! NILP (Vface_ignored_fonts)))
2740 val = font_delete_unmatched (val, need_filtering ? spec : Qnil, size);
2741 if (ASIZE (val) > 0)
2742 list = Fcons (val, list);
2745 list = Fnreverse (list);
2746 FONT_ADD_LOG ("list", spec, list);
2747 return list;
2751 /* Return a font entity matching with SPEC on FRAME. ATTRS, if non
2752 nil, is an array of face's attributes, which specifies preferred
2753 font-related attributes. */
2755 static Lisp_Object
2756 font_matching_entity (FRAME_PTR f, Lisp_Object *attrs, Lisp_Object spec)
2758 struct font_driver_list *driver_list = f->font_driver_list;
2759 Lisp_Object ftype, size, entity;
2760 Lisp_Object frame;
2761 Lisp_Object work = copy_font_spec (spec);
2763 XSETFRAME (frame, f);
2764 ftype = AREF (spec, FONT_TYPE_INDEX);
2765 size = AREF (spec, FONT_SIZE_INDEX);
2767 if (FLOATP (size))
2768 ASET (work, FONT_SIZE_INDEX, make_number (font_pixel_size (f, spec)));
2769 FONT_SET_STYLE (work, FONT_WEIGHT_INDEX, attrs[LFACE_WEIGHT_INDEX]);
2770 FONT_SET_STYLE (work, FONT_SLANT_INDEX, attrs[LFACE_SLANT_INDEX]);
2771 FONT_SET_STYLE (work, FONT_WIDTH_INDEX, attrs[LFACE_SWIDTH_INDEX]);
2773 entity = Qnil;
2774 for (; driver_list; driver_list = driver_list->next)
2775 if (driver_list->on
2776 && (NILP (ftype) || EQ (driver_list->driver->type, ftype)))
2778 Lisp_Object cache = font_get_cache (f, driver_list->driver);
2779 Lisp_Object copy;
2781 ASET (work, FONT_TYPE_INDEX, driver_list->driver->type);
2782 entity = assoc_no_quit (work, XCDR (cache));
2783 if (CONSP (entity))
2784 entity = XCDR (entity);
2785 else
2787 entity = driver_list->driver->match (frame, work);
2788 copy = copy_font_spec (work);
2789 ASET (copy, FONT_TYPE_INDEX, driver_list->driver->type);
2790 XSETCDR (cache, Fcons (Fcons (copy, entity), XCDR (cache)));
2792 if (! NILP (entity))
2793 break;
2795 FONT_ADD_LOG ("match", work, entity);
2796 return entity;
2800 /* Open a font of ENTITY and PIXEL_SIZE on frame F, and return the
2801 opened font object. */
2803 static Lisp_Object
2804 font_open_entity (FRAME_PTR f, Lisp_Object entity, int pixel_size)
2806 struct font_driver_list *driver_list;
2807 Lisp_Object objlist, size, val, font_object;
2808 struct font *font;
2809 int min_width, height;
2810 int scaled_pixel_size = pixel_size;
2812 font_assert (FONT_ENTITY_P (entity));
2813 size = AREF (entity, FONT_SIZE_INDEX);
2814 if (XINT (size) != 0)
2815 scaled_pixel_size = pixel_size = XINT (size);
2816 else if (CONSP (Vface_font_rescale_alist))
2817 scaled_pixel_size = pixel_size * font_rescale_ratio (entity);
2819 val = AREF (entity, FONT_TYPE_INDEX);
2820 for (driver_list = f->font_driver_list;
2821 driver_list && ! EQ (driver_list->driver->type, val);
2822 driver_list = driver_list->next);
2823 if (! driver_list)
2824 return Qnil;
2826 for (objlist = AREF (entity, FONT_OBJLIST_INDEX); CONSP (objlist);
2827 objlist = XCDR (objlist))
2829 Lisp_Object fn = XCAR (objlist);
2830 if (! NILP (AREF (fn, FONT_TYPE_INDEX))
2831 && XFONT_OBJECT (fn)->pixel_size == pixel_size)
2833 if (driver_list->driver->cached_font_ok == NULL
2834 || driver_list->driver->cached_font_ok (f, fn, entity))
2835 return fn;
2839 font_object = driver_list->driver->open (f, entity, scaled_pixel_size);
2840 if (!NILP (font_object))
2841 ASET (font_object, FONT_SIZE_INDEX, make_number (pixel_size));
2842 FONT_ADD_LOG ("open", entity, font_object);
2843 if (NILP (font_object))
2844 return Qnil;
2845 ASET (entity, FONT_OBJLIST_INDEX,
2846 Fcons (font_object, AREF (entity, FONT_OBJLIST_INDEX)));
2847 num_fonts++;
2849 font = XFONT_OBJECT (font_object);
2850 min_width = (font->min_width ? font->min_width
2851 : font->average_width ? font->average_width
2852 : font->space_width ? font->space_width
2853 : 1);
2854 height = (font->height ? font->height : 1);
2855 #ifdef HAVE_WINDOW_SYSTEM
2856 FRAME_X_DISPLAY_INFO (f)->n_fonts++;
2857 if (FRAME_X_DISPLAY_INFO (f)->n_fonts == 1)
2859 FRAME_SMALLEST_CHAR_WIDTH (f) = min_width;
2860 FRAME_SMALLEST_FONT_HEIGHT (f) = height;
2861 fonts_changed_p = 1;
2863 else
2865 if (FRAME_SMALLEST_CHAR_WIDTH (f) > min_width)
2866 FRAME_SMALLEST_CHAR_WIDTH (f) = min_width, fonts_changed_p = 1;
2867 if (FRAME_SMALLEST_FONT_HEIGHT (f) > height)
2868 FRAME_SMALLEST_FONT_HEIGHT (f) = height, fonts_changed_p = 1;
2870 #endif
2872 return font_object;
2876 /* Close FONT_OBJECT that is opened on frame F. */
2878 static void
2879 font_close_object (FRAME_PTR f, Lisp_Object font_object)
2881 struct font *font = XFONT_OBJECT (font_object);
2883 if (NILP (AREF (font_object, FONT_TYPE_INDEX)))
2884 /* Already closed. */
2885 return;
2886 FONT_ADD_LOG ("close", font_object, Qnil);
2887 font->driver->close (f, font);
2888 #ifdef HAVE_WINDOW_SYSTEM
2889 font_assert (FRAME_X_DISPLAY_INFO (f)->n_fonts);
2890 FRAME_X_DISPLAY_INFO (f)->n_fonts--;
2891 #endif
2892 num_fonts--;
2896 /* Return 1 if FONT on F has a glyph for character C, 0 if not, -1 if
2897 FONT is a font-entity and it must be opened to check. */
2900 font_has_char (FRAME_PTR f, Lisp_Object font, int c)
2902 struct font *fontp;
2904 if (FONT_ENTITY_P (font))
2906 Lisp_Object type = AREF (font, FONT_TYPE_INDEX);
2907 struct font_driver_list *driver_list;
2909 for (driver_list = f->font_driver_list;
2910 driver_list && ! EQ (driver_list->driver->type, type);
2911 driver_list = driver_list->next);
2912 if (! driver_list)
2913 return 0;
2914 if (! driver_list->driver->has_char)
2915 return -1;
2916 return driver_list->driver->has_char (font, c);
2919 font_assert (FONT_OBJECT_P (font));
2920 fontp = XFONT_OBJECT (font);
2921 if (fontp->driver->has_char)
2923 int result = fontp->driver->has_char (font, c);
2925 if (result >= 0)
2926 return result;
2928 return (fontp->driver->encode_char (fontp, c) != FONT_INVALID_CODE);
2932 /* Return the glyph ID of FONT_OBJECT for character C. */
2934 static unsigned
2935 font_encode_char (Lisp_Object font_object, int c)
2937 struct font *font;
2939 font_assert (FONT_OBJECT_P (font_object));
2940 font = XFONT_OBJECT (font_object);
2941 return font->driver->encode_char (font, c);
2945 /* Return the name of FONT_OBJECT. */
2947 Lisp_Object
2948 font_get_name (Lisp_Object font_object)
2950 font_assert (FONT_OBJECT_P (font_object));
2951 return AREF (font_object, FONT_NAME_INDEX);
2955 /* Create a new font spec from FONT_NAME, and return it. If FONT_NAME
2956 could not be parsed by font_parse_name, return Qnil. */
2958 Lisp_Object
2959 font_spec_from_name (Lisp_Object font_name)
2961 Lisp_Object spec = Ffont_spec (0, NULL);
2963 CHECK_STRING (font_name);
2964 if (font_parse_name (SSDATA (font_name), spec) == -1)
2965 return Qnil;
2966 font_put_extra (spec, QCname, font_name);
2967 font_put_extra (spec, QCuser_spec, font_name);
2968 return spec;
2972 void
2973 font_clear_prop (Lisp_Object *attrs, enum font_property_index prop)
2975 Lisp_Object font = attrs[LFACE_FONT_INDEX];
2977 if (! FONTP (font))
2978 return;
2980 if (! NILP (Ffont_get (font, QCname)))
2982 font = copy_font_spec (font);
2983 font_put_extra (font, QCname, Qnil);
2986 if (NILP (AREF (font, prop))
2987 && prop != FONT_FAMILY_INDEX
2988 && prop != FONT_FOUNDRY_INDEX
2989 && prop != FONT_WIDTH_INDEX
2990 && prop != FONT_SIZE_INDEX)
2991 return;
2992 if (EQ (font, attrs[LFACE_FONT_INDEX]))
2993 font = copy_font_spec (font);
2994 ASET (font, prop, Qnil);
2995 if (prop == FONT_FAMILY_INDEX || prop == FONT_FOUNDRY_INDEX)
2997 if (prop == FONT_FAMILY_INDEX)
2999 ASET (font, FONT_FOUNDRY_INDEX, Qnil);
3000 /* If we are setting the font family, we must also clear
3001 FONT_WIDTH_INDEX to avoid rejecting families that lack
3002 support for some widths. */
3003 ASET (font, FONT_WIDTH_INDEX, Qnil);
3005 ASET (font, FONT_ADSTYLE_INDEX, Qnil);
3006 ASET (font, FONT_REGISTRY_INDEX, Qnil);
3007 ASET (font, FONT_SIZE_INDEX, Qnil);
3008 ASET (font, FONT_DPI_INDEX, Qnil);
3009 ASET (font, FONT_SPACING_INDEX, Qnil);
3010 ASET (font, FONT_AVGWIDTH_INDEX, Qnil);
3012 else if (prop == FONT_SIZE_INDEX)
3014 ASET (font, FONT_DPI_INDEX, Qnil);
3015 ASET (font, FONT_SPACING_INDEX, Qnil);
3016 ASET (font, FONT_AVGWIDTH_INDEX, Qnil);
3018 else if (prop == FONT_WIDTH_INDEX)
3019 ASET (font, FONT_AVGWIDTH_INDEX, Qnil);
3020 attrs[LFACE_FONT_INDEX] = font;
3023 /* Select a font from ENTITIES (list of font-entity vectors) that
3024 supports C and is the best match for ATTRS and PIXEL_SIZE. */
3026 static Lisp_Object
3027 font_select_entity (Lisp_Object frame, Lisp_Object entities, Lisp_Object *attrs, int pixel_size, int c)
3029 Lisp_Object font_entity;
3030 Lisp_Object prefer;
3031 int result, i;
3032 FRAME_PTR f = XFRAME (frame);
3034 if (NILP (XCDR (entities))
3035 && ASIZE (XCAR (entities)) == 1)
3037 font_entity = AREF (XCAR (entities), 0);
3038 if (c < 0
3039 || (result = font_has_char (f, font_entity, c)) > 0)
3040 return font_entity;
3041 return Qnil;
3044 /* Sort fonts by properties specified in ATTRS. */
3045 prefer = scratch_font_prefer;
3047 for (i = FONT_WEIGHT_INDEX; i <= FONT_SIZE_INDEX; i++)
3048 ASET (prefer, i, Qnil);
3049 if (FONTP (attrs[LFACE_FONT_INDEX]))
3051 Lisp_Object face_font = attrs[LFACE_FONT_INDEX];
3053 for (i = FONT_WEIGHT_INDEX; i <= FONT_SIZE_INDEX; i++)
3054 ASET (prefer, i, AREF (face_font, i));
3056 if (NILP (AREF (prefer, FONT_WEIGHT_INDEX)))
3057 FONT_SET_STYLE (prefer, FONT_WEIGHT_INDEX, attrs[LFACE_WEIGHT_INDEX]);
3058 if (NILP (AREF (prefer, FONT_SLANT_INDEX)))
3059 FONT_SET_STYLE (prefer, FONT_SLANT_INDEX, attrs[LFACE_SLANT_INDEX]);
3060 if (NILP (AREF (prefer, FONT_WIDTH_INDEX)))
3061 FONT_SET_STYLE (prefer, FONT_WIDTH_INDEX, attrs[LFACE_SWIDTH_INDEX]);
3062 ASET (prefer, FONT_SIZE_INDEX, make_number (pixel_size));
3064 return font_sort_entities (entities, prefer, frame, c);
3067 /* Return a font-entity that satisfies SPEC and is the best match for
3068 face's font related attributes in ATTRS. C, if not negative, is a
3069 character that the entity must support. */
3071 Lisp_Object
3072 font_find_for_lface (FRAME_PTR f, Lisp_Object *attrs, Lisp_Object spec, int c)
3074 Lisp_Object work;
3075 Lisp_Object frame, entities, val;
3076 Lisp_Object foundry[3], *family, registry[3], adstyle[3];
3077 int pixel_size;
3078 int i, j, k, l;
3080 registry[0] = AREF (spec, FONT_REGISTRY_INDEX);
3081 if (NILP (registry[0]))
3083 registry[0] = DEFAULT_ENCODING;
3084 registry[1] = Qascii_0;
3085 registry[2] = null_vector;
3087 else
3088 registry[1] = null_vector;
3090 if (c >= 0 && ! NILP (AREF (spec, FONT_REGISTRY_INDEX)))
3092 struct charset *encoding, *repertory;
3094 if (font_registry_charsets (AREF (spec, FONT_REGISTRY_INDEX),
3095 &encoding, &repertory) < 0)
3096 return Qnil;
3097 if (repertory
3098 && ENCODE_CHAR (repertory, c) == CHARSET_INVALID_CODE (repertory))
3099 return Qnil;
3100 else if (c > encoding->max_char)
3101 return Qnil;
3104 work = copy_font_spec (spec);
3105 ASET (work, FONT_TYPE_INDEX, AREF (spec, FONT_TYPE_INDEX));
3106 XSETFRAME (frame, f);
3107 pixel_size = font_pixel_size (f, spec);
3108 if (pixel_size == 0 && INTEGERP (attrs[LFACE_HEIGHT_INDEX]))
3110 double pt = XINT (attrs[LFACE_HEIGHT_INDEX]);
3112 pixel_size = POINT_TO_PIXEL (pt / 10, f->resy);
3114 ASET (work, FONT_SIZE_INDEX, Qnil);
3115 foundry[0] = AREF (work, FONT_FOUNDRY_INDEX);
3116 if (! NILP (foundry[0]))
3117 foundry[1] = null_vector;
3118 else if (STRINGP (attrs[LFACE_FOUNDRY_INDEX]))
3120 val = attrs[LFACE_FOUNDRY_INDEX];
3121 foundry[0] = font_intern_prop (SSDATA (val), SBYTES (val), 1);
3122 foundry[1] = Qnil;
3123 foundry[2] = null_vector;
3125 else
3126 foundry[0] = Qnil, foundry[1] = null_vector;
3128 adstyle[0] = AREF (work, FONT_ADSTYLE_INDEX);
3129 if (! NILP (adstyle[0]))
3130 adstyle[1] = null_vector;
3131 else if (FONTP (attrs[LFACE_FONT_INDEX]))
3133 Lisp_Object face_font = attrs[LFACE_FONT_INDEX];
3135 if (! NILP (AREF (face_font, FONT_ADSTYLE_INDEX)))
3137 adstyle[0] = AREF (face_font, FONT_ADSTYLE_INDEX);
3138 adstyle[1] = Qnil;
3139 adstyle[2] = null_vector;
3141 else
3142 adstyle[0] = Qnil, adstyle[1] = null_vector;
3144 else
3145 adstyle[0] = Qnil, adstyle[1] = null_vector;
3148 val = AREF (work, FONT_FAMILY_INDEX);
3149 if (NILP (val) && STRINGP (attrs[LFACE_FAMILY_INDEX]))
3151 val = attrs[LFACE_FAMILY_INDEX];
3152 val = font_intern_prop (SSDATA (val), SBYTES (val), 1);
3154 if (NILP (val))
3156 family = alloca ((sizeof family[0]) * 2);
3157 family[0] = Qnil;
3158 family[1] = null_vector; /* terminator. */
3160 else
3162 Lisp_Object alters
3163 = Fassoc_string (val, Vface_alternative_font_family_alist,
3164 /* Font family names are case-sensitive under NS. */
3165 #ifndef HAVE_NS
3167 #else
3168 Qnil
3169 #endif
3172 if (! NILP (alters))
3174 family = alloca ((sizeof family[0]) * (XINT (Flength (alters)) + 2));
3175 for (i = 0; CONSP (alters); i++, alters = XCDR (alters))
3176 family[i] = XCAR (alters);
3177 if (NILP (AREF (spec, FONT_FAMILY_INDEX)))
3178 family[i++] = Qnil;
3179 family[i] = null_vector;
3181 else
3183 family = alloca ((sizeof family[0]) * 3);
3184 i = 0;
3185 family[i++] = val;
3186 if (NILP (AREF (spec, FONT_FAMILY_INDEX)))
3187 family[i++] = Qnil;
3188 family[i] = null_vector;
3192 for (i = 0; SYMBOLP (family[i]); i++)
3194 ASET (work, FONT_FAMILY_INDEX, family[i]);
3195 for (j = 0; SYMBOLP (foundry[j]); j++)
3197 ASET (work, FONT_FOUNDRY_INDEX, foundry[j]);
3198 for (k = 0; SYMBOLP (registry[k]); k++)
3200 ASET (work, FONT_REGISTRY_INDEX, registry[k]);
3201 for (l = 0; SYMBOLP (adstyle[l]); l++)
3203 ASET (work, FONT_ADSTYLE_INDEX, adstyle[l]);
3204 entities = font_list_entities (frame, work);
3205 if (! NILP (entities))
3207 val = font_select_entity (frame, entities,
3208 attrs, pixel_size, c);
3209 if (! NILP (val))
3210 return val;
3216 return Qnil;
3220 Lisp_Object
3221 font_open_for_lface (FRAME_PTR f, Lisp_Object entity, Lisp_Object *attrs, Lisp_Object spec)
3223 int size;
3225 if (INTEGERP (AREF (entity, FONT_SIZE_INDEX))
3226 && XINT (AREF (entity, FONT_SIZE_INDEX)) > 0)
3227 size = XINT (AREF (entity, FONT_SIZE_INDEX));
3228 else if (FONT_SPEC_P (spec) && ! NILP (AREF (spec, FONT_SIZE_INDEX)))
3229 size = font_pixel_size (f, spec);
3230 else
3232 double pt;
3233 if (INTEGERP (attrs[LFACE_HEIGHT_INDEX]))
3234 pt = XINT (attrs[LFACE_HEIGHT_INDEX]);
3235 else
3237 struct face *def = FACE_FROM_ID (f, DEFAULT_FACE_ID);
3238 Lisp_Object height = def->lface[LFACE_HEIGHT_INDEX];
3239 if (INTEGERP (height))
3240 pt = XINT (height);
3241 else
3242 abort (); /* We should never end up here. */
3245 pt /= 10;
3246 size = POINT_TO_PIXEL (pt, f->resy);
3247 #ifdef HAVE_NS
3248 if (size == 0)
3250 Lisp_Object ffsize = get_frame_param (f, Qfontsize);
3251 size = NUMBERP (ffsize) ? POINT_TO_PIXEL (XINT (ffsize), f->resy) : 0;
3253 #endif
3255 return font_open_entity (f, entity, size);
3259 /* Find a font that satisfies SPEC and is the best match for
3260 face's attributes in ATTRS on FRAME, and return the opened
3261 font-object. */
3263 Lisp_Object
3264 font_load_for_lface (FRAME_PTR f, Lisp_Object *attrs, Lisp_Object spec)
3266 Lisp_Object entity, name;
3268 entity = font_find_for_lface (f, attrs, spec, -1);
3269 if (NILP (entity))
3271 /* No font is listed for SPEC, but each font-backend may have
3272 different criteria about "font matching". So, try it. */
3273 entity = font_matching_entity (f, attrs, spec);
3274 if (NILP (entity))
3275 return Qnil;
3277 /* Don't lose the original name that was put in initially. We need
3278 it to re-apply the font when font parameters (like hinting or dpi) have
3279 changed. */
3280 entity = font_open_for_lface (f, entity, attrs, spec);
3281 if (!NILP (entity))
3283 name = Ffont_get (spec, QCuser_spec);
3284 if (STRINGP (name)) font_put_extra (entity, QCuser_spec, name);
3286 return entity;
3290 /* Make FACE on frame F ready to use the font opened for FACE. */
3292 void
3293 font_prepare_for_face (FRAME_PTR f, struct face *face)
3295 if (face->font->driver->prepare_face)
3296 face->font->driver->prepare_face (f, face);
3300 /* Make FACE on frame F stop using the font opened for FACE. */
3302 void
3303 font_done_for_face (FRAME_PTR f, struct face *face)
3305 if (face->font->driver->done_face)
3306 face->font->driver->done_face (f, face);
3307 face->extra = NULL;
3311 /* Open a font that is a match for font-spec SPEC on frame F. If no proper
3312 font is found, return Qnil. */
3314 Lisp_Object
3315 font_open_by_spec (FRAME_PTR f, Lisp_Object spec)
3317 Lisp_Object attrs[LFACE_VECTOR_SIZE];
3319 /* We set up the default font-related attributes of a face to prefer
3320 a moderate font. */
3321 attrs[LFACE_FAMILY_INDEX] = attrs[LFACE_FOUNDRY_INDEX] = Qnil;
3322 attrs[LFACE_SWIDTH_INDEX] = attrs[LFACE_WEIGHT_INDEX]
3323 = attrs[LFACE_SLANT_INDEX] = Qnormal;
3324 #ifndef HAVE_NS
3325 attrs[LFACE_HEIGHT_INDEX] = make_number (120);
3326 #else
3327 attrs[LFACE_HEIGHT_INDEX] = make_number (0);
3328 #endif
3329 attrs[LFACE_FONT_INDEX] = Qnil;
3331 return font_load_for_lface (f, attrs, spec);
3335 /* Open a font that matches NAME on frame F. If no proper font is
3336 found, return Qnil. */
3338 Lisp_Object
3339 font_open_by_name (FRAME_PTR f, const char *name)
3341 Lisp_Object args[2];
3342 Lisp_Object spec, ret;
3344 args[0] = QCname;
3345 args[1] = make_unibyte_string (name, strlen (name));
3346 spec = Ffont_spec (2, args);
3347 ret = font_open_by_spec (f, spec);
3348 /* Do not lose name originally put in. */
3349 if (!NILP (ret))
3350 font_put_extra (ret, QCuser_spec, args[1]);
3352 return ret;
3356 /* Register font-driver DRIVER. This function is used in two ways.
3358 The first is with frame F non-NULL. In this case, make DRIVER
3359 available (but not yet activated) on F. All frame creators
3360 (e.g. Fx_create_frame) must call this function at least once with
3361 an available font-driver.
3363 The second is with frame F NULL. In this case, DRIVER is globally
3364 registered in the variable `font_driver_list'. All font-driver
3365 implementations must call this function in its syms_of_XXXX
3366 (e.g. syms_of_xfont). */
3368 void
3369 register_font_driver (struct font_driver *driver, FRAME_PTR f)
3371 struct font_driver_list *root = f ? f->font_driver_list : font_driver_list;
3372 struct font_driver_list *prev, *list;
3374 if (f && ! driver->draw)
3375 error ("Unusable font driver for a frame: %s",
3376 SDATA (SYMBOL_NAME (driver->type)));
3378 for (prev = NULL, list = root; list; prev = list, list = list->next)
3379 if (EQ (list->driver->type, driver->type))
3380 error ("Duplicated font driver: %s", SDATA (SYMBOL_NAME (driver->type)));
3382 list = xmalloc (sizeof (struct font_driver_list));
3383 list->on = 0;
3384 list->driver = driver;
3385 list->next = NULL;
3386 if (prev)
3387 prev->next = list;
3388 else if (f)
3389 f->font_driver_list = list;
3390 else
3391 font_driver_list = list;
3392 if (! f)
3393 num_font_drivers++;
3396 void
3397 free_font_driver_list (FRAME_PTR f)
3399 struct font_driver_list *list, *next;
3401 for (list = f->font_driver_list; list; list = next)
3403 next = list->next;
3404 xfree (list);
3406 f->font_driver_list = NULL;
3410 /* Make the frame F use font backends listed in NEW_DRIVERS (list of
3411 symbols, e.g. xft, x). If NEW_DRIVERS is t, make F use all
3412 available font drivers. If NEW_DRIVERS is nil, finalize all drivers.
3414 A caller must free all realized faces if any in advance. The
3415 return value is a list of font backends actually made used on
3416 F. */
3418 Lisp_Object
3419 font_update_drivers (FRAME_PTR f, Lisp_Object new_drivers)
3421 Lisp_Object active_drivers = Qnil;
3422 struct font_driver_list *list;
3424 /* At first, turn off non-requested drivers, and turn on requested
3425 drivers. */
3426 for (list = f->font_driver_list; list; list = list->next)
3428 struct font_driver *driver = list->driver;
3429 if ((EQ (new_drivers, Qt) || ! NILP (Fmemq (driver->type, new_drivers)))
3430 != list->on)
3432 if (list->on)
3434 if (driver->end_for_frame)
3435 driver->end_for_frame (f);
3436 font_finish_cache (f, driver);
3437 list->on = 0;
3439 else
3441 if (! driver->start_for_frame
3442 || driver->start_for_frame (f) == 0)
3444 font_prepare_cache (f, driver);
3445 list->on = 1;
3451 if (NILP (new_drivers))
3452 return Qnil;
3454 if (! EQ (new_drivers, Qt))
3456 /* Re-order the driver list according to new_drivers. */
3457 struct font_driver_list **list_table, **next;
3458 Lisp_Object tail;
3459 int i;
3461 list_table = alloca (sizeof list_table[0] * (num_font_drivers + 1));
3462 for (i = 0, tail = new_drivers; ! NILP (tail); tail = XCDR (tail))
3464 for (list = f->font_driver_list; list; list = list->next)
3465 if (list->on && EQ (list->driver->type, XCAR (tail)))
3466 break;
3467 if (list)
3468 list_table[i++] = list;
3470 for (list = f->font_driver_list; list; list = list->next)
3471 if (! list->on)
3472 list_table[i++] = list;
3473 list_table[i] = NULL;
3475 next = &f->font_driver_list;
3476 for (i = 0; list_table[i]; i++)
3478 *next = list_table[i];
3479 next = &(*next)->next;
3481 *next = NULL;
3483 if (! f->font_driver_list->on)
3484 { /* None of the drivers is enabled: enable them all.
3485 Happens if you set the list of drivers to (xft x) in your .emacs
3486 and then use it under w32 or ns. */
3487 for (list = f->font_driver_list; list; list = list->next)
3489 struct font_driver *driver = list->driver;
3490 eassert (! list->on);
3491 if (! driver->start_for_frame
3492 || driver->start_for_frame (f) == 0)
3494 font_prepare_cache (f, driver);
3495 list->on = 1;
3501 for (list = f->font_driver_list; list; list = list->next)
3502 if (list->on)
3503 active_drivers = nconc2 (active_drivers,
3504 Fcons (list->driver->type, Qnil));
3505 return active_drivers;
3509 font_put_frame_data (FRAME_PTR f, struct font_driver *driver, void *data)
3511 struct font_data_list *list, *prev;
3513 for (prev = NULL, list = f->font_data_list; list;
3514 prev = list, list = list->next)
3515 if (list->driver == driver)
3516 break;
3517 if (! data)
3519 if (list)
3521 if (prev)
3522 prev->next = list->next;
3523 else
3524 f->font_data_list = list->next;
3525 xfree (list);
3527 return 0;
3530 if (! list)
3532 list = xmalloc (sizeof (struct font_data_list));
3533 list->driver = driver;
3534 list->next = f->font_data_list;
3535 f->font_data_list = list;
3537 list->data = data;
3538 return 0;
3542 void *
3543 font_get_frame_data (FRAME_PTR f, struct font_driver *driver)
3545 struct font_data_list *list;
3547 for (list = f->font_data_list; list; list = list->next)
3548 if (list->driver == driver)
3549 break;
3550 if (! list)
3551 return NULL;
3552 return list->data;
3556 /* Sets attributes on a font. Any properties that appear in ALIST and
3557 BOOLEAN_PROPERTIES or NON_BOOLEAN_PROPERTIES are set on the font.
3558 BOOLEAN_PROPERTIES and NON_BOOLEAN_PROPERTIES are NULL-terminated
3559 arrays of strings. This function is intended for use by the font
3560 drivers to implement their specific font_filter_properties. */
3561 void
3562 font_filter_properties (Lisp_Object font,
3563 Lisp_Object alist,
3564 const char *const boolean_properties[],
3565 const char *const non_boolean_properties[])
3567 Lisp_Object it;
3568 int i;
3570 /* Set boolean values to Qt or Qnil */
3571 for (i = 0; boolean_properties[i] != NULL; ++i)
3572 for (it = alist; ! NILP (it); it = XCDR (it))
3574 Lisp_Object key = XCAR (XCAR (it));
3575 Lisp_Object val = XCDR (XCAR (it));
3576 char *keystr = SSDATA (SYMBOL_NAME (key));
3578 if (strcmp (boolean_properties[i], keystr) == 0)
3580 const char *str = INTEGERP (val) ? (XINT (val) ? "true" : "false")
3581 : SYMBOLP (val) ? SSDATA (SYMBOL_NAME (val))
3582 : "true";
3584 if (strcmp ("false", str) == 0 || strcmp ("False", str) == 0
3585 || strcmp ("FALSE", str) == 0 || strcmp ("FcFalse", str) == 0
3586 || strcmp ("off", str) == 0 || strcmp ("OFF", str) == 0
3587 || strcmp ("Off", str) == 0)
3588 val = Qnil;
3589 else
3590 val = Qt;
3592 Ffont_put (font, key, val);
3596 for (i = 0; non_boolean_properties[i] != NULL; ++i)
3597 for (it = alist; ! NILP (it); it = XCDR (it))
3599 Lisp_Object key = XCAR (XCAR (it));
3600 Lisp_Object val = XCDR (XCAR (it));
3601 char *keystr = SSDATA (SYMBOL_NAME (key));
3602 if (strcmp (non_boolean_properties[i], keystr) == 0)
3603 Ffont_put (font, key, val);
3608 /* Return the font used to draw character C by FACE at buffer position
3609 POS in window W. If STRING is non-nil, it is a string containing C
3610 at index POS. If C is negative, get C from the current buffer or
3611 STRING. */
3613 static Lisp_Object
3614 font_at (int c, EMACS_INT pos, struct face *face, struct window *w,
3615 Lisp_Object string)
3617 FRAME_PTR f;
3618 int multibyte;
3619 Lisp_Object font_object;
3621 multibyte = (NILP (string)
3622 ? ! NILP (BVAR (current_buffer, enable_multibyte_characters))
3623 : STRING_MULTIBYTE (string));
3624 if (c < 0)
3626 if (NILP (string))
3628 if (multibyte)
3630 EMACS_INT pos_byte = CHAR_TO_BYTE (pos);
3632 c = FETCH_CHAR (pos_byte);
3634 else
3635 c = FETCH_BYTE (pos);
3637 else
3639 unsigned char *str;
3641 multibyte = STRING_MULTIBYTE (string);
3642 if (multibyte)
3644 EMACS_INT pos_byte = string_char_to_byte (string, pos);
3646 str = SDATA (string) + pos_byte;
3647 c = STRING_CHAR (str);
3649 else
3650 c = SDATA (string)[pos];
3654 f = XFRAME (w->frame);
3655 if (! FRAME_WINDOW_P (f))
3656 return Qnil;
3657 if (! face)
3659 int face_id;
3660 EMACS_INT endptr;
3662 if (STRINGP (string))
3663 face_id = face_at_string_position (w, string, pos, 0, -1, -1, &endptr,
3664 DEFAULT_FACE_ID, 0);
3665 else
3666 face_id = face_at_buffer_position (w, pos, -1, -1, &endptr,
3667 pos + 100, 0, -1);
3668 face = FACE_FROM_ID (f, face_id);
3670 if (multibyte)
3672 int face_id = FACE_FOR_CHAR (f, face, c, pos, string);
3673 face = FACE_FROM_ID (f, face_id);
3675 if (! face->font)
3676 return Qnil;
3678 XSETFONT (font_object, face->font);
3679 return font_object;
3683 #ifdef HAVE_WINDOW_SYSTEM
3685 /* Check how many characters after POS (at most to *LIMIT) can be
3686 displayed by the same font in the window W. FACE, if non-NULL, is
3687 the face selected for the character at POS. If STRING is not nil,
3688 it is the string to check instead of the current buffer. In that
3689 case, FACE must be not NULL.
3691 The return value is the font-object for the character at POS.
3692 *LIMIT is set to the position where that font can't be used.
3694 It is assured that the current buffer (or STRING) is multibyte. */
3696 Lisp_Object
3697 font_range (EMACS_INT pos, EMACS_INT *limit, struct window *w, struct face *face, Lisp_Object string)
3699 EMACS_INT pos_byte, ignore;
3700 int c;
3701 Lisp_Object font_object = Qnil;
3703 if (NILP (string))
3705 pos_byte = CHAR_TO_BYTE (pos);
3706 if (! face)
3708 int face_id;
3710 face_id = face_at_buffer_position (w, pos, 0, 0, &ignore,
3711 *limit, 0, -1);
3712 face = FACE_FROM_ID (XFRAME (w->frame), face_id);
3715 else
3717 font_assert (face);
3718 pos_byte = string_char_to_byte (string, pos);
3721 while (pos < *limit)
3723 Lisp_Object category;
3725 if (NILP (string))
3726 FETCH_CHAR_ADVANCE_NO_CHECK (c, pos, pos_byte);
3727 else
3728 FETCH_STRING_CHAR_ADVANCE_NO_CHECK (c, string, pos, pos_byte);
3729 category = CHAR_TABLE_REF (Vunicode_category_table, c);
3730 if (INTEGERP (category)
3731 && (XINT (category) == UNICODE_CATEGORY_Cf
3732 || CHAR_VARIATION_SELECTOR_P (c)))
3733 continue;
3734 if (NILP (font_object))
3736 font_object = font_for_char (face, c, pos - 1, string);
3737 if (NILP (font_object))
3738 return Qnil;
3739 continue;
3741 if (font_encode_char (font_object, c) == FONT_INVALID_CODE)
3742 *limit = pos - 1;
3744 return font_object;
3746 #endif
3749 /* Lisp API */
3751 DEFUN ("fontp", Ffontp, Sfontp, 1, 2, 0,
3752 doc: /* Return t if OBJECT is a font-spec, font-entity, or font-object.
3753 Return nil otherwise.
3754 Optional 2nd argument EXTRA-TYPE, if non-nil, specifies to check
3755 which kind of font it is. It must be one of `font-spec', `font-entity',
3756 `font-object'. */)
3757 (Lisp_Object object, Lisp_Object extra_type)
3759 if (NILP (extra_type))
3760 return (FONTP (object) ? Qt : Qnil);
3761 if (EQ (extra_type, Qfont_spec))
3762 return (FONT_SPEC_P (object) ? Qt : Qnil);
3763 if (EQ (extra_type, Qfont_entity))
3764 return (FONT_ENTITY_P (object) ? Qt : Qnil);
3765 if (EQ (extra_type, Qfont_object))
3766 return (FONT_OBJECT_P (object) ? Qt : Qnil);
3767 wrong_type_argument (intern ("font-extra-type"), extra_type);
3770 DEFUN ("font-spec", Ffont_spec, Sfont_spec, 0, MANY, 0,
3771 doc: /* Return a newly created font-spec with arguments as properties.
3773 ARGS must come in pairs KEY VALUE of font properties. KEY must be a
3774 valid font property name listed below:
3776 `:family', `:weight', `:slant', `:width'
3778 They are the same as face attributes of the same name. See
3779 `set-face-attribute'.
3781 `:foundry'
3783 VALUE must be a string or a symbol specifying the font foundry, e.g. ``misc''.
3785 `:adstyle'
3787 VALUE must be a string or a symbol specifying the additional
3788 typographic style information of a font, e.g. ``sans''.
3790 `:registry'
3792 VALUE must be a string or a symbol specifying the charset registry and
3793 encoding of a font, e.g. ``iso8859-1''.
3795 `:size'
3797 VALUE must be a non-negative integer or a floating point number
3798 specifying the font size. It specifies the font size in pixels (if
3799 VALUE is an integer), or in points (if VALUE is a float).
3801 `:name'
3803 VALUE must be a string of XLFD-style or fontconfig-style font name.
3805 `:script'
3807 VALUE must be a symbol representing a script that the font must
3808 support. It may be a symbol representing a subgroup of a script
3809 listed in the variable `script-representative-chars'.
3811 `:lang'
3813 VALUE must be a symbol of two-letter ISO-639 language names,
3814 e.g. `ja'.
3816 `:otf'
3818 VALUE must be a list (SCRIPT-TAG LANGSYS-TAG GSUB [ GPOS ]) to specify
3819 required OpenType features.
3821 SCRIPT-TAG: OpenType script tag symbol (e.g. `deva').
3822 LANGSYS-TAG: OpenType language system tag symbol,
3823 or nil for the default language system.
3824 GSUB: List of OpenType GSUB feature tag symbols, or nil if none required.
3825 GPOS: List of OpenType GPOS feature tag symbols, or nil if none required.
3827 GSUB and GPOS may contain `nil' element. In such a case, the font
3828 must not have any of the remaining elements.
3830 For instance, if the VALUE is `(thai nil nil (mark))', the font must
3831 be an OpenType font whose GPOS table of `thai' script's default
3832 language system must contain `mark' feature.
3834 usage: (font-spec ARGS...) */)
3835 (ptrdiff_t nargs, Lisp_Object *args)
3837 Lisp_Object spec = font_make_spec ();
3838 ptrdiff_t i;
3840 for (i = 0; i < nargs; i += 2)
3842 Lisp_Object key = args[i], val;
3844 CHECK_SYMBOL (key);
3845 if (i + 1 >= nargs)
3846 error ("No value for key `%s'", SDATA (SYMBOL_NAME (key)));
3847 val = args[i + 1];
3849 if (EQ (key, QCname))
3851 CHECK_STRING (val);
3852 font_parse_name (SSDATA (val), spec);
3853 font_put_extra (spec, key, val);
3855 else
3857 int idx = get_font_prop_index (key);
3859 if (idx >= 0)
3861 val = font_prop_validate (idx, Qnil, val);
3862 if (idx < FONT_EXTRA_INDEX)
3863 ASET (spec, idx, val);
3864 else
3865 font_put_extra (spec, key, val);
3867 else
3868 font_put_extra (spec, key, font_prop_validate (0, key, val));
3871 return spec;
3874 /* Return a copy of FONT as a font-spec. */
3875 Lisp_Object
3876 copy_font_spec (Lisp_Object font)
3878 Lisp_Object new_spec, tail, prev, extra;
3879 int i;
3881 CHECK_FONT (font);
3882 new_spec = font_make_spec ();
3883 for (i = 1; i < FONT_EXTRA_INDEX; i++)
3884 ASET (new_spec, i, AREF (font, i));
3885 extra = Fcopy_alist (AREF (font, FONT_EXTRA_INDEX));
3886 /* We must remove :font-entity property. */
3887 for (prev = Qnil, tail = extra; CONSP (tail); prev = tail, tail = XCDR (tail))
3888 if (EQ (XCAR (XCAR (tail)), QCfont_entity))
3890 if (NILP (prev))
3891 extra = XCDR (extra);
3892 else
3893 XSETCDR (prev, XCDR (tail));
3894 break;
3896 ASET (new_spec, FONT_EXTRA_INDEX, extra);
3897 return new_spec;
3900 /* Merge font-specs FROM and TO, and return a new font-spec.
3901 Every specified property in FROM overrides the corresponding
3902 property in TO. */
3903 Lisp_Object
3904 merge_font_spec (Lisp_Object from, Lisp_Object to)
3906 Lisp_Object extra, tail;
3907 int i;
3909 CHECK_FONT (from);
3910 CHECK_FONT (to);
3911 to = copy_font_spec (to);
3912 for (i = 0; i < FONT_EXTRA_INDEX; i++)
3913 ASET (to, i, AREF (from, i));
3914 extra = AREF (to, FONT_EXTRA_INDEX);
3915 for (tail = AREF (from, FONT_EXTRA_INDEX); CONSP (tail); tail = XCDR (tail))
3916 if (! EQ (XCAR (XCAR (tail)), Qfont_entity))
3918 Lisp_Object slot = assq_no_quit (XCAR (XCAR (tail)), extra);
3920 if (! NILP (slot))
3921 XSETCDR (slot, XCDR (XCAR (tail)));
3922 else
3923 extra = Fcons (Fcons (XCAR (XCAR (tail)), XCDR (XCAR (tail))), extra);
3925 ASET (to, FONT_EXTRA_INDEX, extra);
3926 return to;
3929 DEFUN ("font-get", Ffont_get, Sfont_get, 2, 2, 0,
3930 doc: /* Return the value of FONT's property KEY.
3931 FONT is a font-spec, a font-entity, or a font-object.
3932 KEY is any symbol, but these are reserved for specific meanings:
3933 :family, :weight, :slant, :width, :foundry, :adstyle, :registry,
3934 :size, :name, :script, :otf
3935 See the documentation of `font-spec' for their meanings.
3936 In addition, if FONT is a font-entity or a font-object, values of
3937 :script and :otf are different from those of a font-spec as below:
3939 The value of :script may be a list of scripts that are supported by the font.
3941 The value of :otf is a cons (GSUB . GPOS) where GSUB and GPOS are lists
3942 representing the OpenType features supported by the font by this form:
3943 ((SCRIPT (LANGSYS FEATURE ...) ...) ...)
3944 SCRIPT, LANGSYS, and FEATURE are all symbols representing OpenType
3945 Layout tags. */)
3946 (Lisp_Object font, Lisp_Object key)
3948 int idx;
3949 Lisp_Object val;
3951 CHECK_FONT (font);
3952 CHECK_SYMBOL (key);
3954 idx = get_font_prop_index (key);
3955 if (idx >= FONT_WEIGHT_INDEX && idx <= FONT_WIDTH_INDEX)
3956 return font_style_symbolic (font, idx, 0);
3957 if (idx >= 0 && idx < FONT_EXTRA_INDEX)
3958 return AREF (font, idx);
3959 val = Fassq (key, AREF (font, FONT_EXTRA_INDEX));
3960 if (NILP (val) && EQ (key, QCotf) && FONT_OBJECT_P (font))
3962 struct font *fontp = XFONT_OBJECT (font);
3964 if (fontp->driver->otf_capability)
3965 val = fontp->driver->otf_capability (fontp);
3966 else
3967 val = Fcons (Qnil, Qnil);
3969 else
3970 val = Fcdr (val);
3971 return val;
3974 #ifdef HAVE_WINDOW_SYSTEM
3976 DEFUN ("font-face-attributes", Ffont_face_attributes, Sfont_face_attributes, 1, 2, 0,
3977 doc: /* Return a plist of face attributes generated by FONT.
3978 FONT is a font name, a font-spec, a font-entity, or a font-object.
3979 The return value is a list of the form
3981 \(:family FAMILY :height HEIGHT :weight WEIGHT :slant SLANT :width WIDTH)
3983 where FAMILY, HEIGHT, WEIGHT, SLANT, and WIDTH are face attribute values
3984 compatible with `set-face-attribute'. Some of these key-attribute pairs
3985 may be omitted from the list if they are not specified by FONT.
3987 The optional argument FRAME specifies the frame that the face attributes
3988 are to be displayed on. If omitted, the selected frame is used. */)
3989 (Lisp_Object font, Lisp_Object frame)
3991 struct frame *f;
3992 Lisp_Object plist[10];
3993 Lisp_Object val;
3994 int n = 0;
3996 if (NILP (frame))
3997 frame = selected_frame;
3998 CHECK_LIVE_FRAME (frame);
3999 f = XFRAME (frame);
4001 if (STRINGP (font))
4003 int fontset = fs_query_fontset (font, 0);
4004 Lisp_Object name = font;
4005 if (fontset >= 0)
4006 font = fontset_ascii (fontset);
4007 font = font_spec_from_name (name);
4008 if (! FONTP (font))
4009 signal_error ("Invalid font name", name);
4011 else if (! FONTP (font))
4012 signal_error ("Invalid font object", font);
4014 val = AREF (font, FONT_FAMILY_INDEX);
4015 if (! NILP (val))
4017 plist[n++] = QCfamily;
4018 plist[n++] = SYMBOL_NAME (val);
4021 val = AREF (font, FONT_SIZE_INDEX);
4022 if (INTEGERP (val))
4024 Lisp_Object font_dpi = AREF (font, FONT_DPI_INDEX);
4025 int dpi = INTEGERP (font_dpi) ? XINT (font_dpi) : f->resy;
4026 plist[n++] = QCheight;
4027 plist[n++] = make_number (PIXEL_TO_POINT (XINT (val) * 10, dpi));
4029 else if (FLOATP (val))
4031 plist[n++] = QCheight;
4032 plist[n++] = make_number (10 * (int) XFLOAT_DATA (val));
4035 val = FONT_WEIGHT_FOR_FACE (font);
4036 if (! NILP (val))
4038 plist[n++] = QCweight;
4039 plist[n++] = val;
4042 val = FONT_SLANT_FOR_FACE (font);
4043 if (! NILP (val))
4045 plist[n++] = QCslant;
4046 plist[n++] = val;
4049 val = FONT_WIDTH_FOR_FACE (font);
4050 if (! NILP (val))
4052 plist[n++] = QCwidth;
4053 plist[n++] = val;
4056 return Flist (n, plist);
4059 #endif
4061 DEFUN ("font-put", Ffont_put, Sfont_put, 3, 3, 0,
4062 doc: /* Set one property of FONT: give property KEY value VAL.
4063 FONT is a font-spec, a font-entity, or a font-object.
4065 If FONT is a font-spec, KEY can be any symbol. But if KEY is the one
4066 accepted by the function `font-spec' (which see), VAL must be what
4067 allowed in `font-spec'.
4069 If FONT is a font-entity or a font-object, KEY must not be the one
4070 accepted by `font-spec'. */)
4071 (Lisp_Object font, Lisp_Object prop, Lisp_Object val)
4073 int idx;
4075 idx = get_font_prop_index (prop);
4076 if (idx >= 0 && idx < FONT_EXTRA_INDEX)
4078 CHECK_FONT_SPEC (font);
4079 ASET (font, idx, font_prop_validate (idx, Qnil, val));
4081 else
4083 if (EQ (prop, QCname)
4084 || EQ (prop, QCscript)
4085 || EQ (prop, QClang)
4086 || EQ (prop, QCotf))
4087 CHECK_FONT_SPEC (font);
4088 else
4089 CHECK_FONT (font);
4090 font_put_extra (font, prop, font_prop_validate (0, prop, val));
4092 return val;
4095 DEFUN ("list-fonts", Flist_fonts, Slist_fonts, 1, 4, 0,
4096 doc: /* List available fonts matching FONT-SPEC on the current frame.
4097 Optional 2nd argument FRAME specifies the target frame.
4098 Optional 3rd argument NUM, if non-nil, limits the number of returned fonts.
4099 Optional 4th argument PREFER, if non-nil, is a font-spec to
4100 control the order of the returned list. Fonts are sorted by
4101 how close they are to PREFER. */)
4102 (Lisp_Object font_spec, Lisp_Object frame, Lisp_Object num, Lisp_Object prefer)
4104 Lisp_Object vec, list;
4105 int n = 0;
4107 if (NILP (frame))
4108 frame = selected_frame;
4109 CHECK_LIVE_FRAME (frame);
4110 CHECK_FONT_SPEC (font_spec);
4111 if (! NILP (num))
4113 CHECK_NUMBER (num);
4114 n = XINT (num);
4115 if (n <= 0)
4116 return Qnil;
4118 if (! NILP (prefer))
4119 CHECK_FONT_SPEC (prefer);
4121 list = font_list_entities (frame, font_spec);
4122 if (NILP (list))
4123 return Qnil;
4124 if (NILP (XCDR (list))
4125 && ASIZE (XCAR (list)) == 1)
4126 return Fcons (AREF (XCAR (list), 0), Qnil);
4128 if (! NILP (prefer))
4129 vec = font_sort_entities (list, prefer, frame, 0);
4130 else
4131 vec = font_vconcat_entity_vectors (list);
4132 if (n == 0 || n >= ASIZE (vec))
4134 Lisp_Object args[2];
4136 args[0] = vec;
4137 args[1] = Qnil;
4138 list = Fappend (2, args);
4140 else
4142 for (list = Qnil, n--; n >= 0; n--)
4143 list = Fcons (AREF (vec, n), list);
4145 return list;
4148 DEFUN ("font-family-list", Ffont_family_list, Sfont_family_list, 0, 1, 0,
4149 doc: /* List available font families on the current frame.
4150 Optional argument FRAME, if non-nil, specifies the target frame. */)
4151 (Lisp_Object frame)
4153 FRAME_PTR f;
4154 struct font_driver_list *driver_list;
4155 Lisp_Object list;
4157 if (NILP (frame))
4158 frame = selected_frame;
4159 CHECK_LIVE_FRAME (frame);
4160 f = XFRAME (frame);
4161 list = Qnil;
4162 for (driver_list = f->font_driver_list; driver_list;
4163 driver_list = driver_list->next)
4164 if (driver_list->driver->list_family)
4166 Lisp_Object val = driver_list->driver->list_family (frame);
4167 Lisp_Object tail = list;
4169 for (; CONSP (val); val = XCDR (val))
4170 if (NILP (Fmemq (XCAR (val), tail))
4171 && SYMBOLP (XCAR (val)))
4172 list = Fcons (SYMBOL_NAME (XCAR (val)), list);
4174 return list;
4177 DEFUN ("find-font", Ffind_font, Sfind_font, 1, 2, 0,
4178 doc: /* Return a font-entity matching with FONT-SPEC on the current frame.
4179 Optional 2nd argument FRAME, if non-nil, specifies the target frame. */)
4180 (Lisp_Object font_spec, Lisp_Object frame)
4182 Lisp_Object val = Flist_fonts (font_spec, frame, make_number (1), Qnil);
4184 if (CONSP (val))
4185 val = XCAR (val);
4186 return val;
4189 DEFUN ("font-xlfd-name", Ffont_xlfd_name, Sfont_xlfd_name, 1, 2, 0,
4190 doc: /* Return XLFD name of FONT.
4191 FONT is a font-spec, font-entity, or font-object.
4192 If the name is too long for XLFD (maximum 255 chars), return nil.
4193 If the 2nd optional arg FOLD-WILDCARDS is non-nil,
4194 the consecutive wildcards are folded into one. */)
4195 (Lisp_Object font, Lisp_Object fold_wildcards)
4197 char name[256];
4198 int pixel_size = 0;
4200 CHECK_FONT (font);
4202 if (FONT_OBJECT_P (font))
4204 Lisp_Object font_name = AREF (font, FONT_NAME_INDEX);
4206 if (STRINGP (font_name)
4207 && SDATA (font_name)[0] == '-')
4209 if (NILP (fold_wildcards))
4210 return font_name;
4211 strcpy (name, SSDATA (font_name));
4212 goto done;
4214 pixel_size = XFONT_OBJECT (font)->pixel_size;
4216 if (font_unparse_xlfd (font, pixel_size, name, 256) < 0)
4217 return Qnil;
4218 done:
4219 if (! NILP (fold_wildcards))
4221 char *p0 = name, *p1;
4223 while ((p1 = strstr (p0, "-*-*")))
4225 strcpy (p1, p1 + 2);
4226 p0 = p1;
4230 return build_string (name);
4233 DEFUN ("clear-font-cache", Fclear_font_cache, Sclear_font_cache, 0, 0, 0,
4234 doc: /* Clear font cache. */)
4235 (void)
4237 Lisp_Object list, frame;
4239 FOR_EACH_FRAME (list, frame)
4241 FRAME_PTR f = XFRAME (frame);
4242 struct font_driver_list *driver_list = f->font_driver_list;
4244 for (; driver_list; driver_list = driver_list->next)
4245 if (driver_list->on)
4247 Lisp_Object cache = driver_list->driver->get_cache (f);
4248 Lisp_Object val, tmp;
4250 val = XCDR (cache);
4251 while (! NILP (val)
4252 && ! EQ (XCAR (XCAR (val)), driver_list->driver->type))
4253 val = XCDR (val);
4254 font_assert (! NILP (val));
4255 tmp = XCDR (XCAR (val));
4256 if (XINT (XCAR (tmp)) == 0)
4258 font_clear_cache (f, XCAR (val), driver_list->driver);
4259 XSETCDR (cache, XCDR (val));
4264 return Qnil;
4268 void
4269 font_fill_lglyph_metrics (Lisp_Object glyph, Lisp_Object font_object)
4271 struct font *font = XFONT_OBJECT (font_object);
4272 unsigned code;
4273 /* ecode used in LGLYPH_SET_CODE to avoid compiler warnings. */
4274 EMACS_INT ecode = font->driver->encode_char (font, LGLYPH_CHAR (glyph));
4275 struct font_metrics metrics;
4277 LGLYPH_SET_CODE (glyph, ecode);
4278 code = ecode;
4279 font->driver->text_extents (font, &code, 1, &metrics);
4280 LGLYPH_SET_LBEARING (glyph, metrics.lbearing);
4281 LGLYPH_SET_RBEARING (glyph, metrics.rbearing);
4282 LGLYPH_SET_WIDTH (glyph, metrics.width);
4283 LGLYPH_SET_ASCENT (glyph, metrics.ascent);
4284 LGLYPH_SET_DESCENT (glyph, metrics.descent);
4288 DEFUN ("font-shape-gstring", Ffont_shape_gstring, Sfont_shape_gstring, 1, 1, 0,
4289 doc: /* Shape the glyph-string GSTRING.
4290 Shaping means substituting glyphs and/or adjusting positions of glyphs
4291 to get the correct visual image of character sequences set in the
4292 header of the glyph-string.
4294 If the shaping was successful, the value is GSTRING itself or a newly
4295 created glyph-string. Otherwise, the value is nil. */)
4296 (Lisp_Object gstring)
4298 struct font *font;
4299 Lisp_Object font_object, n, glyph;
4300 EMACS_INT i, j, from, to;
4302 if (! composition_gstring_p (gstring))
4303 signal_error ("Invalid glyph-string: ", gstring);
4304 if (! NILP (LGSTRING_ID (gstring)))
4305 return gstring;
4306 font_object = LGSTRING_FONT (gstring);
4307 CHECK_FONT_OBJECT (font_object);
4308 font = XFONT_OBJECT (font_object);
4309 if (! font->driver->shape)
4310 return Qnil;
4312 /* Try at most three times with larger gstring each time. */
4313 for (i = 0; i < 3; i++)
4315 n = font->driver->shape (gstring);
4316 if (INTEGERP (n))
4317 break;
4318 gstring = larger_vector (gstring,
4319 ASIZE (gstring) + LGSTRING_GLYPH_LEN (gstring),
4320 Qnil);
4322 if (i == 3 || XINT (n) == 0)
4323 return Qnil;
4324 if (XINT (n) < LGSTRING_GLYPH_LEN (gstring))
4325 LGSTRING_SET_GLYPH (gstring, XINT (n), Qnil);
4327 glyph = LGSTRING_GLYPH (gstring, 0);
4328 from = LGLYPH_FROM (glyph);
4329 to = LGLYPH_TO (glyph);
4330 for (i = 1, j = 0; i < LGSTRING_GLYPH_LEN (gstring); i++)
4332 Lisp_Object this = LGSTRING_GLYPH (gstring, i);
4334 if (NILP (this))
4335 break;
4336 if (NILP (LGLYPH_ADJUSTMENT (this)))
4338 if (j < i - 1)
4339 for (; j < i; j++)
4341 glyph = LGSTRING_GLYPH (gstring, j);
4342 LGLYPH_SET_FROM (glyph, from);
4343 LGLYPH_SET_TO (glyph, to);
4345 from = LGLYPH_FROM (this);
4346 to = LGLYPH_TO (this);
4347 j = i;
4349 else
4351 if (from > LGLYPH_FROM (this))
4352 from = LGLYPH_FROM (this);
4353 if (to < LGLYPH_TO (this))
4354 to = LGLYPH_TO (this);
4357 if (j < i - 1)
4358 for (; j < i; j++)
4360 glyph = LGSTRING_GLYPH (gstring, j);
4361 LGLYPH_SET_FROM (glyph, from);
4362 LGLYPH_SET_TO (glyph, to);
4364 return composition_gstring_put_cache (gstring, XINT (n));
4367 DEFUN ("font-variation-glyphs", Ffont_variation_glyphs, Sfont_variation_glyphs,
4368 2, 2, 0,
4369 doc: /* Return a list of variation glyphs for CHAR in FONT-OBJECT.
4370 Each element of the value is a cons (VARIATION-SELECTOR . GLYPH-ID),
4371 where
4372 VARIATION-SELECTOR is a character code of variation selection
4373 (#xFE00..#xFE0F or #xE0100..#xE01EF)
4374 GLYPH-ID is a glyph code of the corresponding variation glyph. */)
4375 (Lisp_Object font_object, Lisp_Object character)
4377 unsigned variations[256];
4378 struct font *font;
4379 int i, n;
4380 Lisp_Object val;
4382 CHECK_FONT_OBJECT (font_object);
4383 CHECK_CHARACTER (character);
4384 font = XFONT_OBJECT (font_object);
4385 if (! font->driver->get_variation_glyphs)
4386 return Qnil;
4387 n = font->driver->get_variation_glyphs (font, XINT (character), variations);
4388 if (! n)
4389 return Qnil;
4390 val = Qnil;
4391 for (i = 0; i < 255; i++)
4392 if (variations[i])
4394 int vs = (i < 16 ? 0xFE00 + i : 0xE0100 + (i - 16));
4395 Lisp_Object code = INTEGER_TO_CONS (variations[i]);
4396 val = Fcons (Fcons (make_number (vs), code), val);
4398 return val;
4401 #if 0
4403 DEFUN ("font-drive-otf", Ffont_drive_otf, Sfont_drive_otf, 6, 6, 0,
4404 doc: /* Apply OpenType features on glyph-string GSTRING-IN.
4405 OTF-FEATURES specifies which features to apply in this format:
4406 (SCRIPT LANGSYS GSUB GPOS)
4407 where
4408 SCRIPT is a symbol specifying a script tag of OpenType,
4409 LANGSYS is a symbol specifying a langsys tag of OpenType,
4410 GSUB and GPOS, if non-nil, are lists of symbols specifying feature tags.
4412 If LANGYS is nil, the default langsys is selected.
4414 The features are applied in the order they appear in the list. The
4415 symbol `*' means to apply all available features not present in this
4416 list, and the remaining features are ignored. For instance, (vatu
4417 pstf * haln) is to apply vatu and pstf in this order, then to apply
4418 all available features other than vatu, pstf, and haln.
4420 The features are applied to the glyphs in the range FROM and TO of
4421 the glyph-string GSTRING-IN.
4423 If some feature is actually applicable, the resulting glyphs are
4424 produced in the glyph-string GSTRING-OUT from the index INDEX. In
4425 this case, the value is the number of produced glyphs.
4427 If no feature is applicable, no glyph is produced in GSTRING-OUT, and
4428 the value is 0.
4430 If GSTRING-OUT is too short to hold produced glyphs, no glyphs are
4431 produced in GSTRING-OUT, and the value is nil.
4433 See the documentation of `composition-get-gstring' for the format of
4434 glyph-string. */)
4435 (Lisp_Object otf_features, Lisp_Object gstring_in, Lisp_Object from, Lisp_Object to, Lisp_Object gstring_out, Lisp_Object index)
4437 Lisp_Object font_object = LGSTRING_FONT (gstring_in);
4438 Lisp_Object val;
4439 struct font *font;
4440 int len, num;
4442 check_otf_features (otf_features);
4443 CHECK_FONT_OBJECT (font_object);
4444 font = XFONT_OBJECT (font_object);
4445 if (! font->driver->otf_drive)
4446 error ("Font backend %s can't drive OpenType GSUB table",
4447 SDATA (SYMBOL_NAME (font->driver->type)));
4448 CHECK_CONS (otf_features);
4449 CHECK_SYMBOL (XCAR (otf_features));
4450 val = XCDR (otf_features);
4451 CHECK_SYMBOL (XCAR (val));
4452 val = XCDR (otf_features);
4453 if (! NILP (val))
4454 CHECK_CONS (val);
4455 len = check_gstring (gstring_in);
4456 CHECK_VECTOR (gstring_out);
4457 CHECK_NATNUM (from);
4458 CHECK_NATNUM (to);
4459 CHECK_NATNUM (index);
4461 if (XINT (from) >= XINT (to) || XINT (to) > len)
4462 args_out_of_range_3 (from, to, make_number (len));
4463 if (XINT (index) >= ASIZE (gstring_out))
4464 args_out_of_range (index, make_number (ASIZE (gstring_out)));
4465 num = font->driver->otf_drive (font, otf_features,
4466 gstring_in, XINT (from), XINT (to),
4467 gstring_out, XINT (index), 0);
4468 if (num < 0)
4469 return Qnil;
4470 return make_number (num);
4473 DEFUN ("font-otf-alternates", Ffont_otf_alternates, Sfont_otf_alternates,
4474 3, 3, 0,
4475 doc: /* Return a list of alternate glyphs of CHARACTER in FONT-OBJECT.
4476 OTF-FEATURES specifies which features of the font FONT-OBJECT to apply
4477 in this format:
4478 (SCRIPT LANGSYS FEATURE ...)
4479 See the documentation of `font-drive-otf' for more detail.
4481 The value is a list of cons cells of the format (GLYPH-ID . CHARACTER),
4482 where GLYPH-ID is a glyph index of the font, and CHARACTER is a
4483 character code corresponding to the glyph or nil if there's no
4484 corresponding character. */)
4485 (Lisp_Object font_object, Lisp_Object character, Lisp_Object otf_features)
4487 struct font *font;
4488 Lisp_Object gstring_in, gstring_out, g;
4489 Lisp_Object alternates;
4490 int i, num;
4492 CHECK_FONT_GET_OBJECT (font_object, font);
4493 if (! font->driver->otf_drive)
4494 error ("Font backend %s can't drive OpenType GSUB table",
4495 SDATA (SYMBOL_NAME (font->driver->type)));
4496 CHECK_CHARACTER (character);
4497 CHECK_CONS (otf_features);
4499 gstring_in = Ffont_make_gstring (font_object, make_number (1));
4500 g = LGSTRING_GLYPH (gstring_in, 0);
4501 LGLYPH_SET_CHAR (g, XINT (character));
4502 gstring_out = Ffont_make_gstring (font_object, make_number (10));
4503 while ((num = font->driver->otf_drive (font, otf_features, gstring_in, 0, 1,
4504 gstring_out, 0, 1)) < 0)
4505 gstring_out = Ffont_make_gstring (font_object,
4506 make_number (ASIZE (gstring_out) * 2));
4507 alternates = Qnil;
4508 for (i = 0; i < num; i++)
4510 Lisp_Object g = LGSTRING_GLYPH (gstring_out, i);
4511 int c = LGLYPH_CHAR (g);
4512 unsigned code = LGLYPH_CODE (g);
4514 alternates = Fcons (Fcons (make_number (code),
4515 c > 0 ? make_number (c) : Qnil),
4516 alternates);
4518 return Fnreverse (alternates);
4520 #endif /* 0 */
4522 #ifdef FONT_DEBUG
4524 DEFUN ("open-font", Fopen_font, Sopen_font, 1, 3, 0,
4525 doc: /* Open FONT-ENTITY. */)
4526 (Lisp_Object font_entity, Lisp_Object size, Lisp_Object frame)
4528 int isize;
4530 CHECK_FONT_ENTITY (font_entity);
4531 if (NILP (frame))
4532 frame = selected_frame;
4533 CHECK_LIVE_FRAME (frame);
4535 if (NILP (size))
4536 isize = XINT (AREF (font_entity, FONT_SIZE_INDEX));
4537 else
4539 CHECK_NUMBER_OR_FLOAT (size);
4540 if (FLOATP (size))
4541 isize = POINT_TO_PIXEL (XFLOAT_DATA (size), XFRAME (frame)->resy);
4542 else
4543 isize = XINT (size);
4544 if (isize == 0)
4545 isize = 120;
4547 return font_open_entity (XFRAME (frame), font_entity, isize);
4550 DEFUN ("close-font", Fclose_font, Sclose_font, 1, 2, 0,
4551 doc: /* Close FONT-OBJECT. */)
4552 (Lisp_Object font_object, Lisp_Object frame)
4554 CHECK_FONT_OBJECT (font_object);
4555 if (NILP (frame))
4556 frame = selected_frame;
4557 CHECK_LIVE_FRAME (frame);
4558 font_close_object (XFRAME (frame), font_object);
4559 return Qnil;
4562 DEFUN ("query-font", Fquery_font, Squery_font, 1, 1, 0,
4563 doc: /* Return information about FONT-OBJECT.
4564 The value is a vector:
4565 [ NAME FILENAME PIXEL-SIZE SIZE ASCENT DESCENT SPACE-WIDTH AVERAGE-WIDTH
4566 CAPABILITY ]
4568 NAME is the font name, a string (or nil if the font backend doesn't
4569 provide a name).
4571 FILENAME is the font file name, a string (or nil if the font backend
4572 doesn't provide a file name).
4574 PIXEL-SIZE is a pixel size by which the font is opened.
4576 SIZE is a maximum advance width of the font in pixels.
4578 ASCENT, DESCENT, SPACE-WIDTH, AVERAGE-WIDTH are metrics of the font in
4579 pixels.
4581 CAPABILITY is a list whose first element is a symbol representing the
4582 font format \(x, opentype, truetype, type1, pcf, or bdf) and the
4583 remaining elements describe the details of the font capability.
4585 If the font is OpenType font, the form of the list is
4586 \(opentype GSUB GPOS)
4587 where GSUB shows which "GSUB" features the font supports, and GPOS
4588 shows which "GPOS" features the font supports. Both GSUB and GPOS are
4589 lists of the format:
4590 \((SCRIPT (LANGSYS FEATURE ...) ...) ...)
4592 If the font is not OpenType font, currently the length of the form is
4593 one.
4595 SCRIPT is a symbol representing OpenType script tag.
4597 LANGSYS is a symbol representing OpenType langsys tag, or nil
4598 representing the default langsys.
4600 FEATURE is a symbol representing OpenType feature tag.
4602 If the font is not OpenType font, CAPABILITY is nil. */)
4603 (Lisp_Object font_object)
4605 struct font *font;
4606 Lisp_Object val;
4608 CHECK_FONT_GET_OBJECT (font_object, font);
4610 val = Fmake_vector (make_number (9), Qnil);
4611 ASET (val, 0, AREF (font_object, FONT_NAME_INDEX));
4612 ASET (val, 1, AREF (font_object, FONT_FILE_INDEX));
4613 ASET (val, 2, make_number (font->pixel_size));
4614 ASET (val, 3, make_number (font->max_width));
4615 ASET (val, 4, make_number (font->ascent));
4616 ASET (val, 5, make_number (font->descent));
4617 ASET (val, 6, make_number (font->space_width));
4618 ASET (val, 7, make_number (font->average_width));
4619 if (font->driver->otf_capability)
4620 ASET (val, 8, Fcons (Qopentype, font->driver->otf_capability (font)));
4621 return val;
4624 DEFUN ("font-get-glyphs", Ffont_get_glyphs, Sfont_get_glyphs, 3, 4, 0,
4625 doc:
4626 /* Return a vector of FONT-OBJECT's glyphs for the specified characters.
4627 FROM and TO are positions (integers or markers) specifying a region
4628 of the current buffer.
4629 If the optional fourth arg OBJECT is not nil, it is a string or a
4630 vector containing the target characters.
4632 Each element is a vector containing information of a glyph in this format:
4633 [FROM-IDX TO-IDX C CODE WIDTH LBEARING RBEARING ASCENT DESCENT ADJUSTMENT]
4634 where
4635 FROM is an index numbers of a character the glyph corresponds to.
4636 TO is the same as FROM.
4637 C is the character of the glyph.
4638 CODE is the glyph-code of C in FONT-OBJECT.
4639 WIDTH thru DESCENT are the metrics (in pixels) of the glyph.
4640 ADJUSTMENT is always nil.
4641 If FONT-OBJECT doesn't have a glyph for a character,
4642 the corresponding element is nil. */)
4643 (Lisp_Object font_object, Lisp_Object from, Lisp_Object to,
4644 Lisp_Object object)
4646 struct font *font;
4647 int i, len;
4648 Lisp_Object *chars, vec;
4649 USE_SAFE_ALLOCA;
4651 CHECK_FONT_GET_OBJECT (font_object, font);
4652 if (NILP (object))
4654 EMACS_INT charpos, bytepos;
4656 validate_region (&from, &to);
4657 if (EQ (from, to))
4658 return Qnil;
4659 len = XFASTINT (to) - XFASTINT (from);
4660 SAFE_ALLOCA_LISP (chars, len);
4661 charpos = XFASTINT (from);
4662 bytepos = CHAR_TO_BYTE (charpos);
4663 for (i = 0; charpos < XFASTINT (to); i++)
4665 int c;
4666 FETCH_CHAR_ADVANCE (c, charpos, bytepos);
4667 chars[i] = make_number (c);
4670 else if (STRINGP (object))
4672 const unsigned char *p;
4674 CHECK_NUMBER (from);
4675 CHECK_NUMBER (to);
4676 if (XINT (from) < 0 || XINT (from) > XINT (to)
4677 || XINT (to) > SCHARS (object))
4678 args_out_of_range_3 (object, from, to);
4679 if (EQ (from, to))
4680 return Qnil;
4681 len = XFASTINT (to) - XFASTINT (from);
4682 SAFE_ALLOCA_LISP (chars, len);
4683 p = SDATA (object);
4684 if (STRING_MULTIBYTE (object))
4685 for (i = 0; i < len; i++)
4687 int c = STRING_CHAR_ADVANCE (p);
4688 chars[i] = make_number (c);
4690 else
4691 for (i = 0; i < len; i++)
4692 chars[i] = make_number (p[i]);
4694 else
4696 CHECK_VECTOR (object);
4697 CHECK_NUMBER (from);
4698 CHECK_NUMBER (to);
4699 if (XINT (from) < 0 || XINT (from) > XINT (to)
4700 || XINT (to) > ASIZE (object))
4701 args_out_of_range_3 (object, from, to);
4702 if (EQ (from, to))
4703 return Qnil;
4704 len = XFASTINT (to) - XFASTINT (from);
4705 for (i = 0; i < len; i++)
4707 Lisp_Object elt = AREF (object, XFASTINT (from) + i);
4708 CHECK_CHARACTER (elt);
4710 chars = &(AREF (object, XFASTINT (from)));
4713 vec = Fmake_vector (make_number (len), Qnil);
4714 for (i = 0; i < len; i++)
4716 Lisp_Object g;
4717 int c = XFASTINT (chars[i]);
4718 unsigned code;
4719 struct font_metrics metrics;
4721 code = font->driver->encode_char (font, c);
4722 if (code == FONT_INVALID_CODE)
4723 continue;
4724 g = Fmake_vector (make_number (LGLYPH_SIZE), Qnil);
4725 LGLYPH_SET_FROM (g, i);
4726 LGLYPH_SET_TO (g, i);
4727 LGLYPH_SET_CHAR (g, c);
4728 LGLYPH_SET_CODE (g, code);
4729 font->driver->text_extents (font, &code, 1, &metrics);
4730 LGLYPH_SET_WIDTH (g, metrics.width);
4731 LGLYPH_SET_LBEARING (g, metrics.lbearing);
4732 LGLYPH_SET_RBEARING (g, metrics.rbearing);
4733 LGLYPH_SET_ASCENT (g, metrics.ascent);
4734 LGLYPH_SET_DESCENT (g, metrics.descent);
4735 ASET (vec, i, g);
4737 if (! VECTORP (object))
4738 SAFE_FREE ();
4739 return vec;
4742 DEFUN ("font-match-p", Ffont_match_p, Sfont_match_p, 2, 2, 0,
4743 doc: /* Return t if and only if font-spec SPEC matches with FONT.
4744 FONT is a font-spec, font-entity, or font-object. */)
4745 (Lisp_Object spec, Lisp_Object font)
4747 CHECK_FONT_SPEC (spec);
4748 CHECK_FONT (font);
4750 return (font_match_p (spec, font) ? Qt : Qnil);
4753 DEFUN ("font-at", Ffont_at, Sfont_at, 1, 3, 0,
4754 doc: /* Return a font-object for displaying a character at POSITION.
4755 Optional second arg WINDOW, if non-nil, is a window displaying
4756 the current buffer. It defaults to the currently selected window. */)
4757 (Lisp_Object position, Lisp_Object window, Lisp_Object string)
4759 struct window *w;
4760 EMACS_INT pos;
4762 if (NILP (string))
4764 CHECK_NUMBER_COERCE_MARKER (position);
4765 pos = XINT (position);
4766 if (pos < BEGV || pos >= ZV)
4767 args_out_of_range_3 (position, make_number (BEGV), make_number (ZV));
4769 else
4771 CHECK_NUMBER (position);
4772 CHECK_STRING (string);
4773 pos = XINT (position);
4774 if (pos < 0 || pos >= SCHARS (string))
4775 args_out_of_range (string, position);
4777 if (NILP (window))
4778 window = selected_window;
4779 CHECK_LIVE_WINDOW (window);
4780 w = XWINDOW (window);
4782 return font_at (-1, pos, NULL, w, string);
4785 #if 0
4786 DEFUN ("draw-string", Fdraw_string, Sdraw_string, 2, 2, 0,
4787 doc: /* Draw STRING by FONT-OBJECT on the top left corner of the current frame.
4788 The value is a number of glyphs drawn.
4789 Type C-l to recover what previously shown. */)
4790 (Lisp_Object font_object, Lisp_Object string)
4792 Lisp_Object frame = selected_frame;
4793 FRAME_PTR f = XFRAME (frame);
4794 struct font *font;
4795 struct face *face;
4796 int i, len, width;
4797 unsigned *code;
4799 CHECK_FONT_GET_OBJECT (font_object, font);
4800 CHECK_STRING (string);
4801 len = SCHARS (string);
4802 code = alloca (sizeof (unsigned) * len);
4803 for (i = 0; i < len; i++)
4805 Lisp_Object ch = Faref (string, make_number (i));
4806 Lisp_Object val;
4807 int c = XINT (ch);
4809 code[i] = font->driver->encode_char (font, c);
4810 if (code[i] == FONT_INVALID_CODE)
4811 break;
4813 face = FACE_FROM_ID (f, DEFAULT_FACE_ID);
4814 face->fontp = font;
4815 if (font->driver->prepare_face)
4816 font->driver->prepare_face (f, face);
4817 width = font->driver->text_extents (font, code, i, NULL);
4818 len = font->driver->draw_text (f, face, 0, font->ascent, code, i, width);
4819 if (font->driver->done_face)
4820 font->driver->done_face (f, face);
4821 face->fontp = NULL;
4822 return make_number (len);
4824 #endif
4826 #endif /* FONT_DEBUG */
4828 #ifdef HAVE_WINDOW_SYSTEM
4830 DEFUN ("font-info", Ffont_info, Sfont_info, 1, 2, 0,
4831 doc: /* Return information about a font named NAME on frame FRAME.
4832 If FRAME is omitted or nil, use the selected frame.
4833 The returned value is a vector of OPENED-NAME, FULL-NAME, SIZE,
4834 HEIGHT, BASELINE-OFFSET, RELATIVE-COMPOSE, and DEFAULT-ASCENT,
4835 where
4836 OPENED-NAME is the name used for opening the font,
4837 FULL-NAME is the full name of the font,
4838 SIZE is the pixelsize of the font,
4839 HEIGHT is the pixel-height of the font (i.e ascent + descent),
4840 BASELINE-OFFSET is the upward offset pixels from ASCII baseline,
4841 RELATIVE-COMPOSE and DEFAULT-ASCENT are the numbers controlling
4842 how to compose characters.
4843 If the named font is not yet loaded, return nil. */)
4844 (Lisp_Object name, Lisp_Object frame)
4846 FRAME_PTR f;
4847 struct font *font;
4848 Lisp_Object info;
4849 Lisp_Object font_object;
4851 (*check_window_system_func) ();
4853 if (! FONTP (name))
4854 CHECK_STRING (name);
4855 if (NILP (frame))
4856 frame = selected_frame;
4857 CHECK_LIVE_FRAME (frame);
4858 f = XFRAME (frame);
4860 if (STRINGP (name))
4862 int fontset = fs_query_fontset (name, 0);
4864 if (fontset >= 0)
4865 name = fontset_ascii (fontset);
4866 font_object = font_open_by_name (f, SSDATA (name));
4868 else if (FONT_OBJECT_P (name))
4869 font_object = name;
4870 else if (FONT_ENTITY_P (name))
4871 font_object = font_open_entity (f, name, 0);
4872 else
4874 struct face *face = FACE_FROM_ID (f, DEFAULT_FACE_ID);
4875 Lisp_Object entity = font_matching_entity (f, face->lface, name);
4877 font_object = ! NILP (entity) ? font_open_entity (f, entity, 0) : Qnil;
4879 if (NILP (font_object))
4880 return Qnil;
4881 font = XFONT_OBJECT (font_object);
4883 info = Fmake_vector (make_number (7), Qnil);
4884 XVECTOR (info)->contents[0] = AREF (font_object, FONT_NAME_INDEX);
4885 XVECTOR (info)->contents[1] = AREF (font_object, FONT_FULLNAME_INDEX);
4886 XVECTOR (info)->contents[2] = make_number (font->pixel_size);
4887 XVECTOR (info)->contents[3] = make_number (font->height);
4888 XVECTOR (info)->contents[4] = make_number (font->baseline_offset);
4889 XVECTOR (info)->contents[5] = make_number (font->relative_compose);
4890 XVECTOR (info)->contents[6] = make_number (font->default_ascent);
4892 #if 0
4893 /* As font_object is still in FONT_OBJLIST of the entity, we can't
4894 close it now. Perhaps, we should manage font-objects
4895 by `reference-count'. */
4896 font_close_object (f, font_object);
4897 #endif
4898 return info;
4900 #endif
4903 #define BUILD_STYLE_TABLE(TBL) \
4904 build_style_table ((TBL), sizeof TBL / sizeof (struct table_entry))
4906 static Lisp_Object
4907 build_style_table (const struct table_entry *entry, int nelement)
4909 int i, j;
4910 Lisp_Object table, elt;
4912 table = Fmake_vector (make_number (nelement), Qnil);
4913 for (i = 0; i < nelement; i++)
4915 for (j = 0; entry[i].names[j]; j++);
4916 elt = Fmake_vector (make_number (j + 1), Qnil);
4917 ASET (elt, 0, make_number (entry[i].numeric));
4918 for (j = 0; entry[i].names[j]; j++)
4919 ASET (elt, j + 1, intern_c_string (entry[i].names[j]));
4920 ASET (table, i, elt);
4922 return table;
4925 /* The deferred font-log data of the form [ACTION ARG RESULT].
4926 If ACTION is not nil, that is added to the log when font_add_log is
4927 called next time. At that time, ACTION is set back to nil. */
4928 static Lisp_Object Vfont_log_deferred;
4930 /* Prepend the font-related logging data in Vfont_log if it is not
4931 `t'. ACTION describes a kind of font-related action (e.g. listing,
4932 opening), ARG is the argument for the action, and RESULT is the
4933 result of the action. */
4934 void
4935 font_add_log (const char *action, Lisp_Object arg, Lisp_Object result)
4937 Lisp_Object val;
4938 int i;
4940 if (EQ (Vfont_log, Qt))
4941 return;
4942 if (STRINGP (AREF (Vfont_log_deferred, 0)))
4944 char *str = SSDATA (AREF (Vfont_log_deferred, 0));
4946 ASET (Vfont_log_deferred, 0, Qnil);
4947 font_add_log (str, AREF (Vfont_log_deferred, 1),
4948 AREF (Vfont_log_deferred, 2));
4951 if (FONTP (arg))
4953 Lisp_Object tail, elt;
4954 Lisp_Object equalstr = build_string ("=");
4956 val = Ffont_xlfd_name (arg, Qt);
4957 for (tail = AREF (arg, FONT_EXTRA_INDEX); CONSP (tail);
4958 tail = XCDR (tail))
4960 elt = XCAR (tail);
4961 if (EQ (XCAR (elt), QCscript)
4962 && SYMBOLP (XCDR (elt)))
4963 val = concat3 (val, SYMBOL_NAME (QCscript),
4964 concat2 (equalstr, SYMBOL_NAME (XCDR (elt))));
4965 else if (EQ (XCAR (elt), QClang)
4966 && SYMBOLP (XCDR (elt)))
4967 val = concat3 (val, SYMBOL_NAME (QClang),
4968 concat2 (equalstr, SYMBOL_NAME (XCDR (elt))));
4969 else if (EQ (XCAR (elt), QCotf)
4970 && CONSP (XCDR (elt)) && SYMBOLP (XCAR (XCDR (elt))))
4971 val = concat3 (val, SYMBOL_NAME (QCotf),
4972 concat2 (equalstr,
4973 SYMBOL_NAME (XCAR (XCDR (elt)))));
4975 arg = val;
4978 if (CONSP (result)
4979 && VECTORP (XCAR (result))
4980 && ASIZE (XCAR (result)) > 0
4981 && FONTP (AREF (XCAR (result), 0)))
4982 result = font_vconcat_entity_vectors (result);
4983 if (FONTP (result))
4985 val = Ffont_xlfd_name (result, Qt);
4986 if (! FONT_SPEC_P (result))
4987 val = concat3 (SYMBOL_NAME (AREF (result, FONT_TYPE_INDEX)),
4988 build_string (":"), val);
4989 result = val;
4991 else if (CONSP (result))
4993 Lisp_Object tail;
4994 result = Fcopy_sequence (result);
4995 for (tail = result; CONSP (tail); tail = XCDR (tail))
4997 val = XCAR (tail);
4998 if (FONTP (val))
4999 val = Ffont_xlfd_name (val, Qt);
5000 XSETCAR (tail, val);
5003 else if (VECTORP (result))
5005 result = Fcopy_sequence (result);
5006 for (i = 0; i < ASIZE (result); i++)
5008 val = AREF (result, i);
5009 if (FONTP (val))
5010 val = Ffont_xlfd_name (val, Qt);
5011 ASET (result, i, val);
5014 Vfont_log = Fcons (list3 (intern (action), arg, result), Vfont_log);
5017 /* Record a font-related logging data to be added to Vfont_log when
5018 font_add_log is called next time. ACTION, ARG, RESULT are the same
5019 as font_add_log. */
5021 void
5022 font_deferred_log (const char *action, Lisp_Object arg, Lisp_Object result)
5024 if (EQ (Vfont_log, Qt))
5025 return;
5026 ASET (Vfont_log_deferred, 0, build_string (action));
5027 ASET (Vfont_log_deferred, 1, arg);
5028 ASET (Vfont_log_deferred, 2, result);
5031 void
5032 syms_of_font (void)
5034 sort_shift_bits[FONT_TYPE_INDEX] = 0;
5035 sort_shift_bits[FONT_SLANT_INDEX] = 2;
5036 sort_shift_bits[FONT_WEIGHT_INDEX] = 9;
5037 sort_shift_bits[FONT_SIZE_INDEX] = 16;
5038 sort_shift_bits[FONT_WIDTH_INDEX] = 23;
5039 /* Note that the other elements in sort_shift_bits are not used. */
5041 staticpro (&font_charset_alist);
5042 font_charset_alist = Qnil;
5044 DEFSYM (Qopentype, "opentype");
5046 DEFSYM (Qascii_0, "ascii-0");
5047 DEFSYM (Qiso8859_1, "iso8859-1");
5048 DEFSYM (Qiso10646_1, "iso10646-1");
5049 DEFSYM (Qunicode_bmp, "unicode-bmp");
5050 DEFSYM (Qunicode_sip, "unicode-sip");
5052 DEFSYM (QCf, "Cf");
5054 DEFSYM (QCotf, ":otf");
5055 DEFSYM (QClang, ":lang");
5056 DEFSYM (QCscript, ":script");
5057 DEFSYM (QCantialias, ":antialias");
5059 DEFSYM (QCfoundry, ":foundry");
5060 DEFSYM (QCadstyle, ":adstyle");
5061 DEFSYM (QCregistry, ":registry");
5062 DEFSYM (QCspacing, ":spacing");
5063 DEFSYM (QCdpi, ":dpi");
5064 DEFSYM (QCscalable, ":scalable");
5065 DEFSYM (QCavgwidth, ":avgwidth");
5066 DEFSYM (QCfont_entity, ":font-entity");
5067 DEFSYM (QCfc_unknown_spec, ":fc-unknown-spec");
5069 DEFSYM (Qc, "c");
5070 DEFSYM (Qm, "m");
5071 DEFSYM (Qp, "p");
5072 DEFSYM (Qd, "d");
5074 DEFSYM (Qja, "ja");
5075 DEFSYM (Qko, "ko");
5077 DEFSYM (QCuser_spec, "user-spec");
5079 staticpro (&null_vector);
5080 null_vector = Fmake_vector (make_number (0), Qnil);
5082 staticpro (&scratch_font_spec);
5083 scratch_font_spec = Ffont_spec (0, NULL);
5084 staticpro (&scratch_font_prefer);
5085 scratch_font_prefer = Ffont_spec (0, NULL);
5087 staticpro (&Vfont_log_deferred);
5088 Vfont_log_deferred = Fmake_vector (make_number (3), Qnil);
5090 #if 0
5091 #ifdef HAVE_LIBOTF
5092 staticpro (&otf_list);
5093 otf_list = Qnil;
5094 #endif /* HAVE_LIBOTF */
5095 #endif /* 0 */
5097 defsubr (&Sfontp);
5098 defsubr (&Sfont_spec);
5099 defsubr (&Sfont_get);
5100 #ifdef HAVE_WINDOW_SYSTEM
5101 defsubr (&Sfont_face_attributes);
5102 #endif
5103 defsubr (&Sfont_put);
5104 defsubr (&Slist_fonts);
5105 defsubr (&Sfont_family_list);
5106 defsubr (&Sfind_font);
5107 defsubr (&Sfont_xlfd_name);
5108 defsubr (&Sclear_font_cache);
5109 defsubr (&Sfont_shape_gstring);
5110 defsubr (&Sfont_variation_glyphs);
5111 #if 0
5112 defsubr (&Sfont_drive_otf);
5113 defsubr (&Sfont_otf_alternates);
5114 #endif /* 0 */
5116 #ifdef FONT_DEBUG
5117 defsubr (&Sopen_font);
5118 defsubr (&Sclose_font);
5119 defsubr (&Squery_font);
5120 defsubr (&Sfont_get_glyphs);
5121 defsubr (&Sfont_match_p);
5122 defsubr (&Sfont_at);
5123 #if 0
5124 defsubr (&Sdraw_string);
5125 #endif
5126 #endif /* FONT_DEBUG */
5127 #ifdef HAVE_WINDOW_SYSTEM
5128 defsubr (&Sfont_info);
5129 #endif
5131 DEFVAR_LISP ("font-encoding-alist", Vfont_encoding_alist,
5132 doc: /*
5133 Alist of fontname patterns vs the corresponding encoding and repertory info.
5134 Each element looks like (REGEXP . (ENCODING . REPERTORY)),
5135 where ENCODING is a charset or a char-table,
5136 and REPERTORY is a charset, a char-table, or nil.
5138 If ENCODING and REPERTORY are the same, the element can have the form
5139 \(REGEXP . ENCODING).
5141 ENCODING is for converting a character to a glyph code of the font.
5142 If ENCODING is a charset, encoding a character by the charset gives
5143 the corresponding glyph code. If ENCODING is a char-table, looking up
5144 the table by a character gives the corresponding glyph code.
5146 REPERTORY specifies a repertory of characters supported by the font.
5147 If REPERTORY is a charset, all characters beloging to the charset are
5148 supported. If REPERTORY is a char-table, all characters who have a
5149 non-nil value in the table are supported. If REPERTORY is nil, Emacs
5150 gets the repertory information by an opened font and ENCODING. */);
5151 Vfont_encoding_alist = Qnil;
5153 /* FIXME: These 3 vars are not quite what they appear: setq on them
5154 won't have any effect other than disconnect them from the style
5155 table used by the font display code. So we make them read-only,
5156 to avoid this confusing situation. */
5158 DEFVAR_LISP_NOPRO ("font-weight-table", Vfont_weight_table,
5159 doc: /* Vector of valid font weight values.
5160 Each element has the form:
5161 [NUMERIC-VALUE SYMBOLIC-NAME ALIAS-NAME ...]
5162 NUMERIC-VALUE is an integer, and SYMBOLIC-NAME and ALIAS-NAME are symbols. */);
5163 Vfont_weight_table = BUILD_STYLE_TABLE (weight_table);
5164 XSYMBOL (intern_c_string ("font-weight-table"))->constant = 1;
5166 DEFVAR_LISP_NOPRO ("font-slant-table", Vfont_slant_table,
5167 doc: /* Vector of font slant symbols vs the corresponding numeric values.
5168 See `font-weight-table' for the format of the vector. */);
5169 Vfont_slant_table = BUILD_STYLE_TABLE (slant_table);
5170 XSYMBOL (intern_c_string ("font-slant-table"))->constant = 1;
5172 DEFVAR_LISP_NOPRO ("font-width-table", Vfont_width_table,
5173 doc: /* Alist of font width symbols vs the corresponding numeric values.
5174 See `font-weight-table' for the format of the vector. */);
5175 Vfont_width_table = BUILD_STYLE_TABLE (width_table);
5176 XSYMBOL (intern_c_string ("font-width-table"))->constant = 1;
5178 staticpro (&font_style_table);
5179 font_style_table = Fmake_vector (make_number (3), Qnil);
5180 ASET (font_style_table, 0, Vfont_weight_table);
5181 ASET (font_style_table, 1, Vfont_slant_table);
5182 ASET (font_style_table, 2, Vfont_width_table);
5184 DEFVAR_LISP ("font-log", Vfont_log, doc: /*
5185 *Logging list of font related actions and results.
5186 The value t means to suppress the logging.
5187 The initial value is set to nil if the environment variable
5188 EMACS_FONT_LOG is set. Otherwise, it is set to t. */);
5189 Vfont_log = Qnil;
5191 #ifdef HAVE_WINDOW_SYSTEM
5192 #ifdef HAVE_FREETYPE
5193 syms_of_ftfont ();
5194 #ifdef HAVE_X_WINDOWS
5195 syms_of_xfont ();
5196 syms_of_ftxfont ();
5197 #ifdef HAVE_XFT
5198 syms_of_xftfont ();
5199 #endif /* HAVE_XFT */
5200 #endif /* HAVE_X_WINDOWS */
5201 #else /* not HAVE_FREETYPE */
5202 #ifdef HAVE_X_WINDOWS
5203 syms_of_xfont ();
5204 #endif /* HAVE_X_WINDOWS */
5205 #endif /* not HAVE_FREETYPE */
5206 #ifdef HAVE_BDFFONT
5207 syms_of_bdffont ();
5208 #endif /* HAVE_BDFFONT */
5209 #ifdef WINDOWSNT
5210 syms_of_w32font ();
5211 #endif /* WINDOWSNT */
5212 #ifdef HAVE_NS
5213 syms_of_nsfont ();
5214 #endif /* HAVE_NS */
5215 #endif /* HAVE_WINDOW_SYSTEM */
5218 void
5219 init_font (void)
5221 Vfont_log = egetenv ("EMACS_FONT_LOG") ? Qnil : Qt;