XEmacs 21.2.5
[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
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 }