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