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