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