]> code.delx.au - gnu-emacs/blob - src/font.c
Tweak for sgml-transformation-function
[gnu-emacs] / src / font.c
1 /* font.c -- "Font" primitives.
2
3 Copyright (C) 2006-2013 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
7
8 This file is part of GNU Emacs.
9
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.
14
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.
19
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/>. */
22
23 #include <config.h>
24 #include <float.h>
25 #include <stdio.h>
26
27 #include <c-ctype.h>
28
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"
39
40 #ifdef HAVE_WINDOW_SYSTEM
41 #include TERM_HEADER
42 #endif /* HAVE_WINDOW_SYSTEM */
43
44 Lisp_Object Qopentype;
45
46 /* Important character set strings. */
47 Lisp_Object Qascii_0, Qiso8859_1, Qiso10646_1, Qunicode_bmp, Qunicode_sip;
48
49 #define DEFAULT_ENCODING Qiso8859_1
50
51 /* Unicode category `Cf'. */
52 static Lisp_Object QCf;
53
54 /* Vector of Vfont_weight_table, Vfont_slant_table, and Vfont_width_table. */
55 static Lisp_Object font_style_table;
56
57 /* Structure used for tables mapping weight, slant, and width numeric
58 values and their names. */
59
60 struct table_entry
61 {
62 int numeric;
63 /* The first one is a valid name as a face attribute.
64 The second one (if any) is a typical name in XLFD field. */
65 const char *names[5];
66 };
67
68 /* Table of weight numeric values and their names. This table must be
69 sorted by numeric values in ascending order. */
70
71 static const struct table_entry weight_table[] =
72 {
73 { 0, { "thin" }},
74 { 20, { "ultra-light", "ultralight" }},
75 { 40, { "extra-light", "extralight" }},
76 { 50, { "light" }},
77 { 75, { "semi-light", "semilight", "demilight", "book" }},
78 { 100, { "normal", "medium", "regular", "unspecified" }},
79 { 180, { "semi-bold", "semibold", "demibold", "demi" }},
80 { 200, { "bold" }},
81 { 205, { "extra-bold", "extrabold" }},
82 { 210, { "ultra-bold", "ultrabold", "black" }}
83 };
84
85 /* Table of slant numeric values and their names. This table must be
86 sorted by numeric values in ascending order. */
87
88 static const struct table_entry slant_table[] =
89 {
90 { 0, { "reverse-oblique", "ro" }},
91 { 10, { "reverse-italic", "ri" }},
92 { 100, { "normal", "r", "unspecified" }},
93 { 200, { "italic" ,"i", "ot" }},
94 { 210, { "oblique", "o" }}
95 };
96
97 /* Table of width numeric values and their names. This table must be
98 sorted by numeric values in ascending order. */
99
100 static const struct table_entry width_table[] =
101 {
102 { 50, { "ultra-condensed", "ultracondensed" }},
103 { 63, { "extra-condensed", "extracondensed" }},
104 { 75, { "condensed", "compressed", "narrow" }},
105 { 87, { "semi-condensed", "semicondensed", "demicondensed" }},
106 { 100, { "normal", "medium", "regular", "unspecified" }},
107 { 113, { "semi-expanded", "semiexpanded", "demiexpanded" }},
108 { 125, { "expanded" }},
109 { 150, { "extra-expanded", "extraexpanded" }},
110 { 200, { "ultra-expanded", "ultraexpanded", "wide" }}
111 };
112
113 Lisp_Object QCfoundry;
114 static Lisp_Object QCadstyle, QCregistry;
115 /* Symbols representing keys of font extra info. */
116 Lisp_Object QCspacing, QCdpi, QCscalable, QCotf, QClang, QCscript, QCavgwidth;
117 Lisp_Object QCantialias, QCfont_entity;
118 static Lisp_Object QCfc_unknown_spec;
119 /* Symbols representing values of font spacing property. */
120 static Lisp_Object Qc, Qm, Qd;
121 Lisp_Object Qp;
122 /* Special ADSTYLE properties to avoid fonts used for Latin
123 characters; used in xfont.c and ftfont.c. */
124 Lisp_Object Qja, Qko;
125
126 static Lisp_Object QCuser_spec;
127
128 /* Alist of font registry symbols and the corresponding charset
129 information. The information is retrieved from
130 Vfont_encoding_alist on demand.
131
132 Eash element has the form:
133 (REGISTRY . (ENCODING-CHARSET-ID . REPERTORY-CHARSET-ID))
134 or
135 (REGISTRY . nil)
136
137 In the former form, ENCODING-CHARSET-ID is an ID of a charset that
138 encodes a character code to a glyph code of a font, and
139 REPERTORY-CHARSET-ID is an ID of a charset that tells if a
140 character is supported by a font.
141
142 The latter form means that the information for REGISTRY couldn't be
143 retrieved. */
144 static Lisp_Object font_charset_alist;
145
146 /* List of all font drivers. Each font-backend (XXXfont.c) calls
147 register_font_driver in syms_of_XXXfont to register its font-driver
148 here. */
149 static struct font_driver_list *font_driver_list;
150
151 \f
152
153 /* Creators of font-related Lisp object. */
154
155 static Lisp_Object
156 font_make_spec (void)
157 {
158 Lisp_Object font_spec;
159 struct font_spec *spec
160 = ((struct font_spec *)
161 allocate_pseudovector (VECSIZE (struct font_spec),
162 FONT_SPEC_MAX, PVEC_FONT));
163 XSETFONT (font_spec, spec);
164 return font_spec;
165 }
166
167 Lisp_Object
168 font_make_entity (void)
169 {
170 Lisp_Object font_entity;
171 struct font_entity *entity
172 = ((struct font_entity *)
173 allocate_pseudovector (VECSIZE (struct font_entity),
174 FONT_ENTITY_MAX, PVEC_FONT));
175 XSETFONT (font_entity, entity);
176 return font_entity;
177 }
178
179 /* Create a font-object whose structure size is SIZE. If ENTITY is
180 not nil, copy properties from ENTITY to the font-object. If
181 PIXELSIZE is positive, set the `size' property to PIXELSIZE. */
182 Lisp_Object
183 font_make_object (int size, Lisp_Object entity, int pixelsize)
184 {
185 Lisp_Object font_object;
186 struct font *font
187 = (struct font *) allocate_pseudovector (size, FONT_OBJECT_MAX, PVEC_FONT);
188 int i;
189
190 XSETFONT (font_object, font);
191
192 if (! NILP (entity))
193 {
194 for (i = 1; i < FONT_SPEC_MAX; i++)
195 font->props[i] = AREF (entity, i);
196 if (! NILP (AREF (entity, FONT_EXTRA_INDEX)))
197 font->props[FONT_EXTRA_INDEX]
198 = Fcopy_alist (AREF (entity, FONT_EXTRA_INDEX));
199 }
200 if (size > 0)
201 font->props[FONT_SIZE_INDEX] = make_number (pixelsize);
202 return font_object;
203 }
204
205 \f
206
207 static int font_pixel_size (FRAME_PTR f, Lisp_Object);
208 static Lisp_Object font_open_entity (FRAME_PTR, Lisp_Object, int);
209 static Lisp_Object font_matching_entity (FRAME_PTR, Lisp_Object *,
210 Lisp_Object);
211 static unsigned font_encode_char (Lisp_Object, int);
212
213 /* Number of registered font drivers. */
214 static int num_font_drivers;
215
216
217 /* Return a Lispy value of a font property value at STR and LEN bytes.
218 If STR is "*", return nil. If FORCE_SYMBOL, or if STR does not
219 consist entirely of one or more digits, return a symbol interned
220 from STR. Otherwise, return an integer. */
221
222 Lisp_Object
223 font_intern_prop (const char *str, ptrdiff_t len, bool force_symbol)
224 {
225 ptrdiff_t i;
226 Lisp_Object tem;
227 Lisp_Object obarray;
228 ptrdiff_t nbytes, nchars;
229
230 if (len == 1 && *str == '*')
231 return Qnil;
232 if (!force_symbol && 0 < len && '0' <= *str && *str <= '9')
233 {
234 for (i = 1; i < len; i++)
235 if (! ('0' <= str[i] && str[i] <= '9'))
236 break;
237 if (i == len)
238 {
239 EMACS_INT n;
240
241 i = 0;
242 for (n = 0; (n += str[i++] - '0') <= MOST_POSITIVE_FIXNUM; n *= 10)
243 {
244 if (i == len)
245 return make_number (n);
246 if (MOST_POSITIVE_FIXNUM / 10 < n)
247 break;
248 }
249
250 xsignal1 (Qoverflow_error, make_string (str, len));
251 }
252 }
253
254 /* This code is similar to intern function from lread.c. */
255 obarray = check_obarray (Vobarray);
256 parse_str_as_multibyte ((unsigned char *) str, len, &nchars, &nbytes);
257 tem = oblookup (obarray, str,
258 (len == nchars || len != nbytes) ? len : nchars, len);
259
260 if (SYMBOLP (tem))
261 return tem;
262 if (len == nchars || len != nbytes)
263 tem = make_unibyte_string (str, len);
264 else
265 tem = make_multibyte_string (str, nchars, len);
266 return Fintern (tem, obarray);
267 }
268
269 /* Return a pixel size of font-spec SPEC on frame F. */
270
271 static int
272 font_pixel_size (FRAME_PTR f, Lisp_Object spec)
273 {
274 #ifdef HAVE_WINDOW_SYSTEM
275 Lisp_Object size = AREF (spec, FONT_SIZE_INDEX);
276 double point_size;
277 int dpi, pixel_size;
278 Lisp_Object val;
279
280 if (INTEGERP (size))
281 return XINT (size);
282 if (NILP (size))
283 return 0;
284 eassert (FLOATP (size));
285 point_size = XFLOAT_DATA (size);
286 val = AREF (spec, FONT_DPI_INDEX);
287 if (INTEGERP (val))
288 dpi = XINT (val);
289 else
290 dpi = f->resy;
291 pixel_size = POINT_TO_PIXEL (point_size, dpi);
292 return pixel_size;
293 #else
294 return 1;
295 #endif
296 }
297
298
299 /* Return a value of PROP's VAL (symbol or integer) to be stored in a
300 font vector. If VAL is not valid (i.e. not registered in
301 font_style_table), return -1 if NOERROR is zero, and return a
302 proper index if NOERROR is nonzero. In that case, register VAL in
303 font_style_table if VAL is a symbol, and return the closest index if
304 VAL is an integer. */
305
306 int
307 font_style_to_value (enum font_property_index prop, Lisp_Object val,
308 bool noerror)
309 {
310 Lisp_Object table = AREF (font_style_table, prop - FONT_WEIGHT_INDEX);
311 int len;
312
313 CHECK_VECTOR (table);
314 len = ASIZE (table);
315
316 if (SYMBOLP (val))
317 {
318 int i, j;
319 char *s;
320 Lisp_Object args[2], elt;
321
322 /* At first try exact match. */
323 for (i = 0; i < len; i++)
324 {
325 CHECK_VECTOR (AREF (table, i));
326 for (j = 1; j < ASIZE (AREF (table, i)); j++)
327 if (EQ (val, AREF (AREF (table, i), j)))
328 {
329 CHECK_NUMBER (AREF (AREF (table, i), 0));
330 return ((XINT (AREF (AREF (table, i), 0)) << 8)
331 | (i << 4) | (j - 1));
332 }
333 }
334 /* Try also with case-folding match. */
335 s = SSDATA (SYMBOL_NAME (val));
336 for (i = 0; i < len; i++)
337 for (j = 1; j < ASIZE (AREF (table, i)); j++)
338 {
339 elt = AREF (AREF (table, i), j);
340 if (xstrcasecmp (s, SSDATA (SYMBOL_NAME (elt))) == 0)
341 {
342 CHECK_NUMBER (AREF (AREF (table, i), 0));
343 return ((XINT (AREF (AREF (table, i), 0)) << 8)
344 | (i << 4) | (j - 1));
345 }
346 }
347 if (! noerror)
348 return -1;
349 eassert (len < 255);
350 elt = Fmake_vector (make_number (2), make_number (100));
351 ASET (elt, 1, val);
352 args[0] = table;
353 args[1] = Fmake_vector (make_number (1), elt);
354 ASET (font_style_table, prop - FONT_WEIGHT_INDEX, Fvconcat (2, args));
355 return (100 << 8) | (i << 4);
356 }
357 else
358 {
359 int i, last_n;
360 EMACS_INT numeric = XINT (val);
361
362 for (i = 0, last_n = -1; i < len; i++)
363 {
364 int n;
365
366 CHECK_VECTOR (AREF (table, i));
367 CHECK_NUMBER (AREF (AREF (table, i), 0));
368 n = XINT (AREF (AREF (table, i), 0));
369 if (numeric == n)
370 return (n << 8) | (i << 4);
371 if (numeric < n)
372 {
373 if (! noerror)
374 return -1;
375 return ((i == 0 || n - numeric < numeric - last_n)
376 ? (n << 8) | (i << 4): (last_n << 8 | ((i - 1) << 4)));
377 }
378 last_n = n;
379 }
380 if (! noerror)
381 return -1;
382 return ((last_n << 8) | ((i - 1) << 4));
383 }
384 }
385
386 Lisp_Object
387 font_style_symbolic (Lisp_Object font, enum font_property_index prop,
388 bool for_face)
389 {
390 Lisp_Object val = AREF (font, prop);
391 Lisp_Object table, elt;
392 int i;
393
394 if (NILP (val))
395 return Qnil;
396 table = AREF (font_style_table, prop - FONT_WEIGHT_INDEX);
397 CHECK_VECTOR (table);
398 i = XINT (val) & 0xFF;
399 eassert (((i >> 4) & 0xF) < ASIZE (table));
400 elt = AREF (table, ((i >> 4) & 0xF));
401 CHECK_VECTOR (elt);
402 eassert ((i & 0xF) + 1 < ASIZE (elt));
403 elt = (for_face ? AREF (elt, 1) : AREF (elt, (i & 0xF) + 1));
404 CHECK_SYMBOL (elt);
405 return elt;
406 }
407
408 /* Return ENCODING or a cons of ENCODING and REPERTORY of the font
409 FONTNAME. ENCODING is a charset symbol that specifies the encoding
410 of the font. REPERTORY is a charset symbol or nil. */
411
412 Lisp_Object
413 find_font_encoding (Lisp_Object fontname)
414 {
415 Lisp_Object tail, elt;
416
417 for (tail = Vfont_encoding_alist; CONSP (tail); tail = XCDR (tail))
418 {
419 elt = XCAR (tail);
420 if (CONSP (elt)
421 && STRINGP (XCAR (elt))
422 && fast_string_match_ignore_case (XCAR (elt), fontname) >= 0
423 && (SYMBOLP (XCDR (elt))
424 ? CHARSETP (XCDR (elt))
425 : CONSP (XCDR (elt)) && CHARSETP (XCAR (XCDR (elt)))))
426 return (XCDR (elt));
427 }
428 return Qnil;
429 }
430
431 /* Return encoding charset and repertory charset for REGISTRY in
432 ENCODING and REPERTORY correspondingly. If correct information for
433 REGISTRY is available, return 0. Otherwise return -1. */
434
435 int
436 font_registry_charsets (Lisp_Object registry, struct charset **encoding, struct charset **repertory)
437 {
438 Lisp_Object val;
439 int encoding_id, repertory_id;
440
441 val = Fassoc_string (registry, font_charset_alist, Qt);
442 if (! NILP (val))
443 {
444 val = XCDR (val);
445 if (NILP (val))
446 return -1;
447 encoding_id = XINT (XCAR (val));
448 repertory_id = XINT (XCDR (val));
449 }
450 else
451 {
452 val = find_font_encoding (SYMBOL_NAME (registry));
453 if (SYMBOLP (val) && CHARSETP (val))
454 {
455 encoding_id = repertory_id = XINT (CHARSET_SYMBOL_ID (val));
456 }
457 else if (CONSP (val))
458 {
459 if (! CHARSETP (XCAR (val)))
460 goto invalid_entry;
461 encoding_id = XINT (CHARSET_SYMBOL_ID (XCAR (val)));
462 if (NILP (XCDR (val)))
463 repertory_id = -1;
464 else
465 {
466 if (! CHARSETP (XCDR (val)))
467 goto invalid_entry;
468 repertory_id = XINT (CHARSET_SYMBOL_ID (XCDR (val)));
469 }
470 }
471 else
472 goto invalid_entry;
473 val = Fcons (make_number (encoding_id), make_number (repertory_id));
474 font_charset_alist
475 = nconc2 (font_charset_alist, Fcons (Fcons (registry, val), Qnil));
476 }
477
478 if (encoding)
479 *encoding = CHARSET_FROM_ID (encoding_id);
480 if (repertory)
481 *repertory = repertory_id >= 0 ? CHARSET_FROM_ID (repertory_id) : NULL;
482 return 0;
483
484 invalid_entry:
485 font_charset_alist
486 = nconc2 (font_charset_alist, Fcons (Fcons (registry, Qnil), Qnil));
487 return -1;
488 }
489
490 \f
491 /* Font property value validators. See the comment of
492 font_property_table for the meaning of the arguments. */
493
494 static Lisp_Object font_prop_validate (int, Lisp_Object, Lisp_Object);
495 static Lisp_Object font_prop_validate_symbol (Lisp_Object, Lisp_Object);
496 static Lisp_Object font_prop_validate_style (Lisp_Object, Lisp_Object);
497 static Lisp_Object font_prop_validate_non_neg (Lisp_Object, Lisp_Object);
498 static Lisp_Object font_prop_validate_spacing (Lisp_Object, Lisp_Object);
499 static int get_font_prop_index (Lisp_Object);
500
501 static Lisp_Object
502 font_prop_validate_symbol (Lisp_Object prop, Lisp_Object val)
503 {
504 if (STRINGP (val))
505 val = Fintern (val, Qnil);
506 if (! SYMBOLP (val))
507 val = Qerror;
508 else if (EQ (prop, QCregistry))
509 val = Fintern (Fdowncase (SYMBOL_NAME (val)), Qnil);
510 return val;
511 }
512
513
514 static Lisp_Object
515 font_prop_validate_style (Lisp_Object style, Lisp_Object val)
516 {
517 enum font_property_index prop = (EQ (style, QCweight) ? FONT_WEIGHT_INDEX
518 : EQ (style, QCslant) ? FONT_SLANT_INDEX
519 : FONT_WIDTH_INDEX);
520 if (INTEGERP (val))
521 {
522 EMACS_INT n = XINT (val);
523 CHECK_VECTOR (AREF (font_style_table, prop - FONT_WEIGHT_INDEX));
524 if (((n >> 4) & 0xF)
525 >= ASIZE (AREF (font_style_table, prop - FONT_WEIGHT_INDEX)))
526 val = Qerror;
527 else
528 {
529 Lisp_Object elt = AREF (AREF (font_style_table, prop - FONT_WEIGHT_INDEX), (n >> 4) & 0xF);
530
531 CHECK_VECTOR (elt);
532 if ((n & 0xF) + 1 >= ASIZE (elt))
533 val = Qerror;
534 else
535 {
536 CHECK_NUMBER (AREF (elt, 0));
537 if (XINT (AREF (elt, 0)) != (n >> 8))
538 val = Qerror;
539 }
540 }
541 }
542 else if (SYMBOLP (val))
543 {
544 int n = font_style_to_value (prop, val, 0);
545
546 val = n >= 0 ? make_number (n) : Qerror;
547 }
548 else
549 val = Qerror;
550 return val;
551 }
552
553 static Lisp_Object
554 font_prop_validate_non_neg (Lisp_Object prop, Lisp_Object val)
555 {
556 return (NATNUMP (val) || (FLOATP (val) && XFLOAT_DATA (val) >= 0)
557 ? val : Qerror);
558 }
559
560 static Lisp_Object
561 font_prop_validate_spacing (Lisp_Object prop, Lisp_Object val)
562 {
563 if (NILP (val) || (NATNUMP (val) && XINT (val) <= FONT_SPACING_CHARCELL))
564 return val;
565 if (SYMBOLP (val) && SBYTES (SYMBOL_NAME (val)) == 1)
566 {
567 char spacing = SDATA (SYMBOL_NAME (val))[0];
568
569 if (spacing == 'c' || spacing == 'C')
570 return make_number (FONT_SPACING_CHARCELL);
571 if (spacing == 'm' || spacing == 'M')
572 return make_number (FONT_SPACING_MONO);
573 if (spacing == 'p' || spacing == 'P')
574 return make_number (FONT_SPACING_PROPORTIONAL);
575 if (spacing == 'd' || spacing == 'D')
576 return make_number (FONT_SPACING_DUAL);
577 }
578 return Qerror;
579 }
580
581 static Lisp_Object
582 font_prop_validate_otf (Lisp_Object prop, Lisp_Object val)
583 {
584 Lisp_Object tail, tmp;
585 int i;
586
587 /* VAL = (SCRIPT [ LANGSYS [ GSUB-FEATURES [ GPOS-FEATURES ]]])
588 GSUB-FEATURES = (FEATURE ... [ nil FEATURE ... ]) | nil
589 GPOS-FEATURES = (FEATURE ... [ nil FEATURE ... ]) | nil */
590 if (! CONSP (val))
591 return Qerror;
592 if (! SYMBOLP (XCAR (val)))
593 return Qerror;
594 tail = XCDR (val);
595 if (NILP (tail))
596 return val;
597 if (! CONSP (tail) || ! SYMBOLP (XCAR (val)))
598 return Qerror;
599 for (i = 0; i < 2; i++)
600 {
601 tail = XCDR (tail);
602 if (NILP (tail))
603 return val;
604 if (! CONSP (tail))
605 return Qerror;
606 for (tmp = XCAR (tail); CONSP (tmp); tmp = XCDR (tmp))
607 if (! SYMBOLP (XCAR (tmp)))
608 return Qerror;
609 if (! NILP (tmp))
610 return Qerror;
611 }
612 return val;
613 }
614
615 /* Structure of known font property keys and validator of the
616 values. */
617 static const struct
618 {
619 /* Pointer to the key symbol. */
620 Lisp_Object *key;
621 /* Function to validate PROP's value VAL, or NULL if any value is
622 ok. The value is VAL or its regularized value if VAL is valid,
623 and Qerror if not. */
624 Lisp_Object (*validator) (Lisp_Object prop, Lisp_Object val);
625 } font_property_table[] =
626 { { &QCtype, font_prop_validate_symbol },
627 { &QCfoundry, font_prop_validate_symbol },
628 { &QCfamily, font_prop_validate_symbol },
629 { &QCadstyle, font_prop_validate_symbol },
630 { &QCregistry, font_prop_validate_symbol },
631 { &QCweight, font_prop_validate_style },
632 { &QCslant, font_prop_validate_style },
633 { &QCwidth, font_prop_validate_style },
634 { &QCsize, font_prop_validate_non_neg },
635 { &QCdpi, font_prop_validate_non_neg },
636 { &QCspacing, font_prop_validate_spacing },
637 { &QCavgwidth, font_prop_validate_non_neg },
638 /* The order of the above entries must match with enum
639 font_property_index. */
640 { &QClang, font_prop_validate_symbol },
641 { &QCscript, font_prop_validate_symbol },
642 { &QCotf, font_prop_validate_otf }
643 };
644
645 /* Size (number of elements) of the above table. */
646 #define FONT_PROPERTY_TABLE_SIZE \
647 ((sizeof font_property_table) / (sizeof *font_property_table))
648
649 /* Return an index number of font property KEY or -1 if KEY is not an
650 already known property. */
651
652 static int
653 get_font_prop_index (Lisp_Object key)
654 {
655 int i;
656
657 for (i = 0; i < FONT_PROPERTY_TABLE_SIZE; i++)
658 if (EQ (key, *font_property_table[i].key))
659 return i;
660 return -1;
661 }
662
663 /* Validate the font property. The property key is specified by the
664 symbol PROP, or the index IDX (if PROP is nil). If VAL is invalid,
665 signal an error. The value is VAL or the regularized one. */
666
667 static Lisp_Object
668 font_prop_validate (int idx, Lisp_Object prop, Lisp_Object val)
669 {
670 Lisp_Object validated;
671
672 if (NILP (val))
673 return val;
674 if (NILP (prop))
675 prop = *font_property_table[idx].key;
676 else
677 {
678 idx = get_font_prop_index (prop);
679 if (idx < 0)
680 return val;
681 }
682 validated = (font_property_table[idx].validator) (prop, val);
683 if (EQ (validated, Qerror))
684 signal_error ("invalid font property", Fcons (prop, val));
685 return validated;
686 }
687
688
689 /* Store VAL as a value of extra font property PROP in FONT while
690 keeping the sorting order. Don't check the validity of VAL. */
691
692 Lisp_Object
693 font_put_extra (Lisp_Object font, Lisp_Object prop, Lisp_Object val)
694 {
695 Lisp_Object extra = AREF (font, FONT_EXTRA_INDEX);
696 Lisp_Object slot = (NILP (extra) ? Qnil : assq_no_quit (prop, extra));
697
698 if (NILP (slot))
699 {
700 Lisp_Object prev = Qnil;
701
702 while (CONSP (extra)
703 && NILP (Fstring_lessp (prop, XCAR (XCAR (extra)))))
704 prev = extra, extra = XCDR (extra);
705
706 if (NILP (prev))
707 ASET (font, FONT_EXTRA_INDEX, Fcons (Fcons (prop, val), extra));
708 else
709 XSETCDR (prev, Fcons (Fcons (prop, val), extra));
710
711 return val;
712 }
713 XSETCDR (slot, val);
714 if (NILP (val))
715 ASET (font, FONT_EXTRA_INDEX, Fdelq (slot, extra));
716 return val;
717 }
718
719 \f
720 /* Font name parser and unparser. */
721
722 static int parse_matrix (const char *);
723 static int font_expand_wildcards (Lisp_Object *, int);
724 static int font_parse_name (char *, ptrdiff_t, Lisp_Object);
725
726 /* An enumerator for each field of an XLFD font name. */
727 enum xlfd_field_index
728 {
729 XLFD_FOUNDRY_INDEX,
730 XLFD_FAMILY_INDEX,
731 XLFD_WEIGHT_INDEX,
732 XLFD_SLANT_INDEX,
733 XLFD_SWIDTH_INDEX,
734 XLFD_ADSTYLE_INDEX,
735 XLFD_PIXEL_INDEX,
736 XLFD_POINT_INDEX,
737 XLFD_RESX_INDEX,
738 XLFD_RESY_INDEX,
739 XLFD_SPACING_INDEX,
740 XLFD_AVGWIDTH_INDEX,
741 XLFD_REGISTRY_INDEX,
742 XLFD_ENCODING_INDEX,
743 XLFD_LAST_INDEX
744 };
745
746 /* An enumerator for mask bit corresponding to each XLFD field. */
747 enum xlfd_field_mask
748 {
749 XLFD_FOUNDRY_MASK = 0x0001,
750 XLFD_FAMILY_MASK = 0x0002,
751 XLFD_WEIGHT_MASK = 0x0004,
752 XLFD_SLANT_MASK = 0x0008,
753 XLFD_SWIDTH_MASK = 0x0010,
754 XLFD_ADSTYLE_MASK = 0x0020,
755 XLFD_PIXEL_MASK = 0x0040,
756 XLFD_POINT_MASK = 0x0080,
757 XLFD_RESX_MASK = 0x0100,
758 XLFD_RESY_MASK = 0x0200,
759 XLFD_SPACING_MASK = 0x0400,
760 XLFD_AVGWIDTH_MASK = 0x0800,
761 XLFD_REGISTRY_MASK = 0x1000,
762 XLFD_ENCODING_MASK = 0x2000
763 };
764
765
766 /* Parse P pointing to the pixel/point size field of the form
767 `[A B C D]' which specifies a transformation matrix:
768
769 A B 0
770 C D 0
771 0 0 1
772
773 by which all glyphs of the font are transformed. The spec says
774 that scalar value N for the pixel/point size is equivalent to:
775 A = N * resx/resy, B = C = 0, D = N.
776
777 Return the scalar value N if the form is valid. Otherwise return
778 -1. */
779
780 static int
781 parse_matrix (const char *p)
782 {
783 double matrix[4];
784 char *end;
785 int i;
786
787 for (i = 0, p++; i < 4 && *p && *p != ']'; i++)
788 {
789 if (*p == '~')
790 matrix[i] = - strtod (p + 1, &end);
791 else
792 matrix[i] = strtod (p, &end);
793 p = end;
794 }
795 return (i == 4 ? (int) matrix[3] : -1);
796 }
797
798 /* Expand a wildcard field in FIELD (the first N fields are filled) to
799 multiple fields to fill in all 14 XLFD fields while restricting a
800 field position by its contents. */
801
802 static int
803 font_expand_wildcards (Lisp_Object *field, int n)
804 {
805 /* Copy of FIELD. */
806 Lisp_Object tmp[XLFD_LAST_INDEX];
807 /* Array of information about where this element can go. Nth
808 element is for Nth element of FIELD. */
809 struct {
810 /* Minimum possible field. */
811 int from;
812 /* Maximum possible field. */
813 int to;
814 /* Bit mask of possible field. Nth bit corresponds to Nth field. */
815 int mask;
816 } range[XLFD_LAST_INDEX];
817 int i, j;
818 int range_from, range_to;
819 unsigned range_mask;
820
821 #define XLFD_SYMBOL_MASK (XLFD_FOUNDRY_MASK | XLFD_FAMILY_MASK \
822 | XLFD_ADSTYLE_MASK | XLFD_REGISTRY_MASK)
823 #define XLFD_NULL_MASK (XLFD_FOUNDRY_MASK | XLFD_ADSTYLE_MASK)
824 #define XLFD_LARGENUM_MASK (XLFD_POINT_MASK | XLFD_RESX_MASK | XLFD_RESY_MASK \
825 | XLFD_AVGWIDTH_MASK)
826 #define XLFD_REGENC_MASK (XLFD_REGISTRY_MASK | XLFD_ENCODING_MASK)
827
828 /* Initialize RANGE_MASK for FIELD[0] which can be 0th to (14 - N)th
829 field. The value is shifted to left one bit by one in the
830 following loop. */
831 for (i = 0, range_mask = 0; i <= 14 - n; i++)
832 range_mask = (range_mask << 1) | 1;
833
834 /* The triplet RANGE_FROM, RANGE_TO, and RANGE_MASK is a
835 position-based restriction for FIELD[I]. */
836 for (i = 0, range_from = 0, range_to = 14 - n; i < n;
837 i++, range_from++, range_to++, range_mask <<= 1)
838 {
839 Lisp_Object val = field[i];
840
841 tmp[i] = val;
842 if (NILP (val))
843 {
844 /* Wildcard. */
845 range[i].from = range_from;
846 range[i].to = range_to;
847 range[i].mask = range_mask;
848 }
849 else
850 {
851 /* The triplet FROM, TO, and MASK is a value-based
852 restriction for FIELD[I]. */
853 int from, to;
854 unsigned mask;
855
856 if (INTEGERP (val))
857 {
858 EMACS_INT numeric = XINT (val);
859
860 if (i + 1 == n)
861 from = to = XLFD_ENCODING_INDEX,
862 mask = XLFD_ENCODING_MASK;
863 else if (numeric == 0)
864 from = XLFD_PIXEL_INDEX, to = XLFD_AVGWIDTH_INDEX,
865 mask = XLFD_PIXEL_MASK | XLFD_LARGENUM_MASK;
866 else if (numeric <= 48)
867 from = to = XLFD_PIXEL_INDEX,
868 mask = XLFD_PIXEL_MASK;
869 else
870 from = XLFD_POINT_INDEX, to = XLFD_AVGWIDTH_INDEX,
871 mask = XLFD_LARGENUM_MASK;
872 }
873 else if (SBYTES (SYMBOL_NAME (val)) == 0)
874 from = XLFD_FOUNDRY_INDEX, to = XLFD_ADSTYLE_INDEX,
875 mask = XLFD_NULL_MASK;
876 else if (i == 0)
877 from = to = XLFD_FOUNDRY_INDEX, mask = XLFD_FOUNDRY_MASK;
878 else if (i + 1 == n)
879 {
880 Lisp_Object name = SYMBOL_NAME (val);
881
882 if (SDATA (name)[SBYTES (name) - 1] == '*')
883 from = XLFD_REGISTRY_INDEX, to = XLFD_ENCODING_INDEX,
884 mask = XLFD_REGENC_MASK;
885 else
886 from = to = XLFD_ENCODING_INDEX,
887 mask = XLFD_ENCODING_MASK;
888 }
889 else if (range_from <= XLFD_WEIGHT_INDEX
890 && range_to >= XLFD_WEIGHT_INDEX
891 && FONT_WEIGHT_NAME_NUMERIC (val) >= 0)
892 from = to = XLFD_WEIGHT_INDEX, mask = XLFD_WEIGHT_MASK;
893 else if (range_from <= XLFD_SLANT_INDEX
894 && range_to >= XLFD_SLANT_INDEX
895 && FONT_SLANT_NAME_NUMERIC (val) >= 0)
896 from = to = XLFD_SLANT_INDEX, mask = XLFD_SLANT_MASK;
897 else if (range_from <= XLFD_SWIDTH_INDEX
898 && range_to >= XLFD_SWIDTH_INDEX
899 && FONT_WIDTH_NAME_NUMERIC (val) >= 0)
900 from = to = XLFD_SWIDTH_INDEX, mask = XLFD_SWIDTH_MASK;
901 else
902 {
903 if (EQ (val, Qc) || EQ (val, Qm) || EQ (val, Qp) || EQ (val, Qd))
904 from = to = XLFD_SPACING_INDEX, mask = XLFD_SPACING_MASK;
905 else
906 from = XLFD_FOUNDRY_INDEX, to = XLFD_ENCODING_INDEX,
907 mask = XLFD_SYMBOL_MASK;
908 }
909
910 /* Merge position-based and value-based restrictions. */
911 mask &= range_mask;
912 while (from < range_from)
913 mask &= ~(1 << from++);
914 while (from < 14 && ! (mask & (1 << from)))
915 from++;
916 while (to > range_to)
917 mask &= ~(1 << to--);
918 while (to >= 0 && ! (mask & (1 << to)))
919 to--;
920 if (from > to)
921 return -1;
922 range[i].from = from;
923 range[i].to = to;
924 range[i].mask = mask;
925
926 if (from > range_from || to < range_to)
927 {
928 /* The range is narrowed by value-based restrictions.
929 Reflect it to the other fields. */
930
931 /* Following fields should be after FROM. */
932 range_from = from;
933 /* Preceding fields should be before TO. */
934 for (j = i - 1, from--, to--; j >= 0; j--, from--, to--)
935 {
936 /* Check FROM for non-wildcard field. */
937 if (! NILP (tmp[j]) && range[j].from < from)
938 {
939 while (range[j].from < from)
940 range[j].mask &= ~(1 << range[j].from++);
941 while (from < 14 && ! (range[j].mask & (1 << from)))
942 from++;
943 range[j].from = from;
944 }
945 else
946 from = range[j].from;
947 if (range[j].to > to)
948 {
949 while (range[j].to > to)
950 range[j].mask &= ~(1 << range[j].to--);
951 while (to >= 0 && ! (range[j].mask & (1 << to)))
952 to--;
953 range[j].to = to;
954 }
955 else
956 to = range[j].to;
957 if (from > to)
958 return -1;
959 }
960 }
961 }
962 }
963
964 /* Decide all fields from restrictions in RANGE. */
965 for (i = j = 0; i < n ; i++)
966 {
967 if (j < range[i].from)
968 {
969 if (i == 0 || ! NILP (tmp[i - 1]))
970 /* None of TMP[X] corresponds to Jth field. */
971 return -1;
972 for (; j < range[i].from; j++)
973 field[j] = Qnil;
974 }
975 field[j++] = tmp[i];
976 }
977 if (! NILP (tmp[n - 1]) && j < XLFD_REGISTRY_INDEX)
978 return -1;
979 for (; j < XLFD_LAST_INDEX; j++)
980 field[j] = Qnil;
981 if (INTEGERP (field[XLFD_ENCODING_INDEX]))
982 field[XLFD_ENCODING_INDEX]
983 = Fintern (Fnumber_to_string (field[XLFD_ENCODING_INDEX]), Qnil);
984 return 0;
985 }
986
987
988 /* Parse NAME (null terminated) as XLFD and store information in FONT
989 (font-spec or font-entity). Size property of FONT is set as
990 follows:
991 specified XLFD fields FONT property
992 --------------------- -------------
993 PIXEL_SIZE PIXEL_SIZE (Lisp integer)
994 POINT_SIZE and RESY calculated pixel size (Lisp integer)
995 POINT_SIZE POINT_SIZE/10 (Lisp float)
996
997 If NAME is successfully parsed, return 0. Otherwise return -1.
998
999 FONT is usually a font-spec, but when this function is called from
1000 X font backend driver, it is a font-entity. In that case, NAME is
1001 a fully specified XLFD. */
1002
1003 int
1004 font_parse_xlfd (char *name, ptrdiff_t len, Lisp_Object font)
1005 {
1006 int i, j, n;
1007 char *f[XLFD_LAST_INDEX + 1];
1008 Lisp_Object val;
1009 char *p;
1010
1011 if (len > 255 || !len)
1012 /* Maximum XLFD name length is 255. */
1013 return -1;
1014 /* Accept "*-.." as a fully specified XLFD. */
1015 if (name[0] == '*' && (len == 1 || name[1] == '-'))
1016 i = 1, f[XLFD_FOUNDRY_INDEX] = name;
1017 else
1018 i = 0;
1019 for (p = name + i; *p; p++)
1020 if (*p == '-')
1021 {
1022 f[i++] = p + 1;
1023 if (i == XLFD_LAST_INDEX)
1024 break;
1025 }
1026 f[i] = name + len;
1027
1028 #define INTERN_FIELD(N) font_intern_prop (f[N], f[(N) + 1] - 1 - f[N], 0)
1029 #define INTERN_FIELD_SYM(N) font_intern_prop (f[N], f[(N) + 1] - 1 - f[N], 1)
1030
1031 if (i == XLFD_LAST_INDEX)
1032 {
1033 /* Fully specified XLFD. */
1034 int pixel_size;
1035
1036 ASET (font, FONT_FOUNDRY_INDEX, INTERN_FIELD_SYM (XLFD_FOUNDRY_INDEX));
1037 ASET (font, FONT_FAMILY_INDEX, INTERN_FIELD_SYM (XLFD_FAMILY_INDEX));
1038 for (i = XLFD_WEIGHT_INDEX, j = FONT_WEIGHT_INDEX;
1039 i <= XLFD_SWIDTH_INDEX; i++, j++)
1040 {
1041 val = INTERN_FIELD_SYM (i);
1042 if (! NILP (val))
1043 {
1044 if ((n = font_style_to_value (j, INTERN_FIELD_SYM (i), 0)) < 0)
1045 return -1;
1046 ASET (font, j, make_number (n));
1047 }
1048 }
1049 ASET (font, FONT_ADSTYLE_INDEX, INTERN_FIELD_SYM (XLFD_ADSTYLE_INDEX));
1050 if (strcmp (f[XLFD_REGISTRY_INDEX], "*-*") == 0)
1051 ASET (font, FONT_REGISTRY_INDEX, Qnil);
1052 else
1053 ASET (font, FONT_REGISTRY_INDEX,
1054 font_intern_prop (f[XLFD_REGISTRY_INDEX],
1055 f[XLFD_LAST_INDEX] - f[XLFD_REGISTRY_INDEX],
1056 1));
1057 p = f[XLFD_PIXEL_INDEX];
1058 if (*p == '[' && (pixel_size = parse_matrix (p)) >= 0)
1059 ASET (font, FONT_SIZE_INDEX, make_number (pixel_size));
1060 else
1061 {
1062 val = INTERN_FIELD (XLFD_PIXEL_INDEX);
1063 if (INTEGERP (val))
1064 ASET (font, FONT_SIZE_INDEX, val);
1065 else if (FONT_ENTITY_P (font))
1066 return -1;
1067 else
1068 {
1069 double point_size = -1;
1070
1071 eassert (FONT_SPEC_P (font));
1072 p = f[XLFD_POINT_INDEX];
1073 if (*p == '[')
1074 point_size = parse_matrix (p);
1075 else if (c_isdigit (*p))
1076 point_size = atoi (p), point_size /= 10;
1077 if (point_size >= 0)
1078 ASET (font, FONT_SIZE_INDEX, make_float (point_size));
1079 }
1080 }
1081
1082 val = INTERN_FIELD (XLFD_RESY_INDEX);
1083 if (! NILP (val) && ! INTEGERP (val))
1084 return -1;
1085 ASET (font, FONT_DPI_INDEX, val);
1086 val = INTERN_FIELD (XLFD_SPACING_INDEX);
1087 if (! NILP (val))
1088 {
1089 val = font_prop_validate_spacing (QCspacing, val);
1090 if (! INTEGERP (val))
1091 return -1;
1092 ASET (font, FONT_SPACING_INDEX, val);
1093 }
1094 p = f[XLFD_AVGWIDTH_INDEX];
1095 if (*p == '~')
1096 p++;
1097 val = font_intern_prop (p, f[XLFD_REGISTRY_INDEX] - 1 - p, 0);
1098 if (! NILP (val) && ! INTEGERP (val))
1099 return -1;
1100 ASET (font, FONT_AVGWIDTH_INDEX, val);
1101 }
1102 else
1103 {
1104 bool wild_card_found = 0;
1105 Lisp_Object prop[XLFD_LAST_INDEX];
1106
1107 if (FONT_ENTITY_P (font))
1108 return -1;
1109 for (j = 0; j < i; j++)
1110 {
1111 if (*f[j] == '*')
1112 {
1113 if (f[j][1] && f[j][1] != '-')
1114 return -1;
1115 prop[j] = Qnil;
1116 wild_card_found = 1;
1117 }
1118 else if (j + 1 < i)
1119 prop[j] = INTERN_FIELD (j);
1120 else
1121 prop[j] = font_intern_prop (f[j], f[i] - f[j], 0);
1122 }
1123 if (! wild_card_found)
1124 return -1;
1125 if (font_expand_wildcards (prop, i) < 0)
1126 return -1;
1127
1128 ASET (font, FONT_FOUNDRY_INDEX, prop[XLFD_FOUNDRY_INDEX]);
1129 ASET (font, FONT_FAMILY_INDEX, prop[XLFD_FAMILY_INDEX]);
1130 for (i = XLFD_WEIGHT_INDEX, j = FONT_WEIGHT_INDEX;
1131 i <= XLFD_SWIDTH_INDEX; i++, j++)
1132 if (! NILP (prop[i]))
1133 {
1134 if ((n = font_style_to_value (j, prop[i], 1)) < 0)
1135 return -1;
1136 ASET (font, j, make_number (n));
1137 }
1138 ASET (font, FONT_ADSTYLE_INDEX, prop[XLFD_ADSTYLE_INDEX]);
1139 val = prop[XLFD_REGISTRY_INDEX];
1140 if (NILP (val))
1141 {
1142 val = prop[XLFD_ENCODING_INDEX];
1143 if (! NILP (val))
1144 val = concat2 (build_string ("*-"), SYMBOL_NAME (val));
1145 }
1146 else if (NILP (prop[XLFD_ENCODING_INDEX]))
1147 val = concat2 (SYMBOL_NAME (val), build_string ("-*"));
1148 else
1149 val = concat3 (SYMBOL_NAME (val), build_string ("-"),
1150 SYMBOL_NAME (prop[XLFD_ENCODING_INDEX]));
1151 if (! NILP (val))
1152 ASET (font, FONT_REGISTRY_INDEX, Fintern (val, Qnil));
1153
1154 if (INTEGERP (prop[XLFD_PIXEL_INDEX]))
1155 ASET (font, FONT_SIZE_INDEX, prop[XLFD_PIXEL_INDEX]);
1156 else if (INTEGERP (prop[XLFD_POINT_INDEX]))
1157 {
1158 double point_size = XINT (prop[XLFD_POINT_INDEX]);
1159
1160 ASET (font, FONT_SIZE_INDEX, make_float (point_size / 10));
1161 }
1162
1163 if (INTEGERP (prop[XLFD_RESX_INDEX]))
1164 ASET (font, FONT_DPI_INDEX, prop[XLFD_RESY_INDEX]);
1165 if (! NILP (prop[XLFD_SPACING_INDEX]))
1166 {
1167 val = font_prop_validate_spacing (QCspacing,
1168 prop[XLFD_SPACING_INDEX]);
1169 if (! INTEGERP (val))
1170 return -1;
1171 ASET (font, FONT_SPACING_INDEX, val);
1172 }
1173 if (INTEGERP (prop[XLFD_AVGWIDTH_INDEX]))
1174 ASET (font, FONT_AVGWIDTH_INDEX, prop[XLFD_AVGWIDTH_INDEX]);
1175 }
1176
1177 return 0;
1178 }
1179
1180 /* Store XLFD name of FONT (font-spec or font-entity) in NAME (NBYTES
1181 length), and return the name length. If FONT_SIZE_INDEX of FONT is
1182 0, use PIXEL_SIZE instead. */
1183
1184 ptrdiff_t
1185 font_unparse_xlfd (Lisp_Object font, int pixel_size, char *name, int nbytes)
1186 {
1187 char *p;
1188 const char *f[XLFD_REGISTRY_INDEX + 1];
1189 Lisp_Object val;
1190 int i, j, len;
1191
1192 eassert (FONTP (font));
1193
1194 for (i = FONT_FOUNDRY_INDEX, j = XLFD_FOUNDRY_INDEX; i <= FONT_REGISTRY_INDEX;
1195 i++, j++)
1196 {
1197 if (i == FONT_ADSTYLE_INDEX)
1198 j = XLFD_ADSTYLE_INDEX;
1199 else if (i == FONT_REGISTRY_INDEX)
1200 j = XLFD_REGISTRY_INDEX;
1201 val = AREF (font, i);
1202 if (NILP (val))
1203 {
1204 if (j == XLFD_REGISTRY_INDEX)
1205 f[j] = "*-*";
1206 else
1207 f[j] = "*";
1208 }
1209 else
1210 {
1211 if (SYMBOLP (val))
1212 val = SYMBOL_NAME (val);
1213 if (j == XLFD_REGISTRY_INDEX
1214 && ! strchr (SSDATA (val), '-'))
1215 {
1216 /* Change "jisx0208*" and "jisx0208" to "jisx0208*-*". */
1217 ptrdiff_t alloc = SBYTES (val) + 4;
1218 if (nbytes <= alloc)
1219 return -1;
1220 f[j] = p = alloca (alloc);
1221 sprintf (p, "%s%s-*", SDATA (val),
1222 "*" + (SDATA (val)[SBYTES (val) - 1] == '*'));
1223 }
1224 else
1225 f[j] = SSDATA (val);
1226 }
1227 }
1228
1229 for (i = FONT_WEIGHT_INDEX, j = XLFD_WEIGHT_INDEX; i <= FONT_WIDTH_INDEX;
1230 i++, j++)
1231 {
1232 val = font_style_symbolic (font, i, 0);
1233 if (NILP (val))
1234 f[j] = "*";
1235 else
1236 {
1237 int c, k, l;
1238 ptrdiff_t alloc;
1239
1240 val = SYMBOL_NAME (val);
1241 alloc = SBYTES (val) + 1;
1242 if (nbytes <= alloc)
1243 return -1;
1244 f[j] = p = alloca (alloc);
1245 /* Copy the name while excluding '-', '?', ',', and '"'. */
1246 for (k = l = 0; k < alloc; k++)
1247 {
1248 c = SREF (val, k);
1249 if (c != '-' && c != '?' && c != ',' && c != '"')
1250 p[l++] = c;
1251 }
1252 }
1253 }
1254
1255 val = AREF (font, FONT_SIZE_INDEX);
1256 eassert (NUMBERP (val) || NILP (val));
1257 if (INTEGERP (val))
1258 {
1259 EMACS_INT v = XINT (val);
1260 if (v <= 0)
1261 v = pixel_size;
1262 if (v > 0)
1263 {
1264 f[XLFD_PIXEL_INDEX] = p =
1265 alloca (sizeof "-*" + INT_STRLEN_BOUND (EMACS_INT));
1266 sprintf (p, "%"pI"d-*", v);
1267 }
1268 else
1269 f[XLFD_PIXEL_INDEX] = "*-*";
1270 }
1271 else if (FLOATP (val))
1272 {
1273 double v = XFLOAT_DATA (val) * 10;
1274 f[XLFD_PIXEL_INDEX] = p = alloca (sizeof "*-" + 1 + DBL_MAX_10_EXP + 1);
1275 sprintf (p, "*-%.0f", v);
1276 }
1277 else
1278 f[XLFD_PIXEL_INDEX] = "*-*";
1279
1280 if (INTEGERP (AREF (font, FONT_DPI_INDEX)))
1281 {
1282 EMACS_INT v = XINT (AREF (font, FONT_DPI_INDEX));
1283 f[XLFD_RESX_INDEX] = p =
1284 alloca (sizeof "-" + 2 * INT_STRLEN_BOUND (EMACS_INT));
1285 sprintf (p, "%"pI"d-%"pI"d", v, v);
1286 }
1287 else
1288 f[XLFD_RESX_INDEX] = "*-*";
1289 if (INTEGERP (AREF (font, FONT_SPACING_INDEX)))
1290 {
1291 EMACS_INT spacing = XINT (AREF (font, FONT_SPACING_INDEX));
1292
1293 f[XLFD_SPACING_INDEX] = (spacing <= FONT_SPACING_PROPORTIONAL ? "p"
1294 : spacing <= FONT_SPACING_DUAL ? "d"
1295 : spacing <= FONT_SPACING_MONO ? "m"
1296 : "c");
1297 }
1298 else
1299 f[XLFD_SPACING_INDEX] = "*";
1300 if (INTEGERP (AREF (font, FONT_AVGWIDTH_INDEX)))
1301 {
1302 f[XLFD_AVGWIDTH_INDEX] = p = alloca (INT_BUFSIZE_BOUND (EMACS_INT));
1303 sprintf (p, "%"pI"d", XINT (AREF (font, FONT_AVGWIDTH_INDEX)));
1304 }
1305 else
1306 f[XLFD_AVGWIDTH_INDEX] = "*";
1307 len = snprintf (name, nbytes, "-%s-%s-%s-%s-%s-%s-%s-%s-%s-%s-%s",
1308 f[XLFD_FOUNDRY_INDEX], f[XLFD_FAMILY_INDEX],
1309 f[XLFD_WEIGHT_INDEX], f[XLFD_SLANT_INDEX],
1310 f[XLFD_SWIDTH_INDEX], f[XLFD_ADSTYLE_INDEX],
1311 f[XLFD_PIXEL_INDEX], f[XLFD_RESX_INDEX],
1312 f[XLFD_SPACING_INDEX], f[XLFD_AVGWIDTH_INDEX],
1313 f[XLFD_REGISTRY_INDEX]);
1314 return len < nbytes ? len : -1;
1315 }
1316
1317 /* Parse NAME (null terminated) and store information in FONT
1318 (font-spec or font-entity). NAME is supplied in either the
1319 Fontconfig or GTK font name format. If NAME is successfully
1320 parsed, return 0. Otherwise return -1.
1321
1322 The fontconfig format is
1323
1324 FAMILY[-SIZE][:PROP1[=VAL1][:PROP2[=VAL2]...]]
1325
1326 The GTK format is
1327
1328 FAMILY [PROPS...] [SIZE]
1329
1330 This function tries to guess which format it is. */
1331
1332 static int
1333 font_parse_fcname (char *name, ptrdiff_t len, Lisp_Object font)
1334 {
1335 char *p, *q;
1336 char *size_beg = NULL, *size_end = NULL;
1337 char *props_beg = NULL, *family_end = NULL;
1338
1339 if (len == 0)
1340 return -1;
1341
1342 for (p = name; *p; p++)
1343 {
1344 if (*p == '\\' && p[1])
1345 p++;
1346 else if (*p == ':')
1347 {
1348 props_beg = family_end = p;
1349 break;
1350 }
1351 else if (*p == '-')
1352 {
1353 bool decimal = 0, size_found = 1;
1354 for (q = p + 1; *q && *q != ':'; q++)
1355 if (! c_isdigit (*q))
1356 {
1357 if (*q != '.' || decimal)
1358 {
1359 size_found = 0;
1360 break;
1361 }
1362 decimal = 1;
1363 }
1364 if (size_found)
1365 {
1366 family_end = p;
1367 size_beg = p + 1;
1368 size_end = q;
1369 break;
1370 }
1371 }
1372 }
1373
1374 if (family_end)
1375 {
1376 Lisp_Object extra_props = Qnil;
1377
1378 /* A fontconfig name with size and/or property data. */
1379 if (family_end > name)
1380 {
1381 Lisp_Object family;
1382 family = font_intern_prop (name, family_end - name, 1);
1383 ASET (font, FONT_FAMILY_INDEX, family);
1384 }
1385 if (size_beg)
1386 {
1387 double point_size = strtod (size_beg, &size_end);
1388 ASET (font, FONT_SIZE_INDEX, make_float (point_size));
1389 if (*size_end == ':' && size_end[1])
1390 props_beg = size_end;
1391 }
1392 if (props_beg)
1393 {
1394 /* Now parse ":KEY=VAL" patterns. */
1395 Lisp_Object val;
1396
1397 for (p = props_beg; *p; p = q)
1398 {
1399 for (q = p + 1; *q && *q != '=' && *q != ':'; q++);
1400 if (*q != '=')
1401 {
1402 /* Must be an enumerated value. */
1403 ptrdiff_t word_len;
1404 p = p + 1;
1405 word_len = q - p;
1406 val = font_intern_prop (p, q - p, 1);
1407
1408 #define PROP_MATCH(STR) (word_len == strlen (STR) \
1409 && memcmp (p, STR, strlen (STR)) == 0)
1410
1411 if (PROP_MATCH ("light")
1412 || PROP_MATCH ("medium")
1413 || PROP_MATCH ("demibold")
1414 || PROP_MATCH ("bold")
1415 || PROP_MATCH ("black"))
1416 FONT_SET_STYLE (font, FONT_WEIGHT_INDEX, val);
1417 else if (PROP_MATCH ("roman")
1418 || PROP_MATCH ("italic")
1419 || PROP_MATCH ("oblique"))
1420 FONT_SET_STYLE (font, FONT_SLANT_INDEX, val);
1421 else if (PROP_MATCH ("charcell"))
1422 ASET (font, FONT_SPACING_INDEX,
1423 make_number (FONT_SPACING_CHARCELL));
1424 else if (PROP_MATCH ("mono"))
1425 ASET (font, FONT_SPACING_INDEX,
1426 make_number (FONT_SPACING_MONO));
1427 else if (PROP_MATCH ("proportional"))
1428 ASET (font, FONT_SPACING_INDEX,
1429 make_number (FONT_SPACING_PROPORTIONAL));
1430 #undef PROP_MATCH
1431 }
1432 else
1433 {
1434 /* KEY=VAL pairs */
1435 Lisp_Object key;
1436 int prop;
1437
1438 if (q - p == 10 && memcmp (p + 1, "pixelsize", 9) == 0)
1439 prop = FONT_SIZE_INDEX;
1440 else
1441 {
1442 key = font_intern_prop (p, q - p, 1);
1443 prop = get_font_prop_index (key);
1444 }
1445
1446 p = q + 1;
1447 for (q = p; *q && *q != ':'; q++);
1448 val = font_intern_prop (p, q - p, 0);
1449
1450 if (prop >= FONT_FOUNDRY_INDEX
1451 && prop < FONT_EXTRA_INDEX)
1452 ASET (font, prop, font_prop_validate (prop, Qnil, val));
1453 else
1454 {
1455 extra_props = nconc2 (extra_props,
1456 Fcons (Fcons (key, val), Qnil));
1457 }
1458 }
1459 p = q;
1460 }
1461 }
1462
1463 if (! NILP (extra_props))
1464 {
1465 struct font_driver_list *driver_list = font_driver_list;
1466 for ( ; driver_list; driver_list = driver_list->next)
1467 if (driver_list->driver->filter_properties)
1468 (*driver_list->driver->filter_properties) (font, extra_props);
1469 }
1470
1471 }
1472 else
1473 {
1474 /* Either a fontconfig-style name with no size and property
1475 data, or a GTK-style name. */
1476 Lisp_Object weight = Qnil, slant = Qnil;
1477 Lisp_Object width = Qnil, size = Qnil;
1478 char *word_start;
1479 ptrdiff_t word_len;
1480
1481 /* Scan backwards from the end, looking for a size. */
1482 for (p = name + len - 1; p >= name; p--)
1483 if (!c_isdigit (*p))
1484 break;
1485
1486 if ((p < name + len - 1) && ((p + 1 == name) || *p == ' '))
1487 /* Found a font size. */
1488 size = make_float (strtod (p + 1, NULL));
1489 else
1490 p = name + len;
1491
1492 /* Now P points to the termination of the string, sans size.
1493 Scan backwards, looking for font properties. */
1494 for (; p > name; p = q)
1495 {
1496 for (q = p - 1; q >= name; q--)
1497 {
1498 if (q > name && *(q-1) == '\\')
1499 --q; /* Skip quoting backslashes. */
1500 else if (*q == ' ')
1501 break;
1502 }
1503
1504 word_start = q + 1;
1505 word_len = p - word_start;
1506
1507 #define PROP_MATCH(STR) \
1508 (word_len == strlen (STR) \
1509 && memcmp (word_start, STR, strlen (STR)) == 0)
1510 #define PROP_SAVE(VAR, STR) \
1511 (VAR = NILP (VAR) ? font_intern_prop (STR, strlen (STR), 1) : VAR)
1512
1513 if (PROP_MATCH ("Ultra-Light"))
1514 PROP_SAVE (weight, "ultra-light");
1515 else if (PROP_MATCH ("Light"))
1516 PROP_SAVE (weight, "light");
1517 else if (PROP_MATCH ("Book"))
1518 PROP_SAVE (weight, "book");
1519 else if (PROP_MATCH ("Medium"))
1520 PROP_SAVE (weight, "medium");
1521 else if (PROP_MATCH ("Semi-Bold"))
1522 PROP_SAVE (weight, "semi-bold");
1523 else if (PROP_MATCH ("Bold"))
1524 PROP_SAVE (weight, "bold");
1525 else if (PROP_MATCH ("Italic"))
1526 PROP_SAVE (slant, "italic");
1527 else if (PROP_MATCH ("Oblique"))
1528 PROP_SAVE (slant, "oblique");
1529 else if (PROP_MATCH ("Semi-Condensed"))
1530 PROP_SAVE (width, "semi-condensed");
1531 else if (PROP_MATCH ("Condensed"))
1532 PROP_SAVE (width, "condensed");
1533 /* An unknown word must be part of the font name. */
1534 else
1535 {
1536 family_end = p;
1537 break;
1538 }
1539 }
1540 #undef PROP_MATCH
1541 #undef PROP_SAVE
1542
1543 if (family_end)
1544 ASET (font, FONT_FAMILY_INDEX,
1545 font_intern_prop (name, family_end - name, 1));
1546 if (!NILP (size))
1547 ASET (font, FONT_SIZE_INDEX, size);
1548 if (!NILP (weight))
1549 FONT_SET_STYLE (font, FONT_WEIGHT_INDEX, weight);
1550 if (!NILP (slant))
1551 FONT_SET_STYLE (font, FONT_SLANT_INDEX, slant);
1552 if (!NILP (width))
1553 FONT_SET_STYLE (font, FONT_WIDTH_INDEX, width);
1554 }
1555
1556 return 0;
1557 }
1558
1559 /* Store fontconfig's font name of FONT (font-spec or font-entity) in
1560 NAME (NBYTES length), and return the name length. If
1561 FONT_SIZE_INDEX of FONT is 0, use PIXEL_SIZE instead. */
1562
1563 int
1564 font_unparse_fcname (Lisp_Object font, int pixel_size, char *name, int nbytes)
1565 {
1566 Lisp_Object family, foundry;
1567 Lisp_Object val;
1568 int point_size;
1569 int i;
1570 char *p;
1571 char *lim;
1572 Lisp_Object styles[3];
1573 const char *style_names[3] = { "weight", "slant", "width" };
1574
1575 family = AREF (font, FONT_FAMILY_INDEX);
1576 if (! NILP (family))
1577 {
1578 if (SYMBOLP (family))
1579 family = SYMBOL_NAME (family);
1580 else
1581 family = Qnil;
1582 }
1583
1584 val = AREF (font, FONT_SIZE_INDEX);
1585 if (INTEGERP (val))
1586 {
1587 if (XINT (val) != 0)
1588 pixel_size = XINT (val);
1589 point_size = -1;
1590 }
1591 else
1592 {
1593 eassert (FLOATP (val));
1594 pixel_size = -1;
1595 point_size = (int) XFLOAT_DATA (val);
1596 }
1597
1598 foundry = AREF (font, FONT_FOUNDRY_INDEX);
1599 if (! NILP (foundry))
1600 {
1601 if (SYMBOLP (foundry))
1602 foundry = SYMBOL_NAME (foundry);
1603 else
1604 foundry = Qnil;
1605 }
1606
1607 for (i = 0; i < 3; i++)
1608 styles[i] = font_style_symbolic (font, FONT_WEIGHT_INDEX + i, 0);
1609
1610 p = name;
1611 lim = name + nbytes;
1612 if (! NILP (family))
1613 {
1614 int len = snprintf (p, lim - p, "%s", SSDATA (family));
1615 if (! (0 <= len && len < lim - p))
1616 return -1;
1617 p += len;
1618 }
1619 if (point_size > 0)
1620 {
1621 int len = snprintf (p, lim - p, "-%d" + (p == name), point_size);
1622 if (! (0 <= len && len < lim - p))
1623 return -1;
1624 p += len;
1625 }
1626 else if (pixel_size > 0)
1627 {
1628 int len = snprintf (p, lim - p, ":pixelsize=%d", pixel_size);
1629 if (! (0 <= len && len < lim - p))
1630 return -1;
1631 p += len;
1632 }
1633 if (! NILP (AREF (font, FONT_FOUNDRY_INDEX)))
1634 {
1635 int len = snprintf (p, lim - p, ":foundry=%s",
1636 SSDATA (SYMBOL_NAME (AREF (font,
1637 FONT_FOUNDRY_INDEX))));
1638 if (! (0 <= len && len < lim - p))
1639 return -1;
1640 p += len;
1641 }
1642 for (i = 0; i < 3; i++)
1643 if (! NILP (styles[i]))
1644 {
1645 int len = snprintf (p, lim - p, ":%s=%s", style_names[i],
1646 SSDATA (SYMBOL_NAME (styles[i])));
1647 if (! (0 <= len && len < lim - p))
1648 return -1;
1649 p += len;
1650 }
1651
1652 if (INTEGERP (AREF (font, FONT_DPI_INDEX)))
1653 {
1654 int len = snprintf (p, lim - p, ":dpi=%"pI"d",
1655 XINT (AREF (font, FONT_DPI_INDEX)));
1656 if (! (0 <= len && len < lim - p))
1657 return -1;
1658 p += len;
1659 }
1660
1661 if (INTEGERP (AREF (font, FONT_SPACING_INDEX)))
1662 {
1663 int len = snprintf (p, lim - p, ":spacing=%"pI"d",
1664 XINT (AREF (font, FONT_SPACING_INDEX)));
1665 if (! (0 <= len && len < lim - p))
1666 return -1;
1667 p += len;
1668 }
1669
1670 if (INTEGERP (AREF (font, FONT_AVGWIDTH_INDEX)))
1671 {
1672 int len = snprintf (p, lim - p,
1673 (XINT (AREF (font, FONT_AVGWIDTH_INDEX)) == 0
1674 ? ":scalable=true"
1675 : ":scalable=false"));
1676 if (! (0 <= len && len < lim - p))
1677 return -1;
1678 p += len;
1679 }
1680
1681 return (p - name);
1682 }
1683
1684 /* Parse NAME (null terminated) and store information in FONT
1685 (font-spec or font-entity). If NAME is successfully parsed, return
1686 0. Otherwise return -1. */
1687
1688 static int
1689 font_parse_name (char *name, ptrdiff_t namelen, Lisp_Object font)
1690 {
1691 if (name[0] == '-' || strchr (name, '*') || strchr (name, '?'))
1692 return font_parse_xlfd (name, namelen, font);
1693 return font_parse_fcname (name, namelen, font);
1694 }
1695
1696
1697 /* Merge FAMILY and REGISTRY into FONT_SPEC. FAMILY may have the form
1698 "FAMILY-FOUNDRY". REGISTRY may not contain charset-encoding
1699 part. */
1700
1701 void
1702 font_parse_family_registry (Lisp_Object family, Lisp_Object registry, Lisp_Object font_spec)
1703 {
1704 int len;
1705 char *p0, *p1;
1706
1707 if (! NILP (family)
1708 && NILP (AREF (font_spec, FONT_FAMILY_INDEX)))
1709 {
1710 CHECK_STRING (family);
1711 len = SBYTES (family);
1712 p0 = SSDATA (family);
1713 p1 = strchr (p0, '-');
1714 if (p1)
1715 {
1716 if ((*p0 != '*' && p1 - p0 > 0)
1717 && NILP (AREF (font_spec, FONT_FOUNDRY_INDEX)))
1718 Ffont_put (font_spec, QCfoundry, font_intern_prop (p0, p1 - p0, 1));
1719 p1++;
1720 len -= p1 - p0;
1721 Ffont_put (font_spec, QCfamily, font_intern_prop (p1, len, 1));
1722 }
1723 else
1724 ASET (font_spec, FONT_FAMILY_INDEX, Fintern (family, Qnil));
1725 }
1726 if (! NILP (registry))
1727 {
1728 /* Convert "XXX" and "XXX*" to "XXX*-*". */
1729 CHECK_STRING (registry);
1730 len = SBYTES (registry);
1731 p0 = SSDATA (registry);
1732 p1 = strchr (p0, '-');
1733 if (! p1)
1734 {
1735 if (SDATA (registry)[len - 1] == '*')
1736 registry = concat2 (registry, build_string ("-*"));
1737 else
1738 registry = concat2 (registry, build_string ("*-*"));
1739 }
1740 registry = Fdowncase (registry);
1741 ASET (font_spec, FONT_REGISTRY_INDEX, Fintern (registry, Qnil));
1742 }
1743 }
1744
1745 \f
1746 /* This part (through the next ^L) is still experimental and not
1747 tested much. We may drastically change codes. */
1748
1749 /* OTF handler. */
1750
1751 #if 0
1752
1753 #define LGSTRING_HEADER_SIZE 6
1754 #define LGSTRING_GLYPH_SIZE 8
1755
1756 static int
1757 check_gstring (Lisp_Object gstring)
1758 {
1759 Lisp_Object val;
1760 ptrdiff_t i;
1761 int j;
1762
1763 CHECK_VECTOR (gstring);
1764 val = AREF (gstring, 0);
1765 CHECK_VECTOR (val);
1766 if (ASIZE (val) < LGSTRING_HEADER_SIZE)
1767 goto err;
1768 CHECK_FONT_OBJECT (LGSTRING_FONT (gstring));
1769 if (!NILP (LGSTRING_SLOT (gstring, LGSTRING_IX_LBEARING)))
1770 CHECK_NUMBER (LGSTRING_SLOT (gstring, LGSTRING_IX_LBEARING));
1771 if (!NILP (LGSTRING_SLOT (gstring, LGSTRING_IX_RBEARING)))
1772 CHECK_NUMBER (LGSTRING_SLOT (gstring, LGSTRING_IX_RBEARING));
1773 if (!NILP (LGSTRING_SLOT (gstring, LGSTRING_IX_WIDTH)))
1774 CHECK_NATNUM (LGSTRING_SLOT (gstring, LGSTRING_IX_WIDTH));
1775 if (!NILP (LGSTRING_SLOT (gstring, LGSTRING_IX_ASCENT)))
1776 CHECK_NUMBER (LGSTRING_SLOT (gstring, LGSTRING_IX_ASCENT));
1777 if (!NILP (LGSTRING_SLOT (gstring, LGSTRING_IX_ASCENT)))
1778 CHECK_NUMBER (LGSTRING_SLOT (gstring, LGSTRING_IX_ASCENT));
1779
1780 for (i = 0; i < LGSTRING_GLYPH_LEN (gstring); i++)
1781 {
1782 val = LGSTRING_GLYPH (gstring, i);
1783 CHECK_VECTOR (val);
1784 if (ASIZE (val) < LGSTRING_GLYPH_SIZE)
1785 goto err;
1786 if (NILP (AREF (val, LGLYPH_IX_CHAR)))
1787 break;
1788 CHECK_NATNUM (AREF (val, LGLYPH_IX_FROM));
1789 CHECK_NATNUM (AREF (val, LGLYPH_IX_TO));
1790 CHECK_CHARACTER (AREF (val, LGLYPH_IX_CHAR));
1791 if (!NILP (AREF (val, LGLYPH_IX_CODE)))
1792 CHECK_NATNUM (AREF (val, LGLYPH_IX_CODE));
1793 if (!NILP (AREF (val, LGLYPH_IX_WIDTH)))
1794 CHECK_NATNUM (AREF (val, LGLYPH_IX_WIDTH));
1795 if (!NILP (AREF (val, LGLYPH_IX_ADJUSTMENT)))
1796 {
1797 val = AREF (val, LGLYPH_IX_ADJUSTMENT);
1798 CHECK_VECTOR (val);
1799 if (ASIZE (val) < 3)
1800 goto err;
1801 for (j = 0; j < 3; j++)
1802 CHECK_NUMBER (AREF (val, j));
1803 }
1804 }
1805 return i;
1806 err:
1807 error ("Invalid glyph-string format");
1808 return -1;
1809 }
1810
1811 static void
1812 check_otf_features (Lisp_Object otf_features)
1813 {
1814 Lisp_Object val;
1815
1816 CHECK_CONS (otf_features);
1817 CHECK_SYMBOL (XCAR (otf_features));
1818 otf_features = XCDR (otf_features);
1819 CHECK_CONS (otf_features);
1820 CHECK_SYMBOL (XCAR (otf_features));
1821 otf_features = XCDR (otf_features);
1822 for (val = Fcar (otf_features); CONSP (val); val = XCDR (val))
1823 {
1824 CHECK_SYMBOL (XCAR (val));
1825 if (SBYTES (SYMBOL_NAME (XCAR (val))) > 4)
1826 error ("Invalid OTF GSUB feature: %s",
1827 SDATA (SYMBOL_NAME (XCAR (val))));
1828 }
1829 otf_features = XCDR (otf_features);
1830 for (val = Fcar (otf_features); CONSP (val); val = XCDR (val))
1831 {
1832 CHECK_SYMBOL (XCAR (val));
1833 if (SBYTES (SYMBOL_NAME (XCAR (val))) > 4)
1834 error ("Invalid OTF GPOS feature: %s",
1835 SDATA (SYMBOL_NAME (XCAR (val))));
1836 }
1837 }
1838
1839 #ifdef HAVE_LIBOTF
1840 #include <otf.h>
1841
1842 Lisp_Object otf_list;
1843
1844 static Lisp_Object
1845 otf_tag_symbol (OTF_Tag tag)
1846 {
1847 char name[5];
1848
1849 OTF_tag_name (tag, name);
1850 return Fintern (make_unibyte_string (name, 4), Qnil);
1851 }
1852
1853 static OTF *
1854 otf_open (Lisp_Object file)
1855 {
1856 Lisp_Object val = Fassoc (file, otf_list);
1857 OTF *otf;
1858
1859 if (! NILP (val))
1860 otf = XSAVE_POINTER (XCDR (val), 0);
1861 else
1862 {
1863 otf = STRINGP (file) ? OTF_open (SSDATA (file)) : NULL;
1864 val = make_save_pointer (otf);
1865 otf_list = Fcons (Fcons (file, val), otf_list);
1866 }
1867 return otf;
1868 }
1869
1870
1871 /* Return a list describing which scripts/languages FONT supports by
1872 which GSUB/GPOS features of OpenType tables. See the comment of
1873 (struct font_driver).otf_capability. */
1874
1875 Lisp_Object
1876 font_otf_capability (struct font *font)
1877 {
1878 OTF *otf;
1879 Lisp_Object capability = Fcons (Qnil, Qnil);
1880 int i;
1881
1882 otf = otf_open (font->props[FONT_FILE_INDEX]);
1883 if (! otf)
1884 return Qnil;
1885 for (i = 0; i < 2; i++)
1886 {
1887 OTF_GSUB_GPOS *gsub_gpos;
1888 Lisp_Object script_list = Qnil;
1889 int j;
1890
1891 if (OTF_get_features (otf, i == 0) < 0)
1892 continue;
1893 gsub_gpos = i == 0 ? otf->gsub : otf->gpos;
1894 for (j = gsub_gpos->ScriptList.ScriptCount - 1; j >= 0; j--)
1895 {
1896 OTF_Script *script = gsub_gpos->ScriptList.Script + j;
1897 Lisp_Object langsys_list = Qnil;
1898 Lisp_Object script_tag = otf_tag_symbol (script->ScriptTag);
1899 int k;
1900
1901 for (k = script->LangSysCount; k >= 0; k--)
1902 {
1903 OTF_LangSys *langsys;
1904 Lisp_Object feature_list = Qnil;
1905 Lisp_Object langsys_tag;
1906 int l;
1907
1908 if (k == script->LangSysCount)
1909 {
1910 langsys = &script->DefaultLangSys;
1911 langsys_tag = Qnil;
1912 }
1913 else
1914 {
1915 langsys = script->LangSys + k;
1916 langsys_tag
1917 = otf_tag_symbol (script->LangSysRecord[k].LangSysTag);
1918 }
1919 for (l = langsys->FeatureCount - 1; l >= 0; l--)
1920 {
1921 OTF_Feature *feature
1922 = gsub_gpos->FeatureList.Feature + langsys->FeatureIndex[l];
1923 Lisp_Object feature_tag
1924 = otf_tag_symbol (feature->FeatureTag);
1925
1926 feature_list = Fcons (feature_tag, feature_list);
1927 }
1928 langsys_list = Fcons (Fcons (langsys_tag, feature_list),
1929 langsys_list);
1930 }
1931 script_list = Fcons (Fcons (script_tag, langsys_list),
1932 script_list);
1933 }
1934
1935 if (i == 0)
1936 XSETCAR (capability, script_list);
1937 else
1938 XSETCDR (capability, script_list);
1939 }
1940
1941 return capability;
1942 }
1943
1944 /* Parse OTF features in SPEC and write a proper features spec string
1945 in FEATURES for the call of OTF_drive_gsub/gpos (of libotf). It is
1946 assured that the sufficient memory has already allocated for
1947 FEATURES. */
1948
1949 static void
1950 generate_otf_features (Lisp_Object spec, char *features)
1951 {
1952 Lisp_Object val;
1953 char *p;
1954 bool asterisk;
1955
1956 p = features;
1957 *p = '\0';
1958 for (asterisk = 0; CONSP (spec); spec = XCDR (spec))
1959 {
1960 val = XCAR (spec);
1961 CHECK_SYMBOL (val);
1962 if (p > features)
1963 *p++ = ',';
1964 if (SREF (SYMBOL_NAME (val), 0) == '*')
1965 {
1966 asterisk = 1;
1967 *p++ = '*';
1968 }
1969 else if (! asterisk)
1970 {
1971 val = SYMBOL_NAME (val);
1972 p += esprintf (p, "%s", SDATA (val));
1973 }
1974 else
1975 {
1976 val = SYMBOL_NAME (val);
1977 p += esprintf (p, "~%s", SDATA (val));
1978 }
1979 }
1980 if (CONSP (spec))
1981 error ("OTF spec too long");
1982 }
1983
1984 Lisp_Object
1985 font_otf_DeviceTable (OTF_DeviceTable *device_table)
1986 {
1987 int len = device_table->StartSize - device_table->EndSize + 1;
1988
1989 return Fcons (make_number (len),
1990 make_unibyte_string (device_table->DeltaValue, len));
1991 }
1992
1993 Lisp_Object
1994 font_otf_ValueRecord (int value_format, OTF_ValueRecord *value_record)
1995 {
1996 Lisp_Object val = Fmake_vector (make_number (8), Qnil);
1997
1998 if (value_format & OTF_XPlacement)
1999 ASET (val, 0, make_number (value_record->XPlacement));
2000 if (value_format & OTF_YPlacement)
2001 ASET (val, 1, make_number (value_record->YPlacement));
2002 if (value_format & OTF_XAdvance)
2003 ASET (val, 2, make_number (value_record->XAdvance));
2004 if (value_format & OTF_YAdvance)
2005 ASET (val, 3, make_number (value_record->YAdvance));
2006 if (value_format & OTF_XPlaDevice)
2007 ASET (val, 4, font_otf_DeviceTable (&value_record->XPlaDevice));
2008 if (value_format & OTF_YPlaDevice)
2009 ASET (val, 4, font_otf_DeviceTable (&value_record->YPlaDevice));
2010 if (value_format & OTF_XAdvDevice)
2011 ASET (val, 4, font_otf_DeviceTable (&value_record->XAdvDevice));
2012 if (value_format & OTF_YAdvDevice)
2013 ASET (val, 4, font_otf_DeviceTable (&value_record->YAdvDevice));
2014 return val;
2015 }
2016
2017 Lisp_Object
2018 font_otf_Anchor (OTF_Anchor *anchor)
2019 {
2020 Lisp_Object val;
2021
2022 val = Fmake_vector (make_number (anchor->AnchorFormat + 1), Qnil);
2023 ASET (val, 0, make_number (anchor->XCoordinate));
2024 ASET (val, 1, make_number (anchor->YCoordinate));
2025 if (anchor->AnchorFormat == 2)
2026 ASET (val, 2, make_number (anchor->f.f1.AnchorPoint));
2027 else
2028 {
2029 ASET (val, 3, font_otf_DeviceTable (&anchor->f.f2.XDeviceTable));
2030 ASET (val, 4, font_otf_DeviceTable (&anchor->f.f2.YDeviceTable));
2031 }
2032 return val;
2033 }
2034 #endif /* HAVE_LIBOTF */
2035 #endif /* 0 */
2036
2037 \f
2038 /* Font sorting. */
2039
2040 static unsigned font_score (Lisp_Object, Lisp_Object *);
2041 static int font_compare (const void *, const void *);
2042 static Lisp_Object font_sort_entities (Lisp_Object, Lisp_Object,
2043 Lisp_Object, int);
2044
2045 static double
2046 font_rescale_ratio (Lisp_Object font_entity)
2047 {
2048 Lisp_Object tail, elt;
2049 Lisp_Object name = Qnil;
2050
2051 for (tail = Vface_font_rescale_alist; CONSP (tail); tail = XCDR (tail))
2052 {
2053 elt = XCAR (tail);
2054 if (FLOATP (XCDR (elt)))
2055 {
2056 if (STRINGP (XCAR (elt)))
2057 {
2058 if (NILP (name))
2059 name = Ffont_xlfd_name (font_entity, Qnil);
2060 if (fast_string_match_ignore_case (XCAR (elt), name) >= 0)
2061 return XFLOAT_DATA (XCDR (elt));
2062 }
2063 else if (FONT_SPEC_P (XCAR (elt)))
2064 {
2065 if (font_match_p (XCAR (elt), font_entity))
2066 return XFLOAT_DATA (XCDR (elt));
2067 }
2068 }
2069 }
2070 return 1.0;
2071 }
2072
2073 /* We sort fonts by scoring each of them against a specified
2074 font-spec. The score value is 32 bit (`unsigned'), and the smaller
2075 the value is, the closer the font is to the font-spec.
2076
2077 The lowest 2 bits of the score are used for driver type. The font
2078 available by the most preferred font driver is 0.
2079
2080 The 4 7-bit fields in the higher 28 bits are used for numeric properties
2081 WEIGHT, SLANT, WIDTH, and SIZE. */
2082
2083 /* How many bits to shift to store the difference value of each font
2084 property in a score. Note that floats for FONT_TYPE_INDEX and
2085 FONT_REGISTRY_INDEX are not used. */
2086 static int sort_shift_bits[FONT_SIZE_INDEX + 1];
2087
2088 /* Score font-entity ENTITY against properties of font-spec SPEC_PROP.
2089 The return value indicates how different ENTITY is compared with
2090 SPEC_PROP. */
2091
2092 static unsigned
2093 font_score (Lisp_Object entity, Lisp_Object *spec_prop)
2094 {
2095 unsigned score = 0;
2096 int i;
2097
2098 /* Score three style numeric fields. Maximum difference is 127. */
2099 for (i = FONT_WEIGHT_INDEX; i <= FONT_WIDTH_INDEX; i++)
2100 if (! NILP (spec_prop[i]) && ! EQ (AREF (entity, i), spec_prop[i]))
2101 {
2102 EMACS_INT diff = ((XINT (AREF (entity, i)) >> 8)
2103 - (XINT (spec_prop[i]) >> 8));
2104 score |= min (eabs (diff), 127) << sort_shift_bits[i];
2105 }
2106
2107 /* Score the size. Maximum difference is 127. */
2108 i = FONT_SIZE_INDEX;
2109 if (! NILP (spec_prop[FONT_SIZE_INDEX])
2110 && XINT (AREF (entity, FONT_SIZE_INDEX)) > 0)
2111 {
2112 /* We use the higher 6-bit for the actual size difference. The
2113 lowest bit is set if the DPI is different. */
2114 EMACS_INT diff;
2115 EMACS_INT pixel_size = XINT (spec_prop[FONT_SIZE_INDEX]);
2116
2117 if (CONSP (Vface_font_rescale_alist))
2118 pixel_size *= font_rescale_ratio (entity);
2119 diff = eabs (pixel_size - XINT (AREF (entity, FONT_SIZE_INDEX))) << 1;
2120 if (! NILP (spec_prop[FONT_DPI_INDEX])
2121 && ! EQ (spec_prop[FONT_DPI_INDEX], AREF (entity, FONT_DPI_INDEX)))
2122 diff |= 1;
2123 if (! NILP (spec_prop[FONT_AVGWIDTH_INDEX])
2124 && ! EQ (spec_prop[FONT_AVGWIDTH_INDEX], AREF (entity, FONT_AVGWIDTH_INDEX)))
2125 diff |= 1;
2126 score |= min (diff, 127) << sort_shift_bits[FONT_SIZE_INDEX];
2127 }
2128
2129 return score;
2130 }
2131
2132
2133 /* Concatenate all elements of LIST into one vector. LIST is a list
2134 of font-entity vectors. */
2135
2136 static Lisp_Object
2137 font_vconcat_entity_vectors (Lisp_Object list)
2138 {
2139 int nargs = XINT (Flength (list));
2140 Lisp_Object *args = alloca (word_size * nargs);
2141 int i;
2142
2143 for (i = 0; i < nargs; i++, list = XCDR (list))
2144 args[i] = XCAR (list);
2145 return Fvconcat (nargs, args);
2146 }
2147
2148
2149 /* The structure for elements being sorted by qsort. */
2150 struct font_sort_data
2151 {
2152 unsigned score;
2153 int font_driver_preference;
2154 Lisp_Object entity;
2155 };
2156
2157
2158 /* The comparison function for qsort. */
2159
2160 static int
2161 font_compare (const void *d1, const void *d2)
2162 {
2163 const struct font_sort_data *data1 = d1;
2164 const struct font_sort_data *data2 = d2;
2165
2166 if (data1->score < data2->score)
2167 return -1;
2168 else if (data1->score > data2->score)
2169 return 1;
2170 return (data1->font_driver_preference - data2->font_driver_preference);
2171 }
2172
2173
2174 /* Sort each font-entity vector in LIST by closeness to font-spec PREFER.
2175 If PREFER specifies a point-size, calculate the corresponding
2176 pixel-size from QCdpi property of PREFER or from the Y-resolution
2177 of FRAME before sorting.
2178
2179 If BEST-ONLY is nonzero, return the best matching entity (that
2180 supports the character BEST-ONLY if BEST-ONLY is positive, or any
2181 if BEST-ONLY is negative). Otherwise, return the sorted result as
2182 a single vector of font-entities.
2183
2184 This function does no optimization for the case that the total
2185 number of elements is 1. The caller should avoid calling this in
2186 such a case. */
2187
2188 static Lisp_Object
2189 font_sort_entities (Lisp_Object list, Lisp_Object prefer, Lisp_Object frame, int best_only)
2190 {
2191 Lisp_Object prefer_prop[FONT_SPEC_MAX];
2192 int len, maxlen, i;
2193 struct font_sort_data *data;
2194 unsigned best_score;
2195 Lisp_Object best_entity;
2196 struct frame *f = XFRAME (frame);
2197 Lisp_Object tail, vec IF_LINT (= Qnil);
2198 USE_SAFE_ALLOCA;
2199
2200 for (i = FONT_WEIGHT_INDEX; i <= FONT_AVGWIDTH_INDEX; i++)
2201 prefer_prop[i] = AREF (prefer, i);
2202 if (FLOATP (prefer_prop[FONT_SIZE_INDEX]))
2203 prefer_prop[FONT_SIZE_INDEX]
2204 = make_number (font_pixel_size (XFRAME (frame), prefer));
2205
2206 if (NILP (XCDR (list)))
2207 {
2208 /* What we have to take care of is this single vector. */
2209 vec = XCAR (list);
2210 maxlen = ASIZE (vec);
2211 }
2212 else if (best_only)
2213 {
2214 /* We don't have to perform sort, so there's no need of creating
2215 a single vector. But, we must find the length of the longest
2216 vector. */
2217 maxlen = 0;
2218 for (tail = list; CONSP (tail); tail = XCDR (tail))
2219 if (maxlen < ASIZE (XCAR (tail)))
2220 maxlen = ASIZE (XCAR (tail));
2221 }
2222 else
2223 {
2224 /* We have to create a single vector to sort it. */
2225 vec = font_vconcat_entity_vectors (list);
2226 maxlen = ASIZE (vec);
2227 }
2228
2229 data = SAFE_ALLOCA (maxlen * sizeof *data);
2230 best_score = 0xFFFFFFFF;
2231 best_entity = Qnil;
2232
2233 for (tail = list; CONSP (tail); tail = XCDR (tail))
2234 {
2235 int font_driver_preference = 0;
2236 Lisp_Object current_font_driver;
2237
2238 if (best_only)
2239 vec = XCAR (tail);
2240 len = ASIZE (vec);
2241
2242 /* We are sure that the length of VEC > 0. */
2243 current_font_driver = AREF (AREF (vec, 0), FONT_TYPE_INDEX);
2244 /* Score the elements. */
2245 for (i = 0; i < len; i++)
2246 {
2247 data[i].entity = AREF (vec, i);
2248 data[i].score
2249 = ((best_only <= 0 || font_has_char (f, data[i].entity, best_only)
2250 > 0)
2251 ? font_score (data[i].entity, prefer_prop)
2252 : 0xFFFFFFFF);
2253 if (best_only && best_score > data[i].score)
2254 {
2255 best_score = data[i].score;
2256 best_entity = data[i].entity;
2257 if (best_score == 0)
2258 break;
2259 }
2260 if (! EQ (current_font_driver, AREF (AREF (vec, i), FONT_TYPE_INDEX)))
2261 {
2262 current_font_driver = AREF (AREF (vec, i), FONT_TYPE_INDEX);
2263 font_driver_preference++;
2264 }
2265 data[i].font_driver_preference = font_driver_preference;
2266 }
2267
2268 /* Sort if necessary. */
2269 if (! best_only)
2270 {
2271 qsort (data, len, sizeof *data, font_compare);
2272 for (i = 0; i < len; i++)
2273 ASET (vec, i, data[i].entity);
2274 break;
2275 }
2276 else
2277 vec = best_entity;
2278 }
2279
2280 SAFE_FREE ();
2281
2282 FONT_ADD_LOG ("sort-by", prefer, vec);
2283 return vec;
2284 }
2285
2286 \f
2287 /* API of Font Service Layer. */
2288
2289 /* Reflect ORDER (see the variable font_sort_order in xfaces.c) to
2290 sort_shift_bits. Finternal_set_font_selection_order calls this
2291 function with font_sort_order after setting up it. */
2292
2293 void
2294 font_update_sort_order (int *order)
2295 {
2296 int i, shift_bits;
2297
2298 for (i = 0, shift_bits = 23; i < 4; i++, shift_bits -= 7)
2299 {
2300 int xlfd_idx = order[i];
2301
2302 if (xlfd_idx == XLFD_WEIGHT_INDEX)
2303 sort_shift_bits[FONT_WEIGHT_INDEX] = shift_bits;
2304 else if (xlfd_idx == XLFD_SLANT_INDEX)
2305 sort_shift_bits[FONT_SLANT_INDEX] = shift_bits;
2306 else if (xlfd_idx == XLFD_SWIDTH_INDEX)
2307 sort_shift_bits[FONT_WIDTH_INDEX] = shift_bits;
2308 else
2309 sort_shift_bits[FONT_SIZE_INDEX] = shift_bits;
2310 }
2311 }
2312
2313 static bool
2314 font_check_otf_features (Lisp_Object script, Lisp_Object langsys,
2315 Lisp_Object features, Lisp_Object table)
2316 {
2317 Lisp_Object val;
2318 bool negative;
2319
2320 table = assq_no_quit (script, table);
2321 if (NILP (table))
2322 return 0;
2323 table = XCDR (table);
2324 if (! NILP (langsys))
2325 {
2326 table = assq_no_quit (langsys, table);
2327 if (NILP (table))
2328 return 0;
2329 }
2330 else
2331 {
2332 val = assq_no_quit (Qnil, table);
2333 if (NILP (val))
2334 table = XCAR (table);
2335 else
2336 table = val;
2337 }
2338 table = XCDR (table);
2339 for (negative = 0; CONSP (features); features = XCDR (features))
2340 {
2341 if (NILP (XCAR (features)))
2342 {
2343 negative = 1;
2344 continue;
2345 }
2346 if (NILP (Fmemq (XCAR (features), table)) != negative)
2347 return 0;
2348 }
2349 return 1;
2350 }
2351
2352 /* Check if OTF_CAPABILITY satisfies SPEC (otf-spec). */
2353
2354 static bool
2355 font_check_otf (Lisp_Object spec, Lisp_Object otf_capability)
2356 {
2357 Lisp_Object script, langsys = Qnil, gsub = Qnil, gpos = Qnil;
2358
2359 script = XCAR (spec);
2360 spec = XCDR (spec);
2361 if (! NILP (spec))
2362 {
2363 langsys = XCAR (spec);
2364 spec = XCDR (spec);
2365 if (! NILP (spec))
2366 {
2367 gsub = XCAR (spec);
2368 spec = XCDR (spec);
2369 if (! NILP (spec))
2370 gpos = XCAR (spec);
2371 }
2372 }
2373
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;
2381 }
2382
2383
2384
2385 /* Check if FONT (font-entity or font-object) matches with the font
2386 specification SPEC. */
2387
2388 bool
2389 font_match_p (Lisp_Object spec, Lisp_Object font)
2390 {
2391 Lisp_Object prop[FONT_SPEC_MAX], *props;
2392 Lisp_Object extra, font_extra;
2393 int i;
2394
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]))
2402 {
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;
2408 }
2409
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))
2415 {
2416 Lisp_Object key = XCAR (XCAR (extra));
2417 Lisp_Object val = XCDR (XCAR (extra)), val2;
2418
2419 if (EQ (key, QClang))
2420 {
2421 val2 = assq_no_quit (key, font_extra);
2422 if (NILP (val2))
2423 return 0;
2424 val2 = XCDR (val2);
2425 if (CONSP (val))
2426 {
2427 if (! CONSP (val2))
2428 return 0;
2429 while (CONSP (val))
2430 if (NILP (Fmemq (val, val2)))
2431 return 0;
2432 }
2433 else
2434 if (CONSP (val2)
2435 ? NILP (Fmemq (val, XCDR (val2)))
2436 : ! EQ (val, val2))
2437 return 0;
2438 }
2439 else if (EQ (key, QCscript))
2440 {
2441 val2 = assq_no_quit (val, Vscript_representative_chars);
2442 if (CONSP (val2))
2443 {
2444 val2 = XCDR (val2);
2445 if (CONSP (val2))
2446 {
2447 /* All characters in the list must be supported. */
2448 for (; CONSP (val2); val2 = XCDR (val2))
2449 {
2450 if (! CHARACTERP (XCAR (val2)))
2451 continue;
2452 if (font_encode_char (font, XFASTINT (XCAR (val2)))
2453 == FONT_INVALID_CODE)
2454 return 0;
2455 }
2456 }
2457 else if (VECTORP (val2))
2458 {
2459 /* At most one character in the vector must be supported. */
2460 for (i = 0; i < ASIZE (val2); i++)
2461 {
2462 if (! CHARACTERP (AREF (val2, i)))
2463 continue;
2464 if (font_encode_char (font, XFASTINT (AREF (val2, i)))
2465 != FONT_INVALID_CODE)
2466 break;
2467 }
2468 if (i == ASIZE (val2))
2469 return 0;
2470 }
2471 }
2472 }
2473 else if (EQ (key, QCotf))
2474 {
2475 struct font *fontp;
2476
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;
2485 }
2486 }
2487
2488 return 1;
2489 }
2490 \f
2491
2492 /* Font cache
2493
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:
2498
2499 ((DRIVER-TYPE NUM-FRAMES FONT-CACHE-DATA ...) ...)
2500
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 ...). */
2504
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 *);
2510
2511 static void
2512 font_prepare_cache (FRAME_PTR f, struct font_driver *driver)
2513 {
2514 Lisp_Object cache, val;
2515
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))
2521 {
2522 val = Fcons (driver->type, Fcons (make_number (1), Qnil));
2523 XSETCDR (cache, Fcons (val, XCDR (cache)));
2524 }
2525 else
2526 {
2527 val = XCDR (XCAR (val));
2528 XSETCAR (val, make_number (XINT (XCAR (val)) + 1));
2529 }
2530 }
2531
2532
2533 static void
2534 font_finish_cache (FRAME_PTR f, struct font_driver *driver)
2535 {
2536 Lisp_Object cache, val, tmp;
2537
2538
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 eassert (! NILP (val));
2544 tmp = XCDR (XCAR (val));
2545 XSETCAR (tmp, make_number (XINT (XCAR (tmp)) - 1));
2546 if (XINT (XCAR (tmp)) == 0)
2547 {
2548 font_clear_cache (f, XCAR (val), driver);
2549 XSETCDR (cache, XCDR (val));
2550 }
2551 }
2552
2553
2554 static Lisp_Object
2555 font_get_cache (FRAME_PTR f, struct font_driver *driver)
2556 {
2557 Lisp_Object val = driver->get_cache (f);
2558 Lisp_Object type = driver->type;
2559
2560 eassert (CONSP (val));
2561 for (val = XCDR (val); ! EQ (XCAR (XCAR (val)), type); val = XCDR (val));
2562 eassert (CONSP (val));
2563 /* VAL = ((DRIVER-TYPE NUM-FRAMES FONT-CACHE-DATA ...) ...) */
2564 val = XCDR (XCAR (val));
2565 return val;
2566 }
2567
2568
2569 static void
2570 font_clear_cache (FRAME_PTR f, Lisp_Object cache, struct font_driver *driver)
2571 {
2572 Lisp_Object tail, elt;
2573 Lisp_Object tail2, entity;
2574
2575 /* CACHE = (DRIVER-TYPE NUM-FRAMES FONT-CACHE-DATA ...) */
2576 for (tail = XCDR (XCDR (cache)); CONSP (tail); tail = XCDR (tail))
2577 {
2578 elt = XCAR (tail);
2579 /* elt should have the form (FONT-SPEC FONT-ENTITY ...) */
2580 if (CONSP (elt) && FONT_SPEC_P (XCAR (elt)))
2581 {
2582 for (tail2 = XCDR (elt); CONSP (tail2); tail2 = XCDR (tail2))
2583 {
2584 entity = XCAR (tail2);
2585
2586 if (FONT_ENTITY_P (entity)
2587 && EQ (driver->type, AREF (entity, FONT_TYPE_INDEX)))
2588 {
2589 Lisp_Object objlist = AREF (entity, FONT_OBJLIST_INDEX);
2590
2591 for (; CONSP (objlist); objlist = XCDR (objlist))
2592 {
2593 Lisp_Object val = XCAR (objlist);
2594 struct font *font = XFONT_OBJECT (val);
2595
2596 if (! NILP (AREF (val, FONT_TYPE_INDEX)))
2597 {
2598 eassert (font && driver == font->driver);
2599 driver->close (f, font);
2600 }
2601 }
2602 if (driver->free_entity)
2603 driver->free_entity (entity);
2604 }
2605 }
2606 }
2607 }
2608 XSETCDR (cache, Qnil);
2609 }
2610 \f
2611
2612 static Lisp_Object scratch_font_spec, scratch_font_prefer;
2613
2614 /* Check each font-entity in VEC, and return a list of font-entities
2615 that satisfy these conditions:
2616 (1) matches with SPEC and SIZE if SPEC is not nil, and
2617 (2) doesn't match with any regexps in Vface_ignored_fonts (if non-nil).
2618 */
2619
2620 static Lisp_Object
2621 font_delete_unmatched (Lisp_Object vec, Lisp_Object spec, int size)
2622 {
2623 Lisp_Object entity, val;
2624 enum font_property_index prop;
2625 int i;
2626
2627 for (val = Qnil, i = ASIZE (vec) - 1; i >= 0; i--)
2628 {
2629 entity = AREF (vec, i);
2630 if (! NILP (Vface_ignored_fonts))
2631 {
2632 char name[256];
2633 ptrdiff_t namelen;
2634 Lisp_Object tail, regexp;
2635
2636 namelen = font_unparse_xlfd (entity, 0, name, 256);
2637 if (namelen >= 0)
2638 {
2639 for (tail = Vface_ignored_fonts; CONSP (tail); tail = XCDR (tail))
2640 {
2641 regexp = XCAR (tail);
2642 if (STRINGP (regexp)
2643 && fast_c_string_match_ignore_case (regexp, name,
2644 namelen) >= 0)
2645 break;
2646 }
2647 if (CONSP (tail))
2648 continue;
2649 }
2650 }
2651 if (NILP (spec))
2652 {
2653 val = Fcons (entity, val);
2654 continue;
2655 }
2656 for (prop = FONT_WEIGHT_INDEX; prop < FONT_SIZE_INDEX; prop++)
2657 if (INTEGERP (AREF (spec, prop))
2658 && ((XINT (AREF (spec, prop)) >> 8)
2659 != (XINT (AREF (entity, prop)) >> 8)))
2660 prop = FONT_SPEC_MAX;
2661 if (prop < FONT_SPEC_MAX
2662 && size
2663 && XINT (AREF (entity, FONT_SIZE_INDEX)) > 0)
2664 {
2665 int diff = XINT (AREF (entity, FONT_SIZE_INDEX)) - size;
2666
2667 if (eabs (diff) > FONT_PIXEL_SIZE_QUANTUM)
2668 prop = FONT_SPEC_MAX;
2669 }
2670 if (prop < FONT_SPEC_MAX
2671 && INTEGERP (AREF (spec, FONT_DPI_INDEX))
2672 && INTEGERP (AREF (entity, FONT_DPI_INDEX))
2673 && XINT (AREF (entity, FONT_DPI_INDEX)) != 0
2674 && ! EQ (AREF (spec, FONT_DPI_INDEX), AREF (entity, FONT_DPI_INDEX)))
2675 prop = FONT_SPEC_MAX;
2676 if (prop < FONT_SPEC_MAX
2677 && INTEGERP (AREF (spec, FONT_AVGWIDTH_INDEX))
2678 && INTEGERP (AREF (entity, FONT_AVGWIDTH_INDEX))
2679 && XINT (AREF (entity, FONT_AVGWIDTH_INDEX)) != 0
2680 && ! EQ (AREF (spec, FONT_AVGWIDTH_INDEX),
2681 AREF (entity, FONT_AVGWIDTH_INDEX)))
2682 prop = FONT_SPEC_MAX;
2683 if (prop < FONT_SPEC_MAX)
2684 val = Fcons (entity, val);
2685 }
2686 return (Fvconcat (1, &val));
2687 }
2688
2689
2690 /* Return a list of vectors of font-entities matching with SPEC on
2691 FRAME. Each elements in the list is a vector of entities from the
2692 same font-driver. */
2693
2694 Lisp_Object
2695 font_list_entities (Lisp_Object frame, Lisp_Object spec)
2696 {
2697 FRAME_PTR f = XFRAME (frame);
2698 struct font_driver_list *driver_list = f->font_driver_list;
2699 Lisp_Object ftype, val;
2700 Lisp_Object list = Qnil;
2701 int size;
2702 bool need_filtering = 0;
2703 int i;
2704
2705 eassert (FONT_SPEC_P (spec));
2706
2707 if (INTEGERP (AREF (spec, FONT_SIZE_INDEX)))
2708 size = XINT (AREF (spec, FONT_SIZE_INDEX));
2709 else if (FLOATP (AREF (spec, FONT_SIZE_INDEX)))
2710 size = font_pixel_size (f, spec);
2711 else
2712 size = 0;
2713
2714 ftype = AREF (spec, FONT_TYPE_INDEX);
2715 for (i = FONT_FOUNDRY_INDEX; i <= FONT_REGISTRY_INDEX; i++)
2716 ASET (scratch_font_spec, i, AREF (spec, i));
2717 for (i = FONT_WEIGHT_INDEX; i < FONT_EXTRA_INDEX; i++)
2718 if (i != FONT_SPACING_INDEX)
2719 {
2720 ASET (scratch_font_spec, i, Qnil);
2721 if (! NILP (AREF (spec, i)))
2722 need_filtering = 1;
2723 }
2724 ASET (scratch_font_spec, FONT_SPACING_INDEX, AREF (spec, FONT_SPACING_INDEX));
2725 ASET (scratch_font_spec, FONT_EXTRA_INDEX, AREF (spec, FONT_EXTRA_INDEX));
2726
2727 for (i = 0; driver_list; driver_list = driver_list->next)
2728 if (driver_list->on
2729 && (NILP (ftype) || EQ (driver_list->driver->type, ftype)))
2730 {
2731 Lisp_Object cache = font_get_cache (f, driver_list->driver);
2732
2733 ASET (scratch_font_spec, FONT_TYPE_INDEX, driver_list->driver->type);
2734 val = assoc_no_quit (scratch_font_spec, XCDR (cache));
2735 if (CONSP (val))
2736 val = XCDR (val);
2737 else
2738 {
2739 Lisp_Object copy;
2740
2741 val = driver_list->driver->list (frame, scratch_font_spec);
2742 if (NILP (val))
2743 val = zero_vector;
2744 else
2745 val = Fvconcat (1, &val);
2746 copy = copy_font_spec (scratch_font_spec);
2747 ASET (copy, FONT_TYPE_INDEX, driver_list->driver->type);
2748 XSETCDR (cache, Fcons (Fcons (copy, val), XCDR (cache)));
2749 }
2750 if (ASIZE (val) > 0
2751 && (need_filtering
2752 || ! NILP (Vface_ignored_fonts)))
2753 val = font_delete_unmatched (val, need_filtering ? spec : Qnil, size);
2754 if (ASIZE (val) > 0)
2755 list = Fcons (val, list);
2756 }
2757
2758 list = Fnreverse (list);
2759 FONT_ADD_LOG ("list", spec, list);
2760 return list;
2761 }
2762
2763
2764 /* Return a font entity matching with SPEC on FRAME. ATTRS, if non
2765 nil, is an array of face's attributes, which specifies preferred
2766 font-related attributes. */
2767
2768 static Lisp_Object
2769 font_matching_entity (FRAME_PTR f, Lisp_Object *attrs, Lisp_Object spec)
2770 {
2771 struct font_driver_list *driver_list = f->font_driver_list;
2772 Lisp_Object ftype, size, entity;
2773 Lisp_Object frame;
2774 Lisp_Object work = copy_font_spec (spec);
2775
2776 XSETFRAME (frame, f);
2777 ftype = AREF (spec, FONT_TYPE_INDEX);
2778 size = AREF (spec, FONT_SIZE_INDEX);
2779
2780 if (FLOATP (size))
2781 ASET (work, FONT_SIZE_INDEX, make_number (font_pixel_size (f, spec)));
2782 FONT_SET_STYLE (work, FONT_WEIGHT_INDEX, attrs[LFACE_WEIGHT_INDEX]);
2783 FONT_SET_STYLE (work, FONT_SLANT_INDEX, attrs[LFACE_SLANT_INDEX]);
2784 FONT_SET_STYLE (work, FONT_WIDTH_INDEX, attrs[LFACE_SWIDTH_INDEX]);
2785
2786 entity = Qnil;
2787 for (; driver_list; driver_list = driver_list->next)
2788 if (driver_list->on
2789 && (NILP (ftype) || EQ (driver_list->driver->type, ftype)))
2790 {
2791 Lisp_Object cache = font_get_cache (f, driver_list->driver);
2792 Lisp_Object copy;
2793
2794 ASET (work, FONT_TYPE_INDEX, driver_list->driver->type);
2795 entity = assoc_no_quit (work, XCDR (cache));
2796 if (CONSP (entity))
2797 entity = XCDR (entity);
2798 else
2799 {
2800 entity = driver_list->driver->match (frame, work);
2801 copy = copy_font_spec (work);
2802 ASET (copy, FONT_TYPE_INDEX, driver_list->driver->type);
2803 XSETCDR (cache, Fcons (Fcons (copy, entity), XCDR (cache)));
2804 }
2805 if (! NILP (entity))
2806 break;
2807 }
2808 FONT_ADD_LOG ("match", work, entity);
2809 return entity;
2810 }
2811
2812
2813 /* Open a font of ENTITY and PIXEL_SIZE on frame F, and return the
2814 opened font object. */
2815
2816 static Lisp_Object
2817 font_open_entity (FRAME_PTR f, Lisp_Object entity, int pixel_size)
2818 {
2819 struct font_driver_list *driver_list;
2820 Lisp_Object objlist, size, val, font_object;
2821 struct font *font;
2822 int min_width, height;
2823
2824 eassert (FONT_ENTITY_P (entity));
2825 size = AREF (entity, FONT_SIZE_INDEX);
2826 if (XINT (size) != 0)
2827 pixel_size = XINT (size);
2828
2829 val = AREF (entity, FONT_TYPE_INDEX);
2830 for (driver_list = f->font_driver_list;
2831 driver_list && ! EQ (driver_list->driver->type, val);
2832 driver_list = driver_list->next);
2833 if (! driver_list)
2834 return Qnil;
2835
2836 for (objlist = AREF (entity, FONT_OBJLIST_INDEX); CONSP (objlist);
2837 objlist = XCDR (objlist))
2838 {
2839 Lisp_Object fn = XCAR (objlist);
2840 if (! NILP (AREF (fn, FONT_TYPE_INDEX))
2841 && XFONT_OBJECT (fn)->pixel_size == pixel_size)
2842 {
2843 if (driver_list->driver->cached_font_ok == NULL
2844 || driver_list->driver->cached_font_ok (f, fn, entity))
2845 return fn;
2846 }
2847 }
2848
2849 font_object = driver_list->driver->open (f, entity, pixel_size);
2850 if (!NILP (font_object))
2851 ASET (font_object, FONT_SIZE_INDEX, make_number (pixel_size));
2852 FONT_ADD_LOG ("open", entity, font_object);
2853 if (NILP (font_object))
2854 return Qnil;
2855 ASET (entity, FONT_OBJLIST_INDEX,
2856 Fcons (font_object, AREF (entity, FONT_OBJLIST_INDEX)));
2857
2858 font = XFONT_OBJECT (font_object);
2859 min_width = (font->min_width ? font->min_width
2860 : font->average_width ? font->average_width
2861 : font->space_width ? font->space_width
2862 : 1);
2863 height = (font->height ? font->height : 1);
2864 #ifdef HAVE_WINDOW_SYSTEM
2865 FRAME_X_DISPLAY_INFO (f)->n_fonts++;
2866 if (FRAME_X_DISPLAY_INFO (f)->n_fonts == 1)
2867 {
2868 FRAME_SMALLEST_CHAR_WIDTH (f) = min_width;
2869 FRAME_SMALLEST_FONT_HEIGHT (f) = height;
2870 fonts_changed_p = 1;
2871 }
2872 else
2873 {
2874 if (FRAME_SMALLEST_CHAR_WIDTH (f) > min_width)
2875 FRAME_SMALLEST_CHAR_WIDTH (f) = min_width, fonts_changed_p = 1;
2876 if (FRAME_SMALLEST_FONT_HEIGHT (f) > height)
2877 FRAME_SMALLEST_FONT_HEIGHT (f) = height, fonts_changed_p = 1;
2878 }
2879 #endif
2880
2881 return font_object;
2882 }
2883
2884
2885 /* Close FONT_OBJECT that is opened on frame F. */
2886
2887 static void
2888 font_close_object (FRAME_PTR f, Lisp_Object font_object)
2889 {
2890 struct font *font = XFONT_OBJECT (font_object);
2891
2892 if (NILP (AREF (font_object, FONT_TYPE_INDEX)))
2893 /* Already closed. */
2894 return;
2895 FONT_ADD_LOG ("close", font_object, Qnil);
2896 font->driver->close (f, font);
2897 #ifdef HAVE_WINDOW_SYSTEM
2898 eassert (FRAME_X_DISPLAY_INFO (f)->n_fonts);
2899 FRAME_X_DISPLAY_INFO (f)->n_fonts--;
2900 #endif
2901 }
2902
2903
2904 /* Return 1 if FONT on F has a glyph for character C, 0 if not, -1 if
2905 FONT is a font-entity and it must be opened to check. */
2906
2907 int
2908 font_has_char (FRAME_PTR f, Lisp_Object font, int c)
2909 {
2910 struct font *fontp;
2911
2912 if (FONT_ENTITY_P (font))
2913 {
2914 Lisp_Object type = AREF (font, FONT_TYPE_INDEX);
2915 struct font_driver_list *driver_list;
2916
2917 for (driver_list = f->font_driver_list;
2918 driver_list && ! EQ (driver_list->driver->type, type);
2919 driver_list = driver_list->next);
2920 if (! driver_list)
2921 return 0;
2922 if (! driver_list->driver->has_char)
2923 return -1;
2924 return driver_list->driver->has_char (font, c);
2925 }
2926
2927 eassert (FONT_OBJECT_P (font));
2928 fontp = XFONT_OBJECT (font);
2929 if (fontp->driver->has_char)
2930 {
2931 int result = fontp->driver->has_char (font, c);
2932
2933 if (result >= 0)
2934 return result;
2935 }
2936 return (fontp->driver->encode_char (fontp, c) != FONT_INVALID_CODE);
2937 }
2938
2939
2940 /* Return the glyph ID of FONT_OBJECT for character C. */
2941
2942 static unsigned
2943 font_encode_char (Lisp_Object font_object, int c)
2944 {
2945 struct font *font;
2946
2947 eassert (FONT_OBJECT_P (font_object));
2948 font = XFONT_OBJECT (font_object);
2949 return font->driver->encode_char (font, c);
2950 }
2951
2952
2953 /* Return the name of FONT_OBJECT. */
2954
2955 Lisp_Object
2956 font_get_name (Lisp_Object font_object)
2957 {
2958 eassert (FONT_OBJECT_P (font_object));
2959 return AREF (font_object, FONT_NAME_INDEX);
2960 }
2961
2962
2963 /* Create a new font spec from FONT_NAME, and return it. If FONT_NAME
2964 could not be parsed by font_parse_name, return Qnil. */
2965
2966 Lisp_Object
2967 font_spec_from_name (Lisp_Object font_name)
2968 {
2969 Lisp_Object spec = Ffont_spec (0, NULL);
2970
2971 CHECK_STRING (font_name);
2972 if (font_parse_name (SSDATA (font_name), SBYTES (font_name), spec) == -1)
2973 return Qnil;
2974 font_put_extra (spec, QCname, font_name);
2975 font_put_extra (spec, QCuser_spec, font_name);
2976 return spec;
2977 }
2978
2979
2980 void
2981 font_clear_prop (Lisp_Object *attrs, enum font_property_index prop)
2982 {
2983 Lisp_Object font = attrs[LFACE_FONT_INDEX];
2984
2985 if (! FONTP (font))
2986 return;
2987
2988 if (! NILP (Ffont_get (font, QCname)))
2989 {
2990 font = copy_font_spec (font);
2991 font_put_extra (font, QCname, Qnil);
2992 }
2993
2994 if (NILP (AREF (font, prop))
2995 && prop != FONT_FAMILY_INDEX
2996 && prop != FONT_FOUNDRY_INDEX
2997 && prop != FONT_WIDTH_INDEX
2998 && prop != FONT_SIZE_INDEX)
2999 return;
3000 if (EQ (font, attrs[LFACE_FONT_INDEX]))
3001 font = copy_font_spec (font);
3002 ASET (font, prop, Qnil);
3003 if (prop == FONT_FAMILY_INDEX || prop == FONT_FOUNDRY_INDEX)
3004 {
3005 if (prop == FONT_FAMILY_INDEX)
3006 {
3007 ASET (font, FONT_FOUNDRY_INDEX, Qnil);
3008 /* If we are setting the font family, we must also clear
3009 FONT_WIDTH_INDEX to avoid rejecting families that lack
3010 support for some widths. */
3011 ASET (font, FONT_WIDTH_INDEX, Qnil);
3012 }
3013 ASET (font, FONT_ADSTYLE_INDEX, Qnil);
3014 ASET (font, FONT_REGISTRY_INDEX, Qnil);
3015 ASET (font, FONT_SIZE_INDEX, Qnil);
3016 ASET (font, FONT_DPI_INDEX, Qnil);
3017 ASET (font, FONT_SPACING_INDEX, Qnil);
3018 ASET (font, FONT_AVGWIDTH_INDEX, Qnil);
3019 }
3020 else if (prop == FONT_SIZE_INDEX)
3021 {
3022 ASET (font, FONT_DPI_INDEX, Qnil);
3023 ASET (font, FONT_SPACING_INDEX, Qnil);
3024 ASET (font, FONT_AVGWIDTH_INDEX, Qnil);
3025 }
3026 else if (prop == FONT_WIDTH_INDEX)
3027 ASET (font, FONT_AVGWIDTH_INDEX, Qnil);
3028 attrs[LFACE_FONT_INDEX] = font;
3029 }
3030
3031 /* Select a font from ENTITIES (list of font-entity vectors) that
3032 supports C and is the best match for ATTRS and PIXEL_SIZE. */
3033
3034 static Lisp_Object
3035 font_select_entity (Lisp_Object frame, Lisp_Object entities, Lisp_Object *attrs, int pixel_size, int c)
3036 {
3037 Lisp_Object font_entity;
3038 Lisp_Object prefer;
3039 int i;
3040 FRAME_PTR f = XFRAME (frame);
3041
3042 if (NILP (XCDR (entities))
3043 && ASIZE (XCAR (entities)) == 1)
3044 {
3045 font_entity = AREF (XCAR (entities), 0);
3046 if (c < 0 || font_has_char (f, font_entity, c) > 0)
3047 return font_entity;
3048 return Qnil;
3049 }
3050
3051 /* Sort fonts by properties specified in ATTRS. */
3052 prefer = scratch_font_prefer;
3053
3054 for (i = FONT_WEIGHT_INDEX; i <= FONT_SIZE_INDEX; i++)
3055 ASET (prefer, i, Qnil);
3056 if (FONTP (attrs[LFACE_FONT_INDEX]))
3057 {
3058 Lisp_Object face_font = attrs[LFACE_FONT_INDEX];
3059
3060 for (i = FONT_WEIGHT_INDEX; i <= FONT_SIZE_INDEX; i++)
3061 ASET (prefer, i, AREF (face_font, i));
3062 }
3063 if (NILP (AREF (prefer, FONT_WEIGHT_INDEX)))
3064 FONT_SET_STYLE (prefer, FONT_WEIGHT_INDEX, attrs[LFACE_WEIGHT_INDEX]);
3065 if (NILP (AREF (prefer, FONT_SLANT_INDEX)))
3066 FONT_SET_STYLE (prefer, FONT_SLANT_INDEX, attrs[LFACE_SLANT_INDEX]);
3067 if (NILP (AREF (prefer, FONT_WIDTH_INDEX)))
3068 FONT_SET_STYLE (prefer, FONT_WIDTH_INDEX, attrs[LFACE_SWIDTH_INDEX]);
3069 ASET (prefer, FONT_SIZE_INDEX, make_number (pixel_size));
3070
3071 return font_sort_entities (entities, prefer, frame, c);
3072 }
3073
3074 /* Return a font-entity that satisfies SPEC and is the best match for
3075 face's font related attributes in ATTRS. C, if not negative, is a
3076 character that the entity must support. */
3077
3078 Lisp_Object
3079 font_find_for_lface (FRAME_PTR f, Lisp_Object *attrs, Lisp_Object spec, int c)
3080 {
3081 Lisp_Object work;
3082 Lisp_Object frame, entities, val;
3083 Lisp_Object foundry[3], *family, registry[3], adstyle[3];
3084 int pixel_size;
3085 int i, j, k, l;
3086 USE_SAFE_ALLOCA;
3087
3088 registry[0] = AREF (spec, FONT_REGISTRY_INDEX);
3089 if (NILP (registry[0]))
3090 {
3091 registry[0] = DEFAULT_ENCODING;
3092 registry[1] = Qascii_0;
3093 registry[2] = zero_vector;
3094 }
3095 else
3096 registry[1] = zero_vector;
3097
3098 if (c >= 0 && ! NILP (AREF (spec, FONT_REGISTRY_INDEX)))
3099 {
3100 struct charset *encoding, *repertory;
3101
3102 if (font_registry_charsets (AREF (spec, FONT_REGISTRY_INDEX),
3103 &encoding, &repertory) < 0)
3104 return Qnil;
3105 if (repertory
3106 && ENCODE_CHAR (repertory, c) == CHARSET_INVALID_CODE (repertory))
3107 return Qnil;
3108 else if (c > encoding->max_char)
3109 return Qnil;
3110 }
3111
3112 work = copy_font_spec (spec);
3113 ASET (work, FONT_TYPE_INDEX, AREF (spec, FONT_TYPE_INDEX));
3114 XSETFRAME (frame, f);
3115 pixel_size = font_pixel_size (f, spec);
3116 if (pixel_size == 0 && INTEGERP (attrs[LFACE_HEIGHT_INDEX]))
3117 {
3118 double pt = XINT (attrs[LFACE_HEIGHT_INDEX]);
3119
3120 pixel_size = POINT_TO_PIXEL (pt / 10, f->resy);
3121 }
3122 ASET (work, FONT_SIZE_INDEX, Qnil);
3123 foundry[0] = AREF (work, FONT_FOUNDRY_INDEX);
3124 if (! NILP (foundry[0]))
3125 foundry[1] = zero_vector;
3126 else if (STRINGP (attrs[LFACE_FOUNDRY_INDEX]))
3127 {
3128 val = attrs[LFACE_FOUNDRY_INDEX];
3129 foundry[0] = font_intern_prop (SSDATA (val), SBYTES (val), 1);
3130 foundry[1] = Qnil;
3131 foundry[2] = zero_vector;
3132 }
3133 else
3134 foundry[0] = Qnil, foundry[1] = zero_vector;
3135
3136 adstyle[0] = AREF (work, FONT_ADSTYLE_INDEX);
3137 if (! NILP (adstyle[0]))
3138 adstyle[1] = zero_vector;
3139 else if (FONTP (attrs[LFACE_FONT_INDEX]))
3140 {
3141 Lisp_Object face_font = attrs[LFACE_FONT_INDEX];
3142
3143 if (! NILP (AREF (face_font, FONT_ADSTYLE_INDEX)))
3144 {
3145 adstyle[0] = AREF (face_font, FONT_ADSTYLE_INDEX);
3146 adstyle[1] = Qnil;
3147 adstyle[2] = zero_vector;
3148 }
3149 else
3150 adstyle[0] = Qnil, adstyle[1] = zero_vector;
3151 }
3152 else
3153 adstyle[0] = Qnil, adstyle[1] = zero_vector;
3154
3155
3156 val = AREF (work, FONT_FAMILY_INDEX);
3157 if (NILP (val) && STRINGP (attrs[LFACE_FAMILY_INDEX]))
3158 {
3159 val = attrs[LFACE_FAMILY_INDEX];
3160 val = font_intern_prop (SSDATA (val), SBYTES (val), 1);
3161 }
3162 if (NILP (val))
3163 {
3164 family = alloca ((sizeof family[0]) * 2);
3165 family[0] = Qnil;
3166 family[1] = zero_vector; /* terminator. */
3167 }
3168 else
3169 {
3170 Lisp_Object alters
3171 = Fassoc_string (val, Vface_alternative_font_family_alist, Qt);
3172
3173 if (! NILP (alters))
3174 {
3175 EMACS_INT alterslen = XFASTINT (Flength (alters));
3176 SAFE_ALLOCA_LISP (family, alterslen + 2);
3177 for (i = 0; CONSP (alters); i++, alters = XCDR (alters))
3178 family[i] = XCAR (alters);
3179 if (NILP (AREF (spec, FONT_FAMILY_INDEX)))
3180 family[i++] = Qnil;
3181 family[i] = zero_vector;
3182 }
3183 else
3184 {
3185 family = alloca ((sizeof family[0]) * 3);
3186 i = 0;
3187 family[i++] = val;
3188 if (NILP (AREF (spec, FONT_FAMILY_INDEX)))
3189 family[i++] = Qnil;
3190 family[i] = zero_vector;
3191 }
3192 }
3193
3194 for (i = 0; SYMBOLP (family[i]); i++)
3195 {
3196 ASET (work, FONT_FAMILY_INDEX, family[i]);
3197 for (j = 0; SYMBOLP (foundry[j]); j++)
3198 {
3199 ASET (work, FONT_FOUNDRY_INDEX, foundry[j]);
3200 for (k = 0; SYMBOLP (registry[k]); k++)
3201 {
3202 ASET (work, FONT_REGISTRY_INDEX, registry[k]);
3203 for (l = 0; SYMBOLP (adstyle[l]); l++)
3204 {
3205 ASET (work, FONT_ADSTYLE_INDEX, adstyle[l]);
3206 entities = font_list_entities (frame, work);
3207 if (! NILP (entities))
3208 {
3209 val = font_select_entity (frame, entities,
3210 attrs, pixel_size, c);
3211 if (! NILP (val))
3212 return val;
3213 }
3214 }
3215 }
3216 }
3217 }
3218
3219 SAFE_FREE ();
3220 return Qnil;
3221 }
3222
3223
3224 Lisp_Object
3225 font_open_for_lface (FRAME_PTR f, Lisp_Object entity, Lisp_Object *attrs, Lisp_Object spec)
3226 {
3227 int size;
3228
3229 if (INTEGERP (AREF (entity, FONT_SIZE_INDEX))
3230 && XINT (AREF (entity, FONT_SIZE_INDEX)) > 0)
3231 size = XINT (AREF (entity, FONT_SIZE_INDEX));
3232 else
3233 {
3234 if (FONT_SPEC_P (spec) && ! NILP (AREF (spec, FONT_SIZE_INDEX)))
3235 size = font_pixel_size (f, spec);
3236 else
3237 {
3238 double pt;
3239 if (INTEGERP (attrs[LFACE_HEIGHT_INDEX]))
3240 pt = XINT (attrs[LFACE_HEIGHT_INDEX]);
3241 else
3242 {
3243 struct face *def = FACE_FROM_ID (f, DEFAULT_FACE_ID);
3244 Lisp_Object height = def->lface[LFACE_HEIGHT_INDEX];
3245 eassert (INTEGERP (height));
3246 pt = XINT (height);
3247 }
3248
3249 pt /= 10;
3250 size = POINT_TO_PIXEL (pt, f->resy);
3251 #ifdef HAVE_NS
3252 if (size == 0)
3253 {
3254 Lisp_Object ffsize = get_frame_param (f, Qfontsize);
3255 size = NUMBERP (ffsize) ? POINT_TO_PIXEL (XINT (ffsize), f->resy) : 0;
3256 }
3257 #endif
3258 }
3259 size *= font_rescale_ratio (entity);
3260 }
3261
3262 return font_open_entity (f, entity, size);
3263 }
3264
3265
3266 /* Find a font that satisfies SPEC and is the best match for
3267 face's attributes in ATTRS on FRAME, and return the opened
3268 font-object. */
3269
3270 Lisp_Object
3271 font_load_for_lface (FRAME_PTR f, Lisp_Object *attrs, Lisp_Object spec)
3272 {
3273 Lisp_Object entity, name;
3274
3275 entity = font_find_for_lface (f, attrs, spec, -1);
3276 if (NILP (entity))
3277 {
3278 /* No font is listed for SPEC, but each font-backend may have
3279 different criteria about "font matching". So, try it. */
3280 entity = font_matching_entity (f, attrs, spec);
3281 if (NILP (entity))
3282 return Qnil;
3283 }
3284 /* Don't lose the original name that was put in initially. We need
3285 it to re-apply the font when font parameters (like hinting or dpi) have
3286 changed. */
3287 entity = font_open_for_lface (f, entity, attrs, spec);
3288 if (!NILP (entity))
3289 {
3290 name = Ffont_get (spec, QCuser_spec);
3291 if (STRINGP (name)) font_put_extra (entity, QCuser_spec, name);
3292 }
3293 return entity;
3294 }
3295
3296
3297 /* Make FACE on frame F ready to use the font opened for FACE. */
3298
3299 void
3300 font_prepare_for_face (FRAME_PTR f, struct face *face)
3301 {
3302 if (face->font->driver->prepare_face)
3303 face->font->driver->prepare_face (f, face);
3304 }
3305
3306
3307 /* Make FACE on frame F stop using the font opened for FACE. */
3308
3309 void
3310 font_done_for_face (FRAME_PTR f, struct face *face)
3311 {
3312 if (face->font->driver->done_face)
3313 face->font->driver->done_face (f, face);
3314 face->extra = NULL;
3315 }
3316
3317
3318 /* Open a font that is a match for font-spec SPEC on frame F. If no proper
3319 font is found, return Qnil. */
3320
3321 Lisp_Object
3322 font_open_by_spec (FRAME_PTR f, Lisp_Object spec)
3323 {
3324 Lisp_Object attrs[LFACE_VECTOR_SIZE];
3325
3326 /* We set up the default font-related attributes of a face to prefer
3327 a moderate font. */
3328 attrs[LFACE_FAMILY_INDEX] = attrs[LFACE_FOUNDRY_INDEX] = Qnil;
3329 attrs[LFACE_SWIDTH_INDEX] = attrs[LFACE_WEIGHT_INDEX]
3330 = attrs[LFACE_SLANT_INDEX] = Qnormal;
3331 #ifndef HAVE_NS
3332 attrs[LFACE_HEIGHT_INDEX] = make_number (120);
3333 #else
3334 attrs[LFACE_HEIGHT_INDEX] = make_number (0);
3335 #endif
3336 attrs[LFACE_FONT_INDEX] = Qnil;
3337
3338 return font_load_for_lface (f, attrs, spec);
3339 }
3340
3341
3342 /* Open a font that matches NAME on frame F. If no proper font is
3343 found, return Qnil. */
3344
3345 Lisp_Object
3346 font_open_by_name (FRAME_PTR f, Lisp_Object name)
3347 {
3348 Lisp_Object args[2];
3349 Lisp_Object spec, ret;
3350
3351 args[0] = QCname;
3352 args[1] = name;
3353 spec = Ffont_spec (2, args);
3354 ret = font_open_by_spec (f, spec);
3355 /* Do not lose name originally put in. */
3356 if (!NILP (ret))
3357 font_put_extra (ret, QCuser_spec, args[1]);
3358
3359 return ret;
3360 }
3361
3362
3363 /* Register font-driver DRIVER. This function is used in two ways.
3364
3365 The first is with frame F non-NULL. In this case, make DRIVER
3366 available (but not yet activated) on F. All frame creators
3367 (e.g. Fx_create_frame) must call this function at least once with
3368 an available font-driver.
3369
3370 The second is with frame F NULL. In this case, DRIVER is globally
3371 registered in the variable `font_driver_list'. All font-driver
3372 implementations must call this function in its syms_of_XXXX
3373 (e.g. syms_of_xfont). */
3374
3375 void
3376 register_font_driver (struct font_driver *driver, FRAME_PTR f)
3377 {
3378 struct font_driver_list *root = f ? f->font_driver_list : font_driver_list;
3379 struct font_driver_list *prev, *list;
3380
3381 if (f && ! driver->draw)
3382 error ("Unusable font driver for a frame: %s",
3383 SDATA (SYMBOL_NAME (driver->type)));
3384
3385 for (prev = NULL, list = root; list; prev = list, list = list->next)
3386 if (EQ (list->driver->type, driver->type))
3387 error ("Duplicated font driver: %s", SDATA (SYMBOL_NAME (driver->type)));
3388
3389 list = xmalloc (sizeof *list);
3390 list->on = 0;
3391 list->driver = driver;
3392 list->next = NULL;
3393 if (prev)
3394 prev->next = list;
3395 else if (f)
3396 f->font_driver_list = list;
3397 else
3398 font_driver_list = list;
3399 if (! f)
3400 num_font_drivers++;
3401 }
3402
3403 void
3404 free_font_driver_list (FRAME_PTR f)
3405 {
3406 struct font_driver_list *list, *next;
3407
3408 for (list = f->font_driver_list; list; list = next)
3409 {
3410 next = list->next;
3411 xfree (list);
3412 }
3413 f->font_driver_list = NULL;
3414 }
3415
3416
3417 /* Make the frame F use font backends listed in NEW_DRIVERS (list of
3418 symbols, e.g. xft, x). If NEW_DRIVERS is t, make F use all
3419 available font drivers. If NEW_DRIVERS is nil, finalize all drivers.
3420
3421 A caller must free all realized faces if any in advance. The
3422 return value is a list of font backends actually made used on
3423 F. */
3424
3425 Lisp_Object
3426 font_update_drivers (FRAME_PTR f, Lisp_Object new_drivers)
3427 {
3428 Lisp_Object active_drivers = Qnil;
3429 struct font_driver_list *list;
3430
3431 /* At first, turn off non-requested drivers, and turn on requested
3432 drivers. */
3433 for (list = f->font_driver_list; list; list = list->next)
3434 {
3435 struct font_driver *driver = list->driver;
3436 if ((EQ (new_drivers, Qt) || ! NILP (Fmemq (driver->type, new_drivers)))
3437 != list->on)
3438 {
3439 if (list->on)
3440 {
3441 if (driver->end_for_frame)
3442 driver->end_for_frame (f);
3443 font_finish_cache (f, driver);
3444 list->on = 0;
3445 }
3446 else
3447 {
3448 if (! driver->start_for_frame
3449 || driver->start_for_frame (f) == 0)
3450 {
3451 font_prepare_cache (f, driver);
3452 list->on = 1;
3453 }
3454 }
3455 }
3456 }
3457
3458 if (NILP (new_drivers))
3459 return Qnil;
3460
3461 if (! EQ (new_drivers, Qt))
3462 {
3463 /* Re-order the driver list according to new_drivers. */
3464 struct font_driver_list **list_table, **next;
3465 Lisp_Object tail;
3466 int i;
3467
3468 list_table = alloca (sizeof list_table[0] * (num_font_drivers + 1));
3469 for (i = 0, tail = new_drivers; ! NILP (tail); tail = XCDR (tail))
3470 {
3471 for (list = f->font_driver_list; list; list = list->next)
3472 if (list->on && EQ (list->driver->type, XCAR (tail)))
3473 break;
3474 if (list)
3475 list_table[i++] = list;
3476 }
3477 for (list = f->font_driver_list; list; list = list->next)
3478 if (! list->on)
3479 list_table[i++] = list;
3480 list_table[i] = NULL;
3481
3482 next = &f->font_driver_list;
3483 for (i = 0; list_table[i]; i++)
3484 {
3485 *next = list_table[i];
3486 next = &(*next)->next;
3487 }
3488 *next = NULL;
3489
3490 if (! f->font_driver_list->on)
3491 { /* None of the drivers is enabled: enable them all.
3492 Happens if you set the list of drivers to (xft x) in your .emacs
3493 and then use it under w32 or ns. */
3494 for (list = f->font_driver_list; list; list = list->next)
3495 {
3496 struct font_driver *driver = list->driver;
3497 eassert (! list->on);
3498 if (! driver->start_for_frame
3499 || driver->start_for_frame (f) == 0)
3500 {
3501 font_prepare_cache (f, driver);
3502 list->on = 1;
3503 }
3504 }
3505 }
3506 }
3507
3508 for (list = f->font_driver_list; list; list = list->next)
3509 if (list->on)
3510 active_drivers = nconc2 (active_drivers,
3511 Fcons (list->driver->type, Qnil));
3512 return active_drivers;
3513 }
3514
3515 int
3516 font_put_frame_data (FRAME_PTR f, struct font_driver *driver, void *data)
3517 {
3518 struct font_data_list *list, *prev;
3519
3520 for (prev = NULL, list = f->font_data_list; list;
3521 prev = list, list = list->next)
3522 if (list->driver == driver)
3523 break;
3524 if (! data)
3525 {
3526 if (list)
3527 {
3528 if (prev)
3529 prev->next = list->next;
3530 else
3531 f->font_data_list = list->next;
3532 xfree (list);
3533 }
3534 return 0;
3535 }
3536
3537 if (! list)
3538 {
3539 list = xmalloc (sizeof *list);
3540 list->driver = driver;
3541 list->next = f->font_data_list;
3542 f->font_data_list = list;
3543 }
3544 list->data = data;
3545 return 0;
3546 }
3547
3548
3549 void *
3550 font_get_frame_data (FRAME_PTR f, struct font_driver *driver)
3551 {
3552 struct font_data_list *list;
3553
3554 for (list = f->font_data_list; list; list = list->next)
3555 if (list->driver == driver)
3556 break;
3557 if (! list)
3558 return NULL;
3559 return list->data;
3560 }
3561
3562
3563 /* Sets attributes on a font. Any properties that appear in ALIST and
3564 BOOLEAN_PROPERTIES or NON_BOOLEAN_PROPERTIES are set on the font.
3565 BOOLEAN_PROPERTIES and NON_BOOLEAN_PROPERTIES are NULL-terminated
3566 arrays of strings. This function is intended for use by the font
3567 drivers to implement their specific font_filter_properties. */
3568 void
3569 font_filter_properties (Lisp_Object font,
3570 Lisp_Object alist,
3571 const char *const boolean_properties[],
3572 const char *const non_boolean_properties[])
3573 {
3574 Lisp_Object it;
3575 int i;
3576
3577 /* Set boolean values to Qt or Qnil. */
3578 for (i = 0; boolean_properties[i] != NULL; ++i)
3579 for (it = alist; ! NILP (it); it = XCDR (it))
3580 {
3581 Lisp_Object key = XCAR (XCAR (it));
3582 Lisp_Object val = XCDR (XCAR (it));
3583 char *keystr = SSDATA (SYMBOL_NAME (key));
3584
3585 if (strcmp (boolean_properties[i], keystr) == 0)
3586 {
3587 const char *str = INTEGERP (val) ? (XINT (val) ? "true" : "false")
3588 : SYMBOLP (val) ? SSDATA (SYMBOL_NAME (val))
3589 : "true";
3590
3591 if (strcmp ("false", str) == 0 || strcmp ("False", str) == 0
3592 || strcmp ("FALSE", str) == 0 || strcmp ("FcFalse", str) == 0
3593 || strcmp ("off", str) == 0 || strcmp ("OFF", str) == 0
3594 || strcmp ("Off", str) == 0)
3595 val = Qnil;
3596 else
3597 val = Qt;
3598
3599 Ffont_put (font, key, val);
3600 }
3601 }
3602
3603 for (i = 0; non_boolean_properties[i] != NULL; ++i)
3604 for (it = alist; ! NILP (it); it = XCDR (it))
3605 {
3606 Lisp_Object key = XCAR (XCAR (it));
3607 Lisp_Object val = XCDR (XCAR (it));
3608 char *keystr = SSDATA (SYMBOL_NAME (key));
3609 if (strcmp (non_boolean_properties[i], keystr) == 0)
3610 Ffont_put (font, key, val);
3611 }
3612 }
3613
3614
3615 /* Return the font used to draw character C by FACE at buffer position
3616 POS in window W. If STRING is non-nil, it is a string containing C
3617 at index POS. If C is negative, get C from the current buffer or
3618 STRING. */
3619
3620 static Lisp_Object
3621 font_at (int c, ptrdiff_t pos, struct face *face, struct window *w,
3622 Lisp_Object string)
3623 {
3624 FRAME_PTR f;
3625 bool multibyte;
3626 Lisp_Object font_object;
3627
3628 multibyte = (NILP (string)
3629 ? ! NILP (BVAR (current_buffer, enable_multibyte_characters))
3630 : STRING_MULTIBYTE (string));
3631 if (c < 0)
3632 {
3633 if (NILP (string))
3634 {
3635 if (multibyte)
3636 {
3637 ptrdiff_t pos_byte = CHAR_TO_BYTE (pos);
3638
3639 c = FETCH_CHAR (pos_byte);
3640 }
3641 else
3642 c = FETCH_BYTE (pos);
3643 }
3644 else
3645 {
3646 unsigned char *str;
3647
3648 multibyte = STRING_MULTIBYTE (string);
3649 if (multibyte)
3650 {
3651 ptrdiff_t pos_byte = string_char_to_byte (string, pos);
3652
3653 str = SDATA (string) + pos_byte;
3654 c = STRING_CHAR (str);
3655 }
3656 else
3657 c = SDATA (string)[pos];
3658 }
3659 }
3660
3661 f = XFRAME (w->frame);
3662 if (! FRAME_WINDOW_P (f))
3663 return Qnil;
3664 if (! face)
3665 {
3666 int face_id;
3667 ptrdiff_t endptr;
3668
3669 if (STRINGP (string))
3670 face_id = face_at_string_position (w, string, pos, 0, -1, -1, &endptr,
3671 DEFAULT_FACE_ID, 0);
3672 else
3673 face_id = face_at_buffer_position (w, pos, -1, -1, &endptr,
3674 pos + 100, 0, -1);
3675 face = FACE_FROM_ID (f, face_id);
3676 }
3677 if (multibyte)
3678 {
3679 int face_id = FACE_FOR_CHAR (f, face, c, pos, string);
3680 face = FACE_FROM_ID (f, face_id);
3681 }
3682 if (! face->font)
3683 return Qnil;
3684
3685 XSETFONT (font_object, face->font);
3686 return font_object;
3687 }
3688
3689
3690 #ifdef HAVE_WINDOW_SYSTEM
3691
3692 /* Check how many characters after character/byte position POS/POS_BYTE
3693 (at most to *LIMIT) can be displayed by the same font in the window W.
3694 FACE, if non-NULL, is the face selected for the character at POS.
3695 If STRING is not nil, it is the string to check instead of the current
3696 buffer. In that case, FACE must be not NULL.
3697
3698 The return value is the font-object for the character at POS.
3699 *LIMIT is set to the position where that font can't be used.
3700
3701 It is assured that the current buffer (or STRING) is multibyte. */
3702
3703 Lisp_Object
3704 font_range (ptrdiff_t pos, ptrdiff_t pos_byte, ptrdiff_t *limit,
3705 struct window *w, struct face *face, Lisp_Object string)
3706 {
3707 ptrdiff_t ignore;
3708 int c;
3709 Lisp_Object font_object = Qnil;
3710
3711 if (NILP (string))
3712 {
3713 if (! face)
3714 {
3715 int face_id;
3716
3717 face_id = face_at_buffer_position (w, pos, 0, 0, &ignore,
3718 *limit, 0, -1);
3719 face = FACE_FROM_ID (XFRAME (w->frame), face_id);
3720 }
3721 }
3722 else
3723 eassert (face);
3724
3725 while (pos < *limit)
3726 {
3727 Lisp_Object category;
3728
3729 if (NILP (string))
3730 FETCH_CHAR_ADVANCE_NO_CHECK (c, pos, pos_byte);
3731 else
3732 FETCH_STRING_CHAR_ADVANCE_NO_CHECK (c, string, pos, pos_byte);
3733 category = CHAR_TABLE_REF (Vunicode_category_table, c);
3734 if (INTEGERP (category)
3735 && (XINT (category) == UNICODE_CATEGORY_Cf
3736 || CHAR_VARIATION_SELECTOR_P (c)))
3737 continue;
3738 if (NILP (font_object))
3739 {
3740 font_object = font_for_char (face, c, pos - 1, string);
3741 if (NILP (font_object))
3742 return Qnil;
3743 continue;
3744 }
3745 if (font_encode_char (font_object, c) == FONT_INVALID_CODE)
3746 *limit = pos - 1;
3747 }
3748 return font_object;
3749 }
3750 #endif
3751
3752 \f
3753 /* Lisp API. */
3754
3755 DEFUN ("fontp", Ffontp, Sfontp, 1, 2, 0,
3756 doc: /* Return t if OBJECT is a font-spec, font-entity, or font-object.
3757 Return nil otherwise.
3758 Optional 2nd argument EXTRA-TYPE, if non-nil, specifies to check
3759 which kind of font it is. It must be one of `font-spec', `font-entity',
3760 `font-object'. */)
3761 (Lisp_Object object, Lisp_Object extra_type)
3762 {
3763 if (NILP (extra_type))
3764 return (FONTP (object) ? Qt : Qnil);
3765 if (EQ (extra_type, Qfont_spec))
3766 return (FONT_SPEC_P (object) ? Qt : Qnil);
3767 if (EQ (extra_type, Qfont_entity))
3768 return (FONT_ENTITY_P (object) ? Qt : Qnil);
3769 if (EQ (extra_type, Qfont_object))
3770 return (FONT_OBJECT_P (object) ? Qt : Qnil);
3771 wrong_type_argument (intern ("font-extra-type"), extra_type);
3772 }
3773
3774 DEFUN ("font-spec", Ffont_spec, Sfont_spec, 0, MANY, 0,
3775 doc: /* Return a newly created font-spec with arguments as properties.
3776
3777 ARGS must come in pairs KEY VALUE of font properties. KEY must be a
3778 valid font property name listed below:
3779
3780 `:family', `:weight', `:slant', `:width'
3781
3782 They are the same as face attributes of the same name. See
3783 `set-face-attribute'.
3784
3785 `:foundry'
3786
3787 VALUE must be a string or a symbol specifying the font foundry, e.g. ``misc''.
3788
3789 `:adstyle'
3790
3791 VALUE must be a string or a symbol specifying the additional
3792 typographic style information of a font, e.g. ``sans''.
3793
3794 `:registry'
3795
3796 VALUE must be a string or a symbol specifying the charset registry and
3797 encoding of a font, e.g. ``iso8859-1''.
3798
3799 `:size'
3800
3801 VALUE must be a non-negative integer or a floating point number
3802 specifying the font size. It specifies the font size in pixels (if
3803 VALUE is an integer), or in points (if VALUE is a float).
3804
3805 `:name'
3806
3807 VALUE must be a string of XLFD-style or fontconfig-style font name.
3808
3809 `:script'
3810
3811 VALUE must be a symbol representing a script that the font must
3812 support. It may be a symbol representing a subgroup of a script
3813 listed in the variable `script-representative-chars'.
3814
3815 `:lang'
3816
3817 VALUE must be a symbol of two-letter ISO-639 language names,
3818 e.g. `ja'.
3819
3820 `:otf'
3821
3822 VALUE must be a list (SCRIPT-TAG LANGSYS-TAG GSUB [ GPOS ]) to specify
3823 required OpenType features.
3824
3825 SCRIPT-TAG: OpenType script tag symbol (e.g. `deva').
3826 LANGSYS-TAG: OpenType language system tag symbol,
3827 or nil for the default language system.
3828 GSUB: List of OpenType GSUB feature tag symbols, or nil if none required.
3829 GPOS: List of OpenType GPOS feature tag symbols, or nil if none required.
3830
3831 GSUB and GPOS may contain `nil' element. In such a case, the font
3832 must not have any of the remaining elements.
3833
3834 For instance, if the VALUE is `(thai nil nil (mark))', the font must
3835 be an OpenType font whose GPOS table of `thai' script's default
3836 language system must contain `mark' feature.
3837
3838 usage: (font-spec ARGS...) */)
3839 (ptrdiff_t nargs, Lisp_Object *args)
3840 {
3841 Lisp_Object spec = font_make_spec ();
3842 ptrdiff_t i;
3843
3844 for (i = 0; i < nargs; i += 2)
3845 {
3846 Lisp_Object key = args[i], val;
3847
3848 CHECK_SYMBOL (key);
3849 if (i + 1 >= nargs)
3850 error ("No value for key `%s'", SDATA (SYMBOL_NAME (key)));
3851 val = args[i + 1];
3852
3853 if (EQ (key, QCname))
3854 {
3855 CHECK_STRING (val);
3856 font_parse_name (SSDATA (val), SBYTES (val), spec);
3857 font_put_extra (spec, key, val);
3858 }
3859 else
3860 {
3861 int idx = get_font_prop_index (key);
3862
3863 if (idx >= 0)
3864 {
3865 val = font_prop_validate (idx, Qnil, val);
3866 if (idx < FONT_EXTRA_INDEX)
3867 ASET (spec, idx, val);
3868 else
3869 font_put_extra (spec, key, val);
3870 }
3871 else
3872 font_put_extra (spec, key, font_prop_validate (0, key, val));
3873 }
3874 }
3875 return spec;
3876 }
3877
3878 /* Return a copy of FONT as a font-spec. */
3879 Lisp_Object
3880 copy_font_spec (Lisp_Object font)
3881 {
3882 Lisp_Object new_spec, tail, prev, extra;
3883 int i;
3884
3885 CHECK_FONT (font);
3886 new_spec = font_make_spec ();
3887 for (i = 1; i < FONT_EXTRA_INDEX; i++)
3888 ASET (new_spec, i, AREF (font, i));
3889 extra = Fcopy_alist (AREF (font, FONT_EXTRA_INDEX));
3890 /* We must remove :font-entity property. */
3891 for (prev = Qnil, tail = extra; CONSP (tail); prev = tail, tail = XCDR (tail))
3892 if (EQ (XCAR (XCAR (tail)), QCfont_entity))
3893 {
3894 if (NILP (prev))
3895 extra = XCDR (extra);
3896 else
3897 XSETCDR (prev, XCDR (tail));
3898 break;
3899 }
3900 ASET (new_spec, FONT_EXTRA_INDEX, extra);
3901 return new_spec;
3902 }
3903
3904 /* Merge font-specs FROM and TO, and return a new font-spec.
3905 Every specified property in FROM overrides the corresponding
3906 property in TO. */
3907 Lisp_Object
3908 merge_font_spec (Lisp_Object from, Lisp_Object to)
3909 {
3910 Lisp_Object extra, tail;
3911 int i;
3912
3913 CHECK_FONT (from);
3914 CHECK_FONT (to);
3915 to = copy_font_spec (to);
3916 for (i = 0; i < FONT_EXTRA_INDEX; i++)
3917 ASET (to, i, AREF (from, i));
3918 extra = AREF (to, FONT_EXTRA_INDEX);
3919 for (tail = AREF (from, FONT_EXTRA_INDEX); CONSP (tail); tail = XCDR (tail))
3920 if (! EQ (XCAR (XCAR (tail)), Qfont_entity))
3921 {
3922 Lisp_Object slot = assq_no_quit (XCAR (XCAR (tail)), extra);
3923
3924 if (! NILP (slot))
3925 XSETCDR (slot, XCDR (XCAR (tail)));
3926 else
3927 extra = Fcons (Fcons (XCAR (XCAR (tail)), XCDR (XCAR (tail))), extra);
3928 }
3929 ASET (to, FONT_EXTRA_INDEX, extra);
3930 return to;
3931 }
3932
3933 DEFUN ("font-get", Ffont_get, Sfont_get, 2, 2, 0,
3934 doc: /* Return the value of FONT's property KEY.
3935 FONT is a font-spec, a font-entity, or a font-object.
3936 KEY is any symbol, but these are reserved for specific meanings:
3937 :family, :weight, :slant, :width, :foundry, :adstyle, :registry,
3938 :size, :name, :script, :otf
3939 See the documentation of `font-spec' for their meanings.
3940 In addition, if FONT is a font-entity or a font-object, values of
3941 :script and :otf are different from those of a font-spec as below:
3942
3943 The value of :script may be a list of scripts that are supported by the font.
3944
3945 The value of :otf is a cons (GSUB . GPOS) where GSUB and GPOS are lists
3946 representing the OpenType features supported by the font by this form:
3947 ((SCRIPT (LANGSYS FEATURE ...) ...) ...)
3948 SCRIPT, LANGSYS, and FEATURE are all symbols representing OpenType
3949 Layout tags. */)
3950 (Lisp_Object font, Lisp_Object key)
3951 {
3952 int idx;
3953 Lisp_Object val;
3954
3955 CHECK_FONT (font);
3956 CHECK_SYMBOL (key);
3957
3958 idx = get_font_prop_index (key);
3959 if (idx >= FONT_WEIGHT_INDEX && idx <= FONT_WIDTH_INDEX)
3960 return font_style_symbolic (font, idx, 0);
3961 if (idx >= 0 && idx < FONT_EXTRA_INDEX)
3962 return AREF (font, idx);
3963 val = Fassq (key, AREF (font, FONT_EXTRA_INDEX));
3964 if (NILP (val) && EQ (key, QCotf) && FONT_OBJECT_P (font))
3965 {
3966 struct font *fontp = XFONT_OBJECT (font);
3967
3968 if (fontp->driver->otf_capability)
3969 val = fontp->driver->otf_capability (fontp);
3970 else
3971 val = Fcons (Qnil, Qnil);
3972 }
3973 else
3974 val = Fcdr (val);
3975 return val;
3976 }
3977
3978 #ifdef HAVE_WINDOW_SYSTEM
3979
3980 DEFUN ("font-face-attributes", Ffont_face_attributes, Sfont_face_attributes, 1, 2, 0,
3981 doc: /* Return a plist of face attributes generated by FONT.
3982 FONT is a font name, a font-spec, a font-entity, or a font-object.
3983 The return value is a list of the form
3984
3985 \(:family FAMILY :height HEIGHT :weight WEIGHT :slant SLANT :width WIDTH)
3986
3987 where FAMILY, HEIGHT, WEIGHT, SLANT, and WIDTH are face attribute values
3988 compatible with `set-face-attribute'. Some of these key-attribute pairs
3989 may be omitted from the list if they are not specified by FONT.
3990
3991 The optional argument FRAME specifies the frame that the face attributes
3992 are to be displayed on. If omitted, the selected frame is used. */)
3993 (Lisp_Object font, Lisp_Object frame)
3994 {
3995 struct frame *f = decode_live_frame (frame);
3996 Lisp_Object plist[10];
3997 Lisp_Object val;
3998 int n = 0;
3999
4000 if (STRINGP (font))
4001 {
4002 int fontset = fs_query_fontset (font, 0);
4003 Lisp_Object name = font;
4004 if (fontset >= 0)
4005 font = fontset_ascii (fontset);
4006 font = font_spec_from_name (name);
4007 if (! FONTP (font))
4008 signal_error ("Invalid font name", name);
4009 }
4010 else if (! FONTP (font))
4011 signal_error ("Invalid font object", font);
4012
4013 val = AREF (font, FONT_FAMILY_INDEX);
4014 if (! NILP (val))
4015 {
4016 plist[n++] = QCfamily;
4017 plist[n++] = SYMBOL_NAME (val);
4018 }
4019
4020 val = AREF (font, FONT_SIZE_INDEX);
4021 if (INTEGERP (val))
4022 {
4023 Lisp_Object font_dpi = AREF (font, FONT_DPI_INDEX);
4024 int dpi = INTEGERP (font_dpi) ? XINT (font_dpi) : f->resy;
4025 plist[n++] = QCheight;
4026 plist[n++] = make_number (PIXEL_TO_POINT (XINT (val) * 10, dpi));
4027 }
4028 else if (FLOATP (val))
4029 {
4030 plist[n++] = QCheight;
4031 plist[n++] = make_number (10 * (int) XFLOAT_DATA (val));
4032 }
4033
4034 val = FONT_WEIGHT_FOR_FACE (font);
4035 if (! NILP (val))
4036 {
4037 plist[n++] = QCweight;
4038 plist[n++] = val;
4039 }
4040
4041 val = FONT_SLANT_FOR_FACE (font);
4042 if (! NILP (val))
4043 {
4044 plist[n++] = QCslant;
4045 plist[n++] = val;
4046 }
4047
4048 val = FONT_WIDTH_FOR_FACE (font);
4049 if (! NILP (val))
4050 {
4051 plist[n++] = QCwidth;
4052 plist[n++] = val;
4053 }
4054
4055 return Flist (n, plist);
4056 }
4057
4058 #endif
4059
4060 DEFUN ("font-put", Ffont_put, Sfont_put, 3, 3, 0,
4061 doc: /* Set one property of FONT: give property KEY value VAL.
4062 FONT is a font-spec, a font-entity, or a font-object.
4063
4064 If FONT is a font-spec, KEY can be any symbol. But if KEY is the one
4065 accepted by the function `font-spec' (which see), VAL must be what
4066 allowed in `font-spec'.
4067
4068 If FONT is a font-entity or a font-object, KEY must not be the one
4069 accepted by `font-spec'. */)
4070 (Lisp_Object font, Lisp_Object prop, Lisp_Object val)
4071 {
4072 int idx;
4073
4074 idx = get_font_prop_index (prop);
4075 if (idx >= 0 && idx < FONT_EXTRA_INDEX)
4076 {
4077 CHECK_FONT_SPEC (font);
4078 ASET (font, idx, font_prop_validate (idx, Qnil, val));
4079 }
4080 else
4081 {
4082 if (EQ (prop, QCname)
4083 || EQ (prop, QCscript)
4084 || EQ (prop, QClang)
4085 || EQ (prop, QCotf))
4086 CHECK_FONT_SPEC (font);
4087 else
4088 CHECK_FONT (font);
4089 font_put_extra (font, prop, font_prop_validate (0, prop, val));
4090 }
4091 return val;
4092 }
4093
4094 DEFUN ("list-fonts", Flist_fonts, Slist_fonts, 1, 4, 0,
4095 doc: /* List available fonts matching FONT-SPEC on the current frame.
4096 Optional 2nd argument FRAME specifies the target frame.
4097 Optional 3rd argument NUM, if non-nil, limits the number of returned fonts.
4098 Optional 4th argument PREFER, if non-nil, is a font-spec to
4099 control the order of the returned list. Fonts are sorted by
4100 how close they are to PREFER. */)
4101 (Lisp_Object font_spec, Lisp_Object frame, Lisp_Object num, Lisp_Object prefer)
4102 {
4103 Lisp_Object vec, list;
4104 EMACS_INT n = 0;
4105
4106 if (NILP (frame))
4107 frame = selected_frame;
4108 CHECK_LIVE_FRAME (frame);
4109 CHECK_FONT_SPEC (font_spec);
4110 if (! NILP (num))
4111 {
4112 CHECK_NUMBER (num);
4113 n = XINT (num);
4114 if (n <= 0)
4115 return Qnil;
4116 }
4117 if (! NILP (prefer))
4118 CHECK_FONT_SPEC (prefer);
4119
4120 list = font_list_entities (frame, font_spec);
4121 if (NILP (list))
4122 return Qnil;
4123 if (NILP (XCDR (list))
4124 && ASIZE (XCAR (list)) == 1)
4125 return Fcons (AREF (XCAR (list), 0), Qnil);
4126
4127 if (! NILP (prefer))
4128 vec = font_sort_entities (list, prefer, frame, 0);
4129 else
4130 vec = font_vconcat_entity_vectors (list);
4131 if (n == 0 || n >= ASIZE (vec))
4132 {
4133 Lisp_Object args[2];
4134
4135 args[0] = vec;
4136 args[1] = Qnil;
4137 list = Fappend (2, args);
4138 }
4139 else
4140 {
4141 for (list = Qnil, n--; n >= 0; n--)
4142 list = Fcons (AREF (vec, n), list);
4143 }
4144 return list;
4145 }
4146
4147 DEFUN ("font-family-list", Ffont_family_list, Sfont_family_list, 0, 1, 0,
4148 doc: /* List available font families on the current frame.
4149 If FRAME is omitted or nil, the selected frame is used. */)
4150 (Lisp_Object frame)
4151 {
4152 struct frame *f = decode_live_frame (frame);
4153 struct font_driver_list *driver_list;
4154 Lisp_Object list = Qnil;
4155
4156 XSETFRAME (frame, f);
4157
4158 for (driver_list = f->font_driver_list; driver_list;
4159 driver_list = driver_list->next)
4160 if (driver_list->driver->list_family)
4161 {
4162 Lisp_Object val = driver_list->driver->list_family (frame);
4163 Lisp_Object tail = list;
4164
4165 for (; CONSP (val); val = XCDR (val))
4166 if (NILP (Fmemq (XCAR (val), tail))
4167 && SYMBOLP (XCAR (val)))
4168 list = Fcons (SYMBOL_NAME (XCAR (val)), list);
4169 }
4170 return list;
4171 }
4172
4173 DEFUN ("find-font", Ffind_font, Sfind_font, 1, 2, 0,
4174 doc: /* Return a font-entity matching with FONT-SPEC on the current frame.
4175 Optional 2nd argument FRAME, if non-nil, specifies the target frame. */)
4176 (Lisp_Object font_spec, Lisp_Object frame)
4177 {
4178 Lisp_Object val = Flist_fonts (font_spec, frame, make_number (1), Qnil);
4179
4180 if (CONSP (val))
4181 val = XCAR (val);
4182 return val;
4183 }
4184
4185 DEFUN ("font-xlfd-name", Ffont_xlfd_name, Sfont_xlfd_name, 1, 2, 0,
4186 doc: /* Return XLFD name of FONT.
4187 FONT is a font-spec, font-entity, or font-object.
4188 If the name is too long for XLFD (maximum 255 chars), return nil.
4189 If the 2nd optional arg FOLD-WILDCARDS is non-nil,
4190 the consecutive wildcards are folded into one. */)
4191 (Lisp_Object font, Lisp_Object fold_wildcards)
4192 {
4193 char name[256];
4194 int namelen, pixel_size = 0;
4195
4196 CHECK_FONT (font);
4197
4198 if (FONT_OBJECT_P (font))
4199 {
4200 Lisp_Object font_name = AREF (font, FONT_NAME_INDEX);
4201
4202 if (STRINGP (font_name)
4203 && SDATA (font_name)[0] == '-')
4204 {
4205 if (NILP (fold_wildcards))
4206 return font_name;
4207 strcpy (name, SSDATA (font_name));
4208 namelen = SBYTES (font_name);
4209 goto done;
4210 }
4211 pixel_size = XFONT_OBJECT (font)->pixel_size;
4212 }
4213 namelen = font_unparse_xlfd (font, pixel_size, name, 256);
4214 if (namelen < 0)
4215 return Qnil;
4216 done:
4217 if (! NILP (fold_wildcards))
4218 {
4219 char *p0 = name, *p1;
4220
4221 while ((p1 = strstr (p0, "-*-*")))
4222 {
4223 strcpy (p1, p1 + 2);
4224 namelen -= 2;
4225 p0 = p1;
4226 }
4227 }
4228
4229 return make_string (name, namelen);
4230 }
4231
4232 DEFUN ("clear-font-cache", Fclear_font_cache, Sclear_font_cache, 0, 0, 0,
4233 doc: /* Clear font cache. */)
4234 (void)
4235 {
4236 Lisp_Object list, frame;
4237
4238 FOR_EACH_FRAME (list, frame)
4239 {
4240 FRAME_PTR f = XFRAME (frame);
4241 struct font_driver_list *driver_list = f->font_driver_list;
4242
4243 for (; driver_list; driver_list = driver_list->next)
4244 if (driver_list->on)
4245 {
4246 Lisp_Object cache = driver_list->driver->get_cache (f);
4247 Lisp_Object val, tmp;
4248
4249 val = XCDR (cache);
4250 while (! NILP (val)
4251 && ! EQ (XCAR (XCAR (val)), driver_list->driver->type))
4252 val = XCDR (val);
4253 eassert (! NILP (val));
4254 tmp = XCDR (XCAR (val));
4255 if (XINT (XCAR (tmp)) == 0)
4256 {
4257 font_clear_cache (f, XCAR (val), driver_list->driver);
4258 XSETCDR (cache, XCDR (val));
4259 }
4260 }
4261 }
4262
4263 return Qnil;
4264 }
4265
4266 \f
4267 void
4268 font_fill_lglyph_metrics (Lisp_Object glyph, Lisp_Object font_object)
4269 {
4270 struct font *font = XFONT_OBJECT (font_object);
4271 unsigned code = font->driver->encode_char (font, LGLYPH_CHAR (glyph));
4272 struct font_metrics metrics;
4273
4274 LGLYPH_SET_CODE (glyph, code);
4275 font->driver->text_extents (font, &code, 1, &metrics);
4276 LGLYPH_SET_LBEARING (glyph, metrics.lbearing);
4277 LGLYPH_SET_RBEARING (glyph, metrics.rbearing);
4278 LGLYPH_SET_WIDTH (glyph, metrics.width);
4279 LGLYPH_SET_ASCENT (glyph, metrics.ascent);
4280 LGLYPH_SET_DESCENT (glyph, metrics.descent);
4281 }
4282
4283
4284 DEFUN ("font-shape-gstring", Ffont_shape_gstring, Sfont_shape_gstring, 1, 1, 0,
4285 doc: /* Shape the glyph-string GSTRING.
4286 Shaping means substituting glyphs and/or adjusting positions of glyphs
4287 to get the correct visual image of character sequences set in the
4288 header of the glyph-string.
4289
4290 If the shaping was successful, the value is GSTRING itself or a newly
4291 created glyph-string. Otherwise, the value is nil.
4292
4293 See the documentation of `composition-get-gstring' for the format of
4294 GSTRING. */)
4295 (Lisp_Object gstring)
4296 {
4297 struct font *font;
4298 Lisp_Object font_object, n, glyph;
4299 ptrdiff_t i, from, to;
4300
4301 if (! composition_gstring_p (gstring))
4302 signal_error ("Invalid glyph-string: ", gstring);
4303 if (! NILP (LGSTRING_ID (gstring)))
4304 return gstring;
4305 font_object = LGSTRING_FONT (gstring);
4306 CHECK_FONT_OBJECT (font_object);
4307 font = XFONT_OBJECT (font_object);
4308 if (! font->driver->shape)
4309 return Qnil;
4310
4311 /* Try at most three times with larger gstring each time. */
4312 for (i = 0; i < 3; i++)
4313 {
4314 n = font->driver->shape (gstring);
4315 if (INTEGERP (n))
4316 break;
4317 gstring = larger_vector (gstring,
4318 LGSTRING_GLYPH_LEN (gstring), -1);
4319 }
4320 if (i == 3 || XINT (n) == 0)
4321 return Qnil;
4322 if (XINT (n) < LGSTRING_GLYPH_LEN (gstring))
4323 LGSTRING_SET_GLYPH (gstring, XINT (n), Qnil);
4324
4325 /* Check FROM_IDX and TO_IDX of each GLYPH in GSTRING to assure that
4326 GLYPHS covers all characters (except for the last few ones) in
4327 GSTRING. More formally, provided that NCHARS is the number of
4328 characters in GSTRING and GLYPHS[i] is the ith glyph, FROM_IDX
4329 and TO_IDX of each glyph must satisfy these conditions:
4330
4331 GLYPHS[0].FROM_IDX == 0
4332 GLYPHS[i].FROM_IDX <= GLYPHS[i].TO_IDX
4333 if (GLYPHS[i].FROM_IDX == GLYPHS[i-1].FROM_IDX)
4334 ;; GLYPHS[i] and GLYPHS[i-1] belongs to the same grapheme cluster
4335 GLYPHS[i].TO_IDX == GLYPHS[i-1].TO_IDX
4336 else
4337 ;; Be sure to cover all characters.
4338 GLYPHS[i].FROM_IDX == GLYPHS[i-1].TO_IDX + 1 */
4339 glyph = LGSTRING_GLYPH (gstring, 0);
4340 from = LGLYPH_FROM (glyph);
4341 to = LGLYPH_TO (glyph);
4342 if (from != 0 || to < from)
4343 goto shaper_error;
4344 for (i = 1; i < LGSTRING_GLYPH_LEN (gstring); i++)
4345 {
4346 glyph = LGSTRING_GLYPH (gstring, i);
4347 if (NILP (glyph))
4348 break;
4349 if (! (LGLYPH_FROM (glyph) <= LGLYPH_TO (glyph)
4350 && (LGLYPH_FROM (glyph) == from
4351 ? LGLYPH_TO (glyph) == to
4352 : LGLYPH_FROM (glyph) == to + 1)))
4353 goto shaper_error;
4354 from = LGLYPH_FROM (glyph);
4355 to = LGLYPH_TO (glyph);
4356 }
4357 return composition_gstring_put_cache (gstring, XINT (n));
4358
4359 shaper_error:
4360 return Qnil;
4361 }
4362
4363 DEFUN ("font-variation-glyphs", Ffont_variation_glyphs, Sfont_variation_glyphs,
4364 2, 2, 0,
4365 doc: /* Return a list of variation glyphs for CHAR in FONT-OBJECT.
4366 Each element of the value is a cons (VARIATION-SELECTOR . GLYPH-ID),
4367 where
4368 VARIATION-SELECTOR is a character code of variation selection
4369 (#xFE00..#xFE0F or #xE0100..#xE01EF)
4370 GLYPH-ID is a glyph code of the corresponding variation glyph. */)
4371 (Lisp_Object font_object, Lisp_Object character)
4372 {
4373 unsigned variations[256];
4374 struct font *font;
4375 int i, n;
4376 Lisp_Object val;
4377
4378 CHECK_FONT_OBJECT (font_object);
4379 CHECK_CHARACTER (character);
4380 font = XFONT_OBJECT (font_object);
4381 if (! font->driver->get_variation_glyphs)
4382 return Qnil;
4383 n = font->driver->get_variation_glyphs (font, XINT (character), variations);
4384 if (! n)
4385 return Qnil;
4386 val = Qnil;
4387 for (i = 0; i < 255; i++)
4388 if (variations[i])
4389 {
4390 int vs = (i < 16 ? 0xFE00 + i : 0xE0100 + (i - 16));
4391 Lisp_Object code = INTEGER_TO_CONS (variations[i]);
4392 val = Fcons (Fcons (make_number (vs), code), val);
4393 }
4394 return val;
4395 }
4396
4397 #if 0
4398
4399 DEFUN ("font-drive-otf", Ffont_drive_otf, Sfont_drive_otf, 6, 6, 0,
4400 doc: /* Apply OpenType features on glyph-string GSTRING-IN.
4401 OTF-FEATURES specifies which features to apply in this format:
4402 (SCRIPT LANGSYS GSUB GPOS)
4403 where
4404 SCRIPT is a symbol specifying a script tag of OpenType,
4405 LANGSYS is a symbol specifying a langsys tag of OpenType,
4406 GSUB and GPOS, if non-nil, are lists of symbols specifying feature tags.
4407
4408 If LANGYS is nil, the default langsys is selected.
4409
4410 The features are applied in the order they appear in the list. The
4411 symbol `*' means to apply all available features not present in this
4412 list, and the remaining features are ignored. For instance, (vatu
4413 pstf * haln) is to apply vatu and pstf in this order, then to apply
4414 all available features other than vatu, pstf, and haln.
4415
4416 The features are applied to the glyphs in the range FROM and TO of
4417 the glyph-string GSTRING-IN.
4418
4419 If some feature is actually applicable, the resulting glyphs are
4420 produced in the glyph-string GSTRING-OUT from the index INDEX. In
4421 this case, the value is the number of produced glyphs.
4422
4423 If no feature is applicable, no glyph is produced in GSTRING-OUT, and
4424 the value is 0.
4425
4426 If GSTRING-OUT is too short to hold produced glyphs, no glyphs are
4427 produced in GSTRING-OUT, and the value is nil.
4428
4429 See the documentation of `composition-get-gstring' for the format of
4430 glyph-string. */)
4431 (Lisp_Object otf_features, Lisp_Object gstring_in, Lisp_Object from, Lisp_Object to, Lisp_Object gstring_out, Lisp_Object index)
4432 {
4433 Lisp_Object font_object = LGSTRING_FONT (gstring_in);
4434 Lisp_Object val;
4435 struct font *font;
4436 int len, num;
4437
4438 check_otf_features (otf_features);
4439 CHECK_FONT_OBJECT (font_object);
4440 font = XFONT_OBJECT (font_object);
4441 if (! font->driver->otf_drive)
4442 error ("Font backend %s can't drive OpenType GSUB table",
4443 SDATA (SYMBOL_NAME (font->driver->type)));
4444 CHECK_CONS (otf_features);
4445 CHECK_SYMBOL (XCAR (otf_features));
4446 val = XCDR (otf_features);
4447 CHECK_SYMBOL (XCAR (val));
4448 val = XCDR (otf_features);
4449 if (! NILP (val))
4450 CHECK_CONS (val);
4451 len = check_gstring (gstring_in);
4452 CHECK_VECTOR (gstring_out);
4453 CHECK_NATNUM (from);
4454 CHECK_NATNUM (to);
4455 CHECK_NATNUM (index);
4456
4457 if (XINT (from) >= XINT (to) || XINT (to) > len)
4458 args_out_of_range_3 (from, to, make_number (len));
4459 if (XINT (index) >= ASIZE (gstring_out))
4460 args_out_of_range (index, make_number (ASIZE (gstring_out)));
4461 num = font->driver->otf_drive (font, otf_features,
4462 gstring_in, XINT (from), XINT (to),
4463 gstring_out, XINT (index), 0);
4464 if (num < 0)
4465 return Qnil;
4466 return make_number (num);
4467 }
4468
4469 DEFUN ("font-otf-alternates", Ffont_otf_alternates, Sfont_otf_alternates,
4470 3, 3, 0,
4471 doc: /* Return a list of alternate glyphs of CHARACTER in FONT-OBJECT.
4472 OTF-FEATURES specifies which features of the font FONT-OBJECT to apply
4473 in this format:
4474 (SCRIPT LANGSYS FEATURE ...)
4475 See the documentation of `font-drive-otf' for more detail.
4476
4477 The value is a list of cons cells of the format (GLYPH-ID . CHARACTER),
4478 where GLYPH-ID is a glyph index of the font, and CHARACTER is a
4479 character code corresponding to the glyph or nil if there's no
4480 corresponding character. */)
4481 (Lisp_Object font_object, Lisp_Object character, Lisp_Object otf_features)
4482 {
4483 struct font *font;
4484 Lisp_Object gstring_in, gstring_out, g;
4485 Lisp_Object alternates;
4486 int i, num;
4487
4488 CHECK_FONT_GET_OBJECT (font_object, font);
4489 if (! font->driver->otf_drive)
4490 error ("Font backend %s can't drive OpenType GSUB table",
4491 SDATA (SYMBOL_NAME (font->driver->type)));
4492 CHECK_CHARACTER (character);
4493 CHECK_CONS (otf_features);
4494
4495 gstring_in = Ffont_make_gstring (font_object, make_number (1));
4496 g = LGSTRING_GLYPH (gstring_in, 0);
4497 LGLYPH_SET_CHAR (g, XINT (character));
4498 gstring_out = Ffont_make_gstring (font_object, make_number (10));
4499 while ((num = font->driver->otf_drive (font, otf_features, gstring_in, 0, 1,
4500 gstring_out, 0, 1)) < 0)
4501 gstring_out = Ffont_make_gstring (font_object,
4502 make_number (ASIZE (gstring_out) * 2));
4503 alternates = Qnil;
4504 for (i = 0; i < num; i++)
4505 {
4506 Lisp_Object g = LGSTRING_GLYPH (gstring_out, i);
4507 int c = LGLYPH_CHAR (g);
4508 unsigned code = LGLYPH_CODE (g);
4509
4510 alternates = Fcons (Fcons (make_number (code),
4511 c > 0 ? make_number (c) : Qnil),
4512 alternates);
4513 }
4514 return Fnreverse (alternates);
4515 }
4516 #endif /* 0 */
4517
4518 #ifdef FONT_DEBUG
4519
4520 DEFUN ("open-font", Fopen_font, Sopen_font, 1, 3, 0,
4521 doc: /* Open FONT-ENTITY. */)
4522 (Lisp_Object font_entity, Lisp_Object size, Lisp_Object frame)
4523 {
4524 EMACS_INT isize;
4525 struct frame *f = decode_live_frame (frame);
4526
4527 CHECK_FONT_ENTITY (font_entity);
4528
4529 if (NILP (size))
4530 isize = XINT (AREF (font_entity, FONT_SIZE_INDEX));
4531 else
4532 {
4533 CHECK_NUMBER_OR_FLOAT (size);
4534 if (FLOATP (size))
4535 isize = POINT_TO_PIXEL (XFLOAT_DATA (size), f->resy);
4536 else
4537 isize = XINT (size);
4538 if (! (INT_MIN <= isize && isize <= INT_MAX))
4539 args_out_of_range (font_entity, size);
4540 if (isize == 0)
4541 isize = 120;
4542 }
4543 return font_open_entity (f, font_entity, isize);
4544 }
4545
4546 DEFUN ("close-font", Fclose_font, Sclose_font, 1, 2, 0,
4547 doc: /* Close FONT-OBJECT. */)
4548 (Lisp_Object font_object, Lisp_Object frame)
4549 {
4550 CHECK_FONT_OBJECT (font_object);
4551 font_close_object (decode_live_frame (frame), font_object);
4552 return Qnil;
4553 }
4554
4555 DEFUN ("query-font", Fquery_font, Squery_font, 1, 1, 0,
4556 doc: /* Return information about FONT-OBJECT.
4557 The value is a vector:
4558 [ NAME FILENAME PIXEL-SIZE SIZE ASCENT DESCENT SPACE-WIDTH AVERAGE-WIDTH
4559 CAPABILITY ]
4560
4561 NAME is the font name, a string (or nil if the font backend doesn't
4562 provide a name).
4563
4564 FILENAME is the font file name, a string (or nil if the font backend
4565 doesn't provide a file name).
4566
4567 PIXEL-SIZE is a pixel size by which the font is opened.
4568
4569 SIZE is a maximum advance width of the font in pixels.
4570
4571 ASCENT, DESCENT, SPACE-WIDTH, AVERAGE-WIDTH are metrics of the font in
4572 pixels.
4573
4574 CAPABILITY is a list whose first element is a symbol representing the
4575 font format \(x, opentype, truetype, type1, pcf, or bdf) and the
4576 remaining elements describe the details of the font capability.
4577
4578 If the font is OpenType font, the form of the list is
4579 \(opentype GSUB GPOS)
4580 where GSUB shows which "GSUB" features the font supports, and GPOS
4581 shows which "GPOS" features the font supports. Both GSUB and GPOS are
4582 lists of the format:
4583 \((SCRIPT (LANGSYS FEATURE ...) ...) ...)
4584
4585 If the font is not OpenType font, currently the length of the form is
4586 one.
4587
4588 SCRIPT is a symbol representing OpenType script tag.
4589
4590 LANGSYS is a symbol representing OpenType langsys tag, or nil
4591 representing the default langsys.
4592
4593 FEATURE is a symbol representing OpenType feature tag.
4594
4595 If the font is not OpenType font, CAPABILITY is nil. */)
4596 (Lisp_Object font_object)
4597 {
4598 struct font *font;
4599 Lisp_Object val;
4600
4601 CHECK_FONT_GET_OBJECT (font_object, font);
4602
4603 val = make_uninit_vector (9);
4604 ASET (val, 0, AREF (font_object, FONT_NAME_INDEX));
4605 ASET (val, 1, AREF (font_object, FONT_FILE_INDEX));
4606 ASET (val, 2, make_number (font->pixel_size));
4607 ASET (val, 3, make_number (font->max_width));
4608 ASET (val, 4, make_number (font->ascent));
4609 ASET (val, 5, make_number (font->descent));
4610 ASET (val, 6, make_number (font->space_width));
4611 ASET (val, 7, make_number (font->average_width));
4612 if (font->driver->otf_capability)
4613 ASET (val, 8, Fcons (Qopentype, font->driver->otf_capability (font)));
4614 else
4615 ASET (val, 8, Qnil);
4616 return val;
4617 }
4618
4619 DEFUN ("font-get-glyphs", Ffont_get_glyphs, Sfont_get_glyphs, 3, 4, 0,
4620 doc:
4621 /* Return a vector of FONT-OBJECT's glyphs for the specified characters.
4622 FROM and TO are positions (integers or markers) specifying a region
4623 of the current buffer.
4624 If the optional fourth arg OBJECT is not nil, it is a string or a
4625 vector containing the target characters.
4626
4627 Each element is a vector containing information of a glyph in this format:
4628 [FROM-IDX TO-IDX C CODE WIDTH LBEARING RBEARING ASCENT DESCENT ADJUSTMENT]
4629 where
4630 FROM is an index numbers of a character the glyph corresponds to.
4631 TO is the same as FROM.
4632 C is the character of the glyph.
4633 CODE is the glyph-code of C in FONT-OBJECT.
4634 WIDTH thru DESCENT are the metrics (in pixels) of the glyph.
4635 ADJUSTMENT is always nil.
4636 If FONT-OBJECT doesn't have a glyph for a character,
4637 the corresponding element is nil. */)
4638 (Lisp_Object font_object, Lisp_Object from, Lisp_Object to,
4639 Lisp_Object object)
4640 {
4641 struct font *font;
4642 ptrdiff_t i, len;
4643 Lisp_Object *chars, vec;
4644 USE_SAFE_ALLOCA;
4645
4646 CHECK_FONT_GET_OBJECT (font_object, font);
4647 if (NILP (object))
4648 {
4649 ptrdiff_t charpos, bytepos;
4650
4651 validate_region (&from, &to);
4652 if (EQ (from, to))
4653 return Qnil;
4654 len = XFASTINT (to) - XFASTINT (from);
4655 SAFE_ALLOCA_LISP (chars, len);
4656 charpos = XFASTINT (from);
4657 bytepos = CHAR_TO_BYTE (charpos);
4658 for (i = 0; charpos < XFASTINT (to); i++)
4659 {
4660 int c;
4661 FETCH_CHAR_ADVANCE (c, charpos, bytepos);
4662 chars[i] = make_number (c);
4663 }
4664 }
4665 else if (STRINGP (object))
4666 {
4667 const unsigned char *p;
4668
4669 CHECK_NUMBER (from);
4670 CHECK_NUMBER (to);
4671 if (XINT (from) < 0 || XINT (from) > XINT (to)
4672 || XINT (to) > SCHARS (object))
4673 args_out_of_range_3 (object, from, to);
4674 if (EQ (from, to))
4675 return Qnil;
4676 len = XFASTINT (to) - XFASTINT (from);
4677 SAFE_ALLOCA_LISP (chars, len);
4678 p = SDATA (object);
4679 if (STRING_MULTIBYTE (object))
4680 for (i = 0; i < len; i++)
4681 {
4682 int c = STRING_CHAR_ADVANCE (p);
4683 chars[i] = make_number (c);
4684 }
4685 else
4686 for (i = 0; i < len; i++)
4687 chars[i] = make_number (p[i]);
4688 }
4689 else
4690 {
4691 CHECK_VECTOR (object);
4692 CHECK_NUMBER (from);
4693 CHECK_NUMBER (to);
4694 if (XINT (from) < 0 || XINT (from) > XINT (to)
4695 || XINT (to) > ASIZE (object))
4696 args_out_of_range_3 (object, from, to);
4697 if (EQ (from, to))
4698 return Qnil;
4699 len = XFASTINT (to) - XFASTINT (from);
4700 for (i = 0; i < len; i++)
4701 {
4702 Lisp_Object elt = AREF (object, XFASTINT (from) + i);
4703 CHECK_CHARACTER (elt);
4704 }
4705 chars = aref_addr (object, XFASTINT (from));
4706 }
4707
4708 vec = Fmake_vector (make_number (len), Qnil);
4709 for (i = 0; i < len; i++)
4710 {
4711 Lisp_Object g;
4712 int c = XFASTINT (chars[i]);
4713 unsigned code;
4714 struct font_metrics metrics;
4715
4716 code = font->driver->encode_char (font, c);
4717 if (code == FONT_INVALID_CODE)
4718 continue;
4719 g = Fmake_vector (make_number (LGLYPH_SIZE), Qnil);
4720 LGLYPH_SET_FROM (g, i);
4721 LGLYPH_SET_TO (g, i);
4722 LGLYPH_SET_CHAR (g, c);
4723 LGLYPH_SET_CODE (g, code);
4724 font->driver->text_extents (font, &code, 1, &metrics);
4725 LGLYPH_SET_WIDTH (g, metrics.width);
4726 LGLYPH_SET_LBEARING (g, metrics.lbearing);
4727 LGLYPH_SET_RBEARING (g, metrics.rbearing);
4728 LGLYPH_SET_ASCENT (g, metrics.ascent);
4729 LGLYPH_SET_DESCENT (g, metrics.descent);
4730 ASET (vec, i, g);
4731 }
4732 if (! VECTORP (object))
4733 SAFE_FREE ();
4734 return vec;
4735 }
4736
4737 DEFUN ("font-match-p", Ffont_match_p, Sfont_match_p, 2, 2, 0,
4738 doc: /* Return t if and only if font-spec SPEC matches with FONT.
4739 FONT is a font-spec, font-entity, or font-object. */)
4740 (Lisp_Object spec, Lisp_Object font)
4741 {
4742 CHECK_FONT_SPEC (spec);
4743 CHECK_FONT (font);
4744
4745 return (font_match_p (spec, font) ? Qt : Qnil);
4746 }
4747
4748 DEFUN ("font-at", Ffont_at, Sfont_at, 1, 3, 0,
4749 doc: /* Return a font-object for displaying a character at POSITION.
4750 Optional second arg WINDOW, if non-nil, is a window displaying
4751 the current buffer. It defaults to the currently selected window.
4752 Optional third arg STRING, if non-nil, is a string containing the target
4753 character at index specified by POSITION. */)
4754 (Lisp_Object position, Lisp_Object window, Lisp_Object string)
4755 {
4756 struct window *w = decode_live_window (window);
4757
4758 if (NILP (string))
4759 {
4760 if (XBUFFER (w->buffer) != current_buffer)
4761 error ("Specified window is not displaying the current buffer.");
4762 CHECK_NUMBER_COERCE_MARKER (position);
4763 if (! (BEGV <= XINT (position) && XINT (position) < ZV))
4764 args_out_of_range_3 (position, make_number (BEGV), make_number (ZV));
4765 }
4766 else
4767 {
4768 CHECK_NUMBER (position);
4769 CHECK_STRING (string);
4770 if (! (0 <= XINT (position) && XINT (position) < SCHARS (string)))
4771 args_out_of_range (string, position);
4772 }
4773
4774 return font_at (-1, XINT (position), NULL, w, string);
4775 }
4776
4777 #if 0
4778 DEFUN ("draw-string", Fdraw_string, Sdraw_string, 2, 2, 0,
4779 doc: /* Draw STRING by FONT-OBJECT on the top left corner of the current frame.
4780 The value is a number of glyphs drawn.
4781 Type C-l to recover what previously shown. */)
4782 (Lisp_Object font_object, Lisp_Object string)
4783 {
4784 Lisp_Object frame = selected_frame;
4785 FRAME_PTR f = XFRAME (frame);
4786 struct font *font;
4787 struct face *face;
4788 int i, len, width;
4789 unsigned *code;
4790
4791 CHECK_FONT_GET_OBJECT (font_object, font);
4792 CHECK_STRING (string);
4793 len = SCHARS (string);
4794 code = alloca (sizeof (unsigned) * len);
4795 for (i = 0; i < len; i++)
4796 {
4797 Lisp_Object ch = Faref (string, make_number (i));
4798 Lisp_Object val;
4799 int c = XINT (ch);
4800
4801 code[i] = font->driver->encode_char (font, c);
4802 if (code[i] == FONT_INVALID_CODE)
4803 break;
4804 }
4805 face = FACE_FROM_ID (f, DEFAULT_FACE_ID);
4806 face->fontp = font;
4807 if (font->driver->prepare_face)
4808 font->driver->prepare_face (f, face);
4809 width = font->driver->text_extents (font, code, i, NULL);
4810 len = font->driver->draw_text (f, face, 0, font->ascent, code, i, width);
4811 if (font->driver->done_face)
4812 font->driver->done_face (f, face);
4813 face->fontp = NULL;
4814 return make_number (len);
4815 }
4816 #endif
4817
4818 #endif /* FONT_DEBUG */
4819
4820 #ifdef HAVE_WINDOW_SYSTEM
4821
4822 DEFUN ("font-info", Ffont_info, Sfont_info, 1, 2, 0,
4823 doc: /* Return information about a font named NAME on frame FRAME.
4824 If FRAME is omitted or nil, use the selected frame.
4825 The returned value is a vector of OPENED-NAME, FULL-NAME, SIZE,
4826 HEIGHT, BASELINE-OFFSET, RELATIVE-COMPOSE, and DEFAULT-ASCENT,
4827 where
4828 OPENED-NAME is the name used for opening the font,
4829 FULL-NAME is the full name of the font,
4830 SIZE is the pixelsize of the font,
4831 HEIGHT is the pixel-height of the font (i.e., ascent + descent),
4832 BASELINE-OFFSET is the upward offset pixels from ASCII baseline,
4833 RELATIVE-COMPOSE and DEFAULT-ASCENT are the numbers controlling
4834 how to compose characters.
4835 If the named font is not yet loaded, return nil. */)
4836 (Lisp_Object name, Lisp_Object frame)
4837 {
4838 struct frame *f;
4839 struct font *font;
4840 Lisp_Object info;
4841 Lisp_Object font_object;
4842
4843 (*check_window_system_func) ();
4844
4845 if (! FONTP (name))
4846 CHECK_STRING (name);
4847 f = decode_live_frame (frame);
4848
4849 if (STRINGP (name))
4850 {
4851 int fontset = fs_query_fontset (name, 0);
4852
4853 if (fontset >= 0)
4854 name = fontset_ascii (fontset);
4855 font_object = font_open_by_name (f, name);
4856 }
4857 else if (FONT_OBJECT_P (name))
4858 font_object = name;
4859 else if (FONT_ENTITY_P (name))
4860 font_object = font_open_entity (f, name, 0);
4861 else
4862 {
4863 struct face *face = FACE_FROM_ID (f, DEFAULT_FACE_ID);
4864 Lisp_Object entity = font_matching_entity (f, face->lface, name);
4865
4866 font_object = ! NILP (entity) ? font_open_entity (f, entity, 0) : Qnil;
4867 }
4868 if (NILP (font_object))
4869 return Qnil;
4870 font = XFONT_OBJECT (font_object);
4871
4872 info = make_uninit_vector (7);
4873 ASET (info, 0, AREF (font_object, FONT_NAME_INDEX));
4874 ASET (info, 1, AREF (font_object, FONT_FULLNAME_INDEX));
4875 ASET (info, 2, make_number (font->pixel_size));
4876 ASET (info, 3, make_number (font->height));
4877 ASET (info, 4, make_number (font->baseline_offset));
4878 ASET (info, 5, make_number (font->relative_compose));
4879 ASET (info, 6, make_number (font->default_ascent));
4880
4881 #if 0
4882 /* As font_object is still in FONT_OBJLIST of the entity, we can't
4883 close it now. Perhaps, we should manage font-objects
4884 by `reference-count'. */
4885 font_close_object (f, font_object);
4886 #endif
4887 return info;
4888 }
4889 #endif
4890
4891 \f
4892 #define BUILD_STYLE_TABLE(TBL) \
4893 build_style_table ((TBL), sizeof TBL / sizeof (struct table_entry))
4894
4895 static Lisp_Object
4896 build_style_table (const struct table_entry *entry, int nelement)
4897 {
4898 int i, j;
4899 Lisp_Object table, elt;
4900
4901 table = Fmake_vector (make_number (nelement), Qnil);
4902 for (i = 0; i < nelement; i++)
4903 {
4904 for (j = 0; entry[i].names[j]; j++);
4905 elt = Fmake_vector (make_number (j + 1), Qnil);
4906 ASET (elt, 0, make_number (entry[i].numeric));
4907 for (j = 0; entry[i].names[j]; j++)
4908 ASET (elt, j + 1, intern_c_string (entry[i].names[j]));
4909 ASET (table, i, elt);
4910 }
4911 return table;
4912 }
4913
4914 /* The deferred font-log data of the form [ACTION ARG RESULT].
4915 If ACTION is not nil, that is added to the log when font_add_log is
4916 called next time. At that time, ACTION is set back to nil. */
4917 static Lisp_Object Vfont_log_deferred;
4918
4919 /* Prepend the font-related logging data in Vfont_log if it is not
4920 `t'. ACTION describes a kind of font-related action (e.g. listing,
4921 opening), ARG is the argument for the action, and RESULT is the
4922 result of the action. */
4923 void
4924 font_add_log (const char *action, Lisp_Object arg, Lisp_Object result)
4925 {
4926 Lisp_Object val;
4927 int i;
4928
4929 if (EQ (Vfont_log, Qt))
4930 return;
4931 if (STRINGP (AREF (Vfont_log_deferred, 0)))
4932 {
4933 char *str = SSDATA (AREF (Vfont_log_deferred, 0));
4934
4935 ASET (Vfont_log_deferred, 0, Qnil);
4936 font_add_log (str, AREF (Vfont_log_deferred, 1),
4937 AREF (Vfont_log_deferred, 2));
4938 }
4939
4940 if (FONTP (arg))
4941 {
4942 Lisp_Object tail, elt;
4943 Lisp_Object equalstr = build_string ("=");
4944
4945 val = Ffont_xlfd_name (arg, Qt);
4946 for (tail = AREF (arg, FONT_EXTRA_INDEX); CONSP (tail);
4947 tail = XCDR (tail))
4948 {
4949 elt = XCAR (tail);
4950 if (EQ (XCAR (elt), QCscript)
4951 && SYMBOLP (XCDR (elt)))
4952 val = concat3 (val, SYMBOL_NAME (QCscript),
4953 concat2 (equalstr, SYMBOL_NAME (XCDR (elt))));
4954 else if (EQ (XCAR (elt), QClang)
4955 && SYMBOLP (XCDR (elt)))
4956 val = concat3 (val, SYMBOL_NAME (QClang),
4957 concat2 (equalstr, SYMBOL_NAME (XCDR (elt))));
4958 else if (EQ (XCAR (elt), QCotf)
4959 && CONSP (XCDR (elt)) && SYMBOLP (XCAR (XCDR (elt))))
4960 val = concat3 (val, SYMBOL_NAME (QCotf),
4961 concat2 (equalstr,
4962 SYMBOL_NAME (XCAR (XCDR (elt)))));
4963 }
4964 arg = val;
4965 }
4966
4967 if (CONSP (result)
4968 && VECTORP (XCAR (result))
4969 && ASIZE (XCAR (result)) > 0
4970 && FONTP (AREF (XCAR (result), 0)))
4971 result = font_vconcat_entity_vectors (result);
4972 if (FONTP (result))
4973 {
4974 val = Ffont_xlfd_name (result, Qt);
4975 if (! FONT_SPEC_P (result))
4976 val = concat3 (SYMBOL_NAME (AREF (result, FONT_TYPE_INDEX)),
4977 build_string (":"), val);
4978 result = val;
4979 }
4980 else if (CONSP (result))
4981 {
4982 Lisp_Object tail;
4983 result = Fcopy_sequence (result);
4984 for (tail = result; CONSP (tail); tail = XCDR (tail))
4985 {
4986 val = XCAR (tail);
4987 if (FONTP (val))
4988 val = Ffont_xlfd_name (val, Qt);
4989 XSETCAR (tail, val);
4990 }
4991 }
4992 else if (VECTORP (result))
4993 {
4994 result = Fcopy_sequence (result);
4995 for (i = 0; i < ASIZE (result); i++)
4996 {
4997 val = AREF (result, i);
4998 if (FONTP (val))
4999 val = Ffont_xlfd_name (val, Qt);
5000 ASET (result, i, val);
5001 }
5002 }
5003 Vfont_log = Fcons (list3 (intern (action), arg, result), Vfont_log);
5004 }
5005
5006 /* Record a font-related logging data to be added to Vfont_log when
5007 font_add_log is called next time. ACTION, ARG, RESULT are the same
5008 as font_add_log. */
5009
5010 void
5011 font_deferred_log (const char *action, Lisp_Object arg, Lisp_Object result)
5012 {
5013 if (EQ (Vfont_log, Qt))
5014 return;
5015 ASET (Vfont_log_deferred, 0, build_string (action));
5016 ASET (Vfont_log_deferred, 1, arg);
5017 ASET (Vfont_log_deferred, 2, result);
5018 }
5019
5020 void
5021 syms_of_font (void)
5022 {
5023 sort_shift_bits[FONT_TYPE_INDEX] = 0;
5024 sort_shift_bits[FONT_SLANT_INDEX] = 2;
5025 sort_shift_bits[FONT_WEIGHT_INDEX] = 9;
5026 sort_shift_bits[FONT_SIZE_INDEX] = 16;
5027 sort_shift_bits[FONT_WIDTH_INDEX] = 23;
5028 /* Note that the other elements in sort_shift_bits are not used. */
5029
5030 staticpro (&font_charset_alist);
5031 font_charset_alist = Qnil;
5032
5033 DEFSYM (Qopentype, "opentype");
5034
5035 DEFSYM (Qascii_0, "ascii-0");
5036 DEFSYM (Qiso8859_1, "iso8859-1");
5037 DEFSYM (Qiso10646_1, "iso10646-1");
5038 DEFSYM (Qunicode_bmp, "unicode-bmp");
5039 DEFSYM (Qunicode_sip, "unicode-sip");
5040
5041 DEFSYM (QCf, "Cf");
5042
5043 DEFSYM (QCotf, ":otf");
5044 DEFSYM (QClang, ":lang");
5045 DEFSYM (QCscript, ":script");
5046 DEFSYM (QCantialias, ":antialias");
5047
5048 DEFSYM (QCfoundry, ":foundry");
5049 DEFSYM (QCadstyle, ":adstyle");
5050 DEFSYM (QCregistry, ":registry");
5051 DEFSYM (QCspacing, ":spacing");
5052 DEFSYM (QCdpi, ":dpi");
5053 DEFSYM (QCscalable, ":scalable");
5054 DEFSYM (QCavgwidth, ":avgwidth");
5055 DEFSYM (QCfont_entity, ":font-entity");
5056 DEFSYM (QCfc_unknown_spec, ":fc-unknown-spec");
5057
5058 DEFSYM (Qc, "c");
5059 DEFSYM (Qm, "m");
5060 DEFSYM (Qp, "p");
5061 DEFSYM (Qd, "d");
5062
5063 DEFSYM (Qja, "ja");
5064 DEFSYM (Qko, "ko");
5065
5066 DEFSYM (QCuser_spec, "user-spec");
5067
5068 staticpro (&scratch_font_spec);
5069 scratch_font_spec = Ffont_spec (0, NULL);
5070 staticpro (&scratch_font_prefer);
5071 scratch_font_prefer = Ffont_spec (0, NULL);
5072
5073 staticpro (&Vfont_log_deferred);
5074 Vfont_log_deferred = Fmake_vector (make_number (3), Qnil);
5075
5076 #if 0
5077 #ifdef HAVE_LIBOTF
5078 staticpro (&otf_list);
5079 otf_list = Qnil;
5080 #endif /* HAVE_LIBOTF */
5081 #endif /* 0 */
5082
5083 defsubr (&Sfontp);
5084 defsubr (&Sfont_spec);
5085 defsubr (&Sfont_get);
5086 #ifdef HAVE_WINDOW_SYSTEM
5087 defsubr (&Sfont_face_attributes);
5088 #endif
5089 defsubr (&Sfont_put);
5090 defsubr (&Slist_fonts);
5091 defsubr (&Sfont_family_list);
5092 defsubr (&Sfind_font);
5093 defsubr (&Sfont_xlfd_name);
5094 defsubr (&Sclear_font_cache);
5095 defsubr (&Sfont_shape_gstring);
5096 defsubr (&Sfont_variation_glyphs);
5097 #if 0
5098 defsubr (&Sfont_drive_otf);
5099 defsubr (&Sfont_otf_alternates);
5100 #endif /* 0 */
5101
5102 #ifdef FONT_DEBUG
5103 defsubr (&Sopen_font);
5104 defsubr (&Sclose_font);
5105 defsubr (&Squery_font);
5106 defsubr (&Sfont_get_glyphs);
5107 defsubr (&Sfont_match_p);
5108 defsubr (&Sfont_at);
5109 #if 0
5110 defsubr (&Sdraw_string);
5111 #endif
5112 #endif /* FONT_DEBUG */
5113 #ifdef HAVE_WINDOW_SYSTEM
5114 defsubr (&Sfont_info);
5115 #endif
5116
5117 DEFVAR_LISP ("font-encoding-alist", Vfont_encoding_alist,
5118 doc: /*
5119 Alist of fontname patterns vs the corresponding encoding and repertory info.
5120 Each element looks like (REGEXP . (ENCODING . REPERTORY)),
5121 where ENCODING is a charset or a char-table,
5122 and REPERTORY is a charset, a char-table, or nil.
5123
5124 If ENCODING and REPERTORY are the same, the element can have the form
5125 \(REGEXP . ENCODING).
5126
5127 ENCODING is for converting a character to a glyph code of the font.
5128 If ENCODING is a charset, encoding a character by the charset gives
5129 the corresponding glyph code. If ENCODING is a char-table, looking up
5130 the table by a character gives the corresponding glyph code.
5131
5132 REPERTORY specifies a repertory of characters supported by the font.
5133 If REPERTORY is a charset, all characters belonging to the charset are
5134 supported. If REPERTORY is a char-table, all characters who have a
5135 non-nil value in the table are supported. If REPERTORY is nil, Emacs
5136 gets the repertory information by an opened font and ENCODING. */);
5137 Vfont_encoding_alist = Qnil;
5138
5139 /* FIXME: These 3 vars are not quite what they appear: setq on them
5140 won't have any effect other than disconnect them from the style
5141 table used by the font display code. So we make them read-only,
5142 to avoid this confusing situation. */
5143
5144 DEFVAR_LISP_NOPRO ("font-weight-table", Vfont_weight_table,
5145 doc: /* Vector of valid font weight values.
5146 Each element has the form:
5147 [NUMERIC-VALUE SYMBOLIC-NAME ALIAS-NAME ...]
5148 NUMERIC-VALUE is an integer, and SYMBOLIC-NAME and ALIAS-NAME are symbols. */);
5149 Vfont_weight_table = BUILD_STYLE_TABLE (weight_table);
5150 XSYMBOL (intern_c_string ("font-weight-table"))->constant = 1;
5151
5152 DEFVAR_LISP_NOPRO ("font-slant-table", Vfont_slant_table,
5153 doc: /* Vector of font slant symbols vs the corresponding numeric values.
5154 See `font-weight-table' for the format of the vector. */);
5155 Vfont_slant_table = BUILD_STYLE_TABLE (slant_table);
5156 XSYMBOL (intern_c_string ("font-slant-table"))->constant = 1;
5157
5158 DEFVAR_LISP_NOPRO ("font-width-table", Vfont_width_table,
5159 doc: /* Alist of font width symbols vs the corresponding numeric values.
5160 See `font-weight-table' for the format of the vector. */);
5161 Vfont_width_table = BUILD_STYLE_TABLE (width_table);
5162 XSYMBOL (intern_c_string ("font-width-table"))->constant = 1;
5163
5164 staticpro (&font_style_table);
5165 font_style_table = make_uninit_vector (3);
5166 ASET (font_style_table, 0, Vfont_weight_table);
5167 ASET (font_style_table, 1, Vfont_slant_table);
5168 ASET (font_style_table, 2, Vfont_width_table);
5169
5170 DEFVAR_LISP ("font-log", Vfont_log, doc: /*
5171 *Logging list of font related actions and results.
5172 The value t means to suppress the logging.
5173 The initial value is set to nil if the environment variable
5174 EMACS_FONT_LOG is set. Otherwise, it is set to t. */);
5175 Vfont_log = Qnil;
5176
5177 #ifdef HAVE_WINDOW_SYSTEM
5178 #ifdef HAVE_FREETYPE
5179 syms_of_ftfont ();
5180 #ifdef HAVE_X_WINDOWS
5181 syms_of_xfont ();
5182 syms_of_ftxfont ();
5183 #ifdef HAVE_XFT
5184 syms_of_xftfont ();
5185 #endif /* HAVE_XFT */
5186 #endif /* HAVE_X_WINDOWS */
5187 #else /* not HAVE_FREETYPE */
5188 #ifdef HAVE_X_WINDOWS
5189 syms_of_xfont ();
5190 #endif /* HAVE_X_WINDOWS */
5191 #endif /* not HAVE_FREETYPE */
5192 #ifdef HAVE_BDFFONT
5193 syms_of_bdffont ();
5194 #endif /* HAVE_BDFFONT */
5195 #ifdef HAVE_NTGUI
5196 syms_of_w32font ();
5197 #endif /* HAVE_NTGUI */
5198 #ifdef HAVE_NS
5199 syms_of_nsfont ();
5200 #endif /* HAVE_NS */
5201 #endif /* HAVE_WINDOW_SYSTEM */
5202 }
5203
5204 void
5205 init_font (void)
5206 {
5207 Vfont_log = egetenv ("EMACS_FONT_LOG") ? Qnil : Qt;
5208 }