#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
#ifdef FONTSET_DEBUG
#undef xassert
#define xassert(X) do {if (!(X)) abort ();} while (0)
#undef INLINE
#define INLINE
#endif
extern Lisp_Object Qfont;
Lisp_Object Qfontset;
static Lisp_Object Vfontset_table;
static int next_fontset_id;
static Lisp_Object Vdefault_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;
struct font_info *(*get_font_info_func) P_ ((FRAME_PTR f, int font_idx));
Lisp_Object (*list_fonts_func) P_ ((struct frame *f,
Lisp_Object pattern,
int size,
int maxnames));
struct font_info *(*load_font_func) P_ ((FRAME_PTR f, char *name, int));
struct font_info *(*query_font_func) P_ ((FRAME_PTR f, char *name));
void (*set_frame_fontset_func) P_ ((FRAME_PTR f, Lisp_Object arg,
Lisp_Object oldval));
void (*find_ccl_program_func) P_ ((struct font_info *));
void (*check_window_system_func) P_ ((void));
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));
#define FONTSET_FROM_ID(id) AREF (Vfontset_table, id)
#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))
#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);
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;
}
#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;
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;
}
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;
while (!NILP (AREF (Vfontset_table, id))) id++;
if (id + 1 == size)
{
Lisp_Object tem;
int i;
tem = Fmake_vector (make_number (size + 8), Qnil);
for (i = 0; i < size; i++)
AREF (tem, i) = AREF (Vfontset_table, i);
Vfontset_table = tem;
}
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;
}
static INLINE int
fontset_id_valid_p (id)
int id;
{
return (id >= 0 && id < ASIZE (Vfontset_table) - 1);
}
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);
}
Lisp_Object
fontset_name (id)
int id;
{
Lisp_Object fontset;
fontset = FONTSET_FROM_ID (id);
return FONTSET_NAME (fontset);
}
Lisp_Object
fontset_ascii (id)
int id;
{
Lisp_Object fontset, elt;
fontset= FONTSET_FROM_ID (id);
elt = FONTSET_ASCII (fontset);
return XCDR (elt);
}
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;
}
}
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));
}
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);
face_id = lookup_face (f, face->lface, c, face);
FONTSET_SET (fontset, c, make_number (face_id));
return face_id;
}
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));
}
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);
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
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))
{
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)
return 0;
fontp = (*load_font_func) (f, fontname, size);
if (!fontp)
return 0;
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)
{
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
{
int i;
fontp->encoding[0] = 0;
for (i = MIN_CHARSET_OFFICIAL_DIMENSION1; i <= MAX_CHARSET; i++)
fontp->encoding[i] = 1;
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 (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
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);
}
}
static Lisp_Object Vcached_fontset_data;
#define CACHED_FONTSET_NAME (SDATA (XCAR (Vcached_fontset_data)))
#define CACHED_FONTSET_REGEX (XCDR (Vcached_fontset_data))
static Lisp_Object
fontset_pattern_regexp (pattern)
Lisp_Object pattern;
{
if (!index (SDATA (pattern), '*')
&& !index (SDATA (pattern), '?'))
return Qnil;
if (!CONSP (Vcached_fontset_data)
|| strcmp (SDATA (pattern), CACHED_FONTSET_NAME))
{
unsigned char *regex, *p0, *p1;
int ndashes = 0, nstars = 0;
for (p0 = SDATA (pattern); *p0; p0++)
{
if (*p0 == '-')
ndashes++;
else if (*p0 == '*')
nstars++;
}
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;
}
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: )
(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);
}
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: )
(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));
}
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;
}
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;
}
static Lisp_Object
check_fontset_name (name)
Lisp_Object name;
{
int id;
if (EQ (name, Qnil))
return Vdefault_fontset;
CHECK_STRING (name);
id = fs_query_fontset (name, 2);
if (id < 0)
id = fs_query_fontset (name, 0);
if (id < 0)
error ("Fontset `%s' does not exist", SDATA (name));
return FONTSET_FROM_ID (id);
}
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: )
(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))
{
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");
}
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);
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: )
(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;
}
DEFUN ("internal-char-font", Finternal_char_font, Sinternal_char_font, 1, 2, 0,
doc: )
(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);
rif->encode_char (c, &char2b, fontp, NULL);
code = (XCHAR2B_BYTE1 (&char2b) << 8) | XCHAR2B_BYTE2 (&char2b);
}
return Fcons (build_string (face->font_name), make_number (code));
}
static void
override_font_info (fontset, character, elt)
Lisp_Object fontset, character, elt;
{
if (! NILP (elt))
Faset (fontset, character, elt);
}
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))
{
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: )
(name, frame)
Lisp_Object name, frame;
{
Lisp_Object fontset;
FRAME_PTR f;
Lisp_Object 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);
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))
{
val = Fcopy_sequence (Vdefault_fontset);
map_char_table (override_font_info, Qnil, fontset, fontset, val, 0, indices);
fontset = val;
}
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 (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: )
(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: )
()
{
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: )
(fontlist)
Lisp_Object fontlist;
{
Lisp_Object tail;
fontlist = Fcopy_sequence (fontlist);
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)
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: );
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: );
Vuse_default_ascent = Qnil;
DEFVAR_LISP ("ignore-relative-composition", &Vignore_relative_composition,
doc: );
Vignore_relative_composition = Qnil;
DEFVAR_LISP ("alternate-fontname-alist", &Valternate_fontname_alist,
doc: );
Valternate_fontname_alist = Qnil;
DEFVAR_LISP ("fontset-alias-alist", &Vfontset_alias_alist,
doc: );
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: );
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);
}