Mercurial > emacs
diff src/font.c @ 90400:80fff33f74f5
New file.
author | Kenichi Handa <handa@m17n.org> |
---|---|
date | Tue, 06 Jun 2006 03:47:13 +0000 |
parents | |
children | ddb25860d044 |
line wrap: on
line diff
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/src/font.c Tue Jun 06 03:47:13 2006 +0000 @@ -0,0 +1,2571 @@ +/* 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 + f[XLFD_RESY_INDEX] = "*-*-*", len += 6; + } + else + f[XLFD_RESY_INDEX] = "*-*-*", len += 6; + + len += 3; /* for "-*" of resx, and terminating '\0'. */ + if (len >= nbytes) + return -1; + return sprintf (name, "-%s-%s-%s-%s-%s-%s-%s-*-%s-%s", + f[XLFD_FOUNDRY_INDEX], f[XLFD_FAMILY_INDEX], + f[XLFD_WEIGHT_INDEX], f[XLFD_SLANT_INDEX], + f[XLFD_SWIDTH_INDEX], + f[XLFD_ADSTYLE_INDEX], pixel_point, + f[XLFD_RESY_INDEX], f[XLFD_REGISTRY_INDEX]); +} + +void +font_merge_old_spec (name, family, registry, spec) + Lisp_Object name, family, registry, spec; +{ + if (STRINGP (name)) + { + if (font_parse_xlfd ((char *) SDATA (name), spec, 1) < 0) + { + Lisp_Object extra = Fcons (Fcons (QCname, name), Qnil); + + ASET (spec, FONT_EXTRA_INDEX, extra); + } + } + else + { + if (! NILP (family)) + { + int len; + char *p0, *p1; + + xassert (STRINGP (family)); + len = SBYTES (family); + p0 = (char *) SDATA (family); + p1 = index (p0, '-'); + if (p1) + { + if (NILP (AREF (spec, FONT_FOUNDRY_INDEX))) + ASET (spec, FONT_FOUNDRY_INDEX, + intern_downcase (p0, p1 - p0)); + if (NILP (AREF (spec, FONT_FAMILY_INDEX))) + ASET (spec, FONT_FAMILY_INDEX, + intern_downcase (p1 + 1, len - (p1 + 1 - p0))); + } + else if (NILP (AREF (spec, FONT_FAMILY_INDEX))) + ASET (spec, FONT_FAMILY_INDEX, intern_downcase (p0, len)); + } + if (! NILP (registry) + && NILP (AREF (spec, FONT_REGISTRY_INDEX))) + ASET (spec, FONT_REGISTRY_INDEX, + intern_downcase ((char *) SDATA (registry), SBYTES (registry))); + } +} + + +/* OTF handler */ + +#ifdef HAVE_LIBOTF +#include <otf.h> + +struct otf_list +{ + Lisp_Object entity; + OTF *otf; + struct otf_list *next; +}; + +static struct otf_list *otf_list; + +static Lisp_Object +otf_tag_symbol (tag) + OTF_Tag tag; +{ + char name[5]; + + OTF_tag_name (tag, name); + return Fintern (make_unibyte_string (name, 4), Qnil); +} + +static OTF * +otf_open (entity, file) + Lisp_Object entity; + char *file; +{ + struct otf_list *list = otf_list; + + while (list && ! EQ (list->entity, entity)) + list = list->next; + if (! list) + { + list = malloc (sizeof (struct otf_list)); + list->entity = entity; + list->otf = file ? OTF_open (file) : NULL; + list->next = otf_list; + otf_list = list; + } + return list->otf; +} + + +/* Return a list describing which scripts/languages FONT supports by + which GSUB/GPOS features of OpenType tables. See the comment of + (sturct font_driver).otf_capability. */ + +Lisp_Object +font_otf_capability (font) + struct font *font; +{ + OTF *otf; + Lisp_Object capability = Fcons (Qnil, Qnil); + int i; + + otf = otf_open (font->entity, font->file_name); + if (! otf) + return Qnil; + for (i = 0; i < 2; i++) + { + OTF_GSUB_GPOS *gsub_gpos; + Lisp_Object script_list = Qnil; + int j; + + if (OTF_get_features (otf, i == 0) < 0) + continue; + gsub_gpos = i == 0 ? otf->gsub : otf->gpos; + for (j = gsub_gpos->ScriptList.ScriptCount - 1; j >= 0; j--) + { + OTF_Script *script = gsub_gpos->ScriptList.Script + j; + Lisp_Object langsys_list = Qnil; + Lisp_Object script_tag = otf_tag_symbol (script->ScriptTag); + int k; + + for (k = script->LangSysCount; k >= 0; k--) + { + OTF_LangSys *langsys; + Lisp_Object feature_list = Qnil; + Lisp_Object langsys_tag; + int l; + + if (j == script->LangSysCount) + { + langsys = &script->DefaultLangSys; + langsys_tag = Qnil; + } + else + { + langsys = script->LangSys + k; + langsys_tag + = otf_tag_symbol (script->LangSysRecord[k].LangSysTag); + } + for (l = langsys->FeatureCount -1; l >= 0; l--) + { + OTF_Feature *feature + = gsub_gpos->FeatureList.Feature + langsys->FeatureIndex[l]; + Lisp_Object feature_tag + = otf_tag_symbol (feature->FeatureTag); + + feature_list = Fcons (feature_tag, feature_list); + } + langsys_list = Fcons (Fcons (langsys_tag, feature_list), + langsys_list); + } + script_list = Fcons (Fcons (script_tag, langsys_list), + script_list); + } + + if (i == 0) + XSETCAR (capability, script_list); + else + XSETCDR (capability, script_list); + } + + return capability; +} + +static int +parse_gsub_gpos_spec (spec, script, langsys, features) + Lisp_Object spec; + char **script, **langsys, **features; +{ + Lisp_Object val; + int len; + char *p; + int asterisk; + + val = XCAR (spec); + *script = (char *) SDATA (SYMBOL_NAME (val)); + spec = XCDR (spec); + val = XCAR (spec); + *langsys = NILP (val) ? NULL : (char *) SDATA (SYMBOL_NAME (val)); + spec = XCDR (spec); + len = XINT (Flength (spec)); + *features = p = malloc (6 * len); + if (! p) + return -1; + + for (asterisk = 0; CONSP (spec); spec = XCDR (spec)) + { + val = XCAR (spec); + if (SREF (SYMBOL_NAME (val), 0) == '*') + { + asterisk = 1; + p += sprintf (p, ",*"); + } + else if (! asterisk) + p += sprintf (p, ",%s", SDATA (SYMBOL_NAME (val))); + else + p += sprintf (p, ",~%s", SDATA (SYMBOL_NAME (val))); + } + return 0; +} + +#define DEVICE_DELTA(table, size) \ + (((size) >= (table).StartSize && (size) <= (table).EndSize) \ + ? (table).DeltaValue[(size) >= (table).StartSize] \ + : 0) + +void +adjust_anchor (struct font *font, OTF_Anchor *anchor, + unsigned code, int size, int *x, int *y) +{ + if (anchor->AnchorFormat == 2) + { + int x0, y0; + + if (font->driver->anchor_point (font, code, anchor->f.f1.AnchorPoint, + &x0, &y0) >= 0) + *x = x0, *y = y0; + } + else if (anchor->AnchorFormat == 3) + { + if (anchor->f.f2.XDeviceTable.offset) + *x += DEVICE_DELTA (anchor->f.f2.XDeviceTable, size); + if (anchor->f.f2.YDeviceTable.offset) + *y += DEVICE_DELTA (anchor->f.f2.YDeviceTable, size); + } +} + + +/* Drive FONT's OTF GSUB features according to GSUB_SPEC. See the + comment of (sturct font_driver).otf_gsub. */ + +int +font_otf_gsub (font, gsub_spec, gstring_in, from, to, gstring_out, idx) + struct font *font; + Lisp_Object gsub_spec; + Lisp_Object gstring_in; + int from, to; + Lisp_Object gstring_out; + int idx; +{ + int len; + int i; + OTF *otf; + OTF_GlyphString otf_gstring; + OTF_Glyph *g; + char *script, *langsys, *features; + + otf = otf_open (font->entity, font->file_name); + if (! otf) + return 0; + if (OTF_get_table (otf, "head") < 0) + return 0; + if (OTF_check_table (otf, "GSUB") < 0) + return 0; + if (parse_gsub_gpos_spec (gsub_spec, &script, &langsys, &features) < 0) + return 0; + len = to - from; + otf_gstring.size = otf_gstring.used = len; + otf_gstring.glyphs = (OTF_Glyph *) malloc (sizeof (OTF_Glyph) * len); + memset (otf_gstring.glyphs, 0, sizeof (OTF_Glyph) * len); + for (i = 0; i < len; i++) + { + Lisp_Object g = LGSTRING_GLYPH (gstring_in, from + i); + + otf_gstring.glyphs[i].c = XINT (LGLYPH_CHAR (g)); + otf_gstring.glyphs[i].glyph_id = XINT (LGLYPH_CODE (g)); + } + + OTF_drive_gdef (otf, &otf_gstring); + if (OTF_drive_gsub (otf, &otf_gstring, script, langsys, features) < 0) + { + free (otf_gstring.glyphs); + return 0; + } + if (ASIZE (gstring_out) < idx + otf_gstring.used) + { + free (otf_gstring.glyphs); + return -1; + } + + for (i = 0, g = otf_gstring.glyphs; i < otf_gstring.used;) + { + int i0 = g->f.index.from, i1 = g->f.index.to; + Lisp_Object glyph = LGSTRING_GLYPH (gstring_in, from + i0); + Lisp_Object min_idx = AREF (glyph, 0); + Lisp_Object max_idx = AREF (glyph, 1); + + if (i0 < i1) + { + int min_idx_i = XINT (min_idx), max_idx_i = XINT (max_idx); + + for (i0++; i0 <= i1; i0++) + { + glyph = LGSTRING_GLYPH (gstring_in, from + i0); + if (min_idx_i > XINT (AREF (glyph, 0))) + min_idx_i = XINT (AREF (glyph, 0)); + if (max_idx_i < XINT (AREF (glyph, 1))) + max_idx_i = XINT (AREF (glyph, 1)); + } + min_idx = make_number (min_idx_i); + max_idx = make_number (max_idx_i); + i0 = g->f.index.from; + } + for (; i < otf_gstring.used && g->f.index.from == i0; i++, g++) + { + glyph = LGSTRING_GLYPH (gstring_out, idx + i); + ASET (glyph, 0, min_idx); + ASET (glyph, 1, max_idx); + LGLYPH_SET_CHAR (glyph, make_number (g->c)); + LGLYPH_SET_CODE (glyph, make_number (g->glyph_id)); + } + } + + free (otf_gstring.glyphs); + return i; +} + +/* Drive FONT's OTF GPOS features according to GPOS_SPEC. See the + comment of (sturct font_driver).otf_gpos. */ + +int +font_otf_gpos (font, gpos_spec, gstring, from, to) + struct font *font; + Lisp_Object gpos_spec; + Lisp_Object gstring; + int from, to; +{ + int len; + int i; + OTF *otf; + OTF_GlyphString otf_gstring; + OTF_Glyph *g; + char *script, *langsys, *features; + Lisp_Object glyph; + int u, size; + Lisp_Object base, mark; + + otf = otf_open (font->entity, font->file_name); + if (! otf) + return 0; + if (OTF_get_table (otf, "head") < 0) + return 0; + if (OTF_check_table (otf, "GPOS") < 0) + return 0; + if (parse_gsub_gpos_spec (gpos_spec, &script, &langsys, &features) < 0) + return 0; + len = to - from; + otf_gstring.size = otf_gstring.used = len; + otf_gstring.glyphs = (OTF_Glyph *) malloc (sizeof (OTF_Glyph) * len); + memset (otf_gstring.glyphs, 0, sizeof (OTF_Glyph) * len); + for (i = 0; i < len; i++) + { + glyph = LGSTRING_GLYPH (gstring, from + i); + otf_gstring.glyphs[i].glyph_id = XINT (LGLYPH_CODE (glyph)); + } + + OTF_drive_gdef (otf, &otf_gstring); + + if (OTF_drive_gpos (otf, &otf_gstring, script, langsys, features) < 0) + { + free (otf_gstring.glyphs); + return 0; + } + + u = otf->head->unitsPerEm; + size = font->pixel_size; + base = mark = Qnil; + for (i = 0, g = otf_gstring.glyphs; i < otf_gstring.used; i++, g++) + { + Lisp_Object prev; + int xoff = 0, yoff = 0, width_adjust = 0; + + if (! g->glyph_id) + continue; + + glyph = LGSTRING_GLYPH (gstring, from + i); + switch (g->positioning_type) + { + case 0: + break; + case 1: case 2: + { + int format = g->f.f1.format; + + if (format & OTF_XPlacement) + xoff = g->f.f1.value->XPlacement * size / u; + if (format & OTF_XPlaDevice) + xoff += DEVICE_DELTA (g->f.f1.value->XPlaDevice, size); + if (format & OTF_YPlacement) + yoff = - (g->f.f1.value->YPlacement * size / u); + if (format & OTF_YPlaDevice) + yoff -= DEVICE_DELTA (g->f.f1.value->YPlaDevice, size); + if (format & OTF_XAdvance) + width_adjust += g->f.f1.value->XAdvance * size / u; + if (format & OTF_XAdvDevice) + width_adjust += DEVICE_DELTA (g->f.f1.value->XAdvDevice, size); + } + break; + case 3: + /* Not yet supported. */ + break; + case 4: case 5: + if (NILP (base)) + break; + prev = base; + goto label_adjust_anchor; + default: /* i.e. case 6 */ + if (NILP (mark)) + break; + prev = mark; + + label_adjust_anchor: + { + int base_x, base_y, mark_x, mark_y, width; + unsigned code; + + base_x = g->f.f4.base_anchor->XCoordinate * size / u; + base_y = g->f.f4.base_anchor->YCoordinate * size / u; + mark_x = g->f.f4.mark_anchor->XCoordinate * size / u; + mark_y = g->f.f4.mark_anchor->YCoordinate * size / u; + + code = XINT (LGLYPH_CODE (prev)); + if (g->f.f4.base_anchor->AnchorFormat != 1) + adjust_anchor (font, g->f.f4.base_anchor, + code, size, &base_x, &base_y); + if (g->f.f4.mark_anchor->AnchorFormat != 1) + adjust_anchor (font, g->f.f4.mark_anchor, + code, size, &mark_x, &mark_y); + + if (NILP (LGLYPH_WIDTH (prev))) + { + width = font->driver->text_extents (font, &code, 1, NULL); + LGLYPH_SET_WIDTH (prev, make_number (width)); + } + xoff = XINT (LGLYPH_XOFF (prev)) + (base_x - width) - mark_x; + yoff = XINT (LGLYPH_YOFF (prev)) + mark_y - base_y; + } + } + if (g->GlyphClass == OTF_GlyphClass0) + base = mark = glyph; + else if (g->GlyphClass == OTF_GlyphClassMark) + mark = glyph; + else + base = glyph; + + LGLYPH_SET_XOFF (glyph, make_number (xoff)); + LGLYPH_SET_YOFF (glyph, make_number (yoff)); + LGLYPH_SET_WADJUST (glyph, make_number (width_adjust)); + } + + free (otf_gstring.glyphs); + return 0; +} + +#endif /* HAVE_LIBOTF */ + + +/* glyph-string handler */ + +/* GSTRING is a vector of this form: + [ [FONT-OBJECT LBEARING RBEARING WITH ASCENT DESCENT] GLYPH ... ] + and GLYPH is a vector of this form: + [ FROM-IDX TO-IDX C CODE X-OFF Y-OFF WIDTH WADJUST ] + where + FROM-IDX and TO-IDX are used internally and should not be touched. + C is a character of the glyph. + CODE is a glyph-code of C in FONT-OBJECT. + X-OFF and Y-OFF are offests to the base position for the glyph. + WIDTH is a normal width of the glyph. + WADJUST is an adjustment to the normal width of the glyph. */ + +struct font * +font_prepare_composition (cmp) + struct composition *cmp; +{ + Lisp_Object gstring + = AREF (XHASH_TABLE (composition_hash_table)->key_and_value, + cmp->hash_index * 2); + struct font *font = XSAVE_VALUE (LGSTRING_FONT (gstring))->pointer; + int len = LGSTRING_LENGTH (gstring); + int i; + + cmp->font = font; + cmp->lbearing = cmp->rbearing = cmp->pixel_width = 0; + cmp->ascent = font->ascent; + cmp->descent = font->descent; + + for (i = 0; i < len; i++) + { + Lisp_Object g = LGSTRING_GLYPH (gstring, i); + unsigned code = XINT (LGLYPH_CODE (g)); + struct font_metrics metrics; + + font->driver->text_extents (font, &code, 1, &metrics); + LGLYPH_SET_WIDTH (g, make_number (metrics.width)); + metrics.lbearing += XINT (LGLYPH_XOFF (g)); + metrics.rbearing += XINT (LGLYPH_XOFF (g)); + metrics.ascent += XINT (LGLYPH_YOFF (g)); + metrics.descent += XINT (LGLYPH_YOFF (g)); + + if (cmp->lbearing > cmp->pixel_width + metrics.lbearing) + cmp->lbearing = cmp->pixel_width + metrics.lbearing; + if (cmp->rbearing < cmp->pixel_width + metrics.rbearing) + cmp->rbearing = cmp->pixel_width + metrics.rbearing; + if (cmp->ascent < metrics.ascent) + cmp->ascent = metrics.ascent; + if (cmp->descent < metrics.descent) + cmp->descent = metrics.descent; + cmp->pixel_width += metrics.width + XINT (LGLYPH_WADJUST (g)); + } + LGSTRING_SET_LBEARING (gstring, make_number (cmp->lbearing)); + LGSTRING_SET_RBEARING (gstring, make_number (cmp->rbearing)); + LGSTRING_SET_WIDTH (gstring, make_number (cmp->pixel_width)); + LGSTRING_SET_ASCENT (gstring, make_number (cmp->ascent)); + LGSTRING_SET_DESCENT (gstring, make_number (cmp->descent)); + + return font; +} + +int +font_gstring_produce (old, from, to, new, idx, code, n) + Lisp_Object old; + int from, to; + Lisp_Object new; + int idx; + unsigned *code; + int n; +{ + Lisp_Object min_idx, max_idx; + int i; + + if (idx + n > ASIZE (new)) + return -1; + if (from == to) + { + if (from == 0) + { + min_idx = make_number (0); + max_idx = make_number (1); + } + else + { + min_idx = AREF (AREF (old, from - 1), 0); + max_idx = AREF (AREF (old, from - 1), 1); + } + } + else if (from + 1 == to) + { + min_idx = AREF (AREF (old, from), 0); + max_idx = AREF (AREF (old, from), 1); + } + else + { + int min_idx_i = XINT (AREF (AREF (old, from), 0)); + int max_idx_i = XINT (AREF (AREF (old, from), 1)); + + for (i = from + 1; i < to; i++) + { + if (min_idx_i > XINT (AREF (AREF (old, i), 0))) + min_idx_i = XINT (AREF (AREF (old, i), 0)); + if (max_idx_i < XINT (AREF (AREF (old, i), 1))) + max_idx_i = XINT (AREF (AREF (old, i), 1)); + } + min_idx = make_number (min_idx_i); + max_idx = make_number (max_idx_i); + } + + for (i = 0; i < n; i++) + { + ASET (AREF (new, idx + i), 0, min_idx); + ASET (AREF (new, idx + i), 1, max_idx); + ASET (AREF (new, idx + i), 2, make_number (code[i])); + } + + return 0; +} + +/* Font sorting */ + +static unsigned font_score P_ ((Lisp_Object, Lisp_Object)); +static int font_compare P_ ((const void *, const void *)); +static Lisp_Object font_sort_entites P_ ((Lisp_Object, Lisp_Object, + Lisp_Object, Lisp_Object)); + +/* We sort fonts by scoring each of them against a specified + font-spec. The score value is 32 bit (`unsigned'), and the smaller + the value is, the closer the font is to the font-spec. + + Each 1-bit in the highest 4 bits of the score is used for atomic + properties FOUNDRY, FAMILY, ADSTYLE, and REGISTRY. + + Each 7-bit in the lowest 28 bits are used for numeric properties + WEIGHT, SLANT, WIDTH, and SIZE. */ + +/* How many bits to shift to store the difference value of each font + property in a score. */ +static int sort_shift_bits[FONT_SIZE_INDEX + 1]; + +/* Score font-entity ENTITY against font-spec SPEC. The return value + indicates how different ENTITY is compared with SPEC. */ + +static unsigned +font_score (entity, spec) + Lisp_Object entity, spec; +{ + unsigned score = 0; + int i; + /* Score atomic fields. Maximum difference is 1. */ + for (i = FONT_FOUNDRY_INDEX; i <= FONT_REGISTRY_INDEX; i++) + { + Lisp_Object val = AREF (spec, i); + + if (! NILP (val) + && ! EQ (val, AREF (entity, i))) + score |= 1 << sort_shift_bits[i]; + } + + /* Score numeric fields. Maximum difference is 127. */ + for (i = FONT_WEIGHT_INDEX; i <= FONT_SIZE_INDEX; i++) + { + Lisp_Object spec_val = AREF (spec, i); + Lisp_Object entity_val = AREF (entity, i); + + if (! NILP (spec_val) && ! EQ (spec_val, entity_val)) + { + if (! INTEGERP (entity_val)) + score |= 127 << sort_shift_bits[i]; + else if (i < FONT_SIZE_INDEX + || XINT (entity_val) != 0) + { + int diff = XINT (entity_val) - XINT (spec_val); + + if (diff < 0) + diff = - diff; + score |= min (diff, 127) << sort_shift_bits[i]; + } + } + } + + return score; +} + + +/* The comparison function for qsort. */ + +static int +font_compare (d1, d2) + const void *d1, *d2; +{ + return (*(unsigned *) d1 < *(unsigned *) d2 + ? -1 : *(unsigned *) d1 > *(unsigned *) d2); +} + + +/* The structure for elements being sorted by qsort. */ +struct font_sort_data +{ + unsigned score; + Lisp_Object entity; +}; + + +/* Sort font-entities in vector VEC by closeness to font-spec PREFER. + If PREFER specifies a point-size, calculate the corresponding + pixel-size from the Y-resolution of FRAME before sorting. If SPEC + is not nil, it is a font-spec to get the font-entities in VEC. */ + +static Lisp_Object +font_sort_entites (vec, prefer, frame, spec) + Lisp_Object vec, prefer, frame, spec; +{ + Lisp_Object size; + int len, i; + struct font_sort_data *data; + int prefer_is_copy = 0; + USE_SAFE_ALLOCA; + + len = ASIZE (vec); + if (len <= 1) + return vec; + + size = AREF (spec, FONT_SIZE_INDEX); + if (FLOATP (size)) + { + double point_size = XFLOAT_DATA (size) * 10; + int pixel_size = POINT_TO_PIXEL (point_size, XFRAME (frame)->resy); + + prefer = Fcopy_sequence (prefer); + ASET (prefer, FONT_SIZE_INDEX, make_number (pixel_size)); + prefer_is_copy = 1; + } + + if (! NILP (spec)) + { + /* As it is assured that all fonts in VEC match with SPEC, we + should ignore properties specified in SPEC. So, set the + corresponding properties in PREFER nil. */ + for (i = FONT_WEIGHT_INDEX; i <= FONT_SIZE_INDEX; i++) + if (! NILP (AREF (spec, i)) && ! NILP (AREF (prefer, i))) + break; + if (i <= FONT_SIZE_INDEX) + { + if (! prefer_is_copy) + prefer = Fcopy_sequence (prefer); + for (; i <= FONT_SIZE_INDEX; i++) + if (! NILP (AREF (spec, i)) && ! NILP (AREF (prefer, i))) + ASET (prefer, i, Qnil); + } + } + + /* Scoring and sorting. */ + SAFE_ALLOCA (data, struct font_sort_data *, (sizeof *data) * len); + for (i = 0; i < len; i++) + { + data[i].entity = AREF (vec, i); + data[i].score = font_score (data[i].entity, prefer); + } + qsort (data, len, sizeof *data, font_compare); + for (i = 0; i < len; i++) + ASET (vec, i, data[i].entity); + SAFE_FREE (); + + return vec; +} + + +/* API of Font Service Layer. */ + +void +font_update_sort_order (order) + int *order; +{ + int i, shift_bits = 21; + + for (i = 0; i < 4; i++, shift_bits -= 7) + { + int xlfd_idx = order[i]; + + if (xlfd_idx == XLFD_WEIGHT_INDEX) + sort_shift_bits[FONT_WEIGHT_INDEX] = shift_bits; + else if (xlfd_idx == XLFD_SLANT_INDEX) + sort_shift_bits[FONT_SLANT_INDEX] = shift_bits; + else if (xlfd_idx == XLFD_SWIDTH_INDEX) + sort_shift_bits[FONT_WIDTH_INDEX] = shift_bits; + else + sort_shift_bits[FONT_SIZE_INDEX] = shift_bits; + } +} + +Lisp_Object +font_symbolic_weight (font) + Lisp_Object font; +{ + Lisp_Object weight = AREF (font, FONT_WEIGHT_INDEX); + + if (INTEGERP (weight)) + weight = prop_numeric_to_name (FONT_WEIGHT_INDEX, XINT (weight)); + return weight; +} + +Lisp_Object +font_symbolic_slant (font) + Lisp_Object font; +{ + Lisp_Object slant = AREF (font, FONT_SLANT_INDEX); + + if (INTEGERP (slant)) + slant = prop_numeric_to_name (FONT_SLANT_INDEX, XINT (slant)); + return slant; +} + +Lisp_Object +font_symbolic_width (font) + Lisp_Object font; +{ + Lisp_Object width = AREF (font, FONT_WIDTH_INDEX); + + if (INTEGERP (width)) + width = prop_numeric_to_name (FONT_WIDTH_INDEX, XINT (width)); + return width; +} + +Lisp_Object +font_find_object (font) + struct font *font; +{ + Lisp_Object tail, elt; + + for (tail = AREF (font->entity, FONT_OBJLIST_INDEX); CONSP (tail); + tail = XCDR (tail)) + { + elt = XCAR (tail); + if (font == XSAVE_VALUE (elt)->pointer + && XSAVE_VALUE (elt)->integer > 0) + return elt; + } + abort (); + return Qnil; +} + +static Lisp_Object scratch_font_spec, scratch_font_prefer; + +/* Return a vector of font-entities matching with SPEC on frame F. */ + +static Lisp_Object +font_list_entities (frame, spec) + Lisp_Object frame, spec; +{ + FRAME_PTR f = XFRAME (frame); + struct font_driver_list *driver_list = f->font_driver_list; + Lisp_Object ftype, family, alternate_familes; + Lisp_Object *vec = alloca (sizeof (Lisp_Object) * num_font_drivers); + int i; + + if (! vec) + return null_vector; + + family = AREF (spec, FONT_FAMILY_INDEX); + if (NILP (family)) + alternate_familes = Qnil; + else + { + if (NILP (font_family_alist) + && !NILP (Vface_alternative_font_family_alist)) + build_font_family_alist (); + alternate_familes = assq_no_quit (family, font_family_alist); + if (! NILP (alternate_familes)) + alternate_familes = XCDR (alternate_familes); + } + xassert (ASIZE (spec) == FONT_SPEC_MAX); + ftype = AREF (spec, FONT_TYPE_INDEX); + + for (i = 0; driver_list; driver_list = driver_list->next) + if (NILP (ftype) || EQ (driver_list->driver->type, ftype)) + { + Lisp_Object cache = driver_list->driver->get_cache (frame); + Lisp_Object tail = alternate_familes; + Lisp_Object val; + + xassert (CONSP (cache)); + ASET (spec, FONT_TYPE_INDEX, driver_list->driver->type); + ASET (spec, FONT_FAMILY_INDEX, family); + + while (1) + { + val = assoc_no_quit (spec, XCDR (cache)); + if (CONSP (val)) + val = XCDR (val); + else + { + val = driver_list->driver->list (frame, spec); + if (VECTORP (val)) + XSETCDR (cache, Fcons (Fcons (Fcopy_sequence (spec), val), + XCDR (cache))); + } + if (VECTORP (val) && ASIZE (val) > 0) + { + vec[i++] = val; + break; + } + if (NILP (tail)) + break; + ASET (spec, FONT_FAMILY_INDEX, XCAR (tail)); + tail = XCDR (tail); + } + } + ASET (spec, FONT_TYPE_INDEX, ftype); + ASET (spec, FONT_FAMILY_INDEX, family); + return (i > 0 ? Fvconcat (i, vec) : null_vector); +} + +static int num_fonts; + +static Lisp_Object +font_open_entity (f, entity, pixel_size) + FRAME_PTR f; + Lisp_Object entity; + int pixel_size; +{ + struct font_driver_list *driver_list; + Lisp_Object objlist, size, val; + struct font *font; + + size = AREF (entity, FONT_SIZE_INDEX); + xassert (NATNUMP (size)); + if (XINT (size) != 0) + pixel_size = XINT (size); + + for (objlist = AREF (entity, FONT_OBJLIST_INDEX); CONSP (objlist); + objlist = XCDR (objlist)) + { + font = XSAVE_VALUE (XCAR (objlist))->pointer; + if (font->pixel_size == pixel_size) + { + XSAVE_VALUE (XCAR (objlist))->integer++; + return XCAR (objlist); + } + } + + xassert (FONT_ENTITY_P (entity)); + val = AREF (entity, FONT_TYPE_INDEX); + for (driver_list = f->font_driver_list; + driver_list && ! EQ (driver_list->driver->type, val); + driver_list = driver_list->next); + if (! driver_list) + return Qnil; + + font = driver_list->driver->open (f, entity, pixel_size); + if (! font) + return Qnil; + val = make_save_value (font, 1); + ASET (entity, FONT_OBJLIST_INDEX, + Fcons (val, AREF (entity, FONT_OBJLIST_INDEX))); + num_fonts++; + return val; +} + +void +font_close_object (f, font_object) + FRAME_PTR f; + Lisp_Object font_object; +{ + struct font *font; + Lisp_Object objlist = AREF (font->entity, FONT_OBJLIST_INDEX); + Lisp_Object tail, prev = Qnil; + + for (prev = Qnil, tail = objlist; CONSP (tail); + prev = tail, tail = XCDR (tail)) + if (EQ (font_object, XCAR (tail))) + { + struct Lisp_Save_Value *p = XSAVE_VALUE (font_object); + + xassert (p->integer > 0); + p->integer--; + if (p->integer == 0) + { + if (font->driver->close) + font->driver->close (f, p->pointer); + p->pointer = NULL; + if (NILP (prev)) + ASET (font->entity, FONT_OBJLIST_INDEX, XCDR (objlist)); + else + XSETCDR (prev, XCDR (objlist)); + } + break; + } +} + +int +font_has_char (f, font_entity, c) + FRAME_PTR f; + Lisp_Object font_entity; + int c; +{ + Lisp_Object type = AREF (font_entity, FONT_TYPE_INDEX); + struct font_driver_list *driver_list; + + for (driver_list = f->font_driver_list; + driver_list && ! EQ (driver_list->driver->type, type); + driver_list = driver_list->next); + if (! driver_list) + return -1; + return driver_list->driver->has_char (font_entity, c); +} + +unsigned +font_encode_char (font_object, c) + Lisp_Object font_object; + int c; +{ + struct font *font = XSAVE_VALUE (font_object)->pointer; + + return font->driver->encode_char (font, c); +} + +char * +font_get_name (font_object) + Lisp_Object font_object; +{ + struct font *font = XSAVE_VALUE (font_object)->pointer; + + return (font->font.full_name ? font->font.full_name + : font->file_name ? font->file_name + : ""); +} + +Lisp_Object +font_get_frame (font) + Lisp_Object font; +{ + if (FONT_OBJECT_P (font)) + font = ((struct font *) XSAVE_VALUE (font)->pointer)->entity; + xassert (FONT_ENTITY_P (font)); + return AREF (font, FONT_FRAME_INDEX); +} + +extern Lisp_Object Qunspecified, Qignore_defface; + +Lisp_Object +font_find_for_lface (f, lface, spec) + FRAME_PTR f; + Lisp_Object *lface; + Lisp_Object spec; +{ + Lisp_Object attrs[LFACE_SLANT_INDEX + 1]; + Lisp_Object frame, val, entities; + int i; + unsigned char try_unspecified[FONT_SPEC_MAX]; + + for (i = 0; i <= LFACE_SLANT_INDEX; i++) + { + val = lface[i]; + if (EQ (val, Qunspecified) || EQ (val, Qignore_defface)) + val = Qnil; + attrs[i] = val; + } + if (NILP (spec)) + for (i = 0; i < FONT_SPEC_MAX; i++) + ASET (scratch_font_spec, i, Qnil); + else + for (i = 0; i < FONT_SPEC_MAX; i++) + ASET (scratch_font_spec, i, AREF (spec, i)); + + /* If SPEC doesn't specify a specific property, it can be tried with + nil even if FACE specifies it. */ + for (i = FONT_FOUNDRY_INDEX; i <= FONT_SIZE_INDEX; i++) + try_unspecified[i] = NILP (AREF (scratch_font_spec, i)); + + if (STRINGP (attrs[LFACE_FONT_INDEX])) + font_merge_old_spec (attrs[LFACE_FONT_INDEX], Qnil, Qnil, + scratch_font_spec); + if (NILP (AREF (scratch_font_spec, FONT_FAMILY_INDEX)) + && ! NILP (attrs[LFACE_FAMILY_INDEX])) + font_merge_old_spec (Qnil, attrs[LFACE_FAMILY_INDEX], Qnil, + scratch_font_spec); + if (NILP (AREF (scratch_font_spec, FONT_REGISTRY_INDEX))) + { + ASET (scratch_font_spec, FONT_REGISTRY_INDEX, intern ("iso8859-1")); + try_unspecified[FONT_REGISTRY_INDEX] = 0; + } + + for (i = FONT_FAMILY_INDEX; i <= FONT_SIZE_INDEX; i++) + if (try_unspecified[i] + && NILP (AREF (scratch_font_spec, i))) + try_unspecified[i] = 0; + + XSETFRAME (frame, f); + entities = font_list_entities (frame, scratch_font_spec); + while (ASIZE (entities) == 0) + { + if (try_unspecified[FONT_WEIGHT_INDEX] + || try_unspecified[FONT_SLANT_INDEX] + || try_unspecified[FONT_WIDTH_INDEX] + || try_unspecified[FONT_SIZE_INDEX]) + { + for (i = FONT_WEIGHT_INDEX; i <= FONT_SIZE_INDEX; i++) + { + try_unspecified[i] = 0; + ASET (scratch_font_spec, i, Qnil); + } + entities = font_list_entities (frame, scratch_font_spec); + } + else if (try_unspecified[FONT_FOUNDRY_INDEX]) + { + try_unspecified[FONT_FOUNDRY_INDEX] = 0; + ASET (scratch_font_spec, FONT_FOUNDRY_INDEX, Qnil); + entities = font_list_entities (frame, scratch_font_spec); + } + else if (try_unspecified[FONT_FAMILY_INDEX]) + { + try_unspecified[FONT_FAMILY_INDEX] = 0; + ASET (scratch_font_spec, FONT_FAMILY_INDEX, Qnil); + entities = font_list_entities (frame, scratch_font_spec); + } + else + return Qnil; + } + + if (ASIZE (entities) > 1) + { + Lisp_Object prefer = scratch_font_prefer; + + for (i = 0; i < FONT_WEIGHT_INDEX; i++) + ASET (prefer, i, Qnil); + if (! NILP (attrs[LFACE_WEIGHT_INDEX])) + ASET (prefer, FONT_WEIGHT_INDEX, + font_prop_validate_style (FONT_WEIGHT_INDEX, + attrs[LFACE_WEIGHT_INDEX])); + if (! NILP (attrs[LFACE_SLANT_INDEX])) + ASET (prefer, FONT_SLANT_INDEX, + font_prop_validate_style (FONT_SLANT_INDEX, + attrs[LFACE_SLANT_INDEX])); + if (! NILP (attrs[LFACE_SWIDTH_INDEX])) + ASET (prefer, FONT_WIDTH_INDEX, + font_prop_validate_style (FONT_WIDTH_INDEX, + attrs[LFACE_SWIDTH_INDEX])); + if (! NILP (attrs[LFACE_HEIGHT_INDEX])) + { + int size; + + val = attrs[LFACE_HEIGHT_INDEX]; + size = POINT_TO_PIXEL (XINT (val), f->resy); + ASET (prefer, FONT_SIZE_INDEX, make_number (size)); + } + font_sort_entites (entities, prefer, frame, spec); + } + + return AREF (entities, 0); +} + +Lisp_Object +font_open_for_lface (f, lface, entity) + FRAME_PTR f; + Lisp_Object *lface; + Lisp_Object entity; +{ + int pt = XINT (lface[LFACE_HEIGHT_INDEX]); + int size = POINT_TO_PIXEL (pt, f->resy); + + return font_open_entity (f, entity, size); +} + +void +font_load_for_face (f, face) + FRAME_PTR f; + struct face *face; +{ + Lisp_Object entity; + + face->font_info_id = -1; + face->font_info = NULL; + face->font = NULL; + face->font_name = NULL; + + entity = font_find_for_lface (f, face->lface, Qnil); + if (! NILP (entity)) + { + Lisp_Object font_object = font_open_for_lface (f, face->lface, entity); + + if (! NILP (font_object)) + { + struct font *font = XSAVE_VALUE (font_object)->pointer; + + face->font = font->font.font; + face->font_info = (struct font_info *) font; + face->font_info_id = 0; + face->font_name = font->font.full_name; + } + } + if (! face->font) + add_to_log ("Unable to load font for a face%s", null_string, Qnil); +} + +void +font_prepare_for_face (f, face) + FRAME_PTR f; + struct face *face; +{ + struct font *font = (struct font *) face->font_info; + + if (font->driver->prepare_face) + font->driver->prepare_face (f, face); +} + +void +font_done_for_face (f, face) + FRAME_PTR f; + struct face *face; +{ + struct font *font = (struct font *) face->font_info; + + if (font->driver->done_face) + font->driver->done_face (f, face); + face->extra = NULL; +} + +Lisp_Object +font_open_by_name (f, name) + FRAME_PTR f; + char *name; +{ + Lisp_Object spec = Ffont_spec (0, NULL); + Lisp_Object entities = Qnil; + Lisp_Object frame; + int pixel_size; + + XSETFRAME (frame, f); + + ASET (spec, FONT_EXTRA_INDEX, + Fcons (Fcons (QCname, make_unibyte_string (name, strlen (name))), + Qnil)); + entities = font_list_entities (frame, spec); + if (ASIZE (entities) == 0) + return Qnil; + pixel_size = XINT (AREF (AREF (entities, 0), FONT_SIZE_INDEX)); + if (pixel_size == 0) + pixel_size = 12; + return font_open_entity (f, AREF (entities, 0), pixel_size); +} + + +/* Register font-driver DRIVER. This function is used in two ways. + + The first is with frame F non-NULL. In this case, DRIVER is + registered to be used for drawing characters on F. All frame + creaters (e.g. Fx_create_frame) must call this function at least + once with an available font-driver. + + The second is with frame F NULL. In this case, DRIVER is globally + registered in the variable `font_driver_list'. All font-driver + implementations must call this function in its syms_of_XXXX + (e.g. syms_of_xfont). */ + +void +register_font_driver (driver, f) + struct font_driver *driver; + FRAME_PTR f; +{ + struct font_driver_list *root = f ? f->font_driver_list : font_driver_list; + struct font_driver_list *prev, *list; + + if (f && ! driver->draw) + error ("Unsable font driver for a frame: %s", + SDATA (SYMBOL_NAME (driver->type))); + + for (prev = NULL, list = root; list; prev = list, list = list->next) + if (list->driver->type == driver->type) + error ("Duplicated font driver: %s", SDATA (SYMBOL_NAME (driver->type))); + + list = malloc (sizeof (struct font_driver_list)); + list->driver = driver; + list->next = NULL; + if (prev) + prev->next = list; + else if (f) + f->font_driver_list = list; + else + font_driver_list = list; + num_font_drivers++; +} + +/* Free font-driver list on frame F. It doesn't free font-drivers + themselves. */ + +void +free_font_driver_list (f) + FRAME_PTR f; +{ + while (f->font_driver_list) + { + struct font_driver_list *next = f->font_driver_list->next; + + free (f->font_driver_list); + f->font_driver_list = next; + } +} + + +/* Lisp API */ + +DEFUN ("fontp", Ffontp, Sfontp, 1, 1, 0, + doc: /* Return t if object is a font-spec or font-entity. */) + (object) + Lisp_Object object; +{ + return (FONTP (object) ? Qt : Qnil); +} + +DEFUN ("font-spec", Ffont_spec, Sfont_spec, 0, MANY, 0, + doc: /* Return a newly created font-spec with specified arguments as properties. +usage: (font-spec &rest properties) */) + (nargs, args) + int nargs; + Lisp_Object *args; +{ + Lisp_Object spec = Fmake_vector (make_number (FONT_SPEC_MAX), Qnil); + Lisp_Object extra = Qnil; + int i; + + for (i = 0; i < nargs; i += 2) + { + enum font_property_index prop; + Lisp_Object key = args[i], val = args[i + 1]; + + prop = check_font_prop_name (key); + if (prop < FONT_EXTRA_INDEX) + ASET (spec, prop, (font_property_table[prop].validater) (prop, val)); + else + extra = Fcons (Fcons (key, val), extra); + } + ASET (spec, FONT_EXTRA_INDEX, extra); + return spec; +} + + +DEFUN ("font-get", Ffont_get, Sfont_get, 2, 2, 0, + doc: /* Return the value of FONT's PROP property. +FONT may be a font-spec or font-entity. +If FONT is font-entity and PROP is :extra, always nil is returned. */) + (font, prop) + Lisp_Object font, prop; +{ + enum font_property_index idx; + + CHECK_FONT (font); + idx = check_font_prop_name (prop); + if (idx < FONT_EXTRA_INDEX) + return AREF (font, idx); + if (FONT_ENTITY_P (font)) + return Qnil; + return Fcdr (Fassoc (AREF (font, FONT_EXTRA_INDEX), prop)); +} + + +DEFUN ("font-put", Ffont_put, Sfont_put, 3, 3, 0, + doc: /* Set one property of FONT-SPEC: give property PROP value VALUE. */) + (font_spec, prop, val) + Lisp_Object font_spec, prop, val; +{ + enum font_property_index idx; + Lisp_Object extra, slot; + + CHECK_FONT_SPEC (font_spec); + idx = check_font_prop_name (prop); + if (idx < FONT_EXTRA_INDEX) + return ASET (font_spec, idx, val); + extra = AREF (font_spec, FONT_EXTRA_INDEX); + slot = Fassoc (extra, prop); + if (NILP (slot)) + extra = Fcons (Fcons (prop, val), extra); + else + Fsetcdr (slot, val); + return val; +} + +DEFUN ("list-fonts", Flist_fonts, Slist_fonts, 1, 4, 0, + doc: /* List available fonts matching FONT-SPEC on the current frame. +Optional 2nd argument FRAME specifies the target frame. +Optional 3rd argument NUM, if non-nil, limits the number of returned fonts. +Optional 4th argument PREFER, if non-nil, is a font-spec to sort fonts +by closeness to PREFER. */) + (font_spec, frame, num, prefer) + Lisp_Object font_spec, frame, num, prefer; +{ + Lisp_Object vec, list, tail; + int n = 0, i, len; + + if (NILP (frame)) + frame = selected_frame; + CHECK_LIVE_FRAME (frame); + CHECK_VALIDATE_FONT_SPEC (font_spec); + if (! NILP (num)) + { + CHECK_NUMBER (num); + n = XINT (num); + if (n <= 0) + return Qnil; + } + if (! NILP (prefer)) + CHECK_FONT (prefer); + + vec = font_list_entities (frame, font_spec); + len = ASIZE (vec); + if (len == 0) + return Qnil; + if (len == 1) + return Fcons (AREF (vec, 0), Qnil); + + if (! NILP (prefer)) + vec = font_sort_entites (vec, prefer, frame, font_spec); + + list = tail = Fcons (AREF (vec, 0), Qnil); + if (n == 0 || n > len) + n = len; + for (i = 1; i < n; i++) + { + Lisp_Object val = Fcons (AREF (vec, i), Qnil); + + XSETCDR (tail, val); + tail = val; + } + return list; +} + +DEFUN ("list-families", Flist_families, Slist_families, 0, 1, 0, + doc: /* List available font families on the current frame. +Optional 2nd argument FRAME specifies the target frame. */) + (frame) + Lisp_Object frame; +{ + FRAME_PTR f; + struct font_driver_list *driver_list; + Lisp_Object list; + + if (NILP (frame)) + frame = selected_frame; + CHECK_LIVE_FRAME (frame); + f = XFRAME (frame); + list = Qnil; + for (driver_list = f->font_driver_list; driver_list; + driver_list = driver_list->next) + if (driver_list->driver->list_family) + { + Lisp_Object val = driver_list->driver->list_family (frame); + + if (NILP (list)) + list = val; + else + { + Lisp_Object tail = list; + + for (; CONSP (val); val = XCDR (val)) + if (NILP (Fmemq (XCAR (val), tail))) + list = Fcons (XCAR (val), list); + } + } + return list; +} + +DEFUN ("find-font", Ffind_font, Sfind_font, 1, 2, 0, + doc: /* Return a font-entity matching with FONT-SPEC on the current frame. +Optional 2nd argument FRAME, if non-nil, specifies the target frame. */) + (font_spec, frame) + Lisp_Object font_spec, frame; +{ + Lisp_Object val = Flist_fonts (font_spec, frame, make_number (1), Qnil); + + if (CONSP (val)) + val = XCAR (val); + return val; +} + +DEFUN ("font-xlfd-name", Ffont_xlfd_name, Sfont_xlfd_name, 1, 1, 0, + doc: /* Return XLFD name of FONT. +FONT is a font-spec, font-entity, or font-object. +If the name is too long for XLFD (maximum 255 chars), return nil. */) + (font) + Lisp_Object font; +{ + char name[256]; + int pixel_size = 0; + + if (FONT_SPEC_P (font)) + CHECK_VALIDATE_FONT_SPEC (font); + else if (FONT_ENTITY_P (font)) + CHECK_FONT (font); + else + { + struct font *fontp; + + CHECK_FONT_GET_OBJECT (font, fontp); + font = fontp->entity; + pixel_size = fontp->pixel_size; + } + + if (font_unparse_xlfd (font, pixel_size, name, 256) < 0) + return Qnil; + return build_string (name); +} + +DEFUN ("clear-font-cache", Fclear_font_cache, Sclear_font_cache, 0, 0, 0, + doc: /* Clear font cache. */) + () +{ + Lisp_Object list, frame; + + FOR_EACH_FRAME (list, frame) + { + FRAME_PTR f = XFRAME (frame); + struct font_driver_list *driver_list = f->font_driver_list; + + for (; driver_list; driver_list = driver_list->next) + { + Lisp_Object cache = driver_list->driver->get_cache (frame); + Lisp_Object tail, elt; + + for (tail = XCDR (cache); CONSP (tail); tail = XCDR (tail)) + { + elt = XCAR (tail); + if (CONSP (elt) && FONT_SPEC_P (XCAR (elt))) + { + Lisp_Object vec = XCDR (elt); + int i; + + for (i = 0; i < ASIZE (vec); i++) + { + Lisp_Object entity = AREF (vec, i); + Lisp_Object objlist = AREF (entity, FONT_OBJLIST_INDEX); + + for (; CONSP (objlist); objlist = XCDR (objlist)) + { + Lisp_Object val = XCAR (objlist); + struct Lisp_Save_Value *p = XSAVE_VALUE (val); + struct font *font = p->pointer; + + xassert (font + && driver_list->driver == font->driver); + driver_list->driver->close (f, font); + p->pointer = NULL; + p->integer = 0; + } + if (driver_list->driver->free_entity) + driver_list->driver->free_entity (entity); + } + } + } + XSETCDR (cache, Qnil); + } + } + + return Qnil; +} + +DEFUN ("internal-set-font-style-table", Finternal_set_font_style_table, + Sinternal_set_font_style_table, 2, 2, 0, + doc: /* Set font style table for PROP to TABLE. +PROP must be `:weight', `:slant', or `:width'. +TABLE must be an alist of symbols vs the corresponding numeric values +sorted by numeric values. */) + (prop, table) + Lisp_Object prop, table; +{ + int table_index; + int numeric; + Lisp_Object tail, val; + + CHECK_SYMBOL (prop); + table_index = (EQ (prop, QCweight) ? 0 + : EQ (prop, QCslant) ? 1 + : EQ (prop, QCwidth) ? 2 + : 3); + if (table_index >= ASIZE (font_style_table)) + error ("Invalid font style property: %s", SDATA (SYMBOL_NAME (prop))); + table = Fcopy_sequence (table); + numeric = -1; + for (tail = table; ! NILP (tail); tail = Fcdr (tail)) + { + prop = Fcar (Fcar (tail)); + val = Fcdr (Fcar (tail)); + CHECK_SYMBOL (prop); + CHECK_NATNUM (val); + if (numeric > XINT (val)) + error ("Numeric values not sorted for %s", SDATA (SYMBOL_NAME (prop))); + numeric = XINT (val); + XSETCAR (tail, Fcons (prop, val)); + } + ASET (font_style_table, table_index, table); + return Qnil; +} + +DEFUN ("font-make-gstring", Ffont_make_gstring, Sfont_make_gstring, 2, 2, 0, + doc: /* Return a newly created glyph-string for FONT-OBJECT with NUM glyphs. +FONT-OBJECT may be nil if it is not yet known. */) + (font_object, num) + Lisp_Object font_object, num; +{ + Lisp_Object gstring, g; + int len; + int i; + + if (! NILP (font_object)) + CHECK_FONT_OBJECT (font_object); + CHECK_NATNUM (num); + + len = XINT (num) + 1; + gstring = Fmake_vector (make_number (len), Qnil); + g = Fmake_vector (make_number (6), Qnil); + ASET (g, 0, font_object); + ASET (gstring, 0, g); + for (i = 1; i < len; i++) + ASET (gstring, i, Fmake_vector (make_number (8), make_number (0))); + return gstring; +} + +DEFUN ("font-fill-gstring", Ffont_fill_gstring, Sfont_fill_gstring, 4, 5, 0, + doc: /* Fillin glyph-string GSTRING by characters for FONT-OBJECT. +START and END specifies the region to extract characters. +If optional 3rd argument OBJECT is non-nil, it is a buffer or a string from +where to extract characters. +FONT-OBJECT may be nil if GSTRING already already contains one. */) + (gstring, font_object, start, end, object) + Lisp_Object gstring, font_object, start, end, object; +{ + int len, i, c; + unsigned code; + struct font *font; + + CHECK_VECTOR (gstring); + if (NILP (font_object)) + font_object = Faref (Faref (gstring, make_number (0)), make_number (0)); + CHECK_FONT_GET_OBJECT (font_object, font); + + if (STRINGP (object)) + { + const unsigned char *p; + + CHECK_NATNUM (start); + CHECK_NATNUM (end); + if (XINT (start) > XINT (end) + || XINT (end) > ASIZE (object) + || XINT (end) - XINT (start) >= XINT (Flength (gstring))) + args_out_of_range (start, end); + + len = XINT (end) - XINT (start); + p = SDATA (object) + string_char_to_byte (object, XINT (start)); + for (i = 0; i < len; i++) + { + Lisp_Object g = LGSTRING_GLYPH (gstring, i); + + c = STRING_CHAR_ADVANCE (p); + code = font->driver->encode_char (font, c); + if (code > MOST_POSITIVE_FIXNUM) + error ("Glyph code 0x%X is too large", code); + ASET (g, 0, make_number (i)); + ASET (g, 1, make_number (i + 1)); + LGLYPH_SET_CHAR (g, make_number (c)); + LGLYPH_SET_CODE (g, make_number (code)); + } + } + else + { + int pos, pos_byte; + + if (! NILP (object)) + Fset_buffer (object); + validate_region (&start, &end); + if (XINT (end) - XINT (start) > len) + args_out_of_range (start, end); + len = XINT (end) - XINT (start); + pos = XINT (start); + pos_byte = CHAR_TO_BYTE (pos); + for (i = 0; i < len; i++) + { + Lisp_Object g = LGSTRING_GLYPH (gstring, i); + + FETCH_CHAR_ADVANCE (c, pos, pos_byte); + code = font->driver->encode_char (font, c); + if (code > MOST_POSITIVE_FIXNUM) + error ("Glyph code 0x%X is too large", code); + ASET (g, 0, make_number (i)); + ASET (g, 1, make_number (i + 1)); + LGLYPH_SET_CHAR (g, make_number (c)); + LGLYPH_SET_CODE (g, make_number (code)); + } + } + return Qnil; +} + + +#ifdef FONT_DEBUG + +DEFUN ("open-font", Fopen_font, Sopen_font, 1, 3, 0, + doc: /* Open FONT-ENTITY. */) + (font_entity, size, frame) + Lisp_Object font_entity; + Lisp_Object size; + Lisp_Object frame; +{ + int isize; + + CHECK_FONT_ENTITY (font_entity); + if (NILP (size)) + size = AREF (font_entity, FONT_SIZE_INDEX); + CHECK_NUMBER (size); + if (NILP (frame)) + frame = selected_frame; + CHECK_LIVE_FRAME (frame); + + isize = XINT (size); + if (isize < 0) + isize = POINT_TO_PIXEL (- isize, XFRAME (frame)->resy); + + return font_open_entity (XFRAME (frame), font_entity, isize); +} + +DEFUN ("close-font", Fclose_font, Sclose_font, 1, 2, 0, + doc: /* Close FONT-OBJECT. */) + (font_object, frame) + Lisp_Object font_object, frame; +{ + CHECK_FONT_OBJECT (font_object); + if (NILP (frame)) + frame = selected_frame; + CHECK_LIVE_FRAME (frame); + font_close_object (XFRAME (frame), font_object); + return Qnil; +} + +DEFUN ("query-font", Fquery_font, Squery_font, 1, 1, 0, + doc: /* Return information about FONT-OBJECT. */) + (font_object) + Lisp_Object font_object; +{ + struct font *font; + Lisp_Object val; + + CHECK_FONT_GET_OBJECT (font_object, font); + + val = Fmake_vector (make_number (9), Qnil); + ASET (val, 0, Ffont_xlfd_name (font_object)); + if (font->file_name) + ASET (val, 1, make_unibyte_string (font->file_name, + strlen (font->file_name))); + ASET (val, 2, make_number (font->pixel_size)); + ASET (val, 3, make_number (font->font.size)); + ASET (val, 4, make_number (font->ascent)); + ASET (val, 5, make_number (font->descent)); + ASET (val, 6, make_number (font->font.space_width)); + ASET (val, 7, make_number (font->font.average_width)); + if (font->driver->otf_capability) + ASET (val, 8, font->driver->otf_capability (font)); + return val; +} + +DEFUN ("get-font-glyphs", Fget_font_glyphs, Sget_font_glyphs, 2, 2, 0, + doc: /* Return a vector of glyphs of FONT-OBJECT for drawing STRING. +Each element is a vector [GLYPH-CODE LBEARING RBEARING WIDTH ASCENT DESCENT]. */) + (font_object, string) + Lisp_Object font_object, string; +{ + struct font *font; + int i, len; + Lisp_Object vec; + + CHECK_FONT_GET_OBJECT (font_object, font); + CHECK_STRING (string); + len = SCHARS (string); + vec = Fmake_vector (make_number (len), Qnil); + for (i = 0; i < len; i++) + { + Lisp_Object ch = Faref (string, make_number (i)); + Lisp_Object val; + int c = XINT (ch); + unsigned code; + struct font_metrics metrics; + + code = font->driver->encode_char (font, c); + if (code == FONT_INVALID_CODE) + continue; + val = Fmake_vector (make_number (6), Qnil); + if (code <= MOST_POSITIVE_FIXNUM) + ASET (val, 0, make_number (code)); + else + ASET (val, 0, Fcons (make_number (code >> 16), + make_number (code & 0xFFFF))); + font->driver->text_extents (font, &code, 1, &metrics); + ASET (val, 1, make_number (metrics.lbearing)); + ASET (val, 2, make_number (metrics.rbearing)); + ASET (val, 3, make_number (metrics.width)); + ASET (val, 4, make_number (metrics.ascent)); + ASET (val, 5, make_number (metrics.descent)); + ASET (vec, i, val); + } + return vec; +} + +#if 0 +DEFUN ("draw-string", Fdraw_string, Sdraw_string, 2, 2, 0, + doc: /* Draw STRING by FONT-OBJECT on the top left corner of the current frame. +The value is a number of glyphs drawn. +Type C-l to recover what previously shown. */) + (font_object, string) + Lisp_Object font_object, string; +{ + Lisp_Object frame = selected_frame; + FRAME_PTR f = XFRAME (frame); + struct font *font; + struct face *face; + int i, len, width; + unsigned *code; + + CHECK_FONT_GET_OBJECT (font_object, font); + CHECK_STRING (string); + len = SCHARS (string); + code = alloca (sizeof (unsigned) * len); + for (i = 0; i < len; i++) + { + Lisp_Object ch = Faref (string, make_number (i)); + Lisp_Object val; + int c = XINT (ch); + + code[i] = font->driver->encode_char (font, c); + if (code[i] == FONT_INVALID_CODE) + break; + } + face = FACE_FROM_ID (f, DEFAULT_FACE_ID); + face->fontp = font; + if (font->driver->prepare_face) + font->driver->prepare_face (f, face); + width = font->driver->text_extents (font, code, i, NULL); + len = font->driver->draw_text (f, face, 0, font->ascent, code, i, width); + if (font->driver->done_face) + font->driver->done_face (f, face); + face->fontp = NULL; + return make_number (len); +} +#endif + +#endif /* FONT_DEBUG */ + + +extern void syms_of_ftfont P_ (()); +extern void syms_of_xfont P_ (()); +extern void syms_of_xftfont P_ (()); +extern void syms_of_ftxfont P_ (()); +extern void syms_of_bdffont P_ (()); +extern void syms_of_w32font P_ (()); +extern void syms_of_atmfont P_ (()); + +void +syms_of_font () +{ + sort_shift_bits[FONT_SLANT_INDEX] = 0; + sort_shift_bits[FONT_WEIGHT_INDEX] = 7; + sort_shift_bits[FONT_SIZE_INDEX] = 14; + sort_shift_bits[FONT_WIDTH_INDEX] = 21; + sort_shift_bits[FONT_ADSTYLE_INDEX] = 28; + sort_shift_bits[FONT_FOUNDRY_INDEX] = 29; + sort_shift_bits[FONT_FAMILY_INDEX] = 30; + sort_shift_bits[FONT_REGISTRY_INDEX] = 31; + /* Note that sort_shift_bits[FONT_SLANT_TYPE] is never used. */ + + staticpro (&font_style_table); + font_style_table = Fmake_vector (make_number (3), Qnil); + + staticpro (&font_family_alist); + font_family_alist = Qnil; + + DEFSYM (Qfontp, "fontp"); + + DEFSYM (QCotf, ":otf"); + DEFSYM (QClanguage, ":language"); + DEFSYM (QCscript, ":script"); + + DEFSYM (QCfoundry, ":foundry"); + DEFSYM (QCadstyle, ":adstyle"); + DEFSYM (QCregistry, ":registry"); + DEFSYM (QCextra, ":extra"); + + staticpro (&null_string); + null_string = build_string (""); + staticpro (&null_vector); + null_vector = Fmake_vector (make_number (0), Qnil); + + staticpro (&scratch_font_spec); + scratch_font_spec = Ffont_spec (0, NULL); + staticpro (&scratch_font_prefer); + scratch_font_prefer = Ffont_spec (0, NULL); + + defsubr (&Sfontp); + defsubr (&Sfont_spec); + defsubr (&Sfont_get); + defsubr (&Sfont_put); + defsubr (&Slist_fonts); + defsubr (&Slist_families); + defsubr (&Sfind_font); + defsubr (&Sfont_xlfd_name); + defsubr (&Sclear_font_cache); + defsubr (&Sinternal_set_font_style_table); + defsubr (&Sfont_make_gstring); + defsubr (&Sfont_fill_gstring); + +#ifdef FONT_DEBUG + defsubr (&Sopen_font); + defsubr (&Sclose_font); + defsubr (&Squery_font); + defsubr (&Sget_font_glyphs); +#if 0 + defsubr (&Sdraw_string); +#endif +#endif /* FONT_DEBUG */ + +#ifdef HAVE_FREETYPE + syms_of_ftfont (); +#ifdef HAVE_X_WINDOWS + syms_of_xfont (); + syms_of_ftxfont (); +#ifdef HAVE_XFT + syms_of_xftfont (); +#endif /* HAVE_XFT */ +#endif /* HAVE_X_WINDOWS */ +#else /* not HAVE_FREETYPE */ +#ifdef HAVE_X_WINDOWS + syms_of_xfont (); +#endif /* HAVE_X_WINDOWS */ +#endif /* not HAVE_FREETYPE */ +#ifdef HAVE_BDFFONT + syms_of_bdffont (); +#endif /* HAVE_BDFFONT */ +#ifdef WINDOWSNT + syms_of_w32font (); +#endif /* WINDOWSNT */ +#ifdef MAC_OS + syms_of_atmfont (); +#endif /* MAC_OS */ +}