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