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 /* #### We do not currently deal properly with translating non-ASCII
  34    (including Latin-1!) characters under Mule.  Getting this right is
  35    *hard*, way fucking hard.  So we at least preserve consistency by
  36    sanitizing all the case tables to remove translations that would
  37    get us into trouble and possibly result in inconsistent internal
  38    text, which would likely lead to crashes. */
  39
  40 #include <config.h>
  41 #include "lisp.h"
  42 #include "buffer.h"
  43 #include "opaque.h"
  44
  45 Lisp_Object Qcase_table_p;
  46 Lisp_Object Vascii_downcase_table, Vascii_upcase_table;
  47 Lisp_Object Vascii_canon_table, Vascii_eqv_table;
  48 #ifdef MULE
  49 Lisp_Object Vmirror_ascii_downcase_table, Vmirror_ascii_upcase_table;
  50 Lisp_Object Vmirror_ascii_canon_table, Vmirror_ascii_eqv_table;
  51 #endif
  52 Lisp_Object Qtranslate_table;
  53
  54 static void compute_trt_inverse (Lisp_Object trt, Lisp_Object inverse);
  55
  56 #define STRING256_P(obj) (STRINGP (obj) && XSTRING_CHAR_LENGTH (obj) == 256)
  57
  58 DEFUN ("case-table-p", Fcase_table_p, 1, 1, 0, /*
  59 Return t if ARG is a case table.
  60 See `set-case-table' for more information on these data structures.
  61 */
  62        (table))
  63 {
  64   Lisp_Object down, up, canon, eqv;
  65   if (!CONSP (table)) return Qnil; down  = XCAR (table); table = XCDR (table);
  66   if (!CONSP (table)) return Qnil; up    = XCAR (table); table = XCDR (table);
  67   if (!CONSP (table)) return Qnil; canon = XCAR (table); table = XCDR (table);
  68   if (!CONSP (table)) return Qnil; eqv   = XCAR (table);
  69
  70   return (STRING256_P (down)
  71           && (NILP (up) || STRING256_P (up))
  72           && ((NILP (canon) && NILP (eqv))
  73               || (STRING256_P (canon)
  74                   && (NILP (eqv) || STRING256_P (eqv))))
  75           ? Qt : Qnil);
  76 }
  77
  78 static Lisp_Object
  79 check_case_table (Lisp_Object obj)
  80 {
  81   REGISTER Lisp_Object tem;
  82
  83   while (tem = Fcase_table_p (obj), NILP (tem))
  84     obj = wrong_type_argument (Qcase_table_p, obj);
  85   return (obj);
  86 }
  87
  88 DEFUN ("current-case-table", Fcurrent_case_table, 0, 1, 0, /*
  89 Return the case table of BUFFER, which defaults to the current buffer.
  90 */
  91        (buffer))
  92 {
  93   struct buffer *buf = decode_buffer (buffer, 0);
  94
  95   return list4 (buf->downcase_table,
  96                 buf->upcase_table,
  97                 buf->case_canon_table,
  98                 buf->case_eqv_table);
  99 }
 100
 101 DEFUN ("standard-case-table", Fstandard_case_table, 0, 0, 0, /*
 102 Return the standard case table.
 103 This is the one used for new buffers.
 104 */
 105        ())
 106 {
 107   return list4 (Vascii_downcase_table,
 108                 Vascii_upcase_table,
 109                 Vascii_canon_table,
 110                 Vascii_eqv_table);
 111 }
 112
 113 static Lisp_Object set_case_table (Lisp_Object table, int standard);
 114
 115
 116 DEFUN ("set-case-table", Fset_case_table, 1, 1, 0, /*
 117 Select a new case table for the current buffer.
 118 A case table is a list (DOWNCASE UPCASE CANONICALIZE EQUIVALENCES)
 119  where each element is either nil or a string of length 256.
 120 DOWNCASE maps each character to its lower-case equivalent.
 121 UPCASE maps each character to its upper-case equivalent;
 122  if lower and upper case characters are in 1-1 correspondence,
 123  you may use nil and the upcase table will be deduced from DOWNCASE.
 124 CANONICALIZE maps each character to a canonical equivalent;
 125  any two characters that are related by case-conversion have the same
 126  canonical equivalent character; it may be nil, in which case it is
 127  deduced from DOWNCASE and UPCASE.
 128 EQUIVALENCES is a map that cyclicly permutes each equivalence class
 129  (of characters with the same canonical equivalent); it may be nil,
 130  in which case it is deduced from CANONICALIZE.
 131
 132 BUG: Under XEmacs/Mule, translations to or from non-ASCII characters
 133  (this includes chars in the range 128 - 255) are ignored by
 134  the string/buffer-searching routines.  Thus, `case-fold-search'
 135  will not correctly conflate a-umlaut and A-umlaut even if the
 136  case tables call for this.
 137 */
 138        (table))
 139 {
 140   return set_case_table (table, 0);
 141 }
 142
 143 DEFUN ("set-standard-case-table", Fset_standard_case_table, 1, 1, 0, /*
 144 Select a new standard case table for new buffers.
 145 See `set-case-table' for more info on case tables.
 146 */
 147        (table))
 148 {
 149   return set_case_table (table, 1);
 150 }
 151
 152 #ifdef MULE
 153
 154 static Lisp_Object
 155 make_mirror_trt_table (Lisp_Object table)
 156 {
 157   Lisp_Object new_table;
 158
 159   if (!STRING256_P (table))
 160     {
 161 #ifdef DEBUG_XEMACS
 162       /* This should be caught farther up. */
 163       abort ();
 164 #else
 165       signal_simple_error ("Invalid translate table", table);
 166 #endif
 167     }
 168
 169   new_table = MAKE_MIRROR_TRT_TABLE ();
 170   {
 171     int i;
 172
 173     for (i = 0; i < 256; i++)
 174       {
 175         Emchar newval = string_char (XSTRING (table), i);
 176         if ((i >= 128 && newval != i)
 177             || (i < 128 && newval >= 128))
 178           {
 179             newval = (Emchar) i;
 180           }
 181         SET_MIRROR_TRT_TABLE_CHAR_1 (new_table, i, newval);
 182       }
 183   }
 184   return new_table;
 185 }
 186
 187 #endif /* MULE */
 188
 189 static Lisp_Object
 190 set_case_table (Lisp_Object table, int standard)
 191 {
 192   Lisp_Object down, up, canon, eqv, tail = table;
 193   struct buffer *buf = current_buffer;
 194
 195   check_case_table (table);
 196
 197   down  = XCAR (tail); tail = XCDR (tail);
 198   up    = XCAR (tail); tail = XCDR (tail);
 199   canon = XCAR (tail); tail = XCDR (tail);
 200   eqv   = XCAR (tail);
 201
 202   if (NILP (up))
 203     {
 204       up = MAKE_TRT_TABLE ();
 205       compute_trt_inverse (down, up);
 206     }
 207
 208   if (NILP (canon))
 209     {
 210       REGISTER Charcount i;
 211
 212       canon = MAKE_TRT_TABLE ();
 213
 214       /* Set up the CANON vector; for each character,
 215          this sequence of upcasing and downcasing ought to
 216          get the "preferred" lowercase equivalent.  */
 217       for (i = 0; i < 256; i++)
 218         SET_TRT_TABLE_CHAR_1 (canon, i,
 219                               TRT_TABLE_CHAR_1
 220                               (down,
 221                                TRT_TABLE_CHAR_1
 222                                (up,
 223                                 TRT_TABLE_CHAR_1 (down, i))));
 224     }
 225
 226   if (NILP (eqv))
 227     {
 228       eqv = MAKE_TRT_TABLE ();
 229
 230       compute_trt_inverse (canon, eqv);
 231     }
 232
 233   if (standard)
 234     {
 235       Vascii_downcase_table = down;
 236       Vascii_upcase_table = up;
 237       Vascii_canon_table = canon;
 238       Vascii_eqv_table = eqv;
 239 #ifdef MULE
 240       Vmirror_ascii_downcase_table = make_mirror_trt_table (down);
 241       Vmirror_ascii_upcase_table = make_mirror_trt_table (up);
 242       Vmirror_ascii_canon_table = make_mirror_trt_table (canon);
 243       Vmirror_ascii_eqv_table = make_mirror_trt_table (eqv);
 244 #endif
 245     }
 246   else
 247     {
 248       buf->downcase_table = down;
 249       buf->upcase_table = up;
 250       buf->case_canon_table = canon;
 251       buf->case_eqv_table = eqv;
 252 #ifdef MULE
 253       buf->mirror_downcase_table = make_mirror_trt_table (down);
 254       buf->mirror_upcase_table = make_mirror_trt_table (up);
 255       buf->mirror_case_canon_table = make_mirror_trt_table (canon);
 256       buf->mirror_case_eqv_table = make_mirror_trt_table (eqv);
 257 #endif
 258     }
 259   return table;
 260 }
 261 \f
 262 /* Given a translate table TRT, store the inverse mapping into INVERSE.
 263    Since TRT is not one-to-one, INVERSE is not a simple mapping.
 264    Instead, it divides the space of characters into equivalence classes.
 265    All characters in a given class form one circular list, chained through
 266    the elements of INVERSE.  */
 267
 268 static void
 269 compute_trt_inverse (Lisp_Object trt, Lisp_Object inverse)
 270 {
 271   Charcount i = 0400;
 272   Emchar c, q;
 273
 274   while (--i)
 275     SET_TRT_TABLE_CHAR_1 (inverse, i, (Emchar) i);
 276   i = 0400;
 277   while (--i)
 278     {
 279       if ((q = TRT_TABLE_CHAR_1 (trt, i)) != (Emchar) i)
 280         {
 281           c = TRT_TABLE_CHAR_1 (inverse, q);
 282           SET_TRT_TABLE_CHAR_1 (inverse, q, (Emchar) i);
 283           SET_TRT_TABLE_CHAR_1 (inverse, i, c);
 284         }
 285     }
 286 }
 287
 288 \f
 289 void
 290 syms_of_casetab (void)
 291 {
 292   defsymbol (&Qcase_table_p, "case-table-p");
 293   defsymbol (&Qtranslate_table, "translate-table");
 294
 295   DEFSUBR (Fcase_table_p);
 296   DEFSUBR (Fcurrent_case_table);
 297   DEFSUBR (Fstandard_case_table);
 298   DEFSUBR (Fset_case_table);
 299   DEFSUBR (Fset_standard_case_table);
 300 }
 301
 302 void
 303 complex_vars_of_casetab (void)
 304 {
 305   REGISTER Emchar i;
 306   Lisp_Object tem;
 307
 308   staticpro (&Vascii_downcase_table);
 309   staticpro (&Vascii_upcase_table);
 310   staticpro (&Vascii_canon_table);
 311   staticpro (&Vascii_eqv_table);
 312
 313   tem = MAKE_TRT_TABLE ();
 314   Vascii_downcase_table = tem;
 315   Vascii_canon_table = tem;
 316
 317   /* Under Mule, can't do set_string_char() until Vcharset_control_1
 318      and Vcharset_ascii are initialized. */
 319   for (i = 0; i < 256; i++)
 320     {
 321       unsigned char lowered = tolower (i);
 322
 323       SET_TRT_TABLE_CHAR_1 (tem, i, lowered);
 324     }
 325
 326 #ifdef MULE
 327   tem = make_mirror_trt_table (tem);
 328   Vmirror_ascii_downcase_table = tem;
 329   Vmirror_ascii_canon_table = tem;
 330 #endif
 331
 332   tem = MAKE_TRT_TABLE ();
 333   Vascii_upcase_table = tem;
 334   Vascii_eqv_table = tem;
 335
 336   for (i = 0; i < 256; i++)
 337     {
 338       unsigned char flipped = (isupper (i) ? tolower (i)
 339                                : (islower (i) ? toupper (i) : i));
 340
 341       SET_TRT_TABLE_CHAR_1 (tem, i, flipped);
 342     }
 343
 344 #ifdef MULE
 345   tem = make_mirror_trt_table (tem);
 346   Vmirror_ascii_upcase_table = tem;
 347   Vmirror_ascii_eqv_table = tem;
 348 #endif
 349 }