X-Git-Url: http://git.chise.org/gitweb/?a=blobdiff_plain;f=src%2Fmule-charset.c;h=2db3cbcebfc59250dcea85a408b636e6f39276be;hb=3aca7317dd930beecbddba646284279744087e69;hp=1ca71b194530fcb43f3a8422ad565cd47d70a2ed;hpb=cd308851fe9e867d8fce8673d69e489b83a5d34b;p=chise%2Fxemacs-chise.git-

diff --git a/src/mule-charset.c b/src/mule-charset.c
index 1ca71b1..2db3cbc 100644
--- a/src/mule-charset.c
+++ b/src/mule-charset.c
@@ -421,12 +421,11 @@ put_char_id_table (Emchar ch, Lisp_Object value, Lisp_Object table)
 }
 
 
-Lisp_Object Vcharacter_attribute_table;
-Lisp_Object Vcharacter_name_table;
+Lisp_Object Vchar_attribute_hash_table;
 Lisp_Object Vcharacter_composition_table;
 Lisp_Object Vcharacter_variant_table;
 
-Lisp_Object Qname;
+Lisp_Object Qideograph_daikanwa;
 Lisp_Object Q_decomposition;
 Lisp_Object Qucs;
 Lisp_Object Q_ucs;
@@ -453,12 +452,6 @@ Lisp_Object put_char_ccs_code_point (Lisp_Object character,
 				     Lisp_Object ccs, Lisp_Object value);
 Lisp_Object remove_char_ccs (Lisp_Object character, Lisp_Object ccs);
 
-Lisp_Object put_char_attribute (Lisp_Object character,
-				Lisp_Object attribute, Lisp_Object value);
-Lisp_Object remove_char_attribute (Lisp_Object character,
-				   Lisp_Object attribute);
-
-
 Emchar
 to_char_id (Lisp_Object v, char* err_msg, Lisp_Object err_arg)
 {
@@ -546,14 +539,117 @@ Return variants of CHARACTER.
 					Vcharacter_variant_table));
 }
 
