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
   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 obj, Lisp_Object buffer)
  34 {
  35   struct buffer *buf = decode_buffer (buffer, 0);
  36
  37  retry:
  38
  39   if (CHAR_OR_CHAR_INTP (obj))
  40     {
  41       Emchar c;
  42       CHECK_CHAR_COERCE_INT (obj);
  43       c = XCHAR (obj);
  44       c = (flag == CASE_DOWN) ? DOWNCASE (buf, c) : UPCASE (buf, c);
  45       return make_char (c);
  46     }
  47
  48   if (STRINGP (obj))
  49     {
  50       struct Lisp_Char_Table *syntax_table =
  51         XCHAR_TABLE (buf->mirror_syntax_table);
  52       Bufbyte *storage =
  53         alloca_array (Bufbyte, XSTRING_LENGTH (obj) * MAX_EMCHAR_LEN);
  54       Bufbyte *newp = storage;
  55       Bufbyte *oldp = XSTRING_DATA (obj);
  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   obj = wrong_type_argument (Qchar_or_string_p, obj);
  92   goto retry;
  93 }
  94
  95 DEFUN ("upcase", Fupcase, 1, 2, 0, /*
  96 Convert OBJECT to upper case and return that.
  97 OBJECT may be a character or string.  The result has the same type.
  98 OBJECT 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        (object, buffer))
 104 {
 105   return casify_object (CASE_UP, object, buffer);
 106 }
 107
 108 DEFUN ("downcase", Fdowncase, 1, 2, 0, /*
 109 Convert OBJECT to lower case and return that.
 110 OBJECT may be a character or string.  The result has the same type.
 111 OBJECT 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        (object, buffer))
 116 {
 117   return casify_object (CASE_DOWN, object, buffer);
 118 }
 119
 120 DEFUN ("capitalize", Fcapitalize, 1, 2, 0, /*
 121 Convert OBJECT 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 OBJECT may be a character or string.  The result has the same type.
 125 OBJECT 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        (object, buffer))
 130 {
 131   return casify_object (CASE_CAPITALIZE, object, 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 OBJECT to upper case.
 138 Do not change the other letters of each word.
 139 OBJECT may be a character or string.  The result has the same type.
 140 OBJECT 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        (object, buffer))
 145 {
 146   return casify_object (CASE_CAPITALIZE_UP, object, buffer);
 147 }
 148 \f
 149 /* flag is CASE_UP, CASE_DOWN or CASE_CAPITALIZE or CASE_CAPITALIZE_UP.
 150    b and e specify range of buffer to operate on. */
 151
 152 static void
 153 casify_region_internal (enum case_action flag, Lisp_Object b, Lisp_Object e,
 154                         struct buffer *buf)
 155 {
 156   /* This function can GC */
 157   REGISTER Bufpos i;
 158   Bufpos start, end;
 159   struct Lisp_Char_Table *syntax_table = XCHAR_TABLE (buf->mirror_syntax_table);
 160   int mccount;
 161   Emchar oldc, c;
 162   int wordp = 0, wordp_prev;
 163
 164   if (EQ (b, e))
 165     /* Not modifying because nothing marked */
 166     return;
 167
 168   get_buffer_range_char (buf, b, e, &start, &end, 0);
 169
 170   mccount = begin_multiple_change (buf, start, end);
 171   record_change (buf, start, end - start);
 172
 173   for (i = start; i < end; i++)
 174     {
 175       c = oldc = BUF_FETCH_CHAR (buf, i);
 176
 177       switch (flag)
 178         {
 179         case CASE_UP:
 180           c = UPCASE (buf, oldc);
 181           break;
 182         case CASE_DOWN:
 183           c = DOWNCASE (buf, oldc);
 184           break;
 185         case CASE_CAPITALIZE:
 186         case CASE_CAPITALIZE_UP:
 187           /* !!#### need to revalidate the start and end pointers in case
 188              the buffer was changed */
 189           wordp_prev = wordp;
 190           wordp = WORD_SYNTAX_P (syntax_table, c);
 191           if (!wordp) continue;
 192           if (wordp_prev)
 193             {
 194               if (flag == CASE_CAPITALIZE)
 195                 c = DOWNCASE (buf, c);
 196             }
 197           else
 198             c = UPCASE (buf, c);
 199           break;
 200         }
 201
 202       if (oldc == c) continue;
 203       buffer_replace_char (buf, i, c, 1, (i == start));
 204       BUF_MODIFF (buf)++;
 205     }
 206
 207   end_multiple_change (buf, mccount);
 208 }
 209
 210 static Lisp_Object
 211 casify_region (enum case_action flag, Lisp_Object b, Lisp_Object e,
 212                Lisp_Object buffer)
 213 {
 214   casify_region_internal (flag, b, e, decode_buffer (buffer, 1));
 215   return Qnil;
 216 }
 217
 218 DEFUN ("upcase-region", Fupcase_region, 2, 3, "r", /*
 219 Convert the region to upper case.  In programs, wants two arguments.
 220 These arguments specify the starting and ending character numbers of
 221  the region to operate on.  When used as a command, the text between
 222  point and the mark is operated on.
 223 See also `capitalize-region'.
 224 Optional third arg BUFFER defaults to the current buffer.
 225 */
 226        (b, e, buffer))
 227 {
 228   /* This function can GC */
 229   return casify_region (CASE_UP, b, e, buffer);
 230 }
 231
 232 DEFUN ("downcase-region", Fdowncase_region, 2, 3, "r", /*
 233 Convert the region to lower case.  In programs, wants two arguments.
 234 These arguments specify the starting and ending character numbers of
 235  the region to operate on.  When used as a command, the text between
 236  point and the mark is operated on.
 237 Optional third arg BUFFER defaults to the current buffer.
 238 */
 239        (b, e, buffer))
 240 {
 241   /* This function can GC */
 242   return casify_region (CASE_DOWN, b, e, buffer);
 243 }
 244
 245 DEFUN ("capitalize-region", Fcapitalize_region, 2, 3, "r", /*
 246 Convert the region to capitalized form.
 247 Capitalized form means each word's first character is upper case
 248  and the rest of it is lower case.
 249 In programs, give two arguments, the starting and ending
 250  character positions to operate on.
 251 Optional third arg BUFFER defaults to the current buffer.
 252 */
 253        (b, e, buffer))
 254 {
 255   /* This function can GC */
 256   return casify_region (CASE_CAPITALIZE, b, e, buffer);
 257 }
 258
 259 /* Like Fcapitalize_region but change only the initials.  */
 260
 261 DEFUN ("upcase-initials-region", Fupcase_initials_region, 2, 3, "r", /*
 262 Upcase the initial of each word in the region.
 263 Subsequent letters of each word are not changed.
 264 In programs, give two arguments, the starting and ending
 265  character positions to operate on.
 266 Optional third arg BUFFER defaults to the current buffer.
 267 */
 268        (b, e, buffer))
 269 {
 270   return casify_region (CASE_CAPITALIZE_UP, b, e, buffer);
 271 }
 272
 273 \f
 274 static Lisp_Object
 275 casify_word (enum case_action flag, Lisp_Object arg, Lisp_Object buffer)
 276 {
 277   Bufpos farend;
 278   struct buffer *buf = decode_buffer (buffer, 1);
 279
 280   CHECK_INT (arg);
 281
 282   farend = scan_words (buf, BUF_PT (buf), XINT (arg));
 283   if (!farend)
 284     farend = XINT (arg) > 0 ? BUF_ZV (buf) : BUF_BEGV (buf);
 285
 286   casify_region_internal (flag, make_int (BUF_PT (buf)), make_int (farend), buf);
 287   BUF_SET_PT (buf, max (BUF_PT (buf), farend));
 288   return Qnil;
 289 }
 290
 291 DEFUN ("upcase-word", Fupcase_word, 1, 2, "p", /*
 292 Convert following word (or N words) to upper case, moving over.
 293 With negative argument, convert previous words but do not move.
 294 See also `capitalize-word'.
 295 Optional second arg BUFFER defaults to the current buffer.
 296 */
 297        (n, buffer))
 298 {
 299   /* This function can GC */
 300   return casify_word (CASE_UP, n, buffer);
 301 }
 302
 303 DEFUN ("downcase-word", Fdowncase_word, 1, 2, "p", /*
 304 Convert following word (or N words) to lower case, moving over.
 305 With negative argument, convert previous words but do not move.
 306 Optional second arg BUFFER defaults to the current buffer.
 307 */
 308        (n, buffer))
 309 {
 310   /* This function can GC */
 311   return casify_word (CASE_DOWN, n, buffer);
 312 }
 313
 314 DEFUN ("capitalize-word", Fcapitalize_word, 1, 2, "p", /*
 315 Capitalize the following word (or N words), moving over.
 316 This gives the word(s) a first character in upper case
 317  and the rest lower case.
 318 With negative argument, capitalize previous words but do not move.
 319 Optional second arg BUFFER defaults to the current buffer.
 320 */
 321        (n, buffer))
 322 {
 323   /* This function can GC */
 324   return casify_word (CASE_CAPITALIZE, n, buffer);
 325 }
 326 \f
 327
 328 void
 329 syms_of_casefiddle (void)
 330 {
 331   DEFSUBR (Fupcase);
 332   DEFSUBR (Fdowncase);
 333   DEFSUBR (Fcapitalize);
 334   DEFSUBR (Fupcase_initials);
 335   DEFSUBR (Fupcase_region);
 336   DEFSUBR (Fdowncase_region);
 337   DEFSUBR (Fcapitalize_region);
 338   DEFSUBR (Fupcase_initials_region);
 339   DEFSUBR (Fupcase_word);
 340   DEFSUBR (Fdowncase_word);
 341   DEFSUBR (Fcapitalize_word);
 342 }