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 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)
  51                   && (NILP (eqv) || STRING256_P (eqv))))
  52           ? Qt : Qnil);
  53 }
  54
  55 static Lisp_Object
  56 check_case_table (obj)
  57      Lisp_Object obj;
  58 {
  59   register Lisp_Object tem;
  60
  61   while (tem = Fcase_table_p (obj), NILP (tem))
  62     obj = wrong_type_argument (Qcase_table_p, obj);
  63   return (obj);
  64 }
  65
  66 DEFUN ("current-case-table", Fcurrent_case_table, Scurrent_case_table, 0, 0, 0,
  67   "Return the case table of the current buffer.")
  68   ()
  69 {
  70   Lisp_Object down, up, canon, eqv;
  71
  72   down = current_buffer->downcase_table;
  73   up = current_buffer->upcase_table;
  74   canon = current_buffer->case_canon_table;
  75   eqv = current_buffer->case_eqv_table;
  76
  77   return Fcons (down, Fcons (up, Fcons (canon, Fcons (eqv, Qnil))));
  78 }
  79
  80 DEFUN ("standard-case-table", Fstandard_case_table, 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 static Lisp_Object set_case_table ();
  92
  93 DEFUN ("set-case-table", Fset_case_table, Sset_case_table, 1, 1, 0,
  94   "Select a new case table for the current buffer.\n\
  95 A case table is a list (DOWNCASE UPCASE CANONICALIZE EQUIVALENCES)\n\
  96  where each element is either nil or a string of length 256.\n\
  97 DOWNCASE maps each character to its lower-case equivalent.\n\
  98 UPCASE maps each character to its upper-case equivalent;\n\
  99  if lower and upper case characters are in 1-1 correspondence,\n\
 100  you may use nil and the upcase table will be deduced from DOWNCASE.\n\
 101 CANONICALIZE maps each character to a canonical equivalent;\n\
 102  any two characters that are related by case-conversion have the same\n\
 103  canonical equivalent character; it may be nil, in which case it is\n\
 104  deduced from DOWNCASE and UPCASE.\n\
 105 EQUIVALENCES is a map that cyclicly permutes each equivalence class\n\
 106  (of characters with the same canonical equivalent); it may be nil,\n\
 107  in which case it is deduced from CANONICALIZE.")
 108   (table)
 109      Lisp_Object table;
 110 {
 111   return set_case_table (table, 0);
 112 }
 113
 114 DEFUN ("set-standard-case-table", Fset_standard_case_table, Sset_standard_case_table, 1, 1, 0,
 115   "Select a new standard case table for new buffers.\n\
 116 See `set-case-table' for more info on case tables.")
 117   (table)
 118      Lisp_Object table;
 119 {
 120   return set_case_table (table, 1);
 121 }
 122
 123 static Lisp_Object
 124 set_case_table (table, standard)
 125      Lisp_Object table;
 126      int standard;
 127 {
 128   Lisp_Object down, up, canon, eqv;
 129
 130   check_case_table (table);
 131
 132   down = Fcar_safe (table);
 133   up = Fcar_safe (Fcdr_safe (table));
 134   canon = Fcar_safe (Fcdr_safe (Fcdr_safe (table)));
 135   eqv = Fcar_safe (Fcdr_safe (Fcdr_safe (Fcdr_safe (table))));
 136
 137   if (NILP (up))
 138     {
 139       up = Fmake_string (make_number (256), make_number (0));
 140       compute_trt_inverse (XSTRING (down)->data, XSTRING (up)->data);
 141     }
 142
 143   if (NILP (canon))
 144     {
 145       register int i;
 146       unsigned char *upvec = XSTRING (up)->data;
 147       unsigned char *downvec = XSTRING (down)->data;
 148
 149       canon = 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
 158   if (NILP (eqv))
 159     {
 160       eqv = Fmake_string (make_number (256), make_number (0));
 161
 162       compute_trt_inverse (XSTRING (canon)->data, XSTRING (eqv)->data);
 163     }
 164
 165   if (standard)
 166     {
 167       Vascii_downcase_table = down;
 168       Vascii_upcase_table = up;
 169       Vascii_canon_table = canon;
 170       Vascii_eqv_table = eqv;
 171     }
 172   else
 173     {
 174       current_buffer->downcase_table = down;
 175       current_buffer->upcase_table = up;
 176       current_buffer->case_canon_table = canon;
 177       current_buffer->case_eqv_table = eqv;
 178     }
 179   return table;
 180 }
 181 \f
 182 /* Given a translate table TRT, store the inverse mapping into INVERSE.
 183    Since TRT is not one-to-one, INVERSE is not a simple mapping.
 184    Instead, it divides the space of characters into equivalence classes.
 185    All characters in a given class form one circular list, chained through
 186    the elements of INVERSE.  */
 187
 188 void
 189 compute_trt_inverse (trt, inverse)
 190      register unsigned char *trt;
 191      register unsigned char *inverse;
 192 {
 193   register int i = 0400;
 194   register unsigned char c, q;
 195
 196   while (i--)
 197     inverse[i] = i;
 198   i = 0400;
 199   while (i--)
 200     {
 201       if ((q = trt[i]) != (unsigned char) i)
 202         {
 203           c = inverse[q];
 204           inverse[q] = i;
 205           inverse[i] = c;
 206         }
 207     }
 208 }
 209 \f
 210 init_casetab_once ()
 211 {
 212   register int i;
 213   Lisp_Object tem;
 214
 215   tem = Fmake_string (make_number (256), make_number (0));
 216   Vascii_downcase_table = tem;
 217   Vascii_canon_table = tem;
 218
 219   for (i = 0; i < 256; i++)
 220     XSTRING (tem)->data[i] = (i >= 'A' && i <= 'Z') ? i + 040 : i;
 221
 222   tem = Fmake_string (make_number (256), make_number (0));
 223   Vascii_upcase_table = tem;
 224   Vascii_eqv_table = tem;
 225
 226   for (i = 0; i < 256; i++)
 227     XSTRING (tem)->data[i]
 228       = ((i >= 'A' && i <= 'Z')
 229          ? i + ('a' - 'A')
 230          : ((i >= 'a' && i <= 'z')
 231             ? i + ('A' - 'a')
 232             : i));
 233 }
 234
 235 syms_of_casetab ()
 236 {
 237   Qcase_table_p = intern ("case-table-p");
 238   staticpro (&Qcase_table_p);
 239   staticpro (&Vascii_downcase_table);
 240   staticpro (&Vascii_upcase_table);
 241   staticpro (&Vascii_canon_table);
 242   staticpro (&Vascii_eqv_table);
 243
 244   defsubr (&Scase_table_p);
 245   defsubr (&Scurrent_case_table);
 246   defsubr (&Sstandard_case_table);
 247   defsubr (&Sset_case_table);
 248   defsubr (&Sset_standard_case_table);
 249
 250 #if 0
 251   DEFVAR_LISP ("ascii-downcase-table", &Vascii_downcase_table,
 252                "String mapping ASCII characters to lowercase equivalents.");
 253   DEFVAR_LISP ("ascii-upcase-table", &Vascii_upcase_table,
 254                "String mapping ASCII characters to uppercase equivalents.");
 255 #endif
 256 }