-/* Fontset handler.
- Copyright (C) 2001, 2002, 2003, 2004, 2005, 2006, 2007
- Free Software Foundation, Inc.
- Copyright (C) 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004,
- 2005, 2006, 2007
- National Institute of Advanced Industrial Science and Technology (AIST)
- Registration Number H14PRO021
-
-This file is part of GNU Emacs.
-
-GNU Emacs is free software; you can redistribute it and/or modify
-it under the terms of the GNU General Public License as published by
-the Free Software Foundation; either version 3, or (at your option)
-any later version.
-
-GNU Emacs is distributed in the hope that it will be useful,
-but WITHOUT ANY WARRANTY; without even the implied warranty of
-MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-GNU General Public License for more details.
-
-You should have received a copy of the GNU General Public License
-along with GNU Emacs; see the file COPYING. If not, write to
-the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
-Boston, MA 02110-1301, USA. */
-
-/* #define FONTSET_DEBUG */
-
-#include <config.h>
-
-#ifdef FONTSET_DEBUG
-#include <stdio.h>
-#endif
-
-#include "lisp.h"
-#include "buffer.h"
-#include "charset.h"
-#include "ccl.h"
-#include "keyboard.h"
-#include "frame.h"
-#include "dispextern.h"
-#include "fontset.h"
-#include "window.h"
-#ifdef HAVE_X_WINDOWS
-#include "xterm.h"
-#endif
-#ifdef WINDOWSNT
-#include "w32term.h"
-#endif
-#ifdef MAC_OS
-#include "macterm.h"
-#endif
-#include "termhooks.h"
-
-#ifdef FONTSET_DEBUG
-#undef xassert
-#define xassert(X) do {if (!(X)) abort ();} while (0)
-#undef INLINE
-#define INLINE
-#endif
-
-
-/* FONTSET
-
- A fontset is a collection of font related information to give
- similar appearance (style, size, etc) of characters. There are two
- kinds of fontsets; base and realized. A base fontset is created by
- new-fontset from Emacs Lisp explicitly. A realized fontset is
- created implicitly when a face is realized for ASCII characters. A
- face is also realized for multibyte characters based on an ASCII
- face. All of the multibyte faces based on the same ASCII face
- share the same realized fontset.
-
- A fontset object is implemented by a char-table.
-
- An element of a base fontset is:
- (INDEX . FONTNAME) or
- (INDEX . (FOUNDRY . REGISTRY ))
- FONTNAME is a font name pattern for the corresponding character.
- FOUNDRY and REGISTRY are respectively foundry and registry fields of
- a font name for the corresponding character. INDEX specifies for
- which character (or generic character) the element is defined. It
- may be different from an index to access this element. For
- instance, if a fontset defines some font for all characters of
- charset `japanese-jisx0208', INDEX is the generic character of this
- charset. REGISTRY is the
-
- An element of a realized fontset is FACE-ID which is a face to use
- for displaying the corresponding character.
-
- All single byte characters (ASCII and 8bit-unibyte) share the same
- element in a fontset. The element is stored in the first element
- of the fontset.
-
- To access or set each element, use macros FONTSET_REF and
- FONTSET_SET respectively for efficiency.
-
- A fontset has 3 extra slots.
-
- The 1st slot is an ID number of the fontset.
-
- The 2nd slot is a name of the fontset. This is nil for a realized
- face.
-
- The 3rd slot is a frame that the fontset belongs to. This is nil
- for a default face.
-
- A parent of a base fontset is nil. A parent of a realized fontset
- is a base fontset.
-
- All fontsets are recorded in Vfontset_table.
-
-
- DEFAULT FONTSET
-
- There's a special fontset named `default fontset' which defines a
- default fontname pattern. When a base fontset doesn't specify a
- font for a specific character, the corresponding value in the
- default fontset is used. The format is the same as a base fontset.
-
- The parent of a realized fontset created for such a face that has
- no fontset is the default fontset.
-
-
- These structures are hidden from the other codes than this file.
- The other codes handle fontsets only by their ID numbers. They
- usually use variable name `fontset' for IDs. But, in this file, we
- always use variable name `id' for IDs, and name `fontset' for the
- actual fontset objects.
-
-*/
-
-/********** VARIABLES and FUNCTION PROTOTYPES **********/
-
-extern Lisp_Object Qfont;
-Lisp_Object Qfontset;
-
-/* Vector containing all fontsets. */
-static Lisp_Object Vfontset_table;
-
-/* Next possibly free fontset ID. Usually this keeps the minimum
- fontset ID not yet used. */
-static int next_fontset_id;
-
-/* The default fontset. This gives default FAMILY and REGISTRY of
- font for each characters. */
-static Lisp_Object Vdefault_fontset;
-
-/* Alist of font specifications. It override the font specification
- in the default fontset. */
-static Lisp_Object Voverriding_fontspec_alist;
-
-Lisp_Object Vfont_encoding_alist;
-Lisp_Object Vuse_default_ascent;
-Lisp_Object Vignore_relative_composition;
-Lisp_Object Valternate_fontname_alist;
-Lisp_Object Vfontset_alias_alist;
-Lisp_Object Vvertical_centering_font_regexp;
-
-/* The following six are declarations of callback functions depending
- on window system. See the comments in src/fontset.h for more
- detail. */
-
-/* Return a pointer to struct font_info of font FONT_IDX of frame F. */
-struct font_info *(*get_font_info_func) P_ ((FRAME_PTR f, int font_idx));
-
-/* Return a list of font names which matches PATTERN. See the documentation
- of `x-list-fonts' for more details. */
-Lisp_Object (*list_fonts_func) P_ ((struct frame *f,
- Lisp_Object pattern,
- int size,
- int maxnames));
-
-/* Load a font named NAME for frame F and return a pointer to the
- information of the loaded font. If loading is failed, return 0. */
-struct font_info *(*load_font_func) P_ ((FRAME_PTR f, char *name, int));
-
-/* Return a pointer to struct font_info of a font named NAME for frame F. */
-struct font_info *(*query_font_func) P_ ((FRAME_PTR f, char *name));
-
-/* Additional function for setting fontset or changing fontset
- contents of frame F. */
-void (*set_frame_fontset_func) P_ ((FRAME_PTR f, Lisp_Object arg,
- Lisp_Object oldval));
-
-/* To find a CCL program, fs_load_font calls this function.
- The argument is a pointer to the struct font_info.
- This function set the member `encoder' of the structure. */
-void (*find_ccl_program_func) P_ ((struct font_info *));
-
-/* Check if any window system is used now. */
-void (*check_window_system_func) P_ ((void));
-
-
-/* Prototype declarations for static functions. */
-static Lisp_Object fontset_ref P_ ((Lisp_Object, int));
-static Lisp_Object lookup_overriding_fontspec P_ ((Lisp_Object, int));
-static void fontset_set P_ ((Lisp_Object, int, Lisp_Object));
-static Lisp_Object make_fontset P_ ((Lisp_Object, Lisp_Object, Lisp_Object));
-static int fontset_id_valid_p P_ ((int));
-static Lisp_Object fontset_pattern_regexp P_ ((Lisp_Object));
-static Lisp_Object font_family_registry P_ ((Lisp_Object, int));
-static Lisp_Object regularize_fontname P_ ((Lisp_Object));
-
-\f
-/********** MACROS AND FUNCTIONS TO HANDLE FONTSET **********/
-
-/* Return the fontset with ID. No check of ID's validness. */
-#define FONTSET_FROM_ID(id) AREF (Vfontset_table, id)
-
-/* Macros to access special values of FONTSET. */
-#define FONTSET_ID(fontset) XCHAR_TABLE (fontset)->extras[0]
-#define FONTSET_NAME(fontset) XCHAR_TABLE (fontset)->extras[1]
-#define FONTSET_FRAME(fontset) XCHAR_TABLE (fontset)->extras[2]
-#define FONTSET_ASCII(fontset) XCHAR_TABLE (fontset)->contents[0]
-#define FONTSET_BASE(fontset) XCHAR_TABLE (fontset)->parent
-
-#define BASE_FONTSET_P(fontset) NILP (FONTSET_BASE(fontset))
-
-
-/* Return the element of FONTSET (char-table) at index C (character). */
-
-#define FONTSET_REF(fontset, c) fontset_ref (fontset, c)
-
-static Lisp_Object
-fontset_ref (fontset, c)
- Lisp_Object fontset;
- int c;
-{
- int charset, c1, c2;
- Lisp_Object elt, defalt;
-
- if (SINGLE_BYTE_CHAR_P (c))
- return FONTSET_ASCII (fontset);
-
- SPLIT_CHAR (c, charset, c1, c2);
- elt = XCHAR_TABLE (fontset)->contents[charset + 128];
- if (!SUB_CHAR_TABLE_P (elt))
- return elt;
- defalt = XCHAR_TABLE (elt)->defalt;
- if (c1 < 32
- || (elt = XCHAR_TABLE (elt)->contents[c1],
- NILP (elt)))
- return defalt;
- if (!SUB_CHAR_TABLE_P (elt))
- return elt;
- defalt = XCHAR_TABLE (elt)->defalt;
- if (c2 < 32
- || (elt = XCHAR_TABLE (elt)->contents[c2],
- NILP (elt)))
- return defalt;
- return elt;
-}
-
-
-static Lisp_Object
-lookup_overriding_fontspec (frame, c)
- Lisp_Object frame;
- int c;
-{
- Lisp_Object tail;
-
- for (tail = Voverriding_fontspec_alist; CONSP (tail); tail = XCDR (tail))
- {
- Lisp_Object val, target, elt;
-
- val = XCAR (tail);
- target = XCAR (val);
- val = XCDR (val);
- /* Now VAL is (NO-FRAME-LIST OK-FRAME-LIST CHAR FONTNAME). */
- if (NILP (Fmemq (frame, XCAR (val)))
- && (CHAR_TABLE_P (target)
- ? ! NILP (CHAR_TABLE_REF (target, c))
- : XINT (target) == CHAR_CHARSET (c)))
- {
- val = XCDR (val);
- elt = XCDR (val);
- if (NILP (Fmemq (frame, XCAR (val))))
- {
- if (! face_font_available_p (XFRAME (frame), XCDR (elt)))
- {
- val = XCDR (XCAR (tail));
- XSETCAR (val, Fcons (frame, XCAR (val)));
- continue;
- }
- XSETCAR (val, Fcons (frame, XCAR (val)));
- }
- if (NILP (XCAR (elt)))
- XSETCAR (elt, make_number (c));
- return elt;
- }
- }
- return Qnil;
-}
-
-#define FONTSET_REF_VIA_BASE(fontset, c) fontset_ref_via_base (fontset, &c)
-
-static Lisp_Object
-fontset_ref_via_base (fontset, c)
- Lisp_Object fontset;
- int *c;
-{
- int charset, c1, c2;
- Lisp_Object elt;
-
- if (SINGLE_BYTE_CHAR_P (*c))
- return FONTSET_ASCII (fontset);
-
- elt = Qnil;
- if (! EQ (FONTSET_BASE (fontset), Vdefault_fontset))
- elt = FONTSET_REF (FONTSET_BASE (fontset), *c);
- if (NILP (elt))
- elt = lookup_overriding_fontspec (FONTSET_FRAME (fontset), *c);
- if (NILP (elt))
- elt = FONTSET_REF (Vdefault_fontset, *c);
- if (NILP (elt))
- return Qnil;
-
- *c = XINT (XCAR (elt));
- SPLIT_CHAR (*c, charset, c1, c2);
- elt = XCHAR_TABLE (fontset)->contents[charset + 128];
- if (c1 < 32)
- return (SUB_CHAR_TABLE_P (elt) ? XCHAR_TABLE (elt)->defalt : elt);
- if (!SUB_CHAR_TABLE_P (elt))
- return Qnil;
- elt = XCHAR_TABLE (elt)->contents[c1];
- if (c2 < 32)
- return (SUB_CHAR_TABLE_P (elt) ? XCHAR_TABLE (elt)->defalt : elt);
- if (!SUB_CHAR_TABLE_P (elt))
- return Qnil;
- elt = XCHAR_TABLE (elt)->contents[c2];
- return elt;
-}
-
-
-/* Store into the element of FONTSET at index C the value NEWELT. */
-#define FONTSET_SET(fontset, c, newelt) fontset_set(fontset, c, newelt)
-
-static void
-fontset_set (fontset, c, newelt)
- Lisp_Object fontset;
- int c;
- Lisp_Object newelt;
-{
- int charset, code[3];
- Lisp_Object *elt;
- int i;
-
- if (SINGLE_BYTE_CHAR_P (c))
- {
- FONTSET_ASCII (fontset) = newelt;
- return;
- }
-
- SPLIT_CHAR (c, charset, code[0], code[1]);
- code[2] = 0; /* anchor */
- elt = &XCHAR_TABLE (fontset)->contents[charset + 128];
- for (i = 0; code[i] > 0; i++)
- {
- if (!SUB_CHAR_TABLE_P (*elt))
- {
- Lisp_Object val = *elt;
- *elt = make_sub_char_table (Qnil);
- XCHAR_TABLE (*elt)->defalt = val;
- }
- elt = &XCHAR_TABLE (*elt)->contents[code[i]];
- }
- if (SUB_CHAR_TABLE_P (*elt))
- XCHAR_TABLE (*elt)->defalt = newelt;
- else
- *elt = newelt;
-}
-
-
-/* Return a newly created fontset with NAME. If BASE is nil, make a
- base fontset. Otherwise make a realized fontset whose parent is
- BASE. */
-
-static Lisp_Object
-make_fontset (frame, name, base)
- Lisp_Object frame, name, base;
-{
- Lisp_Object fontset;
- int size = ASIZE (Vfontset_table);
- int id = next_fontset_id;
-
- /* Find a free slot in Vfontset_table. Usually, next_fontset_id is
- the next available fontset ID. So it is expected that this loop
- terminates quickly. In addition, as the last element of
- Vfontset_table is always nil, we don't have to check the range of
- id. */
- while (!NILP (AREF (Vfontset_table, id))) id++;
-
- if (id + 1 == size)
- Vfontset_table = larger_vector (Vfontset_table, size + 8, Qnil);
-
- fontset = Fmake_char_table (Qfontset, Qnil);
-
- FONTSET_ID (fontset) = make_number (id);
- FONTSET_NAME (fontset) = name;
- FONTSET_FRAME (fontset) = frame;
- FONTSET_BASE (fontset) = base;
-
- AREF (Vfontset_table, id) = fontset;
- next_fontset_id = id + 1;
- return fontset;
-}
-
-
-/* Return 1 if ID is a valid fontset id, else return 0. */
-
-static INLINE int
-fontset_id_valid_p (id)
- int id;
-{
- return (id >= 0 && id < ASIZE (Vfontset_table) - 1);
-}
-
-
-/* Extract `family' and `registry' string from FONTNAME and a cons of
- them. Actually, `family' may also contain `foundry', `registry'
- may also contain `encoding' of FONTNAME. But, if FONTNAME doesn't
- conform to XLFD nor explicitely specifies the other fields
- (i.e. not using wildcard `*'), return FONTNAME. If FORCE is
- nonzero, specifications of the other fields are ignored, and return
- a cons as far as FONTNAME conform to XLFD. */
-
-static Lisp_Object
-font_family_registry (fontname, force)
- Lisp_Object fontname;
- int force;
-{
- Lisp_Object family, registry;
- const char *p = SDATA (fontname);
- const char *sep[15];
- int i = 0;
-
- while (*p && i < 15)
- if (*p++ == '-')
- {
- if (!force && i >= 2 && i <= 11 && *p != '*' && p[1] != '-')
- return fontname;
- sep[i++] = p;
- }
- if (i != 14)
- return fontname;
-
- family = make_unibyte_string (sep[0], sep[2] - 1 - sep[0]);
- registry = make_unibyte_string (sep[12], p - sep[12]);
- return Fcons (family, registry);
-}
-
-\f
-/********** INTERFACES TO xfaces.c and dispextern.h **********/
-
-/* Return name of the fontset with ID. */
-
-Lisp_Object
-fontset_name (id)
- int id;
-{
- Lisp_Object fontset;
- fontset = FONTSET_FROM_ID (id);
- return FONTSET_NAME (fontset);
-}
-
-
-/* Return ASCII font name of the fontset with ID. */
-
-Lisp_Object
-fontset_ascii (id)
- int id;
-{
- Lisp_Object fontset, elt;
- fontset= FONTSET_FROM_ID (id);
- elt = FONTSET_ASCII (fontset);
- return XCDR (elt);
-}
-
-
-/* Free fontset of FACE. Called from free_realized_face. */
-
-void
-free_face_fontset (f, face)
- FRAME_PTR f;
- struct face *face;
-{
- if (fontset_id_valid_p (face->fontset))
- {
- AREF (Vfontset_table, face->fontset) = Qnil;
- if (face->fontset < next_fontset_id)
- next_fontset_id = face->fontset;
- }
-}
-
-
-/* Return 1 if FACE is suitable for displaying character C.
- Otherwise return 0. Called from the macro FACE_SUITABLE_FOR_CHAR_P
- when C is not a single byte character.. */
-
-int
-face_suitable_for_char_p (face, c)
- struct face *face;
- int c;
-{
- Lisp_Object fontset, elt;
-
- if (SINGLE_BYTE_CHAR_P (c))
- return (face == face->ascii_face);
-
- xassert (fontset_id_valid_p (face->fontset));
- fontset = FONTSET_FROM_ID (face->fontset);
- xassert (!BASE_FONTSET_P (fontset));
-
- elt = FONTSET_REF_VIA_BASE (fontset, c);
- return (!NILP (elt) && face->id == XFASTINT (elt));
-}
-
-
-/* Return ID of face suitable for displaying character C on frame F.
- The selection of face is done based on the fontset of FACE. FACE
- should already have been realized for ASCII characters. Called
- from the macro FACE_FOR_CHAR when C is not a single byte character. */
-
-int
-face_for_char (f, face, c)
- FRAME_PTR f;
- struct face *face;
- int c;
-{
- Lisp_Object fontset, elt;
- int face_id;
-
- xassert (fontset_id_valid_p (face->fontset));
- fontset = FONTSET_FROM_ID (face->fontset);
- xassert (!BASE_FONTSET_P (fontset));
-
- elt = FONTSET_REF_VIA_BASE (fontset, c);
- if (!NILP (elt))
- return XINT (elt);
-
- /* No face is recorded for C in the fontset of FACE. Make a new
- realized face for C that has the same fontset. */
- face_id = lookup_face (f, face->lface, c, face);
-
- /* Record the face ID in FONTSET at the same index as the
- information in the base fontset. */
- FONTSET_SET (fontset, c, make_number (face_id));
- return face_id;
-}
-
-
-/* Make a realized fontset for ASCII face FACE on frame F from the
- base fontset BASE_FONTSET_ID. If BASE_FONTSET_ID is -1, use the
- default fontset as the base. Value is the id of the new fontset.
- Called from realize_x_face. */
-
-int
-make_fontset_for_ascii_face (f, base_fontset_id)
- FRAME_PTR f;
- int base_fontset_id;
-{
- Lisp_Object base_fontset, fontset, frame;
-
- XSETFRAME (frame, f);
- if (base_fontset_id >= 0)
- {
- base_fontset = FONTSET_FROM_ID (base_fontset_id);
- if (!BASE_FONTSET_P (base_fontset))
- base_fontset = FONTSET_BASE (base_fontset);
- xassert (BASE_FONTSET_P (base_fontset));
- }
- else
- base_fontset = Vdefault_fontset;
-
- fontset = make_fontset (frame, Qnil, base_fontset);
- return XINT (FONTSET_ID (fontset));
-}
-
-
-/* Return the font name pattern for C that is recorded in the fontset
- with ID. If a font name pattern is specified (instead of a cons of
- family and registry), check if a font can be opened by that pattern
- to get the fullname. If a font is opened, return that name.
- Otherwise, return nil. If ID is -1, or the fontset doesn't contain
- information about C, get the registry and encoding of C from the
- default fontset. Called from choose_face_font. */
-
-Lisp_Object
-fontset_font_pattern (f, id, c)
- FRAME_PTR f;
- int id, c;
-{
- Lisp_Object fontset, elt;
- struct font_info *fontp;
-
- elt = Qnil;
- if (fontset_id_valid_p (id))
- {
- fontset = FONTSET_FROM_ID (id);
- xassert (!BASE_FONTSET_P (fontset));
- fontset = FONTSET_BASE (fontset);
- if (! EQ (fontset, Vdefault_fontset))
- elt = FONTSET_REF (fontset, c);
- }
- if (NILP (elt))
- {
- Lisp_Object frame;
-
- XSETFRAME (frame, f);
- elt = lookup_overriding_fontspec (frame, c);
- }
- if (NILP (elt))
- elt = FONTSET_REF (Vdefault_fontset, c);
-
- if (!CONSP (elt))
- return Qnil;
- if (CONSP (XCDR (elt)))
- return XCDR (elt);
-
- /* The fontset specifies only a font name pattern (not cons of
- family and registry). If a font can be opened by that pattern,
- return the name of opened font. Otherwise return nil. The
- exception is a font for single byte characters. In that case, we
- return a cons of FAMILY and REGISTRY extracted from the opened
- font name. */
- elt = XCDR (elt);
- xassert (STRINGP (elt));
- fontp = FS_LOAD_FONT (f, c, SDATA (elt), -1);
- if (!fontp)
- return Qnil;
-
- return font_family_registry (build_string (fontp->full_name),
- SINGLE_BYTE_CHAR_P (c));
-}
-
-
-#if defined(WINDOWSNT) && defined (_MSC_VER)
-#pragma optimize("", off)
-#endif
-
-/* Load a font named FONTNAME to display character C on frame F.
- Return a pointer to the struct font_info of the loaded font. If
- loading fails, return NULL. If FACE is non-zero and a fontset is
- assigned to it, record FACE->id in the fontset for C. If FONTNAME
- is NULL, the name is taken from the fontset of FACE or what
- specified by ID. */
-
-struct font_info *
-fs_load_font (f, c, fontname, id, face)
- FRAME_PTR f;
- int c;
- char *fontname;
- int id;
- struct face *face;
-{
- Lisp_Object fontset;
- Lisp_Object list, elt, fullname;
- int size = 0;
- struct font_info *fontp;
- int charset = CHAR_CHARSET (c);
-
- if (face)
- id = face->fontset;
- if (id < 0)
- fontset = Qnil;
- else
- fontset = FONTSET_FROM_ID (id);
-
- if (!NILP (fontset)
- && !BASE_FONTSET_P (fontset))
- {
- elt = FONTSET_REF_VIA_BASE (fontset, c);
- if (!NILP (elt))
- {
- /* A suitable face for C is already recorded, which means
- that a proper font is already loaded. */
- int face_id = XINT (elt);
-
- xassert (face_id == face->id);
- face = FACE_FROM_ID (f, face_id);
- return (*get_font_info_func) (f, face->font_info_id);
- }
-
- if (!fontname && charset == CHARSET_ASCII)
- {
- elt = FONTSET_ASCII (fontset);
- fontname = SDATA (XCDR (elt));
- }
- }
-
- if (!fontname)
- /* No way to get fontname. */
- return 0;
-
- fontp = (*load_font_func) (f, fontname, size);
- if (!fontp)
- return 0;
-
- /* Fill in members (charset, vertical_centering, encoding, etc) of
- font_info structure that are not set by (*load_font_func). */
- fontp->charset = charset;
-
- fullname = build_string (fontp->full_name);
- fontp->vertical_centering
- = (STRINGP (Vvertical_centering_font_regexp)
- && (fast_string_match_ignore_case
- (Vvertical_centering_font_regexp, fullname) >= 0));
-
- if (fontp->encoding[1] != FONT_ENCODING_NOT_DECIDED)
- {
- /* The font itself tells which code points to be used. Use this
- encoding for all other charsets. */
- int i;
-
- fontp->encoding[0] = fontp->encoding[1];
- for (i = MIN_CHARSET_OFFICIAL_DIMENSION1; i <= MAX_CHARSET; i++)
- fontp->encoding[i] = fontp->encoding[1];
- }
- else
- {
- /* The font itself doesn't have information about encoding. */
- int i;
-
- /* By default, encoding of ASCII chars is 0 (i.e. 0x00..0x7F),
- others is 1 (i.e. 0x80..0xFF). */
- fontp->encoding[0] = 0;
- for (i = MIN_CHARSET_OFFICIAL_DIMENSION1; i <= MAX_CHARSET; i++)
- fontp->encoding[i] = 1;
- /* Then override them by a specification in Vfont_encoding_alist. */
- for (list = Vfont_encoding_alist; CONSP (list); list = XCDR (list))
- {
- elt = XCAR (list);
- if (CONSP (elt)
- && STRINGP (XCAR (elt)) && CONSP (XCDR (elt))
- && (fast_string_match_ignore_case (XCAR (elt), fullname) >= 0))
- {
- Lisp_Object tmp;
-
- for (tmp = XCDR (elt); CONSP (tmp); tmp = XCDR (tmp))
- if (CONSP (XCAR (tmp))
- && ((i = get_charset_id (XCAR (XCAR (tmp))))
- >= 0)
- && INTEGERP (XCDR (XCAR (tmp)))
- && XFASTINT (XCDR (XCAR (tmp))) < 4)
- fontp->encoding[i]
- = XFASTINT (XCDR (XCAR (tmp)));
- }
- }
- }
-
- if (! fontp->font_encoder && find_ccl_program_func)
- (*find_ccl_program_func) (fontp);
-
- /* If we loaded a font for a face that has fontset, record the face
- ID in the fontset for C. */
- if (face
- && !NILP (fontset)
- && !BASE_FONTSET_P (fontset))
- FONTSET_SET (fontset, c, make_number (face->id));
- return fontp;
-}
-
-#if defined(WINDOWSNT) && defined (_MSC_VER)
-#pragma optimize("", on)
-#endif
-
-/* Set the ASCII font of the default fontset to FONTNAME if that is
- not yet set. */
-void
-set_default_ascii_font (fontname)
- Lisp_Object fontname;
-{
- if (! CONSP (FONTSET_ASCII (Vdefault_fontset)))
- {
- int id = fs_query_fontset (fontname, 2);
-
- if (id >= 0)
- fontname = XCDR (FONTSET_ASCII (FONTSET_FROM_ID (id)));
- FONTSET_ASCII (Vdefault_fontset)
- = Fcons (make_number (0), fontname);
- }
-}
-
-\f
-/* Cache data used by fontset_pattern_regexp. The car part is a
- pattern string containing at least one wild card, the cdr part is
- the corresponding regular expression. */
-static Lisp_Object Vcached_fontset_data;
-
-#define CACHED_FONTSET_NAME (SDATA (XCAR (Vcached_fontset_data)))
-#define CACHED_FONTSET_REGEX (XCDR (Vcached_fontset_data))
-
-/* If fontset name PATTERN contains any wild card, return regular
- expression corresponding to PATTERN. */
-
-static Lisp_Object
-fontset_pattern_regexp (pattern)
- Lisp_Object pattern;
-{
- if (!index (SDATA (pattern), '*')
- && !index (SDATA (pattern), '?'))
- /* PATTERN does not contain any wild cards. */
- return Qnil;
-
- if (!CONSP (Vcached_fontset_data)
- || strcmp (SDATA (pattern), CACHED_FONTSET_NAME))
- {
- /* We must at first update the cached data. */
- unsigned char *regex, *p0, *p1;
- int ndashes = 0, nstars = 0;
-
- for (p0 = SDATA (pattern); *p0; p0++)
- {
- if (*p0 == '-')
- ndashes++;
- else if (*p0 == '*')
- nstars++;
- }
-
- /* If PATTERN is not full XLFD we conert "*" to ".*". Otherwise
- we convert "*" to "[^-]*" which is much faster in regular
- expression matching. */
- if (ndashes < 14)
- p1 = regex = (unsigned char *) alloca (SBYTES (pattern) + 2 * nstars + 1);
- else
- p1 = regex = (unsigned char *) alloca (SBYTES (pattern) + 5 * nstars + 1);
-
- *p1++ = '^';
- for (p0 = SDATA (pattern); *p0; p0++)
- {
- if (*p0 == '*')
- {
- if (ndashes < 14)
- *p1++ = '.';
- else
- *p1++ = '[', *p1++ = '^', *p1++ = '-', *p1++ = ']';
- *p1++ = '*';
- }
- else if (*p0 == '?')
- *p1++ = '.';
- else
- *p1++ = *p0;
- }
- *p1++ = '$';
- *p1++ = 0;
-
- Vcached_fontset_data = Fcons (build_string (SDATA (pattern)),
- build_string (regex));
- }
-
- return CACHED_FONTSET_REGEX;
-}
-
-/* Return ID of the base fontset named NAME. If there's no such
- fontset, return -1. NAME_PATTERN specifies how to treat NAME as this:
- 0: pattern containing '*' and '?' as wildcards
- 1: regular expression
- 2: literal fontset name
-*/
-
-int
-fs_query_fontset (name, name_pattern)
- Lisp_Object name;
- int name_pattern;
-{
- Lisp_Object tem;
- int i;
-
- name = Fdowncase (name);
- if (name_pattern != 1)
- {
- tem = Frassoc (name, Vfontset_alias_alist);
- if (CONSP (tem) && STRINGP (XCAR (tem)))
- name = XCAR (tem);
- else if (name_pattern == 0)
- {
- tem = fontset_pattern_regexp (name);
- if (STRINGP (tem))
- {
- name = tem;
- name_pattern = 1;
- }
- }
- }
-
- for (i = 0; i < ASIZE (Vfontset_table); i++)
- {
- Lisp_Object fontset, this_name;
-
- fontset = FONTSET_FROM_ID (i);
- if (NILP (fontset)
- || !BASE_FONTSET_P (fontset))
- continue;
-
- this_name = FONTSET_NAME (fontset);
- if (name_pattern == 1
- ? fast_string_match (name, this_name) >= 0
- : !strcmp (SDATA (name), SDATA (this_name)))
- return i;
- }
- return -1;
-}
-
-
-DEFUN ("query-fontset", Fquery_fontset, Squery_fontset, 1, 2, 0,
- doc: /* Return the name of a fontset that matches PATTERN.
-The value is nil if there is no matching fontset.
-PATTERN can contain `*' or `?' as a wildcard
-just as X font name matching algorithm allows.
-If REGEXPP is non-nil, PATTERN is a regular expression. */)
- (pattern, regexpp)
- Lisp_Object pattern, regexpp;
-{
- Lisp_Object fontset;
- int id;
-
- (*check_window_system_func) ();
-
- CHECK_STRING (pattern);
-
- if (SCHARS (pattern) == 0)
- return Qnil;
-
- id = fs_query_fontset (pattern, !NILP (regexpp));
- if (id < 0)
- return Qnil;
-
- fontset = FONTSET_FROM_ID (id);
- return FONTSET_NAME (fontset);
-}
-
-/* Return a list of base fontset names matching PATTERN on frame F.
- If SIZE is not 0, it is the size (maximum bound width) of fontsets
- to be listed. */
-
-Lisp_Object
-list_fontsets (f, pattern, size)
- FRAME_PTR f;
- Lisp_Object pattern;
- int size;
-{
- Lisp_Object frame, regexp, val;
- int id;
-
- XSETFRAME (frame, f);
-
- regexp = fontset_pattern_regexp (pattern);
- val = Qnil;
-
- for (id = 0; id < ASIZE (Vfontset_table); id++)
- {
- Lisp_Object fontset, name;
-
- fontset = FONTSET_FROM_ID (id);
- if (NILP (fontset)
- || !BASE_FONTSET_P (fontset)
- || !EQ (frame, FONTSET_FRAME (fontset)))
- continue;
- name = FONTSET_NAME (fontset);
-
- if (!NILP (regexp)
- ? (fast_string_match (regexp, name) < 0)
- : strcmp (SDATA (pattern), SDATA (name)))
- continue;
-
- if (size)
- {
- struct font_info *fontp;
- fontp = FS_LOAD_FONT (f, 0, NULL, id);
- if (!fontp || size != fontp->size)
- continue;
- }
- val = Fcons (Fcopy_sequence (FONTSET_NAME (fontset)), val);
- }
-
- return val;
-}
-
-DEFUN ("new-fontset", Fnew_fontset, Snew_fontset, 2, 2, 0,
- doc: /* Create a new fontset NAME that contains font information in FONTLIST.
-FONTLIST is an alist of charsets vs corresponding font name patterns. */)
- (name, fontlist)
- Lisp_Object name, fontlist;
-{
- Lisp_Object fontset, elements, ascii_font;
- Lisp_Object tem, tail, elt;
- int id;
-
- (*check_window_system_func) ();
-
- CHECK_STRING (name);
- CHECK_LIST (fontlist);
-
- name = Fdowncase (name);
- id = fs_query_fontset (name, 2);
- if (id >= 0)
- {
- fontset = FONTSET_FROM_ID (id);
- tem = FONTSET_NAME (fontset);
- error ("Fontset `%s' matches the existing fontset `%s'",
- SDATA (name), SDATA (tem));
- }
-
- /* Check the validity of FONTLIST while creating a template for
- fontset elements. */
- elements = ascii_font = Qnil;
- for (tail = fontlist; CONSP (tail); tail = XCDR (tail))
- {
- int c, charset;
-
- tem = XCAR (tail);
- if (!CONSP (tem)
- || (charset = get_charset_id (XCAR (tem))) < 0
- || (!STRINGP (XCDR (tem)) && !CONSP (XCDR (tem))))
- error ("Elements of fontlist must be a cons of charset and font name pattern");
-
- tem = XCDR (tem);
- if (STRINGP (tem))
- tem = Fdowncase (tem);
- else
- tem = Fcons (Fdowncase (Fcar (tem)), Fdowncase (Fcdr (tem)));
- if (charset == CHARSET_ASCII)
- ascii_font = tem;
- else
- {
- c = MAKE_CHAR (charset, 0, 0);
- elements = Fcons (Fcons (make_number (c), tem), elements);
- }
- }
-
- if (NILP (ascii_font))
- error ("No ASCII font in the fontlist");
-
- fontset = make_fontset (Qnil, name, Qnil);
- FONTSET_ASCII (fontset) = Fcons (make_number (0), ascii_font);
- for (; CONSP (elements); elements = XCDR (elements))
- {
- elt = XCAR (elements);
- tem = XCDR (elt);
- if (STRINGP (tem))
- tem = font_family_registry (tem, 0);
- tem = Fcons (XCAR (elt), tem);
- FONTSET_SET (fontset, XINT (XCAR (elt)), tem);
- }
-
- return Qnil;
-}
-
-
-/* Clear all elements of FONTSET for multibyte characters. */
-
-static void
-clear_fontset_elements (fontset)
- Lisp_Object fontset;
-{
- int i;
-
- for (i = CHAR_TABLE_SINGLE_BYTE_SLOTS; i < CHAR_TABLE_ORDINARY_SLOTS; i++)
- XCHAR_TABLE (fontset)->contents[i] = Qnil;
-}
-
-
-/* Check validity of NAME as a fontset name and return the
- corresponding fontset. If not valid, signal an error.
- If NAME is nil, return Vdefault_fontset. */
-
-static Lisp_Object
-check_fontset_name (name)
- Lisp_Object name;
-{
- int id;
-
- if (EQ (name, Qnil))
- return Vdefault_fontset;
-
- CHECK_STRING (name);
- /* First try NAME as literal. */
- id = fs_query_fontset (name, 2);
- if (id < 0)
- /* For backward compatibility, try again NAME as pattern. */
- id = fs_query_fontset (name, 0);
- if (id < 0)
- error ("Fontset `%s' does not exist", SDATA (name));
- return FONTSET_FROM_ID (id);
-}
-
-/* Downcase FONTNAME or car and cdr of FONTNAME. If FONTNAME is a
- string, maybe change FONTNAME to (FAMILY . REGISTRY). */
-
-static Lisp_Object
-regularize_fontname (Lisp_Object fontname)
-{
- Lisp_Object family, registry;
-
- if (STRINGP (fontname))
- return font_family_registry (Fdowncase (fontname), 0);
-
- CHECK_CONS (fontname);
- family = XCAR (fontname);
- registry = XCDR (fontname);
- if (!NILP (family))
- {
- CHECK_STRING (family);
- family = Fdowncase (family);
- }
- if (!NILP (registry))
- {
- CHECK_STRING (registry);
- registry = Fdowncase (registry);
- }
- return Fcons (family, registry);
-}
-
-DEFUN ("set-fontset-font", Fset_fontset_font, Sset_fontset_font, 3, 4, 0,
- doc: /* Modify fontset NAME to use FONTNAME for CHARACTER.
-
-If NAME is nil, modify the default fontset.
-CHARACTER may be a cons; (FROM . TO), where FROM and TO are
-non-generic characters. In that case, use FONTNAME
-for all characters in the range FROM and TO (inclusive).
-CHARACTER may be a charset. In that case, use FONTNAME
-for all character in the charsets.
-
-FONTNAME may be a cons; (FAMILY . REGISTRY), where FAMILY is a family
-name of a font, REGISTRY is a registry name of a font. */)
- (name, character, fontname, frame)
- Lisp_Object name, character, fontname, frame;
-{
- Lisp_Object fontset, elt;
- Lisp_Object realized;
- int from, to;
- int id;
-
- fontset = check_fontset_name (name);
-
- if (CONSP (character))
- {
- /* CH should be (FROM . TO) where FROM and TO are non-generic
- characters. */
- CHECK_NUMBER_CAR (character);
- CHECK_NUMBER_CDR (character);
- from = XINT (XCAR (character));
- to = XINT (XCDR (character));
- if (!char_valid_p (from, 0) || !char_valid_p (to, 0))
- error ("Character range should be by non-generic characters");
- if (!NILP (name)
- && (SINGLE_BYTE_CHAR_P (from) || SINGLE_BYTE_CHAR_P (to)))
- error ("Can't change font for a single byte character");
- }
- else if (SYMBOLP (character))
- {
- elt = Fget (character, Qcharset);
- if (!VECTORP (elt) || ASIZE (elt) < 1 || !NATNUMP (AREF (elt, 0)))
- error ("Invalid charset: %s", SDATA (SYMBOL_NAME (character)));
- from = MAKE_CHAR (XINT (AREF (elt, 0)), 0, 0);
- to = from;
- }
- else
- {
- CHECK_NUMBER (character);
- from = XINT (character);
- to = from;
- }
- if (!char_valid_p (from, 1))
- invalid_character (from);
- if (SINGLE_BYTE_CHAR_P (from))
- error ("Can't change font for a single byte character");
- if (from < to)
- {
- if (!char_valid_p (to, 1))
- invalid_character (to);
- if (SINGLE_BYTE_CHAR_P (to))
- error ("Can't change font for a single byte character");
- }
-
- /* The arg FRAME is kept for backward compatibility. We only check
- the validity. */
- if (!NILP (frame))
- CHECK_LIVE_FRAME (frame);
-
- elt = Fcons (make_number (from), regularize_fontname (fontname));
- for (; from <= to; from++)
- FONTSET_SET (fontset, from, elt);
- Foptimize_char_table (fontset);
-
- /* If there's a realized fontset REALIZED whose parent is FONTSET,
- clear all the elements of REALIZED and free all multibyte faces
- whose fontset is REALIZED. This way, the specified character(s)
- are surely redisplayed by a correct font. */
- for (id = 0; id < ASIZE (Vfontset_table); id++)
- {
- realized = AREF (Vfontset_table, id);
- if (!NILP (realized)
- && !BASE_FONTSET_P (realized)
- && EQ (FONTSET_BASE (realized), fontset))
- {
- FRAME_PTR f = XFRAME (FONTSET_FRAME (realized));
- clear_fontset_elements (realized);
- free_realized_multibyte_face (f, id);
- }
- }
-
- return Qnil;
-}
-
-DEFUN ("font-info", Ffont_info, Sfont_info, 1, 2, 0,
- doc: /* Return information about a font named NAME on frame FRAME.
-If FRAME is omitted or nil, use the selected frame.
-The returned value is a vector of OPENED-NAME, FULL-NAME, CHARSET, SIZE,
- HEIGHT, BASELINE-OFFSET, RELATIVE-COMPOSE, and DEFAULT-ASCENT,
-where
- OPENED-NAME is the name used for opening the font,
- FULL-NAME is the full name of the font,
- SIZE is the maximum bound width of the font,
- HEIGHT is the height of the font,
- BASELINE-OFFSET is the upward offset pixels from ASCII baseline,
- RELATIVE-COMPOSE and DEFAULT-ASCENT are the numbers controlling
- how to compose characters.
-If the named font is not yet loaded, return nil. */)
- (name, frame)
- Lisp_Object name, frame;
-{
- FRAME_PTR f;
- struct font_info *fontp;
- Lisp_Object info;
-
- (*check_window_system_func) ();
-
- CHECK_STRING (name);
- name = Fdowncase (name);
- if (NILP (frame))
- frame = selected_frame;
- CHECK_LIVE_FRAME (frame);
- f = XFRAME (frame);
-
- if (!query_font_func)
- error ("Font query function is not supported");
-
- fontp = (*query_font_func) (f, SDATA (name));
- if (!fontp)
- return Qnil;
-
- info = Fmake_vector (make_number (7), Qnil);
-
- XVECTOR (info)->contents[0] = build_string (fontp->name);
- XVECTOR (info)->contents[1] = build_string (fontp->full_name);
- XVECTOR (info)->contents[2] = make_number (fontp->size);
- XVECTOR (info)->contents[3] = make_number (fontp->height);
- XVECTOR (info)->contents[4] = make_number (fontp->baseline_offset);
- XVECTOR (info)->contents[5] = make_number (fontp->relative_compose);
- XVECTOR (info)->contents[6] = make_number (fontp->default_ascent);
-
- return info;
-}
-
-
-/* Return a cons (FONT-NAME . GLYPH-CODE).
- FONT-NAME is the font name for the character at POSITION in the current
- buffer. This is computed from all the text properties and overlays
- that apply to POSITION. POSTION may be nil, in which case,
- FONT-NAME is the font name for display the character CH with the
- default face.
-
- GLYPH-CODE is the glyph code in the font to use for the character.
-
- If the 2nd optional arg CH is non-nil, it is a character to check
- the font instead of the character at POSITION.
-
- It returns nil in the following cases:
-
- (1) The window system doesn't have a font for the character (thus
- it is displayed by an empty box).
-
- (2) The character code is invalid.
-
- (3) If POSITION is not nil, and the current buffer is not displayed
- in any window.
-
- In addition, the returned font name may not take into account of
- such redisplay engine hooks as what used in jit-lock-mode if
- POSITION is currently not visible. */
-
-
-DEFUN ("internal-char-font", Finternal_char_font, Sinternal_char_font, 1, 2, 0,
- doc: /* For internal use only. */)
- (position, ch)
- Lisp_Object position, ch;
-{
- int pos, pos_byte, dummy;
- int face_id;
- int c, code;
- struct frame *f;
- struct face *face;
-
- if (NILP (position))
- {
- CHECK_NATNUM (ch);
- c = XINT (ch);
- f = XFRAME (selected_frame);
- face_id = DEFAULT_FACE_ID;
- }
- else
- {
- Lisp_Object window;
- struct window *w;
-
- CHECK_NUMBER_COERCE_MARKER (position);
- pos = XINT (position);
- if (pos < BEGV || pos >= ZV)
- args_out_of_range_3 (position, make_number (BEGV), make_number (ZV));
- pos_byte = CHAR_TO_BYTE (pos);
- if (NILP (ch))
- c = FETCH_CHAR (pos_byte);
- else
- {
- CHECK_NATNUM (ch);
- c = XINT (ch);
- }
- window = Fget_buffer_window (Fcurrent_buffer (), Qnil);
- if (NILP (window))
- return Qnil;
- w = XWINDOW (window);
- f = XFRAME (w->frame);
- face_id = face_at_buffer_position (w, pos, -1, -1, &dummy, pos + 100, 0);
- }
- if (! CHAR_VALID_P (c, 0))
- return Qnil;
- face_id = FACE_FOR_CHAR (f, FACE_FROM_ID (f, face_id), c);
- face = FACE_FROM_ID (f, face_id);
- if (! face->font || ! face->font_name)
- return Qnil;
-
- {
- struct font_info *fontp = (*get_font_info_func) (f, face->font_info_id);
- XChar2b char2b;
- int c1, c2, charset;
-
- SPLIT_CHAR (c, charset, c1, c2);
- if (c2 > 0)
- STORE_XCHAR2B (&char2b, c1, c2);
- else
- STORE_XCHAR2B (&char2b, 0, c1);
- FRAME_RIF (f)->encode_char (c, &char2b, fontp, NULL);
- code = (XCHAR2B_BYTE1 (&char2b) << 8) | XCHAR2B_BYTE2 (&char2b);
- }
- return Fcons (build_string (face->font_name), make_number (code));
-}
-
-
-/* Called from Ffontset_info via map_char_table on each leaf of
- fontset. ARG is a copy of the default fontset. The current leaf
- is indexed by CHARACTER and has value ELT. This function override
- the copy by ELT if ELT is not nil. */
-
-static void
-override_font_info (fontset, character, elt)
- Lisp_Object fontset, character, elt;
-{
- if (! NILP (elt))
- Faset (fontset, character, elt);
-}
-
-/* Called from Ffontset_info via map_char_table on each leaf of
- fontset. ARG is a list (LAST FONT-INFO ...), where LAST is `(last
- ARG)' and FONT-INFOs have this form:
- (CHAR FONT-SPEC) or ((FROM . TO) FONT-SPEC)
- The current leaf is indexed by CHARACTER and has value ELT. This
- function add the information of the current leaf to ARG by
- appending a new element or modifying the last element. */
-
-static void
-accumulate_font_info (arg, character, elt)
- Lisp_Object arg, character, elt;
-{
- Lisp_Object last, last_char, last_elt;
-
- if (!CONSP (elt) && !SINGLE_BYTE_CHAR_P (XINT (character)))
- elt = FONTSET_REF (Vdefault_fontset, XINT (character));
- if (!CONSP (elt))
- return;
- last = XCAR (arg);
- last_char = XCAR (XCAR (last));
- last_elt = XCAR (XCDR (XCAR (last)));
- elt = XCDR (elt);
- if (!NILP (Fequal (elt, last_elt)))
- {
- int this_charset = CHAR_CHARSET (XINT (character));
-
- if (CONSP (last_char)) /* LAST_CHAR == (FROM . TO) */
- {
- if (this_charset == CHAR_CHARSET (XINT (XCAR (last_char))))
- {
- XSETCDR (last_char, character);
- return;
- }
- }
- else if (XINT (last_char) == XINT (character))
- return;
- else if (this_charset == CHAR_CHARSET (XINT (last_char)))
- {
- XSETCAR (XCAR (last), Fcons (last_char, character));
- return;
- }
- }
- XSETCDR (last, Fcons (Fcons (character, Fcons (elt, Qnil)), Qnil));
- XSETCAR (arg, XCDR (last));
-}
-
-
-DEFUN ("fontset-info", Ffontset_info, Sfontset_info, 1, 2, 0,
- doc: /* Return information about a fontset named NAME on frame FRAME.
-If NAME is nil, return information about the default fontset.
-The value is a vector:
- [ SIZE HEIGHT ((CHARSET-OR-RANGE FONT-SPEC OPENED ...) ...) ],
-where,
- SIZE is the maximum bound width of ASCII font in the fontset,
- HEIGHT is the maximum bound height of ASCII font in the fontset,
- CHARSET-OR-RANGE is a charset, a character (may be a generic character)
- or a cons of two characters specifying the range of characters.
- FONT-SPEC is a fontname pattern string or a cons (FAMILY . REGISTRY),
- where FAMILY is a `FAMILY' field of a XLFD font name,
- REGISTRY is a `CHARSET_REGISTRY' field of a XLFD font name.
- FAMILY may contain a `FOUNDRY' field at the head.
- REGISTRY may contain a `CHARSET_ENCODING' field at the tail.
- OPENEDs are names of fonts actually opened.
-If the ASCII font is not yet opened, SIZE and HEIGHT are 0.
-If FRAME is omitted, it defaults to the currently selected frame. */)
- (name, frame)
- Lisp_Object name, frame;
-{
- Lisp_Object fontset;
- FRAME_PTR f;
- int indices[3];
- Lisp_Object val, tail, elt;
- Lisp_Object *realized;
- struct font_info *fontp = NULL;
- int n_realized = 0;
- int i;
-
- (*check_window_system_func) ();
-
- fontset = check_fontset_name (name);
-
- if (NILP (frame))
- frame = selected_frame;
- CHECK_LIVE_FRAME (frame);
- f = XFRAME (frame);
-
- /* Recode realized fontsets whose base is FONTSET in the table
- `realized'. */
- realized = (Lisp_Object *) alloca (sizeof (Lisp_Object)
- * ASIZE (Vfontset_table));
- for (i = 0; i < ASIZE (Vfontset_table); i++)
- {
- elt = FONTSET_FROM_ID (i);
- if (!NILP (elt)
- && EQ (FONTSET_BASE (elt), fontset))
- realized[n_realized++] = elt;
- }
-
- if (! EQ (fontset, Vdefault_fontset))
- {
- /* Merge FONTSET onto the default fontset. */
- val = Fcopy_sequence (Vdefault_fontset);
- map_char_table (override_font_info, Qnil, fontset, fontset, val, 0, indices);
- fontset = val;
- }
-
- /* Accumulate information of the fontset in VAL. The format is
- (LAST FONT-INFO FONT-INFO ...), where FONT-INFO is (CHAR-OR-RANGE
- FONT-SPEC). See the comment for accumulate_font_info for the
- detail. */
- val = Fcons (Fcons (make_number (0),
- Fcons (XCDR (FONTSET_ASCII (fontset)), Qnil)),
- Qnil);
- val = Fcons (val, val);
- map_char_table (accumulate_font_info, Qnil, fontset, fontset, val, 0, indices);
- val = XCDR (val);
-
- /* For each FONT-INFO, if CHAR_OR_RANGE (car part) is a generic
- character for a charset, replace it with the charset symbol. If
- fonts are opened for FONT-SPEC, append the names of the fonts to
- FONT-SPEC. */
- for (tail = val; CONSP (tail); tail = XCDR (tail))
- {
- int c;
- elt = XCAR (tail);
- if (INTEGERP (XCAR (elt)))
- {
- int charset, c1, c2;
- c = XINT (XCAR (elt));
- SPLIT_CHAR (c, charset, c1, c2);
- if (c1 == 0)
- XSETCAR (elt, CHARSET_SYMBOL (charset));
- }
- else
- c = XINT (XCAR (XCAR (elt)));
- for (i = 0; i < n_realized; i++)
- {
- Lisp_Object face_id, font;
- struct face *face;
-
- face_id = FONTSET_REF_VIA_BASE (realized[i], c);
- if (INTEGERP (face_id))
- {
- face = FACE_FROM_ID (f, XINT (face_id));
- if (face && face->font && face->font_name)
- {
- font = build_string (face->font_name);
- if (NILP (Fmember (font, XCDR (XCDR (elt)))))
- XSETCDR (XCDR (elt), Fcons (font, XCDR (XCDR (elt))));
- }
- }
- }
- }
-
- elt = Fcdr (Fcdr (Fassq (CHARSET_SYMBOL (CHARSET_ASCII), val)));
- if (CONSP (elt))
- {
- elt = XCAR (elt);
- fontp = (*query_font_func) (f, SDATA (elt));
- }
- val = Fmake_vector (make_number (3), val);
- AREF (val, 0) = fontp ? make_number (fontp->size) : make_number (0);
- AREF (val, 1) = fontp ? make_number (fontp->height) : make_number (0);
- return val;
-}
-
-DEFUN ("fontset-font", Ffontset_font, Sfontset_font, 2, 2, 0,
- doc: /* Return a font name pattern for character CH in fontset NAME.
-If NAME is nil, find a font name pattern in the default fontset. */)
- (name, ch)
- Lisp_Object name, ch;
-{
- int c;
- Lisp_Object fontset, elt;
-
- fontset = check_fontset_name (name);
-
- CHECK_NUMBER (ch);
- c = XINT (ch);
- if (!char_valid_p (c, 1))
- invalid_character (c);
-
- elt = FONTSET_REF (fontset, c);
- if (CONSP (elt))
- elt = XCDR (elt);
-
- return elt;
-}
-
-DEFUN ("fontset-list", Ffontset_list, Sfontset_list, 0, 0, 0,
- doc: /* Return a list of all defined fontset names. */)
- ()
-{
- Lisp_Object fontset, list;
- int i;
-
- list = Qnil;
- for (i = 0; i < ASIZE (Vfontset_table); i++)
- {
- fontset = FONTSET_FROM_ID (i);
- if (!NILP (fontset)
- && BASE_FONTSET_P (fontset))
- list = Fcons (FONTSET_NAME (fontset), list);
- }
-
- return list;
-}
-
-DEFUN ("set-overriding-fontspec-internal", Fset_overriding_fontspec_internal,
- Sset_overriding_fontspec_internal, 1, 1, 0,
- doc: /* Internal use only.
-
-FONTLIST is an alist of TARGET vs FONTNAME, where TARGET is a charset
-or a char-table, FONTNAME have the same meanings as in
-`set-fontset-font'.
-
-It overrides the font specifications for each TARGET in the default
-fontset by the corresponding FONTNAME.
-
-If TARGET is a charset, targets are all characters in the charset. If
-TARGET is a char-table, targets are characters whose value is non-nil
-in the table.
-
-It is intended that this function is called only from
-`set-language-environment'. */)
- (fontlist)
- Lisp_Object fontlist;
-{
- Lisp_Object tail;
-
- fontlist = Fcopy_sequence (fontlist);
- /* Now FONTLIST is ((TARGET . FONTNAME) ...). Reform it to ((TARGET
- nil nil nil FONTSPEC) ...), where TARGET is a charset-id or a
- char-table. */
- for (tail = fontlist; CONSP (tail); tail = XCDR (tail))
- {
- Lisp_Object elt, target;
-
- elt = XCAR (tail);
- target = Fcar (elt);
- elt = Fcons (Qnil, regularize_fontname (Fcdr (elt)));
- if (! CHAR_TABLE_P (target))
- {
- int charset, c;
-
- CHECK_SYMBOL (target);
- charset = get_charset_id (target);
- if (charset < 0)
- error ("Invalid charset %s", SDATA (SYMBOL_NAME (target)));
- target = make_number (charset);
- c = MAKE_CHAR (charset, 0, 0);
- XSETCAR (elt, make_number (c));
- }
- elt = Fcons (target, Fcons (Qnil, Fcons (Qnil, elt)));
- XSETCAR (tail, elt);
- }
- if (! NILP (Fequal (fontlist, Voverriding_fontspec_alist)))
- return Qnil;
- Voverriding_fontspec_alist = fontlist;
- clear_face_cache (0);
- ++windows_or_buffers_changed;
- return Qnil;
-}
-
-void
-syms_of_fontset ()
-{
- if (!load_font_func)
- /* Window system initializer should have set proper functions. */
- abort ();
-
- Qfontset = intern ("fontset");
- staticpro (&Qfontset);
- Fput (Qfontset, Qchar_table_extra_slots, make_number (3));
-
- Vcached_fontset_data = Qnil;
- staticpro (&Vcached_fontset_data);
-
- Vfontset_table = Fmake_vector (make_number (32), Qnil);
- staticpro (&Vfontset_table);
-
- Vdefault_fontset = Fmake_char_table (Qfontset, Qnil);
- staticpro (&Vdefault_fontset);
- FONTSET_ID (Vdefault_fontset) = make_number (0);
- FONTSET_NAME (Vdefault_fontset)
- = build_string ("-*-*-*-*-*-*-*-*-*-*-*-*-fontset-default");
- AREF (Vfontset_table, 0) = Vdefault_fontset;
- next_fontset_id = 1;
-
- Voverriding_fontspec_alist = Qnil;
- staticpro (&Voverriding_fontspec_alist);
-
- DEFVAR_LISP ("font-encoding-alist", &Vfont_encoding_alist,
- doc: /* Alist of fontname patterns vs corresponding encoding info.
-Each element looks like (REGEXP . ENCODING-INFO),
- where ENCODING-INFO is an alist of CHARSET vs ENCODING.
-ENCODING is one of the following integer values:
- 0: code points 0x20..0x7F or 0x2020..0x7F7F are used,
- 1: code points 0xA0..0xFF or 0xA0A0..0xFFFF are used,
- 2: code points 0x20A0..0x7FFF are used,
- 3: code points 0xA020..0xFF7F are used. */);
- Vfont_encoding_alist = Qnil;
- Vfont_encoding_alist
- = Fcons (Fcons (build_string ("JISX0201"),
- Fcons (Fcons (intern ("latin-jisx0201"), make_number (0)),
- Qnil)),
- Vfont_encoding_alist);
- Vfont_encoding_alist
- = Fcons (Fcons (build_string ("ISO8859-1"),
- Fcons (Fcons (intern ("ascii"), make_number (0)),
- Qnil)),
- Vfont_encoding_alist);
-
- DEFVAR_LISP ("use-default-ascent", &Vuse_default_ascent,
- doc: /* Char table of characters whose ascent values should be ignored.
-If an entry for a character is non-nil, the ascent value of the glyph
-is assumed to be what specified by _MULE_DEFAULT_ASCENT property of a font.
-
-This affects how a composite character which contains
-such a character is displayed on screen. */);
- Vuse_default_ascent = Qnil;
-
- DEFVAR_LISP ("ignore-relative-composition", &Vignore_relative_composition,
- doc: /* Char table of characters which is not composed relatively.
-If an entry for a character is non-nil, a composition sequence
-which contains that character is displayed so that
-the glyph of that character is put without considering
-an ascent and descent value of a previous character. */);
- Vignore_relative_composition = Qnil;
-
- DEFVAR_LISP ("alternate-fontname-alist", &Valternate_fontname_alist,
- doc: /* Alist of fontname vs list of the alternate fontnames.
-When a specified font name is not found, the corresponding
-alternate fontnames (if any) are tried instead. */);
- Valternate_fontname_alist = Qnil;
-
- DEFVAR_LISP ("fontset-alias-alist", &Vfontset_alias_alist,
- doc: /* Alist of fontset names vs the aliases. */);
- Vfontset_alias_alist = Fcons (Fcons (FONTSET_NAME (Vdefault_fontset),
- build_string ("fontset-default")),
- Qnil);
-
- DEFVAR_LISP ("vertical-centering-font-regexp",
- &Vvertical_centering_font_regexp,
- doc: /* *Regexp matching font names that require vertical centering on display.
-When a character is displayed with such fonts, the character is displayed
-at the vertical center of lines. */);
- Vvertical_centering_font_regexp = Qnil;
-
- defsubr (&Squery_fontset);
- defsubr (&Snew_fontset);
- defsubr (&Sset_fontset_font);
- defsubr (&Sfont_info);
- defsubr (&Sinternal_char_font);
- defsubr (&Sfontset_info);
- defsubr (&Sfontset_font);
- defsubr (&Sfontset_list);
- defsubr (&Sset_overriding_fontspec_internal);
-}
-
-/* arch-tag: ea861585-2f5f-4e5b-9849-d04a9c3a3537
- (do not change this comment) */
+/* Fontset handler.
+ Copyright (C) 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008
+ Free Software Foundation, Inc.
+ Copyright (C) 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004,
+ 2005, 2006, 2007, 2008
+ National Institute of Advanced Industrial Science and Technology (AIST)
+ Registration Number H14PRO021
+ Copyright (C) 2003, 2006
+ National Institute of Advanced Industrial Science and Technology (AIST)
+ Registration Number H13PRO009
+
+This file is part of GNU Emacs.
+
+GNU Emacs is free software: you can redistribute it and/or modify
+it under the terms of the GNU General Public License as published by
+the Free Software Foundation, either version 3 of the License, or
+(at your option) any later version.
+
+GNU Emacs is distributed in the hope that it will be useful,
+but WITHOUT ANY WARRANTY; without even the implied warranty of
+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+GNU General Public License for more details.
+
+You should have received a copy of the GNU General Public License
+along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. */
+
+/* #define FONTSET_DEBUG */
+
+#include <config.h>
+#include <stdio.h>
+
+#include "lisp.h"
+#include "blockinput.h"
+#include "buffer.h"
+#include "character.h"
+#include "charset.h"
+#include "ccl.h"
+#include "keyboard.h"
+#include "frame.h"
+#include "dispextern.h"
+#include "intervals.h"
+#include "fontset.h"
+#include "window.h"
+#ifdef HAVE_X_WINDOWS
+#include "xterm.h"
+#endif
+#ifdef WINDOWSNT
+#include "w32term.h"
+#endif
+#ifdef HAVE_NS
+#include "nsterm.h"
+#endif
+#include "termhooks.h"
+
+#include "font.h"
+
+#undef xassert
+#ifdef FONTSET_DEBUG
+#define xassert(X) do {if (!(X)) abort ();} while (0)
+#undef INLINE
+#define INLINE
+#else /* not FONTSET_DEBUG */
+#define xassert(X) (void) 0
+#endif /* not FONTSET_DEBUG */
+
+EXFUN (Fclear_face_cache, 1);
+
+/* FONTSET
+
+ A fontset is a collection of font related information to give
+ similar appearance (style, etc) of characters. A fontset has two
+ roles. One is to use for the frame parameter `font' as if it is an
+ ASCII font. In that case, Emacs uses the font specified for
+ `ascii' script for the frame's default font.
+
+ Another role, the more important one, is to provide information
+ about which font to use for each non-ASCII character.
+
+ There are two kinds of fontsets; base and realized. A base fontset
+ is created by `new-fontset' from Emacs Lisp explicitly. A realized
+ fontset is created implicitly when a face is realized for ASCII
+ characters. A face is also realized for non-ASCII characters based
+ on an ASCII face. All of non-ASCII faces based on the same ASCII
+ face share the same realized fontset.
+
+ A fontset object is implemented by a char-table whose default value
+ and parent are always nil.
+
+ An element of a base fontset is a vector of FONT-DEFs which itself
+ is a vector [ FONT-SPEC ENCODING REPERTORY ].
+
+ An element of a realized fontset is nil, t, or a vector of this form:
+
+ [ CHARSET-ORDERED-LIST-TICK PREFERRED-RFONT-DEF
+ RFONT-DEF0 RFONT-DEF1 ... ]
+
+ RFONT-DEFn (i.e. Realized FONT-DEF) has this form:
+
+ [ FACE-ID FONT-DEF FONT-OBJECT SORTING-SCORE ]
+
+ RFONT-DEFn are automatically reordered by the current charset
+ priority list.
+
+ The value nil means that we have not yet generated the above vector
+ from the base of the fontset.
+
+ The value t means that no font is available for the corresponding
+ range of characters.
+
+
+ A fontset has 9 extra slots.
+
+ The 1st slot: the ID number of the fontset
+
+ The 2nd slot:
+ base: the name of the fontset
+ realized: nil
+
+ The 3rd slot:
+ base: nil
+ realized: the base fontset
+
+ The 4th slot:
+ base: nil
+ realized: the frame that the fontset belongs to
+
+ The 5th slot:
+ base: the font name for ASCII characters
+ realized: nil
+
+ The 6th slot:
+ base: nil
+ realized: the ID number of a face to use for characters that
+ has no font in a realized fontset.
+
+ The 7th slot:
+ base: nil
+ realized: Alist of font index vs the corresponding repertory
+ char-table.
+
+ The 8th slot:
+ base: nil
+ realized: If the base is not the default fontset, a fontset
+ realized from the default fontset, else nil.
+
+ The 9th slot:
+ base: Same as element value (but for fallback fonts).
+ realized: Likewise.
+
+ All fontsets are recorded in the vector Vfontset_table.
+
+
+ DEFAULT FONTSET
+
+ There's a special base fontset named `default fontset' which
+ defines the default font specifications. When a base fontset
+ doesn't specify a font for a specific character, the corresponding
+ value in the default fontset is used.
+
+ The parent of a realized fontset created for such a face that has
+ no fontset is the default fontset.
+
+
+ These structures are hidden from the other codes than this file.
+ The other codes handle fontsets only by their ID numbers. They
+ usually use the variable name `fontset' for IDs. But, in this
+ file, we always use varialbe name `id' for IDs, and name `fontset'
+ for an actual fontset object, i.e., char-table.
+
+*/
+
+/********** VARIABLES and FUNCTION PROTOTYPES **********/
+
+extern Lisp_Object Qfont;
+static Lisp_Object Qfontset;
+static Lisp_Object Qfontset_info;
+static Lisp_Object Qprepend, Qappend;
+static Lisp_Object Qlatin;
+
+/* Vector containing all fontsets. */
+static Lisp_Object Vfontset_table;
+
+/* Next possibly free fontset ID. Usually this keeps the minimum
+ fontset ID not yet used. */
+static int next_fontset_id;
+
+/* The default fontset. This gives default FAMILY and REGISTRY of
+ font for each character. */
+static Lisp_Object Vdefault_fontset;
+
+Lisp_Object Vfont_encoding_charset_alist;
+Lisp_Object Vuse_default_ascent;
+Lisp_Object Vignore_relative_composition;
+Lisp_Object Valternate_fontname_alist;
+Lisp_Object Vfontset_alias_alist;
+Lisp_Object Vvertical_centering_font_regexp;
+Lisp_Object Votf_script_alist;
+
+/* Check if any window system is used now. */
+void (*check_window_system_func) P_ ((void));
+
+
+/* Prototype declarations for static functions. */
+static Lisp_Object fontset_add P_ ((Lisp_Object, Lisp_Object, Lisp_Object,
+ Lisp_Object));
+static Lisp_Object fontset_find_font P_ ((Lisp_Object, int, struct face *,
+ int, int));
+static void reorder_font_vector P_ ((Lisp_Object, struct font *));
+static Lisp_Object fontset_font P_ ((Lisp_Object, int, struct face *, int));
+static Lisp_Object make_fontset P_ ((Lisp_Object, Lisp_Object, Lisp_Object));
+static Lisp_Object fontset_pattern_regexp P_ ((Lisp_Object));
+static void accumulate_script_ranges P_ ((Lisp_Object, Lisp_Object,
+ Lisp_Object));
+Lisp_Object find_font_encoding P_ ((Lisp_Object));
+
+static void set_fontset_font P_ ((Lisp_Object, Lisp_Object));
+
+#ifdef FONTSET_DEBUG
+
+/* Return 1 if ID is a valid fontset id, else return 0. */
+
+static int
+fontset_id_valid_p (id)
+ int id;
+{
+ return (id >= 0 && id < ASIZE (Vfontset_table) - 1);
+}
+
+#endif
+
+
+\f
+/********** MACROS AND FUNCTIONS TO HANDLE FONTSET **********/
+
+/* Return the fontset with ID. No check of ID's validness. */
+#define FONTSET_FROM_ID(id) AREF (Vfontset_table, id)
+
+/* Macros to access special values of FONTSET. */
+#define FONTSET_ID(fontset) XCHAR_TABLE (fontset)->extras[0]
+
+/* Macros to access special values of (base) FONTSET. */
+#define FONTSET_NAME(fontset) XCHAR_TABLE (fontset)->extras[1]
+#define FONTSET_ASCII(fontset) XCHAR_TABLE (fontset)->extras[4]
+#define FONTSET_SPEC(fontset) XCHAR_TABLE (fontset)->extras[5]
+
+/* Macros to access special values of (realized) FONTSET. */
+#define FONTSET_BASE(fontset) XCHAR_TABLE (fontset)->extras[2]
+#define FONTSET_FRAME(fontset) XCHAR_TABLE (fontset)->extras[3]
+#define FONTSET_OBJLIST(fontset) XCHAR_TABLE (fontset)->extras[4]
+#define FONTSET_NOFONT_FACE(fontset) XCHAR_TABLE (fontset)->extras[5]
+#define FONTSET_REPERTORY(fontset) XCHAR_TABLE (fontset)->extras[6]
+#define FONTSET_DEFAULT(fontset) XCHAR_TABLE (fontset)->extras[7]
+
+/* For both base and realized fontset. */
+#define FONTSET_FALLBACK(fontset) XCHAR_TABLE (fontset)->extras[8]
+
+#define BASE_FONTSET_P(fontset) (NILP (FONTSET_BASE (fontset)))
+
+
+/* Macros for FONT-DEF and RFONT-DEF of fontset. */
+#define FONT_DEF_NEW(font_def, font_spec, encoding, repertory) \
+ do { \
+ (font_def) = Fmake_vector (make_number (3), (font_spec)); \
+ ASET ((font_def), 1, encoding); \
+ ASET ((font_def), 2, repertory); \
+ } while (0)
+
+#define FONT_DEF_SPEC(font_def) AREF (font_def, 0)
+#define FONT_DEF_ENCODING(font_def) AREF (font_def, 1)
+#define FONT_DEF_REPERTORY(font_def) AREF (font_def, 2)
+
+#define RFONT_DEF_FACE(rfont_def) AREF (rfont_def, 0)
+#define RFONT_DEF_SET_FACE(rfont_def, face_id) \
+ ASET ((rfont_def), 0, make_number (face_id))
+#define RFONT_DEF_FONT_DEF(rfont_def) AREF (rfont_def, 1)
+#define RFONT_DEF_SPEC(rfont_def) FONT_DEF_SPEC (AREF (rfont_def, 1))
+#define RFONT_DEF_REPERTORY(rfont_def) FONT_DEF_REPERTORY (AREF (rfont_def, 1))
+#define RFONT_DEF_OBJECT(rfont_def) AREF (rfont_def, 2)
+#define RFONT_DEF_SET_OBJECT(rfont_def, object) \
+ ASET ((rfont_def), 2, (object))
+#define RFONT_DEF_SCORE(rfont_def) XINT (AREF (rfont_def, 3))
+#define RFONT_DEF_SET_SCORE(rfont_def, score) \
+ ASET ((rfont_def), 3, make_number (score))
+#define RFONT_DEF_NEW(rfont_def, font_def) \
+ do { \
+ (rfont_def) = Fmake_vector (make_number (4), Qnil); \
+ ASET ((rfont_def), 1, (font_def)); \
+ RFONT_DEF_SET_SCORE ((rfont_def), 0); \
+ } while (0)
+
+
+/* Return the element of FONTSET for the character C. If FONTSET is a
+ base fontset other then the default fontset and FONTSET doesn't
+ contain information for C, return the information in the default
+ fontset. */
+
+#define FONTSET_REF(fontset, c) \
+ (EQ (fontset, Vdefault_fontset) \
+ ? CHAR_TABLE_REF (fontset, c) \
+ : fontset_ref ((fontset), (c)))
+
+static Lisp_Object
+fontset_ref (fontset, c)
+ Lisp_Object fontset;
+ int c;
+{
+ Lisp_Object elt;
+
+ elt = CHAR_TABLE_REF (fontset, c);
+ if (NILP (elt) && ! EQ (fontset, Vdefault_fontset)
+ /* Don't check Vdefault_fontset for a realized fontset. */
+ && NILP (FONTSET_BASE (fontset)))
+ elt = CHAR_TABLE_REF (Vdefault_fontset, c);
+ return elt;
+}
+
+/* Set elements of FONTSET for characters in RANGE to the value ELT.
+ RANGE is a cons (FROM . TO), where FROM and TO are character codes
+ specifying a range. */
+
+#define FONTSET_SET(fontset, range, elt) \
+ Fset_char_table_range ((fontset), (range), (elt))
+
+
+/* Modify the elements of FONTSET for characters in RANGE by replacing
+ with ELT or adding ELT. RANGE is a cons (FROM . TO), where FROM
+ and TO are character codes specifying a range. If ADD is nil,
+ replace with ELT, if ADD is `prepend', prepend ELT, otherwise,
+ append ELT. */
+
+#define FONTSET_ADD(fontset, range, elt, add) \
+ (NILP (add) \
+ ? (NILP (range) \
+ ? (FONTSET_FALLBACK (fontset) = Fmake_vector (make_number (1), (elt))) \
+ : Fset_char_table_range ((fontset), (range), \
+ Fmake_vector (make_number (1), (elt)))) \
+ : fontset_add ((fontset), (range), (elt), (add)))
+
+static Lisp_Object
+fontset_add (fontset, range, elt, add)
+ Lisp_Object fontset, range, elt, add;
+{
+ Lisp_Object args[2];
+ int idx = (EQ (add, Qappend) ? 0 : 1);
+
+ args[1 - idx] = Fmake_vector (make_number (1), elt);
+
+ if (CONSP (range))
+ {
+ int from = XINT (XCAR (range));
+ int to = XINT (XCDR (range));
+ int from1, to1;
+
+ do {
+ args[idx] = char_table_ref_and_range (fontset, from, &from1, &to1);
+ if (to < to1)
+ to1 = to;
+ char_table_set_range (fontset, from, to1,
+ NILP (args[idx]) ? args[1 - idx]
+ : Fvconcat (2, args));
+ from = to1 + 1;
+ } while (from < to);
+ }
+ else
+ {
+ args[idx] = FONTSET_FALLBACK (fontset);
+ FONTSET_FALLBACK (fontset)
+ = NILP (args[idx]) ? args[1 - idx] : Fvconcat (2, args);
+ }
+ return Qnil;
+}
+
+static int
+fontset_compare_rfontdef (val1, val2)
+ const void *val1, *val2;
+{
+ return (RFONT_DEF_SCORE (*(Lisp_Object *) val1)
+ - RFONT_DEF_SCORE (*(Lisp_Object *) val2));
+}
+
+/* Update FONT-GROUP which has this form:
+ [ CHARSET-ORDERED-LIST-TICK PREFERRED-RFONT-DEF
+ RFONT-DEF0 RFONT-DEF1 ... ]
+ Reorder RFONT-DEFs according to the current language, and update
+ CHARSET-ORDERED-LIST-TICK.
+
+ If PREFERRED_FAMILY is not nil, that family has the higher priority
+ if the encoding charsets or languages in font-specs are the same. */
+
+extern Lisp_Object Fassoc_string ();
+
+static void
+reorder_font_vector (font_group, font)
+ Lisp_Object font_group;
+ struct font *font;
+{
+ Lisp_Object vec, font_object;
+ int size;
+ int i;
+ int score_changed = 0;
+
+ if (font)
+ XSETFONT (font_object, font);
+ else
+ font_object = Qnil;
+
+ vec = XCDR (font_group);
+ size = ASIZE (vec);
+ /* Exclude the tailing nil element from the reordering. */
+ if (NILP (AREF (vec, size - 1)))
+ size--;
+
+ for (i = 0; i < size; i++)
+ {
+ Lisp_Object rfont_def = AREF (vec, i);
+ Lisp_Object font_def = RFONT_DEF_FONT_DEF (rfont_def);
+ Lisp_Object font_spec = FONT_DEF_SPEC (font_def);
+ int score = RFONT_DEF_SCORE (rfont_def) & 0xFF;
+
+ if (! font_match_p (font_spec, font_object))
+ {
+ Lisp_Object repertory = FONT_DEF_REPERTORY (font_def);
+
+ if (! NILP (repertory))
+ {
+ Lisp_Object tail;
+
+ for (tail = Vcharset_ordered_list;
+ ! EQ (tail, Vcharset_non_preferred_head) && CONSP (tail);
+ score += 0x100, tail = XCDR (tail))
+ if (EQ (repertory, XCAR (tail)))
+ break;
+ }
+ else
+ {
+ Lisp_Object lang = Ffont_get (font_spec, QClang);
+
+ if (! NILP (lang)
+ && ! EQ (lang, Vcurrent_iso639_language)
+ && (! CONSP (Vcurrent_iso639_language)
+ || NILP (Fmemq (lang, Vcurrent_iso639_language))))
+ score |= 0x100;
+ }
+ }
+ if (RFONT_DEF_SCORE (rfont_def) != score)
+ {
+ RFONT_DEF_SET_SCORE (rfont_def, score);
+ score_changed = 1;
+ }
+ }
+
+ if (score_changed)
+ qsort (XVECTOR (vec)->contents, size, sizeof (Lisp_Object),
+ fontset_compare_rfontdef);
+ XSETCAR (font_group, make_number (charset_ordered_list_tick));
+}
+
+static Lisp_Object
+fontset_get_font_group (Lisp_Object fontset, int c)
+{
+ Lisp_Object font_group;
+ Lisp_Object base_fontset;
+ int from, to, i;
+
+ xassert (! BASE_FONTSET_P (fontset));
+ if (c >= 0)
+ font_group = CHAR_TABLE_REF (fontset, c);
+ else
+ font_group = FONTSET_FALLBACK (fontset);
+ if (! NILP (font_group))
+ return font_group;
+ base_fontset = FONTSET_BASE (fontset);
+ if (c >= 0)
+ font_group = char_table_ref_and_range (base_fontset, c, &from, &to);
+ else
+ font_group = FONTSET_FALLBACK (base_fontset);
+ if (NILP (font_group))
+ return Qnil;
+ font_group = Fcopy_sequence (font_group);
+ for (i = 0; i < ASIZE (font_group); i++)
+ if (! NILP (AREF (font_group, i)))
+ {
+ Lisp_Object rfont_def;
+
+ RFONT_DEF_NEW (rfont_def, AREF (font_group, i));
+ /* Remember the original order. */
+ RFONT_DEF_SET_SCORE (rfont_def, i);
+ ASET (font_group, i, rfont_def);
+ }
+ font_group = Fcons (make_number (-1), font_group);
+ if (c >= 0)
+ char_table_set_range (fontset, from, to, font_group);
+ else
+ FONTSET_FALLBACK (fontset) = font_group;
+ return font_group;
+}
+
+/* Return RFONT-DEF (vector) in the realized fontset FONTSET for the
+ character C. If no font is found, return Qnil if there's a
+ possibility that the default fontset or the fallback font groups
+ have a proper font, and return Qt if not.
+
+ If a font is found but is not yet opened, open it (if FACE is not
+ NULL) or return Qnil (if FACE is NULL).
+
+ ID is a charset-id that must be preferred, or -1 meaning no
+ preference.
+
+ If FALLBACK is nonzero, search only fallback fonts. */
+
+static Lisp_Object
+fontset_find_font (fontset, c, face, id, fallback)
+ Lisp_Object fontset;
+ int c;
+ struct face *face;
+ int id, fallback;
+{
+ Lisp_Object elt, vec, font_group;
+ int i;
+ FRAME_PTR f = XFRAME (FONTSET_FRAME (fontset));
+ int charset_matched = -1;
+
+ font_group = fontset_get_font_group (fontset, fallback ? -1 : c);
+ if (! CONSP (font_group))
+ return Qnil;
+ vec = XCDR (font_group);
+ if (ASIZE (vec) == 0)
+ return Qnil;
+
+ if (ASIZE (vec) > 1)
+ {
+ if (XINT (XCAR (font_group)) != charset_ordered_list_tick)
+ /* We have just created the font-group,
+ or the charset priorities were changed. */
+ reorder_font_vector (font_group, face->ascii_face->font);
+ if (id >= 0)
+ /* Find a spec matching with the charset ID to try at
+ first. */
+ for (i = 0; i < ASIZE (vec); i++)
+ {
+ Lisp_Object rfont_def = AREF (vec, i);
+ Lisp_Object repertory
+ = FONT_DEF_REPERTORY (RFONT_DEF_FONT_DEF (rfont_def));
+
+ if (XINT (repertory) == id)
+ {
+ charset_matched = i;
+ break;
+ }
+ }
+ }
+
+ /* Find the first available font in the vector of RFONT-DEF. */
+ for (i = 0; i < ASIZE (vec); i++)
+ {
+ Lisp_Object font_entity, font_object;
+
+ if (i == 0 && charset_matched >= 0)
+ {
+ /* Try the element matching with the charset ID at first. */
+ elt = AREF (vec, charset_matched);
+ charset_matched = -1;
+ i--;
+ }
+ else if (i != charset_matched)
+ elt = AREF (vec, i);
+ else
+ continue;
+
+ if (NILP (elt))
+ /* This is a sign of not to try the other fonts. */
+ return Qt;
+ if (INTEGERP (RFONT_DEF_FACE (elt))
+ && XINT (AREF (elt, 1)) < 0)
+ /* We couldn't open this font last time. */
+ continue;
+
+ font_object = RFONT_DEF_OBJECT (elt);
+ if (NILP (font_object))
+ {
+ Lisp_Object font_def = RFONT_DEF_FONT_DEF (elt);
+
+ if (! face)
+ /* We have not yet opened the font. */
+ return Qnil;
+ font_entity = font_find_for_lface (f, face->lface,
+ FONT_DEF_SPEC (font_def), -1);
+ if (NILP (font_entity))
+ {
+ /* Record that no font matches the spec. */
+ RFONT_DEF_SET_FACE (elt, -1);
+ continue;
+ }
+ font_object = font_open_for_lface (f, font_entity, face->lface,
+ FONT_DEF_SPEC (font_def));
+ if (NILP (font_object))
+ {
+ /* Record that the font is unsable. */
+ RFONT_DEF_SET_FACE (elt, -1);
+ continue;
+ }
+ RFONT_DEF_SET_OBJECT (elt, font_object);
+ }
+
+ if (font_has_char (f, font_object, c))
+ return elt;
+
+#if 0
+ /* The following code makes Emacs to find a font for C by fairly
+ exhausitive search. But, that takes long time especially for
+ X font backend. */
+
+ /* Try to find the different font maching with the current spec
+ and support C. */
+ font_def = RFONT_DEF_FONT_DEF (elt);
+ for (i++; i < ASIZE (vec); i++)
+ {
+ if (! EQ (RFONT_DEF_FONT_DEF (AREF (vec, i)), font_def))
+ break;
+ if (font_has_char (f, RFONT_DEF_OBJECT (AREF (vec, i)), c))
+ return AREF (vec, i);
+ }
+ /* Find an font-entity that support C. */
+ font_entity = font_find_for_lface (f, face->lface,
+ FONT_DEF_SPEC (font_def), c);
+ if (! NILP (font_entity))
+ {
+ Lisp_Object rfont_def, new_vec;
+ int j;
+
+ font_object = font_open_for_lface (f, font_entity, face->lface,
+ Qnil);
+ RFONT_DEF_NEW (rfont_def, font_def);
+ RFONT_DEF_SET_OBJECT (rfont_def, font_object);
+ RFONT_DEF_SET_SCORE (rfont_def, RFONT_DEF_SCORE (elt));
+ new_vec = Fmake_vector (make_number (ASIZE (vec) + 1), Qnil);
+ for (j = 0; j < i; j++)
+ ASET (new_vec, j, AREF (vec, j));
+ ASET (new_vec, j, rfont_def);
+ for (j++; j < ASIZE (new_vec); j++)
+ ASET (new_vec, j, AREF (vec, j - 1));
+ vec = new_vec;
+ return rfont_def;
+ }
+ i--;
+#endif /* 0 */
+ }
+
+ FONTSET_SET (fontset, make_number (c), make_number (0));
+ return Qnil;
+}
+
+
+static Lisp_Object
+fontset_font (fontset, c, face, id)
+ Lisp_Object fontset;
+ int c;
+ struct face *face;
+ int id;
+{
+ Lisp_Object rfont_def;
+ Lisp_Object base_fontset;
+
+ /* Try a font-group of FONTSET. */
+ rfont_def = fontset_find_font (fontset, c, face, id, 0);
+ if (VECTORP (rfont_def))
+ return rfont_def;
+ if (EQ (rfont_def, Qt))
+ return Qnil;
+
+ /* Try a font-group of the default fontset. */
+ base_fontset = FONTSET_BASE (fontset);
+ if (! EQ (base_fontset, Vdefault_fontset))
+ {
+ if (NILP (FONTSET_DEFAULT (fontset)))
+ FONTSET_DEFAULT (fontset)
+ = make_fontset (FONTSET_FRAME (fontset), Qnil, Vdefault_fontset);
+ rfont_def = fontset_find_font (FONTSET_DEFAULT (fontset), c, face, id, 0);
+ if (VECTORP (rfont_def))
+ return rfont_def;
+ if (EQ (rfont_def, Qt))
+ return Qnil;
+ }
+
+ /* Try a fallback font-group of FONTSET. */
+ rfont_def = fontset_find_font (fontset, c, face, id, 1);
+ if (VECTORP (rfont_def))
+ return rfont_def;
+ if (EQ (rfont_def, Qt))
+ return Qnil;
+
+ /* Try a fallback font-group of the default fontset . */
+ if (! EQ (base_fontset, Vdefault_fontset))
+ {
+ rfont_def = fontset_find_font (FONTSET_DEFAULT (fontset), c, face, id, 1);
+ if (VECTORP (rfont_def))
+ return rfont_def;
+ }
+
+ /* Remeber that we have no font for C. */
+ FONTSET_SET (fontset, make_number (c), Qt);
+
+ return Qnil;
+}
+
+/* Return a newly created fontset with NAME. If BASE is nil, make a
+ base fontset. Otherwise make a realized fontset whose base is
+ BASE. */
+
+static Lisp_Object
+make_fontset (frame, name, base)
+ Lisp_Object frame, name, base;
+{
+ Lisp_Object fontset;
+ int size = ASIZE (Vfontset_table);
+ int id = next_fontset_id;
+
+ /* Find a free slot in Vfontset_table. Usually, next_fontset_id is
+ the next available fontset ID. So it is expected that this loop
+ terminates quickly. In addition, as the last element of
+ Vfontset_table is always nil, we don't have to check the range of
+ id. */
+ while (!NILP (AREF (Vfontset_table, id))) id++;
+
+ if (id + 1 == size)
+ Vfontset_table = larger_vector (Vfontset_table, size + 32, Qnil);
+
+ fontset = Fmake_char_table (Qfontset, Qnil);
+
+ FONTSET_ID (fontset) = make_number (id);
+ if (NILP (base))
+ {
+ FONTSET_NAME (fontset) = name;
+ }
+ else
+ {
+ FONTSET_NAME (fontset) = Qnil;
+ FONTSET_FRAME (fontset) = frame;
+ FONTSET_BASE (fontset) = base;
+ }
+
+ ASET (Vfontset_table, id, fontset);
+ next_fontset_id = id + 1;
+ return fontset;
+}
+
+
+/* Set the ASCII font of the default fontset to FONTNAME if that is
+ not yet set. */
+void
+set_default_ascii_font (fontname)
+ Lisp_Object fontname;
+{
+ if (! STRINGP (FONTSET_ASCII (Vdefault_fontset)))
+ {
+ int id = fs_query_fontset (fontname, 2);
+
+ if (id >= 0)
+ fontname = FONTSET_ASCII (FONTSET_FROM_ID (id));
+ FONTSET_ASCII (Vdefault_fontset)= fontname;
+ }
+}
+
+\f
+/********** INTERFACES TO xfaces.c, xfns.c, and dispextern.h **********/
+
+/* Return the name of the fontset who has ID. */
+
+Lisp_Object
+fontset_name (id)
+ int id;
+{
+ Lisp_Object fontset;
+
+ fontset = FONTSET_FROM_ID (id);
+ return FONTSET_NAME (fontset);
+}
+
+
+/* Return the ASCII font name of the fontset who has ID. */
+
+Lisp_Object
+fontset_ascii (id)
+ int id;
+{
+ Lisp_Object fontset, elt;
+
+ fontset= FONTSET_FROM_ID (id);
+ elt = FONTSET_ASCII (fontset);
+ if (CONSP (elt))
+ elt = XCAR (elt);
+ return elt;
+}
+
+void
+free_realized_fontset (f, fontset)
+ FRAME_PTR f;
+ Lisp_Object fontset;
+{
+ Lisp_Object tail;
+
+ return;
+ for (tail = FONTSET_OBJLIST (fontset); CONSP (tail); tail = XCDR (tail))
+ {
+ xassert (FONT_OBJECT_P (XCAR (tail)));
+ font_close_object (f, XCAR (tail));
+ }
+}
+
+/* Free fontset of FACE defined on frame F. Called from
+ free_realized_face. */
+
+void
+free_face_fontset (f, face)
+ FRAME_PTR f;
+ struct face *face;
+{
+ Lisp_Object fontset;
+
+ fontset = FONTSET_FROM_ID (face->fontset);
+ if (NILP (fontset))
+ return;
+ xassert (! BASE_FONTSET_P (fontset));
+ xassert (f == XFRAME (FONTSET_FRAME (fontset)));
+ free_realized_fontset (f, fontset);
+ ASET (Vfontset_table, face->fontset, Qnil);
+ if (face->fontset < next_fontset_id)
+ next_fontset_id = face->fontset;
+ if (! NILP (FONTSET_DEFAULT (fontset)))
+ {
+ int id = XINT (FONTSET_ID (FONTSET_DEFAULT (fontset)));
+
+ fontset = AREF (Vfontset_table, id);
+ xassert (!NILP (fontset) && ! BASE_FONTSET_P (fontset));
+ xassert (f == XFRAME (FONTSET_FRAME (fontset)));
+ free_realized_fontset (f, fontset);
+ ASET (Vfontset_table, id, Qnil);
+ if (id < next_fontset_id)
+ next_fontset_id = face->fontset;
+ }
+ face->fontset = -1;
+}
+
+
+/* Return 1 if FACE is suitable for displaying character C.
+ Otherwise return 0. Called from the macro FACE_SUITABLE_FOR_CHAR_P
+ when C is not an ASCII character. */
+
+int
+face_suitable_for_char_p (face, c)
+ struct face *face;
+ int c;
+{
+ Lisp_Object fontset, rfont_def;
+
+ fontset = FONTSET_FROM_ID (face->fontset);
+ rfont_def = fontset_font (fontset, c, NULL, -1);
+ return (VECTORP (rfont_def)
+ && INTEGERP (RFONT_DEF_FACE (rfont_def))
+ && face->id == XINT (RFONT_DEF_FACE (rfont_def)));
+}
+
+
+/* Return ID of face suitable for displaying character C on frame F.
+ FACE must be reazlied for ASCII characters in advance. Called from
+ the macro FACE_FOR_CHAR. */
+
+int
+face_for_char (f, face, c, pos, object)
+ FRAME_PTR f;
+ struct face *face;
+ int c, pos;
+ Lisp_Object object;
+{
+ Lisp_Object fontset, rfont_def;
+ int face_id;
+ int id;
+
+ if (ASCII_CHAR_P (c))
+ return face->ascii_face->id;
+
+ xassert (fontset_id_valid_p (face->fontset));
+ fontset = FONTSET_FROM_ID (face->fontset);
+ xassert (!BASE_FONTSET_P (fontset));
+
+ if (pos < 0)
+ id = -1;
+ else
+ {
+ Lisp_Object charset;
+
+ charset = Fget_char_property (make_number (pos), Qcharset, object);
+ if (NILP (charset))
+ id = -1;
+ else if (CHARSETP (charset))
+ {
+ Lisp_Object val;
+
+ val = assoc_no_quit (charset, Vfont_encoding_charset_alist);
+ if (CONSP (val) && CHARSETP (XCDR (val)))
+ charset = XCDR (val);
+ id = XINT (CHARSET_SYMBOL_ID (charset));
+ }
+ }
+
+ rfont_def = fontset_font (fontset, c, face, id);
+ if (VECTORP (rfont_def))
+ {
+ if (INTEGERP (RFONT_DEF_FACE (rfont_def)))
+ face_id = XINT (RFONT_DEF_FACE (rfont_def));
+ else
+ {
+ Lisp_Object font_object;
+
+ font_object = RFONT_DEF_OBJECT (rfont_def);
+ face_id = face_for_font (f, font_object, face);
+ RFONT_DEF_SET_FACE (rfont_def, face_id);
+ }
+ }
+ else
+ {
+ if (INTEGERP (FONTSET_NOFONT_FACE (fontset)))
+ face_id = XINT (FONTSET_NOFONT_FACE (fontset));
+ else
+ {
+ face_id = face_for_font (f, Qnil, face);
+ FONTSET_NOFONT_FACE (fontset) = make_number (face_id);
+ }
+ }
+ xassert (face_id >= 0);
+ return face_id;
+}
+
+
+/* Make a realized fontset for ASCII face FACE on frame F from the
+ base fontset BASE_FONTSET_ID. If BASE_FONTSET_ID is -1, use the
+ default fontset as the base. Value is the id of the new fontset.
+ Called from realize_x_face. */
+
+int
+make_fontset_for_ascii_face (f, base_fontset_id, face)
+ FRAME_PTR f;
+ int base_fontset_id;
+ struct face *face;
+{
+ Lisp_Object base_fontset, fontset, frame;
+
+ XSETFRAME (frame, f);
+ if (base_fontset_id >= 0)
+ {
+ base_fontset = FONTSET_FROM_ID (base_fontset_id);
+ if (!BASE_FONTSET_P (base_fontset))
+ base_fontset = FONTSET_BASE (base_fontset);
+ if (! BASE_FONTSET_P (base_fontset))
+ abort ();
+ }
+ else
+ base_fontset = Vdefault_fontset;
+
+ fontset = make_fontset (frame, Qnil, base_fontset);
+ return XINT (FONTSET_ID (fontset));
+}
+
+\f
+
+/* Cache data used by fontset_pattern_regexp. The car part is a
+ pattern string containing at least one wild card, the cdr part is
+ the corresponding regular expression. */
+static Lisp_Object Vcached_fontset_data;
+
+#define CACHED_FONTSET_NAME ((char *) SDATA (XCAR (Vcached_fontset_data)))
+#define CACHED_FONTSET_REGEX (XCDR (Vcached_fontset_data))
+
+/* If fontset name PATTERN contains any wild card, return regular
+ expression corresponding to PATTERN. */
+
+static Lisp_Object
+fontset_pattern_regexp (pattern)
+ Lisp_Object pattern;
+{
+ if (!index ((char *) SDATA (pattern), '*')
+ && !index ((char *) SDATA (pattern), '?'))
+ /* PATTERN does not contain any wild cards. */
+ return Qnil;
+
+ if (!CONSP (Vcached_fontset_data)
+ || strcmp ((char *) SDATA (pattern), CACHED_FONTSET_NAME))
+ {
+ /* We must at first update the cached data. */
+ unsigned char *regex, *p0, *p1;
+ int ndashes = 0, nstars = 0, nescs = 0;
+
+ for (p0 = SDATA (pattern); *p0; p0++)
+ {
+ if (*p0 == '-')
+ ndashes++;
+ else if (*p0 == '*')
+ nstars++;
+ else if (*p0 == '['
+ || *p0 == '.' || *p0 == '\\'
+ || *p0 == '+' || *p0 == '^'
+ || *p0 == '$')
+ nescs++;
+ }
+
+ /* If PATTERN is not full XLFD we conert "*" to ".*". Otherwise
+ we convert "*" to "[^-]*" which is much faster in regular
+ expression matching. */
+ if (ndashes < 14)
+ p1 = regex = (unsigned char *) alloca (SBYTES (pattern) + 2 * nstars + 2 * nescs + 1);
+ else
+ p1 = regex = (unsigned char *) alloca (SBYTES (pattern) + 5 * nstars + 2 * nescs + 1);
+
+ *p1++ = '^';
+ for (p0 = SDATA (pattern); *p0; p0++)
+ {
+ if (*p0 == '*')
+ {
+ if (ndashes < 14)
+ *p1++ = '.';
+ else
+ *p1++ = '[', *p1++ = '^', *p1++ = '-', *p1++ = ']';
+ *p1++ = '*';
+ }
+ else if (*p0 == '?')
+ *p1++ = '.';
+ else if (*p0 == '['
+ || *p0 == '.' || *p0 == '\\'
+ || *p0 == '+' || *p0 == '^'
+ || *p0 == '$')
+ *p1++ = '\\', *p1++ = *p0;
+ else
+ *p1++ = *p0;
+ }
+ *p1++ = '$';
+ *p1++ = 0;
+
+ Vcached_fontset_data = Fcons (build_string ((char *) SDATA (pattern)),
+ build_string ((char *) regex));
+ }
+
+ return CACHED_FONTSET_REGEX;
+}
+
+/* Return ID of the base fontset named NAME. If there's no such
+ fontset, return -1. NAME_PATTERN specifies how to treat NAME as this:
+ 0: pattern containing '*' and '?' as wildcards
+ 1: regular expression
+ 2: literal fontset name
+*/
+
+int
+fs_query_fontset (name, name_pattern)
+ Lisp_Object name;
+ int name_pattern;
+{
+ Lisp_Object tem;
+ int i;
+
+ name = Fdowncase (name);
+ if (name_pattern != 1)
+ {
+ tem = Frassoc (name, Vfontset_alias_alist);
+ if (NILP (tem))
+ tem = Fassoc (name, Vfontset_alias_alist);
+ if (CONSP (tem) && STRINGP (XCAR (tem)))
+ name = XCAR (tem);
+ else if (name_pattern == 0)
+ {
+ tem = fontset_pattern_regexp (name);
+ if (STRINGP (tem))
+ {
+ name = tem;
+ name_pattern = 1;
+ }
+ }
+ }
+
+ for (i = 0; i < ASIZE (Vfontset_table); i++)
+ {
+ Lisp_Object fontset, this_name;
+
+ fontset = FONTSET_FROM_ID (i);
+ if (NILP (fontset)
+ || !BASE_FONTSET_P (fontset))
+ continue;
+
+ this_name = FONTSET_NAME (fontset);
+ if (name_pattern == 1
+ ? fast_string_match_ignore_case (name, this_name) >= 0
+ : !xstrcasecmp (SDATA (name), SDATA (this_name)))
+ return i;
+ }
+ return -1;
+}
+
+
+DEFUN ("query-fontset", Fquery_fontset, Squery_fontset, 1, 2, 0,
+ doc: /* Return the name of a fontset that matches PATTERN.
+The value is nil if there is no matching fontset.
+PATTERN can contain `*' or `?' as a wildcard
+just as X font name matching algorithm allows.
+If REGEXPP is non-nil, PATTERN is a regular expression. */)
+ (pattern, regexpp)
+ Lisp_Object pattern, regexpp;
+{
+ Lisp_Object fontset;
+ int id;
+
+ (*check_window_system_func) ();
+
+ CHECK_STRING (pattern);
+
+ if (SCHARS (pattern) == 0)
+ return Qnil;
+
+ id = fs_query_fontset (pattern, !NILP (regexpp));
+ if (id < 0)
+ return Qnil;
+
+ fontset = FONTSET_FROM_ID (id);
+ return FONTSET_NAME (fontset);
+}
+
+/* Return a list of base fontset names matching PATTERN on frame F. */
+
+Lisp_Object
+list_fontsets (f, pattern, size)
+ FRAME_PTR f;
+ Lisp_Object pattern;
+ int size;
+{
+ Lisp_Object frame, regexp, val;
+ int id;
+
+ XSETFRAME (frame, f);
+
+ regexp = fontset_pattern_regexp (pattern);
+ val = Qnil;
+
+ for (id = 0; id < ASIZE (Vfontset_table); id++)
+ {
+ Lisp_Object fontset, name;
+
+ fontset = FONTSET_FROM_ID (id);
+ if (NILP (fontset)
+ || !BASE_FONTSET_P (fontset)
+ || !EQ (frame, FONTSET_FRAME (fontset)))
+ continue;
+ name = FONTSET_NAME (fontset);
+
+ if (STRINGP (regexp)
+ ? (fast_string_match (regexp, name) < 0)
+ : strcmp ((char *) SDATA (pattern), (char *) SDATA (name)))
+ continue;
+
+ val = Fcons (Fcopy_sequence (FONTSET_NAME (fontset)), val);
+ }
+
+ return val;
+}
+
+
+/* Free all realized fontsets whose base fontset is BASE. */
+
+static void
+free_realized_fontsets (base)
+ Lisp_Object base;
+{
+ int id;
+
+#if 0
+ /* For the moment, this doesn't work because free_realized_face
+ doesn't remove FACE from a cache. Until we find a solution, we
+ suppress this code, and simply use Fclear_face_cache even though
+ that is not efficient. */
+ BLOCK_INPUT;
+ for (id = 0; id < ASIZE (Vfontset_table); id++)
+ {
+ Lisp_Object this = AREF (Vfontset_table, id);
+
+ if (EQ (FONTSET_BASE (this), base))
+ {
+ Lisp_Object tail;
+
+ for (tail = FONTSET_FACE_ALIST (this); CONSP (tail);
+ tail = XCDR (tail))
+ {
+ FRAME_PTR f = XFRAME (FONTSET_FRAME (this));
+ int face_id = XINT (XCDR (XCAR (tail)));
+ struct face *face = FACE_FROM_ID (f, face_id);
+
+ /* Face THIS itself is also freed by the following call. */
+ free_realized_face (f, face);
+ }
+ }
+ }
+ UNBLOCK_INPUT;
+#else /* not 0 */
+ /* But, we don't have to call Fclear_face_cache if no fontset has
+ been realized from BASE. */
+ for (id = 0; id < ASIZE (Vfontset_table); id++)
+ {
+ Lisp_Object this = AREF (Vfontset_table, id);
+
+ if (CHAR_TABLE_P (this) && EQ (FONTSET_BASE (this), base))
+ {
+ Fclear_face_cache (Qt);
+ break;
+ }
+ }
+#endif /* not 0 */
+}
+
+
+/* Check validity of NAME as a fontset name and return the
+ corresponding fontset. If not valid, signal an error.
+ If NAME is t, return Vdefault_fontset. */
+
+static Lisp_Object
+check_fontset_name (name)
+ Lisp_Object name;
+{
+ int id;
+
+ if (EQ (name, Qt))
+ return Vdefault_fontset;
+
+ CHECK_STRING (name);
+ /* First try NAME as literal. */
+ id = fs_query_fontset (name, 2);
+ if (id < 0)
+ /* For backward compatibility, try again NAME as pattern. */
+ id = fs_query_fontset (name, 0);
+ if (id < 0)
+ error ("Fontset `%s' does not exist", SDATA (name));
+ return FONTSET_FROM_ID (id);
+}
+
+static void
+accumulate_script_ranges (arg, range, val)
+ Lisp_Object arg, range, val;
+{
+ if (EQ (XCAR (arg), val))
+ {
+ if (CONSP (range))
+ XSETCDR (arg, Fcons (Fcons (XCAR (range), XCDR (range)), XCDR (arg)));
+ else
+ XSETCDR (arg, Fcons (Fcons (range, range), XCDR (arg)));
+ }
+}
+
+
+/* Return an ASCII font name generated from fontset name NAME and
+ font-spec ASCII_SPEC. NAME is a string conforming to XLFD. */
+
+static INLINE Lisp_Object
+generate_ascii_font_name (name, ascii_spec)
+ Lisp_Object name, ascii_spec;
+{
+ Lisp_Object font_spec = Ffont_spec (0, NULL);
+ int i;
+ char xlfd[256];
+
+ if (font_parse_xlfd ((char *) SDATA (name), font_spec) < 0)
+ error ("Not an XLFD font name: %s", SDATA (name));
+ for (i = FONT_FOUNDRY_INDEX; i < FONT_EXTRA_INDEX; i++)
+ if (! NILP (AREF (ascii_spec, i)))
+ ASET (font_spec, i, AREF (ascii_spec, i));
+ i = font_unparse_xlfd (font_spec, 0, xlfd, 256);
+ if (i < 0)
+ error ("Not an XLFD font name: %s", SDATA (name));
+ return make_unibyte_string (xlfd, i);
+}
+
+/* Variables referred in set_fontset_font. They are set before
+ map_charset_chars is called in Fset_fontset_font. */
+static Lisp_Object font_def_arg, add_arg;
+static int from_arg, to_arg;
+
+/* Callback function for map_charset_chars in Fset_fontset_font. In
+ FONTSET, set font_def_arg in a fashion specified by add_arg for
+ characters in RANGE while ignoring the range between from_arg and
+ to_arg. */
+
+static void
+set_fontset_font (fontset, range)
+ Lisp_Object fontset, range;
+{
+ if (from_arg < to_arg)
+ {
+ int from = XINT (XCAR (range)), to = XINT (XCDR (range));
+
+ if (from < from_arg)
+ {
+ if (to > to_arg)
+ {
+ Lisp_Object range2;
+
+ range2 = Fcons (make_number (to_arg), XCDR (range));
+ FONTSET_ADD (fontset, range, font_def_arg, add_arg);
+ to = to_arg;
+ }
+ if (to > from_arg)
+ range = Fcons (XCAR (range), make_number (from_arg));
+ }
+ else if (to <= to_arg)
+ return;
+ else
+ {
+ if (from < to_arg)
+ range = Fcons (make_number (to_arg), XCDR (range));
+ }
+ }
+ FONTSET_ADD (fontset, range, font_def_arg, add_arg);
+}
+
+extern Lisp_Object QCfamily, QCregistry;
+
+DEFUN ("set-fontset-font", Fset_fontset_font, Sset_fontset_font, 3, 5, 0,
+ doc: /*
+Modify fontset NAME to use FONT-SPEC for TARGET characters.
+
+TARGET may be a cons; (FROM . TO), where FROM and TO are characters.
+In that case, use FONT-SPEC for all characters in the range FROM and
+TO (inclusive).
+
+TARGET may be a script name symbol. In that case, use FONT-SPEC for
+all characters that belong to the script.
+
+TARGET may be a charset. In that case, use FONT-SPEC for all
+characters in the charset.
+
+TARGET may be nil. In that case, use FONT-SPEC for any characters for
+that no FONT-SPEC is specified.
+
+FONT-SPEC may one of these:
+ * A font-spec object made by the function `font-spec' (which see).
+ * A cons (FAMILY . REGISTRY), where FAMILY is a font family name and
+ REGISTRY is a font registry name. FAMILY may contain foundry
+ name, and REGISTRY may contain encoding name.
+ * A font name string.
+ * nil, which explicitly specifies that there's no font for TARGET.
+
+Optional 4th argument FRAME, if non-nil, is a frame. This argument is
+kept for backward compatibility and has no meaning.
+
+Optional 5th argument ADD, if non-nil, specifies how to add FONT-SPEC
+to the font specifications for TARGET previously set. If it is
+`prepend', FONT-SPEC is prepended. If it is `append', FONT-SPEC is
+appended. By default, FONT-SPEC overrides the previous settings. */)
+ (name, target, font_spec, frame, add)
+ Lisp_Object name, target, font_spec, frame, add;
+{
+ Lisp_Object fontset;
+ Lisp_Object font_def, registry, family;
+ Lisp_Object range_list;
+ struct charset *charset = NULL;
+
+ fontset = check_fontset_name (name);
+
+ /* The arg FRAME is kept for backward compatibility. We only check
+ the validity. */
+ if (!NILP (frame))
+ CHECK_LIVE_FRAME (frame);
+
+ if (CONSP (font_spec))
+ {
+ Lisp_Object spec = Ffont_spec (0, NULL);
+
+ font_parse_family_registry (XCAR (font_spec), XCDR (font_spec), spec);
+ font_spec = spec;
+ }
+ else if (STRINGP (font_spec))
+ {
+ Lisp_Object args[2];
+ extern Lisp_Object QCname;
+
+ args[0] = QCname;
+ args[1] = font_spec;
+ font_spec = Ffont_spec (2, args);
+ }
+ else if (! NILP (font_spec) && ! FONT_SPEC_P (font_spec))
+ Fsignal (Qfont, list2 (build_string ("Invalid font-spec"), font_spec));
+
+ if (! NILP (font_spec))
+ {
+ Lisp_Object encoding, repertory;
+
+ family = AREF (font_spec, FONT_FAMILY_INDEX);
+ if (! NILP (family) )
+ family = SYMBOL_NAME (family);
+ registry = AREF (font_spec, FONT_REGISTRY_INDEX);
+ if (! NILP (registry))
+ registry = Fdowncase (SYMBOL_NAME (registry));
+ encoding = find_font_encoding (concat3 (family, build_string ("-"),
+ registry));
+ if (NILP (encoding))
+ encoding = Qascii;
+
+ if (SYMBOLP (encoding))
+ {
+ CHECK_CHARSET (encoding);
+ encoding = repertory = CHARSET_SYMBOL_ID (encoding);
+ }
+ else
+ {
+ repertory = XCDR (encoding);
+ encoding = XCAR (encoding);
+ CHECK_CHARSET (encoding);
+ encoding = CHARSET_SYMBOL_ID (encoding);
+ if (! NILP (repertory) && SYMBOLP (repertory))
+ {
+ CHECK_CHARSET (repertory);
+ repertory = CHARSET_SYMBOL_ID (repertory);
+ }
+ }
+ FONT_DEF_NEW (font_def, font_spec, encoding, repertory);
+ }
+ else
+ font_def = Qnil;
+
+ if (CHARACTERP (target))
+ range_list = Fcons (Fcons (target, target), Qnil);
+ else if (CONSP (target))
+ {
+ Lisp_Object from, to;
+
+ from = Fcar (target);
+ to = Fcdr (target);
+ CHECK_CHARACTER (from);
+ CHECK_CHARACTER (to);
+ range_list = Fcons (target, Qnil);
+ }
+ else if (SYMBOLP (target) && !NILP (target))
+ {
+ Lisp_Object script_list;
+ Lisp_Object val;
+
+ range_list = Qnil;
+ script_list = XCHAR_TABLE (Vchar_script_table)->extras[0];
+ if (! NILP (Fmemq (target, script_list)))
+ {
+ val = Fcons (target, Qnil);
+ map_char_table (accumulate_script_ranges, Qnil, Vchar_script_table,
+ val);
+ range_list = XCDR (val);
+ if (EQ (target, Qlatin) && NILP (FONTSET_ASCII (fontset)))
+ {
+ if (VECTORP (font_spec))
+ val = generate_ascii_font_name (FONTSET_NAME (fontset),
+ font_spec);
+ else
+ val = font_spec;
+ FONTSET_ASCII (fontset) = val;
+ }
+ }
+ if (CHARSETP (target))
+ {
+ if (EQ (target, Qascii) && NILP (FONTSET_ASCII (fontset)))
+ {
+ if (VECTORP (font_spec))
+ font_spec = generate_ascii_font_name (FONTSET_NAME (fontset),
+ font_spec);
+ FONTSET_ASCII (fontset) = font_spec;
+ range_list = Fcons (Fcons (make_number (0), make_number (127)),
+ Qnil);
+ }
+ else
+ {
+ CHECK_CHARSET_GET_CHARSET (target, charset);
+ }
+ }
+ else if (NILP (range_list))
+ error ("Invalid script or charset name: %s",
+ SDATA (SYMBOL_NAME (target)));
+ }
+ else if (NILP (target))
+ range_list = Fcons (Qnil, Qnil);
+ else
+ error ("Invalid target for setting a font");
+
+
+ if (charset)
+ {
+ font_def_arg = font_def;
+ add_arg = add;
+ if (NILP (range_list))
+ from_arg = to_arg = 0;
+ else
+ from_arg = XINT (XCAR (XCAR (range_list))),
+ to_arg = XINT (XCDR (XCAR (range_list)));
+
+ map_charset_chars (set_fontset_font, Qnil, fontset, charset,
+ CHARSET_MIN_CODE (charset),
+ CHARSET_MAX_CODE (charset));
+ }
+ for (; CONSP (range_list); range_list = XCDR (range_list))
+ FONTSET_ADD (fontset, XCAR (range_list), font_def, add);
+
+ /* Free all realized fontsets whose base is FONTSET. This way, the
+ specified character(s) are surely redisplayed by a correct
+ font. */
+ free_realized_fontsets (fontset);
+
+ return Qnil;
+}
+
+
+DEFUN ("new-fontset", Fnew_fontset, Snew_fontset, 2, 2, 0,
+ doc: /* Create a new fontset NAME from font information in FONTLIST.
+
+FONTLIST is an alist of scripts vs the corresponding font specification list.
+Each element of FONTLIST has the form (SCRIPT FONT-SPEC ...), where a
+character of SCRIPT is displayed by a font that matches one of
+FONT-SPEC.
+
+SCRIPT is a symbol that appears in the first extra slot of the
+char-table `char-script-table'.
+
+FONT-SPEC is a vector, a cons, or a string. See the documentation of
+`set-fontset-font' for the meaning. */)
+ (name, fontlist)
+ Lisp_Object name, fontlist;
+{
+ Lisp_Object fontset;
+ int id;
+
+ CHECK_STRING (name);
+ CHECK_LIST (fontlist);
+
+ name = Fdowncase (name);
+ id = fs_query_fontset (name, 0);
+ if (id < 0)
+ {
+ Lisp_Object font_spec = Ffont_spec (0, NULL);
+ Lisp_Object short_name;
+ char xlfd[256];
+ int len;
+
+ if (font_parse_xlfd ((char *) SDATA (name), font_spec) < 0)
+ error ("Fontset name must be in XLFD format");
+ short_name = AREF (font_spec, FONT_REGISTRY_INDEX);
+ if (strncmp ((char *) SDATA (SYMBOL_NAME (short_name)), "fontset-", 8)
+ || SBYTES (SYMBOL_NAME (short_name)) < 9)
+ error ("Registry field of fontset name must be \"fontset-*\"");
+ Vfontset_alias_alist = Fcons (Fcons (name, SYMBOL_NAME (short_name)),
+ Vfontset_alias_alist);
+ ASET (font_spec, FONT_REGISTRY_INDEX, Qiso8859_1);
+ fontset = make_fontset (Qnil, name, Qnil);
+ len = font_unparse_xlfd (font_spec, 0, xlfd, 256);
+ if (len < 0)
+ error ("Invalid fontset name (perhaps too long): %s", SDATA (name));
+ FONTSET_ASCII (fontset) = make_unibyte_string (xlfd, len);
+ }
+ else
+ {
+ fontset = FONTSET_FROM_ID (id);;
+ free_realized_fontsets (fontset);
+ Fset_char_table_range (fontset, Qt, Qnil);
+ }
+
+ for (; ! NILP (fontlist); fontlist = Fcdr (fontlist))
+ {
+ Lisp_Object elt, script;
+
+ elt = Fcar (fontlist);
+ script = Fcar (elt);
+ elt = Fcdr (elt);
+ if (CONSP (elt) && (NILP (XCDR (elt)) || CONSP (XCDR (elt))))
+ for (; CONSP (elt); elt = XCDR (elt))
+ Fset_fontset_font (name, script, XCAR (elt), Qnil, Qappend);
+ else
+ Fset_fontset_font (name, script, elt, Qnil, Qappend);
+ }
+ return name;
+}
+
+
+/* Alist of automatically created fontsets. Each element is a cons
+ (FONT-SPEC . FONTSET-ID). */
+static Lisp_Object auto_fontset_alist;
+
+int
+fontset_from_font (font_object)
+ Lisp_Object font_object;
+{
+ Lisp_Object font_name = font_get_name (font_object);
+ Lisp_Object font_spec = Fcopy_font_spec (font_object);
+ Lisp_Object fontset_spec, alias, name, fontset;
+ Lisp_Object val;
+ int i;
+
+ val = assoc_no_quit (font_spec, auto_fontset_alist);
+ if (CONSP (val))
+ return XINT (FONTSET_ID (XCDR (val)));
+ if (NILP (auto_fontset_alist))
+ alias = intern ("fontset-startup");
+ else
+ {
+ char temp[32];
+ int len = XINT (Flength (auto_fontset_alist));
+
+ sprintf (temp, "fontset-auto%d", len);
+ alias = intern (temp);
+ }
+ fontset_spec = Fcopy_font_spec (font_spec);
+ ASET (fontset_spec, FONT_REGISTRY_INDEX, alias);
+ name = Ffont_xlfd_name (fontset_spec, Qnil);
+ if (NILP (name))
+ abort ();
+ fontset = make_fontset (Qnil, name, Qnil);
+ Vfontset_alias_alist = Fcons (Fcons (name, SYMBOL_NAME (alias)),
+ Vfontset_alias_alist);
+ alias = Fdowncase (AREF (font_object, FONT_NAME_INDEX));
+ Vfontset_alias_alist = Fcons (Fcons (name, alias), Vfontset_alias_alist);
+ auto_fontset_alist = Fcons (Fcons (font_spec, fontset), auto_fontset_alist);
+ FONTSET_ASCII (fontset) = font_name;
+ font_spec = Fcopy_font_spec (font_spec);
+ ASET (font_spec, FONT_REGISTRY_INDEX, Qiso10646_1);
+ for (i = FONT_WEIGHT_INDEX; i < FONT_EXTRA_INDEX; i++)
+ ASET (font_spec, i, Qnil);
+ Fset_fontset_font (name, Qlatin, font_spec, Qnil, Qnil);
+ Fset_fontset_font (name, Qnil, font_spec, Qnil, Qnil);
+
+#ifdef HAVE_NS
+ nsfont_make_fontset_for_font(name, font_object);
+#endif
+
+ return XINT (FONTSET_ID (fontset));
+}
+
+/* Return a cons (FONT-OBJECT . GLYPH-CODE).
+ FONT-OBJECT is the font for the character at POSITION in the current
+ buffer. This is computed from all the text properties and overlays
+ that apply to POSITION. POSTION may be nil, in which case,
+ FONT-SPEC is the font for displaying the character CH with the
+ default face.
+
+ GLYPH-CODE is the glyph code in the font to use for the character.
+
+ If the 2nd optional arg CH is non-nil, it is a character to check
+ the font instead of the character at POSITION.
+
+ It returns nil in the following cases:
+
+ (1) The window system doesn't have a font for the character (thus
+ it is displayed by an empty box).
+
+ (2) The character code is invalid.
+
+ (3) If POSITION is not nil, and the current buffer is not displayed
+ in any window.
+
+ In addition, the returned font name may not take into account of
+ such redisplay engine hooks as what used in jit-lock-mode if
+ POSITION is currently not visible. */
+
+
+DEFUN ("internal-char-font", Finternal_char_font, Sinternal_char_font, 1, 2, 0,
+ doc: /* For internal use only. */)
+ (position, ch)
+ Lisp_Object position, ch;
+{
+ EMACS_INT pos, pos_byte, dummy;
+ int face_id;
+ int c;
+ struct frame *f;
+ struct face *face;
+ int cs_id;
+
+ if (NILP (position))
+ {
+ CHECK_CHARACTER (ch);
+ c = XINT (ch);
+ f = XFRAME (selected_frame);
+ face_id = lookup_basic_face (f, DEFAULT_FACE_ID);
+ pos = -1;
+ cs_id = -1;
+ }
+ else
+ {
+ Lisp_Object window, charset;
+ struct window *w;
+
+ CHECK_NUMBER_COERCE_MARKER (position);
+ pos = XINT (position);
+ if (pos < BEGV || pos >= ZV)
+ args_out_of_range_3 (position, make_number (BEGV), make_number (ZV));
+ pos_byte = CHAR_TO_BYTE (pos);
+ if (NILP (ch))
+ c = FETCH_CHAR (pos_byte);
+ else
+ {
+ CHECK_NATNUM (ch);
+ c = XINT (ch);
+ }
+ window = Fget_buffer_window (Fcurrent_buffer (), Qnil);
+ if (NILP (window))
+ return Qnil;
+ w = XWINDOW (window);
+ f = XFRAME (w->frame);
+ face_id = face_at_buffer_position (w, pos, -1, -1, &dummy, pos + 100, 0);
+ charset = Fget_char_property (position, Qcharset, Qnil);
+ if (CHARSETP (charset))
+ cs_id = XINT (CHARSET_SYMBOL_ID (charset));
+ else
+ cs_id = -1;
+ }
+ if (! CHAR_VALID_P (c, 0))
+ return Qnil;
+ face_id = FACE_FOR_CHAR (f, FACE_FROM_ID (f, face_id), c, pos, Qnil);
+ face = FACE_FROM_ID (f, face_id);
+ if (face->font)
+ {
+ unsigned code = face->font->driver->encode_char (face->font, c);
+ Lisp_Object font_object;
+ /* Assignment to EMACS_INT stops GCC whining about limited range
+ of data type. */
+ EMACS_INT cod = code;
+
+ if (code == FONT_INVALID_CODE)
+ return Qnil;
+ XSETFONT (font_object, face->font);
+ if (cod <= MOST_POSITIVE_FIXNUM)
+ return Fcons (font_object, make_number (code));
+ return Fcons (font_object, Fcons (make_number (code >> 16),
+ make_number (code & 0xFFFF)));
+ }
+ return Qnil;
+}
+
+
+DEFUN ("fontset-info", Ffontset_info, Sfontset_info, 1, 2, 0,
+ doc: /* Return information about a fontset FONTSET on frame FRAME.
+The value is a char-table whose elements have this form:
+
+ ((FONT-PATTERN OPENED-FONT ...) ...)
+
+FONT-PATTERN is a vector:
+
+ [ FAMILY WEIGHT SLANT SWIDTH ADSTYLE REGISTRY ]
+
+or a string of font name pattern.
+
+OPENED-FONT is a name of a font actually opened.
+
+The char-table has one extra slot. The value is a char-table
+containing the information about the derived fonts from the default
+fontset. The format is the same as above. */)
+ (fontset, frame)
+ Lisp_Object fontset, frame;
+{
+ FRAME_PTR f;
+ Lisp_Object *realized[2], fontsets[2], tables[2];
+ Lisp_Object val, elt;
+ int c, i, j, k;
+
+ (*check_window_system_func) ();
+
+ fontset = check_fontset_name (fontset);
+
+ if (NILP (frame))
+ frame = selected_frame;
+ CHECK_LIVE_FRAME (frame);
+ f = XFRAME (frame);
+
+ /* Recode fontsets realized on FRAME from the base fontset FONTSET
+ in the table `realized'. */
+ realized[0] = (Lisp_Object *) alloca (sizeof (Lisp_Object)
+ * ASIZE (Vfontset_table));
+ for (i = j = 0; i < ASIZE (Vfontset_table); i++)
+ {
+ elt = FONTSET_FROM_ID (i);
+ if (!NILP (elt)
+ && EQ (FONTSET_BASE (elt), fontset)
+ && EQ (FONTSET_FRAME (elt), frame))
+ realized[0][j++] = elt;
+ }
+ realized[0][j] = Qnil;
+
+ realized[1] = (Lisp_Object *) alloca (sizeof (Lisp_Object)
+ * ASIZE (Vfontset_table));
+ for (i = j = 0; ! NILP (realized[0][i]); i++)
+ {
+ elt = FONTSET_DEFAULT (realized[0][i]);
+ if (! NILP (elt))
+ realized[1][j++] = elt;
+ }
+ realized[1][j] = Qnil;
+
+ tables[0] = Fmake_char_table (Qfontset_info, Qnil);
+ tables[1] = Fmake_char_table (Qnil, Qnil);
+ XCHAR_TABLE (tables[0])->extras[0] = tables[1];
+ fontsets[0] = fontset;
+ fontsets[1] = Vdefault_fontset;
+
+ /* Accumulate information of the fontset in TABLE. The format of
+ each element is ((FONT-SPEC OPENED-FONT ...) ...). */
+ for (k = 0; k <= 1; k++)
+ {
+ for (c = 0; c <= MAX_CHAR; )
+ {
+ int from, to;
+
+ if (c <= MAX_5_BYTE_CHAR)
+ {
+ val = char_table_ref_and_range (fontsets[k], c, &from, &to);
+ if (to > MAX_5_BYTE_CHAR)
+ to = MAX_5_BYTE_CHAR;
+ }
+ else
+ {
+ val = FONTSET_FALLBACK (fontsets[k]);
+ to = MAX_CHAR;
+ }
+ if (VECTORP (val))
+ {
+ Lisp_Object alist;
+
+ /* At first, set ALIST to ((FONT-SPEC) ...). */
+ for (alist = Qnil, i = 0; i < ASIZE (val); i++)
+ if (! NILP (AREF (val, i)))
+ alist = Fcons (Fcons (FONT_DEF_SPEC (AREF (val, i)), Qnil),
+ alist);
+ alist = Fnreverse (alist);
+
+ /* Then store opened font names to cdr of each elements. */
+ for (i = 0; ! NILP (realized[k][i]); i++)
+ {
+ if (c <= MAX_5_BYTE_CHAR)
+ val = FONTSET_REF (realized[k][i], c);
+ else
+ val = FONTSET_FALLBACK (realized[k][i]);
+ if (! VECTORP (val))
+ continue;
+ /* VAL: [int ? [FACE-ID FONT-DEF FONT-OBJECT int] ... ] */
+ for (j = 2; j < ASIZE (val); j++)
+ {
+ elt = AREF (val, j);
+ if (FONT_OBJECT_P (RFONT_DEF_OBJECT (elt)))
+ {
+ Lisp_Object font_object = RFONT_DEF_OBJECT (elt);
+ Lisp_Object slot, name;
+
+ slot = Fassq (RFONT_DEF_SPEC (elt), alist);
+ name = AREF (font_object, FONT_NAME_INDEX);
+ if (NILP (Fmember (name, XCDR (slot))))
+ nconc2 (slot, Fcons (name, Qnil));
+ }
+ }
+ }
+
+ /* Store ALIST in TBL for characters C..TO. */
+ if (c <= MAX_5_BYTE_CHAR)
+ char_table_set_range (tables[k], c, to, alist);
+ else
+ XCHAR_TABLE (tables[k])->defalt = alist;
+
+ /* At last, change each elements to font names. */
+ for (; CONSP (alist); alist = XCDR (alist))
+ {
+ elt = XCAR (alist);
+ XSETCAR (elt, Ffont_xlfd_name (XCAR (elt), Qnil));
+ }
+ }
+ c = to + 1;
+ }
+ }
+
+ return tables[0];
+}
+
+
+DEFUN ("fontset-font", Ffontset_font, Sfontset_font, 2, 3, 0,
+ doc: /* Return a font name pattern for character CH in fontset NAME.
+If NAME is t, find a pattern in the default fontset.
+
+The value has the form (FAMILY . REGISTRY), where FAMILY is a font
+family name and REGISTRY is a font registry name. This is actually
+the first font name pattern for CH in the fontset or in the default
+fontset.
+
+If the 2nd optional arg ALL is non-nil, return a list of all font name
+patterns. */)
+ (name, ch, all)
+ Lisp_Object name, ch, all;
+{
+ int c;
+ Lisp_Object fontset, elt, list, repertory, val;
+ int i, j;
+
+ fontset = check_fontset_name (name);
+
+ CHECK_CHARACTER (ch);
+ c = XINT (ch);
+ list = Qnil;
+ while (1)
+ {
+ for (i = 0, elt = FONTSET_REF (fontset, c); i < 2;
+ i++, elt = FONTSET_FALLBACK (fontset))
+ if (VECTORP (elt))
+ for (j = 0; j < ASIZE (elt); j++)
+ {
+ val = AREF (elt, j);
+ repertory = AREF (val, 1);
+ if (INTEGERP (repertory))
+ {
+ struct charset *charset = CHARSET_FROM_ID (XINT (repertory));
+
+ if (! CHAR_CHARSET_P (c, charset))
+ continue;
+ }
+ else if (CHAR_TABLE_P (repertory))
+ {
+ if (NILP (CHAR_TABLE_REF (repertory, c)))
+ continue;
+ }
+ val = AREF (val, 0);
+ val = Fcons (AREF (val, 0), AREF (val, 5));
+ if (NILP (all))
+ return val;
+ list = Fcons (val, list);
+ }
+ if (EQ (fontset, Vdefault_fontset))
+ break;
+ fontset = Vdefault_fontset;
+ }
+ return (Fnreverse (list));
+}
+
+DEFUN ("fontset-list", Ffontset_list, Sfontset_list, 0, 0, 0,
+ doc: /* Return a list of all defined fontset names. */)
+ ()
+{
+ Lisp_Object fontset, list;
+ int i;
+
+ list = Qnil;
+ for (i = 0; i < ASIZE (Vfontset_table); i++)
+ {
+ fontset = FONTSET_FROM_ID (i);
+ if (!NILP (fontset)
+ && BASE_FONTSET_P (fontset))
+ list = Fcons (FONTSET_NAME (fontset), list);
+ }
+
+ return list;
+}
+
+
+#ifdef FONTSET_DEBUG
+
+Lisp_Object
+dump_fontset (fontset)
+ Lisp_Object fontset;
+{
+ Lisp_Object vec;
+
+ vec = Fmake_vector (make_number (3), Qnil);
+ ASET (vec, 0, FONTSET_ID (fontset));
+
+ if (BASE_FONTSET_P (fontset))
+ {
+ ASET (vec, 1, FONTSET_NAME (fontset));
+ }
+ else
+ {
+ Lisp_Object frame;
+
+ frame = FONTSET_FRAME (fontset);
+ if (FRAMEP (frame))
+ {
+ FRAME_PTR f = XFRAME (frame);
+
+ if (FRAME_LIVE_P (f))
+ ASET (vec, 1,
+ Fcons (FONTSET_NAME (FONTSET_BASE (fontset)), f->name));
+ else
+ ASET (vec, 1,
+ Fcons (FONTSET_NAME (FONTSET_BASE (fontset)), Qnil));
+ }
+ if (!NILP (FONTSET_DEFAULT (fontset)))
+ ASET (vec, 2, FONTSET_ID (FONTSET_DEFAULT (fontset)));
+ }
+ return vec;
+}
+
+DEFUN ("fontset-list-all", Ffontset_list_all, Sfontset_list_all, 0, 0, 0,
+ doc: /* Return a brief summary of all fontsets for debug use. */)
+ ()
+{
+ Lisp_Object val;
+ int i;
+
+ for (i = 0, val = Qnil; i < ASIZE (Vfontset_table); i++)
+ if (! NILP (AREF (Vfontset_table, i)))
+ val = Fcons (dump_fontset (AREF (Vfontset_table, i)), val);
+ return (Fnreverse (val));
+}
+#endif /* FONTSET_DEBUG */
+
+void
+syms_of_fontset ()
+{
+ DEFSYM (Qfontset, "fontset");
+ Fput (Qfontset, Qchar_table_extra_slots, make_number (9));
+ DEFSYM (Qfontset_info, "fontset-info");
+ Fput (Qfontset_info, Qchar_table_extra_slots, make_number (1));
+
+ DEFSYM (Qprepend, "prepend");
+ DEFSYM (Qappend, "append");
+ DEFSYM (Qlatin, "latin");
+
+ Vcached_fontset_data = Qnil;
+ staticpro (&Vcached_fontset_data);
+
+ Vfontset_table = Fmake_vector (make_number (32), Qnil);
+ staticpro (&Vfontset_table);
+
+ Vdefault_fontset = Fmake_char_table (Qfontset, Qnil);
+ staticpro (&Vdefault_fontset);
+ FONTSET_ID (Vdefault_fontset) = make_number (0);
+ FONTSET_NAME (Vdefault_fontset)
+ = build_string ("-*-*-*-*-*-*-*-*-*-*-*-*-fontset-default");
+ ASET (Vfontset_table, 0, Vdefault_fontset);
+ next_fontset_id = 1;
+
+ auto_fontset_alist = Qnil;
+ staticpro (&auto_fontset_alist);
+
+ DEFVAR_LISP ("font-encoding-charset-alist", &Vfont_encoding_charset_alist,
+ doc: /*
+Alist of charsets vs the charsets to determine the preferred font encoding.
+Each element looks like (CHARSET . ENCODING-CHARSET),
+where ENCODING-CHARSET is a charset registered in the variable
+`font-encoding-alist' as ENCODING.
+
+When a text has a property `charset' and the value is CHARSET, a font
+whose encoding corresponds to ENCODING-CHARSET is preferred. */);
+ Vfont_encoding_charset_alist = Qnil;
+
+ DEFVAR_LISP ("use-default-ascent", &Vuse_default_ascent,
+ doc: /*
+Char table of characters whose ascent values should be ignored.
+If an entry for a character is non-nil, the ascent value of the glyph
+is assumed to be specified by _MULE_DEFAULT_ASCENT property of a font.
+
+This affects how a composite character which contains
+such a character is displayed on screen. */);
+ Vuse_default_ascent = Qnil;
+
+ DEFVAR_LISP ("ignore-relative-composition", &Vignore_relative_composition,
+ doc: /*
+Char table of characters which are not composed relatively.
+If an entry for a character is non-nil, a composition sequence
+which contains that character is displayed so that
+the glyph of that character is put without considering
+an ascent and descent value of a previous character. */);
+ Vignore_relative_composition = Qnil;
+
+ DEFVAR_LISP ("alternate-fontname-alist", &Valternate_fontname_alist,
+ doc: /* Alist of fontname vs list of the alternate fontnames.
+When a specified font name is not found, the corresponding
+alternate fontnames (if any) are tried instead. */);
+ Valternate_fontname_alist = Qnil;
+
+ DEFVAR_LISP ("fontset-alias-alist", &Vfontset_alias_alist,
+ doc: /* Alist of fontset names vs the aliases. */);
+ Vfontset_alias_alist = Fcons (Fcons (FONTSET_NAME (Vdefault_fontset),
+ build_string ("fontset-default")),
+ Qnil);
+
+ DEFVAR_LISP ("vertical-centering-font-regexp",
+ &Vvertical_centering_font_regexp,
+ doc: /* *Regexp matching font names that require vertical centering on display.
+When a character is displayed with such fonts, the character is displayed
+at the vertical center of lines. */);
+ Vvertical_centering_font_regexp = Qnil;
+
+ DEFVAR_LISP ("otf-script-alist", &Votf_script_alist,
+ doc: /* Alist of OpenType script tags vs the corresponding script names. */);
+ Votf_script_alist = Qnil;
+
+ defsubr (&Squery_fontset);
+ defsubr (&Snew_fontset);
+ defsubr (&Sset_fontset_font);
+ defsubr (&Sinternal_char_font);
+ defsubr (&Sfontset_info);
+ defsubr (&Sfontset_font);
+ defsubr (&Sfontset_list);
+#ifdef FONTSET_DEBUG
+ defsubr (&Sfontset_list_all);
+#endif
+}
+
+/* arch-tag: ea861585-2f5f-4e5b-9849-d04a9c3a3537
+ (do not change this comment) */
HCoop / bpt / emacs.git / blobdiff