+
+/* We store the char-attributes in hash tables with the names as the
+   key and the actual char-id-table object as the value.  Occasionally
+   we need to use them in a list format.  These routines provide us
+   with that. */
+struct char_attribute_list_closure
+{
+  Lisp_Object *char_attribute_list;
+};
+
+static int
+add_char_attribute_to_list_mapper (Lisp_Object key, Lisp_Object value,
+				   void *char_attribute_list_closure)
+{
+  /* This function can GC */
+  struct char_attribute_list_closure *calcl
+    = (struct char_attribute_list_closure*) char_attribute_list_closure;
+  Lisp_Object *char_attribute_list = calcl->char_attribute_list;
+
+  *char_attribute_list = Fcons (key, *char_attribute_list);
+  return 0;
+}
+
+DEFUN ("char-attribute-list", Fchar_attribute_list, 0, 0, 0, /*
+Return the list of all existing character attributes except coded-charsets.
+*/
+       ())
+{
+  Lisp_Object char_attribute_list = Qnil;
+  struct gcpro gcpro1;
+  struct char_attribute_list_closure char_attribute_list_closure;
+  
+  GCPRO1 (char_attribute_list);
+  char_attribute_list_closure.char_attribute_list = &char_attribute_list;
+  elisp_maphash (add_char_attribute_to_list_mapper,
+		 Vchar_attribute_hash_table,
+		 &char_attribute_list_closure);
+  UNGCPRO;
+  return char_attribute_list;
+}
+
+
+/* We store the char-id-tables in hash tables with the attributes as
+   the key and the actual char-id-table object as the value.  Each
+   char-id-table stores values of an attribute corresponding with
+   characters.  Occasionally we need to get attributes of a character
+   in a association-list format.  These routines provide us with
+   that. */
+struct char_attribute_alist_closure
+{
+  Emchar char_id;
+  Lisp_Object *char_attribute_alist;
+};
+
+static int
+add_char_attribute_alist_mapper (Lisp_Object key, Lisp_Object value,
+				 void *char_attribute_alist_closure)
+{
+  /* This function can GC */
+  struct char_attribute_alist_closure *caacl =
+    (struct char_attribute_alist_closure*) char_attribute_alist_closure;
+  Lisp_Object ret = get_char_id_table (caacl->char_id, value);
+  if (!UNBOUNDP (ret))
+    {
+      Lisp_Object *char_attribute_alist = caacl->char_attribute_alist;
+      *char_attribute_alist
+	= Fcons (Fcons (key, ret), *char_attribute_alist);
+    }
+  return 0;
+}
+
 DEFUN ("char-attribute-alist", Fchar_attribute_alist, 1, 1, 0, /*
 Return the alist of attributes of CHARACTER.
 */
        (character))
 {
+  Lisp_Object alist = Qnil;
+  int i;
+
   CHECK_CHAR (character);
-  return Fcopy_alist (get_char_id_table (XCHAR (character),
-					 Vcharacter_attribute_table));
+  {
+    struct gcpro gcpro1;
+    struct char_attribute_alist_closure char_attribute_alist_closure;
+  
+    GCPRO1 (alist);
+    char_attribute_alist_closure.char_id = XCHAR (character);
+    char_attribute_alist_closure.char_attribute_alist = &alist;
+    elisp_maphash (add_char_attribute_alist_mapper,
+		   Vchar_attribute_hash_table,
+		   &char_attribute_alist_closure);
+    UNGCPRO;
+  }
+
+  for (i = 0; i < countof (chlook->charset_by_leading_byte); i++)
+    {
+      Lisp_Object ccs = chlook->charset_by_leading_byte[i];
+
+      if (!NILP (ccs))
+	{
+	  Lisp_Object encoding_table = XCHARSET_ENCODING_TABLE (ccs);
+	  Lisp_Object cpos;
+
+	  if ( CHAR_ID_TABLE_P (encoding_table)
+	       && INTP (cpos = get_char_id_table (XCHAR (character),
+						  encoding_table)) )
+	    {
+	      alist = Fcons (Fcons (ccs, cpos), alist);
+	    }
+	}
+    }
+  return alist;
 }
 
 DEFUN ("get-char-attribute", Fget_char_attribute, 2, 2, 0, /*
@@ -573,20 +669,19 @@ Return the value of CHARACTER's ATTRIBUTE.
       else
 	return Qnil;
     }
-  else if (EQ (attribute, Qname))
-    {
-      return get_char_id_table (XCHAR (character), Vcharacter_name_table);
-    }
   else
     {
-      Lisp_Object ret
-	= get_char_id_table (XCHAR (character), Vcharacter_attribute_table);
-
-      if (EQ (ret, Qnil))
-	return Qnil;
-      else
-	return Fcdr (Fassq (attribute, ret));
+      Lisp_Object table = Fgethash (attribute,
+				    Vchar_attribute_hash_table,
+				    Qunbound);
+      if (!UNBOUNDP (table))
+	{
+	  Lisp_Object ret = get_char_id_table (XCHAR (character), table);
+	  if (!UNBOUNDP (ret))
+	    return ret;
+	}
     }
+  return Qnil;
 }
 
 DEFUN ("put-char-attribute", Fput_char_attribute, 3, 3, 0, /*
@@ -602,14 +697,10 @@ Store CHARACTER's ATTRIBUTE with VALUE.
     {
       return put_char_ccs_code_point (character, ccs, value);
     }
-  else if (EQ (attribute, Qname))
-    {
-      CHECK_STRING (value);
-      put_char_id_table (XCHAR (character), value, Vcharacter_name_table);
-      return value;
-    }
   else if (EQ (attribute, Q_decomposition))
     {
+      Lisp_Object seq;
+
       if (!CONSP (value))
 	signal_simple_error ("Invalid value for ->decomposition",
 			     value);
@@ -618,6 +709,11 @@ Store CHARACTER's ATTRIBUTE with VALUE.
 	{
 	  Lisp_Object rest = value;
 	  Lisp_Object table = Vcharacter_composition_table;
+	  size_t len;
+	  int i = 0;
+
+	  GET_EXTERNAL_LIST_LENGTH (rest, len);
+	  seq = make_vector (len, Qnil);
 
 	  while (CONSP (rest))
 	    {
@@ -626,6 +722,10 @@ Store CHARACTER's ATTRIBUTE with VALUE.
 	      Emchar c
 		= to_char_id (v, "Invalid value for ->decomposition", value);
 
+	      if (c < 0)
+		XVECTOR_DATA(seq)[i++] = v;
+	      else
+		XVECTOR_DATA(seq)[i++] = make_char (c);
 	      rest = Fcdr (rest);
 	      if (!CONSP (rest))
 		{
@@ -661,7 +761,9 @@ Store CHARACTER's ATTRIBUTE with VALUE.
 				     Vcharacter_variant_table);
 		}
 	    }
+	  seq = make_vector (1, v);
 	}
+      value = seq;
     }
   else if (EQ (attribute, Q_ucs))
     {
@@ -680,7 +782,19 @@ Store CHARACTER's ATTRIBUTE with VALUE.
 			     Vcharacter_variant_table);
 	}
     }
-  return put_char_attribute (character, attribute, value);
+  {
+    Lisp_Object table = Fgethash (attribute,
+				  Vchar_attribute_hash_table,
+				  Qnil);
+
+    if (NILP (table))
+      {
+	table = make_char_id_table (Qunbound, 0);
+	Fputhash (attribute, table, Vchar_attribute_hash_table);
+      }
+    put_char_id_table (XCHAR (character), value, table);
+    return value;
+  }
 }
   
 DEFUN ("remove-char-attribute", Fremove_char_attribute, 2, 2, 0, /*
@@ -696,7 +810,18 @@ Remove CHARACTER's ATTRIBUTE.
     {
       return remove_char_ccs (character, ccs);
     }
-  return remove_char_attribute (character, attribute);
+  else
+    {
+      Lisp_Object table = Fgethash (attribute,
+				    Vchar_attribute_hash_table,
+				    Qunbound);
+      if (!UNBOUNDP (table))
+	{
+	  put_char_id_table (XCHAR (character), Qunbound, table);
+	  return Qt;
+	}
+    }
+  return Qnil;
 }
 
 INLINE_HEADER int CHARSET_BYTE_SIZE (Lisp_Charset* cs);
@@ -713,6 +838,34 @@ CHARSET_BYTE_SIZE (Lisp_Charset* cs)
 
 #define XCHARSET_BYTE_SIZE(ccs)	CHARSET_BYTE_SIZE (XCHARSET (ccs))
 
+int decoding_table_check_elements (Lisp_Object v, int dim, int ccs_len);
+int
+decoding_table_check_elements (Lisp_Object v, int dim, int ccs_len)
+{
+  int i;
+
+  if (XVECTOR_LENGTH (v) > ccs_len)
+    return -1;
+
+  for (i = 0; i < XVECTOR_LENGTH (v); i++)
+    {
+      Lisp_Object c = XVECTOR_DATA(v)[i];
+
+      if (!NILP (c) && !CHARP (c))
+	{
+	  if (VECTORP (c))
+	    {
+	      int ret = decoding_table_check_elements (c, dim - 1, ccs_len);
+	      if (ret)
+		return ret;
+	    }
+	  else
+	    return -2;
+	}
+    }
+  return 0;
+}
+
 INLINE_HEADER void
 decoding_table_remove_char (Lisp_Object v, int dim, int byte_offset,
 			    int code_point);
@@ -872,58 +1025,6 @@ remove_char_ccs (Lisp_Object character, Lisp_Object ccs)
   return Qt;
 }
 
-Lisp_Object
-put_char_attribute (Lisp_Object character, Lisp_Object attribute,
-		    Lisp_Object value)
-{
-  Emchar char_id = XCHAR (character);
-  Lisp_Object ret = get_char_id_table (char_id, Vcharacter_attribute_table);
-  Lisp_Object cell;
-
-  cell = Fassq (attribute, ret);
-
-  if (NILP (cell))
-    {
-      ret = Fcons (Fcons (attribute, value), ret);
-    }
-  else if (!EQ (Fcdr (cell), value))
-    {
-      Fsetcdr (cell, value);
-    }
-  put_char_id_table (char_id, ret, Vcharacter_attribute_table);
-  return ret;
-}
-
-Lisp_Object
-remove_char_attribute (Lisp_Object character, Lisp_Object attribute)
-{
-  Emchar char_id = XCHAR (character);
-  Lisp_Object alist = get_char_id_table (char_id, Vcharacter_attribute_table);
-
-  if (EQ (attribute, Fcar (Fcar (alist))))
-    {
-      alist = Fcdr (alist);
-    }
-  else
-    {
-      Lisp_Object pr = alist;
-      Lisp_Object r = Fcdr (alist);
-
-      while (!NILP (r))
-	{
-	  if (EQ (attribute, Fcar (Fcar (r))))
-	    {
-	      XCDR (pr) = Fcdr (r);
-	      break;
-	    }
-	  pr = r;
-	  r = Fcdr (r);
-	}
-    }
-  put_char_id_table (char_id, alist, Vcharacter_attribute_table);
-  return alist;
-}
-
 EXFUN (Fmake_char, 3);
 EXFUN (Fdecode_char, 2);
 
@@ -935,6 +1036,9 @@ Store character's ATTRIBUTES.
   Lisp_Object rest = attributes;
   Lisp_Object code = Fcdr (Fassq (Qucs, attributes));
   Lisp_Object character;
+#if 0
+  Lisp_Object daikanwa = Qnil;
+#endif
 
   if (NILP (code))
     {
@@ -978,14 +1082,39 @@ Store character's ATTRIBUTES.
   while (CONSP (rest))
     {
       Lisp_Object cell = Fcar (rest);
+#if 0
+      Lisp_Object key = Fcar (cell);
+      Lisp_Object value = Fcdr (cell);
+#endif
 
       if (!LISTP (cell))
 	signal_simple_error ("Invalid argument", attributes);
+
+#if 0
+      if (EQ (key, Qmorohashi_daikanwa))
+	{
+	  size_t len;
+	  GET_EXTERNAL_LIST_LENGTH (value, len);
+
+	  if (len == 1)
+	    {
+	      if (NILP (daikanwa))
+		daikanwa = Fcdr (Fassq (Qideograph_daikanwa, rest));
+	      if (EQ (Fcar (value), daikanwa))
+		goto ignored;
+	    }
+	}
+      else if (EQ (key, Qideograph_daikanwa))
+	daikanwa = value;
+#endif
+
       Fput_char_attribute (character, Fcar (cell), Fcdr (cell));
+#if 0
+    ignored:
+#endif
       rest = Fcdr (rest);
     }
-  return
-    get_char_id_table (XCHAR (character), Vcharacter_attribute_table);
+  return character;
 }
 
 Lisp_Object Vutf_2000_version;
@@ -1034,7 +1163,6 @@ Lisp_Object Qascii,
   Qlatin_viscii_upper,
   Qvietnamese_viscii_lower,
   Qvietnamese_viscii_upper,
-  Qideograph_daikanwa,
   Qmojikyo,
   Qmojikyo_pj_1,
   Qmojikyo_pj_2,
@@ -1996,7 +2124,7 @@ add_charset_to_list_mapper (Lisp_Object key, Lisp_Object value,
     (struct charset_list_closure*) charset_list_closure;
   Lisp_Object *charset_list = chcl->charset_list;
 
-  *charset_list = Fcons (XCHARSET_NAME (value), *charset_list);
+  *charset_list = Fcons (key /* XCHARSET_NAME (value) */, *charset_list);
   return 0;
 }
 
