git.chise.org Git - chise/xemacs-chise.git-/blob - src/casefiddle.c

   1 /* XEmacs case conversion functions.
   2    Copyright (C) 1985, 1992, 1993, 1994, 1997, 1998 Free Software Foundation, Inc.
   3    Copyright (C) 2001 MORIOKA Tomohiko
   4
   5 This file is part of XEmacs.
   6
   7 XEmacs is free software; you can redistribute it and/or modify it
   8 under the terms of the GNU General Public License as published by the
   9 Free Software Foundation; either version 2, or (at your option) any
  10 later version.
  11
  12 XEmacs is distributed in the hope that it will be useful, but WITHOUT
  13 ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or
  14 FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License
  15 for more details.
  16
  17 You should have received a copy of the GNU General Public License
  18 along with XEmacs; see the file COPYING.  If not, write to
  19 the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
  20 Boston, MA 02111-1307, USA.  */
  21
  22 /* Synched up with: FSF 19.34, but substantially rewritten by Martin. */
  23
  24 #include <config.h>
  25 #include "lisp.h"
  26
  27 #include "buffer.h"
  28 #include "insdel.h"
  29 #include "syntax.h"
  30
  31 enum case_action {CASE_UP, CASE_DOWN, CASE_CAPITALIZE, CASE_CAPITALIZE_UP};
  32 \f
  33 static Lisp_Object
  34 casify_object (enum case_action flag, Lisp_Object string_or_char,
  35                Lisp_Object buffer)
  36 {
  37   struct buffer *buf = decode_buffer (buffer, 0);
  38
  39  retry:
  40
  41   if (CHAR_OR_CHAR_INTP (string_or_char))
  42     {
  43       Emchar c;
  44       CHECK_CHAR_COERCE_INT (string_or_char);
  45       c = XCHAR (string_or_char);
  46       c = (flag == CASE_DOWN) ? DOWNCASE (buf, c) : UPCASE (buf, c);
  47       return make_char (c);
  48     }
  49
  50   if (STRINGP (string_or_char))
  51     {
  52 #ifdef UTF2000
  53       Lisp_Char_Table *syntax_table = XCHAR_TABLE (buf->syntax_table);
  54 #else
  55       Lisp_Char_Table *syntax_table = XCHAR_TABLE (buf->mirror_syntax_table);
  56 #endif
  57       Bufbyte *storage =
  58         alloca_array (Bufbyte, XSTRING_LENGTH (string_or_char) * MAX_EMCHAR_LEN);
  59       Bufbyte *newp = storage;
  60       Bufbyte *oldp = XSTRING_DATA (string_or_char);
  61       int wordp = 0, wordp_prev;
  62
  63       while (*oldp)
  64         {
  65           Emchar c = charptr_emchar (oldp);
  66           switch (flag)
  67             {
  68             case CASE_UP:
  69               c = UPCASE (buf, c);
  70               break;
  71             case CASE_DOWN:
  72               c = DOWNCASE (buf, c);
  73               break;
  74             case CASE_CAPITALIZE:
  75             case CASE_CAPITALIZE_UP:
  76               wordp_prev = wordp;
  77               wordp = WORD_SYNTAX_P (syntax_table, c);
  78               if (!wordp) break;
  79               if (wordp_prev)
  80                 {
  81                   if (flag == CASE_CAPITALIZE)
  82                     c = DOWNCASE (buf, c);
  83                 }
  84               else
  85                 c = UPCASE (buf, c);
  86               break;
  87             }
  88
  89           newp += set_charptr_emchar (newp, c);
  90           INC_CHARPTR (oldp);
  91         }
  92
  93       return make_string (storage, newp - storage);
  94     }
  95
  96   string_or_char = wrong_type_argument (Qchar_or_string_p, string_or_char);
  97   goto retry;
  98 }
  99
 100 DEFUN ("upcase", Fupcase, 1, 2, 0, /*
 101 Convert STRING-OR-CHAR to upper case and return that.
 102 STRING-OR-CHAR may be a character or string.  The result has the same type.
 103 STRING-OR-CHAR is not altered--the value is a copy.
 104 See also `capitalize', `downcase' and `upcase-initials'.
 105 Optional second arg BUFFER specifies which buffer's case tables to use,
 106  and defaults to the current buffer.
 107 */
 108        (string_or_char, buffer))
 109 {
 110   return casify_object (CASE_UP, string_or_char, buffer);
 111 }
 112
 113 DEFUN ("downcase", Fdowncase, 1, 2, 0, /*
 114 Convert STRING-OR-CHAR to lower case and return that.
 115 STRING-OR-CHAR may be a character or string.  The result has the same type.
 116 STRING-OR-CHAR is not altered--the value is a copy.
 117 Optional second arg BUFFER specifies which buffer's case tables to use,
 118  and defaults to the current buffer.
 119 */
 120        (string_or_char, buffer))
 121 {
 122   return casify_object (CASE_DOWN, string_or_char, buffer);
 123 }
 124
 125 DEFUN ("capitalize", Fcapitalize, 1, 2, 0, /*
 126 Convert STRING-OR-CHAR to capitalized form and return that.
 127 This means that each word's first character is upper case
 128 and the rest is lower case.
 129 STRING-OR-CHAR may be a character or string.  The result has the same type.
 130 STRING-OR-CHAR is not altered--the value is a copy.
 131 Optional second arg BUFFER specifies which buffer's case tables to use,
 132  and defaults to the current buffer.
 133 */
 134        (string_or_char, buffer))
 135 {
 136   return casify_object (CASE_CAPITALIZE, string_or_char, buffer);
 137 }
 138
 139 /* Like Fcapitalize but change only the initial characters.  */
 140
 141 DEFUN ("upcase-initials", Fupcase_initials, 1, 2, 0, /*
 142 Convert the initial of each word in STRING-OR-CHAR to upper case.
 143 Do not change the other letters of each word.
 144 STRING-OR-CHAR may be a character or string.  The result has the same type.
 145 STRING-OR-CHAR is not altered--the value is a copy.
 146 Optional second arg BUFFER specifies which buffer's case tables to use,
 147  and defaults to the current buffer.
 148 */
 149        (string_or_char, buffer))
 150 {
 151   return casify_object (CASE_CAPITALIZE_UP, string_or_char, buffer);
 152 }
 153 \f
 154 /* flag is CASE_UP, CASE_DOWN or CASE_CAPITALIZE or CASE_CAPITALIZE_UP.
 155    START and END specify range of buffer to operate on. */
 156
 157 static void
 158 casify_region_internal (enum case_action flag, Lisp_Object start,
 159                         Lisp_Object end, struct buffer *buf)
 160 {
 161   /* This function can GC */
 162   Bufpos pos, s, e;
 163 #ifdef UTF2000
 164   Lisp_Char_Table *syntax_table = XCHAR_TABLE (buf->syntax_table);
 165 #else
 166   Lisp_Char_Table *syntax_table = XCHAR_TABLE (buf->mirror_syntax_table);
 167 #endif
 168   int mccount;
 169   int wordp = 0, wordp_prev;
 170
 171   if (EQ (start, end))
 172     /* Not modifying because nothing marked */
 173     return;
 174
 175   get_buffer_range_char (buf, start, end, &s, &e, 0);
 176
 177   mccount = begin_multiple_change (buf, s, e);
 178   record_change (buf, s, e - s);
 179
 180   for (pos = s; pos < e; pos++)
 181     {
 182       Emchar oldc = BUF_FETCH_CHAR (buf, pos);
 183       Emchar c = oldc;
 184
 185       switch (flag)
 186         {
 187         case CASE_UP:
 188           c = UPCASE (buf, oldc);
 189           break;
 190         case CASE_DOWN:
 191           c = DOWNCASE (buf, oldc);
 192           break;
 193         case CASE_CAPITALIZE:
 194         case CASE_CAPITALIZE_UP:
 195           /* !!#### need to revalidate the start and end pointers in case
 196              the buffer was changed */
 197           wordp_prev = wordp;
 198           wordp = WORD_SYNTAX_P (syntax_table, c);
 199           if (!wordp) continue;
 200           if (wordp_prev)
 201             {
 202               if (flag == CASE_CAPITALIZE)
 203                 c = DOWNCASE (buf, c);
 204             }
 205           else
 206             c = UPCASE (buf, c);
 207           break;
 208         }
 209
 210       if (oldc == c) continue;
 211       buffer_replace_char (buf, pos, c, 1, (pos == s));
 212       BUF_MODIFF (buf)++;
 213     }
 214
 215   end_multiple_change (buf, mccount);
 216 }
 217
 218 static Lisp_Object
 219 casify_region (enum case_action flag, Lisp_Object start, Lisp_Object end,
 220                Lisp_Object buffer)
 221 {
 222   casify_region_internal (flag, start, end, decode_buffer (buffer, 1));
 223   return Qnil;
 224 }
 225
 226 DEFUN ("upcase-region", Fupcase_region, 2, 3, "r", /*
 227 Convert the region to upper case.  In programs, wants two arguments.
 228 These arguments specify the starting and ending character numbers of
 229  the region to operate on.  When used as a command, the text between
 230  point and the mark is operated on.
 231 See also `capitalize-region'.
 232 Optional third arg BUFFER defaults to the current buffer.
 233 */
 234        (start, end, buffer))
 235 {
 236   /* This function can GC */
 237   return casify_region (CASE_UP, start, end, buffer);
 238 }
 239
 240 DEFUN ("downcase-region", Fdowncase_region, 2, 3, "r", /*
 241 Convert the region to lower case.  In programs, wants two arguments.
 242 These arguments specify the starting and ending character numbers of
 243  the region to operate on.  When used as a command, the text between
 244  point and the mark is operated on.
 245 Optional third arg BUFFER defaults to the current buffer.
 246 */
 247        (start, end, buffer))
 248 {
 249   /* This function can GC */
 250   return casify_region (CASE_DOWN, start, end, buffer);
 251 }
 252
 253 DEFUN ("capitalize-region", Fcapitalize_region, 2, 3, "r", /*
 254 Convert the region to capitalized form.
 255 Capitalized form means each word's first character is upper case
 256  and the rest of it is lower case.
 257 In programs, give two arguments, the starting and ending
 258  character positions to operate on.
 259 Optional third arg BUFFER defaults to the current buffer.
 260 */
 261        (start, end, buffer))
 262 {
 263   /* This function can GC */
 264   return casify_region (CASE_CAPITALIZE, start, end, buffer);
 265 }
 266
 267 /* Like Fcapitalize_region but change only the initials.  */
 268
 269 DEFUN ("upcase-initials-region", Fupcase_initials_region, 2, 3, "r", /*
 270 Upcase the initial of each word in the region.
 271 Subsequent letters of each word are not changed.
 272 In programs, give two arguments, the starting and ending
 273  character positions to operate on.
 274 Optional third arg BUFFER defaults to the current buffer.
 275 */
 276        (start, end, buffer))
 277 {
 278   return casify_region (CASE_CAPITALIZE_UP, start, end, buffer);
 279 }
 280
 281 \f
 282 static Lisp_Object
 283 casify_word (enum case_action flag, Lisp_Object arg, Lisp_Object buffer)
 284 {
 285   Bufpos farend;
 286   struct buffer *buf = decode_buffer (buffer, 1);
 287
 288   CHECK_INT (arg);
 289
 290   farend = scan_words (buf, BUF_PT (buf), XINT (arg));
 291   if (!farend)
 292     farend = XINT (arg) > 0 ? BUF_ZV (buf) : BUF_BEGV (buf);
 293
 294   casify_region_internal (flag, make_int (BUF_PT (buf)), make_int (farend), buf);
 295   BUF_SET_PT (buf, max (BUF_PT (buf), farend));
 296   return Qnil;
 297 }
 298
 299 DEFUN ("upcase-word", Fupcase_word, 1, 2, "p", /*
 300 Convert following word (or COUNT words) to upper case, moving over.
 301 With negative argument, convert previous words but do not move.
 302 See also `capitalize-word'.
 303 Optional second arg BUFFER defaults to the current buffer.
 304 */
 305        (count, buffer))
 306 {
 307   /* This function can GC */
 308   return casify_word (CASE_UP, count, buffer);
 309 }
 310
 311 DEFUN ("downcase-word", Fdowncase_word, 1, 2, "p", /*
 312 Convert following word (or COUNT words) to lower case, moving over.
 313 With negative argument, convert previous words but do not move.
 314 Optional second arg BUFFER defaults to the current buffer.
 315 */
 316        (count, buffer))
 317 {
 318   /* This function can GC */
 319   return casify_word (CASE_DOWN, count, buffer);
 320 }
 321
 322 DEFUN ("capitalize-word", Fcapitalize_word, 1, 2, "p", /*
 323 Capitalize the following word (or COUNT words), moving over.
 324 This gives the word(s) a first character in upper case
 325  and the rest lower case.
 326 With negative argument, capitalize previous words but do not move.
 327 Optional second arg BUFFER defaults to the current buffer.
 328 */
 329        (count, buffer))
 330 {
 331   /* This function can GC */
 332   return casify_word (CASE_CAPITALIZE, count, buffer);
 333 }
 334 \f
 335
 336 void
 337 syms_of_casefiddle (void)
 338 {
 339   DEFSUBR (Fupcase);
 340   DEFSUBR (Fdowncase);
 341   DEFSUBR (Fcapitalize);
 342   DEFSUBR (Fupcase_initials);
 343   DEFSUBR (Fupcase_region);
 344   DEFSUBR (Fdowncase_region);
 345   DEFSUBR (Fcapitalize_region);
 346   DEFSUBR (Fupcase_initials_region);
 347   DEFSUBR (Fupcase_word);
 348   DEFSUBR (Fdowncase_word);
 349   DEFSUBR (Fcapitalize_word);
 350 }