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   (Lisp_Object object)
  45 {
  46   Lisp_Object up, canon, eqv;
  47
  48   if (! CHAR_TABLE_P (object))
  49     return Qnil;
  50   if (! EQ (XCHAR_TABLE (object)->purpose, Qcase_table))
  51     return Qnil;
  52
  53   up = XCHAR_TABLE (object)->extras[0];
  54   canon = XCHAR_TABLE (object)->extras[1];
  55   eqv = XCHAR_TABLE (object)->extras[2];
  56
  57   return ((NILP (up) || CHAR_TABLE_P (up))
  58           && ((NILP (canon) && NILP (eqv))
  59               || (CHAR_TABLE_P (canon)
  60                   && (NILP (eqv) || CHAR_TABLE_P (eqv))))
  61           ? Qt : Qnil);
  62 }
  63
  64 static Lisp_Object
  65 check_case_table (Lisp_Object obj)
  66 {
  67   CHECK_TYPE (!NILP (Fcase_table_p (obj)), Qcase_table_p, obj);
  68   return (obj);
  69 }
  70
  71 DEFUN ("current-case-table", Fcurrent_case_table, Scurrent_case_table, 0, 0, 0,
  72        doc: /* Return the case table of the current buffer.  */)
  73   (void)
  74 {
  75   return current_buffer->downcase_table;
  76 }
  77
  78 DEFUN ("standard-case-table", Fstandard_case_table, Sstandard_case_table, 0, 0, 0,
  79        doc: /* Return the standard case table.
  80 This is the one used for new buffers.  */)
  81   (void)
  82 {
  83   return Vascii_downcase_table;
  84 }
  85
  86 static Lisp_Object set_case_table (Lisp_Object table, int standard);
  87
  88 DEFUN ("set-case-table", Fset_case_table, Sset_case_table, 1, 1, 0,
  89        doc: /* Select a new case table for the current buffer.
  90 A case table is a char-table which maps characters
  91 to their lower-case equivalents.  It also has three \"extra\" slots
  92 which may be additional char-tables or nil.
  93 These slots are called UPCASE, CANONICALIZE and EQUIVALENCES.
  94 UPCASE maps each non-upper-case character to its upper-case equivalent.
  95  (The value in UPCASE for an upper-case character is never used.)
  96  If lower and upper case characters are in 1-1 correspondence,
  97  you may use nil and the upcase table will be deduced from DOWNCASE.
  98 CANONICALIZE maps each character to a canonical equivalent;
  99  any two characters that are related by case-conversion have the same
 100  canonical equivalent character; it may be nil, in which case it is
 101  deduced from DOWNCASE and UPCASE.
 102 EQUIVALENCES is a map that cyclicly permutes each equivalence class
 103  (of characters with the same canonical equivalent); it may be nil,
 104  in which case it is deduced from CANONICALIZE.  */)
 105   (Lisp_Object table)
 106 {
 107   return set_case_table (table, 0);
 108 }
 109
 110 DEFUN ("set-standard-case-table", Fset_standard_case_table, Sset_standard_case_table, 1, 1, 0,
 111        doc: /* Select a new standard case table for new buffers.
 112 See `set-case-table' for more info on case tables.  */)
 113   (Lisp_Object table)
 114 {
 115   return set_case_table (table, 1);
 116 }
 117
 118 static Lisp_Object
 119 set_case_table (Lisp_Object table, int standard)
 120 {
 121   Lisp_Object up, canon, eqv;
 122
 123   check_case_table (table);
 124
 125   up = XCHAR_TABLE (table)->extras[0];
 126   canon = XCHAR_TABLE (table)->extras[1];
 127   eqv = XCHAR_TABLE (table)->extras[2];
 128
 129   if (NILP (up))
 130     {
 131       up = Fmake_char_table (Qcase_table, Qnil);
 132       map_char_table (set_identity, Qnil, table, up);
 133       map_char_table (shuffle, Qnil, table, up);
 134       XCHAR_TABLE (table)->extras[0] = up;
 135     }
 136
 137   if (NILP (canon))
 138     {
 139       canon = Fmake_char_table (Qcase_table, Qnil);
 140       XCHAR_TABLE (table)->extras[1] = canon;
 141       map_char_table (set_canon, Qnil, table, table);
 142     }
 143
 144   if (NILP (eqv))
 145     {
 146       eqv = Fmake_char_table (Qcase_table, Qnil);
 147       map_char_table (set_identity, Qnil, canon, eqv);
 148       map_char_table (shuffle, Qnil, canon, eqv);
 149       XCHAR_TABLE (table)->extras[2] = eqv;
 150     }
 151
 152   /* This is so set_image_of_range_1 in regex.c can find the EQV table.  */
 153   XCHAR_TABLE (canon)->extras[2] = eqv;
 154
 155   if (standard)
 156     {
 157       Vascii_downcase_table = table;
 158       Vascii_upcase_table = up;
 159       Vascii_canon_table = canon;
 160       Vascii_eqv_table = eqv;
 161     }
 162   else
 163     {
 164       current_buffer->downcase_table = table;
 165       current_buffer->upcase_table = up;
 166       current_buffer->case_canon_table = canon;
 167       current_buffer->case_eqv_table = eqv;
 168     }
 169
 170   return table;
 171 }
 172 \f
 173 /* The following functions are called in map_char_table.  */
 174
 175 /* Set CANON char-table element for characters in RANGE to a
 176    translated ELT by UP and DOWN char-tables.  This is done only when
 177    ELT is a character.  The char-tables CANON, UP, and DOWN are in
 178    CASE_TABLE.  */
 179
 180 static void
 181 set_canon (Lisp_Object case_table, Lisp_Object range, Lisp_Object elt)
 182 {
 183   Lisp_Object up = XCHAR_TABLE (case_table)->extras[0];
 184   Lisp_Object canon = XCHAR_TABLE (case_table)->extras[1];
 185
 186   if (NATNUMP (elt))
 187     Fset_char_table_range (canon, range, Faref (case_table, Faref (up, elt)));
 188 }
 189
 190 /* Set elements of char-table TABLE for C to C itself.  C may be a
 191    cons specifying a character range.  In that case, set characters in
 192    that range to themselves.  This is done only when ELT is a
 193    character.  This is called in map_char_table.  */
 194
 195 static void
 196 set_identity (Lisp_Object table, Lisp_Object c, Lisp_Object elt)
 197 {
 198   if (NATNUMP (elt))
 199     {
 200       int from, to;
 201
 202       if (CONSP (c))
 203         {
 204           from = XINT (XCAR (c));
 205           to = XINT (XCDR (c));
 206         }
 207       else
 208         from = to = XINT (c);
 209       for (; from <= to; from++)
 210         CHAR_TABLE_SET (table, from, make_number (from));
 211     }
 212 }
 213
 214 /* Permute the elements of TABLE (which is initially an identity
 215    mapping) so that it has one cycle for each equivalence class
 216    induced by the translation table on which map_char_table is
 217    operated.  */
 218
 219 static void
 220 shuffle (Lisp_Object table, Lisp_Object c, Lisp_Object elt)
 221 {
 222   if (NATNUMP (elt))
 223     {
 224       int from, to;
 225
 226       if (CONSP (c))
 227         {
 228           from = XINT (XCAR (c));
 229           to = XINT (XCDR (c));
 230         }
 231       else
 232         from = to = XINT (c);
 233
 234       for (; from <= to; from++)
 235         {
 236           Lisp_Object tem = Faref (table, elt);
 237           Faset (table, elt, make_number (from));
 238           Faset (table, make_number (from), tem);
 239         }
 240     }
 241 }
 242 \f
 243 void
 244 init_casetab_once (void)
 245 {
 246   register int i;
 247   Lisp_Object down, up;
 248   Qcase_table = intern_c_string ("case-table");
 249   staticpro (&Qcase_table);
 250
 251   /* Intern this now in case it isn't already done.
 252      Setting this variable twice is harmless.
 253      But don't staticpro it here--that is done in alloc.c.  */
 254   Qchar_table_extra_slots = intern_c_string ("char-table-extra-slots");
 255
 256   /* Now we are ready to set up this property, so we can
 257      create char tables.  */
 258   Fput (Qcase_table, Qchar_table_extra_slots, make_number (3));
 259
 260   down = Fmake_char_table (Qcase_table, Qnil);
 261   Vascii_downcase_table = down;
 262   XCHAR_TABLE (down)->purpose = Qcase_table;
 263
 264   for (i = 0; i < 128; i++)
 265     {
 266       int c = (i >= 'A' && i <= 'Z') ? i + ('a' - 'A') : i;
 267       CHAR_TABLE_SET (down, i, make_number (c));
 268     }
 269
 270   XCHAR_TABLE (down)->extras[1] = Fcopy_sequence (down);
 271
 272   up = Fmake_char_table (Qcase_table, Qnil);
 273   XCHAR_TABLE (down)->extras[0] = up;
 274
 275   for (i = 0; i < 128; i++)
 276     {
 277       int c = ((i >= 'A' && i <= 'Z') ? i + ('a' - 'A')
 278                : ((i >= 'a' && i <= 'z') ? i + ('A' - 'a')
 279                   : i));
 280       CHAR_TABLE_SET (up, i, make_number (c));
 281     }
 282
 283   XCHAR_TABLE (down)->extras[2] = Fcopy_sequence (up);
 284
 285   /* Fill in what isn't filled in.  */
 286   set_case_table (down, 1);
 287 }
 288
 289 void
 290 syms_of_casetab (void)
 291 {
 292   Qcase_table_p = intern_c_string ("case-table-p");
 293   staticpro (&Qcase_table_p);
 294
 295   staticpro (&Vascii_canon_table);
 296   staticpro (&Vascii_downcase_table);
 297   staticpro (&Vascii_eqv_table);
 298   staticpro (&Vascii_upcase_table);
 299
 300   defsubr (&Scase_table_p);
 301   defsubr (&Scurrent_case_table);
 302   defsubr (&Sstandard_case_table);
 303   defsubr (&Sset_case_table);
 304   defsubr (&Sset_standard_case_table);
 305 }
 306
 307 /* arch-tag: e06388ad-99fe-40ec-ba67-9d010fcc4916
 308    (do not change this comment) */