(C6-6267): Delete M-36791.
[chise/xemacs-chise.git] / src / mule-charset.c
index 4626e60..9ab731d 100644 (file)
@@ -67,6 +67,7 @@ Lisp_Object Vcharset_chinese_cns11643_2;
 Lisp_Object Vcharset_ucs;
 Lisp_Object Vcharset_ucs_bmp;
 Lisp_Object Vcharset_ucs_cns;
+Lisp_Object Vcharset_ucs_jis;
 Lisp_Object Vcharset_ucs_big5;
 Lisp_Object Vcharset_latin_viscii;
 Lisp_Object Vcharset_latin_tcvn5712;
@@ -343,6 +344,29 @@ uint8_byte_table_same_value_p (Lisp_Object obj)
   return -1;
 }
 
+static int
+map_over_uint8_byte_table (Lisp_Uint8_Byte_Table *ct,
+                          int (*fn) (Emchar c, Lisp_Object val, void *arg),
+                          void *arg, Emchar ofs, int place)
+{
+  int i, retval;
+  int unit = 1 << (8 * place);
+  Emchar c = ofs;
+  Emchar c1;
+
+  for (i = 0, retval = 0; i < 256 && retval == 0; i++)
+    {
+      if (ct->property[i] != BT_UINT8_unbound)
+       {
+         c1 = c + unit;
+         for (; c < c1 && retval == 0; c++)
+           retval = (fn) (c, UINT8_DECODE (ct->property[i]), arg);
+       }
+      else
+       c += unit;
+    }
+  return retval;
+}
 
 #define BT_UINT16_MIN          0
 #define BT_UINT16_MAX   (USHRT_MAX - 3)
@@ -537,6 +561,30 @@ uint16_byte_table_same_value_p (Lisp_Object obj)
   return -1;
 }
 
+static int
+map_over_uint16_byte_table (Lisp_Uint16_Byte_Table *ct,
+                           int (*fn) (Emchar c, Lisp_Object val, void *arg),
+                           void *arg, Emchar ofs, int place)
+{
+  int i, retval;
+  int unit = 1 << (8 * place);
+  Emchar c = ofs;
+  Emchar c1;
+
+  for (i = 0, retval = 0; i < 256 && retval == 0; i++)
+    {
+      if (ct->property[i] != BT_UINT16_unbound)
+       {
+         c1 = c + unit;
+         for (; c < c1 && retval == 0; c++)
+           retval = (fn) (c, UINT16_DECODE (ct->property[i]), arg);
+       }
+      else
+       c += unit;
+    }
+  return retval;
+}
+
 
 static Lisp_Object
 mark_byte_table (Lisp_Object obj)
@@ -652,6 +700,52 @@ byte_table_same_value_p (Lisp_Object obj)
   return -1;
 }
 
+static int
+map_over_byte_table (Lisp_Byte_Table *ct,
+                    int (*fn) (Emchar c, Lisp_Object val, void *arg),
+                    void *arg, Emchar ofs, int place)
+{
+  int i, retval;
+  Lisp_Object v;
+  int unit = 1 << (8 * place);
+  Emchar c = ofs;
+
+  for (i = 0, retval = 0; i < 256 && retval == 0; i++)
+    {
+      v = ct->property[i];
+      if (UINT8_BYTE_TABLE_P (v))
+       {
+         retval
+           = map_over_uint8_byte_table (XUINT8_BYTE_TABLE(v),
+                                        fn, arg, c, place - 1);
+         c += unit;
+       }
+      else if (UINT16_BYTE_TABLE_P (v))
+       {
+         retval
+           = map_over_uint16_byte_table (XUINT16_BYTE_TABLE(v),
+                                         fn, arg, c, place - 1);
+         c += unit;
+       }
+      else if (BYTE_TABLE_P (v))
+       {
+         retval = map_over_byte_table (XBYTE_TABLE(v),
+                                       fn, arg, c, place - 1);
+         c += unit;
+       }
+      else if (!UNBOUNDP (v))
+       {
+         Emchar c1 = c + unit;
+
+         for (; c < c1 && retval == 0; c++)
+           retval = (fn) (c, v, arg);
+       }
+      else
+       c += unit;
+    }
+  return retval;
+}
+
 
 Lisp_Object get_byte_table (Lisp_Object table, unsigned char idx);
 Lisp_Object put_byte_table (Lisp_Object table, unsigned char idx,
@@ -881,6 +975,55 @@ put_char_id_table (Emchar ch, Lisp_Object value, Lisp_Object table)
     = put_byte_table (table1, (unsigned char)(code >> 24), table2);
 }
 
