git.chise.org Git - chise/xemacs-chise.git.1/blob - src/casetab.c

   1 /* XEmacs routines to deal with case tables.
   2    Copyright (C) 1987, 1992, 1993, 1994 Free Software Foundation, Inc.
   3    Copyright (C) 1995 Sun Microsystems, Inc.
   4    Copyright (C) 2002 MORIOKA Tomohiko
   5
   6 This file is part of XEmacs.
   7
   8 XEmacs is free software; you can redistribute it and/or modify it
   9 under the terms of the GNU General Public License as published by the
  10 Free Software Foundation; either version 2, or (at your option) any
  11 later version.
  12
  13 XEmacs is distributed in the hope that it will be useful, but WITHOUT
  14 ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or
  15 FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License
  16 for more details.
  17
  18 You should have received a copy of the GNU General Public License
  19 along with XEmacs; see the file COPYING.  If not, write to
  20 the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
  21 Boston, MA 02111-1307, USA.  */
  22
  23  /* Synched up with: FSF 19.28.  Between FSF 19.28 and 19.30, casetab.c
  24    was rewritten to use junky FSF char tables.  Meanwhile I rewrote it
  25    to use more logical char tables.  RMS also discards the "list of four
  26    tables" format and instead stuffs the other tables as "extra slots"
  27    in the downcase table.  I've kept the four-lists format for now. */
  28
  29 /* Written by Howard Gayle.  See some mythical and not-in-the-Emacs-
  30    distribution file chartab.c for details. */
  31
  32 /* Modified for Mule by Ben Wing. */
  33 /* Modified for UTF-2000 by MORIOKA Tomohiko */
  34
  35 /* Case table consists of four char-table.  Those are for downcase,
  36    upcase, canonical and equivalent respectively.
  37
  38    It's entry is like this:
  39
  40    downcase:    a -> a, A -> a.
  41    upcase:      a -> A, A -> a.  (The latter is for NOCASEP.)
  42    canon:       a -> a, A -> a.
  43    eqv:         a -> A, A -> a.
  44 */
  45
  46 #include <config.h>
  47 #include "lisp.h"
  48 #include "buffer.h"
  49 #include "opaque.h"
  50 #include "chartab.h"
  51 #include "casetab.h"
  52
  53 Lisp_Object Qcase_tablep, Qdowncase, Qupcase;
  54 Lisp_Object Vstandard_case_table;
  55 #ifdef UTF2000
  56 Lisp_Object Qflippedcase, Q_lowercase, Q_uppercase;
  57 #endif
  58
  59 static void compute_trt_inverse (Lisp_Object trt, Lisp_Object inverse);
  60 Lisp_Object case_table_char (Lisp_Object ch, Lisp_Object table);
  61
  62 #define STRING256_P(obj) ((STRINGP (obj) && XSTRING_CHAR_LENGTH (obj) == 256))
  63
  64 static Lisp_Object
  65 mark_case_table (Lisp_Object obj)
  66 {
  67   Lisp_Case_Table *ct = XCASE_TABLE (obj);
  68
  69   mark_object (CASE_TABLE_DOWNCASE (ct));
  70   mark_object (CASE_TABLE_UPCASE (ct));
  71   mark_object (CASE_TABLE_CANON (ct));
  72   mark_object (CASE_TABLE_EQV (ct));
  73   return Qnil;
  74 }
  75
  76 static void
  77 print_case_table (Lisp_Object obj, Lisp_Object printcharfun, int escapeflag)
  78 {
  79   Lisp_Case_Table *ct = XCASE_TABLE (obj);
  80   char buf[200];
  81   if (print_readably)
  82     error ("printing unreadable object #<case-table 0x%x", ct->header.uid);
  83   write_c_string ("#<case-table ", printcharfun);
  84   sprintf (buf, "0x%x>", ct->header.uid);
  85   write_c_string (buf, printcharfun);
  86 }
  87
  88 static const struct lrecord_description case_table_description [] = {
  89   { XD_LISP_OBJECT, offsetof (Lisp_Case_Table, downcase_table) },
  90   { XD_LISP_OBJECT, offsetof (Lisp_Case_Table, upcase_table) },
  91   { XD_LISP_OBJECT, offsetof (Lisp_Case_Table, case_canon_table) },
  92   { XD_LISP_OBJECT, offsetof (Lisp_Case_Table, case_eqv_table) },
  93   { XD_END }
  94 };
  95
  96 DEFINE_LRECORD_IMPLEMENTATION ("case-table", case_table,
  97                               mark_case_table, print_case_table, 0,
  98                               0, 0, case_table_description, Lisp_Case_Table);
  99
 100 static Lisp_Object
 101 allocate_case_table (void)
 102 {
 103   Lisp_Object val;
 104   Lisp_Case_Table *ct =
 105     alloc_lcrecord_type (Lisp_Case_Table, &lrecord_case_table);
 106
 107   SET_CASE_TABLE_DOWNCASE (ct, Qnil);
 108   SET_CASE_TABLE_UPCASE (ct, Qnil);
 109   SET_CASE_TABLE_CANON (ct, Qnil);
 110   SET_CASE_TABLE_EQV (ct, Qnil);
 111
 112   XSETCASE_TABLE (val, ct);
 113   return val;
 114 }
 115
 116 DEFUN ("case-table-p", Fcase_table_p, 1, 1, 0, /*
 117 Return t if OBJECT is a case table.
 118 See `set-case-table' for more information on these data structures.
 119 */
 120        (object))
 121 {
 122   if (CASE_TABLEP (object))
 123     return Qt;
 124   else
 125     {
 126       Lisp_Object down, up, canon, eqv;
 127       if (!CONSP (object))
 128         return Qnil;
 129       down = XCAR (object); object = XCDR (object);
 130       if (!CONSP (object))
 131         return Qnil;
 132       up = XCAR (object); object = XCDR (object);
 133       if (!CONSP (object))
 134         return Qnil;
 135       canon = XCAR (object); object = XCDR (object);
 136       if (!CONSP (object))
 137         return Qnil;
 138       eqv = XCAR (object);
 139
 140       return ((STRING256_P (down)
 141                && (NILP (up) || STRING256_P (up))
 142                && ((NILP (canon) && NILP (eqv))
 143                    || STRING256_P (canon))
 144                && (NILP (eqv) || STRING256_P (eqv)))
 145               ? Qt : Qnil);
 146
 147     }
 148 }
 149
 150 static Lisp_Object
 151 check_case_table (Lisp_Object object)
 152 {
 153   /* This function can GC */
 154   while (NILP (Fcase_table_p (object)))
 155     object = wrong_type_argument (Qcase_tablep, object);
 156   return object;
 157 }
 158
 159 Lisp_Object
 160 case_table_char (Lisp_Object ch, Lisp_Object table)
 161 {
 162   Lisp_Object ct_char;
 163   ct_char = get_char_table (XCHAR (ch), XCHAR_TABLE (table));
 164   if (NILP (ct_char))
 165     return ch;
 166   else
 167     return ct_char;
 168 }
 169
 170 DEFUN ("get-case-table", Fget_case_table, 3, 3, 0, /*
 171 Return CHAR-CASE version of CHARACTER in CASE-TABLE.
 172
 173 CHAR-CASE is either downcase or upcase.
 174 */
 175        (char_case, character, case_table))
 176 {
 177   CHECK_CHAR (character);
 178   CHECK_CASE_TABLE (case_table);
 179   if (EQ (char_case, Qdowncase))
 180     return case_table_char (character, XCASE_TABLE_DOWNCASE (case_table));
 181   else if (EQ (char_case, Qupcase))
 182     return case_table_char (character, XCASE_TABLE_UPCASE (case_table));
 183   else
 184     signal_simple_error ("Char case must be downcase or upcase", char_case);
 185
 186   return Qnil; /* Not reached. */
 187 }
 188
 189 DEFUN ("put-case-table", Fput_case_table, 4, 4, 0, /*
 190 Set CHAR-CASE version of CHARACTER to be VALUE in CASE-TABLE.
 191
 192 CHAR-CASE is either downcase or upcase.
 193 See also `put-case-table-pair'.
 194 */
 195        (char_case, character, value, case_table))
 196 {
 197   CHECK_CHAR (character);
 198   CHECK_CHAR (value);
 199
 200   if (EQ (char_case, Qdowncase))
 201     {
 202       Fput_char_table (character, value, XCASE_TABLE_DOWNCASE (case_table));
 203       /* This one is not at all intuitive.  */
 204       Fput_char_table (character, value, XCASE_TABLE_UPCASE (case_table));
 205       Fput_char_table (character, value, XCASE_TABLE_CANON (case_table));
 206       Fput_char_table (value, value, XCASE_TABLE_CANON (case_table));
 207       Fput_char_table (value, character, XCASE_TABLE_EQV (case_table));
 208       Fput_char_table (character, value, XCASE_TABLE_EQV (case_table));
 209     }
 210   else if (EQ (char_case, Qupcase))
 211     {
 212       Fput_char_table (character, value, XCASE_TABLE_UPCASE (case_table));
 213       Fput_char_table (character, character, XCASE_TABLE_DOWNCASE (case_table));
 214       Fput_char_table (character, character, XCASE_TABLE_CANON (case_table));
 215       Fput_char_table (value, character, XCASE_TABLE_CANON (case_table));
 216       Fput_char_table (value, character, XCASE_TABLE_EQV (case_table));
 217       Fput_char_table (character, value, XCASE_TABLE_EQV (case_table));
 218     }
 219   else
 220     signal_simple_error ("Char case must be downcase or upcase", char_case);
 221
 222   return Qnil;
 223 }
 224
 225 DEFUN ("put-case-table-pair", Fput_case_table_pair, 3, 3, 0, /*
 226 Make UC and LC a pair of inter-case-converting letters in CASE-TABLE.
 227 UC is an uppercase character and LC is a downcase character.
 228 */
 229        (uc, lc, case_table))
 230 {
 231   CHECK_CHAR (uc);
 232   CHECK_CHAR (lc);
 233   CHECK_CASE_TABLE (case_table);
 234
 235   Fput_char_table (lc, lc, XCASE_TABLE_DOWNCASE (case_table));
 236   Fput_char_table (uc, lc, XCASE_TABLE_UPCASE (case_table));
 237   Fput_char_table (uc, lc, XCASE_TABLE_DOWNCASE (case_table));
 238   Fput_char_table (lc, uc, XCASE_TABLE_UPCASE (case_table));
 239
 240   Fput_char_table (lc, lc, XCASE_TABLE_CANON (case_table));
 241   Fput_char_table (uc, lc, XCASE_TABLE_CANON (case_table));
 242   Fput_char_table (uc, lc, XCASE_TABLE_EQV (case_table));
 243   Fput_char_table (lc, uc, XCASE_TABLE_EQV (case_table));
 244   return Qnil;
 245 }
 246
 247 DEFUN ("copy-case-table", Fcopy_case_table, 1, 1, 0, /*
 248 Return a new case table which is a copy of CASE-TABLE
 249 */
 250        (case_table))
 251 {
 252   Lisp_Object new_obj;
 253   CHECK_CASE_TABLE (case_table);
 254
 255   new_obj = allocate_case_table ();
 256   XSET_CASE_TABLE_DOWNCASE
 257     (new_obj, Fcopy_char_table (XCASE_TABLE_DOWNCASE (case_table)));
 258   XSET_CASE_TABLE_UPCASE
 259     (new_obj, Fcopy_char_table (XCASE_TABLE_UPCASE (case_table)));
 260   XSET_CASE_TABLE_CANON
 261     (new_obj, Fcopy_char_table (XCASE_TABLE_CANON (case_table)));
 262   XSET_CASE_TABLE_EQV
 263     (new_obj, Fcopy_char_table (XCASE_TABLE_EQV (case_table)));
 264   return new_obj;
 265 }
 266
 267 DEFUN ("current-case-table", Fcurrent_case_table, 0, 1, 0, /*
 268 Return the case table of BUFFER, which defaults to the current buffer.
 269 */
 270        (buffer))
 271 {
 272   struct buffer *buf = decode_buffer (buffer, 0);
 273
 274   return buf->case_table;
 275 }
 276
 277 DEFUN ("standard-case-table", Fstandard_case_table, 0, 0, 0, /*
 278 Return the standard case table.
 279 This is the one used for new buffers.
 280 */
 281        ())
 282 {
 283   return Vstandard_case_table;
 284 }
 285
 286 static Lisp_Object set_case_table (Lisp_Object table, int standard);
 287
 288 DEFUN ("set-case-table", Fset_case_table, 1, 1, 0, /*
 289 Select CASE-TABLE as the new case table for the current buffer.
 290 A case table is a case-table object or list
 291  (DOWNCASE UPCASE CANONICALIZE EQUIVALENCES)
 292  where each element is either nil or a string of length 256.
 293 The latter is provided for backward-compatibility.
 294 DOWNCASE maps each character to its lower-case equivalent.
 295 UPCASE maps each character to its upper-case equivalent;
 296  if lower and upper case characters are in 1-1 correspondence,
 297  you may use nil and the upcase table will be deduced from DOWNCASE.
 298 CANONICALIZE maps each character to a canonical equivalent;
 299  any two characters that are related by case-conversion have the same
 300  canonical equivalent character; it may be nil, in which case it is
 301  deduced from DOWNCASE and UPCASE.
 302 EQUIVALENCES is a map that cyclicly permutes each equivalence class
 303  (of characters with the same canonical equivalent); it may be nil,
 304  in which case it is deduced from CANONICALIZE.
 305
 306 See also `get-case-table', `put-case-table' and `put-case-table-pair'.
 307 */
 308        (case_table))
 309 {
 310   /* This function can GC */
 311   return set_case_table (case_table, 0);
 312 }
 313
 314 DEFUN ("set-standard-case-table", Fset_standard_case_table, 1, 1, 0, /*
 315 Select CASE-TABLE as the new standard case table for new buffers.
 316 See `set-case-table' for more info on case tables.
 317 */
 318        (case_table))
 319 {
 320   /* This function can GC */
 321   return set_case_table (case_table, 1);
 322 }
 323
 324 static Lisp_Object
 325 set_case_table (Lisp_Object table, int standard)
 326 {
 327   /* This function can GC */
 328   struct buffer *buf =
 329     standard ? XBUFFER(Vbuffer_defaults) : current_buffer;
 330
 331   check_case_table (table);
 332
 333   if (CASE_TABLEP (table))
 334     {
 335       if (standard)
 336         Vstandard_case_table = table;
 337
 338       buf->case_table = table;
 339     }
 340   else
 341     {
 342       /* For backward compatibility. */
 343       Lisp_Object down, up, canon, eqv, tail = table;
 344       Lisp_Object temp;
 345       int i;
 346
 347       down = XCAR (tail); tail = XCDR (tail);
 348       up = XCAR (tail); tail = XCDR (tail);
 349       canon = XCAR (tail); tail = XCDR (tail);
 350       eqv = XCAR (tail);
 351
 352       temp = down;
 353       down = MAKE_TRT_TABLE ();
 354       for (i = 0; i < 256; i++)
 355         SET_TRT_TABLE_CHAR_1 (down, i, string_char (XSTRING (temp), i));
 356
 357       if (NILP (up))
 358         {
 359           up = MAKE_TRT_TABLE ();
 360           compute_trt_inverse (down, up);
 361         }
 362       else
 363         {
 364           temp = up;
 365           up = MAKE_TRT_TABLE ();
 366           for (i = 0; i < 256; i++)
 367             SET_TRT_TABLE_CHAR_1 (up, i, string_char (XSTRING (temp), i));
 368         }
 369       if (NILP (canon))
 370         {
 371           canon = MAKE_TRT_TABLE ();
 372
 373           /* Set up the CANON table; for each character,
 374              this sequence of upcasing and downcasing ought to
 375              get the "preferred" lowercase equivalent.  */
 376           for (i = 0; i < 256; i++)
 377             SET_TRT_TABLE_CHAR_1 (canon, i,
 378                                   TRT_TABLE_CHAR_1
 379                                   (down,
 380                                    TRT_TABLE_CHAR_1
 381                                    (up,
 382                                     TRT_TABLE_CHAR_1 (down, i))));
 383         }
 384       else
 385         {
 386           temp = canon;
 387           canon = MAKE_TRT_TABLE ();
 388           for (i = 0; i < 256; i++)
 389             SET_TRT_TABLE_CHAR_1 (canon, i, string_char (XSTRING (temp), i));
 390         }
 391
 392       if (NILP (eqv))
 393         {
 394           eqv = MAKE_TRT_TABLE ();
 395           compute_trt_inverse (canon, eqv);
 396         }
 397       else
 398         {
 399           temp = eqv;
 400           eqv = MAKE_TRT_TABLE ();
 401           for (i = 0; i < 256; i++)
 402             SET_TRT_TABLE_CHAR_1 (eqv, i, string_char (XSTRING (temp), i));
 403         }
 404
 405       if (standard)
 406         {
 407           XSET_CASE_TABLE_DOWNCASE (Vstandard_case_table, down);
 408           XSET_CASE_TABLE_UPCASE (Vstandard_case_table, up);
 409           XSET_CASE_TABLE_CANON (Vstandard_case_table, canon);
 410           XSET_CASE_TABLE_EQV (Vstandard_case_table, eqv);
 411         }
 412
 413       buf->case_table = allocate_case_table ();
 414       XSET_CASE_TABLE_DOWNCASE (buf->case_table, down);
 415       XSET_CASE_TABLE_UPCASE (buf->case_table, up);
 416       XSET_CASE_TABLE_CANON (buf->case_table, canon);
 417       XSET_CASE_TABLE_EQV (buf->case_table, eqv);
 418     }
 419
 420   return buf->case_table;
 421 }
 422 \f
 423 /* Given a translate table TRT, store the inverse mapping into INVERSE.
 424    Since TRT is not one-to-one, INVERSE is not a simple mapping.
 425    Instead, it divides the space of characters into equivalence classes.
 426    All characters in a given class form one circular list, chained through
 427    the elements of INVERSE.  */
 428
 429 static void
 430 compute_trt_inverse (Lisp_Object trt, Lisp_Object inverse)
 431 {
 432   Charcount i = 0400;
 433   Emchar c, q;
 434
 435   while (--i)
 436     SET_TRT_TABLE_CHAR_1 (inverse, i, (Emchar) i);
 437   i = 0400;
 438   while (--i)
 439     {
 440       if ((q = TRT_TABLE_CHAR_1 (trt, i)) != (Emchar) i)
 441         {
 442           c = TRT_TABLE_CHAR_1 (inverse, q);
 443           SET_TRT_TABLE_CHAR_1 (inverse, q, (Emchar) i);
 444           SET_TRT_TABLE_CHAR_1 (inverse, i, c);
 445         }
 446     }
 447 }
 448
 449 \f
 450 void
 451 syms_of_casetab (void)
 452 {
 453   INIT_LRECORD_IMPLEMENTATION (case_table);
 454
 455   defsymbol (&Qcase_tablep, "case-table-p");
 456   defsymbol (&Qdowncase, "downcase");
 457   defsymbol (&Qupcase, "upcase");
 458 #ifdef UTF2000
 459   defsymbol (&Qflippedcase, "flippedcase");
 460   defsymbol (&Q_lowercase, "->lowercase");
 461   defsymbol (&Q_uppercase, "->uppercase");
 462 #endif
 463
 464   DEFSUBR (Fcase_table_p);
 465   DEFSUBR (Fget_case_table);
 466   DEFSUBR (Fput_case_table);
 467   DEFSUBR (Fput_case_table_pair);
 468   DEFSUBR (Fcurrent_case_table);
 469   DEFSUBR (Fstandard_case_table);
 470   DEFSUBR (Fcopy_case_table);
 471   DEFSUBR (Fset_case_table);
 472   DEFSUBR (Fset_standard_case_table);
 473 }
 474
 475 void
 476 complex_vars_of_casetab (void)
 477 {
 478   REGISTER Emchar i;
 479   Lisp_Object tem;
 480
 481   staticpro (&Vstandard_case_table);
 482
 483   Vstandard_case_table = allocate_case_table ();
 484
 485 #ifdef UTF2000
 486   tem = MAKE_TRT_TABLE ();
 487 #ifdef HAVE_CHISE_CLIENT
 488   XCHAR_TABLE_NAME (tem) = Qdowncase;
 489 #endif
 490 #else
 491   tem = MAKE_TRT_TABLE ();
 492 #endif
 493   XSET_CASE_TABLE_DOWNCASE (Vstandard_case_table, tem);
 494   XSET_CASE_TABLE_CANON (Vstandard_case_table, tem);
 495
 496   /* Under Mule, can't do set_string_char() until Vcharset_control_1
 497      and Vcharset_ascii are initialized. */
 498   for (i = 0; i < 256; i++)
 499     {
 500       unsigned char lowered = tolower (i);
 501
 502       SET_TRT_TABLE_CHAR_1 (tem, i, lowered);
 503     }
 504
 505 #ifdef UTF2000
 506   tem = MAKE_TRT_TABLE ();
 507 #ifdef HAVE_CHISE_CLIENT
 508   XCHAR_TABLE_NAME (tem) = Qflippedcase;
 509 #endif
 510 #else
 511   tem = MAKE_TRT_TABLE ();
 512 #endif
 513   XSET_CASE_TABLE_UPCASE (Vstandard_case_table, tem);
 514   XSET_CASE_TABLE_EQV (Vstandard_case_table, tem);
 515
 516   for (i = 0; i < 256; i++)
 517     {
 518       unsigned char flipped = (isupper (i) ? tolower (i)
 519                                : (islower (i) ? toupper (i) : i));
 520
 521       SET_TRT_TABLE_CHAR_1 (tem, i, flipped);
 522     }
 523 }