1 /* font.c -- "Font" primitives.
2 Copyright (C) 2006 Free Software Foundation, Inc.
4 National Institute of Advanced Industrial Science and Technology (AIST)
5 Registration Number H13PRO009
7 This file is part of GNU Emacs.
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 2, or (at your option)
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.
19 You should have received a copy of the GNU General Public License
20 along with GNU Emacs; see the file COPYING. If not, write to
21 the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
22 Boston, MA 02110-1301, USA. */
33 #include "dispextern.h"
35 #include "character.h"
36 #include "composite.h"
46 #define xassert(X) do {if (!(X)) abort ();} while (0)
48 #define xassert(X) (void) 0
51 int enable_font_backend
;
55 /* Important character set symbols. */
56 Lisp_Object Qiso8859_1
, Qiso10646_1
, Qunicode_bmp
;
58 /* Like CHECK_FONT_SPEC but also validate properties of the font-spec,
59 and set X to the validated result. */
61 #define CHECK_VALIDATE_FONT_SPEC(x) \
63 if (! FONT_SPEC_P (x)) x = wrong_type_argument (Qfont, x); \
64 x = font_prop_validate (x); \
67 /* Number of pt per inch (from the TeXbook). */
68 #define PT_PER_INCH 72.27
70 /* Return a pixel size (integer) corresponding to POINT size (double)
72 #define POINT_TO_PIXEL(POINT, DPI) ((POINT) * (DPI) / PT_PER_INCH + 0.5)
74 /* Return a point size (double) corresponding to POINT size (integer)
76 #define PIXEL_TO_POINT(PIXEL, DPI) ((PIXEL) * PT_PER_INCH * 10 / (DPI) + 0.5)
78 /* Special string of zero length. It is used to specify a NULL name
79 in a font properties (e.g. adstyle). We don't use the symbol of
80 NULL name because it's confusing (Lisp printer prints nothing for
82 Lisp_Object null_string
;
84 /* Special vector of zero length. This is repeatedly used by (struct
85 font_driver *)->list when a specified font is not found. */
86 Lisp_Object null_vector
;
88 /* Vector of 3 elements. Each element is an alist for one of font
89 style properties (weight, slant, width). The alist contains a
90 mapping between symbolic property values (e.g. `medium' for weight)
91 and numeric property values (e.g. 100). So, it looks like this:
92 [((thin . 0) ... (heavy . 210))
93 ((ro . 0) ... (ot . 210))
94 ((ultracondensed . 50) ... (wide . 200))] */
95 static Lisp_Object font_style_table
;
97 /* Alist of font family vs the corresponding aliases.
98 Each element has this form:
99 (FAMILY ALIAS1 ALIAS2 ...) */
101 static Lisp_Object font_family_alist
;
103 /* Symbols representing keys of normal font properties. */
104 extern Lisp_Object QCtype
, QCfamily
, QCweight
, QCslant
, QCwidth
, QCsize
, QCname
;
105 Lisp_Object QCfoundry
, QCadstyle
, QCregistry
, QCextra
;
106 /* Symbols representing keys of font extra info. */
107 Lisp_Object QCspacing
, QCdpi
, QCscalable
, QCotf
, QClanguage
, QCscript
;
108 /* Symbols representing values of font spacing property. */
109 Lisp_Object Qc
, Qm
, Qp
, Qd
;
111 /* List of all font drivers. All font-backends (XXXfont.c) call
112 add_font_driver in syms_of_XXXfont to register the font-driver
114 static struct font_driver_list
*font_driver_list
;
116 static int font_pixel_size
P_ ((FRAME_PTR f
, Lisp_Object
));
117 static Lisp_Object prop_name_to_numeric
P_ ((enum font_property_index
,
119 static Lisp_Object prop_numeric_to_name
P_ ((enum font_property_index
, int));
120 static Lisp_Object font_open_entity
P_ ((FRAME_PTR
, Lisp_Object
, int));
121 static void build_font_family_alist
P_ ((void));
123 /* Number of registered font drivers. */
124 static int num_font_drivers
;
126 /* Return a pixel size of font-spec SPEC on frame F. */
129 font_pixel_size (f
, spec
)
133 Lisp_Object size
= AREF (spec
, FONT_SIZE_INDEX
);
136 Lisp_Object extra
, val
;
142 point_size
= XFLOAT_DATA (size
);
143 extra
= AREF (spec
, FONT_EXTRA_INDEX
);
144 val
= assq_no_quit (extra
, QCdpi
);
147 if (INTEGERP (XCDR (val
)))
148 dpi
= XINT (XCDR (val
));
150 dpi
= XFLOAT_DATA (XCDR (val
)) + 0.5;
154 pixel_size
= POINT_TO_PIXEL (point_size
, dpi
);
158 /* Return a numeric value corresponding to PROP's NAME (symbol). If
159 NAME is not registered in font_style_table, return Qnil. PROP must
160 be one of FONT_{WEIGHT|SLANT|SWIDTH}_INDEX. */
163 prop_name_to_numeric (prop
, name
)
164 enum font_property_index prop
;
167 int table_index
= prop
- FONT_WEIGHT_INDEX
;
170 val
= assq_no_quit (name
, AREF (font_style_table
, table_index
));
171 return (NILP (val
) ? Qnil
: XCDR (val
));
175 /* Return a name (symbol) corresponding to PROP's NUMERIC value. If
176 no name is registered for NUMERIC in font_style_table, return a
177 symbol of integer name (e.g. `123'). PROP must be one of
178 FONT_{WEIGHT|SLANT|SWIDTH}_INDEX. */
181 prop_numeric_to_name (prop
, numeric
)
182 enum font_property_index prop
;
185 int table_index
= prop
- FONT_WEIGHT_INDEX
;
186 Lisp_Object table
= AREF (font_style_table
, table_index
);
189 while (! NILP (table
))
191 if (XINT (XCDR (XCAR (table
))) >= numeric
)
193 if (XINT (XCDR (XCAR (table
))) == numeric
)
194 return XCAR (XCAR (table
));
198 table
= XCDR (table
);
200 sprintf (buf
, "%d", numeric
);
205 /* Return a symbol whose name is STR (length LEN). If STR contains
206 uppercase letters, downcase them in advance. */
209 intern_downcase (str
, len
)
216 for (i
= 0; i
< len
; i
++)
217 if (isupper (str
[i
]))
220 return Fintern (make_unibyte_string (str
, len
), Qnil
);
223 return Fintern (null_string
, Qnil
);
224 bcopy (str
, buf
, len
);
226 if (isascii (buf
[i
]))
227 buf
[i
] = tolower (buf
[i
]);
228 return Fintern (make_unibyte_string (buf
, len
), Qnil
);
231 extern Lisp_Object Vface_alternative_font_family_alist
;
234 build_font_family_alist ()
236 Lisp_Object alist
= Vface_alternative_font_family_alist
;
238 for (; CONSP (alist
); alist
= XCDR (alist
))
240 Lisp_Object tail
, elt
;
242 for (tail
= XCAR (alist
), elt
= Qnil
; CONSP (tail
); tail
= XCDR (tail
))
243 elt
= nconc2 (elt
, Fcons (Fintern (XCAR (tail
), Qnil
), Qnil
));
244 font_family_alist
= Fcons (elt
, font_family_alist
);
249 /* Font property validater. */
251 static Lisp_Object font_prop_validate_symbol
P_ ((enum font_property_index
,
252 Lisp_Object
, Lisp_Object
));
253 static Lisp_Object font_prop_validate_style
P_ ((enum font_property_index
,
254 Lisp_Object
, Lisp_Object
));
255 static Lisp_Object font_prop_validate_non_neg
P_ ((enum font_property_index
,
256 Lisp_Object
, Lisp_Object
));
257 static Lisp_Object font_prop_validate_spacing
P_ ((enum font_property_index
,
258 Lisp_Object
, Lisp_Object
));
259 static int get_font_prop_index
P_ ((Lisp_Object
, int));
260 static Lisp_Object font_prop_validate
P_ ((Lisp_Object
));
261 static Lisp_Object font_put_extra
P_ ((Lisp_Object
, Lisp_Object
, Lisp_Object
));
264 font_prop_validate_symbol (prop_index
, prop
, val
)
265 enum font_property_index prop_index
;
266 Lisp_Object prop
, val
;
268 if (EQ (prop
, QCotf
))
269 return (SYMBOLP (val
) ? val
: Qerror
);
271 val
= (SCHARS (val
) == 0 ? null_string
272 : intern_downcase ((char *) SDATA (val
), SBYTES (val
)));
273 else if (SYMBOLP (val
))
275 if (SCHARS (SYMBOL_NAME (val
)) == 0)
284 font_prop_validate_style (prop_index
, prop
, val
)
285 enum font_property_index prop_index
;
286 Lisp_Object prop
, val
;
288 if (! INTEGERP (val
))
291 val
= intern_downcase ((char *) SDATA (val
), SBYTES (val
));
296 val
= prop_name_to_numeric (prop_index
, val
);
305 font_prop_validate_non_neg (prop_index
, prop
, val
)
306 enum font_property_index prop_index
;
307 Lisp_Object prop
, val
;
309 return (NATNUMP (val
) || (FLOATP (val
) && XFLOAT_DATA (val
) >= 0)
314 font_prop_validate_spacing (prop_index
, prop
, val
)
315 enum font_property_index prop_index
;
316 Lisp_Object prop
, val
;
318 if (NILP (val
) || (NATNUMP (val
) && XINT (val
) <= FONT_SPACING_CHARCELL
))
321 return make_number (FONT_SPACING_CHARCELL
);
323 return make_number (FONT_SPACING_MONO
);
325 return make_number (FONT_SPACING_PROPORTIONAL
);
329 /* Structure of known font property keys and validater of the
333 /* Pointer to the key symbol. */
335 /* Function to validate the value VAL, or NULL if any value is ok. */
336 Lisp_Object (*validater
) P_ ((enum font_property_index prop_index
,
337 Lisp_Object prop
, Lisp_Object val
));
338 } font_property_table
[] =
339 { { &QCtype
, font_prop_validate_symbol
},
340 { &QCfoundry
, font_prop_validate_symbol
},
341 { &QCfamily
, font_prop_validate_symbol
},
342 { &QCadstyle
, font_prop_validate_symbol
},
343 { &QCregistry
, font_prop_validate_symbol
},
344 { &QCweight
, font_prop_validate_style
},
345 { &QCslant
, font_prop_validate_style
},
346 { &QCwidth
, font_prop_validate_style
},
347 { &QCsize
, font_prop_validate_non_neg
},
348 { &QClanguage
, font_prop_validate_symbol
},
349 { &QCscript
, font_prop_validate_symbol
},
350 { &QCdpi
, font_prop_validate_non_neg
},
351 { &QCspacing
, font_prop_validate_spacing
},
352 { &QCscalable
, NULL
},
353 { &QCotf
, font_prop_validate_symbol
}
356 #define FONT_PROPERTY_TABLE_SIZE \
357 ((sizeof font_property_table) / (sizeof *font_property_table))
360 get_font_prop_index (key
, from
)
364 for (; from
< FONT_PROPERTY_TABLE_SIZE
; from
++)
365 if (EQ (key
, *font_property_table
[from
].key
))
371 font_prop_validate (spec
)
375 Lisp_Object prop
, val
, extra
;
377 for (i
= FONT_TYPE_INDEX
; i
< FONT_EXTRA_INDEX
; i
++)
379 if (! NILP (AREF (spec
, i
)))
381 prop
= *font_property_table
[i
].key
;
382 val
= (font_property_table
[i
].validater
) (i
, prop
, AREF (spec
, i
));
383 if (EQ (val
, Qerror
))
384 Fsignal (Qfont
, list2 (build_string ("invalid font property"),
385 Fcons (prop
, AREF (spec
, i
))));
389 for (extra
= AREF (spec
, FONT_EXTRA_INDEX
);
390 CONSP (extra
); extra
= XCDR (extra
))
392 Lisp_Object elt
= XCAR (extra
);
395 i
= get_font_prop_index (prop
, FONT_EXTRA_INDEX
);
397 && font_property_table
[i
].validater
)
399 val
= (font_property_table
[i
].validater
) (i
, prop
, XCDR (elt
));
400 if (EQ (val
, Qerror
))
401 Fsignal (Qfont
, list2 (build_string ("invalid font property"),
410 font_put_extra (font
, prop
, val
)
411 Lisp_Object font
, prop
, val
;
413 Lisp_Object extra
= AREF (font
, FONT_EXTRA_INDEX
);
414 Lisp_Object slot
= (NILP (extra
) ? Qnil
: assq_no_quit (prop
, extra
));
418 extra
= Fcons (Fcons (prop
, val
), extra
);
419 ASET (font
, FONT_EXTRA_INDEX
, extra
);
427 /* Font name parser and unparser */
429 static Lisp_Object intern_font_field
P_ ((char *, int));
430 static int parse_matrix
P_ ((char *));
431 static int font_expand_wildcards
P_ ((Lisp_Object
*, int));
432 static int font_parse_name
P_ ((char *, Lisp_Object
));
434 /* An enumerator for each field of an XLFD font name. */
435 enum xlfd_field_index
454 /* An enumerator for mask bit corresponding to each XLFD field. */
457 XLFD_FOUNDRY_MASK
= 0x0001,
458 XLFD_FAMILY_MASK
= 0x0002,
459 XLFD_WEIGHT_MASK
= 0x0004,
460 XLFD_SLANT_MASK
= 0x0008,
461 XLFD_SWIDTH_MASK
= 0x0010,
462 XLFD_ADSTYLE_MASK
= 0x0020,
463 XLFD_PIXEL_MASK
= 0x0040,
464 XLFD_POINT_MASK
= 0x0080,
465 XLFD_RESX_MASK
= 0x0100,
466 XLFD_RESY_MASK
= 0x0200,
467 XLFD_SPACING_MASK
= 0x0400,
468 XLFD_AVGWIDTH_MASK
= 0x0800,
469 XLFD_REGISTRY_MASK
= 0x1000,
470 XLFD_ENCODING_MASK
= 0x2000
474 /* Return a Lispy value of a XLFD font field at STR and LEN bytes.
475 If LEN is zero, it returns `null_string'.
476 If STR is "*", it returns nil.
477 If all characters in STR are digits, it returns an integer.
478 Otherwise, it returns a symbol interned from downcased STR. */
481 intern_font_field (str
, len
)
489 if (*str
== '*' && len
== 1)
493 for (i
= 1; i
< len
; i
++)
494 if (! isdigit (str
[i
]))
497 return make_number (atoi (str
));
499 return intern_downcase (str
, len
);
502 /* Parse P pointing the pixel/point size field of the form
503 `[A B C D]' which specifies a transformation matrix:
509 by which all glyphs of the font are transformed. The spec says
510 that scalar value N for the pixel/point size is equivalent to:
511 A = N * resx/resy, B = C = 0, D = N.
513 Return the scalar value N if the form is valid. Otherwise return
524 for (i
= 0, p
++; i
< 4 && *p
&& *p
!= ']'; i
++)
527 matrix
[i
] = - strtod (p
+ 1, &end
);
529 matrix
[i
] = strtod (p
, &end
);
532 return (i
== 4 ? (int) matrix
[3] : -1);
535 /* Expand a wildcard field in FIELD (the first N fields are filled) to
536 multiple fields to fill in all 14 XLFD fields while restring a
537 field position by its contents. */
540 font_expand_wildcards (field
, n
)
541 Lisp_Object field
[XLFD_LAST_INDEX
];
545 Lisp_Object tmp
[XLFD_LAST_INDEX
];
546 /* Array of information about where this element can go. Nth
547 element is for Nth element of FIELD. */
549 /* Minimum possible field. */
551 /* Maxinum possible field. */
553 /* Bit mask of possible field. Nth bit corresponds to Nth field. */
555 } range
[XLFD_LAST_INDEX
];
557 int range_from
, range_to
;
560 #define XLFD_SYMBOL_MASK (XLFD_FOUNDRY_MASK | XLFD_FAMILY_MASK \
561 | XLFD_ADSTYLE_MASK | XLFD_REGISTRY_MASK)
562 #define XLFD_NULL_MASK (XLFD_FOUNDRY_MASK | XLFD_ADSTYLE_MASK)
563 #define XLFD_LARGENUM_MASK (XLFD_POINT_MASK | XLFD_RESX_MASK | XLFD_RESY_MASK \
564 | XLFD_AVGWIDTH_MASK)
565 #define XLFD_REGENC_MASK (XLFD_REGISTRY_MASK | XLFD_ENCODING_MASK)
567 /* Initialize RANGE_MASK for FIELD[0] which can be 0th to (14 - N)th
568 field. The value is shifted to left one bit by one in the
570 for (i
= 0, range_mask
= 0; i
<= 14 - n
; i
++)
571 range_mask
= (range_mask
<< 1) | 1;
573 /* The triplet RANGE_FROM, RANGE_TO, and RANGE_MASK is a
574 position-based retriction for FIELD[I]. */
575 for (i
= 0, range_from
= 0, range_to
= 14 - n
; i
< n
;
576 i
++, range_from
++, range_to
++, range_mask
<<= 1)
578 Lisp_Object val
= field
[i
];
584 range
[i
].from
= range_from
;
585 range
[i
].to
= range_to
;
586 range
[i
].mask
= range_mask
;
590 /* The triplet FROM, TO, and MASK is a value-based
591 retriction for FIELD[I]. */
597 int numeric
= XINT (val
);
600 from
= to
= XLFD_ENCODING_INDEX
,
601 mask
= XLFD_ENCODING_MASK
;
602 else if (numeric
== 0)
603 from
= XLFD_PIXEL_INDEX
, to
= XLFD_AVGWIDTH_INDEX
,
604 mask
= XLFD_PIXEL_MASK
| XLFD_LARGENUM_MASK
;
605 else if (numeric
<= 48)
606 from
= to
= XLFD_PIXEL_INDEX
,
607 mask
= XLFD_PIXEL_MASK
;
609 from
= XLFD_POINT_INDEX
, to
= XLFD_AVGWIDTH_INDEX
,
610 mask
= XLFD_LARGENUM_MASK
;
612 else if (EQ (val
, null_string
))
613 from
= XLFD_FOUNDRY_INDEX
, to
= XLFD_ADSTYLE_INDEX
,
614 mask
= XLFD_NULL_MASK
;
616 from
= to
= XLFD_FOUNDRY_INDEX
, mask
= XLFD_FOUNDRY_MASK
;
619 Lisp_Object name
= SYMBOL_NAME (val
);
621 if (SDATA (name
)[SBYTES (name
) - 1] == '*')
622 from
= XLFD_REGISTRY_INDEX
, to
= XLFD_ENCODING_INDEX
,
623 mask
= XLFD_REGENC_MASK
;
625 from
= to
= XLFD_ENCODING_INDEX
,
626 mask
= XLFD_ENCODING_MASK
;
628 else if (range_from
<= XLFD_WEIGHT_INDEX
629 && range_to
>= XLFD_WEIGHT_INDEX
630 && !NILP (prop_name_to_numeric (FONT_WEIGHT_INDEX
, val
)))
631 from
= to
= XLFD_WEIGHT_INDEX
, mask
= XLFD_WEIGHT_MASK
;
632 else if (range_from
<= XLFD_SLANT_INDEX
633 && range_to
>= XLFD_SLANT_INDEX
634 && !NILP (prop_name_to_numeric (FONT_SLANT_INDEX
, val
)))
635 from
= to
= XLFD_SLANT_INDEX
, mask
= XLFD_SLANT_MASK
;
636 else if (range_from
<= XLFD_SWIDTH_INDEX
637 && range_to
>= XLFD_SWIDTH_INDEX
638 && !NILP (prop_name_to_numeric (FONT_WIDTH_INDEX
, val
)))
639 from
= to
= XLFD_SWIDTH_INDEX
, mask
= XLFD_SWIDTH_MASK
;
642 if (EQ (val
, Qc
) || EQ (val
, Qm
) || EQ (val
, Qp
) || EQ (val
, Qd
))
643 from
= to
= XLFD_SPACING_INDEX
, mask
= XLFD_SPACING_MASK
;
645 from
= XLFD_FOUNDRY_INDEX
, to
= XLFD_ENCODING_INDEX
,
646 mask
= XLFD_SYMBOL_MASK
;
649 /* Merge position-based and value-based restrictions. */
651 while (from
< range_from
)
652 mask
&= ~(1 << from
++);
653 while (from
< 14 && ! (mask
& (1 << from
)))
655 while (to
> range_to
)
656 mask
&= ~(1 << to
--);
657 while (to
>= 0 && ! (mask
& (1 << to
)))
661 range
[i
].from
= from
;
663 range
[i
].mask
= mask
;
665 if (from
> range_from
|| to
< range_to
)
667 /* The range is narrowed by value-based restrictions.
668 Reflect it to the other fields. */
670 /* Following fields should be after FROM. */
672 /* Preceding fields should be before TO. */
673 for (j
= i
- 1, from
--, to
--; j
>= 0; j
--, from
--, to
--)
675 /* Check FROM for non-wildcard field. */
676 if (! NILP (tmp
[j
]) && range
[j
].from
< from
)
678 while (range
[j
].from
< from
)
679 range
[j
].mask
&= ~(1 << range
[j
].from
++);
680 while (from
< 14 && ! (range
[j
].mask
& (1 << from
)))
682 range
[j
].from
= from
;
685 from
= range
[j
].from
;
686 if (range
[j
].to
> to
)
688 while (range
[j
].to
> to
)
689 range
[j
].mask
&= ~(1 << range
[j
].to
--);
690 while (to
>= 0 && ! (range
[j
].mask
& (1 << to
)))
703 /* Decide all fileds from restrictions in RANGE. */
704 for (i
= j
= 0; i
< n
; i
++)
706 if (j
< range
[i
].from
)
708 if (i
== 0 || ! NILP (tmp
[i
- 1]))
709 /* None of TMP[X] corresponds to Jth field. */
711 for (; j
< range
[i
].from
; j
++)
716 if (! NILP (tmp
[n
- 1]) && j
< XLFD_REGISTRY_INDEX
)
718 for (; j
< XLFD_LAST_INDEX
; j
++)
720 if (INTEGERP (field
[XLFD_ENCODING_INDEX
]))
721 field
[XLFD_ENCODING_INDEX
]
722 = Fintern (Fnumber_to_string (field
[XLFD_ENCODING_INDEX
]), Qnil
);
726 /* Parse NAME (null terminated) as XLFD and store information in FONT
727 (font-spec or font-entity). Size property of FONT is set as
729 specified XLFD fields FONT property
730 --------------------- -------------
731 PIXEL_SIZE PIXEL_SIZE (Lisp integer)
732 POINT_SIZE and RESY calculated pixel size (Lisp integer)
733 POINT_SIZE POINT_SIZE/10 (Lisp float)
735 If NAME is successfully parsed, return 0. Otherwise return -1.
737 FONT is usually a font-spec, but when this function is called from
738 X font backend driver, it is a font-entity. In that case, NAME is
739 a fully specified XLFD, and we set FONT_EXTRA_INDEX of FONT to a
740 symbol RESX-RESY-SPACING-AVGWIDTH.
744 font_parse_xlfd (name
, font
)
748 int len
= strlen (name
);
750 Lisp_Object dpi
, spacing
;
752 char *f
[XLFD_LAST_INDEX
];
757 /* Maximum XLFD name length is 255. */
759 /* Accept "*-.." as a fully specified XLFD. */
760 if (name
[0] == '*' && name
[1] == '-')
761 i
= 1, f
[XLFD_FOUNDRY_INDEX
] = name
;
764 for (p
= name
+ i
; *p
; p
++)
765 if (*p
== '-' && i
< XLFD_LAST_INDEX
)
769 dpi
= spacing
= Qnil
;
772 if (i
== XLFD_LAST_INDEX
)
776 /* Fully specified XLFD. */
777 for (i
= 0, j
= FONT_FOUNDRY_INDEX
; i
< XLFD_WEIGHT_INDEX
; i
++, j
++)
779 val
= intern_font_field (f
[i
], f
[i
+ 1] - 1 - f
[i
]);
783 for (j
= FONT_WEIGHT_INDEX
; i
< XLFD_ADSTYLE_INDEX
; i
++, j
++)
785 val
= intern_font_field (f
[i
], f
[i
+ 1] - 1 - f
[i
]);
788 Lisp_Object numeric
= prop_name_to_numeric (j
, val
);
790 if (INTEGERP (numeric
))
795 val
= intern_font_field (f
[i
], f
[i
+ 1] - 1 - f
[i
]);
797 ASET (font
, FONT_ADSTYLE_INDEX
, val
);
798 i
= XLFD_REGISTRY_INDEX
;
799 val
= intern_font_field (f
[i
], f
[i
+ 2] - f
[i
]);
801 ASET (font
, FONT_REGISTRY_INDEX
, val
);
803 p
= f
[XLFD_PIXEL_INDEX
];
804 if (*p
== '[' && (pixel_size
= parse_matrix (p
)) >= 0)
805 ASET (font
, FONT_SIZE_INDEX
, make_number (pixel_size
));
808 i
= XLFD_PIXEL_INDEX
;
809 val
= intern_font_field (f
[i
], f
[i
+ 1] - 1 - f
[i
]);
811 ASET (font
, FONT_SIZE_INDEX
, val
);
814 double point_size
= -1;
816 xassert (FONT_SPEC_P (font
));
817 p
= f
[XLFD_POINT_INDEX
];
819 point_size
= parse_matrix (p
);
820 else if (isdigit (*p
))
821 point_size
= atoi (p
), point_size
/= 10;
823 ASET (font
, FONT_SIZE_INDEX
, make_float (point_size
));
826 i
= XLFD_PIXEL_INDEX
;
827 val
= intern_font_field (f
[i
], f
[i
+ 1] - 1 - f
[i
]);
829 ASET (font
, FONT_SIZE_INDEX
, val
);
834 /* Parse RESX, RESY, SPACING, and AVGWIDTH. */
835 if (FONT_ENTITY_P (font
))
838 ASET (font
, FONT_EXTRA_INDEX
,
839 intern_font_field (f
[i
], f
[XLFD_REGISTRY_INDEX
] - 1 - f
[i
]));
843 /* Here we just setup DPI, SPACING, and AVGWIDTH. They are set
844 in FONT_EXTRA_INDEX later. */
846 dpi
= intern_font_field (f
[i
], f
[i
+ 1] - 1 - f
[i
]);
847 i
= XLFD_SPACING_INDEX
;
848 spacing
= intern_font_field (f
[i
], f
[i
+ 1] - 1 - f
[i
]);
849 p
= f
[XLFD_AVGWIDTH_INDEX
];
857 int wild_card_found
= 0;
858 Lisp_Object prop
[XLFD_LAST_INDEX
];
860 for (j
= 0; j
< i
; j
++)
864 if (f
[j
][1] && f
[j
][1] != '-')
869 else if (isdigit (*f
[j
]))
871 for (p
= f
[j
] + 1; isdigit (*p
); p
++);
873 prop
[j
] = intern_downcase (f
[j
], p
- f
[j
]);
875 prop
[j
] = make_number (atoi (f
[j
]));
878 prop
[j
] = intern_font_field (f
[j
], f
[j
+ 1] - 1 - f
[j
]);
880 prop
[j
] = intern_font_field (f
[j
], f
[i
] - f
[j
]);
882 if (! wild_card_found
)
884 if (font_expand_wildcards (prop
, i
) < 0)
887 for (i
= 0, j
= FONT_FOUNDRY_INDEX
; i
< XLFD_WEIGHT_INDEX
; i
++, j
++)
888 if (! NILP (prop
[i
]))
889 ASET (font
, j
, prop
[i
]);
890 for (j
= FONT_WEIGHT_INDEX
; i
< XLFD_ADSTYLE_INDEX
; i
++, j
++)
891 if (! NILP (prop
[i
]))
892 ASET (font
, j
, prop
[i
]);
893 if (! NILP (prop
[XLFD_ADSTYLE_INDEX
]))
894 ASET (font
, FONT_ADSTYLE_INDEX
, prop
[XLFD_ADSTYLE_INDEX
]);
895 val
= prop
[XLFD_REGISTRY_INDEX
];
898 val
= prop
[XLFD_ENCODING_INDEX
];
900 val
= Fintern (concat2 (build_string ("*-"), SYMBOL_NAME (val
)),
903 else if (NILP (prop
[XLFD_ENCODING_INDEX
]))
904 val
= Fintern (concat2 (SYMBOL_NAME (val
), build_string ("-*")),
907 val
= Fintern (concat3 (SYMBOL_NAME (val
), build_string ("-"),
908 SYMBOL_NAME (prop
[XLFD_ENCODING_INDEX
])),
911 ASET (font
, FONT_REGISTRY_INDEX
, val
);
913 if (INTEGERP (prop
[XLFD_PIXEL_INDEX
]))
914 ASET (font
, FONT_SIZE_INDEX
, prop
[XLFD_PIXEL_INDEX
]);
915 else if (INTEGERP (prop
[XLFD_POINT_INDEX
]))
917 double point_size
= XINT (prop
[XLFD_POINT_INDEX
]);
919 ASET (font
, FONT_SIZE_INDEX
, make_float (point_size
/ 10));
922 dpi
= prop
[XLFD_RESX_INDEX
];
923 spacing
= prop
[XLFD_SPACING_INDEX
];
924 if (INTEGERP (prop
[XLFD_AVGWIDTH_INDEX
]))
925 avgwidth
= XINT (prop
[XLFD_AVGWIDTH_INDEX
]);
929 font_put_extra (font
, QCdpi
, dpi
);
930 if (! NILP (spacing
))
931 font_put_extra (font
, QCspacing
, spacing
);
933 font_put_extra (font
, QCscalable
, avgwidth
== 0 ? Qt
: Qnil
);
938 /* Store XLFD name of FONT (font-spec or font-entity) in NAME (NBYTES
939 length), and return the name length. If FONT_SIZE_INDEX of FONT is
940 0, use PIXEL_SIZE instead. */
943 font_unparse_xlfd (font
, pixel_size
, name
, nbytes
)
949 char *f
[XLFD_REGISTRY_INDEX
+ 1];
953 xassert (FONTP (font
));
955 for (i
= FONT_FOUNDRY_INDEX
, j
= XLFD_FOUNDRY_INDEX
; i
<= FONT_REGISTRY_INDEX
;
958 if (i
== FONT_ADSTYLE_INDEX
)
959 j
= XLFD_ADSTYLE_INDEX
;
960 else if (i
== FONT_REGISTRY_INDEX
)
961 j
= XLFD_REGISTRY_INDEX
;
962 val
= AREF (font
, i
);
965 if (j
== XLFD_REGISTRY_INDEX
)
966 f
[j
] = "*-*", len
+= 4;
968 f
[j
] = "*", len
+= 2;
973 val
= SYMBOL_NAME (val
);
974 if (j
== XLFD_REGISTRY_INDEX
975 && ! strchr ((char *) SDATA (val
), '-'))
977 /* Change "jisx0208*" and "jisx0208" to "jisx0208*-*". */
978 if (SDATA (val
)[SBYTES (val
) - 1] == '*')
980 f
[j
] = alloca (SBYTES (val
) + 3);
981 sprintf (f
[j
], "%s-*", SDATA (val
));
982 len
+= SBYTES (val
) + 3;
986 f
[j
] = alloca (SBYTES (val
) + 4);
987 sprintf (f
[j
], "%s*-*", SDATA (val
));
988 len
+= SBYTES (val
) + 4;
992 f
[j
] = (char *) SDATA (val
), len
+= SBYTES (val
) + 1;
996 for (i
= FONT_WEIGHT_INDEX
, j
= XLFD_WEIGHT_INDEX
; i
<= FONT_WIDTH_INDEX
;
999 val
= AREF (font
, i
);
1001 f
[j
] = "*", len
+= 2;
1005 val
= prop_numeric_to_name (i
, XINT (val
));
1007 val
= SYMBOL_NAME (val
);
1008 xassert (STRINGP (val
));
1009 f
[j
] = (char *) SDATA (val
), len
+= SBYTES (val
) + 1;
1013 val
= AREF (font
, FONT_SIZE_INDEX
);
1014 xassert (NUMBERP (val
) || NILP (val
));
1017 f
[XLFD_PIXEL_INDEX
] = alloca (22);
1020 len
+= sprintf (f
[XLFD_PIXEL_INDEX
], "%d-*", i
) + 1;
1022 len
+= sprintf (f
[XLFD_PIXEL_INDEX
], "%d-*", pixel_size
) + 1;
1024 else if (FLOATP (val
))
1026 f
[XLFD_PIXEL_INDEX
] = alloca (12);
1027 i
= XFLOAT_DATA (val
) * 10;
1028 len
+= sprintf (f
[XLFD_PIXEL_INDEX
], "*-%d", i
) + 1;
1031 f
[XLFD_PIXEL_INDEX
] = "*-*", len
+= 4;
1033 val
= AREF (font
, FONT_EXTRA_INDEX
);
1035 if (FONT_ENTITY_P (font
)
1036 && EQ (AREF (font
, FONT_TYPE_INDEX
), Qx
))
1038 /* Setup names for RESX-RESY-SPACING-AVWIDTH. */
1039 if (SYMBOLP (val
) && ! NILP (val
))
1041 val
= SYMBOL_NAME (val
);
1042 f
[XLFD_RESX_INDEX
] = (char *) SDATA (val
), len
+= SBYTES (val
) + 1;
1045 f
[XLFD_RESX_INDEX
] = "*-*-*-*", len
+= 6;
1049 Lisp_Object dpi
= assq_no_quit (QCdpi
, val
);
1050 Lisp_Object spacing
= assq_no_quit (QCspacing
, val
);
1051 Lisp_Object scalable
= assq_no_quit (QCscalable
, val
);
1053 if (CONSP (dpi
) || CONSP (spacing
) || CONSP (scalable
))
1055 char *str
= alloca (24);
1058 if (CONSP (dpi
) && INTEGERP (XCDR (dpi
)))
1059 this_len
= sprintf (str
, "%d-%d",
1060 XINT (XCDR (dpi
)), XINT (XCDR (dpi
)));
1062 this_len
= sprintf (str
, "*-*");
1063 if (CONSP (spacing
) && ! NILP (XCDR (spacing
)))
1065 val
= XCDR (spacing
);
1068 if (XINT (val
) < FONT_SPACING_MONO
)
1070 else if (XINT (val
) < FONT_SPACING_CHARCELL
)
1075 xassert (SYMBOLP (val
));
1076 this_len
+= sprintf (str
+ this_len
, "-%c",
1077 SDATA (SYMBOL_NAME (val
))[0]);
1080 this_len
+= sprintf (str
+ this_len
, "-*");
1081 if (CONSP (scalable
) && ! NILP (XCDR (spacing
)))
1082 this_len
+= sprintf (str
+ this_len
, "-0");
1084 this_len
+= sprintf (str
+ this_len
, "-*");
1085 f
[XLFD_RESX_INDEX
] = str
;
1089 f
[XLFD_RESX_INDEX
] = "*-*-*-*", len
+= 8;
1092 len
++; /* for terminating '\0'. */
1095 return sprintf (name
, "-%s-%s-%s-%s-%s-%s-%s-%s-%s",
1096 f
[XLFD_FOUNDRY_INDEX
], f
[XLFD_FAMILY_INDEX
],
1097 f
[XLFD_WEIGHT_INDEX
], f
[XLFD_SLANT_INDEX
],
1098 f
[XLFD_SWIDTH_INDEX
],
1099 f
[XLFD_ADSTYLE_INDEX
], f
[XLFD_PIXEL_INDEX
],
1100 f
[XLFD_RESX_INDEX
], f
[XLFD_REGISTRY_INDEX
]);
1103 /* Parse NAME (null terminated) as Fonconfig's name format and store
1104 information in FONT (font-spec or font-entity). If NAME is
1105 successfully parsed, return 0. Otherwise return -1. */
1108 font_parse_fcname (name
, font
)
1113 int len
= strlen (name
);
1118 /* It is assured that (name[0] && name[0] != '-'). */
1126 for (p0
= name
+ 1; *p0
&& (*p0
!= '-' && *p0
!= ':'); p0
++)
1127 if (*p0
== '\\' && p0
[1])
1129 family
= intern_font_field (name
, p0
- name
);
1132 if (! isdigit (p0
[1]))
1134 point_size
= strtod (p0
+ 1, &p1
);
1135 if (*p1
&& *p1
!= ':')
1137 ASET (font
, FONT_SIZE_INDEX
, make_float (point_size
));
1140 ASET (font
, FONT_FAMILY_INDEX
, family
);
1144 copy
= alloca (len
+ 1);
1149 /* Now parse ":KEY=VAL" patterns. Store known keys and values in
1150 extra, copy unknown ones to COPY. */
1153 Lisp_Object key
, val
;
1156 for (p1
= p0
+ 1; *p1
&& *p1
!= '=' && *p1
!= ':'; p1
++);
1159 /* Must be an enumerated value. */
1160 val
= intern_font_field (p0
+ 1, p1
- p0
- 1);
1161 if (memcmp (p0
+ 1, "light", 5) == 0
1162 || memcmp (p0
+ 1, "medium", 6) == 0
1163 || memcmp (p0
+ 1, "demibold", 8) == 0
1164 || memcmp (p0
+ 1, "bold", 4) == 0
1165 || memcmp (p0
+ 1, "black", 5) == 0)
1167 ASET (font
, FONT_WEIGHT_INDEX
, val
);
1169 else if (memcmp (p0
+ 1, "roman", 5) == 0
1170 || memcmp (p0
+ 1, "italic", 6) == 0
1171 || memcmp (p0
+ 1, "oblique", 7) == 0)
1173 ASET (font
, FONT_SLANT_INDEX
, val
);
1175 else if (memcmp (p0
+ 1, "charcell", 8) == 0
1176 || memcmp (p0
+ 1, "mono", 4) == 0
1177 || memcmp (p0
+ 1, "proportional", 12) == 0)
1179 font_put_extra (font
, QCspacing
,
1180 (p0
[1] == 'c' ? Qc
: p0
[1] == 'm' ? Qm
: Qp
));
1185 bcopy (p0
, copy
, p1
- p0
);
1193 if (memcmp (p0
+ 1, "pixelsize=", 10) == 0)
1194 prop
= FONT_SIZE_INDEX
;
1197 key
= intern_font_field (p0
, p1
- p0
);
1198 prop
= get_font_prop_index (key
, 0);
1201 for (p1
= p0
; *p1
&& *p1
!= ':'; p1
++);
1202 val
= intern_font_field (p0
, p1
- p0
);
1205 if (prop
>= 0 && prop
< FONT_EXTRA_INDEX
)
1207 ASET (font
, prop
, val
);
1210 font_put_extra (font
, key
, val
);
1213 /* Unknown attribute, keep it in name. */
1214 bcopy (pbeg
, copy
, p1
- pbeg
);
1223 font_put_extra (font
, QCname
, make_unibyte_string (name
, copy
- name
));
1228 /* Store fontconfig's font name of FONT (font-spec or font-entity) in
1229 NAME (NBYTES length), and return the name length. If
1230 FONT_SIZE_INDEX of FONT is 0, use PIXEL_SIZE instead. */
1233 font_unparse_fcname (font
, pixel_size
, name
, nbytes
)
1241 int dpi
, spacing
, scalable
;
1244 Lisp_Object styles
[3];
1245 char *style_names
[3] = { "weight", "slant", "swidth" };
1247 val
= AREF (font
, FONT_FAMILY_INDEX
);
1248 if (SYMBOLP (val
) && ! NILP (val
))
1249 len
+= SBYTES (SYMBOL_NAME (val
));
1251 val
= AREF (font
, FONT_SIZE_INDEX
);
1254 if (XINT (val
) != 0)
1255 pixel_size
= XINT (val
);
1257 len
+= 21; /* for ":pixelsize=NUM" */
1259 else if (FLOATP (val
))
1262 point_size
= (int) XFLOAT_DATA (val
);
1263 len
+= 11; /* for "-NUM" */
1266 val
= AREF (font
, FONT_FOUNDRY_INDEX
);
1268 /* ":foundry=NAME" */
1269 len
+= 9 + SBYTES (SYMBOL_NAME (val
));
1271 for (i
= FONT_WEIGHT_INDEX
; i
<= FONT_WIDTH_INDEX
; i
++)
1273 val
= AREF (font
, i
);
1276 val
= prop_numeric_to_name (i
, XINT (val
));
1277 len
+= (strlen (style_names
[i
- FONT_WEIGHT_INDEX
])
1278 + 2 + SBYTES (SYMBOL_NAME (val
))); /* :xxx=NAME */
1280 styles
[i
- FONT_WEIGHT_INDEX
] = val
;
1283 val
= AREF (font
, FONT_EXTRA_INDEX
);
1284 if (FONT_ENTITY_P (font
)
1285 && EQ (AREF (font
, FONT_TYPE_INDEX
), Qx
))
1289 /* VAL is a symbol of name `RESX-RESY-SPACING-AVWIDTH'. */
1290 p
= (char *) SDATA (SYMBOL_NAME (val
));
1292 for (p
++; *p
!= '-'; p
++); /* skip RESX */
1293 for (p
++; *p
!= '-'; p
++); /* skip RESY */
1294 spacing
= (*p
== 'c' ? FONT_SPACING_CHARCELL
1295 : *p
== 'm' ? FONT_SPACING_MONO
1296 : FONT_SPACING_PROPORTIONAL
);
1297 for (p
++; *p
!= '-'; p
++); /* skip SPACING */
1298 scalable
= (atoi (p
) == 0);
1299 /* The longest pattern is ":dpi=NUM:scalable=False:spacing=100" */
1306 dpi
= spacing
= scalable
= -1;
1307 elt
= assq_no_quit (QCdpi
, val
);
1309 dpi
= XINT (XCDR (elt
)), len
+= 15; /* for ":dpi=NUM" */
1310 elt
= assq_no_quit (QCspacing
, val
);
1312 spacing
= XINT (XCDR (elt
)), len
+= 12; /* for ":spacing=100" */
1313 elt
= assq_no_quit (QCscalable
, val
);
1315 scalable
= ! NILP (XCDR (elt
)), len
+= 15; /* for ":scalable=False" */
1321 if (! NILP (AREF (font
, FONT_FAMILY_INDEX
)))
1322 p
+= sprintf(p
, "%s",
1323 SDATA (SYMBOL_NAME (AREF (font
, FONT_FAMILY_INDEX
))));
1327 p
+= sprintf (p
, "%d", point_size
);
1329 p
+= sprintf (p
, "-%d", point_size
);
1331 else if (pixel_size
> 0)
1332 p
+= sprintf (p
, ":pixelsize=%d", pixel_size
);
1333 if (SYMBOLP (AREF (font
, FONT_FOUNDRY_INDEX
))
1334 && ! NILP (AREF (font
, FONT_FOUNDRY_INDEX
)))
1335 p
+= sprintf (p
, ":foundry=%s",
1336 SDATA (SYMBOL_NAME (AREF (font
, FONT_FOUNDRY_INDEX
))));
1337 for (i
= 0; i
< 3; i
++)
1338 if (! NILP (styles
[i
]))
1339 p
+= sprintf (p
, ":%s=%s", style_names
[i
],
1340 SDATA (SYMBOL_NAME (styles
[i
])));
1342 p
+= sprintf (p
, ":dpi=%d", dpi
);
1344 p
+= sprintf (p
, ":spacing=%d", spacing
);
1346 p
+= sprintf (p
, ":scalable=True");
1347 else if (scalable
== 0)
1348 p
+= sprintf (p
, ":scalable=False");
1352 /* Parse NAME (null terminated) and store information in FONT
1353 (font-spec or font-entity). If NAME is successfully parsed, return
1354 0. Otherwise return -1.
1356 If NAME is XLFD and FONT is a font-entity, store
1357 RESX-RESY-SPACING-AVWIDTH information as a symbol in
1358 FONT_EXTRA_INDEX. */
1361 font_parse_name (name
, font
)
1365 if (name
[0] == '-' || index (name
, '*'))
1367 if (font_parse_xlfd (name
, font
) == 0)
1369 font_put_extra (font
, QCname
, make_unibyte_string (name
, strlen (name
)));
1372 font_put_extra (font
, QCname
, make_unibyte_string (name
, strlen (name
)));
1373 return font_parse_fcname (name
, font
);
1377 font_merge_old_spec (name
, family
, registry
, spec
)
1378 Lisp_Object name
, family
, registry
, spec
;
1382 if (font_parse_xlfd ((char *) SDATA (name
), spec
) < 0)
1384 Lisp_Object extra
= Fcons (Fcons (QCname
, name
), Qnil
);
1386 ASET (spec
, FONT_EXTRA_INDEX
, extra
);
1391 if (! NILP (family
))
1396 xassert (STRINGP (family
));
1397 len
= SBYTES (family
);
1398 p0
= (char *) SDATA (family
);
1399 p1
= index (p0
, '-');
1402 if ((*p0
!= '*' || p1
- p0
> 1)
1403 && NILP (AREF (spec
, FONT_FOUNDRY_INDEX
)))
1404 ASET (spec
, FONT_FOUNDRY_INDEX
,
1405 intern_downcase (p0
, p1
- p0
));
1406 if (NILP (AREF (spec
, FONT_FAMILY_INDEX
)))
1407 ASET (spec
, FONT_FAMILY_INDEX
,
1408 intern_downcase (p1
+ 1, len
- (p1
+ 1 - p0
)));
1410 else if (NILP (AREF (spec
, FONT_FAMILY_INDEX
)))
1411 ASET (spec
, FONT_FAMILY_INDEX
, intern_downcase (p0
, len
));
1413 if (! NILP (registry
)
1414 && NILP (AREF (spec
, FONT_REGISTRY_INDEX
)))
1415 ASET (spec
, FONT_REGISTRY_INDEX
,
1416 intern_downcase ((char *) SDATA (registry
), SBYTES (registry
)));
1421 font_lispy_object (font
)
1424 Lisp_Object objlist
= AREF (font
->entity
, FONT_OBJLIST_INDEX
);
1426 for (; ! NILP (objlist
); objlist
= XCDR (objlist
))
1428 struct Lisp_Save_Value
*p
= XSAVE_VALUE (XCAR (objlist
));
1430 if (font
== (struct font
*) p
->pointer
)
1433 xassert (! NILP (objlist
));
1434 return XCAR (objlist
);
1447 struct otf_list
*next
;
1450 static struct otf_list
*otf_list
;
1453 otf_tag_symbol (tag
)
1458 OTF_tag_name (tag
, name
);
1459 return Fintern (make_unibyte_string (name
, 4), Qnil
);
1463 otf_open (entity
, file
)
1467 struct otf_list
*list
= otf_list
;
1469 while (list
&& ! EQ (list
->entity
, entity
))
1473 list
= malloc (sizeof (struct otf_list
));
1474 list
->entity
= entity
;
1475 list
->otf
= file
? OTF_open (file
) : NULL
;
1476 list
->next
= otf_list
;
1483 /* Return a list describing which scripts/languages FONT supports by
1484 which GSUB/GPOS features of OpenType tables. See the comment of
1485 (sturct font_driver).otf_capability. */
1488 font_otf_capability (font
)
1492 Lisp_Object capability
= Fcons (Qnil
, Qnil
);
1495 otf
= otf_open (font
->entity
, font
->file_name
);
1498 for (i
= 0; i
< 2; i
++)
1500 OTF_GSUB_GPOS
*gsub_gpos
;
1501 Lisp_Object script_list
= Qnil
;
1504 if (OTF_get_features (otf
, i
== 0) < 0)
1506 gsub_gpos
= i
== 0 ? otf
->gsub
: otf
->gpos
;
1507 for (j
= gsub_gpos
->ScriptList
.ScriptCount
- 1; j
>= 0; j
--)
1509 OTF_Script
*script
= gsub_gpos
->ScriptList
.Script
+ j
;
1510 Lisp_Object langsys_list
= Qnil
;
1511 Lisp_Object script_tag
= otf_tag_symbol (script
->ScriptTag
);
1514 for (k
= script
->LangSysCount
; k
>= 0; k
--)
1516 OTF_LangSys
*langsys
;
1517 Lisp_Object feature_list
= Qnil
;
1518 Lisp_Object langsys_tag
;
1521 if (j
== script
->LangSysCount
)
1523 langsys
= &script
->DefaultLangSys
;
1528 langsys
= script
->LangSys
+ k
;
1530 = otf_tag_symbol (script
->LangSysRecord
[k
].LangSysTag
);
1532 for (l
= langsys
->FeatureCount
-1; l
>= 0; l
--)
1534 OTF_Feature
*feature
1535 = gsub_gpos
->FeatureList
.Feature
+ langsys
->FeatureIndex
[l
];
1536 Lisp_Object feature_tag
1537 = otf_tag_symbol (feature
->FeatureTag
);
1539 feature_list
= Fcons (feature_tag
, feature_list
);
1541 langsys_list
= Fcons (Fcons (langsys_tag
, feature_list
),
1544 script_list
= Fcons (Fcons (script_tag
, langsys_list
),
1549 XSETCAR (capability
, script_list
);
1551 XSETCDR (capability
, script_list
);
1558 parse_gsub_gpos_spec (spec
, script
, langsys
, features
)
1560 char **script
, **langsys
, **features
;
1568 *script
= (char *) SDATA (SYMBOL_NAME (val
));
1571 *langsys
= NILP (val
) ? NULL
: (char *) SDATA (SYMBOL_NAME (val
));
1573 len
= XINT (Flength (spec
));
1574 *features
= p
= malloc (6 * len
);
1578 for (asterisk
= 0; CONSP (spec
); spec
= XCDR (spec
))
1581 if (SREF (SYMBOL_NAME (val
), 0) == '*')
1584 p
+= sprintf (p
, ",*");
1586 else if (! asterisk
)
1587 p
+= sprintf (p
, ",%s", SDATA (SYMBOL_NAME (val
)));
1589 p
+= sprintf (p
, ",~%s", SDATA (SYMBOL_NAME (val
)));
1594 #define DEVICE_DELTA(table, size) \
1595 (((size) >= (table).StartSize && (size) <= (table).EndSize) \
1596 ? (table).DeltaValue[(size) - (table).StartSize] \
1600 adjust_anchor (struct font
*font
, OTF_Anchor
*anchor
,
1601 unsigned code
, int size
, int *x
, int *y
)
1603 if (anchor
->AnchorFormat
== 2)
1607 if (font
->driver
->anchor_point (font
, code
, anchor
->f
.f1
.AnchorPoint
,
1611 else if (anchor
->AnchorFormat
== 3)
1613 if (anchor
->f
.f2
.XDeviceTable
.offset
)
1614 *x
+= DEVICE_DELTA (anchor
->f
.f2
.XDeviceTable
, size
);
1615 if (anchor
->f
.f2
.YDeviceTable
.offset
)
1616 *y
+= DEVICE_DELTA (anchor
->f
.f2
.YDeviceTable
, size
);
1621 /* Drive FONT's OTF GSUB features according to GSUB_SPEC. See the
1622 comment of (sturct font_driver).otf_gsub. */
1625 font_otf_gsub (font
, gsub_spec
, gstring_in
, from
, to
, gstring_out
, idx
)
1627 Lisp_Object gsub_spec
;
1628 Lisp_Object gstring_in
;
1630 Lisp_Object gstring_out
;
1636 OTF_GlyphString otf_gstring
;
1638 char *script
, *langsys
, *features
;
1640 otf
= otf_open (font
->entity
, font
->file_name
);
1643 if (OTF_get_table (otf
, "head") < 0)
1645 if (OTF_check_table (otf
, "GSUB") < 0)
1647 if (parse_gsub_gpos_spec (gsub_spec
, &script
, &langsys
, &features
) < 0)
1650 otf_gstring
.size
= otf_gstring
.used
= len
;
1651 otf_gstring
.glyphs
= (OTF_Glyph
*) malloc (sizeof (OTF_Glyph
) * len
);
1652 memset (otf_gstring
.glyphs
, 0, sizeof (OTF_Glyph
) * len
);
1653 for (i
= 0; i
< len
; i
++)
1655 Lisp_Object g
= LGSTRING_GLYPH (gstring_in
, from
+ i
);
1657 otf_gstring
.glyphs
[i
].c
= XINT (LGLYPH_CHAR (g
));
1658 otf_gstring
.glyphs
[i
].glyph_id
= XINT (LGLYPH_CODE (g
));
1661 OTF_drive_gdef (otf
, &otf_gstring
);
1662 if (OTF_drive_gsub (otf
, &otf_gstring
, script
, langsys
, features
) < 0)
1664 free (otf_gstring
.glyphs
);
1667 if (ASIZE (gstring_out
) < idx
+ otf_gstring
.used
)
1669 free (otf_gstring
.glyphs
);
1673 for (i
= 0, g
= otf_gstring
.glyphs
; i
< otf_gstring
.used
;)
1675 int i0
= g
->f
.index
.from
, i1
= g
->f
.index
.to
;
1676 Lisp_Object glyph
= LGSTRING_GLYPH (gstring_in
, from
+ i0
);
1677 Lisp_Object min_idx
= AREF (glyph
, 0);
1678 Lisp_Object max_idx
= AREF (glyph
, 1);
1682 int min_idx_i
= XINT (min_idx
), max_idx_i
= XINT (max_idx
);
1684 for (i0
++; i0
<= i1
; i0
++)
1686 glyph
= LGSTRING_GLYPH (gstring_in
, from
+ i0
);
1687 if (min_idx_i
> XINT (AREF (glyph
, 0)))
1688 min_idx_i
= XINT (AREF (glyph
, 0));
1689 if (max_idx_i
< XINT (AREF (glyph
, 1)))
1690 max_idx_i
= XINT (AREF (glyph
, 1));
1692 min_idx
= make_number (min_idx_i
);
1693 max_idx
= make_number (max_idx_i
);
1694 i0
= g
->f
.index
.from
;
1696 for (; i
< otf_gstring
.used
&& g
->f
.index
.from
== i0
; i
++, g
++)
1698 glyph
= LGSTRING_GLYPH (gstring_out
, idx
+ i
);
1699 ASET (glyph
, 0, min_idx
);
1700 ASET (glyph
, 1, max_idx
);
1701 LGLYPH_SET_CHAR (glyph
, make_number (g
->c
));
1702 LGLYPH_SET_CODE (glyph
, make_number (g
->glyph_id
));
1706 free (otf_gstring
.glyphs
);
1710 /* Drive FONT's OTF GPOS features according to GPOS_SPEC. See the
1711 comment of (sturct font_driver).otf_gpos. */
1714 font_otf_gpos (font
, gpos_spec
, gstring
, from
, to
)
1716 Lisp_Object gpos_spec
;
1717 Lisp_Object gstring
;
1723 OTF_GlyphString otf_gstring
;
1725 char *script
, *langsys
, *features
;
1728 Lisp_Object base
, mark
;
1730 otf
= otf_open (font
->entity
, font
->file_name
);
1733 if (OTF_get_table (otf
, "head") < 0)
1735 if (OTF_check_table (otf
, "GPOS") < 0)
1737 if (parse_gsub_gpos_spec (gpos_spec
, &script
, &langsys
, &features
) < 0)
1740 otf_gstring
.size
= otf_gstring
.used
= len
;
1741 otf_gstring
.glyphs
= (OTF_Glyph
*) malloc (sizeof (OTF_Glyph
) * len
);
1742 memset (otf_gstring
.glyphs
, 0, sizeof (OTF_Glyph
) * len
);
1743 for (i
= 0; i
< len
; i
++)
1745 glyph
= LGSTRING_GLYPH (gstring
, from
+ i
);
1746 otf_gstring
.glyphs
[i
].glyph_id
= XINT (LGLYPH_CODE (glyph
));
1749 OTF_drive_gdef (otf
, &otf_gstring
);
1751 if (OTF_drive_gpos (otf
, &otf_gstring
, script
, langsys
, features
) < 0)
1753 free (otf_gstring
.glyphs
);
1757 u
= otf
->head
->unitsPerEm
;
1758 size
= font
->pixel_size
;
1760 for (i
= 0, g
= otf_gstring
.glyphs
; i
< otf_gstring
.used
; i
++, g
++)
1763 int xoff
= 0, yoff
= 0, width_adjust
= 0;
1768 glyph
= LGSTRING_GLYPH (gstring
, from
+ i
);
1769 switch (g
->positioning_type
)
1775 int format
= g
->f
.f1
.format
;
1777 if (format
& OTF_XPlacement
)
1778 xoff
= g
->f
.f1
.value
->XPlacement
* size
/ u
;
1779 if (format
& OTF_XPlaDevice
)
1780 xoff
+= DEVICE_DELTA (g
->f
.f1
.value
->XPlaDevice
, size
);
1781 if (format
& OTF_YPlacement
)
1782 yoff
= - (g
->f
.f1
.value
->YPlacement
* size
/ u
);
1783 if (format
& OTF_YPlaDevice
)
1784 yoff
-= DEVICE_DELTA (g
->f
.f1
.value
->YPlaDevice
, size
);
1785 if (format
& OTF_XAdvance
)
1786 width_adjust
+= g
->f
.f1
.value
->XAdvance
* size
/ u
;
1787 if (format
& OTF_XAdvDevice
)
1788 width_adjust
+= DEVICE_DELTA (g
->f
.f1
.value
->XAdvDevice
, size
);
1792 /* Not yet supported. */
1798 goto label_adjust_anchor
;
1799 default: /* i.e. case 6 */
1804 label_adjust_anchor
:
1806 int base_x
, base_y
, mark_x
, mark_y
, width
;
1809 base_x
= g
->f
.f4
.base_anchor
->XCoordinate
* size
/ u
;
1810 base_y
= g
->f
.f4
.base_anchor
->YCoordinate
* size
/ u
;
1811 mark_x
= g
->f
.f4
.mark_anchor
->XCoordinate
* size
/ u
;
1812 mark_y
= g
->f
.f4
.mark_anchor
->YCoordinate
* size
/ u
;
1814 code
= XINT (LGLYPH_CODE (prev
));
1815 if (g
->f
.f4
.base_anchor
->AnchorFormat
!= 1)
1816 adjust_anchor (font
, g
->f
.f4
.base_anchor
,
1817 code
, size
, &base_x
, &base_y
);
1818 if (g
->f
.f4
.mark_anchor
->AnchorFormat
!= 1)
1819 adjust_anchor (font
, g
->f
.f4
.mark_anchor
,
1820 code
, size
, &mark_x
, &mark_y
);
1822 if (NILP (LGLYPH_WIDTH (prev
)))
1824 width
= font
->driver
->text_extents (font
, &code
, 1, NULL
);
1825 LGLYPH_SET_WIDTH (prev
, make_number (width
));
1828 width
= XINT (LGLYPH_WIDTH (prev
));
1829 xoff
= XINT (LGLYPH_XOFF (prev
)) + (base_x
- width
) - mark_x
;
1830 yoff
= XINT (LGLYPH_YOFF (prev
)) + mark_y
- base_y
;
1834 if (xoff
|| yoff
|| width_adjust
)
1836 Lisp_Object adjustment
= Fmake_vector (make_number (3), Qnil
);
1838 ASET (adjustment
, 0, make_number (xoff
));
1839 ASET (adjustment
, 1, make_number (yoff
));
1840 ASET (adjustment
, 2, make_number (width_adjust
));
1841 LGLYPH_SET_ADJUSTMENT (glyph
, adjustment
);
1844 if (g
->GlyphClass
== OTF_GlyphClass0
)
1845 base
= mark
= glyph
;
1846 else if (g
->GlyphClass
== OTF_GlyphClassMark
)
1852 free (otf_gstring
.glyphs
);
1856 #endif /* HAVE_LIBOTF */
1859 /* glyph-string handler */
1861 /* GSTRING is a vector of this form:
1862 [ [FONT-OBJECT LBEARING RBEARING WIDTH ASCENT DESCENT] GLYPH ... ]
1863 and GLYPH is a vector of this form:
1864 [ FROM-IDX TO-IDX C CODE WIDTH [ [X-OFF Y-OFF WADJUST] | nil] ]
1866 FROM-IDX and TO-IDX are used internally and should not be touched.
1867 C is a character of the glyph.
1868 CODE is a glyph-code of C in FONT-OBJECT.
1869 X-OFF and Y-OFF are offests to the base position for the glyph.
1870 WIDTH is a normal width of the glyph.
1871 WADJUST is an adjustment to the normal width of the glyph. */
1874 font_prepare_composition (cmp
)
1875 struct composition
*cmp
;
1878 = AREF (XHASH_TABLE (composition_hash_table
)->key_and_value
,
1879 cmp
->hash_index
* 2);
1880 struct font
*font
= XSAVE_VALUE (LGSTRING_FONT (gstring
))->pointer
;
1881 int len
= LGSTRING_LENGTH (gstring
);
1885 cmp
->lbearing
= cmp
->rbearing
= cmp
->pixel_width
= 0;
1886 cmp
->ascent
= font
->ascent
;
1887 cmp
->descent
= font
->descent
;
1889 for (i
= 0; i
< len
; i
++)
1891 Lisp_Object g
= LGSTRING_GLYPH (gstring
, i
);
1893 struct font_metrics metrics
;
1895 if (NILP (LGLYPH_FROM (g
)))
1897 code
= XINT (LGLYPH_CODE (g
));
1898 font
->driver
->text_extents (font
, &code
, 1, &metrics
);
1899 LGLYPH_SET_WIDTH (g
, make_number (metrics
.width
));
1900 metrics
.lbearing
+= LGLYPH_XOFF (g
);
1901 metrics
.rbearing
+= LGLYPH_XOFF (g
);
1902 metrics
.ascent
+= LGLYPH_YOFF (g
);
1903 metrics
.descent
+= LGLYPH_YOFF (g
);
1905 if (cmp
->lbearing
> cmp
->pixel_width
+ metrics
.lbearing
)
1906 cmp
->lbearing
= cmp
->pixel_width
+ metrics
.lbearing
;
1907 if (cmp
->rbearing
< cmp
->pixel_width
+ metrics
.rbearing
)
1908 cmp
->rbearing
= cmp
->pixel_width
+ metrics
.rbearing
;
1909 if (cmp
->ascent
< metrics
.ascent
)
1910 cmp
->ascent
= metrics
.ascent
;
1911 if (cmp
->descent
< metrics
.descent
)
1912 cmp
->descent
= metrics
.descent
;
1913 cmp
->pixel_width
+= metrics
.width
+ LGLYPH_WADJUST (g
);
1915 LGSTRING_SET_LBEARING (gstring
, make_number (cmp
->lbearing
));
1916 LGSTRING_SET_RBEARING (gstring
, make_number (cmp
->rbearing
));
1917 LGSTRING_SET_WIDTH (gstring
, make_number (cmp
->pixel_width
));
1918 LGSTRING_SET_ASCENT (gstring
, make_number (cmp
->ascent
));
1919 LGSTRING_SET_DESCENT (gstring
, make_number (cmp
->descent
));
1925 font_gstring_produce (old
, from
, to
, new, idx
, code
, n
)
1933 Lisp_Object min_idx
, max_idx
;
1936 if (idx
+ n
> ASIZE (new))
1942 min_idx
= make_number (0);
1943 max_idx
= make_number (1);
1947 min_idx
= AREF (AREF (old
, from
- 1), 0);
1948 max_idx
= AREF (AREF (old
, from
- 1), 1);
1951 else if (from
+ 1 == to
)
1953 min_idx
= AREF (AREF (old
, from
), 0);
1954 max_idx
= AREF (AREF (old
, from
), 1);
1958 int min_idx_i
= XINT (AREF (AREF (old
, from
), 0));
1959 int max_idx_i
= XINT (AREF (AREF (old
, from
), 1));
1961 for (i
= from
+ 1; i
< to
; i
++)
1963 if (min_idx_i
> XINT (AREF (AREF (old
, i
), 0)))
1964 min_idx_i
= XINT (AREF (AREF (old
, i
), 0));
1965 if (max_idx_i
< XINT (AREF (AREF (old
, i
), 1)))
1966 max_idx_i
= XINT (AREF (AREF (old
, i
), 1));
1968 min_idx
= make_number (min_idx_i
);
1969 max_idx
= make_number (max_idx_i
);
1972 for (i
= 0; i
< n
; i
++)
1974 ASET (AREF (new, idx
+ i
), 0, min_idx
);
1975 ASET (AREF (new, idx
+ i
), 1, max_idx
);
1976 ASET (AREF (new, idx
+ i
), 2, make_number (code
[i
]));
1984 static unsigned font_score
P_ ((Lisp_Object
, Lisp_Object
*));
1985 static int font_compare
P_ ((const void *, const void *));
1986 static Lisp_Object font_sort_entites
P_ ((Lisp_Object
, Lisp_Object
,
1987 Lisp_Object
, Lisp_Object
));
1989 /* We sort fonts by scoring each of them against a specified
1990 font-spec. The score value is 32 bit (`unsigned'), and the smaller
1991 the value is, the closer the font is to the font-spec.
1993 Each 1-bit in the highest 4 bits of the score is used for atomic
1994 properties FOUNDRY, FAMILY, ADSTYLE, and REGISTRY.
1996 Each 7-bit in the lowest 28 bits are used for numeric properties
1997 WEIGHT, SLANT, WIDTH, and SIZE. */
1999 /* How many bits to shift to store the difference value of each font
2000 property in a score. */
2001 static int sort_shift_bits
[FONT_SIZE_INDEX
+ 1];
2003 /* Score font-entity ENTITY against properties of font-spec SPEC_PROP.
2004 The return value indicates how different ENTITY is compared with
2008 font_score (entity
, spec_prop
)
2009 Lisp_Object entity
, *spec_prop
;
2013 /* Score four atomic fields. Maximum difference is 1. */
2014 for (i
= FONT_FOUNDRY_INDEX
; i
<= FONT_REGISTRY_INDEX
; i
++)
2015 if (! NILP (spec_prop
[i
])
2016 && ! EQ (spec_prop
[i
], AREF (entity
, i
)))
2017 score
|= 1 << sort_shift_bits
[i
];
2019 /* Score four numeric fields. Maximum difference is 127. */
2020 for (i
= FONT_WEIGHT_INDEX
; i
<= FONT_SIZE_INDEX
; i
++)
2022 Lisp_Object entity_val
= AREF (entity
, i
);
2024 if (! NILP (spec_prop
[i
]) && ! EQ (spec_prop
[i
], entity_val
))
2026 if (! INTEGERP (entity_val
))
2027 score
|= 127 << sort_shift_bits
[i
];
2030 int diff
= XINT (entity_val
) - XINT (spec_prop
[i
]);
2034 if (i
== FONT_SIZE_INDEX
)
2036 if (XINT (entity_val
) > 0
2037 && diff
> FONT_PIXEL_SIZE_QUANTUM
)
2038 score
|= min (diff
, 127) << sort_shift_bits
[i
];
2041 score
|= min (diff
, 127) << sort_shift_bits
[i
];
2050 /* The comparison function for qsort. */
2053 font_compare (d1
, d2
)
2054 const void *d1
, *d2
;
2056 return (*(unsigned *) d1
< *(unsigned *) d2
2057 ? -1 : *(unsigned *) d1
> *(unsigned *) d2
);
2061 /* The structure for elements being sorted by qsort. */
2062 struct font_sort_data
2069 /* Sort font-entities in vector VEC by closeness to font-spec PREFER.
2070 If PREFER specifies a point-size, calculate the corresponding
2071 pixel-size from QCdpi property of PREFER or from the Y-resolution
2072 of FRAME before sorting. If SPEC is not nil, it is a font-spec to
2073 get the font-entities in VEC. */
2076 font_sort_entites (vec
, prefer
, frame
, spec
)
2077 Lisp_Object vec
, prefer
, frame
, spec
;
2079 Lisp_Object prefer_prop
[FONT_SPEC_MAX
];
2081 struct font_sort_data
*data
;
2088 for (i
= FONT_FOUNDRY_INDEX
; i
<= FONT_SIZE_INDEX
; i
++)
2089 prefer_prop
[i
] = AREF (prefer
, i
);
2093 /* As it is assured that all fonts in VEC match with SPEC, we
2094 should ignore properties specified in SPEC. So, set the
2095 corresponding properties in PREFER_PROP to nil. */
2096 for (i
= FONT_WEIGHT_INDEX
; i
<= FONT_SIZE_INDEX
; i
++)
2097 if (! NILP (AREF (spec
, i
)))
2098 prefer_prop
[i
++] = Qnil
;
2101 if (FLOATP (prefer_prop
[FONT_SIZE_INDEX
]))
2102 prefer_prop
[FONT_SIZE_INDEX
]
2103 = make_number (font_pixel_size (XFRAME (frame
), prefer
));
2105 /* Scoring and sorting. */
2106 SAFE_ALLOCA (data
, struct font_sort_data
*, (sizeof *data
) * len
);
2107 for (i
= 0; i
< len
; i
++)
2109 data
[i
].entity
= AREF (vec
, i
);
2110 data
[i
].score
= font_score (data
[i
].entity
, prefer_prop
);
2112 qsort (data
, len
, sizeof *data
, font_compare
);
2113 for (i
= 0; i
< len
; i
++)
2114 ASET (vec
, i
, data
[i
].entity
);
2121 /* API of Font Service Layer. */
2124 font_update_sort_order (order
)
2127 int i
, shift_bits
= 21;
2129 for (i
= 0; i
< 4; i
++, shift_bits
-= 7)
2131 int xlfd_idx
= order
[i
];
2133 if (xlfd_idx
== XLFD_WEIGHT_INDEX
)
2134 sort_shift_bits
[FONT_WEIGHT_INDEX
] = shift_bits
;
2135 else if (xlfd_idx
== XLFD_SLANT_INDEX
)
2136 sort_shift_bits
[FONT_SLANT_INDEX
] = shift_bits
;
2137 else if (xlfd_idx
== XLFD_SWIDTH_INDEX
)
2138 sort_shift_bits
[FONT_WIDTH_INDEX
] = shift_bits
;
2140 sort_shift_bits
[FONT_SIZE_INDEX
] = shift_bits
;
2145 font_symbolic_weight (font
)
2148 Lisp_Object weight
= AREF (font
, FONT_WEIGHT_INDEX
);
2150 if (INTEGERP (weight
))
2151 weight
= prop_numeric_to_name (FONT_WEIGHT_INDEX
, XINT (weight
));
2156 font_symbolic_slant (font
)
2159 Lisp_Object slant
= AREF (font
, FONT_SLANT_INDEX
);
2161 if (INTEGERP (slant
))
2162 slant
= prop_numeric_to_name (FONT_SLANT_INDEX
, XINT (slant
));
2167 font_symbolic_width (font
)
2170 Lisp_Object width
= AREF (font
, FONT_WIDTH_INDEX
);
2172 if (INTEGERP (width
))
2173 width
= prop_numeric_to_name (FONT_WIDTH_INDEX
, XINT (width
));
2178 font_match_p (spec
, entity
)
2179 Lisp_Object spec
, entity
;
2183 for (i
= FONT_FOUNDRY_INDEX
; i
< FONT_SIZE_INDEX
; i
++)
2184 if (! NILP (AREF (spec
, i
))
2185 && ! EQ (AREF (spec
, i
), AREF (entity
, i
)))
2187 if (INTEGERP (AREF (spec
, FONT_SIZE_INDEX
))
2188 && XINT (AREF (entity
, FONT_SIZE_INDEX
)) > 0
2189 && (XINT (AREF (spec
, FONT_SIZE_INDEX
))
2190 != XINT (AREF (entity
, FONT_SIZE_INDEX
))))
2196 font_find_object (font
)
2199 Lisp_Object tail
, elt
;
2201 for (tail
= AREF (font
->entity
, FONT_OBJLIST_INDEX
); CONSP (tail
);
2205 if (font
== XSAVE_VALUE (elt
)->pointer
2206 && XSAVE_VALUE (elt
)->integer
> 0)
2213 static Lisp_Object scratch_font_spec
, scratch_font_prefer
;
2215 /* Return a vector of font-entities matching with SPEC on frame F. */
2218 font_list_entities (frame
, spec
)
2219 Lisp_Object frame
, spec
;
2221 FRAME_PTR f
= XFRAME (frame
);
2222 struct font_driver_list
*driver_list
= f
->font_driver_list
;
2223 Lisp_Object ftype
, family
, size
, alternate_familes
;
2224 Lisp_Object
*vec
= alloca (sizeof (Lisp_Object
) * num_font_drivers
);
2230 family
= AREF (spec
, FONT_FAMILY_INDEX
);
2232 alternate_familes
= Qnil
;
2235 if (NILP (font_family_alist
)
2236 && !NILP (Vface_alternative_font_family_alist
))
2237 build_font_family_alist ();
2238 alternate_familes
= assq_no_quit (family
, font_family_alist
);
2239 if (! NILP (alternate_familes
))
2240 alternate_familes
= XCDR (alternate_familes
);
2242 size
= AREF (spec
, FONT_SIZE_INDEX
);
2244 ASET (spec
, FONT_SIZE_INDEX
, make_number (font_pixel_size (f
, spec
)));
2246 xassert (ASIZE (spec
) == FONT_SPEC_MAX
);
2247 ftype
= AREF (spec
, FONT_TYPE_INDEX
);
2249 for (i
= 0; driver_list
; driver_list
= driver_list
->next
)
2250 if (NILP (ftype
) || EQ (driver_list
->driver
->type
, ftype
))
2252 Lisp_Object cache
= driver_list
->driver
->get_cache (frame
);
2253 Lisp_Object tail
= alternate_familes
;
2256 xassert (CONSP (cache
));
2257 ASET (spec
, FONT_TYPE_INDEX
, driver_list
->driver
->type
);
2258 ASET (spec
, FONT_FAMILY_INDEX
, family
);
2262 val
= assoc_no_quit (spec
, XCDR (cache
));
2267 val
= driver_list
->driver
->list (frame
, spec
);
2269 XSETCDR (cache
, Fcons (Fcons (Fcopy_sequence (spec
), val
),
2272 if (VECTORP (val
) && ASIZE (val
) > 0)
2279 ASET (spec
, FONT_FAMILY_INDEX
, XCAR (tail
));
2283 ASET (spec
, FONT_TYPE_INDEX
, ftype
);
2284 ASET (spec
, FONT_FAMILY_INDEX
, family
);
2285 ASET (spec
, FONT_SIZE_INDEX
, size
);
2286 return (i
> 0 ? Fvconcat (i
, vec
) : null_vector
);
2289 static int num_fonts
;
2292 font_open_entity (f
, entity
, pixel_size
)
2297 struct font_driver_list
*driver_list
;
2298 Lisp_Object objlist
, size
, val
;
2301 size
= AREF (entity
, FONT_SIZE_INDEX
);
2302 xassert (NATNUMP (size
));
2303 if (XINT (size
) != 0)
2304 pixel_size
= XINT (size
);
2306 for (objlist
= AREF (entity
, FONT_OBJLIST_INDEX
); CONSP (objlist
);
2307 objlist
= XCDR (objlist
))
2309 font
= XSAVE_VALUE (XCAR (objlist
))->pointer
;
2310 if (font
->pixel_size
== pixel_size
)
2312 XSAVE_VALUE (XCAR (objlist
))->integer
++;
2313 return XCAR (objlist
);
2317 xassert (FONT_ENTITY_P (entity
));
2318 val
= AREF (entity
, FONT_TYPE_INDEX
);
2319 for (driver_list
= f
->font_driver_list
;
2320 driver_list
&& ! EQ (driver_list
->driver
->type
, val
);
2321 driver_list
= driver_list
->next
);
2325 font
= driver_list
->driver
->open (f
, entity
, pixel_size
);
2328 val
= make_save_value (font
, 1);
2329 ASET (entity
, FONT_OBJLIST_INDEX
,
2330 Fcons (val
, AREF (entity
, FONT_OBJLIST_INDEX
)));
2336 font_close_object (f
, font_object
)
2338 Lisp_Object font_object
;
2340 struct font
*font
= XSAVE_VALUE (font_object
)->pointer
;
2341 Lisp_Object objlist
;
2342 Lisp_Object tail
, prev
= Qnil
;
2344 XSAVE_VALUE (font_object
)->integer
--;
2345 xassert (XSAVE_VALUE (font_object
)->integer
>= 0);
2346 if (XSAVE_VALUE (font_object
)->integer
> 0)
2349 objlist
= AREF (font
->entity
, FONT_OBJLIST_INDEX
);
2350 for (prev
= Qnil
, tail
= objlist
; CONSP (tail
);
2351 prev
= tail
, tail
= XCDR (tail
))
2352 if (EQ (font_object
, XCAR (tail
)))
2354 if (font
->driver
->close
)
2355 font
->driver
->close (f
, font
);
2356 XSAVE_VALUE (font_object
)->pointer
= NULL
;
2358 ASET (font
->entity
, FONT_OBJLIST_INDEX
, XCDR (objlist
));
2360 XSETCDR (prev
, XCDR (objlist
));
2367 font_has_char (f
, font
, c
)
2374 if (FONT_ENTITY_P (font
))
2376 Lisp_Object type
= AREF (font
, FONT_TYPE_INDEX
);
2377 struct font_driver_list
*driver_list
;
2379 for (driver_list
= f
->font_driver_list
;
2380 driver_list
&& ! EQ (driver_list
->driver
->type
, type
);
2381 driver_list
= driver_list
->next
);
2384 if (! driver_list
->driver
->has_char
)
2386 return driver_list
->driver
->has_char (font
, c
);
2389 xassert (FONT_OBJECT_P (font
));
2390 fontp
= XSAVE_VALUE (font
)->pointer
;
2392 if (fontp
->driver
->has_char
)
2394 int result
= fontp
->driver
->has_char (fontp
->entity
, c
);
2399 return (fontp
->driver
->encode_char (fontp
, c
) != FONT_INVALID_CODE
);
2403 font_encode_char (font_object
, c
)
2404 Lisp_Object font_object
;
2407 struct font
*font
= XSAVE_VALUE (font_object
)->pointer
;
2409 return font
->driver
->encode_char (font
, c
);
2413 font_get_name (font_object
)
2414 Lisp_Object font_object
;
2416 struct font
*font
= XSAVE_VALUE (font_object
)->pointer
;
2417 char *name
= (font
->font
.full_name
? font
->font
.full_name
2418 : font
->font
.name
? font
->font
.name
2421 return (name
? make_unibyte_string (name
, strlen (name
)) : null_string
);
2425 font_get_spec (font_object
)
2426 Lisp_Object font_object
;
2428 struct font
*font
= XSAVE_VALUE (font_object
)->pointer
;
2429 Lisp_Object spec
= Ffont_spec (0, NULL
);
2432 for (i
= 0; i
< FONT_SIZE_INDEX
; i
++)
2433 ASET (spec
, i
, AREF (font
->entity
, i
));
2434 ASET (spec
, FONT_SIZE_INDEX
, make_number (font
->pixel_size
));
2439 font_get_frame (font
)
2442 if (FONT_OBJECT_P (font
))
2443 font
= ((struct font
*) XSAVE_VALUE (font
)->pointer
)->entity
;
2444 xassert (FONT_ENTITY_P (font
));
2445 return AREF (font
, FONT_FRAME_INDEX
);
2448 /* Find a font entity best matching with LFACE. If SPEC is non-nil,
2449 the font must exactly match with it. */
2452 font_find_for_lface (f
, lface
, spec
)
2457 Lisp_Object frame
, entities
;
2460 XSETFRAME (frame
, f
);
2464 for (i
= 0; i
< FONT_SPEC_MAX
; i
++)
2465 ASET (scratch_font_spec
, i
, Qnil
);
2466 ASET (scratch_font_spec
, FONT_REGISTRY_INDEX
, Qiso8859_1
);
2468 if (! NILP (lface
[LFACE_FAMILY_INDEX
]))
2469 font_merge_old_spec (Qnil
, lface
[LFACE_FAMILY_INDEX
], Qnil
,
2471 entities
= font_list_entities (frame
, scratch_font_spec
);
2472 while (ASIZE (entities
) == 0)
2474 /* Try without FOUNDRY or FAMILY. */
2475 if (! NILP (AREF (scratch_font_spec
, FONT_FOUNDRY_INDEX
)))
2477 ASET (scratch_font_spec
, FONT_FOUNDRY_INDEX
, Qnil
);
2478 entities
= font_list_entities (frame
, scratch_font_spec
);
2480 else if (! NILP (AREF (scratch_font_spec
, FONT_FAMILY_INDEX
)))
2482 ASET (scratch_font_spec
, FONT_FAMILY_INDEX
, Qnil
);
2483 entities
= font_list_entities (frame
, scratch_font_spec
);
2491 for (i
= 0; i
< FONT_SPEC_MAX
; i
++)
2492 ASET (scratch_font_spec
, i
, AREF (spec
, i
));
2493 if (NILP (AREF (spec
, FONT_REGISTRY_INDEX
)))
2494 ASET (scratch_font_spec
, FONT_REGISTRY_INDEX
, Qiso8859_1
);
2495 entities
= font_list_entities (frame
, scratch_font_spec
);
2498 if (ASIZE (entities
) == 0)
2500 if (ASIZE (entities
) > 1)
2502 /* Sort fonts by properties specified in LFACE. */
2503 Lisp_Object prefer
= scratch_font_prefer
;
2506 if (! NILP (lface
[LFACE_FAMILY_INDEX
]))
2507 font_merge_old_spec (Qnil
, lface
[LFACE_FAMILY_INDEX
], Qnil
, prefer
);
2508 ASET (prefer
, FONT_WEIGHT_INDEX
,
2509 font_prop_validate_style (FONT_WEIGHT_INDEX
, QCweight
,
2510 lface
[LFACE_WEIGHT_INDEX
]));
2511 ASET (prefer
, FONT_SLANT_INDEX
,
2512 font_prop_validate_style (FONT_SLANT_INDEX
, QCslant
,
2513 lface
[LFACE_SLANT_INDEX
]));
2514 ASET (prefer
, FONT_WIDTH_INDEX
,
2515 font_prop_validate_style (FONT_WIDTH_INDEX
, QCwidth
,
2516 lface
[LFACE_SWIDTH_INDEX
]));
2517 pt
= XINT (lface
[LFACE_HEIGHT_INDEX
]);
2518 ASET (prefer
, FONT_SIZE_INDEX
, make_float (pt
/ 10));
2520 font_sort_entites (entities
, prefer
, frame
, spec
);
2523 return AREF (entities
, 0);
2527 font_open_for_lface (f
, lface
, entity
)
2532 double pt
= XINT (lface
[LFACE_HEIGHT_INDEX
]);
2536 size
= POINT_TO_PIXEL (pt
, f
->resy
);
2537 return font_open_entity (f
, entity
, size
);
2541 font_load_for_face (f
, face
)
2545 Lisp_Object font_object
= face
->lface
[LFACE_FONT_INDEX
];
2547 if (NILP (font_object
))
2549 Lisp_Object entity
= font_find_for_lface (f
, face
->lface
, Qnil
);
2551 if (! NILP (entity
))
2552 font_object
= font_open_for_lface (f
, face
->lface
, entity
);
2555 if (! NILP (font_object
))
2557 struct font
*font
= XSAVE_VALUE (font_object
)->pointer
;
2559 face
->font
= font
->font
.font
;
2560 face
->font_info
= (struct font_info
*) font
;
2561 face
->font_info_id
= 0;
2562 face
->font_name
= font
->font
.full_name
;
2567 face
->font_info
= NULL
;
2568 face
->font_info_id
= -1;
2569 face
->font_name
= NULL
;
2570 add_to_log ("Unable to load font for a face%s", null_string
, Qnil
);
2575 font_prepare_for_face (f
, face
)
2579 struct font
*font
= (struct font
*) face
->font_info
;
2581 if (font
->driver
->prepare_face
)
2582 font
->driver
->prepare_face (f
, face
);
2586 font_done_for_face (f
, face
)
2590 struct font
*font
= (struct font
*) face
->font_info
;
2592 if (font
->driver
->done_face
)
2593 font
->driver
->done_face (f
, face
);
2598 font_open_by_name (f
, name
)
2602 Lisp_Object args
[2];
2603 Lisp_Object spec
, prefer
, size
, entities
;
2608 XSETFRAME (frame
, f
);
2611 args
[1] = make_unibyte_string (name
, strlen (name
));
2612 spec
= Ffont_spec (2, args
);
2613 prefer
= scratch_font_prefer
;
2614 for (i
= FONT_WEIGHT_INDEX
; i
< FONT_SIZE_INDEX
; i
++)
2615 if (NILP (AREF (spec
, i
)))
2616 ASET (prefer
, i
, make_number (100));
2617 size
= AREF (spec
, FONT_SIZE_INDEX
);
2620 else if (INTEGERP (size
))
2621 pixel_size
= XINT (size
);
2622 else /* FLOATP (size) */
2624 double pt
= XFLOAT_DATA (size
);
2626 pixel_size
= POINT_TO_PIXEL (pt
, f
->resy
);
2627 size
= make_number (pixel_size
);
2628 ASET (spec
, FONT_SIZE_INDEX
, size
);
2630 if (pixel_size
== 0)
2632 pixel_size
= POINT_TO_PIXEL (12.0, f
->resy
);
2633 size
= make_number (pixel_size
);
2635 ASET (prefer
, FONT_SIZE_INDEX
, size
);
2636 if (NILP (AREF (spec
, FONT_REGISTRY_INDEX
)))
2637 ASET (spec
, FONT_REGISTRY_INDEX
, Qiso8859_1
);
2639 entities
= Flist_fonts (spec
, frame
, make_number (1), prefer
);
2640 return (NILP (entities
)
2642 : font_open_entity (f
, XCAR (entities
), pixel_size
));
2646 /* Register font-driver DRIVER. This function is used in two ways.
2648 The first is with frame F non-NULL. In this case, DRIVER is
2649 registered to be used for drawing characters on F. All frame
2650 creaters (e.g. Fx_create_frame) must call this function at least
2651 once with an available font-driver.
2653 The second is with frame F NULL. In this case, DRIVER is globally
2654 registered in the variable `font_driver_list'. All font-driver
2655 implementations must call this function in its syms_of_XXXX
2656 (e.g. syms_of_xfont). */
2659 register_font_driver (driver
, f
)
2660 struct font_driver
*driver
;
2663 struct font_driver_list
*root
= f
? f
->font_driver_list
: font_driver_list
;
2664 struct font_driver_list
*prev
, *list
;
2666 if (f
&& ! driver
->draw
)
2667 error ("Unsable font driver for a frame: %s",
2668 SDATA (SYMBOL_NAME (driver
->type
)));
2670 for (prev
= NULL
, list
= root
; list
; prev
= list
, list
= list
->next
)
2671 if (list
->driver
->type
== driver
->type
)
2672 error ("Duplicated font driver: %s", SDATA (SYMBOL_NAME (driver
->type
)));
2674 list
= malloc (sizeof (struct font_driver_list
));
2675 list
->driver
= driver
;
2680 f
->font_driver_list
= list
;
2682 font_driver_list
= list
;
2686 /* Free font-driver list on frame F. It doesn't free font-drivers
2690 free_font_driver_list (f
)
2693 while (f
->font_driver_list
)
2695 struct font_driver_list
*next
= f
->font_driver_list
->next
;
2697 free (f
->font_driver_list
);
2698 f
->font_driver_list
= next
;
2703 font_at (c
, pos
, face
, w
, object
)
2714 f
= XFRAME (w
->frame
);
2717 if (STRINGP (object
))
2718 face_id
= face_at_string_position (w
, object
, pos
, 0, -1, -1, &dummy
,
2719 DEFAULT_FACE_ID
, 0);
2721 face_id
= face_at_buffer_position (w
, pos
, -1, -1, &dummy
,
2723 face
= FACE_FROM_ID (f
, face_id
);
2725 face_id
= FACE_FOR_CHAR (f
, face
, c
, pos
, object
);
2726 face
= FACE_FROM_ID (f
, face_id
);
2727 if (! face
->font_info
)
2729 return font_lispy_object ((struct font
*) face
->font_info
);
2735 DEFUN ("fontp", Ffontp
, Sfontp
, 1, 1, 0,
2736 doc
: /* Return t if object is a font-spec or font-entity. */)
2740 return (FONTP (object
) ? Qt
: Qnil
);
2743 DEFUN ("font-spec", Ffont_spec
, Sfont_spec
, 0, MANY
, 0,
2744 doc
: /* Return a newly created font-spec with specified arguments as properties.
2745 usage: (font-spec &rest properties) */)
2750 Lisp_Object spec
= Fmake_vector (make_number (FONT_SPEC_MAX
), Qnil
);
2753 for (i
= 0; i
< nargs
; i
+= 2)
2755 enum font_property_index prop
;
2756 Lisp_Object key
= args
[i
], val
= args
[i
+ 1];
2758 prop
= get_font_prop_index (key
, 0);
2759 if (prop
< FONT_EXTRA_INDEX
)
2760 ASET (spec
, prop
, val
);
2763 if (EQ (key
, QCname
))
2766 font_parse_name ((char *) SDATA (val
), spec
);
2769 font_put_extra (spec
, key
, val
);
2772 CHECK_VALIDATE_FONT_SPEC (spec
);
2777 DEFUN ("font-get", Ffont_get
, Sfont_get
, 2, 2, 0,
2778 doc
: /* Return the value of FONT's PROP property.
2779 FONT may be a font-spec or font-entity.
2780 If FONT is font-entity and PROP is :extra, always nil is returned. */)
2782 Lisp_Object font
, prop
;
2784 enum font_property_index idx
;
2786 if (FONT_OBJECT_P (font
))
2787 font
= ((struct font
*) XSAVE_VALUE (font
)->pointer
)->entity
;
2790 idx
= get_font_prop_index (prop
, 0);
2791 if (idx
< FONT_EXTRA_INDEX
)
2792 return AREF (font
, idx
);
2793 if (FONT_ENTITY_P (font
))
2795 return Fcdr (Fassoc (AREF (font
, FONT_EXTRA_INDEX
), prop
));
2799 DEFUN ("font-put", Ffont_put
, Sfont_put
, 3, 3, 0,
2800 doc
: /* Set one property of FONT-SPEC: give property PROP value VALUE. */)
2801 (font_spec
, prop
, val
)
2802 Lisp_Object font_spec
, prop
, val
;
2804 enum font_property_index idx
;
2805 Lisp_Object extra
, slot
;
2807 CHECK_FONT_SPEC (font_spec
);
2808 idx
= get_font_prop_index (prop
, 0);
2809 if (idx
< FONT_EXTRA_INDEX
)
2810 return ASET (font_spec
, idx
, val
);
2811 extra
= AREF (font_spec
, FONT_EXTRA_INDEX
);
2812 slot
= Fassoc (extra
, prop
);
2814 extra
= Fcons (Fcons (prop
, val
), extra
);
2816 Fsetcdr (slot
, val
);
2820 DEFUN ("list-fonts", Flist_fonts
, Slist_fonts
, 1, 4, 0,
2821 doc
: /* List available fonts matching FONT-SPEC on the current frame.
2822 Optional 2nd argument FRAME specifies the target frame.
2823 Optional 3rd argument NUM, if non-nil, limits the number of returned fonts.
2824 Optional 4th argument PREFER, if non-nil, is a font-spec
2825 to which closeness fonts are sorted. */)
2826 (font_spec
, frame
, num
, prefer
)
2827 Lisp_Object font_spec
, frame
, num
, prefer
;
2829 Lisp_Object vec
, list
, tail
;
2833 frame
= selected_frame
;
2834 CHECK_LIVE_FRAME (frame
);
2835 CHECK_VALIDATE_FONT_SPEC (font_spec
);
2843 if (! NILP (prefer
))
2844 CHECK_FONT (prefer
);
2846 vec
= font_list_entities (frame
, font_spec
);
2851 return Fcons (AREF (vec
, 0), Qnil
);
2853 if (! NILP (prefer
))
2854 vec
= font_sort_entites (vec
, prefer
, frame
, font_spec
);
2856 list
= tail
= Fcons (AREF (vec
, 0), Qnil
);
2857 if (n
== 0 || n
> len
)
2859 for (i
= 1; i
< n
; i
++)
2861 Lisp_Object val
= Fcons (AREF (vec
, i
), Qnil
);
2863 XSETCDR (tail
, val
);
2869 DEFUN ("list-families", Flist_families
, Slist_families
, 0, 1, 0,
2870 doc
: /* List available font families on the current frame.
2871 Optional 2nd argument FRAME specifies the target frame. */)
2876 struct font_driver_list
*driver_list
;
2880 frame
= selected_frame
;
2881 CHECK_LIVE_FRAME (frame
);
2884 for (driver_list
= f
->font_driver_list
; driver_list
;
2885 driver_list
= driver_list
->next
)
2886 if (driver_list
->driver
->list_family
)
2888 Lisp_Object val
= driver_list
->driver
->list_family (frame
);
2894 Lisp_Object tail
= list
;
2896 for (; CONSP (val
); val
= XCDR (val
))
2897 if (NILP (Fmemq (XCAR (val
), tail
)))
2898 list
= Fcons (XCAR (val
), list
);
2904 DEFUN ("find-font", Ffind_font
, Sfind_font
, 1, 2, 0,
2905 doc
: /* Return a font-entity matching with FONT-SPEC on the current frame.
2906 Optional 2nd argument FRAME, if non-nil, specifies the target frame. */)
2908 Lisp_Object font_spec
, frame
;
2910 Lisp_Object val
= Flist_fonts (font_spec
, frame
, make_number (1), Qnil
);
2917 DEFUN ("font-xlfd-name", Ffont_xlfd_name
, Sfont_xlfd_name
, 1, 1, 0,
2918 doc
: /* Return XLFD name of FONT.
2919 FONT is a font-spec, font-entity, or font-object.
2920 If the name is too long for XLFD (maximum 255 chars), return nil. */)
2927 if (FONT_SPEC_P (font
))
2928 CHECK_VALIDATE_FONT_SPEC (font
);
2929 else if (FONT_ENTITY_P (font
))
2935 CHECK_FONT_GET_OBJECT (font
, fontp
);
2936 font
= fontp
->entity
;
2937 pixel_size
= fontp
->pixel_size
;
2940 if (font_unparse_xlfd (font
, pixel_size
, name
, 256) < 0)
2942 return build_string (name
);
2945 DEFUN ("clear-font-cache", Fclear_font_cache
, Sclear_font_cache
, 0, 0, 0,
2946 doc
: /* Clear font cache. */)
2949 Lisp_Object list
, frame
;
2951 FOR_EACH_FRAME (list
, frame
)
2953 FRAME_PTR f
= XFRAME (frame
);
2954 struct font_driver_list
*driver_list
= f
->font_driver_list
;
2956 for (; driver_list
; driver_list
= driver_list
->next
)
2958 Lisp_Object cache
= driver_list
->driver
->get_cache (frame
);
2959 Lisp_Object tail
, elt
;
2961 for (tail
= XCDR (cache
); CONSP (tail
); tail
= XCDR (tail
))
2964 if (CONSP (elt
) && FONT_SPEC_P (XCAR (elt
)))
2966 Lisp_Object vec
= XCDR (elt
);
2969 for (i
= 0; i
< ASIZE (vec
); i
++)
2971 Lisp_Object entity
= AREF (vec
, i
);
2972 Lisp_Object objlist
= AREF (entity
, FONT_OBJLIST_INDEX
);
2974 for (; CONSP (objlist
); objlist
= XCDR (objlist
))
2976 Lisp_Object val
= XCAR (objlist
);
2977 struct Lisp_Save_Value
*p
= XSAVE_VALUE (val
);
2978 struct font
*font
= p
->pointer
;
2981 && driver_list
->driver
== font
->driver
);
2982 driver_list
->driver
->close (f
, font
);
2986 if (driver_list
->driver
->free_entity
)
2987 driver_list
->driver
->free_entity (entity
);
2991 XSETCDR (cache
, Qnil
);
2998 DEFUN ("internal-set-font-style-table", Finternal_set_font_style_table
,
2999 Sinternal_set_font_style_table
, 2, 2, 0,
3000 doc
: /* Set font style table for PROP to TABLE.
3001 PROP must be `:weight', `:slant', or `:width'.
3002 TABLE must be an alist of symbols vs the corresponding numeric values
3003 sorted by numeric values. */)
3005 Lisp_Object prop
, table
;
3009 Lisp_Object tail
, val
;
3011 CHECK_SYMBOL (prop
);
3012 table_index
= (EQ (prop
, QCweight
) ? 0
3013 : EQ (prop
, QCslant
) ? 1
3014 : EQ (prop
, QCwidth
) ? 2
3016 if (table_index
>= ASIZE (font_style_table
))
3017 error ("Invalid font style property: %s", SDATA (SYMBOL_NAME (prop
)));
3018 table
= Fcopy_sequence (table
);
3020 for (tail
= table
; ! NILP (tail
); tail
= Fcdr (tail
))
3022 prop
= Fcar (Fcar (tail
));
3023 val
= Fcdr (Fcar (tail
));
3024 CHECK_SYMBOL (prop
);
3026 if (numeric
> XINT (val
))
3027 error ("Numeric values not sorted for %s", SDATA (SYMBOL_NAME (prop
)));
3028 numeric
= XINT (val
);
3029 XSETCAR (tail
, Fcons (prop
, val
));
3031 ASET (font_style_table
, table_index
, table
);
3035 DEFUN ("font-make-gstring", Ffont_make_gstring
, Sfont_make_gstring
, 2, 2, 0,
3036 doc
: /* Return a newly created glyph-string for FONT-OBJECT with NUM glyphs.
3037 FONT-OBJECT may be nil if it is not yet known. */)
3039 Lisp_Object font_object
, num
;
3041 Lisp_Object gstring
, g
;
3045 if (! NILP (font_object
))
3046 CHECK_FONT_OBJECT (font_object
);
3049 len
= XINT (num
) + 1;
3050 gstring
= Fmake_vector (make_number (len
), Qnil
);
3051 g
= Fmake_vector (make_number (6), Qnil
);
3052 ASET (g
, 0, font_object
);
3053 ASET (gstring
, 0, g
);
3054 for (i
= 1; i
< len
; i
++)
3055 ASET (gstring
, i
, Fmake_vector (make_number (8), Qnil
));
3059 DEFUN ("font-fill-gstring", Ffont_fill_gstring
, Sfont_fill_gstring
, 4, 5, 0,
3060 doc
: /* Fillin glyph-string GSTRING by characters for FONT-OBJECT.
3061 START and END specifies the region to extract characters.
3062 If optional 3rd argument OBJECT is non-nil, it is a buffer or a string from
3063 where to extract characters.
3064 FONT-OBJECT may be nil if GSTRING already already contains one. */)
3065 (gstring
, font_object
, start
, end
, object
)
3066 Lisp_Object gstring
, font_object
, start
, end
, object
;
3072 CHECK_VECTOR (gstring
);
3073 if (NILP (font_object
))
3074 font_object
= LGSTRING_FONT (gstring
);
3075 CHECK_FONT_GET_OBJECT (font_object
, font
);
3077 if (STRINGP (object
))
3079 const unsigned char *p
;
3081 CHECK_NATNUM (start
);
3083 if (XINT (start
) > XINT (end
)
3084 || XINT (end
) > ASIZE (object
)
3085 || XINT (end
) - XINT (start
) > LGSTRING_LENGTH (gstring
))
3086 args_out_of_range (start
, end
);
3088 len
= XINT (end
) - XINT (start
);
3089 p
= SDATA (object
) + string_char_to_byte (object
, XINT (start
));
3090 for (i
= 0; i
< len
; i
++)
3092 Lisp_Object g
= LGSTRING_GLYPH (gstring
, i
);
3094 c
= STRING_CHAR_ADVANCE (p
);
3095 code
= font
->driver
->encode_char (font
, c
);
3096 if (code
> MOST_POSITIVE_FIXNUM
)
3097 error ("Glyph code 0x%X is too large", code
);
3098 LGLYPH_SET_FROM (g
, make_number (i
));
3099 LGLYPH_SET_TO (g
, make_number (i
+ 1));
3100 LGLYPH_SET_CHAR (g
, make_number (c
));
3101 LGLYPH_SET_CODE (g
, make_number (code
));
3108 if (! NILP (object
))
3109 Fset_buffer (object
);
3110 validate_region (&start
, &end
);
3111 if (XINT (end
) - XINT (start
) > LGSTRING_LENGTH (gstring
))
3112 args_out_of_range (start
, end
);
3113 len
= XINT (end
) - XINT (start
);
3115 pos_byte
= CHAR_TO_BYTE (pos
);
3116 for (i
= 0; i
< len
; i
++)
3118 Lisp_Object g
= LGSTRING_GLYPH (gstring
, i
);
3120 FETCH_CHAR_ADVANCE (c
, pos
, pos_byte
);
3121 code
= font
->driver
->encode_char (font
, c
);
3122 if (code
> MOST_POSITIVE_FIXNUM
)
3123 error ("Glyph code 0x%X is too large", code
);
3124 LGLYPH_SET_FROM (g
, make_number (i
));
3125 LGLYPH_SET_TO (g
, make_number (i
+ 1));
3126 LGLYPH_SET_CHAR (g
, make_number (c
));
3127 LGLYPH_SET_CODE (g
, make_number (code
));
3130 for (i
= LGSTRING_LENGTH (gstring
) - 1; i
>= len
; i
--)
3132 Lisp_Object g
= LGSTRING_GLYPH (gstring
, i
);
3134 LGLYPH_SET_FROM (g
, Qnil
);
3142 DEFUN ("open-font", Fopen_font
, Sopen_font
, 1, 3, 0,
3143 doc
: /* Open FONT-ENTITY. */)
3144 (font_entity
, size
, frame
)
3145 Lisp_Object font_entity
;
3151 CHECK_FONT_ENTITY (font_entity
);
3153 size
= AREF (font_entity
, FONT_SIZE_INDEX
);
3154 CHECK_NUMBER (size
);
3156 frame
= selected_frame
;
3157 CHECK_LIVE_FRAME (frame
);
3159 isize
= XINT (size
);
3161 isize
= POINT_TO_PIXEL (- isize
, XFRAME (frame
)->resy
);
3163 return font_open_entity (XFRAME (frame
), font_entity
, isize
);
3166 DEFUN ("close-font", Fclose_font
, Sclose_font
, 1, 2, 0,
3167 doc
: /* Close FONT-OBJECT. */)
3168 (font_object
, frame
)
3169 Lisp_Object font_object
, frame
;
3171 CHECK_FONT_OBJECT (font_object
);
3173 frame
= selected_frame
;
3174 CHECK_LIVE_FRAME (frame
);
3175 font_close_object (XFRAME (frame
), font_object
);
3179 DEFUN ("query-font", Fquery_font
, Squery_font
, 1, 1, 0,
3180 doc
: /* Return information about FONT-OBJECT. */)
3182 Lisp_Object font_object
;
3187 CHECK_FONT_GET_OBJECT (font_object
, font
);
3189 val
= Fmake_vector (make_number (9), Qnil
);
3190 ASET (val
, 0, Ffont_xlfd_name (font_object
));
3191 if (font
->file_name
)
3192 ASET (val
, 1, make_unibyte_string (font
->file_name
,
3193 strlen (font
->file_name
)));
3194 ASET (val
, 2, make_number (font
->pixel_size
));
3195 ASET (val
, 3, make_number (font
->font
.size
));
3196 ASET (val
, 4, make_number (font
->ascent
));
3197 ASET (val
, 5, make_number (font
->descent
));
3198 ASET (val
, 6, make_number (font
->font
.space_width
));
3199 ASET (val
, 7, make_number (font
->font
.average_width
));
3200 if (font
->driver
->otf_capability
)
3201 ASET (val
, 8, font
->driver
->otf_capability (font
));
3205 DEFUN ("get-font-glyphs", Fget_font_glyphs
, Sget_font_glyphs
, 2, 2, 0,
3206 doc
: /* Return a vector of glyphs of FONT-OBJECT for drawing STRING.
3207 Each element is a vector [GLYPH-CODE LBEARING RBEARING WIDTH ASCENT DESCENT]. */)
3208 (font_object
, string
)
3209 Lisp_Object font_object
, string
;
3215 CHECK_FONT_GET_OBJECT (font_object
, font
);
3216 CHECK_STRING (string
);
3217 len
= SCHARS (string
);
3218 vec
= Fmake_vector (make_number (len
), Qnil
);
3219 for (i
= 0; i
< len
; i
++)
3221 Lisp_Object ch
= Faref (string
, make_number (i
));
3225 struct font_metrics metrics
;
3227 code
= font
->driver
->encode_char (font
, c
);
3228 if (code
== FONT_INVALID_CODE
)
3230 val
= Fmake_vector (make_number (6), Qnil
);
3231 if (code
<= MOST_POSITIVE_FIXNUM
)
3232 ASET (val
, 0, make_number (code
));
3234 ASET (val
, 0, Fcons (make_number (code
>> 16),
3235 make_number (code
& 0xFFFF)));
3236 font
->driver
->text_extents (font
, &code
, 1, &metrics
);
3237 ASET (val
, 1, make_number (metrics
.lbearing
));
3238 ASET (val
, 2, make_number (metrics
.rbearing
));
3239 ASET (val
, 3, make_number (metrics
.width
));
3240 ASET (val
, 4, make_number (metrics
.ascent
));
3241 ASET (val
, 5, make_number (metrics
.descent
));
3247 DEFUN ("font-match-p", Ffont_match_p
, Sfont_match_p
, 2, 2, 0,
3248 doc
: /* Return t iff font-spec SPEC matches with FONT.
3249 FONT is a font-spec, font-entity, or font-object. */)
3251 Lisp_Object spec
, font
;
3253 CHECK_FONT_SPEC (spec
);
3254 if (FONT_OBJECT_P (font
))
3255 font
= ((struct font
*) XSAVE_VALUE (font
)->pointer
)->entity
;
3256 else if (! FONT_ENTITY_P (font
))
3257 CHECK_FONT_SPEC (font
);
3259 return (font_match_p (spec
, font
) ? Qt
: Qnil
);
3262 DEFUN ("font-at", Ffont_at
, Sfont_at
, 1, 2, 0,
3263 doc
: /* Return a font-object for displaying a character at POSISTION.
3264 Optional second arg WINDOW, if non-nil, is a window displaying
3265 the current buffer. It defaults to the currently selected window. */)
3267 Lisp_Object position
, window
;
3270 EMACS_INT pos
, pos_byte
;
3273 CHECK_NUMBER_COERCE_MARKER (position
);
3274 pos
= XINT (position
);
3275 if (pos
< BEGV
|| pos
>= ZV
)
3276 args_out_of_range_3 (position
, make_number (BEGV
), make_number (ZV
));
3277 pos_byte
= CHAR_TO_BYTE (pos
);
3278 c
= FETCH_CHAR (pos_byte
);
3280 window
= selected_window
;
3281 CHECK_LIVE_WINDOW (window
);
3282 w
= XWINDOW (selected_window
);
3284 return font_at (c
, pos
, NULL
, w
, Qnil
);
3288 DEFUN ("draw-string", Fdraw_string
, Sdraw_string
, 2, 2, 0,
3289 doc
: /* Draw STRING by FONT-OBJECT on the top left corner of the current frame.
3290 The value is a number of glyphs drawn.
3291 Type C-l to recover what previously shown. */)
3292 (font_object
, string
)
3293 Lisp_Object font_object
, string
;
3295 Lisp_Object frame
= selected_frame
;
3296 FRAME_PTR f
= XFRAME (frame
);
3302 CHECK_FONT_GET_OBJECT (font_object
, font
);
3303 CHECK_STRING (string
);
3304 len
= SCHARS (string
);
3305 code
= alloca (sizeof (unsigned) * len
);
3306 for (i
= 0; i
< len
; i
++)
3308 Lisp_Object ch
= Faref (string
, make_number (i
));
3312 code
[i
] = font
->driver
->encode_char (font
, c
);
3313 if (code
[i
] == FONT_INVALID_CODE
)
3316 face
= FACE_FROM_ID (f
, DEFAULT_FACE_ID
);
3318 if (font
->driver
->prepare_face
)
3319 font
->driver
->prepare_face (f
, face
);
3320 width
= font
->driver
->text_extents (font
, code
, i
, NULL
);
3321 len
= font
->driver
->draw_text (f
, face
, 0, font
->ascent
, code
, i
, width
);
3322 if (font
->driver
->done_face
)
3323 font
->driver
->done_face (f
, face
);
3325 return make_number (len
);
3329 #endif /* FONT_DEBUG */
3332 extern void syms_of_ftfont
P_ (());
3333 extern void syms_of_xfont
P_ (());
3334 extern void syms_of_xftfont
P_ (());
3335 extern void syms_of_ftxfont
P_ (());
3336 extern void syms_of_bdffont
P_ (());
3337 extern void syms_of_w32font
P_ (());
3338 extern void syms_of_atmfont
P_ (());
3343 sort_shift_bits
[FONT_SLANT_INDEX
] = 0;
3344 sort_shift_bits
[FONT_WEIGHT_INDEX
] = 7;
3345 sort_shift_bits
[FONT_SIZE_INDEX
] = 14;
3346 sort_shift_bits
[FONT_WIDTH_INDEX
] = 21;
3347 sort_shift_bits
[FONT_ADSTYLE_INDEX
] = 28;
3348 sort_shift_bits
[FONT_FOUNDRY_INDEX
] = 29;
3349 sort_shift_bits
[FONT_FAMILY_INDEX
] = 30;
3350 sort_shift_bits
[FONT_REGISTRY_INDEX
] = 31;
3351 /* Note that sort_shift_bits[FONT_TYPE_INDEX] is never used. */
3353 staticpro (&font_style_table
);
3354 font_style_table
= Fmake_vector (make_number (3), Qnil
);
3356 staticpro (&font_family_alist
);
3357 font_family_alist
= Qnil
;
3359 DEFSYM (Qfontp
, "fontp");
3361 DEFSYM (Qiso8859_1
, "iso8859-1");
3362 DEFSYM (Qiso10646_1
, "iso10646-1");
3363 DEFSYM (Qunicode_bmp
, "unicode-bmp");
3365 DEFSYM (QCotf
, ":otf");
3366 DEFSYM (QClanguage
, ":language");
3367 DEFSYM (QCscript
, ":script");
3369 DEFSYM (QCfoundry
, ":foundry");
3370 DEFSYM (QCadstyle
, ":adstyle");
3371 DEFSYM (QCregistry
, ":registry");
3372 DEFSYM (QCspacing
, ":spacing");
3373 DEFSYM (QCdpi
, ":dpi");
3374 DEFSYM (QCscalable
, ":scalable");
3375 DEFSYM (QCextra
, ":extra");
3382 staticpro (&null_string
);
3383 null_string
= build_string ("");
3384 staticpro (&null_vector
);
3385 null_vector
= Fmake_vector (make_number (0), Qnil
);
3387 staticpro (&scratch_font_spec
);
3388 scratch_font_spec
= Ffont_spec (0, NULL
);
3389 staticpro (&scratch_font_prefer
);
3390 scratch_font_prefer
= Ffont_spec (0, NULL
);
3393 defsubr (&Sfont_spec
);
3394 defsubr (&Sfont_get
);
3395 defsubr (&Sfont_put
);
3396 defsubr (&Slist_fonts
);
3397 defsubr (&Slist_families
);
3398 defsubr (&Sfind_font
);
3399 defsubr (&Sfont_xlfd_name
);
3400 defsubr (&Sclear_font_cache
);
3401 defsubr (&Sinternal_set_font_style_table
);
3402 defsubr (&Sfont_make_gstring
);
3403 defsubr (&Sfont_fill_gstring
);
3406 defsubr (&Sopen_font
);
3407 defsubr (&Sclose_font
);
3408 defsubr (&Squery_font
);
3409 defsubr (&Sget_font_glyphs
);
3410 defsubr (&Sfont_match_p
);
3411 defsubr (&Sfont_at
);
3413 defsubr (&Sdraw_string
);
3415 #endif /* FONT_DEBUG */
3417 #ifdef HAVE_FREETYPE
3419 #ifdef HAVE_X_WINDOWS
3424 #endif /* HAVE_XFT */
3425 #endif /* HAVE_X_WINDOWS */
3426 #else /* not HAVE_FREETYPE */
3427 #ifdef HAVE_X_WINDOWS
3429 #endif /* HAVE_X_WINDOWS */
3430 #endif /* not HAVE_FREETYPE */
3433 #endif /* HAVE_BDFFONT */
3436 #endif /* WINDOWSNT */
3442 /* arch-tag: 74c9475d-5976-4c93-a327-942ae3072846
3443 (do not change this comment) */