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

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