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