Auto-commit of generated files.
[emacs.git] / src / font.c
blob4520d9bc9a21d2a08acdb6bd4663ba0bb1768749
1 /* font.c -- "Font" primitives.
3 Copyright (C) 2006-2012 Free Software Foundation, Inc.
4 Copyright (C) 2006, 2007, 2008, 2009, 2010, 2011
5 National Institute of Advanced Industrial Science and Technology (AIST)
6 Registration Number H13PRO009
8 This file is part of GNU Emacs.
10 GNU Emacs is free software: you can redistribute it and/or modify
11 it under the terms of the GNU General Public License as published by
12 the Free Software Foundation, either version 3 of the License, or
13 (at your option) any later version.
15 GNU Emacs is distributed in the hope that it will be useful,
16 but WITHOUT ANY WARRANTY; without even the implied warranty of
17 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
18 GNU General Public License for more details.
20 You should have received a copy of the GNU General Public License
21 along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. */
23 #include <config.h>
24 #include <float.h>
25 #include <stdio.h>
26 #include <ctype.h>
27 #include <setjmp.h>
29 #include "lisp.h"
30 #include "character.h"
31 #include "buffer.h"
32 #include "frame.h"
33 #include "window.h"
34 #include "dispextern.h"
35 #include "charset.h"
36 #include "composite.h"
37 #include "fontset.h"
38 #include "font.h"
40 #ifdef HAVE_X_WINDOWS
41 #include "xterm.h"
42 #endif /* HAVE_X_WINDOWS */
44 #ifdef HAVE_NTGUI
45 #include "w32term.h"
46 #endif /* HAVE_NTGUI */
48 #ifdef HAVE_NS
49 #include "nsterm.h"
50 #endif /* HAVE_NS */
52 Lisp_Object Qopentype;
54 /* Important character set strings. */
55 Lisp_Object Qascii_0, Qiso8859_1, Qiso10646_1, Qunicode_bmp, Qunicode_sip;
57 #define DEFAULT_ENCODING Qiso8859_1
59 /* Unicode category `Cf'. */
60 static Lisp_Object QCf;
62 /* Vector of Vfont_weight_table, Vfont_slant_table, and Vfont_width_table. */
63 static Lisp_Object font_style_table;
65 /* Structure used for tables mapping weight, slant, and width numeric
66 values and their names. */
68 struct table_entry
70 int numeric;
71 /* The first one is a valid name as a face attribute.
72 The second one (if any) is a typical name in XLFD field. */
73 const char *names[5];
76 /* Table of weight numeric values and their names. This table must be
77 sorted by numeric values in ascending order. */
79 static const struct table_entry weight_table[] =
81 { 0, { "thin" }},
82 { 20, { "ultra-light", "ultralight" }},
83 { 40, { "extra-light", "extralight" }},
84 { 50, { "light" }},
85 { 75, { "semi-light", "semilight", "demilight", "book" }},
86 { 100, { "normal", "medium", "regular", "unspecified" }},
87 { 180, { "semi-bold", "semibold", "demibold", "demi" }},
88 { 200, { "bold" }},
89 { 205, { "extra-bold", "extrabold" }},
90 { 210, { "ultra-bold", "ultrabold", "black" }}
93 /* Table of slant numeric values and their names. This table must be
94 sorted by numeric values in ascending order. */
96 static const struct table_entry slant_table[] =
98 { 0, { "reverse-oblique", "ro" }},
99 { 10, { "reverse-italic", "ri" }},
100 { 100, { "normal", "r", "unspecified" }},
101 { 200, { "italic" ,"i", "ot" }},
102 { 210, { "oblique", "o" }}
105 /* Table of width numeric values and their names. This table must be
106 sorted by numeric values in ascending order. */
108 static const struct table_entry width_table[] =
110 { 50, { "ultra-condensed", "ultracondensed" }},
111 { 63, { "extra-condensed", "extracondensed" }},
112 { 75, { "condensed", "compressed", "narrow" }},
113 { 87, { "semi-condensed", "semicondensed", "demicondensed" }},
114 { 100, { "normal", "medium", "regular", "unspecified" }},
115 { 113, { "semi-expanded", "semiexpanded", "demiexpanded" }},
116 { 125, { "expanded" }},
117 { 150, { "extra-expanded", "extraexpanded" }},
118 { 200, { "ultra-expanded", "ultraexpanded", "wide" }}
121 Lisp_Object QCfoundry;
122 static Lisp_Object QCadstyle, QCregistry;
123 /* Symbols representing keys of font extra info. */
124 Lisp_Object QCspacing, QCdpi, QCscalable, QCotf, QClang, QCscript, QCavgwidth;
125 Lisp_Object QCantialias, QCfont_entity;
126 static Lisp_Object QCfc_unknown_spec;
127 /* Symbols representing values of font spacing property. */
128 static Lisp_Object Qc, Qm, Qd;
129 Lisp_Object Qp;
130 /* Special ADSTYLE properties to avoid fonts used for Latin
131 characters; used in xfont.c and ftfont.c. */
132 Lisp_Object Qja, Qko;
134 static Lisp_Object QCuser_spec;
136 /* Alist of font registry symbols and the corresponding charset
137 information. The information is retrieved from
138 Vfont_encoding_alist on demand.
140 Eash element has the form:
141 (REGISTRY . (ENCODING-CHARSET-ID . REPERTORY-CHARSET-ID))
143 (REGISTRY . nil)
145 In the former form, ENCODING-CHARSET-ID is an ID of a charset that
146 encodes a character code to a glyph code of a font, and
147 REPERTORY-CHARSET-ID is an ID of a charset that tells if a
148 character is supported by a font.
150 The latter form means that the information for REGISTRY couldn't be
151 retrieved. */
152 static Lisp_Object font_charset_alist;
154 /* List of all font drivers. Each font-backend (XXXfont.c) calls
155 register_font_driver in syms_of_XXXfont to register its font-driver
156 here. */
157 static struct font_driver_list *font_driver_list;
161 /* Creators of font-related Lisp object. */
163 static Lisp_Object
164 font_make_spec (void)
166 Lisp_Object font_spec;
167 struct font_spec *spec
168 = ((struct font_spec *)
169 allocate_pseudovector (VECSIZE (struct font_spec),
170 FONT_SPEC_MAX, PVEC_FONT));
171 XSETFONT (font_spec, spec);
172 return font_spec;
175 Lisp_Object
176 font_make_entity (void)
178 Lisp_Object font_entity;
179 struct font_entity *entity
180 = ((struct font_entity *)
181 allocate_pseudovector (VECSIZE (struct font_entity),
182 FONT_ENTITY_MAX, PVEC_FONT));
183 XSETFONT (font_entity, entity);
184 return font_entity;
187 /* Create a font-object whose structure size is SIZE. If ENTITY is
188 not nil, copy properties from ENTITY to the font-object. If
189 PIXELSIZE is positive, set the `size' property to PIXELSIZE. */
190 Lisp_Object
191 font_make_object (int size, Lisp_Object entity, int pixelsize)
193 Lisp_Object font_object;
194 struct font *font
195 = (struct font *) allocate_pseudovector (size, FONT_OBJECT_MAX, PVEC_FONT);
196 int i;
198 XSETFONT (font_object, font);
200 if (! NILP (entity))
202 for (i = 1; i < FONT_SPEC_MAX; i++)
203 font->props[i] = AREF (entity, i);
204 if (! NILP (AREF (entity, FONT_EXTRA_INDEX)))
205 font->props[FONT_EXTRA_INDEX]
206 = Fcopy_alist (AREF (entity, FONT_EXTRA_INDEX));
208 if (size > 0)
209 font->props[FONT_SIZE_INDEX] = make_number (pixelsize);
210 return font_object;
215 static int font_pixel_size (FRAME_PTR f, Lisp_Object);
216 static Lisp_Object font_open_entity (FRAME_PTR, Lisp_Object, int);
217 static Lisp_Object font_matching_entity (FRAME_PTR, Lisp_Object *,
218 Lisp_Object);
219 static unsigned font_encode_char (Lisp_Object, int);
221 /* Number of registered font drivers. */
222 static int num_font_drivers;
225 /* Return a Lispy value of a font property value at STR and LEN bytes.
226 If STR is "*", return nil.
227 If FORCE_SYMBOL is zero and all characters in STR are digits,
228 return an integer. Otherwise, return a symbol interned from
229 STR. */
231 Lisp_Object
232 font_intern_prop (const char *str, ptrdiff_t len, int force_symbol)
234 ptrdiff_t i;
235 Lisp_Object tem;
236 Lisp_Object obarray;
237 ptrdiff_t nbytes, nchars;
239 if (len == 1 && *str == '*')
240 return Qnil;
241 if (!force_symbol && 0 < len && '0' <= *str && *str <= '9')
243 for (i = 1; i < len; i++)
244 if (! ('0' <= str[i] && str[i] <= '9'))
245 break;
246 if (i == len)
248 EMACS_INT n;
250 i = 0;
251 for (n = 0; (n += str[i++] - '0') <= MOST_POSITIVE_FIXNUM; n *= 10)
253 if (i == len)
254 return make_number (n);
255 if (MOST_POSITIVE_FIXNUM / 10 < n)
256 break;
259 xsignal1 (Qoverflow_error, make_string (str, len));
263 /* This code is similar to intern function from lread.c. */
264 obarray = check_obarray (Vobarray);
265 parse_str_as_multibyte ((unsigned char *) str, len, &nchars, &nbytes);
266 tem = oblookup (obarray, str,
267 (len == nchars || len != nbytes) ? len : nchars, len);
269 if (SYMBOLP (tem))
270 return tem;
271 if (len == nchars || len != nbytes)
272 tem = make_unibyte_string (str, len);
273 else
274 tem = make_multibyte_string (str, nchars, len);
275 return Fintern (tem, obarray);
278 /* Return a pixel size of font-spec SPEC on frame F. */
280 static int
281 font_pixel_size (FRAME_PTR f, Lisp_Object spec)
283 #ifdef HAVE_WINDOW_SYSTEM
284 Lisp_Object size = AREF (spec, FONT_SIZE_INDEX);
285 double point_size;
286 int dpi, pixel_size;
287 Lisp_Object val;
289 if (INTEGERP (size))
290 return XINT (size);
291 if (NILP (size))
292 return 0;
293 font_assert (FLOATP (size));
294 point_size = XFLOAT_DATA (size);
295 val = AREF (spec, FONT_DPI_INDEX);
296 if (INTEGERP (val))
297 dpi = XINT (val);
298 else
299 dpi = f->resy;
300 pixel_size = POINT_TO_PIXEL (point_size, dpi);
301 return pixel_size;
302 #else
303 return 1;
304 #endif
308 /* Return a value of PROP's VAL (symbol or integer) to be stored in a
309 font vector. If VAL is not valid (i.e. not registered in
310 font_style_table), return -1 if NOERROR is zero, and return a
311 proper index if NOERROR is nonzero. In that case, register VAL in
312 font_style_table if VAL is a symbol, and return the closest index if
313 VAL is an integer. */
316 font_style_to_value (enum font_property_index prop, Lisp_Object val, int noerror)
318 Lisp_Object table = AREF (font_style_table, prop - FONT_WEIGHT_INDEX);
319 int len;
321 CHECK_VECTOR (table);
322 len = ASIZE (table);
324 if (SYMBOLP (val))
326 int i, j;
327 char *s;
328 Lisp_Object args[2], elt;
330 /* At first try exact match. */
331 for (i = 0; i < len; i++)
333 CHECK_VECTOR (AREF (table, i));
334 for (j = 1; j < ASIZE (AREF (table, i)); j++)
335 if (EQ (val, AREF (AREF (table, i), j)))
337 CHECK_NUMBER (AREF (AREF (table, i), 0));
338 return ((XINT (AREF (AREF (table, i), 0)) << 8)
339 | (i << 4) | (j - 1));
342 /* Try also with case-folding match. */
343 s = SSDATA (SYMBOL_NAME (val));
344 for (i = 0; i < len; i++)
345 for (j = 1; j < ASIZE (AREF (table, i)); j++)
347 elt = AREF (AREF (table, i), j);
348 if (xstrcasecmp (s, SSDATA (SYMBOL_NAME (elt))) == 0)
350 CHECK_NUMBER (AREF (AREF (table, i), 0));
351 return ((XINT (AREF (AREF (table, i), 0)) << 8)
352 | (i << 4) | (j - 1));
355 if (! noerror)
356 return -1;
357 if (len == 255)
358 abort ();
359 elt = Fmake_vector (make_number (2), make_number (100));
360 ASET (elt, 1, val);
361 args[0] = table;
362 args[1] = Fmake_vector (make_number (1), elt);
363 ASET (font_style_table, prop - FONT_WEIGHT_INDEX, Fvconcat (2, args));
364 return (100 << 8) | (i << 4);
366 else
368 int i, last_n;
369 EMACS_INT numeric = XINT (val);
371 for (i = 0, last_n = -1; i < len; i++)
373 int n;
375 CHECK_VECTOR (AREF (table, i));
376 CHECK_NUMBER (AREF (AREF (table, i), 0));
377 n = XINT (AREF (AREF (table, i), 0));
378 if (numeric == n)
379 return (n << 8) | (i << 4);
380 if (numeric < n)
382 if (! noerror)
383 return -1;
384 return ((i == 0 || n - numeric < numeric - last_n)
385 ? (n << 8) | (i << 4): (last_n << 8 | ((i - 1) << 4)));
387 last_n = n;
389 if (! noerror)
390 return -1;
391 return ((last_n << 8) | ((i - 1) << 4));
395 Lisp_Object
396 font_style_symbolic (Lisp_Object font, enum font_property_index prop, int for_face)
398 Lisp_Object val = AREF (font, prop);
399 Lisp_Object table, elt;
400 int i;
402 if (NILP (val))
403 return Qnil;
404 table = AREF (font_style_table, prop - FONT_WEIGHT_INDEX);
405 CHECK_VECTOR (table);
406 i = XINT (val) & 0xFF;
407 font_assert (((i >> 4) & 0xF) < ASIZE (table));
408 elt = AREF (table, ((i >> 4) & 0xF));
409 CHECK_VECTOR (elt);
410 font_assert ((i & 0xF) + 1 < ASIZE (elt));
411 elt = (for_face ? AREF (elt, 1) : AREF (elt, (i & 0xF) + 1));
412 CHECK_SYMBOL (elt);
413 return elt;
416 /* Return ENCODING or a cons of ENCODING and REPERTORY of the font
417 FONTNAME. ENCODING is a charset symbol that specifies the encoding
418 of the font. REPERTORY is a charset symbol or nil. */
420 Lisp_Object
421 find_font_encoding (Lisp_Object fontname)
423 Lisp_Object tail, elt;
425 for (tail = Vfont_encoding_alist; CONSP (tail); tail = XCDR (tail))
427 elt = XCAR (tail);
428 if (CONSP (elt)
429 && STRINGP (XCAR (elt))
430 && fast_string_match_ignore_case (XCAR (elt), fontname) >= 0
431 && (SYMBOLP (XCDR (elt))
432 ? CHARSETP (XCDR (elt))
433 : CONSP (XCDR (elt)) && CHARSETP (XCAR (XCDR (elt)))))
434 return (XCDR (elt));
436 return Qnil;
439 /* Return encoding charset and repertory charset for REGISTRY in
440 ENCODING and REPERTORY correspondingly. If correct information for
441 REGISTRY is available, return 0. Otherwise return -1. */
444 font_registry_charsets (Lisp_Object registry, struct charset **encoding, struct charset **repertory)
446 Lisp_Object val;
447 int encoding_id, repertory_id;
449 val = Fassoc_string (registry, font_charset_alist, Qt);
450 if (! NILP (val))
452 val = XCDR (val);
453 if (NILP (val))
454 return -1;
455 encoding_id = XINT (XCAR (val));
456 repertory_id = XINT (XCDR (val));
458 else
460 val = find_font_encoding (SYMBOL_NAME (registry));
461 if (SYMBOLP (val) && CHARSETP (val))
463 encoding_id = repertory_id = XINT (CHARSET_SYMBOL_ID (val));
465 else if (CONSP (val))
467 if (! CHARSETP (XCAR (val)))
468 goto invalid_entry;
469 encoding_id = XINT (CHARSET_SYMBOL_ID (XCAR (val)));
470 if (NILP (XCDR (val)))
471 repertory_id = -1;
472 else
474 if (! CHARSETP (XCDR (val)))
475 goto invalid_entry;
476 repertory_id = XINT (CHARSET_SYMBOL_ID (XCDR (val)));
479 else
480 goto invalid_entry;
481 val = Fcons (make_number (encoding_id), make_number (repertory_id));
482 font_charset_alist
483 = nconc2 (font_charset_alist, Fcons (Fcons (registry, val), Qnil));
486 if (encoding)
487 *encoding = CHARSET_FROM_ID (encoding_id);
488 if (repertory)
489 *repertory = repertory_id >= 0 ? CHARSET_FROM_ID (repertory_id) : NULL;
490 return 0;
492 invalid_entry:
493 font_charset_alist
494 = nconc2 (font_charset_alist, Fcons (Fcons (registry, Qnil), Qnil));
495 return -1;
499 /* Font property value validators. See the comment of
500 font_property_table for the meaning of the arguments. */
502 static Lisp_Object font_prop_validate (int, Lisp_Object, Lisp_Object);
503 static Lisp_Object font_prop_validate_symbol (Lisp_Object, Lisp_Object);
504 static Lisp_Object font_prop_validate_style (Lisp_Object, Lisp_Object);
505 static Lisp_Object font_prop_validate_non_neg (Lisp_Object, Lisp_Object);
506 static Lisp_Object font_prop_validate_spacing (Lisp_Object, Lisp_Object);
507 static int get_font_prop_index (Lisp_Object);
509 static Lisp_Object
510 font_prop_validate_symbol (Lisp_Object prop, Lisp_Object val)
512 if (STRINGP (val))
513 val = Fintern (val, Qnil);
514 if (! SYMBOLP (val))
515 val = Qerror;
516 else if (EQ (prop, QCregistry))
517 val = Fintern (Fdowncase (SYMBOL_NAME (val)), Qnil);
518 return val;
522 static Lisp_Object
523 font_prop_validate_style (Lisp_Object style, Lisp_Object val)
525 enum font_property_index prop = (EQ (style, QCweight) ? FONT_WEIGHT_INDEX
526 : EQ (style, QCslant) ? FONT_SLANT_INDEX
527 : FONT_WIDTH_INDEX);
528 if (INTEGERP (val))
530 EMACS_INT n = XINT (val);
531 CHECK_VECTOR (AREF (font_style_table, prop - FONT_WEIGHT_INDEX));
532 if (((n >> 4) & 0xF)
533 >= ASIZE (AREF (font_style_table, prop - FONT_WEIGHT_INDEX)))
534 val = Qerror;
535 else
537 Lisp_Object elt = AREF (AREF (font_style_table, prop - FONT_WEIGHT_INDEX), (n >> 4) & 0xF);
539 CHECK_VECTOR (elt);
540 if ((n & 0xF) + 1 >= ASIZE (elt))
541 val = Qerror;
542 else
544 CHECK_NUMBER (AREF (elt, 0));
545 if (XINT (AREF (elt, 0)) != (n >> 8))
546 val = Qerror;
550 else if (SYMBOLP (val))
552 int n = font_style_to_value (prop, val, 0);
554 val = n >= 0 ? make_number (n) : Qerror;
556 else
557 val = Qerror;
558 return val;
561 static Lisp_Object
562 font_prop_validate_non_neg (Lisp_Object prop, Lisp_Object val)
564 return (NATNUMP (val) || (FLOATP (val) && XFLOAT_DATA (val) >= 0)
565 ? val : Qerror);
568 static Lisp_Object
569 font_prop_validate_spacing (Lisp_Object prop, Lisp_Object val)
571 if (NILP (val) || (NATNUMP (val) && XINT (val) <= FONT_SPACING_CHARCELL))
572 return val;
573 if (SYMBOLP (val) && SBYTES (SYMBOL_NAME (val)) == 1)
575 char spacing = SDATA (SYMBOL_NAME (val))[0];
577 if (spacing == 'c' || spacing == 'C')
578 return make_number (FONT_SPACING_CHARCELL);
579 if (spacing == 'm' || spacing == 'M')
580 return make_number (FONT_SPACING_MONO);
581 if (spacing == 'p' || spacing == 'P')
582 return make_number (FONT_SPACING_PROPORTIONAL);
583 if (spacing == 'd' || spacing == 'D')
584 return make_number (FONT_SPACING_DUAL);
586 return Qerror;
589 static Lisp_Object
590 font_prop_validate_otf (Lisp_Object prop, Lisp_Object val)
592 Lisp_Object tail, tmp;
593 int i;
595 /* VAL = (SCRIPT [ LANGSYS [ GSUB-FEATURES [ GPOS-FEATURES ]]])
596 GSUB-FEATURES = (FEATURE ... [ nil FEATURE ... ]) | nil
597 GPOS-FEATURES = (FEATURE ... [ nil FEATURE ... ]) | nil */
598 if (! CONSP (val))
599 return Qerror;
600 if (! SYMBOLP (XCAR (val)))
601 return Qerror;
602 tail = XCDR (val);
603 if (NILP (tail))
604 return val;
605 if (! CONSP (tail) || ! SYMBOLP (XCAR (val)))
606 return Qerror;
607 for (i = 0; i < 2; i++)
609 tail = XCDR (tail);
610 if (NILP (tail))
611 return val;
612 if (! CONSP (tail))
613 return Qerror;
614 for (tmp = XCAR (tail); CONSP (tmp); tmp = XCDR (tmp))
615 if (! SYMBOLP (XCAR (tmp)))
616 return Qerror;
617 if (! NILP (tmp))
618 return Qerror;
620 return val;
623 /* Structure of known font property keys and validator of the
624 values. */
625 static const struct
627 /* Pointer to the key symbol. */
628 Lisp_Object *key;
629 /* Function to validate PROP's value VAL, or NULL if any value is
630 ok. The value is VAL or its regularized value if VAL is valid,
631 and Qerror if not. */
632 Lisp_Object (*validator) (Lisp_Object prop, Lisp_Object val);
633 } font_property_table[] =
634 { { &QCtype, font_prop_validate_symbol },
635 { &QCfoundry, font_prop_validate_symbol },
636 { &QCfamily, font_prop_validate_symbol },
637 { &QCadstyle, font_prop_validate_symbol },
638 { &QCregistry, font_prop_validate_symbol },
639 { &QCweight, font_prop_validate_style },
640 { &QCslant, font_prop_validate_style },
641 { &QCwidth, font_prop_validate_style },
642 { &QCsize, font_prop_validate_non_neg },
643 { &QCdpi, font_prop_validate_non_neg },
644 { &QCspacing, font_prop_validate_spacing },
645 { &QCavgwidth, font_prop_validate_non_neg },
646 /* The order of the above entries must match with enum
647 font_property_index. */
648 { &QClang, font_prop_validate_symbol },
649 { &QCscript, font_prop_validate_symbol },
650 { &QCotf, font_prop_validate_otf }
653 /* Size (number of elements) of the above table. */
654 #define FONT_PROPERTY_TABLE_SIZE \
655 ((sizeof font_property_table) / (sizeof *font_property_table))
657 /* Return an index number of font property KEY or -1 if KEY is not an
658 already known property. */
660 static int
661 get_font_prop_index (Lisp_Object key)
663 int i;
665 for (i = 0; i < FONT_PROPERTY_TABLE_SIZE; i++)
666 if (EQ (key, *font_property_table[i].key))
667 return i;
668 return -1;
671 /* Validate the font property. The property key is specified by the
672 symbol PROP, or the index IDX (if PROP is nil). If VAL is invalid,
673 signal an error. The value is VAL or the regularized one. */
675 static Lisp_Object
676 font_prop_validate (int idx, Lisp_Object prop, Lisp_Object val)
678 Lisp_Object validated;
680 if (NILP (val))
681 return val;
682 if (NILP (prop))
683 prop = *font_property_table[idx].key;
684 else
686 idx = get_font_prop_index (prop);
687 if (idx < 0)
688 return val;
690 validated = (font_property_table[idx].validator) (prop, val);
691 if (EQ (validated, Qerror))
692 signal_error ("invalid font property", Fcons (prop, val));
693 return validated;
697 /* Store VAL as a value of extra font property PROP in FONT while
698 keeping the sorting order. Don't check the validity of VAL. */
700 Lisp_Object
701 font_put_extra (Lisp_Object font, Lisp_Object prop, Lisp_Object val)
703 Lisp_Object extra = AREF (font, FONT_EXTRA_INDEX);
704 Lisp_Object slot = (NILP (extra) ? Qnil : assq_no_quit (prop, extra));
706 if (NILP (slot))
708 Lisp_Object prev = Qnil;
710 while (CONSP (extra)
711 && NILP (Fstring_lessp (prop, XCAR (XCAR (extra)))))
712 prev = extra, extra = XCDR (extra);
714 if (NILP (prev))
715 ASET (font, FONT_EXTRA_INDEX, Fcons (Fcons (prop, val), extra));
716 else
717 XSETCDR (prev, Fcons (Fcons (prop, val), extra));
719 return val;
721 XSETCDR (slot, val);
722 if (NILP (val))
723 ASET (font, FONT_EXTRA_INDEX, Fdelq (slot, extra));
724 return val;
728 /* Font name parser and unparser */
730 static int parse_matrix (const char *);
731 static int font_expand_wildcards (Lisp_Object *, int);
732 static int font_parse_name (char *, ptrdiff_t, Lisp_Object);
734 /* An enumerator for each field of an XLFD font name. */
735 enum xlfd_field_index
737 XLFD_FOUNDRY_INDEX,
738 XLFD_FAMILY_INDEX,
739 XLFD_WEIGHT_INDEX,
740 XLFD_SLANT_INDEX,
741 XLFD_SWIDTH_INDEX,
742 XLFD_ADSTYLE_INDEX,
743 XLFD_PIXEL_INDEX,
744 XLFD_POINT_INDEX,
745 XLFD_RESX_INDEX,
746 XLFD_RESY_INDEX,
747 XLFD_SPACING_INDEX,
748 XLFD_AVGWIDTH_INDEX,
749 XLFD_REGISTRY_INDEX,
750 XLFD_ENCODING_INDEX,
751 XLFD_LAST_INDEX
754 /* An enumerator for mask bit corresponding to each XLFD field. */
755 enum xlfd_field_mask
757 XLFD_FOUNDRY_MASK = 0x0001,
758 XLFD_FAMILY_MASK = 0x0002,
759 XLFD_WEIGHT_MASK = 0x0004,
760 XLFD_SLANT_MASK = 0x0008,
761 XLFD_SWIDTH_MASK = 0x0010,
762 XLFD_ADSTYLE_MASK = 0x0020,
763 XLFD_PIXEL_MASK = 0x0040,
764 XLFD_POINT_MASK = 0x0080,
765 XLFD_RESX_MASK = 0x0100,
766 XLFD_RESY_MASK = 0x0200,
767 XLFD_SPACING_MASK = 0x0400,
768 XLFD_AVGWIDTH_MASK = 0x0800,
769 XLFD_REGISTRY_MASK = 0x1000,
770 XLFD_ENCODING_MASK = 0x2000
774 /* Parse P pointing to the pixel/point size field of the form
775 `[A B C D]' which specifies a transformation matrix:
777 A B 0
778 C D 0
779 0 0 1
781 by which all glyphs of the font are transformed. The spec says
782 that scalar value N for the pixel/point size is equivalent to:
783 A = N * resx/resy, B = C = 0, D = N.
785 Return the scalar value N if the form is valid. Otherwise return
786 -1. */
788 static int
789 parse_matrix (const char *p)
791 double matrix[4];
792 char *end;
793 int i;
795 for (i = 0, p++; i < 4 && *p && *p != ']'; i++)
797 if (*p == '~')
798 matrix[i] = - strtod (p + 1, &end);
799 else
800 matrix[i] = strtod (p, &end);
801 p = end;
803 return (i == 4 ? (int) matrix[3] : -1);
806 /* Expand a wildcard field in FIELD (the first N fields are filled) to
807 multiple fields to fill in all 14 XLFD fields while restricting a
808 field position by its contents. */
810 static int
811 font_expand_wildcards (Lisp_Object *field, int n)
813 /* Copy of FIELD. */
814 Lisp_Object tmp[XLFD_LAST_INDEX];
815 /* Array of information about where this element can go. Nth
816 element is for Nth element of FIELD. */
817 struct {
818 /* Minimum possible field. */
819 int from;
820 /* Maximum possible field. */
821 int to;
822 /* Bit mask of possible field. Nth bit corresponds to Nth field. */
823 int mask;
824 } range[XLFD_LAST_INDEX];
825 int i, j;
826 int range_from, range_to;
827 unsigned range_mask;
829 #define XLFD_SYMBOL_MASK (XLFD_FOUNDRY_MASK | XLFD_FAMILY_MASK \
830 | XLFD_ADSTYLE_MASK | XLFD_REGISTRY_MASK)
831 #define XLFD_NULL_MASK (XLFD_FOUNDRY_MASK | XLFD_ADSTYLE_MASK)
832 #define XLFD_LARGENUM_MASK (XLFD_POINT_MASK | XLFD_RESX_MASK | XLFD_RESY_MASK \
833 | XLFD_AVGWIDTH_MASK)
834 #define XLFD_REGENC_MASK (XLFD_REGISTRY_MASK | XLFD_ENCODING_MASK)
836 /* Initialize RANGE_MASK for FIELD[0] which can be 0th to (14 - N)th
837 field. The value is shifted to left one bit by one in the
838 following loop. */
839 for (i = 0, range_mask = 0; i <= 14 - n; i++)
840 range_mask = (range_mask << 1) | 1;
842 /* The triplet RANGE_FROM, RANGE_TO, and RANGE_MASK is a
843 position-based restriction for FIELD[I]. */
844 for (i = 0, range_from = 0, range_to = 14 - n; i < n;
845 i++, range_from++, range_to++, range_mask <<= 1)
847 Lisp_Object val = field[i];
849 tmp[i] = val;
850 if (NILP (val))
852 /* Wildcard. */
853 range[i].from = range_from;
854 range[i].to = range_to;
855 range[i].mask = range_mask;
857 else
859 /* The triplet FROM, TO, and MASK is a value-based
860 restriction for FIELD[I]. */
861 int from, to;
862 unsigned mask;
864 if (INTEGERP (val))
866 EMACS_INT numeric = XINT (val);
868 if (i + 1 == n)
869 from = to = XLFD_ENCODING_INDEX,
870 mask = XLFD_ENCODING_MASK;
871 else if (numeric == 0)
872 from = XLFD_PIXEL_INDEX, to = XLFD_AVGWIDTH_INDEX,
873 mask = XLFD_PIXEL_MASK | XLFD_LARGENUM_MASK;
874 else if (numeric <= 48)
875 from = to = XLFD_PIXEL_INDEX,
876 mask = XLFD_PIXEL_MASK;
877 else
878 from = XLFD_POINT_INDEX, to = XLFD_AVGWIDTH_INDEX,
879 mask = XLFD_LARGENUM_MASK;
881 else if (SBYTES (SYMBOL_NAME (val)) == 0)
882 from = XLFD_FOUNDRY_INDEX, to = XLFD_ADSTYLE_INDEX,
883 mask = XLFD_NULL_MASK;
884 else if (i == 0)
885 from = to = XLFD_FOUNDRY_INDEX, mask = XLFD_FOUNDRY_MASK;
886 else if (i + 1 == n)
888 Lisp_Object name = SYMBOL_NAME (val);
890 if (SDATA (name)[SBYTES (name) - 1] == '*')
891 from = XLFD_REGISTRY_INDEX, to = XLFD_ENCODING_INDEX,
892 mask = XLFD_REGENC_MASK;
893 else
894 from = to = XLFD_ENCODING_INDEX,
895 mask = XLFD_ENCODING_MASK;
897 else if (range_from <= XLFD_WEIGHT_INDEX
898 && range_to >= XLFD_WEIGHT_INDEX
899 && FONT_WEIGHT_NAME_NUMERIC (val) >= 0)
900 from = to = XLFD_WEIGHT_INDEX, mask = XLFD_WEIGHT_MASK;
901 else if (range_from <= XLFD_SLANT_INDEX
902 && range_to >= XLFD_SLANT_INDEX
903 && FONT_SLANT_NAME_NUMERIC (val) >= 0)
904 from = to = XLFD_SLANT_INDEX, mask = XLFD_SLANT_MASK;
905 else if (range_from <= XLFD_SWIDTH_INDEX
906 && range_to >= XLFD_SWIDTH_INDEX
907 && FONT_WIDTH_NAME_NUMERIC (val) >= 0)
908 from = to = XLFD_SWIDTH_INDEX, mask = XLFD_SWIDTH_MASK;
909 else
911 if (EQ (val, Qc) || EQ (val, Qm) || EQ (val, Qp) || EQ (val, Qd))
912 from = to = XLFD_SPACING_INDEX, mask = XLFD_SPACING_MASK;
913 else
914 from = XLFD_FOUNDRY_INDEX, to = XLFD_ENCODING_INDEX,
915 mask = XLFD_SYMBOL_MASK;
918 /* Merge position-based and value-based restrictions. */
919 mask &= range_mask;
920 while (from < range_from)
921 mask &= ~(1 << from++);
922 while (from < 14 && ! (mask & (1 << from)))
923 from++;
924 while (to > range_to)
925 mask &= ~(1 << to--);
926 while (to >= 0 && ! (mask & (1 << to)))
927 to--;
928 if (from > to)
929 return -1;
930 range[i].from = from;
931 range[i].to = to;
932 range[i].mask = mask;
934 if (from > range_from || to < range_to)
936 /* The range is narrowed by value-based restrictions.
937 Reflect it to the other fields. */
939 /* Following fields should be after FROM. */
940 range_from = from;
941 /* Preceding fields should be before TO. */
942 for (j = i - 1, from--, to--; j >= 0; j--, from--, to--)
944 /* Check FROM for non-wildcard field. */
945 if (! NILP (tmp[j]) && range[j].from < from)
947 while (range[j].from < from)
948 range[j].mask &= ~(1 << range[j].from++);
949 while (from < 14 && ! (range[j].mask & (1 << from)))
950 from++;
951 range[j].from = from;
953 else
954 from = range[j].from;
955 if (range[j].to > to)
957 while (range[j].to > to)
958 range[j].mask &= ~(1 << range[j].to--);
959 while (to >= 0 && ! (range[j].mask & (1 << to)))
960 to--;
961 range[j].to = to;
963 else
964 to = range[j].to;
965 if (from > to)
966 return -1;
972 /* Decide all fields from restrictions in RANGE. */
973 for (i = j = 0; i < n ; i++)
975 if (j < range[i].from)
977 if (i == 0 || ! NILP (tmp[i - 1]))
978 /* None of TMP[X] corresponds to Jth field. */
979 return -1;
980 for (; j < range[i].from; j++)
981 field[j] = Qnil;
983 field[j++] = tmp[i];
985 if (! NILP (tmp[n - 1]) && j < XLFD_REGISTRY_INDEX)
986 return -1;
987 for (; j < XLFD_LAST_INDEX; j++)
988 field[j] = Qnil;
989 if (INTEGERP (field[XLFD_ENCODING_INDEX]))
990 field[XLFD_ENCODING_INDEX]
991 = Fintern (Fnumber_to_string (field[XLFD_ENCODING_INDEX]), Qnil);
992 return 0;
996 /* Parse NAME (null terminated) as XLFD and store information in FONT
997 (font-spec or font-entity). Size property of FONT is set as
998 follows:
999 specified XLFD fields FONT property
1000 --------------------- -------------
1001 PIXEL_SIZE PIXEL_SIZE (Lisp integer)
1002 POINT_SIZE and RESY calculated pixel size (Lisp integer)
1003 POINT_SIZE POINT_SIZE/10 (Lisp float)
1005 If NAME is successfully parsed, return 0. Otherwise return -1.
1007 FONT is usually a font-spec, but when this function is called from
1008 X font backend driver, it is a font-entity. In that case, NAME is
1009 a fully specified XLFD. */
1012 font_parse_xlfd (char *name, ptrdiff_t len, Lisp_Object font)
1014 int i, j, n;
1015 char *f[XLFD_LAST_INDEX + 1];
1016 Lisp_Object val;
1017 char *p;
1019 if (len > 255 || !len)
1020 /* Maximum XLFD name length is 255. */
1021 return -1;
1022 /* Accept "*-.." as a fully specified XLFD. */
1023 if (name[0] == '*' && (len == 1 || name[1] == '-'))
1024 i = 1, f[XLFD_FOUNDRY_INDEX] = name;
1025 else
1026 i = 0;
1027 for (p = name + i; *p; p++)
1028 if (*p == '-')
1030 f[i++] = p + 1;
1031 if (i == XLFD_LAST_INDEX)
1032 break;
1034 f[i] = name + len;
1036 #define INTERN_FIELD(N) font_intern_prop (f[N], f[(N) + 1] - 1 - f[N], 0)
1037 #define INTERN_FIELD_SYM(N) font_intern_prop (f[N], f[(N) + 1] - 1 - f[N], 1)
1039 if (i == XLFD_LAST_INDEX)
1041 /* Fully specified XLFD. */
1042 int pixel_size;
1044 ASET (font, FONT_FOUNDRY_INDEX, INTERN_FIELD_SYM (XLFD_FOUNDRY_INDEX));
1045 ASET (font, FONT_FAMILY_INDEX, INTERN_FIELD_SYM (XLFD_FAMILY_INDEX));
1046 for (i = XLFD_WEIGHT_INDEX, j = FONT_WEIGHT_INDEX;
1047 i <= XLFD_SWIDTH_INDEX; i++, j++)
1049 val = INTERN_FIELD_SYM (i);
1050 if (! NILP (val))
1052 if ((n = font_style_to_value (j, INTERN_FIELD_SYM (i), 0)) < 0)
1053 return -1;
1054 ASET (font, j, make_number (n));
1057 ASET (font, FONT_ADSTYLE_INDEX, INTERN_FIELD_SYM (XLFD_ADSTYLE_INDEX));
1058 if (strcmp (f[XLFD_REGISTRY_INDEX], "*-*") == 0)
1059 ASET (font, FONT_REGISTRY_INDEX, Qnil);
1060 else
1061 ASET (font, FONT_REGISTRY_INDEX,
1062 font_intern_prop (f[XLFD_REGISTRY_INDEX],
1063 f[XLFD_LAST_INDEX] - f[XLFD_REGISTRY_INDEX],
1064 1));
1065 p = f[XLFD_PIXEL_INDEX];
1066 if (*p == '[' && (pixel_size = parse_matrix (p)) >= 0)
1067 ASET (font, FONT_SIZE_INDEX, make_number (pixel_size));
1068 else
1070 val = INTERN_FIELD (XLFD_PIXEL_INDEX);
1071 if (INTEGERP (val))
1072 ASET (font, FONT_SIZE_INDEX, val);
1073 else if (FONT_ENTITY_P (font))
1074 return -1;
1075 else
1077 double point_size = -1;
1079 font_assert (FONT_SPEC_P (font));
1080 p = f[XLFD_POINT_INDEX];
1081 if (*p == '[')
1082 point_size = parse_matrix (p);
1083 else if (isdigit (*p))
1084 point_size = atoi (p), point_size /= 10;
1085 if (point_size >= 0)
1086 ASET (font, FONT_SIZE_INDEX, make_float (point_size));
1090 val = INTERN_FIELD (XLFD_RESY_INDEX);
1091 if (! NILP (val) && ! INTEGERP (val))
1092 return -1;
1093 ASET (font, FONT_DPI_INDEX, val);
1094 val = INTERN_FIELD (XLFD_SPACING_INDEX);
1095 if (! NILP (val))
1097 val = font_prop_validate_spacing (QCspacing, val);
1098 if (! INTEGERP (val))
1099 return -1;
1100 ASET (font, FONT_SPACING_INDEX, val);
1102 p = f[XLFD_AVGWIDTH_INDEX];
1103 if (*p == '~')
1104 p++;
1105 val = font_intern_prop (p, f[XLFD_REGISTRY_INDEX] - 1 - p, 0);
1106 if (! NILP (val) && ! INTEGERP (val))
1107 return -1;
1108 ASET (font, FONT_AVGWIDTH_INDEX, val);
1110 else
1112 int wild_card_found = 0;
1113 Lisp_Object prop[XLFD_LAST_INDEX];
1115 if (FONT_ENTITY_P (font))
1116 return -1;
1117 for (j = 0; j < i; j++)
1119 if (*f[j] == '*')
1121 if (f[j][1] && f[j][1] != '-')
1122 return -1;
1123 prop[j] = Qnil;
1124 wild_card_found = 1;
1126 else if (j + 1 < i)
1127 prop[j] = INTERN_FIELD (j);
1128 else
1129 prop[j] = font_intern_prop (f[j], f[i] - f[j], 0);
1131 if (! wild_card_found)
1132 return -1;
1133 if (font_expand_wildcards (prop, i) < 0)
1134 return -1;
1136 ASET (font, FONT_FOUNDRY_INDEX, prop[XLFD_FOUNDRY_INDEX]);
1137 ASET (font, FONT_FAMILY_INDEX, prop[XLFD_FAMILY_INDEX]);
1138 for (i = XLFD_WEIGHT_INDEX, j = FONT_WEIGHT_INDEX;
1139 i <= XLFD_SWIDTH_INDEX; i++, j++)
1140 if (! NILP (prop[i]))
1142 if ((n = font_style_to_value (j, prop[i], 1)) < 0)
1143 return -1;
1144 ASET (font, j, make_number (n));
1146 ASET (font, FONT_ADSTYLE_INDEX, prop[XLFD_ADSTYLE_INDEX]);
1147 val = prop[XLFD_REGISTRY_INDEX];
1148 if (NILP (val))
1150 val = prop[XLFD_ENCODING_INDEX];
1151 if (! NILP (val))
1152 val = concat2 (build_string ("*-"), SYMBOL_NAME (val));
1154 else if (NILP (prop[XLFD_ENCODING_INDEX]))
1155 val = concat2 (SYMBOL_NAME (val), build_string ("-*"));
1156 else
1157 val = concat3 (SYMBOL_NAME (val), build_string ("-"),
1158 SYMBOL_NAME (prop[XLFD_ENCODING_INDEX]));
1159 if (! NILP (val))
1160 ASET (font, FONT_REGISTRY_INDEX, Fintern (val, Qnil));
1162 if (INTEGERP (prop[XLFD_PIXEL_INDEX]))
1163 ASET (font, FONT_SIZE_INDEX, prop[XLFD_PIXEL_INDEX]);
1164 else if (INTEGERP (prop[XLFD_POINT_INDEX]))
1166 double point_size = XINT (prop[XLFD_POINT_INDEX]);
1168 ASET (font, FONT_SIZE_INDEX, make_float (point_size / 10));
1171 if (INTEGERP (prop[XLFD_RESX_INDEX]))
1172 ASET (font, FONT_DPI_INDEX, prop[XLFD_RESY_INDEX]);
1173 if (! NILP (prop[XLFD_SPACING_INDEX]))
1175 val = font_prop_validate_spacing (QCspacing,
1176 prop[XLFD_SPACING_INDEX]);
1177 if (! INTEGERP (val))
1178 return -1;
1179 ASET (font, FONT_SPACING_INDEX, val);
1181 if (INTEGERP (prop[XLFD_AVGWIDTH_INDEX]))
1182 ASET (font, FONT_AVGWIDTH_INDEX, prop[XLFD_AVGWIDTH_INDEX]);
1185 return 0;
1188 /* Store XLFD name of FONT (font-spec or font-entity) in NAME (NBYTES
1189 length), and return the name length. If FONT_SIZE_INDEX of FONT is
1190 0, use PIXEL_SIZE instead. */
1192 ptrdiff_t
1193 font_unparse_xlfd (Lisp_Object font, int pixel_size, char *name, int nbytes)
1195 char *p;
1196 const char *f[XLFD_REGISTRY_INDEX + 1];
1197 Lisp_Object val;
1198 int i, j, len;
1200 font_assert (FONTP (font));
1202 for (i = FONT_FOUNDRY_INDEX, j = XLFD_FOUNDRY_INDEX; i <= FONT_REGISTRY_INDEX;
1203 i++, j++)
1205 if (i == FONT_ADSTYLE_INDEX)
1206 j = XLFD_ADSTYLE_INDEX;
1207 else if (i == FONT_REGISTRY_INDEX)
1208 j = XLFD_REGISTRY_INDEX;
1209 val = AREF (font, i);
1210 if (NILP (val))
1212 if (j == XLFD_REGISTRY_INDEX)
1213 f[j] = "*-*";
1214 else
1215 f[j] = "*";
1217 else
1219 if (SYMBOLP (val))
1220 val = SYMBOL_NAME (val);
1221 if (j == XLFD_REGISTRY_INDEX
1222 && ! strchr (SSDATA (val), '-'))
1224 /* Change "jisx0208*" and "jisx0208" to "jisx0208*-*". */
1225 ptrdiff_t alloc = SBYTES (val) + 4;
1226 if (nbytes <= alloc)
1227 return -1;
1228 f[j] = p = alloca (alloc);
1229 sprintf (p, "%s%s-*", SDATA (val),
1230 "*" + (SDATA (val)[SBYTES (val) - 1] == '*'));
1232 else
1233 f[j] = SSDATA (val);
1237 for (i = FONT_WEIGHT_INDEX, j = XLFD_WEIGHT_INDEX; i <= FONT_WIDTH_INDEX;
1238 i++, j++)
1240 val = font_style_symbolic (font, i, 0);
1241 if (NILP (val))
1242 f[j] = "*";
1243 else
1245 val = SYMBOL_NAME (val);
1246 f[j] = SSDATA (val);
1250 val = AREF (font, FONT_SIZE_INDEX);
1251 font_assert (NUMBERP (val) || NILP (val));
1252 if (INTEGERP (val))
1254 EMACS_INT v = XINT (val);
1255 if (v <= 0)
1256 v = pixel_size;
1257 if (v > 0)
1259 f[XLFD_PIXEL_INDEX] = p =
1260 alloca (sizeof "-*" + INT_STRLEN_BOUND (EMACS_INT));
1261 sprintf (p, "%"pI"d-*", v);
1263 else
1264 f[XLFD_PIXEL_INDEX] = "*-*";
1266 else if (FLOATP (val))
1268 double v = XFLOAT_DATA (val) * 10;
1269 f[XLFD_PIXEL_INDEX] = p = alloca (sizeof "*-" + 1 + DBL_MAX_10_EXP + 1);
1270 sprintf (p, "*-%.0f", v);
1272 else
1273 f[XLFD_PIXEL_INDEX] = "*-*";
1275 if (INTEGERP (AREF (font, FONT_DPI_INDEX)))
1277 EMACS_INT v = XINT (AREF (font, FONT_DPI_INDEX));
1278 f[XLFD_RESX_INDEX] = p =
1279 alloca (sizeof "-" + 2 * INT_STRLEN_BOUND (EMACS_INT));
1280 sprintf (p, "%"pI"d-%"pI"d", v, v);
1282 else
1283 f[XLFD_RESX_INDEX] = "*-*";
1284 if (INTEGERP (AREF (font, FONT_SPACING_INDEX)))
1286 EMACS_INT spacing = XINT (AREF (font, FONT_SPACING_INDEX));
1288 f[XLFD_SPACING_INDEX] = (spacing <= FONT_SPACING_PROPORTIONAL ? "p"
1289 : spacing <= FONT_SPACING_DUAL ? "d"
1290 : spacing <= FONT_SPACING_MONO ? "m"
1291 : "c");
1293 else
1294 f[XLFD_SPACING_INDEX] = "*";
1295 if (INTEGERP (AREF (font, FONT_AVGWIDTH_INDEX)))
1297 f[XLFD_AVGWIDTH_INDEX] = p = alloca (INT_BUFSIZE_BOUND (EMACS_INT));
1298 sprintf (p, "%"pI"d", XINT (AREF (font, FONT_AVGWIDTH_INDEX)));
1300 else
1301 f[XLFD_AVGWIDTH_INDEX] = "*";
1302 len = snprintf (name, nbytes, "-%s-%s-%s-%s-%s-%s-%s-%s-%s-%s-%s",
1303 f[XLFD_FOUNDRY_INDEX], f[XLFD_FAMILY_INDEX],
1304 f[XLFD_WEIGHT_INDEX], f[XLFD_SLANT_INDEX],
1305 f[XLFD_SWIDTH_INDEX], f[XLFD_ADSTYLE_INDEX],
1306 f[XLFD_PIXEL_INDEX], f[XLFD_RESX_INDEX],
1307 f[XLFD_SPACING_INDEX], f[XLFD_AVGWIDTH_INDEX],
1308 f[XLFD_REGISTRY_INDEX]);
1309 return len < nbytes ? len : -1;
1312 /* Parse NAME (null terminated) and store information in FONT
1313 (font-spec or font-entity). NAME is supplied in either the
1314 Fontconfig or GTK font name format. If NAME is successfully
1315 parsed, return 0. Otherwise return -1.
1317 The fontconfig format is
1319 FAMILY[-SIZE][:PROP1[=VAL1][:PROP2[=VAL2]...]]
1321 The GTK format is
1323 FAMILY [PROPS...] [SIZE]
1325 This function tries to guess which format it is. */
1327 static int
1328 font_parse_fcname (char *name, ptrdiff_t len, Lisp_Object font)
1330 char *p, *q;
1331 char *size_beg = NULL, *size_end = NULL;
1332 char *props_beg = NULL, *family_end = NULL;
1334 if (len == 0)
1335 return -1;
1337 for (p = name; *p; p++)
1339 if (*p == '\\' && p[1])
1340 p++;
1341 else if (*p == ':')
1343 props_beg = family_end = p;
1344 break;
1346 else if (*p == '-')
1348 int decimal = 0, size_found = 1;
1349 for (q = p + 1; *q && *q != ':'; q++)
1350 if (! isdigit (*q))
1352 if (*q != '.' || decimal)
1354 size_found = 0;
1355 break;
1357 decimal = 1;
1359 if (size_found)
1361 family_end = p;
1362 size_beg = p + 1;
1363 size_end = q;
1364 break;
1369 if (family_end)
1371 Lisp_Object extra_props = Qnil;
1373 /* A fontconfig name with size and/or property data. */
1374 if (family_end > name)
1376 Lisp_Object family;
1377 family = font_intern_prop (name, family_end - name, 1);
1378 ASET (font, FONT_FAMILY_INDEX, family);
1380 if (size_beg)
1382 double point_size = strtod (size_beg, &size_end);
1383 ASET (font, FONT_SIZE_INDEX, make_float (point_size));
1384 if (*size_end == ':' && size_end[1])
1385 props_beg = size_end;
1387 if (props_beg)
1389 /* Now parse ":KEY=VAL" patterns. */
1390 Lisp_Object val;
1392 for (p = props_beg; *p; p = q)
1394 for (q = p + 1; *q && *q != '=' && *q != ':'; q++);
1395 if (*q != '=')
1397 /* Must be an enumerated value. */
1398 ptrdiff_t word_len;
1399 p = p + 1;
1400 word_len = q - p;
1401 val = font_intern_prop (p, q - p, 1);
1403 #define PROP_MATCH(STR) (word_len == strlen (STR) \
1404 && memcmp (p, STR, strlen (STR)) == 0)
1406 if (PROP_MATCH ("light")
1407 || PROP_MATCH ("medium")
1408 || PROP_MATCH ("demibold")
1409 || PROP_MATCH ("bold")
1410 || PROP_MATCH ("black"))
1411 FONT_SET_STYLE (font, FONT_WEIGHT_INDEX, val);
1412 else if (PROP_MATCH ("roman")
1413 || PROP_MATCH ("italic")
1414 || PROP_MATCH ("oblique"))
1415 FONT_SET_STYLE (font, FONT_SLANT_INDEX, val);
1416 else if (PROP_MATCH ("charcell"))
1417 ASET (font, FONT_SPACING_INDEX,
1418 make_number (FONT_SPACING_CHARCELL));
1419 else if (PROP_MATCH ("mono"))
1420 ASET (font, FONT_SPACING_INDEX,
1421 make_number (FONT_SPACING_MONO));
1422 else if (PROP_MATCH ("proportional"))
1423 ASET (font, FONT_SPACING_INDEX,
1424 make_number (FONT_SPACING_PROPORTIONAL));
1425 #undef PROP_MATCH
1427 else
1429 /* KEY=VAL pairs */
1430 Lisp_Object key;
1431 int prop;
1433 if (q - p == 10 && memcmp (p + 1, "pixelsize", 9) == 0)
1434 prop = FONT_SIZE_INDEX;
1435 else
1437 key = font_intern_prop (p, q - p, 1);
1438 prop = get_font_prop_index (key);
1441 p = q + 1;
1442 for (q = p; *q && *q != ':'; q++);
1443 val = font_intern_prop (p, q - p, 0);
1445 if (prop >= FONT_FOUNDRY_INDEX
1446 && prop < FONT_EXTRA_INDEX)
1447 ASET (font, prop, font_prop_validate (prop, Qnil, val));
1448 else
1450 extra_props = nconc2 (extra_props,
1451 Fcons (Fcons (key, val), Qnil));
1454 p = q;
1458 if (! NILP (extra_props))
1460 struct font_driver_list *driver_list = font_driver_list;
1461 for ( ; driver_list; driver_list = driver_list->next)
1462 if (driver_list->driver->filter_properties)
1463 (*driver_list->driver->filter_properties) (font, extra_props);
1467 else
1469 /* Either a fontconfig-style name with no size and property
1470 data, or a GTK-style name. */
1471 Lisp_Object weight = Qnil, slant = Qnil;
1472 Lisp_Object width = Qnil, size = Qnil;
1473 char *word_start;
1474 ptrdiff_t word_len;
1476 /* Scan backwards from the end, looking for a size. */
1477 for (p = name + len - 1; p >= name; p--)
1478 if (!isdigit (*p))
1479 break;
1481 if ((p < name + len - 1) && ((p + 1 == name) || *p == ' '))
1482 /* Found a font size. */
1483 size = make_float (strtod (p + 1, NULL));
1484 else
1485 p = name + len;
1487 /* Now P points to the termination of the string, sans size.
1488 Scan backwards, looking for font properties. */
1489 for (; p > name; p = q)
1491 for (q = p - 1; q >= name; q--)
1493 if (q > name && *(q-1) == '\\')
1494 --q; /* Skip quoting backslashes. */
1495 else if (*q == ' ')
1496 break;
1499 word_start = q + 1;
1500 word_len = p - word_start;
1502 #define PROP_MATCH(STR) \
1503 (word_len == strlen (STR) \
1504 && memcmp (word_start, STR, strlen (STR)) == 0)
1505 #define PROP_SAVE(VAR, STR) \
1506 (VAR = NILP (VAR) ? font_intern_prop (STR, strlen (STR), 1) : VAR)
1508 if (PROP_MATCH ("Ultra-Light"))
1509 PROP_SAVE (weight, "ultra-light");
1510 else if (PROP_MATCH ("Light"))
1511 PROP_SAVE (weight, "light");
1512 else if (PROP_MATCH ("Book"))
1513 PROP_SAVE (weight, "book");
1514 else if (PROP_MATCH ("Medium"))
1515 PROP_SAVE (weight, "medium");
1516 else if (PROP_MATCH ("Semi-Bold"))
1517 PROP_SAVE (weight, "semi-bold");
1518 else if (PROP_MATCH ("Bold"))
1519 PROP_SAVE (weight, "bold");
1520 else if (PROP_MATCH ("Italic"))
1521 PROP_SAVE (slant, "italic");
1522 else if (PROP_MATCH ("Oblique"))
1523 PROP_SAVE (slant, "oblique");
1524 else if (PROP_MATCH ("Semi-Condensed"))
1525 PROP_SAVE (width, "semi-condensed");
1526 else if (PROP_MATCH ("Condensed"))
1527 PROP_SAVE (width, "condensed");
1528 /* An unknown word must be part of the font name. */
1529 else
1531 family_end = p;
1532 break;
1535 #undef PROP_MATCH
1536 #undef PROP_SAVE
1538 if (family_end)
1539 ASET (font, FONT_FAMILY_INDEX,
1540 font_intern_prop (name, family_end - name, 1));
1541 if (!NILP (size))
1542 ASET (font, FONT_SIZE_INDEX, size);
1543 if (!NILP (weight))
1544 FONT_SET_STYLE (font, FONT_WEIGHT_INDEX, weight);
1545 if (!NILP (slant))
1546 FONT_SET_STYLE (font, FONT_SLANT_INDEX, slant);
1547 if (!NILP (width))
1548 FONT_SET_STYLE (font, FONT_WIDTH_INDEX, width);
1551 return 0;
1554 /* Store fontconfig's font name of FONT (font-spec or font-entity) in
1555 NAME (NBYTES length), and return the name length. If
1556 FONT_SIZE_INDEX of FONT is 0, use PIXEL_SIZE instead. */
1559 font_unparse_fcname (Lisp_Object font, int pixel_size, char *name, int nbytes)
1561 Lisp_Object family, foundry;
1562 Lisp_Object val;
1563 int point_size;
1564 int i;
1565 char *p;
1566 char *lim;
1567 Lisp_Object styles[3];
1568 const char *style_names[3] = { "weight", "slant", "width" };
1570 family = AREF (font, FONT_FAMILY_INDEX);
1571 if (! NILP (family))
1573 if (SYMBOLP (family))
1574 family = SYMBOL_NAME (family);
1575 else
1576 family = Qnil;
1579 val = AREF (font, FONT_SIZE_INDEX);
1580 if (INTEGERP (val))
1582 if (XINT (val) != 0)
1583 pixel_size = XINT (val);
1584 point_size = -1;
1586 else
1588 if (! FLOATP (val))
1589 abort ();
1590 pixel_size = -1;
1591 point_size = (int) XFLOAT_DATA (val);
1594 foundry = AREF (font, FONT_FOUNDRY_INDEX);
1595 if (! NILP (foundry))
1597 if (SYMBOLP (foundry))
1598 foundry = SYMBOL_NAME (foundry);
1599 else
1600 foundry = Qnil;
1603 for (i = 0; i < 3; i++)
1604 styles[i] = font_style_symbolic (font, FONT_WEIGHT_INDEX + i, 0);
1606 p = name;
1607 lim = name + nbytes;
1608 if (! NILP (family))
1610 int len = snprintf (p, lim - p, "%s", SSDATA (family));
1611 if (! (0 <= len && len < lim - p))
1612 return -1;
1613 p += len;
1615 if (point_size > 0)
1617 int len = snprintf (p, lim - p, "-%d" + (p == name), point_size);
1618 if (! (0 <= len && len < lim - p))
1619 return -1;
1620 p += len;
1622 else if (pixel_size > 0)
1624 int len = snprintf (p, lim - p, ":pixelsize=%d", pixel_size);
1625 if (! (0 <= len && len < lim - p))
1626 return -1;
1627 p += len;
1629 if (! NILP (AREF (font, FONT_FOUNDRY_INDEX)))
1631 int len = snprintf (p, lim - p, ":foundry=%s",
1632 SSDATA (SYMBOL_NAME (AREF (font,
1633 FONT_FOUNDRY_INDEX))));
1634 if (! (0 <= len && len < lim - p))
1635 return -1;
1636 p += len;
1638 for (i = 0; i < 3; i++)
1639 if (! NILP (styles[i]))
1641 int len = snprintf (p, lim - p, ":%s=%s", style_names[i],
1642 SSDATA (SYMBOL_NAME (styles[i])));
1643 if (! (0 <= len && len < lim - p))
1644 return -1;
1645 p += len;
1648 if (INTEGERP (AREF (font, FONT_DPI_INDEX)))
1650 int len = snprintf (p, lim - p, ":dpi=%"pI"d",
1651 XINT (AREF (font, FONT_DPI_INDEX)));
1652 if (! (0 <= len && len < lim - p))
1653 return -1;
1654 p += len;
1657 if (INTEGERP (AREF (font, FONT_SPACING_INDEX)))
1659 int len = snprintf (p, lim - p, ":spacing=%"pI"d",
1660 XINT (AREF (font, FONT_SPACING_INDEX)));
1661 if (! (0 <= len && len < lim - p))
1662 return -1;
1663 p += len;
1666 if (INTEGERP (AREF (font, FONT_AVGWIDTH_INDEX)))
1668 int len = snprintf (p, lim - p,
1669 (XINT (AREF (font, FONT_AVGWIDTH_INDEX)) == 0
1670 ? ":scalable=true"
1671 : ":scalable=false"));
1672 if (! (0 <= len && len < lim - p))
1673 return -1;
1674 p += len;
1677 return (p - name);
1680 /* Parse NAME (null terminated) and store information in FONT
1681 (font-spec or font-entity). If NAME is successfully parsed, return
1682 0. Otherwise return -1. */
1684 static int
1685 font_parse_name (char *name, ptrdiff_t namelen, Lisp_Object font)
1687 if (name[0] == '-' || strchr (name, '*') || strchr (name, '?'))
1688 return font_parse_xlfd (name, namelen, font);
1689 return font_parse_fcname (name, namelen, font);
1693 /* Merge FAMILY and REGISTRY into FONT_SPEC. FAMILY may have the form
1694 "FAMILY-FOUNDRY". REGISTRY may not contain charset-encoding
1695 part. */
1697 void
1698 font_parse_family_registry (Lisp_Object family, Lisp_Object registry, Lisp_Object font_spec)
1700 int len;
1701 char *p0, *p1;
1703 if (! NILP (family)
1704 && NILP (AREF (font_spec, FONT_FAMILY_INDEX)))
1706 CHECK_STRING (family);
1707 len = SBYTES (family);
1708 p0 = SSDATA (family);
1709 p1 = strchr (p0, '-');
1710 if (p1)
1712 if ((*p0 != '*' && p1 - p0 > 0)
1713 && NILP (AREF (font_spec, FONT_FOUNDRY_INDEX)))
1714 Ffont_put (font_spec, QCfoundry, font_intern_prop (p0, p1 - p0, 1));
1715 p1++;
1716 len -= p1 - p0;
1717 Ffont_put (font_spec, QCfamily, font_intern_prop (p1, len, 1));
1719 else
1720 ASET (font_spec, FONT_FAMILY_INDEX, Fintern (family, Qnil));
1722 if (! NILP (registry))
1724 /* Convert "XXX" and "XXX*" to "XXX*-*". */
1725 CHECK_STRING (registry);
1726 len = SBYTES (registry);
1727 p0 = SSDATA (registry);
1728 p1 = strchr (p0, '-');
1729 if (! p1)
1731 if (SDATA (registry)[len - 1] == '*')
1732 registry = concat2 (registry, build_string ("-*"));
1733 else
1734 registry = concat2 (registry, build_string ("*-*"));
1736 registry = Fdowncase (registry);
1737 ASET (font_spec, FONT_REGISTRY_INDEX, Fintern (registry, Qnil));
1742 /* This part (through the next ^L) is still experimental and not
1743 tested much. We may drastically change codes. */
1745 /* OTF handler */
1747 #if 0
1749 #define LGSTRING_HEADER_SIZE 6
1750 #define LGSTRING_GLYPH_SIZE 8
1752 static int
1753 check_gstring (Lisp_Object gstring)
1755 Lisp_Object val;
1756 ptrdiff_t i;
1757 int j;
1759 CHECK_VECTOR (gstring);
1760 val = AREF (gstring, 0);
1761 CHECK_VECTOR (val);
1762 if (ASIZE (val) < LGSTRING_HEADER_SIZE)
1763 goto err;
1764 CHECK_FONT_OBJECT (LGSTRING_FONT (gstring));
1765 if (!NILP (LGSTRING_SLOT (gstring, LGSTRING_IX_LBEARING)))
1766 CHECK_NUMBER (LGSTRING_SLOT (gstring, LGSTRING_IX_LBEARING));
1767 if (!NILP (LGSTRING_SLOT (gstring, LGSTRING_IX_RBEARING)))
1768 CHECK_NUMBER (LGSTRING_SLOT (gstring, LGSTRING_IX_RBEARING));
1769 if (!NILP (LGSTRING_SLOT (gstring, LGSTRING_IX_WIDTH)))
1770 CHECK_NATNUM (LGSTRING_SLOT (gstring, LGSTRING_IX_WIDTH));
1771 if (!NILP (LGSTRING_SLOT (gstring, LGSTRING_IX_ASCENT)))
1772 CHECK_NUMBER (LGSTRING_SLOT (gstring, LGSTRING_IX_ASCENT));
1773 if (!NILP (LGSTRING_SLOT (gstring, LGSTRING_IX_ASCENT)))
1774 CHECK_NUMBER (LGSTRING_SLOT (gstring, LGSTRING_IX_ASCENT));
1776 for (i = 0; i < LGSTRING_GLYPH_LEN (gstring); i++)
1778 val = LGSTRING_GLYPH (gstring, i);
1779 CHECK_VECTOR (val);
1780 if (ASIZE (val) < LGSTRING_GLYPH_SIZE)
1781 goto err;
1782 if (NILP (AREF (val, LGLYPH_IX_CHAR)))
1783 break;
1784 CHECK_NATNUM (AREF (val, LGLYPH_IX_FROM));
1785 CHECK_NATNUM (AREF (val, LGLYPH_IX_TO));
1786 CHECK_CHARACTER (AREF (val, LGLYPH_IX_CHAR));
1787 if (!NILP (AREF (val, LGLYPH_IX_CODE)))
1788 CHECK_NATNUM (AREF (val, LGLYPH_IX_CODE));
1789 if (!NILP (AREF (val, LGLYPH_IX_WIDTH)))
1790 CHECK_NATNUM (AREF (val, LGLYPH_IX_WIDTH));
1791 if (!NILP (AREF (val, LGLYPH_IX_ADJUSTMENT)))
1793 val = AREF (val, LGLYPH_IX_ADJUSTMENT);
1794 CHECK_VECTOR (val);
1795 if (ASIZE (val) < 3)
1796 goto err;
1797 for (j = 0; j < 3; j++)
1798 CHECK_NUMBER (AREF (val, j));
1801 return i;
1802 err:
1803 error ("Invalid glyph-string format");
1804 return -1;
1807 static void
1808 check_otf_features (Lisp_Object otf_features)
1810 Lisp_Object val;
1812 CHECK_CONS (otf_features);
1813 CHECK_SYMBOL (XCAR (otf_features));
1814 otf_features = XCDR (otf_features);
1815 CHECK_CONS (otf_features);
1816 CHECK_SYMBOL (XCAR (otf_features));
1817 otf_features = XCDR (otf_features);
1818 for (val = Fcar (otf_features); CONSP (val); val = XCDR (val))
1820 CHECK_SYMBOL (XCAR (val));
1821 if (SBYTES (SYMBOL_NAME (XCAR (val))) > 4)
1822 error ("Invalid OTF GSUB feature: %s",
1823 SDATA (SYMBOL_NAME (XCAR (val))));
1825 otf_features = XCDR (otf_features);
1826 for (val = Fcar (otf_features); CONSP (val); val = XCDR (val))
1828 CHECK_SYMBOL (XCAR (val));
1829 if (SBYTES (SYMBOL_NAME (XCAR (val))) > 4)
1830 error ("Invalid OTF GPOS feature: %s",
1831 SDATA (SYMBOL_NAME (XCAR (val))));
1835 #ifdef HAVE_LIBOTF
1836 #include <otf.h>
1838 Lisp_Object otf_list;
1840 static Lisp_Object
1841 otf_tag_symbol (OTF_Tag tag)
1843 char name[5];
1845 OTF_tag_name (tag, name);
1846 return Fintern (make_unibyte_string (name, 4), Qnil);
1849 static OTF *
1850 otf_open (Lisp_Object file)
1852 Lisp_Object val = Fassoc (file, otf_list);
1853 OTF *otf;
1855 if (! NILP (val))
1856 otf = XSAVE_VALUE (XCDR (val))->pointer;
1857 else
1859 otf = STRINGP (file) ? OTF_open (SSDATA (file)) : NULL;
1860 val = make_save_value (otf, 0);
1861 otf_list = Fcons (Fcons (file, val), otf_list);
1863 return otf;
1867 /* Return a list describing which scripts/languages FONT supports by
1868 which GSUB/GPOS features of OpenType tables. See the comment of
1869 (struct font_driver).otf_capability. */
1871 Lisp_Object
1872 font_otf_capability (struct font *font)
1874 OTF *otf;
1875 Lisp_Object capability = Fcons (Qnil, Qnil);
1876 int i;
1878 otf = otf_open (font->props[FONT_FILE_INDEX]);
1879 if (! otf)
1880 return Qnil;
1881 for (i = 0; i < 2; i++)
1883 OTF_GSUB_GPOS *gsub_gpos;
1884 Lisp_Object script_list = Qnil;
1885 int j;
1887 if (OTF_get_features (otf, i == 0) < 0)
1888 continue;
1889 gsub_gpos = i == 0 ? otf->gsub : otf->gpos;
1890 for (j = gsub_gpos->ScriptList.ScriptCount - 1; j >= 0; j--)
1892 OTF_Script *script = gsub_gpos->ScriptList.Script + j;
1893 Lisp_Object langsys_list = Qnil;
1894 Lisp_Object script_tag = otf_tag_symbol (script->ScriptTag);
1895 int k;
1897 for (k = script->LangSysCount; k >= 0; k--)
1899 OTF_LangSys *langsys;
1900 Lisp_Object feature_list = Qnil;
1901 Lisp_Object langsys_tag;
1902 int l;
1904 if (k == script->LangSysCount)
1906 langsys = &script->DefaultLangSys;
1907 langsys_tag = Qnil;
1909 else
1911 langsys = script->LangSys + k;
1912 langsys_tag
1913 = otf_tag_symbol (script->LangSysRecord[k].LangSysTag);
1915 for (l = langsys->FeatureCount - 1; l >= 0; l--)
1917 OTF_Feature *feature
1918 = gsub_gpos->FeatureList.Feature + langsys->FeatureIndex[l];
1919 Lisp_Object feature_tag
1920 = otf_tag_symbol (feature->FeatureTag);
1922 feature_list = Fcons (feature_tag, feature_list);
1924 langsys_list = Fcons (Fcons (langsys_tag, feature_list),
1925 langsys_list);
1927 script_list = Fcons (Fcons (script_tag, langsys_list),
1928 script_list);
1931 if (i == 0)
1932 XSETCAR (capability, script_list);
1933 else
1934 XSETCDR (capability, script_list);
1937 return capability;
1940 /* Parse OTF features in SPEC and write a proper features spec string
1941 in FEATURES for the call of OTF_drive_gsub/gpos (of libotf). It is
1942 assured that the sufficient memory has already allocated for
1943 FEATURES. */
1945 static void
1946 generate_otf_features (Lisp_Object spec, char *features)
1948 Lisp_Object val;
1949 char *p;
1950 int asterisk;
1952 p = features;
1953 *p = '\0';
1954 for (asterisk = 0; CONSP (spec); spec = XCDR (spec))
1956 val = XCAR (spec);
1957 CHECK_SYMBOL (val);
1958 if (p > features)
1959 *p++ = ',';
1960 if (SREF (SYMBOL_NAME (val), 0) == '*')
1962 asterisk = 1;
1963 *p++ = '*';
1965 else if (! asterisk)
1967 val = SYMBOL_NAME (val);
1968 p += esprintf (p, "%s", SDATA (val));
1970 else
1972 val = SYMBOL_NAME (val);
1973 p += esprintf (p, "~%s", SDATA (val));
1976 if (CONSP (spec))
1977 error ("OTF spec too long");
1980 Lisp_Object
1981 font_otf_DeviceTable (OTF_DeviceTable *device_table)
1983 int len = device_table->StartSize - device_table->EndSize + 1;
1985 return Fcons (make_number (len),
1986 make_unibyte_string (device_table->DeltaValue, len));
1989 Lisp_Object
1990 font_otf_ValueRecord (int value_format, OTF_ValueRecord *value_record)
1992 Lisp_Object val = Fmake_vector (make_number (8), Qnil);
1994 if (value_format & OTF_XPlacement)
1995 ASET (val, 0, make_number (value_record->XPlacement));
1996 if (value_format & OTF_YPlacement)
1997 ASET (val, 1, make_number (value_record->YPlacement));
1998 if (value_format & OTF_XAdvance)
1999 ASET (val, 2, make_number (value_record->XAdvance));
2000 if (value_format & OTF_YAdvance)
2001 ASET (val, 3, make_number (value_record->YAdvance));
2002 if (value_format & OTF_XPlaDevice)
2003 ASET (val, 4, font_otf_DeviceTable (&value_record->XPlaDevice));
2004 if (value_format & OTF_YPlaDevice)
2005 ASET (val, 4, font_otf_DeviceTable (&value_record->YPlaDevice));
2006 if (value_format & OTF_XAdvDevice)
2007 ASET (val, 4, font_otf_DeviceTable (&value_record->XAdvDevice));
2008 if (value_format & OTF_YAdvDevice)
2009 ASET (val, 4, font_otf_DeviceTable (&value_record->YAdvDevice));
2010 return val;
2013 Lisp_Object
2014 font_otf_Anchor (OTF_Anchor *anchor)
2016 Lisp_Object val;
2018 val = Fmake_vector (make_number (anchor->AnchorFormat + 1), Qnil);
2019 ASET (val, 0, make_number (anchor->XCoordinate));
2020 ASET (val, 1, make_number (anchor->YCoordinate));
2021 if (anchor->AnchorFormat == 2)
2022 ASET (val, 2, make_number (anchor->f.f1.AnchorPoint));
2023 else
2025 ASET (val, 3, font_otf_DeviceTable (&anchor->f.f2.XDeviceTable));
2026 ASET (val, 4, font_otf_DeviceTable (&anchor->f.f2.YDeviceTable));
2028 return val;
2030 #endif /* HAVE_LIBOTF */
2031 #endif /* 0 */
2034 /* Font sorting */
2036 static unsigned font_score (Lisp_Object, Lisp_Object *);
2037 static int font_compare (const void *, const void *);
2038 static Lisp_Object font_sort_entities (Lisp_Object, Lisp_Object,
2039 Lisp_Object, int);
2041 static double
2042 font_rescale_ratio (Lisp_Object font_entity)
2044 Lisp_Object tail, elt;
2045 Lisp_Object name = Qnil;
2047 for (tail = Vface_font_rescale_alist; CONSP (tail); tail = XCDR (tail))
2049 elt = XCAR (tail);
2050 if (FLOATP (XCDR (elt)))
2052 if (STRINGP (XCAR (elt)))
2054 if (NILP (name))
2055 name = Ffont_xlfd_name (font_entity, Qnil);
2056 if (fast_string_match_ignore_case (XCAR (elt), name) >= 0)
2057 return XFLOAT_DATA (XCDR (elt));
2059 else if (FONT_SPEC_P (XCAR (elt)))
2061 if (font_match_p (XCAR (elt), font_entity))
2062 return XFLOAT_DATA (XCDR (elt));
2066 return 1.0;
2069 /* We sort fonts by scoring each of them against a specified
2070 font-spec. The score value is 32 bit (`unsigned'), and the smaller
2071 the value is, the closer the font is to the font-spec.
2073 The lowest 2 bits of the score are used for driver type. The font
2074 available by the most preferred font driver is 0.
2076 The 4 7-bit fields in the higher 28 bits are used for numeric properties
2077 WEIGHT, SLANT, WIDTH, and SIZE. */
2079 /* How many bits to shift to store the difference value of each font
2080 property in a score. Note that floats for FONT_TYPE_INDEX and
2081 FONT_REGISTRY_INDEX are not used. */
2082 static int sort_shift_bits[FONT_SIZE_INDEX + 1];
2084 /* Score font-entity ENTITY against properties of font-spec SPEC_PROP.
2085 The return value indicates how different ENTITY is compared with
2086 SPEC_PROP. */
2088 static unsigned
2089 font_score (Lisp_Object entity, Lisp_Object *spec_prop)
2091 unsigned score = 0;
2092 int i;
2094 /* Score three style numeric fields. Maximum difference is 127. */
2095 for (i = FONT_WEIGHT_INDEX; i <= FONT_WIDTH_INDEX; i++)
2096 if (! NILP (spec_prop[i]) && ! EQ (AREF (entity, i), spec_prop[i]))
2098 EMACS_INT diff = ((XINT (AREF (entity, i)) >> 8)
2099 - (XINT (spec_prop[i]) >> 8));
2100 if (diff < 0)
2101 diff = - diff;
2102 score |= min (diff, 127) << sort_shift_bits[i];
2105 /* Score the size. Maximum difference is 127. */
2106 i = FONT_SIZE_INDEX;
2107 if (! NILP (spec_prop[FONT_SIZE_INDEX])
2108 && XINT (AREF (entity, FONT_SIZE_INDEX)) > 0)
2110 /* We use the higher 6-bit for the actual size difference. The
2111 lowest bit is set if the DPI is different. */
2112 EMACS_INT diff;
2113 EMACS_INT pixel_size = XINT (spec_prop[FONT_SIZE_INDEX]);
2115 if (CONSP (Vface_font_rescale_alist))
2116 pixel_size *= font_rescale_ratio (entity);
2117 diff = pixel_size - XINT (AREF (entity, FONT_SIZE_INDEX));
2118 if (diff < 0)
2119 diff = - diff;
2120 diff <<= 1;
2121 if (! NILP (spec_prop[FONT_DPI_INDEX])
2122 && ! EQ (spec_prop[FONT_DPI_INDEX], AREF (entity, FONT_DPI_INDEX)))
2123 diff |= 1;
2124 if (! NILP (spec_prop[FONT_AVGWIDTH_INDEX])
2125 && ! EQ (spec_prop[FONT_AVGWIDTH_INDEX], AREF (entity, FONT_AVGWIDTH_INDEX)))
2126 diff |= 1;
2127 score |= min (diff, 127) << sort_shift_bits[FONT_SIZE_INDEX];
2130 return score;
2134 /* Concatenate all elements of LIST into one vector. LIST is a list
2135 of font-entity vectors. */
2137 static Lisp_Object
2138 font_vconcat_entity_vectors (Lisp_Object list)
2140 int nargs = XINT (Flength (list));
2141 Lisp_Object *args = alloca (word_size * nargs);
2142 int i;
2144 for (i = 0; i < nargs; i++, list = XCDR (list))
2145 args[i] = XCAR (list);
2146 return Fvconcat (nargs, args);
2150 /* The structure for elements being sorted by qsort. */
2151 struct font_sort_data
2153 unsigned score;
2154 int font_driver_preference;
2155 Lisp_Object entity;
2159 /* The comparison function for qsort. */
2161 static int
2162 font_compare (const void *d1, const void *d2)
2164 const struct font_sort_data *data1 = d1;
2165 const struct font_sort_data *data2 = d2;
2167 if (data1->score < data2->score)
2168 return -1;
2169 else if (data1->score > data2->score)
2170 return 1;
2171 return (data1->font_driver_preference - data2->font_driver_preference);
2175 /* Sort each font-entity vector in LIST by closeness to font-spec PREFER.
2176 If PREFER specifies a point-size, calculate the corresponding
2177 pixel-size from QCdpi property of PREFER or from the Y-resolution
2178 of FRAME before sorting.
2180 If BEST-ONLY is nonzero, return the best matching entity (that
2181 supports the character BEST-ONLY if BEST-ONLY is positive, or any
2182 if BEST-ONLY is negative). Otherwise, return the sorted result as
2183 a single vector of font-entities.
2185 This function does no optimization for the case that the total
2186 number of elements is 1. The caller should avoid calling this in
2187 such a case. */
2189 static Lisp_Object
2190 font_sort_entities (Lisp_Object list, Lisp_Object prefer, Lisp_Object frame, int best_only)
2192 Lisp_Object prefer_prop[FONT_SPEC_MAX];
2193 int len, maxlen, i;
2194 struct font_sort_data *data;
2195 unsigned best_score;
2196 Lisp_Object best_entity;
2197 struct frame *f = XFRAME (frame);
2198 Lisp_Object tail, vec IF_LINT (= Qnil);
2199 USE_SAFE_ALLOCA;
2201 for (i = FONT_WEIGHT_INDEX; i <= FONT_AVGWIDTH_INDEX; i++)
2202 prefer_prop[i] = AREF (prefer, i);
2203 if (FLOATP (prefer_prop[FONT_SIZE_INDEX]))
2204 prefer_prop[FONT_SIZE_INDEX]
2205 = make_number (font_pixel_size (XFRAME (frame), prefer));
2207 if (NILP (XCDR (list)))
2209 /* What we have to take care of is this single vector. */
2210 vec = XCAR (list);
2211 maxlen = ASIZE (vec);
2213 else if (best_only)
2215 /* We don't have to perform sort, so there's no need of creating
2216 a single vector. But, we must find the length of the longest
2217 vector. */
2218 maxlen = 0;
2219 for (tail = list; CONSP (tail); tail = XCDR (tail))
2220 if (maxlen < ASIZE (XCAR (tail)))
2221 maxlen = ASIZE (XCAR (tail));
2223 else
2225 /* We have to create a single vector to sort it. */
2226 vec = font_vconcat_entity_vectors (list);
2227 maxlen = ASIZE (vec);
2230 data = SAFE_ALLOCA (maxlen * sizeof *data);
2231 best_score = 0xFFFFFFFF;
2232 best_entity = Qnil;
2234 for (tail = list; CONSP (tail); tail = XCDR (tail))
2236 int font_driver_preference = 0;
2237 Lisp_Object current_font_driver;
2239 if (best_only)
2240 vec = XCAR (tail);
2241 len = ASIZE (vec);
2243 /* We are sure that the length of VEC > 0. */
2244 current_font_driver = AREF (AREF (vec, 0), FONT_TYPE_INDEX);
2245 /* Score the elements. */
2246 for (i = 0; i < len; i++)
2248 data[i].entity = AREF (vec, i);
2249 data[i].score
2250 = ((best_only <= 0 || font_has_char (f, data[i].entity, best_only)
2251 > 0)
2252 ? font_score (data[i].entity, prefer_prop)
2253 : 0xFFFFFFFF);
2254 if (best_only && best_score > data[i].score)
2256 best_score = data[i].score;
2257 best_entity = data[i].entity;
2258 if (best_score == 0)
2259 break;
2261 if (! EQ (current_font_driver, AREF (AREF (vec, i), FONT_TYPE_INDEX)))
2263 current_font_driver = AREF (AREF (vec, i), FONT_TYPE_INDEX);
2264 font_driver_preference++;
2266 data[i].font_driver_preference = font_driver_preference;
2269 /* Sort if necessary. */
2270 if (! best_only)
2272 qsort (data, len, sizeof *data, font_compare);
2273 for (i = 0; i < len; i++)
2274 ASET (vec, i, data[i].entity);
2275 break;
2277 else
2278 vec = best_entity;
2281 SAFE_FREE ();
2283 FONT_ADD_LOG ("sort-by", prefer, vec);
2284 return vec;
2288 /* API of Font Service Layer. */
2290 /* Reflect ORDER (see the variable font_sort_order in xfaces.c) to
2291 sort_shift_bits. Finternal_set_font_selection_order calls this
2292 function with font_sort_order after setting up it. */
2294 void
2295 font_update_sort_order (int *order)
2297 int i, shift_bits;
2299 for (i = 0, shift_bits = 23; i < 4; i++, shift_bits -= 7)
2301 int xlfd_idx = order[i];
2303 if (xlfd_idx == XLFD_WEIGHT_INDEX)
2304 sort_shift_bits[FONT_WEIGHT_INDEX] = shift_bits;
2305 else if (xlfd_idx == XLFD_SLANT_INDEX)
2306 sort_shift_bits[FONT_SLANT_INDEX] = shift_bits;
2307 else if (xlfd_idx == XLFD_SWIDTH_INDEX)
2308 sort_shift_bits[FONT_WIDTH_INDEX] = shift_bits;
2309 else
2310 sort_shift_bits[FONT_SIZE_INDEX] = shift_bits;
2314 static int
2315 font_check_otf_features (Lisp_Object script, Lisp_Object langsys, Lisp_Object features, Lisp_Object table)
2317 Lisp_Object val;
2318 int negative;
2320 table = assq_no_quit (script, table);
2321 if (NILP (table))
2322 return 0;
2323 table = XCDR (table);
2324 if (! NILP (langsys))
2326 table = assq_no_quit (langsys, table);
2327 if (NILP (table))
2328 return 0;
2330 else
2332 val = assq_no_quit (Qnil, table);
2333 if (NILP (val))
2334 table = XCAR (table);
2335 else
2336 table = val;
2338 table = XCDR (table);
2339 for (negative = 0; CONSP (features); features = XCDR (features))
2341 if (NILP (XCAR (features)))
2343 negative = 1;
2344 continue;
2346 if (NILP (Fmemq (XCAR (features), table)) != negative)
2347 return 0;
2349 return 1;
2352 /* Check if OTF_CAPABILITY satisfies SPEC (otf-spec). */
2354 static int
2355 font_check_otf (Lisp_Object spec, Lisp_Object otf_capability)
2357 Lisp_Object script, langsys = Qnil, gsub = Qnil, gpos = Qnil;
2359 script = XCAR (spec);
2360 spec = XCDR (spec);
2361 if (! NILP (spec))
2363 langsys = XCAR (spec);
2364 spec = XCDR (spec);
2365 if (! NILP (spec))
2367 gsub = XCAR (spec);
2368 spec = XCDR (spec);
2369 if (! NILP (spec))
2370 gpos = XCAR (spec);
2374 if (! NILP (gsub) && ! font_check_otf_features (script, langsys, gsub,
2375 XCAR (otf_capability)))
2376 return 0;
2377 if (! NILP (gpos) && ! font_check_otf_features (script, langsys, gpos,
2378 XCDR (otf_capability)))
2379 return 0;
2380 return 1;
2385 /* Check if FONT (font-entity or font-object) matches with the font
2386 specification SPEC. */
2389 font_match_p (Lisp_Object spec, Lisp_Object font)
2391 Lisp_Object prop[FONT_SPEC_MAX], *props;
2392 Lisp_Object extra, font_extra;
2393 int i;
2395 for (i = FONT_FOUNDRY_INDEX; i <= FONT_REGISTRY_INDEX; i++)
2396 if (! NILP (AREF (spec, i))
2397 && ! NILP (AREF (font, i))
2398 && ! EQ (AREF (spec, i), AREF (font, i)))
2399 return 0;
2400 props = XFONT_SPEC (spec)->props;
2401 if (FLOATP (props[FONT_SIZE_INDEX]))
2403 for (i = FONT_FOUNDRY_INDEX; i < FONT_SIZE_INDEX; i++)
2404 prop[i] = AREF (spec, i);
2405 prop[FONT_SIZE_INDEX]
2406 = make_number (font_pixel_size (XFRAME (selected_frame), spec));
2407 props = prop;
2410 if (font_score (font, props) > 0)
2411 return 0;
2412 extra = AREF (spec, FONT_EXTRA_INDEX);
2413 font_extra = AREF (font, FONT_EXTRA_INDEX);
2414 for (; CONSP (extra); extra = XCDR (extra))
2416 Lisp_Object key = XCAR (XCAR (extra));
2417 Lisp_Object val = XCDR (XCAR (extra)), val2;
2419 if (EQ (key, QClang))
2421 val2 = assq_no_quit (key, font_extra);
2422 if (NILP (val2))
2423 return 0;
2424 val2 = XCDR (val2);
2425 if (CONSP (val))
2427 if (! CONSP (val2))
2428 return 0;
2429 while (CONSP (val))
2430 if (NILP (Fmemq (val, val2)))
2431 return 0;
2433 else
2434 if (CONSP (val2)
2435 ? NILP (Fmemq (val, XCDR (val2)))
2436 : ! EQ (val, val2))
2437 return 0;
2439 else if (EQ (key, QCscript))
2441 val2 = assq_no_quit (val, Vscript_representative_chars);
2442 if (CONSP (val2))
2444 val2 = XCDR (val2);
2445 if (CONSP (val2))
2447 /* All characters in the list must be supported. */
2448 for (; CONSP (val2); val2 = XCDR (val2))
2450 if (! CHARACTERP (XCAR (val2)))
2451 continue;
2452 if (font_encode_char (font, XFASTINT (XCAR (val2)))
2453 == FONT_INVALID_CODE)
2454 return 0;
2457 else if (VECTORP (val2))
2459 /* At most one character in the vector must be supported. */
2460 for (i = 0; i < ASIZE (val2); i++)
2462 if (! CHARACTERP (AREF (val2, i)))
2463 continue;
2464 if (font_encode_char (font, XFASTINT (AREF (val2, i)))
2465 != FONT_INVALID_CODE)
2466 break;
2468 if (i == ASIZE (val2))
2469 return 0;
2473 else if (EQ (key, QCotf))
2475 struct font *fontp;
2477 if (! FONT_OBJECT_P (font))
2478 return 0;
2479 fontp = XFONT_OBJECT (font);
2480 if (! fontp->driver->otf_capability)
2481 return 0;
2482 val2 = fontp->driver->otf_capability (fontp);
2483 if (NILP (val2) || ! font_check_otf (val, val2))
2484 return 0;
2488 return 1;
2492 /* Font cache
2494 Each font backend has the callback function get_cache, and it
2495 returns a cons cell of which cdr part can be freely used for
2496 caching fonts. The cons cell may be shared by multiple frames
2497 and/or multiple font drivers. So, we arrange the cdr part as this:
2499 ((DRIVER-TYPE NUM-FRAMES FONT-CACHE-DATA ...) ...)
2501 where DRIVER-TYPE is a symbol such as `x', `xft', etc., NUM-FRAMES
2502 is a number frames sharing this cache, and FONT-CACHE-DATA is a
2503 cons (FONT-SPEC FONT-ENTITY ...). */
2505 static void font_prepare_cache (FRAME_PTR, struct font_driver *);
2506 static void font_finish_cache (FRAME_PTR, struct font_driver *);
2507 static Lisp_Object font_get_cache (FRAME_PTR, struct font_driver *);
2508 static void font_clear_cache (FRAME_PTR, Lisp_Object,
2509 struct font_driver *);
2511 static void
2512 font_prepare_cache (FRAME_PTR f, struct font_driver *driver)
2514 Lisp_Object cache, val;
2516 cache = driver->get_cache (f);
2517 val = XCDR (cache);
2518 while (CONSP (val) && ! EQ (XCAR (XCAR (val)), driver->type))
2519 val = XCDR (val);
2520 if (NILP (val))
2522 val = Fcons (driver->type, Fcons (make_number (1), Qnil));
2523 XSETCDR (cache, Fcons (val, XCDR (cache)));
2525 else
2527 val = XCDR (XCAR (val));
2528 XSETCAR (val, make_number (XINT (XCAR (val)) + 1));
2533 static void
2534 font_finish_cache (FRAME_PTR f, struct font_driver *driver)
2536 Lisp_Object cache, val, tmp;
2539 cache = driver->get_cache (f);
2540 val = XCDR (cache);
2541 while (CONSP (val) && ! EQ (XCAR (XCAR (val)), driver->type))
2542 cache = val, val = XCDR (val);
2543 font_assert (! NILP (val));
2544 tmp = XCDR (XCAR (val));
2545 XSETCAR (tmp, make_number (XINT (XCAR (tmp)) - 1));
2546 if (XINT (XCAR (tmp)) == 0)
2548 font_clear_cache (f, XCAR (val), driver);
2549 XSETCDR (cache, XCDR (val));
2554 static Lisp_Object
2555 font_get_cache (FRAME_PTR f, struct font_driver *driver)
2557 Lisp_Object val = driver->get_cache (f);
2558 Lisp_Object type = driver->type;
2560 font_assert (CONSP (val));
2561 for (val = XCDR (val); ! EQ (XCAR (XCAR (val)), type); val = XCDR (val));
2562 font_assert (CONSP (val));
2563 /* VAL = ((DRIVER-TYPE NUM-FRAMES FONT-CACHE-DATA ...) ...) */
2564 val = XCDR (XCAR (val));
2565 return val;
2568 static int num_fonts;
2570 static void
2571 font_clear_cache (FRAME_PTR f, Lisp_Object cache, struct font_driver *driver)
2573 Lisp_Object tail, elt;
2574 Lisp_Object tail2, entity;
2576 /* CACHE = (DRIVER-TYPE NUM-FRAMES FONT-CACHE-DATA ...) */
2577 for (tail = XCDR (XCDR (cache)); CONSP (tail); tail = XCDR (tail))
2579 elt = XCAR (tail);
2580 /* elt should have the form (FONT-SPEC FONT-ENTITY ...) */
2581 if (CONSP (elt) && FONT_SPEC_P (XCAR (elt)))
2583 for (tail2 = XCDR (elt); CONSP (tail2); tail2 = XCDR (tail2))
2585 entity = XCAR (tail2);
2587 if (FONT_ENTITY_P (entity)
2588 && EQ (driver->type, AREF (entity, FONT_TYPE_INDEX)))
2590 Lisp_Object objlist = AREF (entity, FONT_OBJLIST_INDEX);
2592 for (; CONSP (objlist); objlist = XCDR (objlist))
2594 Lisp_Object val = XCAR (objlist);
2595 struct font *font = XFONT_OBJECT (val);
2597 if (! NILP (AREF (val, FONT_TYPE_INDEX)))
2599 font_assert (font && driver == font->driver);
2600 driver->close (f, font);
2601 num_fonts--;
2604 if (driver->free_entity)
2605 driver->free_entity (entity);
2610 XSETCDR (cache, Qnil);
2614 static Lisp_Object scratch_font_spec, scratch_font_prefer;
2616 /* Check each font-entity in VEC, and return a list of font-entities
2617 that satisfy these conditions:
2618 (1) matches with SPEC and SIZE if SPEC is not nil, and
2619 (2) doesn't match with any regexps in Vface_ignored_fonts (if non-nil).
2622 static Lisp_Object
2623 font_delete_unmatched (Lisp_Object vec, Lisp_Object spec, int size)
2625 Lisp_Object entity, val;
2626 enum font_property_index prop;
2627 int i;
2629 for (val = Qnil, i = ASIZE (vec) - 1; i >= 0; i--)
2631 entity = AREF (vec, i);
2632 if (! NILP (Vface_ignored_fonts))
2634 char name[256];
2635 ptrdiff_t namelen;
2636 Lisp_Object tail, regexp;
2638 namelen = font_unparse_xlfd (entity, 0, name, 256);
2639 if (namelen >= 0)
2641 for (tail = Vface_ignored_fonts; CONSP (tail); tail = XCDR (tail))
2643 regexp = XCAR (tail);
2644 if (STRINGP (regexp)
2645 && fast_c_string_match_ignore_case (regexp, name,
2646 namelen) >= 0)
2647 break;
2649 if (CONSP (tail))
2650 continue;
2653 if (NILP (spec))
2655 val = Fcons (entity, val);
2656 continue;
2658 for (prop = FONT_WEIGHT_INDEX; prop < FONT_SIZE_INDEX; prop++)
2659 if (INTEGERP (AREF (spec, prop))
2660 && ((XINT (AREF (spec, prop)) >> 8)
2661 != (XINT (AREF (entity, prop)) >> 8)))
2662 prop = FONT_SPEC_MAX;
2663 if (prop < FONT_SPEC_MAX
2664 && size
2665 && XINT (AREF (entity, FONT_SIZE_INDEX)) > 0)
2667 int diff = XINT (AREF (entity, FONT_SIZE_INDEX)) - size;
2669 if (diff != 0
2670 && (diff < 0 ? -diff > FONT_PIXEL_SIZE_QUANTUM
2671 : diff > FONT_PIXEL_SIZE_QUANTUM))
2672 prop = FONT_SPEC_MAX;
2674 if (prop < FONT_SPEC_MAX
2675 && INTEGERP (AREF (spec, FONT_DPI_INDEX))
2676 && INTEGERP (AREF (entity, FONT_DPI_INDEX))
2677 && XINT (AREF (entity, FONT_DPI_INDEX)) != 0
2678 && ! EQ (AREF (spec, FONT_DPI_INDEX), AREF (entity, FONT_DPI_INDEX)))
2679 prop = FONT_SPEC_MAX;
2680 if (prop < FONT_SPEC_MAX
2681 && INTEGERP (AREF (spec, FONT_AVGWIDTH_INDEX))
2682 && INTEGERP (AREF (entity, FONT_AVGWIDTH_INDEX))
2683 && XINT (AREF (entity, FONT_AVGWIDTH_INDEX)) != 0
2684 && ! EQ (AREF (spec, FONT_AVGWIDTH_INDEX),
2685 AREF (entity, FONT_AVGWIDTH_INDEX)))
2686 prop = FONT_SPEC_MAX;
2687 if (prop < FONT_SPEC_MAX)
2688 val = Fcons (entity, val);
2690 return (Fvconcat (1, &val));
2694 /* Return a list of vectors of font-entities matching with SPEC on
2695 FRAME. Each elements in the list is a vector of entities from the
2696 same font-driver. */
2698 Lisp_Object
2699 font_list_entities (Lisp_Object frame, Lisp_Object spec)
2701 FRAME_PTR f = XFRAME (frame);
2702 struct font_driver_list *driver_list = f->font_driver_list;
2703 Lisp_Object ftype, val;
2704 Lisp_Object list = Qnil;
2705 int size;
2706 int need_filtering = 0;
2707 int i;
2709 font_assert (FONT_SPEC_P (spec));
2711 if (INTEGERP (AREF (spec, FONT_SIZE_INDEX)))
2712 size = XINT (AREF (spec, FONT_SIZE_INDEX));
2713 else if (FLOATP (AREF (spec, FONT_SIZE_INDEX)))
2714 size = font_pixel_size (f, spec);
2715 else
2716 size = 0;
2718 ftype = AREF (spec, FONT_TYPE_INDEX);
2719 for (i = FONT_FOUNDRY_INDEX; i <= FONT_REGISTRY_INDEX; i++)
2720 ASET (scratch_font_spec, i, AREF (spec, i));
2721 for (i = FONT_WEIGHT_INDEX; i < FONT_EXTRA_INDEX; i++)
2722 if (i != FONT_SPACING_INDEX)
2724 ASET (scratch_font_spec, i, Qnil);
2725 if (! NILP (AREF (spec, i)))
2726 need_filtering = 1;
2728 ASET (scratch_font_spec, FONT_SPACING_INDEX, AREF (spec, FONT_SPACING_INDEX));
2729 ASET (scratch_font_spec, FONT_EXTRA_INDEX, AREF (spec, FONT_EXTRA_INDEX));
2731 for (i = 0; driver_list; driver_list = driver_list->next)
2732 if (driver_list->on
2733 && (NILP (ftype) || EQ (driver_list->driver->type, ftype)))
2735 Lisp_Object cache = font_get_cache (f, driver_list->driver);
2737 ASET (scratch_font_spec, FONT_TYPE_INDEX, driver_list->driver->type);
2738 val = assoc_no_quit (scratch_font_spec, XCDR (cache));
2739 if (CONSP (val))
2740 val = XCDR (val);
2741 else
2743 Lisp_Object copy;
2745 val = driver_list->driver->list (frame, scratch_font_spec);
2746 if (NILP (val))
2747 val = zero_vector;
2748 else
2749 val = Fvconcat (1, &val);
2750 copy = copy_font_spec (scratch_font_spec);
2751 ASET (copy, FONT_TYPE_INDEX, driver_list->driver->type);
2752 XSETCDR (cache, Fcons (Fcons (copy, val), XCDR (cache)));
2754 if (ASIZE (val) > 0
2755 && (need_filtering
2756 || ! NILP (Vface_ignored_fonts)))
2757 val = font_delete_unmatched (val, need_filtering ? spec : Qnil, size);
2758 if (ASIZE (val) > 0)
2759 list = Fcons (val, list);
2762 list = Fnreverse (list);
2763 FONT_ADD_LOG ("list", spec, list);
2764 return list;
2768 /* Return a font entity matching with SPEC on FRAME. ATTRS, if non
2769 nil, is an array of face's attributes, which specifies preferred
2770 font-related attributes. */
2772 static Lisp_Object
2773 font_matching_entity (FRAME_PTR f, Lisp_Object *attrs, Lisp_Object spec)
2775 struct font_driver_list *driver_list = f->font_driver_list;
2776 Lisp_Object ftype, size, entity;
2777 Lisp_Object frame;
2778 Lisp_Object work = copy_font_spec (spec);
2780 XSETFRAME (frame, f);
2781 ftype = AREF (spec, FONT_TYPE_INDEX);
2782 size = AREF (spec, FONT_SIZE_INDEX);
2784 if (FLOATP (size))
2785 ASET (work, FONT_SIZE_INDEX, make_number (font_pixel_size (f, spec)));
2786 FONT_SET_STYLE (work, FONT_WEIGHT_INDEX, attrs[LFACE_WEIGHT_INDEX]);
2787 FONT_SET_STYLE (work, FONT_SLANT_INDEX, attrs[LFACE_SLANT_INDEX]);
2788 FONT_SET_STYLE (work, FONT_WIDTH_INDEX, attrs[LFACE_SWIDTH_INDEX]);
2790 entity = Qnil;
2791 for (; driver_list; driver_list = driver_list->next)
2792 if (driver_list->on
2793 && (NILP (ftype) || EQ (driver_list->driver->type, ftype)))
2795 Lisp_Object cache = font_get_cache (f, driver_list->driver);
2796 Lisp_Object copy;
2798 ASET (work, FONT_TYPE_INDEX, driver_list->driver->type);
2799 entity = assoc_no_quit (work, XCDR (cache));
2800 if (CONSP (entity))
2801 entity = XCDR (entity);
2802 else
2804 entity = driver_list->driver->match (frame, work);
2805 copy = copy_font_spec (work);
2806 ASET (copy, FONT_TYPE_INDEX, driver_list->driver->type);
2807 XSETCDR (cache, Fcons (Fcons (copy, entity), XCDR (cache)));
2809 if (! NILP (entity))
2810 break;
2812 FONT_ADD_LOG ("match", work, entity);
2813 return entity;
2817 /* Open a font of ENTITY and PIXEL_SIZE on frame F, and return the
2818 opened font object. */
2820 static Lisp_Object
2821 font_open_entity (FRAME_PTR f, Lisp_Object entity, int pixel_size)
2823 struct font_driver_list *driver_list;
2824 Lisp_Object objlist, size, val, font_object;
2825 struct font *font;
2826 int min_width, height;
2827 int scaled_pixel_size = pixel_size;
2829 font_assert (FONT_ENTITY_P (entity));
2830 size = AREF (entity, FONT_SIZE_INDEX);
2831 if (XINT (size) != 0)
2832 scaled_pixel_size = pixel_size = XINT (size);
2833 else if (CONSP (Vface_font_rescale_alist))
2834 scaled_pixel_size = pixel_size * font_rescale_ratio (entity);
2836 val = AREF (entity, FONT_TYPE_INDEX);
2837 for (driver_list = f->font_driver_list;
2838 driver_list && ! EQ (driver_list->driver->type, val);
2839 driver_list = driver_list->next);
2840 if (! driver_list)
2841 return Qnil;
2843 for (objlist = AREF (entity, FONT_OBJLIST_INDEX); CONSP (objlist);
2844 objlist = XCDR (objlist))
2846 Lisp_Object fn = XCAR (objlist);
2847 if (! NILP (AREF (fn, FONT_TYPE_INDEX))
2848 && XFONT_OBJECT (fn)->pixel_size == pixel_size)
2850 if (driver_list->driver->cached_font_ok == NULL
2851 || driver_list->driver->cached_font_ok (f, fn, entity))
2852 return fn;
2856 font_object = driver_list->driver->open (f, entity, scaled_pixel_size);
2857 if (!NILP (font_object))
2858 ASET (font_object, FONT_SIZE_INDEX, make_number (pixel_size));
2859 FONT_ADD_LOG ("open", entity, font_object);
2860 if (NILP (font_object))
2861 return Qnil;
2862 ASET (entity, FONT_OBJLIST_INDEX,
2863 Fcons (font_object, AREF (entity, FONT_OBJLIST_INDEX)));
2864 num_fonts++;
2866 font = XFONT_OBJECT (font_object);
2867 min_width = (font->min_width ? font->min_width
2868 : font->average_width ? font->average_width
2869 : font->space_width ? font->space_width
2870 : 1);
2871 height = (font->height ? font->height : 1);
2872 #ifdef HAVE_WINDOW_SYSTEM
2873 FRAME_X_DISPLAY_INFO (f)->n_fonts++;
2874 if (FRAME_X_DISPLAY_INFO (f)->n_fonts == 1)
2876 FRAME_SMALLEST_CHAR_WIDTH (f) = min_width;
2877 FRAME_SMALLEST_FONT_HEIGHT (f) = height;
2878 fonts_changed_p = 1;
2880 else
2882 if (FRAME_SMALLEST_CHAR_WIDTH (f) > min_width)
2883 FRAME_SMALLEST_CHAR_WIDTH (f) = min_width, fonts_changed_p = 1;
2884 if (FRAME_SMALLEST_FONT_HEIGHT (f) > height)
2885 FRAME_SMALLEST_FONT_HEIGHT (f) = height, fonts_changed_p = 1;
2887 #endif
2889 return font_object;
2893 /* Close FONT_OBJECT that is opened on frame F. */
2895 static void
2896 font_close_object (FRAME_PTR f, Lisp_Object font_object)
2898 struct font *font = XFONT_OBJECT (font_object);
2900 if (NILP (AREF (font_object, FONT_TYPE_INDEX)))
2901 /* Already closed. */
2902 return;
2903 FONT_ADD_LOG ("close", font_object, Qnil);
2904 font->driver->close (f, font);
2905 #ifdef HAVE_WINDOW_SYSTEM
2906 font_assert (FRAME_X_DISPLAY_INFO (f)->n_fonts);
2907 FRAME_X_DISPLAY_INFO (f)->n_fonts--;
2908 #endif
2909 num_fonts--;
2913 /* Return 1 if FONT on F has a glyph for character C, 0 if not, -1 if
2914 FONT is a font-entity and it must be opened to check. */
2917 font_has_char (FRAME_PTR f, Lisp_Object font, int c)
2919 struct font *fontp;
2921 if (FONT_ENTITY_P (font))
2923 Lisp_Object type = AREF (font, FONT_TYPE_INDEX);
2924 struct font_driver_list *driver_list;
2926 for (driver_list = f->font_driver_list;
2927 driver_list && ! EQ (driver_list->driver->type, type);
2928 driver_list = driver_list->next);
2929 if (! driver_list)
2930 return 0;
2931 if (! driver_list->driver->has_char)
2932 return -1;
2933 return driver_list->driver->has_char (font, c);
2936 font_assert (FONT_OBJECT_P (font));
2937 fontp = XFONT_OBJECT (font);
2938 if (fontp->driver->has_char)
2940 int result = fontp->driver->has_char (font, c);
2942 if (result >= 0)
2943 return result;
2945 return (fontp->driver->encode_char (fontp, c) != FONT_INVALID_CODE);
2949 /* Return the glyph ID of FONT_OBJECT for character C. */
2951 static unsigned
2952 font_encode_char (Lisp_Object font_object, int c)
2954 struct font *font;
2956 font_assert (FONT_OBJECT_P (font_object));
2957 font = XFONT_OBJECT (font_object);
2958 return font->driver->encode_char (font, c);
2962 /* Return the name of FONT_OBJECT. */
2964 Lisp_Object
2965 font_get_name (Lisp_Object font_object)
2967 font_assert (FONT_OBJECT_P (font_object));
2968 return AREF (font_object, FONT_NAME_INDEX);
2972 /* Create a new font spec from FONT_NAME, and return it. If FONT_NAME
2973 could not be parsed by font_parse_name, return Qnil. */
2975 Lisp_Object
2976 font_spec_from_name (Lisp_Object font_name)
2978 Lisp_Object spec = Ffont_spec (0, NULL);
2980 CHECK_STRING (font_name);
2981 if (font_parse_name (SSDATA (font_name), SBYTES (font_name), spec) == -1)
2982 return Qnil;
2983 font_put_extra (spec, QCname, font_name);
2984 font_put_extra (spec, QCuser_spec, font_name);
2985 return spec;
2989 void
2990 font_clear_prop (Lisp_Object *attrs, enum font_property_index prop)
2992 Lisp_Object font = attrs[LFACE_FONT_INDEX];
2994 if (! FONTP (font))
2995 return;
2997 if (! NILP (Ffont_get (font, QCname)))
2999 font = copy_font_spec (font);
3000 font_put_extra (font, QCname, Qnil);
3003 if (NILP (AREF (font, prop))
3004 && prop != FONT_FAMILY_INDEX
3005 && prop != FONT_FOUNDRY_INDEX
3006 && prop != FONT_WIDTH_INDEX
3007 && prop != FONT_SIZE_INDEX)
3008 return;
3009 if (EQ (font, attrs[LFACE_FONT_INDEX]))
3010 font = copy_font_spec (font);
3011 ASET (font, prop, Qnil);
3012 if (prop == FONT_FAMILY_INDEX || prop == FONT_FOUNDRY_INDEX)
3014 if (prop == FONT_FAMILY_INDEX)
3016 ASET (font, FONT_FOUNDRY_INDEX, Qnil);
3017 /* If we are setting the font family, we must also clear
3018 FONT_WIDTH_INDEX to avoid rejecting families that lack
3019 support for some widths. */
3020 ASET (font, FONT_WIDTH_INDEX, Qnil);
3022 ASET (font, FONT_ADSTYLE_INDEX, Qnil);
3023 ASET (font, FONT_REGISTRY_INDEX, Qnil);
3024 ASET (font, FONT_SIZE_INDEX, Qnil);
3025 ASET (font, FONT_DPI_INDEX, Qnil);
3026 ASET (font, FONT_SPACING_INDEX, Qnil);
3027 ASET (font, FONT_AVGWIDTH_INDEX, Qnil);
3029 else if (prop == FONT_SIZE_INDEX)
3031 ASET (font, FONT_DPI_INDEX, Qnil);
3032 ASET (font, FONT_SPACING_INDEX, Qnil);
3033 ASET (font, FONT_AVGWIDTH_INDEX, Qnil);
3035 else if (prop == FONT_WIDTH_INDEX)
3036 ASET (font, FONT_AVGWIDTH_INDEX, Qnil);
3037 attrs[LFACE_FONT_INDEX] = font;
3040 /* Select a font from ENTITIES (list of font-entity vectors) that
3041 supports C and is the best match for ATTRS and PIXEL_SIZE. */
3043 static Lisp_Object
3044 font_select_entity (Lisp_Object frame, Lisp_Object entities, Lisp_Object *attrs, int pixel_size, int c)
3046 Lisp_Object font_entity;
3047 Lisp_Object prefer;
3048 int result, i;
3049 FRAME_PTR f = XFRAME (frame);
3051 if (NILP (XCDR (entities))
3052 && ASIZE (XCAR (entities)) == 1)
3054 font_entity = AREF (XCAR (entities), 0);
3055 if (c < 0
3056 || (result = font_has_char (f, font_entity, c)) > 0)
3057 return font_entity;
3058 return Qnil;
3061 /* Sort fonts by properties specified in ATTRS. */
3062 prefer = scratch_font_prefer;
3064 for (i = FONT_WEIGHT_INDEX; i <= FONT_SIZE_INDEX; i++)
3065 ASET (prefer, i, Qnil);
3066 if (FONTP (attrs[LFACE_FONT_INDEX]))
3068 Lisp_Object face_font = attrs[LFACE_FONT_INDEX];
3070 for (i = FONT_WEIGHT_INDEX; i <= FONT_SIZE_INDEX; i++)
3071 ASET (prefer, i, AREF (face_font, i));
3073 if (NILP (AREF (prefer, FONT_WEIGHT_INDEX)))
3074 FONT_SET_STYLE (prefer, FONT_WEIGHT_INDEX, attrs[LFACE_WEIGHT_INDEX]);
3075 if (NILP (AREF (prefer, FONT_SLANT_INDEX)))
3076 FONT_SET_STYLE (prefer, FONT_SLANT_INDEX, attrs[LFACE_SLANT_INDEX]);
3077 if (NILP (AREF (prefer, FONT_WIDTH_INDEX)))
3078 FONT_SET_STYLE (prefer, FONT_WIDTH_INDEX, attrs[LFACE_SWIDTH_INDEX]);
3079 ASET (prefer, FONT_SIZE_INDEX, make_number (pixel_size));
3081 return font_sort_entities (entities, prefer, frame, c);
3084 /* Return a font-entity that satisfies SPEC and is the best match for
3085 face's font related attributes in ATTRS. C, if not negative, is a
3086 character that the entity must support. */
3088 Lisp_Object
3089 font_find_for_lface (FRAME_PTR f, Lisp_Object *attrs, Lisp_Object spec, int c)
3091 Lisp_Object work;
3092 Lisp_Object frame, entities, val;
3093 Lisp_Object foundry[3], *family, registry[3], adstyle[3];
3094 int pixel_size;
3095 int i, j, k, l;
3096 USE_SAFE_ALLOCA;
3098 registry[0] = AREF (spec, FONT_REGISTRY_INDEX);
3099 if (NILP (registry[0]))
3101 registry[0] = DEFAULT_ENCODING;
3102 registry[1] = Qascii_0;
3103 registry[2] = zero_vector;
3105 else
3106 registry[1] = zero_vector;
3108 if (c >= 0 && ! NILP (AREF (spec, FONT_REGISTRY_INDEX)))
3110 struct charset *encoding, *repertory;
3112 if (font_registry_charsets (AREF (spec, FONT_REGISTRY_INDEX),
3113 &encoding, &repertory) < 0)
3114 return Qnil;
3115 if (repertory
3116 && ENCODE_CHAR (repertory, c) == CHARSET_INVALID_CODE (repertory))
3117 return Qnil;
3118 else if (c > encoding->max_char)
3119 return Qnil;
3122 work = copy_font_spec (spec);
3123 ASET (work, FONT_TYPE_INDEX, AREF (spec, FONT_TYPE_INDEX));
3124 XSETFRAME (frame, f);
3125 pixel_size = font_pixel_size (f, spec);
3126 if (pixel_size == 0 && INTEGERP (attrs[LFACE_HEIGHT_INDEX]))
3128 double pt = XINT (attrs[LFACE_HEIGHT_INDEX]);
3130 pixel_size = POINT_TO_PIXEL (pt / 10, f->resy);
3132 ASET (work, FONT_SIZE_INDEX, Qnil);
3133 foundry[0] = AREF (work, FONT_FOUNDRY_INDEX);
3134 if (! NILP (foundry[0]))
3135 foundry[1] = zero_vector;
3136 else if (STRINGP (attrs[LFACE_FOUNDRY_INDEX]))
3138 val = attrs[LFACE_FOUNDRY_INDEX];
3139 foundry[0] = font_intern_prop (SSDATA (val), SBYTES (val), 1);
3140 foundry[1] = Qnil;
3141 foundry[2] = zero_vector;
3143 else
3144 foundry[0] = Qnil, foundry[1] = zero_vector;
3146 adstyle[0] = AREF (work, FONT_ADSTYLE_INDEX);
3147 if (! NILP (adstyle[0]))
3148 adstyle[1] = zero_vector;
3149 else if (FONTP (attrs[LFACE_FONT_INDEX]))
3151 Lisp_Object face_font = attrs[LFACE_FONT_INDEX];
3153 if (! NILP (AREF (face_font, FONT_ADSTYLE_INDEX)))
3155 adstyle[0] = AREF (face_font, FONT_ADSTYLE_INDEX);
3156 adstyle[1] = Qnil;
3157 adstyle[2] = zero_vector;
3159 else
3160 adstyle[0] = Qnil, adstyle[1] = zero_vector;
3162 else
3163 adstyle[0] = Qnil, adstyle[1] = zero_vector;
3166 val = AREF (work, FONT_FAMILY_INDEX);
3167 if (NILP (val) && STRINGP (attrs[LFACE_FAMILY_INDEX]))
3169 val = attrs[LFACE_FAMILY_INDEX];
3170 val = font_intern_prop (SSDATA (val), SBYTES (val), 1);
3172 if (NILP (val))
3174 family = alloca ((sizeof family[0]) * 2);
3175 family[0] = Qnil;
3176 family[1] = zero_vector; /* terminator. */
3178 else
3180 Lisp_Object alters
3181 = Fassoc_string (val, Vface_alternative_font_family_alist, Qt);
3183 if (! NILP (alters))
3185 EMACS_INT alterslen = XFASTINT (Flength (alters));
3186 SAFE_ALLOCA_LISP (family, alterslen + 2);
3187 for (i = 0; CONSP (alters); i++, alters = XCDR (alters))
3188 family[i] = XCAR (alters);
3189 if (NILP (AREF (spec, FONT_FAMILY_INDEX)))
3190 family[i++] = Qnil;
3191 family[i] = zero_vector;
3193 else
3195 family = alloca ((sizeof family[0]) * 3);
3196 i = 0;
3197 family[i++] = val;
3198 if (NILP (AREF (spec, FONT_FAMILY_INDEX)))
3199 family[i++] = Qnil;
3200 family[i] = zero_vector;
3204 for (i = 0; SYMBOLP (family[i]); i++)
3206 ASET (work, FONT_FAMILY_INDEX, family[i]);
3207 for (j = 0; SYMBOLP (foundry[j]); j++)
3209 ASET (work, FONT_FOUNDRY_INDEX, foundry[j]);
3210 for (k = 0; SYMBOLP (registry[k]); k++)
3212 ASET (work, FONT_REGISTRY_INDEX, registry[k]);
3213 for (l = 0; SYMBOLP (adstyle[l]); l++)
3215 ASET (work, FONT_ADSTYLE_INDEX, adstyle[l]);
3216 entities = font_list_entities (frame, work);
3217 if (! NILP (entities))
3219 val = font_select_entity (frame, entities,
3220 attrs, pixel_size, c);
3221 if (! NILP (val))
3222 return val;
3229 SAFE_FREE ();
3230 return Qnil;
3234 Lisp_Object
3235 font_open_for_lface (FRAME_PTR f, Lisp_Object entity, Lisp_Object *attrs, Lisp_Object spec)
3237 int size;
3239 if (INTEGERP (AREF (entity, FONT_SIZE_INDEX))
3240 && XINT (AREF (entity, FONT_SIZE_INDEX)) > 0)
3241 size = XINT (AREF (entity, FONT_SIZE_INDEX));
3242 else if (FONT_SPEC_P (spec) && ! NILP (AREF (spec, FONT_SIZE_INDEX)))
3243 size = font_pixel_size (f, spec);
3244 else
3246 double pt;
3247 if (INTEGERP (attrs[LFACE_HEIGHT_INDEX]))
3248 pt = XINT (attrs[LFACE_HEIGHT_INDEX]);
3249 else
3251 struct face *def = FACE_FROM_ID (f, DEFAULT_FACE_ID);
3252 Lisp_Object height = def->lface[LFACE_HEIGHT_INDEX];
3253 if (INTEGERP (height))
3254 pt = XINT (height);
3255 else
3256 abort (); /* We should never end up here. */
3259 pt /= 10;
3260 size = POINT_TO_PIXEL (pt, f->resy);
3261 #ifdef HAVE_NS
3262 if (size == 0)
3264 Lisp_Object ffsize = get_frame_param (f, Qfontsize);
3265 size = NUMBERP (ffsize) ? POINT_TO_PIXEL (XINT (ffsize), f->resy) : 0;
3267 #endif
3269 return font_open_entity (f, entity, size);
3273 /* Find a font that satisfies SPEC and is the best match for
3274 face's attributes in ATTRS on FRAME, and return the opened
3275 font-object. */
3277 Lisp_Object
3278 font_load_for_lface (FRAME_PTR f, Lisp_Object *attrs, Lisp_Object spec)
3280 Lisp_Object entity, name;
3282 entity = font_find_for_lface (f, attrs, spec, -1);
3283 if (NILP (entity))
3285 /* No font is listed for SPEC, but each font-backend may have
3286 different criteria about "font matching". So, try it. */
3287 entity = font_matching_entity (f, attrs, spec);
3288 if (NILP (entity))
3289 return Qnil;
3291 /* Don't lose the original name that was put in initially. We need
3292 it to re-apply the font when font parameters (like hinting or dpi) have
3293 changed. */
3294 entity = font_open_for_lface (f, entity, attrs, spec);
3295 if (!NILP (entity))
3297 name = Ffont_get (spec, QCuser_spec);
3298 if (STRINGP (name)) font_put_extra (entity, QCuser_spec, name);
3300 return entity;
3304 /* Make FACE on frame F ready to use the font opened for FACE. */
3306 void
3307 font_prepare_for_face (FRAME_PTR f, struct face *face)
3309 if (face->font->driver->prepare_face)
3310 face->font->driver->prepare_face (f, face);
3314 /* Make FACE on frame F stop using the font opened for FACE. */
3316 void
3317 font_done_for_face (FRAME_PTR f, struct face *face)
3319 if (face->font->driver->done_face)
3320 face->font->driver->done_face (f, face);
3321 face->extra = NULL;
3325 /* Open a font that is a match for font-spec SPEC on frame F. If no proper
3326 font is found, return Qnil. */
3328 Lisp_Object
3329 font_open_by_spec (FRAME_PTR f, Lisp_Object spec)
3331 Lisp_Object attrs[LFACE_VECTOR_SIZE];
3333 /* We set up the default font-related attributes of a face to prefer
3334 a moderate font. */
3335 attrs[LFACE_FAMILY_INDEX] = attrs[LFACE_FOUNDRY_INDEX] = Qnil;
3336 attrs[LFACE_SWIDTH_INDEX] = attrs[LFACE_WEIGHT_INDEX]
3337 = attrs[LFACE_SLANT_INDEX] = Qnormal;
3338 #ifndef HAVE_NS
3339 attrs[LFACE_HEIGHT_INDEX] = make_number (120);
3340 #else
3341 attrs[LFACE_HEIGHT_INDEX] = make_number (0);
3342 #endif
3343 attrs[LFACE_FONT_INDEX] = Qnil;
3345 return font_load_for_lface (f, attrs, spec);
3349 /* Open a font that matches NAME on frame F. If no proper font is
3350 found, return Qnil. */
3352 Lisp_Object
3353 font_open_by_name (FRAME_PTR f, Lisp_Object name)
3355 Lisp_Object args[2];
3356 Lisp_Object spec, ret;
3358 args[0] = QCname;
3359 args[1] = name;
3360 spec = Ffont_spec (2, args);
3361 ret = font_open_by_spec (f, spec);
3362 /* Do not lose name originally put in. */
3363 if (!NILP (ret))
3364 font_put_extra (ret, QCuser_spec, args[1]);
3366 return ret;
3370 /* Register font-driver DRIVER. This function is used in two ways.
3372 The first is with frame F non-NULL. In this case, make DRIVER
3373 available (but not yet activated) on F. All frame creators
3374 (e.g. Fx_create_frame) must call this function at least once with
3375 an available font-driver.
3377 The second is with frame F NULL. In this case, DRIVER is globally
3378 registered in the variable `font_driver_list'. All font-driver
3379 implementations must call this function in its syms_of_XXXX
3380 (e.g. syms_of_xfont). */
3382 void
3383 register_font_driver (struct font_driver *driver, FRAME_PTR f)
3385 struct font_driver_list *root = f ? f->font_driver_list : font_driver_list;
3386 struct font_driver_list *prev, *list;
3388 if (f && ! driver->draw)
3389 error ("Unusable font driver for a frame: %s",
3390 SDATA (SYMBOL_NAME (driver->type)));
3392 for (prev = NULL, list = root; list; prev = list, list = list->next)
3393 if (EQ (list->driver->type, driver->type))
3394 error ("Duplicated font driver: %s", SDATA (SYMBOL_NAME (driver->type)));
3396 list = xmalloc (sizeof *list);
3397 list->on = 0;
3398 list->driver = driver;
3399 list->next = NULL;
3400 if (prev)
3401 prev->next = list;
3402 else if (f)
3403 f->font_driver_list = list;
3404 else
3405 font_driver_list = list;
3406 if (! f)
3407 num_font_drivers++;
3410 void
3411 free_font_driver_list (FRAME_PTR f)
3413 struct font_driver_list *list, *next;
3415 for (list = f->font_driver_list; list; list = next)
3417 next = list->next;
3418 xfree (list);
3420 f->font_driver_list = NULL;
3424 /* Make the frame F use font backends listed in NEW_DRIVERS (list of
3425 symbols, e.g. xft, x). If NEW_DRIVERS is t, make F use all
3426 available font drivers. If NEW_DRIVERS is nil, finalize all drivers.
3428 A caller must free all realized faces if any in advance. The
3429 return value is a list of font backends actually made used on
3430 F. */
3432 Lisp_Object
3433 font_update_drivers (FRAME_PTR f, Lisp_Object new_drivers)
3435 Lisp_Object active_drivers = Qnil;
3436 struct font_driver_list *list;
3438 /* At first, turn off non-requested drivers, and turn on requested
3439 drivers. */
3440 for (list = f->font_driver_list; list; list = list->next)
3442 struct font_driver *driver = list->driver;
3443 if ((EQ (new_drivers, Qt) || ! NILP (Fmemq (driver->type, new_drivers)))
3444 != list->on)
3446 if (list->on)
3448 if (driver->end_for_frame)
3449 driver->end_for_frame (f);
3450 font_finish_cache (f, driver);
3451 list->on = 0;
3453 else
3455 if (! driver->start_for_frame
3456 || driver->start_for_frame (f) == 0)
3458 font_prepare_cache (f, driver);
3459 list->on = 1;
3465 if (NILP (new_drivers))
3466 return Qnil;
3468 if (! EQ (new_drivers, Qt))
3470 /* Re-order the driver list according to new_drivers. */
3471 struct font_driver_list **list_table, **next;
3472 Lisp_Object tail;
3473 int i;
3475 list_table = alloca (sizeof list_table[0] * (num_font_drivers + 1));
3476 for (i = 0, tail = new_drivers; ! NILP (tail); tail = XCDR (tail))
3478 for (list = f->font_driver_list; list; list = list->next)
3479 if (list->on && EQ (list->driver->type, XCAR (tail)))
3480 break;
3481 if (list)
3482 list_table[i++] = list;
3484 for (list = f->font_driver_list; list; list = list->next)
3485 if (! list->on)
3486 list_table[i++] = list;
3487 list_table[i] = NULL;
3489 next = &f->font_driver_list;
3490 for (i = 0; list_table[i]; i++)
3492 *next = list_table[i];
3493 next = &(*next)->next;
3495 *next = NULL;
3497 if (! f->font_driver_list->on)
3498 { /* None of the drivers is enabled: enable them all.
3499 Happens if you set the list of drivers to (xft x) in your .emacs
3500 and then use it under w32 or ns. */
3501 for (list = f->font_driver_list; list; list = list->next)
3503 struct font_driver *driver = list->driver;
3504 eassert (! list->on);
3505 if (! driver->start_for_frame
3506 || driver->start_for_frame (f) == 0)
3508 font_prepare_cache (f, driver);
3509 list->on = 1;
3515 for (list = f->font_driver_list; list; list = list->next)
3516 if (list->on)
3517 active_drivers = nconc2 (active_drivers,
3518 Fcons (list->driver->type, Qnil));
3519 return active_drivers;
3523 font_put_frame_data (FRAME_PTR f, struct font_driver *driver, void *data)
3525 struct font_data_list *list, *prev;
3527 for (prev = NULL, list = f->font_data_list; list;
3528 prev = list, list = list->next)
3529 if (list->driver == driver)
3530 break;
3531 if (! data)
3533 if (list)
3535 if (prev)
3536 prev->next = list->next;
3537 else
3538 f->font_data_list = list->next;
3539 xfree (list);
3541 return 0;
3544 if (! list)
3546 list = xmalloc (sizeof *list);
3547 list->driver = driver;
3548 list->next = f->font_data_list;
3549 f->font_data_list = list;
3551 list->data = data;
3552 return 0;
3556 void *
3557 font_get_frame_data (FRAME_PTR f, struct font_driver *driver)
3559 struct font_data_list *list;
3561 for (list = f->font_data_list; list; list = list->next)
3562 if (list->driver == driver)
3563 break;
3564 if (! list)
3565 return NULL;
3566 return list->data;
3570 /* Sets attributes on a font. Any properties that appear in ALIST and
3571 BOOLEAN_PROPERTIES or NON_BOOLEAN_PROPERTIES are set on the font.
3572 BOOLEAN_PROPERTIES and NON_BOOLEAN_PROPERTIES are NULL-terminated
3573 arrays of strings. This function is intended for use by the font
3574 drivers to implement their specific font_filter_properties. */
3575 void
3576 font_filter_properties (Lisp_Object font,
3577 Lisp_Object alist,
3578 const char *const boolean_properties[],
3579 const char *const non_boolean_properties[])
3581 Lisp_Object it;
3582 int i;
3584 /* Set boolean values to Qt or Qnil */
3585 for (i = 0; boolean_properties[i] != NULL; ++i)
3586 for (it = alist; ! NILP (it); it = XCDR (it))
3588 Lisp_Object key = XCAR (XCAR (it));
3589 Lisp_Object val = XCDR (XCAR (it));
3590 char *keystr = SSDATA (SYMBOL_NAME (key));
3592 if (strcmp (boolean_properties[i], keystr) == 0)
3594 const char *str = INTEGERP (val) ? (XINT (val) ? "true" : "false")
3595 : SYMBOLP (val) ? SSDATA (SYMBOL_NAME (val))
3596 : "true";
3598 if (strcmp ("false", str) == 0 || strcmp ("False", str) == 0
3599 || strcmp ("FALSE", str) == 0 || strcmp ("FcFalse", str) == 0
3600 || strcmp ("off", str) == 0 || strcmp ("OFF", str) == 0
3601 || strcmp ("Off", str) == 0)
3602 val = Qnil;
3603 else
3604 val = Qt;
3606 Ffont_put (font, key, val);
3610 for (i = 0; non_boolean_properties[i] != NULL; ++i)
3611 for (it = alist; ! NILP (it); it = XCDR (it))
3613 Lisp_Object key = XCAR (XCAR (it));
3614 Lisp_Object val = XCDR (XCAR (it));
3615 char *keystr = SSDATA (SYMBOL_NAME (key));
3616 if (strcmp (non_boolean_properties[i], keystr) == 0)
3617 Ffont_put (font, key, val);
3622 /* Return the font used to draw character C by FACE at buffer position
3623 POS in window W. If STRING is non-nil, it is a string containing C
3624 at index POS. If C is negative, get C from the current buffer or
3625 STRING. */
3627 static Lisp_Object
3628 font_at (int c, ptrdiff_t pos, struct face *face, struct window *w,
3629 Lisp_Object string)
3631 FRAME_PTR f;
3632 int multibyte;
3633 Lisp_Object font_object;
3635 multibyte = (NILP (string)
3636 ? ! NILP (BVAR (current_buffer, enable_multibyte_characters))
3637 : STRING_MULTIBYTE (string));
3638 if (c < 0)
3640 if (NILP (string))
3642 if (multibyte)
3644 ptrdiff_t pos_byte = CHAR_TO_BYTE (pos);
3646 c = FETCH_CHAR (pos_byte);
3648 else
3649 c = FETCH_BYTE (pos);
3651 else
3653 unsigned char *str;
3655 multibyte = STRING_MULTIBYTE (string);
3656 if (multibyte)
3658 ptrdiff_t pos_byte = string_char_to_byte (string, pos);
3660 str = SDATA (string) + pos_byte;
3661 c = STRING_CHAR (str);
3663 else
3664 c = SDATA (string)[pos];
3668 f = XFRAME (w->frame);
3669 if (! FRAME_WINDOW_P (f))
3670 return Qnil;
3671 if (! face)
3673 int face_id;
3674 ptrdiff_t endptr;
3676 if (STRINGP (string))
3677 face_id = face_at_string_position (w, string, pos, 0, -1, -1, &endptr,
3678 DEFAULT_FACE_ID, 0);
3679 else
3680 face_id = face_at_buffer_position (w, pos, -1, -1, &endptr,
3681 pos + 100, 0, -1);
3682 face = FACE_FROM_ID (f, face_id);
3684 if (multibyte)
3686 int face_id = FACE_FOR_CHAR (f, face, c, pos, string);
3687 face = FACE_FROM_ID (f, face_id);
3689 if (! face->font)
3690 return Qnil;
3692 XSETFONT (font_object, face->font);
3693 return font_object;
3697 #ifdef HAVE_WINDOW_SYSTEM
3699 /* Check how many characters after POS (at most to *LIMIT) can be
3700 displayed by the same font in the window W. FACE, if non-NULL, is
3701 the face selected for the character at POS. If STRING is not nil,
3702 it is the string to check instead of the current buffer. In that
3703 case, FACE must be not NULL.
3705 The return value is the font-object for the character at POS.
3706 *LIMIT is set to the position where that font can't be used.
3708 It is assured that the current buffer (or STRING) is multibyte. */
3710 Lisp_Object
3711 font_range (ptrdiff_t pos, ptrdiff_t *limit, struct window *w, struct face *face, Lisp_Object string)
3713 ptrdiff_t pos_byte, ignore;
3714 int c;
3715 Lisp_Object font_object = Qnil;
3717 if (NILP (string))
3719 pos_byte = CHAR_TO_BYTE (pos);
3720 if (! face)
3722 int face_id;
3724 face_id = face_at_buffer_position (w, pos, 0, 0, &ignore,
3725 *limit, 0, -1);
3726 face = FACE_FROM_ID (XFRAME (w->frame), face_id);
3729 else
3731 font_assert (face);
3732 pos_byte = string_char_to_byte (string, pos);
3735 while (pos < *limit)
3737 Lisp_Object category;
3739 if (NILP (string))
3740 FETCH_CHAR_ADVANCE_NO_CHECK (c, pos, pos_byte);
3741 else
3742 FETCH_STRING_CHAR_ADVANCE_NO_CHECK (c, string, pos, pos_byte);
3743 category = CHAR_TABLE_REF (Vunicode_category_table, c);
3744 if (INTEGERP (category)
3745 && (XINT (category) == UNICODE_CATEGORY_Cf
3746 || CHAR_VARIATION_SELECTOR_P (c)))
3747 continue;
3748 if (NILP (font_object))
3750 font_object = font_for_char (face, c, pos - 1, string);
3751 if (NILP (font_object))
3752 return Qnil;
3753 continue;
3755 if (font_encode_char (font_object, c) == FONT_INVALID_CODE)
3756 *limit = pos - 1;
3758 return font_object;
3760 #endif
3763 /* Lisp API */
3765 DEFUN ("fontp", Ffontp, Sfontp, 1, 2, 0,
3766 doc: /* Return t if OBJECT is a font-spec, font-entity, or font-object.
3767 Return nil otherwise.
3768 Optional 2nd argument EXTRA-TYPE, if non-nil, specifies to check
3769 which kind of font it is. It must be one of `font-spec', `font-entity',
3770 `font-object'. */)
3771 (Lisp_Object object, Lisp_Object extra_type)
3773 if (NILP (extra_type))
3774 return (FONTP (object) ? Qt : Qnil);
3775 if (EQ (extra_type, Qfont_spec))
3776 return (FONT_SPEC_P (object) ? Qt : Qnil);
3777 if (EQ (extra_type, Qfont_entity))
3778 return (FONT_ENTITY_P (object) ? Qt : Qnil);
3779 if (EQ (extra_type, Qfont_object))
3780 return (FONT_OBJECT_P (object) ? Qt : Qnil);
3781 wrong_type_argument (intern ("font-extra-type"), extra_type);
3784 DEFUN ("font-spec", Ffont_spec, Sfont_spec, 0, MANY, 0,
3785 doc: /* Return a newly created font-spec with arguments as properties.
3787 ARGS must come in pairs KEY VALUE of font properties. KEY must be a
3788 valid font property name listed below:
3790 `:family', `:weight', `:slant', `:width'
3792 They are the same as face attributes of the same name. See
3793 `set-face-attribute'.
3795 `:foundry'
3797 VALUE must be a string or a symbol specifying the font foundry, e.g. ``misc''.
3799 `:adstyle'
3801 VALUE must be a string or a symbol specifying the additional
3802 typographic style information of a font, e.g. ``sans''.
3804 `:registry'
3806 VALUE must be a string or a symbol specifying the charset registry and
3807 encoding of a font, e.g. ``iso8859-1''.
3809 `:size'
3811 VALUE must be a non-negative integer or a floating point number
3812 specifying the font size. It specifies the font size in pixels (if
3813 VALUE is an integer), or in points (if VALUE is a float).
3815 `:name'
3817 VALUE must be a string of XLFD-style or fontconfig-style font name.
3819 `:script'
3821 VALUE must be a symbol representing a script that the font must
3822 support. It may be a symbol representing a subgroup of a script
3823 listed in the variable `script-representative-chars'.
3825 `:lang'
3827 VALUE must be a symbol of two-letter ISO-639 language names,
3828 e.g. `ja'.
3830 `:otf'
3832 VALUE must be a list (SCRIPT-TAG LANGSYS-TAG GSUB [ GPOS ]) to specify
3833 required OpenType features.
3835 SCRIPT-TAG: OpenType script tag symbol (e.g. `deva').
3836 LANGSYS-TAG: OpenType language system tag symbol,
3837 or nil for the default language system.
3838 GSUB: List of OpenType GSUB feature tag symbols, or nil if none required.
3839 GPOS: List of OpenType GPOS feature tag symbols, or nil if none required.
3841 GSUB and GPOS may contain `nil' element. In such a case, the font
3842 must not have any of the remaining elements.
3844 For instance, if the VALUE is `(thai nil nil (mark))', the font must
3845 be an OpenType font whose GPOS table of `thai' script's default
3846 language system must contain `mark' feature.
3848 usage: (font-spec ARGS...) */)
3849 (ptrdiff_t nargs, Lisp_Object *args)
3851 Lisp_Object spec = font_make_spec ();
3852 ptrdiff_t i;
3854 for (i = 0; i < nargs; i += 2)
3856 Lisp_Object key = args[i], val;
3858 CHECK_SYMBOL (key);
3859 if (i + 1 >= nargs)
3860 error ("No value for key `%s'", SDATA (SYMBOL_NAME (key)));
3861 val = args[i + 1];
3863 if (EQ (key, QCname))
3865 CHECK_STRING (val);
3866 font_parse_name (SSDATA (val), SBYTES (val), spec);
3867 font_put_extra (spec, key, val);
3869 else
3871 int idx = get_font_prop_index (key);
3873 if (idx >= 0)
3875 val = font_prop_validate (idx, Qnil, val);
3876 if (idx < FONT_EXTRA_INDEX)
3877 ASET (spec, idx, val);
3878 else
3879 font_put_extra (spec, key, val);
3881 else
3882 font_put_extra (spec, key, font_prop_validate (0, key, val));
3885 return spec;
3888 /* Return a copy of FONT as a font-spec. */
3889 Lisp_Object
3890 copy_font_spec (Lisp_Object font)
3892 Lisp_Object new_spec, tail, prev, extra;
3893 int i;
3895 CHECK_FONT (font);
3896 new_spec = font_make_spec ();
3897 for (i = 1; i < FONT_EXTRA_INDEX; i++)
3898 ASET (new_spec, i, AREF (font, i));
3899 extra = Fcopy_alist (AREF (font, FONT_EXTRA_INDEX));
3900 /* We must remove :font-entity property. */
3901 for (prev = Qnil, tail = extra; CONSP (tail); prev = tail, tail = XCDR (tail))
3902 if (EQ (XCAR (XCAR (tail)), QCfont_entity))
3904 if (NILP (prev))
3905 extra = XCDR (extra);
3906 else
3907 XSETCDR (prev, XCDR (tail));
3908 break;
3910 ASET (new_spec, FONT_EXTRA_INDEX, extra);
3911 return new_spec;
3914 /* Merge font-specs FROM and TO, and return a new font-spec.
3915 Every specified property in FROM overrides the corresponding
3916 property in TO. */
3917 Lisp_Object
3918 merge_font_spec (Lisp_Object from, Lisp_Object to)
3920 Lisp_Object extra, tail;
3921 int i;
3923 CHECK_FONT (from);
3924 CHECK_FONT (to);
3925 to = copy_font_spec (to);
3926 for (i = 0; i < FONT_EXTRA_INDEX; i++)
3927 ASET (to, i, AREF (from, i));
3928 extra = AREF (to, FONT_EXTRA_INDEX);
3929 for (tail = AREF (from, FONT_EXTRA_INDEX); CONSP (tail); tail = XCDR (tail))
3930 if (! EQ (XCAR (XCAR (tail)), Qfont_entity))
3932 Lisp_Object slot = assq_no_quit (XCAR (XCAR (tail)), extra);
3934 if (! NILP (slot))
3935 XSETCDR (slot, XCDR (XCAR (tail)));
3936 else
3937 extra = Fcons (Fcons (XCAR (XCAR (tail)), XCDR (XCAR (tail))), extra);
3939 ASET (to, FONT_EXTRA_INDEX, extra);
3940 return to;
3943 DEFUN ("font-get", Ffont_get, Sfont_get, 2, 2, 0,
3944 doc: /* Return the value of FONT's property KEY.
3945 FONT is a font-spec, a font-entity, or a font-object.
3946 KEY is any symbol, but these are reserved for specific meanings:
3947 :family, :weight, :slant, :width, :foundry, :adstyle, :registry,
3948 :size, :name, :script, :otf
3949 See the documentation of `font-spec' for their meanings.
3950 In addition, if FONT is a font-entity or a font-object, values of
3951 :script and :otf are different from those of a font-spec as below:
3953 The value of :script may be a list of scripts that are supported by the font.
3955 The value of :otf is a cons (GSUB . GPOS) where GSUB and GPOS are lists
3956 representing the OpenType features supported by the font by this form:
3957 ((SCRIPT (LANGSYS FEATURE ...) ...) ...)
3958 SCRIPT, LANGSYS, and FEATURE are all symbols representing OpenType
3959 Layout tags. */)
3960 (Lisp_Object font, Lisp_Object key)
3962 int idx;
3963 Lisp_Object val;
3965 CHECK_FONT (font);
3966 CHECK_SYMBOL (key);
3968 idx = get_font_prop_index (key);
3969 if (idx >= FONT_WEIGHT_INDEX && idx <= FONT_WIDTH_INDEX)
3970 return font_style_symbolic (font, idx, 0);
3971 if (idx >= 0 && idx < FONT_EXTRA_INDEX)
3972 return AREF (font, idx);
3973 val = Fassq (key, AREF (font, FONT_EXTRA_INDEX));
3974 if (NILP (val) && EQ (key, QCotf) && FONT_OBJECT_P (font))
3976 struct font *fontp = XFONT_OBJECT (font);
3978 if (fontp->driver->otf_capability)
3979 val = fontp->driver->otf_capability (fontp);
3980 else
3981 val = Fcons (Qnil, Qnil);
3983 else
3984 val = Fcdr (val);
3985 return val;
3988 #ifdef HAVE_WINDOW_SYSTEM
3990 DEFUN ("font-face-attributes", Ffont_face_attributes, Sfont_face_attributes, 1, 2, 0,
3991 doc: /* Return a plist of face attributes generated by FONT.
3992 FONT is a font name, a font-spec, a font-entity, or a font-object.
3993 The return value is a list of the form
3995 \(:family FAMILY :height HEIGHT :weight WEIGHT :slant SLANT :width WIDTH)
3997 where FAMILY, HEIGHT, WEIGHT, SLANT, and WIDTH are face attribute values
3998 compatible with `set-face-attribute'. Some of these key-attribute pairs
3999 may be omitted from the list if they are not specified by FONT.
4001 The optional argument FRAME specifies the frame that the face attributes
4002 are to be displayed on. If omitted, the selected frame is used. */)
4003 (Lisp_Object font, Lisp_Object frame)
4005 struct frame *f;
4006 Lisp_Object plist[10];
4007 Lisp_Object val;
4008 int n = 0;
4010 if (NILP (frame))
4011 frame = selected_frame;
4012 CHECK_LIVE_FRAME (frame);
4013 f = XFRAME (frame);
4015 if (STRINGP (font))
4017 int fontset = fs_query_fontset (font, 0);
4018 Lisp_Object name = font;
4019 if (fontset >= 0)
4020 font = fontset_ascii (fontset);
4021 font = font_spec_from_name (name);
4022 if (! FONTP (font))
4023 signal_error ("Invalid font name", name);
4025 else if (! FONTP (font))
4026 signal_error ("Invalid font object", font);
4028 val = AREF (font, FONT_FAMILY_INDEX);
4029 if (! NILP (val))
4031 plist[n++] = QCfamily;
4032 plist[n++] = SYMBOL_NAME (val);
4035 val = AREF (font, FONT_SIZE_INDEX);
4036 if (INTEGERP (val))
4038 Lisp_Object font_dpi = AREF (font, FONT_DPI_INDEX);
4039 int dpi = INTEGERP (font_dpi) ? XINT (font_dpi) : f->resy;
4040 plist[n++] = QCheight;
4041 plist[n++] = make_number (PIXEL_TO_POINT (XINT (val) * 10, dpi));
4043 else if (FLOATP (val))
4045 plist[n++] = QCheight;
4046 plist[n++] = make_number (10 * (int) XFLOAT_DATA (val));
4049 val = FONT_WEIGHT_FOR_FACE (font);
4050 if (! NILP (val))
4052 plist[n++] = QCweight;
4053 plist[n++] = val;
4056 val = FONT_SLANT_FOR_FACE (font);
4057 if (! NILP (val))
4059 plist[n++] = QCslant;
4060 plist[n++] = val;
4063 val = FONT_WIDTH_FOR_FACE (font);
4064 if (! NILP (val))
4066 plist[n++] = QCwidth;
4067 plist[n++] = val;
4070 return Flist (n, plist);
4073 #endif
4075 DEFUN ("font-put", Ffont_put, Sfont_put, 3, 3, 0,
4076 doc: /* Set one property of FONT: give property KEY value VAL.
4077 FONT is a font-spec, a font-entity, or a font-object.
4079 If FONT is a font-spec, KEY can be any symbol. But if KEY is the one
4080 accepted by the function `font-spec' (which see), VAL must be what
4081 allowed in `font-spec'.
4083 If FONT is a font-entity or a font-object, KEY must not be the one
4084 accepted by `font-spec'. */)
4085 (Lisp_Object font, Lisp_Object prop, Lisp_Object val)
4087 int idx;
4089 idx = get_font_prop_index (prop);
4090 if (idx >= 0 && idx < FONT_EXTRA_INDEX)
4092 CHECK_FONT_SPEC (font);
4093 ASET (font, idx, font_prop_validate (idx, Qnil, val));
4095 else
4097 if (EQ (prop, QCname)
4098 || EQ (prop, QCscript)
4099 || EQ (prop, QClang)
4100 || EQ (prop, QCotf))
4101 CHECK_FONT_SPEC (font);
4102 else
4103 CHECK_FONT (font);
4104 font_put_extra (font, prop, font_prop_validate (0, prop, val));
4106 return val;
4109 DEFUN ("list-fonts", Flist_fonts, Slist_fonts, 1, 4, 0,
4110 doc: /* List available fonts matching FONT-SPEC on the current frame.
4111 Optional 2nd argument FRAME specifies the target frame.
4112 Optional 3rd argument NUM, if non-nil, limits the number of returned fonts.
4113 Optional 4th argument PREFER, if non-nil, is a font-spec to
4114 control the order of the returned list. Fonts are sorted by
4115 how close they are to PREFER. */)
4116 (Lisp_Object font_spec, Lisp_Object frame, Lisp_Object num, Lisp_Object prefer)
4118 Lisp_Object vec, list;
4119 EMACS_INT n = 0;
4121 if (NILP (frame))
4122 frame = selected_frame;
4123 CHECK_LIVE_FRAME (frame);
4124 CHECK_FONT_SPEC (font_spec);
4125 if (! NILP (num))
4127 CHECK_NUMBER (num);
4128 n = XINT (num);
4129 if (n <= 0)
4130 return Qnil;
4132 if (! NILP (prefer))
4133 CHECK_FONT_SPEC (prefer);
4135 list = font_list_entities (frame, font_spec);
4136 if (NILP (list))
4137 return Qnil;
4138 if (NILP (XCDR (list))
4139 && ASIZE (XCAR (list)) == 1)
4140 return Fcons (AREF (XCAR (list), 0), Qnil);
4142 if (! NILP (prefer))
4143 vec = font_sort_entities (list, prefer, frame, 0);
4144 else
4145 vec = font_vconcat_entity_vectors (list);
4146 if (n == 0 || n >= ASIZE (vec))
4148 Lisp_Object args[2];
4150 args[0] = vec;
4151 args[1] = Qnil;
4152 list = Fappend (2, args);
4154 else
4156 for (list = Qnil, n--; n >= 0; n--)
4157 list = Fcons (AREF (vec, n), list);
4159 return list;
4162 DEFUN ("font-family-list", Ffont_family_list, Sfont_family_list, 0, 1, 0,
4163 doc: /* List available font families on the current frame.
4164 Optional argument FRAME, if non-nil, specifies the target frame. */)
4165 (Lisp_Object frame)
4167 FRAME_PTR f;
4168 struct font_driver_list *driver_list;
4169 Lisp_Object list;
4171 if (NILP (frame))
4172 frame = selected_frame;
4173 CHECK_LIVE_FRAME (frame);
4174 f = XFRAME (frame);
4175 list = Qnil;
4176 for (driver_list = f->font_driver_list; driver_list;
4177 driver_list = driver_list->next)
4178 if (driver_list->driver->list_family)
4180 Lisp_Object val = driver_list->driver->list_family (frame);
4181 Lisp_Object tail = list;
4183 for (; CONSP (val); val = XCDR (val))
4184 if (NILP (Fmemq (XCAR (val), tail))
4185 && SYMBOLP (XCAR (val)))
4186 list = Fcons (SYMBOL_NAME (XCAR (val)), list);
4188 return list;
4191 DEFUN ("find-font", Ffind_font, Sfind_font, 1, 2, 0,
4192 doc: /* Return a font-entity matching with FONT-SPEC on the current frame.
4193 Optional 2nd argument FRAME, if non-nil, specifies the target frame. */)
4194 (Lisp_Object font_spec, Lisp_Object frame)
4196 Lisp_Object val = Flist_fonts (font_spec, frame, make_number (1), Qnil);
4198 if (CONSP (val))
4199 val = XCAR (val);
4200 return val;
4203 DEFUN ("font-xlfd-name", Ffont_xlfd_name, Sfont_xlfd_name, 1, 2, 0,
4204 doc: /* Return XLFD name of FONT.
4205 FONT is a font-spec, font-entity, or font-object.
4206 If the name is too long for XLFD (maximum 255 chars), return nil.
4207 If the 2nd optional arg FOLD-WILDCARDS is non-nil,
4208 the consecutive wildcards are folded into one. */)
4209 (Lisp_Object font, Lisp_Object fold_wildcards)
4211 char name[256];
4212 int namelen, pixel_size = 0;
4214 CHECK_FONT (font);
4216 if (FONT_OBJECT_P (font))
4218 Lisp_Object font_name = AREF (font, FONT_NAME_INDEX);
4220 if (STRINGP (font_name)
4221 && SDATA (font_name)[0] == '-')
4223 if (NILP (fold_wildcards))
4224 return font_name;
4225 strcpy (name, SSDATA (font_name));
4226 namelen = SBYTES (font_name);
4227 goto done;
4229 pixel_size = XFONT_OBJECT (font)->pixel_size;
4231 namelen = font_unparse_xlfd (font, pixel_size, name, 256);
4232 if (namelen < 0)
4233 return Qnil;
4234 done:
4235 if (! NILP (fold_wildcards))
4237 char *p0 = name, *p1;
4239 while ((p1 = strstr (p0, "-*-*")))
4241 strcpy (p1, p1 + 2);
4242 namelen -= 2;
4243 p0 = p1;
4247 return make_string (name, namelen);
4250 DEFUN ("clear-font-cache", Fclear_font_cache, Sclear_font_cache, 0, 0, 0,
4251 doc: /* Clear font cache. */)
4252 (void)
4254 Lisp_Object list, frame;
4256 FOR_EACH_FRAME (list, frame)
4258 FRAME_PTR f = XFRAME (frame);
4259 struct font_driver_list *driver_list = f->font_driver_list;
4261 for (; driver_list; driver_list = driver_list->next)
4262 if (driver_list->on)
4264 Lisp_Object cache = driver_list->driver->get_cache (f);
4265 Lisp_Object val, tmp;
4267 val = XCDR (cache);
4268 while (! NILP (val)
4269 && ! EQ (XCAR (XCAR (val)), driver_list->driver->type))
4270 val = XCDR (val);
4271 font_assert (! NILP (val));
4272 tmp = XCDR (XCAR (val));
4273 if (XINT (XCAR (tmp)) == 0)
4275 font_clear_cache (f, XCAR (val), driver_list->driver);
4276 XSETCDR (cache, XCDR (val));
4281 return Qnil;
4285 void
4286 font_fill_lglyph_metrics (Lisp_Object glyph, Lisp_Object font_object)
4288 struct font *font = XFONT_OBJECT (font_object);
4289 unsigned code = font->driver->encode_char (font, LGLYPH_CHAR (glyph));
4290 struct font_metrics metrics;
4292 LGLYPH_SET_CODE (glyph, code);
4293 font->driver->text_extents (font, &code, 1, &metrics);
4294 LGLYPH_SET_LBEARING (glyph, metrics.lbearing);
4295 LGLYPH_SET_RBEARING (glyph, metrics.rbearing);
4296 LGLYPH_SET_WIDTH (glyph, metrics.width);
4297 LGLYPH_SET_ASCENT (glyph, metrics.ascent);
4298 LGLYPH_SET_DESCENT (glyph, metrics.descent);
4302 DEFUN ("font-shape-gstring", Ffont_shape_gstring, Sfont_shape_gstring, 1, 1, 0,
4303 doc: /* Shape the glyph-string GSTRING.
4304 Shaping means substituting glyphs and/or adjusting positions of glyphs
4305 to get the correct visual image of character sequences set in the
4306 header of the glyph-string.
4308 If the shaping was successful, the value is GSTRING itself or a newly
4309 created glyph-string. Otherwise, the value is nil. */)
4310 (Lisp_Object gstring)
4312 struct font *font;
4313 Lisp_Object font_object, n, glyph;
4314 ptrdiff_t i, j, from, to;
4316 if (! composition_gstring_p (gstring))
4317 signal_error ("Invalid glyph-string: ", gstring);
4318 if (! NILP (LGSTRING_ID (gstring)))
4319 return gstring;
4320 font_object = LGSTRING_FONT (gstring);
4321 CHECK_FONT_OBJECT (font_object);
4322 font = XFONT_OBJECT (font_object);
4323 if (! font->driver->shape)
4324 return Qnil;
4326 /* Try at most three times with larger gstring each time. */
4327 for (i = 0; i < 3; i++)
4329 n = font->driver->shape (gstring);
4330 if (INTEGERP (n))
4331 break;
4332 gstring = larger_vector (gstring,
4333 LGSTRING_GLYPH_LEN (gstring), -1);
4335 if (i == 3 || XINT (n) == 0)
4336 return Qnil;
4337 if (XINT (n) < LGSTRING_GLYPH_LEN (gstring))
4338 LGSTRING_SET_GLYPH (gstring, XINT (n), Qnil);
4340 glyph = LGSTRING_GLYPH (gstring, 0);
4341 from = LGLYPH_FROM (glyph);
4342 to = LGLYPH_TO (glyph);
4343 for (i = 1, j = 0; i < LGSTRING_GLYPH_LEN (gstring); i++)
4345 Lisp_Object this = LGSTRING_GLYPH (gstring, i);
4347 if (NILP (this))
4348 break;
4349 if (NILP (LGLYPH_ADJUSTMENT (this)))
4351 if (j < i - 1)
4352 for (; j < i; j++)
4354 glyph = LGSTRING_GLYPH (gstring, j);
4355 LGLYPH_SET_FROM (glyph, from);
4356 LGLYPH_SET_TO (glyph, to);
4358 from = LGLYPH_FROM (this);
4359 to = LGLYPH_TO (this);
4360 j = i;
4362 else
4364 if (from > LGLYPH_FROM (this))
4365 from = LGLYPH_FROM (this);
4366 if (to < LGLYPH_TO (this))
4367 to = LGLYPH_TO (this);
4370 if (j < i - 1)
4371 for (; j < i; j++)
4373 glyph = LGSTRING_GLYPH (gstring, j);
4374 LGLYPH_SET_FROM (glyph, from);
4375 LGLYPH_SET_TO (glyph, to);
4377 return composition_gstring_put_cache (gstring, XINT (n));
4380 DEFUN ("font-variation-glyphs", Ffont_variation_glyphs, Sfont_variation_glyphs,
4381 2, 2, 0,
4382 doc: /* Return a list of variation glyphs for CHAR in FONT-OBJECT.
4383 Each element of the value is a cons (VARIATION-SELECTOR . GLYPH-ID),
4384 where
4385 VARIATION-SELECTOR is a character code of variation selection
4386 (#xFE00..#xFE0F or #xE0100..#xE01EF)
4387 GLYPH-ID is a glyph code of the corresponding variation glyph. */)
4388 (Lisp_Object font_object, Lisp_Object character)
4390 unsigned variations[256];
4391 struct font *font;
4392 int i, n;
4393 Lisp_Object val;
4395 CHECK_FONT_OBJECT (font_object);
4396 CHECK_CHARACTER (character);
4397 font = XFONT_OBJECT (font_object);
4398 if (! font->driver->get_variation_glyphs)
4399 return Qnil;
4400 n = font->driver->get_variation_glyphs (font, XINT (character), variations);
4401 if (! n)
4402 return Qnil;
4403 val = Qnil;
4404 for (i = 0; i < 255; i++)
4405 if (variations[i])
4407 int vs = (i < 16 ? 0xFE00 + i : 0xE0100 + (i - 16));
4408 Lisp_Object code = INTEGER_TO_CONS (variations[i]);
4409 val = Fcons (Fcons (make_number (vs), code), val);
4411 return val;
4414 #if 0
4416 DEFUN ("font-drive-otf", Ffont_drive_otf, Sfont_drive_otf, 6, 6, 0,
4417 doc: /* Apply OpenType features on glyph-string GSTRING-IN.
4418 OTF-FEATURES specifies which features to apply in this format:
4419 (SCRIPT LANGSYS GSUB GPOS)
4420 where
4421 SCRIPT is a symbol specifying a script tag of OpenType,
4422 LANGSYS is a symbol specifying a langsys tag of OpenType,
4423 GSUB and GPOS, if non-nil, are lists of symbols specifying feature tags.
4425 If LANGYS is nil, the default langsys is selected.
4427 The features are applied in the order they appear in the list. The
4428 symbol `*' means to apply all available features not present in this
4429 list, and the remaining features are ignored. For instance, (vatu
4430 pstf * haln) is to apply vatu and pstf in this order, then to apply
4431 all available features other than vatu, pstf, and haln.
4433 The features are applied to the glyphs in the range FROM and TO of
4434 the glyph-string GSTRING-IN.
4436 If some feature is actually applicable, the resulting glyphs are
4437 produced in the glyph-string GSTRING-OUT from the index INDEX. In
4438 this case, the value is the number of produced glyphs.
4440 If no feature is applicable, no glyph is produced in GSTRING-OUT, and
4441 the value is 0.
4443 If GSTRING-OUT is too short to hold produced glyphs, no glyphs are
4444 produced in GSTRING-OUT, and the value is nil.
4446 See the documentation of `composition-get-gstring' for the format of
4447 glyph-string. */)
4448 (Lisp_Object otf_features, Lisp_Object gstring_in, Lisp_Object from, Lisp_Object to, Lisp_Object gstring_out, Lisp_Object index)
4450 Lisp_Object font_object = LGSTRING_FONT (gstring_in);
4451 Lisp_Object val;
4452 struct font *font;
4453 int len, num;
4455 check_otf_features (otf_features);
4456 CHECK_FONT_OBJECT (font_object);
4457 font = XFONT_OBJECT (font_object);
4458 if (! font->driver->otf_drive)
4459 error ("Font backend %s can't drive OpenType GSUB table",
4460 SDATA (SYMBOL_NAME (font->driver->type)));
4461 CHECK_CONS (otf_features);
4462 CHECK_SYMBOL (XCAR (otf_features));
4463 val = XCDR (otf_features);
4464 CHECK_SYMBOL (XCAR (val));
4465 val = XCDR (otf_features);
4466 if (! NILP (val))
4467 CHECK_CONS (val);
4468 len = check_gstring (gstring_in);
4469 CHECK_VECTOR (gstring_out);
4470 CHECK_NATNUM (from);
4471 CHECK_NATNUM (to);
4472 CHECK_NATNUM (index);
4474 if (XINT (from) >= XINT (to) || XINT (to) > len)
4475 args_out_of_range_3 (from, to, make_number (len));
4476 if (XINT (index) >= ASIZE (gstring_out))
4477 args_out_of_range (index, make_number (ASIZE (gstring_out)));
4478 num = font->driver->otf_drive (font, otf_features,
4479 gstring_in, XINT (from), XINT (to),
4480 gstring_out, XINT (index), 0);
4481 if (num < 0)
4482 return Qnil;
4483 return make_number (num);
4486 DEFUN ("font-otf-alternates", Ffont_otf_alternates, Sfont_otf_alternates,
4487 3, 3, 0,
4488 doc: /* Return a list of alternate glyphs of CHARACTER in FONT-OBJECT.
4489 OTF-FEATURES specifies which features of the font FONT-OBJECT to apply
4490 in this format:
4491 (SCRIPT LANGSYS FEATURE ...)
4492 See the documentation of `font-drive-otf' for more detail.
4494 The value is a list of cons cells of the format (GLYPH-ID . CHARACTER),
4495 where GLYPH-ID is a glyph index of the font, and CHARACTER is a
4496 character code corresponding to the glyph or nil if there's no
4497 corresponding character. */)
4498 (Lisp_Object font_object, Lisp_Object character, Lisp_Object otf_features)
4500 struct font *font;
4501 Lisp_Object gstring_in, gstring_out, g;
4502 Lisp_Object alternates;
4503 int i, num;
4505 CHECK_FONT_GET_OBJECT (font_object, font);
4506 if (! font->driver->otf_drive)
4507 error ("Font backend %s can't drive OpenType GSUB table",
4508 SDATA (SYMBOL_NAME (font->driver->type)));
4509 CHECK_CHARACTER (character);
4510 CHECK_CONS (otf_features);
4512 gstring_in = Ffont_make_gstring (font_object, make_number (1));
4513 g = LGSTRING_GLYPH (gstring_in, 0);
4514 LGLYPH_SET_CHAR (g, XINT (character));
4515 gstring_out = Ffont_make_gstring (font_object, make_number (10));
4516 while ((num = font->driver->otf_drive (font, otf_features, gstring_in, 0, 1,
4517 gstring_out, 0, 1)) < 0)
4518 gstring_out = Ffont_make_gstring (font_object,
4519 make_number (ASIZE (gstring_out) * 2));
4520 alternates = Qnil;
4521 for (i = 0; i < num; i++)
4523 Lisp_Object g = LGSTRING_GLYPH (gstring_out, i);
4524 int c = LGLYPH_CHAR (g);
4525 unsigned code = LGLYPH_CODE (g);
4527 alternates = Fcons (Fcons (make_number (code),
4528 c > 0 ? make_number (c) : Qnil),
4529 alternates);
4531 return Fnreverse (alternates);
4533 #endif /* 0 */
4535 #ifdef FONT_DEBUG
4537 DEFUN ("open-font", Fopen_font, Sopen_font, 1, 3, 0,
4538 doc: /* Open FONT-ENTITY. */)
4539 (Lisp_Object font_entity, Lisp_Object size, Lisp_Object frame)
4541 EMACS_INT isize;
4543 CHECK_FONT_ENTITY (font_entity);
4544 if (NILP (frame))
4545 frame = selected_frame;
4546 CHECK_LIVE_FRAME (frame);
4548 if (NILP (size))
4549 isize = XINT (AREF (font_entity, FONT_SIZE_INDEX));
4550 else
4552 CHECK_NUMBER_OR_FLOAT (size);
4553 if (FLOATP (size))
4554 isize = POINT_TO_PIXEL (XFLOAT_DATA (size), XFRAME (frame)->resy);
4555 else
4556 isize = XINT (size);
4557 if (! (INT_MIN <= isize && isize <= INT_MAX))
4558 args_out_of_range (font_entity, size);
4559 if (isize == 0)
4560 isize = 120;
4562 return font_open_entity (XFRAME (frame), font_entity, isize);
4565 DEFUN ("close-font", Fclose_font, Sclose_font, 1, 2, 0,
4566 doc: /* Close FONT-OBJECT. */)
4567 (Lisp_Object font_object, Lisp_Object frame)
4569 CHECK_FONT_OBJECT (font_object);
4570 if (NILP (frame))
4571 frame = selected_frame;
4572 CHECK_LIVE_FRAME (frame);
4573 font_close_object (XFRAME (frame), font_object);
4574 return Qnil;
4577 DEFUN ("query-font", Fquery_font, Squery_font, 1, 1, 0,
4578 doc: /* Return information about FONT-OBJECT.
4579 The value is a vector:
4580 [ NAME FILENAME PIXEL-SIZE SIZE ASCENT DESCENT SPACE-WIDTH AVERAGE-WIDTH
4581 CAPABILITY ]
4583 NAME is the font name, a string (or nil if the font backend doesn't
4584 provide a name).
4586 FILENAME is the font file name, a string (or nil if the font backend
4587 doesn't provide a file name).
4589 PIXEL-SIZE is a pixel size by which the font is opened.
4591 SIZE is a maximum advance width of the font in pixels.
4593 ASCENT, DESCENT, SPACE-WIDTH, AVERAGE-WIDTH are metrics of the font in
4594 pixels.
4596 CAPABILITY is a list whose first element is a symbol representing the
4597 font format \(x, opentype, truetype, type1, pcf, or bdf) and the
4598 remaining elements describe the details of the font capability.
4600 If the font is OpenType font, the form of the list is
4601 \(opentype GSUB GPOS)
4602 where GSUB shows which "GSUB" features the font supports, and GPOS
4603 shows which "GPOS" features the font supports. Both GSUB and GPOS are
4604 lists of the format:
4605 \((SCRIPT (LANGSYS FEATURE ...) ...) ...)
4607 If the font is not OpenType font, currently the length of the form is
4608 one.
4610 SCRIPT is a symbol representing OpenType script tag.
4612 LANGSYS is a symbol representing OpenType langsys tag, or nil
4613 representing the default langsys.
4615 FEATURE is a symbol representing OpenType feature tag.
4617 If the font is not OpenType font, CAPABILITY is nil. */)
4618 (Lisp_Object font_object)
4620 struct font *font;
4621 Lisp_Object val;
4623 CHECK_FONT_GET_OBJECT (font_object, font);
4625 val = Fmake_vector (make_number (9), Qnil);
4626 ASET (val, 0, AREF (font_object, FONT_NAME_INDEX));
4627 ASET (val, 1, AREF (font_object, FONT_FILE_INDEX));
4628 ASET (val, 2, make_number (font->pixel_size));
4629 ASET (val, 3, make_number (font->max_width));
4630 ASET (val, 4, make_number (font->ascent));
4631 ASET (val, 5, make_number (font->descent));
4632 ASET (val, 6, make_number (font->space_width));
4633 ASET (val, 7, make_number (font->average_width));
4634 if (font->driver->otf_capability)
4635 ASET (val, 8, Fcons (Qopentype, font->driver->otf_capability (font)));
4636 return val;
4639 DEFUN ("font-get-glyphs", Ffont_get_glyphs, Sfont_get_glyphs, 3, 4, 0,
4640 doc:
4641 /* Return a vector of FONT-OBJECT's glyphs for the specified characters.
4642 FROM and TO are positions (integers or markers) specifying a region
4643 of the current buffer.
4644 If the optional fourth arg OBJECT is not nil, it is a string or a
4645 vector containing the target characters.
4647 Each element is a vector containing information of a glyph in this format:
4648 [FROM-IDX TO-IDX C CODE WIDTH LBEARING RBEARING ASCENT DESCENT ADJUSTMENT]
4649 where
4650 FROM is an index numbers of a character the glyph corresponds to.
4651 TO is the same as FROM.
4652 C is the character of the glyph.
4653 CODE is the glyph-code of C in FONT-OBJECT.
4654 WIDTH thru DESCENT are the metrics (in pixels) of the glyph.
4655 ADJUSTMENT is always nil.
4656 If FONT-OBJECT doesn't have a glyph for a character,
4657 the corresponding element is nil. */)
4658 (Lisp_Object font_object, Lisp_Object from, Lisp_Object to,
4659 Lisp_Object object)
4661 struct font *font;
4662 ptrdiff_t i, len;
4663 Lisp_Object *chars, vec;
4664 USE_SAFE_ALLOCA;
4666 CHECK_FONT_GET_OBJECT (font_object, font);
4667 if (NILP (object))
4669 ptrdiff_t charpos, bytepos;
4671 validate_region (&from, &to);
4672 if (EQ (from, to))
4673 return Qnil;
4674 len = XFASTINT (to) - XFASTINT (from);
4675 SAFE_ALLOCA_LISP (chars, len);
4676 charpos = XFASTINT (from);
4677 bytepos = CHAR_TO_BYTE (charpos);
4678 for (i = 0; charpos < XFASTINT (to); i++)
4680 int c;
4681 FETCH_CHAR_ADVANCE (c, charpos, bytepos);
4682 chars[i] = make_number (c);
4685 else if (STRINGP (object))
4687 const unsigned char *p;
4689 CHECK_NUMBER (from);
4690 CHECK_NUMBER (to);
4691 if (XINT (from) < 0 || XINT (from) > XINT (to)
4692 || XINT (to) > SCHARS (object))
4693 args_out_of_range_3 (object, from, to);
4694 if (EQ (from, to))
4695 return Qnil;
4696 len = XFASTINT (to) - XFASTINT (from);
4697 SAFE_ALLOCA_LISP (chars, len);
4698 p = SDATA (object);
4699 if (STRING_MULTIBYTE (object))
4700 for (i = 0; i < len; i++)
4702 int c = STRING_CHAR_ADVANCE (p);
4703 chars[i] = make_number (c);
4705 else
4706 for (i = 0; i < len; i++)
4707 chars[i] = make_number (p[i]);
4709 else
4711 CHECK_VECTOR (object);
4712 CHECK_NUMBER (from);
4713 CHECK_NUMBER (to);
4714 if (XINT (from) < 0 || XINT (from) > XINT (to)
4715 || XINT (to) > ASIZE (object))
4716 args_out_of_range_3 (object, from, to);
4717 if (EQ (from, to))
4718 return Qnil;
4719 len = XFASTINT (to) - XFASTINT (from);
4720 for (i = 0; i < len; i++)
4722 Lisp_Object elt = AREF (object, XFASTINT (from) + i);
4723 CHECK_CHARACTER (elt);
4725 chars = aref_addr (object, XFASTINT (from));
4728 vec = Fmake_vector (make_number (len), Qnil);
4729 for (i = 0; i < len; i++)
4731 Lisp_Object g;
4732 int c = XFASTINT (chars[i]);
4733 unsigned code;
4734 struct font_metrics metrics;
4736 code = font->driver->encode_char (font, c);
4737 if (code == FONT_INVALID_CODE)
4738 continue;
4739 g = Fmake_vector (make_number (LGLYPH_SIZE), Qnil);
4740 LGLYPH_SET_FROM (g, i);
4741 LGLYPH_SET_TO (g, i);
4742 LGLYPH_SET_CHAR (g, c);
4743 LGLYPH_SET_CODE (g, code);
4744 font->driver->text_extents (font, &code, 1, &metrics);
4745 LGLYPH_SET_WIDTH (g, metrics.width);
4746 LGLYPH_SET_LBEARING (g, metrics.lbearing);
4747 LGLYPH_SET_RBEARING (g, metrics.rbearing);
4748 LGLYPH_SET_ASCENT (g, metrics.ascent);
4749 LGLYPH_SET_DESCENT (g, metrics.descent);
4750 ASET (vec, i, g);
4752 if (! VECTORP (object))
4753 SAFE_FREE ();
4754 return vec;
4757 DEFUN ("font-match-p", Ffont_match_p, Sfont_match_p, 2, 2, 0,
4758 doc: /* Return t if and only if font-spec SPEC matches with FONT.
4759 FONT is a font-spec, font-entity, or font-object. */)
4760 (Lisp_Object spec, Lisp_Object font)
4762 CHECK_FONT_SPEC (spec);
4763 CHECK_FONT (font);
4765 return (font_match_p (spec, font) ? Qt : Qnil);
4768 DEFUN ("font-at", Ffont_at, Sfont_at, 1, 3, 0,
4769 doc: /* Return a font-object for displaying a character at POSITION.
4770 Optional second arg WINDOW, if non-nil, is a window displaying
4771 the current buffer. It defaults to the currently selected window. */)
4772 (Lisp_Object position, Lisp_Object window, Lisp_Object string)
4774 struct window *w;
4775 ptrdiff_t pos;
4777 if (NILP (string))
4779 CHECK_NUMBER_COERCE_MARKER (position);
4780 if (! (BEGV <= XINT (position) && XINT (position) < ZV))
4781 args_out_of_range_3 (position, make_number (BEGV), make_number (ZV));
4782 pos = XINT (position);
4784 else
4786 CHECK_NUMBER (position);
4787 CHECK_STRING (string);
4788 if (! (0 < XINT (position) && XINT (position) < SCHARS (string)))
4789 args_out_of_range (string, position);
4790 pos = XINT (position);
4792 if (NILP (window))
4793 window = selected_window;
4794 CHECK_LIVE_WINDOW (window);
4795 w = XWINDOW (window);
4797 return font_at (-1, pos, NULL, w, string);
4800 #if 0
4801 DEFUN ("draw-string", Fdraw_string, Sdraw_string, 2, 2, 0,
4802 doc: /* Draw STRING by FONT-OBJECT on the top left corner of the current frame.
4803 The value is a number of glyphs drawn.
4804 Type C-l to recover what previously shown. */)
4805 (Lisp_Object font_object, Lisp_Object string)
4807 Lisp_Object frame = selected_frame;
4808 FRAME_PTR f = XFRAME (frame);
4809 struct font *font;
4810 struct face *face;
4811 int i, len, width;
4812 unsigned *code;
4814 CHECK_FONT_GET_OBJECT (font_object, font);
4815 CHECK_STRING (string);
4816 len = SCHARS (string);
4817 code = alloca (sizeof (unsigned) * len);
4818 for (i = 0; i < len; i++)
4820 Lisp_Object ch = Faref (string, make_number (i));
4821 Lisp_Object val;
4822 int c = XINT (ch);
4824 code[i] = font->driver->encode_char (font, c);
4825 if (code[i] == FONT_INVALID_CODE)
4826 break;
4828 face = FACE_FROM_ID (f, DEFAULT_FACE_ID);
4829 face->fontp = font;
4830 if (font->driver->prepare_face)
4831 font->driver->prepare_face (f, face);
4832 width = font->driver->text_extents (font, code, i, NULL);
4833 len = font->driver->draw_text (f, face, 0, font->ascent, code, i, width);
4834 if (font->driver->done_face)
4835 font->driver->done_face (f, face);
4836 face->fontp = NULL;
4837 return make_number (len);
4839 #endif
4841 #endif /* FONT_DEBUG */
4843 #ifdef HAVE_WINDOW_SYSTEM
4845 DEFUN ("font-info", Ffont_info, Sfont_info, 1, 2, 0,
4846 doc: /* Return information about a font named NAME on frame FRAME.
4847 If FRAME is omitted or nil, use the selected frame.
4848 The returned value is a vector of OPENED-NAME, FULL-NAME, SIZE,
4849 HEIGHT, BASELINE-OFFSET, RELATIVE-COMPOSE, and DEFAULT-ASCENT,
4850 where
4851 OPENED-NAME is the name used for opening the font,
4852 FULL-NAME is the full name of the font,
4853 SIZE is the pixelsize of the font,
4854 HEIGHT is the pixel-height of the font (i.e ascent + descent),
4855 BASELINE-OFFSET is the upward offset pixels from ASCII baseline,
4856 RELATIVE-COMPOSE and DEFAULT-ASCENT are the numbers controlling
4857 how to compose characters.
4858 If the named font is not yet loaded, return nil. */)
4859 (Lisp_Object name, Lisp_Object frame)
4861 FRAME_PTR f;
4862 struct font *font;
4863 Lisp_Object info;
4864 Lisp_Object font_object;
4866 (*check_window_system_func) ();
4868 if (! FONTP (name))
4869 CHECK_STRING (name);
4870 if (NILP (frame))
4871 frame = selected_frame;
4872 CHECK_LIVE_FRAME (frame);
4873 f = XFRAME (frame);
4875 if (STRINGP (name))
4877 int fontset = fs_query_fontset (name, 0);
4879 if (fontset >= 0)
4880 name = fontset_ascii (fontset);
4881 font_object = font_open_by_name (f, name);
4883 else if (FONT_OBJECT_P (name))
4884 font_object = name;
4885 else if (FONT_ENTITY_P (name))
4886 font_object = font_open_entity (f, name, 0);
4887 else
4889 struct face *face = FACE_FROM_ID (f, DEFAULT_FACE_ID);
4890 Lisp_Object entity = font_matching_entity (f, face->lface, name);
4892 font_object = ! NILP (entity) ? font_open_entity (f, entity, 0) : Qnil;
4894 if (NILP (font_object))
4895 return Qnil;
4896 font = XFONT_OBJECT (font_object);
4898 info = Fmake_vector (make_number (7), Qnil);
4899 ASET (info, 0, AREF (font_object, FONT_NAME_INDEX));
4900 ASET (info, 1, AREF (font_object, FONT_FULLNAME_INDEX));
4901 ASET (info, 2, make_number (font->pixel_size));
4902 ASET (info, 3, make_number (font->height));
4903 ASET (info, 4, make_number (font->baseline_offset));
4904 ASET (info, 5, make_number (font->relative_compose));
4905 ASET (info, 6, make_number (font->default_ascent));
4907 #if 0
4908 /* As font_object is still in FONT_OBJLIST of the entity, we can't
4909 close it now. Perhaps, we should manage font-objects
4910 by `reference-count'. */
4911 font_close_object (f, font_object);
4912 #endif
4913 return info;
4915 #endif
4918 #define BUILD_STYLE_TABLE(TBL) \
4919 build_style_table ((TBL), sizeof TBL / sizeof (struct table_entry))
4921 static Lisp_Object
4922 build_style_table (const struct table_entry *entry, int nelement)
4924 int i, j;
4925 Lisp_Object table, elt;
4927 table = Fmake_vector (make_number (nelement), Qnil);
4928 for (i = 0; i < nelement; i++)
4930 for (j = 0; entry[i].names[j]; j++);
4931 elt = Fmake_vector (make_number (j + 1), Qnil);
4932 ASET (elt, 0, make_number (entry[i].numeric));
4933 for (j = 0; entry[i].names[j]; j++)
4934 ASET (elt, j + 1, intern_c_string (entry[i].names[j]));
4935 ASET (table, i, elt);
4937 return table;
4940 /* The deferred font-log data of the form [ACTION ARG RESULT].
4941 If ACTION is not nil, that is added to the log when font_add_log is
4942 called next time. At that time, ACTION is set back to nil. */
4943 static Lisp_Object Vfont_log_deferred;
4945 /* Prepend the font-related logging data in Vfont_log if it is not
4946 `t'. ACTION describes a kind of font-related action (e.g. listing,
4947 opening), ARG is the argument for the action, and RESULT is the
4948 result of the action. */
4949 void
4950 font_add_log (const char *action, Lisp_Object arg, Lisp_Object result)
4952 Lisp_Object val;
4953 int i;
4955 if (EQ (Vfont_log, Qt))
4956 return;
4957 if (STRINGP (AREF (Vfont_log_deferred, 0)))
4959 char *str = SSDATA (AREF (Vfont_log_deferred, 0));
4961 ASET (Vfont_log_deferred, 0, Qnil);
4962 font_add_log (str, AREF (Vfont_log_deferred, 1),
4963 AREF (Vfont_log_deferred, 2));
4966 if (FONTP (arg))
4968 Lisp_Object tail, elt;
4969 Lisp_Object equalstr = build_string ("=");
4971 val = Ffont_xlfd_name (arg, Qt);
4972 for (tail = AREF (arg, FONT_EXTRA_INDEX); CONSP (tail);
4973 tail = XCDR (tail))
4975 elt = XCAR (tail);
4976 if (EQ (XCAR (elt), QCscript)
4977 && SYMBOLP (XCDR (elt)))
4978 val = concat3 (val, SYMBOL_NAME (QCscript),
4979 concat2 (equalstr, SYMBOL_NAME (XCDR (elt))));
4980 else if (EQ (XCAR (elt), QClang)
4981 && SYMBOLP (XCDR (elt)))
4982 val = concat3 (val, SYMBOL_NAME (QClang),
4983 concat2 (equalstr, SYMBOL_NAME (XCDR (elt))));
4984 else if (EQ (XCAR (elt), QCotf)
4985 && CONSP (XCDR (elt)) && SYMBOLP (XCAR (XCDR (elt))))
4986 val = concat3 (val, SYMBOL_NAME (QCotf),
4987 concat2 (equalstr,
4988 SYMBOL_NAME (XCAR (XCDR (elt)))));
4990 arg = val;
4993 if (CONSP (result)
4994 && VECTORP (XCAR (result))
4995 && ASIZE (XCAR (result)) > 0
4996 && FONTP (AREF (XCAR (result), 0)))
4997 result = font_vconcat_entity_vectors (result);
4998 if (FONTP (result))
5000 val = Ffont_xlfd_name (result, Qt);
5001 if (! FONT_SPEC_P (result))
5002 val = concat3 (SYMBOL_NAME (AREF (result, FONT_TYPE_INDEX)),
5003 build_string (":"), val);
5004 result = val;
5006 else if (CONSP (result))
5008 Lisp_Object tail;
5009 result = Fcopy_sequence (result);
5010 for (tail = result; CONSP (tail); tail = XCDR (tail))
5012 val = XCAR (tail);
5013 if (FONTP (val))
5014 val = Ffont_xlfd_name (val, Qt);
5015 XSETCAR (tail, val);
5018 else if (VECTORP (result))
5020 result = Fcopy_sequence (result);
5021 for (i = 0; i < ASIZE (result); i++)
5023 val = AREF (result, i);
5024 if (FONTP (val))
5025 val = Ffont_xlfd_name (val, Qt);
5026 ASET (result, i, val);
5029 Vfont_log = Fcons (list3 (intern (action), arg, result), Vfont_log);
5032 /* Record a font-related logging data to be added to Vfont_log when
5033 font_add_log is called next time. ACTION, ARG, RESULT are the same
5034 as font_add_log. */
5036 void
5037 font_deferred_log (const char *action, Lisp_Object arg, Lisp_Object result)
5039 if (EQ (Vfont_log, Qt))
5040 return;
5041 ASET (Vfont_log_deferred, 0, build_string (action));
5042 ASET (Vfont_log_deferred, 1, arg);
5043 ASET (Vfont_log_deferred, 2, result);
5046 void
5047 syms_of_font (void)
5049 sort_shift_bits[FONT_TYPE_INDEX] = 0;
5050 sort_shift_bits[FONT_SLANT_INDEX] = 2;
5051 sort_shift_bits[FONT_WEIGHT_INDEX] = 9;
5052 sort_shift_bits[FONT_SIZE_INDEX] = 16;
5053 sort_shift_bits[FONT_WIDTH_INDEX] = 23;
5054 /* Note that the other elements in sort_shift_bits are not used. */
5056 staticpro (&font_charset_alist);
5057 font_charset_alist = Qnil;
5059 DEFSYM (Qopentype, "opentype");
5061 DEFSYM (Qascii_0, "ascii-0");
5062 DEFSYM (Qiso8859_1, "iso8859-1");
5063 DEFSYM (Qiso10646_1, "iso10646-1");
5064 DEFSYM (Qunicode_bmp, "unicode-bmp");
5065 DEFSYM (Qunicode_sip, "unicode-sip");
5067 DEFSYM (QCf, "Cf");
5069 DEFSYM (QCotf, ":otf");
5070 DEFSYM (QClang, ":lang");
5071 DEFSYM (QCscript, ":script");
5072 DEFSYM (QCantialias, ":antialias");
5074 DEFSYM (QCfoundry, ":foundry");
5075 DEFSYM (QCadstyle, ":adstyle");
5076 DEFSYM (QCregistry, ":registry");
5077 DEFSYM (QCspacing, ":spacing");
5078 DEFSYM (QCdpi, ":dpi");
5079 DEFSYM (QCscalable, ":scalable");
5080 DEFSYM (QCavgwidth, ":avgwidth");
5081 DEFSYM (QCfont_entity, ":font-entity");
5082 DEFSYM (QCfc_unknown_spec, ":fc-unknown-spec");
5084 DEFSYM (Qc, "c");
5085 DEFSYM (Qm, "m");
5086 DEFSYM (Qp, "p");
5087 DEFSYM (Qd, "d");
5089 DEFSYM (Qja, "ja");
5090 DEFSYM (Qko, "ko");
5092 DEFSYM (QCuser_spec, "user-spec");
5094 staticpro (&scratch_font_spec);
5095 scratch_font_spec = Ffont_spec (0, NULL);
5096 staticpro (&scratch_font_prefer);
5097 scratch_font_prefer = Ffont_spec (0, NULL);
5099 staticpro (&Vfont_log_deferred);
5100 Vfont_log_deferred = Fmake_vector (make_number (3), Qnil);
5102 #if 0
5103 #ifdef HAVE_LIBOTF
5104 staticpro (&otf_list);
5105 otf_list = Qnil;
5106 #endif /* HAVE_LIBOTF */
5107 #endif /* 0 */
5109 defsubr (&Sfontp);
5110 defsubr (&Sfont_spec);
5111 defsubr (&Sfont_get);
5112 #ifdef HAVE_WINDOW_SYSTEM
5113 defsubr (&Sfont_face_attributes);
5114 #endif
5115 defsubr (&Sfont_put);
5116 defsubr (&Slist_fonts);
5117 defsubr (&Sfont_family_list);
5118 defsubr (&Sfind_font);
5119 defsubr (&Sfont_xlfd_name);
5120 defsubr (&Sclear_font_cache);
5121 defsubr (&Sfont_shape_gstring);
5122 defsubr (&Sfont_variation_glyphs);
5123 #if 0
5124 defsubr (&Sfont_drive_otf);
5125 defsubr (&Sfont_otf_alternates);
5126 #endif /* 0 */
5128 #ifdef FONT_DEBUG
5129 defsubr (&Sopen_font);
5130 defsubr (&Sclose_font);
5131 defsubr (&Squery_font);
5132 defsubr (&Sfont_get_glyphs);
5133 defsubr (&Sfont_match_p);
5134 defsubr (&Sfont_at);
5135 #if 0
5136 defsubr (&Sdraw_string);
5137 #endif
5138 #endif /* FONT_DEBUG */
5139 #ifdef HAVE_WINDOW_SYSTEM
5140 defsubr (&Sfont_info);
5141 #endif
5143 DEFVAR_LISP ("font-encoding-alist", Vfont_encoding_alist,
5144 doc: /*
5145 Alist of fontname patterns vs the corresponding encoding and repertory info.
5146 Each element looks like (REGEXP . (ENCODING . REPERTORY)),
5147 where ENCODING is a charset or a char-table,
5148 and REPERTORY is a charset, a char-table, or nil.
5150 If ENCODING and REPERTORY are the same, the element can have the form
5151 \(REGEXP . ENCODING).
5153 ENCODING is for converting a character to a glyph code of the font.
5154 If ENCODING is a charset, encoding a character by the charset gives
5155 the corresponding glyph code. If ENCODING is a char-table, looking up
5156 the table by a character gives the corresponding glyph code.
5158 REPERTORY specifies a repertory of characters supported by the font.
5159 If REPERTORY is a charset, all characters belonging to the charset are
5160 supported. If REPERTORY is a char-table, all characters who have a
5161 non-nil value in the table are supported. If REPERTORY is nil, Emacs
5162 gets the repertory information by an opened font and ENCODING. */);
5163 Vfont_encoding_alist = Qnil;
5165 /* FIXME: These 3 vars are not quite what they appear: setq on them
5166 won't have any effect other than disconnect them from the style
5167 table used by the font display code. So we make them read-only,
5168 to avoid this confusing situation. */
5170 DEFVAR_LISP_NOPRO ("font-weight-table", Vfont_weight_table,
5171 doc: /* Vector of valid font weight values.
5172 Each element has the form:
5173 [NUMERIC-VALUE SYMBOLIC-NAME ALIAS-NAME ...]
5174 NUMERIC-VALUE is an integer, and SYMBOLIC-NAME and ALIAS-NAME are symbols. */);
5175 Vfont_weight_table = BUILD_STYLE_TABLE (weight_table);
5176 XSYMBOL (intern_c_string ("font-weight-table"))->constant = 1;
5178 DEFVAR_LISP_NOPRO ("font-slant-table", Vfont_slant_table,
5179 doc: /* Vector of font slant symbols vs the corresponding numeric values.
5180 See `font-weight-table' for the format of the vector. */);
5181 Vfont_slant_table = BUILD_STYLE_TABLE (slant_table);
5182 XSYMBOL (intern_c_string ("font-slant-table"))->constant = 1;
5184 DEFVAR_LISP_NOPRO ("font-width-table", Vfont_width_table,
5185 doc: /* Alist of font width symbols vs the corresponding numeric values.
5186 See `font-weight-table' for the format of the vector. */);
5187 Vfont_width_table = BUILD_STYLE_TABLE (width_table);
5188 XSYMBOL (intern_c_string ("font-width-table"))->constant = 1;
5190 staticpro (&font_style_table);
5191 font_style_table = Fmake_vector (make_number (3), Qnil);
5192 ASET (font_style_table, 0, Vfont_weight_table);
5193 ASET (font_style_table, 1, Vfont_slant_table);
5194 ASET (font_style_table, 2, Vfont_width_table);
5196 DEFVAR_LISP ("font-log", Vfont_log, doc: /*
5197 *Logging list of font related actions and results.
5198 The value t means to suppress the logging.
5199 The initial value is set to nil if the environment variable
5200 EMACS_FONT_LOG is set. Otherwise, it is set to t. */);
5201 Vfont_log = Qnil;
5203 #ifdef HAVE_WINDOW_SYSTEM
5204 #ifdef HAVE_FREETYPE
5205 syms_of_ftfont ();
5206 #ifdef HAVE_X_WINDOWS
5207 syms_of_xfont ();
5208 syms_of_ftxfont ();
5209 #ifdef HAVE_XFT
5210 syms_of_xftfont ();
5211 #endif /* HAVE_XFT */
5212 #endif /* HAVE_X_WINDOWS */
5213 #else /* not HAVE_FREETYPE */
5214 #ifdef HAVE_X_WINDOWS
5215 syms_of_xfont ();
5216 #endif /* HAVE_X_WINDOWS */
5217 #endif /* not HAVE_FREETYPE */
5218 #ifdef HAVE_BDFFONT
5219 syms_of_bdffont ();
5220 #endif /* HAVE_BDFFONT */
5221 #ifdef WINDOWSNT
5222 syms_of_w32font ();
5223 #endif /* WINDOWSNT */
5224 #ifdef HAVE_NS
5225 syms_of_nsfont ();
5226 #endif /* HAVE_NS */
5227 #endif /* HAVE_WINDOW_SYSTEM */
5230 void
5231 init_font (void)
5233 Vfont_log = egetenv ("EMACS_FONT_LOG") ? Qnil : Qt;