src/casetab.c

   1 /* GNU Emacs routines to deal with case tables.
   2    Copyright (C) 1993 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 1, 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) \
  45   (XTYPE (obj) == Lisp_String && XSTRING (obj)->size == 256)
  46
  47   return (STRING256_P (down)
  48           && (NILP (up) || STRING256_P (up))
  49           && ((NILP (canon) && NILP (eqv))
  50               || (STRING256_P (canon) && 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.\n\
 103 EQUIVALENCES is a map that cyclicly permutes each equivalence class\n\
 104  (of characters with the same canonical equivalent).\n\
 105 Both CANONICALIZE and EQUIVALENCES may be nil, in which case\n\
 106  both are deduced from DOWNCASE and UPCASE.")
 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       eqv = Fmake_string (make_number (256), make_number (0));
 150
 151       /* Set up the CANON vector; for each character,
 152          this sequence of upcasing and downcasing ought to
 153          get the "preferred" lowercase equivalent.  */
 154       for (i = 0; i < 256; i++)
 155         XSTRING (canon)->data[i] = downvec[upvec[downvec[i]]];
 156
 157       compute_trt_inverse (XSTRING (canon)->data, XSTRING (eqv)->data);
 158     }
 159
 160   if (standard)
 161     {
 162       Vascii_downcase_table = down;
 163       Vascii_upcase_table = up;
 164       Vascii_canon_table = canon;
 165       Vascii_eqv_table = eqv;
 166     }
 167   else
 168     {
 169       current_buffer->downcase_table = down;
 170       current_buffer->upcase_table = up;
 171       current_buffer->case_canon_table = canon;
 172       current_buffer->case_eqv_table = eqv;
 173     }
 174   return table;
 175 }
 176 \f
 177 /* Given a translate table TRT, store the inverse mapping into INVERSE.
 178    Since TRT is not one-to-one, INVERSE is not a simple mapping.
 179    Instead, it divides the space of characters into equivalence classes.
 180    All characters in a given class form one circular list, chained through
 181    the elements of INVERSE.  */
 182
 183 void
 184 compute_trt_inverse (trt, inverse)
 185      register unsigned char *trt;
 186      register unsigned char *inverse;
 187 {
 188   register int i = 0400;
 189   register unsigned char c, q;
 190
 191   while (i--)
 192     inverse[i] = i;
 193   i = 0400;
 194   while (i--)
 195     {
 196       if ((q = trt[i]) != (unsigned char) i)
 197         {
 198           c = inverse[q];
 199           inverse[q] = i;
 200           inverse[i] = c;
 201         }
 202     }
 203 }
 204 \f
 205 init_casetab_once ()
 206 {
 207   register int i;
 208   Lisp_Object tem;
 209
 210   tem = Fmake_string (make_number (256), make_number (0));
 211   Vascii_downcase_table = tem;
 212   Vascii_canon_table = tem;
 213
 214   for (i = 0; i < 256; i++)
 215     XSTRING (tem)->data[i] = (i >= 'A' && i <= 'Z') ? i + 040 : i;
 216
 217   tem = Fmake_string (make_number (256), make_number (0));
 218   Vascii_upcase_table = tem;
 219   Vascii_eqv_table = tem;
 220
 221   for (i = 0; i < 256; i++)
 222     XSTRING (tem)->data[i]
 223       = ((i >= 'A' && i <= 'Z')
 224          ? i + ('a' - 'A')
 225          : ((i >= 'a' && i <= 'z')
 226             ? i + ('A' - 'a')
 227             : i));
 228 }
 229
 230 syms_of_casetab ()
 231 {
 232   Qcase_table_p = intern ("case-table-p");
 233   staticpro (&Qcase_table_p);
 234   staticpro (&Vascii_downcase_table);
 235   staticpro (&Vascii_upcase_table);
 236   staticpro (&Vascii_canon_table);
 237   staticpro (&Vascii_eqv_table);
 238
 239   defsubr (&Scase_table_p);
 240   defsubr (&Scurrent_case_table);
 241   defsubr (&Sstandard_case_table);
 242   defsubr (&Sset_case_table);
 243   defsubr (&Sset_standard_case_table);
 244
 245 #if 0
 246   DEFVAR_LISP ("ascii-downcase-table", &Vascii_downcase_table,
 247                "String mapping ASCII characters to lowercase equivalents.");
 248   DEFVAR_LISP ("ascii-upcase-table", &Vascii_upcase_table,
 249                "String mapping ASCII characters to uppercase equivalents.");
 250 #endif
 251 }