@@ -2505,32 +2633,42 @@ Set mapping-table of CHARSET to TABLE.
        (charset, table))
 {
   struct Lisp_Charset *cs;
-  Lisp_Object old_table;
   size_t i;
+  int byte_offset;
 
   charset = Fget_charset (charset);
   cs = XCHARSET (charset);
 
-  if (EQ (table, Qnil))
+  if (NILP (table))
     {
-      CHARSET_DECODING_TABLE(cs) = table;
+      if (VECTORP (CHARSET_DECODING_TABLE(cs)))
+	make_vector_newer (CHARSET_DECODING_TABLE(cs));
+      CHARSET_DECODING_TABLE(cs) = Qnil;
       return table;
     }
   else if (VECTORP (table))
     {
       int ccs_len = CHARSET_BYTE_SIZE (cs);
-
-      if (XVECTOR_LENGTH (table) > ccs_len)
-	args_out_of_range (table, make_int (CHARSET_CHARS (cs)));
-      old_table = CHARSET_DECODING_TABLE(cs);
-      CHARSET_DECODING_TABLE(cs) = table;
+      int ret = decoding_table_check_elements (table,
+					       CHARSET_DIMENSION (cs),
+					       ccs_len);
+      if (ret)
+	{
+	  if (ret == -1)
+	    signal_simple_error ("Too big table", table);
+	  else if (ret == -2)
+	    signal_simple_error ("Invalid element is found", table);
+	  else
+	    signal_simple_error ("Something wrong", table);
+	}
+      CHARSET_DECODING_TABLE(cs) = Qnil;
     }
   else
     signal_error (Qwrong_type_argument,
 		  list2 (build_translated_string ("vector-or-nil-p"),
 			 table));
-  /* signal_simple_error ("Wrong type argument: vector-or-nil-p", table); */
 
+  byte_offset = CHARSET_BYTE_OFFSET (cs);
   switch (CHARSET_DIMENSION (cs))
     {
     case 1:
@@ -2539,9 +2677,8 @@ Set mapping-table of CHARSET to TABLE.
 	  Lisp_Object c = XVECTOR_DATA(table)[i];
 
 	  if (CHARP (c))
-	    put_char_attribute
-	      (c, charset,
-	       make_int (i + CHARSET_BYTE_OFFSET (cs)));
+	    put_char_ccs_code_point (c, charset,
+				     make_int (i + byte_offset));
 	}
       break;
     case 2:
@@ -2553,25 +2690,21 @@ Set mapping-table of CHARSET to TABLE.
 	    {
 	      size_t j;
 
-	      if (XVECTOR_LENGTH (v) > CHARSET_CHARS (cs))
-		{
-		  CHARSET_DECODING_TABLE(cs) = old_table;
-		  args_out_of_range (v, make_int (CHARSET_CHARS (cs)));
-		}
 	      for (j = 0; j < XVECTOR_LENGTH (v); j++)
 		{
 		  Lisp_Object c = XVECTOR_DATA(v)[j];
 
 		  if (CHARP (c))
-		    put_char_attribute
+		    put_char_ccs_code_point
 		      (c, charset,
-		       make_int ( ((i + CHARSET_BYTE_OFFSET (cs)) << 8)
-				  | (j + CHARSET_BYTE_OFFSET (cs)) ));
+		       make_int ( ( (i + byte_offset) << 8 )
+				  | (j + byte_offset)
+				  ) );
 		}
 	    }
 	  else if (CHARP (v))
