code.delx.au - gnu-emacs/blob - src/casetab.c

   1 /* GNU Emacs routines to deal with case tables.
   2    Copyright (C) 1993, 1994, 2001, 2002, 2003, 2004, 2005, 2006, 2007,
   3                  2008, 2009, 2010  Free Software Foundation, Inc.
   4
   5 Author: Howard Gayle
   6
   7 This file is part of GNU Emacs.
   8
   9 GNU Emacs is free software: you can redistribute it and/or modify
  10 it under the terms of the GNU General Public License as published by
  11 the Free Software Foundation, either version 3 of the License, or
  12 (at your option) any later version.
  13
  14 GNU Emacs is distributed in the hope that it will be useful,
  15 but WITHOUT ANY WARRANTY; without even the implied warranty of
  16 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  17 GNU General Public License for more details.
  18
  19 You should have received a copy of the GNU General Public License
  20 along with GNU Emacs.  If not, see <http://www.gnu.org/licenses/>.  */
  21
  22 #include <config.h>
  23 #include <setjmp.h>
  24 #include "lisp.h"
  25 #include "buffer.h"
  26 #include "character.h"
  27
  28 Lisp_Object Qcase_table_p, Qcase_table;
  29 Lisp_Object Vascii_downcase_table, Vascii_upcase_table;
  30 Lisp_Object Vascii_canon_table, Vascii_eqv_table;
  31
  32 /* Used as a temporary in DOWNCASE and other macros in lisp.h.  No
  33    need to mark it, since it is used only very temporarily.  */
  34 int case_temp1;
  35 Lisp_Object case_temp2;
  36
  37 static void set_canon (Lisp_Object case_table, Lisp_Object range, Lisp_Object elt);
  38 static void set_identity (Lisp_Object table, Lisp_Object c, Lisp_Object elt);
  39 static void shuffle (Lisp_Object table, Lisp_Object c, Lisp_Object elt);
  40
  41 DEFUN ("case-table-p", Fcase_table_p, Scase_table_p, 1, 1, 0,
  42        doc: /* Return t if OBJECT is a case table.
  43 See `set-case-table' for more information on these data structures.  */)
  44      (object)
  45      Lisp_Object object;
  46 {
  47   Lisp_Object up, canon, eqv;
  48
  49   if (! CHAR_TABLE_P (object))
  50     return Qnil;
  51   if (! EQ (XCHAR_TABLE (object)->purpose, Qcase_table))
  52     return Qnil;
  53
  54   up = XCHAR_TABLE (object)->extras[0];
  55   canon = XCHAR_TABLE (object)->extras[1];
  56   eqv = XCHAR_TABLE (object)->extras[2];
  57
  58   return ((NILP (up) || CHAR_TABLE_P (up))
  59           && ((NILP (canon) && NILP (eqv))
  60               || (CHAR_TABLE_P (canon)
  61                   && (NILP (eqv) || CHAR_TABLE_P (eqv))))
  62           ? Qt : Qnil);
  63 }
  64
  65 static Lisp_Object
  66 check_case_table (Lisp_Object obj)
  67 {
  68   CHECK_TYPE (!NILP (Fcase_table_p (obj)), Qcase_table_p, obj);
  69   return (obj);
  70 }
  71
  72 DEFUN ("current-case-table", Fcurrent_case_table, Scurrent_case_table, 0, 0, 0,
  73        doc: /* Return the case table of the current buffer.  */)
  74      ()
  75 {
  76   return current_buffer->downcase_table;
  77 }
  78
  79 DEFUN ("standard-case-table", Fstandard_case_table, Sstandard_case_table, 0, 0, 0,
  80        doc: /* Return the standard case table.
  81 This is the one used for new buffers.  */)
  82      ()
  83 {
  84   return Vascii_downcase_table;
  85 }
  86
  87 static Lisp_Object set_case_table (Lisp_Object table, int standard);
  88
  89 DEFUN ("set-case-table", Fset_case_table, Sset_case_table, 1, 1, 0,
  90        doc: /* Select a new case table for the current buffer.
  91 A case table is a char-table which maps characters
  92 to their lower-case equivalents.  It also has three \"extra\" slots
  93 which may be additional char-tables or nil.
  94 These slots are called UPCASE, CANONICALIZE and EQUIVALENCES.
  95 UPCASE maps each non-upper-case character to its upper-case equivalent.
  96  (The value in UPCASE for an upper-case character is never used.)
  97  If lower and upper case characters are in 1-1 correspondence,
  98  you may use nil and the upcase table will be deduced from DOWNCASE.
  99 CANONICALIZE maps each character to a canonical equivalent;
 100  any two characters that are related by case-conversion have the same
 101  canonical equivalent character; it may be nil, in which case it is
 102  deduced from DOWNCASE and UPCASE.
 103 EQUIVALENCES is a map that cyclicly permutes each equivalence class
 104  (of characters with the same canonical equivalent); it may be nil,
 105  in which case it is deduced from CANONICALIZE.  */)
 106      (table)
 107      Lisp_Object table;
 108 {
 109   return set_case_table (table, 0);
 110 }
 111
 112 DEFUN ("set-standard-case-table", Fset_standard_case_table, Sset_standard_case_table, 1, 1, 0,
 113        doc: /* Select a new standard case table for new buffers.
 114 See `set-case-table' for more info on case tables.  */)
 115      (table)
 116      Lisp_Object table;
 117 {
 118   return set_case_table (table, 1);
 119 }
 120
 121 static Lisp_Object
 122 set_case_table (Lisp_Object table, int standard)
 123 {
 124   Lisp_Object up, canon, eqv;
 125
 126   check_case_table (table);
 127
 128   up = XCHAR_TABLE (table)->extras[0];
 129   canon = XCHAR_TABLE (table)->extras[1];
 130   eqv = XCHAR_TABLE (table)->extras[2];
 131
 132   if (NILP (up))
 133     {
 134       up = Fmake_char_table (Qcase_table, Qnil);
 135       map_char_table (set_identity, Qnil, table, up);
 136       map_char_table (shuffle, Qnil, table, up);
 137       XCHAR_TABLE (table)->extras[0] = up;
 138     }
 139
 140   if (NILP (canon))
 141     {
 142       canon = Fmake_char_table (Qcase_table, Qnil);
 143       XCHAR_TABLE (table)->extras[1] = canon;
 144       map_char_table (set_canon, Qnil, table, table);
 145     }
 146
 147   if (NILP (eqv))
 148     {
 149       eqv = Fmake_char_table (Qcase_table, Qnil);
 150       map_char_table (set_identity, Qnil, canon, eqv);
 151       map_char_table (shuffle, Qnil, canon, eqv);
 152       XCHAR_TABLE (table)->extras[2] = eqv;
 153     }
 154
 155   /* This is so set_image_of_range_1 in regex.c can find the EQV table.  */
 156   XCHAR_TABLE (canon)->extras[2] = eqv;
 157
 158   if (standard)
 159     {
 160       Vascii_downcase_table = table;
 161       Vascii_upcase_table = up;
 162       Vascii_canon_table = canon;
 163       Vascii_eqv_table = eqv;
 164     }
 165   else
 166     {
 167       current_buffer->downcase_table = table;
 168       current_buffer->upcase_table = up;
 169       current_buffer->case_canon_table = canon;
 170       current_buffer->case_eqv_table = eqv;
 171     }
 172
 173   return table;
 174 }
 175 \f
 176 /* The following functions are called in map_char_table.  */
 177
 178 /* Set CANON char-table element for characters in RANGE to a
 179    translated ELT by UP and DOWN char-tables.  This is done only when
 180    ELT is a character.  The char-tables CANON, UP, and DOWN are in
 181    CASE_TABLE.  */
 182
 183 static void
 184 set_canon (Lisp_Object case_table, Lisp_Object range, Lisp_Object elt)
 185 {
 186   Lisp_Object up = XCHAR_TABLE (case_table)->extras[0];
 187   Lisp_Object canon = XCHAR_TABLE (case_table)->extras[1];
 188
 189   if (NATNUMP (elt))
 190     Fset_char_table_range (canon, range, Faref (case_table, Faref (up, elt)));
 191 }
 192
 193 /* Set elements of char-table TABLE for C to C itself.  C may be a
 194    cons specifying a character range.  In that case, set characters in
 195    that range to themselves.  This is done only when ELT is a
 196    character.  This is called in map_char_table.  */
 197
 198 static void
 199 set_identity (Lisp_Object table, Lisp_Object c, Lisp_Object elt)
 200 {
 201   if (NATNUMP (elt))
 202     {
 203       int from, to;
 204
 205       if (CONSP (c))
 206         {
 207           from = XINT (XCAR (c));
 208           to = XINT (XCDR (c));
 209         }
 210       else
 211         from = to = XINT (c);
 212       for (; from <= to; from++)
 213         CHAR_TABLE_SET (table, from, make_number (from));
 214     }
 215 }
 216
 217 /* Permute the elements of TABLE (which is initially an identity
 218    mapping) so that it has one cycle for each equivalence class
 219    induced by the translation table on which map_char_table is
 220    operated.  */
 221
 222 static void
 223 shuffle (Lisp_Object table, Lisp_Object c, Lisp_Object elt)
 224 {
 225   if (NATNUMP (elt))
 226     {
 227       int from, to;
 228
 229       if (CONSP (c))
 230         {
 231           from = XINT (XCAR (c));
 232           to = XINT (XCDR (c));
 233         }
 234       else
 235         from = to = XINT (c);
 236
 237       for (; from <= to; from++)
 238         {
 239           Lisp_Object tem = Faref (table, elt);
 240           Faset (table, elt, make_number (from));
 241           Faset (table, make_number (from), tem);
 242         }
 243     }
 244 }
 245 \f
 246 void
 247 init_casetab_once (void)
 248 {
 249   register int i;
 250   Lisp_Object down, up;
 251   Qcase_table = intern_c_string ("case-table");
 252   staticpro (&Qcase_table);
 253
 254   /* Intern this now in case it isn't already done.
 255      Setting this variable twice is harmless.
 256      But don't staticpro it here--that is done in alloc.c.  */
 257   Qchar_table_extra_slots = intern_c_string ("char-table-extra-slots");
 258
 259   /* Now we are ready to set up this property, so we can
 260      create char tables.  */
 261   Fput (Qcase_table, Qchar_table_extra_slots, make_number (3));
 262
 263   down = Fmake_char_table (Qcase_table, Qnil);
 264   Vascii_downcase_table = down;
 265   XCHAR_TABLE (down)->purpose = Qcase_table;
 266
 267   for (i = 0; i < 128; i++)
 268     {
 269       int c = (i >= 'A' && i <= 'Z') ? i + ('a' - 'A') : i;
 270       CHAR_TABLE_SET (down, i, make_number (c));
 271     }
 272
 273   XCHAR_TABLE (down)->extras[1] = Fcopy_sequence (down);
 274
 275   up = Fmake_char_table (Qcase_table, Qnil);
 276   XCHAR_TABLE (down)->extras[0] = up;
 277
 278   for (i = 0; i < 128; i++)
 279     {
 280       int c = ((i >= 'A' && i <= 'Z') ? i + ('a' - 'A')
 281                : ((i >= 'a' && i <= 'z') ? i + ('A' - 'a')
 282                   : i));
 283       CHAR_TABLE_SET (up, i, make_number (c));
 284     }
 285
 286   XCHAR_TABLE (down)->extras[2] = Fcopy_sequence (up);
 287
 288   /* Fill in what isn't filled in.  */
 289   set_case_table (down, 1);
 290 }
 291
 292 void
 293 syms_of_casetab (void)
 294 {
 295   Qcase_table_p = intern_c_string ("case-table-p");
 296   staticpro (&Qcase_table_p);
 297
 298   staticpro (&Vascii_canon_table);
 299   staticpro (&Vascii_downcase_table);
 300   staticpro (&Vascii_eqv_table);
 301   staticpro (&Vascii_upcase_table);
 302
 303   defsubr (&Scase_table_p);
 304   defsubr (&Scurrent_case_table);
 305   defsubr (&Sstandard_case_table);
 306   defsubr (&Sset_case_table);
 307   defsubr (&Sset_standard_case_table);
 308 }
 309
 310 /* arch-tag: e06388ad-99fe-40ec-ba67-9d010fcc4916
 311    (do not change this comment) */