+/* Map FN (with client data ARG) in char table CT.
+   Mapping stops the first time FN returns non-zero, and that value
+   becomes the return value of map_char_id_table(). */
+int
+map_char_id_table (Lisp_Char_ID_Table *ct,
+                  int (*fn) (Emchar c, Lisp_Object val, void *arg),
+                  void *arg);
+int
+map_char_id_table (Lisp_Char_ID_Table *ct,
+                  int (*fn) (Emchar c, Lisp_Object val, void *arg),
+                  void *arg)
+{
+  Lisp_Object v = ct->table;
+
+  if (UINT8_BYTE_TABLE_P (v))
+    return map_over_uint8_byte_table (XUINT8_BYTE_TABLE(v), fn, arg, 0, 3);
+  else if (UINT16_BYTE_TABLE_P (v))
+    return map_over_uint16_byte_table (XUINT16_BYTE_TABLE(v), fn, arg, 0, 3);
+  else if (BYTE_TABLE_P (v))
+    return map_over_byte_table (XBYTE_TABLE(v), fn, arg, 0, 3);
+  else if (!UNBOUNDP (v))
+    {
+      int unit = 1 << 24;
+      Emchar c = 0;
+      Emchar c1 = c + unit;
+      int retval;
+
+      for (retval = 0; c < c1 && retval == 0; c++)
+       retval = (fn) (c, v, arg);
+    }
+  return 0;
+}
+
+struct slow_map_char_id_table_arg
+{
+  Lisp_Object function;
+  Lisp_Object retval;
+};
+
+static int
+slow_map_char_id_table_fun (Emchar c, Lisp_Object val, void *arg)
+{
+  struct slow_map_char_id_table_arg *closure =
+    (struct slow_map_char_id_table_arg *) arg;
+
+  closure->retval = call2 (closure->function, make_char (c), val);
+  return !NILP (closure->retval);
+}
+
 
 Lisp_Object Vchar_attribute_hash_table;
 Lisp_Object Vcharacter_composition_table;
@@ -1296,6 +1439,45 @@ Remove CHARACTER's ATTRIBUTE.
   return Qnil;
 }
 
+DEFUN ("map-char-attribute", Fmap_char_attribute, 2, 2, 0, /*
+Map FUNCTION over entries in ATTRIBUTE, calling it with two args,
+each key and value in the table.
+*/
+       (function, attribute))
+{
+  Lisp_Object ccs;
+  Lisp_Char_ID_Table *ct;
+  struct slow_map_char_id_table_arg slarg;
+  struct gcpro gcpro1, gcpro2;
+
+  if (!NILP (ccs = Ffind_charset (attribute)))
+    {
+      Lisp_Object encoding_table = XCHARSET_ENCODING_TABLE (ccs);
+
+      if (CHAR_ID_TABLE_P (encoding_table))
+       ct = XCHAR_ID_TABLE (encoding_table);
+      else
+       return Qnil;
+    }
+  else
+    {
+      Lisp_Object table = Fgethash (attribute,
+                                   Vchar_attribute_hash_table,
+                                   Qunbound);
+      if (CHAR_ID_TABLE_P (table))
+       ct = XCHAR_ID_TABLE (table);
+      else
+       return Qnil;
+    }
+  slarg.function = function;
+  slarg.retval = Qnil;
+  GCPRO2 (slarg.function, slarg.retval);
+  map_char_id_table (ct, slow_map_char_id_table_fun, &slarg);
+  UNGCPRO;
+
+  return slarg.retval;
+}
+
 INLINE_HEADER int CHARSET_BYTE_SIZE (Lisp_Charset* cs);
 INLINE_HEADER int
 CHARSET_BYTE_SIZE (Lisp_Charset* cs)
@@ -1642,6 +1824,7 @@ Lisp_Object Qascii,
 #ifdef UTF2000
   Qucs_bmp,
   Qucs_cns,
+  Qucs_jis,
   Qucs_big5,
   Qlatin_viscii,
   Qlatin_tcvn5712,
@@ -3497,6 +3680,7 @@ syms_of_mule_charset (void)
   DEFSUBR (Fget_char_attribute);
   DEFSUBR (Fput_char_attribute);
   DEFSUBR (Fremove_char_attribute);
+  DEFSUBR (Fmap_char_attribute);
   DEFSUBR (Fdefine_char);
   DEFSUBR (Ffind_char);
   DEFSUBR (Fchar_variants);
@@ -3579,6 +3763,7 @@ syms_of_mule_charset (void)
   defsymbol (&Qucs,                    "ucs");
   defsymbol (&Qucs_bmp,                        "ucs-bmp");
   defsymbol (&Qucs_cns,                        "ucs-cns");
+  defsymbol (&Qucs_jis,                        "ucs-jis");
   defsymbol (&Qucs_big5,               "ucs-big5");
   defsymbol (&Qlatin_viscii,           "latin-viscii");
   defsymbol (&Qlatin_tcvn5712,         "latin-tcvn5712");
@@ -3640,8 +3825,8 @@ vars_of_mule_charset (void)
   int k;
 #endif
 
-  chlook = xnew (struct charset_lookup);
-  dumpstruct (&chlook, &charset_lookup_description);
+  chlook = xnew_and_zero (struct charset_lookup); /* zero for Purify. */
+  dump_add_root_struct_ptr (&chlook, &charset_lookup_description);
 
   /* Table of charsets indexed by leading byte. */
   for (i = 0; i < countof (chlook->charset_by_leading_byte); i++)
@@ -3737,6 +3922,15 @@ complex_vars_of_mule_charset (void)
                  build_string ("ISO/IEC 10646 for CNS 11643"),
                  build_string (""),
                  Qnil, 0, 0, 0, 0);
+  staticpro (&Vcharset_ucs_jis);
+  Vcharset_ucs_jis =
+    make_charset (LEADING_BYTE_UCS_JIS, Qucs_jis, 256, 3,
+                 1, 2, 0, CHARSET_LEFT_TO_RIGHT,
+                 build_string ("UCS for JIS"),
+                 build_string ("UCS for JIS X 0208, 0212 and 0213"),
+                 build_string ("ISO/IEC 10646 for JIS X 0208, 0212 and 0213"),
+                 build_string (""),
+                 Qnil, 0, 0, 0, 0);
   staticpro (&Vcharset_ucs_big5);
   Vcharset_ucs_big5 =
     make_charset (LEADING_BYTE_UCS_BIG5, Qucs_big5, 256, 3,