src/casetab.c

   1 /* GNU Emacs routines to deal with case tables.
   2    Copyright (C) 1993, 1994 Free Software Foundation, Inc.
   3
   4 This file is part of GNU Emacs.
   5
   6 GNU Emacs is free software; you can redistribute it and/or modify
   7 it under the terms of the GNU General Public License as published by
   8 the Free Software Foundation; either version 2, or (at your option)
   9 any later version.
  10
  11 GNU Emacs is distributed in the hope that it will be useful,
  12 but WITHOUT ANY WARRANTY; without even the implied warranty of
  13 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  14 GNU General Public License for more details.
  15
  16 You should have received a copy of the GNU General Public License
  17 along with GNU Emacs; see the file COPYING.  If not, write to
  18 the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.  */
  19
  20 /* Written by Howard Gayle.  See chartab.c for details. */
  21
  22 #include <config.h>
  23 #include "lisp.h"
  24 #include "buffer.h"
  25
  26 Lisp_Object Qcase_table_p;
  27 Lisp_Object Vascii_downcase_table, Vascii_upcase_table;
  28 Lisp_Object Vascii_canon_table, Vascii_eqv_table;
  29
  30 void compute_trt_inverse ();
  31
  32 DEFUN ("case-table-p", Fcase_table_p, Scase_table_p, 1, 1, 0,
  33   "Return t iff ARG is a case table.\n\
  34 See `set-case-table' for more information on these data structures.")
  35   (table)
  36      Lisp_Object table;
  37 {
  38   Lisp_Object down, up, canon, eqv;
  39   down = Fcar_safe (table);
  40   up = Fcar_safe (Fcdr_safe (table));
  41   canon = Fcar_safe (Fcdr_safe (Fcdr_safe (table)));
  42   eqv = Fcar_safe (Fcdr_safe (Fcdr_safe (Fcdr_safe (table))));
  43
  44 #define STRING256_P(obj) (STRINGP (obj) && XSTRING (obj)->size == 256)
  45
  46   return (STRING256_P (down)
  47           && (NILP (up) || STRING256_P (up))
  48           && ((NILP (canon) && NILP (eqv))
  49               || (STRING256_P (canon)
  50                   && (NILP (eqv) || STRING256_P (eqv))))
  51           ? Qt : Qnil);
  52 }
  53
  54 static Lisp_Object
  55 check_case_table (obj)
  56      Lisp_Object obj;
  57 {
  58   register Lisp_Object tem;
  59
  60   while (tem = Fcase_table_p (obj), NILP (tem))
  61     obj = wrong_type_argument (Qcase_table_p, obj);
  62   return (obj);
  63 }
  64
  65 DEFUN ("current-case-table", Fcurrent_case_table, Scurrent_case_table, 0, 0, 0,
  66   "Return the case table of the current buffer.")
  67   ()
  68 {
  69   Lisp_Object down, up, canon, eqv;
  70
  71   down = current_buffer->downcase_table;
  72   up = current_buffer->upcase_table;
  73   canon = current_buffer->case_canon_table;
  74   eqv = current_buffer->case_eqv_table;
  75
  76   return Fcons (down, Fcons (up, Fcons (canon, Fcons (eqv, Qnil))));
  77 }
  78
  79 DEFUN ("standard-case-table", Fstandard_case_table, Sstandard_case_table, 0, 0, 0,
  80   "Return the standard case table.\n\
  81 This is the one used for new buffers.")
  82   ()
  83 {
  84   return Fcons (Vascii_downcase_table,
  85                 Fcons (Vascii_upcase_table,
  86                        Fcons (Vascii_canon_table,
  87                               Fcons (Vascii_eqv_table, Qnil))));
  88 }
  89
  90 static Lisp_Object set_case_table ();
  91
  92 DEFUN ("set-case-table", Fset_case_table, Sset_case_table, 1, 1, 0,
  93   "Select a new case table for the current buffer.\n\
  94 A case table is a list (DOWNCASE UPCASE CANONICALIZE EQUIVALENCES)\n\
  95  where each element is either nil or a string of length 256.\n\
  96 DOWNCASE maps each character to its lower-case equivalent.\n\
  97 UPCASE maps each character to its upper-case equivalent;\n\
  98  if lower and upper case characters are in 1-1 correspondence,\n\
  99  you may use nil and the upcase table will be deduced from DOWNCASE.\n\
 100 CANONICALIZE maps each character to a canonical equivalent;\n\
 101  any two characters that are related by case-conversion have the same\n\
 102  canonical equivalent character; it may be nil, in which case it is\n\
 103  deduced from DOWNCASE and UPCASE.\n\
 104 EQUIVALENCES is a map that cyclicly permutes each equivalence class\n\
 105  (of characters with the same canonical equivalent); it may be nil,\n\
 106  in which case it is deduced from CANONICALIZE.")
 107   (table)
 108      Lisp_Object table;
 109 {
 110   return set_case_table (table, 0);
 111 }
 112
 113 DEFUN ("set-standard-case-table", Fset_standard_case_table, Sset_standard_case_table, 1, 1, 0,
 114   "Select a new standard case table for new buffers.\n\
 115 See `set-case-table' for more info on case tables.")
 116   (table)
 117      Lisp_Object table;
 118 {
 119   return set_case_table (table, 1);
 120 }
 121
 122 static Lisp_Object
 123 set_case_table (table, standard)
 124      Lisp_Object table;
 125      int standard;
 126 {
 127   Lisp_Object down, up, canon, eqv;
 128
 129   check_case_table (table);
 130
 131   down = Fcar_safe (table);
 132   up = Fcar_safe (Fcdr_safe (table));
 133   canon = Fcar_safe (Fcdr_safe (Fcdr_safe (table)));
 134   eqv = Fcar_safe (Fcdr_safe (Fcdr_safe (Fcdr_safe (table))));
 135
 136   if (NILP (up))
 137     {
 138       up = Fmake_string (make_number (256), make_number (0));
 139       compute_trt_inverse (XSTRING (down)->data, XSTRING (up)->data);
 140     }
 141
 142   if (NILP (canon))
 143     {
 144       register int i;
 145       unsigned char *upvec = XSTRING (up)->data;
 146       unsigned char *downvec = XSTRING (down)->data;
 147
 148       canon = Fmake_string (make_number (256), make_number (0));
 149
 150       /* Set up the CANON vector; for each character,
 151          this sequence of upcasing and downcasing ought to
 152          get the "preferred" lowercase equivalent.  */
 153       for (i = 0; i < 256; i++)
 154         XSTRING (canon)->data[i] = downvec[upvec[downvec[i]]];
 155     }
 156
 157   if (NILP (eqv))
 158     {
 159       eqv = Fmake_string (make_number (256), make_number (0));
 160
 161       compute_trt_inverse (XSTRING (canon)->data, XSTRING (eqv)->data);
 162     }
 163
 164   if (standard)
 165     {
 166       Vascii_downcase_table = down;
 167       Vascii_upcase_table = up;
 168       Vascii_canon_table = canon;
 169       Vascii_eqv_table = eqv;
 170     }
 171   else
 172     {
 173       current_buffer->downcase_table = down;
 174       current_buffer->upcase_table = up;
 175       current_buffer->case_canon_table = canon;
 176       current_buffer->case_eqv_table = eqv;
 177     }
 178   return table;
 179 }
 180 \f
 181 /* Given a translate table TRT, store the inverse mapping into INVERSE.
 182    Since TRT is not one-to-one, INVERSE is not a simple mapping.
 183    Instead, it divides the space of characters into equivalence classes.
 184    All characters in a given class form one circular list, chained through
 185    the elements of INVERSE.  */
 186
 187 void
 188 compute_trt_inverse (trt, inverse)
 189      register unsigned char *trt;
 190      register unsigned char *inverse;
 191 {
 192   register int i = 0400;
 193   register unsigned char c, q;
 194
 195   while (i--)
 196     inverse[i] = i;
 197   i = 0400;
 198   while (i--)
 199     {
 200       if ((q = trt[i]) != (unsigned char) i)
 201         {
 202           c = inverse[q];
 203           inverse[q] = i;
 204           inverse[i] = c;
 205         }
 206     }
 207 }
 208 \f
 209 init_casetab_once ()
 210 {
 211   register int i;
 212   Lisp_Object tem;
 213
 214   tem = Fmake_string (make_number (256), make_number (0));
 215   Vascii_downcase_table = tem;
 216   Vascii_canon_table = tem;
 217
 218   for (i = 0; i < 256; i++)
 219     XSTRING (tem)->data[i] = (i >= 'A' && i <= 'Z') ? i + 040 : i;
 220
 221   tem = Fmake_string (make_number (256), make_number (0));
 222   Vascii_upcase_table = tem;
 223   Vascii_eqv_table = tem;
 224
 225   for (i = 0; i < 256; i++)
 226     XSTRING (tem)->data[i]
 227       = ((i >= 'A' && i <= 'Z')
 228          ? i + ('a' - 'A')
 229          : ((i >= 'a' && i <= 'z')
 230             ? i + ('A' - 'a')
 231             : i));
 232 }
 233
 234 syms_of_casetab ()
 235 {
 236   Qcase_table_p = intern ("case-table-p");
 237   staticpro (&Qcase_table_p);
 238   staticpro (&Vascii_downcase_table);
 239   staticpro (&Vascii_upcase_table);
 240   staticpro (&Vascii_canon_table);
 241   staticpro (&Vascii_eqv_table);
 242
 243   defsubr (&Scase_table_p);
 244   defsubr (&Scurrent_case_table);
 245   defsubr (&Sstandard_case_table);
 246   defsubr (&Sset_case_table);
 247   defsubr (&Sset_standard_case_table);
 248
 249 #if 0
 250   DEFVAR_LISP ("ascii-downcase-table", &Vascii_downcase_table,
 251                "String mapping ASCII characters to lowercase equivalents.");
 252   DEFVAR_LISP ("ascii-upcase-table", &Vascii_upcase_table,
 253                "String mapping ASCII characters to uppercase equivalents.");
 254 #endif
 255 }