From: Eli Zaretskii Date: Wed, 24 Apr 2019 06:38:03 +0000 (+0300) Subject: Revert "Remove font.c code commented out for a decade" X-Git-Tag: emacs-27.0.90~3114 X-Git-Url: http://git.eshelyaron.com/gitweb/?a=commitdiff_plain;h=5ae407aad4f2564fae7ddce077eb01aa8efa37fb;p=emacs.git Revert "Remove font.c code commented out for a decade" This reverts commit 64d0cd9810af6bd0c378fc6bc666c76ddfa97e40. Rationale: any font-related code and comments, even if unused for decades, serves as important source of useful information in an area of Emacs code that is notoriously under-documented. Please do NOT remove this stuff until we have an active expert in this are on board, who will then decide whether this can be retired. --- diff --git a/src/font.c b/src/font.c index e7686cf4bb3..5ca89c97dcf 100644 --- a/src/font.c +++ b/src/font.c @@ -1785,6 +1785,296 @@ font_parse_family_registry (Lisp_Object family, Lisp_Object registry, Lisp_Objec } } + +/* This part (through the next ^L) is still experimental and not + tested much. We may drastically change codes. */ + +/* OTF handler. */ + +#if 0 + +#define LGSTRING_HEADER_SIZE 6 +#define LGSTRING_GLYPH_SIZE 8 + +static int +check_gstring (Lisp_Object gstring) +{ + Lisp_Object val; + ptrdiff_t i; + int j; + + CHECK_VECTOR (gstring); + val = AREF (gstring, 0); + CHECK_VECTOR (val); + if (ASIZE (val) < LGSTRING_HEADER_SIZE) + goto err; + CHECK_FONT_OBJECT (LGSTRING_FONT (gstring)); + if (!NILP (LGSTRING_SLOT (gstring, LGSTRING_IX_LBEARING))) + CHECK_FIXNUM (LGSTRING_SLOT (gstring, LGSTRING_IX_LBEARING)); + if (!NILP (LGSTRING_SLOT (gstring, LGSTRING_IX_RBEARING))) + CHECK_FIXNUM (LGSTRING_SLOT (gstring, LGSTRING_IX_RBEARING)); + if (!NILP (LGSTRING_SLOT (gstring, LGSTRING_IX_WIDTH))) + CHECK_FIXNAT (LGSTRING_SLOT (gstring, LGSTRING_IX_WIDTH)); + if (!NILP (LGSTRING_SLOT (gstring, LGSTRING_IX_ASCENT))) + CHECK_FIXNUM (LGSTRING_SLOT (gstring, LGSTRING_IX_ASCENT)); + if (!NILP (LGSTRING_SLOT (gstring, LGSTRING_IX_ASCENT))) + CHECK_FIXNUM (LGSTRING_SLOT (gstring, LGSTRING_IX_ASCENT)); + + for (i = 0; i < LGSTRING_GLYPH_LEN (gstring); i++) + { + val = LGSTRING_GLYPH (gstring, i); + CHECK_VECTOR (val); + if (ASIZE (val) < LGSTRING_GLYPH_SIZE) + goto err; + if (NILP (AREF (val, LGLYPH_IX_CHAR))) + break; + CHECK_FIXNAT (AREF (val, LGLYPH_IX_FROM)); + CHECK_FIXNAT (AREF (val, LGLYPH_IX_TO)); + CHECK_CHARACTER (AREF (val, LGLYPH_IX_CHAR)); + if (!NILP (AREF (val, LGLYPH_IX_CODE))) + CHECK_FIXNAT (AREF (val, LGLYPH_IX_CODE)); + if (!NILP (AREF (val, LGLYPH_IX_WIDTH))) + CHECK_FIXNAT (AREF (val, LGLYPH_IX_WIDTH)); + if (!NILP (AREF (val, LGLYPH_IX_ADJUSTMENT))) + { + val = AREF (val, LGLYPH_IX_ADJUSTMENT); + CHECK_VECTOR (val); + if (ASIZE (val) < 3) + goto err; + for (j = 0; j < 3; j++) + CHECK_FIXNUM (AREF (val, j)); + } + } + return i; + err: + error ("Invalid glyph-string format"); + return -1; +} + +static void +check_otf_features (Lisp_Object otf_features) +{ + Lisp_Object val; + + CHECK_CONS (otf_features); + CHECK_SYMBOL (XCAR (otf_features)); + otf_features = XCDR (otf_features); + CHECK_CONS (otf_features); + CHECK_SYMBOL (XCAR (otf_features)); + otf_features = XCDR (otf_features); + for (val = Fcar (otf_features); CONSP (val); val = XCDR (val)) + { + CHECK_SYMBOL (XCAR (val)); + if (SBYTES (SYMBOL_NAME (XCAR (val))) > 4) + error ("Invalid OTF GSUB feature: %s", + SDATA (SYMBOL_NAME (XCAR (val)))); + } + otf_features = XCDR (otf_features); + for (val = Fcar (otf_features); CONSP (val); val = XCDR (val)) + { + CHECK_SYMBOL (XCAR (val)); + if (SBYTES (SYMBOL_NAME (XCAR (val))) > 4) + error ("Invalid OTF GPOS feature: %s", + SDATA (SYMBOL_NAME (XCAR (val)))); + } +} + +#ifdef HAVE_LIBOTF +#include + +Lisp_Object otf_list; + +static Lisp_Object +otf_tag_symbol (OTF_Tag tag) +{ + char name[5]; + + OTF_tag_name (tag, name); + return Fintern (make_unibyte_string (name, 4), Qnil); +} + +static OTF * +otf_open (Lisp_Object file) +{ + Lisp_Object val = Fassoc (file, otf_list, Qnil); + OTF *otf; + + if (! NILP (val)) + otf = xmint_pointer (XCDR (val)); + else + { + otf = STRINGP (file) ? OTF_open (SSDATA (file)) : NULL; + val = make_mint_ptr (otf); + otf_list = Fcons (Fcons (file, val), otf_list); + } + return otf; +} + + +/* Return a list describing which scripts/languages FONT supports by + which GSUB/GPOS features of OpenType tables. See the comment of + (struct font_driver).otf_capability. */ + +Lisp_Object +font_otf_capability (struct font *font) +{ + OTF *otf; + Lisp_Object capability = Fcons (Qnil, Qnil); + int i; + + otf = otf_open (font->props[FONT_FILE_INDEX]); + 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 (k == 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; +} + +/* Parse OTF features in SPEC and write a proper features spec string + in FEATURES for the call of OTF_drive_gsub/gpos (of libotf). It is + assured that the sufficient memory has already allocated for + FEATURES. */ + +static void +generate_otf_features (Lisp_Object spec, char *features) +{ + Lisp_Object val; + char *p; + bool asterisk; + + p = features; + *p = '\0'; + for (asterisk = 0; CONSP (spec); spec = XCDR (spec)) + { + val = XCAR (spec); + CHECK_SYMBOL (val); + if (p > features) + *p++ = ','; + if (SREF (SYMBOL_NAME (val), 0) == '*') + { + asterisk = 1; + *p++ = '*'; + } + else if (! asterisk) + { + val = SYMBOL_NAME (val); + p += esprintf (p, "%s", SDATA (val)); + } + else + { + val = SYMBOL_NAME (val); + p += esprintf (p, "~%s", SDATA (val)); + } + } + if (CONSP (spec)) + error ("OTF spec too long"); +} + +Lisp_Object +font_otf_DeviceTable (OTF_DeviceTable *device_table) +{ + int len = device_table->StartSize - device_table->EndSize + 1; + + return Fcons (make_fixnum (len), + make_unibyte_string (device_table->DeltaValue, len)); +} + +Lisp_Object +font_otf_ValueRecord (int value_format, OTF_ValueRecord *value_record) +{ + Lisp_Object val = make_nil_vector (8); + + if (value_format & OTF_XPlacement) + ASET (val, 0, make_fixnum (value_record->XPlacement)); + if (value_format & OTF_YPlacement) + ASET (val, 1, make_fixnum (value_record->YPlacement)); + if (value_format & OTF_XAdvance) + ASET (val, 2, make_fixnum (value_record->XAdvance)); + if (value_format & OTF_YAdvance) + ASET (val, 3, make_fixnum (value_record->YAdvance)); + if (value_format & OTF_XPlaDevice) + ASET (val, 4, font_otf_DeviceTable (&value_record->XPlaDevice)); + if (value_format & OTF_YPlaDevice) + ASET (val, 4, font_otf_DeviceTable (&value_record->YPlaDevice)); + if (value_format & OTF_XAdvDevice) + ASET (val, 4, font_otf_DeviceTable (&value_record->XAdvDevice)); + if (value_format & OTF_YAdvDevice) + ASET (val, 4, font_otf_DeviceTable (&value_record->YAdvDevice)); + return val; +} + +Lisp_Object +font_otf_Anchor (OTF_Anchor *anchor) +{ + Lisp_Object val = make_nil_vector (anchor->AnchorFormat + 1); + ASET (val, 0, make_fixnum (anchor->XCoordinate)); + ASET (val, 1, make_fixnum (anchor->YCoordinate)); + if (anchor->AnchorFormat == 2) + ASET (val, 2, make_fixnum (anchor->f.f1.AnchorPoint)); + else + { + ASET (val, 3, font_otf_DeviceTable (&anchor->f.f2.XDeviceTable)); + ASET (val, 4, font_otf_DeviceTable (&anchor->f.f2.YDeviceTable)); + } + return val; +} +#endif /* HAVE_LIBOTF */ +#endif /* 0 */ + /* Font sorting. */ @@ -4322,6 +4612,126 @@ DEFUN ("internal-char-font", Finternal_char_font, Sinternal_char_font, 1, 2, 0, return Fcons (font_object, INT_TO_INTEGER (code)); } +#if 0 + +DEFUN ("font-drive-otf", Ffont_drive_otf, Sfont_drive_otf, 6, 6, 0, + doc: /* Apply OpenType features on glyph-string GSTRING-IN. +OTF-FEATURES specifies which features to apply in this format: + (SCRIPT LANGSYS GSUB GPOS) +where + SCRIPT is a symbol specifying a script tag of OpenType, + LANGSYS is a symbol specifying a langsys tag of OpenType, + GSUB and GPOS, if non-nil, are lists of symbols specifying feature tags. + +If LANGSYS is nil, the default langsys is selected. + +The features are applied in the order they appear in the list. The +symbol `*' means to apply all available features not present in this +list, and the remaining features are ignored. For instance, (vatu +pstf * haln) is to apply vatu and pstf in this order, then to apply +all available features other than vatu, pstf, and haln. + +The features are applied to the glyphs in the range FROM and TO of +the glyph-string GSTRING-IN. + +If some feature is actually applicable, the resulting glyphs are +produced in the glyph-string GSTRING-OUT from the index INDEX. In +this case, the value is the number of produced glyphs. + +If no feature is applicable, no glyph is produced in GSTRING-OUT, and +the value is 0. + +If GSTRING-OUT is too short to hold produced glyphs, no glyphs are +produced in GSTRING-OUT, and the value is nil. + +See the documentation of `composition-get-gstring' for the format of +glyph-string. */) + (Lisp_Object otf_features, Lisp_Object gstring_in, Lisp_Object from, Lisp_Object to, Lisp_Object gstring_out, Lisp_Object index) +{ + Lisp_Object font_object = LGSTRING_FONT (gstring_in); + Lisp_Object val; + struct font *font; + int len, num; + + check_otf_features (otf_features); + CHECK_FONT_OBJECT (font_object); + font = XFONT_OBJECT (font_object); + if (! font->driver->otf_drive) + error ("Font backend %s can't drive OpenType GSUB table", + SDATA (SYMBOL_NAME (font->driver->type))); + CHECK_CONS (otf_features); + CHECK_SYMBOL (XCAR (otf_features)); + val = XCDR (otf_features); + CHECK_SYMBOL (XCAR (val)); + val = XCDR (otf_features); + if (! NILP (val)) + CHECK_CONS (val); + len = check_gstring (gstring_in); + CHECK_VECTOR (gstring_out); + CHECK_FIXNAT (from); + CHECK_FIXNAT (to); + CHECK_FIXNAT (index); + + if (XFIXNUM (from) >= XFIXNUM (to) || XFIXNUM (to) > len) + args_out_of_range_3 (from, to, make_fixnum (len)); + if (XFIXNUM (index) >= ASIZE (gstring_out)) + args_out_of_range (index, make_fixnum (ASIZE (gstring_out))); + num = font->driver->otf_drive (font, otf_features, + gstring_in, XFIXNUM (from), XFIXNUM (to), + gstring_out, XFIXNUM (index), 0); + if (num < 0) + return Qnil; + return make_fixnum (num); +} + +DEFUN ("font-otf-alternates", Ffont_otf_alternates, Sfont_otf_alternates, + 3, 3, 0, + doc: /* Return a list of alternate glyphs of CHARACTER in FONT-OBJECT. +OTF-FEATURES specifies which features of the font FONT-OBJECT to apply +in this format: + (SCRIPT LANGSYS FEATURE ...) +See the documentation of `font-drive-otf' for more detail. + +The value is a list of cons cells of the format (GLYPH-ID . CHARACTER), +where GLYPH-ID is a glyph index of the font, and CHARACTER is a +character code corresponding to the glyph or nil if there's no +corresponding character. */) + (Lisp_Object font_object, Lisp_Object character, Lisp_Object otf_features) +{ + struct font *font = CHECK_FONT_GET_OBJECT (font_object); + Lisp_Object gstring_in, gstring_out, g; + Lisp_Object alternates; + int i, num; + + if (! font->driver->otf_drive) + error ("Font backend %s can't drive OpenType GSUB table", + SDATA (SYMBOL_NAME (font->driver->type))); + CHECK_CHARACTER (character); + CHECK_CONS (otf_features); + + gstring_in = Ffont_make_gstring (font_object, make_fixnum (1)); + g = LGSTRING_GLYPH (gstring_in, 0); + LGLYPH_SET_CHAR (g, XFIXNUM (character)); + gstring_out = Ffont_make_gstring (font_object, make_fixnum (10)); + while ((num = font->driver->otf_drive (font, otf_features, gstring_in, 0, 1, + gstring_out, 0, 1)) < 0) + gstring_out = Ffont_make_gstring (font_object, + make_fixnum (ASIZE (gstring_out) * 2)); + alternates = Qnil; + for (i = 0; i < num; i++) + { + Lisp_Object g = LGSTRING_GLYPH (gstring_out, i); + int c = LGLYPH_CHAR (g); + unsigned code = LGLYPH_CODE (g); + + alternates = Fcons (Fcons (make_fixnum (code), + c > 0 ? make_fixnum (c) : Qnil), + alternates); + } + return Fnreverse (alternates); +} +#endif /* 0 */ + #ifdef FONT_DEBUG DEFUN ("open-font", Fopen_font, Sopen_font, 1, 3, 0, @@ -4586,6 +4996,47 @@ character at index specified by POSITION. */) return font_at (-1, XFIXNUM (position), NULL, w, string); } +#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. */) + (Lisp_Object font_object, Lisp_Object string) +{ + Lisp_Object frame = selected_frame; + struct frame *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_fixnum (i)); + Lisp_Object val; + int c = XFIXNUM (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_fixnum (len); +} +#endif + DEFUN ("frame-font-cache", Fframe_font_cache, Sframe_font_cache, 0, 1, 0, doc: /* Return FRAME's font cache. Mainly used for debugging. If FRAME is omitted or nil, use the selected frame. */) @@ -4908,6 +5359,13 @@ syms_of_font (void) Vfont_log_deferred = make_nil_vector (3); staticpro (&Vfont_log_deferred); +#if 0 +#ifdef HAVE_LIBOTF + staticpro (&otf_list); + otf_list = Qnil; +#endif /* HAVE_LIBOTF */ +#endif /* 0 */ + defsubr (&Sfontp); defsubr (&Sfont_spec); defsubr (&Sfont_get); @@ -4923,6 +5381,10 @@ syms_of_font (void) defsubr (&Sfont_shape_gstring); defsubr (&Sfont_variation_glyphs); defsubr (&Sinternal_char_font); +#if 0 + defsubr (&Sfont_drive_otf); + defsubr (&Sfont_otf_alternates); +#endif /* 0 */ #ifdef FONT_DEBUG defsubr (&Sopen_font); @@ -4931,6 +5393,9 @@ syms_of_font (void) defsubr (&Sfont_get_glyphs); defsubr (&Sfont_match_p); defsubr (&Sfont_at); +#if 0 + defsubr (&Sdraw_string); +#endif defsubr (&Sframe_font_cache); #endif /* FONT_DEBUG */ #ifdef HAVE_WINDOW_SYSTEM