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. */
32 #include "dispextern.h"
34 #include "character.h"
35 #include "composite.h"
43 #define xassert(X) do {if (!(X)) abort ();} while (0)
45 #define xassert(X) (void) 0
48 int enable_font_backend
;
52 /* Important character set symbols. */
53 Lisp_Object Qiso8859_1
, Qiso10646_1
, Qunicode_bmp
;
55 /* Like CHECK_FONT_SPEC but also validate properties of the font-spec,
56 and set X to the validated result. */
58 #define CHECK_VALIDATE_FONT_SPEC(x) \
60 if (! FONT_SPEC_P (x)) x = wrong_type_argument (Qfont, x); \
61 x = font_prop_validate (x); \
64 /* Number of pt per inch (from the TeXbook). */
65 #define PT_PER_INCH 72.27
67 /* Return a pixel size corresponding to POINT size (1/10 pt unit) on
69 #define POINT_TO_PIXEL(POINT, RESY) ((POINT) * (RESY) / PT_PER_INCH / 10 + 0.5)
71 #define PIXEL_TO_POINT(PIXEL, RESY) ((PIXEL) * PT_PER_INCH * 10 / (RESY) + 0.5)
73 /* Special string of zero length. It is used to specify a NULL name
74 in a font properties (e.g. adstyle). We don't use the symbol of
75 NULL name because it's confusing (Lisp printer prints nothing for
77 Lisp_Object null_string
;
79 /* Special vector of zero length. This is repeatedly used by (struct
80 font_driver *)->list when a specified font is not found. */
81 Lisp_Object null_vector
;
83 /* Vector of 3 elements. Each element is an alist for one of font
84 style properties (weight, slant, width). The alist contains a
85 mapping between symbolic property values (e.g. `medium' for weight)
86 and numeric property values (e.g. 100). So, it looks like this:
87 [((thin . 0) ... (heavy . 210))
88 ((ro . 0) ... (ot . 210))
89 ((ultracondensed . 50) ... (wide . 200))] */
90 static Lisp_Object font_style_table
;
92 /* Alist of font family vs the corresponding aliases.
93 Each element has this form:
94 (FAMILY ALIAS1 ALIAS2 ...) */
96 static Lisp_Object font_family_alist
;
98 /* Symbols representing keys of normal font properties. */
99 extern Lisp_Object QCtype
, QCfamily
, QCweight
, QCslant
, QCwidth
, QCsize
, QCname
;
100 Lisp_Object QCfoundry
, QCadstyle
, QCregistry
, QCextra
;
101 /* Symbols representing keys of font extra info. */
102 Lisp_Object QCotf
, QClanguage
, QCscript
;
104 /* List of all font drivers. All font-backends (XXXfont.c) call
105 add_font_driver in syms_of_XXXfont to register the font-driver
107 static struct font_driver_list
*font_driver_list
;
109 static Lisp_Object prop_name_to_numeric
P_ ((enum font_property_index
,
111 static Lisp_Object prop_numeric_to_name
P_ ((enum font_property_index
, int));
112 static Lisp_Object font_open_entity
P_ ((FRAME_PTR
, Lisp_Object
, int));
114 /* Number of registered font drivers. */
115 static int num_font_drivers
;
117 /* Return a numeric value corresponding to PROP's NAME (symbol). If
118 NAME is not registered in font_style_table, return Qnil. PROP must
119 be one of FONT_{WEIGHT|SLANT|SWIDTH}_INDEX. */
122 prop_name_to_numeric (prop
, name
)
123 enum font_property_index prop
;
126 int table_index
= prop
- FONT_WEIGHT_INDEX
;
129 val
= assq_no_quit (name
, AREF (font_style_table
, table_index
));
130 return (NILP (val
) ? Qnil
: XCDR (val
));
134 /* Return a name (symbol) corresponding to PROP's NUMERIC value. If
135 no name is registered for NUMERIC in font_style_table, return a
136 symbol of integer name (e.g. `123'). PROP must be one of
137 FONT_{WEIGHT|SLANT|SWIDTH}_INDEX. */
140 prop_numeric_to_name (prop
, numeric
)
141 enum font_property_index prop
;
144 int table_index
= prop
- FONT_WEIGHT_INDEX
;
145 Lisp_Object table
= AREF (font_style_table
, table_index
);
148 while (! NILP (table
))
150 if (XINT (XCDR (XCAR (table
))) >= numeric
)
152 if (XINT (XCDR (XCAR (table
))) == numeric
)
153 return XCAR (XCAR (table
));
157 table
= XCDR (table
);
159 sprintf (buf
, "%d", numeric
);
164 /* Return a symbol whose name is STR (length LEN). If STR contains
165 uppercase letters, downcase them in advance. */
168 intern_downcase (str
, len
)
175 for (i
= 0; i
< len
; i
++)
176 if (isupper (str
[i
]))
179 return Fintern (make_unibyte_string (str
, len
), Qnil
);
182 return Fintern (null_string
, Qnil
);
183 bcopy (str
, buf
, len
);
185 if (isascii (buf
[i
]))
186 buf
[i
] = tolower (buf
[i
]);
187 return Fintern (make_unibyte_string (buf
, len
), Qnil
);
190 extern Lisp_Object Vface_alternative_font_family_alist
;
193 build_font_family_alist ()
195 Lisp_Object alist
= Vface_alternative_font_family_alist
;
197 for (; CONSP (alist
); alist
= XCDR (alist
))
199 Lisp_Object tail
, elt
;
201 for (tail
= XCAR (alist
), elt
= Qnil
; CONSP (tail
); tail
= XCDR (tail
))
202 elt
= nconc2 (elt
, Fcons (Fintern (XCAR (tail
), Qnil
), Qnil
));
203 font_family_alist
= Fcons (elt
, font_family_alist
);
208 /* Font property validater. */
211 font_prop_validate_type (prop
, val
)
212 enum font_property_index prop
;
215 return (SYMBOLP (val
) ? val
: Qerror
);
219 font_prop_validate_symbol (prop
, val
)
220 enum font_property_index prop
;
224 val
= (SCHARS (val
) == 0 ? null_string
225 : intern_downcase ((char *) SDATA (val
), SBYTES (val
)));
226 else if (SYMBOLP (val
))
228 if (SCHARS (SYMBOL_NAME (val
)) == 0)
237 font_prop_validate_style (prop
, val
)
238 enum font_property_index prop
;
241 if (! INTEGERP (val
))
244 val
= intern_downcase ((char *) SDATA (val
), SBYTES (val
));
249 val
= prop_name_to_numeric (prop
, val
);
258 font_prop_validate_size (prop
, val
)
259 enum font_property_index prop
;
262 return (NATNUMP (val
) || (FLOATP (val
) && XFLOAT_DATA (val
) >= 0)
267 font_prop_validate_extra (prop
, val
)
268 enum font_property_index prop
;
273 for (tail
= val
; CONSP (tail
); tail
= XCDR (tail
))
275 Lisp_Object key
= Fcar (XCAR (tail
)), this_val
= Fcdr (XCAR (tail
));
279 if (EQ (key
, QClanguage
))
280 if (! SYMBOLP (this_val
))
282 for (; CONSP (this_val
); this_val
= XCDR (this_val
))
283 if (! SYMBOLP (XCAR (this_val
)))
285 if (! NILP (this_val
))
289 if (! STRINGP (this_val
))
292 return (NILP (tail
) ? val
: Qerror
);
299 Lisp_Object (*validater
) P_ ((enum font_property_index prop
,
301 } font_property_table
[FONT_SPEC_MAX
] =
302 { { &QCtype
, font_prop_validate_type
},
303 { &QCfoundry
, font_prop_validate_symbol
},
304 { &QCfamily
, font_prop_validate_symbol
},
305 { &QCadstyle
, font_prop_validate_symbol
},
306 { &QCregistry
, font_prop_validate_symbol
},
307 { &QCweight
, font_prop_validate_style
},
308 { &QCslant
, font_prop_validate_style
},
309 { &QCwidth
, font_prop_validate_style
},
310 { &QCsize
, font_prop_validate_size
},
311 { &QCextra
, font_prop_validate_extra
}
314 static enum font_property_index
315 check_font_prop_name (key
)
318 enum font_property_index i
;
320 for (i
= FONT_TYPE_INDEX
; i
< FONT_SPEC_MAX
; i
++)
321 if (EQ (key
, *font_property_table
[i
].key
))
327 font_prop_validate (spec
)
330 enum font_property_index i
;
333 for (i
= FONT_TYPE_INDEX
; i
<= FONT_EXTRA_INDEX
; i
++)
335 if (! NILP (AREF (spec
, i
)))
337 val
= (font_property_table
[i
].validater
) (i
, AREF (spec
, i
));
338 if (EQ (val
, Qerror
))
339 Fsignal (Qerror
, list3 (build_string ("invalid font property"),
340 *font_property_table
[i
].key
,
349 /* Font name parser and unparser */
351 /* An enumerator for each field of an XLFD font name. */
353 enum xlfd_field_index
374 XLFD_FOUNDRY_MASK
= 0x0001,
375 XLFD_FAMILY_MASK
= 0x0002,
376 XLFD_WEIGHT_MASK
= 0x0004,
377 XLFD_SLANT_MASK
= 0x0008,
378 XLFD_SWIDTH_MASK
= 0x0010,
379 XLFD_ADSTYLE_MASK
= 0x0020,
380 XLFD_PIXEL_MASK
= 0x0040,
381 XLFD_POINT_MASK
= 0x0080,
382 XLFD_RESX_MASK
= 0x0100,
383 XLFD_RESY_MASK
= 0x0200,
384 XLFD_SPACING_MASK
= 0x0400,
385 XLFD_AVGWIDTH_MASK
= 0x0800,
386 XLFD_REGISTRY_MASK
= 0x1000,
387 XLFD_ENCODING_MASK
= 0x2000
391 /* Return a Lispy value for string at STR and bytes LEN.
392 If LEN == 0, return a null string.
393 If the string is "*", return Qnil.
394 It is assured that LEN < 256. */
397 intern_font_field (str
, len
)
405 if (*str
== '*' && len
== 1)
409 for (i
= 1; i
< len
; i
++)
410 if (! isdigit (str
[i
]))
413 return make_number (atoi (str
));
415 return intern_downcase (str
, len
);
418 /* Parse P pointing the pixel/point size field of the form
419 `[A B C D]' which specifies a transformation matrix:
425 by which all glyphs of the font are transformed. The spec says
426 that scalar value N for the pixel/point size is equivalent to:
427 A = N * resx/resy, B = C = 0, D = N.
429 Return the scalar value N if the form is valid. Otherwise return
440 for (i
= 0, p
++; i
< 4 && *p
&& *p
!= ']'; i
++)
443 matrix
[i
] = - strtod (p
+ 1, &end
);
445 matrix
[i
] = strtod (p
, &end
);
448 return (i
== 4 ? (int) matrix
[3] : -1);
451 /* Expand a wildcard field in FIELD (the first N fields are filled) to
452 multiple fields to fill in all 14 XLFD fields while restring a
453 field position by its contents. */
456 font_expand_wildcards (field
, n
)
457 Lisp_Object field
[XLFD_LAST_INDEX
];
461 Lisp_Object tmp
[XLFD_LAST_INDEX
];
462 /* Array of information about where this element can go. Nth
463 element is for Nth element of FIELD. */
465 /* Minimum possible field. */
467 /* Maxinum possible field. */
469 /* Bit mask of possible field. Nth bit corresponds to Nth field. */
471 } range
[XLFD_LAST_INDEX
];
475 #define XLFD_SYMBOL_MASK (XLFD_FOUNDRY_MASK | XLFD_FAMILY_MASK \
476 | XLFD_ADSTYLE_MASK | XLFD_REGISTRY_MASK)
477 #define XLFD_NULL_MASK (XLFD_FOUNDRY_MASK | XLFD_ADSTYLE_MASK)
478 #define XLFD_SMALLNUM_MASK (XLFD_PIXEL_MASK | XLFD_ENCODING_MASK)
479 #define XLFD_LARGENUM_MASK (XLFD_POINT_MASK | XLFD_RESX_MASK | XLFD_RESY_MASK \
480 | XLFD_AVGWIDTH_MASK | XLFD_ENCODING_MASK)
481 #define XLFD_REGENC_MASK (XLFD_REGISTRY_MASK | XLFD_ENCODING_MASK)
483 /* Initialize RANGE_MASK for FIELD[0] which can be 0th to (14 - N)th
484 field. The value is shifted to left one bit by one in the
486 for (i
= 0, range_mask
= 0; i
<= 14 - n
; i
++)
487 range_mask
= (range_mask
<< 1) | 1;
489 for (i
= 0; i
< n
; i
++, range_mask
<<= 1)
491 /* The triplet RANGE_FROM, RANGE_TO, and RANGE_MASK is a
492 position-based retriction for FIELD[I]. */
493 int range_from
= i
, range_to
= 14 - n
+ i
;
494 Lisp_Object val
= field
[i
];
500 range
[i
].from
= range_from
;
501 range
[i
].to
= range_to
;
502 range
[i
].mask
= range_mask
;
506 /* The triplet FROM, TO, and MASK is a value-based
507 retriction for FIELD[I]. */
513 int numeric
= XINT (val
);
516 from
= XLFD_PIXEL_INDEX
, to
= XLFD_ENCODING_INDEX
,
517 mask
= XLFD_SMALLNUM_MASK
;
519 from
= XLFD_POINT_INDEX
, to
= XLFD_ENCODING_INDEX
,
520 mask
= XLFD_LARGENUM_MASK
;
522 else if (EQ (val
, null_string
))
523 from
= XLFD_FOUNDRY_INDEX
, to
= XLFD_ADSTYLE_INDEX
,
524 mask
= XLFD_NULL_MASK
;
526 from
= to
= XLFD_FOUNDRY_INDEX
, mask
= XLFD_FOUNDRY_MASK
;
529 Lisp_Object name
= SYMBOL_NAME (val
);
531 if (SDATA (name
)[SBYTES (name
) - 1] == '*')
532 from
= XLFD_REGISTRY_INDEX
, to
= XLFD_ENCODING_INDEX
,
533 mask
= XLFD_REGENC_MASK
;
535 from
= to
= XLFD_ENCODING_INDEX
,
536 mask
= XLFD_ENCODING_MASK
;
538 else if (!NILP (prop_name_to_numeric (FONT_WEIGHT_INDEX
, val
)))
539 from
= to
= XLFD_WEIGHT_INDEX
, mask
= XLFD_WEIGHT_MASK
;
540 else if (!NILP (prop_name_to_numeric (FONT_SLANT_INDEX
, val
)))
541 from
= to
= XLFD_SLANT_INDEX
, mask
= XLFD_SLANT_MASK
;
542 else if (!NILP (prop_name_to_numeric (FONT_WIDTH_INDEX
, val
)))
543 from
= to
= XLFD_SWIDTH_INDEX
, mask
= XLFD_SWIDTH_MASK
;
546 Lisp_Object name
= SYMBOL_NAME (val
);
548 if (SBYTES (name
) == 1
549 && (SDATA (name
)[0] == 'c'
550 || SDATA (name
)[0] == 'm'
551 || SDATA (name
)[0] == 'p'))
552 from
= to
= XLFD_SPACING_INDEX
, mask
= XLFD_SPACING_MASK
;
554 from
= XLFD_FOUNDRY_INDEX
, to
= XLFD_ENCODING_INDEX
,
555 mask
= XLFD_SYMBOL_MASK
;
558 /* Merge position-based and value-based restrictions. */
560 while (from
< range_from
)
561 mask
&= ~(1 << from
++);
562 while (from
< 14 && ! (mask
& (1 << from
)))
564 while (to
> range_to
)
565 mask
&= ~(1 << to
--);
566 while (to
>= 0 && ! (mask
& (1 << to
)))
570 range
[i
].from
= from
;
572 range
[i
].mask
= mask
;
574 if (from
> range_from
|| to
< range_to
)
575 /* The range is narrowed by value-based restrictions.
576 Reflect it to the previous fields. */
577 for (j
= i
- 1, from
--, to
--; j
>= 0; j
--, from
--, to
--)
579 /* Check FROM for non-wildcard field. */
580 if (! NILP (tmp
[j
]) && range
[j
].from
< from
)
582 while (range
[j
].from
< from
)
583 range
[j
].mask
&= ~(1 << range
[j
].from
++);
584 while (from
< 14 && ! (range
[j
].mask
& (1 << from
)))
586 range
[j
].from
= from
;
589 from
= range
[j
].from
;
590 if (range
[j
].to
> to
)
592 while (range
[j
].to
> to
)
593 range
[j
].mask
&= ~(1 << range
[j
].to
--);
594 while (to
>= 0 && ! (range
[j
].mask
& (1 << to
)))
606 /* Decide all fileds from restrictions in RANGE. */
607 for (i
= j
= 0; i
< n
; i
++)
609 if (j
< range
[i
].from
)
611 if (i
== 0 || ! NILP (tmp
[i
- 1]))
612 /* None of TMP[X] corresponds to Jth field. */
614 for (; j
< range
[i
].from
; j
++)
619 if (! NILP (tmp
[n
- 1]) && j
< XLFD_REGISTRY_INDEX
)
621 for (; j
< XLFD_LAST_INDEX
; j
++)
623 if (INTEGERP (field
[XLFD_ENCODING_INDEX
]))
624 field
[XLFD_ENCODING_INDEX
]
625 = Fintern (Fnumber_to_string (field
[XLFD_ENCODING_INDEX
]), Qnil
);
629 /* Parse NAME (null terminated) as XLFD format, and store information
630 in FONT (font-spec or font-entity). If NAME is successfully
631 parsed, return 2 (non-scalable font), 1 (scalable vector font), or
632 0 (auto-scaled font). Otherwise return -1.
634 If FONT is a font-entity, store RESY-SPACING-AVWIDTH information as
635 a symbol in FONT_EXTRA_INDEX.
637 If MERGE is nonzero, set a property of FONT only when it's nil. */
640 font_parse_xlfd (name
, font
, merge
)
645 int len
= strlen (name
);
647 int pixel_size
, resy
, avgwidth
;
649 Lisp_Object f
[XLFD_LAST_INDEX
];
654 /* Maximum XLFD name length is 255. */
656 i
= (name
[0] == '*' && name
[1] == '-');
657 for (p
= name
+ 1; *p
; p
++)
662 if (i
== XLFD_ENCODING_INDEX
)
667 pixel_size
= resy
= avgwidth
= -1;
670 if (i
== XLFD_ENCODING_INDEX
)
672 /* Fully specified XLFD. */
675 for (i
= 0, p
= name
; ; p
++)
679 if (i
< XLFD_PIXEL_INDEX
)
680 f
[i
++] = intern_font_field (name
, p
- name
);
681 else if (i
== XLFD_PIXEL_INDEX
)
684 pixel_size
= atoi (name
);
685 else if (*name
== '[')
686 pixel_size
= parse_matrix (name
);
689 else if (i
== XLFD_POINT_INDEX
)
694 point_size
= atoi (name
);
695 else if (*name
== '[')
696 point_size
= parse_matrix (name
);
700 else if (i
== XLFD_RESX_INDEX
)
702 /* Skip this field. */
705 else if (i
== XLFD_RESY_INDEX
)
707 /* Stuff RESY, SPACING, and AVGWIDTH. */
708 if (pixel_size
< 0 && isdigit (*name
))
710 for (p
++; *p
!= '-'; p
++);
712 avgwidth
= atoi (p
+ 1);
713 else if (p
[1] == '~' && isdigit (p
[2]))
714 avgwidth
= atoi (p
+ 2);
715 for (p
++; *p
!= '-'; p
++);
716 if (FONT_ENTITY_P (font
))
717 f
[i
] = intern_font_field (name
, p
- name
);
720 i
= XLFD_REGISTRY_INDEX
;
724 /* Stuff REGISTRY and ENCODING. */
726 f
[i
++] = intern_font_field (name
, p
- name
);
732 xassert (i
== XLFD_ENCODING_INDEX
);
736 int wild_card_found
= 0;
740 for (i
= 0, p
= name
; ; p
++)
742 if (*p
== '-' || ! *p
)
751 else if (isdigit (*name
))
753 f
[i
++] = make_number (atoi (name
));
754 /* Check if all chars in this field is number. */
756 while (isdigit (*name
)) name
++;
761 f
[i
++] = null_string
;
764 f
[i
++] = intern_downcase (name
, p
- name
);
771 if (! wild_card_found
)
773 if (font_expand_wildcards (f
, i
) < 0)
775 if (! NILP (f
[XLFD_PIXEL_INDEX
]))
776 pixel_size
= XINT (f
[XLFD_PIXEL_INDEX
]);
777 if (! NILP (f
[XLFD_POINT_INDEX
]))
778 point_size
= XINT (f
[XLFD_POINT_INDEX
]);
779 if (! NILP (f
[XLFD_RESY_INDEX
]))
780 resy
= XINT (f
[XLFD_RESY_INDEX
]);
781 if (! NILP (f
[XLFD_AVGWIDTH_INDEX
]))
782 avgwidth
= XINT (f
[XLFD_AVGWIDTH_INDEX
]);
783 if (NILP (f
[XLFD_REGISTRY_INDEX
]))
785 if (! NILP (f
[XLFD_ENCODING_INDEX
]))
786 f
[XLFD_REGISTRY_INDEX
]
787 = Fintern (concat2 (build_string ("*-"),
788 SYMBOL_NAME (f
[XLFD_ENCODING_INDEX
])), Qnil
);
792 if (! NILP (f
[XLFD_ENCODING_INDEX
]))
793 f
[XLFD_REGISTRY_INDEX
]
794 = Fintern (concat2 (SYMBOL_NAME (f
[XLFD_REGISTRY_INDEX
]),
795 SYMBOL_NAME (f
[XLFD_ENCODING_INDEX
])), Qnil
);
799 if (! merge
|| NILP (AREF (font
, FONT_FOUNDRY_INDEX
)))
800 ASET (font
, FONT_FOUNDRY_INDEX
, f
[XLFD_FOUNDRY_INDEX
]);
801 if (! merge
|| NILP (AREF (font
, FONT_FAMILY_INDEX
)))
802 ASET (font
, FONT_FAMILY_INDEX
, f
[XLFD_FAMILY_INDEX
]);
803 if (! merge
|| NILP (AREF (font
, FONT_ADSTYLE_INDEX
)))
804 ASET (font
, FONT_ADSTYLE_INDEX
, f
[XLFD_ADSTYLE_INDEX
]);
805 if (! merge
|| NILP (AREF (font
, FONT_REGISTRY_INDEX
)))
806 ASET (font
, FONT_REGISTRY_INDEX
, f
[XLFD_REGISTRY_INDEX
]);
808 for (i
= FONT_WEIGHT_INDEX
, j
= XLFD_WEIGHT_INDEX
;
809 j
<= XLFD_SWIDTH_INDEX
; i
++, j
++)
810 if (! merge
|| NILP (AREF (font
, i
)))
812 if (! INTEGERP (f
[j
]))
814 val
= prop_name_to_numeric (i
, f
[j
]);
818 ASET (font
, i
, f
[j
]);
821 if (pixel_size
< 0 && FONT_ENTITY_P (font
))
824 if (! merge
|| NILP (AREF (font
, FONT_SIZE_INDEX
)))
827 ASET (font
, FONT_SIZE_INDEX
, make_number (pixel_size
));
828 else if (point_size
>= 0)
832 pixel_size
= POINT_TO_PIXEL (point_size
, resy
);
833 ASET (font
, FONT_SIZE_INDEX
, make_number (pixel_size
));
837 ASET (font
, FONT_SIZE_INDEX
, make_float (point_size
/ 10));
842 if (FONT_ENTITY_P (font
)
843 && EQ (AREF (font
, FONT_TYPE_INDEX
), Qx
))
844 ASET (font
, FONT_EXTRA_INDEX
, f
[XLFD_RESY_INDEX
]);
846 return (avgwidth
> 0 ? 2 : resy
== 0);
849 /* Store XLFD name of FONT (font-spec or font-entity) in NAME (NBYTES
850 length), and return the name length. If FONT_SIZE_INDEX of FONT is
851 0, use PIXEL_SIZE instead. */
854 font_unparse_xlfd (font
, pixel_size
, name
, nbytes
)
860 char *f
[XLFD_REGISTRY_INDEX
+ 1], *pixel_point
;
865 xassert (FONTP (font
));
867 for (i
= FONT_FOUNDRY_INDEX
, j
= XLFD_FOUNDRY_INDEX
; i
<= FONT_REGISTRY_INDEX
;
870 if (i
== FONT_ADSTYLE_INDEX
)
871 j
= XLFD_ADSTYLE_INDEX
;
872 else if (i
== FONT_REGISTRY_INDEX
)
873 j
= XLFD_REGISTRY_INDEX
;
874 val
= AREF (font
, i
);
877 if (j
== XLFD_REGISTRY_INDEX
)
878 f
[j
] = "*-*", len
+= 4;
880 f
[j
] = "*", len
+= 2;
885 val
= SYMBOL_NAME (val
);
886 if (j
== XLFD_REGISTRY_INDEX
887 && ! strchr ((char *) SDATA (val
), '-'))
889 /* Change "jisx0208*" and "jisx0208" to "jisx0208*-*". */
890 if (SDATA (val
)[SBYTES (val
) - 1] == '*')
892 f
[j
] = alloca (SBYTES (val
) + 3);
893 sprintf (f
[j
], "%s-*", SDATA (val
));
894 len
+= SBYTES (val
) + 3;
898 f
[j
] = alloca (SBYTES (val
) + 4);
899 sprintf (f
[j
], "%s*-*", SDATA (val
));
900 len
+= SBYTES (val
) + 4;
904 f
[j
] = (char *) SDATA (val
), len
+= SBYTES (val
) + 1;
908 for (i
= FONT_WEIGHT_INDEX
, j
= XLFD_WEIGHT_INDEX
; i
<= FONT_WIDTH_INDEX
;
911 val
= AREF (font
, i
);
913 f
[j
] = "*", len
+= 2;
917 val
= prop_numeric_to_name (i
, XINT (val
));
919 val
= SYMBOL_NAME (val
);
920 xassert (STRINGP (val
));
921 f
[j
] = (char *) SDATA (val
), len
+= SBYTES (val
) + 1;
925 val
= AREF (font
, FONT_SIZE_INDEX
);
926 xassert (NUMBERP (val
) || NILP (val
));
931 len
+= sprintf (work
, "%d", i
) + 1;
933 len
+= sprintf (work
, "%d-*", pixel_size
) + 1;
936 else if (FLOATP (val
))
938 i
= XFLOAT_DATA (val
) * 10;
939 len
+= sprintf (work
, "*-%d", i
) + 1;
943 pixel_point
= "*-*", len
+= 4;
945 if (FONT_ENTITY_P (font
)
946 && EQ (AREF (font
, FONT_TYPE_INDEX
), Qx
))
948 /* Setup names for RESY-SPACING-AVWIDTH. */
949 val
= AREF (font
, FONT_EXTRA_INDEX
);
950 if (SYMBOLP (val
) && ! NILP (val
))
952 val
= SYMBOL_NAME (val
);
953 f
[XLFD_RESY_INDEX
] = (char *) SDATA (val
), len
+= SBYTES (val
) + 1;
956 f
[XLFD_RESY_INDEX
] = "*-*-*", len
+= 6;
959 f
[XLFD_RESY_INDEX
] = "*-*-*", len
+= 6;
961 len
+= 3; /* for "-*" of resx, and terminating '\0'. */
964 return sprintf (name
, "-%s-%s-%s-%s-%s-%s-%s-*-%s-%s",
965 f
[XLFD_FOUNDRY_INDEX
], f
[XLFD_FAMILY_INDEX
],
966 f
[XLFD_WEIGHT_INDEX
], f
[XLFD_SLANT_INDEX
],
967 f
[XLFD_SWIDTH_INDEX
],
968 f
[XLFD_ADSTYLE_INDEX
], pixel_point
,
969 f
[XLFD_RESY_INDEX
], f
[XLFD_REGISTRY_INDEX
]);
973 font_merge_old_spec (name
, family
, registry
, spec
)
974 Lisp_Object name
, family
, registry
, spec
;
978 if (font_parse_xlfd ((char *) SDATA (name
), spec
, 1) < 0)
980 Lisp_Object extra
= Fcons (Fcons (QCname
, name
), Qnil
);
982 ASET (spec
, FONT_EXTRA_INDEX
, extra
);
992 xassert (STRINGP (family
));
993 len
= SBYTES (family
);
994 p0
= (char *) SDATA (family
);
995 p1
= index (p0
, '-');
998 if (NILP (AREF (spec
, FONT_FOUNDRY_INDEX
)))
999 ASET (spec
, FONT_FOUNDRY_INDEX
,
1000 intern_downcase (p0
, p1
- p0
));
1001 if (NILP (AREF (spec
, FONT_FAMILY_INDEX
)))
1002 ASET (spec
, FONT_FAMILY_INDEX
,
1003 intern_downcase (p1
+ 1, len
- (p1
+ 1 - p0
)));
1005 else if (NILP (AREF (spec
, FONT_FAMILY_INDEX
)))
1006 ASET (spec
, FONT_FAMILY_INDEX
, intern_downcase (p0
, len
));
1008 if (! NILP (registry
)
1009 && NILP (AREF (spec
, FONT_REGISTRY_INDEX
)))
1010 ASET (spec
, FONT_REGISTRY_INDEX
,
1011 intern_downcase ((char *) SDATA (registry
), SBYTES (registry
)));
1025 struct otf_list
*next
;
1028 static struct otf_list
*otf_list
;
1031 otf_tag_symbol (tag
)
1036 OTF_tag_name (tag
, name
);
1037 return Fintern (make_unibyte_string (name
, 4), Qnil
);
1041 otf_open (entity
, file
)
1045 struct otf_list
*list
= otf_list
;
1047 while (list
&& ! EQ (list
->entity
, entity
))
1051 list
= malloc (sizeof (struct otf_list
));
1052 list
->entity
= entity
;
1053 list
->otf
= file
? OTF_open (file
) : NULL
;
1054 list
->next
= otf_list
;
1061 /* Return a list describing which scripts/languages FONT supports by
1062 which GSUB/GPOS features of OpenType tables. See the comment of
1063 (sturct font_driver).otf_capability. */
1066 font_otf_capability (font
)
1070 Lisp_Object capability
= Fcons (Qnil
, Qnil
);
1073 otf
= otf_open (font
->entity
, font
->file_name
);
1076 for (i
= 0; i
< 2; i
++)
1078 OTF_GSUB_GPOS
*gsub_gpos
;
1079 Lisp_Object script_list
= Qnil
;
1082 if (OTF_get_features (otf
, i
== 0) < 0)
1084 gsub_gpos
= i
== 0 ? otf
->gsub
: otf
->gpos
;
1085 for (j
= gsub_gpos
->ScriptList
.ScriptCount
- 1; j
>= 0; j
--)
1087 OTF_Script
*script
= gsub_gpos
->ScriptList
.Script
+ j
;
1088 Lisp_Object langsys_list
= Qnil
;
1089 Lisp_Object script_tag
= otf_tag_symbol (script
->ScriptTag
);
1092 for (k
= script
->LangSysCount
; k
>= 0; k
--)
1094 OTF_LangSys
*langsys
;
1095 Lisp_Object feature_list
= Qnil
;
1096 Lisp_Object langsys_tag
;
1099 if (j
== script
->LangSysCount
)
1101 langsys
= &script
->DefaultLangSys
;
1106 langsys
= script
->LangSys
+ k
;
1108 = otf_tag_symbol (script
->LangSysRecord
[k
].LangSysTag
);
1110 for (l
= langsys
->FeatureCount
-1; l
>= 0; l
--)
1112 OTF_Feature
*feature
1113 = gsub_gpos
->FeatureList
.Feature
+ langsys
->FeatureIndex
[l
];
1114 Lisp_Object feature_tag
1115 = otf_tag_symbol (feature
->FeatureTag
);
1117 feature_list
= Fcons (feature_tag
, feature_list
);
1119 langsys_list
= Fcons (Fcons (langsys_tag
, feature_list
),
1122 script_list
= Fcons (Fcons (script_tag
, langsys_list
),
1127 XSETCAR (capability
, script_list
);
1129 XSETCDR (capability
, script_list
);
1136 parse_gsub_gpos_spec (spec
, script
, langsys
, features
)
1138 char **script
, **langsys
, **features
;
1146 *script
= (char *) SDATA (SYMBOL_NAME (val
));
1149 *langsys
= NILP (val
) ? NULL
: (char *) SDATA (SYMBOL_NAME (val
));
1151 len
= XINT (Flength (spec
));
1152 *features
= p
= malloc (6 * len
);
1156 for (asterisk
= 0; CONSP (spec
); spec
= XCDR (spec
))
1159 if (SREF (SYMBOL_NAME (val
), 0) == '*')
1162 p
+= sprintf (p
, ",*");
1164 else if (! asterisk
)
1165 p
+= sprintf (p
, ",%s", SDATA (SYMBOL_NAME (val
)));
1167 p
+= sprintf (p
, ",~%s", SDATA (SYMBOL_NAME (val
)));
1172 #define DEVICE_DELTA(table, size) \
1173 (((size) >= (table).StartSize && (size) <= (table).EndSize) \
1174 ? (table).DeltaValue[(size) >= (table).StartSize] \
1178 adjust_anchor (struct font
*font
, OTF_Anchor
*anchor
,
1179 unsigned code
, int size
, int *x
, int *y
)
1181 if (anchor
->AnchorFormat
== 2)
1185 if (font
->driver
->anchor_point (font
, code
, anchor
->f
.f1
.AnchorPoint
,
1189 else if (anchor
->AnchorFormat
== 3)
1191 if (anchor
->f
.f2
.XDeviceTable
.offset
)
1192 *x
+= DEVICE_DELTA (anchor
->f
.f2
.XDeviceTable
, size
);
1193 if (anchor
->f
.f2
.YDeviceTable
.offset
)
1194 *y
+= DEVICE_DELTA (anchor
->f
.f2
.YDeviceTable
, size
);
1199 /* Drive FONT's OTF GSUB features according to GSUB_SPEC. See the
1200 comment of (sturct font_driver).otf_gsub. */
1203 font_otf_gsub (font
, gsub_spec
, gstring_in
, from
, to
, gstring_out
, idx
)
1205 Lisp_Object gsub_spec
;
1206 Lisp_Object gstring_in
;
1208 Lisp_Object gstring_out
;
1214 OTF_GlyphString otf_gstring
;
1216 char *script
, *langsys
, *features
;
1218 otf
= otf_open (font
->entity
, font
->file_name
);
1221 if (OTF_get_table (otf
, "head") < 0)
1223 if (OTF_check_table (otf
, "GSUB") < 0)
1225 if (parse_gsub_gpos_spec (gsub_spec
, &script
, &langsys
, &features
) < 0)
1228 otf_gstring
.size
= otf_gstring
.used
= len
;
1229 otf_gstring
.glyphs
= (OTF_Glyph
*) malloc (sizeof (OTF_Glyph
) * len
);
1230 memset (otf_gstring
.glyphs
, 0, sizeof (OTF_Glyph
) * len
);
1231 for (i
= 0; i
< len
; i
++)
1233 Lisp_Object g
= LGSTRING_GLYPH (gstring_in
, from
+ i
);
1235 otf_gstring
.glyphs
[i
].c
= XINT (LGLYPH_CHAR (g
));
1236 otf_gstring
.glyphs
[i
].glyph_id
= XINT (LGLYPH_CODE (g
));
1239 OTF_drive_gdef (otf
, &otf_gstring
);
1240 if (OTF_drive_gsub (otf
, &otf_gstring
, script
, langsys
, features
) < 0)
1242 free (otf_gstring
.glyphs
);
1245 if (ASIZE (gstring_out
) < idx
+ otf_gstring
.used
)
1247 free (otf_gstring
.glyphs
);
1251 for (i
= 0, g
= otf_gstring
.glyphs
; i
< otf_gstring
.used
;)
1253 int i0
= g
->f
.index
.from
, i1
= g
->f
.index
.to
;
1254 Lisp_Object glyph
= LGSTRING_GLYPH (gstring_in
, from
+ i0
);
1255 Lisp_Object min_idx
= AREF (glyph
, 0);
1256 Lisp_Object max_idx
= AREF (glyph
, 1);
1260 int min_idx_i
= XINT (min_idx
), max_idx_i
= XINT (max_idx
);
1262 for (i0
++; i0
<= i1
; i0
++)
1264 glyph
= LGSTRING_GLYPH (gstring_in
, from
+ i0
);
1265 if (min_idx_i
> XINT (AREF (glyph
, 0)))
1266 min_idx_i
= XINT (AREF (glyph
, 0));
1267 if (max_idx_i
< XINT (AREF (glyph
, 1)))
1268 max_idx_i
= XINT (AREF (glyph
, 1));
1270 min_idx
= make_number (min_idx_i
);
1271 max_idx
= make_number (max_idx_i
);
1272 i0
= g
->f
.index
.from
;
1274 for (; i
< otf_gstring
.used
&& g
->f
.index
.from
== i0
; i
++, g
++)
1276 glyph
= LGSTRING_GLYPH (gstring_out
, idx
+ i
);
1277 ASET (glyph
, 0, min_idx
);
1278 ASET (glyph
, 1, max_idx
);
1279 LGLYPH_SET_CHAR (glyph
, make_number (g
->c
));
1280 LGLYPH_SET_CODE (glyph
, make_number (g
->glyph_id
));
1284 free (otf_gstring
.glyphs
);
1288 /* Drive FONT's OTF GPOS features according to GPOS_SPEC. See the
1289 comment of (sturct font_driver).otf_gpos. */
1292 font_otf_gpos (font
, gpos_spec
, gstring
, from
, to
)
1294 Lisp_Object gpos_spec
;
1295 Lisp_Object gstring
;
1301 OTF_GlyphString otf_gstring
;
1303 char *script
, *langsys
, *features
;
1306 Lisp_Object base
, mark
;
1308 otf
= otf_open (font
->entity
, font
->file_name
);
1311 if (OTF_get_table (otf
, "head") < 0)
1313 if (OTF_check_table (otf
, "GPOS") < 0)
1315 if (parse_gsub_gpos_spec (gpos_spec
, &script
, &langsys
, &features
) < 0)
1318 otf_gstring
.size
= otf_gstring
.used
= len
;
1319 otf_gstring
.glyphs
= (OTF_Glyph
*) malloc (sizeof (OTF_Glyph
) * len
);
1320 memset (otf_gstring
.glyphs
, 0, sizeof (OTF_Glyph
) * len
);
1321 for (i
= 0; i
< len
; i
++)
1323 glyph
= LGSTRING_GLYPH (gstring
, from
+ i
);
1324 otf_gstring
.glyphs
[i
].glyph_id
= XINT (LGLYPH_CODE (glyph
));
1327 OTF_drive_gdef (otf
, &otf_gstring
);
1329 if (OTF_drive_gpos (otf
, &otf_gstring
, script
, langsys
, features
) < 0)
1331 free (otf_gstring
.glyphs
);
1335 u
= otf
->head
->unitsPerEm
;
1336 size
= font
->pixel_size
;
1338 for (i
= 0, g
= otf_gstring
.glyphs
; i
< otf_gstring
.used
; i
++, g
++)
1341 int xoff
= 0, yoff
= 0, width_adjust
= 0;
1346 glyph
= LGSTRING_GLYPH (gstring
, from
+ i
);
1347 switch (g
->positioning_type
)
1353 int format
= g
->f
.f1
.format
;
1355 if (format
& OTF_XPlacement
)
1356 xoff
= g
->f
.f1
.value
->XPlacement
* size
/ u
;
1357 if (format
& OTF_XPlaDevice
)
1358 xoff
+= DEVICE_DELTA (g
->f
.f1
.value
->XPlaDevice
, size
);
1359 if (format
& OTF_YPlacement
)
1360 yoff
= - (g
->f
.f1
.value
->YPlacement
* size
/ u
);
1361 if (format
& OTF_YPlaDevice
)
1362 yoff
-= DEVICE_DELTA (g
->f
.f1
.value
->YPlaDevice
, size
);
1363 if (format
& OTF_XAdvance
)
1364 width_adjust
+= g
->f
.f1
.value
->XAdvance
* size
/ u
;
1365 if (format
& OTF_XAdvDevice
)
1366 width_adjust
+= DEVICE_DELTA (g
->f
.f1
.value
->XAdvDevice
, size
);
1370 /* Not yet supported. */
1376 goto label_adjust_anchor
;
1377 default: /* i.e. case 6 */
1382 label_adjust_anchor
:
1384 int base_x
, base_y
, mark_x
, mark_y
, width
;
1387 base_x
= g
->f
.f4
.base_anchor
->XCoordinate
* size
/ u
;
1388 base_y
= g
->f
.f4
.base_anchor
->YCoordinate
* size
/ u
;
1389 mark_x
= g
->f
.f4
.mark_anchor
->XCoordinate
* size
/ u
;
1390 mark_y
= g
->f
.f4
.mark_anchor
->YCoordinate
* size
/ u
;
1392 code
= XINT (LGLYPH_CODE (prev
));
1393 if (g
->f
.f4
.base_anchor
->AnchorFormat
!= 1)
1394 adjust_anchor (font
, g
->f
.f4
.base_anchor
,
1395 code
, size
, &base_x
, &base_y
);
1396 if (g
->f
.f4
.mark_anchor
->AnchorFormat
!= 1)
1397 adjust_anchor (font
, g
->f
.f4
.mark_anchor
,
1398 code
, size
, &mark_x
, &mark_y
);
1400 if (NILP (LGLYPH_WIDTH (prev
)))
1402 width
= font
->driver
->text_extents (font
, &code
, 1, NULL
);
1403 LGLYPH_SET_WIDTH (prev
, make_number (width
));
1405 xoff
= XINT (LGLYPH_XOFF (prev
)) + (base_x
- width
) - mark_x
;
1406 yoff
= XINT (LGLYPH_YOFF (prev
)) + mark_y
- base_y
;
1409 if (g
->GlyphClass
== OTF_GlyphClass0
)
1410 base
= mark
= glyph
;
1411 else if (g
->GlyphClass
== OTF_GlyphClassMark
)
1416 LGLYPH_SET_XOFF (glyph
, make_number (xoff
));
1417 LGLYPH_SET_YOFF (glyph
, make_number (yoff
));
1418 LGLYPH_SET_WADJUST (glyph
, make_number (width_adjust
));
1421 free (otf_gstring
.glyphs
);
1425 #endif /* HAVE_LIBOTF */
1428 /* glyph-string handler */
1430 /* GSTRING is a vector of this form:
1431 [ [FONT-OBJECT LBEARING RBEARING WITH ASCENT DESCENT] GLYPH ... ]
1432 and GLYPH is a vector of this form:
1433 [ FROM-IDX TO-IDX C CODE X-OFF Y-OFF WIDTH WADJUST ]
1435 FROM-IDX and TO-IDX are used internally and should not be touched.
1436 C is a character of the glyph.
1437 CODE is a glyph-code of C in FONT-OBJECT.
1438 X-OFF and Y-OFF are offests to the base position for the glyph.
1439 WIDTH is a normal width of the glyph.
1440 WADJUST is an adjustment to the normal width of the glyph. */
1443 font_prepare_composition (cmp
)
1444 struct composition
*cmp
;
1447 = AREF (XHASH_TABLE (composition_hash_table
)->key_and_value
,
1448 cmp
->hash_index
* 2);
1449 struct font
*font
= XSAVE_VALUE (LGSTRING_FONT (gstring
))->pointer
;
1450 int len
= LGSTRING_LENGTH (gstring
);
1454 cmp
->lbearing
= cmp
->rbearing
= cmp
->pixel_width
= 0;
1455 cmp
->ascent
= font
->ascent
;
1456 cmp
->descent
= font
->descent
;
1458 for (i
= 0; i
< len
; i
++)
1460 Lisp_Object g
= LGSTRING_GLYPH (gstring
, i
);
1461 unsigned code
= XINT (LGLYPH_CODE (g
));
1462 struct font_metrics metrics
;
1464 font
->driver
->text_extents (font
, &code
, 1, &metrics
);
1465 LGLYPH_SET_WIDTH (g
, make_number (metrics
.width
));
1466 metrics
.lbearing
+= XINT (LGLYPH_XOFF (g
));
1467 metrics
.rbearing
+= XINT (LGLYPH_XOFF (g
));
1468 metrics
.ascent
+= XINT (LGLYPH_YOFF (g
));
1469 metrics
.descent
+= XINT (LGLYPH_YOFF (g
));
1471 if (cmp
->lbearing
> cmp
->pixel_width
+ metrics
.lbearing
)
1472 cmp
->lbearing
= cmp
->pixel_width
+ metrics
.lbearing
;
1473 if (cmp
->rbearing
< cmp
->pixel_width
+ metrics
.rbearing
)
1474 cmp
->rbearing
= cmp
->pixel_width
+ metrics
.rbearing
;
1475 if (cmp
->ascent
< metrics
.ascent
)
1476 cmp
->ascent
= metrics
.ascent
;
1477 if (cmp
->descent
< metrics
.descent
)
1478 cmp
->descent
= metrics
.descent
;
1479 cmp
->pixel_width
+= metrics
.width
+ XINT (LGLYPH_WADJUST (g
));
1481 LGSTRING_SET_LBEARING (gstring
, make_number (cmp
->lbearing
));
1482 LGSTRING_SET_RBEARING (gstring
, make_number (cmp
->rbearing
));
1483 LGSTRING_SET_WIDTH (gstring
, make_number (cmp
->pixel_width
));
1484 LGSTRING_SET_ASCENT (gstring
, make_number (cmp
->ascent
));
1485 LGSTRING_SET_DESCENT (gstring
, make_number (cmp
->descent
));
1491 font_gstring_produce (old
, from
, to
, new, idx
, code
, n
)
1499 Lisp_Object min_idx
, max_idx
;
1502 if (idx
+ n
> ASIZE (new))
1508 min_idx
= make_number (0);
1509 max_idx
= make_number (1);
1513 min_idx
= AREF (AREF (old
, from
- 1), 0);
1514 max_idx
= AREF (AREF (old
, from
- 1), 1);
1517 else if (from
+ 1 == to
)
1519 min_idx
= AREF (AREF (old
, from
), 0);
1520 max_idx
= AREF (AREF (old
, from
), 1);
1524 int min_idx_i
= XINT (AREF (AREF (old
, from
), 0));
1525 int max_idx_i
= XINT (AREF (AREF (old
, from
), 1));
1527 for (i
= from
+ 1; i
< to
; i
++)
1529 if (min_idx_i
> XINT (AREF (AREF (old
, i
), 0)))
1530 min_idx_i
= XINT (AREF (AREF (old
, i
), 0));
1531 if (max_idx_i
< XINT (AREF (AREF (old
, i
), 1)))
1532 max_idx_i
= XINT (AREF (AREF (old
, i
), 1));
1534 min_idx
= make_number (min_idx_i
);
1535 max_idx
= make_number (max_idx_i
);
1538 for (i
= 0; i
< n
; i
++)
1540 ASET (AREF (new, idx
+ i
), 0, min_idx
);
1541 ASET (AREF (new, idx
+ i
), 1, max_idx
);
1542 ASET (AREF (new, idx
+ i
), 2, make_number (code
[i
]));
1550 static unsigned font_score
P_ ((Lisp_Object
, Lisp_Object
));
1551 static int font_compare
P_ ((const void *, const void *));
1552 static Lisp_Object font_sort_entites
P_ ((Lisp_Object
, Lisp_Object
,
1553 Lisp_Object
, Lisp_Object
));
1555 /* We sort fonts by scoring each of them against a specified
1556 font-spec. The score value is 32 bit (`unsigned'), and the smaller
1557 the value is, the closer the font is to the font-spec.
1559 Each 1-bit in the highest 4 bits of the score is used for atomic
1560 properties FOUNDRY, FAMILY, ADSTYLE, and REGISTRY.
1562 Each 7-bit in the lowest 28 bits are used for numeric properties
1563 WEIGHT, SLANT, WIDTH, and SIZE. */
1565 /* How many bits to shift to store the difference value of each font
1566 property in a score. */
1567 static int sort_shift_bits
[FONT_SIZE_INDEX
+ 1];
1569 /* Score font-entity ENTITY against font-spec SPEC. The return value
1570 indicates how different ENTITY is compared with SPEC. */
1573 font_score (entity
, spec
)
1574 Lisp_Object entity
, spec
;
1578 /* Score atomic fields. Maximum difference is 1. */
1579 for (i
= FONT_FOUNDRY_INDEX
; i
<= FONT_REGISTRY_INDEX
; i
++)
1581 Lisp_Object val
= AREF (spec
, i
);
1584 && ! EQ (val
, AREF (entity
, i
)))
1585 score
|= 1 << sort_shift_bits
[i
];
1588 /* Score numeric fields. Maximum difference is 127. */
1589 for (i
= FONT_WEIGHT_INDEX
; i
<= FONT_SIZE_INDEX
; i
++)
1591 Lisp_Object spec_val
= AREF (spec
, i
);
1592 Lisp_Object entity_val
= AREF (entity
, i
);
1594 if (! NILP (spec_val
) && ! EQ (spec_val
, entity_val
))
1596 if (! INTEGERP (entity_val
))
1597 score
|= 127 << sort_shift_bits
[i
];
1598 else if (i
< FONT_SIZE_INDEX
1599 || XINT (entity_val
) != 0)
1601 int diff
= XINT (entity_val
) - XINT (spec_val
);
1605 score
|= min (diff
, 127) << sort_shift_bits
[i
];
1614 /* The comparison function for qsort. */
1617 font_compare (d1
, d2
)
1618 const void *d1
, *d2
;
1620 return (*(unsigned *) d1
< *(unsigned *) d2
1621 ? -1 : *(unsigned *) d1
> *(unsigned *) d2
);
1625 /* The structure for elements being sorted by qsort. */
1626 struct font_sort_data
1633 /* Sort font-entities in vector VEC by closeness to font-spec PREFER.
1634 If PREFER specifies a point-size, calculate the corresponding
1635 pixel-size from the Y-resolution of FRAME before sorting. If SPEC
1636 is not nil, it is a font-spec to get the font-entities in VEC. */
1639 font_sort_entites (vec
, prefer
, frame
, spec
)
1640 Lisp_Object vec
, prefer
, frame
, spec
;
1644 struct font_sort_data
*data
;
1645 int prefer_is_copy
= 0;
1652 size
= AREF (spec
, FONT_SIZE_INDEX
);
1655 double point_size
= XFLOAT_DATA (size
) * 10;
1656 int pixel_size
= POINT_TO_PIXEL (point_size
, XFRAME (frame
)->resy
);
1658 prefer
= Fcopy_sequence (prefer
);
1659 ASET (prefer
, FONT_SIZE_INDEX
, make_number (pixel_size
));
1665 /* As it is assured that all fonts in VEC match with SPEC, we
1666 should ignore properties specified in SPEC. So, set the
1667 corresponding properties in PREFER nil. */
1668 for (i
= FONT_WEIGHT_INDEX
; i
<= FONT_SIZE_INDEX
; i
++)
1669 if (! NILP (AREF (spec
, i
)) && ! NILP (AREF (prefer
, i
)))
1671 if (i
<= FONT_SIZE_INDEX
)
1673 if (! prefer_is_copy
)
1674 prefer
= Fcopy_sequence (prefer
);
1675 for (; i
<= FONT_SIZE_INDEX
; i
++)
1676 if (! NILP (AREF (spec
, i
)) && ! NILP (AREF (prefer
, i
)))
1677 ASET (prefer
, i
, Qnil
);
1681 /* Scoring and sorting. */
1682 SAFE_ALLOCA (data
, struct font_sort_data
*, (sizeof *data
) * len
);
1683 for (i
= 0; i
< len
; i
++)
1685 data
[i
].entity
= AREF (vec
, i
);
1686 data
[i
].score
= font_score (data
[i
].entity
, prefer
);
1688 qsort (data
, len
, sizeof *data
, font_compare
);
1689 for (i
= 0; i
< len
; i
++)
1690 ASET (vec
, i
, data
[i
].entity
);
1697 /* API of Font Service Layer. */
1700 font_update_sort_order (order
)
1703 int i
, shift_bits
= 21;
1705 for (i
= 0; i
< 4; i
++, shift_bits
-= 7)
1707 int xlfd_idx
= order
[i
];
1709 if (xlfd_idx
== XLFD_WEIGHT_INDEX
)
1710 sort_shift_bits
[FONT_WEIGHT_INDEX
] = shift_bits
;
1711 else if (xlfd_idx
== XLFD_SLANT_INDEX
)
1712 sort_shift_bits
[FONT_SLANT_INDEX
] = shift_bits
;
1713 else if (xlfd_idx
== XLFD_SWIDTH_INDEX
)
1714 sort_shift_bits
[FONT_WIDTH_INDEX
] = shift_bits
;
1716 sort_shift_bits
[FONT_SIZE_INDEX
] = shift_bits
;
1721 font_symbolic_weight (font
)
1724 Lisp_Object weight
= AREF (font
, FONT_WEIGHT_INDEX
);
1726 if (INTEGERP (weight
))
1727 weight
= prop_numeric_to_name (FONT_WEIGHT_INDEX
, XINT (weight
));
1732 font_symbolic_slant (font
)
1735 Lisp_Object slant
= AREF (font
, FONT_SLANT_INDEX
);
1737 if (INTEGERP (slant
))
1738 slant
= prop_numeric_to_name (FONT_SLANT_INDEX
, XINT (slant
));
1743 font_symbolic_width (font
)
1746 Lisp_Object width
= AREF (font
, FONT_WIDTH_INDEX
);
1748 if (INTEGERP (width
))
1749 width
= prop_numeric_to_name (FONT_WIDTH_INDEX
, XINT (width
));
1754 font_find_object (font
)
1757 Lisp_Object tail
, elt
;
1759 for (tail
= AREF (font
->entity
, FONT_OBJLIST_INDEX
); CONSP (tail
);
1763 if (font
== XSAVE_VALUE (elt
)->pointer
1764 && XSAVE_VALUE (elt
)->integer
> 0)
1771 static Lisp_Object scratch_font_spec
, scratch_font_prefer
;
1773 /* Return a vector of font-entities matching with SPEC on frame F. */
1776 font_list_entities (frame
, spec
)
1777 Lisp_Object frame
, spec
;
1779 FRAME_PTR f
= XFRAME (frame
);
1780 struct font_driver_list
*driver_list
= f
->font_driver_list
;
1781 Lisp_Object ftype
, family
, alternate_familes
;
1782 Lisp_Object
*vec
= alloca (sizeof (Lisp_Object
) * num_font_drivers
);
1788 family
= AREF (spec
, FONT_FAMILY_INDEX
);
1790 alternate_familes
= Qnil
;
1793 if (NILP (font_family_alist
)
1794 && !NILP (Vface_alternative_font_family_alist
))
1795 build_font_family_alist ();
1796 alternate_familes
= assq_no_quit (family
, font_family_alist
);
1797 if (! NILP (alternate_familes
))
1798 alternate_familes
= XCDR (alternate_familes
);
1800 xassert (ASIZE (spec
) == FONT_SPEC_MAX
);
1801 ftype
= AREF (spec
, FONT_TYPE_INDEX
);
1803 for (i
= 0; driver_list
; driver_list
= driver_list
->next
)
1804 if (NILP (ftype
) || EQ (driver_list
->driver
->type
, ftype
))
1806 Lisp_Object cache
= driver_list
->driver
->get_cache (frame
);
1807 Lisp_Object tail
= alternate_familes
;
1810 xassert (CONSP (cache
));
1811 ASET (spec
, FONT_TYPE_INDEX
, driver_list
->driver
->type
);
1812 ASET (spec
, FONT_FAMILY_INDEX
, family
);
1816 val
= assoc_no_quit (spec
, XCDR (cache
));
1821 val
= driver_list
->driver
->list (frame
, spec
);
1823 XSETCDR (cache
, Fcons (Fcons (Fcopy_sequence (spec
), val
),
1826 if (VECTORP (val
) && ASIZE (val
) > 0)
1833 ASET (spec
, FONT_FAMILY_INDEX
, XCAR (tail
));
1837 ASET (spec
, FONT_TYPE_INDEX
, ftype
);
1838 ASET (spec
, FONT_FAMILY_INDEX
, family
);
1839 return (i
> 0 ? Fvconcat (i
, vec
) : null_vector
);
1842 static int num_fonts
;
1845 font_open_entity (f
, entity
, pixel_size
)
1850 struct font_driver_list
*driver_list
;
1851 Lisp_Object objlist
, size
, val
;
1854 size
= AREF (entity
, FONT_SIZE_INDEX
);
1855 xassert (NATNUMP (size
));
1856 if (XINT (size
) != 0)
1857 pixel_size
= XINT (size
);
1859 for (objlist
= AREF (entity
, FONT_OBJLIST_INDEX
); CONSP (objlist
);
1860 objlist
= XCDR (objlist
))
1862 font
= XSAVE_VALUE (XCAR (objlist
))->pointer
;
1863 if (font
->pixel_size
== pixel_size
)
1865 XSAVE_VALUE (XCAR (objlist
))->integer
++;
1866 return XCAR (objlist
);
1870 xassert (FONT_ENTITY_P (entity
));
1871 val
= AREF (entity
, FONT_TYPE_INDEX
);
1872 for (driver_list
= f
->font_driver_list
;
1873 driver_list
&& ! EQ (driver_list
->driver
->type
, val
);
1874 driver_list
= driver_list
->next
);
1878 font
= driver_list
->driver
->open (f
, entity
, pixel_size
);
1881 val
= make_save_value (font
, 1);
1882 ASET (entity
, FONT_OBJLIST_INDEX
,
1883 Fcons (val
, AREF (entity
, FONT_OBJLIST_INDEX
)));
1889 font_close_object (f
, font_object
)
1891 Lisp_Object font_object
;
1894 Lisp_Object objlist
= AREF (font
->entity
, FONT_OBJLIST_INDEX
);
1895 Lisp_Object tail
, prev
= Qnil
;
1897 for (prev
= Qnil
, tail
= objlist
; CONSP (tail
);
1898 prev
= tail
, tail
= XCDR (tail
))
1899 if (EQ (font_object
, XCAR (tail
)))
1901 struct Lisp_Save_Value
*p
= XSAVE_VALUE (font_object
);
1903 xassert (p
->integer
> 0);
1905 if (p
->integer
== 0)
1907 if (font
->driver
->close
)
1908 font
->driver
->close (f
, p
->pointer
);
1911 ASET (font
->entity
, FONT_OBJLIST_INDEX
, XCDR (objlist
));
1913 XSETCDR (prev
, XCDR (objlist
));
1920 font_has_char (f
, font_entity
, c
)
1922 Lisp_Object font_entity
;
1925 Lisp_Object type
= AREF (font_entity
, FONT_TYPE_INDEX
);
1926 struct font_driver_list
*driver_list
;
1928 for (driver_list
= f
->font_driver_list
;
1929 driver_list
&& ! EQ (driver_list
->driver
->type
, type
);
1930 driver_list
= driver_list
->next
);
1933 return driver_list
->driver
->has_char (font_entity
, c
);
1937 font_encode_char (font_object
, c
)
1938 Lisp_Object font_object
;
1941 struct font
*font
= XSAVE_VALUE (font_object
)->pointer
;
1943 return font
->driver
->encode_char (font
, c
);
1947 font_get_name (font_object
)
1948 Lisp_Object font_object
;
1950 struct font
*font
= XSAVE_VALUE (font_object
)->pointer
;
1952 return (font
->font
.full_name
? font
->font
.full_name
1953 : font
->file_name
? font
->file_name
1958 font_get_frame (font
)
1961 if (FONT_OBJECT_P (font
))
1962 font
= ((struct font
*) XSAVE_VALUE (font
)->pointer
)->entity
;
1963 xassert (FONT_ENTITY_P (font
));
1964 return AREF (font
, FONT_FRAME_INDEX
);
1967 extern Lisp_Object Qunspecified
, Qignore_defface
;
1970 font_find_for_lface (f
, lface
, spec
)
1975 Lisp_Object attrs
[LFACE_FONT_INDEX
+ 1];
1976 Lisp_Object frame
, val
, entities
;
1978 unsigned char try_unspecified
[FONT_SPEC_MAX
];
1980 for (i
= 0; i
<= LFACE_FONT_INDEX
; i
++)
1983 if (EQ (val
, Qunspecified
) || EQ (val
, Qignore_defface
))
1988 for (i
= 0; i
< FONT_SPEC_MAX
; i
++)
1989 ASET (scratch_font_spec
, i
, Qnil
);
1991 for (i
= 0; i
< FONT_SPEC_MAX
; i
++)
1992 ASET (scratch_font_spec
, i
, AREF (spec
, i
));
1994 /* If SPEC doesn't specify a specific property, it can be tried with
1995 nil even if FACE specifies it. */
1996 for (i
= FONT_FOUNDRY_INDEX
; i
<= FONT_SIZE_INDEX
; i
++)
1997 try_unspecified
[i
] = NILP (AREF (scratch_font_spec
, i
));
1999 if (NILP (spec
) && STRINGP (attrs
[LFACE_FONT_INDEX
]))
2000 font_merge_old_spec (attrs
[LFACE_FONT_INDEX
], Qnil
, Qnil
,
2002 if (NILP (AREF (scratch_font_spec
, FONT_FAMILY_INDEX
))
2003 && ! NILP (attrs
[LFACE_FAMILY_INDEX
]))
2004 font_merge_old_spec (Qnil
, attrs
[LFACE_FAMILY_INDEX
], Qnil
,
2006 if (NILP (AREF (scratch_font_spec
, FONT_REGISTRY_INDEX
)))
2008 ASET (scratch_font_spec
, FONT_REGISTRY_INDEX
, intern ("iso8859-1"));
2009 try_unspecified
[FONT_REGISTRY_INDEX
] = 0;
2012 for (i
= FONT_FAMILY_INDEX
; i
<= FONT_SIZE_INDEX
; i
++)
2013 if (try_unspecified
[i
]
2014 && NILP (AREF (scratch_font_spec
, i
)))
2015 try_unspecified
[i
] = 0;
2017 XSETFRAME (frame
, f
);
2018 entities
= font_list_entities (frame
, scratch_font_spec
);
2019 while (ASIZE (entities
) == 0)
2021 if (try_unspecified
[FONT_WEIGHT_INDEX
]
2022 || try_unspecified
[FONT_SLANT_INDEX
]
2023 || try_unspecified
[FONT_WIDTH_INDEX
]
2024 || try_unspecified
[FONT_SIZE_INDEX
])
2026 for (i
= FONT_WEIGHT_INDEX
; i
<= FONT_SIZE_INDEX
; i
++)
2028 try_unspecified
[i
] = 0;
2029 ASET (scratch_font_spec
, i
, Qnil
);
2031 entities
= font_list_entities (frame
, scratch_font_spec
);
2033 else if (try_unspecified
[FONT_FOUNDRY_INDEX
])
2035 try_unspecified
[FONT_FOUNDRY_INDEX
] = 0;
2036 ASET (scratch_font_spec
, FONT_FOUNDRY_INDEX
, Qnil
);
2037 entities
= font_list_entities (frame
, scratch_font_spec
);
2039 else if (try_unspecified
[FONT_FAMILY_INDEX
])
2041 try_unspecified
[FONT_FAMILY_INDEX
] = 0;
2042 ASET (scratch_font_spec
, FONT_FAMILY_INDEX
, Qnil
);
2043 entities
= font_list_entities (frame
, scratch_font_spec
);
2049 if (ASIZE (entities
) > 1)
2051 Lisp_Object prefer
= scratch_font_prefer
;
2053 for (i
= 0; i
< FONT_WEIGHT_INDEX
; i
++)
2054 ASET (prefer
, i
, Qnil
);
2055 if (! NILP (attrs
[LFACE_WEIGHT_INDEX
]))
2056 ASET (prefer
, FONT_WEIGHT_INDEX
,
2057 font_prop_validate_style (FONT_WEIGHT_INDEX
,
2058 attrs
[LFACE_WEIGHT_INDEX
]));
2059 if (! NILP (attrs
[LFACE_SLANT_INDEX
]))
2060 ASET (prefer
, FONT_SLANT_INDEX
,
2061 font_prop_validate_style (FONT_SLANT_INDEX
,
2062 attrs
[LFACE_SLANT_INDEX
]));
2063 if (! NILP (attrs
[LFACE_SWIDTH_INDEX
]))
2064 ASET (prefer
, FONT_WIDTH_INDEX
,
2065 font_prop_validate_style (FONT_WIDTH_INDEX
,
2066 attrs
[LFACE_SWIDTH_INDEX
]));
2067 if (! NILP (attrs
[LFACE_HEIGHT_INDEX
]))
2071 val
= attrs
[LFACE_HEIGHT_INDEX
];
2072 size
= POINT_TO_PIXEL (XINT (val
), f
->resy
);
2073 ASET (prefer
, FONT_SIZE_INDEX
, make_number (size
));
2075 font_sort_entites (entities
, prefer
, frame
, spec
);
2078 return AREF (entities
, 0);
2082 font_open_for_lface (f
, lface
, entity
)
2087 int pt
= XINT (lface
[LFACE_HEIGHT_INDEX
]);
2088 int size
= POINT_TO_PIXEL (pt
, f
->resy
);
2090 return font_open_entity (f
, entity
, size
);
2094 font_load_for_face (f
, face
)
2100 face
->font_info_id
= -1;
2101 face
->font_info
= NULL
;
2103 face
->font_name
= NULL
;
2105 entity
= font_find_for_lface (f
, face
->lface
, Qnil
);
2106 if (! NILP (entity
))
2108 Lisp_Object font_object
= font_open_for_lface (f
, face
->lface
, entity
);
2110 if (! NILP (font_object
))
2112 struct font
*font
= XSAVE_VALUE (font_object
)->pointer
;
2114 face
->font
= font
->font
.font
;
2115 face
->font_info
= (struct font_info
*) font
;
2116 face
->font_info_id
= 0;
2117 face
->font_name
= font
->font
.full_name
;
2121 add_to_log ("Unable to load font for a face%s", null_string
, Qnil
);
2125 font_prepare_for_face (f
, face
)
2129 struct font
*font
= (struct font
*) face
->font_info
;
2131 if (font
->driver
->prepare_face
)
2132 font
->driver
->prepare_face (f
, face
);
2136 font_done_for_face (f
, face
)
2140 struct font
*font
= (struct font
*) face
->font_info
;
2142 if (font
->driver
->done_face
)
2143 font
->driver
->done_face (f
, face
);
2148 font_open_by_name (f
, name
)
2152 Lisp_Object spec
= Ffont_spec (0, NULL
);
2154 struct font_driver_list
*dlist
;
2156 XSETFRAME (frame
, f
);
2157 ASET (spec
, FONT_EXTRA_INDEX
,
2158 Fcons (Fcons (QCname
, make_unibyte_string (name
, strlen (name
))),
2161 for (dlist
= f
->font_driver_list
; dlist
; dlist
= dlist
->next
)
2162 if (dlist
->driver
->parse_name
2163 && dlist
->driver
->parse_name (f
, name
, spec
) >= 0)
2165 Lisp_Object entities
= font_list_entities (frame
, spec
);
2166 Lisp_Object font_object
;
2169 if (ASIZE (entities
) == 0)
2171 pixel_size
= XINT (AREF (AREF (entities
, 0), FONT_SIZE_INDEX
));
2172 if (pixel_size
== 0 && INTEGERP (AREF (spec
, FONT_SIZE_INDEX
)))
2173 pixel_size
= XINT (AREF (spec
, FONT_SIZE_INDEX
));
2174 font_object
= font_open_entity (f
, AREF (entities
, 0), pixel_size
);
2175 if (! NILP (font_object
))
2182 /* Register font-driver DRIVER. This function is used in two ways.
2184 The first is with frame F non-NULL. In this case, DRIVER is
2185 registered to be used for drawing characters on F. All frame
2186 creaters (e.g. Fx_create_frame) must call this function at least
2187 once with an available font-driver.
2189 The second is with frame F NULL. In this case, DRIVER is globally
2190 registered in the variable `font_driver_list'. All font-driver
2191 implementations must call this function in its syms_of_XXXX
2192 (e.g. syms_of_xfont). */
2195 register_font_driver (driver
, f
)
2196 struct font_driver
*driver
;
2199 struct font_driver_list
*root
= f
? f
->font_driver_list
: font_driver_list
;
2200 struct font_driver_list
*prev
, *list
;
2202 if (f
&& ! driver
->draw
)
2203 error ("Unsable font driver for a frame: %s",
2204 SDATA (SYMBOL_NAME (driver
->type
)));
2206 for (prev
= NULL
, list
= root
; list
; prev
= list
, list
= list
->next
)
2207 if (list
->driver
->type
== driver
->type
)
2208 error ("Duplicated font driver: %s", SDATA (SYMBOL_NAME (driver
->type
)));
2210 list
= malloc (sizeof (struct font_driver_list
));
2211 list
->driver
= driver
;
2216 f
->font_driver_list
= list
;
2218 font_driver_list
= list
;
2222 /* Free font-driver list on frame F. It doesn't free font-drivers
2226 free_font_driver_list (f
)
2229 while (f
->font_driver_list
)
2231 struct font_driver_list
*next
= f
->font_driver_list
->next
;
2233 free (f
->font_driver_list
);
2234 f
->font_driver_list
= next
;
2241 DEFUN ("fontp", Ffontp
, Sfontp
, 1, 1, 0,
2242 doc
: /* Return t if object is a font-spec or font-entity. */)
2246 return (FONTP (object
) ? Qt
: Qnil
);
2249 DEFUN ("font-spec", Ffont_spec
, Sfont_spec
, 0, MANY
, 0,
2250 doc
: /* Return a newly created font-spec with specified arguments as properties.
2251 usage: (font-spec &rest properties) */)
2256 Lisp_Object spec
= Fmake_vector (make_number (FONT_SPEC_MAX
), Qnil
);
2257 Lisp_Object extra
= Qnil
;
2260 for (i
= 0; i
< nargs
; i
+= 2)
2262 enum font_property_index prop
;
2263 Lisp_Object key
= args
[i
], val
= args
[i
+ 1];
2265 prop
= check_font_prop_name (key
);
2266 if (prop
< FONT_EXTRA_INDEX
)
2267 ASET (spec
, prop
, (font_property_table
[prop
].validater
) (prop
, val
));
2270 if (EQ (key
, QCname
))
2271 font_parse_xlfd ((char *) SDATA (val
), spec
, 0);
2272 extra
= Fcons (Fcons (key
, val
), extra
);
2275 ASET (spec
, FONT_EXTRA_INDEX
, extra
);
2280 DEFUN ("font-get", Ffont_get
, Sfont_get
, 2, 2, 0,
2281 doc
: /* Return the value of FONT's PROP property.
2282 FONT may be a font-spec or font-entity.
2283 If FONT is font-entity and PROP is :extra, always nil is returned. */)
2285 Lisp_Object font
, prop
;
2287 enum font_property_index idx
;
2290 idx
= check_font_prop_name (prop
);
2291 if (idx
< FONT_EXTRA_INDEX
)
2292 return AREF (font
, idx
);
2293 if (FONT_ENTITY_P (font
))
2295 return Fcdr (Fassoc (AREF (font
, FONT_EXTRA_INDEX
), prop
));
2299 DEFUN ("font-put", Ffont_put
, Sfont_put
, 3, 3, 0,
2300 doc
: /* Set one property of FONT-SPEC: give property PROP value VALUE. */)
2301 (font_spec
, prop
, val
)
2302 Lisp_Object font_spec
, prop
, val
;
2304 enum font_property_index idx
;
2305 Lisp_Object extra
, slot
;
2307 CHECK_FONT_SPEC (font_spec
);
2308 idx
= check_font_prop_name (prop
);
2309 if (idx
< FONT_EXTRA_INDEX
)
2310 return ASET (font_spec
, idx
, val
);
2311 extra
= AREF (font_spec
, FONT_EXTRA_INDEX
);
2312 slot
= Fassoc (extra
, prop
);
2314 extra
= Fcons (Fcons (prop
, val
), extra
);
2316 Fsetcdr (slot
, val
);
2320 DEFUN ("list-fonts", Flist_fonts
, Slist_fonts
, 1, 4, 0,
2321 doc
: /* List available fonts matching FONT-SPEC on the current frame.
2322 Optional 2nd argument FRAME specifies the target frame.
2323 Optional 3rd argument NUM, if non-nil, limits the number of returned fonts.
2324 Optional 4th argument PREFER, if non-nil, is a font-spec to sort fonts
2325 by closeness to PREFER. */)
2326 (font_spec
, frame
, num
, prefer
)
2327 Lisp_Object font_spec
, frame
, num
, prefer
;
2329 Lisp_Object vec
, list
, tail
;
2333 frame
= selected_frame
;
2334 CHECK_LIVE_FRAME (frame
);
2335 CHECK_VALIDATE_FONT_SPEC (font_spec
);
2343 if (! NILP (prefer
))
2344 CHECK_FONT (prefer
);
2346 vec
= font_list_entities (frame
, font_spec
);
2351 return Fcons (AREF (vec
, 0), Qnil
);
2353 if (! NILP (prefer
))
2354 vec
= font_sort_entites (vec
, prefer
, frame
, font_spec
);
2356 list
= tail
= Fcons (AREF (vec
, 0), Qnil
);
2357 if (n
== 0 || n
> len
)
2359 for (i
= 1; i
< n
; i
++)
2361 Lisp_Object val
= Fcons (AREF (vec
, i
), Qnil
);
2363 XSETCDR (tail
, val
);
2369 DEFUN ("list-families", Flist_families
, Slist_families
, 0, 1, 0,
2370 doc
: /* List available font families on the current frame.
2371 Optional 2nd argument FRAME specifies the target frame. */)
2376 struct font_driver_list
*driver_list
;
2380 frame
= selected_frame
;
2381 CHECK_LIVE_FRAME (frame
);
2384 for (driver_list
= f
->font_driver_list
; driver_list
;
2385 driver_list
= driver_list
->next
)
2386 if (driver_list
->driver
->list_family
)
2388 Lisp_Object val
= driver_list
->driver
->list_family (frame
);
2394 Lisp_Object tail
= list
;
2396 for (; CONSP (val
); val
= XCDR (val
))
2397 if (NILP (Fmemq (XCAR (val
), tail
)))
2398 list
= Fcons (XCAR (val
), list
);
2404 DEFUN ("find-font", Ffind_font
, Sfind_font
, 1, 2, 0,
2405 doc
: /* Return a font-entity matching with FONT-SPEC on the current frame.
2406 Optional 2nd argument FRAME, if non-nil, specifies the target frame. */)
2408 Lisp_Object font_spec
, frame
;
2410 Lisp_Object val
= Flist_fonts (font_spec
, frame
, make_number (1), Qnil
);
2417 DEFUN ("font-xlfd-name", Ffont_xlfd_name
, Sfont_xlfd_name
, 1, 1, 0,
2418 doc
: /* Return XLFD name of FONT.
2419 FONT is a font-spec, font-entity, or font-object.
2420 If the name is too long for XLFD (maximum 255 chars), return nil. */)
2427 if (FONT_SPEC_P (font
))
2428 CHECK_VALIDATE_FONT_SPEC (font
);
2429 else if (FONT_ENTITY_P (font
))
2435 CHECK_FONT_GET_OBJECT (font
, fontp
);
2436 font
= fontp
->entity
;
2437 pixel_size
= fontp
->pixel_size
;
2440 if (font_unparse_xlfd (font
, pixel_size
, name
, 256) < 0)
2442 return build_string (name
);
2445 DEFUN ("clear-font-cache", Fclear_font_cache
, Sclear_font_cache
, 0, 0, 0,
2446 doc
: /* Clear font cache. */)
2449 Lisp_Object list
, frame
;
2451 FOR_EACH_FRAME (list
, frame
)
2453 FRAME_PTR f
= XFRAME (frame
);
2454 struct font_driver_list
*driver_list
= f
->font_driver_list
;
2456 for (; driver_list
; driver_list
= driver_list
->next
)
2458 Lisp_Object cache
= driver_list
->driver
->get_cache (frame
);
2459 Lisp_Object tail
, elt
;
2461 for (tail
= XCDR (cache
); CONSP (tail
); tail
= XCDR (tail
))
2464 if (CONSP (elt
) && FONT_SPEC_P (XCAR (elt
)))
2466 Lisp_Object vec
= XCDR (elt
);
2469 for (i
= 0; i
< ASIZE (vec
); i
++)
2471 Lisp_Object entity
= AREF (vec
, i
);
2472 Lisp_Object objlist
= AREF (entity
, FONT_OBJLIST_INDEX
);
2474 for (; CONSP (objlist
); objlist
= XCDR (objlist
))
2476 Lisp_Object val
= XCAR (objlist
);
2477 struct Lisp_Save_Value
*p
= XSAVE_VALUE (val
);
2478 struct font
*font
= p
->pointer
;
2481 && driver_list
->driver
== font
->driver
);
2482 driver_list
->driver
->close (f
, font
);
2486 if (driver_list
->driver
->free_entity
)
2487 driver_list
->driver
->free_entity (entity
);
2491 XSETCDR (cache
, Qnil
);
2498 DEFUN ("internal-set-font-style-table", Finternal_set_font_style_table
,
2499 Sinternal_set_font_style_table
, 2, 2, 0,
2500 doc
: /* Set font style table for PROP to TABLE.
2501 PROP must be `:weight', `:slant', or `:width'.
2502 TABLE must be an alist of symbols vs the corresponding numeric values
2503 sorted by numeric values. */)
2505 Lisp_Object prop
, table
;
2509 Lisp_Object tail
, val
;
2511 CHECK_SYMBOL (prop
);
2512 table_index
= (EQ (prop
, QCweight
) ? 0
2513 : EQ (prop
, QCslant
) ? 1
2514 : EQ (prop
, QCwidth
) ? 2
2516 if (table_index
>= ASIZE (font_style_table
))
2517 error ("Invalid font style property: %s", SDATA (SYMBOL_NAME (prop
)));
2518 table
= Fcopy_sequence (table
);
2520 for (tail
= table
; ! NILP (tail
); tail
= Fcdr (tail
))
2522 prop
= Fcar (Fcar (tail
));
2523 val
= Fcdr (Fcar (tail
));
2524 CHECK_SYMBOL (prop
);
2526 if (numeric
> XINT (val
))
2527 error ("Numeric values not sorted for %s", SDATA (SYMBOL_NAME (prop
)));
2528 numeric
= XINT (val
);
2529 XSETCAR (tail
, Fcons (prop
, val
));
2531 ASET (font_style_table
, table_index
, table
);
2535 DEFUN ("font-make-gstring", Ffont_make_gstring
, Sfont_make_gstring
, 2, 2, 0,
2536 doc
: /* Return a newly created glyph-string for FONT-OBJECT with NUM glyphs.
2537 FONT-OBJECT may be nil if it is not yet known. */)
2539 Lisp_Object font_object
, num
;
2541 Lisp_Object gstring
, g
;
2545 if (! NILP (font_object
))
2546 CHECK_FONT_OBJECT (font_object
);
2549 len
= XINT (num
) + 1;
2550 gstring
= Fmake_vector (make_number (len
), Qnil
);
2551 g
= Fmake_vector (make_number (6), Qnil
);
2552 ASET (g
, 0, font_object
);
2553 ASET (gstring
, 0, g
);
2554 for (i
= 1; i
< len
; i
++)
2555 ASET (gstring
, i
, Fmake_vector (make_number (8), make_number (0)));
2559 DEFUN ("font-fill-gstring", Ffont_fill_gstring
, Sfont_fill_gstring
, 4, 5, 0,
2560 doc
: /* Fillin glyph-string GSTRING by characters for FONT-OBJECT.
2561 START and END specifies the region to extract characters.
2562 If optional 3rd argument OBJECT is non-nil, it is a buffer or a string from
2563 where to extract characters.
2564 FONT-OBJECT may be nil if GSTRING already already contains one. */)
2565 (gstring
, font_object
, start
, end
, object
)
2566 Lisp_Object gstring
, font_object
, start
, end
, object
;
2572 CHECK_VECTOR (gstring
);
2573 if (NILP (font_object
))
2574 font_object
= Faref (Faref (gstring
, make_number (0)), make_number (0));
2575 CHECK_FONT_GET_OBJECT (font_object
, font
);
2577 if (STRINGP (object
))
2579 const unsigned char *p
;
2581 CHECK_NATNUM (start
);
2583 if (XINT (start
) > XINT (end
)
2584 || XINT (end
) > ASIZE (object
)
2585 || XINT (end
) - XINT (start
) >= XINT (Flength (gstring
)))
2586 args_out_of_range (start
, end
);
2588 len
= XINT (end
) - XINT (start
);
2589 p
= SDATA (object
) + string_char_to_byte (object
, XINT (start
));
2590 for (i
= 0; i
< len
; i
++)
2592 Lisp_Object g
= LGSTRING_GLYPH (gstring
, i
);
2594 c
= STRING_CHAR_ADVANCE (p
);
2595 code
= font
->driver
->encode_char (font
, c
);
2596 if (code
> MOST_POSITIVE_FIXNUM
)
2597 error ("Glyph code 0x%X is too large", code
);
2598 ASET (g
, 0, make_number (i
));
2599 ASET (g
, 1, make_number (i
+ 1));
2600 LGLYPH_SET_CHAR (g
, make_number (c
));
2601 LGLYPH_SET_CODE (g
, make_number (code
));
2608 if (! NILP (object
))
2609 Fset_buffer (object
);
2610 validate_region (&start
, &end
);
2611 if (XINT (end
) - XINT (start
) > len
)
2612 args_out_of_range (start
, end
);
2613 len
= XINT (end
) - XINT (start
);
2615 pos_byte
= CHAR_TO_BYTE (pos
);
2616 for (i
= 0; i
< len
; i
++)
2618 Lisp_Object g
= LGSTRING_GLYPH (gstring
, i
);
2620 FETCH_CHAR_ADVANCE (c
, pos
, pos_byte
);
2621 code
= font
->driver
->encode_char (font
, c
);
2622 if (code
> MOST_POSITIVE_FIXNUM
)
2623 error ("Glyph code 0x%X is too large", code
);
2624 ASET (g
, 0, make_number (i
));
2625 ASET (g
, 1, make_number (i
+ 1));
2626 LGLYPH_SET_CHAR (g
, make_number (c
));
2627 LGLYPH_SET_CODE (g
, make_number (code
));
2636 DEFUN ("open-font", Fopen_font
, Sopen_font
, 1, 3, 0,
2637 doc
: /* Open FONT-ENTITY. */)
2638 (font_entity
, size
, frame
)
2639 Lisp_Object font_entity
;
2645 CHECK_FONT_ENTITY (font_entity
);
2647 size
= AREF (font_entity
, FONT_SIZE_INDEX
);
2648 CHECK_NUMBER (size
);
2650 frame
= selected_frame
;
2651 CHECK_LIVE_FRAME (frame
);
2653 isize
= XINT (size
);
2655 isize
= POINT_TO_PIXEL (- isize
, XFRAME (frame
)->resy
);
2657 return font_open_entity (XFRAME (frame
), font_entity
, isize
);
2660 DEFUN ("close-font", Fclose_font
, Sclose_font
, 1, 2, 0,
2661 doc
: /* Close FONT-OBJECT. */)
2662 (font_object
, frame
)
2663 Lisp_Object font_object
, frame
;
2665 CHECK_FONT_OBJECT (font_object
);
2667 frame
= selected_frame
;
2668 CHECK_LIVE_FRAME (frame
);
2669 font_close_object (XFRAME (frame
), font_object
);
2673 DEFUN ("query-font", Fquery_font
, Squery_font
, 1, 1, 0,
2674 doc
: /* Return information about FONT-OBJECT. */)
2676 Lisp_Object font_object
;
2681 CHECK_FONT_GET_OBJECT (font_object
, font
);
2683 val
= Fmake_vector (make_number (9), Qnil
);
2684 ASET (val
, 0, Ffont_xlfd_name (font_object
));
2685 if (font
->file_name
)
2686 ASET (val
, 1, make_unibyte_string (font
->file_name
,
2687 strlen (font
->file_name
)));
2688 ASET (val
, 2, make_number (font
->pixel_size
));
2689 ASET (val
, 3, make_number (font
->font
.size
));
2690 ASET (val
, 4, make_number (font
->ascent
));
2691 ASET (val
, 5, make_number (font
->descent
));
2692 ASET (val
, 6, make_number (font
->font
.space_width
));
2693 ASET (val
, 7, make_number (font
->font
.average_width
));
2694 if (font
->driver
->otf_capability
)
2695 ASET (val
, 8, font
->driver
->otf_capability (font
));
2699 DEFUN ("get-font-glyphs", Fget_font_glyphs
, Sget_font_glyphs
, 2, 2, 0,
2700 doc
: /* Return a vector of glyphs of FONT-OBJECT for drawing STRING.
2701 Each element is a vector [GLYPH-CODE LBEARING RBEARING WIDTH ASCENT DESCENT]. */)
2702 (font_object
, string
)
2703 Lisp_Object font_object
, string
;
2709 CHECK_FONT_GET_OBJECT (font_object
, font
);
2710 CHECK_STRING (string
);
2711 len
= SCHARS (string
);
2712 vec
= Fmake_vector (make_number (len
), Qnil
);
2713 for (i
= 0; i
< len
; i
++)
2715 Lisp_Object ch
= Faref (string
, make_number (i
));
2719 struct font_metrics metrics
;
2721 code
= font
->driver
->encode_char (font
, c
);
2722 if (code
== FONT_INVALID_CODE
)
2724 val
= Fmake_vector (make_number (6), Qnil
);
2725 if (code
<= MOST_POSITIVE_FIXNUM
)
2726 ASET (val
, 0, make_number (code
));
2728 ASET (val
, 0, Fcons (make_number (code
>> 16),
2729 make_number (code
& 0xFFFF)));
2730 font
->driver
->text_extents (font
, &code
, 1, &metrics
);
2731 ASET (val
, 1, make_number (metrics
.lbearing
));
2732 ASET (val
, 2, make_number (metrics
.rbearing
));
2733 ASET (val
, 3, make_number (metrics
.width
));
2734 ASET (val
, 4, make_number (metrics
.ascent
));
2735 ASET (val
, 5, make_number (metrics
.descent
));
2742 DEFUN ("draw-string", Fdraw_string
, Sdraw_string
, 2, 2, 0,
2743 doc
: /* Draw STRING by FONT-OBJECT on the top left corner of the current frame.
2744 The value is a number of glyphs drawn.
2745 Type C-l to recover what previously shown. */)
2746 (font_object
, string
)
2747 Lisp_Object font_object
, string
;
2749 Lisp_Object frame
= selected_frame
;
2750 FRAME_PTR f
= XFRAME (frame
);
2756 CHECK_FONT_GET_OBJECT (font_object
, font
);
2757 CHECK_STRING (string
);
2758 len
= SCHARS (string
);
2759 code
= alloca (sizeof (unsigned) * len
);
2760 for (i
= 0; i
< len
; i
++)
2762 Lisp_Object ch
= Faref (string
, make_number (i
));
2766 code
[i
] = font
->driver
->encode_char (font
, c
);
2767 if (code
[i
] == FONT_INVALID_CODE
)
2770 face
= FACE_FROM_ID (f
, DEFAULT_FACE_ID
);
2772 if (font
->driver
->prepare_face
)
2773 font
->driver
->prepare_face (f
, face
);
2774 width
= font
->driver
->text_extents (font
, code
, i
, NULL
);
2775 len
= font
->driver
->draw_text (f
, face
, 0, font
->ascent
, code
, i
, width
);
2776 if (font
->driver
->done_face
)
2777 font
->driver
->done_face (f
, face
);
2779 return make_number (len
);
2783 #endif /* FONT_DEBUG */
2786 extern void syms_of_ftfont
P_ (());
2787 extern void syms_of_xfont
P_ (());
2788 extern void syms_of_xftfont
P_ (());
2789 extern void syms_of_ftxfont
P_ (());
2790 extern void syms_of_bdffont
P_ (());
2791 extern void syms_of_w32font
P_ (());
2792 extern void syms_of_atmfont
P_ (());
2797 sort_shift_bits
[FONT_SLANT_INDEX
] = 0;
2798 sort_shift_bits
[FONT_WEIGHT_INDEX
] = 7;
2799 sort_shift_bits
[FONT_SIZE_INDEX
] = 14;
2800 sort_shift_bits
[FONT_WIDTH_INDEX
] = 21;
2801 sort_shift_bits
[FONT_ADSTYLE_INDEX
] = 28;
2802 sort_shift_bits
[FONT_FOUNDRY_INDEX
] = 29;
2803 sort_shift_bits
[FONT_FAMILY_INDEX
] = 30;
2804 sort_shift_bits
[FONT_REGISTRY_INDEX
] = 31;
2805 /* Note that sort_shift_bits[FONT_SLANT_TYPE] is never used. */
2807 staticpro (&font_style_table
);
2808 font_style_table
= Fmake_vector (make_number (3), Qnil
);
2810 staticpro (&font_family_alist
);
2811 font_family_alist
= Qnil
;
2813 DEFSYM (Qfontp
, "fontp");
2815 DEFSYM (Qiso8859_1
, "iso8859-1");
2816 DEFSYM (Qiso10646_1
, "iso10646-1");
2817 DEFSYM (Qunicode_bmp
, "unicode-bmp");
2819 DEFSYM (QCotf
, ":otf");
2820 DEFSYM (QClanguage
, ":language");
2821 DEFSYM (QCscript
, ":script");
2823 DEFSYM (QCfoundry
, ":foundry");
2824 DEFSYM (QCadstyle
, ":adstyle");
2825 DEFSYM (QCregistry
, ":registry");
2826 DEFSYM (QCextra
, ":extra");
2828 staticpro (&null_string
);
2829 null_string
= build_string ("");
2830 staticpro (&null_vector
);
2831 null_vector
= Fmake_vector (make_number (0), Qnil
);
2833 staticpro (&scratch_font_spec
);
2834 scratch_font_spec
= Ffont_spec (0, NULL
);
2835 staticpro (&scratch_font_prefer
);
2836 scratch_font_prefer
= Ffont_spec (0, NULL
);
2839 defsubr (&Sfont_spec
);
2840 defsubr (&Sfont_get
);
2841 defsubr (&Sfont_put
);
2842 defsubr (&Slist_fonts
);
2843 defsubr (&Slist_families
);
2844 defsubr (&Sfind_font
);
2845 defsubr (&Sfont_xlfd_name
);
2846 defsubr (&Sclear_font_cache
);
2847 defsubr (&Sinternal_set_font_style_table
);
2848 defsubr (&Sfont_make_gstring
);
2849 defsubr (&Sfont_fill_gstring
);
2852 defsubr (&Sopen_font
);
2853 defsubr (&Sclose_font
);
2854 defsubr (&Squery_font
);
2855 defsubr (&Sget_font_glyphs
);
2857 defsubr (&Sdraw_string
);
2859 #endif /* FONT_DEBUG */
2861 #ifdef HAVE_FREETYPE
2863 #ifdef HAVE_X_WINDOWS
2868 #endif /* HAVE_XFT */
2869 #endif /* HAVE_X_WINDOWS */
2870 #else /* not HAVE_FREETYPE */
2871 #ifdef HAVE_X_WINDOWS
2873 #endif /* HAVE_X_WINDOWS */
2874 #endif /* not HAVE_FREETYPE */
2877 #endif /* HAVE_BDFFONT */
2880 #endif /* WINDOWSNT */
2886 /* arch-tag: 74c9475d-5976-4c93-a327-942ae3072846
2887 (do not change this comment) */