* net/tramp-sh.el (tramp-find-shell): Apply workaround also for
[emacs.git] / src / font.c
blob398198324a451b57927a42a23ba3185a88603d22
1 /* font.c -- "Font" primitives.
3 Copyright (C) 2006-2011 Free Software Foundation, Inc.
4 Copyright (C) 2006, 2007, 2008, 2009, 2010, 2011
5 National Institute of Advanced Industrial Science and Technology (AIST)
6 Registration Number H13PRO009
8 This file is part of GNU Emacs.
10 GNU Emacs is free software: you can redistribute it and/or modify
11 it under the terms of the GNU General Public License as published by
12 the Free Software Foundation, either version 3 of the License, or
13 (at your option) any later version.
15 GNU Emacs is distributed in the hope that it will be useful,
16 but WITHOUT ANY WARRANTY; without even the implied warranty of
17 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
18 GNU General Public License for more details.
20 You should have received a copy of the GNU General Public License
21 along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. */
23 #include <config.h>
24 #include <stdio.h>
25 #include <ctype.h>
26 #include <setjmp.h>
28 #include "lisp.h"
29 #include "buffer.h"
30 #include "frame.h"
31 #include "window.h"
32 #include "dispextern.h"
33 #include "charset.h"
34 #include "character.h"
35 #include "composite.h"
36 #include "fontset.h"
37 #include "font.h"
39 #ifdef HAVE_X_WINDOWS
40 #include "xterm.h"
41 #endif /* HAVE_X_WINDOWS */
43 #ifdef HAVE_NTGUI
44 #include "w32term.h"
45 #endif /* HAVE_NTGUI */
47 #ifdef HAVE_NS
48 #include "nsterm.h"
49 #endif /* HAVE_NS */
51 Lisp_Object Qopentype;
53 /* Important character set strings. */
54 Lisp_Object Qascii_0, Qiso8859_1, Qiso10646_1, Qunicode_bmp, Qunicode_sip;
56 #define DEFAULT_ENCODING Qiso8859_1
58 /* Unicode category `Cf'. */
59 static Lisp_Object QCf;
61 /* Special vector of zero length. This is repeatedly used by (struct
62 font_driver *)->list when a specified font is not found. */
63 static Lisp_Object null_vector;
65 /* Vector of Vfont_weight_table, Vfont_slant_table, and Vfont_width_table. */
66 static Lisp_Object font_style_table;
68 /* Structure used for tables mapping weight, slant, and width numeric
69 values and their names. */
71 struct table_entry
73 int numeric;
74 /* The first one is a valid name as a face attribute.
75 The second one (if any) is a typical name in XLFD field. */
76 const char *names[5];
79 /* Table of weight numeric values and their names. This table must be
80 sorted by numeric values in ascending order. */
82 static const struct table_entry weight_table[] =
84 { 0, { "thin" }},
85 { 20, { "ultra-light", "ultralight" }},
86 { 40, { "extra-light", "extralight" }},
87 { 50, { "light" }},
88 { 75, { "semi-light", "semilight", "demilight", "book" }},
89 { 100, { "normal", "medium", "regular", "unspecified" }},
90 { 180, { "semi-bold", "semibold", "demibold", "demi" }},
91 { 200, { "bold" }},
92 { 205, { "extra-bold", "extrabold" }},
93 { 210, { "ultra-bold", "ultrabold", "black" }}
96 /* Table of slant numeric values and their names. This table must be
97 sorted by numeric values in ascending order. */
99 static const struct table_entry slant_table[] =
101 { 0, { "reverse-oblique", "ro" }},
102 { 10, { "reverse-italic", "ri" }},
103 { 100, { "normal", "r", "unspecified" }},
104 { 200, { "italic" ,"i", "ot" }},
105 { 210, { "oblique", "o" }}
108 /* Table of width numeric values and their names. This table must be
109 sorted by numeric values in ascending order. */
111 static const struct table_entry width_table[] =
113 { 50, { "ultra-condensed", "ultracondensed" }},
114 { 63, { "extra-condensed", "extracondensed" }},
115 { 75, { "condensed", "compressed", "narrow" }},
116 { 87, { "semi-condensed", "semicondensed", "demicondensed" }},
117 { 100, { "normal", "medium", "regular", "unspecified" }},
118 { 113, { "semi-expanded", "semiexpanded", "demiexpanded" }},
119 { 125, { "expanded" }},
120 { 150, { "extra-expanded", "extraexpanded" }},
121 { 200, { "ultra-expanded", "ultraexpanded", "wide" }}
124 Lisp_Object QCfoundry;
125 static Lisp_Object QCadstyle, QCregistry;
126 /* Symbols representing keys of font extra info. */
127 Lisp_Object QCspacing, QCdpi, QCscalable, QCotf, QClang, QCscript, QCavgwidth;
128 Lisp_Object QCantialias, QCfont_entity;
129 static Lisp_Object QCfc_unknown_spec;
130 /* Symbols representing values of font spacing property. */
131 static Lisp_Object Qc, Qm, Qd;
132 Lisp_Object Qp;
133 /* Special ADSTYLE properties to avoid fonts used for Latin
134 characters; used in xfont.c and ftfont.c. */
135 Lisp_Object Qja, Qko;
137 static Lisp_Object QCuser_spec;
139 /* Alist of font registry symbols and the corresponding charset
140 information. The information is retrieved from
141 Vfont_encoding_alist on demand.
143 Eash element has the form:
144 (REGISTRY . (ENCODING-CHARSET-ID . REPERTORY-CHARSET-ID))
146 (REGISTRY . nil)
148 In the former form, ENCODING-CHARSET-ID is an ID of a charset that
149 encodes a character code to a glyph code of a font, and
150 REPERTORY-CHARSET-ID is an ID of a charset that tells if a
151 character is supported by a font.
153 The latter form means that the information for REGISTRY couldn't be
154 retrieved. */
155 static Lisp_Object font_charset_alist;
157 /* List of all font drivers. Each font-backend (XXXfont.c) calls
158 register_font_driver in syms_of_XXXfont to register its font-driver
159 here. */
160 static struct font_driver_list *font_driver_list;
164 /* Creaters of font-related Lisp object. */
166 static Lisp_Object
167 font_make_spec (void)
169 Lisp_Object font_spec;
170 struct font_spec *spec
171 = ((struct font_spec *)
172 allocate_pseudovector (VECSIZE (struct font_spec),
173 FONT_SPEC_MAX, PVEC_FONT));
174 XSETFONT (font_spec, spec);
175 return font_spec;
178 Lisp_Object
179 font_make_entity (void)
181 Lisp_Object font_entity;
182 struct font_entity *entity
183 = ((struct font_entity *)
184 allocate_pseudovector (VECSIZE (struct font_entity),
185 FONT_ENTITY_MAX, PVEC_FONT));
186 XSETFONT (font_entity, entity);
187 return font_entity;
190 /* Create a font-object whose structure size is SIZE. If ENTITY is
191 not nil, copy properties from ENTITY to the font-object. If
192 PIXELSIZE is positive, set the `size' property to PIXELSIZE. */
193 Lisp_Object
194 font_make_object (int size, Lisp_Object entity, int pixelsize)
196 Lisp_Object font_object;
197 struct font *font
198 = (struct font *) allocate_pseudovector (size, FONT_OBJECT_MAX, PVEC_FONT);
199 int i;
201 XSETFONT (font_object, font);
203 if (! NILP (entity))
205 for (i = 1; i < FONT_SPEC_MAX; i++)
206 font->props[i] = AREF (entity, i);
207 if (! NILP (AREF (entity, FONT_EXTRA_INDEX)))
208 font->props[FONT_EXTRA_INDEX]
209 = Fcopy_alist (AREF (entity, FONT_EXTRA_INDEX));
211 if (size > 0)
212 font->props[FONT_SIZE_INDEX] = make_number (pixelsize);
213 return font_object;
218 static int font_pixel_size (FRAME_PTR f, Lisp_Object);
219 static Lisp_Object font_open_entity (FRAME_PTR, Lisp_Object, int);
220 static Lisp_Object font_matching_entity (FRAME_PTR, Lisp_Object *,
221 Lisp_Object);
222 static unsigned font_encode_char (Lisp_Object, int);
224 /* Number of registered font drivers. */
225 static int num_font_drivers;
228 /* Return a Lispy value of a font property value at STR and LEN bytes.
229 If STR is "*", return nil.
230 If FORCE_SYMBOL is zero and all characters in STR are digits,
231 return an integer. Otherwise, return a symbol interned from
232 STR. */
234 Lisp_Object
235 font_intern_prop (const char *str, int len, int force_symbol)
237 int i;
238 Lisp_Object tem;
239 Lisp_Object obarray;
240 EMACS_INT nbytes, nchars;
242 if (len == 1 && *str == '*')
243 return Qnil;
244 if (!force_symbol && len >=1 && isdigit (*str))
246 for (i = 1; i < len; i++)
247 if (! isdigit (str[i]))
248 break;
249 if (i == len)
250 return make_number (atoi (str));
253 /* The following code is copied from the function intern (in
254 lread.c), and modified to suit our purpose. */
255 obarray = Vobarray;
256 if (!VECTORP (obarray) || ASIZE (obarray) == 0)
257 obarray = check_obarray (obarray);
258 parse_str_as_multibyte ((unsigned char *) str, len, &nchars, &nbytes);
259 if (len == nchars || len != nbytes)
260 /* CONTENTS contains no multibyte sequences or contains an invalid
261 multibyte sequence. We'll make a unibyte string. */
262 tem = oblookup (obarray, str, len, len);
263 else
264 tem = oblookup (obarray, str, nchars, len);
265 if (SYMBOLP (tem))
266 return tem;
267 if (len == nchars || len != nbytes)
268 tem = make_unibyte_string (str, len);
269 else
270 tem = make_multibyte_string (str, nchars, len);
271 return Fintern (tem, obarray);
274 /* Return a pixel size of font-spec SPEC on frame F. */
276 static int
277 font_pixel_size (FRAME_PTR f, Lisp_Object spec)
279 #ifdef HAVE_WINDOW_SYSTEM
280 Lisp_Object size = AREF (spec, FONT_SIZE_INDEX);
281 double point_size;
282 int dpi, pixel_size;
283 Lisp_Object val;
285 if (INTEGERP (size))
286 return XINT (size);
287 if (NILP (size))
288 return 0;
289 font_assert (FLOATP (size));
290 point_size = XFLOAT_DATA (size);
291 val = AREF (spec, FONT_DPI_INDEX);
292 if (INTEGERP (val))
293 dpi = XINT (val);
294 else
295 dpi = f->resy;
296 pixel_size = POINT_TO_PIXEL (point_size, dpi);
297 return pixel_size;
298 #else
299 return 1;
300 #endif
304 /* Return a value of PROP's VAL (symbol or integer) to be stored in a
305 font vector. If VAL is not valid (i.e. not registered in
306 font_style_table), return -1 if NOERROR is zero, and return a
307 proper index if NOERROR is nonzero. In that case, register VAL in
308 font_style_table if VAL is a symbol, and return the closest index if
309 VAL is an integer. */
312 font_style_to_value (enum font_property_index prop, Lisp_Object val, int noerror)
314 Lisp_Object table = AREF (font_style_table, prop - FONT_WEIGHT_INDEX);
315 int len = ASIZE (table);
317 if (SYMBOLP (val))
319 int i, j;
320 char *s;
321 Lisp_Object args[2], elt;
323 /* At first try exact match. */
324 for (i = 0; i < len; i++)
325 for (j = 1; j < ASIZE (AREF (table, i)); j++)
326 if (EQ (val, AREF (AREF (table, i), j)))
327 return ((XINT (AREF (AREF (table, i), 0)) << 8)
328 | (i << 4) | (j - 1));
329 /* Try also with case-folding match. */
330 s = SSDATA (SYMBOL_NAME (val));
331 for (i = 0; i < len; i++)
332 for (j = 1; j < ASIZE (AREF (table, i)); j++)
334 elt = AREF (AREF (table, i), j);
335 if (xstrcasecmp (s, SSDATA (SYMBOL_NAME (elt))) == 0)
336 return ((XINT (AREF (AREF (table, i), 0)) << 8)
337 | (i << 4) | (j - 1));
339 if (! noerror)
340 return -1;
341 if (len == 255)
342 abort ();
343 elt = Fmake_vector (make_number (2), make_number (100));
344 ASET (elt, 1, val);
345 args[0] = table;
346 args[1] = Fmake_vector (make_number (1), elt);
347 ASET (font_style_table, prop - FONT_WEIGHT_INDEX, Fvconcat (2, args));
348 return (100 << 8) | (i << 4);
350 else
352 int i, last_n;
353 int numeric = XINT (val);
355 for (i = 0, last_n = -1; i < len; i++)
357 int n = XINT (AREF (AREF (table, i), 0));
359 if (numeric == n)
360 return (n << 8) | (i << 4);
361 if (numeric < n)
363 if (! noerror)
364 return -1;
365 return ((i == 0 || n - numeric < numeric - last_n)
366 ? (n << 8) | (i << 4): (last_n << 8 | ((i - 1) << 4)));
368 last_n = n;
370 if (! noerror)
371 return -1;
372 return ((last_n << 8) | ((i - 1) << 4));
376 Lisp_Object
377 font_style_symbolic (Lisp_Object font, enum font_property_index prop, int for_face)
379 Lisp_Object val = AREF (font, prop);
380 Lisp_Object table, elt;
381 int i;
383 if (NILP (val))
384 return Qnil;
385 table = AREF (font_style_table, prop - FONT_WEIGHT_INDEX);
386 i = XINT (val) & 0xFF;
387 font_assert (((i >> 4) & 0xF) < ASIZE (table));
388 elt = AREF (table, ((i >> 4) & 0xF));
389 font_assert ((i & 0xF) + 1 < ASIZE (elt));
390 return (for_face ? AREF (elt, 1) : AREF (elt, (i & 0xF) + 1));
393 /* Return ENCODING or a cons of ENCODING and REPERTORY of the font
394 FONTNAME. ENCODING is a charset symbol that specifies the encoding
395 of the font. REPERTORY is a charset symbol or nil. */
397 Lisp_Object
398 find_font_encoding (Lisp_Object fontname)
400 Lisp_Object tail, elt;
402 for (tail = Vfont_encoding_alist; CONSP (tail); tail = XCDR (tail))
404 elt = XCAR (tail);
405 if (CONSP (elt)
406 && STRINGP (XCAR (elt))
407 && fast_string_match_ignore_case (XCAR (elt), fontname) >= 0
408 && (SYMBOLP (XCDR (elt))
409 ? CHARSETP (XCDR (elt))
410 : CONSP (XCDR (elt)) && CHARSETP (XCAR (XCDR (elt)))))
411 return (XCDR (elt));
413 return Qnil;
416 /* Return encoding charset and repertory charset for REGISTRY in
417 ENCODING and REPERTORY correspondingly. If correct information for
418 REGISTRY is available, return 0. Otherwise return -1. */
421 font_registry_charsets (Lisp_Object registry, struct charset **encoding, struct charset **repertory)
423 Lisp_Object val;
424 int encoding_id, repertory_id;
426 val = Fassoc_string (registry, font_charset_alist, Qt);
427 if (! NILP (val))
429 val = XCDR (val);
430 if (NILP (val))
431 return -1;
432 encoding_id = XINT (XCAR (val));
433 repertory_id = XINT (XCDR (val));
435 else
437 val = find_font_encoding (SYMBOL_NAME (registry));
438 if (SYMBOLP (val) && CHARSETP (val))
440 encoding_id = repertory_id = XINT (CHARSET_SYMBOL_ID (val));
442 else if (CONSP (val))
444 if (! CHARSETP (XCAR (val)))
445 goto invalid_entry;
446 encoding_id = XINT (CHARSET_SYMBOL_ID (XCAR (val)));
447 if (NILP (XCDR (val)))
448 repertory_id = -1;
449 else
451 if (! CHARSETP (XCDR (val)))
452 goto invalid_entry;
453 repertory_id = XINT (CHARSET_SYMBOL_ID (XCDR (val)));
456 else
457 goto invalid_entry;
458 val = Fcons (make_number (encoding_id), make_number (repertory_id));
459 font_charset_alist
460 = nconc2 (font_charset_alist, Fcons (Fcons (registry, val), Qnil));
463 if (encoding)
464 *encoding = CHARSET_FROM_ID (encoding_id);
465 if (repertory)
466 *repertory = repertory_id >= 0 ? CHARSET_FROM_ID (repertory_id) : NULL;
467 return 0;
469 invalid_entry:
470 font_charset_alist
471 = nconc2 (font_charset_alist, Fcons (Fcons (registry, Qnil), Qnil));
472 return -1;
476 /* Font property value validators. See the comment of
477 font_property_table for the meaning of the arguments. */
479 static Lisp_Object font_prop_validate (int, Lisp_Object, Lisp_Object);
480 static Lisp_Object font_prop_validate_symbol (Lisp_Object, Lisp_Object);
481 static Lisp_Object font_prop_validate_style (Lisp_Object, Lisp_Object);
482 static Lisp_Object font_prop_validate_non_neg (Lisp_Object, Lisp_Object);
483 static Lisp_Object font_prop_validate_spacing (Lisp_Object, Lisp_Object);
484 static int get_font_prop_index (Lisp_Object);
486 static Lisp_Object
487 font_prop_validate_symbol (Lisp_Object prop, Lisp_Object val)
489 if (STRINGP (val))
490 val = Fintern (val, Qnil);
491 if (! SYMBOLP (val))
492 val = Qerror;
493 else if (EQ (prop, QCregistry))
494 val = Fintern (Fdowncase (SYMBOL_NAME (val)), Qnil);
495 return val;
499 static Lisp_Object
500 font_prop_validate_style (Lisp_Object style, Lisp_Object val)
502 enum font_property_index prop = (EQ (style, QCweight) ? FONT_WEIGHT_INDEX
503 : EQ (style, QCslant) ? FONT_SLANT_INDEX
504 : FONT_WIDTH_INDEX);
505 if (INTEGERP (val))
507 int n = XINT (val);
508 if (((n >> 4) & 0xF)
509 >= ASIZE (AREF (font_style_table, prop - FONT_WEIGHT_INDEX)))
510 val = Qerror;
511 else
513 Lisp_Object elt = AREF (AREF (font_style_table, prop - FONT_WEIGHT_INDEX), (n >> 4) & 0xF);
515 if ((n & 0xF) + 1 >= ASIZE (elt))
516 val = Qerror;
517 else if (XINT (AREF (elt, 0)) != (n >> 8))
518 val = Qerror;
521 else if (SYMBOLP (val))
523 int n = font_style_to_value (prop, val, 0);
525 val = n >= 0 ? make_number (n) : Qerror;
527 else
528 val = Qerror;
529 return val;
532 static Lisp_Object
533 font_prop_validate_non_neg (Lisp_Object prop, Lisp_Object val)
535 return (NATNUMP (val) || (FLOATP (val) && XFLOAT_DATA (val) >= 0)
536 ? val : Qerror);
539 static Lisp_Object
540 font_prop_validate_spacing (Lisp_Object prop, Lisp_Object val)
542 if (NILP (val) || (NATNUMP (val) && XINT (val) <= FONT_SPACING_CHARCELL))
543 return val;
544 if (SYMBOLP (val) && SBYTES (SYMBOL_NAME (val)) == 1)
546 char spacing = SDATA (SYMBOL_NAME (val))[0];
548 if (spacing == 'c' || spacing == 'C')
549 return make_number (FONT_SPACING_CHARCELL);
550 if (spacing == 'm' || spacing == 'M')
551 return make_number (FONT_SPACING_MONO);
552 if (spacing == 'p' || spacing == 'P')
553 return make_number (FONT_SPACING_PROPORTIONAL);
554 if (spacing == 'd' || spacing == 'D')
555 return make_number (FONT_SPACING_DUAL);
557 return Qerror;
560 static Lisp_Object
561 font_prop_validate_otf (Lisp_Object prop, Lisp_Object val)
563 Lisp_Object tail, tmp;
564 int i;
566 /* VAL = (SCRIPT [ LANGSYS [ GSUB-FEATURES [ GPOS-FEATURES ]]])
567 GSUB-FEATURES = (FEATURE ... [ nil FEATURE ... ]) | nil
568 GPOS-FEATURES = (FEATURE ... [ nil FEATURE ... ]) | nil */
569 if (! CONSP (val))
570 return Qerror;
571 if (! SYMBOLP (XCAR (val)))
572 return Qerror;
573 tail = XCDR (val);
574 if (NILP (tail))
575 return val;
576 if (! CONSP (tail) || ! SYMBOLP (XCAR (val)))
577 return Qerror;
578 for (i = 0; i < 2; i++)
580 tail = XCDR (tail);
581 if (NILP (tail))
582 return val;
583 if (! CONSP (tail))
584 return Qerror;
585 for (tmp = XCAR (tail); CONSP (tmp); tmp = XCDR (tmp))
586 if (! SYMBOLP (XCAR (tmp)))
587 return Qerror;
588 if (! NILP (tmp))
589 return Qerror;
591 return val;
594 /* Structure of known font property keys and validator of the
595 values. */
596 static const struct
598 /* Pointer to the key symbol. */
599 Lisp_Object *key;
600 /* Function to validate PROP's value VAL, or NULL if any value is
601 ok. The value is VAL or its regularized value if VAL is valid,
602 and Qerror if not. */
603 Lisp_Object (*validater) (Lisp_Object prop, Lisp_Object val);
604 } font_property_table[] =
605 { { &QCtype, font_prop_validate_symbol },
606 { &QCfoundry, font_prop_validate_symbol },
607 { &QCfamily, font_prop_validate_symbol },
608 { &QCadstyle, font_prop_validate_symbol },
609 { &QCregistry, font_prop_validate_symbol },
610 { &QCweight, font_prop_validate_style },
611 { &QCslant, font_prop_validate_style },
612 { &QCwidth, font_prop_validate_style },
613 { &QCsize, font_prop_validate_non_neg },
614 { &QCdpi, font_prop_validate_non_neg },
615 { &QCspacing, font_prop_validate_spacing },
616 { &QCavgwidth, font_prop_validate_non_neg },
617 /* The order of the above entries must match with enum
618 font_property_index. */
619 { &QClang, font_prop_validate_symbol },
620 { &QCscript, font_prop_validate_symbol },
621 { &QCotf, font_prop_validate_otf }
624 /* Size (number of elements) of the above table. */
625 #define FONT_PROPERTY_TABLE_SIZE \
626 ((sizeof font_property_table) / (sizeof *font_property_table))
628 /* Return an index number of font property KEY or -1 if KEY is not an
629 already known property. */
631 static int
632 get_font_prop_index (Lisp_Object key)
634 int i;
636 for (i = 0; i < FONT_PROPERTY_TABLE_SIZE; i++)
637 if (EQ (key, *font_property_table[i].key))
638 return i;
639 return -1;
642 /* Validate the font property. The property key is specified by the
643 symbol PROP, or the index IDX (if PROP is nil). If VAL is invalid,
644 signal an error. The value is VAL or the regularized one. */
646 static Lisp_Object
647 font_prop_validate (int idx, Lisp_Object prop, Lisp_Object val)
649 Lisp_Object validated;
651 if (NILP (val))
652 return val;
653 if (NILP (prop))
654 prop = *font_property_table[idx].key;
655 else
657 idx = get_font_prop_index (prop);
658 if (idx < 0)
659 return val;
661 validated = (font_property_table[idx].validater) (prop, val);
662 if (EQ (validated, Qerror))
663 signal_error ("invalid font property", Fcons (prop, val));
664 return validated;
668 /* Store VAL as a value of extra font property PROP in FONT while
669 keeping the sorting order. Don't check the validity of VAL. */
671 Lisp_Object
672 font_put_extra (Lisp_Object font, Lisp_Object prop, Lisp_Object val)
674 Lisp_Object extra = AREF (font, FONT_EXTRA_INDEX);
675 Lisp_Object slot = (NILP (extra) ? Qnil : assq_no_quit (prop, extra));
677 if (NILP (slot))
679 Lisp_Object prev = Qnil;
681 while (CONSP (extra)
682 && NILP (Fstring_lessp (prop, XCAR (XCAR (extra)))))
683 prev = extra, extra = XCDR (extra);
685 if (NILP (prev))
686 ASET (font, FONT_EXTRA_INDEX, Fcons (Fcons (prop, val), extra));
687 else
688 XSETCDR (prev, Fcons (Fcons (prop, val), extra));
690 return val;
692 XSETCDR (slot, val);
693 if (NILP (val))
694 ASET (font, FONT_EXTRA_INDEX, Fdelq (slot, extra));
695 return val;
699 /* Font name parser and unparser */
701 static int parse_matrix (const char *);
702 static int font_expand_wildcards (Lisp_Object *, int);
703 static int font_parse_name (char *, Lisp_Object);
705 /* An enumerator for each field of an XLFD font name. */
706 enum xlfd_field_index
708 XLFD_FOUNDRY_INDEX,
709 XLFD_FAMILY_INDEX,
710 XLFD_WEIGHT_INDEX,
711 XLFD_SLANT_INDEX,
712 XLFD_SWIDTH_INDEX,
713 XLFD_ADSTYLE_INDEX,
714 XLFD_PIXEL_INDEX,
715 XLFD_POINT_INDEX,
716 XLFD_RESX_INDEX,
717 XLFD_RESY_INDEX,
718 XLFD_SPACING_INDEX,
719 XLFD_AVGWIDTH_INDEX,
720 XLFD_REGISTRY_INDEX,
721 XLFD_ENCODING_INDEX,
722 XLFD_LAST_INDEX
725 /* An enumerator for mask bit corresponding to each XLFD field. */
726 enum xlfd_field_mask
728 XLFD_FOUNDRY_MASK = 0x0001,
729 XLFD_FAMILY_MASK = 0x0002,
730 XLFD_WEIGHT_MASK = 0x0004,
731 XLFD_SLANT_MASK = 0x0008,
732 XLFD_SWIDTH_MASK = 0x0010,
733 XLFD_ADSTYLE_MASK = 0x0020,
734 XLFD_PIXEL_MASK = 0x0040,
735 XLFD_POINT_MASK = 0x0080,
736 XLFD_RESX_MASK = 0x0100,
737 XLFD_RESY_MASK = 0x0200,
738 XLFD_SPACING_MASK = 0x0400,
739 XLFD_AVGWIDTH_MASK = 0x0800,
740 XLFD_REGISTRY_MASK = 0x1000,
741 XLFD_ENCODING_MASK = 0x2000
745 /* Parse P pointing to the pixel/point size field of the form
746 `[A B C D]' which specifies a transformation matrix:
748 A B 0
749 C D 0
750 0 0 1
752 by which all glyphs of the font are transformed. The spec says
753 that scalar value N for the pixel/point size is equivalent to:
754 A = N * resx/resy, B = C = 0, D = N.
756 Return the scalar value N if the form is valid. Otherwise return
757 -1. */
759 static int
760 parse_matrix (const char *p)
762 double matrix[4];
763 char *end;
764 int i;
766 for (i = 0, p++; i < 4 && *p && *p != ']'; i++)
768 if (*p == '~')
769 matrix[i] = - strtod (p + 1, &end);
770 else
771 matrix[i] = strtod (p, &end);
772 p = end;
774 return (i == 4 ? (int) matrix[3] : -1);
777 /* Expand a wildcard field in FIELD (the first N fields are filled) to
778 multiple fields to fill in all 14 XLFD fields while restricting a
779 field position by its contents. */
781 static int
782 font_expand_wildcards (Lisp_Object *field, int n)
784 /* Copy of FIELD. */
785 Lisp_Object tmp[XLFD_LAST_INDEX];
786 /* Array of information about where this element can go. Nth
787 element is for Nth element of FIELD. */
788 struct {
789 /* Minimum possible field. */
790 int from;
791 /* Maxinum possible field. */
792 int to;
793 /* Bit mask of possible field. Nth bit corresponds to Nth field. */
794 int mask;
795 } range[XLFD_LAST_INDEX];
796 int i, j;
797 int range_from, range_to;
798 unsigned range_mask;
800 #define XLFD_SYMBOL_MASK (XLFD_FOUNDRY_MASK | XLFD_FAMILY_MASK \
801 | XLFD_ADSTYLE_MASK | XLFD_REGISTRY_MASK)
802 #define XLFD_NULL_MASK (XLFD_FOUNDRY_MASK | XLFD_ADSTYLE_MASK)
803 #define XLFD_LARGENUM_MASK (XLFD_POINT_MASK | XLFD_RESX_MASK | XLFD_RESY_MASK \
804 | XLFD_AVGWIDTH_MASK)
805 #define XLFD_REGENC_MASK (XLFD_REGISTRY_MASK | XLFD_ENCODING_MASK)
807 /* Initialize RANGE_MASK for FIELD[0] which can be 0th to (14 - N)th
808 field. The value is shifted to left one bit by one in the
809 following loop. */
810 for (i = 0, range_mask = 0; i <= 14 - n; i++)
811 range_mask = (range_mask << 1) | 1;
813 /* The triplet RANGE_FROM, RANGE_TO, and RANGE_MASK is a
814 position-based retriction for FIELD[I]. */
815 for (i = 0, range_from = 0, range_to = 14 - n; i < n;
816 i++, range_from++, range_to++, range_mask <<= 1)
818 Lisp_Object val = field[i];
820 tmp[i] = val;
821 if (NILP (val))
823 /* Wildcard. */
824 range[i].from = range_from;
825 range[i].to = range_to;
826 range[i].mask = range_mask;
828 else
830 /* The triplet FROM, TO, and MASK is a value-based
831 retriction for FIELD[I]. */
832 int from, to;
833 unsigned mask;
835 if (INTEGERP (val))
837 int numeric = XINT (val);
839 if (i + 1 == n)
840 from = to = XLFD_ENCODING_INDEX,
841 mask = XLFD_ENCODING_MASK;
842 else if (numeric == 0)
843 from = XLFD_PIXEL_INDEX, to = XLFD_AVGWIDTH_INDEX,
844 mask = XLFD_PIXEL_MASK | XLFD_LARGENUM_MASK;
845 else if (numeric <= 48)
846 from = to = XLFD_PIXEL_INDEX,
847 mask = XLFD_PIXEL_MASK;
848 else
849 from = XLFD_POINT_INDEX, to = XLFD_AVGWIDTH_INDEX,
850 mask = XLFD_LARGENUM_MASK;
852 else if (SBYTES (SYMBOL_NAME (val)) == 0)
853 from = XLFD_FOUNDRY_INDEX, to = XLFD_ADSTYLE_INDEX,
854 mask = XLFD_NULL_MASK;
855 else if (i == 0)
856 from = to = XLFD_FOUNDRY_INDEX, mask = XLFD_FOUNDRY_MASK;
857 else if (i + 1 == n)
859 Lisp_Object name = SYMBOL_NAME (val);
861 if (SDATA (name)[SBYTES (name) - 1] == '*')
862 from = XLFD_REGISTRY_INDEX, to = XLFD_ENCODING_INDEX,
863 mask = XLFD_REGENC_MASK;
864 else
865 from = to = XLFD_ENCODING_INDEX,
866 mask = XLFD_ENCODING_MASK;
868 else if (range_from <= XLFD_WEIGHT_INDEX
869 && range_to >= XLFD_WEIGHT_INDEX
870 && FONT_WEIGHT_NAME_NUMERIC (val) >= 0)
871 from = to = XLFD_WEIGHT_INDEX, mask = XLFD_WEIGHT_MASK;
872 else if (range_from <= XLFD_SLANT_INDEX
873 && range_to >= XLFD_SLANT_INDEX
874 && FONT_SLANT_NAME_NUMERIC (val) >= 0)
875 from = to = XLFD_SLANT_INDEX, mask = XLFD_SLANT_MASK;
876 else if (range_from <= XLFD_SWIDTH_INDEX
877 && range_to >= XLFD_SWIDTH_INDEX
878 && FONT_WIDTH_NAME_NUMERIC (val) >= 0)
879 from = to = XLFD_SWIDTH_INDEX, mask = XLFD_SWIDTH_MASK;
880 else
882 if (EQ (val, Qc) || EQ (val, Qm) || EQ (val, Qp) || EQ (val, Qd))
883 from = to = XLFD_SPACING_INDEX, mask = XLFD_SPACING_MASK;
884 else
885 from = XLFD_FOUNDRY_INDEX, to = XLFD_ENCODING_INDEX,
886 mask = XLFD_SYMBOL_MASK;
889 /* Merge position-based and value-based restrictions. */
890 mask &= range_mask;
891 while (from < range_from)
892 mask &= ~(1 << from++);
893 while (from < 14 && ! (mask & (1 << from)))
894 from++;
895 while (to > range_to)
896 mask &= ~(1 << to--);
897 while (to >= 0 && ! (mask & (1 << to)))
898 to--;
899 if (from > to)
900 return -1;
901 range[i].from = from;
902 range[i].to = to;
903 range[i].mask = mask;
905 if (from > range_from || to < range_to)
907 /* The range is narrowed by value-based restrictions.
908 Reflect it to the other fields. */
910 /* Following fields should be after FROM. */
911 range_from = from;
912 /* Preceding fields should be before TO. */
913 for (j = i - 1, from--, to--; j >= 0; j--, from--, to--)
915 /* Check FROM for non-wildcard field. */
916 if (! NILP (tmp[j]) && range[j].from < from)
918 while (range[j].from < from)
919 range[j].mask &= ~(1 << range[j].from++);
920 while (from < 14 && ! (range[j].mask & (1 << from)))
921 from++;
922 range[j].from = from;
924 else
925 from = range[j].from;
926 if (range[j].to > to)
928 while (range[j].to > to)
929 range[j].mask &= ~(1 << range[j].to--);
930 while (to >= 0 && ! (range[j].mask & (1 << to)))
931 to--;
932 range[j].to = to;
934 else
935 to = range[j].to;
936 if (from > to)
937 return -1;
943 /* Decide all fileds from restrictions in RANGE. */
944 for (i = j = 0; i < n ; i++)
946 if (j < range[i].from)
948 if (i == 0 || ! NILP (tmp[i - 1]))
949 /* None of TMP[X] corresponds to Jth field. */
950 return -1;
951 for (; j < range[i].from; j++)
952 field[j] = Qnil;
954 field[j++] = tmp[i];
956 if (! NILP (tmp[n - 1]) && j < XLFD_REGISTRY_INDEX)
957 return -1;
958 for (; j < XLFD_LAST_INDEX; j++)
959 field[j] = Qnil;
960 if (INTEGERP (field[XLFD_ENCODING_INDEX]))
961 field[XLFD_ENCODING_INDEX]
962 = Fintern (Fnumber_to_string (field[XLFD_ENCODING_INDEX]), Qnil);
963 return 0;
967 /* Parse NAME (null terminated) as XLFD and store information in FONT
968 (font-spec or font-entity). Size property of FONT is set as
969 follows:
970 specified XLFD fields FONT property
971 --------------------- -------------
972 PIXEL_SIZE PIXEL_SIZE (Lisp integer)
973 POINT_SIZE and RESY calculated pixel size (Lisp integer)
974 POINT_SIZE POINT_SIZE/10 (Lisp float)
976 If NAME is successfully parsed, return 0. Otherwise return -1.
978 FONT is usually a font-spec, but when this function is called from
979 X font backend driver, it is a font-entity. In that case, NAME is
980 a fully specified XLFD. */
983 font_parse_xlfd (char *name, Lisp_Object font)
985 int len = strlen (name);
986 int i, j, n;
987 char *f[XLFD_LAST_INDEX + 1];
988 Lisp_Object val;
989 char *p;
991 if (len > 255 || !len)
992 /* Maximum XLFD name length is 255. */
993 return -1;
994 /* Accept "*-.." as a fully specified XLFD. */
995 if (name[0] == '*' && (len == 1 || name[1] == '-'))
996 i = 1, f[XLFD_FOUNDRY_INDEX] = name;
997 else
998 i = 0;
999 for (p = name + i; *p; p++)
1000 if (*p == '-')
1002 f[i++] = p + 1;
1003 if (i == XLFD_LAST_INDEX)
1004 break;
1006 f[i] = name + len;
1008 #define INTERN_FIELD(N) font_intern_prop (f[N], f[(N) + 1] - 1 - f[N], 0)
1009 #define INTERN_FIELD_SYM(N) font_intern_prop (f[N], f[(N) + 1] - 1 - f[N], 1)
1011 if (i == XLFD_LAST_INDEX)
1013 /* Fully specified XLFD. */
1014 int pixel_size;
1016 ASET (font, FONT_FOUNDRY_INDEX, INTERN_FIELD_SYM (XLFD_FOUNDRY_INDEX));
1017 ASET (font, FONT_FAMILY_INDEX, INTERN_FIELD_SYM (XLFD_FAMILY_INDEX));
1018 for (i = XLFD_WEIGHT_INDEX, j = FONT_WEIGHT_INDEX;
1019 i <= XLFD_SWIDTH_INDEX; i++, j++)
1021 val = INTERN_FIELD_SYM (i);
1022 if (! NILP (val))
1024 if ((n = font_style_to_value (j, INTERN_FIELD_SYM (i), 0)) < 0)
1025 return -1;
1026 ASET (font, j, make_number (n));
1029 ASET (font, FONT_ADSTYLE_INDEX, INTERN_FIELD_SYM (XLFD_ADSTYLE_INDEX));
1030 if (strcmp (f[XLFD_REGISTRY_INDEX], "*-*") == 0)
1031 ASET (font, FONT_REGISTRY_INDEX, Qnil);
1032 else
1033 ASET (font, FONT_REGISTRY_INDEX,
1034 font_intern_prop (f[XLFD_REGISTRY_INDEX],
1035 f[XLFD_LAST_INDEX] - f[XLFD_REGISTRY_INDEX],
1036 1));
1037 p = f[XLFD_PIXEL_INDEX];
1038 if (*p == '[' && (pixel_size = parse_matrix (p)) >= 0)
1039 ASET (font, FONT_SIZE_INDEX, make_number (pixel_size));
1040 else
1042 val = INTERN_FIELD (XLFD_PIXEL_INDEX);
1043 if (INTEGERP (val))
1044 ASET (font, FONT_SIZE_INDEX, val);
1045 else if (FONT_ENTITY_P (font))
1046 return -1;
1047 else
1049 double point_size = -1;
1051 font_assert (FONT_SPEC_P (font));
1052 p = f[XLFD_POINT_INDEX];
1053 if (*p == '[')
1054 point_size = parse_matrix (p);
1055 else if (isdigit (*p))
1056 point_size = atoi (p), point_size /= 10;
1057 if (point_size >= 0)
1058 ASET (font, FONT_SIZE_INDEX, make_float (point_size));
1062 val = INTERN_FIELD (XLFD_RESY_INDEX);
1063 if (! NILP (val) && ! INTEGERP (val))
1064 return -1;
1065 ASET (font, FONT_DPI_INDEX, val);
1066 val = INTERN_FIELD (XLFD_SPACING_INDEX);
1067 if (! NILP (val))
1069 val = font_prop_validate_spacing (QCspacing, val);
1070 if (! INTEGERP (val))
1071 return -1;
1072 ASET (font, FONT_SPACING_INDEX, val);
1074 p = f[XLFD_AVGWIDTH_INDEX];
1075 if (*p == '~')
1076 p++;
1077 val = font_intern_prop (p, f[XLFD_REGISTRY_INDEX] - 1 - p, 0);
1078 if (! NILP (val) && ! INTEGERP (val))
1079 return -1;
1080 ASET (font, FONT_AVGWIDTH_INDEX, val);
1082 else
1084 int wild_card_found = 0;
1085 Lisp_Object prop[XLFD_LAST_INDEX];
1087 if (FONT_ENTITY_P (font))
1088 return -1;
1089 for (j = 0; j < i; j++)
1091 if (*f[j] == '*')
1093 if (f[j][1] && f[j][1] != '-')
1094 return -1;
1095 prop[j] = Qnil;
1096 wild_card_found = 1;
1098 else if (j + 1 < i)
1099 prop[j] = INTERN_FIELD (j);
1100 else
1101 prop[j] = font_intern_prop (f[j], f[i] - f[j], 0);
1103 if (! wild_card_found)
1104 return -1;
1105 if (font_expand_wildcards (prop, i) < 0)
1106 return -1;
1108 ASET (font, FONT_FOUNDRY_INDEX, prop[XLFD_FOUNDRY_INDEX]);
1109 ASET (font, FONT_FAMILY_INDEX, prop[XLFD_FAMILY_INDEX]);
1110 for (i = XLFD_WEIGHT_INDEX, j = FONT_WEIGHT_INDEX;
1111 i <= XLFD_SWIDTH_INDEX; i++, j++)
1112 if (! NILP (prop[i]))
1114 if ((n = font_style_to_value (j, prop[i], 1)) < 0)
1115 return -1;
1116 ASET (font, j, make_number (n));
1118 ASET (font, FONT_ADSTYLE_INDEX, prop[XLFD_ADSTYLE_INDEX]);
1119 val = prop[XLFD_REGISTRY_INDEX];
1120 if (NILP (val))
1122 val = prop[XLFD_ENCODING_INDEX];
1123 if (! NILP (val))
1124 val = concat2 (build_string ("*-"), SYMBOL_NAME (val));
1126 else if (NILP (prop[XLFD_ENCODING_INDEX]))
1127 val = concat2 (SYMBOL_NAME (val), build_string ("-*"));
1128 else
1129 val = concat3 (SYMBOL_NAME (val), build_string ("-"),
1130 SYMBOL_NAME (prop[XLFD_ENCODING_INDEX]));
1131 if (! NILP (val))
1132 ASET (font, FONT_REGISTRY_INDEX, Fintern (val, Qnil));
1134 if (INTEGERP (prop[XLFD_PIXEL_INDEX]))
1135 ASET (font, FONT_SIZE_INDEX, prop[XLFD_PIXEL_INDEX]);
1136 else if (INTEGERP (prop[XLFD_POINT_INDEX]))
1138 double point_size = XINT (prop[XLFD_POINT_INDEX]);
1140 ASET (font, FONT_SIZE_INDEX, make_float (point_size / 10));
1143 if (INTEGERP (prop[XLFD_RESX_INDEX]))
1144 ASET (font, FONT_DPI_INDEX, prop[XLFD_RESY_INDEX]);
1145 if (! NILP (prop[XLFD_SPACING_INDEX]))
1147 val = font_prop_validate_spacing (QCspacing,
1148 prop[XLFD_SPACING_INDEX]);
1149 if (! INTEGERP (val))
1150 return -1;
1151 ASET (font, FONT_SPACING_INDEX, val);
1153 if (INTEGERP (prop[XLFD_AVGWIDTH_INDEX]))
1154 ASET (font, FONT_AVGWIDTH_INDEX, prop[XLFD_AVGWIDTH_INDEX]);
1157 return 0;
1160 /* Store XLFD name of FONT (font-spec or font-entity) in NAME (NBYTES
1161 length), and return the name length. If FONT_SIZE_INDEX of FONT is
1162 0, use PIXEL_SIZE instead. */
1165 font_unparse_xlfd (Lisp_Object font, int pixel_size, char *name, int nbytes)
1167 char *p;
1168 const char *f[XLFD_REGISTRY_INDEX + 1];
1169 Lisp_Object val;
1170 int i, j, len = 0;
1172 font_assert (FONTP (font));
1174 for (i = FONT_FOUNDRY_INDEX, j = XLFD_FOUNDRY_INDEX; i <= FONT_REGISTRY_INDEX;
1175 i++, j++)
1177 if (i == FONT_ADSTYLE_INDEX)
1178 j = XLFD_ADSTYLE_INDEX;
1179 else if (i == FONT_REGISTRY_INDEX)
1180 j = XLFD_REGISTRY_INDEX;
1181 val = AREF (font, i);
1182 if (NILP (val))
1184 if (j == XLFD_REGISTRY_INDEX)
1185 f[j] = "*-*", len += 4;
1186 else
1187 f[j] = "*", len += 2;
1189 else
1191 if (SYMBOLP (val))
1192 val = SYMBOL_NAME (val);
1193 if (j == XLFD_REGISTRY_INDEX
1194 && ! strchr (SSDATA (val), '-'))
1196 /* Change "jisx0208*" and "jisx0208" to "jisx0208*-*". */
1197 if (SDATA (val)[SBYTES (val) - 1] == '*')
1199 f[j] = p = alloca (SBYTES (val) + 3);
1200 sprintf (p, "%s-*", SDATA (val));
1201 len += SBYTES (val) + 3;
1203 else
1205 f[j] = p = alloca (SBYTES (val) + 4);
1206 sprintf (p, "%s*-*", SDATA (val));
1207 len += SBYTES (val) + 4;
1210 else
1211 f[j] = SSDATA (val), len += SBYTES (val) + 1;
1215 for (i = FONT_WEIGHT_INDEX, j = XLFD_WEIGHT_INDEX; i <= FONT_WIDTH_INDEX;
1216 i++, j++)
1218 val = font_style_symbolic (font, i, 0);
1219 if (NILP (val))
1220 f[j] = "*", len += 2;
1221 else
1223 val = SYMBOL_NAME (val);
1224 f[j] = SSDATA (val), len += SBYTES (val) + 1;
1228 val = AREF (font, FONT_SIZE_INDEX);
1229 font_assert (NUMBERP (val) || NILP (val));
1230 if (INTEGERP (val))
1232 i = XINT (val);
1233 if (i <= 0)
1234 i = pixel_size;
1235 if (i > 0)
1237 f[XLFD_PIXEL_INDEX] = p = alloca (22);
1238 len += sprintf (p, "%d-*", i) + 1;
1240 else
1241 f[XLFD_PIXEL_INDEX] = "*-*", len += 4;
1243 else if (FLOATP (val))
1245 i = XFLOAT_DATA (val) * 10;
1246 f[XLFD_PIXEL_INDEX] = p = alloca (12);
1247 len += sprintf (p, "*-%d", i) + 1;
1249 else
1250 f[XLFD_PIXEL_INDEX] = "*-*", len += 4;
1252 if (INTEGERP (AREF (font, FONT_DPI_INDEX)))
1254 i = XINT (AREF (font, FONT_DPI_INDEX));
1255 f[XLFD_RESX_INDEX] = p = alloca (22);
1256 len += sprintf (p, "%d-%d", i, i) + 1;
1258 else
1259 f[XLFD_RESX_INDEX] = "*-*", len += 4;
1260 if (INTEGERP (AREF (font, FONT_SPACING_INDEX)))
1262 int spacing = XINT (AREF (font, FONT_SPACING_INDEX));
1264 f[XLFD_SPACING_INDEX] = (spacing <= FONT_SPACING_PROPORTIONAL ? "p"
1265 : spacing <= FONT_SPACING_DUAL ? "d"
1266 : spacing <= FONT_SPACING_MONO ? "m"
1267 : "c");
1268 len += 2;
1270 else
1271 f[XLFD_SPACING_INDEX] = "*", len += 2;
1272 if (INTEGERP (AREF (font, FONT_AVGWIDTH_INDEX)))
1274 f[XLFD_AVGWIDTH_INDEX] = p = alloca (22);
1275 len += sprintf (p, "%"pI"d",
1276 XINT (AREF (font, FONT_AVGWIDTH_INDEX))) + 1;
1278 else
1279 f[XLFD_AVGWIDTH_INDEX] = "*", len += 2;
1280 len++; /* for terminating '\0'. */
1281 if (len >= nbytes)
1282 return -1;
1283 return sprintf (name, "-%s-%s-%s-%s-%s-%s-%s-%s-%s-%s-%s",
1284 f[XLFD_FOUNDRY_INDEX], f[XLFD_FAMILY_INDEX],
1285 f[XLFD_WEIGHT_INDEX], f[XLFD_SLANT_INDEX],
1286 f[XLFD_SWIDTH_INDEX], f[XLFD_ADSTYLE_INDEX],
1287 f[XLFD_PIXEL_INDEX], f[XLFD_RESX_INDEX],
1288 f[XLFD_SPACING_INDEX], f[XLFD_AVGWIDTH_INDEX],
1289 f[XLFD_REGISTRY_INDEX]);
1292 /* Parse NAME (null terminated) and store information in FONT
1293 (font-spec or font-entity). NAME is supplied in either the
1294 Fontconfig or GTK font name format. If NAME is successfully
1295 parsed, return 0. Otherwise return -1.
1297 The fontconfig format is
1299 FAMILY[-SIZE][:PROP1[=VAL1][:PROP2[=VAL2]...]]
1301 The GTK format is
1303 FAMILY [PROPS...] [SIZE]
1305 This function tries to guess which format it is. */
1307 static int
1308 font_parse_fcname (char *name, Lisp_Object font)
1310 char *p, *q;
1311 char *size_beg = NULL, *size_end = NULL;
1312 char *props_beg = NULL, *family_end = NULL;
1313 int len = strlen (name);
1315 if (len == 0)
1316 return -1;
1318 for (p = name; *p; p++)
1320 if (*p == '\\' && p[1])
1321 p++;
1322 else if (*p == ':')
1324 props_beg = family_end = p;
1325 break;
1327 else if (*p == '-')
1329 int decimal = 0, size_found = 1;
1330 for (q = p + 1; *q && *q != ':'; q++)
1331 if (! isdigit(*q))
1333 if (*q != '.' || decimal)
1335 size_found = 0;
1336 break;
1338 decimal = 1;
1340 if (size_found)
1342 family_end = p;
1343 size_beg = p + 1;
1344 size_end = q;
1345 break;
1350 if (family_end)
1352 Lisp_Object extra_props = Qnil;
1354 /* A fontconfig name with size and/or property data. */
1355 if (family_end > name)
1357 Lisp_Object family;
1358 family = font_intern_prop (name, family_end - name, 1);
1359 ASET (font, FONT_FAMILY_INDEX, family);
1361 if (size_beg)
1363 double point_size = strtod (size_beg, &size_end);
1364 ASET (font, FONT_SIZE_INDEX, make_float (point_size));
1365 if (*size_end == ':' && size_end[1])
1366 props_beg = size_end;
1368 if (props_beg)
1370 /* Now parse ":KEY=VAL" patterns. */
1371 Lisp_Object val;
1373 for (p = props_beg; *p; p = q)
1375 for (q = p + 1; *q && *q != '=' && *q != ':'; q++);
1376 if (*q != '=')
1378 /* Must be an enumerated value. */
1379 int word_len;
1380 p = p + 1;
1381 word_len = q - p;
1382 val = font_intern_prop (p, q - p, 1);
1384 #define PROP_MATCH(STR) (word_len == strlen (STR) \
1385 && memcmp (p, STR, strlen (STR)) == 0)
1387 if (PROP_MATCH ("light")
1388 || PROP_MATCH ("medium")
1389 || PROP_MATCH ("demibold")
1390 || PROP_MATCH ("bold")
1391 || PROP_MATCH ("black"))
1392 FONT_SET_STYLE (font, FONT_WEIGHT_INDEX, val);
1393 else if (PROP_MATCH ("roman")
1394 || PROP_MATCH ("italic")
1395 || PROP_MATCH ("oblique"))
1396 FONT_SET_STYLE (font, FONT_SLANT_INDEX, val);
1397 else if (PROP_MATCH ("charcell"))
1398 ASET (font, FONT_SPACING_INDEX,
1399 make_number (FONT_SPACING_CHARCELL));
1400 else if (PROP_MATCH ("mono"))
1401 ASET (font, FONT_SPACING_INDEX,
1402 make_number (FONT_SPACING_MONO));
1403 else if (PROP_MATCH ("proportional"))
1404 ASET (font, FONT_SPACING_INDEX,
1405 make_number (FONT_SPACING_PROPORTIONAL));
1406 #undef PROP_MATCH
1408 else
1410 /* KEY=VAL pairs */
1411 Lisp_Object key;
1412 int prop;
1414 if (q - p == 10 && memcmp (p + 1, "pixelsize", 9) == 0)
1415 prop = FONT_SIZE_INDEX;
1416 else
1418 key = font_intern_prop (p, q - p, 1);
1419 prop = get_font_prop_index (key);
1422 p = q + 1;
1423 for (q = p; *q && *q != ':'; q++);
1424 val = font_intern_prop (p, q - p, 0);
1426 if (prop >= FONT_FOUNDRY_INDEX
1427 && prop < FONT_EXTRA_INDEX)
1428 ASET (font, prop, font_prop_validate (prop, Qnil, val));
1429 else
1431 extra_props = nconc2 (extra_props,
1432 Fcons (Fcons (key, val), Qnil));
1435 p = q;
1439 if (! NILP (extra_props))
1441 struct font_driver_list *driver_list = font_driver_list;
1442 for ( ; driver_list; driver_list = driver_list->next)
1443 if (driver_list->driver->filter_properties)
1444 (*driver_list->driver->filter_properties) (font, extra_props);
1448 else
1450 /* Either a fontconfig-style name with no size and property
1451 data, or a GTK-style name. */
1452 Lisp_Object weight = Qnil, slant = Qnil;
1453 Lisp_Object width = Qnil, size = Qnil;
1454 char *word_start;
1455 int word_len;
1457 /* Scan backwards from the end, looking for a size. */
1458 for (p = name + len - 1; p >= name; p--)
1459 if (!isdigit (*p))
1460 break;
1462 if ((p < name + len - 1) && ((p + 1 == name) || *p == ' '))
1463 /* Found a font size. */
1464 size = make_float (strtod (p + 1, NULL));
1465 else
1466 p = name + len;
1468 /* Now P points to the termination of the string, sans size.
1469 Scan backwards, looking for font properties. */
1470 for (; p > name; p = q)
1472 for (q = p - 1; q >= name; q--)
1474 if (q > name && *(q-1) == '\\')
1475 --q; /* Skip quoting backslashes. */
1476 else if (*q == ' ')
1477 break;
1480 word_start = q + 1;
1481 word_len = p - word_start;
1483 #define PROP_MATCH(STR) \
1484 (word_len == strlen (STR) \
1485 && memcmp (word_start, STR, strlen (STR)) == 0)
1486 #define PROP_SAVE(VAR, STR) \
1487 (VAR = NILP (VAR) ? font_intern_prop (STR, strlen (STR), 1) : VAR)
1489 if (PROP_MATCH ("Ultra-Light"))
1490 PROP_SAVE (weight, "ultra-light");
1491 else if (PROP_MATCH ("Light"))
1492 PROP_SAVE (weight, "light");
1493 else if (PROP_MATCH ("Book"))
1494 PROP_SAVE (weight, "book");
1495 else if (PROP_MATCH ("Medium"))
1496 PROP_SAVE (weight, "medium");
1497 else if (PROP_MATCH ("Semi-Bold"))
1498 PROP_SAVE (weight, "semi-bold");
1499 else if (PROP_MATCH ("Bold"))
1500 PROP_SAVE (weight, "bold");
1501 else if (PROP_MATCH ("Italic"))
1502 PROP_SAVE (slant, "italic");
1503 else if (PROP_MATCH ("Oblique"))
1504 PROP_SAVE (slant, "oblique");
1505 else if (PROP_MATCH ("Semi-Condensed"))
1506 PROP_SAVE (width, "semi-condensed");
1507 else if (PROP_MATCH ("Condensed"))
1508 PROP_SAVE (width, "condensed");
1509 /* An unknown word must be part of the font name. */
1510 else
1512 family_end = p;
1513 break;
1516 #undef PROP_MATCH
1517 #undef PROP_SAVE
1519 if (family_end)
1520 ASET (font, FONT_FAMILY_INDEX,
1521 font_intern_prop (name, family_end - name, 1));
1522 if (!NILP (size))
1523 ASET (font, FONT_SIZE_INDEX, size);
1524 if (!NILP (weight))
1525 FONT_SET_STYLE (font, FONT_WEIGHT_INDEX, weight);
1526 if (!NILP (slant))
1527 FONT_SET_STYLE (font, FONT_SLANT_INDEX, slant);
1528 if (!NILP (width))
1529 FONT_SET_STYLE (font, FONT_WIDTH_INDEX, width);
1532 return 0;
1535 /* Store fontconfig's font name of FONT (font-spec or font-entity) in
1536 NAME (NBYTES length), and return the name length. If
1537 FONT_SIZE_INDEX of FONT is 0, use PIXEL_SIZE instead. */
1540 font_unparse_fcname (Lisp_Object font, int pixel_size, char *name, int nbytes)
1542 Lisp_Object family, foundry;
1543 Lisp_Object tail, val;
1544 int point_size;
1545 int i, len = 1;
1546 char *p;
1547 Lisp_Object styles[3];
1548 const char *style_names[3] = { "weight", "slant", "width" };
1549 char work[256];
1551 family = AREF (font, FONT_FAMILY_INDEX);
1552 if (! NILP (family))
1554 if (SYMBOLP (family))
1556 family = SYMBOL_NAME (family);
1557 len += SBYTES (family);
1559 else
1560 family = Qnil;
1563 val = AREF (font, FONT_SIZE_INDEX);
1564 if (INTEGERP (val))
1566 if (XINT (val) != 0)
1567 pixel_size = XINT (val);
1568 point_size = -1;
1569 len += 21; /* for ":pixelsize=NUM" */
1571 else
1573 if (! FLOATP (val))
1574 abort ();
1575 pixel_size = -1;
1576 point_size = (int) XFLOAT_DATA (val);
1577 len += 11; /* for "-NUM" */
1580 foundry = AREF (font, FONT_FOUNDRY_INDEX);
1581 if (! NILP (foundry))
1583 if (SYMBOLP (foundry))
1585 foundry = SYMBOL_NAME (foundry);
1586 len += 9 + SBYTES (foundry); /* ":foundry=NAME" */
1588 else
1589 foundry = Qnil;
1592 for (i = 0; i < 3; i++)
1594 styles[i] = font_style_symbolic (font, FONT_WEIGHT_INDEX + i, 0);
1595 if (! NILP (styles[i]))
1596 len += sprintf (work, ":%s=%s", style_names[i],
1597 SDATA (SYMBOL_NAME (styles[i])));
1600 if (INTEGERP (AREF (font, FONT_DPI_INDEX)))
1601 len += sprintf (work, ":dpi=%"pI"d", XINT (AREF (font, FONT_DPI_INDEX)));
1602 if (INTEGERP (AREF (font, FONT_SPACING_INDEX)))
1603 len += strlen (":spacing=100");
1604 if (INTEGERP (AREF (font, FONT_AVGWIDTH_INDEX)))
1605 len += strlen (":scalable=false"); /* or ":scalable=true" */
1606 for (tail = AREF (font, FONT_EXTRA_INDEX); CONSP (tail); tail = XCDR (tail))
1608 Lisp_Object key = XCAR (XCAR (tail)), value = XCDR (XCAR (tail));
1610 len += SBYTES (SYMBOL_NAME (key)) + 1; /* for :KEY= */
1611 if (STRINGP (value))
1612 len += SBYTES (value);
1613 else if (INTEGERP (value))
1614 len += sprintf (work, "%"pI"d", XINT (value));
1615 else if (SYMBOLP (value))
1616 len += (NILP (value) ? 5 : 4); /* for "false" or "true" */
1619 if (len > nbytes)
1620 return -1;
1621 p = name;
1622 if (! NILP (family))
1623 p += sprintf (p, "%s", SDATA (family));
1624 if (point_size > 0)
1626 if (p == name)
1627 p += sprintf (p, "%d", point_size);
1628 else
1629 p += sprintf (p, "-%d", point_size);
1631 else if (pixel_size > 0)
1632 p += sprintf (p, ":pixelsize=%d", pixel_size);
1633 if (! NILP (AREF (font, FONT_FOUNDRY_INDEX)))
1634 p += sprintf (p, ":foundry=%s",
1635 SDATA (SYMBOL_NAME (AREF (font, FONT_FOUNDRY_INDEX))));
1636 for (i = 0; i < 3; i++)
1637 if (! NILP (styles[i]))
1638 p += sprintf (p, ":%s=%s", style_names[i],
1639 SDATA (SYMBOL_NAME (styles[i])));
1640 if (INTEGERP (AREF (font, FONT_DPI_INDEX)))
1641 p += sprintf (p, ":dpi=%"pI"d", XINT (AREF (font, FONT_DPI_INDEX)));
1642 if (INTEGERP (AREF (font, FONT_SPACING_INDEX)))
1643 p += sprintf (p, ":spacing=%"pI"d", XINT (AREF (font, FONT_SPACING_INDEX)));
1644 if (INTEGERP (AREF (font, FONT_AVGWIDTH_INDEX)))
1646 if (XINT (AREF (font, FONT_AVGWIDTH_INDEX)) == 0)
1647 p += sprintf (p, ":scalable=true");
1648 else
1649 p += sprintf (p, ":scalable=false");
1651 return (p - name);
1654 /* Parse NAME (null terminated) and store information in FONT
1655 (font-spec or font-entity). If NAME is successfully parsed, return
1656 0. Otherwise return -1. */
1658 static int
1659 font_parse_name (char *name, Lisp_Object font)
1661 if (name[0] == '-' || strchr (name, '*') || strchr (name, '?'))
1662 return font_parse_xlfd (name, font);
1663 return font_parse_fcname (name, font);
1667 /* Merge FAMILY and REGISTRY into FONT_SPEC. FAMILY may have the form
1668 "FAMILY-FOUNDRY". REGISTRY may not contain charset-encoding
1669 part. */
1671 void
1672 font_parse_family_registry (Lisp_Object family, Lisp_Object registry, Lisp_Object font_spec)
1674 int len;
1675 char *p0, *p1;
1677 if (! NILP (family)
1678 && NILP (AREF (font_spec, FONT_FAMILY_INDEX)))
1680 CHECK_STRING (family);
1681 len = SBYTES (family);
1682 p0 = SSDATA (family);
1683 p1 = strchr (p0, '-');
1684 if (p1)
1686 if ((*p0 != '*' && p1 - p0 > 0)
1687 && NILP (AREF (font_spec, FONT_FOUNDRY_INDEX)))
1688 Ffont_put (font_spec, QCfoundry, font_intern_prop (p0, p1 - p0, 1));
1689 p1++;
1690 len -= p1 - p0;
1691 Ffont_put (font_spec, QCfamily, font_intern_prop (p1, len, 1));
1693 else
1694 ASET (font_spec, FONT_FAMILY_INDEX, Fintern (family, Qnil));
1696 if (! NILP (registry))
1698 /* Convert "XXX" and "XXX*" to "XXX*-*". */
1699 CHECK_STRING (registry);
1700 len = SBYTES (registry);
1701 p0 = SSDATA (registry);
1702 p1 = strchr (p0, '-');
1703 if (! p1)
1705 if (SDATA (registry)[len - 1] == '*')
1706 registry = concat2 (registry, build_string ("-*"));
1707 else
1708 registry = concat2 (registry, build_string ("*-*"));
1710 registry = Fdowncase (registry);
1711 ASET (font_spec, FONT_REGISTRY_INDEX, Fintern (registry, Qnil));
1716 /* This part (through the next ^L) is still experimental and not
1717 tested much. We may drastically change codes. */
1719 /* OTF handler */
1721 #if 0
1723 #define LGSTRING_HEADER_SIZE 6
1724 #define LGSTRING_GLYPH_SIZE 8
1726 static int
1727 check_gstring (gstring)
1728 Lisp_Object gstring;
1730 Lisp_Object val;
1731 int i, j;
1733 CHECK_VECTOR (gstring);
1734 val = AREF (gstring, 0);
1735 CHECK_VECTOR (val);
1736 if (ASIZE (val) < LGSTRING_HEADER_SIZE)
1737 goto err;
1738 CHECK_FONT_OBJECT (LGSTRING_FONT (gstring));
1739 if (!NILP (LGSTRING_SLOT (gstring, LGSTRING_IX_LBEARING)))
1740 CHECK_NUMBER (LGSTRING_SLOT (gstring, LGSTRING_IX_LBEARING));
1741 if (!NILP (LGSTRING_SLOT (gstring, LGSTRING_IX_RBEARING)))
1742 CHECK_NUMBER (LGSTRING_SLOT (gstring, LGSTRING_IX_RBEARING));
1743 if (!NILP (LGSTRING_SLOT (gstring, LGSTRING_IX_WIDTH)))
1744 CHECK_NATNUM (LGSTRING_SLOT (gstring, LGSTRING_IX_WIDTH));
1745 if (!NILP (LGSTRING_SLOT (gstring, LGSTRING_IX_ASCENT)))
1746 CHECK_NUMBER (LGSTRING_SLOT (gstring, LGSTRING_IX_ASCENT));
1747 if (!NILP (LGSTRING_SLOT (gstring, LGSTRING_IX_ASCENT)))
1748 CHECK_NUMBER (LGSTRING_SLOT (gstring, LGSTRING_IX_ASCENT));
1750 for (i = 0; i < LGSTRING_GLYPH_LEN (gstring); i++)
1752 val = LGSTRING_GLYPH (gstring, i);
1753 CHECK_VECTOR (val);
1754 if (ASIZE (val) < LGSTRING_GLYPH_SIZE)
1755 goto err;
1756 if (NILP (AREF (val, LGLYPH_IX_CHAR)))
1757 break;
1758 CHECK_NATNUM (AREF (val, LGLYPH_IX_FROM));
1759 CHECK_NATNUM (AREF (val, LGLYPH_IX_TO));
1760 CHECK_CHARACTER (AREF (val, LGLYPH_IX_CHAR));
1761 if (!NILP (AREF (val, LGLYPH_IX_CODE)))
1762 CHECK_NATNUM (AREF (val, LGLYPH_IX_CODE));
1763 if (!NILP (AREF (val, LGLYPH_IX_WIDTH)))
1764 CHECK_NATNUM (AREF (val, LGLYPH_IX_WIDTH));
1765 if (!NILP (AREF (val, LGLYPH_IX_ADJUSTMENT)))
1767 val = AREF (val, LGLYPH_IX_ADJUSTMENT);
1768 CHECK_VECTOR (val);
1769 if (ASIZE (val) < 3)
1770 goto err;
1771 for (j = 0; j < 3; j++)
1772 CHECK_NUMBER (AREF (val, j));
1775 return i;
1776 err:
1777 error ("Invalid glyph-string format");
1778 return -1;
1781 static void
1782 check_otf_features (otf_features)
1783 Lisp_Object otf_features;
1785 Lisp_Object val;
1787 CHECK_CONS (otf_features);
1788 CHECK_SYMBOL (XCAR (otf_features));
1789 otf_features = XCDR (otf_features);
1790 CHECK_CONS (otf_features);
1791 CHECK_SYMBOL (XCAR (otf_features));
1792 otf_features = XCDR (otf_features);
1793 for (val = Fcar (otf_features); ! NILP (val); val = Fcdr (val))
1795 CHECK_SYMBOL (Fcar (val));
1796 if (SBYTES (SYMBOL_NAME (XCAR (val))) > 4)
1797 error ("Invalid OTF GSUB feature: %s",
1798 SDATA (SYMBOL_NAME (XCAR (val))));
1800 otf_features = XCDR (otf_features);
1801 for (val = Fcar (otf_features); ! NILP (val); val = Fcdr (val))
1803 CHECK_SYMBOL (Fcar (val));
1804 if (SBYTES (SYMBOL_NAME (XCAR (val))) > 4)
1805 error ("Invalid OTF GPOS feature: %s",
1806 SDATA (SYMBOL_NAME (XCAR (val))));
1810 #ifdef HAVE_LIBOTF
1811 #include <otf.h>
1813 Lisp_Object otf_list;
1815 static Lisp_Object
1816 otf_tag_symbol (tag)
1817 OTF_Tag tag;
1819 char name[5];
1821 OTF_tag_name (tag, name);
1822 return Fintern (make_unibyte_string (name, 4), Qnil);
1825 static OTF *
1826 otf_open (file)
1827 Lisp_Object file;
1829 Lisp_Object val = Fassoc (file, otf_list);
1830 OTF *otf;
1832 if (! NILP (val))
1833 otf = XSAVE_VALUE (XCDR (val))->pointer;
1834 else
1836 otf = STRINGP (file) ? OTF_open (SSDATA (file)) : NULL;
1837 val = make_save_value (otf, 0);
1838 otf_list = Fcons (Fcons (file, val), otf_list);
1840 return otf;
1844 /* Return a list describing which scripts/languages FONT supports by
1845 which GSUB/GPOS features of OpenType tables. See the comment of
1846 (struct font_driver).otf_capability. */
1848 Lisp_Object
1849 font_otf_capability (font)
1850 struct font *font;
1852 OTF *otf;
1853 Lisp_Object capability = Fcons (Qnil, Qnil);
1854 int i;
1856 otf = otf_open (font->props[FONT_FILE_INDEX]);
1857 if (! otf)
1858 return Qnil;
1859 for (i = 0; i < 2; i++)
1861 OTF_GSUB_GPOS *gsub_gpos;
1862 Lisp_Object script_list = Qnil;
1863 int j;
1865 if (OTF_get_features (otf, i == 0) < 0)
1866 continue;
1867 gsub_gpos = i == 0 ? otf->gsub : otf->gpos;
1868 for (j = gsub_gpos->ScriptList.ScriptCount - 1; j >= 0; j--)
1870 OTF_Script *script = gsub_gpos->ScriptList.Script + j;
1871 Lisp_Object langsys_list = Qnil;
1872 Lisp_Object script_tag = otf_tag_symbol (script->ScriptTag);
1873 int k;
1875 for (k = script->LangSysCount; k >= 0; k--)
1877 OTF_LangSys *langsys;
1878 Lisp_Object feature_list = Qnil;
1879 Lisp_Object langsys_tag;
1880 int l;
1882 if (k == script->LangSysCount)
1884 langsys = &script->DefaultLangSys;
1885 langsys_tag = Qnil;
1887 else
1889 langsys = script->LangSys + k;
1890 langsys_tag
1891 = otf_tag_symbol (script->LangSysRecord[k].LangSysTag);
1893 for (l = langsys->FeatureCount - 1; l >= 0; l--)
1895 OTF_Feature *feature
1896 = gsub_gpos->FeatureList.Feature + langsys->FeatureIndex[l];
1897 Lisp_Object feature_tag
1898 = otf_tag_symbol (feature->FeatureTag);
1900 feature_list = Fcons (feature_tag, feature_list);
1902 langsys_list = Fcons (Fcons (langsys_tag, feature_list),
1903 langsys_list);
1905 script_list = Fcons (Fcons (script_tag, langsys_list),
1906 script_list);
1909 if (i == 0)
1910 XSETCAR (capability, script_list);
1911 else
1912 XSETCDR (capability, script_list);
1915 return capability;
1918 /* Parse OTF features in SPEC and write a proper features spec string
1919 in FEATURES for the call of OTF_drive_gsub/gpos (of libotf). It is
1920 assured that the sufficient memory has already allocated for
1921 FEATURES. */
1923 static void
1924 generate_otf_features (spec, features)
1925 Lisp_Object spec;
1926 char *features;
1928 Lisp_Object val;
1929 char *p;
1930 int asterisk;
1932 p = features;
1933 *p = '\0';
1934 for (asterisk = 0; CONSP (spec); spec = XCDR (spec))
1936 val = XCAR (spec);
1937 CHECK_SYMBOL (val);
1938 if (p > features)
1939 *p++ = ',';
1940 if (SREF (SYMBOL_NAME (val), 0) == '*')
1942 asterisk = 1;
1943 *p++ = '*';
1945 else if (! asterisk)
1947 val = SYMBOL_NAME (val);
1948 p += sprintf (p, "%s", SDATA (val));
1950 else
1952 val = SYMBOL_NAME (val);
1953 p += sprintf (p, "~%s", SDATA (val));
1956 if (CONSP (spec))
1957 error ("OTF spec too long");
1960 Lisp_Object
1961 font_otf_DeviceTable (device_table)
1962 OTF_DeviceTable *device_table;
1964 int len = device_table->StartSize - device_table->EndSize + 1;
1966 return Fcons (make_number (len),
1967 make_unibyte_string (device_table->DeltaValue, len));
1970 Lisp_Object
1971 font_otf_ValueRecord (value_format, value_record)
1972 int value_format;
1973 OTF_ValueRecord *value_record;
1975 Lisp_Object val = Fmake_vector (make_number (8), Qnil);
1977 if (value_format & OTF_XPlacement)
1978 ASET (val, 0, make_number (value_record->XPlacement));
1979 if (value_format & OTF_YPlacement)
1980 ASET (val, 1, make_number (value_record->YPlacement));
1981 if (value_format & OTF_XAdvance)
1982 ASET (val, 2, make_number (value_record->XAdvance));
1983 if (value_format & OTF_YAdvance)
1984 ASET (val, 3, make_number (value_record->YAdvance));
1985 if (value_format & OTF_XPlaDevice)
1986 ASET (val, 4, font_otf_DeviceTable (&value_record->XPlaDevice));
1987 if (value_format & OTF_YPlaDevice)
1988 ASET (val, 4, font_otf_DeviceTable (&value_record->YPlaDevice));
1989 if (value_format & OTF_XAdvDevice)
1990 ASET (val, 4, font_otf_DeviceTable (&value_record->XAdvDevice));
1991 if (value_format & OTF_YAdvDevice)
1992 ASET (val, 4, font_otf_DeviceTable (&value_record->YAdvDevice));
1993 return val;
1996 Lisp_Object
1997 font_otf_Anchor (anchor)
1998 OTF_Anchor *anchor;
2000 Lisp_Object val;
2002 val = Fmake_vector (make_number (anchor->AnchorFormat + 1), Qnil);
2003 ASET (val, 0, make_number (anchor->XCoordinate));
2004 ASET (val, 1, make_number (anchor->YCoordinate));
2005 if (anchor->AnchorFormat == 2)
2006 ASET (val, 2, make_number (anchor->f.f1.AnchorPoint));
2007 else
2009 ASET (val, 3, font_otf_DeviceTable (&anchor->f.f2.XDeviceTable));
2010 ASET (val, 4, font_otf_DeviceTable (&anchor->f.f2.YDeviceTable));
2012 return val;
2014 #endif /* HAVE_LIBOTF */
2015 #endif /* 0 */
2018 /* Font sorting */
2020 static unsigned font_score (Lisp_Object, Lisp_Object *);
2021 static int font_compare (const void *, const void *);
2022 static Lisp_Object font_sort_entities (Lisp_Object, Lisp_Object,
2023 Lisp_Object, int);
2025 static double
2026 font_rescale_ratio (Lisp_Object font_entity)
2028 Lisp_Object tail, elt;
2029 Lisp_Object name = Qnil;
2031 for (tail = Vface_font_rescale_alist; CONSP (tail); tail = XCDR (tail))
2033 elt = XCAR (tail);
2034 if (FLOATP (XCDR (elt)))
2036 if (STRINGP (XCAR (elt)))
2038 if (NILP (name))
2039 name = Ffont_xlfd_name (font_entity, Qnil);
2040 if (fast_string_match_ignore_case (XCAR (elt), name) >= 0)
2041 return XFLOAT_DATA (XCDR (elt));
2043 else if (FONT_SPEC_P (XCAR (elt)))
2045 if (font_match_p (XCAR (elt), font_entity))
2046 return XFLOAT_DATA (XCDR (elt));
2050 return 1.0;
2053 /* We sort fonts by scoring each of them against a specified
2054 font-spec. The score value is 32 bit (`unsigned'), and the smaller
2055 the value is, the closer the font is to the font-spec.
2057 The lowest 2 bits of the score are used for driver type. The font
2058 available by the most preferred font driver is 0.
2060 The 4 7-bit fields in the higher 28 bits are used for numeric properties
2061 WEIGHT, SLANT, WIDTH, and SIZE. */
2063 /* How many bits to shift to store the difference value of each font
2064 property in a score. Note that floats for FONT_TYPE_INDEX and
2065 FONT_REGISTRY_INDEX are not used. */
2066 static int sort_shift_bits[FONT_SIZE_INDEX + 1];
2068 /* Score font-entity ENTITY against properties of font-spec SPEC_PROP.
2069 The return value indicates how different ENTITY is compared with
2070 SPEC_PROP. */
2072 static unsigned
2073 font_score (Lisp_Object entity, Lisp_Object *spec_prop)
2075 unsigned score = 0;
2076 int i;
2078 /* Score three style numeric fields. Maximum difference is 127. */
2079 for (i = FONT_WEIGHT_INDEX; i <= FONT_WIDTH_INDEX; i++)
2080 if (! NILP (spec_prop[i]) && ! EQ (AREF (entity, i), spec_prop[i]))
2082 EMACS_INT diff = ((XINT (AREF (entity, i)) >> 8)
2083 - (XINT (spec_prop[i]) >> 8));
2084 if (diff < 0)
2085 diff = - diff;
2086 score |= min (diff, 127) << sort_shift_bits[i];
2089 /* Score the size. Maximum difference is 127. */
2090 i = FONT_SIZE_INDEX;
2091 if (! NILP (spec_prop[FONT_SIZE_INDEX])
2092 && XINT (AREF (entity, FONT_SIZE_INDEX)) > 0)
2094 /* We use the higher 6-bit for the actual size difference. The
2095 lowest bit is set if the DPI is different. */
2096 int diff;
2097 int pixel_size = XINT (spec_prop[FONT_SIZE_INDEX]);
2099 if (CONSP (Vface_font_rescale_alist))
2100 pixel_size *= font_rescale_ratio (entity);
2101 diff = pixel_size - XINT (AREF (entity, FONT_SIZE_INDEX));
2102 if (diff < 0)
2103 diff = - diff;
2104 diff <<= 1;
2105 if (! NILP (spec_prop[FONT_DPI_INDEX])
2106 && ! EQ (spec_prop[FONT_DPI_INDEX], AREF (entity, FONT_DPI_INDEX)))
2107 diff |= 1;
2108 if (! NILP (spec_prop[FONT_AVGWIDTH_INDEX])
2109 && ! EQ (spec_prop[FONT_AVGWIDTH_INDEX], AREF (entity, FONT_AVGWIDTH_INDEX)))
2110 diff |= 1;
2111 score |= min (diff, 127) << sort_shift_bits[FONT_SIZE_INDEX];
2114 return score;
2118 /* Concatenate all elements of LIST into one vector. LIST is a list
2119 of font-entity vectors. */
2121 static Lisp_Object
2122 font_vconcat_entity_vectors (Lisp_Object list)
2124 int nargs = XINT (Flength (list));
2125 Lisp_Object *args = alloca (sizeof (Lisp_Object) * nargs);
2126 int i;
2128 for (i = 0; i < nargs; i++, list = XCDR (list))
2129 args[i] = XCAR (list);
2130 return Fvconcat (nargs, args);
2134 /* The structure for elements being sorted by qsort. */
2135 struct font_sort_data
2137 unsigned score;
2138 int font_driver_preference;
2139 Lisp_Object entity;
2143 /* The comparison function for qsort. */
2145 static int
2146 font_compare (const void *d1, const void *d2)
2148 const struct font_sort_data *data1 = d1;
2149 const struct font_sort_data *data2 = d2;
2151 if (data1->score < data2->score)
2152 return -1;
2153 else if (data1->score > data2->score)
2154 return 1;
2155 return (data1->font_driver_preference - data2->font_driver_preference);
2159 /* Sort each font-entity vector in LIST by closeness to font-spec PREFER.
2160 If PREFER specifies a point-size, calculate the corresponding
2161 pixel-size from QCdpi property of PREFER or from the Y-resolution
2162 of FRAME before sorting.
2164 If BEST-ONLY is nonzero, return the best matching entity (that
2165 supports the character BEST-ONLY if BEST-ONLY is positive, or any
2166 if BEST-ONLY is negative). Otherwise, return the sorted result as
2167 a single vector of font-entities.
2169 This function does no optimization for the case that the total
2170 number of elements is 1. The caller should avoid calling this in
2171 such a case. */
2173 static Lisp_Object
2174 font_sort_entities (Lisp_Object list, Lisp_Object prefer, Lisp_Object frame, int best_only)
2176 Lisp_Object prefer_prop[FONT_SPEC_MAX];
2177 int len, maxlen, i;
2178 struct font_sort_data *data;
2179 unsigned best_score;
2180 Lisp_Object best_entity;
2181 struct frame *f = XFRAME (frame);
2182 Lisp_Object tail, vec IF_LINT (= Qnil);
2183 USE_SAFE_ALLOCA;
2185 for (i = FONT_WEIGHT_INDEX; i <= FONT_AVGWIDTH_INDEX; i++)
2186 prefer_prop[i] = AREF (prefer, i);
2187 if (FLOATP (prefer_prop[FONT_SIZE_INDEX]))
2188 prefer_prop[FONT_SIZE_INDEX]
2189 = make_number (font_pixel_size (XFRAME (frame), prefer));
2191 if (NILP (XCDR (list)))
2193 /* What we have to take care of is this single vector. */
2194 vec = XCAR (list);
2195 maxlen = ASIZE (vec);
2197 else if (best_only)
2199 /* We don't have to perform sort, so there's no need of creating
2200 a single vector. But, we must find the length of the longest
2201 vector. */
2202 maxlen = 0;
2203 for (tail = list; CONSP (tail); tail = XCDR (tail))
2204 if (maxlen < ASIZE (XCAR (tail)))
2205 maxlen = ASIZE (XCAR (tail));
2207 else
2209 /* We have to create a single vector to sort it. */
2210 vec = font_vconcat_entity_vectors (list);
2211 maxlen = ASIZE (vec);
2214 SAFE_ALLOCA (data, struct font_sort_data *, (sizeof *data) * maxlen);
2215 best_score = 0xFFFFFFFF;
2216 best_entity = Qnil;
2218 for (tail = list; CONSP (tail); tail = XCDR (tail))
2220 int font_driver_preference = 0;
2221 Lisp_Object current_font_driver;
2223 if (best_only)
2224 vec = XCAR (tail);
2225 len = ASIZE (vec);
2227 /* We are sure that the length of VEC > 0. */
2228 current_font_driver = AREF (AREF (vec, 0), FONT_TYPE_INDEX);
2229 /* Score the elements. */
2230 for (i = 0; i < len; i++)
2232 data[i].entity = AREF (vec, i);
2233 data[i].score
2234 = ((best_only <= 0 || font_has_char (f, data[i].entity, best_only)
2235 > 0)
2236 ? font_score (data[i].entity, prefer_prop)
2237 : 0xFFFFFFFF);
2238 if (best_only && best_score > data[i].score)
2240 best_score = data[i].score;
2241 best_entity = data[i].entity;
2242 if (best_score == 0)
2243 break;
2245 if (! EQ (current_font_driver, AREF (AREF (vec, i), FONT_TYPE_INDEX)))
2247 current_font_driver = AREF (AREF (vec, i), FONT_TYPE_INDEX);
2248 font_driver_preference++;
2250 data[i].font_driver_preference = font_driver_preference;
2253 /* Sort if necessary. */
2254 if (! best_only)
2256 qsort (data, len, sizeof *data, font_compare);
2257 for (i = 0; i < len; i++)
2258 ASET (vec, i, data[i].entity);
2259 break;
2261 else
2262 vec = best_entity;
2265 SAFE_FREE ();
2267 FONT_ADD_LOG ("sort-by", prefer, vec);
2268 return vec;
2272 /* API of Font Service Layer. */
2274 /* Reflect ORDER (see the variable font_sort_order in xfaces.c) to
2275 sort_shift_bits. Finternal_set_font_selection_order calls this
2276 function with font_sort_order after setting up it. */
2278 void
2279 font_update_sort_order (int *order)
2281 int i, shift_bits;
2283 for (i = 0, shift_bits = 23; i < 4; i++, shift_bits -= 7)
2285 int xlfd_idx = order[i];
2287 if (xlfd_idx == XLFD_WEIGHT_INDEX)
2288 sort_shift_bits[FONT_WEIGHT_INDEX] = shift_bits;
2289 else if (xlfd_idx == XLFD_SLANT_INDEX)
2290 sort_shift_bits[FONT_SLANT_INDEX] = shift_bits;
2291 else if (xlfd_idx == XLFD_SWIDTH_INDEX)
2292 sort_shift_bits[FONT_WIDTH_INDEX] = shift_bits;
2293 else
2294 sort_shift_bits[FONT_SIZE_INDEX] = shift_bits;
2298 static int
2299 font_check_otf_features (Lisp_Object script, Lisp_Object langsys, Lisp_Object features, Lisp_Object table)
2301 Lisp_Object val;
2302 int negative;
2304 table = assq_no_quit (script, table);
2305 if (NILP (table))
2306 return 0;
2307 table = XCDR (table);
2308 if (! NILP (langsys))
2310 table = assq_no_quit (langsys, table);
2311 if (NILP (table))
2312 return 0;
2314 else
2316 val = assq_no_quit (Qnil, table);
2317 if (NILP (val))
2318 table = XCAR (table);
2319 else
2320 table = val;
2322 table = XCDR (table);
2323 for (negative = 0; CONSP (features); features = XCDR (features))
2325 if (NILP (XCAR (features)))
2327 negative = 1;
2328 continue;
2330 if (NILP (Fmemq (XCAR (features), table)) != negative)
2331 return 0;
2333 return 1;
2336 /* Check if OTF_CAPABILITY satisfies SPEC (otf-spec). */
2338 static int
2339 font_check_otf (Lisp_Object spec, Lisp_Object otf_capability)
2341 Lisp_Object script, langsys = Qnil, gsub = Qnil, gpos = Qnil;
2343 script = XCAR (spec);
2344 spec = XCDR (spec);
2345 if (! NILP (spec))
2347 langsys = XCAR (spec);
2348 spec = XCDR (spec);
2349 if (! NILP (spec))
2351 gsub = XCAR (spec);
2352 spec = XCDR (spec);
2353 if (! NILP (spec))
2354 gpos = XCAR (spec);
2358 if (! NILP (gsub) && ! font_check_otf_features (script, langsys, gsub,
2359 XCAR (otf_capability)))
2360 return 0;
2361 if (! NILP (gpos) && ! font_check_otf_features (script, langsys, gpos,
2362 XCDR (otf_capability)))
2363 return 0;
2364 return 1;
2369 /* Check if FONT (font-entity or font-object) matches with the font
2370 specification SPEC. */
2373 font_match_p (Lisp_Object spec, Lisp_Object font)
2375 Lisp_Object prop[FONT_SPEC_MAX], *props;
2376 Lisp_Object extra, font_extra;
2377 int i;
2379 for (i = FONT_FOUNDRY_INDEX; i <= FONT_REGISTRY_INDEX; i++)
2380 if (! NILP (AREF (spec, i))
2381 && ! NILP (AREF (font, i))
2382 && ! EQ (AREF (spec, i), AREF (font, i)))
2383 return 0;
2384 props = XFONT_SPEC (spec)->props;
2385 if (FLOATP (props[FONT_SIZE_INDEX]))
2387 for (i = FONT_FOUNDRY_INDEX; i < FONT_SIZE_INDEX; i++)
2388 prop[i] = AREF (spec, i);
2389 prop[FONT_SIZE_INDEX]
2390 = make_number (font_pixel_size (XFRAME (selected_frame), spec));
2391 props = prop;
2394 if (font_score (font, props) > 0)
2395 return 0;
2396 extra = AREF (spec, FONT_EXTRA_INDEX);
2397 font_extra = AREF (font, FONT_EXTRA_INDEX);
2398 for (; CONSP (extra); extra = XCDR (extra))
2400 Lisp_Object key = XCAR (XCAR (extra));
2401 Lisp_Object val = XCDR (XCAR (extra)), val2;
2403 if (EQ (key, QClang))
2405 val2 = assq_no_quit (key, font_extra);
2406 if (NILP (val2))
2407 return 0;
2408 val2 = XCDR (val2);
2409 if (CONSP (val))
2411 if (! CONSP (val2))
2412 return 0;
2413 while (CONSP (val))
2414 if (NILP (Fmemq (val, val2)))
2415 return 0;
2417 else
2418 if (CONSP (val2)
2419 ? NILP (Fmemq (val, XCDR (val2)))
2420 : ! EQ (val, val2))
2421 return 0;
2423 else if (EQ (key, QCscript))
2425 val2 = assq_no_quit (val, Vscript_representative_chars);
2426 if (CONSP (val2))
2428 val2 = XCDR (val2);
2429 if (CONSP (val2))
2431 /* All characters in the list must be supported. */
2432 for (; CONSP (val2); val2 = XCDR (val2))
2434 if (! NATNUMP (XCAR (val2)))
2435 continue;
2436 if (font_encode_char (font, XFASTINT (XCAR (val2)))
2437 == FONT_INVALID_CODE)
2438 return 0;
2441 else if (VECTORP (val2))
2443 /* At most one character in the vector must be supported. */
2444 for (i = 0; i < ASIZE (val2); i++)
2446 if (! NATNUMP (AREF (val2, i)))
2447 continue;
2448 if (font_encode_char (font, XFASTINT (AREF (val2, i)))
2449 != FONT_INVALID_CODE)
2450 break;
2452 if (i == ASIZE (val2))
2453 return 0;
2457 else if (EQ (key, QCotf))
2459 struct font *fontp;
2461 if (! FONT_OBJECT_P (font))
2462 return 0;
2463 fontp = XFONT_OBJECT (font);
2464 if (! fontp->driver->otf_capability)
2465 return 0;
2466 val2 = fontp->driver->otf_capability (fontp);
2467 if (NILP (val2) || ! font_check_otf (val, val2))
2468 return 0;
2472 return 1;
2476 /* Font cache
2478 Each font backend has the callback function get_cache, and it
2479 returns a cons cell of which cdr part can be freely used for
2480 caching fonts. The cons cell may be shared by multiple frames
2481 and/or multiple font drivers. So, we arrange the cdr part as this:
2483 ((DRIVER-TYPE NUM-FRAMES FONT-CACHE-DATA ...) ...)
2485 where DRIVER-TYPE is a symbol such as `x', `xft', etc., NUM-FRAMES
2486 is a number frames sharing this cache, and FONT-CACHE-DATA is a
2487 cons (FONT-SPEC FONT-ENTITY ...). */
2489 static void font_prepare_cache (FRAME_PTR, struct font_driver *);
2490 static void font_finish_cache (FRAME_PTR, struct font_driver *);
2491 static Lisp_Object font_get_cache (FRAME_PTR, struct font_driver *);
2492 static void font_clear_cache (FRAME_PTR, Lisp_Object,
2493 struct font_driver *);
2495 static void
2496 font_prepare_cache (FRAME_PTR f, struct font_driver *driver)
2498 Lisp_Object cache, val;
2500 cache = driver->get_cache (f);
2501 val = XCDR (cache);
2502 while (CONSP (val) && ! EQ (XCAR (XCAR (val)), driver->type))
2503 val = XCDR (val);
2504 if (NILP (val))
2506 val = Fcons (driver->type, Fcons (make_number (1), Qnil));
2507 XSETCDR (cache, Fcons (val, XCDR (cache)));
2509 else
2511 val = XCDR (XCAR (val));
2512 XSETCAR (val, make_number (XINT (XCAR (val)) + 1));
2517 static void
2518 font_finish_cache (FRAME_PTR f, struct font_driver *driver)
2520 Lisp_Object cache, val, tmp;
2523 cache = driver->get_cache (f);
2524 val = XCDR (cache);
2525 while (CONSP (val) && ! EQ (XCAR (XCAR (val)), driver->type))
2526 cache = val, val = XCDR (val);
2527 font_assert (! NILP (val));
2528 tmp = XCDR (XCAR (val));
2529 XSETCAR (tmp, make_number (XINT (XCAR (tmp)) - 1));
2530 if (XINT (XCAR (tmp)) == 0)
2532 font_clear_cache (f, XCAR (val), driver);
2533 XSETCDR (cache, XCDR (val));
2538 static Lisp_Object
2539 font_get_cache (FRAME_PTR f, struct font_driver *driver)
2541 Lisp_Object val = driver->get_cache (f);
2542 Lisp_Object type = driver->type;
2544 font_assert (CONSP (val));
2545 for (val = XCDR (val); ! EQ (XCAR (XCAR (val)), type); val = XCDR (val));
2546 font_assert (CONSP (val));
2547 /* VAL = ((DRIVER-TYPE NUM-FRAMES FONT-CACHE-DATA ...) ...) */
2548 val = XCDR (XCAR (val));
2549 return val;
2552 static int num_fonts;
2554 static void
2555 font_clear_cache (FRAME_PTR f, Lisp_Object cache, struct font_driver *driver)
2557 Lisp_Object tail, elt;
2558 Lisp_Object tail2, entity;
2560 /* CACHE = (DRIVER-TYPE NUM-FRAMES FONT-CACHE-DATA ...) */
2561 for (tail = XCDR (XCDR (cache)); CONSP (tail); tail = XCDR (tail))
2563 elt = XCAR (tail);
2564 /* elt should have the form (FONT-SPEC FONT-ENTITY ...) */
2565 if (CONSP (elt) && FONT_SPEC_P (XCAR (elt)))
2567 for (tail2 = XCDR (elt); CONSP (tail2); tail2 = XCDR (tail2))
2569 entity = XCAR (tail2);
2571 if (FONT_ENTITY_P (entity)
2572 && EQ (driver->type, AREF (entity, FONT_TYPE_INDEX)))
2574 Lisp_Object objlist = AREF (entity, FONT_OBJLIST_INDEX);
2576 for (; CONSP (objlist); objlist = XCDR (objlist))
2578 Lisp_Object val = XCAR (objlist);
2579 struct font *font = XFONT_OBJECT (val);
2581 if (! NILP (AREF (val, FONT_TYPE_INDEX)))
2583 font_assert (font && driver == font->driver);
2584 driver->close (f, font);
2585 num_fonts--;
2588 if (driver->free_entity)
2589 driver->free_entity (entity);
2594 XSETCDR (cache, Qnil);
2598 static Lisp_Object scratch_font_spec, scratch_font_prefer;
2600 /* Check each font-entity in VEC, and return a list of font-entities
2601 that satisfy these conditions:
2602 (1) matches with SPEC and SIZE if SPEC is not nil, and
2603 (2) doesn't match with any regexps in Vface_ignored_fonts (if non-nil).
2606 static Lisp_Object
2607 font_delete_unmatched (Lisp_Object vec, Lisp_Object spec, int size)
2609 Lisp_Object entity, val;
2610 enum font_property_index prop;
2611 int i;
2613 for (val = Qnil, i = ASIZE (vec) - 1; i >= 0; i--)
2615 entity = AREF (vec, i);
2616 if (! NILP (Vface_ignored_fonts))
2618 char name[256];
2619 Lisp_Object tail, regexp;
2621 if (font_unparse_xlfd (entity, 0, name, 256) >= 0)
2623 for (tail = Vface_ignored_fonts; CONSP (tail); tail = XCDR (tail))
2625 regexp = XCAR (tail);
2626 if (STRINGP (regexp)
2627 && fast_c_string_match_ignore_case (regexp, name) >= 0)
2628 break;
2630 if (CONSP (tail))
2631 continue;
2634 if (NILP (spec))
2636 val = Fcons (entity, val);
2637 continue;
2639 for (prop = FONT_WEIGHT_INDEX; prop < FONT_SIZE_INDEX; prop++)
2640 if (INTEGERP (AREF (spec, prop))
2641 && ((XINT (AREF (spec, prop)) >> 8)
2642 != (XINT (AREF (entity, prop)) >> 8)))
2643 prop = FONT_SPEC_MAX;
2644 if (prop < FONT_SPEC_MAX
2645 && size
2646 && XINT (AREF (entity, FONT_SIZE_INDEX)) > 0)
2648 int diff = XINT (AREF (entity, FONT_SIZE_INDEX)) - size;
2650 if (diff != 0
2651 && (diff < 0 ? -diff > FONT_PIXEL_SIZE_QUANTUM
2652 : diff > FONT_PIXEL_SIZE_QUANTUM))
2653 prop = FONT_SPEC_MAX;
2655 if (prop < FONT_SPEC_MAX
2656 && INTEGERP (AREF (spec, FONT_DPI_INDEX))
2657 && INTEGERP (AREF (entity, FONT_DPI_INDEX))
2658 && XINT (AREF (entity, FONT_DPI_INDEX)) != 0
2659 && ! EQ (AREF (spec, FONT_DPI_INDEX), AREF (entity, FONT_DPI_INDEX)))
2660 prop = FONT_SPEC_MAX;
2661 if (prop < FONT_SPEC_MAX
2662 && INTEGERP (AREF (spec, FONT_AVGWIDTH_INDEX))
2663 && INTEGERP (AREF (entity, FONT_AVGWIDTH_INDEX))
2664 && XINT (AREF (entity, FONT_AVGWIDTH_INDEX)) != 0
2665 && ! EQ (AREF (spec, FONT_AVGWIDTH_INDEX),
2666 AREF (entity, FONT_AVGWIDTH_INDEX)))
2667 prop = FONT_SPEC_MAX;
2668 if (prop < FONT_SPEC_MAX)
2669 val = Fcons (entity, val);
2671 return (Fvconcat (1, &val));
2675 /* Return a list of vectors of font-entities matching with SPEC on
2676 FRAME. Each elements in the list is a vector of entities from the
2677 same font-driver. */
2679 Lisp_Object
2680 font_list_entities (Lisp_Object frame, Lisp_Object spec)
2682 FRAME_PTR f = XFRAME (frame);
2683 struct font_driver_list *driver_list = f->font_driver_list;
2684 Lisp_Object ftype, val;
2685 Lisp_Object list = Qnil;
2686 int size;
2687 int need_filtering = 0;
2688 int i;
2690 font_assert (FONT_SPEC_P (spec));
2692 if (INTEGERP (AREF (spec, FONT_SIZE_INDEX)))
2693 size = XINT (AREF (spec, FONT_SIZE_INDEX));
2694 else if (FLOATP (AREF (spec, FONT_SIZE_INDEX)))
2695 size = font_pixel_size (f, spec);
2696 else
2697 size = 0;
2699 ftype = AREF (spec, FONT_TYPE_INDEX);
2700 for (i = FONT_FOUNDRY_INDEX; i <= FONT_REGISTRY_INDEX; i++)
2701 ASET (scratch_font_spec, i, AREF (spec, i));
2702 for (i = FONT_WEIGHT_INDEX; i < FONT_EXTRA_INDEX; i++)
2703 if (i != FONT_SPACING_INDEX)
2705 ASET (scratch_font_spec, i, Qnil);
2706 if (! NILP (AREF (spec, i)))
2707 need_filtering = 1;
2709 ASET (scratch_font_spec, FONT_SPACING_INDEX, AREF (spec, FONT_SPACING_INDEX));
2710 ASET (scratch_font_spec, FONT_EXTRA_INDEX, AREF (spec, FONT_EXTRA_INDEX));
2712 for (i = 0; driver_list; driver_list = driver_list->next)
2713 if (driver_list->on
2714 && (NILP (ftype) || EQ (driver_list->driver->type, ftype)))
2716 Lisp_Object cache = font_get_cache (f, driver_list->driver);
2718 ASET (scratch_font_spec, FONT_TYPE_INDEX, driver_list->driver->type);
2719 val = assoc_no_quit (scratch_font_spec, XCDR (cache));
2720 if (CONSP (val))
2721 val = XCDR (val);
2722 else
2724 Lisp_Object copy;
2726 val = driver_list->driver->list (frame, scratch_font_spec);
2727 if (NILP (val))
2728 val = null_vector;
2729 else
2730 val = Fvconcat (1, &val);
2731 copy = copy_font_spec (scratch_font_spec);
2732 ASET (copy, FONT_TYPE_INDEX, driver_list->driver->type);
2733 XSETCDR (cache, Fcons (Fcons (copy, val), XCDR (cache)));
2735 if (ASIZE (val) > 0
2736 && (need_filtering
2737 || ! NILP (Vface_ignored_fonts)))
2738 val = font_delete_unmatched (val, need_filtering ? spec : Qnil, size);
2739 if (ASIZE (val) > 0)
2740 list = Fcons (val, list);
2743 list = Fnreverse (list);
2744 FONT_ADD_LOG ("list", spec, list);
2745 return list;
2749 /* Return a font entity matching with SPEC on FRAME. ATTRS, if non
2750 nil, is an array of face's attributes, which specifies preferred
2751 font-related attributes. */
2753 static Lisp_Object
2754 font_matching_entity (FRAME_PTR f, Lisp_Object *attrs, Lisp_Object spec)
2756 struct font_driver_list *driver_list = f->font_driver_list;
2757 Lisp_Object ftype, size, entity;
2758 Lisp_Object frame;
2759 Lisp_Object work = copy_font_spec (spec);
2761 XSETFRAME (frame, f);
2762 ftype = AREF (spec, FONT_TYPE_INDEX);
2763 size = AREF (spec, FONT_SIZE_INDEX);
2765 if (FLOATP (size))
2766 ASET (work, FONT_SIZE_INDEX, make_number (font_pixel_size (f, spec)));
2767 FONT_SET_STYLE (work, FONT_WEIGHT_INDEX, attrs[LFACE_WEIGHT_INDEX]);
2768 FONT_SET_STYLE (work, FONT_SLANT_INDEX, attrs[LFACE_SLANT_INDEX]);
2769 FONT_SET_STYLE (work, FONT_WIDTH_INDEX, attrs[LFACE_SWIDTH_INDEX]);
2771 entity = Qnil;
2772 for (; driver_list; driver_list = driver_list->next)
2773 if (driver_list->on
2774 && (NILP (ftype) || EQ (driver_list->driver->type, ftype)))
2776 Lisp_Object cache = font_get_cache (f, driver_list->driver);
2777 Lisp_Object copy;
2779 ASET (work, FONT_TYPE_INDEX, driver_list->driver->type);
2780 entity = assoc_no_quit (work, XCDR (cache));
2781 if (CONSP (entity))
2782 entity = XCDR (entity);
2783 else
2785 entity = driver_list->driver->match (frame, work);
2786 copy = copy_font_spec (work);
2787 ASET (copy, FONT_TYPE_INDEX, driver_list->driver->type);
2788 XSETCDR (cache, Fcons (Fcons (copy, entity), XCDR (cache)));
2790 if (! NILP (entity))
2791 break;
2793 FONT_ADD_LOG ("match", work, entity);
2794 return entity;
2798 /* Open a font of ENTITY and PIXEL_SIZE on frame F, and return the
2799 opened font object. */
2801 static Lisp_Object
2802 font_open_entity (FRAME_PTR f, Lisp_Object entity, int pixel_size)
2804 struct font_driver_list *driver_list;
2805 Lisp_Object objlist, size, val, font_object;
2806 struct font *font;
2807 int min_width, height;
2808 int scaled_pixel_size = pixel_size;
2810 font_assert (FONT_ENTITY_P (entity));
2811 size = AREF (entity, FONT_SIZE_INDEX);
2812 if (XINT (size) != 0)
2813 scaled_pixel_size = pixel_size = XINT (size);
2814 else if (CONSP (Vface_font_rescale_alist))
2815 scaled_pixel_size = pixel_size * font_rescale_ratio (entity);
2817 val = AREF (entity, FONT_TYPE_INDEX);
2818 for (driver_list = f->font_driver_list;
2819 driver_list && ! EQ (driver_list->driver->type, val);
2820 driver_list = driver_list->next);
2821 if (! driver_list)
2822 return Qnil;
2824 for (objlist = AREF (entity, FONT_OBJLIST_INDEX); CONSP (objlist);
2825 objlist = XCDR (objlist))
2827 Lisp_Object fn = XCAR (objlist);
2828 if (! NILP (AREF (fn, FONT_TYPE_INDEX))
2829 && XFONT_OBJECT (fn)->pixel_size == pixel_size)
2831 if (driver_list->driver->cached_font_ok == NULL
2832 || driver_list->driver->cached_font_ok (f, fn, entity))
2833 return fn;
2837 font_object = driver_list->driver->open (f, entity, scaled_pixel_size);
2838 if (!NILP (font_object))
2839 ASET (font_object, FONT_SIZE_INDEX, make_number (pixel_size));
2840 FONT_ADD_LOG ("open", entity, font_object);
2841 if (NILP (font_object))
2842 return Qnil;
2843 ASET (entity, FONT_OBJLIST_INDEX,
2844 Fcons (font_object, AREF (entity, FONT_OBJLIST_INDEX)));
2845 num_fonts++;
2847 font = XFONT_OBJECT (font_object);
2848 min_width = (font->min_width ? font->min_width
2849 : font->average_width ? font->average_width
2850 : font->space_width ? font->space_width
2851 : 1);
2852 height = (font->height ? font->height : 1);
2853 #ifdef HAVE_WINDOW_SYSTEM
2854 FRAME_X_DISPLAY_INFO (f)->n_fonts++;
2855 if (FRAME_X_DISPLAY_INFO (f)->n_fonts == 1)
2857 FRAME_SMALLEST_CHAR_WIDTH (f) = min_width;
2858 FRAME_SMALLEST_FONT_HEIGHT (f) = height;
2859 fonts_changed_p = 1;
2861 else
2863 if (FRAME_SMALLEST_CHAR_WIDTH (f) > min_width)
2864 FRAME_SMALLEST_CHAR_WIDTH (f) = min_width, fonts_changed_p = 1;
2865 if (FRAME_SMALLEST_FONT_HEIGHT (f) > height)
2866 FRAME_SMALLEST_FONT_HEIGHT (f) = height, fonts_changed_p = 1;
2868 #endif
2870 return font_object;
2874 /* Close FONT_OBJECT that is opened on frame F. */
2876 static void
2877 font_close_object (FRAME_PTR f, Lisp_Object font_object)
2879 struct font *font = XFONT_OBJECT (font_object);
2881 if (NILP (AREF (font_object, FONT_TYPE_INDEX)))
2882 /* Already closed. */
2883 return;
2884 FONT_ADD_LOG ("close", font_object, Qnil);
2885 font->driver->close (f, font);
2886 #ifdef HAVE_WINDOW_SYSTEM
2887 font_assert (FRAME_X_DISPLAY_INFO (f)->n_fonts);
2888 FRAME_X_DISPLAY_INFO (f)->n_fonts--;
2889 #endif
2890 num_fonts--;
2894 /* Return 1 if FONT on F has a glyph for character C, 0 if not, -1 if
2895 FONT is a font-entity and it must be opened to check. */
2898 font_has_char (FRAME_PTR f, Lisp_Object font, int c)
2900 struct font *fontp;
2902 if (FONT_ENTITY_P (font))
2904 Lisp_Object type = AREF (font, FONT_TYPE_INDEX);
2905 struct font_driver_list *driver_list;
2907 for (driver_list = f->font_driver_list;
2908 driver_list && ! EQ (driver_list->driver->type, type);
2909 driver_list = driver_list->next);
2910 if (! driver_list)
2911 return 0;
2912 if (! driver_list->driver->has_char)
2913 return -1;
2914 return driver_list->driver->has_char (font, c);
2917 font_assert (FONT_OBJECT_P (font));
2918 fontp = XFONT_OBJECT (font);
2919 if (fontp->driver->has_char)
2921 int result = fontp->driver->has_char (font, c);
2923 if (result >= 0)
2924 return result;
2926 return (fontp->driver->encode_char (fontp, c) != FONT_INVALID_CODE);
2930 /* Return the glyph ID of FONT_OBJECT for character C. */
2932 static unsigned
2933 font_encode_char (Lisp_Object font_object, int c)
2935 struct font *font;
2937 font_assert (FONT_OBJECT_P (font_object));
2938 font = XFONT_OBJECT (font_object);
2939 return font->driver->encode_char (font, c);
2943 /* Return the name of FONT_OBJECT. */
2945 Lisp_Object
2946 font_get_name (Lisp_Object font_object)
2948 font_assert (FONT_OBJECT_P (font_object));
2949 return AREF (font_object, FONT_NAME_INDEX);
2953 /* Create a new font spec from FONT_NAME, and return it. If FONT_NAME
2954 could not be parsed by font_parse_name, return Qnil. */
2956 Lisp_Object
2957 font_spec_from_name (Lisp_Object font_name)
2959 Lisp_Object spec = Ffont_spec (0, NULL);
2961 CHECK_STRING (font_name);
2962 if (font_parse_name (SSDATA (font_name), spec) == -1)
2963 return Qnil;
2964 font_put_extra (spec, QCname, font_name);
2965 font_put_extra (spec, QCuser_spec, font_name);
2966 return spec;
2970 void
2971 font_clear_prop (Lisp_Object *attrs, enum font_property_index prop)
2973 Lisp_Object font = attrs[LFACE_FONT_INDEX];
2975 if (! FONTP (font))
2976 return;
2978 if (! NILP (Ffont_get (font, QCname)))
2980 font = copy_font_spec (font);
2981 font_put_extra (font, QCname, Qnil);
2984 if (NILP (AREF (font, prop))
2985 && prop != FONT_FAMILY_INDEX
2986 && prop != FONT_FOUNDRY_INDEX
2987 && prop != FONT_WIDTH_INDEX
2988 && prop != FONT_SIZE_INDEX)
2989 return;
2990 if (EQ (font, attrs[LFACE_FONT_INDEX]))
2991 font = copy_font_spec (font);
2992 ASET (font, prop, Qnil);
2993 if (prop == FONT_FAMILY_INDEX || prop == FONT_FOUNDRY_INDEX)
2995 if (prop == FONT_FAMILY_INDEX)
2997 ASET (font, FONT_FOUNDRY_INDEX, Qnil);
2998 /* If we are setting the font family, we must also clear
2999 FONT_WIDTH_INDEX to avoid rejecting families that lack
3000 support for some widths. */
3001 ASET (font, FONT_WIDTH_INDEX, Qnil);
3003 ASET (font, FONT_ADSTYLE_INDEX, Qnil);
3004 ASET (font, FONT_REGISTRY_INDEX, Qnil);
3005 ASET (font, FONT_SIZE_INDEX, Qnil);
3006 ASET (font, FONT_DPI_INDEX, Qnil);
3007 ASET (font, FONT_SPACING_INDEX, Qnil);
3008 ASET (font, FONT_AVGWIDTH_INDEX, Qnil);
3010 else if (prop == FONT_SIZE_INDEX)
3012 ASET (font, FONT_DPI_INDEX, Qnil);
3013 ASET (font, FONT_SPACING_INDEX, Qnil);
3014 ASET (font, FONT_AVGWIDTH_INDEX, Qnil);
3016 else if (prop == FONT_WIDTH_INDEX)
3017 ASET (font, FONT_AVGWIDTH_INDEX, Qnil);
3018 attrs[LFACE_FONT_INDEX] = font;
3021 /* Select a font from ENTITIES (list of font-entity vectors) that
3022 supports C and is the best match for ATTRS and PIXEL_SIZE. */
3024 static Lisp_Object
3025 font_select_entity (Lisp_Object frame, Lisp_Object entities, Lisp_Object *attrs, int pixel_size, int c)
3027 Lisp_Object font_entity;
3028 Lisp_Object prefer;
3029 int result, i;
3030 FRAME_PTR f = XFRAME (frame);
3032 if (NILP (XCDR (entities))
3033 && ASIZE (XCAR (entities)) == 1)
3035 font_entity = AREF (XCAR (entities), 0);
3036 if (c < 0
3037 || (result = font_has_char (f, font_entity, c)) > 0)
3038 return font_entity;
3039 return Qnil;
3042 /* Sort fonts by properties specified in ATTRS. */
3043 prefer = scratch_font_prefer;
3045 for (i = FONT_WEIGHT_INDEX; i <= FONT_SIZE_INDEX; i++)
3046 ASET (prefer, i, Qnil);
3047 if (FONTP (attrs[LFACE_FONT_INDEX]))
3049 Lisp_Object face_font = attrs[LFACE_FONT_INDEX];
3051 for (i = FONT_WEIGHT_INDEX; i <= FONT_SIZE_INDEX; i++)
3052 ASET (prefer, i, AREF (face_font, i));
3054 if (NILP (AREF (prefer, FONT_WEIGHT_INDEX)))
3055 FONT_SET_STYLE (prefer, FONT_WEIGHT_INDEX, attrs[LFACE_WEIGHT_INDEX]);
3056 if (NILP (AREF (prefer, FONT_SLANT_INDEX)))
3057 FONT_SET_STYLE (prefer, FONT_SLANT_INDEX, attrs[LFACE_SLANT_INDEX]);
3058 if (NILP (AREF (prefer, FONT_WIDTH_INDEX)))
3059 FONT_SET_STYLE (prefer, FONT_WIDTH_INDEX, attrs[LFACE_SWIDTH_INDEX]);
3060 ASET (prefer, FONT_SIZE_INDEX, make_number (pixel_size));
3062 return font_sort_entities (entities, prefer, frame, c);
3065 /* Return a font-entity that satisfies SPEC and is the best match for
3066 face's font related attributes in ATTRS. C, if not negative, is a
3067 character that the entity must support. */
3069 Lisp_Object
3070 font_find_for_lface (FRAME_PTR f, Lisp_Object *attrs, Lisp_Object spec, int c)
3072 Lisp_Object work;
3073 Lisp_Object frame, entities, val;
3074 Lisp_Object foundry[3], *family, registry[3], adstyle[3];
3075 int pixel_size;
3076 int i, j, k, l;
3078 registry[0] = AREF (spec, FONT_REGISTRY_INDEX);
3079 if (NILP (registry[0]))
3081 registry[0] = DEFAULT_ENCODING;
3082 registry[1] = Qascii_0;
3083 registry[2] = null_vector;
3085 else
3086 registry[1] = null_vector;
3088 if (c >= 0 && ! NILP (AREF (spec, FONT_REGISTRY_INDEX)))
3090 struct charset *encoding, *repertory;
3092 if (font_registry_charsets (AREF (spec, FONT_REGISTRY_INDEX),
3093 &encoding, &repertory) < 0)
3094 return Qnil;
3095 if (repertory
3096 && ENCODE_CHAR (repertory, c) == CHARSET_INVALID_CODE (repertory))
3097 return Qnil;
3098 else if (c > encoding->max_char)
3099 return Qnil;
3102 work = copy_font_spec (spec);
3103 ASET (work, FONT_TYPE_INDEX, AREF (spec, FONT_TYPE_INDEX));
3104 XSETFRAME (frame, f);
3105 pixel_size = font_pixel_size (f, spec);
3106 if (pixel_size == 0 && INTEGERP (attrs[LFACE_HEIGHT_INDEX]))
3108 double pt = XINT (attrs[LFACE_HEIGHT_INDEX]);
3110 pixel_size = POINT_TO_PIXEL (pt / 10, f->resy);
3112 ASET (work, FONT_SIZE_INDEX, Qnil);
3113 foundry[0] = AREF (work, FONT_FOUNDRY_INDEX);
3114 if (! NILP (foundry[0]))
3115 foundry[1] = null_vector;
3116 else if (STRINGP (attrs[LFACE_FOUNDRY_INDEX]))
3118 val = attrs[LFACE_FOUNDRY_INDEX];
3119 foundry[0] = font_intern_prop (SSDATA (val), SBYTES (val), 1);
3120 foundry[1] = Qnil;
3121 foundry[2] = null_vector;
3123 else
3124 foundry[0] = Qnil, foundry[1] = null_vector;
3126 adstyle[0] = AREF (work, FONT_ADSTYLE_INDEX);
3127 if (! NILP (adstyle[0]))
3128 adstyle[1] = null_vector;
3129 else if (FONTP (attrs[LFACE_FONT_INDEX]))
3131 Lisp_Object face_font = attrs[LFACE_FONT_INDEX];
3133 if (! NILP (AREF (face_font, FONT_ADSTYLE_INDEX)))
3135 adstyle[0] = AREF (face_font, FONT_ADSTYLE_INDEX);
3136 adstyle[1] = Qnil;
3137 adstyle[2] = null_vector;
3139 else
3140 adstyle[0] = Qnil, adstyle[1] = null_vector;
3142 else
3143 adstyle[0] = Qnil, adstyle[1] = null_vector;
3146 val = AREF (work, FONT_FAMILY_INDEX);
3147 if (NILP (val) && STRINGP (attrs[LFACE_FAMILY_INDEX]))
3149 val = attrs[LFACE_FAMILY_INDEX];
3150 val = font_intern_prop (SSDATA (val), SBYTES (val), 1);
3152 if (NILP (val))
3154 family = alloca ((sizeof family[0]) * 2);
3155 family[0] = Qnil;
3156 family[1] = null_vector; /* terminator. */
3158 else
3160 Lisp_Object alters
3161 = Fassoc_string (val, Vface_alternative_font_family_alist,
3162 /* Font family names are case-sensitive under NS. */
3163 #ifndef HAVE_NS
3165 #else
3166 Qnil
3167 #endif
3170 if (! NILP (alters))
3172 family = alloca ((sizeof family[0]) * (XINT (Flength (alters)) + 2));
3173 for (i = 0; CONSP (alters); i++, alters = XCDR (alters))
3174 family[i] = XCAR (alters);
3175 if (NILP (AREF (spec, FONT_FAMILY_INDEX)))
3176 family[i++] = Qnil;
3177 family[i] = null_vector;
3179 else
3181 family = alloca ((sizeof family[0]) * 3);
3182 i = 0;
3183 family[i++] = val;
3184 if (NILP (AREF (spec, FONT_FAMILY_INDEX)))
3185 family[i++] = Qnil;
3186 family[i] = null_vector;
3190 for (i = 0; SYMBOLP (family[i]); i++)
3192 ASET (work, FONT_FAMILY_INDEX, family[i]);
3193 for (j = 0; SYMBOLP (foundry[j]); j++)
3195 ASET (work, FONT_FOUNDRY_INDEX, foundry[j]);
3196 for (k = 0; SYMBOLP (registry[k]); k++)
3198 ASET (work, FONT_REGISTRY_INDEX, registry[k]);
3199 for (l = 0; SYMBOLP (adstyle[l]); l++)
3201 ASET (work, FONT_ADSTYLE_INDEX, adstyle[l]);
3202 entities = font_list_entities (frame, work);
3203 if (! NILP (entities))
3205 val = font_select_entity (frame, entities,
3206 attrs, pixel_size, c);
3207 if (! NILP (val))
3208 return val;
3214 return Qnil;
3218 Lisp_Object
3219 font_open_for_lface (FRAME_PTR f, Lisp_Object entity, Lisp_Object *attrs, Lisp_Object spec)
3221 int size;
3223 if (INTEGERP (AREF (entity, FONT_SIZE_INDEX))
3224 && XINT (AREF (entity, FONT_SIZE_INDEX)) > 0)
3225 size = XINT (AREF (entity, FONT_SIZE_INDEX));
3226 else if (FONT_SPEC_P (spec) && ! NILP (AREF (spec, FONT_SIZE_INDEX)))
3227 size = font_pixel_size (f, spec);
3228 else
3230 double pt;
3231 if (INTEGERP (attrs[LFACE_HEIGHT_INDEX]))
3232 pt = XINT (attrs[LFACE_HEIGHT_INDEX]);
3233 else
3235 struct face *def = FACE_FROM_ID (f, DEFAULT_FACE_ID);
3236 Lisp_Object height = def->lface[LFACE_HEIGHT_INDEX];
3237 if (INTEGERP (height))
3238 pt = XINT (height);
3239 else
3240 abort(); /* We should never end up here. */
3243 pt /= 10;
3244 size = POINT_TO_PIXEL (pt, f->resy);
3245 #ifdef HAVE_NS
3246 if (size == 0)
3248 Lisp_Object ffsize = get_frame_param(f, Qfontsize);
3249 size = NUMBERP (ffsize) ? POINT_TO_PIXEL (XINT (ffsize), f->resy) : 0;
3251 #endif
3253 return font_open_entity (f, entity, size);
3257 /* Find a font that satisfies SPEC and is the best match for
3258 face's attributes in ATTRS on FRAME, and return the opened
3259 font-object. */
3261 Lisp_Object
3262 font_load_for_lface (FRAME_PTR f, Lisp_Object *attrs, Lisp_Object spec)
3264 Lisp_Object entity, name;
3266 entity = font_find_for_lface (f, attrs, spec, -1);
3267 if (NILP (entity))
3269 /* No font is listed for SPEC, but each font-backend may have
3270 different criteria about "font matching". So, try it. */
3271 entity = font_matching_entity (f, attrs, spec);
3272 if (NILP (entity))
3273 return Qnil;
3275 /* Don't lose the original name that was put in initially. We need
3276 it to re-apply the font when font parameters (like hinting or dpi) have
3277 changed. */
3278 entity = font_open_for_lface (f, entity, attrs, spec);
3279 if (!NILP (entity))
3281 name = Ffont_get (spec, QCuser_spec);
3282 if (STRINGP (name)) font_put_extra (entity, QCuser_spec, name);
3284 return entity;
3288 /* Make FACE on frame F ready to use the font opened for FACE. */
3290 void
3291 font_prepare_for_face (FRAME_PTR f, struct face *face)
3293 if (face->font->driver->prepare_face)
3294 face->font->driver->prepare_face (f, face);
3298 /* Make FACE on frame F stop using the font opened for FACE. */
3300 void
3301 font_done_for_face (FRAME_PTR f, struct face *face)
3303 if (face->font->driver->done_face)
3304 face->font->driver->done_face (f, face);
3305 face->extra = NULL;
3309 /* Open a font that is a match for font-spec SPEC on frame F. If no proper
3310 font is found, return Qnil. */
3312 Lisp_Object
3313 font_open_by_spec (FRAME_PTR f, Lisp_Object spec)
3315 Lisp_Object attrs[LFACE_VECTOR_SIZE];
3317 /* We set up the default font-related attributes of a face to prefer
3318 a moderate font. */
3319 attrs[LFACE_FAMILY_INDEX] = attrs[LFACE_FOUNDRY_INDEX] = Qnil;
3320 attrs[LFACE_SWIDTH_INDEX] = attrs[LFACE_WEIGHT_INDEX]
3321 = attrs[LFACE_SLANT_INDEX] = Qnormal;
3322 #ifndef HAVE_NS
3323 attrs[LFACE_HEIGHT_INDEX] = make_number (120);
3324 #else
3325 attrs[LFACE_HEIGHT_INDEX] = make_number (0);
3326 #endif
3327 attrs[LFACE_FONT_INDEX] = Qnil;
3329 return font_load_for_lface (f, attrs, spec);
3333 /* Open a font that matches NAME on frame F. If no proper font is
3334 found, return Qnil. */
3336 Lisp_Object
3337 font_open_by_name (FRAME_PTR f, const char *name)
3339 Lisp_Object args[2];
3340 Lisp_Object spec, ret;
3342 args[0] = QCname;
3343 args[1] = make_unibyte_string (name, strlen (name));
3344 spec = Ffont_spec (2, args);
3345 ret = font_open_by_spec (f, spec);
3346 /* Do not lose name originally put in. */
3347 if (!NILP (ret))
3348 font_put_extra (ret, QCuser_spec, args[1]);
3350 return ret;
3354 /* Register font-driver DRIVER. This function is used in two ways.
3356 The first is with frame F non-NULL. In this case, make DRIVER
3357 available (but not yet activated) on F. All frame creators
3358 (e.g. Fx_create_frame) must call this function at least once with
3359 an available font-driver.
3361 The second is with frame F NULL. In this case, DRIVER is globally
3362 registered in the variable `font_driver_list'. All font-driver
3363 implementations must call this function in its syms_of_XXXX
3364 (e.g. syms_of_xfont). */
3366 void
3367 register_font_driver (struct font_driver *driver, FRAME_PTR f)
3369 struct font_driver_list *root = f ? f->font_driver_list : font_driver_list;
3370 struct font_driver_list *prev, *list;
3372 if (f && ! driver->draw)
3373 error ("Unusable font driver for a frame: %s",
3374 SDATA (SYMBOL_NAME (driver->type)));
3376 for (prev = NULL, list = root; list; prev = list, list = list->next)
3377 if (EQ (list->driver->type, driver->type))
3378 error ("Duplicated font driver: %s", SDATA (SYMBOL_NAME (driver->type)));
3380 list = xmalloc (sizeof (struct font_driver_list));
3381 list->on = 0;
3382 list->driver = driver;
3383 list->next = NULL;
3384 if (prev)
3385 prev->next = list;
3386 else if (f)
3387 f->font_driver_list = list;
3388 else
3389 font_driver_list = list;
3390 if (! f)
3391 num_font_drivers++;
3394 void
3395 free_font_driver_list (FRAME_PTR f)
3397 struct font_driver_list *list, *next;
3399 for (list = f->font_driver_list; list; list = next)
3401 next = list->next;
3402 xfree (list);
3404 f->font_driver_list = NULL;
3408 /* Make the frame F use font backends listed in NEW_DRIVERS (list of
3409 symbols, e.g. xft, x). If NEW_DRIVERS is t, make F use all
3410 available font drivers. If NEW_DRIVERS is nil, finalize all drivers.
3412 A caller must free all realized faces if any in advance. The
3413 return value is a list of font backends actually made used on
3414 F. */
3416 Lisp_Object
3417 font_update_drivers (FRAME_PTR f, Lisp_Object new_drivers)
3419 Lisp_Object active_drivers = Qnil;
3420 struct font_driver_list *list;
3422 /* At first, turn off non-requested drivers, and turn on requested
3423 drivers. */
3424 for (list = f->font_driver_list; list; list = list->next)
3426 struct font_driver *driver = list->driver;
3427 if ((EQ (new_drivers, Qt) || ! NILP (Fmemq (driver->type, new_drivers)))
3428 != list->on)
3430 if (list->on)
3432 if (driver->end_for_frame)
3433 driver->end_for_frame (f);
3434 font_finish_cache (f, driver);
3435 list->on = 0;
3437 else
3439 if (! driver->start_for_frame
3440 || driver->start_for_frame (f) == 0)
3442 font_prepare_cache (f, driver);
3443 list->on = 1;
3449 if (NILP (new_drivers))
3450 return Qnil;
3452 if (! EQ (new_drivers, Qt))
3454 /* Re-order the driver list according to new_drivers. */
3455 struct font_driver_list **list_table, **next;
3456 Lisp_Object tail;
3457 int i;
3459 list_table = alloca (sizeof list_table[0] * (num_font_drivers + 1));
3460 for (i = 0, tail = new_drivers; ! NILP (tail); tail = XCDR (tail))
3462 for (list = f->font_driver_list; list; list = list->next)
3463 if (list->on && EQ (list->driver->type, XCAR (tail)))
3464 break;
3465 if (list)
3466 list_table[i++] = list;
3468 for (list = f->font_driver_list; list; list = list->next)
3469 if (! list->on)
3470 list_table[i++] = list;
3471 list_table[i] = NULL;
3473 next = &f->font_driver_list;
3474 for (i = 0; list_table[i]; i++)
3476 *next = list_table[i];
3477 next = &(*next)->next;
3479 *next = NULL;
3481 if (! f->font_driver_list->on)
3482 { /* None of the drivers is enabled: enable them all.
3483 Happens if you set the list of drivers to (xft x) in your .emacs
3484 and then use it under w32 or ns. */
3485 for (list = f->font_driver_list; list; list = list->next)
3487 struct font_driver *driver = list->driver;
3488 eassert (! list->on);
3489 if (! driver->start_for_frame
3490 || driver->start_for_frame (f) == 0)
3492 font_prepare_cache (f, driver);
3493 list->on = 1;
3499 for (list = f->font_driver_list; list; list = list->next)
3500 if (list->on)
3501 active_drivers = nconc2 (active_drivers,
3502 Fcons (list->driver->type, Qnil));
3503 return active_drivers;
3507 font_put_frame_data (FRAME_PTR f, struct font_driver *driver, void *data)
3509 struct font_data_list *list, *prev;
3511 for (prev = NULL, list = f->font_data_list; list;
3512 prev = list, list = list->next)
3513 if (list->driver == driver)
3514 break;
3515 if (! data)
3517 if (list)
3519 if (prev)
3520 prev->next = list->next;
3521 else
3522 f->font_data_list = list->next;
3523 xfree (list);
3525 return 0;
3528 if (! list)
3530 list = xmalloc (sizeof (struct font_data_list));
3531 list->driver = driver;
3532 list->next = f->font_data_list;
3533 f->font_data_list = list;
3535 list->data = data;
3536 return 0;
3540 void *
3541 font_get_frame_data (FRAME_PTR f, struct font_driver *driver)
3543 struct font_data_list *list;
3545 for (list = f->font_data_list; list; list = list->next)
3546 if (list->driver == driver)
3547 break;
3548 if (! list)
3549 return NULL;
3550 return list->data;
3554 /* Sets attributes on a font. Any properties that appear in ALIST and
3555 BOOLEAN_PROPERTIES or NON_BOOLEAN_PROPERTIES are set on the font.
3556 BOOLEAN_PROPERTIES and NON_BOOLEAN_PROPERTIES are NULL-terminated
3557 arrays of strings. This function is intended for use by the font
3558 drivers to implement their specific font_filter_properties. */
3559 void
3560 font_filter_properties (Lisp_Object font,
3561 Lisp_Object alist,
3562 const char *const boolean_properties[],
3563 const char *const non_boolean_properties[])
3565 Lisp_Object it;
3566 int i;
3568 /* Set boolean values to Qt or Qnil */
3569 for (i = 0; boolean_properties[i] != NULL; ++i)
3570 for (it = alist; ! NILP (it); it = XCDR (it))
3572 Lisp_Object key = XCAR (XCAR (it));
3573 Lisp_Object val = XCDR (XCAR (it));
3574 char *keystr = SSDATA (SYMBOL_NAME (key));
3576 if (strcmp (boolean_properties[i], keystr) == 0)
3578 const char *str = INTEGERP (val) ? (XINT (val) ? "true" : "false")
3579 : SYMBOLP (val) ? SSDATA (SYMBOL_NAME (val))
3580 : "true";
3582 if (strcmp ("false", str) == 0 || strcmp ("False", str) == 0
3583 || strcmp ("FALSE", str) == 0 || strcmp ("FcFalse", str) == 0
3584 || strcmp ("off", str) == 0 || strcmp ("OFF", str) == 0
3585 || strcmp ("Off", str) == 0)
3586 val = Qnil;
3587 else
3588 val = Qt;
3590 Ffont_put (font, key, val);
3594 for (i = 0; non_boolean_properties[i] != NULL; ++i)
3595 for (it = alist; ! NILP (it); it = XCDR (it))
3597 Lisp_Object key = XCAR (XCAR (it));
3598 Lisp_Object val = XCDR (XCAR (it));
3599 char *keystr = SSDATA (SYMBOL_NAME (key));
3600 if (strcmp (non_boolean_properties[i], keystr) == 0)
3601 Ffont_put (font, key, val);
3606 /* Return the font used to draw character C by FACE at buffer position
3607 POS in window W. If STRING is non-nil, it is a string containing C
3608 at index POS. If C is negative, get C from the current buffer or
3609 STRING. */
3611 static Lisp_Object
3612 font_at (int c, EMACS_INT pos, struct face *face, struct window *w,
3613 Lisp_Object string)
3615 FRAME_PTR f;
3616 int multibyte;
3617 Lisp_Object font_object;
3619 multibyte = (NILP (string)
3620 ? ! NILP (BVAR (current_buffer, enable_multibyte_characters))
3621 : STRING_MULTIBYTE (string));
3622 if (c < 0)
3624 if (NILP (string))
3626 if (multibyte)
3628 EMACS_INT pos_byte = CHAR_TO_BYTE (pos);
3630 c = FETCH_CHAR (pos_byte);
3632 else
3633 c = FETCH_BYTE (pos);
3635 else
3637 unsigned char *str;
3639 multibyte = STRING_MULTIBYTE (string);
3640 if (multibyte)
3642 EMACS_INT pos_byte = string_char_to_byte (string, pos);
3644 str = SDATA (string) + pos_byte;
3645 c = STRING_CHAR (str);
3647 else
3648 c = SDATA (string)[pos];
3652 f = XFRAME (w->frame);
3653 if (! FRAME_WINDOW_P (f))
3654 return Qnil;
3655 if (! face)
3657 int face_id;
3658 EMACS_INT endptr;
3660 if (STRINGP (string))
3661 face_id = face_at_string_position (w, string, pos, 0, -1, -1, &endptr,
3662 DEFAULT_FACE_ID, 0);
3663 else
3664 face_id = face_at_buffer_position (w, pos, -1, -1, &endptr,
3665 pos + 100, 0, -1);
3666 face = FACE_FROM_ID (f, face_id);
3668 if (multibyte)
3670 int face_id = FACE_FOR_CHAR (f, face, c, pos, string);
3671 face = FACE_FROM_ID (f, face_id);
3673 if (! face->font)
3674 return Qnil;
3676 XSETFONT (font_object, face->font);
3677 return font_object;
3681 #ifdef HAVE_WINDOW_SYSTEM
3683 /* Check how many characters after POS (at most to *LIMIT) can be
3684 displayed by the same font in the window W. FACE, if non-NULL, is
3685 the face selected for the character at POS. If STRING is not nil,
3686 it is the string to check instead of the current buffer. In that
3687 case, FACE must be not NULL.
3689 The return value is the font-object for the character at POS.
3690 *LIMIT is set to the position where that font can't be used.
3692 It is assured that the current buffer (or STRING) is multibyte. */
3694 Lisp_Object
3695 font_range (EMACS_INT pos, EMACS_INT *limit, struct window *w, struct face *face, Lisp_Object string)
3697 EMACS_INT pos_byte, ignore;
3698 int c;
3699 Lisp_Object font_object = Qnil;
3701 if (NILP (string))
3703 pos_byte = CHAR_TO_BYTE (pos);
3704 if (! face)
3706 int face_id;
3708 face_id = face_at_buffer_position (w, pos, 0, 0, &ignore,
3709 *limit, 0, -1);
3710 face = FACE_FROM_ID (XFRAME (w->frame), face_id);
3713 else
3715 font_assert (face);
3716 pos_byte = string_char_to_byte (string, pos);
3719 while (pos < *limit)
3721 Lisp_Object category;
3723 if (NILP (string))
3724 FETCH_CHAR_ADVANCE_NO_CHECK (c, pos, pos_byte);
3725 else
3726 FETCH_STRING_CHAR_ADVANCE_NO_CHECK (c, string, pos, pos_byte);
3727 category = CHAR_TABLE_REF (Vunicode_category_table, c);
3728 if (EQ (category, QCf)
3729 || CHAR_VARIATION_SELECTOR_P (c))
3730 continue;
3731 if (NILP (font_object))
3733 font_object = font_for_char (face, c, pos - 1, string);
3734 if (NILP (font_object))
3735 return Qnil;
3736 continue;
3738 if (font_encode_char (font_object, c) == FONT_INVALID_CODE)
3739 *limit = pos - 1;
3741 return font_object;
3743 #endif
3746 /* Lisp API */
3748 DEFUN ("fontp", Ffontp, Sfontp, 1, 2, 0,
3749 doc: /* Return t if OBJECT is a font-spec, font-entity, or font-object.
3750 Return nil otherwise.
3751 Optional 2nd argument EXTRA-TYPE, if non-nil, specifies to check
3752 which kind of font it is. It must be one of `font-spec', `font-entity',
3753 `font-object'. */)
3754 (Lisp_Object object, Lisp_Object extra_type)
3756 if (NILP (extra_type))
3757 return (FONTP (object) ? Qt : Qnil);
3758 if (EQ (extra_type, Qfont_spec))
3759 return (FONT_SPEC_P (object) ? Qt : Qnil);
3760 if (EQ (extra_type, Qfont_entity))
3761 return (FONT_ENTITY_P (object) ? Qt : Qnil);
3762 if (EQ (extra_type, Qfont_object))
3763 return (FONT_OBJECT_P (object) ? Qt : Qnil);
3764 wrong_type_argument (intern ("font-extra-type"), extra_type);
3767 DEFUN ("font-spec", Ffont_spec, Sfont_spec, 0, MANY, 0,
3768 doc: /* Return a newly created font-spec with arguments as properties.
3770 ARGS must come in pairs KEY VALUE of font properties. KEY must be a
3771 valid font property name listed below:
3773 `:family', `:weight', `:slant', `:width'
3775 They are the same as face attributes of the same name. See
3776 `set-face-attribute'.
3778 `:foundry'
3780 VALUE must be a string or a symbol specifying the font foundry, e.g. ``misc''.
3782 `:adstyle'
3784 VALUE must be a string or a symbol specifying the additional
3785 typographic style information of a font, e.g. ``sans''.
3787 `:registry'
3789 VALUE must be a string or a symbol specifying the charset registry and
3790 encoding of a font, e.g. ``iso8859-1''.
3792 `:size'
3794 VALUE must be a non-negative integer or a floating point number
3795 specifying the font size. It specifies the font size in pixels (if
3796 VALUE is an integer), or in points (if VALUE is a float).
3798 `:name'
3800 VALUE must be a string of XLFD-style or fontconfig-style font name.
3802 `:script'
3804 VALUE must be a symbol representing a script that the font must
3805 support. It may be a symbol representing a subgroup of a script
3806 listed in the variable `script-representative-chars'.
3808 `:lang'
3810 VALUE must be a symbol of two-letter ISO-639 language names,
3811 e.g. `ja'.
3813 `:otf'
3815 VALUE must be a list (SCRIPT-TAG LANGSYS-TAG GSUB [ GPOS ]) to specify
3816 required OpenType features.
3818 SCRIPT-TAG: OpenType script tag symbol (e.g. `deva').
3819 LANGSYS-TAG: OpenType language system tag symbol,
3820 or nil for the default language system.
3821 GSUB: List of OpenType GSUB feature tag symbols, or nil if none required.
3822 GPOS: List of OpenType GPOS feature tag symbols, or nil if none required.
3824 GSUB and GPOS may contain `nil' element. In such a case, the font
3825 must not have any of the remaining elements.
3827 For instance, if the VALUE is `(thai nil nil (mark))', the font must
3828 be an OpenType font whose GPOS table of `thai' script's default
3829 language system must contain `mark' feature.
3831 usage: (font-spec ARGS...) */)
3832 (size_t nargs, Lisp_Object *args)
3834 Lisp_Object spec = font_make_spec ();
3835 size_t i;
3837 for (i = 0; i < nargs; i += 2)
3839 Lisp_Object key = args[i], val;
3841 CHECK_SYMBOL (key);
3842 if (i + 1 >= nargs)
3843 error ("No value for key `%s'", SDATA (SYMBOL_NAME (key)));
3844 val = args[i + 1];
3846 if (EQ (key, QCname))
3848 CHECK_STRING (val);
3849 font_parse_name (SSDATA (val), spec);
3850 font_put_extra (spec, key, val);
3852 else
3854 int idx = get_font_prop_index (key);
3856 if (idx >= 0)
3858 val = font_prop_validate (idx, Qnil, val);
3859 if (idx < FONT_EXTRA_INDEX)
3860 ASET (spec, idx, val);
3861 else
3862 font_put_extra (spec, key, val);
3864 else
3865 font_put_extra (spec, key, font_prop_validate (0, key, val));
3868 return spec;
3871 /* Return a copy of FONT as a font-spec. */
3872 Lisp_Object
3873 copy_font_spec (Lisp_Object font)
3875 Lisp_Object new_spec, tail, prev, extra;
3876 int i;
3878 CHECK_FONT (font);
3879 new_spec = font_make_spec ();
3880 for (i = 1; i < FONT_EXTRA_INDEX; i++)
3881 ASET (new_spec, i, AREF (font, i));
3882 extra = Fcopy_alist (AREF (font, FONT_EXTRA_INDEX));
3883 /* We must remove :font-entity property. */
3884 for (prev = Qnil, tail = extra; CONSP (tail); prev = tail, tail = XCDR (tail))
3885 if (EQ (XCAR (XCAR (tail)), QCfont_entity))
3887 if (NILP (prev))
3888 extra = XCDR (extra);
3889 else
3890 XSETCDR (prev, XCDR (tail));
3891 break;
3893 ASET (new_spec, FONT_EXTRA_INDEX, extra);
3894 return new_spec;
3897 /* Merge font-specs FROM and TO, and return a new font-spec.
3898 Every specified property in FROM overrides the corresponding
3899 property in TO. */
3900 Lisp_Object
3901 merge_font_spec (Lisp_Object from, Lisp_Object to)
3903 Lisp_Object extra, tail;
3904 int i;
3906 CHECK_FONT (from);
3907 CHECK_FONT (to);
3908 to = copy_font_spec (to);
3909 for (i = 0; i < FONT_EXTRA_INDEX; i++)
3910 ASET (to, i, AREF (from, i));
3911 extra = AREF (to, FONT_EXTRA_INDEX);
3912 for (tail = AREF (from, FONT_EXTRA_INDEX); CONSP (tail); tail = XCDR (tail))
3913 if (! EQ (XCAR (XCAR (tail)), Qfont_entity))
3915 Lisp_Object slot = assq_no_quit (XCAR (XCAR (tail)), extra);
3917 if (! NILP (slot))
3918 XSETCDR (slot, XCDR (XCAR (tail)));
3919 else
3920 extra = Fcons (Fcons (XCAR (XCAR (tail)), XCDR (XCAR (tail))), extra);
3922 ASET (to, FONT_EXTRA_INDEX, extra);
3923 return to;
3926 DEFUN ("font-get", Ffont_get, Sfont_get, 2, 2, 0,
3927 doc: /* Return the value of FONT's property KEY.
3928 FONT is a font-spec, a font-entity, or a font-object.
3929 KEY is any symbol, but these are reserved for specific meanings:
3930 :family, :weight, :slant, :width, :foundry, :adstyle, :registry,
3931 :size, :name, :script, :otf
3932 See the documentation of `font-spec' for their meanings.
3933 In addition, if FONT is a font-entity or a font-object, values of
3934 :script and :otf are different from those of a font-spec as below:
3936 The value of :script may be a list of scripts that are supported by the font.
3938 The value of :otf is a cons (GSUB . GPOS) where GSUB and GPOS are lists
3939 representing the OpenType features supported by the font by this form:
3940 ((SCRIPT (LANGSYS FEATURE ...) ...) ...)
3941 SCRIPT, LANGSYS, and FEATURE are all symbols representing OpenType
3942 Layout tags. */)
3943 (Lisp_Object font, Lisp_Object key)
3945 int idx;
3946 Lisp_Object val;
3948 CHECK_FONT (font);
3949 CHECK_SYMBOL (key);
3951 idx = get_font_prop_index (key);
3952 if (idx >= FONT_WEIGHT_INDEX && idx <= FONT_WIDTH_INDEX)
3953 return font_style_symbolic (font, idx, 0);
3954 if (idx >= 0 && idx < FONT_EXTRA_INDEX)
3955 return AREF (font, idx);
3956 val = Fassq (key, AREF (font, FONT_EXTRA_INDEX));
3957 if (NILP (val) && EQ (key, QCotf) && FONT_OBJECT_P (font))
3959 struct font *fontp = XFONT_OBJECT (font);
3961 if (fontp->driver->otf_capability)
3962 val = fontp->driver->otf_capability (fontp);
3963 else
3964 val = Fcons (Qnil, Qnil);
3966 else
3967 val = Fcdr (val);
3968 return val;
3971 #ifdef HAVE_WINDOW_SYSTEM
3973 DEFUN ("font-face-attributes", Ffont_face_attributes, Sfont_face_attributes, 1, 2, 0,
3974 doc: /* Return a plist of face attributes generated by FONT.
3975 FONT is a font name, a font-spec, a font-entity, or a font-object.
3976 The return value is a list of the form
3978 \(:family FAMILY :height HEIGHT :weight WEIGHT :slant SLANT :width WIDTH)
3980 where FAMILY, HEIGHT, WEIGHT, SLANT, and WIDTH are face attribute values
3981 compatible with `set-face-attribute'. Some of these key-attribute pairs
3982 may be omitted from the list if they are not specified by FONT.
3984 The optional argument FRAME specifies the frame that the face attributes
3985 are to be displayed on. If omitted, the selected frame is used. */)
3986 (Lisp_Object font, Lisp_Object frame)
3988 struct frame *f;
3989 Lisp_Object plist[10];
3990 Lisp_Object val;
3991 int n = 0;
3993 if (NILP (frame))
3994 frame = selected_frame;
3995 CHECK_LIVE_FRAME (frame);
3996 f = XFRAME (frame);
3998 if (STRINGP (font))
4000 int fontset = fs_query_fontset (font, 0);
4001 Lisp_Object name = font;
4002 if (fontset >= 0)
4003 font = fontset_ascii (fontset);
4004 font = font_spec_from_name (name);
4005 if (! FONTP (font))
4006 signal_error ("Invalid font name", name);
4008 else if (! FONTP (font))
4009 signal_error ("Invalid font object", font);
4011 val = AREF (font, FONT_FAMILY_INDEX);
4012 if (! NILP (val))
4014 plist[n++] = QCfamily;
4015 plist[n++] = SYMBOL_NAME (val);
4018 val = AREF (font, FONT_SIZE_INDEX);
4019 if (INTEGERP (val))
4021 Lisp_Object font_dpi = AREF (font, FONT_DPI_INDEX);
4022 int dpi = INTEGERP (font_dpi) ? XINT (font_dpi) : f->resy;
4023 plist[n++] = QCheight;
4024 plist[n++] = make_number (PIXEL_TO_POINT (XINT (val) * 10, dpi));
4026 else if (FLOATP (val))
4028 plist[n++] = QCheight;
4029 plist[n++] = make_number (10 * (int) XFLOAT_DATA (val));
4032 val = FONT_WEIGHT_FOR_FACE (font);
4033 if (! NILP (val))
4035 plist[n++] = QCweight;
4036 plist[n++] = val;
4039 val = FONT_SLANT_FOR_FACE (font);
4040 if (! NILP (val))
4042 plist[n++] = QCslant;
4043 plist[n++] = val;
4046 val = FONT_WIDTH_FOR_FACE (font);
4047 if (! NILP (val))
4049 plist[n++] = QCwidth;
4050 plist[n++] = val;
4053 return Flist (n, plist);
4056 #endif
4058 DEFUN ("font-put", Ffont_put, Sfont_put, 3, 3, 0,
4059 doc: /* Set one property of FONT: give property KEY value VAL.
4060 FONT is a font-spec, a font-entity, or a font-object.
4062 If FONT is a font-spec, KEY can be any symbol. But if KEY is the one
4063 accepted by the function `font-spec' (which see), VAL must be what
4064 allowed in `font-spec'.
4066 If FONT is a font-entity or a font-object, KEY must not be the one
4067 accepted by `font-spec'. */)
4068 (Lisp_Object font, Lisp_Object prop, Lisp_Object val)
4070 int idx;
4072 idx = get_font_prop_index (prop);
4073 if (idx >= 0 && idx < FONT_EXTRA_INDEX)
4075 CHECK_FONT_SPEC (font);
4076 ASET (font, idx, font_prop_validate (idx, Qnil, val));
4078 else
4080 if (EQ (prop, QCname)
4081 || EQ (prop, QCscript)
4082 || EQ (prop, QClang)
4083 || EQ (prop, QCotf))
4084 CHECK_FONT_SPEC (font);
4085 else
4086 CHECK_FONT (font);
4087 font_put_extra (font, prop, font_prop_validate (0, prop, val));
4089 return val;
4092 DEFUN ("list-fonts", Flist_fonts, Slist_fonts, 1, 4, 0,
4093 doc: /* List available fonts matching FONT-SPEC on the current frame.
4094 Optional 2nd argument FRAME specifies the target frame.
4095 Optional 3rd argument NUM, if non-nil, limits the number of returned fonts.
4096 Optional 4th argument PREFER, if non-nil, is a font-spec to
4097 control the order of the returned list. Fonts are sorted by
4098 how close they are to PREFER. */)
4099 (Lisp_Object font_spec, Lisp_Object frame, Lisp_Object num, Lisp_Object prefer)
4101 Lisp_Object vec, list;
4102 int n = 0;
4104 if (NILP (frame))
4105 frame = selected_frame;
4106 CHECK_LIVE_FRAME (frame);
4107 CHECK_FONT_SPEC (font_spec);
4108 if (! NILP (num))
4110 CHECK_NUMBER (num);
4111 n = XINT (num);
4112 if (n <= 0)
4113 return Qnil;
4115 if (! NILP (prefer))
4116 CHECK_FONT_SPEC (prefer);
4118 list = font_list_entities (frame, font_spec);
4119 if (NILP (list))
4120 return Qnil;
4121 if (NILP (XCDR (list))
4122 && ASIZE (XCAR (list)) == 1)
4123 return Fcons (AREF (XCAR (list), 0), Qnil);
4125 if (! NILP (prefer))
4126 vec = font_sort_entities (list, prefer, frame, 0);
4127 else
4128 vec = font_vconcat_entity_vectors (list);
4129 if (n == 0 || n >= ASIZE (vec))
4131 Lisp_Object args[2];
4133 args[0] = vec;
4134 args[1] = Qnil;
4135 list = Fappend (2, args);
4137 else
4139 for (list = Qnil, n--; n >= 0; n--)
4140 list = Fcons (AREF (vec, n), list);
4142 return list;
4145 DEFUN ("font-family-list", Ffont_family_list, Sfont_family_list, 0, 1, 0,
4146 doc: /* List available font families on the current frame.
4147 Optional argument FRAME, if non-nil, specifies the target frame. */)
4148 (Lisp_Object frame)
4150 FRAME_PTR f;
4151 struct font_driver_list *driver_list;
4152 Lisp_Object list;
4154 if (NILP (frame))
4155 frame = selected_frame;
4156 CHECK_LIVE_FRAME (frame);
4157 f = XFRAME (frame);
4158 list = Qnil;
4159 for (driver_list = f->font_driver_list; driver_list;
4160 driver_list = driver_list->next)
4161 if (driver_list->driver->list_family)
4163 Lisp_Object val = driver_list->driver->list_family (frame);
4164 Lisp_Object tail = list;
4166 for (; CONSP (val); val = XCDR (val))
4167 if (NILP (Fmemq (XCAR (val), tail))
4168 && SYMBOLP (XCAR (val)))
4169 list = Fcons (SYMBOL_NAME (XCAR (val)), list);
4171 return list;
4174 DEFUN ("find-font", Ffind_font, Sfind_font, 1, 2, 0,
4175 doc: /* Return a font-entity matching with FONT-SPEC on the current frame.
4176 Optional 2nd argument FRAME, if non-nil, specifies the target frame. */)
4177 (Lisp_Object font_spec, Lisp_Object frame)
4179 Lisp_Object val = Flist_fonts (font_spec, frame, make_number (1), Qnil);
4181 if (CONSP (val))
4182 val = XCAR (val);
4183 return val;
4186 DEFUN ("font-xlfd-name", Ffont_xlfd_name, Sfont_xlfd_name, 1, 2, 0,
4187 doc: /* Return XLFD name of FONT.
4188 FONT is a font-spec, font-entity, or font-object.
4189 If the name is too long for XLFD (maximum 255 chars), return nil.
4190 If the 2nd optional arg FOLD-WILDCARDS is non-nil,
4191 the consecutive wildcards are folded into one. */)
4192 (Lisp_Object font, Lisp_Object fold_wildcards)
4194 char name[256];
4195 int pixel_size = 0;
4197 CHECK_FONT (font);
4199 if (FONT_OBJECT_P (font))
4201 Lisp_Object font_name = AREF (font, FONT_NAME_INDEX);
4203 if (STRINGP (font_name)
4204 && SDATA (font_name)[0] == '-')
4206 if (NILP (fold_wildcards))
4207 return font_name;
4208 strcpy (name, SSDATA (font_name));
4209 goto done;
4211 pixel_size = XFONT_OBJECT (font)->pixel_size;
4213 if (font_unparse_xlfd (font, pixel_size, name, 256) < 0)
4214 return Qnil;
4215 done:
4216 if (! NILP (fold_wildcards))
4218 char *p0 = name, *p1;
4220 while ((p1 = strstr (p0, "-*-*")))
4222 strcpy (p1, p1 + 2);
4223 p0 = p1;
4227 return build_string (name);
4230 DEFUN ("clear-font-cache", Fclear_font_cache, Sclear_font_cache, 0, 0, 0,
4231 doc: /* Clear font cache. */)
4232 (void)
4234 Lisp_Object list, frame;
4236 FOR_EACH_FRAME (list, frame)
4238 FRAME_PTR f = XFRAME (frame);
4239 struct font_driver_list *driver_list = f->font_driver_list;
4241 for (; driver_list; driver_list = driver_list->next)
4242 if (driver_list->on)
4244 Lisp_Object cache = driver_list->driver->get_cache (f);
4245 Lisp_Object val, tmp;
4247 val = XCDR (cache);
4248 while (! NILP (val)
4249 && ! EQ (XCAR (XCAR (val)), driver_list->driver->type))
4250 val = XCDR (val);
4251 font_assert (! NILP (val));
4252 tmp = XCDR (XCAR (val));
4253 if (XINT (XCAR (tmp)) == 0)
4255 font_clear_cache (f, XCAR (val), driver_list->driver);
4256 XSETCDR (cache, XCDR (val));
4261 return Qnil;
4265 void
4266 font_fill_lglyph_metrics (Lisp_Object glyph, Lisp_Object font_object)
4268 struct font *font = XFONT_OBJECT (font_object);
4269 unsigned code;
4270 /* ecode used in LGLYPH_SET_CODE to avoid compiler warnings. */
4271 EMACS_INT ecode = font->driver->encode_char (font, LGLYPH_CHAR (glyph));
4272 struct font_metrics metrics;
4274 LGLYPH_SET_CODE (glyph, ecode);
4275 code = ecode;
4276 font->driver->text_extents (font, &code, 1, &metrics);
4277 LGLYPH_SET_LBEARING (glyph, metrics.lbearing);
4278 LGLYPH_SET_RBEARING (glyph, metrics.rbearing);
4279 LGLYPH_SET_WIDTH (glyph, metrics.width);
4280 LGLYPH_SET_ASCENT (glyph, metrics.ascent);
4281 LGLYPH_SET_DESCENT (glyph, metrics.descent);
4285 DEFUN ("font-shape-gstring", Ffont_shape_gstring, Sfont_shape_gstring, 1, 1, 0,
4286 doc: /* Shape the glyph-string GSTRING.
4287 Shaping means substituting glyphs and/or adjusting positions of glyphs
4288 to get the correct visual image of character sequences set in the
4289 header of the glyph-string.
4291 If the shaping was successful, the value is GSTRING itself or a newly
4292 created glyph-string. Otherwise, the value is nil. */)
4293 (Lisp_Object gstring)
4295 struct font *font;
4296 Lisp_Object font_object, n, glyph;
4297 int i, j, from, to;
4299 if (! composition_gstring_p (gstring))
4300 signal_error ("Invalid glyph-string: ", gstring);
4301 if (! NILP (LGSTRING_ID (gstring)))
4302 return gstring;
4303 font_object = LGSTRING_FONT (gstring);
4304 CHECK_FONT_OBJECT (font_object);
4305 font = XFONT_OBJECT (font_object);
4306 if (! font->driver->shape)
4307 return Qnil;
4309 /* Try at most three times with larger gstring each time. */
4310 for (i = 0; i < 3; i++)
4312 n = font->driver->shape (gstring);
4313 if (INTEGERP (n))
4314 break;
4315 gstring = larger_vector (gstring,
4316 ASIZE (gstring) + LGSTRING_GLYPH_LEN (gstring),
4317 Qnil);
4319 if (i == 3 || XINT (n) == 0)
4320 return Qnil;
4321 if (XINT (n) < LGSTRING_GLYPH_LEN (gstring))
4322 LGSTRING_SET_GLYPH (gstring, XINT (n), Qnil);
4324 glyph = LGSTRING_GLYPH (gstring, 0);
4325 from = LGLYPH_FROM (glyph);
4326 to = LGLYPH_TO (glyph);
4327 for (i = 1, j = 0; i < LGSTRING_GLYPH_LEN (gstring); i++)
4329 Lisp_Object this = LGSTRING_GLYPH (gstring, i);
4331 if (NILP (this))
4332 break;
4333 if (NILP (LGLYPH_ADJUSTMENT (this)))
4335 if (j < i - 1)
4336 for (; j < i; j++)
4338 glyph = LGSTRING_GLYPH (gstring, j);
4339 LGLYPH_SET_FROM (glyph, from);
4340 LGLYPH_SET_TO (glyph, to);
4342 from = LGLYPH_FROM (this);
4343 to = LGLYPH_TO (this);
4344 j = i;
4346 else
4348 if (from > LGLYPH_FROM (this))
4349 from = LGLYPH_FROM (this);
4350 if (to < LGLYPH_TO (this))
4351 to = LGLYPH_TO (this);
4354 if (j < i - 1)
4355 for (; j < i; j++)
4357 glyph = LGSTRING_GLYPH (gstring, j);
4358 LGLYPH_SET_FROM (glyph, from);
4359 LGLYPH_SET_TO (glyph, to);
4361 return composition_gstring_put_cache (gstring, XINT (n));
4364 DEFUN ("font-variation-glyphs", Ffont_variation_glyphs, Sfont_variation_glyphs,
4365 2, 2, 0,
4366 doc: /* Return a list of variation glyphs for CHAR in FONT-OBJECT.
4367 Each element of the value is a cons (VARIATION-SELECTOR . GLYPH-ID),
4368 where
4369 VARIATION-SELECTOR is a character code of variation selection
4370 (#xFE00..#xFE0F or #xE0100..#xE01EF)
4371 GLYPH-ID is a glyph code of the corresponding variation glyph. */)
4372 (Lisp_Object font_object, Lisp_Object character)
4374 unsigned variations[256];
4375 struct font *font;
4376 int i, n;
4377 Lisp_Object val;
4379 CHECK_FONT_OBJECT (font_object);
4380 CHECK_CHARACTER (character);
4381 font = XFONT_OBJECT (font_object);
4382 if (! font->driver->get_variation_glyphs)
4383 return Qnil;
4384 n = font->driver->get_variation_glyphs (font, XINT (character), variations);
4385 if (! n)
4386 return Qnil;
4387 val = Qnil;
4388 for (i = 0; i < 255; i++)
4389 if (variations[i])
4391 Lisp_Object code;
4392 int vs = (i < 16 ? 0xFE00 + i : 0xE0100 + (i - 16));
4393 /* Stops GCC whining about limited range of data type. */
4394 EMACS_INT var = variations[i];
4396 if (var > MOST_POSITIVE_FIXNUM)
4397 code = Fcons (make_number ((variations[i]) >> 16),
4398 make_number ((variations[i]) & 0xFFFF));
4399 else
4400 code = make_number (variations[i]);
4401 val = Fcons (Fcons (make_number (vs), code), val);
4403 return val;
4406 #if 0
4408 DEFUN ("font-drive-otf", Ffont_drive_otf, Sfont_drive_otf, 6, 6, 0,
4409 doc: /* Apply OpenType features on glyph-string GSTRING-IN.
4410 OTF-FEATURES specifies which features to apply in this format:
4411 (SCRIPT LANGSYS GSUB GPOS)
4412 where
4413 SCRIPT is a symbol specifying a script tag of OpenType,
4414 LANGSYS is a symbol specifying a langsys tag of OpenType,
4415 GSUB and GPOS, if non-nil, are lists of symbols specifying feature tags.
4417 If LANGYS is nil, the default langsys is selected.
4419 The features are applied in the order they appear in the list. The
4420 symbol `*' means to apply all available features not present in this
4421 list, and the remaining features are ignored. For instance, (vatu
4422 pstf * haln) is to apply vatu and pstf in this order, then to apply
4423 all available features other than vatu, pstf, and haln.
4425 The features are applied to the glyphs in the range FROM and TO of
4426 the glyph-string GSTRING-IN.
4428 If some feature is actually applicable, the resulting glyphs are
4429 produced in the glyph-string GSTRING-OUT from the index INDEX. In
4430 this case, the value is the number of produced glyphs.
4432 If no feature is applicable, no glyph is produced in GSTRING-OUT, and
4433 the value is 0.
4435 If GSTRING-OUT is too short to hold produced glyphs, no glyphs are
4436 produced in GSTRING-OUT, and the value is nil.
4438 See the documentation of `composition-get-gstring' for the format of
4439 glyph-string. */)
4440 (Lisp_Object otf_features, Lisp_Object gstring_in, Lisp_Object from, Lisp_Object to, Lisp_Object gstring_out, Lisp_Object index)
4442 Lisp_Object font_object = LGSTRING_FONT (gstring_in);
4443 Lisp_Object val;
4444 struct font *font;
4445 int len, num;
4447 check_otf_features (otf_features);
4448 CHECK_FONT_OBJECT (font_object);
4449 font = XFONT_OBJECT (font_object);
4450 if (! font->driver->otf_drive)
4451 error ("Font backend %s can't drive OpenType GSUB table",
4452 SDATA (SYMBOL_NAME (font->driver->type)));
4453 CHECK_CONS (otf_features);
4454 CHECK_SYMBOL (XCAR (otf_features));
4455 val = XCDR (otf_features);
4456 CHECK_SYMBOL (XCAR (val));
4457 val = XCDR (otf_features);
4458 if (! NILP (val))
4459 CHECK_CONS (val);
4460 len = check_gstring (gstring_in);
4461 CHECK_VECTOR (gstring_out);
4462 CHECK_NATNUM (from);
4463 CHECK_NATNUM (to);
4464 CHECK_NATNUM (index);
4466 if (XINT (from) >= XINT (to) || XINT (to) > len)
4467 args_out_of_range_3 (from, to, make_number (len));
4468 if (XINT (index) >= ASIZE (gstring_out))
4469 args_out_of_range (index, make_number (ASIZE (gstring_out)));
4470 num = font->driver->otf_drive (font, otf_features,
4471 gstring_in, XINT (from), XINT (to),
4472 gstring_out, XINT (index), 0);
4473 if (num < 0)
4474 return Qnil;
4475 return make_number (num);
4478 DEFUN ("font-otf-alternates", Ffont_otf_alternates, Sfont_otf_alternates,
4479 3, 3, 0,
4480 doc: /* Return a list of alternate glyphs of CHARACTER in FONT-OBJECT.
4481 OTF-FEATURES specifies which features of the font FONT-OBJECT to apply
4482 in this format:
4483 (SCRIPT LANGSYS FEATURE ...)
4484 See the documentation of `font-drive-otf' for more detail.
4486 The value is a list of cons cells of the format (GLYPH-ID . CHARACTER),
4487 where GLYPH-ID is a glyph index of the font, and CHARACTER is a
4488 character code corresponding to the glyph or nil if there's no
4489 corresponding character. */)
4490 (Lisp_Object font_object, Lisp_Object character, Lisp_Object otf_features)
4492 struct font *font;
4493 Lisp_Object gstring_in, gstring_out, g;
4494 Lisp_Object alternates;
4495 int i, num;
4497 CHECK_FONT_GET_OBJECT (font_object, font);
4498 if (! font->driver->otf_drive)
4499 error ("Font backend %s can't drive OpenType GSUB table",
4500 SDATA (SYMBOL_NAME (font->driver->type)));
4501 CHECK_CHARACTER (character);
4502 CHECK_CONS (otf_features);
4504 gstring_in = Ffont_make_gstring (font_object, make_number (1));
4505 g = LGSTRING_GLYPH (gstring_in, 0);
4506 LGLYPH_SET_CHAR (g, XINT (character));
4507 gstring_out = Ffont_make_gstring (font_object, make_number (10));
4508 while ((num = font->driver->otf_drive (font, otf_features, gstring_in, 0, 1,
4509 gstring_out, 0, 1)) < 0)
4510 gstring_out = Ffont_make_gstring (font_object,
4511 make_number (ASIZE (gstring_out) * 2));
4512 alternates = Qnil;
4513 for (i = 0; i < num; i++)
4515 Lisp_Object g = LGSTRING_GLYPH (gstring_out, i);
4516 int c = LGLYPH_CHAR (g);
4517 unsigned code = LGLYPH_CODE (g);
4519 alternates = Fcons (Fcons (make_number (code),
4520 c > 0 ? make_number (c) : Qnil),
4521 alternates);
4523 return Fnreverse (alternates);
4525 #endif /* 0 */
4527 #ifdef FONT_DEBUG
4529 DEFUN ("open-font", Fopen_font, Sopen_font, 1, 3, 0,
4530 doc: /* Open FONT-ENTITY. */)
4531 (Lisp_Object font_entity, Lisp_Object size, Lisp_Object frame)
4533 int isize;
4535 CHECK_FONT_ENTITY (font_entity);
4536 if (NILP (frame))
4537 frame = selected_frame;
4538 CHECK_LIVE_FRAME (frame);
4540 if (NILP (size))
4541 isize = XINT (AREF (font_entity, FONT_SIZE_INDEX));
4542 else
4544 CHECK_NUMBER_OR_FLOAT (size);
4545 if (FLOATP (size))
4546 isize = POINT_TO_PIXEL (XFLOAT_DATA (size), XFRAME (frame)->resy);
4547 else
4548 isize = XINT (size);
4549 if (isize == 0)
4550 isize = 120;
4552 return font_open_entity (XFRAME (frame), font_entity, isize);
4555 DEFUN ("close-font", Fclose_font, Sclose_font, 1, 2, 0,
4556 doc: /* Close FONT-OBJECT. */)
4557 (Lisp_Object font_object, Lisp_Object frame)
4559 CHECK_FONT_OBJECT (font_object);
4560 if (NILP (frame))
4561 frame = selected_frame;
4562 CHECK_LIVE_FRAME (frame);
4563 font_close_object (XFRAME (frame), font_object);
4564 return Qnil;
4567 DEFUN ("query-font", Fquery_font, Squery_font, 1, 1, 0,
4568 doc: /* Return information about FONT-OBJECT.
4569 The value is a vector:
4570 [ NAME FILENAME PIXEL-SIZE SIZE ASCENT DESCENT SPACE-WIDTH AVERAGE-WIDTH
4571 CAPABILITY ]
4573 NAME is the font name, a string (or nil if the font backend doesn't
4574 provide a name).
4576 FILENAME is the font file name, a string (or nil if the font backend
4577 doesn't provide a file name).
4579 PIXEL-SIZE is a pixel size by which the font is opened.
4581 SIZE is a maximum advance width of the font in pixels.
4583 ASCENT, DESCENT, SPACE-WIDTH, AVERAGE-WIDTH are metrics of the font in
4584 pixels.
4586 CAPABILITY is a list whose first element is a symbol representing the
4587 font format \(x, opentype, truetype, type1, pcf, or bdf) and the
4588 remaining elements describe the details of the font capability.
4590 If the font is OpenType font, the form of the list is
4591 \(opentype GSUB GPOS)
4592 where GSUB shows which "GSUB" features the font supports, and GPOS
4593 shows which "GPOS" features the font supports. Both GSUB and GPOS are
4594 lists of the format:
4595 \((SCRIPT (LANGSYS FEATURE ...) ...) ...)
4597 If the font is not OpenType font, currently the length of the form is
4598 one.
4600 SCRIPT is a symbol representing OpenType script tag.
4602 LANGSYS is a symbol representing OpenType langsys tag, or nil
4603 representing the default langsys.
4605 FEATURE is a symbol representing OpenType feature tag.
4607 If the font is not OpenType font, CAPABILITY is nil. */)
4608 (Lisp_Object font_object)
4610 struct font *font;
4611 Lisp_Object val;
4613 CHECK_FONT_GET_OBJECT (font_object, font);
4615 val = Fmake_vector (make_number (9), Qnil);
4616 ASET (val, 0, AREF (font_object, FONT_NAME_INDEX));
4617 ASET (val, 1, AREF (font_object, FONT_FILE_INDEX));
4618 ASET (val, 2, make_number (font->pixel_size));
4619 ASET (val, 3, make_number (font->max_width));
4620 ASET (val, 4, make_number (font->ascent));
4621 ASET (val, 5, make_number (font->descent));
4622 ASET (val, 6, make_number (font->space_width));
4623 ASET (val, 7, make_number (font->average_width));
4624 if (font->driver->otf_capability)
4625 ASET (val, 8, Fcons (Qopentype, font->driver->otf_capability (font)));
4626 return val;
4629 DEFUN ("font-get-glyphs", Ffont_get_glyphs, Sfont_get_glyphs, 3, 4, 0,
4630 doc:
4631 /* Return a vector of FONT-OBJECT's glyphs for the specified characters.
4632 FROM and TO are positions (integers or markers) specifying a region
4633 of the current buffer.
4634 If the optional fourth arg OBJECT is not nil, it is a string or a
4635 vector containing the target characters.
4637 Each element is a vector containing information of a glyph in this format:
4638 [FROM-IDX TO-IDX C CODE WIDTH LBEARING RBEARING ASCENT DESCENT ADJUSTMENT]
4639 where
4640 FROM is an index numbers of a character the glyph corresponds to.
4641 TO is the same as FROM.
4642 C is the character of the glyph.
4643 CODE is the glyph-code of C in FONT-OBJECT.
4644 WIDTH thru DESCENT are the metrics (in pixels) of the glyph.
4645 ADJUSTMENT is always nil.
4646 If FONT-OBJECT doesn't have a glyph for a character,
4647 the corresponding element is nil. */)
4648 (Lisp_Object font_object, Lisp_Object from, Lisp_Object to,
4649 Lisp_Object object)
4651 struct font *font;
4652 int i, len;
4653 Lisp_Object *chars, vec;
4654 USE_SAFE_ALLOCA;
4656 CHECK_FONT_GET_OBJECT (font_object, font);
4657 if (NILP (object))
4659 EMACS_INT charpos, bytepos;
4661 validate_region (&from, &to);
4662 if (EQ (from, to))
4663 return Qnil;
4664 len = XFASTINT (to) - XFASTINT (from);
4665 SAFE_ALLOCA_LISP (chars, len);
4666 charpos = XFASTINT (from);
4667 bytepos = CHAR_TO_BYTE (charpos);
4668 for (i = 0; charpos < XFASTINT (to); i++)
4670 int c;
4671 FETCH_CHAR_ADVANCE (c, charpos, bytepos);
4672 chars[i] = make_number (c);
4675 else if (STRINGP (object))
4677 const unsigned char *p;
4679 CHECK_NUMBER (from);
4680 CHECK_NUMBER (to);
4681 if (XINT (from) < 0 || XINT (from) > XINT (to)
4682 || XINT (to) > SCHARS (object))
4683 args_out_of_range_3 (object, from, to);
4684 if (EQ (from, to))
4685 return Qnil;
4686 len = XFASTINT (to) - XFASTINT (from);
4687 SAFE_ALLOCA_LISP (chars, len);
4688 p = SDATA (object);
4689 if (STRING_MULTIBYTE (object))
4690 for (i = 0; i < len; i++)
4692 int c = STRING_CHAR_ADVANCE (p);
4693 chars[i] = make_number (c);
4695 else
4696 for (i = 0; i < len; i++)
4697 chars[i] = make_number (p[i]);
4699 else
4701 CHECK_VECTOR (object);
4702 CHECK_NUMBER (from);
4703 CHECK_NUMBER (to);
4704 if (XINT (from) < 0 || XINT (from) > XINT (to)
4705 || XINT (to) > ASIZE (object))
4706 args_out_of_range_3 (object, from, to);
4707 if (EQ (from, to))
4708 return Qnil;
4709 len = XFASTINT (to) - XFASTINT (from);
4710 for (i = 0; i < len; i++)
4712 Lisp_Object elt = AREF (object, XFASTINT (from) + i);
4713 CHECK_CHARACTER (elt);
4715 chars = &(AREF (object, XFASTINT (from)));
4718 vec = Fmake_vector (make_number (len), Qnil);
4719 for (i = 0; i < len; i++)
4721 Lisp_Object g;
4722 int c = XFASTINT (chars[i]);
4723 unsigned code;
4724 struct font_metrics metrics;
4726 code = font->driver->encode_char (font, c);
4727 if (code == FONT_INVALID_CODE)
4728 continue;
4729 g = Fmake_vector (make_number (LGLYPH_SIZE), Qnil);
4730 LGLYPH_SET_FROM (g, i);
4731 LGLYPH_SET_TO (g, i);
4732 LGLYPH_SET_CHAR (g, c);
4733 LGLYPH_SET_CODE (g, code);
4734 font->driver->text_extents (font, &code, 1, &metrics);
4735 LGLYPH_SET_WIDTH (g, metrics.width);
4736 LGLYPH_SET_LBEARING (g, metrics.lbearing);
4737 LGLYPH_SET_RBEARING (g, metrics.rbearing);
4738 LGLYPH_SET_ASCENT (g, metrics.ascent);
4739 LGLYPH_SET_DESCENT (g, metrics.descent);
4740 ASET (vec, i, g);
4742 if (! VECTORP (object))
4743 SAFE_FREE ();
4744 return vec;
4747 DEFUN ("font-match-p", Ffont_match_p, Sfont_match_p, 2, 2, 0,
4748 doc: /* Return t if and only if font-spec SPEC matches with FONT.
4749 FONT is a font-spec, font-entity, or font-object. */)
4750 (Lisp_Object spec, Lisp_Object font)
4752 CHECK_FONT_SPEC (spec);
4753 CHECK_FONT (font);
4755 return (font_match_p (spec, font) ? Qt : Qnil);
4758 DEFUN ("font-at", Ffont_at, Sfont_at, 1, 3, 0,
4759 doc: /* Return a font-object for displaying a character at POSITION.
4760 Optional second arg WINDOW, if non-nil, is a window displaying
4761 the current buffer. It defaults to the currently selected window. */)
4762 (Lisp_Object position, Lisp_Object window, Lisp_Object string)
4764 struct window *w;
4765 EMACS_INT pos;
4767 if (NILP (string))
4769 CHECK_NUMBER_COERCE_MARKER (position);
4770 pos = XINT (position);
4771 if (pos < BEGV || pos >= ZV)
4772 args_out_of_range_3 (position, make_number (BEGV), make_number (ZV));
4774 else
4776 CHECK_NUMBER (position);
4777 CHECK_STRING (string);
4778 pos = XINT (position);
4779 if (pos < 0 || pos >= SCHARS (string))
4780 args_out_of_range (string, position);
4782 if (NILP (window))
4783 window = selected_window;
4784 CHECK_LIVE_WINDOW (window);
4785 w = XWINDOW (window);
4787 return font_at (-1, pos, NULL, w, string);
4790 #if 0
4791 DEFUN ("draw-string", Fdraw_string, Sdraw_string, 2, 2, 0,
4792 doc: /* Draw STRING by FONT-OBJECT on the top left corner of the current frame.
4793 The value is a number of glyphs drawn.
4794 Type C-l to recover what previously shown. */)
4795 (Lisp_Object font_object, Lisp_Object string)
4797 Lisp_Object frame = selected_frame;
4798 FRAME_PTR f = XFRAME (frame);
4799 struct font *font;
4800 struct face *face;
4801 int i, len, width;
4802 unsigned *code;
4804 CHECK_FONT_GET_OBJECT (font_object, font);
4805 CHECK_STRING (string);
4806 len = SCHARS (string);
4807 code = alloca (sizeof (unsigned) * len);
4808 for (i = 0; i < len; i++)
4810 Lisp_Object ch = Faref (string, make_number (i));
4811 Lisp_Object val;
4812 int c = XINT (ch);
4814 code[i] = font->driver->encode_char (font, c);
4815 if (code[i] == FONT_INVALID_CODE)
4816 break;
4818 face = FACE_FROM_ID (f, DEFAULT_FACE_ID);
4819 face->fontp = font;
4820 if (font->driver->prepare_face)
4821 font->driver->prepare_face (f, face);
4822 width = font->driver->text_extents (font, code, i, NULL);
4823 len = font->driver->draw_text (f, face, 0, font->ascent, code, i, width);
4824 if (font->driver->done_face)
4825 font->driver->done_face (f, face);
4826 face->fontp = NULL;
4827 return make_number (len);
4829 #endif
4831 #endif /* FONT_DEBUG */
4833 #ifdef HAVE_WINDOW_SYSTEM
4835 DEFUN ("font-info", Ffont_info, Sfont_info, 1, 2, 0,
4836 doc: /* Return information about a font named NAME on frame FRAME.
4837 If FRAME is omitted or nil, use the selected frame.
4838 The returned value is a vector of OPENED-NAME, FULL-NAME, SIZE,
4839 HEIGHT, BASELINE-OFFSET, RELATIVE-COMPOSE, and DEFAULT-ASCENT,
4840 where
4841 OPENED-NAME is the name used for opening the font,
4842 FULL-NAME is the full name of the font,
4843 SIZE is the pixelsize of the font,
4844 HEIGHT is the pixel-height of the font (i.e ascent + descent),
4845 BASELINE-OFFSET is the upward offset pixels from ASCII baseline,
4846 RELATIVE-COMPOSE and DEFAULT-ASCENT are the numbers controlling
4847 how to compose characters.
4848 If the named font is not yet loaded, return nil. */)
4849 (Lisp_Object name, Lisp_Object frame)
4851 FRAME_PTR f;
4852 struct font *font;
4853 Lisp_Object info;
4854 Lisp_Object font_object;
4856 (*check_window_system_func) ();
4858 if (! FONTP (name))
4859 CHECK_STRING (name);
4860 if (NILP (frame))
4861 frame = selected_frame;
4862 CHECK_LIVE_FRAME (frame);
4863 f = XFRAME (frame);
4865 if (STRINGP (name))
4867 int fontset = fs_query_fontset (name, 0);
4869 if (fontset >= 0)
4870 name = fontset_ascii (fontset);
4871 font_object = font_open_by_name (f, SSDATA (name));
4873 else if (FONT_OBJECT_P (name))
4874 font_object = name;
4875 else if (FONT_ENTITY_P (name))
4876 font_object = font_open_entity (f, name, 0);
4877 else
4879 struct face *face = FACE_FROM_ID (f, DEFAULT_FACE_ID);
4880 Lisp_Object entity = font_matching_entity (f, face->lface, name);
4882 font_object = ! NILP (entity) ? font_open_entity (f, entity, 0) : Qnil;
4884 if (NILP (font_object))
4885 return Qnil;
4886 font = XFONT_OBJECT (font_object);
4888 info = Fmake_vector (make_number (7), Qnil);
4889 XVECTOR (info)->contents[0] = AREF (font_object, FONT_NAME_INDEX);
4890 XVECTOR (info)->contents[1] = AREF (font_object, FONT_FULLNAME_INDEX);
4891 XVECTOR (info)->contents[2] = make_number (font->pixel_size);
4892 XVECTOR (info)->contents[3] = make_number (font->height);
4893 XVECTOR (info)->contents[4] = make_number (font->baseline_offset);
4894 XVECTOR (info)->contents[5] = make_number (font->relative_compose);
4895 XVECTOR (info)->contents[6] = make_number (font->default_ascent);
4897 #if 0
4898 /* As font_object is still in FONT_OBJLIST of the entity, we can't
4899 close it now. Perhaps, we should manage font-objects
4900 by `reference-count'. */
4901 font_close_object (f, font_object);
4902 #endif
4903 return info;
4905 #endif
4908 #define BUILD_STYLE_TABLE(TBL) \
4909 build_style_table ((TBL), sizeof TBL / sizeof (struct table_entry))
4911 static Lisp_Object
4912 build_style_table (const struct table_entry *entry, int nelement)
4914 int i, j;
4915 Lisp_Object table, elt;
4917 table = Fmake_vector (make_number (nelement), Qnil);
4918 for (i = 0; i < nelement; i++)
4920 for (j = 0; entry[i].names[j]; j++);
4921 elt = Fmake_vector (make_number (j + 1), Qnil);
4922 ASET (elt, 0, make_number (entry[i].numeric));
4923 for (j = 0; entry[i].names[j]; j++)
4924 ASET (elt, j + 1, intern_c_string (entry[i].names[j]));
4925 ASET (table, i, elt);
4927 return table;
4930 /* The deferred font-log data of the form [ACTION ARG RESULT].
4931 If ACTION is not nil, that is added to the log when font_add_log is
4932 called next time. At that time, ACTION is set back to nil. */
4933 static Lisp_Object Vfont_log_deferred;
4935 /* Prepend the font-related logging data in Vfont_log if it is not
4936 `t'. ACTION describes a kind of font-related action (e.g. listing,
4937 opening), ARG is the argument for the action, and RESULT is the
4938 result of the action. */
4939 void
4940 font_add_log (const char *action, Lisp_Object arg, Lisp_Object result)
4942 Lisp_Object val;
4943 int i;
4945 if (EQ (Vfont_log, Qt))
4946 return;
4947 if (STRINGP (AREF (Vfont_log_deferred, 0)))
4949 char *str = SSDATA (AREF (Vfont_log_deferred, 0));
4951 ASET (Vfont_log_deferred, 0, Qnil);
4952 font_add_log (str, AREF (Vfont_log_deferred, 1),
4953 AREF (Vfont_log_deferred, 2));
4956 if (FONTP (arg))
4958 Lisp_Object tail, elt;
4959 Lisp_Object equalstr = build_string ("=");
4961 val = Ffont_xlfd_name (arg, Qt);
4962 for (tail = AREF (arg, FONT_EXTRA_INDEX); CONSP (tail);
4963 tail = XCDR (tail))
4965 elt = XCAR (tail);
4966 if (EQ (XCAR (elt), QCscript)
4967 && SYMBOLP (XCDR (elt)))
4968 val = concat3 (val, SYMBOL_NAME (QCscript),
4969 concat2 (equalstr, SYMBOL_NAME (XCDR (elt))));
4970 else if (EQ (XCAR (elt), QClang)
4971 && SYMBOLP (XCDR (elt)))
4972 val = concat3 (val, SYMBOL_NAME (QClang),
4973 concat2 (equalstr, SYMBOL_NAME (XCDR (elt))));
4974 else if (EQ (XCAR (elt), QCotf)
4975 && CONSP (XCDR (elt)) && SYMBOLP (XCAR (XCDR (elt))))
4976 val = concat3 (val, SYMBOL_NAME (QCotf),
4977 concat2 (equalstr,
4978 SYMBOL_NAME (XCAR (XCDR (elt)))));
4980 arg = val;
4983 if (CONSP (result)
4984 && VECTORP (XCAR (result))
4985 && ASIZE (XCAR (result)) > 0
4986 && FONTP (AREF (XCAR (result), 0)))
4987 result = font_vconcat_entity_vectors (result);
4988 if (FONTP (result))
4990 val = Ffont_xlfd_name (result, Qt);
4991 if (! FONT_SPEC_P (result))
4992 val = concat3 (SYMBOL_NAME (AREF (result, FONT_TYPE_INDEX)),
4993 build_string (":"), val);
4994 result = val;
4996 else if (CONSP (result))
4998 Lisp_Object tail;
4999 result = Fcopy_sequence (result);
5000 for (tail = result; CONSP (tail); tail = XCDR (tail))
5002 val = XCAR (tail);
5003 if (FONTP (val))
5004 val = Ffont_xlfd_name (val, Qt);
5005 XSETCAR (tail, val);
5008 else if (VECTORP (result))
5010 result = Fcopy_sequence (result);
5011 for (i = 0; i < ASIZE (result); i++)
5013 val = AREF (result, i);
5014 if (FONTP (val))
5015 val = Ffont_xlfd_name (val, Qt);
5016 ASET (result, i, val);
5019 Vfont_log = Fcons (list3 (intern (action), arg, result), Vfont_log);
5022 /* Record a font-related logging data to be added to Vfont_log when
5023 font_add_log is called next time. ACTION, ARG, RESULT are the same
5024 as font_add_log. */
5026 void
5027 font_deferred_log (const char *action, Lisp_Object arg, Lisp_Object result)
5029 if (EQ (Vfont_log, Qt))
5030 return;
5031 ASET (Vfont_log_deferred, 0, build_string (action));
5032 ASET (Vfont_log_deferred, 1, arg);
5033 ASET (Vfont_log_deferred, 2, result);
5036 void
5037 syms_of_font (void)
5039 sort_shift_bits[FONT_TYPE_INDEX] = 0;
5040 sort_shift_bits[FONT_SLANT_INDEX] = 2;
5041 sort_shift_bits[FONT_WEIGHT_INDEX] = 9;
5042 sort_shift_bits[FONT_SIZE_INDEX] = 16;
5043 sort_shift_bits[FONT_WIDTH_INDEX] = 23;
5044 /* Note that the other elements in sort_shift_bits are not used. */
5046 staticpro (&font_charset_alist);
5047 font_charset_alist = Qnil;
5049 DEFSYM (Qopentype, "opentype");
5051 DEFSYM (Qascii_0, "ascii-0");
5052 DEFSYM (Qiso8859_1, "iso8859-1");
5053 DEFSYM (Qiso10646_1, "iso10646-1");
5054 DEFSYM (Qunicode_bmp, "unicode-bmp");
5055 DEFSYM (Qunicode_sip, "unicode-sip");
5057 DEFSYM (QCf, "Cf");
5059 DEFSYM (QCotf, ":otf");
5060 DEFSYM (QClang, ":lang");
5061 DEFSYM (QCscript, ":script");
5062 DEFSYM (QCantialias, ":antialias");
5064 DEFSYM (QCfoundry, ":foundry");
5065 DEFSYM (QCadstyle, ":adstyle");
5066 DEFSYM (QCregistry, ":registry");
5067 DEFSYM (QCspacing, ":spacing");
5068 DEFSYM (QCdpi, ":dpi");
5069 DEFSYM (QCscalable, ":scalable");
5070 DEFSYM (QCavgwidth, ":avgwidth");
5071 DEFSYM (QCfont_entity, ":font-entity");
5072 DEFSYM (QCfc_unknown_spec, ":fc-unknown-spec");
5074 DEFSYM (Qc, "c");
5075 DEFSYM (Qm, "m");
5076 DEFSYM (Qp, "p");
5077 DEFSYM (Qd, "d");
5079 DEFSYM (Qja, "ja");
5080 DEFSYM (Qko, "ko");
5082 DEFSYM (QCuser_spec, "user-spec");
5084 staticpro (&null_vector);
5085 null_vector = Fmake_vector (make_number (0), Qnil);
5087 staticpro (&scratch_font_spec);
5088 scratch_font_spec = Ffont_spec (0, NULL);
5089 staticpro (&scratch_font_prefer);
5090 scratch_font_prefer = Ffont_spec (0, NULL);
5092 staticpro (&Vfont_log_deferred);
5093 Vfont_log_deferred = Fmake_vector (make_number (3), Qnil);
5095 #if 0
5096 #ifdef HAVE_LIBOTF
5097 staticpro (&otf_list);
5098 otf_list = Qnil;
5099 #endif /* HAVE_LIBOTF */
5100 #endif /* 0 */
5102 defsubr (&Sfontp);
5103 defsubr (&Sfont_spec);
5104 defsubr (&Sfont_get);
5105 #ifdef HAVE_WINDOW_SYSTEM
5106 defsubr (&Sfont_face_attributes);
5107 #endif
5108 defsubr (&Sfont_put);
5109 defsubr (&Slist_fonts);
5110 defsubr (&Sfont_family_list);
5111 defsubr (&Sfind_font);
5112 defsubr (&Sfont_xlfd_name);
5113 defsubr (&Sclear_font_cache);
5114 defsubr (&Sfont_shape_gstring);
5115 defsubr (&Sfont_variation_glyphs);
5116 #if 0
5117 defsubr (&Sfont_drive_otf);
5118 defsubr (&Sfont_otf_alternates);
5119 #endif /* 0 */
5121 #ifdef FONT_DEBUG
5122 defsubr (&Sopen_font);
5123 defsubr (&Sclose_font);
5124 defsubr (&Squery_font);
5125 defsubr (&Sfont_get_glyphs);
5126 defsubr (&Sfont_match_p);
5127 defsubr (&Sfont_at);
5128 #if 0
5129 defsubr (&Sdraw_string);
5130 #endif
5131 #endif /* FONT_DEBUG */
5132 #ifdef HAVE_WINDOW_SYSTEM
5133 defsubr (&Sfont_info);
5134 #endif
5136 DEFVAR_LISP ("font-encoding-alist", Vfont_encoding_alist,
5137 doc: /*
5138 Alist of fontname patterns vs the corresponding encoding and repertory info.
5139 Each element looks like (REGEXP . (ENCODING . REPERTORY)),
5140 where ENCODING is a charset or a char-table,
5141 and REPERTORY is a charset, a char-table, or nil.
5143 If ENCODING and REPERTORY are the same, the element can have the form
5144 \(REGEXP . ENCODING).
5146 ENCODING is for converting a character to a glyph code of the font.
5147 If ENCODING is a charset, encoding a character by the charset gives
5148 the corresponding glyph code. If ENCODING is a char-table, looking up
5149 the table by a character gives the corresponding glyph code.
5151 REPERTORY specifies a repertory of characters supported by the font.
5152 If REPERTORY is a charset, all characters beloging to the charset are
5153 supported. If REPERTORY is a char-table, all characters who have a
5154 non-nil value in the table are supported. If REPERTORY is nil, Emacs
5155 gets the repertory information by an opened font and ENCODING. */);
5156 Vfont_encoding_alist = Qnil;
5158 /* FIXME: These 3 vars are not quite what they appear: setq on them
5159 won't have any effect other than disconnect them from the style
5160 table used by the font display code. So we make them read-only,
5161 to avoid this confusing situation. */
5163 DEFVAR_LISP_NOPRO ("font-weight-table", Vfont_weight_table,
5164 doc: /* Vector of valid font weight values.
5165 Each element has the form:
5166 [NUMERIC-VALUE SYMBOLIC-NAME ALIAS-NAME ...]
5167 NUMERIC-VALUE is an integer, and SYMBOLIC-NAME and ALIAS-NAME are symbols. */);
5168 Vfont_weight_table = BUILD_STYLE_TABLE (weight_table);
5169 XSYMBOL (intern_c_string ("font-weight-table"))->constant = 1;
5171 DEFVAR_LISP_NOPRO ("font-slant-table", Vfont_slant_table,
5172 doc: /* Vector of font slant symbols vs the corresponding numeric values.
5173 See `font-weight-table' for the format of the vector. */);
5174 Vfont_slant_table = BUILD_STYLE_TABLE (slant_table);
5175 XSYMBOL (intern_c_string ("font-slant-table"))->constant = 1;
5177 DEFVAR_LISP_NOPRO ("font-width-table", Vfont_width_table,
5178 doc: /* Alist of font width symbols vs the corresponding numeric values.
5179 See `font-weight-table' for the format of the vector. */);
5180 Vfont_width_table = BUILD_STYLE_TABLE (width_table);
5181 XSYMBOL (intern_c_string ("font-width-table"))->constant = 1;
5183 staticpro (&font_style_table);
5184 font_style_table = Fmake_vector (make_number (3), Qnil);
5185 ASET (font_style_table, 0, Vfont_weight_table);
5186 ASET (font_style_table, 1, Vfont_slant_table);
5187 ASET (font_style_table, 2, Vfont_width_table);
5189 DEFVAR_LISP ("font-log", Vfont_log, doc: /*
5190 *Logging list of font related actions and results.
5191 The value t means to suppress the logging.
5192 The initial value is set to nil if the environment variable
5193 EMACS_FONT_LOG is set. Otherwise, it is set to t. */);
5194 Vfont_log = Qnil;
5196 #ifdef HAVE_WINDOW_SYSTEM
5197 #ifdef HAVE_FREETYPE
5198 syms_of_ftfont ();
5199 #ifdef HAVE_X_WINDOWS
5200 syms_of_xfont ();
5201 syms_of_ftxfont ();
5202 #ifdef HAVE_XFT
5203 syms_of_xftfont ();
5204 #endif /* HAVE_XFT */
5205 #endif /* HAVE_X_WINDOWS */
5206 #else /* not HAVE_FREETYPE */
5207 #ifdef HAVE_X_WINDOWS
5208 syms_of_xfont ();
5209 #endif /* HAVE_X_WINDOWS */
5210 #endif /* not HAVE_FREETYPE */
5211 #ifdef HAVE_BDFFONT
5212 syms_of_bdffont ();
5213 #endif /* HAVE_BDFFONT */
5214 #ifdef WINDOWSNT
5215 syms_of_w32font ();
5216 #endif /* WINDOWSNT */
5217 #ifdef HAVE_NS
5218 syms_of_nsfont ();
5219 #endif /* HAVE_NS */
5220 #endif /* HAVE_WINDOW_SYSTEM */
5223 void
5224 init_font (void)
5226 Vfont_log = egetenv ("EMACS_FONT_LOG") ? Qnil : Qt;