/* Fontset handler.
+ Copyright (C) 2004 Free Software Foundation, Inc.
Copyright (C) 1995, 1997, 2000 Electrotechnical Laboratory, JAPAN.
Licensed to the Free Software Foundation.
#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
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;
/* 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 **********/
}
+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
if (SINGLE_BYTE_CHAR_P (*c))
return FONTSET_ASCII (fontset);
- elt = FONTSET_REF (FONTSET_BASE (fontset), *c);
- if (NILP (elt) && ! EQ (fontset, Vdefault_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;
int force;
{
Lisp_Object family, registry;
- char *p = XSTRING (fontname)->data;
- char *sep[15];
+ const char *p = SDATA (fontname);
+ const char *sep[15];
int i = 0;
while (*p && i < 15)
fontset = FONTSET_FROM_ID (id);
xassert (!BASE_FONTSET_P (fontset));
fontset = FONTSET_BASE (fontset);
- elt = FONTSET_REF (fontset, c);
+ 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);
font name. */
elt = XCDR (elt);
xassert (STRINGP (elt));
- fontp = FS_LOAD_FONT (f, c, XSTRING (elt)->data, -1);
+ fontp = FS_LOAD_FONT (f, c, SDATA (elt), -1);
if (!fontp)
return Qnil;
if (!fontname && charset == CHARSET_ASCII)
{
elt = FONTSET_ASCII (fontset);
- fontname = XSTRING (XCDR (elt))->data;
+ fontname = SDATA (XCDR (elt));
}
}
}
}
- fontp->font_encoder = (struct ccl_program *) 0;
-
- if (find_ccl_program_func)
+ 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
the corresponding regular expression. */
static Lisp_Object Vcached_fontset_data;
-#define CACHED_FONTSET_NAME (XSTRING (XCAR (Vcached_fontset_data))->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
fontset_pattern_regexp (pattern)
Lisp_Object pattern;
{
- if (!index (XSTRING (pattern)->data, '*')
- && !index (XSTRING (pattern)->data, '?'))
+ if (!index (SDATA (pattern), '*')
+ && !index (SDATA (pattern), '?'))
/* PATTERN does not contain any wild cards. */
return Qnil;
if (!CONSP (Vcached_fontset_data)
- || strcmp (XSTRING (pattern)->data, CACHED_FONTSET_NAME))
+ || strcmp (SDATA (pattern), CACHED_FONTSET_NAME))
{
/* We must at first update the cached data. */
- char *regex = (char *) alloca (XSTRING (pattern)->size * 2 + 3);
+ char *regex = (char *) alloca (SCHARS (pattern) * 2 + 3);
char *p0, *p1 = regex;
/* Convert "*" to ".*", "?" to ".". */
*p1++ = '^';
- for (p0 = (char *) XSTRING (pattern)->data; *p0; p0++)
+ for (p0 = (char *) SDATA (pattern); *p0; p0++)
{
if (*p0 == '*')
{
*p1++ = '$';
*p1++ = 0;
- Vcached_fontset_data = Fcons (build_string (XSTRING (pattern)->data),
+ Vcached_fontset_data = Fcons (build_string (SDATA (pattern)),
build_string (regex));
}
for (i = 0; i < ASIZE (Vfontset_table); i++)
{
Lisp_Object fontset;
- unsigned char *this_name;
+ const unsigned char *this_name;
fontset = FONTSET_FROM_ID (i);
if (NILP (fontset)
|| !BASE_FONTSET_P (fontset))
continue;
- this_name = XSTRING (FONTSET_NAME (fontset))->data;
+ this_name = SDATA (FONTSET_NAME (fontset));
if (regexpp
? fast_c_string_match_ignore_case (name, this_name) >= 0
- : !strcmp (XSTRING (name)->data, this_name))
+ : !strcmp (SDATA (name), this_name))
return i;
}
return -1;
CHECK_STRING (pattern);
- if (XSTRING (pattern)->size == 0)
+ if (SCHARS (pattern) == 0)
return Qnil;
id = fs_query_fontset (pattern, !NILP (regexpp));
for (id = 0; id < ASIZE (Vfontset_table); id++)
{
Lisp_Object fontset;
- unsigned char *name;
+ const unsigned char *name;
fontset = FONTSET_FROM_ID (id);
if (NILP (fontset)
|| !BASE_FONTSET_P (fontset)
|| !EQ (frame, FONTSET_FRAME (fontset)))
continue;
- name = XSTRING (FONTSET_NAME (fontset))->data;
+ name = SDATA (FONTSET_NAME (fontset));
if (!NILP (regexp)
? (fast_c_string_match_ignore_case (regexp, name) < 0)
- : strcmp (XSTRING (pattern)->data, name))
+ : strcmp (SDATA (pattern), name))
continue;
if (size)
tem = Fquery_fontset (name, Qnil);
if (!NILP (tem))
error ("Fontset `%s' matches the existing fontset `%s'",
- XSTRING (name)->data, XSTRING (tem)->data);
+ SDATA (name), SDATA (tem));
/* Check the validity of FONTLIST while creating a template for
fontset elements. */
/* 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. */
+ If NAME is nil, return Vdefault_fontset. */
static Lisp_Object
check_fontset_name (name)
{
int id;
- if (EQ (name, Qt))
+ if (EQ (name, Qnil))
return Vdefault_fontset;
CHECK_STRING (name);
id = fs_query_fontset (name, 0);
if (id < 0)
- error ("Fontset `%s' does not exist", XSTRING (name)->data);
+ 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
+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
Lisp_Object realized;
int from, to;
int id;
- Lisp_Object family, registry;
fontset = check_fontset_name (name);
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.");
+ 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");
{
elt = Fget (character, Qcharset);
if (!VECTORP (elt) || ASIZE (elt) < 1 || !NATNUMP (AREF (elt, 0)))
- error ("Invalid charset: %s", (XSYMBOL (character)->name)->data);
+ error ("Invalid charset: %s", SDATA (SYMBOL_NAME (character)));
from = MAKE_CHAR (XINT (AREF (elt, 0)), 0, 0);
to = from;
}
error ("Can't change font for a single byte character");
}
- if (STRINGP (fontname))
- {
- fontname = Fdowncase (fontname);
- elt = Fcons (make_number (from), font_family_registry (fontname, 0));
- }
- else
- {
- 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);
- }
- elt = Fcons (make_number (from), Fcons (family, registry));
- }
-
/* 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 (!query_font_func)
error ("Font query function is not supported");
- fontp = (*query_font_func) (f, XSTRING (name)->data);
+ fontp = (*query_font_func) (f, SDATA (name));
if (!fontp)
return Qnil;
}
-/* Return the font name for the character at POSITION in the current
+/* 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. It returns nil in the following cases:
+ 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) The current buffer is not displayed in any window.
+ (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, 1, 0,
+DEFUN ("internal-char-font", Finternal_char_font, Sinternal_char_font, 1, 2, 0,
doc: /* For internal use only. */)
- (position)
- Lisp_Object position;
+ (position, ch)
+ Lisp_Object position, ch;
{
int pos, pos_byte, dummy;
int face_id;
- int c;
- Lisp_Object window;
- struct window *w;
+ int c, code;
struct frame *f;
struct face *face;
- 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);
- c = FETCH_CHAR (pos_byte);
+ 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;
- 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);
face_id = FACE_FOR_CHAR (f, FACE_FROM_ID (f, face_id), c);
face = FACE_FROM_ID (f, face_id);
- return (face->font && face->font_name
- ? build_string (face->font_name)
- : Qnil);
+ 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));
}
+/* 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.. */
+ appending a new element or modifying the last element. */
static void
accumulate_font_info (arg, character, elt)
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,
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
Fcons (XCDR (FONTSET_ASCII (fontset)), Qnil)),
Qnil);
val = Fcons (val, val);
- map_char_table (accumulate_font_info, Qnil, fontset, val, 0, indices);
+ 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
if (CONSP (elt))
{
elt = XCAR (elt);
- fontp = (*query_font_func) (f, XSTRING (elt)->data);
+ 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);
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 t, find a font name pattern in the default fontset. */)
+If NAME is nil, find a font name pattern in the default fontset. */)
(name, ch)
Lisp_Object name, ch;
{
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);
+ }
+ Voverriding_fontspec_alist = fontlist;
+ clear_face_cache (0);
+ ++windows_or_buffers_changed;
+ return Qnil;
+}
+
void
syms_of_fontset ()
{
#if defined (MAC_OS)
FONTSET_ASCII (Vdefault_fontset)
= Fcons (make_number (0),
- build_string ("-ETL-fixed-medium-r-*--*-160-*-*-*-*-iso8859-1"));
+ build_string ("-apple-monaco-medium-r-*--*-120-*-*-*-*-mac-roman"));
#elif defined (WINDOWSNT)
FONTSET_ASCII (Vdefault_fontset)
= Fcons (make_number (0),
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),
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.
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) */