Merge from origin/emacs-24
[emacs.git] / src / casefiddle.c
bloba7477bb64b26f07dc2d3cce6df9ba55260127bfb
1 /* GNU Emacs case conversion functions.
3 Copyright (C) 1985, 1994, 1997-1999, 2001-2014 Free Software Foundation,
4 Inc.
6 This file is part of GNU Emacs.
8 GNU Emacs is free software: you can redistribute it and/or modify
9 it under the terms of the GNU General Public License as published by
10 the Free Software Foundation, either version 3 of the License, or
11 (at your option) any later version.
13 GNU Emacs is distributed in the hope that it will be useful,
14 but WITHOUT ANY WARRANTY; without even the implied warranty of
15 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
16 GNU General Public License for more details.
18 You should have received a copy of the GNU General Public License
19 along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. */
22 #include <config.h>
24 #include "lisp.h"
25 #include "character.h"
26 #include "buffer.h"
27 #include "commands.h"
28 #include "syntax.h"
29 #include "composite.h"
30 #include "keymap.h"
32 enum case_action {CASE_UP, CASE_DOWN, CASE_CAPITALIZE, CASE_CAPITALIZE_UP};
34 Lisp_Object Qidentity;
36 static Lisp_Object
37 casify_object (enum case_action flag, Lisp_Object obj)
39 int c, c1;
40 bool inword = flag == CASE_DOWN;
42 /* If the case table is flagged as modified, rescan it. */
43 if (NILP (XCHAR_TABLE (BVAR (current_buffer, downcase_table))->extras[1]))
44 Fset_case_table (BVAR (current_buffer, downcase_table));
46 if (INTEGERP (obj))
48 int flagbits = (CHAR_ALT | CHAR_SUPER | CHAR_HYPER
49 | CHAR_SHIFT | CHAR_CTL | CHAR_META);
50 int flags = XINT (obj) & flagbits;
51 bool multibyte = ! NILP (BVAR (current_buffer,
52 enable_multibyte_characters));
54 /* If the character has higher bits set
55 above the flags, return it unchanged.
56 It is not a real character. */
57 if (UNSIGNED_CMP (XFASTINT (obj), >, flagbits))
58 return obj;
60 c1 = XFASTINT (obj) & ~flagbits;
61 /* FIXME: Even if enable-multibyte-characters is nil, we may
62 manipulate multibyte chars. This means we have a bug for latin-1
63 chars since when we receive an int 128-255 we can't tell whether
64 it's an eight-bit byte or a latin-1 char. */
65 if (c1 >= 256)
66 multibyte = 1;
67 if (! multibyte)
68 MAKE_CHAR_MULTIBYTE (c1);
69 c = downcase (c1);
70 if (inword)
71 XSETFASTINT (obj, c | flags);
72 else if (c == (XFASTINT (obj) & ~flagbits))
74 if (! inword)
75 c = upcase1 (c1);
76 if (! multibyte)
77 MAKE_CHAR_UNIBYTE (c);
78 XSETFASTINT (obj, c | flags);
80 return obj;
83 if (!STRINGP (obj))
84 wrong_type_argument (Qchar_or_string_p, obj);
85 else if (!STRING_MULTIBYTE (obj))
87 ptrdiff_t i;
88 ptrdiff_t size = SCHARS (obj);
90 obj = Fcopy_sequence (obj);
91 for (i = 0; i < size; i++)
93 c = SREF (obj, i);
94 MAKE_CHAR_MULTIBYTE (c);
95 c1 = c;
96 if (inword && flag != CASE_CAPITALIZE_UP)
97 c = downcase (c);
98 else if (!uppercasep (c)
99 && (!inword || flag != CASE_CAPITALIZE_UP))
100 c = upcase1 (c1);
101 if ((int) flag >= (int) CASE_CAPITALIZE)
102 inword = (SYNTAX (c) == Sword);
103 if (c != c1)
105 MAKE_CHAR_UNIBYTE (c);
106 /* If the char can't be converted to a valid byte, just don't
107 change it. */
108 if (c >= 0 && c < 256)
109 SSET (obj, i, c);
112 return obj;
114 else
116 ptrdiff_t i, i_byte, size = SCHARS (obj);
117 int len;
118 USE_SAFE_ALLOCA;
119 ptrdiff_t o_size = (size < STRING_BYTES_BOUND / MAX_MULTIBYTE_LENGTH
120 ? size * MAX_MULTIBYTE_LENGTH
121 : STRING_BYTES_BOUND);
122 unsigned char *dst = SAFE_ALLOCA (o_size);
123 unsigned char *o = dst;
125 for (i = i_byte = 0; i < size; i++, i_byte += len)
127 if (o_size - (o - dst) < MAX_MULTIBYTE_LENGTH)
128 string_overflow ();
129 c = STRING_CHAR_AND_LENGTH (SDATA (obj) + i_byte, len);
130 if (inword && flag != CASE_CAPITALIZE_UP)
131 c = downcase (c);
132 else if (!uppercasep (c)
133 && (!inword || flag != CASE_CAPITALIZE_UP))
134 c = upcase1 (c);
135 if ((int) flag >= (int) CASE_CAPITALIZE)
136 inword = (SYNTAX (c) == Sword);
137 o += CHAR_STRING (c, o);
139 eassert (o - dst <= o_size);
140 obj = make_multibyte_string ((char *) dst, size, o - dst);
141 SAFE_FREE ();
142 return obj;
146 DEFUN ("upcase", Fupcase, Supcase, 1, 1, 0,
147 doc: /* Convert argument to upper case and return that.
148 The argument may be a character or string. The result has the same type.
149 The argument object is not altered--the value is a copy.
150 See also `capitalize', `downcase' and `upcase-initials'. */)
151 (Lisp_Object obj)
153 return casify_object (CASE_UP, obj);
156 DEFUN ("downcase", Fdowncase, Sdowncase, 1, 1, 0,
157 doc: /* Convert argument to lower case and return that.
158 The argument may be a character or string. The result has the same type.
159 The argument object is not altered--the value is a copy. */)
160 (Lisp_Object obj)
162 return casify_object (CASE_DOWN, obj);
165 DEFUN ("capitalize", Fcapitalize, Scapitalize, 1, 1, 0,
166 doc: /* Convert argument to capitalized form and return that.
167 This means that each word's first character is upper case
168 and the rest is lower case.
169 The argument may be a character or string. The result has the same type.
170 The argument object is not altered--the value is a copy. */)
171 (Lisp_Object obj)
173 return casify_object (CASE_CAPITALIZE, obj);
176 /* Like Fcapitalize but change only the initials. */
178 DEFUN ("upcase-initials", Fupcase_initials, Supcase_initials, 1, 1, 0,
179 doc: /* Convert the initial of each word in the argument to upper case.
180 Do not change the other letters of each word.
181 The argument may be a character or string. The result has the same type.
182 The argument object is not altered--the value is a copy. */)
183 (Lisp_Object obj)
185 return casify_object (CASE_CAPITALIZE_UP, obj);
188 /* flag is CASE_UP, CASE_DOWN or CASE_CAPITALIZE or CASE_CAPITALIZE_UP.
189 b and e specify range of buffer to operate on. */
191 static void
192 casify_region (enum case_action flag, Lisp_Object b, Lisp_Object e)
194 int c;
195 bool inword = flag == CASE_DOWN;
196 bool multibyte = !NILP (BVAR (current_buffer, enable_multibyte_characters));
197 ptrdiff_t start, end;
198 ptrdiff_t start_byte;
200 /* Position of first and last changes. */
201 ptrdiff_t first = -1, last IF_LINT (= 0);
203 ptrdiff_t opoint = PT;
204 ptrdiff_t opoint_byte = PT_BYTE;
206 if (EQ (b, e))
207 /* Not modifying because nothing marked */
208 return;
210 /* If the case table is flagged as modified, rescan it. */
211 if (NILP (XCHAR_TABLE (BVAR (current_buffer, downcase_table))->extras[1]))
212 Fset_case_table (BVAR (current_buffer, downcase_table));
214 validate_region (&b, &e);
215 start = XFASTINT (b);
216 end = XFASTINT (e);
217 modify_text (start, end);
218 record_change (start, end - start);
219 start_byte = CHAR_TO_BYTE (start);
221 SETUP_BUFFER_SYNTAX_TABLE (); /* For syntax_prefix_flag_p. */
223 while (start < end)
225 int c2, len;
227 if (multibyte)
229 c = FETCH_MULTIBYTE_CHAR (start_byte);
230 len = CHAR_BYTES (c);
232 else
234 c = FETCH_BYTE (start_byte);
235 MAKE_CHAR_MULTIBYTE (c);
236 len = 1;
238 c2 = c;
239 if (inword && flag != CASE_CAPITALIZE_UP)
240 c = downcase (c);
241 else if (!uppercasep (c)
242 && (!inword || flag != CASE_CAPITALIZE_UP))
243 c = upcase1 (c);
244 if ((int) flag >= (int) CASE_CAPITALIZE)
245 inword = ((SYNTAX (c) == Sword)
246 && (inword || !syntax_prefix_flag_p (c)));
247 if (c != c2)
249 last = start;
250 if (first < 0)
251 first = start;
253 if (! multibyte)
255 MAKE_CHAR_UNIBYTE (c);
256 FETCH_BYTE (start_byte) = c;
258 else if (ASCII_CHAR_P (c2) && ASCII_CHAR_P (c))
259 FETCH_BYTE (start_byte) = c;
260 else
262 int tolen = CHAR_BYTES (c);
263 int j;
264 unsigned char str[MAX_MULTIBYTE_LENGTH];
266 CHAR_STRING (c, str);
267 if (len == tolen)
269 /* Length is unchanged. */
270 for (j = 0; j < len; ++j)
271 FETCH_BYTE (start_byte + j) = str[j];
273 else
275 /* Replace one character with the other,
276 keeping text properties the same. */
277 replace_range_2 (start, start_byte,
278 start + 1, start_byte + len,
279 (char *) str, 1, tolen,
281 len = tolen;
285 start++;
286 start_byte += len;
289 if (PT != opoint)
290 TEMP_SET_PT_BOTH (opoint, opoint_byte);
292 if (first >= 0)
294 signal_after_change (first, last + 1 - first, last + 1 - first);
295 update_compositions (first, last + 1, CHECK_ALL);
299 DEFUN ("upcase-region", Fupcase_region, Supcase_region, 2, 2, "r",
300 doc: /* Convert the region to upper case. In programs, wants two arguments.
301 These arguments specify the starting and ending character numbers of
302 the region to operate on. When used as a command, the text between
303 point and the mark is operated on.
304 See also `capitalize-region'. */)
305 (Lisp_Object beg, Lisp_Object end)
307 casify_region (CASE_UP, beg, end);
308 return Qnil;
311 DEFUN ("downcase-region", Fdowncase_region, Sdowncase_region, 2, 2, "r",
312 doc: /* Convert the region to lower case. In programs, wants two arguments.
313 These arguments specify the starting and ending character numbers of
314 the region to operate on. When used as a command, the text between
315 point and the mark is operated on. */)
316 (Lisp_Object beg, Lisp_Object end)
318 casify_region (CASE_DOWN, beg, end);
319 return Qnil;
322 DEFUN ("capitalize-region", Fcapitalize_region, Scapitalize_region, 2, 2, "r",
323 doc: /* Convert the region to capitalized form.
324 Capitalized form means each word's first character is upper case
325 and the rest of it is lower case.
326 In programs, give two arguments, the starting and ending
327 character positions to operate on. */)
328 (Lisp_Object beg, Lisp_Object end)
330 casify_region (CASE_CAPITALIZE, beg, end);
331 return Qnil;
334 /* Like Fcapitalize_region but change only the initials. */
336 DEFUN ("upcase-initials-region", Fupcase_initials_region,
337 Supcase_initials_region, 2, 2, "r",
338 doc: /* Upcase the initial of each word in the region.
339 Subsequent letters of each word are not changed.
340 In programs, give two arguments, the starting and ending
341 character positions to operate on. */)
342 (Lisp_Object beg, Lisp_Object end)
344 casify_region (CASE_CAPITALIZE_UP, beg, end);
345 return Qnil;
348 static Lisp_Object
349 operate_on_word (Lisp_Object arg, ptrdiff_t *newpoint)
351 Lisp_Object val;
352 ptrdiff_t farend;
353 EMACS_INT iarg;
355 CHECK_NUMBER (arg);
356 iarg = XINT (arg);
357 farend = scan_words (PT, iarg);
358 if (!farend)
359 farend = iarg > 0 ? ZV : BEGV;
361 *newpoint = PT > farend ? PT : farend;
362 XSETFASTINT (val, farend);
364 return val;
367 DEFUN ("upcase-word", Fupcase_word, Supcase_word, 1, 1, "p",
368 doc: /* Convert to upper case from point to end of word, moving over.
370 If point is in the middle of a word, the part of that word before point
371 is ignored when moving forward.
373 With negative argument, convert previous words but do not move.
374 See also `capitalize-word'. */)
375 (Lisp_Object arg)
377 Lisp_Object beg, end;
378 ptrdiff_t newpoint;
379 XSETFASTINT (beg, PT);
380 end = operate_on_word (arg, &newpoint);
381 casify_region (CASE_UP, beg, end);
382 SET_PT (newpoint);
383 return Qnil;
386 DEFUN ("downcase-word", Fdowncase_word, Sdowncase_word, 1, 1, "p",
387 doc: /* Convert to lower case from point to end of word, moving over.
389 If point is in the middle of a word, the part of that word before point
390 is ignored when moving forward.
392 With negative argument, convert previous words but do not move. */)
393 (Lisp_Object arg)
395 Lisp_Object beg, end;
396 ptrdiff_t newpoint;
397 XSETFASTINT (beg, PT);
398 end = operate_on_word (arg, &newpoint);
399 casify_region (CASE_DOWN, beg, end);
400 SET_PT (newpoint);
401 return Qnil;
404 DEFUN ("capitalize-word", Fcapitalize_word, Scapitalize_word, 1, 1, "p",
405 doc: /* Capitalize from point to the end of word, moving over.
406 With numerical argument ARG, capitalize the next ARG-1 words as well.
407 This gives the word(s) a first character in upper case
408 and the rest lower case.
410 If point is in the middle of a word, the part of that word before point
411 is ignored when moving forward.
413 With negative argument, capitalize previous words but do not move. */)
414 (Lisp_Object arg)
416 Lisp_Object beg, end;
417 ptrdiff_t newpoint;
418 XSETFASTINT (beg, PT);
419 end = operate_on_word (arg, &newpoint);
420 casify_region (CASE_CAPITALIZE, beg, end);
421 SET_PT (newpoint);
422 return Qnil;
425 void
426 syms_of_casefiddle (void)
428 DEFSYM (Qidentity, "identity");
429 defsubr (&Supcase);
430 defsubr (&Sdowncase);
431 defsubr (&Scapitalize);
432 defsubr (&Supcase_initials);
433 defsubr (&Supcase_region);
434 defsubr (&Sdowncase_region);
435 defsubr (&Scapitalize_region);
436 defsubr (&Supcase_initials_region);
437 defsubr (&Supcase_word);
438 defsubr (&Sdowncase_word);
439 defsubr (&Scapitalize_word);
442 void
443 keys_of_casefiddle (void)
445 initial_define_key (control_x_map, Ctl ('U'), "upcase-region");
446 Fput (intern ("upcase-region"), Qdisabled, Qt);
447 initial_define_key (control_x_map, Ctl ('L'), "downcase-region");
448 Fput (intern ("downcase-region"), Qdisabled, Qt);
450 initial_define_key (meta_map, 'u', "upcase-word");
451 initial_define_key (meta_map, 'l', "downcase-word");
452 initial_define_key (meta_map, 'c', "capitalize-word");