* fontset.c (fontset_get_font_group): Add proper type checks.
[bpt/emacs.git] / src / fontset.c
1 /* Fontset handler.
2 Copyright (C) 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010, 2011
3 Free Software Foundation, Inc.
4 Copyright (C) 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004,
5 2005, 2006, 2007, 2008, 2009, 2010, 2011
6 National Institute of Advanced Industrial Science and Technology (AIST)
7 Registration Number H14PRO021
8 Copyright (C) 2003, 2006
9 National Institute of Advanced Industrial Science and Technology (AIST)
10 Registration Number H13PRO009
11
12 This file is part of GNU Emacs.
13
14 GNU Emacs is free software: you can redistribute it and/or modify
15 it under the terms of the GNU General Public License as published by
16 the Free Software Foundation, either version 3 of the License, or
17 (at your option) any later version.
18
19 GNU Emacs is distributed in the hope that it will be useful,
20 but WITHOUT ANY WARRANTY; without even the implied warranty of
21 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
22 GNU General Public License for more details.
23
24 You should have received a copy of the GNU General Public License
25 along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. */
26
27 /* #define FONTSET_DEBUG */
28
29 #include <config.h>
30 #include <stdio.h>
31 #include <setjmp.h>
32
33 #include "lisp.h"
34 #include "blockinput.h"
35 #include "buffer.h"
36 #include "character.h"
37 #include "charset.h"
38 #include "ccl.h"
39 #include "keyboard.h"
40 #include "frame.h"
41 #include "dispextern.h"
42 #include "intervals.h"
43 #include "fontset.h"
44 #include "window.h"
45 #ifdef HAVE_X_WINDOWS
46 #include "xterm.h"
47 #endif
48 #ifdef WINDOWSNT
49 #include "w32term.h"
50 #endif
51 #ifdef HAVE_NS
52 #include "nsterm.h"
53 #endif
54 #include "termhooks.h"
55
56 #include "font.h"
57
58 #undef xassert
59 #ifdef FONTSET_DEBUG
60 #define xassert(X) do {if (!(X)) abort ();} while (0)
61 #undef INLINE
62 #define INLINE
63 #else /* not FONTSET_DEBUG */
64 #define xassert(X) (void) 0
65 #endif /* not FONTSET_DEBUG */
66
67 EXFUN (Fclear_face_cache, 1);
68
69 /* FONTSET
70
71 A fontset is a collection of font related information to give
72 similar appearance (style, etc) of characters. A fontset has two
73 roles. One is to use for the frame parameter `font' as if it is an
74 ASCII font. In that case, Emacs uses the font specified for
75 `ascii' script for the frame's default font.
76
77 Another role, the more important one, is to provide information
78 about which font to use for each non-ASCII character.
79
80 There are two kinds of fontsets; base and realized. A base fontset
81 is created by `new-fontset' from Emacs Lisp explicitly. A realized
82 fontset is created implicitly when a face is realized for ASCII
83 characters. A face is also realized for non-ASCII characters based
84 on an ASCII face. All of non-ASCII faces based on the same ASCII
85 face share the same realized fontset.
86
87 A fontset object is implemented by a char-table whose default value
88 and parent are always nil.
89
90 An element of a base fontset is a vector of FONT-DEFs which itself
91 is a vector [ FONT-SPEC ENCODING REPERTORY ].
92
93 An element of a realized fontset is nil, t, 0, or a vector of this
94 form:
95
96 [ CHARSET-ORDERED-LIST-TICK PREFERRED-RFONT-DEF
97 RFONT-DEF0 RFONT-DEF1 ... ]
98
99 RFONT-DEFn (i.e. Realized FONT-DEF) has this form:
100
101 [ FACE-ID FONT-DEF FONT-OBJECT SORTING-SCORE ]
102
103 RFONT-DEFn are automatically reordered by the current charset
104 priority list.
105
106 The value nil means that we have not yet generated the above vector
107 from the base of the fontset.
108
109 The value t means that no font is available for the corresponding
110 range of characters.
111
112 The value 0 means that no font is available for the corresponding
113 range of characters in this fontset, but may be available in the
114 default fontset.
115
116
117 A fontset has 9 extra slots.
118
119 The 1st slot: the ID number of the fontset
120
121 The 2nd slot:
122 base: the name of the fontset
123 realized: nil
124
125 The 3rd slot:
126 base: nil
127 realized: the base fontset
128
129 The 4th slot:
130 base: nil
131 realized: the frame that the fontset belongs to
132
133 The 5th slot:
134 base: the font name for ASCII characters
135 realized: nil
136
137 The 6th slot:
138 base: nil
139 realized: the ID number of a face to use for characters that
140 has no font in a realized fontset.
141
142 The 7th slot:
143 base: nil
144 realized: Alist of font index vs the corresponding repertory
145 char-table.
146
147 The 8th slot:
148 base: nil
149 realized: If the base is not the default fontset, a fontset
150 realized from the default fontset, else nil.
151
152 The 9th slot:
153 base: Same as element value (but for fallback fonts).
154 realized: Likewise.
155
156 All fontsets are recorded in the vector Vfontset_table.
157
158
159 DEFAULT FONTSET
160
161 There's a special base fontset named `default fontset' which
162 defines the default font specifications. When a base fontset
163 doesn't specify a font for a specific character, the corresponding
164 value in the default fontset is used.
165
166 The parent of a realized fontset created for such a face that has
167 no fontset is the default fontset.
168
169
170 These structures are hidden from the other codes than this file.
171 The other codes handle fontsets only by their ID numbers. They
172 usually use the variable name `fontset' for IDs. But, in this
173 file, we always use varialbe name `id' for IDs, and name `fontset'
174 for an actual fontset object, i.e., char-table.
175
176 */
177
178 /********** VARIABLES and FUNCTION PROTOTYPES **********/
179
180 extern Lisp_Object Qfont;
181 static Lisp_Object Qfontset;
182 static Lisp_Object Qfontset_info;
183 static Lisp_Object Qprepend, Qappend;
184 Lisp_Object Qlatin;
185
186 /* Vector containing all fontsets. */
187 static Lisp_Object Vfontset_table;
188
189 /* Next possibly free fontset ID. Usually this keeps the minimum
190 fontset ID not yet used. */
191 static int next_fontset_id;
192
193 /* The default fontset. This gives default FAMILY and REGISTRY of
194 font for each character. */
195 static Lisp_Object Vdefault_fontset;
196
197 Lisp_Object Vfont_encoding_charset_alist;
198 Lisp_Object Vuse_default_ascent;
199 Lisp_Object Vignore_relative_composition;
200 Lisp_Object Valternate_fontname_alist;
201 Lisp_Object Vfontset_alias_alist;
202 Lisp_Object Vvertical_centering_font_regexp;
203 Lisp_Object Votf_script_alist;
204
205 /* Check if any window system is used now. */
206 void (*check_window_system_func) P_ ((void));
207
208
209 /* Prototype declarations for static functions. */
210 static Lisp_Object fontset_add P_ ((Lisp_Object, Lisp_Object, Lisp_Object,
211 Lisp_Object));
212 static Lisp_Object fontset_find_font P_ ((Lisp_Object, int, struct face *,
213 int, int));
214 static void reorder_font_vector P_ ((Lisp_Object, struct font *));
215 static Lisp_Object fontset_font P_ ((Lisp_Object, int, struct face *, int));
216 static Lisp_Object make_fontset P_ ((Lisp_Object, Lisp_Object, Lisp_Object));
217 static Lisp_Object fontset_pattern_regexp P_ ((Lisp_Object));
218 static void accumulate_script_ranges P_ ((Lisp_Object, Lisp_Object,
219 Lisp_Object));
220 Lisp_Object find_font_encoding P_ ((Lisp_Object));
221
222 static void set_fontset_font P_ ((Lisp_Object, Lisp_Object));
223
224 #ifdef FONTSET_DEBUG
225
226 /* Return 1 if ID is a valid fontset id, else return 0. */
227
228 static int
229 fontset_id_valid_p (id)
230 int id;
231 {
232 return (id >= 0 && id < ASIZE (Vfontset_table) - 1);
233 }
234
235 #endif
236
237
238 \f
239 /********** MACROS AND FUNCTIONS TO HANDLE FONTSET **********/
240
241 /* Return the fontset with ID. No check of ID's validness. */
242 #define FONTSET_FROM_ID(id) AREF (Vfontset_table, id)
243
244 /* Macros to access special values of FONTSET. */
245 #define FONTSET_ID(fontset) XCHAR_TABLE (fontset)->extras[0]
246
247 /* Macros to access special values of (base) FONTSET. */
248 #define FONTSET_NAME(fontset) XCHAR_TABLE (fontset)->extras[1]
249 #define FONTSET_ASCII(fontset) XCHAR_TABLE (fontset)->extras[4]
250 #define FONTSET_SPEC(fontset) XCHAR_TABLE (fontset)->extras[5]
251
252 /* Macros to access special values of (realized) FONTSET. */
253 #define FONTSET_BASE(fontset) XCHAR_TABLE (fontset)->extras[2]
254 #define FONTSET_FRAME(fontset) XCHAR_TABLE (fontset)->extras[3]
255 #define FONTSET_OBJLIST(fontset) XCHAR_TABLE (fontset)->extras[4]
256 #define FONTSET_NOFONT_FACE(fontset) XCHAR_TABLE (fontset)->extras[5]
257 #define FONTSET_REPERTORY(fontset) XCHAR_TABLE (fontset)->extras[6]
258 #define FONTSET_DEFAULT(fontset) XCHAR_TABLE (fontset)->extras[7]
259
260 /* For both base and realized fontset. */
261 #define FONTSET_FALLBACK(fontset) XCHAR_TABLE (fontset)->extras[8]
262
263 #define BASE_FONTSET_P(fontset) (NILP (FONTSET_BASE (fontset)))
264
265
266 /* Macros for FONT-DEF and RFONT-DEF of fontset. */
267 #define FONT_DEF_NEW(font_def, font_spec, encoding, repertory) \
268 do { \
269 (font_def) = Fmake_vector (make_number (3), (font_spec)); \
270 ASET ((font_def), 1, encoding); \
271 ASET ((font_def), 2, repertory); \
272 } while (0)
273
274 #define FONT_DEF_SPEC(font_def) AREF (font_def, 0)
275 #define FONT_DEF_ENCODING(font_def) AREF (font_def, 1)
276 #define FONT_DEF_REPERTORY(font_def) AREF (font_def, 2)
277
278 #define RFONT_DEF_FACE(rfont_def) AREF (rfont_def, 0)
279 #define RFONT_DEF_SET_FACE(rfont_def, face_id) \
280 ASET ((rfont_def), 0, make_number (face_id))
281 #define RFONT_DEF_FONT_DEF(rfont_def) AREF (rfont_def, 1)
282 #define RFONT_DEF_SPEC(rfont_def) FONT_DEF_SPEC (AREF (rfont_def, 1))
283 #define RFONT_DEF_REPERTORY(rfont_def) FONT_DEF_REPERTORY (AREF (rfont_def, 1))
284 #define RFONT_DEF_OBJECT(rfont_def) AREF (rfont_def, 2)
285 #define RFONT_DEF_SET_OBJECT(rfont_def, object) \
286 ASET ((rfont_def), 2, (object))
287 #define RFONT_DEF_SCORE(rfont_def) XINT (AREF (rfont_def, 3))
288 #define RFONT_DEF_SET_SCORE(rfont_def, score) \
289 ASET ((rfont_def), 3, make_number (score))
290 #define RFONT_DEF_NEW(rfont_def, font_def) \
291 do { \
292 (rfont_def) = Fmake_vector (make_number (4), Qnil); \
293 ASET ((rfont_def), 1, (font_def)); \
294 RFONT_DEF_SET_SCORE ((rfont_def), 0); \
295 } while (0)
296
297
298 /* Return the element of FONTSET for the character C. If FONTSET is a
299 base fontset other then the default fontset and FONTSET doesn't
300 contain information for C, return the information in the default
301 fontset. */
302
303 #define FONTSET_REF(fontset, c) \
304 (EQ (fontset, Vdefault_fontset) \
305 ? CHAR_TABLE_REF (fontset, c) \
306 : fontset_ref ((fontset), (c)))
307
308 static Lisp_Object
309 fontset_ref (fontset, c)
310 Lisp_Object fontset;
311 int c;
312 {
313 Lisp_Object elt;
314
315 elt = CHAR_TABLE_REF (fontset, c);
316 if (NILP (elt) && ! EQ (fontset, Vdefault_fontset)
317 /* Don't check Vdefault_fontset for a realized fontset. */
318 && NILP (FONTSET_BASE (fontset)))
319 elt = CHAR_TABLE_REF (Vdefault_fontset, c);
320 return elt;
321 }
322
323 /* Set elements of FONTSET for characters in RANGE to the value ELT.
324 RANGE is a cons (FROM . TO), where FROM and TO are character codes
325 specifying a range. */
326
327 #define FONTSET_SET(fontset, range, elt) \
328 Fset_char_table_range ((fontset), (range), (elt))
329
330
331 /* Modify the elements of FONTSET for characters in RANGE by replacing
332 with ELT or adding ELT. RANGE is a cons (FROM . TO), where FROM
333 and TO are character codes specifying a range. If ADD is nil,
334 replace with ELT, if ADD is `prepend', prepend ELT, otherwise,
335 append ELT. */
336
337 #define FONTSET_ADD(fontset, range, elt, add) \
338 (NILP (add) \
339 ? (NILP (range) \
340 ? (FONTSET_FALLBACK (fontset) = Fmake_vector (make_number (1), (elt))) \
341 : Fset_char_table_range ((fontset), (range), \
342 Fmake_vector (make_number (1), (elt)))) \
343 : fontset_add ((fontset), (range), (elt), (add)))
344
345 static Lisp_Object
346 fontset_add (fontset, range, elt, add)
347 Lisp_Object fontset, range, elt, add;
348 {
349 Lisp_Object args[2];
350 int idx = (EQ (add, Qappend) ? 0 : 1);
351
352 args[1 - idx] = Fmake_vector (make_number (1), elt);
353
354 if (CONSP (range))
355 {
356 int from = XINT (XCAR (range));
357 int to = XINT (XCDR (range));
358 int from1, to1;
359
360 do {
361 from1 = from, to1 = to;
362 args[idx] = char_table_ref_and_range (fontset, from, &from1, &to1);
363 char_table_set_range (fontset, from, to1,
364 NILP (args[idx]) ? args[1 - idx]
365 : Fvconcat (2, args));
366 from = to1 + 1;
367 } while (from < to);
368 }
369 else
370 {
371 args[idx] = FONTSET_FALLBACK (fontset);
372 FONTSET_FALLBACK (fontset)
373 = NILP (args[idx]) ? args[1 - idx] : Fvconcat (2, args);
374 }
375 return Qnil;
376 }
377
378 static int
379 fontset_compare_rfontdef (val1, val2)
380 const void *val1, *val2;
381 {
382 return (RFONT_DEF_SCORE (*(Lisp_Object *) val1)
383 - RFONT_DEF_SCORE (*(Lisp_Object *) val2));
384 }
385
386 /* Update FONT-GROUP which has this form:
387 [ CHARSET-ORDERED-LIST-TICK PREFERRED-RFONT-DEF
388 RFONT-DEF0 RFONT-DEF1 ... ]
389 Reorder RFONT-DEFs according to the current language, and update
390 CHARSET-ORDERED-LIST-TICK.
391
392 If PREFERRED_FAMILY is not nil, that family has the higher priority
393 if the encoding charsets or languages in font-specs are the same. */
394
395 extern Lisp_Object Fassoc_string ();
396
397 static void
398 reorder_font_vector (font_group, font)
399 Lisp_Object font_group;
400 struct font *font;
401 {
402 Lisp_Object vec, font_object;
403 int size;
404 int i;
405 int score_changed = 0;
406
407 if (font)
408 XSETFONT (font_object, font);
409 else
410 font_object = Qnil;
411
412 vec = XCDR (font_group);
413 size = ASIZE (vec);
414 /* Exclude the tailing nil element from the reordering. */
415 if (NILP (AREF (vec, size - 1)))
416 size--;
417
418 for (i = 0; i < size; i++)
419 {
420 Lisp_Object rfont_def = AREF (vec, i);
421 Lisp_Object font_def = RFONT_DEF_FONT_DEF (rfont_def);
422 Lisp_Object font_spec = FONT_DEF_SPEC (font_def);
423 int score = RFONT_DEF_SCORE (rfont_def) & 0xFF;
424
425 if (! font_match_p (font_spec, font_object))
426 {
427 Lisp_Object encoding = FONT_DEF_ENCODING (font_def);
428
429 if (! NILP (encoding))
430 {
431 Lisp_Object tail;
432
433 for (tail = Vcharset_ordered_list;
434 ! EQ (tail, Vcharset_non_preferred_head) && CONSP (tail);
435 score += 0x100, tail = XCDR (tail))
436 if (EQ (encoding, XCAR (tail)))
437 break;
438 }
439 else
440 {
441 Lisp_Object lang = Ffont_get (font_spec, QClang);
442
443 if (! NILP (lang)
444 && ! EQ (lang, Vcurrent_iso639_language)
445 && (! CONSP (Vcurrent_iso639_language)
446 || NILP (Fmemq (lang, Vcurrent_iso639_language))))
447 score |= 0x100;
448 }
449 }
450 if (RFONT_DEF_SCORE (rfont_def) != score)
451 {
452 RFONT_DEF_SET_SCORE (rfont_def, score);
453 score_changed = 1;
454 }
455 }
456
457 if (score_changed)
458 qsort (XVECTOR (vec)->contents, size, sizeof (Lisp_Object),
459 fontset_compare_rfontdef);
460 XSETCAR (font_group, make_number (charset_ordered_list_tick));
461 }
462
463 /* Return a font-group (actually a cons (-1 . FONT-GROUP-VECTOR)) for
464 character C in FONTSET. If C is -1, return a fallback font-group.
465 If C is not -1, the value may be Qt (FONTSET doesn't have a font
466 for C even in the fallback group), or 0 (a font for C may be found
467 only in the fallback group). */
468
469 static Lisp_Object
470 fontset_get_font_group (Lisp_Object fontset, int c)
471 {
472 Lisp_Object font_group;
473 Lisp_Object base_fontset;
474 int from = 0, to = MAX_CHAR, i;
475
476 xassert (! BASE_FONTSET_P (fontset));
477 if (c >= 0)
478 font_group = CHAR_TABLE_REF (fontset, c);
479 else
480 font_group = FONTSET_FALLBACK (fontset);
481 if (! NILP (font_group))
482 return font_group;
483 base_fontset = FONTSET_BASE (fontset);
484 if (NILP (base_fontset))
485 font_group = Qnil;
486 else if (c >= 0)
487 font_group = char_table_ref_and_range (base_fontset, c, &from, &to);
488 else
489 font_group = FONTSET_FALLBACK (base_fontset);
490 if (NILP (font_group))
491 {
492 font_group = make_number (0);
493 if (c >= 0)
494 char_table_set_range (fontset, from, to, font_group);
495 return font_group;
496 }
497 if (!VECTORP (font_group))
498 return font_group;
499 font_group = Fcopy_sequence (font_group);
500 for (i = 0; i < ASIZE (font_group); i++)
501 if (! NILP (AREF (font_group, i)))
502 {
503 Lisp_Object rfont_def;
504
505 RFONT_DEF_NEW (rfont_def, AREF (font_group, i));
506 /* Remember the original order. */
507 RFONT_DEF_SET_SCORE (rfont_def, i);
508 ASET (font_group, i, rfont_def);
509 }
510 font_group = Fcons (make_number (-1), font_group);
511 if (c >= 0)
512 char_table_set_range (fontset, from, to, font_group);
513 else
514 FONTSET_FALLBACK (fontset) = font_group;
515 return font_group;
516 }
517
518 /* Return RFONT-DEF (vector) in the realized fontset FONTSET for the
519 character C. If no font is found, return Qnil if there's a
520 possibility that the default fontset or the fallback font groups
521 have a proper font, and return Qt if not.
522
523 If a font is found but is not yet opened, open it (if FACE is not
524 NULL) or return Qnil (if FACE is NULL).
525
526 ID is a charset-id that must be preferred, or -1 meaning no
527 preference.
528
529 If FALLBACK is nonzero, search only fallback fonts. */
530
531 static Lisp_Object
532 fontset_find_font (fontset, c, face, id, fallback)
533 Lisp_Object fontset;
534 int c;
535 struct face *face;
536 int id, fallback;
537 {
538 Lisp_Object vec, font_group;
539 int i, charset_matched = 0, found_index;
540 FRAME_PTR f = (FRAMEP (FONTSET_FRAME (fontset))
541 ? XFRAME (FONTSET_FRAME (fontset)) : XFRAME (selected_frame));
542 Lisp_Object rfont_def;
543
544 font_group = fontset_get_font_group (fontset, fallback ? -1 : c);
545 if (! CONSP (font_group))
546 return font_group;
547 vec = XCDR (font_group);
548 if (ASIZE (vec) == 0)
549 return Qnil;
550
551 if (ASIZE (vec) > 1)
552 {
553 if (XINT (XCAR (font_group)) != charset_ordered_list_tick)
554 /* We have just created the font-group,
555 or the charset priorities were changed. */
556 reorder_font_vector (font_group, face->ascii_face->font);
557 if (id >= 0)
558 /* Find a spec matching with the charset ID to try at
559 first. */
560 for (i = 0; i < ASIZE (vec); i++)
561 {
562 Lisp_Object repertory;
563
564 rfont_def = AREF (vec, i);
565 if (NILP (rfont_def))
566 break;
567 repertory = FONT_DEF_REPERTORY (RFONT_DEF_FONT_DEF (rfont_def));
568
569 if (XINT (repertory) == id)
570 {
571 charset_matched = i;
572 break;
573 }
574 }
575 }
576
577 /* Find the first available font in the vector of RFONT-DEF. */
578 for (i = 0; i < ASIZE (vec); i++)
579 {
580 Lisp_Object font_def;
581 Lisp_Object font_entity, font_object;
582
583 found_index = i;
584 if (i == 0)
585 {
586 if (charset_matched > 0)
587 {
588 /* Try the element matching with the charset ID at first. */
589 found_index = charset_matched;
590 /* Make this negative so that we don't come here in the
591 next loop. */
592 charset_matched = - charset_matched;
593 /* We must try the first element in the next loop. */
594 i--;
595 }
596 }
597 else if (i == - charset_matched)
598 {
599 /* We have already tried this element and the followings
600 that have the same font specifications in the first
601 iteration. So, skip them all. */
602 rfont_def = AREF (vec, i);
603 font_def = RFONT_DEF_FONT_DEF (rfont_def);
604 for (; i + 1 < ASIZE (vec); i++)
605 {
606 rfont_def = AREF (vec, i + 1);
607 if (NILP (rfont_def))
608 break;
609 if (! EQ (RFONT_DEF_FONT_DEF (rfont_def), font_def))
610 break;
611 }
612 continue;
613 }
614
615 rfont_def = AREF (vec, found_index);
616 if (NILP (rfont_def))
617 {
618 if (i < 0)
619 continue;
620 /* This is a sign of not to try the other fonts. */
621 return Qt;
622 }
623 if (INTEGERP (RFONT_DEF_FACE (rfont_def))
624 && XINT (RFONT_DEF_FACE (rfont_def)) < 0)
625 /* We couldn't open this font last time. */
626 continue;
627
628 font_object = RFONT_DEF_OBJECT (rfont_def);
629 if (NILP (font_object))
630 {
631 font_def = RFONT_DEF_FONT_DEF (rfont_def);
632
633 if (! face)
634 /* We have not yet opened the font. */
635 return Qnil;
636 /* Find a font best-matching with the spec without checking
637 the support of the character C. That checking is costly,
638 and even without the checking, the found font supports C
639 in high possibility. */
640 font_entity = font_find_for_lface (f, face->lface,
641 FONT_DEF_SPEC (font_def), -1);
642 if (NILP (font_entity))
643 {
644 /* Record that no font matches the spec. */
645 RFONT_DEF_SET_FACE (rfont_def, -1);
646 continue;
647 }
648 font_object = font_open_for_lface (f, font_entity, face->lface,
649 FONT_DEF_SPEC (font_def));
650 if (NILP (font_object))
651 {
652 /* Something strange happened, perhaps because of a
653 Font-backend problem. Too avoid crashing, record
654 that this spec is unsable. It may be better to find
655 another font of the same spec, but currently we don't
656 have such an API. */
657 RFONT_DEF_SET_FACE (rfont_def, -1);
658 continue;
659 }
660 RFONT_DEF_SET_OBJECT (rfont_def, font_object);
661 }
662
663 if (font_has_char (f, font_object, c))
664 goto found;
665
666 /* Find a font already opened, maching with the current spec,
667 and supporting C. */
668 font_def = RFONT_DEF_FONT_DEF (rfont_def);
669 for (; found_index + 1 < ASIZE (vec); found_index++)
670 {
671 rfont_def = AREF (vec, found_index + 1);
672 if (NILP (rfont_def))
673 break;
674 if (! EQ (RFONT_DEF_FONT_DEF (rfont_def), font_def))
675 break;
676 font_object = RFONT_DEF_OBJECT (rfont_def);
677 if (! NILP (font_object) && font_has_char (f, font_object, c))
678 {
679 found_index++;
680 goto found;
681 }
682 }
683
684 /* Find a font-entity with the current spec and supporting C. */
685 font_entity = font_find_for_lface (f, face->lface,
686 FONT_DEF_SPEC (font_def), c);
687 if (! NILP (font_entity))
688 {
689 /* We found a font. Open it and insert a new element for
690 that font in VEC. */
691 Lisp_Object new_vec;
692 int j;
693
694 font_object = font_open_for_lface (f, font_entity, face->lface,
695 Qnil);
696 if (NILP (font_object))
697 continue;
698 RFONT_DEF_NEW (rfont_def, font_def);
699 RFONT_DEF_SET_OBJECT (rfont_def, font_object);
700 RFONT_DEF_SET_SCORE (rfont_def, RFONT_DEF_SCORE (rfont_def));
701 new_vec = Fmake_vector (make_number (ASIZE (vec) + 1), Qnil);
702 found_index++;
703 for (j = 0; j < found_index; j++)
704 ASET (new_vec, j, AREF (vec, j));
705 ASET (new_vec, j, rfont_def);
706 for (j++; j < ASIZE (new_vec); j++)
707 ASET (new_vec, j, AREF (vec, j - 1));
708 XSETCDR (font_group, new_vec);
709 vec = new_vec;
710 goto found;
711 }
712 if (i >= 0)
713 i = found_index;
714 }
715
716 FONTSET_SET (fontset, make_number (c), make_number (0));
717 return Qnil;
718
719 found:
720 if (fallback && found_index > 0)
721 {
722 /* The order of fonts in the fallback font-group is not that
723 important, and it is better to move the found font to the
724 first of the group so that the next try will find it
725 quickly. */
726 for (i = found_index; i > 0; i--)
727 ASET (vec, i, AREF (vec, i - 1));
728 ASET (vec, 0, rfont_def);
729 }
730 return rfont_def;
731 }
732
733
734 static Lisp_Object
735 fontset_font (fontset, c, face, id)
736 Lisp_Object fontset;
737 int c;
738 struct face *face;
739 int id;
740 {
741 Lisp_Object rfont_def, default_rfont_def;
742 Lisp_Object base_fontset;
743
744 /* Try a font-group of FONTSET. */
745 FONT_DEFERRED_LOG ("current fontset: font for", make_number (c), Qnil);
746 rfont_def = fontset_find_font (fontset, c, face, id, 0);
747 if (VECTORP (rfont_def))
748 return rfont_def;
749 if (NILP (rfont_def))
750 FONTSET_SET (fontset, make_number (c), make_number (0));
751
752 /* Try a font-group of the default fontset. */
753 base_fontset = FONTSET_BASE (fontset);
754 if (! EQ (base_fontset, Vdefault_fontset))
755 {
756 if (NILP (FONTSET_DEFAULT (fontset)))
757 FONTSET_DEFAULT (fontset)
758 = make_fontset (FONTSET_FRAME (fontset), Qnil, Vdefault_fontset);
759 FONT_DEFERRED_LOG ("default fontset: font for", make_number (c), Qnil);
760 default_rfont_def
761 = fontset_find_font (FONTSET_DEFAULT (fontset), c, face, id, 0);
762 if (VECTORP (default_rfont_def))
763 return default_rfont_def;
764 if (NILP (default_rfont_def))
765 FONTSET_SET (FONTSET_DEFAULT (fontset), make_number (c),
766 make_number (0));
767 }
768
769 /* Try a fallback font-group of FONTSET. */
770 if (! EQ (rfont_def, Qt))
771 {
772 FONT_DEFERRED_LOG ("current fallback: font for", make_number (c), Qnil);
773 rfont_def = fontset_find_font (fontset, c, face, id, 1);
774 if (VECTORP (rfont_def))
775 return rfont_def;
776 /* Remember that FONTSET has no font for C. */
777 FONTSET_SET (fontset, make_number (c), Qt);
778 }
779
780 /* Try a fallback font-group of the default fontset. */
781 if (! EQ (base_fontset, Vdefault_fontset)
782 && ! EQ (default_rfont_def, Qt))
783 {
784 FONT_DEFERRED_LOG ("default fallback: font for", make_number (c), Qnil);
785 rfont_def = fontset_find_font (FONTSET_DEFAULT (fontset), c, face, id, 1);
786 if (VECTORP (rfont_def))
787 return rfont_def;
788 /* Remember that the default fontset has no font for C. */
789 FONTSET_SET (FONTSET_DEFAULT (fontset), make_number (c), Qt);
790 }
791
792 return Qnil;
793 }
794
795 /* Return a newly created fontset with NAME. If BASE is nil, make a
796 base fontset. Otherwise make a realized fontset whose base is
797 BASE. */
798
799 static Lisp_Object
800 make_fontset (frame, name, base)
801 Lisp_Object frame, name, base;
802 {
803 Lisp_Object fontset;
804 int size = ASIZE (Vfontset_table);
805 int id = next_fontset_id;
806
807 /* Find a free slot in Vfontset_table. Usually, next_fontset_id is
808 the next available fontset ID. So it is expected that this loop
809 terminates quickly. In addition, as the last element of
810 Vfontset_table is always nil, we don't have to check the range of
811 id. */
812 while (!NILP (AREF (Vfontset_table, id))) id++;
813
814 if (id + 1 == size)
815 Vfontset_table = larger_vector (Vfontset_table, size + 32, Qnil);
816
817 fontset = Fmake_char_table (Qfontset, Qnil);
818
819 FONTSET_ID (fontset) = make_number (id);
820 if (NILP (base))
821 {
822 FONTSET_NAME (fontset) = name;
823 }
824 else
825 {
826 FONTSET_NAME (fontset) = Qnil;
827 FONTSET_FRAME (fontset) = frame;
828 FONTSET_BASE (fontset) = base;
829 }
830
831 ASET (Vfontset_table, id, fontset);
832 next_fontset_id = id + 1;
833 return fontset;
834 }
835
836 \f
837 /********** INTERFACES TO xfaces.c, xfns.c, and dispextern.h **********/
838
839 /* Return the name of the fontset who has ID. */
840
841 Lisp_Object
842 fontset_name (id)
843 int id;
844 {
845 Lisp_Object fontset;
846
847 fontset = FONTSET_FROM_ID (id);
848 return FONTSET_NAME (fontset);
849 }
850
851
852 /* Return the ASCII font name of the fontset who has ID. */
853
854 Lisp_Object
855 fontset_ascii (id)
856 int id;
857 {
858 Lisp_Object fontset, elt;
859
860 fontset= FONTSET_FROM_ID (id);
861 elt = FONTSET_ASCII (fontset);
862 if (CONSP (elt))
863 elt = XCAR (elt);
864 return elt;
865 }
866
867 void
868 free_realized_fontset (f, fontset)
869 FRAME_PTR f;
870 Lisp_Object fontset;
871 {
872 Lisp_Object tail;
873
874 return;
875 for (tail = FONTSET_OBJLIST (fontset); CONSP (tail); tail = XCDR (tail))
876 {
877 xassert (FONT_OBJECT_P (XCAR (tail)));
878 font_close_object (f, XCAR (tail));
879 }
880 }
881
882 /* Free fontset of FACE defined on frame F. Called from
883 free_realized_face. */
884
885 void
886 free_face_fontset (f, face)
887 FRAME_PTR f;
888 struct face *face;
889 {
890 Lisp_Object fontset;
891
892 fontset = FONTSET_FROM_ID (face->fontset);
893 if (NILP (fontset))
894 return;
895 xassert (! BASE_FONTSET_P (fontset));
896 xassert (f == XFRAME (FONTSET_FRAME (fontset)));
897 free_realized_fontset (f, fontset);
898 ASET (Vfontset_table, face->fontset, Qnil);
899 if (face->fontset < next_fontset_id)
900 next_fontset_id = face->fontset;
901 if (! NILP (FONTSET_DEFAULT (fontset)))
902 {
903 int id = XINT (FONTSET_ID (FONTSET_DEFAULT (fontset)));
904
905 fontset = AREF (Vfontset_table, id);
906 xassert (!NILP (fontset) && ! BASE_FONTSET_P (fontset));
907 xassert (f == XFRAME (FONTSET_FRAME (fontset)));
908 free_realized_fontset (f, fontset);
909 ASET (Vfontset_table, id, Qnil);
910 if (id < next_fontset_id)
911 next_fontset_id = face->fontset;
912 }
913 face->fontset = -1;
914 }
915
916
917 /* Return 1 if FACE is suitable for displaying character C.
918 Otherwise return 0. Called from the macro FACE_SUITABLE_FOR_CHAR_P
919 when C is not an ASCII character. */
920
921 int
922 face_suitable_for_char_p (face, c)
923 struct face *face;
924 int c;
925 {
926 Lisp_Object fontset, rfont_def;
927
928 fontset = FONTSET_FROM_ID (face->fontset);
929 rfont_def = fontset_font (fontset, c, NULL, -1);
930 return (VECTORP (rfont_def)
931 && INTEGERP (RFONT_DEF_FACE (rfont_def))
932 && face->id == XINT (RFONT_DEF_FACE (rfont_def)));
933 }
934
935
936 /* Return ID of face suitable for displaying character C on frame F.
937 FACE must be reazlied for ASCII characters in advance. Called from
938 the macro FACE_FOR_CHAR. */
939
940 int
941 face_for_char (f, face, c, pos, object)
942 FRAME_PTR f;
943 struct face *face;
944 int c, pos;
945 Lisp_Object object;
946 {
947 Lisp_Object fontset, rfont_def, charset;
948 int face_id;
949 int id;
950
951 /* If face->fontset is negative (that happens when no font is found
952 for face), just return face->ascii_face because we can't do
953 anything. Perhaps, we should fix the callers to assure
954 that face->fontset is always valid. */
955 if (ASCII_CHAR_P (c) || face->fontset < 0)
956 return face->ascii_face->id;
957
958 xassert (fontset_id_valid_p (face->fontset));
959 fontset = FONTSET_FROM_ID (face->fontset);
960 xassert (!BASE_FONTSET_P (fontset));
961
962 if (pos < 0)
963 {
964 id = -1;
965 charset = Qnil;
966 }
967 else
968 {
969 charset = Fget_char_property (make_number (pos), Qcharset, object);
970 if (CHARSETP (charset))
971 {
972 Lisp_Object val;
973
974 val = assq_no_quit (charset, Vfont_encoding_charset_alist);
975 if (CONSP (val) && CHARSETP (XCDR (val)))
976 charset = XCDR (val);
977 id = XINT (CHARSET_SYMBOL_ID (charset));
978 }
979 else
980 id = -1;
981 }
982
983 rfont_def = fontset_font (fontset, c, face, id);
984 if (VECTORP (rfont_def))
985 {
986 if (INTEGERP (RFONT_DEF_FACE (rfont_def)))
987 face_id = XINT (RFONT_DEF_FACE (rfont_def));
988 else
989 {
990 Lisp_Object font_object;
991
992 font_object = RFONT_DEF_OBJECT (rfont_def);
993 face_id = face_for_font (f, font_object, face);
994 RFONT_DEF_SET_FACE (rfont_def, face_id);
995 }
996 }
997 else
998 {
999 if (INTEGERP (FONTSET_NOFONT_FACE (fontset)))
1000 face_id = XINT (FONTSET_NOFONT_FACE (fontset));
1001 else
1002 {
1003 face_id = face_for_font (f, Qnil, face);
1004 FONTSET_NOFONT_FACE (fontset) = make_number (face_id);
1005 }
1006 }
1007 xassert (face_id >= 0);
1008 return face_id;
1009 }
1010
1011
1012 Lisp_Object
1013 font_for_char (face, c, pos, object)
1014 struct face *face;
1015 int c, pos;
1016 Lisp_Object object;
1017 {
1018 Lisp_Object fontset, rfont_def, charset;
1019 int id;
1020
1021 if (ASCII_CHAR_P (c))
1022 {
1023 Lisp_Object font_object;
1024
1025 XSETFONT (font_object, face->ascii_face->font);
1026 return font_object;
1027 }
1028
1029 xassert (fontset_id_valid_p (face->fontset));
1030 fontset = FONTSET_FROM_ID (face->fontset);
1031 xassert (!BASE_FONTSET_P (fontset));
1032 if (pos < 0)
1033 {
1034 id = -1;
1035 charset = Qnil;
1036 }
1037 else
1038 {
1039 charset = Fget_char_property (make_number (pos), Qcharset, object);
1040 if (CHARSETP (charset))
1041 {
1042 Lisp_Object val;
1043
1044 val = assq_no_quit (charset, Vfont_encoding_charset_alist);
1045 if (CONSP (val) && CHARSETP (XCDR (val)))
1046 charset = XCDR (val);
1047 id = XINT (CHARSET_SYMBOL_ID (charset));
1048 }
1049 else
1050 id = -1;
1051 }
1052
1053 rfont_def = fontset_font (fontset, c, face, id);
1054 return (VECTORP (rfont_def)
1055 ? RFONT_DEF_OBJECT (rfont_def)
1056 : Qnil);
1057 }
1058
1059
1060 /* Make a realized fontset for ASCII face FACE on frame F from the
1061 base fontset BASE_FONTSET_ID. If BASE_FONTSET_ID is -1, use the
1062 default fontset as the base. Value is the id of the new fontset.
1063 Called from realize_x_face. */
1064
1065 int
1066 make_fontset_for_ascii_face (f, base_fontset_id, face)
1067 FRAME_PTR f;
1068 int base_fontset_id;
1069 struct face *face;
1070 {
1071 Lisp_Object base_fontset, fontset, frame;
1072
1073 XSETFRAME (frame, f);
1074 if (base_fontset_id >= 0)
1075 {
1076 base_fontset = FONTSET_FROM_ID (base_fontset_id);
1077 if (!BASE_FONTSET_P (base_fontset))
1078 base_fontset = FONTSET_BASE (base_fontset);
1079 if (! BASE_FONTSET_P (base_fontset))
1080 abort ();
1081 }
1082 else
1083 base_fontset = Vdefault_fontset;
1084
1085 fontset = make_fontset (frame, Qnil, base_fontset);
1086 return XINT (FONTSET_ID (fontset));
1087 }
1088
1089 \f
1090
1091 /* Cache data used by fontset_pattern_regexp. The car part is a
1092 pattern string containing at least one wild card, the cdr part is
1093 the corresponding regular expression. */
1094 static Lisp_Object Vcached_fontset_data;
1095
1096 #define CACHED_FONTSET_NAME ((char *) SDATA (XCAR (Vcached_fontset_data)))
1097 #define CACHED_FONTSET_REGEX (XCDR (Vcached_fontset_data))
1098
1099 /* If fontset name PATTERN contains any wild card, return regular
1100 expression corresponding to PATTERN. */
1101
1102 static Lisp_Object
1103 fontset_pattern_regexp (pattern)
1104 Lisp_Object pattern;
1105 {
1106 if (!index ((char *) SDATA (pattern), '*')
1107 && !index ((char *) SDATA (pattern), '?'))
1108 /* PATTERN does not contain any wild cards. */
1109 return Qnil;
1110
1111 if (!CONSP (Vcached_fontset_data)
1112 || strcmp ((char *) SDATA (pattern), CACHED_FONTSET_NAME))
1113 {
1114 /* We must at first update the cached data. */
1115 unsigned char *regex, *p0, *p1;
1116 int ndashes = 0, nstars = 0, nescs = 0;
1117
1118 for (p0 = SDATA (pattern); *p0; p0++)
1119 {
1120 if (*p0 == '-')
1121 ndashes++;
1122 else if (*p0 == '*')
1123 nstars++;
1124 else if (*p0 == '['
1125 || *p0 == '.' || *p0 == '\\'
1126 || *p0 == '+' || *p0 == '^'
1127 || *p0 == '$')
1128 nescs++;
1129 }
1130
1131 /* If PATTERN is not full XLFD we conert "*" to ".*". Otherwise
1132 we convert "*" to "[^-]*" which is much faster in regular
1133 expression matching. */
1134 if (ndashes < 14)
1135 p1 = regex = (unsigned char *) alloca (SBYTES (pattern) + 2 * nstars + 2 * nescs + 1);
1136 else
1137 p1 = regex = (unsigned char *) alloca (SBYTES (pattern) + 5 * nstars + 2 * nescs + 1);
1138
1139 *p1++ = '^';
1140 for (p0 = SDATA (pattern); *p0; p0++)
1141 {
1142 if (*p0 == '*')
1143 {
1144 if (ndashes < 14)
1145 *p1++ = '.';
1146 else
1147 *p1++ = '[', *p1++ = '^', *p1++ = '-', *p1++ = ']';
1148 *p1++ = '*';
1149 }
1150 else if (*p0 == '?')
1151 *p1++ = '.';
1152 else if (*p0 == '['
1153 || *p0 == '.' || *p0 == '\\'
1154 || *p0 == '+' || *p0 == '^'
1155 || *p0 == '$')
1156 *p1++ = '\\', *p1++ = *p0;
1157 else
1158 *p1++ = *p0;
1159 }
1160 *p1++ = '$';
1161 *p1++ = 0;
1162
1163 Vcached_fontset_data = Fcons (build_string ((char *) SDATA (pattern)),
1164 build_string ((char *) regex));
1165 }
1166
1167 return CACHED_FONTSET_REGEX;
1168 }
1169
1170 /* Return ID of the base fontset named NAME. If there's no such
1171 fontset, return -1. NAME_PATTERN specifies how to treat NAME as this:
1172 0: pattern containing '*' and '?' as wildcards
1173 1: regular expression
1174 2: literal fontset name
1175 */
1176
1177 int
1178 fs_query_fontset (name, name_pattern)
1179 Lisp_Object name;
1180 int name_pattern;
1181 {
1182 Lisp_Object tem;
1183 int i;
1184
1185 name = Fdowncase (name);
1186 if (name_pattern != 1)
1187 {
1188 tem = Frassoc (name, Vfontset_alias_alist);
1189 if (NILP (tem))
1190 tem = Fassoc (name, Vfontset_alias_alist);
1191 if (CONSP (tem) && STRINGP (XCAR (tem)))
1192 name = XCAR (tem);
1193 else if (name_pattern == 0)
1194 {
1195 tem = fontset_pattern_regexp (name);
1196 if (STRINGP (tem))
1197 {
1198 name = tem;
1199 name_pattern = 1;
1200 }
1201 }
1202 }
1203
1204 for (i = 0; i < ASIZE (Vfontset_table); i++)
1205 {
1206 Lisp_Object fontset, this_name;
1207
1208 fontset = FONTSET_FROM_ID (i);
1209 if (NILP (fontset)
1210 || !BASE_FONTSET_P (fontset))
1211 continue;
1212
1213 this_name = FONTSET_NAME (fontset);
1214 if (name_pattern == 1
1215 ? fast_string_match_ignore_case (name, this_name) >= 0
1216 : !xstrcasecmp (SDATA (name), SDATA (this_name)))
1217 return i;
1218 }
1219 return -1;
1220 }
1221
1222
1223 DEFUN ("query-fontset", Fquery_fontset, Squery_fontset, 1, 2, 0,
1224 doc: /* Return the name of a fontset that matches PATTERN.
1225 The value is nil if there is no matching fontset.
1226 PATTERN can contain `*' or `?' as a wildcard
1227 just as X font name matching algorithm allows.
1228 If REGEXPP is non-nil, PATTERN is a regular expression. */)
1229 (pattern, regexpp)
1230 Lisp_Object pattern, regexpp;
1231 {
1232 Lisp_Object fontset;
1233 int id;
1234
1235 (*check_window_system_func) ();
1236
1237 CHECK_STRING (pattern);
1238
1239 if (SCHARS (pattern) == 0)
1240 return Qnil;
1241
1242 id = fs_query_fontset (pattern, !NILP (regexpp));
1243 if (id < 0)
1244 return Qnil;
1245
1246 fontset = FONTSET_FROM_ID (id);
1247 return FONTSET_NAME (fontset);
1248 }
1249
1250 /* Return a list of base fontset names matching PATTERN on frame F. */
1251
1252 Lisp_Object
1253 list_fontsets (f, pattern, size)
1254 FRAME_PTR f;
1255 Lisp_Object pattern;
1256 int size;
1257 {
1258 Lisp_Object frame, regexp, val;
1259 int id;
1260
1261 XSETFRAME (frame, f);
1262
1263 regexp = fontset_pattern_regexp (pattern);
1264 val = Qnil;
1265
1266 for (id = 0; id < ASIZE (Vfontset_table); id++)
1267 {
1268 Lisp_Object fontset, name;
1269
1270 fontset = FONTSET_FROM_ID (id);
1271 if (NILP (fontset)
1272 || !BASE_FONTSET_P (fontset)
1273 || !EQ (frame, FONTSET_FRAME (fontset)))
1274 continue;
1275 name = FONTSET_NAME (fontset);
1276
1277 if (STRINGP (regexp)
1278 ? (fast_string_match (regexp, name) < 0)
1279 : strcmp ((char *) SDATA (pattern), (char *) SDATA (name)))
1280 continue;
1281
1282 val = Fcons (Fcopy_sequence (FONTSET_NAME (fontset)), val);
1283 }
1284
1285 return val;
1286 }
1287
1288
1289 /* Free all realized fontsets whose base fontset is BASE. */
1290
1291 static void
1292 free_realized_fontsets (base)
1293 Lisp_Object base;
1294 {
1295 int id;
1296
1297 #if 0
1298 /* For the moment, this doesn't work because free_realized_face
1299 doesn't remove FACE from a cache. Until we find a solution, we
1300 suppress this code, and simply use Fclear_face_cache even though
1301 that is not efficient. */
1302 BLOCK_INPUT;
1303 for (id = 0; id < ASIZE (Vfontset_table); id++)
1304 {
1305 Lisp_Object this = AREF (Vfontset_table, id);
1306
1307 if (EQ (FONTSET_BASE (this), base))
1308 {
1309 Lisp_Object tail;
1310
1311 for (tail = FONTSET_FACE_ALIST (this); CONSP (tail);
1312 tail = XCDR (tail))
1313 {
1314 FRAME_PTR f = XFRAME (FONTSET_FRAME (this));
1315 int face_id = XINT (XCDR (XCAR (tail)));
1316 struct face *face = FACE_FROM_ID (f, face_id);
1317
1318 /* Face THIS itself is also freed by the following call. */
1319 free_realized_face (f, face);
1320 }
1321 }
1322 }
1323 UNBLOCK_INPUT;
1324 #else /* not 0 */
1325 /* But, we don't have to call Fclear_face_cache if no fontset has
1326 been realized from BASE. */
1327 for (id = 0; id < ASIZE (Vfontset_table); id++)
1328 {
1329 Lisp_Object this = AREF (Vfontset_table, id);
1330
1331 if (CHAR_TABLE_P (this) && EQ (FONTSET_BASE (this), base))
1332 {
1333 Fclear_face_cache (Qt);
1334 break;
1335 }
1336 }
1337 #endif /* not 0 */
1338 }
1339
1340
1341 /* Check validity of NAME as a fontset name and return the
1342 corresponding fontset. If not valid, signal an error.
1343
1344 If NAME is t, return Vdefault_fontset. If NAME is nil, return the
1345 fontset of *FRAME.
1346
1347 Set *FRAME to the actual frame. */
1348
1349 static Lisp_Object
1350 check_fontset_name (name, frame)
1351 Lisp_Object name, *frame;
1352 {
1353 int id;
1354
1355 if (NILP (*frame))
1356 *frame = selected_frame;
1357 CHECK_LIVE_FRAME (*frame);
1358
1359 if (EQ (name, Qt))
1360 return Vdefault_fontset;
1361 if (NILP (name))
1362 {
1363 id = FRAME_FONTSET (XFRAME (*frame));
1364 }
1365 else
1366 {
1367 CHECK_STRING (name);
1368 /* First try NAME as literal. */
1369 id = fs_query_fontset (name, 2);
1370 if (id < 0)
1371 /* For backward compatibility, try again NAME as pattern. */
1372 id = fs_query_fontset (name, 0);
1373 if (id < 0)
1374 error ("Fontset `%s' does not exist", SDATA (name));
1375 }
1376 return FONTSET_FROM_ID (id);
1377 }
1378
1379 static void
1380 accumulate_script_ranges (arg, range, val)
1381 Lisp_Object arg, range, val;
1382 {
1383 if (EQ (XCAR (arg), val))
1384 {
1385 if (CONSP (range))
1386 XSETCDR (arg, Fcons (Fcons (XCAR (range), XCDR (range)), XCDR (arg)));
1387 else
1388 XSETCDR (arg, Fcons (Fcons (range, range), XCDR (arg)));
1389 }
1390 }
1391
1392
1393 /* Callback function for map_charset_chars in Fset_fontset_font.
1394 ARG is a vector [ FONTSET FONT_DEF ADD ASCII SCRIPT_RANGE_LIST ].
1395
1396 In FONTSET, set FONT_DEF in a fashion specified by ADD for
1397 characters in RANGE and ranges in SCRIPT_RANGE_LIST before RANGE.
1398 The consumed ranges are poped up from SCRIPT_RANGE_LIST, and the
1399 new SCRIPT_RANGE_LIST is stored in ARG.
1400
1401 If ASCII is nil, don't set FONT_DEF for ASCII characters. It is
1402 assured that SCRIPT_RANGE_LIST doesn't contain ASCII in that
1403 case. */
1404
1405 static void
1406 set_fontset_font (arg, range)
1407 Lisp_Object arg, range;
1408 {
1409 Lisp_Object fontset, font_def, add, ascii, script_range_list;
1410 int from = XINT (XCAR (range)), to = XINT (XCDR (range));
1411
1412 fontset = AREF (arg, 0);
1413 font_def = AREF (arg, 1);
1414 add = AREF (arg, 2);
1415 ascii = AREF (arg, 3);
1416 script_range_list = AREF (arg, 4);
1417
1418 if (NILP (ascii) && from < 0x80)
1419 {
1420 if (to < 0x80)
1421 return;
1422 from = 0x80;
1423 range = Fcons (make_number (0x80), XCDR (range));
1424 }
1425
1426 #define SCRIPT_FROM XINT (XCAR (XCAR (script_range_list)))
1427 #define SCRIPT_TO XINT (XCDR (XCAR (script_range_list)))
1428 #define POP_SCRIPT_RANGE() script_range_list = XCDR (script_range_list)
1429
1430 for (; CONSP (script_range_list) && SCRIPT_TO < from; POP_SCRIPT_RANGE ())
1431 FONTSET_ADD (fontset, XCAR (script_range_list), font_def, add);
1432 if (CONSP (script_range_list))
1433 {
1434 if (SCRIPT_FROM < from)
1435 range = Fcons (make_number (SCRIPT_FROM), XCDR (range));
1436 while (CONSP (script_range_list) && SCRIPT_TO <= to)
1437 POP_SCRIPT_RANGE ();
1438 if (CONSP (script_range_list) && SCRIPT_FROM <= to)
1439 XSETCAR (XCAR (script_range_list), make_number (to + 1));
1440 }
1441
1442 FONTSET_ADD (fontset, range, font_def, add);
1443 ASET (arg, 4, script_range_list);
1444 }
1445
1446 extern Lisp_Object QCfamily, QCregistry;
1447 static void update_auto_fontset_alist P_ ((Lisp_Object, Lisp_Object));
1448
1449
1450 DEFUN ("set-fontset-font", Fset_fontset_font, Sset_fontset_font, 3, 5, 0,
1451 doc: /*
1452 Modify fontset NAME to use FONT-SPEC for TARGET characters.
1453
1454 NAME is a fontset name string, nil for the fontset of FRAME, or t for
1455 the default fontset.
1456
1457 TARGET may be a cons; (FROM . TO), where FROM and TO are characters.
1458 In that case, use FONT-SPEC for all characters in the range FROM and
1459 TO (inclusive).
1460
1461 TARGET may be a script name symbol. In that case, use FONT-SPEC for
1462 all characters that belong to the script.
1463
1464 TARGET may be a charset. In that case, use FONT-SPEC for all
1465 characters in the charset.
1466
1467 TARGET may be nil. In that case, use FONT-SPEC for any characters for
1468 that no FONT-SPEC is specified.
1469
1470 FONT-SPEC may one of these:
1471 * A font-spec object made by the function `font-spec' (which see).
1472 * A cons (FAMILY . REGISTRY), where FAMILY is a font family name and
1473 REGISTRY is a font registry name. FAMILY may contain foundry
1474 name, and REGISTRY may contain encoding name.
1475 * A font name string.
1476 * nil, which explicitly specifies that there's no font for TARGET.
1477
1478 Optional 4th argument FRAME is a frame or nil for the selected frame
1479 that is concerned in the case that NAME is nil.
1480
1481 Optional 5th argument ADD, if non-nil, specifies how to add FONT-SPEC
1482 to the font specifications for TARGET previously set. If it is
1483 `prepend', FONT-SPEC is prepended. If it is `append', FONT-SPEC is
1484 appended. By default, FONT-SPEC overrides the previous settings. */)
1485 (name, target, font_spec, frame, add)
1486 Lisp_Object name, target, font_spec, frame, add;
1487 {
1488 Lisp_Object fontset;
1489 Lisp_Object font_def, registry, family;
1490 Lisp_Object range_list;
1491 struct charset *charset = NULL;
1492 Lisp_Object fontname;
1493 int ascii_changed = 0;
1494
1495 fontset = check_fontset_name (name, &frame);
1496
1497 fontname = Qnil;
1498 if (CONSP (font_spec))
1499 {
1500 Lisp_Object spec = Ffont_spec (0, NULL);
1501
1502 font_parse_family_registry (XCAR (font_spec), XCDR (font_spec), spec);
1503 font_spec = spec;
1504 fontname = Ffont_xlfd_name (font_spec, Qnil);
1505 }
1506 else if (STRINGP (font_spec))
1507 {
1508 Lisp_Object args[2];
1509 extern Lisp_Object QCname;
1510
1511 fontname = font_spec;
1512 args[0] = QCname;
1513 args[1] = font_spec;
1514 font_spec = Ffont_spec (2, args);
1515 }
1516 else if (FONT_SPEC_P (font_spec))
1517 fontname = Ffont_xlfd_name (font_spec, Qnil);
1518 else if (! NILP (font_spec))
1519 Fsignal (Qfont, list2 (build_string ("Invalid font-spec"), font_spec));
1520
1521 if (! NILP (font_spec))
1522 {
1523 Lisp_Object encoding, repertory;
1524
1525 family = AREF (font_spec, FONT_FAMILY_INDEX);
1526 if (! NILP (family) )
1527 family = SYMBOL_NAME (family);
1528 registry = AREF (font_spec, FONT_REGISTRY_INDEX);
1529 if (! NILP (registry))
1530 registry = Fdowncase (SYMBOL_NAME (registry));
1531 encoding = find_font_encoding (concat3 (family, build_string ("-"),
1532 registry));
1533 if (NILP (encoding))
1534 encoding = Qascii;
1535
1536 if (SYMBOLP (encoding))
1537 {
1538 CHECK_CHARSET (encoding);
1539 encoding = repertory = CHARSET_SYMBOL_ID (encoding);
1540 }
1541 else
1542 {
1543 repertory = XCDR (encoding);
1544 encoding = XCAR (encoding);
1545 CHECK_CHARSET (encoding);
1546 encoding = CHARSET_SYMBOL_ID (encoding);
1547 if (! NILP (repertory) && SYMBOLP (repertory))
1548 {
1549 CHECK_CHARSET (repertory);
1550 repertory = CHARSET_SYMBOL_ID (repertory);
1551 }
1552 }
1553 FONT_DEF_NEW (font_def, font_spec, encoding, repertory);
1554 }
1555 else
1556 font_def = Qnil;
1557
1558 if (CHARACTERP (target))
1559 {
1560 if (XFASTINT (target) < 0x80)
1561 error ("Can't set a font for partial ASCII range");
1562 range_list = Fcons (Fcons (target, target), Qnil);
1563 }
1564 else if (CONSP (target))
1565 {
1566 Lisp_Object from, to;
1567
1568 from = Fcar (target);
1569 to = Fcdr (target);
1570 CHECK_CHARACTER (from);
1571 CHECK_CHARACTER (to);
1572 if (XFASTINT (from) < 0x80)
1573 {
1574 if (XFASTINT (from) != 0 || XFASTINT (to) < 0x7F)
1575 error ("Can't set a font for partial ASCII range");
1576 ascii_changed = 1;
1577 }
1578 range_list = Fcons (target, Qnil);
1579 }
1580 else if (SYMBOLP (target) && !NILP (target))
1581 {
1582 Lisp_Object script_list;
1583 Lisp_Object val;
1584
1585 range_list = Qnil;
1586 script_list = XCHAR_TABLE (Vchar_script_table)->extras[0];
1587 if (! NILP (Fmemq (target, script_list)))
1588 {
1589 if (EQ (target, Qlatin))
1590 ascii_changed = 1;
1591 val = Fcons (target, Qnil);
1592 map_char_table (accumulate_script_ranges, Qnil, Vchar_script_table,
1593 val);
1594 range_list = Fnreverse (XCDR (val));
1595 }
1596 if (CHARSETP (target))
1597 {
1598 CHECK_CHARSET_GET_CHARSET (target, charset);
1599 if (charset->ascii_compatible_p)
1600 ascii_changed = 1;
1601 }
1602 else if (NILP (range_list))
1603 error ("Invalid script or charset name: %s",
1604 SDATA (SYMBOL_NAME (target)));
1605 }
1606 else if (NILP (target))
1607 range_list = Fcons (Qnil, Qnil);
1608 else
1609 error ("Invalid target for setting a font");
1610
1611 if (ascii_changed)
1612 {
1613 Lisp_Object val;
1614
1615 if (NILP (font_spec))
1616 error ("Can't set ASCII font to nil");
1617 val = CHAR_TABLE_REF (fontset, 0);
1618 if (! NILP (val) && EQ (add, Qappend))
1619 /* We are going to change just an additional font for ASCII. */
1620 ascii_changed = 0;
1621 }
1622
1623 if (charset)
1624 {
1625 Lisp_Object arg;
1626
1627 arg = Fmake_vector (make_number (5), Qnil);
1628 ASET (arg, 0, fontset);
1629 ASET (arg, 1, font_def);
1630 ASET (arg, 2, add);
1631 ASET (arg, 3, ascii_changed ? Qt : Qnil);
1632 ASET (arg, 4, range_list);
1633
1634 map_charset_chars (set_fontset_font, Qnil, arg, charset,
1635 CHARSET_MIN_CODE (charset),
1636 CHARSET_MAX_CODE (charset));
1637 range_list = AREF (arg, 4);
1638 }
1639 for (; CONSP (range_list); range_list = XCDR (range_list))
1640 FONTSET_ADD (fontset, XCAR (range_list), font_def, add);
1641
1642 if (ascii_changed)
1643 {
1644 Lisp_Object tail, frame, alist;
1645 int fontset_id = XINT (FONTSET_ID (fontset));
1646
1647 FONTSET_ASCII (fontset) = fontname;
1648 name = FONTSET_NAME (fontset);
1649 FOR_EACH_FRAME (tail, frame)
1650 {
1651 FRAME_PTR f = XFRAME (frame);
1652 Lisp_Object font_object;
1653 struct face *face;
1654
1655 if (FRAME_INITIAL_P (f) || FRAME_TERMCAP_P (f))
1656 continue;
1657 if (fontset_id != FRAME_FONTSET (f))
1658 continue;
1659 face = FACE_FROM_ID (f, DEFAULT_FACE_ID);
1660 if (face)
1661 font_object = font_load_for_lface (f, face->lface, font_spec);
1662 else
1663 font_object = font_open_by_spec (f, font_spec);
1664 if (! NILP (font_object))
1665 {
1666 update_auto_fontset_alist (font_object, fontset);
1667 alist = Fcons (Fcons (Qfont, Fcons (name, font_object)), Qnil);
1668 Fmodify_frame_parameters (frame, alist);
1669 }
1670 }
1671 }
1672
1673 /* Free all realized fontsets whose base is FONTSET. This way, the
1674 specified character(s) are surely redisplayed by a correct
1675 font. */
1676 free_realized_fontsets (fontset);
1677
1678 return Qnil;
1679 }
1680
1681
1682 DEFUN ("new-fontset", Fnew_fontset, Snew_fontset, 2, 2, 0,
1683 doc: /* Create a new fontset NAME from font information in FONTLIST.
1684
1685 FONTLIST is an alist of scripts vs the corresponding font specification list.
1686 Each element of FONTLIST has the form (SCRIPT FONT-SPEC ...), where a
1687 character of SCRIPT is displayed by a font that matches one of
1688 FONT-SPEC.
1689
1690 SCRIPT is a symbol that appears in the first extra slot of the
1691 char-table `char-script-table'.
1692
1693 FONT-SPEC is a vector, a cons, or a string. See the documentation of
1694 `set-fontset-font' for the meaning. */)
1695 (name, fontlist)
1696 Lisp_Object name, fontlist;
1697 {
1698 Lisp_Object fontset;
1699 int id;
1700
1701 CHECK_STRING (name);
1702 CHECK_LIST (fontlist);
1703
1704 name = Fdowncase (name);
1705 id = fs_query_fontset (name, 0);
1706 if (id < 0)
1707 {
1708 Lisp_Object font_spec = Ffont_spec (0, NULL);
1709 Lisp_Object short_name;
1710 char xlfd[256];
1711 int len;
1712
1713 if (font_parse_xlfd ((char *) SDATA (name), font_spec) < 0)
1714 error ("Fontset name must be in XLFD format");
1715 short_name = AREF (font_spec, FONT_REGISTRY_INDEX);
1716 if (strncmp ((char *) SDATA (SYMBOL_NAME (short_name)), "fontset-", 8)
1717 || SBYTES (SYMBOL_NAME (short_name)) < 9)
1718 error ("Registry field of fontset name must be \"fontset-*\"");
1719 Vfontset_alias_alist = Fcons (Fcons (name, SYMBOL_NAME (short_name)),
1720 Vfontset_alias_alist);
1721 ASET (font_spec, FONT_REGISTRY_INDEX, Qiso8859_1);
1722 fontset = make_fontset (Qnil, name, Qnil);
1723 len = font_unparse_xlfd (font_spec, 0, xlfd, 256);
1724 if (len < 0)
1725 error ("Invalid fontset name (perhaps too long): %s", SDATA (name));
1726 FONTSET_ASCII (fontset) = make_unibyte_string (xlfd, len);
1727 }
1728 else
1729 {
1730 fontset = FONTSET_FROM_ID (id);
1731 free_realized_fontsets (fontset);
1732 Fset_char_table_range (fontset, Qt, Qnil);
1733 }
1734
1735 for (; ! NILP (fontlist); fontlist = Fcdr (fontlist))
1736 {
1737 Lisp_Object elt, script;
1738
1739 elt = Fcar (fontlist);
1740 script = Fcar (elt);
1741 elt = Fcdr (elt);
1742 if (CONSP (elt) && (NILP (XCDR (elt)) || CONSP (XCDR (elt))))
1743 for (; CONSP (elt); elt = XCDR (elt))
1744 Fset_fontset_font (name, script, XCAR (elt), Qnil, Qappend);
1745 else
1746 Fset_fontset_font (name, script, elt, Qnil, Qappend);
1747 }
1748 return name;
1749 }
1750
1751
1752 /* Alist of automatically created fontsets. Each element is a cons
1753 (FONT-SPEC . FONTSET-ID). */
1754 static Lisp_Object auto_fontset_alist;
1755
1756 /* Number of automatically created fontsets. */
1757 static int num_auto_fontsets;
1758
1759 /* Retun a fontset synthesized from FONT-OBJECT. This is called from
1760 x_new_font when FONT-OBJECT is used for the default ASCII font of a
1761 frame, and the returned fontset is used for the default fontset of
1762 that frame. The fontset specifies a font of the same registry as
1763 FONT-OBJECT for all characters in the repertory of the registry
1764 (see Vfont_encoding_alist). If the repertory is not known, the
1765 fontset specifies the font for all Latin characters assuming that a
1766 user intends to use FONT-OBJECT for Latin characters. */
1767
1768 int
1769 fontset_from_font (font_object)
1770 Lisp_Object font_object;
1771 {
1772 Lisp_Object font_name = font_get_name (font_object);
1773 Lisp_Object font_spec = Fcopy_font_spec (font_object);
1774 Lisp_Object registry = AREF (font_spec, FONT_REGISTRY_INDEX);
1775 Lisp_Object fontset_spec, alias, name, fontset;
1776 Lisp_Object val;
1777
1778 val = assoc_no_quit (font_spec, auto_fontset_alist);
1779 if (CONSP (val))
1780 return XINT (FONTSET_ID (XCDR (val)));
1781 if (num_auto_fontsets++ == 0)
1782 alias = intern ("fontset-startup");
1783 else
1784 {
1785 char temp[32];
1786
1787 sprintf (temp, "fontset-auto%d", num_auto_fontsets - 1);
1788 alias = intern (temp);
1789 }
1790 fontset_spec = Fcopy_font_spec (font_spec);
1791 ASET (fontset_spec, FONT_REGISTRY_INDEX, alias);
1792 name = Ffont_xlfd_name (fontset_spec, Qnil);
1793 if (NILP (name))
1794 abort ();
1795 fontset = make_fontset (Qnil, name, Qnil);
1796 Vfontset_alias_alist = Fcons (Fcons (name, SYMBOL_NAME (alias)),
1797 Vfontset_alias_alist);
1798 alias = Fdowncase (AREF (font_object, FONT_NAME_INDEX));
1799 Vfontset_alias_alist = Fcons (Fcons (name, alias), Vfontset_alias_alist);
1800 auto_fontset_alist = Fcons (Fcons (font_spec, fontset), auto_fontset_alist);
1801 font_spec = Ffont_spec (0, NULL);
1802 ASET (font_spec, FONT_REGISTRY_INDEX, registry);
1803 {
1804 Lisp_Object target = find_font_encoding (SYMBOL_NAME (registry));
1805
1806 if (CONSP (target))
1807 target = XCDR (target);
1808 if (! CHARSETP (target))
1809 target = Qlatin;
1810 Fset_fontset_font (name, target, font_spec, Qnil, Qnil);
1811 Fset_fontset_font (name, Qnil, font_spec, Qnil, Qnil);
1812 }
1813
1814 FONTSET_ASCII (fontset) = font_name;
1815
1816 return XINT (FONTSET_ID (fontset));
1817 }
1818
1819
1820 /* Update auto_fontset_alist for FONTSET. When an ASCII font of
1821 FONTSET is changed, we delete an entry of FONTSET if any from
1822 auto_fontset_alist so that FONTSET is not re-used by
1823 fontset_from_font. */
1824
1825 static void
1826 update_auto_fontset_alist (font_object, fontset)
1827 Lisp_Object font_object, fontset;
1828 {
1829 Lisp_Object prev, tail;
1830
1831 for (prev = Qnil, tail = auto_fontset_alist; CONSP (tail);
1832 prev = tail, tail = XCDR (tail))
1833 if (EQ (fontset, XCDR (XCAR (tail))))
1834 {
1835 if (NILP (prev))
1836 auto_fontset_alist = XCDR (tail);
1837 else
1838 XSETCDR (prev, XCDR (tail));
1839 break;
1840 }
1841 }
1842
1843
1844 /* Return a cons (FONT-OBJECT . GLYPH-CODE).
1845 FONT-OBJECT is the font for the character at POSITION in the current
1846 buffer. This is computed from all the text properties and overlays
1847 that apply to POSITION. POSTION may be nil, in which case,
1848 FONT-SPEC is the font for displaying the character CH with the
1849 default face.
1850
1851 GLYPH-CODE is the glyph code in the font to use for the character.
1852
1853 If the 2nd optional arg CH is non-nil, it is a character to check
1854 the font instead of the character at POSITION.
1855
1856 It returns nil in the following cases:
1857
1858 (1) The window system doesn't have a font for the character (thus
1859 it is displayed by an empty box).
1860
1861 (2) The character code is invalid.
1862
1863 (3) If POSITION is not nil, and the current buffer is not displayed
1864 in any window.
1865
1866 In addition, the returned font name may not take into account of
1867 such redisplay engine hooks as what used in jit-lock-mode if
1868 POSITION is currently not visible. */
1869
1870
1871 DEFUN ("internal-char-font", Finternal_char_font, Sinternal_char_font, 1, 2, 0,
1872 doc: /* For internal use only. */)
1873 (position, ch)
1874 Lisp_Object position, ch;
1875 {
1876 EMACS_INT pos, pos_byte, dummy;
1877 int face_id;
1878 int c;
1879 struct frame *f;
1880 struct face *face;
1881 int cs_id;
1882
1883 if (NILP (position))
1884 {
1885 CHECK_CHARACTER (ch);
1886 c = XINT (ch);
1887 f = XFRAME (selected_frame);
1888 face_id = lookup_basic_face (f, DEFAULT_FACE_ID);
1889 pos = -1;
1890 cs_id = -1;
1891 }
1892 else
1893 {
1894 Lisp_Object window, charset;
1895 struct window *w;
1896
1897 CHECK_NUMBER_COERCE_MARKER (position);
1898 pos = XINT (position);
1899 if (pos < BEGV || pos >= ZV)
1900 args_out_of_range_3 (position, make_number (BEGV), make_number (ZV));
1901 pos_byte = CHAR_TO_BYTE (pos);
1902 if (NILP (ch))
1903 c = FETCH_CHAR (pos_byte);
1904 else
1905 {
1906 CHECK_NATNUM (ch);
1907 c = XINT (ch);
1908 }
1909 window = Fget_buffer_window (Fcurrent_buffer (), Qnil);
1910 if (NILP (window))
1911 return Qnil;
1912 w = XWINDOW (window);
1913 f = XFRAME (w->frame);
1914 face_id = face_at_buffer_position (w, pos, -1, -1, &dummy,
1915 pos + 100, 0, -1);
1916 charset = Fget_char_property (position, Qcharset, Qnil);
1917 if (CHARSETP (charset))
1918 cs_id = XINT (CHARSET_SYMBOL_ID (charset));
1919 else
1920 cs_id = -1;
1921 }
1922 if (! CHAR_VALID_P (c, 0))
1923 return Qnil;
1924 face_id = FACE_FOR_CHAR (f, FACE_FROM_ID (f, face_id), c, pos, Qnil);
1925 face = FACE_FROM_ID (f, face_id);
1926 if (face->font)
1927 {
1928 unsigned code = face->font->driver->encode_char (face->font, c);
1929 Lisp_Object font_object;
1930 /* Assignment to EMACS_INT stops GCC whining about limited range
1931 of data type. */
1932 EMACS_INT cod = code;
1933
1934 if (code == FONT_INVALID_CODE)
1935 return Qnil;
1936 XSETFONT (font_object, face->font);
1937 if (cod <= MOST_POSITIVE_FIXNUM)
1938 return Fcons (font_object, make_number (code));
1939 return Fcons (font_object, Fcons (make_number (code >> 16),
1940 make_number (code & 0xFFFF)));
1941 }
1942 return Qnil;
1943 }
1944
1945
1946 DEFUN ("fontset-info", Ffontset_info, Sfontset_info, 1, 2, 0,
1947 doc: /* Return information about a fontset FONTSET on frame FRAME.
1948
1949 FONTSET is a fontset name string, nil for the fontset of FRAME, or t
1950 for the default fontset. FRAME nil means the selected frame.
1951
1952 The value is a char-table whose elements have this form:
1953
1954 ((FONT OPENED-FONT ...) ...)
1955
1956 FONT is a name of font specified for a range of characters.
1957
1958 OPENED-FONT is a name of a font actually opened.
1959
1960 The char-table has one extra slot. If FONTSET is not the default
1961 fontset, the value the extra slot is a char-table containing the
1962 information about the derived fonts from the default fontset. The
1963 format is the same as above. */)
1964 (fontset, frame)
1965 Lisp_Object fontset, frame;
1966 {
1967 FRAME_PTR f;
1968 Lisp_Object *realized[2], fontsets[2], tables[2];
1969 Lisp_Object val, elt;
1970 int c, i, j, k;
1971
1972 (*check_window_system_func) ();
1973
1974 fontset = check_fontset_name (fontset, &frame);
1975 f = XFRAME (frame);
1976
1977 /* Recode fontsets realized on FRAME from the base fontset FONTSET
1978 in the table `realized'. */
1979 realized[0] = (Lisp_Object *) alloca (sizeof (Lisp_Object)
1980 * ASIZE (Vfontset_table));
1981 for (i = j = 0; i < ASIZE (Vfontset_table); i++)
1982 {
1983 elt = FONTSET_FROM_ID (i);
1984 if (!NILP (elt)
1985 && EQ (FONTSET_BASE (elt), fontset)
1986 && EQ (FONTSET_FRAME (elt), frame))
1987 realized[0][j++] = elt;
1988 }
1989 realized[0][j] = Qnil;
1990
1991 realized[1] = (Lisp_Object *) alloca (sizeof (Lisp_Object)
1992 * ASIZE (Vfontset_table));
1993 for (i = j = 0; ! NILP (realized[0][i]); i++)
1994 {
1995 elt = FONTSET_DEFAULT (realized[0][i]);
1996 if (! NILP (elt))
1997 realized[1][j++] = elt;
1998 }
1999 realized[1][j] = Qnil;
2000
2001 tables[0] = Fmake_char_table (Qfontset_info, Qnil);
2002 fontsets[0] = fontset;
2003 if (!EQ (fontset, Vdefault_fontset))
2004 {
2005 tables[1] = Fmake_char_table (Qnil, Qnil);
2006 XCHAR_TABLE (tables[0])->extras[0] = tables[1];
2007 fontsets[1] = Vdefault_fontset;
2008 }
2009
2010 /* Accumulate information of the fontset in TABLE. The format of
2011 each element is ((FONT-SPEC OPENED-FONT ...) ...). */
2012 for (k = 0; k <= 1; k++)
2013 {
2014 for (c = 0; c <= MAX_CHAR; )
2015 {
2016 int from = c, to = MAX_5_BYTE_CHAR;
2017
2018 if (c <= MAX_5_BYTE_CHAR)
2019 {
2020 val = char_table_ref_and_range (fontsets[k], c, &from, &to);
2021 }
2022 else
2023 {
2024 val = FONTSET_FALLBACK (fontsets[k]);
2025 to = MAX_CHAR;
2026 }
2027 if (VECTORP (val))
2028 {
2029 Lisp_Object alist;
2030
2031 /* At first, set ALIST to ((FONT-SPEC) ...). */
2032 for (alist = Qnil, i = 0; i < ASIZE (val); i++)
2033 if (! NILP (AREF (val, i)))
2034 alist = Fcons (Fcons (FONT_DEF_SPEC (AREF (val, i)), Qnil),
2035 alist);
2036 alist = Fnreverse (alist);
2037
2038 /* Then store opened font names to cdr of each elements. */
2039 for (i = 0; ! NILP (realized[k][i]); i++)
2040 {
2041 if (c <= MAX_5_BYTE_CHAR)
2042 val = FONTSET_REF (realized[k][i], c);
2043 else
2044 val = FONTSET_FALLBACK (realized[k][i]);
2045 if (! CONSP (val) || ! VECTORP (XCDR (val)))
2046 continue;
2047 /* VAL: (int . [[FACE-ID FONT-DEF FONT-OBJECT int] ... ]) */
2048 val = XCDR (val);
2049 for (j = 0; j < ASIZE (val); j++)
2050 {
2051 elt = AREF (val, j);
2052 if (FONT_OBJECT_P (RFONT_DEF_OBJECT (elt)))
2053 {
2054 Lisp_Object font_object = RFONT_DEF_OBJECT (elt);
2055 Lisp_Object slot, name;
2056
2057 slot = Fassq (RFONT_DEF_SPEC (elt), alist);
2058 name = AREF (font_object, FONT_NAME_INDEX);
2059 if (NILP (Fmember (name, XCDR (slot))))
2060 nconc2 (slot, Fcons (name, Qnil));
2061 }
2062 }
2063 }
2064
2065 /* Store ALIST in TBL for characters C..TO. */
2066 if (c <= MAX_5_BYTE_CHAR)
2067 char_table_set_range (tables[k], c, to, alist);
2068 else
2069 XCHAR_TABLE (tables[k])->defalt = alist;
2070
2071 /* At last, change each elements to font names. */
2072 for (; CONSP (alist); alist = XCDR (alist))
2073 {
2074 elt = XCAR (alist);
2075 XSETCAR (elt, Ffont_xlfd_name (XCAR (elt), Qnil));
2076 }
2077 }
2078 c = to + 1;
2079 }
2080 if (EQ (fontset, Vdefault_fontset))
2081 break;
2082 }
2083
2084 return tables[0];
2085 }
2086
2087
2088 DEFUN ("fontset-font", Ffontset_font, Sfontset_font, 2, 3, 0,
2089 doc: /* Return a font name pattern for character CH in fontset NAME.
2090 If NAME is t, find a pattern in the default fontset.
2091 If NAME is nil, find a pattern in the fontset of the selected frame.
2092
2093 The value has the form (FAMILY . REGISTRY), where FAMILY is a font
2094 family name and REGISTRY is a font registry name. This is actually
2095 the first font name pattern for CH in the fontset or in the default
2096 fontset.
2097
2098 If the 2nd optional arg ALL is non-nil, return a list of all font name
2099 patterns. */)
2100 (name, ch, all)
2101 Lisp_Object name, ch, all;
2102 {
2103 int c;
2104 Lisp_Object fontset, elt, list, repertory, val;
2105 int i, j;
2106 Lisp_Object frame;
2107
2108 frame = Qnil;
2109 fontset = check_fontset_name (name, &frame);
2110
2111 CHECK_CHARACTER (ch);
2112 c = XINT (ch);
2113 list = Qnil;
2114 while (1)
2115 {
2116 for (i = 0, elt = FONTSET_REF (fontset, c); i < 2;
2117 i++, elt = FONTSET_FALLBACK (fontset))
2118 if (VECTORP (elt))
2119 for (j = 0; j < ASIZE (elt); j++)
2120 {
2121 Lisp_Object family, registry;
2122
2123 val = AREF (elt, j);
2124 if (NILP (val))
2125 return Qnil;
2126 repertory = AREF (val, 1);
2127 if (INTEGERP (repertory))
2128 {
2129 struct charset *charset = CHARSET_FROM_ID (XINT (repertory));
2130
2131 if (! CHAR_CHARSET_P (c, charset))
2132 continue;
2133 }
2134 else if (CHAR_TABLE_P (repertory))
2135 {
2136 if (NILP (CHAR_TABLE_REF (repertory, c)))
2137 continue;
2138 }
2139 val = AREF (val, 0);
2140 /* VAL is a FONT-SPEC */
2141 family = AREF (val, FONT_FAMILY_INDEX);
2142 if (! NILP (family))
2143 family = SYMBOL_NAME (family);
2144 registry = AREF (val, FONT_REGISTRY_INDEX);
2145 if (! NILP (registry))
2146 registry = SYMBOL_NAME (registry);
2147 val = Fcons (family, registry);
2148 if (NILP (all))
2149 return val;
2150 list = Fcons (val, list);
2151 }
2152 if (EQ (fontset, Vdefault_fontset))
2153 break;
2154 fontset = Vdefault_fontset;
2155 }
2156 return (Fnreverse (list));
2157 }
2158
2159 DEFUN ("fontset-list", Ffontset_list, Sfontset_list, 0, 0, 0,
2160 doc: /* Return a list of all defined fontset names. */)
2161 ()
2162 {
2163 Lisp_Object fontset, list;
2164 int i;
2165
2166 list = Qnil;
2167 for (i = 0; i < ASIZE (Vfontset_table); i++)
2168 {
2169 fontset = FONTSET_FROM_ID (i);
2170 if (!NILP (fontset)
2171 && BASE_FONTSET_P (fontset))
2172 list = Fcons (FONTSET_NAME (fontset), list);
2173 }
2174
2175 return list;
2176 }
2177
2178
2179 #ifdef FONTSET_DEBUG
2180
2181 Lisp_Object
2182 dump_fontset (fontset)
2183 Lisp_Object fontset;
2184 {
2185 Lisp_Object vec;
2186
2187 vec = Fmake_vector (make_number (3), Qnil);
2188 ASET (vec, 0, FONTSET_ID (fontset));
2189
2190 if (BASE_FONTSET_P (fontset))
2191 {
2192 ASET (vec, 1, FONTSET_NAME (fontset));
2193 }
2194 else
2195 {
2196 Lisp_Object frame;
2197
2198 frame = FONTSET_FRAME (fontset);
2199 if (FRAMEP (frame))
2200 {
2201 FRAME_PTR f = XFRAME (frame);
2202
2203 if (FRAME_LIVE_P (f))
2204 ASET (vec, 1,
2205 Fcons (FONTSET_NAME (FONTSET_BASE (fontset)), f->name));
2206 else
2207 ASET (vec, 1,
2208 Fcons (FONTSET_NAME (FONTSET_BASE (fontset)), Qnil));
2209 }
2210 if (!NILP (FONTSET_DEFAULT (fontset)))
2211 ASET (vec, 2, FONTSET_ID (FONTSET_DEFAULT (fontset)));
2212 }
2213 return vec;
2214 }
2215
2216 DEFUN ("fontset-list-all", Ffontset_list_all, Sfontset_list_all, 0, 0, 0,
2217 doc: /* Return a brief summary of all fontsets for debug use. */)
2218 ()
2219 {
2220 Lisp_Object val;
2221 int i;
2222
2223 for (i = 0, val = Qnil; i < ASIZE (Vfontset_table); i++)
2224 if (! NILP (AREF (Vfontset_table, i)))
2225 val = Fcons (dump_fontset (AREF (Vfontset_table, i)), val);
2226 return (Fnreverse (val));
2227 }
2228 #endif /* FONTSET_DEBUG */
2229
2230 void
2231 syms_of_fontset ()
2232 {
2233 DEFSYM (Qfontset, "fontset");
2234 Fput (Qfontset, Qchar_table_extra_slots, make_number (9));
2235 DEFSYM (Qfontset_info, "fontset-info");
2236 Fput (Qfontset_info, Qchar_table_extra_slots, make_number (1));
2237
2238 DEFSYM (Qprepend, "prepend");
2239 DEFSYM (Qappend, "append");
2240 DEFSYM (Qlatin, "latin");
2241
2242 Vcached_fontset_data = Qnil;
2243 staticpro (&Vcached_fontset_data);
2244
2245 Vfontset_table = Fmake_vector (make_number (32), Qnil);
2246 staticpro (&Vfontset_table);
2247
2248 Vdefault_fontset = Fmake_char_table (Qfontset, Qnil);
2249 staticpro (&Vdefault_fontset);
2250 FONTSET_ID (Vdefault_fontset) = make_number (0);
2251 FONTSET_NAME (Vdefault_fontset)
2252 = make_pure_c_string ("-*-*-*-*-*-*-*-*-*-*-*-*-fontset-default");
2253 ASET (Vfontset_table, 0, Vdefault_fontset);
2254 next_fontset_id = 1;
2255
2256 auto_fontset_alist = Qnil;
2257 staticpro (&auto_fontset_alist);
2258
2259 DEFVAR_LISP ("font-encoding-charset-alist", &Vfont_encoding_charset_alist,
2260 doc: /*
2261 Alist of charsets vs the charsets to determine the preferred font encoding.
2262 Each element looks like (CHARSET . ENCODING-CHARSET),
2263 where ENCODING-CHARSET is a charset registered in the variable
2264 `font-encoding-alist' as ENCODING.
2265
2266 When a text has a property `charset' and the value is CHARSET, a font
2267 whose encoding corresponds to ENCODING-CHARSET is preferred. */);
2268 Vfont_encoding_charset_alist = Qnil;
2269
2270 DEFVAR_LISP ("use-default-ascent", &Vuse_default_ascent,
2271 doc: /*
2272 Char table of characters whose ascent values should be ignored.
2273 If an entry for a character is non-nil, the ascent value of the glyph
2274 is assumed to be specified by _MULE_DEFAULT_ASCENT property of a font.
2275
2276 This affects how a composite character which contains
2277 such a character is displayed on screen. */);
2278 Vuse_default_ascent = Qnil;
2279
2280 DEFVAR_LISP ("ignore-relative-composition", &Vignore_relative_composition,
2281 doc: /*
2282 Char table of characters which are not composed relatively.
2283 If an entry for a character is non-nil, a composition sequence
2284 which contains that character is displayed so that
2285 the glyph of that character is put without considering
2286 an ascent and descent value of a previous character. */);
2287 Vignore_relative_composition = Qnil;
2288
2289 DEFVAR_LISP ("alternate-fontname-alist", &Valternate_fontname_alist,
2290 doc: /* Alist of fontname vs list of the alternate fontnames.
2291 When a specified font name is not found, the corresponding
2292 alternate fontnames (if any) are tried instead. */);
2293 Valternate_fontname_alist = Qnil;
2294
2295 DEFVAR_LISP ("fontset-alias-alist", &Vfontset_alias_alist,
2296 doc: /* Alist of fontset names vs the aliases. */);
2297 Vfontset_alias_alist = Fcons (Fcons (FONTSET_NAME (Vdefault_fontset),
2298 make_pure_c_string ("fontset-default")),
2299 Qnil);
2300
2301 DEFVAR_LISP ("vertical-centering-font-regexp",
2302 &Vvertical_centering_font_regexp,
2303 doc: /* *Regexp matching font names that require vertical centering on display.
2304 When a character is displayed with such fonts, the character is displayed
2305 at the vertical center of lines. */);
2306 Vvertical_centering_font_regexp = Qnil;
2307
2308 DEFVAR_LISP ("otf-script-alist", &Votf_script_alist,
2309 doc: /* Alist of OpenType script tags vs the corresponding script names. */);
2310 Votf_script_alist = Qnil;
2311
2312 defsubr (&Squery_fontset);
2313 defsubr (&Snew_fontset);
2314 defsubr (&Sset_fontset_font);
2315 defsubr (&Sinternal_char_font);
2316 defsubr (&Sfontset_info);
2317 defsubr (&Sfontset_font);
2318 defsubr (&Sfontset_list);
2319 #ifdef FONTSET_DEBUG
2320 defsubr (&Sfontset_list_all);
2321 #endif
2322 }
2323
2324 /* arch-tag: ea861585-2f5f-4e5b-9849-d04a9c3a3537
2325 (do not change this comment) */