src/casetab.c

   1 /* GNU Emacs routines to deal with case tables.
   2    Copyright (C) 1987 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, 0);
  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,
  80   Sstandard_case_table, 0, 0, 0,
  81   "Return the standard case table.\n\
  82 This is the one used for new buffers.")
  83   ()
  84 {
  85   return Fcons (Vascii_downcase_table,
  86                 Fcons (Vascii_upcase_table,
  87                        Fcons (Vascii_canon_table,
  88                               Fcons (Vascii_eqv_table, Qnil))));
  89 }
  90
  91 DEFUN ("set-case-table", Fset_case_table, Sset_case_table, 1, 1, 0,
  92   "Select a new case table for the current buffer.\n\
  93 A case table is a list (DOWNCASE UPCASE CANONICALIZE EQUIVALENCES)\n\
  94  where each element is either nil or a string of length 256.\n\
  95 DOWNCASE maps each character to its lower-case equivalent.\n\
  96 UPCASE maps each character to its upper-case equivalent;\n\
  97  if lower and upper case characters are in 1-1 correspondence,\n\
  98  you may use nil and the upcase table will be deduced from DOWNCASE.\n\
  99 CANONICALIZE maps each character to a canonical equivalent;\n\
 100  any two characters that are related by case-conversion have the same\n\
 101  canonical equivalent character.\n\
 102 EQUIVALENCES is a map that cyclicly permutes each equivalence class\n\
 103  (of characters with the same canonical equivalent).\n\
 104 Both CANONICALIZE and EQUIVALENCES may be nil, in which case\n\
 105  both are deduced from DOWNCASE and UPCASE.")
 106   (table)
 107      Lisp_Object table;
 108 {
 109   set_case_table (table, 0);
 110 }
 111
 112 DEFUN ("set-standard-case-table",
 113        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   set_case_table (table, 1);
 120 }
 121
 122 set_case_table (table, standard)
 123      Lisp_Object table;
 124      int standard;
 125 {
 126   Lisp_Object down, up, canon, eqv;
 127
 128   check_case_table (table);
 129
 130   down = Fcar_safe (table);
 131   up = Fcar_safe (Fcdr_safe (table));
 132   canon = Fcar_safe (Fcdr_safe (Fcdr_safe (table)));
 133   eqv = Fcar_safe (Fcdr_safe (Fcdr_safe (Fcdr_safe (table))));
 134
 135   if (NILP (up))
 136     {
 137       up = Fmake_string (make_number (256), make_number (0));
 138       compute_trt_inverse (XSTRING (down)->data, XSTRING (up)->data);
 139     }
 140
 141   if (NILP (canon))
 142     {
 143       register int i;
 144       unsigned char *upvec = XSTRING (up)->data;
 145       unsigned char *downvec = XSTRING (down)->data;
 146
 147       canon = Fmake_string (make_number (256), make_number (0));
 148       eqv = 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       compute_trt_inverse (XSTRING (canon)->data, XSTRING (eqv)->data);
 157     }
 158
 159   if (standard)
 160     {
 161       Vascii_downcase_table = down;
 162       Vascii_upcase_table = up;
 163       Vascii_canon_table = canon;
 164       Vascii_eqv_table = eqv;
 165     }
 166   else
 167     {
 168       current_buffer->downcase_table = down;
 169       current_buffer->upcase_table = up;
 170       current_buffer->case_canon_table = canon;
 171       current_buffer->case_eqv_table = eqv;
 172     }
 173   return table;
 174 }
 175 \f
 176 /* Given a translate table TRT, store the inverse mapping into INVERSE.
 177    Since TRT is not one-to-one, INVERSE is not a simple mapping.
 178    Instead, it divides the space of characters into equivalence classes.
 179    All characters in a given class form one circular list, chained through
 180    the elements of INVERSE.  */
 181
 182 void
 183 compute_trt_inverse (trt, inverse)
 184      register unsigned char *trt;
 185      register unsigned char *inverse;
 186 {
 187   register int i = 0400;
 188   register unsigned char c, q;
 189
 190   while (i--)
 191     inverse[i] = i;
 192   i = 0400;
 193   while (i--)
 194     {
 195       if ((q = trt[i]) != (unsigned char) i)
 196         {
 197           c = inverse[q];
 198           inverse[q] = i;
 199           inverse[i] = c;
 200         }
 201     }
 202 }
 203 \f
 204 init_casetab_once ()
 205 {
 206   register int i;
 207   Lisp_Object tem;
 208
 209   tem = Fmake_string (make_number (256), make_number (0));
 210   Vascii_downcase_table = tem;
 211   Vascii_canon_table = tem;
 212
 213   for (i = 0; i < 256; i++)
 214     XSTRING (tem)->data[i] = (i >= 'A' && i <= 'Z') ? i + 040 : i;
 215
 216   tem = Fmake_string (make_number (256), make_number (0));
 217   Vascii_upcase_table = tem;
 218   Vascii_eqv_table = tem;
 219
 220   for (i = 0; i < 256; i++)
 221     XSTRING (tem)->data[i]
 222       = ((i >= 'A' && i <= 'Z')
 223          ? i + ('a' - 'A')
 224          : ((i >= 'a' && i <= 'z')
 225             ? i + ('A' - 'a')
 226             : i));
 227 }
 228
 229 syms_of_casetab ()
 230 {
 231   Qcase_table_p = intern ("case-table-p");
 232   staticpro (&Qcase_table_p);
 233   staticpro (&Vascii_downcase_table);
 234   staticpro (&Vascii_upcase_table);
 235   staticpro (&Vascii_canon_table);
 236   staticpro (&Vascii_eqv_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
 244 #if 0
 245   DEFVAR_LISP ("ascii-downcase-table", &Vascii_downcase_table,
 246                "String mapping ASCII characters to lowercase equivalents.");
 247   DEFVAR_LISP ("ascii-upcase-table", &Vascii_upcase_table,
 248                "String mapping ASCII characters to uppercase equivalents.");
 249 #endif
 250 }