Commit c2f5bfd6 authored by Kenichi Handa's avatar Kenichi Handa

New file.

parent 4ed925c6
/* font.c -- "Font" primitives.
Copyright (C) 2006 Free Software Foundation, Inc.
Copyright (C) 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 2, 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. */
#include <config.h>
#include <stdio.h>
#include <stdlib.h>
#include <ctype.h>
#include "lisp.h"
#include "buffer.h"
#include "frame.h"
#include "dispextern.h"
#include "charset.h"
#include "character.h"
#include "composite.h"
#include "fontset.h"
#include "font.h"
#define FONT_DEBUG
#ifdef FONT_DEBUG
#undef xassert
#define xassert(X) do {if (!(X)) abort ();} while (0)
#else
#define xassert(X) (void) 0
#endif
int enable_font_backend;
Lisp_Object Qfontp;
/* Like CHECK_FONT_SPEC but also validate properties of the font-spec,
and set X to the validated result. */
#define CHECK_VALIDATE_FONT_SPEC(x) \
do { \
if (! FONT_SPEC_P (x)) x = wrong_type_argument (Qfont, x); \
x = font_prop_validate (x); \
} while (0)
/* Number of pt per inch (from the TeXbook). */
#define PT_PER_INCH 72.27
/* Return a pixel size corresponding to POINT size (1/10 pt unit) on
resolution RESY. */
#define POINT_TO_PIXEL(POINT, RESY) ((POINT) * (RESY) / PT_PER_INCH / 10 + 0.5)
#define PIXEL_TO_POINT(PIXEL, RESY) ((PIXEL) * PT_PER_INCH * 10 / (RESY) + 0.5)
/* Special string of zero length. It is used to specify a NULL name
in a font properties (e.g. adstyle). We don't use the symbol of
NULL name because it's confusing (Lisp printer prints nothing for
it). */
Lisp_Object null_string;
/* Special vector of zero length. This is repeatedly used by (struct
font_driver *)->list when a specified font is not found. */
Lisp_Object null_vector;
/* Vector of 3 elements. Each element is an alist for one of font
style properties (weight, slant, width). The alist contains a
mapping between symbolic property values (e.g. `medium' for weight)
and numeric property values (e.g. 100). So, it looks like this:
[((thin . 0) ... (heavy . 210))
((ro . 0) ... (ot . 210))
((ultracondensed . 50) ... (wide . 200))] */
static Lisp_Object font_style_table;
/* Alist of font family vs the corresponding aliases.
Each element has this form:
(FAMILY ALIAS1 ALIAS2 ...) */
static Lisp_Object font_family_alist;
/* Symbols representing keys of normal font properties. */
extern Lisp_Object QCtype, QCfamily, QCweight, QCslant, QCwidth, QCsize, QCname;
Lisp_Object QCfoundry, QCadstyle, QCregistry, QCextra;
/* Symbols representing keys of font extra info. */
Lisp_Object QCotf, QClanguage, QCscript;
/* List of all font drivers. All font-backends (XXXfont.c) call
add_font_driver in syms_of_XXXfont to register the font-driver
here. */
static struct font_driver_list *font_driver_list;
static Lisp_Object prop_name_to_numeric P_ ((enum font_property_index,
Lisp_Object));
static Lisp_Object prop_numeric_to_name P_ ((enum font_property_index, int));
static Lisp_Object font_open_entity P_ ((FRAME_PTR, Lisp_Object, int));
/* Number of registered font drivers. */
static int num_font_drivers;
/* Return a numeric value corresponding to PROP's NAME (symbol). If
NAME is not registered in font_style_table, return Qnil. PROP must
be one of FONT_{WEIGHT|SLANT|SWIDTH}_INDEX. */
static Lisp_Object
prop_name_to_numeric (prop, name)
enum font_property_index prop;
Lisp_Object name;
{
int table_index = prop - FONT_WEIGHT_INDEX;
Lisp_Object val;
val = assq_no_quit (name, AREF (font_style_table, table_index));
return (NILP (val) ? Qnil : XCDR (val));
}
/* Return a name (symbol) corresponding to PROP's NUMERIC value. If
no name is registered for NUMERIC in font_style_table, return a
symbol of integer name (e.g. `123'). PROP must be one of
FONT_{WEIGHT|SLANT|SWIDTH}_INDEX. */
static Lisp_Object
prop_numeric_to_name (prop, numeric)
enum font_property_index prop;
int numeric;
{
int table_index = prop - FONT_WEIGHT_INDEX;
Lisp_Object table = AREF (font_style_table, table_index);
char buf[10];
while (! NILP (table))
{
if (XINT (XCDR (XCAR (table))) >= numeric)
{
if (XINT (XCDR (XCAR (table))) == numeric)
return XCAR (XCAR (table));
else
break;
}
table = XCDR (table);
}
sprintf (buf, "%d", numeric);
return intern (buf);
}
/* Return a symbol whose name is STR (length LEN). If STR contains
uppercase letters, downcase them in advance. */
Lisp_Object
intern_downcase (str, len)
char *str;
int len;
{
char *buf;
int i;
for (i = 0; i < len; i++)
if (isupper (str[i]))
break;
if (i == len)
return Fintern (make_unibyte_string (str, len), Qnil);
buf = alloca (len);
if (! buf)
return Fintern (null_string, Qnil);
bcopy (str, buf, len);
for (; i < len; i++)
if (isascii (buf[i]))
buf[i] = tolower (buf[i]);
return Fintern (make_unibyte_string (buf, len), Qnil);
}
extern Lisp_Object Vface_alternative_font_family_alist;
static void
build_font_family_alist ()
{
Lisp_Object alist = Vface_alternative_font_family_alist;
for (; CONSP (alist); alist = XCDR (alist))
{
Lisp_Object tail, elt;
for (tail = XCAR (alist), elt = Qnil ; CONSP (tail); tail = XCDR (tail))
elt = nconc2 (elt, Fcons (Fintern (XCAR (tail), Qnil), Qnil));
font_family_alist = Fcons (elt, font_family_alist);
}
}
/* Font property validater. */
static Lisp_Object
font_prop_validate_type (prop, val)
enum font_property_index prop;
Lisp_Object val;
{
return (SYMBOLP (val) ? val : Qerror);
}
static Lisp_Object
font_prop_validate_symbol (prop, val)
enum font_property_index prop;
Lisp_Object val;
{
if (STRINGP (val))
val = (SCHARS (val) == 0 ? null_string
: intern_downcase ((char *) SDATA (val), SBYTES (val)));
else if (SYMBOLP (val))
{
if (SCHARS (SYMBOL_NAME (val)) == 0)
val = null_string;
}
else
val = Qerror;
return val;
}
static Lisp_Object
font_prop_validate_style (prop, val)
enum font_property_index prop;
Lisp_Object val;
{
if (! INTEGERP (val))
{
if (STRINGP (val))
val = intern_downcase ((char *) SDATA (val), SBYTES (val));
if (! SYMBOLP (val))
val = Qerror;
else
{
val = prop_name_to_numeric (prop, val);
if (NILP (val))
val = Qerror;
}
}
return val;
}
static Lisp_Object
font_prop_validate_size (prop, val)
enum font_property_index prop;
Lisp_Object val;
{
return (NATNUMP (val) || (FLOATP (val) && XFLOAT_DATA (val) >= 0)
? val : Qerror);
}
static Lisp_Object
font_prop_validate_extra (prop, val)
enum font_property_index prop;
Lisp_Object val;
{
Lisp_Object tail;
for (tail = val; CONSP (tail); tail = XCDR (tail))
{
Lisp_Object key = Fcar (XCAR (tail)), this_val = Fcdr (XCAR (tail));
if (NILP (this_val))
return Qnil;
if (EQ (key, QClanguage))
if (! SYMBOLP (this_val))
{
for (; CONSP (this_val); this_val = XCDR (this_val))
if (! SYMBOLP (XCAR (this_val)))
return Qerror;
if (! NILP (this_val))
return Qerror;
}
if (EQ (key, QCotf))
if (! STRINGP (this_val))
return Qerror;
}
return (NILP (tail) ? val : Qerror);
}
struct
{
Lisp_Object *key;
Lisp_Object (*validater) P_ ((enum font_property_index prop,
Lisp_Object val));
} font_property_table[FONT_SPEC_MAX] =
{ { &QCtype, font_prop_validate_type },
{ &QCfoundry, font_prop_validate_symbol },
{ &QCfamily, font_prop_validate_symbol },
{ &QCadstyle, font_prop_validate_symbol },
{ &QCregistry, font_prop_validate_symbol },
{ &QCweight, font_prop_validate_style },
{ &QCslant, font_prop_validate_style },
{ &QCwidth, font_prop_validate_style },
{ &QCsize, font_prop_validate_size },
{ &QCextra, font_prop_validate_extra }
};
static enum font_property_index
check_font_prop_name (key)
Lisp_Object key;
{
enum font_property_index i;
for (i = FONT_TYPE_INDEX; i < FONT_SPEC_MAX; i++)
if (EQ (key, *font_property_table[i].key))
break;
return i;
}
static Lisp_Object
font_prop_validate (spec)
Lisp_Object spec;
{
enum font_property_index i;
Lisp_Object val;
for (i = FONT_TYPE_INDEX; i <= FONT_EXTRA_INDEX; i++)
{
if (! NILP (AREF (spec, i)))
{
val = (font_property_table[i].validater) (i, AREF (spec, i));
if (EQ (val, Qerror))
Fsignal (Qerror, list3 (build_string ("invalid font property"),
*font_property_table[i].key,
AREF (spec, i)));
ASET (spec, i, val);
}
}
return spec;
}
/* Font name parser and unparser */
/* An enumerator for each field of an XLFD font name. */
enum xlfd_field_index
{
XLFD_FOUNDRY_INDEX,
XLFD_FAMILY_INDEX,
XLFD_WEIGHT_INDEX,
XLFD_SLANT_INDEX,
XLFD_SWIDTH_INDEX,
XLFD_ADSTYLE_INDEX,
XLFD_PIXEL_SIZE_INDEX,
XLFD_POINT_SIZE_INDEX,
XLFD_RESX_INDEX,
XLFD_RESY_INDEX,
XLFD_SPACING_INDEX,
XLFD_AVGWIDTH_INDEX,
XLFD_REGISTRY_INDEX,
XLFD_ENCODING_INDEX,
XLFD_LAST_INDEX
};
/* Return a symbol interned by string at STR and bytes LEN.
If LEN == 0, return a null string.
If the string is "*", return Qnil.
It is assured that LEN < 256. */
static Lisp_Object
intern_font_field (f, xlfd)
char *f[XLFD_LAST_INDEX + 1];
int xlfd;
{
char *str = f[xlfd] + 1;
int len;
if (xlfd != XLFD_RESY_INDEX)
len = f[xlfd + 1] - f[xlfd] - 1;
else
len = f[XLFD_REGISTRY_INDEX] - f[xlfd] - 1;
if (len == 0)
return null_string;
if (*str == '*' && len == 1)
return Qnil;
return intern_downcase (str, len);
}
/* Parse P pointing the pixel/point size field of the form
`[A B C D]' which specifies a transformation matrix:
A B 0
C D 0
0 0 1
by which all glyphs of the font are transformed. The spec says
that scalar value N for the pixel/point size is equivalent to:
A = N * resx/resy, B = C = 0, D = N.
Return the scalar value N if the form is valid. Otherwise return
-1. */
static int
parse_matrix (p)
char *p;
{
double matrix[4];
char *end;
int i;
for (i = 0, p++; i < 4 && *p && *p != ']'; i++)
{
if (*p == '~')
matrix[i] = - strtod (p + 1, &end);
else
matrix[i] = strtod (p, &end);
p = end;
}
return (i == 4 ? (int) matrix[3] : -1);
}
/* Parse NAME (null terminated) as XLFD format, and store information
in FONT (font-spec or font-entity). If NAME is successfully
parsed, return 2 (non-scalable font), 1 (scalable vector font), or
0 (auto-scaled font). Otherwise return -1.
If FONT is a font-entity, store RESY-SPACING-AVWIDTH information as
a symbol in FONT_EXTRA_INDEX.
If MERGE is nonzero, set a property of FONT only when it's nil. */
int
font_parse_xlfd (name, font, merge)
char *name;
Lisp_Object font;
int merge;
{
int len = strlen (name);
int i, j;
int pixel_size, resy, avwidth;
double point_size;
char *f[XLFD_LAST_INDEX + 1];
Lisp_Object val;
int first_wildcard_field = -1, last_wildcard_field = XLFD_LAST_INDEX;
if (len > 255)
/* Maximum XLFD name length is 255. */
return -1;
for (i = 0; *name; name++)
if (*name == '-'
&& i < XLFD_LAST_INDEX)
{
f[i] = name;
if (name[1] == '*' && (! name[2] || name[2] == '-'))
{
if (first_wildcard_field < 0)
first_wildcard_field = i;
last_wildcard_field = i;
}
i++;
}
f[XLFD_LAST_INDEX] = name;
if (i < XLFD_LAST_INDEX)
{
/* Not a fully specified XLFD. */
if (first_wildcard_field < 0 )
/* No wild card. */
return -1;
i--;
if (last_wildcard_field < i)
{
/* Shift fields after the last wildcard field. */
for (j = XLFD_LAST_INDEX - 1; j > last_wildcard_field; j--, i--)
f[j] = f[i];
/* Make all fields between the first and last wildcard fieled
also wildcard fields. */
for (j--; j > first_wildcard_field; j--)
f[j] = "-*";
}
}
f[XLFD_ENCODING_INDEX] = f[XLFD_LAST_INDEX];
if (! merge || NILP (AREF (font, FONT_FOUNDRY_INDEX)))
ASET (font, FONT_FOUNDRY_INDEX, intern_font_field (f, XLFD_FOUNDRY_INDEX));
if (! merge || NILP (AREF (font, FONT_FAMILY_INDEX)))
ASET (font, FONT_FAMILY_INDEX, intern_font_field (f, XLFD_FAMILY_INDEX));
if (! merge || NILP (AREF (font, FONT_ADSTYLE_INDEX)))
ASET (font, FONT_ADSTYLE_INDEX, intern_font_field (f, XLFD_ADSTYLE_INDEX));
if (! merge || NILP (AREF (font, FONT_REGISTRY_INDEX)))
ASET (font, FONT_REGISTRY_INDEX, intern_font_field (f, XLFD_REGISTRY_INDEX));
for (i = FONT_WEIGHT_INDEX, j = XLFD_WEIGHT_INDEX;
j <= XLFD_SWIDTH_INDEX; i++, j++)
if (! merge || NILP (AREF (font, i)))
{
if (isdigit(f[j][1]))
val = make_number (atoi (f[j] + 1));
else
{
Lisp_Object sym = intern_font_field (f, j);
val = prop_name_to_numeric (i, sym);
if (NILP (val))
val = sym;
}
ASET (font, i, val);
}
if (f[XLFD_PIXEL_SIZE_INDEX][1] == '*')
pixel_size = -1; /* indicates "unspecified" */
else if (f[XLFD_PIXEL_SIZE_INDEX][1] == '[')
pixel_size = parse_matrix (f[XLFD_PIXEL_SIZE_INDEX] + 1);
else if (isdigit (f[XLFD_PIXEL_SIZE_INDEX][1]))
pixel_size = strtod (f[XLFD_PIXEL_SIZE_INDEX] + 1, NULL);
else
pixel_size = -1;
if (pixel_size < 0 && FONT_ENTITY_P (font))
return -1;
if (f[XLFD_POINT_SIZE_INDEX][1] == '*')
point_size = -1; /* indicates "unspecified" */
else if (f[XLFD_POINT_SIZE_INDEX][1] == '[')
point_size = parse_matrix (f[XLFD_POINT_SIZE_INDEX] + 1);
else if (isdigit (f[XLFD_POINT_SIZE_INDEX][1]))
point_size = strtod (f[XLFD_POINT_SIZE_INDEX] + 1, NULL);
else
point_size = -1;
if (f[XLFD_RESY_INDEX][1] == '*')
resy = -1; /* indicates "unspecified" */
else
resy = strtod (f[XLFD_RESY_INDEX] + 1, NULL);
if (f[XLFD_AVGWIDTH_INDEX][1] == '*')
avwidth = -1; /* indicates "unspecified" */
else if (f[XLFD_AVGWIDTH_INDEX][1] == '~')
avwidth = - strtod (f[XLFD_AVGWIDTH_INDEX] + 2, NULL);
else
avwidth = strtod (f[XLFD_AVGWIDTH_INDEX] + 1, NULL);
if (! merge || NILP (AREF (font, FONT_SIZE_INDEX)))
{
if (pixel_size >= 0)
ASET (font, FONT_SIZE_INDEX, make_number (pixel_size));
else
{
if (point_size >= 0)
{
if (resy > 0)
{
pixel_size = POINT_TO_PIXEL (point_size, resy);
ASET (font, FONT_SIZE_INDEX, make_number (pixel_size));
}
else
{
ASET (font, FONT_SIZE_INDEX, make_float (point_size / 10));
}
}
else
ASET (font, FONT_SIZE_INDEX, Qnil);
}
}
if (FONT_ENTITY_P (font)
&& EQ (AREF (font, FONT_TYPE_INDEX), Qx))
ASET (font, FONT_EXTRA_INDEX, intern_font_field (f, XLFD_RESY_INDEX));
return (avwidth > 0 ? 2 : resy == 0);
}
/* Store XLFD name of FONT (font-spec or font-entity) in NAME (NBYTES
length), and return the name length. If FONT_SIZE_INDEX of FONT is
0, use PIXEL_SIZE instead. */
int
font_unparse_xlfd (font, pixel_size, name, nbytes)
Lisp_Object font;
char *name;
int nbytes;
{
char *f[XLFD_REGISTRY_INDEX + 1], *pixel_point;
char work[256];
Lisp_Object val;
int i, j, len = 0;
xassert (FONTP (font));
for (i = FONT_FOUNDRY_INDEX, j = XLFD_FOUNDRY_INDEX; i <= FONT_REGISTRY_INDEX;
i++, j++)
{
if (i == FONT_ADSTYLE_INDEX)
j = XLFD_ADSTYLE_INDEX;
else if (i == FONT_REGISTRY_INDEX)
j = XLFD_REGISTRY_INDEX;
val = AREF (font, i);
if (NILP (val))
f[j] = "*", len += 2;
else
{
if (SYMBOLP (val))
val = SYMBOL_NAME (val);
f[j] = (char *) SDATA (val), len += SBYTES (val) + 1;
}
}
for (i = FONT_WEIGHT_INDEX, j = XLFD_WEIGHT_INDEX; i <= FONT_WIDTH_INDEX;
i++, j++)
{
val = AREF (font, i);
if (NILP (val))
f[j] = "*", len += 2;
else
{
if (INTEGERP (val))
val = prop_numeric_to_name (i, XINT (val));
if (SYMBOLP (val))
val = SYMBOL_NAME (val);
xassert (STRINGP (val));
f[j] = (char *) SDATA (val), len += SBYTES (val) + 1;
}
}
val = AREF (font, FONT_SIZE_INDEX);
xassert (NUMBERP (val) || NILP (val));
if (INTEGERP (val))
{
i = XINT (val);
if (i > 0)
len += sprintf (work, "%d", i) + 1;
else /* i == 0 */
len += sprintf (work, "%d-*", pixel_size) + 1;
pixel_point = work;
}
else if (FLOATP (val))
{
i = XFLOAT_DATA (val) * 10;
len += sprintf (work, "*-%d", i) + 1;
pixel_point = work;
}
else
pixel_point = "*-*", len += 4;
if (FONT_ENTITY_P (font)
&& EQ (AREF (font, FONT_TYPE_INDEX), Qx))
{
/* Setup names for RESY-SPACING-AVWIDTH. */
val = AREF (font, FONT_EXTRA_INDEX);
if (SYMBOLP (val) && ! NILP (val))
{
val = SYMBOL_NAME (val);
f[XLFD_RESY_INDEX] = (char *) SDATA (val), len += SBYTES (val) + 1;
}
else