[Emacs-diffs] master 5ae407a: Revert "Remove font.c code commented out for a decade"

[Eli Zaretskii]

branch: master
commit 5ae407aad4f2564fae7ddce077eb01aa8efa37fb
Author: Eli Zaretskii <address@hidden>
Commit: Eli Zaretskii <address@hidden>

    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.
---
 src/font.c | 465 +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
 1 file changed, 465 insertions(+)

diff --git a/src/font.c b/src/font.c
index e7686cf..5ca89c9 100644
--- a/src/font.c
+++ b/src/font.c
@@ -1786,6 +1786,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 <otf.h>
+
+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.  */
 
 static double
@@ -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