update.
[chise/xemacs-chise.git-] / 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 }