-	    put_char_attribute (v, charset,
-				make_int (i + CHARSET_BYTE_OFFSET (cs)));
+	    put_char_ccs_code_point (v, charset,
+				     make_int (i + byte_offset));
 	}
       break;
     }
@@ -2599,6 +2732,77 @@ Make a character from CHARSET and code-point CODE.
     c &= 0x7F7F7F7F;
   return make_char (DECODE_CHAR (charset, c));
 }
+
+DEFUN ("decode-builtin-char", Fdecode_builtin_char, 2, 2, 0, /*
+Make a builtin character from CHARSET and code-point CODE.
+*/
+       (charset, code))
+{
+  int c;
+  int final;
+
+  charset = Fget_charset (charset);
+  CHECK_INT (code);
+  c = XINT (code);
+
+  if ((final = XCHARSET_FINAL (charset)) >= '0')
+    {
+      if (XCHARSET_DIMENSION (charset) == 1)
+	{
+	  switch (XCHARSET_CHARS (charset))
+	    {
+	    case 94:
+	      return
+		make_char (MIN_CHAR_94 + (final - '0') * 94
+			   + ((c & 0x7F) - 33));
+	    case 96:
+	      return
+		make_char (MIN_CHAR_96 + (final - '0') * 96
+			   + ((c & 0x7F) - 32));
+	    default:
+	      return Fdecode_char (charset, code);
+	    }
+	}
+      else
+	{
+	  switch (XCHARSET_CHARS (charset))
+	    {
+	    case 94:
+	      return
+		make_char (MIN_CHAR_94x94
+			   + (final - '0') * 94 * 94
+			   + (((c >> 8) & 0x7F) - 33) * 94
+			   + ((c & 0x7F) - 33));
+	    case 96:
+	      return
+		make_char (MIN_CHAR_96x96
+			   + (final - '0') * 96 * 96
+			   + (((c >> 8) & 0x7F) - 32) * 96
+			   + ((c & 0x7F) - 32));
+	    default:
+	      return Fdecode_char (charset, code);
+	    }
+	}
+    }
+  else if (XCHARSET_UCS_MAX (charset))
+    {
+      Emchar cid
+	= (XCHARSET_DIMENSION (charset) == 1
+	   ?
+	   c - XCHARSET_BYTE_OFFSET (charset)
+	   :
+	   ((c >> 8) - XCHARSET_BYTE_OFFSET (charset))
+	   * XCHARSET_CHARS (charset)
+	   + (c & 0xFF) - XCHARSET_BYTE_OFFSET (charset))
+	- XCHARSET_CODE_OFFSET (charset) + XCHARSET_UCS_MIN (charset);
+      if ((cid < XCHARSET_UCS_MIN (charset))
+	  || (XCHARSET_UCS_MAX (charset) < cid))
+	return Fdecode_char (charset, code);
+      return make_char (cid);
+    }
+  else
+    return Fdecode_char (charset, code);
+}
 #endif
 
 DEFUN ("make-char", Fmake_char, 2, 3, 0, /*
@@ -2845,6 +3049,7 @@ syms_of_mule_charset (void)
   DEFSUBR (Fset_charset_ccl_program);
   DEFSUBR (Fset_charset_registry);
 #ifdef UTF2000
+  DEFSUBR (Fchar_attribute_list);
   DEFSUBR (Fchar_attribute_alist);
   DEFSUBR (Fget_char_attribute);
   DEFSUBR (Fput_char_attribute);
@@ -2858,6 +3063,7 @@ syms_of_mule_charset (void)
 
 #ifdef UTF2000
   DEFSUBR (Fdecode_char);
+  DEFSUBR (Fdecode_builtin_char);
 #endif
   DEFSUBR (Fmake_char);
   DEFSUBR (Fchar_charset);
@@ -2906,7 +3112,6 @@ syms_of_mule_charset (void)
   defsymbol (&Qchinese_cns11643_1,	"chinese-cns11643-1");
   defsymbol (&Qchinese_cns11643_2,	"chinese-cns11643-2");
 #ifdef UTF2000
-  defsymbol (&Qname,			"name");
   defsymbol (&Q_ucs,			"->ucs");
   defsymbol (&Q_decomposition,		"->decomposition");
   defsymbol (&Qcompat,			"compat");
@@ -3008,18 +3213,12 @@ Leading-code of private TYPE9N charset of column-width 1.
 #endif
 
 #ifdef UTF2000
-  Vutf_2000_version = build_string("0.15 (Sangō)");
+  Vutf_2000_version = build_string("0.16 (Ōji)");
   DEFVAR_LISP ("utf-2000-version", &Vutf_2000_version /*
 Version number of UTF-2000.
 */ );
 
-  staticpro (&Vcharacter_attribute_table);
-  Vcharacter_attribute_table = make_char_id_table (Qnil, 0);
-
-  staticpro (&Vcharacter_name_table);
-  Vcharacter_name_table = make_char_id_table (Qnil, 0);
-
-  /* staticpro (&Vcharacter_composition_table); */
+  staticpro (&Vcharacter_composition_table);
   Vcharacter_composition_table = make_char_id_table (Qnil, -1);
 
   staticpro (&Vcharacter_variant_table);
@@ -3044,6 +3243,10 @@ complex_vars_of_mule_charset (void)
      ease of access. */
 
 #ifdef UTF2000
+  staticpro (&Vchar_attribute_hash_table);
+  Vchar_attribute_hash_table
+    = make_lisp_hash_table (16, HASH_TABLE_NON_WEAK, HASH_TABLE_EQ);
+
   staticpro (&Vcharset_ucs);
   Vcharset_ucs =
     make_charset (LEADING_BYTE_UCS, Qucs, 256, 4,