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 =
 193     standard ? XBUFFER(Vbuffer_defaults) : 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   buf->downcase_table = down;
 247   buf->upcase_table = up;
 248   buf->case_canon_table = canon;
 249   buf->case_eqv_table = eqv;
 250 #ifdef MULE
 251   buf->mirror_downcase_table = make_mirror_trt_table (down);
 252   buf->mirror_upcase_table = make_mirror_trt_table (up);
 253   buf->mirror_case_canon_table = make_mirror_trt_table (canon);
 254   buf->mirror_case_eqv_table = make_mirror_trt_table (eqv);
 255 #endif
 256
 257   return table;
 258 }
 259 \f
 260 /* Given a translate table TRT, store the inverse mapping into INVERSE.
 261    Since TRT is not one-to-one, INVERSE is not a simple mapping.
 262    Instead, it divides the space of characters into equivalence classes.
 263    All characters in a given class form one circular list, chained through
 264    the elements of INVERSE.  */
 265
 266 static void
 267 compute_trt_inverse (Lisp_Object trt, Lisp_Object inverse)
 268 {
 269   Charcount i = 0400;
 270   Emchar c, q;
 271
 272   while (--i)
 273     SET_TRT_TABLE_CHAR_1 (inverse, i, (Emchar) i);
 274   i = 0400;
 275   while (--i)
 276     {
 277       if ((q = TRT_TABLE_CHAR_1 (trt, i)) != (Emchar) i)
 278         {
 279           c = TRT_TABLE_CHAR_1 (inverse, q);
 280           SET_TRT_TABLE_CHAR_1 (inverse, q, (Emchar) i);
 281           SET_TRT_TABLE_CHAR_1 (inverse, i, c);
 282         }
 283     }
 284 }
 285
 286 \f
 287 void
 288 syms_of_casetab (void)
 289 {
 290   defsymbol (&Qcase_tablep, "case-table-p");
 291
 292   DEFSUBR (Fcase_table_p);
 293   DEFSUBR (Fcurrent_case_table);
 294   DEFSUBR (Fstandard_case_table);
 295   DEFSUBR (Fset_case_table);
 296   DEFSUBR (Fset_standard_case_table);
 297 }
 298
 299 void
 300 complex_vars_of_casetab (void)
 301 {
 302   REGISTER Emchar i;
 303   Lisp_Object tem;
 304
 305   staticpro (&Vascii_downcase_table);
 306   staticpro (&Vascii_upcase_table);
 307   staticpro (&Vascii_canon_table);
 308   staticpro (&Vascii_eqv_table);
 309
 310 #ifdef MULE
 311   staticpro (&Vmirror_ascii_downcase_table);
 312   staticpro (&Vmirror_ascii_upcase_table);
 313   staticpro (&Vmirror_ascii_canon_table);
 314   staticpro (&Vmirror_ascii_eqv_table);
 315 #endif
 316
 317   tem = MAKE_TRT_TABLE ();
 318   Vascii_downcase_table = tem;
 319   Vascii_canon_table = tem;
 320
 321   /* Under Mule, can't do set_string_char() until Vcharset_control_1
 322      and Vcharset_ascii are initialized. */
 323   for (i = 0; i < 256; i++)
 324     {
 325       unsigned char lowered = tolower (i);
 326
 327       SET_TRT_TABLE_CHAR_1 (tem, i, lowered);
 328     }
 329
 330 #ifdef MULE
 331   tem = make_mirror_trt_table (tem);
 332   Vmirror_ascii_downcase_table = tem;
 333   Vmirror_ascii_canon_table = tem;
 334 #endif
 335
 336   tem = MAKE_TRT_TABLE ();
 337   Vascii_upcase_table = tem;
 338   Vascii_eqv_table = tem;
 339
 340   for (i = 0; i < 256; i++)
 341     {
 342       unsigned char flipped = (isupper (i) ? tolower (i)
 343                                : (islower (i) ? toupper (i) : i));
 344
 345       SET_TRT_TABLE_CHAR_1 (tem, i, flipped);
 346     }
 347
 348 #ifdef MULE
 349   tem = make_mirror_trt_table (tem);
 350   Vmirror_ascii_upcase_table = tem;
 351   Vmirror_ascii_eqv_table = tem;
 352 #endif
 353 }