+#if defined(MULE)&&!defined(UTF2000)
+
+static Lisp_Object
+make_char_table_entry (Lisp_Object initval)
+{
+ Lisp_Object obj;
+ int i;
+ Lisp_Char_Table_Entry *cte =
+ alloc_lcrecord_type (Lisp_Char_Table_Entry, &lrecord_char_table_entry);
+
+ for (i = 0; i < 96; i++)
+ cte->level2[i] = initval;
+
+ XSETCHAR_TABLE_ENTRY (obj, cte);
+ return obj;
+}
+
+static Lisp_Object
+copy_char_table_entry (Lisp_Object entry)
+{
+ Lisp_Char_Table_Entry *cte = XCHAR_TABLE_ENTRY (entry);
+ Lisp_Object obj;
+ int i;
+ Lisp_Char_Table_Entry *ctenew =
+ alloc_lcrecord_type (Lisp_Char_Table_Entry, &lrecord_char_table_entry);
+
+ for (i = 0; i < 96; i++)
+ {
+ Lisp_Object new = cte->level2[i];
+ if (CHAR_TABLE_ENTRYP (new))
+ ctenew->level2[i] = copy_char_table_entry (new);
+ else
+ ctenew->level2[i] = new;
+ }
+
+ XSETCHAR_TABLE_ENTRY (obj, ctenew);
+ return obj;
+}
+
+#endif /* MULE */
+
+DEFUN ("copy-char-table", Fcopy_char_table, 1, 1, 0, /*
+Return a new char table which is a copy of CHAR-TABLE.
+It will contain the same values for the same characters and ranges
+as CHAR-TABLE. The values will not themselves be copied.
+*/
+ (char_table))
+{
+ Lisp_Char_Table *ct, *ctnew;
+ Lisp_Object obj;
+#ifndef UTF2000
+ int i;
+#endif
+
+ CHECK_CHAR_TABLE (char_table);
+ ct = XCHAR_TABLE (char_table);
+ ctnew = alloc_lcrecord_type (Lisp_Char_Table, &lrecord_char_table);
+ ctnew->type = ct->type;
+#ifdef UTF2000
+ ctnew->default_value = ct->default_value;
+
+ if (UINT8_BYTE_TABLE_P (ct->table))
+ {
+ ctnew->table = copy_uint8_byte_table (ct->table);
+ }
+ else if (UINT16_BYTE_TABLE_P (ct->table))
+ {
+ ctnew->table = copy_uint16_byte_table (ct->table);
+ }
+ else if (BYTE_TABLE_P (ct->table))
+ {
+ ctnew->table = copy_byte_table (ct->table);
+ }
+ else if (!UNBOUNDP (ct->table))
+ ctnew->table = ct->table;
+#else /* non UTF2000 */
+
+ for (i = 0; i < NUM_ASCII_CHARS; i++)
+ {
+ Lisp_Object new = ct->ascii[i];
+#ifdef MULE
+ assert (! (CHAR_TABLE_ENTRYP (new)));
+#endif /* MULE */
+ ctnew->ascii[i] = new;
+ }
+
+#ifdef MULE
+
+ for (i = 0; i < NUM_LEADING_BYTES; i++)
+ {
+ Lisp_Object new = ct->level1[i];
+ if (CHAR_TABLE_ENTRYP (new))
+ ctnew->level1[i] = copy_char_table_entry (new);
+ else
+ ctnew->level1[i] = new;
+ }
+
+#endif /* MULE */
+#endif /* non UTF2000 */
+
+#ifndef UTF2000
+ if (CHAR_TABLEP (ct->mirror_table))
+ ctnew->mirror_table = Fcopy_char_table (ct->mirror_table);
+ else
+ ctnew->mirror_table = ct->mirror_table;
+#endif
+ ctnew->next_table = Qnil;
+ XSETCHAR_TABLE (obj, ctnew);
+ if (ctnew->type == CHAR_TABLE_TYPE_SYNTAX)
+ {
+ ctnew->next_table = Vall_syntax_tables;
+ Vall_syntax_tables = obj;
+ }
+ return obj;
+}
+
+INLINE_HEADER int XCHARSET_CELL_RANGE (Lisp_Object ccs);
+INLINE_HEADER int
+XCHARSET_CELL_RANGE (Lisp_Object ccs)
+{
+ switch (XCHARSET_CHARS (ccs))
+ {
+ case 94:
+ return (33 << 8) | 126;
+ case 96:
+ return (32 << 8) | 127;
+#ifdef UTF2000
+ case 128:
+ return (0 << 8) | 127;
+ case 256:
+ return (0 << 8) | 255;
+#endif
+ default:
+ abort ();
+ return 0;
+ }
+}
+
+#ifndef UTF2000
+static
+#endif
+void
+decode_char_table_range (Lisp_Object range, struct chartab_range *outrange)
+{
+ if (EQ (range, Qt))
+ outrange->type = CHARTAB_RANGE_ALL;
+ else if (EQ (range, Qnil))
+ outrange->type = CHARTAB_RANGE_DEFAULT;
+ else if (CHAR_OR_CHAR_INTP (range))
+ {
+ outrange->type = CHARTAB_RANGE_CHAR;
+ outrange->ch = XCHAR_OR_CHAR_INT (range);
+ }
+#ifndef MULE
+ else
+ signal_simple_error ("Range must be t or a character", range);
+#else /* MULE */
+ else if (VECTORP (range))
+ {
+ Lisp_Vector *vec = XVECTOR (range);
+ Lisp_Object *elts = vector_data (vec);
+ int cell_min, cell_max;
+
+ outrange->type = CHARTAB_RANGE_ROW;
+ outrange->charset = Fget_charset (elts[0]);
+ CHECK_INT (elts[1]);
+ outrange->row = XINT (elts[1]);
+ if (XCHARSET_DIMENSION (outrange->charset) < 2)
+ signal_simple_error ("Charset in row vector must be multi-byte",
+ outrange->charset);
+ else
+ {
+ int ret = XCHARSET_CELL_RANGE (outrange->charset);
+
+ cell_min = ret >> 8;
+ cell_max = ret & 0xFF;
+ }
+ if (XCHARSET_DIMENSION (outrange->charset) == 2)
+ check_int_range (outrange->row, cell_min, cell_max);
+#ifdef UTF2000
+ else if (XCHARSET_DIMENSION (outrange->charset) == 3)
+ {
+ check_int_range (outrange->row >> 8 , cell_min, cell_max);
+ check_int_range (outrange->row & 0xFF, cell_min, cell_max);
+ }
+ else if (XCHARSET_DIMENSION (outrange->charset) == 4)
+ {
+ check_int_range ( outrange->row >> 16 , cell_min, cell_max);
+ check_int_range ((outrange->row >> 8) & 0xFF, cell_min, cell_max);
+ check_int_range ( outrange->row & 0xFF, cell_min, cell_max);
+ }
+#endif
+ else
+ abort ();
+ }
+ else
+ {
+ if (!CHARSETP (range) && !SYMBOLP (range))
+ signal_simple_error
+ ("Char table range must be t, charset, char, or vector", range);
+ outrange->type = CHARTAB_RANGE_CHARSET;
+ outrange->charset = Fget_charset (range);
+ }
+#endif /* MULE */
+}
+
+#if defined(MULE)&&!defined(UTF2000)
+
+/* called from CHAR_TABLE_VALUE(). */
+Lisp_Object
+get_non_ascii_char_table_value (Lisp_Char_Table *ct, Charset_ID leading_byte,
+ Emchar c)
+{
+ Lisp_Object val;
+#ifdef UTF2000
+ Lisp_Object charset;
+#else
+ Lisp_Object charset = CHARSET_BY_LEADING_BYTE (leading_byte);
+#endif
+ int byte1, byte2;
+
+#ifdef UTF2000
+ BREAKUP_CHAR (c, charset, byte1, byte2);
+#else
+ BREAKUP_CHAR_1_UNSAFE (c, charset, byte1, byte2);
+#endif
+ val = ct->level1[leading_byte - MIN_LEADING_BYTE];
+ if (CHAR_TABLE_ENTRYP (val))
+ {
+ Lisp_Char_Table_Entry *cte = XCHAR_TABLE_ENTRY (val);
+ val = cte->level2[byte1 - 32];
+ if (CHAR_TABLE_ENTRYP (val))
+ {
+ cte = XCHAR_TABLE_ENTRY (val);
+ assert (byte2 >= 32);
+ val = cte->level2[byte2 - 32];
+ assert (!CHAR_TABLE_ENTRYP (val));
+ }
+ }
+
+ return val;
+}
+
+#endif /* MULE */
+
+Lisp_Object
+get_char_table (Emchar ch, Lisp_Char_Table *ct)
+{
+#ifdef UTF2000
+ return get_char_id_table (ct, ch);
+#elif defined(MULE)
+ {
+ Lisp_Object charset;
+ int byte1, byte2;
+ Lisp_Object val;
+
+ BREAKUP_CHAR (ch, charset, byte1, byte2);
+
+ if (EQ (charset, Vcharset_ascii))
+ val = ct->ascii[byte1];
+ else if (EQ (charset, Vcharset_control_1))
+ val = ct->ascii[byte1 + 128];
+ else
+ {
+ int lb = XCHARSET_LEADING_BYTE (charset) - MIN_LEADING_BYTE;
+ val = ct->level1[lb];
+ if (CHAR_TABLE_ENTRYP (val))
+ {
+ Lisp_Char_Table_Entry *cte = XCHAR_TABLE_ENTRY (val);
+ val = cte->level2[byte1 - 32];
+ if (CHAR_TABLE_ENTRYP (val))
+ {
+ cte = XCHAR_TABLE_ENTRY (val);
+ assert (byte2 >= 32);
+ val = cte->level2[byte2 - 32];
+ assert (!CHAR_TABLE_ENTRYP (val));
+ }
+ }
+ }
+
+ return val;
+ }
+#else /* not MULE */
+ return ct->ascii[(unsigned char)ch];
+#endif /* not MULE */
+}
+
+
+DEFUN ("get-char-table", Fget_char_table, 2, 2, 0, /*
+Find value for CHARACTER in CHAR-TABLE.
+*/
+ (character, char_table))
+{
+ CHECK_CHAR_TABLE (char_table);
+ CHECK_CHAR_COERCE_INT (character);
+
+ return get_char_table (XCHAR (character), XCHAR_TABLE (char_table));
+}
+
+DEFUN ("get-range-char-table", Fget_range_char_table, 2, 3, 0, /*
+Find value for a range in CHAR-TABLE.
+If there is more than one value, return MULTI (defaults to nil).
+*/
+ (range, char_table, multi))
+{
+ Lisp_Char_Table *ct;
+ struct chartab_range rainj;
+
+ if (CHAR_OR_CHAR_INTP (range))
+ return Fget_char_table (range, char_table);
+ CHECK_CHAR_TABLE (char_table);
+ ct = XCHAR_TABLE (char_table);
+
+ decode_char_table_range (range, &rainj);
+ switch (rainj.type)
+ {
+ case CHARTAB_RANGE_ALL:
+ {
+#ifdef UTF2000
+ if (UINT8_BYTE_TABLE_P (ct->table))
+ return multi;
+ else if (UINT16_BYTE_TABLE_P (ct->table))
+ return multi;
+ else if (BYTE_TABLE_P (ct->table))
+ return multi;
+ else
+ return ct->table;
+#else /* non UTF2000 */
+ int i;
+ Lisp_Object first = ct->ascii[0];
+
+ for (i = 1; i < NUM_ASCII_CHARS; i++)
+ if (!EQ (first, ct->ascii[i]))
+ return multi;
+
+#ifdef MULE
+ for (i = MIN_LEADING_BYTE; i < MIN_LEADING_BYTE + NUM_LEADING_BYTES;
+ i++)
+ {
+ if (!CHARSETP (CHARSET_BY_LEADING_BYTE (i))
+ || i == LEADING_BYTE_ASCII
+ || i == LEADING_BYTE_CONTROL_1)
+ continue;
+ if (!EQ (first, ct->level1[i - MIN_LEADING_BYTE]))
+ return multi;
+ }
+#endif /* MULE */
+
+ return first;
+#endif /* non UTF2000 */
+ }
+
+#ifdef MULE
+ case CHARTAB_RANGE_CHARSET:
+#ifdef UTF2000
+ return multi;
+#else
+ if (EQ (rainj.charset, Vcharset_ascii))
+ {
+ int i;
+ Lisp_Object first = ct->ascii[0];
+
+ for (i = 1; i < 128; i++)
+ if (!EQ (first, ct->ascii[i]))
+ return multi;
+ return first;
+ }
+
+ if (EQ (rainj.charset, Vcharset_control_1))
+ {
+ int i;
+ Lisp_Object first = ct->ascii[128];
+
+ for (i = 129; i < 160; i++)
+ if (!EQ (first, ct->ascii[i]))
+ return multi;
+ return first;
+ }
+
+ {
+ Lisp_Object val = ct->level1[XCHARSET_LEADING_BYTE (rainj.charset) -
+ MIN_LEADING_BYTE];
+ if (CHAR_TABLE_ENTRYP (val))
+ return multi;
+ return val;
+ }
+#endif
+
+ case CHARTAB_RANGE_ROW:
+#ifdef UTF2000
+ return multi;
+#else
+ {
+ Lisp_Object val = ct->level1[XCHARSET_LEADING_BYTE (rainj.charset) -
+ MIN_LEADING_BYTE];
+ if (!CHAR_TABLE_ENTRYP (val))
+ return val;
+ val = XCHAR_TABLE_ENTRY (val)->level2[rainj.row - 32];
+ if (CHAR_TABLE_ENTRYP (val))
+ return multi;
+ return val;
+ }
+#endif /* not UTF2000 */
+#endif /* not MULE */
+
+ default:
+ abort ();
+ }
+
+ return Qnil; /* not reached */
+}
+
+static int
+check_valid_char_table_value (Lisp_Object value, enum char_table_type type,
+ Error_behavior errb)
+{
+ switch (type)
+ {
+ case CHAR_TABLE_TYPE_SYNTAX:
+ if (!ERRB_EQ (errb, ERROR_ME))
+ return INTP (value) || (CONSP (value) && INTP (XCAR (value))
+ && CHAR_OR_CHAR_INTP (XCDR (value)));
+ if (CONSP (value))
+ {
+ Lisp_Object cdr = XCDR (value);
+ CHECK_INT (XCAR (value));
+ CHECK_CHAR_COERCE_INT (cdr);
+ }
+ else
+ CHECK_INT (value);
+ break;
+
+#ifdef MULE
+ case CHAR_TABLE_TYPE_CATEGORY:
+ if (!ERRB_EQ (errb, ERROR_ME))
+ return CATEGORY_TABLE_VALUEP (value);
+ CHECK_CATEGORY_TABLE_VALUE (value);
+ break;
+#endif /* MULE */
+
+ case CHAR_TABLE_TYPE_GENERIC:
+ return 1;
+
+ case CHAR_TABLE_TYPE_DISPLAY:
+ /* #### fix this */
+ maybe_signal_simple_error ("Display char tables not yet implemented",
+ value, Qchar_table, errb);
+ return 0;
+
+ case CHAR_TABLE_TYPE_CHAR:
+ if (!ERRB_EQ (errb, ERROR_ME))
+ return CHAR_OR_CHAR_INTP (value);
+ CHECK_CHAR_COERCE_INT (value);
+ break;
+
+ default:
+ abort ();
+ }
+
+ return 0; /* not reached */
+}
+
+static Lisp_Object
+canonicalize_char_table_value (Lisp_Object value, enum char_table_type type)
+{
+ switch (type)
+ {
+ case CHAR_TABLE_TYPE_SYNTAX:
+ if (CONSP (value))
+ {
+ Lisp_Object car = XCAR (value);
+ Lisp_Object cdr = XCDR (value);
+ CHECK_CHAR_COERCE_INT (cdr);
+ return Fcons (car, cdr);
+ }
+ break;
+ case CHAR_TABLE_TYPE_CHAR:
+ CHECK_CHAR_COERCE_INT (value);
+ break;
+ default:
+ break;
+ }
+ return value;
+}
+
+DEFUN ("valid-char-table-value-p", Fvalid_char_table_value_p, 2, 2, 0, /*
+Return non-nil if VALUE is a valid value for CHAR-TABLE-TYPE.
+*/
+ (value, char_table_type))
+{
+ enum char_table_type type = symbol_to_char_table_type (char_table_type);
+
+ return check_valid_char_table_value (value, type, ERROR_ME_NOT) ? Qt : Qnil;
+}
+
+DEFUN ("check-valid-char-table-value", Fcheck_valid_char_table_value, 2, 2, 0, /*
+Signal an error if VALUE is not a valid value for CHAR-TABLE-TYPE.
+*/
+ (value, char_table_type))
+{
+ enum char_table_type type = symbol_to_char_table_type (char_table_type);
+
+ check_valid_char_table_value (value, type, ERROR_ME);
+ return Qnil;
+}
+
+/* Assign VAL to all characters in RANGE in char table CT. */
+
+void
+put_char_table (Lisp_Char_Table *ct, struct chartab_range *range,
+ Lisp_Object val)
+{
+ switch (range->type)
+ {
+ case CHARTAB_RANGE_ALL:
+ /* printf ("put-char-table: range = all\n"); */
+ fill_char_table (ct, val);
+ return; /* avoid the duplicate call to update_syntax_table() below,
+ since fill_char_table() also did that. */
+
+#ifdef UTF2000
+ case CHARTAB_RANGE_DEFAULT:
+ ct->default_value = val;
+ return;
+#endif
+
+#ifdef MULE
+ case CHARTAB_RANGE_CHARSET:
+#ifdef UTF2000
+ {
+ Emchar c;
+ Lisp_Object encoding_table = XCHARSET_ENCODING_TABLE (range->charset);
+
+ /* printf ("put-char-table: range = charset: %d\n",
+ XCHARSET_LEADING_BYTE (range->charset));
+ */
+ if ( CHAR_TABLEP (encoding_table) )
+ {
+ for (c = 0; c < 1 << 24; c++)
+ {
+ if ( INTP (get_char_id_table (XCHAR_TABLE(encoding_table),
+ c)) )
+ put_char_id_table_0 (ct, c, val);
+ }
+ }
+ else
+ {
+ for (c = 0; c < 1 << 24; c++)
+ {
+ if ( charset_code_point (range->charset, c, 0) >= 0 )
+ put_char_id_table_0 (ct, c, val);
+ }
+ }
+ }
+#else
+ if (EQ (range->charset, Vcharset_ascii))
+ {
+ int i;
+ for (i = 0; i < 128; i++)
+ ct->ascii[i] = val;
+ }
+ else if (EQ (range->charset, Vcharset_control_1))
+ {
+ int i;
+ for (i = 128; i < 160; i++)
+ ct->ascii[i] = val;
+ }
+ else
+ {
+ int lb = XCHARSET_LEADING_BYTE (range->charset) - MIN_LEADING_BYTE;
+ ct->level1[lb] = val;
+ }
+#endif
+ break;
+
+ case CHARTAB_RANGE_ROW:
+#ifdef UTF2000
+ {
+ int cell_min, cell_max, i;
+
+ i = XCHARSET_CELL_RANGE (range->charset);
+ cell_min = i >> 8;
+ cell_max = i & 0xFF;
+ for (i = cell_min; i <= cell_max; i++)
+ {
+ Emchar ch = DECODE_CHAR (range->charset, (range->row << 8) | i);
+
+ if ( charset_code_point (range->charset, ch, 0) >= 0 )
+ put_char_id_table_0 (ct, ch, val);
+ }
+ }
+#else
+ {
+ Lisp_Char_Table_Entry *cte;
+ int lb = XCHARSET_LEADING_BYTE (range->charset) - MIN_LEADING_BYTE;
+ /* make sure that there is a separate entry for the row. */
+ if (!CHAR_TABLE_ENTRYP (ct->level1[lb]))
+ ct->level1[lb] = make_char_table_entry (ct->level1[lb]);
+ cte = XCHAR_TABLE_ENTRY (ct->level1[lb]);
+ cte->level2[range->row - 32] = val;
+ }
+#endif /* not UTF2000 */
+ break;
+#endif /* MULE */
+
+ case CHARTAB_RANGE_CHAR:
+#ifdef UTF2000
+ /* printf ("put-char-table: range = char: 0x%x\n", range->ch); */
+ put_char_id_table_0 (ct, range->ch, val);
+ break;
+#elif defined(MULE)
+ {
+ Lisp_Object charset;
+ int byte1, byte2;
+
+ BREAKUP_CHAR (range->ch, charset, byte1, byte2);
+ if (EQ (charset, Vcharset_ascii))
+ ct->ascii[byte1] = val;
+ else if (EQ (charset, Vcharset_control_1))
+ ct->ascii[byte1 + 128] = val;
+ else
+ {
+ Lisp_Char_Table_Entry *cte;
+ int lb = XCHARSET_LEADING_BYTE (charset) - MIN_LEADING_BYTE;
+ /* make sure that there is a separate entry for the row. */
+ if (!CHAR_TABLE_ENTRYP (ct->level1[lb]))
+ ct->level1[lb] = make_char_table_entry (ct->level1[lb]);
+ cte = XCHAR_TABLE_ENTRY (ct->level1[lb]);
+ /* now CTE is a char table entry for the charset;
+ each entry is for a single row (or character of
+ a one-octet charset). */
+ if (XCHARSET_DIMENSION (charset) == 1)
+ cte->level2[byte1 - 32] = val;
+ else
+ {
+ /* assigning to one character in a two-octet charset. */
+ /* make sure that the charset row contains a separate
+ entry for each character. */
+ if (!CHAR_TABLE_ENTRYP (cte->level2[byte1 - 32]))
+ cte->level2[byte1 - 32] =
+ make_char_table_entry (cte->level2[byte1 - 32]);
+ cte = XCHAR_TABLE_ENTRY (cte->level2[byte1 - 32]);
+ cte->level2[byte2 - 32] = val;
+ }
+ }
+ }
+#else /* not MULE */
+ ct->ascii[(unsigned char) (range->ch)] = val;
+ break;
+#endif /* not MULE */
+ }
+
+#ifndef UTF2000
+ if (ct->type == CHAR_TABLE_TYPE_SYNTAX)
+ update_syntax_table (ct);
+#endif
+}
projects / chise / xemacs-chise.git / blobdiff