code.delx.au - gnu-emacs/blob - 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, Qcase_table;
  27 Lisp_Object Vascii_downcase_table, Vascii_upcase_table;
  28 Lisp_Object Vascii_canon_table, Vascii_eqv_table;
  29
  30 static 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 up, canon, eqv;
  39
  40   if (! CHAR_TABLE_P (table))
  41     return Qnil;
  42   if (! EQ (XCHAR_TABLE (table)->purpose, Qcase_table))
  43     return Qnil;
  44
  45   up = XCHAR_TABLE (table)->extras[0];
  46   canon = XCHAR_TABLE (table)->extras[1];
  47   eqv = XCHAR_TABLE (table)->extras[2];
  48
  49   return ((NILP (up) || CHAR_TABLE_P (up))
  50           && ((NILP (canon) && NILP (eqv))
  51               || (CHAR_TABLE_P (canon)
  52                   && (NILP (eqv) || CHAR_TABLE_P (eqv))))
  53           ? Qt : Qnil);
  54 }
  55
  56 static Lisp_Object
  57 check_case_table (obj)
  58      Lisp_Object obj;
  59 {
  60   register Lisp_Object tem;
  61
  62   while (tem = Fcase_table_p (obj), NILP (tem))
  63     obj = wrong_type_argument (Qcase_table_p, obj);
  64   return (obj);
  65 }
  66
  67 DEFUN ("current-case-table", Fcurrent_case_table, Scurrent_case_table, 0, 0, 0,
  68   "Return the case table of the current buffer.")
  69   ()
  70 {
  71   return current_buffer->downcase_table;
  72 }
  73
  74 DEFUN ("standard-case-table", Fstandard_case_table, Sstandard_case_table, 0, 0, 0,
  75   "Return the standard case table.\n\
  76 This is the one used for new buffers.")
  77   ()
  78 {
  79   return Vascii_downcase_table;
  80 }
  81
  82 static Lisp_Object set_case_table ();
  83
  84 DEFUN ("set-case-table", Fset_case_table, Sset_case_table, 1, 1, 0,
  85   "Select a new case table for the current buffer.\n\
  86 A case table is a char-table which maps characters\n\
  87 to their lower-case equivalents.  It also has three \"extra\" slots\n\
  88 which may be additional char-tables or nil.\n\
  89 These slots are called UPCASE, CANONICALIZE and EQUIVALENCES.\n\
  90 UPCASE maps each character to its upper-case equivalent;\n\
  91  if lower and upper case characters are in 1-1 correspondence,\n\
  92  you may use nil and the upcase table will be deduced from DOWNCASE.\n\
  93 CANONICALIZE maps each character to a canonical equivalent;\n\
  94  any two characters that are related by case-conversion have the same\n\
  95  canonical equivalent character; it may be nil, in which case it is\n\
  96  deduced from DOWNCASE and UPCASE.\n\
  97 EQUIVALENCES is a map that cyclicly permutes each equivalence class\n\
  98  (of characters with the same canonical equivalent); it may be nil,\n\
  99  in which case it is deduced from CANONICALIZE.")
 100   (table)
 101      Lisp_Object table;
 102 {
 103   return set_case_table (table, 0);
 104 }
 105
 106 DEFUN ("set-standard-case-table", Fset_standard_case_table, Sset_standard_case_table, 1, 1, 0,
 107   "Select a new standard case table for new buffers.\n\
 108 See `set-case-table' for more info on case tables.")
 109   (table)
 110      Lisp_Object table;
 111 {
 112   return set_case_table (table, 1);
 113 }
 114
 115 static Lisp_Object
 116 set_case_table (table, standard)
 117      Lisp_Object table;
 118      int standard;
 119 {
 120   Lisp_Object up, canon, eqv;
 121
 122   check_case_table (table);
 123
 124   up = XCHAR_TABLE (table)->extras[0];
 125   canon = XCHAR_TABLE (table)->extras[1];
 126   eqv = XCHAR_TABLE (table)->extras[2];
 127
 128   if (NILP (up))
 129     {
 130       up = Fmake_char_table (Qcase_table, Qnil);
 131       compute_trt_inverse (XCHAR_TABLE (table), XCHAR_TABLE (up));
 132       XCHAR_TABLE (table)->extras[0] = up;
 133     }
 134
 135   if (NILP (canon))
 136     {
 137       register int i;
 138       Lisp_Object *upvec = XCHAR_TABLE (up)->contents;
 139       Lisp_Object *downvec = XCHAR_TABLE (table)->contents;
 140
 141       canon = Fmake_char_table (Qcase_table, Qnil);
 142
 143       /* Set up the CANON vector; for each character,
 144          this sequence of upcasing and downcasing ought to
 145          get the "preferred" lowercase equivalent.  */
 146       for (i = 0; i < 256; i++)
 147         XCHAR_TABLE (canon)->contents[i] = downvec[upvec[downvec[i]]];
 148       XCHAR_TABLE (table)->extras[1] = canon;
 149     }
 150
 151   if (NILP (eqv))
 152     {
 153       eqv = Fmake_char_table (Qcase_table, Qnil);
 154       compute_trt_inverse (XCHAR_TABLE (canon), XCHAR_TABLE (eqv));
 155       XCHAR_TABLE (table)->extras[2] = eqv;
 156     }
 157
 158   if (standard)
 159     Vascii_downcase_table = table;
 160   else
 161     current_buffer->downcase_table = table;
 162
 163   return table;
 164 }
 165 \f
 166 /* Given a translate table TRT, store the inverse mapping into INVERSE.
 167    Since TRT is not one-to-one, INVERSE is not a simple mapping.
 168    Instead, it divides the space of characters into equivalence classes.
 169    All characters in a given class form one circular list, chained through
 170    the elements of INVERSE.  */
 171
 172 static void
 173 compute_trt_inverse (trt, inverse)
 174      struct Lisp_Char_Table *trt, *inverse;
 175 {
 176   register int i = 0400;
 177   register unsigned char c, q;
 178
 179   while (i--)
 180     inverse->contents[i] = i;
 181   i = 0400;
 182   while (i--)
 183     {
 184       if ((q = trt->contents[i]) != (unsigned char) i)
 185         {
 186           c = inverse->contents[q];
 187           inverse->contents[q] = i;
 188           inverse->contents[i] = c;
 189         }
 190     }
 191 }
 192 \f
 193 init_casetab_once ()
 194 {
 195   register int i;
 196   Lisp_Object down, up;
 197   Qcase_table = intern ("case-table");
 198   staticpro (&Qcase_table);
 199
 200   /* Intern this now in case it isn't already done.
 201      Setting this variable twice is harmless.
 202      But don't staticpro it here--that is done in alloc.c.  */
 203   Qchar_table_extra_slots = intern ("char-table-extra-slots");
 204
 205   /* Now we are ready to set up this property, so we can
 206      create char tables.  */
 207   Fput (Qcase_table, Qchar_table_extra_slots, make_number (3));
 208
 209   down = Fmake_char_table (Qcase_table, Qnil);
 210   Vascii_downcase_table = down;
 211
 212   for (i = 0; i < 256; i++)
 213     XCHAR_TABLE (down)->contents[i] = (i >= 'A' && i <= 'Z') ? i + 040 : i;
 214
 215   XCHAR_TABLE (down)->extras[1] = Fcopy_sequence (down);
 216
 217   up = Fmake_char_table (Qcase_table, Qnil);
 218   XCHAR_TABLE (down)->extras[0] = up;
 219
 220   for (i = 0; i < 256; i++)
 221     XCHAR_TABLE (up)->contents[i]
 222       = ((i >= 'A' && i <= 'Z')
 223          ? i + ('a' - 'A')
 224          : ((i >= 'a' && i <= 'z')
 225             ? i + ('A' - 'a')
 226             : i));
 227
 228   XCHAR_TABLE (down)->extras[2] = Fcopy_sequence (up);
 229 }
 230
 231 syms_of_casetab ()
 232 {
 233   Qcase_table_p = intern ("case-table-p");
 234   staticpro (&Qcase_table_p);
 235
 236   staticpro (&Vascii_downcase_table);
 237
 238   defsubr (&Scase_table_p);
 239   defsubr (&Scurrent_case_table);
 240   defsubr (&Sstandard_case_table);
 241   defsubr (&Sset_case_table);
 242   defsubr (&Sset_standard_case_table);
 243 }