Merge from gnulib
[emacs.git] / src / casefiddle.c
blob8755353240aa8a7889b0fce3e6ec6e5b97de0ca7
1 /* GNU Emacs case conversion functions.
3 Copyright (C) 1985, 1994, 1997-1999, 2001-2015 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 static Lisp_Object
35 casify_object (enum case_action flag, Lisp_Object obj)
37 int c, c1;
38 bool inword = flag == CASE_DOWN;
40 /* If the case table is flagged as modified, rescan it. */
41 if (NILP (XCHAR_TABLE (BVAR (current_buffer, downcase_table))->extras[1]))
42 Fset_case_table (BVAR (current_buffer, downcase_table));
44 if (INTEGERP (obj))
46 int flagbits = (CHAR_ALT | CHAR_SUPER | CHAR_HYPER
47 | CHAR_SHIFT | CHAR_CTL | CHAR_META);
48 int flags = XINT (obj) & flagbits;
49 bool multibyte = ! NILP (BVAR (current_buffer,
50 enable_multibyte_characters));
52 /* If the character has higher bits set
53 above the flags, return it unchanged.
54 It is not a real character. */
55 if (UNSIGNED_CMP (XFASTINT (obj), >, flagbits))
56 return obj;
58 c1 = XFASTINT (obj) & ~flagbits;
59 /* FIXME: Even if enable-multibyte-characters is nil, we may
60 manipulate multibyte chars. This means we have a bug for latin-1
61 chars since when we receive an int 128-255 we can't tell whether
62 it's an eight-bit byte or a latin-1 char. */
63 if (c1 >= 256)
64 multibyte = 1;
65 if (! multibyte)
66 MAKE_CHAR_MULTIBYTE (c1);
67 c = downcase (c1);
68 if (inword)
69 XSETFASTINT (obj, c | flags);
70 else if (c == (XFASTINT (obj) & ~flagbits))
72 if (! inword)
73 c = upcase1 (c1);
74 if (! multibyte)
75 MAKE_CHAR_UNIBYTE (c);
76 XSETFASTINT (obj, c | flags);
78 return obj;
81 if (!STRINGP (obj))
82 wrong_type_argument (Qchar_or_string_p, obj);
83 else if (!STRING_MULTIBYTE (obj))
85 ptrdiff_t i;
86 ptrdiff_t size = SCHARS (obj);
88 obj = Fcopy_sequence (obj);
89 for (i = 0; i < size; i++)
91 c = SREF (obj, i);
92 MAKE_CHAR_MULTIBYTE (c);
93 c1 = c;
94 if (inword && flag != CASE_CAPITALIZE_UP)
95 c = downcase (c);
96 else if (!uppercasep (c)
97 && (!inword || flag != CASE_CAPITALIZE_UP))
98 c = upcase1 (c1);
99 if ((int) flag >= (int) CASE_CAPITALIZE)
100 inword = (SYNTAX (c) == Sword);
101 if (c != c1)
103 MAKE_CHAR_UNIBYTE (c);
104 /* If the char can't be converted to a valid byte, just don't
105 change it. */
106 if (c >= 0 && c < 256)
107 SSET (obj, i, c);
110 return obj;
112 else
114 ptrdiff_t i, i_byte, size = SCHARS (obj);
115 int len;
116 USE_SAFE_ALLOCA;
117 ptrdiff_t o_size = (size < STRING_BYTES_BOUND / MAX_MULTIBYTE_LENGTH
118 ? size * MAX_MULTIBYTE_LENGTH
119 : STRING_BYTES_BOUND);
120 unsigned char *dst = SAFE_ALLOCA (o_size);
121 unsigned char *o = dst;
123 for (i = i_byte = 0; i < size; i++, i_byte += len)
125 if (o_size - (o - dst) < MAX_MULTIBYTE_LENGTH)
126 string_overflow ();
127 c = STRING_CHAR_AND_LENGTH (SDATA (obj) + i_byte, len);
128 if (inword && flag != CASE_CAPITALIZE_UP)
129 c = downcase (c);
130 else if (!uppercasep (c)
131 && (!inword || flag != CASE_CAPITALIZE_UP))
132 c = upcase1 (c);
133 if ((int) flag >= (int) CASE_CAPITALIZE)
134 inword = (SYNTAX (c) == Sword);
135 o += CHAR_STRING (c, o);
137 eassert (o - dst <= o_size);
138 obj = make_multibyte_string ((char *) dst, size, o - dst);
139 SAFE_FREE ();
140 return obj;
144 DEFUN ("upcase", Fupcase, Supcase, 1, 1, 0,
145 doc: /* Convert argument to upper case and return that.
146 The argument may be a character or string. The result has the same type.
147 The argument object is not altered--the value is a copy.
148 See also `capitalize', `downcase' and `upcase-initials'. */)
149 (Lisp_Object obj)
151 return casify_object (CASE_UP, obj);
154 DEFUN ("downcase", Fdowncase, Sdowncase, 1, 1, 0,
155 doc: /* Convert argument to lower case and return that.
156 The argument may be a character or string. The result has the same type.
157 The argument object is not altered--the value is a copy. */)
158 (Lisp_Object obj)
160 return casify_object (CASE_DOWN, obj);
163 DEFUN ("capitalize", Fcapitalize, Scapitalize, 1, 1, 0,
164 doc: /* Convert argument to capitalized form and return that.
165 This means that each word's first character is upper case
166 and the rest is lower case.
167 The argument may be a character or string. The result has the same type.
168 The argument object is not altered--the value is a copy. */)
169 (Lisp_Object obj)
171 return casify_object (CASE_CAPITALIZE, obj);
174 /* Like Fcapitalize but change only the initials. */
176 DEFUN ("upcase-initials", Fupcase_initials, Supcase_initials, 1, 1, 0,
177 doc: /* Convert the initial of each word in the argument to upper case.
178 Do not change the other letters of each word.
179 The argument may be a character or string. The result has the same type.
180 The argument object is not altered--the value is a copy. */)
181 (Lisp_Object obj)
183 return casify_object (CASE_CAPITALIZE_UP, obj);
186 /* flag is CASE_UP, CASE_DOWN or CASE_CAPITALIZE or CASE_CAPITALIZE_UP.
187 b and e specify range of buffer to operate on. */
189 static void
190 casify_region (enum case_action flag, Lisp_Object b, Lisp_Object e)
192 int c;
193 bool inword = flag == CASE_DOWN;
194 bool multibyte = !NILP (BVAR (current_buffer, enable_multibyte_characters));
195 ptrdiff_t start, end;
196 ptrdiff_t start_byte;
198 /* Position of first and last changes. */
199 ptrdiff_t first = -1, last IF_LINT (= 0);
201 ptrdiff_t opoint = PT;
202 ptrdiff_t opoint_byte = PT_BYTE;
204 if (EQ (b, e))
205 /* Not modifying because nothing marked */
206 return;
208 /* If the case table is flagged as modified, rescan it. */
209 if (NILP (XCHAR_TABLE (BVAR (current_buffer, downcase_table))->extras[1]))
210 Fset_case_table (BVAR (current_buffer, downcase_table));
212 validate_region (&b, &e);
213 start = XFASTINT (b);
214 end = XFASTINT (e);
215 modify_text (start, end);
216 record_change (start, end - start);
217 start_byte = CHAR_TO_BYTE (start);
219 SETUP_BUFFER_SYNTAX_TABLE (); /* For syntax_prefix_flag_p. */
221 while (start < end)
223 int c2, len;
225 if (multibyte)
227 c = FETCH_MULTIBYTE_CHAR (start_byte);
228 len = CHAR_BYTES (c);
230 else
232 c = FETCH_BYTE (start_byte);
233 MAKE_CHAR_MULTIBYTE (c);
234 len = 1;
236 c2 = c;
237 if (inword && flag != CASE_CAPITALIZE_UP)
238 c = downcase (c);
239 else if (!uppercasep (c)
240 && (!inword || flag != CASE_CAPITALIZE_UP))
241 c = upcase1 (c);
242 if ((int) flag >= (int) CASE_CAPITALIZE)
243 inword = ((SYNTAX (c) == Sword)
244 && (inword || !syntax_prefix_flag_p (c)));
245 if (c != c2)
247 last = start;
248 if (first < 0)
249 first = start;
251 if (! multibyte)
253 MAKE_CHAR_UNIBYTE (c);
254 FETCH_BYTE (start_byte) = c;
256 else if (ASCII_CHAR_P (c2) && ASCII_CHAR_P (c))
257 FETCH_BYTE (start_byte) = c;
258 else
260 int tolen = CHAR_BYTES (c);
261 int j;
262 unsigned char str[MAX_MULTIBYTE_LENGTH];
264 CHAR_STRING (c, str);
265 if (len == tolen)
267 /* Length is unchanged. */
268 for (j = 0; j < len; ++j)
269 FETCH_BYTE (start_byte + j) = str[j];
271 else
273 /* Replace one character with the other,
274 keeping text properties the same. */
275 replace_range_2 (start, start_byte,
276 start + 1, start_byte + len,
277 (char *) str, 1, tolen,
279 len = tolen;
283 start++;
284 start_byte += len;
287 if (PT != opoint)
288 TEMP_SET_PT_BOTH (opoint, opoint_byte);
290 if (first >= 0)
292 signal_after_change (first, last + 1 - first, last + 1 - first);
293 update_compositions (first, last + 1, CHECK_ALL);
297 DEFUN ("upcase-region", Fupcase_region, Supcase_region, 2, 2, "r",
298 doc: /* Convert the region to upper case. In programs, wants two arguments.
299 These arguments specify the starting and ending character numbers of
300 the region to operate on. When used as a command, the text between
301 point and the mark is operated on.
302 See also `capitalize-region'. */)
303 (Lisp_Object beg, Lisp_Object end)
305 casify_region (CASE_UP, beg, end);
306 return Qnil;
309 DEFUN ("downcase-region", Fdowncase_region, Sdowncase_region, 2, 2, "r",
310 doc: /* Convert the region to lower case. In programs, wants two arguments.
311 These arguments specify the starting and ending character numbers of
312 the region to operate on. When used as a command, the text between
313 point and the mark is operated on. */)
314 (Lisp_Object beg, Lisp_Object end)
316 casify_region (CASE_DOWN, beg, end);
317 return Qnil;
320 DEFUN ("capitalize-region", Fcapitalize_region, Scapitalize_region, 2, 2, "r",
321 doc: /* Convert the region to capitalized form.
322 Capitalized form means each word's first character is upper case
323 and the rest of it is lower case.
324 In programs, give two arguments, the starting and ending
325 character positions to operate on. */)
326 (Lisp_Object beg, Lisp_Object end)
328 casify_region (CASE_CAPITALIZE, beg, end);
329 return Qnil;
332 /* Like Fcapitalize_region but change only the initials. */
334 DEFUN ("upcase-initials-region", Fupcase_initials_region,
335 Supcase_initials_region, 2, 2, "r",
336 doc: /* Upcase the initial of each word in the region.
337 Subsequent letters of each word are not changed.
338 In programs, give two arguments, the starting and ending
339 character positions to operate on. */)
340 (Lisp_Object beg, Lisp_Object end)
342 casify_region (CASE_CAPITALIZE_UP, beg, end);
343 return Qnil;
346 static Lisp_Object
347 operate_on_word (Lisp_Object arg, ptrdiff_t *newpoint)
349 Lisp_Object val;
350 ptrdiff_t farend;
351 EMACS_INT iarg;
353 CHECK_NUMBER (arg);
354 iarg = XINT (arg);
355 farend = scan_words (PT, iarg);
356 if (!farend)
357 farend = iarg > 0 ? ZV : BEGV;
359 *newpoint = PT > farend ? PT : farend;
360 XSETFASTINT (val, farend);
362 return val;
365 DEFUN ("upcase-word", Fupcase_word, Supcase_word, 1, 1, "p",
366 doc: /* Convert to upper case from point to end of word, moving over.
368 If point is in the middle of a word, the part of that word before point
369 is ignored when moving forward.
371 With negative argument, convert previous words but do not move.
372 See also `capitalize-word'. */)
373 (Lisp_Object arg)
375 Lisp_Object beg, end;
376 ptrdiff_t newpoint;
377 XSETFASTINT (beg, PT);
378 end = operate_on_word (arg, &newpoint);
379 casify_region (CASE_UP, beg, end);
380 SET_PT (newpoint);
381 return Qnil;
384 DEFUN ("downcase-word", Fdowncase_word, Sdowncase_word, 1, 1, "p",
385 doc: /* Convert to lower case from point to end of word, moving over.
387 If point is in the middle of a word, the part of that word before point
388 is ignored when moving forward.
390 With negative argument, convert previous words but do not move. */)
391 (Lisp_Object arg)
393 Lisp_Object beg, end;
394 ptrdiff_t newpoint;
395 XSETFASTINT (beg, PT);
396 end = operate_on_word (arg, &newpoint);
397 casify_region (CASE_DOWN, beg, end);
398 SET_PT (newpoint);
399 return Qnil;
402 DEFUN ("capitalize-word", Fcapitalize_word, Scapitalize_word, 1, 1, "p",
403 doc: /* Capitalize from point to the end of word, moving over.
404 With numerical argument ARG, capitalize the next ARG-1 words as well.
405 This gives the word(s) a first character in upper case
406 and the rest lower case.
408 If point is in the middle of a word, the part of that word before point
409 is ignored when moving forward.
411 With negative argument, capitalize previous words but do not move. */)
412 (Lisp_Object arg)
414 Lisp_Object beg, end;
415 ptrdiff_t newpoint;
416 XSETFASTINT (beg, PT);
417 end = operate_on_word (arg, &newpoint);
418 casify_region (CASE_CAPITALIZE, beg, end);
419 SET_PT (newpoint);
420 return Qnil;
423 void
424 syms_of_casefiddle (void)
426 DEFSYM (Qidentity, "identity");
427 defsubr (&Supcase);
428 defsubr (&Sdowncase);
429 defsubr (&Scapitalize);
430 defsubr (&Supcase_initials);
431 defsubr (&Supcase_region);
432 defsubr (&Sdowncase_region);
433 defsubr (&Scapitalize_region);
434 defsubr (&Supcase_initials_region);
435 defsubr (&Supcase_word);
436 defsubr (&Sdowncase_word);
437 defsubr (&Scapitalize_word);
440 void
441 keys_of_casefiddle (void)
443 initial_define_key (control_x_map, Ctl ('U'), "upcase-region");
444 Fput (intern ("upcase-region"), Qdisabled, Qt);
445 initial_define_key (control_x_map, Ctl ('L'), "downcase-region");
446 Fput (intern ("downcase-region"), Qdisabled, Qt);
448 initial_define_key (meta_map, 'u', "upcase-word");
449 initial_define_key (meta_map, 'l', "downcase-word");
450 initial_define_key (meta_map, 'c', "capitalize-word");