1 /* Lisp functions pertaining to editing. -*- coding: utf-8 -*-
2
3 Copyright (C) 1985-1987, 1989, 1993-2021 Free Software Foundation, Inc.
4
5 This file is part of GNU Emacs.
6
7 GNU Emacs is free software: you can redistribute it and/or modify
8 it under the terms of the GNU General Public License as published by
9 the Free Software Foundation, either version 3 of the License, or (at
10 your option) any later version.
11
12 GNU Emacs is distributed in the hope that it will be useful,
13 but WITHOUT ANY WARRANTY; without even the implied warranty of
14 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
15 GNU General Public License for more details.
16
17 You should have received a copy of the GNU General Public License
18 along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. */
19
20
21 #include <config.h>
22 #include <sys/types.h>
23 #include <stdio.h>
24
25 #ifdef HAVE_PWD_H
26 #include <pwd.h>
27 #include <grp.h>
28 #endif
29
30 #include <unistd.h>
31
32 #ifdef HAVE_SYS_UTSNAME_H
33 #include <sys/utsname.h>
34 #endif
35
36 #include "lisp.h"
37
38 #include <float.h>
39 #include <limits.h>
40 #include <math.h>
41
42 #include <c-ctype.h>
43 #include <intprops.h>
44 #include <stdlib.h>
45 #include <verify.h>
46
47 #include "composite.h"
48 #include "intervals.h"
49 #include "systime.h"
50 #include "character.h"
51 #include "buffer.h"
52 #include "window.h"
53 #include "blockinput.h"
54
55 #ifdef WINDOWSNT
56 # include "w32common.h"
57 #endif
58 static void update_buffer_properties (ptrdiff_t, ptrdiff_t);
59 static Lisp_Object styled_format (ptrdiff_t, Lisp_Object *, bool);
60
61 /* The cached value of Vsystem_name. This is used only to compare it
62 to Vsystem_name, so it need not be visible to the GC. */
63 static Lisp_Object cached_system_name;
64
65 static void
init_and_cache_system_name(void)66 init_and_cache_system_name (void)
67 {
68 init_system_name ();
69 cached_system_name = Vsystem_name;
70 }
71
72 void
init_editfns(void)73 init_editfns (void)
74 {
75 const char *user_name;
76 register char *p;
77 struct passwd *pw; /* password entry for the current user */
78 Lisp_Object tem;
79
80 /* Set up system_name even when dumping. */
81 init_and_cache_system_name ();
82
83 pw = getpwuid (getuid ());
84 #ifdef MSDOS
85 /* We let the real user name default to "root" because that's quite
86 accurate on MS-DOS and because it lets Emacs find the init file.
87 (The DVX libraries override the Djgpp libraries here.) */
88 Vuser_real_login_name = build_string (pw ? pw->pw_name : "root");
89 #else
90 Vuser_real_login_name = build_string (pw ? pw->pw_name : "unknown");
91 #endif
92
93 /* Get the effective user name, by consulting environment variables,
94 or the effective uid if those are unset. */
95 user_name = getenv ("LOGNAME");
96 if (!user_name)
97 #ifdef WINDOWSNT
98 user_name = getenv ("USERNAME"); /* it's USERNAME on NT */
99 #else /* WINDOWSNT */
100 user_name = getenv ("USER");
101 #endif /* WINDOWSNT */
102 if (!user_name)
103 {
104 pw = getpwuid (geteuid ());
105 user_name = pw ? pw->pw_name : "unknown";
106 }
107 Vuser_login_name = build_string (user_name);
108
109 /* If the user name claimed in the environment vars differs from
110 the real uid, use the claimed name to find the full name. */
111 tem = Fstring_equal (Vuser_login_name, Vuser_real_login_name);
112 if (! NILP (tem))
113 tem = Vuser_login_name;
114 else
115 {
116 uid_t euid = geteuid ();
117 tem = INT_TO_INTEGER (euid);
118 }
119 Vuser_full_name = Fuser_full_name (tem);
120
121 p = getenv ("NAME");
122 if (p)
123 Vuser_full_name = build_string (p);
124 else if (NILP (Vuser_full_name))
125 Vuser_full_name = build_string ("unknown");
126
127 #if defined HAVE_SYS_UTSNAME_H
128 {
129 struct utsname uts;
130 uname (&uts);
131 Voperating_system_release = build_string (uts.release);
132 }
133 #elif defined WINDOWSNT
134 Voperating_system_release = build_string (w32_version_string ());
135 #else
136 Voperating_system_release = Qnil;
137 #endif
138 }
139
140 DEFUN ("char-to-string", Fchar_to_string, Schar_to_string, 1, 1, 0,
141 doc: /* Convert arg CHAR to a string containing that character.
142 usage: (char-to-string CHAR) */)
143 (Lisp_Object character)
144 {
145 int c, len;
146 unsigned char str[MAX_MULTIBYTE_LENGTH];
147
148 CHECK_CHARACTER (character);
149 c = XFIXNAT (character);
150
151 len = CHAR_STRING (c, str);
152 return make_string_from_bytes ((char *) str, 1, len);
153 }
154
155 DEFUN ("byte-to-string", Fbyte_to_string, Sbyte_to_string, 1, 1, 0,
156 doc: /* Convert arg BYTE to a unibyte string containing that byte. */)
157 (Lisp_Object byte)
158 {
159 unsigned char b;
160 CHECK_FIXNUM (byte);
161 if (XFIXNUM (byte) < 0 || XFIXNUM (byte) > 255)
162 error ("Invalid byte");
163 b = XFIXNUM (byte);
164 return make_string_from_bytes ((char *) &b, 1, 1);
165 }
166
167 DEFUN ("string-to-char", Fstring_to_char, Sstring_to_char, 1, 1, 0,
168 doc: /* Return the first character in STRING. */)
169 (Lisp_Object string)
170 {
171 CHECK_STRING (string);
172
173 /* This returns zero if STRING is empty. */
174 return make_fixnum (STRING_MULTIBYTE (string)
175 ? STRING_CHAR (SDATA (string))
176 : SREF (string, 0));
177 }
178
179 DEFUN ("point", Fpoint, Spoint, 0, 0, 0,
180 doc: /* Return value of point, as an integer.
181 Beginning of buffer is position (point-min). */)
182 (void)
183 {
184 Lisp_Object temp;
185 XSETFASTINT (temp, PT);
186 return temp;
187 }
188
189 DEFUN ("point-marker", Fpoint_marker, Spoint_marker, 0, 0, 0,
190 doc: /* Return value of point, as a marker object. */)
191 (void)
192 {
193 return build_marker (current_buffer, PT, PT_BYTE);
194 }
195
196 DEFUN ("goto-char", Fgoto_char, Sgoto_char, 1, 1,
197 "(goto-char--read-natnum-interactive \"Go to char: \")",
198 doc: /* Set point to POSITION, a number or marker.
199 Beginning of buffer is position (point-min), end is (point-max).
200
201 The return value is POSITION.
202
203 If called interactively, a numeric prefix argument specifies
204 POSITION; without a numeric prefix argument, read POSITION from the
205 minibuffer. The default value is the number at point (if any). */)
206 (register Lisp_Object position)
207 {
208 if (MARKERP (position))
209 set_point_from_marker (position);
210 else if (FIXNUMP (position))
211 SET_PT (clip_to_bounds (BEGV, XFIXNUM (position), ZV));
212 else
213 wrong_type_argument (Qinteger_or_marker_p, position);
214 return position;
215 }
216
217
218 /* Return the start or end position of the region.
219 BEGINNINGP means return the start.
220 If there is no region active, signal an error. */
221
222 static Lisp_Object
region_limit(bool beginningp)223 region_limit (bool beginningp)
224 {
225 Lisp_Object m;
226
227 if (!NILP (Vtransient_mark_mode)
228 && NILP (Vmark_even_if_inactive)
229 && NILP (BVAR (current_buffer, mark_active)))
230 xsignal0 (Qmark_inactive);
231
232 m = Fmarker_position (BVAR (current_buffer, mark));
233 if (NILP (m))
234 error ("The mark is not set now, so there is no region");
235
236 /* Clip to the current narrowing (bug#11770). */
237 return make_fixnum ((PT < XFIXNAT (m)) == beginningp
238 ? PT
239 : clip_to_bounds (BEGV, XFIXNAT (m), ZV));
240 }
241
242 DEFUN ("region-beginning", Fregion_beginning, Sregion_beginning, 0, 0, 0,
243 doc: /* Return the integer value of point or mark, whichever is smaller. */)
244 (void)
245 {
246 return region_limit (1);
247 }
248
249 DEFUN ("region-end", Fregion_end, Sregion_end, 0, 0, 0,
250 doc: /* Return the integer value of point or mark, whichever is larger. */)
251 (void)
252 {
253 return region_limit (0);
254 }
255
256 DEFUN ("mark-marker", Fmark_marker, Smark_marker, 0, 0, 0,
257 doc: /* Return this buffer's mark, as a marker object.
258 Watch out! Moving this marker changes the mark position.
259 If you set the marker not to point anywhere, the buffer will have no mark. */)
260 (void)
261 {
262 return BVAR (current_buffer, mark);
263 }
264
265
266 /* Find all the overlays in the current buffer that touch position POS.
267 Return the number found, and store them in a vector in VEC
268 of length LEN. */
269
270 static ptrdiff_t
overlays_around(EMACS_INT pos,Lisp_Object * vec,ptrdiff_t len)271 overlays_around (EMACS_INT pos, Lisp_Object *vec, ptrdiff_t len)
272 {
273 ptrdiff_t idx = 0;
274
275 for (struct Lisp_Overlay *tail = current_buffer->overlays_before;
276 tail; tail = tail->next)
277 {
278 Lisp_Object overlay = make_lisp_ptr (tail, Lisp_Vectorlike);
279 Lisp_Object end = OVERLAY_END (overlay);
280 ptrdiff_t endpos = OVERLAY_POSITION (end);
281 if (endpos < pos)
282 break;
283 Lisp_Object start = OVERLAY_START (overlay);
284 ptrdiff_t startpos = OVERLAY_POSITION (start);
285 if (startpos <= pos)
286 {
287 if (idx < len)
288 vec[idx] = overlay;
289 /* Keep counting overlays even if we can't return them all. */
290 idx++;
291 }
292 }
293
294 for (struct Lisp_Overlay *tail = current_buffer->overlays_after;
295 tail; tail = tail->next)
296 {
297 Lisp_Object overlay = make_lisp_ptr (tail, Lisp_Vectorlike);
298 Lisp_Object start = OVERLAY_START (overlay);
299 ptrdiff_t startpos = OVERLAY_POSITION (start);
300 if (pos < startpos)
301 break;
302 Lisp_Object end = OVERLAY_END (overlay);
303 ptrdiff_t endpos = OVERLAY_POSITION (end);
304 if (pos <= endpos)
305 {
306 if (idx < len)
307 vec[idx] = overlay;
308 idx++;
309 }
310 }
311
312 return idx;
313 }
314
315 DEFUN ("get-pos-property", Fget_pos_property, Sget_pos_property, 2, 3, 0,
316 doc: /* Return the value of POSITION's property PROP, in OBJECT.
317 Almost identical to `get-char-property' except for the following difference:
318 Whereas `get-char-property' returns the property of the char at (i.e. right
319 after) POSITION, this pays attention to properties's stickiness and overlays's
320 advancement settings, in order to find the property of POSITION itself,
321 i.e. the property that a char would inherit if it were inserted
322 at POSITION. */)
323 (Lisp_Object position, register Lisp_Object prop, Lisp_Object object)
324 {
325 CHECK_FIXNUM_COERCE_MARKER (position);
326
327 if (NILP (object))
328 XSETBUFFER (object, current_buffer);
329 else if (WINDOWP (object))
330 object = XWINDOW (object)->contents;
331
332 if (!BUFFERP (object))
333 /* pos-property only makes sense in buffers right now, since strings
334 have no overlays and no notion of insertion for which stickiness
335 could be obeyed. */
336 return Fget_text_property (position, prop, object);
337 else
338 {
339 EMACS_INT posn = XFIXNUM (position);
340 ptrdiff_t noverlays;
341 Lisp_Object *overlay_vec, tem;
342 struct buffer *obuf = current_buffer;
343 USE_SAFE_ALLOCA;
344
345 set_buffer_temp (XBUFFER (object));
346
347 /* First try with room for 40 overlays. */
348 Lisp_Object overlay_vecbuf[40];
349 noverlays = ARRAYELTS (overlay_vecbuf);
350 overlay_vec = overlay_vecbuf;
351 noverlays = overlays_around (posn, overlay_vec, noverlays);
352
353 /* If there are more than 40,
354 make enough space for all, and try again. */
355 if (ARRAYELTS (overlay_vecbuf) < noverlays)
356 {
357 SAFE_ALLOCA_LISP (overlay_vec, noverlays);
358 noverlays = overlays_around (posn, overlay_vec, noverlays);
359 }
360 noverlays = sort_overlays (overlay_vec, noverlays, NULL);
361
362 set_buffer_temp (obuf);
363
364 /* Now check the overlays in order of decreasing priority. */
365 while (--noverlays >= 0)
366 {
367 Lisp_Object ol = overlay_vec[noverlays];
368 tem = Foverlay_get (ol, prop);
369 if (!NILP (tem))
370 {
371 /* Check the overlay is indeed active at point. */
372 Lisp_Object start = OVERLAY_START (ol), finish = OVERLAY_END (ol);
373 if ((OVERLAY_POSITION (start) == posn
374 && XMARKER (start)->insertion_type == 1)
375 || (OVERLAY_POSITION (finish) == posn
376 && XMARKER (finish)->insertion_type == 0))
377 ; /* The overlay will not cover a char inserted at point. */
378 else
379 {
380 SAFE_FREE ();
381 return tem;
382 }
383 }
384 }
385 SAFE_FREE ();
386
387 { /* Now check the text properties. */
388 int stickiness = text_property_stickiness (prop, position, object);
389 if (stickiness > 0)
390 return Fget_text_property (position, prop, object);
391 else if (stickiness < 0
392 && XFIXNUM (position) > BUF_BEGV (XBUFFER (object)))
393 return Fget_text_property (make_fixnum (XFIXNUM (position) - 1),
394 prop, object);
395 else
396 return Qnil;
397 }
398 }
399 }
400
401 /* Find the field surrounding POS in *BEG and *END. If POS is nil,
402 the value of point is used instead. If BEG or END is null,
403 means don't store the beginning or end of the field.
404
405 BEG_LIMIT and END_LIMIT serve to limit the ranged of the returned
406 results; they do not effect boundary behavior.
407
408 If MERGE_AT_BOUNDARY is non-nil, then if POS is at the very first
409 position of a field, then the beginning of the previous field is
410 returned instead of the beginning of POS's field (since the end of a
411 field is actually also the beginning of the next input field, this
412 behavior is sometimes useful). Additionally in the MERGE_AT_BOUNDARY
413 non-nil case, if two fields are separated by a field with the special
414 value `boundary', and POS lies within it, then the two separated
415 fields are considered to be adjacent, and POS between them, when
416 finding the beginning and ending of the "merged" field.
417
418 Either BEG or END may be 0, in which case the corresponding value
419 is not stored. */
420
421 static void
find_field(Lisp_Object pos,Lisp_Object merge_at_boundary,Lisp_Object beg_limit,ptrdiff_t * beg,Lisp_Object end_limit,ptrdiff_t * end)422 find_field (Lisp_Object pos, Lisp_Object merge_at_boundary,
423 Lisp_Object beg_limit,
424 ptrdiff_t *beg, Lisp_Object end_limit, ptrdiff_t *end)
425 {
426 /* Fields right before and after the point. */
427 Lisp_Object before_field, after_field;
428 /* True if POS counts as the start of a field. */
429 bool at_field_start = 0;
430 /* True if POS counts as the end of a field. */
431 bool at_field_end = 0;
432
433 if (NILP (pos))
434 XSETFASTINT (pos, PT);
435 else
436 CHECK_FIXNUM_COERCE_MARKER (pos);
437
438 after_field
439 = get_char_property_and_overlay (pos, Qfield, Qnil, NULL);
440 before_field
441 = (XFIXNAT (pos) > BEGV
442 ? get_char_property_and_overlay (make_fixnum (XFIXNUM (pos) - 1),
443 Qfield, Qnil, NULL)
444 /* Using nil here would be a more obvious choice, but it would
445 fail when the buffer starts with a non-sticky field. */
446 : after_field);
447
448 /* See if we need to handle the case where MERGE_AT_BOUNDARY is nil
449 and POS is at beginning of a field, which can also be interpreted
450 as the end of the previous field. Note that the case where if
451 MERGE_AT_BOUNDARY is non-nil (see function comment) is actually the
452 more natural one; then we avoid treating the beginning of a field
453 specially. */
454 if (NILP (merge_at_boundary))
455 {
456 Lisp_Object field = Fget_pos_property (pos, Qfield, Qnil);
457 if (!EQ (field, after_field))
458 at_field_end = 1;
459 if (!EQ (field, before_field))
460 at_field_start = 1;
461 if (NILP (field) && at_field_start && at_field_end)
462 /* If an inserted char would have a nil field while the surrounding
463 text is non-nil, we're probably not looking at a
464 zero-length field, but instead at a non-nil field that's
465 not intended for editing (such as comint's prompts). */
466 at_field_end = at_field_start = 0;
467 }
468
469 /* Note about special `boundary' fields:
470
471 Consider the case where the point (`.') is between the fields `x' and `y':
472
473 xxxx.yyyy
474
475 In this situation, if merge_at_boundary is non-nil, consider the
476 `x' and `y' fields as forming one big merged field, and so the end
477 of the field is the end of `y'.
478
479 However, if `x' and `y' are separated by a special `boundary' field
480 (a field with a `field' char-property of 'boundary), then ignore
481 this special field when merging adjacent fields. Here's the same
482 situation, but with a `boundary' field between the `x' and `y' fields:
483
484 xxx.BBBByyyy
485
486 Here, if point is at the end of `x', the beginning of `y', or
487 anywhere in-between (within the `boundary' field), merge all
488 three fields and consider the beginning as being the beginning of
489 the `x' field, and the end as being the end of the `y' field. */
490
491 if (beg)
492 {
493 if (at_field_start)
494 /* POS is at the edge of a field, and we should consider it as
495 the beginning of the following field. */
496 *beg = XFIXNAT (pos);
497 else
498 /* Find the previous field boundary. */
499 {
500 Lisp_Object p = pos;
501 if (!NILP (merge_at_boundary) && EQ (before_field, Qboundary))
502 /* Skip a `boundary' field. */
503 p = Fprevious_single_char_property_change (p, Qfield, Qnil,
504 beg_limit);
505
506 p = Fprevious_single_char_property_change (p, Qfield, Qnil,
507 beg_limit);
508 *beg = NILP (p) ? BEGV : XFIXNAT (p);
509 }
510 }
511
512 if (end)
513 {
514 if (at_field_end)
515 /* POS is at the edge of a field, and we should consider it as
516 the end of the previous field. */
517 *end = XFIXNAT (pos);
518 else
519 /* Find the next field boundary. */
520 {
521 if (!NILP (merge_at_boundary) && EQ (after_field, Qboundary))
522 /* Skip a `boundary' field. */
523 pos = Fnext_single_char_property_change (pos, Qfield, Qnil,
524 end_limit);
525
526 pos = Fnext_single_char_property_change (pos, Qfield, Qnil,
527 end_limit);
528 *end = NILP (pos) ? ZV : XFIXNAT (pos);
529 }
530 }
531 }
532
533
534 DEFUN ("delete-field", Fdelete_field, Sdelete_field, 0, 1, 0,
535 doc: /* Delete the field surrounding POS.
536 A field is a region of text with the same `field' property.
537 If POS is nil, the value of point is used for POS. */)
538 (Lisp_Object pos)
539 {
540 ptrdiff_t beg, end;
541 find_field (pos, Qnil, Qnil, &beg, Qnil, &end);
542 if (beg != end)
543 del_range (beg, end);
544 return Qnil;
545 }
546
547 DEFUN ("field-string", Ffield_string, Sfield_string, 0, 1, 0,
548 doc: /* Return the contents of the field surrounding POS as a string.
549 A field is a region of text with the same `field' property.
550 If POS is nil, the value of point is used for POS. */)
551 (Lisp_Object pos)
552 {
553 ptrdiff_t beg, end;
554 find_field (pos, Qnil, Qnil, &beg, Qnil, &end);
555 return make_buffer_string (beg, end, 1);
556 }
557
558 DEFUN ("field-string-no-properties", Ffield_string_no_properties, Sfield_string_no_properties, 0, 1, 0,
559 doc: /* Return the contents of the field around POS, without text properties.
560 A field is a region of text with the same `field' property.
561 If POS is nil, the value of point is used for POS. */)
562 (Lisp_Object pos)
563 {
564 ptrdiff_t beg, end;
565 find_field (pos, Qnil, Qnil, &beg, Qnil, &end);
566 return make_buffer_string (beg, end, 0);
567 }
568
569 DEFUN ("field-beginning", Ffield_beginning, Sfield_beginning, 0, 3, 0,
570 doc: /* Return the beginning of the field surrounding POS.
571 A field is a region of text with the same `field' property.
572 If POS is nil, the value of point is used for POS.
573 If ESCAPE-FROM-EDGE is non-nil and POS is at the beginning of its
574 field, then the beginning of the *previous* field is returned.
575 If LIMIT is non-nil, it is a buffer position; if the beginning of the field
576 is before LIMIT, then LIMIT will be returned instead. */)
577 (Lisp_Object pos, Lisp_Object escape_from_edge, Lisp_Object limit)
578 {
579 ptrdiff_t beg;
580 find_field (pos, escape_from_edge, limit, &beg, Qnil, 0);
581 return make_fixnum (beg);
582 }
583
584 DEFUN ("field-end", Ffield_end, Sfield_end, 0, 3, 0,
585 doc: /* Return the end of the field surrounding POS.
586 A field is a region of text with the same `field' property.
587 If POS is nil, the value of point is used for POS.
588 If ESCAPE-FROM-EDGE is non-nil and POS is at the end of its field,
589 then the end of the *following* field is returned.
590 If LIMIT is non-nil, it is a buffer position; if the end of the field
591 is after LIMIT, then LIMIT will be returned instead. */)
592 (Lisp_Object pos, Lisp_Object escape_from_edge, Lisp_Object limit)
593 {
594 ptrdiff_t end;
595 find_field (pos, escape_from_edge, Qnil, 0, limit, &end);
596 return make_fixnum (end);
597 }
598
599 DEFUN ("constrain-to-field", Fconstrain_to_field, Sconstrain_to_field, 2, 5, 0,
600 doc: /* Return the position closest to NEW-POS that is in the same field as OLD-POS.
601 A field is a region of text with the same `field' property.
602
603 If NEW-POS is nil, then use the current point instead, and move point
604 to the resulting constrained position, in addition to returning that
605 position.
606
607 If OLD-POS is at the boundary of two fields, then the allowable
608 positions for NEW-POS depends on the value of the optional argument
609 ESCAPE-FROM-EDGE: If ESCAPE-FROM-EDGE is nil, then NEW-POS is
610 constrained to the field that has the same `field' char-property
611 as any new characters inserted at OLD-POS, whereas if ESCAPE-FROM-EDGE
612 is non-nil, NEW-POS is constrained to the union of the two adjacent
613 fields. Additionally, if two fields are separated by another field with
614 the special value `boundary', then any point within this special field is
615 also considered to be `on the boundary'.
616
617 If the optional argument ONLY-IN-LINE is non-nil and constraining
618 NEW-POS would move it to a different line, NEW-POS is returned
619 unconstrained. This is useful for commands that move by line, like
620 \\[next-line] or \\[beginning-of-line], which should generally respect field boundaries
621 only in the case where they can still move to the right line.
622
623 If the optional argument INHIBIT-CAPTURE-PROPERTY is non-nil, and OLD-POS has
624 a non-nil property of that name, then any field boundaries are ignored.
625
626 Field boundaries are not noticed if `inhibit-field-text-motion' is non-nil. */)
627 (Lisp_Object new_pos, Lisp_Object old_pos, Lisp_Object escape_from_edge,
628 Lisp_Object only_in_line, Lisp_Object inhibit_capture_property)
629 {
630 /* If non-zero, then the original point, before re-positioning. */
631 ptrdiff_t orig_point = 0;
632 bool fwd;
633 Lisp_Object prev_old, prev_new;
634
635 if (NILP (new_pos))
636 /* Use the current point, and afterwards, set it. */
637 {
638 orig_point = PT;
639 XSETFASTINT (new_pos, PT);
640 }
641
642 CHECK_FIXNUM_COERCE_MARKER (new_pos);
643 CHECK_FIXNUM_COERCE_MARKER (old_pos);
644
645 fwd = (XFIXNUM (new_pos) > XFIXNUM (old_pos));
646
647 prev_old = make_fixnum (XFIXNUM (old_pos) - 1);
648 prev_new = make_fixnum (XFIXNUM (new_pos) - 1);
649
650 if (NILP (Vinhibit_field_text_motion)
651 && !EQ (new_pos, old_pos)
652 && (!NILP (Fget_char_property (new_pos, Qfield, Qnil))
653 || !NILP (Fget_char_property (old_pos, Qfield, Qnil))
654 /* To recognize field boundaries, we must also look at the
655 previous positions; we could use `Fget_pos_property'
656 instead, but in itself that would fail inside non-sticky
657 fields (like comint prompts). */
658 || (XFIXNAT (new_pos) > BEGV
659 && !NILP (Fget_char_property (prev_new, Qfield, Qnil)))
660 || (XFIXNAT (old_pos) > BEGV
661 && !NILP (Fget_char_property (prev_old, Qfield, Qnil))))
662 && (NILP (inhibit_capture_property)
663 /* Field boundaries are again a problem; but now we must
664 decide the case exactly, so we need to call
665 `get_pos_property' as well. */
666 || (NILP (Fget_pos_property (old_pos, inhibit_capture_property, Qnil))
667 && (XFIXNAT (old_pos) <= BEGV
668 || NILP (Fget_char_property
669 (old_pos, inhibit_capture_property, Qnil))
670 || NILP (Fget_char_property
671 (prev_old, inhibit_capture_property, Qnil))))))
672 /* It is possible that NEW_POS is not within the same field as
673 OLD_POS; try to move NEW_POS so that it is. */
674 {
675 ptrdiff_t counted;
676 Lisp_Object field_bound;
677
678 if (fwd)
679 field_bound = Ffield_end (old_pos, escape_from_edge, new_pos);
680 else
681 field_bound = Ffield_beginning (old_pos, escape_from_edge, new_pos);
682
683 if (/* See if ESCAPE_FROM_EDGE caused FIELD_BOUND to jump to the
684 other side of NEW_POS, which would mean that NEW_POS is
685 already acceptable, and it's not necessary to constrain it
686 to FIELD_BOUND. */
687 ((XFIXNAT (field_bound) < XFIXNAT (new_pos)) ? fwd : !fwd)
688 /* NEW_POS should be constrained, but only if either
689 ONLY_IN_LINE is nil (in which case any constraint is OK),
690 or NEW_POS and FIELD_BOUND are on the same line (in which
691 case the constraint is OK even if ONLY_IN_LINE is non-nil). */
692 && (NILP (only_in_line)
693 /* This is the ONLY_IN_LINE case, check that NEW_POS and
694 FIELD_BOUND are on the same line by seeing whether
695 there's an intervening newline or not. */
696 || (find_newline (XFIXNAT (new_pos), -1,
697 XFIXNAT (field_bound), -1,
698 fwd ? -1 : 1, &counted, NULL, 1),
699 counted == 0)))
700 /* Constrain NEW_POS to FIELD_BOUND. */
701 new_pos = field_bound;
702
703 if (orig_point && XFIXNAT (new_pos) != orig_point)
704 /* The NEW_POS argument was originally nil, so automatically set PT. */
705 SET_PT (XFIXNAT (new_pos));
706 }
707
708 return new_pos;
709 }
710
711
712 DEFUN ("line-beginning-position",
713 Fline_beginning_position, Sline_beginning_position, 0, 1, 0,
714 doc: /* Return the character position of the first character on the current line.
715 With optional argument N, scan forward N - 1 lines first.
716 If the scan reaches the end of the buffer, return that position.
717
718 This function ignores text display directionality; it returns the
719 position of the first character in logical order, i.e. the smallest
720 character position on the logical line. See `vertical-motion' for
721 movement by screen lines.
722
723 This function constrains the returned position to the current field
724 unless that position would be on a different line from the original,
725 unconstrained result. If N is nil or 1, and a front-sticky field
726 starts at point, the scan stops as soon as it starts. To ignore field
727 boundaries, bind `inhibit-field-text-motion' to t.
728
729 This function does not move point. */)
730 (Lisp_Object n)
731 {
732 ptrdiff_t charpos, bytepos, count;
733
734 if (NILP (n))
735 count = 0;
736 else if (FIXNUMP (n))
737 count = clip_to_bounds (-BUF_BYTES_MAX, XFIXNUM (n) - 1, BUF_BYTES_MAX);
738 else
739 {
740 CHECK_INTEGER (n);
741 count = NILP (Fnatnump (n)) ? -BUF_BYTES_MAX : BUF_BYTES_MAX;
742 }
743
744 scan_newline_from_point (count, &charpos, &bytepos);
745
746 /* Return END constrained to the current input field. */
747 return Fconstrain_to_field (make_fixnum (charpos), make_fixnum (PT),
748 count != 0 ? Qt : Qnil,
749 Qt, Qnil);
750 }
751
752 DEFUN ("line-end-position", Fline_end_position, Sline_end_position, 0, 1, 0,
753 doc: /* Return the character position of the last character on the current line.
754 With argument N not nil or 1, move forward N - 1 lines first.
755 If scan reaches end of buffer, return that position.
756
757 This function ignores text display directionality; it returns the
758 position of the last character in logical order, i.e. the largest
759 character position on the line.
760
761 This function constrains the returned position to the current field
762 unless that would be on a different line from the original,
763 unconstrained result. If N is nil or 1, and a rear-sticky field ends
764 at point, the scan stops as soon as it starts. To ignore field
765 boundaries bind `inhibit-field-text-motion' to t.
766
767 This function does not move point. */)
768 (Lisp_Object n)
769 {
770 ptrdiff_t clipped_n;
771 ptrdiff_t end_pos;
772 ptrdiff_t orig = PT;
773
774 if (NILP (n))
775 clipped_n = 1;
776 else if (FIXNUMP (n))
777 clipped_n = clip_to_bounds (-BUF_BYTES_MAX, XFIXNUM (n), BUF_BYTES_MAX);
778 else
779 {
780 CHECK_INTEGER (n);
781 clipped_n = NILP (Fnatnump (n)) ? -BUF_BYTES_MAX : BUF_BYTES_MAX;
782 }
783 end_pos = find_before_next_newline (orig, 0, clipped_n - (clipped_n <= 0),
784 NULL);
785
786 /* Return END_POS constrained to the current input field. */
787 return Fconstrain_to_field (make_fixnum (end_pos), make_fixnum (orig),
788 Qnil, Qt, Qnil);
789 }
790
791 /* Save current buffer state for save-excursion special form. */
792
793 void
save_excursion_save(union specbinding * pdl)794 save_excursion_save (union specbinding *pdl)
795 {
796 eassert (pdl->unwind_excursion.kind == SPECPDL_UNWIND_EXCURSION);
797 pdl->unwind_excursion.marker = Fpoint_marker ();
798 /* Selected window if current buffer is shown in it, nil otherwise. */
799 pdl->unwind_excursion.window
800 = (EQ (XWINDOW (selected_window)->contents, Fcurrent_buffer ())
801 ? selected_window : Qnil);
802 }
803
804 /* Restore saved buffer before leaving `save-excursion' special form. */
805
806 void
save_excursion_restore(Lisp_Object marker,Lisp_Object window)807 save_excursion_restore (Lisp_Object marker, Lisp_Object window)
808 {
809 Lisp_Object buffer = Fmarker_buffer (marker);
810 /* If we're unwinding to top level, saved buffer may be deleted. This
811 means that all of its markers are unchained and so BUFFER is nil. */
812 if (NILP (buffer))
813 return;
814
815 Fset_buffer (buffer);
816
817 /* Point marker. */
818 Fgoto_char (marker);
819 unchain_marker (XMARKER (marker));
820
821 /* If buffer was visible in a window, and a different window was
822 selected, and the old selected window is still showing this
823 buffer, restore point in that window. */
824 if (WINDOWP (window) && !EQ (window, selected_window))
825 {
826 /* Set window point if WINDOW is live and shows the current buffer. */
827 Lisp_Object contents = XWINDOW (window)->contents;
828 if (BUFFERP (contents) && XBUFFER (contents) == current_buffer)
829 Fset_window_point (window, make_fixnum (PT));
830 }
831 }
832
833 DEFUN ("save-excursion", Fsave_excursion, Ssave_excursion, 0, UNEVALLED, 0,
834 doc: /* Save point, and current buffer; execute BODY; restore those things.
835 Executes BODY just like `progn'.
836 The values of point and the current buffer are restored
837 even in case of abnormal exit (throw or error).
838
839 If you only want to save the current buffer but not point,
840 then just use `save-current-buffer', or even `with-current-buffer'.
841
842 Before Emacs 25.1, `save-excursion' used to save the mark state.
843 To save the mark state as well as point and the current buffer, use
844 `save-mark-and-excursion'.
845
846 usage: (save-excursion &rest BODY) */)
847 (Lisp_Object args)
848 {
849 register Lisp_Object val;
850 ptrdiff_t count = SPECPDL_INDEX ();
851
852 record_unwind_protect_excursion ();
853
854 val = Fprogn (args);
855 return unbind_to (count, val);
856 }
857
858 DEFUN ("save-current-buffer", Fsave_current_buffer, Ssave_current_buffer, 0, UNEVALLED, 0,
859 doc: /* Record which buffer is current; execute BODY; make that buffer current.
860 BODY is executed just like `progn'.
861 usage: (save-current-buffer &rest BODY) */)
862 (Lisp_Object args)
863 {
864 ptrdiff_t count = SPECPDL_INDEX ();
865
866 record_unwind_current_buffer ();
867 return unbind_to (count, Fprogn (args));
868 }
869
870 DEFUN ("buffer-size", Fbuffer_size, Sbuffer_size, 0, 1, 0,
871 doc: /* Return the number of characters in the current buffer.
872 If BUFFER is not nil, return the number of characters in that buffer
873 instead.
874
875 This does not take narrowing into account; to count the number of
876 characters in the accessible portion of the current buffer, use
877 `(- (point-max) (point-min))', and to count the number of characters
878 in the accessible portion of some other BUFFER, use
879 `(with-current-buffer BUFFER (- (point-max) (point-min)))'. */)
880 (Lisp_Object buffer)
881 {
882 if (NILP (buffer))
883 return make_fixnum (Z - BEG);
884 else
885 {
886 CHECK_BUFFER (buffer);
887 return make_fixnum (BUF_Z (XBUFFER (buffer))
888 - BUF_BEG (XBUFFER (buffer)));
889 }
890 }
891
892 DEFUN ("point-min", Fpoint_min, Spoint_min, 0, 0, 0,
893 doc: /* Return the minimum permissible value of point in the current buffer.
894 This is 1, unless narrowing (a buffer restriction) is in effect. */)
895 (void)
896 {
897 Lisp_Object temp;
898 XSETFASTINT (temp, BEGV);
899 return temp;
900 }
901
902 DEFUN ("point-min-marker", Fpoint_min_marker, Spoint_min_marker, 0, 0, 0,
903 doc: /* Return a marker to the minimum permissible value of point in this buffer.
904 This is the beginning, unless narrowing (a buffer restriction) is in effect. */)
905 (void)
906 {
907 return build_marker (current_buffer, BEGV, BEGV_BYTE);
908 }
909
910 DEFUN ("point-max", Fpoint_max, Spoint_max, 0, 0, 0,
911 doc: /* Return the maximum permissible value of point in the current buffer.
912 This is (1+ (buffer-size)), unless narrowing (a buffer restriction)
913 is in effect, in which case it is less. */)
914 (void)
915 {
916 Lisp_Object temp;
917 XSETFASTINT (temp, ZV);
918 return temp;
919 }
920
921 DEFUN ("point-max-marker", Fpoint_max_marker, Spoint_max_marker, 0, 0, 0,
922 doc: /* Return a marker to the maximum permissible value of point in this buffer.
923 This is (1+ (buffer-size)), unless narrowing (a buffer restriction)
924 is in effect, in which case it is less. */)
925 (void)
926 {
927 return build_marker (current_buffer, ZV, ZV_BYTE);
928 }
929
930 DEFUN ("gap-position", Fgap_position, Sgap_position, 0, 0, 0,
931 doc: /* Return the position of the gap, in the current buffer.
932 See also `gap-size'. */)
933 (void)
934 {
935 Lisp_Object temp;
936 XSETFASTINT (temp, GPT);
937 return temp;
938 }
939
940 DEFUN ("gap-size", Fgap_size, Sgap_size, 0, 0, 0,
941 doc: /* Return the size of the current buffer's gap.
942 See also `gap-position'. */)
943 (void)
944 {
945 Lisp_Object temp;
946 XSETFASTINT (temp, GAP_SIZE);
947 return temp;
948 }
949
950 DEFUN ("position-bytes", Fposition_bytes, Sposition_bytes, 1, 1, 0,
951 doc: /* Return the byte position for character position POSITION.
952 If POSITION is out of range, the value is nil. */)
953 (Lisp_Object position)
954 {
955 EMACS_INT pos = fix_position (position);
956 if (! (BEG <= pos && pos <= Z))
957 return Qnil;
958 return make_fixnum (CHAR_TO_BYTE (pos));
959 }
960
961 DEFUN ("byte-to-position", Fbyte_to_position, Sbyte_to_position, 1, 1, 0,
962 doc: /* Return the character position for byte position BYTEPOS.
963 If BYTEPOS is out of range, the value is nil. */)
964 (Lisp_Object bytepos)
965 {
966 ptrdiff_t pos_byte;
967
968 CHECK_FIXNUM (bytepos);
969 pos_byte = XFIXNUM (bytepos);
970 if (pos_byte < BEG_BYTE || pos_byte > Z_BYTE)
971 return Qnil;
972 if (Z != Z_BYTE)
973 /* There are multibyte characters in the buffer.
974 The argument of BYTE_TO_CHAR must be a byte position at
975 a character boundary, so search for the start of the current
976 character. */
977 while (!CHAR_HEAD_P (FETCH_BYTE (pos_byte)))
978 pos_byte--;
979 return make_fixnum (BYTE_TO_CHAR (pos_byte));
980 }
981
982 DEFUN ("following-char", Ffollowing_char, Sfollowing_char, 0, 0, 0,
983 doc: /* Return the character following point, as a number.
984 At the end of the buffer or accessible region, return 0. */)
985 (void)
986 {
987 Lisp_Object temp;
988 if (PT >= ZV)
989 XSETFASTINT (temp, 0);
990 else
991 XSETFASTINT (temp, FETCH_CHAR (PT_BYTE));
992 return temp;
993 }
994
995 DEFUN ("preceding-char", Fprevious_char, Sprevious_char, 0, 0, 0,
996 doc: /* Return the character preceding point, as a number.
997 At the beginning of the buffer or accessible region, return 0. */)
998 (void)
999 {
1000 Lisp_Object temp;
1001 if (PT <= BEGV)
1002 XSETFASTINT (temp, 0);
1003 else if (!NILP (BVAR (current_buffer, enable_multibyte_characters)))
1004 {
1005 ptrdiff_t pos = PT_BYTE;
1006 pos -= prev_char_len (pos);
1007 XSETFASTINT (temp, FETCH_CHAR (pos));
1008 }
1009 else
1010 XSETFASTINT (temp, FETCH_BYTE (PT_BYTE - 1));
1011 return temp;
1012 }
1013
1014 DEFUN ("bobp", Fbobp, Sbobp, 0, 0, 0,
1015 doc: /* Return t if point is at the beginning of the buffer.
1016 If the buffer is narrowed, this means the beginning of the narrowed part. */)
1017 (void)
1018 {
1019 if (PT == BEGV)
1020 return Qt;
1021 return Qnil;
1022 }
1023
1024 DEFUN ("eobp", Feobp, Seobp, 0, 0, 0,
1025 doc: /* Return t if point is at the end of the buffer.
1026 If the buffer is narrowed, this means the end of the narrowed part. */)
1027 (void)
1028 {
1029 if (PT == ZV)
1030 return Qt;
1031 return Qnil;
1032 }
1033
1034 DEFUN ("bolp", Fbolp, Sbolp, 0, 0, 0,
1035 doc: /* Return t if point is at the beginning of a line. */)
1036 (void)
1037 {
1038 if (PT == BEGV || FETCH_BYTE (PT_BYTE - 1) == '\n')
1039 return Qt;
1040 return Qnil;
1041 }
1042
1043 DEFUN ("eolp", Feolp, Seolp, 0, 0, 0,
1044 doc: /* Return t if point is at the end of a line.
1045 `End of a line' includes point being at the end of the buffer. */)
1046 (void)
1047 {
1048 if (PT == ZV || FETCH_BYTE (PT_BYTE) == '\n')
1049 return Qt;
1050 return Qnil;
1051 }
1052
1053 DEFUN ("char-after", Fchar_after, Schar_after, 0, 1, 0,
1054 doc: /* Return character in current buffer at position POS.
1055 POS is an integer or a marker and defaults to point.
1056 If POS is out of range, the value is nil. */)
1057 (Lisp_Object pos)
1058 {
1059 register ptrdiff_t pos_byte;
1060
1061 if (NILP (pos))
1062 {
1063 pos_byte = PT_BYTE;
1064 if (pos_byte < BEGV_BYTE || pos_byte >= ZV_BYTE)
1065 return Qnil;
1066 }
1067 else if (MARKERP (pos))
1068 {
1069 pos_byte = marker_byte_position (pos);
1070 if (pos_byte < BEGV_BYTE || pos_byte >= ZV_BYTE)
1071 return Qnil;
1072 }
1073 else
1074 {
1075 EMACS_INT p = fix_position (pos);
1076 if (! (BEGV <= p && p < ZV))
1077 return Qnil;
1078
1079 pos_byte = CHAR_TO_BYTE (p);
1080 }
1081
1082 return make_fixnum (FETCH_CHAR (pos_byte));
1083 }
1084
1085 DEFUN ("char-before", Fchar_before, Schar_before, 0, 1, 0,
1086 doc: /* Return character in current buffer preceding position POS.
1087 POS is an integer or a marker and defaults to point.
1088 If POS is out of range, the value is nil. */)
1089 (Lisp_Object pos)
1090 {
1091 register Lisp_Object val;
1092 register ptrdiff_t pos_byte;
1093
1094 if (NILP (pos))
1095 {
1096 pos_byte = PT_BYTE;
1097 XSETFASTINT (pos, PT);
1098 }
1099
1100 if (MARKERP (pos))
1101 {
1102 pos_byte = marker_byte_position (pos);
1103
1104 if (pos_byte <= BEGV_BYTE || pos_byte > ZV_BYTE)
1105 return Qnil;
1106 }
1107 else
1108 {
1109 EMACS_INT p = fix_position (pos);
1110
1111 if (! (BEGV < p && p <= ZV))
1112 return Qnil;
1113
1114 pos_byte = CHAR_TO_BYTE (p);
1115 }
1116
1117 if (!NILP (BVAR (current_buffer, enable_multibyte_characters)))
1118 {
1119 pos_byte -= prev_char_len (pos_byte);
1120 XSETFASTINT (val, FETCH_CHAR (pos_byte));
1121 }
1122 else
1123 {
1124 pos_byte--;
1125 XSETFASTINT (val, FETCH_BYTE (pos_byte));
1126 }
1127 return val;
1128 }
1129
1130 DEFUN ("user-login-name", Fuser_login_name, Suser_login_name, 0, 1, 0,
1131 doc: /* Return the name under which the user logged in, as a string.
1132 This is based on the effective uid, not the real uid.
1133 Also, if the environment variables LOGNAME or USER are set,
1134 that determines the value of this function.
1135
1136 If optional argument UID is an integer, return the login name
1137 of the user with that uid, or nil if there is no such user. */)
1138 (Lisp_Object uid)
1139 {
1140 struct passwd *pw;
1141 uid_t id;
1142
1143 /* Set up the user name info if we didn't do it before.
1144 (That can happen if Emacs is dumpable
1145 but you decide to run `temacs -l loadup' and not dump. */
1146 if (NILP (Vuser_login_name))
1147 init_editfns ();
1148
1149 if (NILP (uid))
1150 return Vuser_login_name;
1151
1152 CONS_TO_INTEGER (uid, uid_t, id);
1153 block_input ();
1154 pw = getpwuid (id);
1155 unblock_input ();
1156 return (pw ? build_string (pw->pw_name) : Qnil);
1157 }
1158
1159 DEFUN ("user-real-login-name", Fuser_real_login_name, Suser_real_login_name,
1160 0, 0, 0,
1161 doc: /* Return the name of the user's real uid, as a string.
1162 This ignores the environment variables LOGNAME and USER, so it differs from
1163 `user-login-name' when running under `su'. */)
1164 (void)
1165 {
1166 /* Set up the user name info if we didn't do it before.
1167 (That can happen if Emacs is dumpable
1168 but you decide to run `temacs -l loadup' and not dump. */
1169 if (NILP (Vuser_login_name))
1170 init_editfns ();
1171 return Vuser_real_login_name;
1172 }
1173
1174 DEFUN ("user-uid", Fuser_uid, Suser_uid, 0, 0, 0,
1175 doc: /* Return the effective uid of Emacs.
1176 Value is a fixnum, if it's small enough, otherwise a bignum. */)
1177 (void)
1178 {
1179 uid_t euid = geteuid ();
1180 return INT_TO_INTEGER (euid);
1181 }
1182
1183 DEFUN ("user-real-uid", Fuser_real_uid, Suser_real_uid, 0, 0, 0,
1184 doc: /* Return the real uid of Emacs.
1185 Value is a fixnum, if it's small enough, otherwise a bignum. */)
1186 (void)
1187 {
1188 uid_t uid = getuid ();
1189 return INT_TO_INTEGER (uid);
1190 }
1191
1192 DEFUN ("group-name", Fgroup_name, Sgroup_name, 1, 1, 0,
1193 doc: /* Return the name of the group whose numeric group ID is GID.
1194 The argument GID should be an integer or a float.
1195 Return nil if a group with such GID does not exists or is not known. */)
1196 (Lisp_Object gid)
1197 {
1198 struct group *gr;
1199 gid_t id;
1200
1201 if (!NUMBERP (gid) && !CONSP (gid))
1202 error ("Invalid GID specification");
1203 CONS_TO_INTEGER (gid, gid_t, id);
1204 block_input ();
1205 gr = getgrgid (id);
1206 unblock_input ();
1207 return gr ? build_string (gr->gr_name) : Qnil;
1208 }
1209
1210 DEFUN ("group-gid", Fgroup_gid, Sgroup_gid, 0, 0, 0,
1211 doc: /* Return the effective gid of Emacs.
1212 Value is a fixnum, if it's small enough, otherwise a bignum. */)
1213 (void)
1214 {
1215 gid_t egid = getegid ();
1216 return INT_TO_INTEGER (egid);
1217 }
1218
1219 DEFUN ("group-real-gid", Fgroup_real_gid, Sgroup_real_gid, 0, 0, 0,
1220 doc: /* Return the real gid of Emacs.
1221 Value is a fixnum, if it's small enough, otherwise a bignum. */)
1222 (void)
1223 {
1224 gid_t gid = getgid ();
1225 return INT_TO_INTEGER (gid);
1226 }
1227
1228 DEFUN ("user-full-name", Fuser_full_name, Suser_full_name, 0, 1, 0,
1229 doc: /* Return the full name of the user logged in, as a string.
1230 If the full name corresponding to Emacs's userid is not known,
1231 return "unknown".
1232
1233 If optional argument UID is an integer, return the full name
1234 of the user with that uid, or nil if there is no such user.
1235 If UID is a string, return the full name of the user with that login
1236 name, or nil if there is no such user.
1237
1238 If the full name includes commas, remove everything starting with
1239 the first comma, because the \\='gecos\\=' field of the \\='/etc/passwd\\=' file
1240 is in general a comma-separated list. */)
1241 (Lisp_Object uid)
1242 {
1243 struct passwd *pw;
1244 register char *p, *q;
1245 Lisp_Object full;
1246
1247 if (NILP (uid))
1248 return Vuser_full_name;
1249 else if (NUMBERP (uid))
1250 {
1251 uid_t u;
1252 CONS_TO_INTEGER (uid, uid_t, u);
1253 block_input ();
1254 pw = getpwuid (u);
1255 unblock_input ();
1256 }
1257 else if (STRINGP (uid))
1258 {
1259 block_input ();
1260 pw = getpwnam (SSDATA (uid));
1261 unblock_input ();
1262 }
1263 else
1264 error ("Invalid UID specification");
1265
1266 if (!pw)
1267 return Qnil;
1268
1269 p = USER_FULL_NAME;
1270 /* Chop off everything after the first comma, since 'pw_gecos' is a
1271 comma-separated list. */
1272 q = strchr (p, ',');
1273 full = make_string (p, q ? q - p : strlen (p));
1274
1275 #ifdef AMPERSAND_FULL_NAME
1276 p = SSDATA (full);
1277 q = strchr (p, '&');
1278 /* Substitute the login name for the &, upcasing the first character. */
1279 if (q)
1280 {
1281 Lisp_Object login = Fuser_login_name (INT_TO_INTEGER (pw->pw_uid));
1282 if (!NILP (login))
1283 {
1284 USE_SAFE_ALLOCA;
1285 char *r = SAFE_ALLOCA (strlen (p) + SBYTES (login) + 1);
1286 memcpy (r, p, q - p);
1287 char *s = lispstpcpy (&r[q - p], login);
1288 r[q - p] = upcase ((unsigned char) r[q - p]);
1289 strcpy (s, q + 1);
1290 full = build_string (r);
1291 SAFE_FREE ();
1292 }
1293 }
1294 #endif /* AMPERSAND_FULL_NAME */
1295
1296 return full;
1297 }
1298
1299 DEFUN ("system-name", Fsystem_name, Ssystem_name, 0, 0, 0,
1300 doc: /* Return the host name of the machine you are running on, as a string. */)
1301 (void)
1302 {
1303 if (EQ (Vsystem_name, cached_system_name))
1304 init_and_cache_system_name ();
1305 return Vsystem_name;
1306 }
1307
1308 DEFUN ("emacs-pid", Femacs_pid, Semacs_pid, 0, 0, 0,
1309 doc: /* Return the process ID of Emacs, as a number.
1310 Value is a fixnum, if it's small enough, otherwise a bignum. */)
1311 (void)
1312 {
1313 pid_t pid = getpid ();
1314 return INT_TO_INTEGER (pid);
1315 }
1316
1317
1318 /* Insert NARGS Lisp objects in the array ARGS by calling INSERT_FUNC
1319 (if a type of object is Lisp_Int) or INSERT_FROM_STRING_FUNC (if a
1320 type of object is Lisp_String). INHERIT is passed to
1321 INSERT_FROM_STRING_FUNC as the last argument. */
1322
1323 static void
general_insert_function(void (* insert_func)(const char *,ptrdiff_t),void (* insert_from_string_func)(Lisp_Object,ptrdiff_t,ptrdiff_t,ptrdiff_t,ptrdiff_t,bool),bool inherit,ptrdiff_t nargs,Lisp_Object * args)1324 general_insert_function (void (*insert_func)
1325 (const char *, ptrdiff_t),
1326 void (*insert_from_string_func)
1327 (Lisp_Object, ptrdiff_t, ptrdiff_t,
1328 ptrdiff_t, ptrdiff_t, bool),
1329 bool inherit, ptrdiff_t nargs, Lisp_Object *args)
1330 {
1331 ptrdiff_t argnum;
1332 Lisp_Object val;
1333
1334 for (argnum = 0; argnum < nargs; argnum++)
1335 {
1336 val = args[argnum];
1337 if (CHARACTERP (val))
1338 {
1339 int c = XFIXNAT (val);
1340 unsigned char str[MAX_MULTIBYTE_LENGTH];
1341 int len;
1342
1343 if (!NILP (BVAR (current_buffer, enable_multibyte_characters)))
1344 len = CHAR_STRING (c, str);
1345 else
1346 {
1347 str[0] = CHAR_TO_BYTE8 (c);
1348 len = 1;
1349 }
1350 (*insert_func) ((char *) str, len);
1351 }
1352 else if (STRINGP (val))
1353 {
1354 (*insert_from_string_func) (val, 0, 0,
1355 SCHARS (val),
1356 SBYTES (val),
1357 inherit);
1358 }
1359 else
1360 wrong_type_argument (Qchar_or_string_p, val);
1361 }
1362 }
1363
1364 void
insert1(Lisp_Object arg)1365 insert1 (Lisp_Object arg)
1366 {
1367 Finsert (1, &arg);
1368 }
1369
1370
1371 DEFUN ("insert", Finsert, Sinsert, 0, MANY, 0,
1372 doc: /* Insert the arguments, either strings or characters, at point.
1373 Point and after-insertion markers move forward to end up
1374 after the inserted text.
1375 Any other markers at the point of insertion remain before the text.
1376
1377 If the current buffer is multibyte, unibyte strings are converted
1378 to multibyte for insertion (see `string-make-multibyte').
1379 If the current buffer is unibyte, multibyte strings are converted
1380 to unibyte for insertion (see `string-make-unibyte').
1381
1382 When operating on binary data, it may be necessary to preserve the
1383 original bytes of a unibyte string when inserting it into a multibyte
1384 buffer; to accomplish this, apply `string-as-multibyte' to the string
1385 and insert the result.
1386
1387 usage: (insert &rest ARGS) */)
1388 (ptrdiff_t nargs, Lisp_Object *args)
1389 {
1390 general_insert_function (insert, insert_from_string, 0, nargs, args);
1391 return Qnil;
1392 }
1393
1394 DEFUN ("insert-and-inherit", Finsert_and_inherit, Sinsert_and_inherit,
1395 0, MANY, 0,
1396 doc: /* Insert the arguments at point, inheriting properties from adjoining text.
1397 Point and after-insertion markers move forward to end up
1398 after the inserted text.
1399 Any other markers at the point of insertion remain before the text.
1400
1401 If the current buffer is multibyte, unibyte strings are converted
1402 to multibyte for insertion (see `unibyte-char-to-multibyte').
1403 If the current buffer is unibyte, multibyte strings are converted
1404 to unibyte for insertion.
1405
1406 usage: (insert-and-inherit &rest ARGS) */)
1407 (ptrdiff_t nargs, Lisp_Object *args)
1408 {
1409 general_insert_function (insert_and_inherit, insert_from_string, 1,
1410 nargs, args);
1411 return Qnil;
1412 }
1413
1414 DEFUN ("insert-before-markers", Finsert_before_markers, Sinsert_before_markers, 0, MANY, 0,
1415 doc: /* Insert strings or characters at point, relocating markers after the text.
1416 Point and markers move forward to end up after the inserted text.
1417
1418 If the current buffer is multibyte, unibyte strings are converted
1419 to multibyte for insertion (see `unibyte-char-to-multibyte').
1420 If the current buffer is unibyte, multibyte strings are converted
1421 to unibyte for insertion.
1422
1423 If an overlay begins at the insertion point, the inserted text falls
1424 outside the overlay; if a nonempty overlay ends at the insertion
1425 point, the inserted text falls inside that overlay.
1426
1427 usage: (insert-before-markers &rest ARGS) */)
1428 (ptrdiff_t nargs, Lisp_Object *args)
1429 {
1430 general_insert_function (insert_before_markers,
1431 insert_from_string_before_markers, 0,
1432 nargs, args);
1433 return Qnil;
1434 }
1435
1436 DEFUN ("insert-before-markers-and-inherit", Finsert_and_inherit_before_markers,
1437 Sinsert_and_inherit_before_markers, 0, MANY, 0,
1438 doc: /* Insert text at point, relocating markers and inheriting properties.
1439 Point and markers move forward to end up after the inserted text.
1440
1441 If the current buffer is multibyte, unibyte strings are converted
1442 to multibyte for insertion (see `unibyte-char-to-multibyte').
1443 If the current buffer is unibyte, multibyte strings are converted
1444 to unibyte for insertion.
1445
1446 usage: (insert-before-markers-and-inherit &rest ARGS) */)
1447 (ptrdiff_t nargs, Lisp_Object *args)
1448 {
1449 general_insert_function (insert_before_markers_and_inherit,
1450 insert_from_string_before_markers, 1,
1451 nargs, args);
1452 return Qnil;
1453 }
1454
1455 DEFUN ("insert-char", Finsert_char, Sinsert_char, 1, 3,
1456 "(list (read-char-by-name \"Insert character (Unicode name or hex): \")\
1457 (prefix-numeric-value current-prefix-arg)\
1458 t))",
1459 doc: /* Insert COUNT copies of CHARACTER.
1460 Interactively, prompt for CHARACTER using `read-char-by-name'.
1461 You can specify CHARACTER in one of these ways:
1462
1463 - As its Unicode character name, e.g. \"LATIN SMALL LETTER A\".
1464 Completion is available; if you type a substring of the name
1465 preceded by an asterisk `*', Emacs shows all names which include
1466 that substring, not necessarily at the beginning of the name.
1467
1468 - As a hexadecimal code point, e.g. 263A. Note that code points in
1469 Emacs are equivalent to Unicode up to 10FFFF (which is the limit of
1470 the Unicode code space).
1471
1472 - As a code point with a radix specified with #, e.g. #o21430
1473 (octal), #x2318 (hex), or #10r8984 (decimal).
1474
1475 If called interactively, COUNT is given by the prefix argument. If
1476 omitted or nil, it defaults to 1.
1477
1478 Inserting the character(s) relocates point and before-insertion
1479 markers in the same ways as the function `insert'.
1480
1481 The optional third argument INHERIT, if non-nil, says to inherit text
1482 properties from adjoining text, if those properties are sticky. If
1483 called interactively, INHERIT is t. */)
1484 (Lisp_Object character, Lisp_Object count, Lisp_Object inherit)
1485 {
1486 int i, stringlen;
1487 register ptrdiff_t n;
1488 int c, len;
1489 unsigned char str[MAX_MULTIBYTE_LENGTH];
1490 char string[4000];
1491
1492 CHECK_CHARACTER (character);
1493 if (NILP (count))
1494 XSETFASTINT (count, 1);
1495 else
1496 CHECK_FIXNUM (count);
1497 c = XFIXNAT (character);
1498
1499 if (!NILP (BVAR (current_buffer, enable_multibyte_characters)))
1500 len = CHAR_STRING (c, str);
1501 else
1502 str[0] = c, len = 1;
1503 if (XFIXNUM (count) <= 0)
1504 return Qnil;
1505 if (BUF_BYTES_MAX / len < XFIXNUM (count))
1506 buffer_overflow ();
1507 n = XFIXNUM (count) * len;
1508 stringlen = min (n, sizeof string - sizeof string % len);
1509 for (i = 0; i < stringlen; i++)
1510 string[i] = str[i % len];
1511 while (n > stringlen)
1512 {
1513 maybe_quit ();
1514 if (!NILP (inherit))
1515 insert_and_inherit (string, stringlen);
1516 else
1517 insert (string, stringlen);
1518 n -= stringlen;
1519 }
1520 if (!NILP (inherit))
1521 insert_and_inherit (string, n);
1522 else
1523 insert (string, n);
1524 return Qnil;
1525 }
1526
1527 DEFUN ("insert-byte", Finsert_byte, Sinsert_byte, 2, 3, 0,
1528 doc: /* Insert COUNT (second arg) copies of BYTE (first arg).
1529 Both arguments are required.
1530 BYTE is a number of the range 0..255.
1531
1532 If BYTE is 128..255 and the current buffer is multibyte, the
1533 corresponding eight-bit character is inserted.
1534
1535 Point, and before-insertion markers, are relocated as in the function `insert'.
1536 The optional third arg INHERIT, if non-nil, says to inherit text properties
1537 from adjoining text, if those properties are sticky. */)
1538 (Lisp_Object byte, Lisp_Object count, Lisp_Object inherit)
1539 {
1540 CHECK_FIXNUM (byte);
1541 if (XFIXNUM (byte) < 0 || XFIXNUM (byte) > 255)
1542 args_out_of_range_3 (byte, make_fixnum (0), make_fixnum (255));
1543 if (XFIXNUM (byte) >= 128
1544 && ! NILP (BVAR (current_buffer, enable_multibyte_characters)))
1545 XSETFASTINT (byte, BYTE8_TO_CHAR (XFIXNUM (byte)));
1546 return Finsert_char (byte, count, inherit);
1547 }
1548
1549
1550 /* Making strings from buffer contents. */
1551
1552 /* Return a Lisp_String containing the text of the current buffer from
1553 START to END. If text properties are in use and the current buffer
1554 has properties in the range specified, the resulting string will also
1555 have them, if PROPS is true.
1556
1557 We don't want to use plain old make_string here, because it calls
1558 make_uninit_string, which can cause the buffer arena to be
1559 compacted. make_string has no way of knowing that the data has
1560 been moved, and thus copies the wrong data into the string. This
1561 doesn't affect most of the other users of make_string, so it should
1562 be left as is. But we should use this function when conjuring
1563 buffer substrings. */
1564
1565 Lisp_Object
make_buffer_string(ptrdiff_t start,ptrdiff_t end,bool props)1566 make_buffer_string (ptrdiff_t start, ptrdiff_t end, bool props)
1567 {
1568 ptrdiff_t start_byte = CHAR_TO_BYTE (start);
1569 ptrdiff_t end_byte = CHAR_TO_BYTE (end);
1570
1571 return make_buffer_string_both (start, start_byte, end, end_byte, props);
1572 }
1573
1574 /* Return a Lisp_String containing the text of the current buffer from
1575 START / START_BYTE to END / END_BYTE.
1576
1577 If text properties are in use and the current buffer
1578 has properties in the range specified, the resulting string will also
1579 have them, if PROPS is true.
1580
1581 We don't want to use plain old make_string here, because it calls
1582 make_uninit_string, which can cause the buffer arena to be
1583 compacted. make_string has no way of knowing that the data has
1584 been moved, and thus copies the wrong data into the string. This
1585 doesn't effect most of the other users of make_string, so it should
1586 be left as is. But we should use this function when conjuring
1587 buffer substrings. */
1588
1589 Lisp_Object
make_buffer_string_both(ptrdiff_t start,ptrdiff_t start_byte,ptrdiff_t end,ptrdiff_t end_byte,bool props)1590 make_buffer_string_both (ptrdiff_t start, ptrdiff_t start_byte,
1591 ptrdiff_t end, ptrdiff_t end_byte, bool props)
1592 {
1593 Lisp_Object result, tem, tem1;
1594 ptrdiff_t beg0, end0, beg1, end1, size;
1595
1596 if (start_byte < GPT_BYTE && GPT_BYTE < end_byte)
1597 {
1598 /* Two regions, before and after the gap. */
1599 beg0 = start_byte;
1600 end0 = GPT_BYTE;
1601 beg1 = GPT_BYTE + GAP_SIZE - BEG_BYTE;
1602 end1 = end_byte + GAP_SIZE - BEG_BYTE;
1603 }
1604 else
1605 {
1606 /* The only region. */
1607 beg0 = start_byte;
1608 end0 = end_byte;
1609 beg1 = -1;
1610 end1 = -1;
1611 }
1612
1613 if (! NILP (BVAR (current_buffer, enable_multibyte_characters)))
1614 result = make_uninit_multibyte_string (end - start, end_byte - start_byte);
1615 else
1616 result = make_uninit_string (end - start);
1617
1618 size = end0 - beg0;
1619 memcpy (SDATA (result), BYTE_POS_ADDR (beg0), size);
1620 if (beg1 != -1)
1621 memcpy (SDATA (result) + size, BEG_ADDR + beg1, end1 - beg1);
1622
1623 /* If desired, update and copy the text properties. */
1624 if (props)
1625 {
1626 update_buffer_properties (start, end);
1627
1628 tem = Fnext_property_change (make_fixnum (start), Qnil, make_fixnum (end));
1629 tem1 = Ftext_properties_at (make_fixnum (start), Qnil);
1630
1631 if (XFIXNUM (tem) != end || !NILP (tem1))
1632 copy_intervals_to_string (result, current_buffer, start,
1633 end - start);
1634 }
1635
1636 return result;
1637 }
1638
1639 /* Call Vbuffer_access_fontify_functions for the range START ... END
1640 in the current buffer, if necessary. */
1641
1642 static void
update_buffer_properties(ptrdiff_t start,ptrdiff_t end)1643 update_buffer_properties (ptrdiff_t start, ptrdiff_t end)
1644 {
1645 /* If this buffer has some access functions,
1646 call them, specifying the range of the buffer being accessed. */
1647 if (!NILP (Vbuffer_access_fontify_functions))
1648 {
1649 /* But don't call them if we can tell that the work
1650 has already been done. */
1651 if (!NILP (Vbuffer_access_fontified_property))
1652 {
1653 Lisp_Object tem
1654 = Ftext_property_any (make_fixnum (start), make_fixnum (end),
1655 Vbuffer_access_fontified_property,
1656 Qnil, Qnil);
1657 if (NILP (tem))
1658 return;
1659 }
1660
1661 CALLN (Frun_hook_with_args, Qbuffer_access_fontify_functions,
1662 make_fixnum (start), make_fixnum (end));
1663 }
1664 }
1665
1666 DEFUN ("buffer-substring", Fbuffer_substring, Sbuffer_substring, 2, 2, 0,
1667 doc: /* Return the contents of part of the current buffer as a string.
1668 The two arguments START and END are character positions;
1669 they can be in either order.
1670 The string returned is multibyte if the buffer is multibyte.
1671
1672 This function copies the text properties of that part of the buffer
1673 into the result string; if you don't want the text properties,
1674 use `buffer-substring-no-properties' instead. */)
1675 (Lisp_Object start, Lisp_Object end)
1676 {
1677 register ptrdiff_t b, e;
1678
1679 validate_region (&start, &end);
1680 b = XFIXNUM (start);
1681 e = XFIXNUM (end);
1682
1683 return make_buffer_string (b, e, 1);
1684 }
1685
1686 DEFUN ("buffer-substring-no-properties", Fbuffer_substring_no_properties,
1687 Sbuffer_substring_no_properties, 2, 2, 0,
1688 doc: /* Return the characters of part of the buffer, without the text properties.
1689 The two arguments START and END are character positions;
1690 they can be in either order. */)
1691 (Lisp_Object start, Lisp_Object end)
1692 {
1693 register ptrdiff_t b, e;
1694
1695 validate_region (&start, &end);
1696 b = XFIXNUM (start);
1697 e = XFIXNUM (end);
1698
1699 return make_buffer_string (b, e, 0);
1700 }
1701
1702 DEFUN ("buffer-string", Fbuffer_string, Sbuffer_string, 0, 0, 0,
1703 doc: /* Return the contents of the current buffer as a string.
1704 If narrowing is in effect, this function returns only the visible part
1705 of the buffer.
1706
1707 This function copies the text properties of that part of the buffer
1708 into the result string; if you don’t want the text properties,
1709 use `buffer-substring-no-properties' instead. */)
1710 (void)
1711 {
1712 return make_buffer_string_both (BEGV, BEGV_BYTE, ZV, ZV_BYTE, 1);
1713 }
1714
1715 DEFUN ("insert-buffer-substring", Finsert_buffer_substring, Sinsert_buffer_substring,
1716 1, 3, 0,
1717 doc: /* Insert before point a substring of the contents of BUFFER.
1718 BUFFER may be a buffer or a buffer name.
1719 Arguments START and END are character positions specifying the substring.
1720 They default to the values of (point-min) and (point-max) in BUFFER.
1721
1722 Point and before-insertion markers move forward to end up after the
1723 inserted text.
1724 Any other markers at the point of insertion remain before the text.
1725
1726 If the current buffer is multibyte and BUFFER is unibyte, or vice
1727 versa, strings are converted from unibyte to multibyte or vice versa
1728 using `string-make-multibyte' or `string-make-unibyte', which see. */)
1729 (Lisp_Object buffer, Lisp_Object start, Lisp_Object end)
1730 {
1731 register EMACS_INT b, e, temp;
1732 register struct buffer *bp, *obuf;
1733 Lisp_Object buf;
1734
1735 buf = Fget_buffer (buffer);
1736 if (NILP (buf))
1737 nsberror (buffer);
1738 bp = XBUFFER (buf);
1739 if (!BUFFER_LIVE_P (bp))
1740 error ("Selecting deleted buffer");
1741
1742 b = !NILP (start) ? fix_position (start) : BUF_BEGV (bp);
1743 e = !NILP (end) ? fix_position (end) : BUF_ZV (bp);
1744 if (b > e)
1745 temp = b, b = e, e = temp;
1746
1747 if (!(BUF_BEGV (bp) <= b && e <= BUF_ZV (bp)))
1748 args_out_of_range (start, end);
1749
1750 obuf = current_buffer;
1751 set_buffer_internal_1 (bp);
1752 update_buffer_properties (b, e);
1753 set_buffer_internal_1 (obuf);
1754
1755 insert_from_buffer (bp, b, e - b, 0);
1756 return Qnil;
1757 }
1758
1759 DEFUN ("compare-buffer-substrings", Fcompare_buffer_substrings, Scompare_buffer_substrings,
1760 6, 6, 0,
1761 doc: /* Compare two substrings of two buffers; return result as number.
1762 Return -N if first string is less after N-1 chars, +N if first string is
1763 greater after N-1 chars, or 0 if strings match.
1764 The first substring is in BUFFER1 from START1 to END1 and the second
1765 is in BUFFER2 from START2 to END2.
1766 All arguments may be nil. If BUFFER1 or BUFFER2 is nil, the current
1767 buffer is used. If START1 or START2 is nil, the value of `point-min'
1768 in the respective buffers is used. If END1 or END2 is nil, the value
1769 of `point-max' in the respective buffers is used.
1770 The value of `case-fold-search' in the current buffer
1771 determines whether case is significant or ignored. */)
1772 (Lisp_Object buffer1, Lisp_Object start1, Lisp_Object end1, Lisp_Object buffer2, Lisp_Object start2, Lisp_Object end2)
1773 {
1774 register EMACS_INT begp1, endp1, begp2, endp2, temp;
1775 register struct buffer *bp1, *bp2;
1776 register Lisp_Object trt
1777 = (!NILP (BVAR (current_buffer, case_fold_search))
1778 ? BVAR (current_buffer, case_canon_table) : Qnil);
1779 ptrdiff_t chars = 0;
1780 ptrdiff_t i1, i2, i1_byte, i2_byte;
1781
1782 /* Find the first buffer and its substring. */
1783
1784 if (NILP (buffer1))
1785 bp1 = current_buffer;
1786 else
1787 {
1788 Lisp_Object buf1;
1789 buf1 = Fget_buffer (buffer1);
1790 if (NILP (buf1))
1791 nsberror (buffer1);
1792 bp1 = XBUFFER (buf1);
1793 if (!BUFFER_LIVE_P (bp1))
1794 error ("Selecting deleted buffer");
1795 }
1796
1797 begp1 = !NILP (start1) ? fix_position (start1) : BUF_BEGV (bp1);
1798 endp1 = !NILP (end1) ? fix_position (end1) : BUF_ZV (bp1);
1799 if (begp1 > endp1)
1800 temp = begp1, begp1 = endp1, endp1 = temp;
1801
1802 if (!(BUF_BEGV (bp1) <= begp1
1803 && begp1 <= endp1
1804 && endp1 <= BUF_ZV (bp1)))
1805 args_out_of_range (start1, end1);
1806
1807 /* Likewise for second substring. */
1808
1809 if (NILP (buffer2))
1810 bp2 = current_buffer;
1811 else
1812 {
1813 Lisp_Object buf2;
1814 buf2 = Fget_buffer (buffer2);
1815 if (NILP (buf2))
1816 nsberror (buffer2);
1817 bp2 = XBUFFER (buf2);
1818 if (!BUFFER_LIVE_P (bp2))
1819 error ("Selecting deleted buffer");
1820 }
1821
1822 begp2 = !NILP (start2) ? fix_position (start2) : BUF_BEGV (bp2);
1823 endp2 = !NILP (end2) ? fix_position (end2) : BUF_ZV (bp2);
1824 if (begp2 > endp2)
1825 temp = begp2, begp2 = endp2, endp2 = temp;
1826
1827 if (!(BUF_BEGV (bp2) <= begp2
1828 && begp2 <= endp2
1829 && endp2 <= BUF_ZV (bp2)))
1830 args_out_of_range (start2, end2);
1831
1832 i1 = begp1;
1833 i2 = begp2;
1834 i1_byte = buf_charpos_to_bytepos (bp1, i1);
1835 i2_byte = buf_charpos_to_bytepos (bp2, i2);
1836
1837 while (i1 < endp1 && i2 < endp2)
1838 {
1839 /* When we find a mismatch, we must compare the
1840 characters, not just the bytes. */
1841 int c1, c2;
1842
1843 if (! NILP (BVAR (bp1, enable_multibyte_characters)))
1844 {
1845 c1 = BUF_FETCH_MULTIBYTE_CHAR (bp1, i1_byte);
1846 i1_byte += buf_next_char_len (bp1, i1_byte);
1847 i1++;
1848 }
1849 else
1850 {
1851 c1 = make_char_multibyte (BUF_FETCH_BYTE (bp1, i1));
1852 i1++;
1853 }
1854
1855 if (! NILP (BVAR (bp2, enable_multibyte_characters)))
1856 {
1857 c2 = BUF_FETCH_MULTIBYTE_CHAR (bp2, i2_byte);
1858 i2_byte += buf_next_char_len (bp2, i2_byte);
1859 i2++;
1860 }
1861 else
1862 {
1863 c2 = make_char_multibyte (BUF_FETCH_BYTE (bp2, i2));
1864 i2++;
1865 }
1866
1867 if (!NILP (trt))
1868 {
1869 c1 = char_table_translate (trt, c1);
1870 c2 = char_table_translate (trt, c2);
1871 }
1872
1873 if (c1 != c2)
1874 return make_fixnum (c1 < c2 ? -1 - chars : chars + 1);
1875
1876 chars++;
1877 rarely_quit (chars);
1878 }
1879
1880 /* The strings match as far as they go.
1881 If one is shorter, that one is less. */
1882 if (chars < endp1 - begp1)
1883 return make_fixnum (chars + 1);
1884 else if (chars < endp2 - begp2)
1885 return make_fixnum (- chars - 1);
1886
1887 /* Same length too => they are equal. */
1888 return make_fixnum (0);
1889 }
1890
1891
1892 /* Set up necessary definitions for diffseq.h; see comments in
1893 diffseq.h for explanation. */
1894
1895 #undef ELEMENT
1896 #undef EQUAL
1897 #define USE_HEURISTIC
1898
1899 #define XVECREF_YVECREF_EQUAL(ctx, xoff, yoff) \
1900 buffer_chars_equal ((ctx), (xoff), (yoff))
1901
1902 #define OFFSET ptrdiff_t
1903
1904 #define EXTRA_CONTEXT_FIELDS \
1905 /* Buffers to compare. */ \
1906 struct buffer *buffer_a; \
1907 struct buffer *buffer_b; \
1908 /* BEGV of each buffer */ \
1909 ptrdiff_t beg_a; \
1910 ptrdiff_t beg_b; \
1911 /* Whether each buffer is unibyte/plain-ASCII or not. */ \
1912 bool a_unibyte; \
1913 bool b_unibyte; \
1914 /* Bit vectors recording for each character whether it was deleted
1915 or inserted. */ \
1916 unsigned char *deletions; \
1917 unsigned char *insertions; \
1918 struct timespec time_limit; \
1919 sys_jmp_buf jmp; \
1920 unsigned short quitcounter;
1921
1922 #define NOTE_DELETE(ctx, xoff) set_bit ((ctx)->deletions, xoff)
1923 #define NOTE_INSERT(ctx, yoff) set_bit ((ctx)->insertions, yoff)
1924 #define EARLY_ABORT(ctx) compareseq_early_abort (ctx)
1925
1926 struct context;
1927 static void set_bit (unsigned char *, OFFSET);
1928 static bool bit_is_set (const unsigned char *, OFFSET);
1929 static bool buffer_chars_equal (struct context *, OFFSET, OFFSET);
1930 static bool compareseq_early_abort (struct context *);
1931
1932 #include "minmax.h"
1933 #include "diffseq.h"
1934
1935 DEFUN ("replace-buffer-contents", Freplace_buffer_contents,
1936 Sreplace_buffer_contents, 1, 3, "bSource buffer: ",
1937 doc: /* Replace accessible portion of current buffer with that of SOURCE.
1938 SOURCE can be a buffer or a string that names a buffer.
1939 Interactively, prompt for SOURCE.
1940
1941 As far as possible the replacement is non-destructive, i.e. existing
1942 buffer contents, markers, properties, and overlays in the current
1943 buffer stay intact.
1944
1945 Because this function can be very slow if there is a large number of
1946 differences between the two buffers, there are two optional arguments
1947 mitigating this issue.
1948
1949 The MAX-SECS argument, if given, defines a hard limit on the time used
1950 for comparing the buffers. If it takes longer than MAX-SECS, the
1951 function falls back to a plain `delete-region' and
1952 `insert-buffer-substring'. (Note that the checks are not performed
1953 too evenly over time, so in some cases it may run a bit longer than
1954 allowed).
1955
1956 The optional argument MAX-COSTS defines the quality of the difference
1957 computation. If the actual costs exceed this limit, heuristics are
1958 used to provide a faster but suboptimal solution. The default value
1959 is 1000000.
1960
1961 This function returns t if a non-destructive replacement could be
1962 performed. Otherwise, i.e., if MAX-SECS was exceeded, it returns
1963 nil. */)
1964 (Lisp_Object source, Lisp_Object max_secs, Lisp_Object max_costs)
1965 {
1966 struct buffer *a = current_buffer;
1967 Lisp_Object source_buffer = Fget_buffer (source);
1968 if (NILP (source_buffer))
1969 nsberror (source);
1970 struct buffer *b = XBUFFER (source_buffer);
1971 if (! BUFFER_LIVE_P (b))
1972 error ("Selecting deleted buffer");
1973 if (a == b)
1974 error ("Cannot replace a buffer with itself");
1975
1976 ptrdiff_t too_expensive;
1977 if (NILP (max_costs))
1978 too_expensive = 1000000;
1979 else if (FIXNUMP (max_costs))
1980 too_expensive = clip_to_bounds (0, XFIXNUM (max_costs), PTRDIFF_MAX);
1981 else
1982 {
1983 CHECK_INTEGER (max_costs);
1984 too_expensive = NILP (Fnatnump (max_costs)) ? 0 : PTRDIFF_MAX;
1985 }
1986
1987 struct timespec time_limit = make_timespec (0, -1);
1988 if (!NILP (max_secs))
1989 {
1990 struct timespec
1991 tlim = timespec_add (current_timespec (),
1992 lisp_time_argument (max_secs)),
1993 tmax = make_timespec (TYPE_MAXIMUM (time_t), TIMESPEC_HZ - 1);
1994 if (timespec_cmp (tlim, tmax) < 0)
1995 time_limit = tlim;
1996 }
1997
1998 ptrdiff_t min_a = BEGV;
1999 ptrdiff_t min_b = BUF_BEGV (b);
2000 ptrdiff_t size_a = ZV - min_a;
2001 ptrdiff_t size_b = BUF_ZV (b) - min_b;
2002 eassume (size_a >= 0);
2003 eassume (size_b >= 0);
2004 bool a_empty = size_a == 0;
2005 bool b_empty = size_b == 0;
2006
2007 /* Handle trivial cases where at least one accessible portion is
2008 empty. */
2009
2010 if (a_empty && b_empty)
2011 return Qt;
2012
2013 if (a_empty)
2014 {
2015 Finsert_buffer_substring (source, Qnil, Qnil);
2016 return Qt;
2017 }
2018
2019 if (b_empty)
2020 {
2021 del_range_both (BEGV, BEGV_BYTE, ZV, ZV_BYTE, true);
2022 return Qt;
2023 }
2024
2025 ptrdiff_t count = SPECPDL_INDEX ();
2026
2027
2028 ptrdiff_t diags = size_a + size_b + 3;
2029 ptrdiff_t del_bytes = size_a / CHAR_BIT + 1;
2030 ptrdiff_t ins_bytes = size_b / CHAR_BIT + 1;
2031 ptrdiff_t *buffer;
2032 ptrdiff_t bytes_needed;
2033 if (INT_MULTIPLY_WRAPV (diags, 2 * sizeof *buffer, &bytes_needed)
2034 || INT_ADD_WRAPV (del_bytes + ins_bytes, bytes_needed, &bytes_needed))
2035 memory_full (SIZE_MAX);
2036 USE_SAFE_ALLOCA;
2037 buffer = SAFE_ALLOCA (bytes_needed);
2038 unsigned char *deletions_insertions = memset (buffer + 2 * diags, 0,
2039 del_bytes + ins_bytes);
2040
2041 /* FIXME: It is not documented how to initialize the contents of the
2042 context structure. This code cargo-cults from the existing
2043 caller in src/analyze.c of GNU Diffutils, which appears to
2044 work. */
2045 struct context ctx = {
2046 .buffer_a = a,
2047 .buffer_b = b,
2048 .beg_a = min_a,
2049 .beg_b = min_b,
2050 .a_unibyte = BUF_ZV (a) == BUF_ZV_BYTE (a),
2051 .b_unibyte = BUF_ZV (b) == BUF_ZV_BYTE (b),
2052 .deletions = deletions_insertions,
2053 .insertions = deletions_insertions + del_bytes,
2054 .fdiag = buffer + size_b + 1,
2055 .bdiag = buffer + diags + size_b + 1,
2056 .heuristic = true,
2057 .too_expensive = too_expensive,
2058 .time_limit = time_limit,
2059 };
2060
2061 /* compareseq requires indices to be zero-based. We add BEGV back
2062 later. */
2063 bool early_abort;
2064 if (! sys_setjmp (ctx.jmp))
2065 early_abort = compareseq (0, size_a, 0, size_b, false, &ctx);
2066 else
2067 early_abort = true;
2068
2069 if (early_abort)
2070 {
2071 del_range (min_a, ZV);
2072 Finsert_buffer_substring (source, Qnil,Qnil);
2073 SAFE_FREE_UNBIND_TO (count, Qnil);
2074 return Qnil;
2075 }
2076
2077 Fundo_boundary ();
2078 bool modification_hooks_inhibited = false;
2079 record_unwind_protect_excursion ();
2080
2081 /* We are going to make a lot of small modifications, and having the
2082 modification hooks called for each of them will slow us down.
2083 Instead, we announce a single modification for the entire
2084 modified region. But don't do that if the caller inhibited
2085 modification hooks, because then they don't want that. */
2086 if (!inhibit_modification_hooks)
2087 {
2088 prepare_to_modify_buffer (BEGV, ZV, NULL);
2089 specbind (Qinhibit_modification_hooks, Qt);
2090 modification_hooks_inhibited = true;
2091 }
2092
2093 ptrdiff_t i = size_a;
2094 ptrdiff_t j = size_b;
2095 /* Walk backwards through the lists of changes. This was also
2096 cargo-culted from src/analyze.c in GNU Diffutils. Because we
2097 walk backwards, we don’t have to keep the positions in sync. */
2098 while (i >= 0 || j >= 0)
2099 {
2100 rarely_quit (++ctx.quitcounter);
2101
2102 /* Check whether there is a change (insertion or deletion)
2103 before the current position. */
2104 if ((i > 0 && bit_is_set (ctx.deletions, i - 1))
2105 || (j > 0 && bit_is_set (ctx.insertions, j - 1)))
2106 {
2107 ptrdiff_t end_a = min_a + i;
2108 ptrdiff_t end_b = min_b + j;
2109 /* Find the beginning of the current change run. */
2110 while (i > 0 && bit_is_set (ctx.deletions, i - 1))
2111 --i;
2112 while (j > 0 && bit_is_set (ctx.insertions, j - 1))
2113 --j;
2114
2115 ptrdiff_t beg_a = min_a + i;
2116 ptrdiff_t beg_b = min_b + j;
2117 eassert (beg_a <= end_a);
2118 eassert (beg_b <= end_b);
2119 eassert (beg_a < end_a || beg_b < end_b);
2120 if (beg_a < end_a)
2121 del_range (beg_a, end_a);
2122 if (beg_b < end_b)
2123 {
2124 SET_PT (beg_a);
2125 Finsert_buffer_substring (source, make_fixed_natnum (beg_b),
2126 make_fixed_natnum (end_b));
2127 }
2128 }
2129 --i;
2130 --j;
2131 }
2132
2133 SAFE_FREE_UNBIND_TO (count, Qnil);
2134
2135 if (modification_hooks_inhibited)
2136 {
2137 signal_after_change (BEGV, size_a, ZV - BEGV);
2138 update_compositions (BEGV, ZV, CHECK_INSIDE);
2139 /* We've locked the buffer's file above in
2140 prepare_to_modify_buffer; if the buffer is unchanged at this
2141 point, i.e. no insertions or deletions have been made, unlock
2142 the file now. */
2143 if (SAVE_MODIFF == MODIFF
2144 && STRINGP (BVAR (a, file_truename)))
2145 Funlock_file (BVAR (a, file_truename));
2146 }
2147
2148 return Qt;
2149 }
2150
2151 static void
set_bit(unsigned char * a,ptrdiff_t i)2152 set_bit (unsigned char *a, ptrdiff_t i)
2153 {
2154 eassume (0 <= i);
2155 a[i / CHAR_BIT] |= (1 << (i % CHAR_BIT));
2156 }
2157
2158 static bool
bit_is_set(const unsigned char * a,ptrdiff_t i)2159 bit_is_set (const unsigned char *a, ptrdiff_t i)
2160 {
2161 eassume (0 <= i);
2162 return a[i / CHAR_BIT] & (1 << (i % CHAR_BIT));
2163 }
2164
2165 /* Return true if the characters at position POS_A of buffer
2166 CTX->buffer_a and at position POS_B of buffer CTX->buffer_b are
2167 equal. POS_A and POS_B are zero-based. Text properties are
2168 ignored.
2169
2170 Implementation note: this function is called inside the inner-most
2171 loops of compareseq, so it absolutely must be optimized for speed,
2172 every last bit of it. E.g., each additional use of BEGV or such
2173 likes will slow down replace-buffer-contents by dozens of percents,
2174 because builtin_lisp_symbol will be called one more time in the
2175 innermost loop. */
2176
2177 static bool
buffer_chars_equal(struct context * ctx,ptrdiff_t pos_a,ptrdiff_t pos_b)2178 buffer_chars_equal (struct context *ctx,
2179 ptrdiff_t pos_a, ptrdiff_t pos_b)
2180 {
2181 if (!++ctx->quitcounter)
2182 {
2183 maybe_quit ();
2184 if (compareseq_early_abort (ctx))
2185 sys_longjmp (ctx->jmp, 1);
2186 }
2187
2188 pos_a += ctx->beg_a;
2189 pos_b += ctx->beg_b;
2190
2191 ptrdiff_t bpos_a =
2192 ctx->a_unibyte ? pos_a : buf_charpos_to_bytepos (ctx->buffer_a, pos_a);
2193 ptrdiff_t bpos_b =
2194 ctx->b_unibyte ? pos_b : buf_charpos_to_bytepos (ctx->buffer_b, pos_b);
2195
2196 /* We make the below a series of specific test to avoid using
2197 BUF_FETCH_CHAR_AS_MULTIBYTE, which references Lisp symbols, and
2198 is therefore significantly slower (see the note in the commentary
2199 to this function). */
2200 if (ctx->a_unibyte && ctx->b_unibyte)
2201 return BUF_FETCH_BYTE (ctx->buffer_a, bpos_a)
2202 == BUF_FETCH_BYTE (ctx->buffer_b, bpos_b);
2203 if (ctx->a_unibyte && !ctx->b_unibyte)
2204 return UNIBYTE_TO_CHAR (BUF_FETCH_BYTE (ctx->buffer_a, bpos_a))
2205 == BUF_FETCH_MULTIBYTE_CHAR (ctx->buffer_b, bpos_b);
2206 if (!ctx->a_unibyte && ctx->b_unibyte)
2207 return BUF_FETCH_MULTIBYTE_CHAR (ctx->buffer_a, bpos_a)
2208 == UNIBYTE_TO_CHAR (BUF_FETCH_BYTE (ctx->buffer_b, bpos_b));
2209 return BUF_FETCH_MULTIBYTE_CHAR (ctx->buffer_a, bpos_a)
2210 == BUF_FETCH_MULTIBYTE_CHAR (ctx->buffer_b, bpos_b);
2211 }
2212
2213 static bool
compareseq_early_abort(struct context * ctx)2214 compareseq_early_abort (struct context *ctx)
2215 {
2216 if (ctx->time_limit.tv_nsec < 0)
2217 return false;
2218 return timespec_cmp (ctx->time_limit, current_timespec ()) < 0;
2219 }
2220
2221
2222 static void
subst_char_in_region_unwind(Lisp_Object arg)2223 subst_char_in_region_unwind (Lisp_Object arg)
2224 {
2225 bset_undo_list (current_buffer, arg);
2226 }
2227
2228 static void
subst_char_in_region_unwind_1(Lisp_Object arg)2229 subst_char_in_region_unwind_1 (Lisp_Object arg)
2230 {
2231 bset_filename (current_buffer, arg);
2232 }
2233
2234 DEFUN ("subst-char-in-region", Fsubst_char_in_region,
2235 Ssubst_char_in_region, 4, 5, 0,
2236 doc: /* From START to END, replace FROMCHAR with TOCHAR each time it occurs.
2237 If optional arg NOUNDO is non-nil, don't record this change for undo
2238 and don't mark the buffer as really changed.
2239 Both characters must have the same length of multi-byte form. */)
2240 (Lisp_Object start, Lisp_Object end, Lisp_Object fromchar, Lisp_Object tochar, Lisp_Object noundo)
2241 {
2242 register ptrdiff_t pos, pos_byte, stop, i, len, end_byte;
2243 /* Keep track of the first change in the buffer:
2244 if 0 we haven't found it yet.
2245 if < 0 we've found it and we've run the before-change-function.
2246 if > 0 we've actually performed it and the value is its position. */
2247 ptrdiff_t changed = 0;
2248 unsigned char fromstr[MAX_MULTIBYTE_LENGTH], tostr[MAX_MULTIBYTE_LENGTH];
2249 unsigned char *p;
2250 ptrdiff_t count = SPECPDL_INDEX ();
2251 #define COMBINING_NO 0
2252 #define COMBINING_BEFORE 1
2253 #define COMBINING_AFTER 2
2254 #define COMBINING_BOTH (COMBINING_BEFORE | COMBINING_AFTER)
2255 int maybe_byte_combining = COMBINING_NO;
2256 ptrdiff_t last_changed = 0;
2257 bool multibyte_p
2258 = !NILP (BVAR (current_buffer, enable_multibyte_characters));
2259 int fromc, toc;
2260
2261 restart:
2262
2263 validate_region (&start, &end);
2264 CHECK_CHARACTER (fromchar);
2265 CHECK_CHARACTER (tochar);
2266 fromc = XFIXNAT (fromchar);
2267 toc = XFIXNAT (tochar);
2268
2269 if (multibyte_p)
2270 {
2271 len = CHAR_STRING (fromc, fromstr);
2272 if (CHAR_STRING (toc, tostr) != len)
2273 error ("Characters in `subst-char-in-region' have different byte-lengths");
2274 if (!ASCII_CHAR_P (*tostr))
2275 {
2276 /* If *TOSTR is in the range 0x80..0x9F and TOCHAR is not a
2277 complete multibyte character, it may be combined with the
2278 after bytes. If it is in the range 0xA0..0xFF, it may be
2279 combined with the before and after bytes. */
2280 if (!CHAR_HEAD_P (*tostr))
2281 maybe_byte_combining = COMBINING_BOTH;
2282 else if (BYTES_BY_CHAR_HEAD (*tostr) > len)
2283 maybe_byte_combining = COMBINING_AFTER;
2284 }
2285 }
2286 else
2287 {
2288 len = 1;
2289 fromstr[0] = fromc;
2290 tostr[0] = toc;
2291 }
2292
2293 pos = XFIXNUM (start);
2294 pos_byte = CHAR_TO_BYTE (pos);
2295 stop = CHAR_TO_BYTE (XFIXNUM (end));
2296 end_byte = stop;
2297
2298 /* If we don't want undo, turn off putting stuff on the list.
2299 That's faster than getting rid of things,
2300 and it prevents even the entry for a first change.
2301 Also inhibit locking the file. */
2302 if (!changed && !NILP (noundo))
2303 {
2304 record_unwind_protect (subst_char_in_region_unwind,
2305 BVAR (current_buffer, undo_list));
2306 bset_undo_list (current_buffer, Qt);
2307 /* Don't do file-locking. */
2308 record_unwind_protect (subst_char_in_region_unwind_1,
2309 BVAR (current_buffer, filename));
2310 bset_filename (current_buffer, Qnil);
2311 }
2312
2313 if (pos_byte < GPT_BYTE)
2314 stop = min (stop, GPT_BYTE);
2315 while (1)
2316 {
2317 ptrdiff_t pos_byte_next = pos_byte;
2318
2319 if (pos_byte >= stop)
2320 {
2321 if (pos_byte >= end_byte) break;
2322 stop = end_byte;
2323 }
2324 p = BYTE_POS_ADDR (pos_byte);
2325 if (multibyte_p)
2326 pos_byte_next += next_char_len (pos_byte_next);
2327 else
2328 ++pos_byte_next;
2329 if (pos_byte_next - pos_byte == len
2330 && p[0] == fromstr[0]
2331 && (len == 1
2332 || (p[1] == fromstr[1]
2333 && (len == 2 || (p[2] == fromstr[2]
2334 && (len == 3 || p[3] == fromstr[3]))))))
2335 {
2336 if (changed < 0)
2337 /* We've already seen this and run the before-change-function;
2338 this time we only need to record the actual position. */
2339 changed = pos;
2340 else if (!changed)
2341 {
2342 changed = -1;
2343 modify_text (pos, XFIXNUM (end));
2344
2345 if (! NILP (noundo))
2346 {
2347 modiff_count m = MODIFF;
2348 if (SAVE_MODIFF == m - 1)
2349 SAVE_MODIFF = m;
2350 if (BUF_AUTOSAVE_MODIFF (current_buffer) == m - 1)
2351 BUF_AUTOSAVE_MODIFF (current_buffer) = m;
2352 }
2353
2354 /* The before-change-function may have moved the gap
2355 or even modified the buffer so we should start over. */
2356 goto restart;
2357 }
2358
2359 /* Take care of the case where the new character
2360 combines with neighboring bytes. */
2361 if (maybe_byte_combining
2362 && (maybe_byte_combining == COMBINING_AFTER
2363 ? (pos_byte_next < Z_BYTE
2364 && ! CHAR_HEAD_P (FETCH_BYTE (pos_byte_next)))
2365 : ((pos_byte_next < Z_BYTE
2366 && ! CHAR_HEAD_P (FETCH_BYTE (pos_byte_next)))
2367 || (pos_byte > BEG_BYTE
2368 && ! ASCII_CHAR_P (FETCH_BYTE (pos_byte - 1))))))
2369 {
2370 Lisp_Object tem, string;
2371
2372 tem = BVAR (current_buffer, undo_list);
2373
2374 /* Make a multibyte string containing this single character. */
2375 string = make_multibyte_string ((char *) tostr, 1, len);
2376 /* replace_range is less efficient, because it moves the gap,
2377 but it handles combining correctly. */
2378 replace_range (pos, pos + 1, string,
2379 false, false, true, false, false);
2380 pos_byte_next = CHAR_TO_BYTE (pos);
2381 if (pos_byte_next > pos_byte)
2382 /* Before combining happened. We should not increment
2383 POS. So, to cancel the later increment of POS,
2384 decrease it now. */
2385 pos--;
2386 else
2387 pos_byte_next += next_char_len (pos_byte_next);
2388
2389 if (! NILP (noundo))
2390 bset_undo_list (current_buffer, tem);
2391 }
2392 else
2393 {
2394 if (NILP (noundo))
2395 record_change (pos, 1);
2396 for (i = 0; i < len; i++) *p++ = tostr[i];
2397 }
2398 last_changed = pos + 1;
2399 }
2400 pos_byte = pos_byte_next;
2401 pos++;
2402 }
2403
2404 if (changed > 0)
2405 {
2406 signal_after_change (changed,
2407 last_changed - changed, last_changed - changed);
2408 update_compositions (changed, last_changed, CHECK_ALL);
2409 }
2410
2411 return unbind_to (count, Qnil);
2412 }
2413
2414
2415 static Lisp_Object check_translation (ptrdiff_t, ptrdiff_t, ptrdiff_t,
2416 Lisp_Object);
2417
2418 /* Helper function for Ftranslate_region_internal.
2419
2420 Check if a character sequence at POS (POS_BYTE) matches an element
2421 of VAL. VAL is a list (([FROM-CHAR ...] . TO) ...). If a matching
2422 element is found, return it. Otherwise return Qnil. */
2423
2424 static Lisp_Object
check_translation(ptrdiff_t pos,ptrdiff_t pos_byte,ptrdiff_t end,Lisp_Object val)2425 check_translation (ptrdiff_t pos, ptrdiff_t pos_byte, ptrdiff_t end,
2426 Lisp_Object val)
2427 {
2428 int initial_buf[16];
2429 int *buf = initial_buf;
2430 ptrdiff_t buf_size = ARRAYELTS (initial_buf);
2431 int *bufalloc = 0;
2432 ptrdiff_t buf_used = 0;
2433 Lisp_Object result = Qnil;
2434
2435 for (; CONSP (val); val = XCDR (val))
2436 {
2437 Lisp_Object elt;
2438 ptrdiff_t len, i;
2439
2440 elt = XCAR (val);
2441 if (! CONSP (elt))
2442 continue;
2443 elt = XCAR (elt);
2444 if (! VECTORP (elt))
2445 continue;
2446 len = ASIZE (elt);
2447 if (len <= end - pos)
2448 {
2449 for (i = 0; i < len; i++)
2450 {
2451 if (buf_used <= i)
2452 {
2453 unsigned char *p = BYTE_POS_ADDR (pos_byte);
2454 int len1;
2455
2456 if (buf_used == buf_size)
2457 {
2458 bufalloc = xpalloc (bufalloc, &buf_size, 1, -1,
2459 sizeof *bufalloc);
2460 if (buf == initial_buf)
2461 memcpy (bufalloc, buf, sizeof initial_buf);
2462 buf = bufalloc;
2463 }
2464 buf[buf_used++] = string_char_and_length (p, &len1);
2465 pos_byte += len1;
2466 }
2467 if (XFIXNUM (AREF (elt, i)) != buf[i])
2468 break;
2469 }
2470 if (i == len)
2471 {
2472 result = XCAR (val);
2473 break;
2474 }
2475 }
2476 }
2477
2478 xfree (bufalloc);
2479 return result;
2480 }
2481
2482
2483 DEFUN ("translate-region-internal", Ftranslate_region_internal,
2484 Stranslate_region_internal, 3, 3, 0,
2485 doc: /* Internal use only.
2486 From START to END, translate characters according to TABLE.
2487 TABLE is a string or a char-table; the Nth character in it is the
2488 mapping for the character with code N.
2489 It returns the number of characters changed. */)
2490 (Lisp_Object start, Lisp_Object end, Lisp_Object table)
2491 {
2492 int translatable_chars = MAX_CHAR + 1;
2493 bool multibyte = !NILP (BVAR (current_buffer, enable_multibyte_characters));
2494 bool string_multibyte UNINIT;
2495
2496 validate_region (&start, &end);
2497 if (STRINGP (table))
2498 {
2499 if (! multibyte)
2500 table = string_make_unibyte (table);
2501 translatable_chars = min (translatable_chars, SBYTES (table));
2502 string_multibyte = STRING_MULTIBYTE (table);
2503 }
2504 else if (! (CHAR_TABLE_P (table)
2505 && EQ (XCHAR_TABLE (table)->purpose, Qtranslation_table)))
2506 error ("Not a translation table");
2507
2508 ptrdiff_t pos = XFIXNUM (start);
2509 ptrdiff_t pos_byte = CHAR_TO_BYTE (pos);
2510 ptrdiff_t end_pos = XFIXNUM (end);
2511 modify_text (pos, end_pos);
2512
2513 ptrdiff_t characters_changed = 0;
2514
2515 while (pos < end_pos)
2516 {
2517 unsigned char *p = BYTE_POS_ADDR (pos_byte);
2518 unsigned char *str UNINIT;
2519 unsigned char buf[MAX_MULTIBYTE_LENGTH];
2520 int len, oc;
2521
2522 if (multibyte)
2523 oc = string_char_and_length (p, &len);
2524 else
2525 oc = *p, len = 1;
2526 if (oc < translatable_chars)
2527 {
2528 int nc; /* New character. */
2529 int str_len UNINIT;
2530 Lisp_Object val;
2531
2532 if (STRINGP (table))
2533 {
2534 /* Reload as signal_after_change in last iteration may GC. */
2535 unsigned char *tt = SDATA (table);
2536
2537 if (string_multibyte)
2538 {
2539 str = tt + string_char_to_byte (table, oc);
2540 nc = string_char_and_length (str, &str_len);
2541 }
2542 else
2543 {
2544 nc = tt[oc];
2545 if (! ASCII_CHAR_P (nc) && multibyte)
2546 {
2547 str_len = BYTE8_STRING (nc, buf);
2548 str = buf;
2549 }
2550 else
2551 {
2552 str_len = 1;
2553 str = tt + oc;
2554 }
2555 }
2556 }
2557 else
2558 {
2559 nc = oc;
2560 val = CHAR_TABLE_REF (table, oc);
2561 if (CHARACTERP (val))
2562 {
2563 nc = XFIXNAT (val);
2564 str_len = CHAR_STRING (nc, buf);
2565 str = buf;
2566 }
2567 else if (VECTORP (val) || (CONSP (val)))
2568 {
2569 /* VAL is [TO_CHAR ...] or (([FROM-CHAR ...] . TO) ...)
2570 where TO is TO-CHAR or [TO-CHAR ...]. */
2571 nc = -1;
2572 }
2573 }
2574
2575 if (nc != oc && nc >= 0)
2576 {
2577 /* Simple one char to one char translation. */
2578 if (len != str_len)
2579 {
2580 Lisp_Object string;
2581
2582 /* This is less efficient, because it moves the gap,
2583 but it should handle multibyte characters correctly. */
2584 string = make_multibyte_string ((char *) str, 1, str_len);
2585 replace_range (pos, pos + 1, string,
2586 true, false, true, false, false);
2587 len = str_len;
2588 }
2589 else
2590 {
2591 record_change (pos, 1);
2592 while (str_len-- > 0)
2593 *p++ = *str++;
2594 signal_after_change (pos, 1, 1);
2595 update_compositions (pos, pos + 1, CHECK_BORDER);
2596 }
2597 characters_changed++;
2598 }
2599 else if (nc < 0)
2600 {
2601 if (CONSP (val))
2602 {
2603 val = check_translation (pos, pos_byte, end_pos, val);
2604 if (NILP (val))
2605 {
2606 pos_byte += len;
2607 pos++;
2608 continue;
2609 }
2610 /* VAL is ([FROM-CHAR ...] . TO). */
2611 len = ASIZE (XCAR (val));
2612 val = XCDR (val);
2613 }
2614 else
2615 len = 1;
2616
2617 Lisp_Object string
2618 = (VECTORP (val)
2619 ? Fconcat (1, &val)
2620 : Fmake_string (make_fixnum (1), val, Qnil));
2621 replace_range (pos, pos + len, string, true, false, true, false,
2622 false);
2623 pos_byte += SBYTES (string);
2624 pos += SCHARS (string);
2625 characters_changed += SCHARS (string);
2626 end_pos += SCHARS (string) - len;
2627 continue;
2628 }
2629 }
2630 pos_byte += len;
2631 pos++;
2632 }
2633
2634 return make_fixnum (characters_changed);
2635 }
2636
2637 DEFUN ("delete-region", Fdelete_region, Sdelete_region, 2, 2, "r",
2638 doc: /* Delete the text between START and END.
2639 If called interactively, delete the region between point and mark.
2640 This command deletes buffer text without modifying the kill ring. */)
2641 (Lisp_Object start, Lisp_Object end)
2642 {
2643 validate_region (&start, &end);
2644 del_range (XFIXNUM (start), XFIXNUM (end));
2645 return Qnil;
2646 }
2647
2648 DEFUN ("delete-and-extract-region", Fdelete_and_extract_region,
2649 Sdelete_and_extract_region, 2, 2, 0,
2650 doc: /* Delete the text between START and END and return it. */)
2651 (Lisp_Object start, Lisp_Object end)
2652 {
2653 validate_region (&start, &end);
2654 if (XFIXNUM (start) == XFIXNUM (end))
2655 return empty_unibyte_string;
2656 return del_range_1 (XFIXNUM (start), XFIXNUM (end), 1, 1);
2657 }
2658
2659 DEFUN ("widen", Fwiden, Swiden, 0, 0, "",
2660 doc: /* Remove restrictions (narrowing) from current buffer.
2661 This allows the buffer's full text to be seen and edited. */)
2662 (void)
2663 {
2664 if (BEG != BEGV || Z != ZV)
2665 current_buffer->clip_changed = 1;
2666 BEGV = BEG;
2667 BEGV_BYTE = BEG_BYTE;
2668 SET_BUF_ZV_BOTH (current_buffer, Z, Z_BYTE);
2669 /* Changing the buffer bounds invalidates any recorded current column. */
2670 invalidate_current_column ();
2671 return Qnil;
2672 }
2673
2674 DEFUN ("narrow-to-region", Fnarrow_to_region, Snarrow_to_region, 2, 2, "r",
2675 doc: /* Restrict editing in this buffer to the current region.
2676 The rest of the text becomes temporarily invisible and untouchable
2677 but is not deleted; if you save the buffer in a file, the invisible
2678 text is included in the file. \\[widen] makes all visible again.
2679 See also `save-restriction'.
2680
2681 When calling from Lisp, pass two arguments START and END:
2682 positions (integers or markers) bounding the text that should
2683 remain visible. */)
2684 (Lisp_Object start, Lisp_Object end)
2685 {
2686 EMACS_INT s = fix_position (start), e = fix_position (end);
2687
2688 if (e < s)
2689 {
2690 EMACS_INT tem = s; s = e; e = tem;
2691 }
2692
2693 if (!(BEG <= s && s <= e && e <= Z))
2694 args_out_of_range (start, end);
2695
2696 if (BEGV != s || ZV != e)
2697 current_buffer->clip_changed = 1;
2698
2699 SET_BUF_BEGV (current_buffer, s);
2700 SET_BUF_ZV (current_buffer, e);
2701 if (PT < s)
2702 SET_PT (s);
2703 if (e < PT)
2704 SET_PT (e);
2705 /* Changing the buffer bounds invalidates any recorded current column. */
2706 invalidate_current_column ();
2707 return Qnil;
2708 }
2709
2710 Lisp_Object
save_restriction_save(void)2711 save_restriction_save (void)
2712 {
2713 if (BEGV == BEG && ZV == Z)
2714 /* The common case that the buffer isn't narrowed.
2715 We return just the buffer object, which save_restriction_restore
2716 recognizes as meaning `no restriction'. */
2717 return Fcurrent_buffer ();
2718 else
2719 /* We have to save a restriction, so return a pair of markers, one
2720 for the beginning and one for the end. */
2721 {
2722 Lisp_Object beg, end;
2723
2724 beg = build_marker (current_buffer, BEGV, BEGV_BYTE);
2725 end = build_marker (current_buffer, ZV, ZV_BYTE);
2726
2727 /* END must move forward if text is inserted at its exact location. */
2728 XMARKER (end)->insertion_type = 1;
2729
2730 return Fcons (beg, end);
2731 }
2732 }
2733
2734 void
save_restriction_restore(Lisp_Object data)2735 save_restriction_restore (Lisp_Object data)
2736 {
2737 struct buffer *cur = NULL;
2738 struct buffer *buf = (CONSP (data)
2739 ? XMARKER (XCAR (data))->buffer
2740 : XBUFFER (data));
2741
2742 if (buf && buf != current_buffer && !NILP (BVAR (buf, pt_marker)))
2743 { /* If `buf' uses markers to keep track of PT, BEGV, and ZV (as
2744 is the case if it is or has an indirect buffer), then make
2745 sure it is current before we update BEGV, so
2746 set_buffer_internal takes care of managing those markers. */
2747 cur = current_buffer;
2748 set_buffer_internal (buf);
2749 }
2750
2751 if (CONSP (data))
2752 /* A pair of marks bounding a saved restriction. */
2753 {
2754 struct Lisp_Marker *beg = XMARKER (XCAR (data));
2755 struct Lisp_Marker *end = XMARKER (XCDR (data));
2756 eassert (buf == end->buffer);
2757
2758 if (buf /* Verify marker still points to a buffer. */
2759 && (beg->charpos != BUF_BEGV (buf) || end->charpos != BUF_ZV (buf)))
2760 /* The restriction has changed from the saved one, so restore
2761 the saved restriction. */
2762 {
2763 ptrdiff_t pt = BUF_PT (buf);
2764
2765 SET_BUF_BEGV_BOTH (buf, beg->charpos, beg->bytepos);
2766 SET_BUF_ZV_BOTH (buf, end->charpos, end->bytepos);
2767
2768 if (pt < beg->charpos || pt > end->charpos)
2769 /* The point is outside the new visible range, move it inside. */
2770 SET_BUF_PT_BOTH (buf,
2771 clip_to_bounds (beg->charpos, pt, end->charpos),
2772 clip_to_bounds (beg->bytepos, BUF_PT_BYTE (buf),
2773 end->bytepos));
2774
2775 buf->clip_changed = 1; /* Remember that the narrowing changed. */
2776 }
2777 /* Detach the markers, and free the cons instead of waiting for GC. */
2778 detach_marker (XCAR (data));
2779 detach_marker (XCDR (data));
2780 free_cons (XCONS (data));
2781 }
2782 else
2783 /* A buffer, which means that there was no old restriction. */
2784 {
2785 if (buf /* Verify marker still points to a buffer. */
2786 && (BUF_BEGV (buf) != BUF_BEG (buf) || BUF_ZV (buf) != BUF_Z (buf)))
2787 /* The buffer has been narrowed, get rid of the narrowing. */
2788 {
2789 SET_BUF_BEGV_BOTH (buf, BUF_BEG (buf), BUF_BEG_BYTE (buf));
2790 SET_BUF_ZV_BOTH (buf, BUF_Z (buf), BUF_Z_BYTE (buf));
2791
2792 buf->clip_changed = 1; /* Remember that the narrowing changed. */
2793 }
2794 }
2795
2796 /* Changing the buffer bounds invalidates any recorded current column. */
2797 invalidate_current_column ();
2798
2799 if (cur)
2800 set_buffer_internal (cur);
2801 }
2802
2803 DEFUN ("save-restriction", Fsave_restriction, Ssave_restriction, 0, UNEVALLED, 0,
2804 doc: /* Execute BODY, saving and restoring current buffer's restrictions.
2805 The buffer's restrictions make parts of the beginning and end invisible.
2806 \(They are set up with `narrow-to-region' and eliminated with `widen'.)
2807 This special form, `save-restriction', saves the current buffer's restrictions
2808 when it is entered, and restores them when it is exited.
2809 So any `narrow-to-region' within BODY lasts only until the end of the form.
2810 The old restrictions settings are restored
2811 even in case of abnormal exit (throw or error).
2812
2813 The value returned is the value of the last form in BODY.
2814
2815 Note: if you are using both `save-excursion' and `save-restriction',
2816 use `save-excursion' outermost:
2817 (save-excursion (save-restriction ...))
2818
2819 usage: (save-restriction &rest BODY) */)
2820 (Lisp_Object body)
2821 {
2822 register Lisp_Object val;
2823 ptrdiff_t count = SPECPDL_INDEX ();
2824
2825 record_unwind_protect (save_restriction_restore, save_restriction_save ());
2826 val = Fprogn (body);
2827 return unbind_to (count, val);
2828 }
2829
2830 /* i18n (internationalization). */
2831
2832 DEFUN ("ngettext", Fngettext, Sngettext, 3, 3, 0,
2833 doc: /* Return the translation of MSGID (plural MSGID-PLURAL) depending on N.
2834 MSGID is the singular form of the string to be converted;
2835 use it as the key for the search in the translation catalog.
2836 MSGID-PLURAL is the plural form. Use N to select the proper translation.
2837 If no message catalog is found, MSGID is returned if N is equal to 1,
2838 otherwise MSGID-PLURAL. */)
2839 (Lisp_Object msgid, Lisp_Object msgid_plural, Lisp_Object n)
2840 {
2841 CHECK_STRING (msgid);
2842 CHECK_STRING (msgid_plural);
2843 CHECK_INTEGER (n);
2844
2845 /* Placeholder implementation until we get our act together. */
2846 return EQ (n, make_fixnum (1)) ? msgid : msgid_plural;
2847 }
2848
2849 DEFUN ("message", Fmessage, Smessage, 1, MANY, 0,
2850 doc: /* Display a message at the bottom of the screen.
2851 The message also goes into the `*Messages*' buffer, if `message-log-max'
2852 is non-nil. (In keyboard macros, that's all it does.)
2853 Return the message.
2854
2855 In batch mode, the message is printed to the standard error stream,
2856 followed by a newline.
2857
2858 The first argument is a format control string, and the rest are data
2859 to be formatted under control of the string. Percent sign (%), grave
2860 accent (\\=`) and apostrophe (\\=') are special in the format; see
2861 `format-message' for details. To display STRING without special
2862 treatment, use (message "%s" STRING).
2863
2864 If the first argument is nil or the empty string, the function clears
2865 any existing message; this lets the minibuffer contents show. See
2866 also `current-message'.
2867
2868 usage: (message FORMAT-STRING &rest ARGS) */)
2869 (ptrdiff_t nargs, Lisp_Object *args)
2870 {
2871 if (NILP (args[0])
2872 || (STRINGP (args[0])
2873 && SBYTES (args[0]) == 0))
2874 {
2875 message1 (0);
2876 return args[0];
2877 }
2878 else
2879 {
2880 Lisp_Object val = Fformat_message (nargs, args);
2881 message3 (val);
2882 return val;
2883 }
2884 }
2885
2886 DEFUN ("message-box", Fmessage_box, Smessage_box, 1, MANY, 0,
2887 doc: /* Display a message, in a dialog box if possible.
2888 If a dialog box is not available, use the echo area.
2889 The first argument is a format control string, and the rest are data
2890 to be formatted under control of the string. See `format-message' for
2891 details.
2892
2893 If the first argument is nil or the empty string, clear any existing
2894 message; let the minibuffer contents show.
2895
2896 usage: (message-box FORMAT-STRING &rest ARGS) */)
2897 (ptrdiff_t nargs, Lisp_Object *args)
2898 {
2899 if (NILP (args[0]))
2900 {
2901 message1 (0);
2902 return Qnil;
2903 }
2904 else
2905 {
2906 Lisp_Object val = Fformat_message (nargs, args);
2907 Lisp_Object pane, menu;
2908
2909 pane = list1 (Fcons (build_string ("OK"), Qt));
2910 menu = Fcons (val, pane);
2911 Fx_popup_dialog (Qt, menu, Qt);
2912 return val;
2913 }
2914 }
2915
2916 DEFUN ("message-or-box", Fmessage_or_box, Smessage_or_box, 1, MANY, 0,
2917 doc: /* Display a message in a dialog box or in the echo area.
2918 If this command was invoked with the mouse, use a dialog box if
2919 `use-dialog-box' is non-nil.
2920 Otherwise, use the echo area.
2921 The first argument is a format control string, and the rest are data
2922 to be formatted under control of the string. See `format-message' for
2923 details.
2924
2925 If the first argument is nil or the empty string, clear any existing
2926 message; let the minibuffer contents show.
2927
2928 usage: (message-or-box FORMAT-STRING &rest ARGS) */)
2929 (ptrdiff_t nargs, Lisp_Object *args)
2930 {
2931 if ((NILP (last_nonmenu_event) || CONSP (last_nonmenu_event))
2932 && use_dialog_box)
2933 return Fmessage_box (nargs, args);
2934 return Fmessage (nargs, args);
2935 }
2936
2937 DEFUN ("current-message", Fcurrent_message, Scurrent_message, 0, 0, 0,
2938 doc: /* Return the string currently displayed in the echo area, or nil if none. */)
2939 (void)
2940 {
2941 return current_message ();
2942 }
2943
2944
2945 DEFUN ("propertize", Fpropertize, Spropertize, 1, MANY, 0,
2946 doc: /* Return a copy of STRING with text properties added.
2947 First argument is the string to copy.
2948 Remaining arguments form a sequence of PROPERTY VALUE pairs for text
2949 properties to add to the result.
2950
2951 See Info node `(elisp) Text Properties' for more information.
2952 usage: (propertize STRING &rest PROPERTIES) */)
2953 (ptrdiff_t nargs, Lisp_Object *args)
2954 {
2955 Lisp_Object properties, string;
2956 ptrdiff_t i;
2957
2958 /* Number of args must be odd. */
2959 if ((nargs & 1) == 0)
2960 xsignal2 (Qwrong_number_of_arguments, Qpropertize, make_fixnum (nargs));
2961
2962 properties = string = Qnil;
2963
2964 /* First argument must be a string. */
2965 CHECK_STRING (args[0]);
2966 string = Fcopy_sequence (args[0]);
2967
2968 for (i = 1; i < nargs; i += 2)
2969 properties = Fcons (args[i], Fcons (args[i + 1], properties));
2970
2971 Fadd_text_properties (make_fixnum (0),
2972 make_fixnum (SCHARS (string)),
2973 properties, string);
2974 return string;
2975 }
2976
2977 /* Convert the prefix of STR from ASCII decimal digits to a number.
2978 Set *STR_END to the address of the first non-digit. Return the
2979 number, or PTRDIFF_MAX on overflow. Return 0 if there is no number.
2980 This is like strtol for ptrdiff_t and base 10 and C locale,
2981 except without negative numbers or errno. */
2982
2983 static ptrdiff_t
str2num(char * str,char ** str_end)2984 str2num (char *str, char **str_end)
2985 {
2986 ptrdiff_t n = 0;
2987 for (; c_isdigit (*str); str++)
2988 if (INT_MULTIPLY_WRAPV (n, 10, &n) || INT_ADD_WRAPV (n, *str - '0', &n))
2989 n = PTRDIFF_MAX;
2990 *str_end = str;
2991 return n;
2992 }
2993
2994 DEFUN ("format", Fformat, Sformat, 1, MANY, 0,
2995 doc: /* Format a string out of a format-string and arguments.
2996 The first argument is a format control string.
2997 The other arguments are substituted into it to make the result, a string.
2998
2999 The format control string may contain %-sequences meaning to substitute
3000 the next available argument, or the argument explicitly specified:
3001
3002 %s means print a string argument. Actually, prints any object, with `princ'.
3003 %d means print as signed number in decimal.
3004 %o means print a number in octal.
3005 %x means print a number in hex.
3006 %X is like %x, but uses upper case.
3007 %e means print a number in exponential notation.
3008 %f means print a number in decimal-point notation.
3009 %g means print a number in exponential notation if the exponent would be
3010 less than -4 or greater than or equal to the precision (default: 6);
3011 otherwise it prints in decimal-point notation.
3012 %c means print a number as a single character.
3013 %S means print any object as an s-expression (using `prin1').
3014
3015 The argument used for %d, %o, %x, %e, %f, %g or %c must be a number.
3016 %o, %x, and %X treat arguments as unsigned if `binary-as-unsigned' is t
3017 (this is experimental; email 32252@debbugs.gnu.org if you need it).
3018 Use %% to put a single % into the output.
3019
3020 A %-sequence other than %% may contain optional field number, flag,
3021 width, and precision specifiers, as follows:
3022
3023 %<field><flags><width><precision>character
3024
3025 where field is [0-9]+ followed by a literal dollar "$", flags is
3026 [+ #0-]+, width is [0-9]+, and precision is a literal period "."
3027 followed by [0-9]+.
3028
3029 If a %-sequence is numbered with a field with positive value N, the
3030 Nth argument is substituted instead of the next one. A format can
3031 contain either numbered or unnumbered %-sequences but not both, except
3032 that %% can be mixed with numbered %-sequences.
3033
3034 The + flag character inserts a + before any nonnegative number, while a
3035 space inserts a space before any nonnegative number; these flags
3036 affect only numeric %-sequences, and the + flag takes precedence.
3037 The - and 0 flags affect the width specifier, as described below.
3038
3039 The # flag means to use an alternate display form for %o, %x, %X, %e,
3040 %f, and %g sequences: for %o, it ensures that the result begins with
3041 \"0\"; for %x and %X, it prefixes nonzero results with \"0x\" or \"0X\";
3042 for %e and %f, it causes a decimal point to be included even if the
3043 precision is zero; for %g, it causes a decimal point to be
3044 included even if the precision is zero, and also forces trailing
3045 zeros after the decimal point to be left in place.
3046
3047 The width specifier supplies a lower limit for the length of the
3048 printed representation. The padding, if any, normally goes on the
3049 left, but it goes on the right if the - flag is present. The padding
3050 character is normally a space, but it is 0 if the 0 flag is present.
3051 The 0 flag is ignored if the - flag is present, or the format sequence
3052 is something other than %d, %o, %x, %e, %f, and %g.
3053
3054 For %e and %f sequences, the number after the "." in the precision
3055 specifier says how many decimal places to show; if zero, the decimal
3056 point itself is omitted. For %g, the precision specifies how many
3057 significant digits to print; zero or omitted are treated as 1.
3058 For %s and %S, the precision specifier truncates the string to the
3059 given width.
3060
3061 Text properties, if any, are copied from the format-string to the
3062 produced text.
3063
3064 usage: (format STRING &rest OBJECTS) */)
3065 (ptrdiff_t nargs, Lisp_Object *args)
3066 {
3067 return styled_format (nargs, args, false);
3068 }
3069
3070 DEFUN ("format-message", Fformat_message, Sformat_message, 1, MANY, 0,
3071 doc: /* Format a string out of a format-string and arguments.
3072 The first argument is a format control string.
3073 The other arguments are substituted into it to make the result, a string.
3074
3075 This acts like `format', except it also replaces each grave accent (\\=`)
3076 by a left quote, and each apostrophe (\\=') by a right quote. The left
3077 and right quote replacement characters are specified by
3078 `text-quoting-style'.
3079
3080 usage: (format-message STRING &rest OBJECTS) */)
3081 (ptrdiff_t nargs, Lisp_Object *args)
3082 {
3083 return styled_format (nargs, args, true);
3084 }
3085
3086 /* Implement ‘format-message’ if MESSAGE is true, ‘format’ otherwise. */
3087
3088 static Lisp_Object
styled_format(ptrdiff_t nargs,Lisp_Object * args,bool message)3089 styled_format (ptrdiff_t nargs, Lisp_Object *args, bool message)
3090 {
3091 enum
3092 {
3093 /* Maximum precision for a %f conversion such that the trailing
3094 output digit might be nonzero. Any precision larger than this
3095 will not yield useful information. */
3096 USEFUL_PRECISION_MAX = ((1 - LDBL_MIN_EXP)
3097 * (FLT_RADIX == 2 || FLT_RADIX == 10 ? 1
3098 : FLT_RADIX == 16 ? 4
3099 : -1)),
3100
3101 /* Maximum number of bytes (including terminating null) generated
3102 by any format, if precision is no more than USEFUL_PRECISION_MAX.
3103 On all practical hosts, %Lf is the worst case. */
3104 SPRINTF_BUFSIZE = (sizeof "-." + (LDBL_MAX_10_EXP + 1)
3105 + USEFUL_PRECISION_MAX)
3106 };
3107 verify (USEFUL_PRECISION_MAX > 0);
3108
3109 ptrdiff_t n; /* The number of the next arg to substitute. */
3110 char initial_buffer[1000 + SPRINTF_BUFSIZE];
3111 char *buf = initial_buffer;
3112 ptrdiff_t bufsize = sizeof initial_buffer;
3113 ptrdiff_t max_bufsize = STRING_BYTES_BOUND + 1;
3114 char *p;
3115 ptrdiff_t buf_save_value_index UNINIT;
3116 char *format, *end;
3117 ptrdiff_t nchars;
3118 /* When we make a multibyte string, we must pay attention to the
3119 byte combining problem, i.e., a byte may be combined with a
3120 multibyte character of the previous string. This flag tells if we
3121 must consider such a situation or not. */
3122 bool maybe_combine_byte;
3123 Lisp_Object val;
3124 bool arg_intervals = false;
3125 USE_SAFE_ALLOCA;
3126 sa_avail -= sizeof initial_buffer;
3127
3128 /* Information recorded for each format spec. */
3129 struct info
3130 {
3131 /* The corresponding argument, converted to string if conversion
3132 was needed. */
3133 Lisp_Object argument;
3134
3135 /* The start and end bytepos in the output string. */
3136 ptrdiff_t start, end;
3137
3138 /* The start bytepos of the spec in the format string. */
3139 ptrdiff_t fbeg;
3140
3141 /* Whether the argument is a string with intervals. */
3142 bool_bf intervals : 1;
3143 } *info;
3144
3145 CHECK_STRING (args[0]);
3146 char *format_start = SSDATA (args[0]);
3147 bool multibyte_format = STRING_MULTIBYTE (args[0]);
3148 ptrdiff_t formatlen = SBYTES (args[0]);
3149 bool fmt_props = !!string_intervals (args[0]);
3150
3151 /* Upper bound on number of format specs. Each uses at least 2 chars. */
3152 ptrdiff_t nspec_bound = SCHARS (args[0]) >> 1;
3153
3154 /* Allocate the info and discarded tables. */
3155 ptrdiff_t info_size, alloca_size;
3156 if (INT_MULTIPLY_WRAPV (nspec_bound, sizeof *info, &info_size)
3157 || INT_ADD_WRAPV (formatlen, info_size, &alloca_size)
3158 || SIZE_MAX < alloca_size)
3159 memory_full (SIZE_MAX);
3160 info = SAFE_ALLOCA (alloca_size);
3161 /* discarded[I] is 1 if byte I of the format
3162 string was not copied into the output.
3163 It is 2 if byte I was not the first byte of its character. */
3164 char *discarded = (char *) &info[nspec_bound];
3165 memset (discarded, 0, formatlen);
3166
3167 /* Try to determine whether the result should be multibyte.
3168 This is not always right; sometimes the result needs to be multibyte
3169 because of an object that we will pass through prin1.
3170 or because a grave accent or apostrophe is requoted,
3171 and in that case, we won't know it here. */
3172
3173 /* True if the output should be a multibyte string,
3174 which is true if any of the inputs is one. */
3175 bool multibyte = multibyte_format;
3176 for (ptrdiff_t i = 1; !multibyte && i < nargs; i++)
3177 if (STRINGP (args[i]) && STRING_MULTIBYTE (args[i]))
3178 multibyte = true;
3179
3180 Lisp_Object quoting_style = message ? Ftext_quoting_style () : Qnil;
3181
3182 ptrdiff_t ispec;
3183 ptrdiff_t nspec = 0;
3184
3185 /* True if a string needs to be allocated to hold the result. */
3186 bool new_result = false;
3187
3188 /* If we start out planning a unibyte result,
3189 then discover it has to be multibyte, we jump back to retry. */
3190 retry:
3191
3192 p = buf;
3193 nchars = 0;
3194
3195 /* N is the argument index, ISPEC is the specification index. */
3196 n = 0;
3197 ispec = 0;
3198
3199 /* Scan the format and store result in BUF. */
3200 format = format_start;
3201 end = format + formatlen;
3202 maybe_combine_byte = false;
3203
3204 while (format != end)
3205 {
3206 /* The values of N, ISPEC, and FORMAT when the loop body is
3207 entered. */
3208 ptrdiff_t n0 = n;
3209 ptrdiff_t ispec0 = ispec;
3210 char *format0 = format;
3211 char const *convsrc = format;
3212 unsigned char format_char = *format++;
3213
3214 /* Number of bytes to be preallocated for the next directive's
3215 output. At the end of each iteration this is at least
3216 CONVBYTES_ROOM, and is greater if the current directive
3217 output was so large that it will be retried after buffer
3218 reallocation. */
3219 ptrdiff_t convbytes = 1;
3220 enum { CONVBYTES_ROOM = SPRINTF_BUFSIZE - 1 };
3221 eassert (p <= buf + bufsize - SPRINTF_BUFSIZE);
3222
3223 if (format_char == '%')
3224 {
3225 /* General format specifications look like
3226
3227 '%' [field-number] [flags] [field-width] [precision] format
3228
3229 where
3230
3231 field-number ::= [0-9]+ '$'
3232 flags ::= [-+0# ]+
3233 field-width ::= [0-9]+
3234 precision ::= '.' [0-9]*
3235
3236 If present, a field-number specifies the argument number
3237 to substitute. Otherwise, the next argument is taken.
3238
3239 If a field-width is specified, it specifies to which width
3240 the output should be padded with blanks, if the output
3241 string is shorter than field-width.
3242
3243 If precision is specified, it specifies the number of
3244 digits to print after the '.' for floats, or the max.
3245 number of chars to print from a string. */
3246
3247 ptrdiff_t num;
3248 char *num_end;
3249 if (c_isdigit (*format))
3250 {
3251 num = str2num (format, &num_end);
3252 if (*num_end == '$')
3253 {
3254 n = num - 1;
3255 format = num_end + 1;
3256 }
3257 }
3258
3259 bool minus_flag = false;
3260 bool plus_flag = false;
3261 bool space_flag = false;
3262 bool sharp_flag = false;
3263 bool zero_flag = false;
3264
3265 for (; ; format++)
3266 {
3267 switch (*format)
3268 {
3269 case '-': minus_flag = true; continue;
3270 case '+': plus_flag = true; continue;
3271 case ' ': space_flag = true; continue;
3272 case '#': sharp_flag = true; continue;
3273 case '0': zero_flag = true; continue;
3274 }
3275 break;
3276 }
3277
3278 /* Ignore flags when sprintf ignores them. */
3279 space_flag &= ! plus_flag;
3280 zero_flag &= ! minus_flag;
3281
3282 num = str2num (format, &num_end);
3283 if (max_bufsize <= num)
3284 string_overflow ();
3285 ptrdiff_t field_width = num;
3286
3287 bool precision_given = *num_end == '.';
3288 ptrdiff_t precision = (precision_given
3289 ? str2num (num_end + 1, &num_end)
3290 : PTRDIFF_MAX);
3291 format = num_end;
3292
3293 if (format == end)
3294 error ("Format string ends in middle of format specifier");
3295
3296 char conversion = *format++;
3297 memset (&discarded[format0 - format_start], 1,
3298 format - format0 - (conversion == '%'));
3299 info[ispec].fbeg = format0 - format_start;
3300 if (conversion == '%')
3301 {
3302 new_result = true;
3303 goto copy_char;
3304 }
3305
3306 ++n;
3307 if (! (n < nargs))
3308 error ("Not enough arguments for format string");
3309
3310 struct info *spec = &info[ispec++];
3311 if (nspec < ispec)
3312 {
3313 spec->argument = args[n];
3314 spec->intervals = false;
3315 nspec = ispec;
3316 }
3317 Lisp_Object arg = spec->argument;
3318
3319 /* For 'S', prin1 the argument, and then treat like 's'.
3320 For 's', princ any argument that is not a string or
3321 symbol. But don't do this conversion twice, which might
3322 happen after retrying. */
3323 if ((conversion == 'S'
3324 || (conversion == 's'
3325 && ! STRINGP (arg) && ! SYMBOLP (arg))))
3326 {
3327 if (EQ (arg, args[n]))
3328 {
3329 Lisp_Object noescape = conversion == 'S' ? Qnil : Qt;
3330 spec->argument = arg = Fprin1_to_string (arg, noescape);
3331 if (STRING_MULTIBYTE (arg) && ! multibyte)
3332 {
3333 multibyte = true;
3334 goto retry;
3335 }
3336 }
3337 conversion = 's';
3338 }
3339 else if (conversion == 'c')
3340 {
3341 if (FIXNUMP (arg) && ! ASCII_CHAR_P (XFIXNUM (arg)))
3342 {
3343 if (!multibyte)
3344 {
3345 multibyte = true;
3346 goto retry;
3347 }
3348 spec->argument = arg = Fchar_to_string (arg);
3349 }
3350
3351 if (!EQ (arg, args[n]))
3352 conversion = 's';
3353 zero_flag = false;
3354 }
3355
3356 if (SYMBOLP (arg))
3357 {
3358 spec->argument = arg = SYMBOL_NAME (arg);
3359 if (STRING_MULTIBYTE (arg) && ! multibyte)
3360 {
3361 multibyte = true;
3362 goto retry;
3363 }
3364 }
3365
3366 bool float_conversion
3367 = conversion == 'e' || conversion == 'f' || conversion == 'g';
3368
3369 if (conversion == 's')
3370 {
3371 if (format == end && format - format_start == 2
3372 && ! string_intervals (args[0]))
3373 {
3374 val = arg;
3375 goto return_val;
3376 }
3377
3378 /* handle case (precision[n] >= 0) */
3379
3380 ptrdiff_t prec = -1;
3381 if (precision_given)
3382 prec = precision;
3383
3384 /* lisp_string_width ignores a precision of 0, but GNU
3385 libc functions print 0 characters when the precision
3386 is 0. Imitate libc behavior here. Changing
3387 lisp_string_width is the right thing, and will be
3388 done, but meanwhile we work with it. */
3389
3390 ptrdiff_t width, nbytes;
3391 ptrdiff_t nchars_string;
3392 if (prec == 0)
3393 width = nchars_string = nbytes = 0;
3394 else
3395 {
3396 ptrdiff_t nch, nby;
3397 nchars_string = SCHARS (arg);
3398 width = lisp_string_width (arg, 0, nchars_string, prec,
3399 &nch, &nby, false);
3400 if (prec < 0)
3401 nbytes = SBYTES (arg);
3402 else
3403 {
3404 nchars_string = nch;
3405 nbytes = nby;
3406 }
3407 }
3408
3409 convbytes = nbytes;
3410 if (convbytes && multibyte && ! STRING_MULTIBYTE (arg))
3411 convbytes = count_size_as_multibyte (SDATA (arg), nbytes);
3412
3413 ptrdiff_t padding
3414 = width < field_width ? field_width - width : 0;
3415
3416 if (max_bufsize - padding <= convbytes)
3417 string_overflow ();
3418 convbytes += padding;
3419 if (convbytes <= buf + bufsize - p)
3420 {
3421 /* If the format spec has properties, we should account
3422 for the padding on the left in the info[] array. */
3423 if (fmt_props)
3424 spec->start = nchars;
3425 if (! minus_flag)
3426 {
3427 memset (p, ' ', padding);
3428 p += padding;
3429 nchars += padding;
3430 }
3431 /* If the properties will come from the argument, we
3432 don't extend them to the left due to padding. */
3433 if (!fmt_props)
3434 spec->start = nchars;
3435
3436 if (p > buf
3437 && multibyte
3438 && !ASCII_CHAR_P (*((unsigned char *) p - 1))
3439 && STRING_MULTIBYTE (arg)
3440 && !CHAR_HEAD_P (SREF (arg, 0)))
3441 maybe_combine_byte = true;
3442
3443 p += copy_text (SDATA (arg), (unsigned char *) p,
3444 nbytes,
3445 STRING_MULTIBYTE (arg), multibyte);
3446
3447 nchars += nchars_string;
3448
3449 if (minus_flag)
3450 {
3451 memset (p, ' ', padding);
3452 p += padding;
3453 nchars += padding;
3454 }
3455 spec->end = nchars;
3456
3457 /* If this argument has text properties, record where
3458 in the result string it appears. */
3459 if (string_intervals (arg))
3460 spec->intervals = arg_intervals = true;
3461
3462 new_result = true;
3463 convbytes = CONVBYTES_ROOM;
3464 }
3465 }
3466 else if (! (conversion == 'c' || conversion == 'd'
3467 || float_conversion || conversion == 'i'
3468 || conversion == 'o' || conversion == 'x'
3469 || conversion == 'X'))
3470 error ("Invalid format operation %%%c",
3471 STRING_CHAR ((unsigned char *) format - 1));
3472 else if (! (FIXNUMP (arg) || ((BIGNUMP (arg) || FLOATP (arg))
3473 && conversion != 'c')))
3474 error ("Format specifier doesn't match argument type");
3475 else
3476 {
3477 /* Length of PRIdMAX without the trailing "d". */
3478 enum { pMlen = sizeof PRIdMAX - 2 };
3479
3480 /* Avoid undefined behavior in underlying sprintf. */
3481 if (conversion == 'd' || conversion == 'i')
3482 sharp_flag = false;
3483
3484 /* Create the copy of the conversion specification, with
3485 any width and precision removed, with ".*" inserted,
3486 with "L" possibly inserted for floating-point formats,
3487 and with PRIdMAX (sans "d") inserted for integer formats.
3488 At most two flags F can be specified at once. */
3489 char convspec[sizeof "%FF.*d" + max (sizeof "L" - 1, pMlen)];
3490 char *f = convspec;
3491 *f++ = '%';
3492 /* MINUS_FLAG and ZERO_FLAG are dealt with later. */
3493 *f = '+'; f += plus_flag;
3494 *f = ' '; f += space_flag;
3495 *f = '#'; f += sharp_flag;
3496 *f++ = '.';
3497 *f++ = '*';
3498 if (! (float_conversion || conversion == 'c'))
3499 {
3500 memcpy (f, PRIdMAX, pMlen);
3501 f += pMlen;
3502 zero_flag &= ! precision_given;
3503 }
3504 *f++ = conversion;
3505 *f = '\0';
3506
3507 int prec = -1;
3508 if (precision_given)
3509 prec = min (precision, USEFUL_PRECISION_MAX);
3510
3511 /* Characters to be inserted after spaces and before
3512 leading zeros. This can occur with bignums, since
3513 bignum_to_string does only leading '-'. */
3514 char prefix[sizeof "-0x" - 1];
3515 int prefixlen = 0;
3516
3517 /* Use sprintf or bignum_to_string to format this number. Omit
3518 padding and excess precision, though, because sprintf limits
3519 output length to INT_MAX and bignum_to_string doesn't
3520 do padding or precision.
3521
3522 Use five sprintf conversions: double, long double, unsigned
3523 char (passed as int), wide signed int, and wide
3524 unsigned int. Treat them separately because the
3525 sprintf ABI is sensitive to which type is passed. Be
3526 careful about integer overflow, NaNs, infinities, and
3527 conversions; for example, the min and max macros are
3528 not suitable here. */
3529 ptrdiff_t sprintf_bytes;
3530 if (float_conversion)
3531 {
3532 /* Format as a long double if the arg is an integer
3533 that would lose less information than when formatting
3534 it as a double. Otherwise, format as a double;
3535 this is likely to be faster and better-tested. */
3536
3537 bool format_as_long_double = false;
3538 double darg;
3539 long double ldarg UNINIT;
3540
3541 if (FLOATP (arg))
3542 darg = XFLOAT_DATA (arg);
3543 else
3544 {
3545 bool format_bignum_as_double = false;
3546 if (LDBL_MANT_DIG <= DBL_MANT_DIG)
3547 {
3548 if (FIXNUMP (arg))
3549 darg = XFIXNUM (arg);
3550 else
3551 format_bignum_as_double = true;
3552 }
3553 else
3554 {
3555 if (INTEGERP (arg))
3556 {
3557 intmax_t iarg;
3558 uintmax_t uarg;
3559 if (integer_to_intmax (arg, &iarg))
3560 ldarg = iarg;
3561 else if (integer_to_uintmax (arg, &uarg))
3562 ldarg = uarg;
3563 else
3564 format_bignum_as_double = true;
3565 }
3566 if (!format_bignum_as_double)
3567 {
3568 darg = ldarg;
3569 format_as_long_double = darg != ldarg;
3570 }
3571 }
3572 if (format_bignum_as_double)
3573 darg = bignum_to_double (arg);
3574 }
3575
3576 if (format_as_long_double)
3577 {
3578 f[-1] = 'L';
3579 *f++ = conversion;
3580 *f = '\0';
3581 sprintf_bytes = sprintf (p, convspec, prec, ldarg);
3582 }
3583 else
3584 sprintf_bytes = sprintf (p, convspec, prec, darg);
3585 }
3586 else if (conversion == 'c')
3587 {
3588 /* Don't use sprintf here, as it might mishandle prec. */
3589 p[0] = XFIXNUM (arg);
3590 p[1] = '\0';
3591 sprintf_bytes = prec != 0;
3592 }
3593 else if (BIGNUMP (arg))
3594 bignum_arg:
3595 {
3596 int base = ((conversion == 'd' || conversion == 'i') ? 10
3597 : conversion == 'o' ? 8 : 16);
3598 sprintf_bytes = bignum_bufsize (arg, base);
3599 if (sprintf_bytes <= buf + bufsize - p)
3600 {
3601 int signedbase = conversion == 'X' ? -base : base;
3602 sprintf_bytes = bignum_to_c_string (p, sprintf_bytes,
3603 arg, signedbase);
3604 bool negative = p[0] == '-';
3605 prec = min (precision, sprintf_bytes - prefixlen);
3606 prefix[prefixlen] = plus_flag ? '+' : ' ';
3607 prefixlen += (plus_flag | space_flag) & !negative;
3608 prefix[prefixlen] = '0';
3609 prefix[prefixlen + 1] = conversion;
3610 prefixlen += sharp_flag && base == 16 ? 2 : 0;
3611 }
3612 }
3613 else if (conversion == 'd' || conversion == 'i')
3614 {
3615 if (FIXNUMP (arg))
3616 {
3617 intmax_t x = XFIXNUM (arg);
3618 sprintf_bytes = sprintf (p, convspec, prec, x);
3619 }
3620 else
3621 {
3622 strcpy (f - pMlen - 1, "f");
3623 double x = XFLOAT_DATA (arg);
3624
3625 /* Truncate and then convert -0 to 0, to be more
3626 consistent with %x etc.; see Bug#31938. */
3627 x = trunc (x);
3628 x = x ? x : 0;
3629
3630 sprintf_bytes = sprintf (p, convspec, 0, x);
3631 bool signedp = ! c_isdigit (p[0]);
3632 prec = min (precision, sprintf_bytes - signedp);
3633 }
3634 }
3635 else
3636 {
3637 uintmax_t x;
3638 bool negative;
3639 if (FIXNUMP (arg))
3640 {
3641 if (binary_as_unsigned)
3642 {
3643 x = XUFIXNUM (arg);
3644 negative = false;
3645 }
3646 else
3647 {
3648 EMACS_INT i = XFIXNUM (arg);
3649 negative = i < 0;
3650 x = negative ? -i : i;
3651 }
3652 }
3653 else
3654 {
3655 double d = XFLOAT_DATA (arg);
3656 double abs_d = fabs (d);
3657 if (abs_d < UINTMAX_MAX + 1.0)
3658 {
3659 negative = d <= -1;
3660 x = abs_d;
3661 }
3662 else
3663 {
3664 arg = double_to_integer (d);
3665 goto bignum_arg;
3666 }
3667 }
3668 p[0] = negative ? '-' : plus_flag ? '+' : ' ';
3669 bool signedp = negative | plus_flag | space_flag;
3670 sprintf_bytes = sprintf (p + signedp, convspec, prec, x);
3671 sprintf_bytes += signedp;
3672 }
3673
3674 /* Now the length of the formatted item is known, except it omits
3675 padding and excess precision. Deal with excess precision
3676 first. This happens when the format specifies ridiculously
3677 large precision, or when %d or %i formats a float that would
3678 ordinarily need fewer digits than a specified precision,
3679 or when a bignum is formatted using an integer format
3680 with enough precision. */
3681 ptrdiff_t excess_precision
3682 = precision_given ? precision - prec : 0;
3683 ptrdiff_t trailing_zeros = 0;
3684 if (excess_precision != 0 && float_conversion)
3685 {
3686 if (! c_isdigit (p[sprintf_bytes - 1])
3687 || (conversion == 'g'
3688 && ! (sharp_flag && strchr (p, '.'))))
3689 excess_precision = 0;
3690 trailing_zeros = excess_precision;
3691 }
3692 ptrdiff_t leading_zeros = excess_precision - trailing_zeros;
3693
3694 /* Compute the total bytes needed for this item, including
3695 excess precision and padding. */
3696 ptrdiff_t numwidth;
3697 if (INT_ADD_WRAPV (prefixlen + sprintf_bytes, excess_precision,
3698 &numwidth))
3699 numwidth = PTRDIFF_MAX;
3700 ptrdiff_t padding
3701 = numwidth < field_width ? field_width - numwidth : 0;
3702 if (max_bufsize - (prefixlen + sprintf_bytes) <= excess_precision
3703 || max_bufsize - padding <= numwidth)
3704 string_overflow ();
3705 convbytes = numwidth + padding;
3706
3707 if (convbytes <= buf + bufsize - p)
3708 {
3709 bool signedp = p[0] == '-' || p[0] == '+' || p[0] == ' ';
3710 int beglen = (signedp
3711 + ((p[signedp] == '0'
3712 && (p[signedp + 1] == 'x'
3713 || p[signedp + 1] == 'X'))
3714 ? 2 : 0));
3715 eassert (prefixlen == 0 || beglen == 0
3716 || (beglen == 1 && p[0] == '-'
3717 && ! (prefix[0] == '-' || prefix[0] == '+'
3718 || prefix[0] == ' ')));
3719 if (zero_flag && 0 <= char_hexdigit (p[beglen]))
3720 {
3721 leading_zeros += padding;
3722 padding = 0;
3723 }
3724 if (leading_zeros == 0 && sharp_flag && conversion == 'o'
3725 && p[beglen] != '0')
3726 {
3727 leading_zeros++;
3728 padding -= padding != 0;
3729 }
3730
3731 int endlen = 0;
3732 if (trailing_zeros
3733 && (conversion == 'e' || conversion == 'g'))
3734 {
3735 char *e = strchr (p, 'e');
3736 if (e)
3737 endlen = p + sprintf_bytes - e;
3738 }
3739
3740 ptrdiff_t midlen = sprintf_bytes - beglen - endlen;
3741 ptrdiff_t leading_padding = minus_flag ? 0 : padding;
3742 ptrdiff_t trailing_padding = padding - leading_padding;
3743
3744 /* Insert padding and excess-precision zeros. The output
3745 contains the following components, in left-to-right order:
3746
3747 LEADING_PADDING spaces.
3748 BEGLEN bytes taken from the start of sprintf output.
3749 PREFIXLEN bytes taken from the start of the prefix array.
3750 LEADING_ZEROS zeros.
3751 MIDLEN bytes taken from the middle of sprintf output.
3752 TRAILING_ZEROS zeros.
3753 ENDLEN bytes taken from the end of sprintf output.
3754 TRAILING_PADDING spaces.
3755
3756 The sprintf output is taken from the buffer starting at
3757 P and continuing for SPRINTF_BYTES bytes. */
3758
3759 ptrdiff_t incr
3760 = (padding + leading_zeros + prefixlen
3761 + sprintf_bytes + trailing_zeros);
3762
3763 /* Optimize for the typical case with padding or zeros. */
3764 if (incr != sprintf_bytes)
3765 {
3766 /* Move data to make room to insert spaces and '0's.
3767 As this may entail overlapping moves, process
3768 the output right-to-left and use memmove.
3769 With any luck this code is rarely executed. */
3770 char *src = p + sprintf_bytes;
3771 char *dst = p + incr;
3772 dst -= trailing_padding;
3773 memset (dst, ' ', trailing_padding);
3774 src -= endlen;
3775 dst -= endlen;
3776 memmove (dst, src, endlen);
3777 dst -= trailing_zeros;
3778 memset (dst, '0', trailing_zeros);
3779 src -= midlen;
3780 dst -= midlen;
3781 memmove (dst, src, midlen);
3782 dst -= leading_zeros;
3783 memset (dst, '0', leading_zeros);
3784 dst -= prefixlen;
3785 memcpy (dst, prefix, prefixlen);
3786 src -= beglen;
3787 dst -= beglen;
3788 memmove (dst, src, beglen);
3789 dst -= leading_padding;
3790 memset (dst, ' ', leading_padding);
3791 }
3792
3793 p += incr;
3794 spec->start = nchars;
3795 spec->end = nchars += incr;
3796 new_result = true;
3797 convbytes = CONVBYTES_ROOM;
3798 }
3799 }
3800 }
3801 else
3802 {
3803 unsigned char str[MAX_MULTIBYTE_LENGTH];
3804
3805 if ((format_char == '`' || format_char == '\'')
3806 && EQ (quoting_style, Qcurve))
3807 {
3808 if (! multibyte)
3809 {
3810 multibyte = true;
3811 goto retry;
3812 }
3813 convsrc = format_char == '`' ? uLSQM : uRSQM;
3814 convbytes = 3;
3815 new_result = true;
3816 }
3817 else if (format_char == '`' && EQ (quoting_style, Qstraight))
3818 {
3819 convsrc = "'";
3820 new_result = true;
3821 }
3822 else
3823 {
3824 /* Copy a single character from format to buf. */
3825 if (multibyte_format)
3826 {
3827 /* Copy a whole multibyte character. */
3828 if (p > buf
3829 && !ASCII_CHAR_P (*((unsigned char *) p - 1))
3830 && !CHAR_HEAD_P (format_char))
3831 maybe_combine_byte = true;
3832
3833 while (! CHAR_HEAD_P (*format))
3834 format++;
3835
3836 convbytes = format - format0;
3837 memset (&discarded[format0 + 1 - format_start], 2,
3838 convbytes - 1);
3839 }
3840 else if (multibyte && !ASCII_CHAR_P (format_char))
3841 {
3842 int c = BYTE8_TO_CHAR (format_char);
3843 convbytes = CHAR_STRING (c, str);
3844 convsrc = (char *) str;
3845 new_result = true;
3846 }
3847 }
3848
3849 copy_char:
3850 memcpy (p, convsrc, convbytes);
3851 p += convbytes;
3852 nchars++;
3853 convbytes = CONVBYTES_ROOM;
3854 }
3855
3856 ptrdiff_t used = p - buf;
3857 ptrdiff_t buflen_needed;
3858 if (INT_ADD_WRAPV (used, convbytes, &buflen_needed))
3859 string_overflow ();
3860 if (bufsize <= buflen_needed)
3861 {
3862 if (max_bufsize <= buflen_needed)
3863 string_overflow ();
3864
3865 /* Either there wasn't enough room to store this conversion,
3866 or there won't be enough room to do a sprintf the next
3867 time through the loop. Allocate enough room (and then some). */
3868
3869 bufsize = (buflen_needed <= max_bufsize / 2
3870 ? buflen_needed * 2 : max_bufsize);
3871
3872 if (buf == initial_buffer)
3873 {
3874 buf = xmalloc (bufsize);
3875 buf_save_value_index = SPECPDL_INDEX ();
3876 record_unwind_protect_ptr (xfree, buf);
3877 memcpy (buf, initial_buffer, used);
3878 }
3879 else
3880 {
3881 buf = xrealloc (buf, bufsize);
3882 set_unwind_protect_ptr (buf_save_value_index, xfree, buf);
3883 }
3884
3885 p = buf + used;
3886 if (convbytes != CONVBYTES_ROOM)
3887 {
3888 /* There wasn't enough room for this conversion; do it over. */
3889 eassert (CONVBYTES_ROOM < convbytes);
3890 format = format0;
3891 n = n0;
3892 ispec = ispec0;
3893 }
3894 }
3895 }
3896
3897 if (bufsize < p - buf)
3898 emacs_abort ();
3899
3900 if (! new_result)
3901 {
3902 val = args[0];
3903 goto return_val;
3904 }
3905
3906 if (maybe_combine_byte)
3907 nchars = multibyte_chars_in_text ((unsigned char *) buf, p - buf);
3908 val = make_specified_string (buf, nchars, p - buf, multibyte);
3909
3910 /* If the format string has text properties, or any of the string
3911 arguments has text properties, set up text properties of the
3912 result string. */
3913
3914 if (string_intervals (args[0]) || arg_intervals)
3915 {
3916 /* Add text properties from the format string. */
3917 Lisp_Object len = make_fixnum (SCHARS (args[0]));
3918 Lisp_Object props = text_property_list (args[0], make_fixnum (0),
3919 len, Qnil);
3920 if (CONSP (props))
3921 {
3922 ptrdiff_t bytepos = 0, position = 0, translated = 0;
3923 ptrdiff_t fieldn = 0;
3924
3925 /* Adjust the bounds of each text property
3926 to the proper start and end in the output string. */
3927
3928 /* Put the positions in PROPS in increasing order, so that
3929 we can do (effectively) one scan through the position
3930 space of the format string. */
3931 props = Fnreverse (props);
3932
3933 /* BYTEPOS is the byte position in the format string,
3934 POSITION is the untranslated char position in it,
3935 TRANSLATED is the translated char position in BUF,
3936 and ARGN is the number of the next arg we will come to. */
3937 for (Lisp_Object list = props; CONSP (list); list = XCDR (list))
3938 {
3939 Lisp_Object item = XCAR (list);
3940
3941 /* First adjust the property start position. */
3942 ptrdiff_t pos = XFIXNUM (XCAR (item));
3943
3944 /* Advance BYTEPOS, POSITION, TRANSLATED and ARGN
3945 up to this position. */
3946 for (; position < pos; bytepos++)
3947 {
3948 if (! discarded[bytepos])
3949 position++, translated++;
3950 else if (discarded[bytepos] == 1)
3951 {
3952 position++;
3953 if (fieldn < nspec
3954 && bytepos >= info[fieldn].fbeg
3955 && translated == info[fieldn].start)
3956 {
3957 translated += info[fieldn].end - info[fieldn].start;
3958 fieldn++;
3959 }
3960 }
3961 }
3962
3963 XSETCAR (item, make_fixnum (translated));
3964
3965 /* Likewise adjust the property end position. */
3966 pos = XFIXNUM (XCAR (XCDR (item)));
3967
3968 for (; position < pos; bytepos++)
3969 {
3970 if (! discarded[bytepos])
3971 position++, translated++;
3972 else if (discarded[bytepos] == 1)
3973 {
3974 position++;
3975 if (fieldn < nspec
3976 && bytepos >= info[fieldn].fbeg
3977 && translated == info[fieldn].start)
3978 {
3979 translated += info[fieldn].end - info[fieldn].start;
3980 fieldn++;
3981 }
3982 }
3983 }
3984
3985 XSETCAR (XCDR (item), make_fixnum (translated));
3986 }
3987
3988 add_text_properties_from_list (val, props, make_fixnum (0));
3989 }
3990
3991 /* Add text properties from arguments. */
3992 if (arg_intervals)
3993 for (ptrdiff_t i = 0; i < nspec; i++)
3994 if (info[i].intervals)
3995 {
3996 len = make_fixnum (SCHARS (info[i].argument));
3997 Lisp_Object new_len = make_fixnum (info[i].end - info[i].start);
3998 props = text_property_list (info[i].argument,
3999 make_fixnum (0), len, Qnil);
4000 props = extend_property_ranges (props, len, new_len);
4001 /* If successive arguments have properties, be sure that
4002 the value of `composition' property be the copy. */
4003 if (1 < i && info[i - 1].end)
4004 make_composition_value_copy (props);
4005 add_text_properties_from_list (val, props,
4006 make_fixnum (info[i].start));
4007 }
4008 }
4009
4010 return_val:
4011 /* If we allocated BUF or INFO with malloc, free it too. */
4012 SAFE_FREE ();
4013
4014 return val;
4015 }
4016
4017 DEFUN ("char-equal", Fchar_equal, Schar_equal, 2, 2, 0,
4018 doc: /* Return t if two characters match, optionally ignoring case.
4019 Both arguments must be characters (i.e. integers).
4020 Case is ignored if `case-fold-search' is non-nil in the current buffer. */)
4021 (register Lisp_Object c1, Lisp_Object c2)
4022 {
4023 int i1, i2;
4024 /* Check they're chars, not just integers, otherwise we could get array
4025 bounds violations in downcase. */
4026 CHECK_CHARACTER (c1);
4027 CHECK_CHARACTER (c2);
4028
4029 if (XFIXNUM (c1) == XFIXNUM (c2))
4030 return Qt;
4031 if (NILP (BVAR (current_buffer, case_fold_search)))
4032 return Qnil;
4033
4034 i1 = XFIXNAT (c1);
4035 i2 = XFIXNAT (c2);
4036
4037 /* FIXME: It is possible to compare multibyte characters even when
4038 the current buffer is unibyte. Unfortunately this is ambiguous
4039 for characters between 128 and 255, as they could be either
4040 eight-bit raw bytes or Latin-1 characters. Assume the former for
4041 now. See Bug#17011, and also see casefiddle.c's casify_object,
4042 which has a similar problem. */
4043 if (NILP (BVAR (current_buffer, enable_multibyte_characters)))
4044 {
4045 if (SINGLE_BYTE_CHAR_P (i1))
4046 i1 = UNIBYTE_TO_CHAR (i1);
4047 if (SINGLE_BYTE_CHAR_P (i2))
4048 i2 = UNIBYTE_TO_CHAR (i2);
4049 }
4050
4051 return (downcase (i1) == downcase (i2) ? Qt : Qnil);
4052 }
4053
4054 /* Transpose the markers in two regions of the current buffer, and
4055 adjust the ones between them if necessary (i.e.: if the regions
4056 differ in size).
4057
4058 START1, END1 are the character positions of the first region.
4059 START1_BYTE, END1_BYTE are the byte positions.
4060 START2, END2 are the character positions of the second region.
4061 START2_BYTE, END2_BYTE are the byte positions.
4062
4063 Traverses the entire marker list of the buffer to do so, adding an
4064 appropriate amount to some, subtracting from some, and leaving the
4065 rest untouched. Most of this is copied from adjust_markers in insdel.c.
4066
4067 It's the caller's job to ensure that START1 <= END1 <= START2 <= END2. */
4068
4069 static void
transpose_markers(ptrdiff_t start1,ptrdiff_t end1,ptrdiff_t start2,ptrdiff_t end2,ptrdiff_t start1_byte,ptrdiff_t end1_byte,ptrdiff_t start2_byte,ptrdiff_t end2_byte)4070 transpose_markers (ptrdiff_t start1, ptrdiff_t end1,
4071 ptrdiff_t start2, ptrdiff_t end2,
4072 ptrdiff_t start1_byte, ptrdiff_t end1_byte,
4073 ptrdiff_t start2_byte, ptrdiff_t end2_byte)
4074 {
4075 register ptrdiff_t amt1, amt1_byte, amt2, amt2_byte, diff, diff_byte, mpos;
4076 register struct Lisp_Marker *marker;
4077
4078 /* Update point as if it were a marker. */
4079 if (PT < start1)
4080 ;
4081 else if (PT < end1)
4082 TEMP_SET_PT_BOTH (PT + (end2 - end1),
4083 PT_BYTE + (end2_byte - end1_byte));
4084 else if (PT < start2)
4085 TEMP_SET_PT_BOTH (PT + (end2 - start2) - (end1 - start1),
4086 (PT_BYTE + (end2_byte - start2_byte)
4087 - (end1_byte - start1_byte)));
4088 else if (PT < end2)
4089 TEMP_SET_PT_BOTH (PT - (start2 - start1),
4090 PT_BYTE - (start2_byte - start1_byte));
4091
4092 /* We used to adjust the endpoints here to account for the gap, but that
4093 isn't good enough. Even if we assume the caller has tried to move the
4094 gap out of our way, it might still be at start1 exactly, for example;
4095 and that places it `inside' the interval, for our purposes. The amount
4096 of adjustment is nontrivial if there's a `denormalized' marker whose
4097 position is between GPT and GPT + GAP_SIZE, so it's simpler to leave
4098 the dirty work to Fmarker_position, below. */
4099
4100 /* The difference between the region's lengths */
4101 diff = (end2 - start2) - (end1 - start1);
4102 diff_byte = (end2_byte - start2_byte) - (end1_byte - start1_byte);
4103
4104 /* For shifting each marker in a region by the length of the other
4105 region plus the distance between the regions. */
4106 amt1 = (end2 - start2) + (start2 - end1);
4107 amt2 = (end1 - start1) + (start2 - end1);
4108 amt1_byte = (end2_byte - start2_byte) + (start2_byte - end1_byte);
4109 amt2_byte = (end1_byte - start1_byte) + (start2_byte - end1_byte);
4110
4111 for (marker = BUF_MARKERS (current_buffer); marker; marker = marker->next)
4112 {
4113 mpos = marker->bytepos;
4114 if (mpos >= start1_byte && mpos < end2_byte)
4115 {
4116 if (mpos < end1_byte)
4117 mpos += amt1_byte;
4118 else if (mpos < start2_byte)
4119 mpos += diff_byte;
4120 else
4121 mpos -= amt2_byte;
4122 marker->bytepos = mpos;
4123 }
4124 mpos = marker->charpos;
4125 if (mpos >= start1 && mpos < end2)
4126 {
4127 if (mpos < end1)
4128 mpos += amt1;
4129 else if (mpos < start2)
4130 mpos += diff;
4131 else
4132 mpos -= amt2;
4133 }
4134 marker->charpos = mpos;
4135 }
4136 }
4137
4138 DEFUN ("transpose-regions", Ftranspose_regions, Stranspose_regions, 4, 5,
4139 "(if (< (length mark-ring) 2)\
4140 (error \"Other region must be marked before transposing two regions\")\
4141 (let* ((num (if current-prefix-arg\
4142 (prefix-numeric-value current-prefix-arg)\
4143 0))\
4144 (ring-length (length mark-ring))\
4145 (eltnum (mod num ring-length))\
4146 (eltnum2 (mod (1+ num) ring-length)))\
4147 (list (point) (mark) (elt mark-ring eltnum) (elt mark-ring eltnum2))))",
4148 doc: /* Transpose region STARTR1 to ENDR1 with STARTR2 to ENDR2.
4149 The regions should not be overlapping, because the size of the buffer is
4150 never changed in a transposition.
4151
4152 Optional fifth arg LEAVE-MARKERS, if non-nil, means don't update
4153 any markers that happen to be located in the regions.
4154
4155 Transposing beyond buffer boundaries is an error.
4156
4157 Interactively, STARTR1 and ENDR1 are point and mark; STARTR2 and ENDR2
4158 are the last two marks pushed to the mark ring; LEAVE-MARKERS is nil.
4159 If a prefix argument N is given, STARTR2 and ENDR2 are the two
4160 successive marks N entries back in the mark ring. A negative prefix
4161 argument instead counts forward from the oldest mark in the mark
4162 ring. */)
4163 (Lisp_Object startr1, Lisp_Object endr1, Lisp_Object startr2, Lisp_Object endr2, Lisp_Object leave_markers)
4164 {
4165 register ptrdiff_t start1, end1, start2, end2;
4166 ptrdiff_t start1_byte, start2_byte, len1_byte, len2_byte, end2_byte;
4167 ptrdiff_t gap, len1, len_mid, len2;
4168 unsigned char *start1_addr, *start2_addr, *temp;
4169
4170 INTERVAL cur_intv, tmp_interval1, tmp_interval_mid, tmp_interval2, tmp_interval3;
4171 Lisp_Object buf;
4172
4173 XSETBUFFER (buf, current_buffer);
4174 cur_intv = buffer_intervals (current_buffer);
4175
4176 validate_region (&startr1, &endr1);
4177 validate_region (&startr2, &endr2);
4178
4179 start1 = XFIXNAT (startr1);
4180 end1 = XFIXNAT (endr1);
4181 start2 = XFIXNAT (startr2);
4182 end2 = XFIXNAT (endr2);
4183 gap = GPT;
4184
4185 /* Swap the regions if they're reversed. */
4186 if (start2 < end1)
4187 {
4188 register ptrdiff_t glumph = start1;
4189 start1 = start2;
4190 start2 = glumph;
4191 glumph = end1;
4192 end1 = end2;
4193 end2 = glumph;
4194 }
4195
4196 len1 = end1 - start1;
4197 len2 = end2 - start2;
4198
4199 if (start2 < end1)
4200 error ("Transposed regions overlap");
4201 /* Nothing to change for adjacent regions with one being empty */
4202 else if ((start1 == end1 || start2 == end2) && end1 == start2)
4203 return Qnil;
4204
4205 /* The possibilities are:
4206 1. Adjacent (contiguous) regions, or separate but equal regions
4207 (no, really equal, in this case!), or
4208 2. Separate regions of unequal size.
4209
4210 The worst case is usually No. 2. It means that (aside from
4211 potential need for getting the gap out of the way), there also
4212 needs to be a shifting of the text between the two regions. So
4213 if they are spread far apart, we are that much slower... sigh. */
4214
4215 /* It must be pointed out that the really studly thing to do would
4216 be not to move the gap at all, but to leave it in place and work
4217 around it if necessary. This would be extremely efficient,
4218 especially considering that people are likely to do
4219 transpositions near where they are working interactively, which
4220 is exactly where the gap would be found. However, such code
4221 would be much harder to write and to read. So, if you are
4222 reading this comment and are feeling squirrely, by all means have
4223 a go! I just didn't feel like doing it, so I will simply move
4224 the gap the minimum distance to get it out of the way, and then
4225 deal with an unbroken array. */
4226
4227 start1_byte = CHAR_TO_BYTE (start1);
4228 end2_byte = CHAR_TO_BYTE (end2);
4229
4230 /* Make sure the gap won't interfere, by moving it out of the text
4231 we will operate on. */
4232 if (start1 < gap && gap < end2)
4233 {
4234 if (gap - start1 < end2 - gap)
4235 move_gap_both (start1, start1_byte);
4236 else
4237 move_gap_both (end2, end2_byte);
4238 }
4239
4240 start2_byte = CHAR_TO_BYTE (start2);
4241 len1_byte = CHAR_TO_BYTE (end1) - start1_byte;
4242 len2_byte = end2_byte - start2_byte;
4243
4244 #ifdef BYTE_COMBINING_DEBUG
4245 if (end1 == start2)
4246 {
4247 if (count_combining_before (BYTE_POS_ADDR (start2_byte),
4248 len2_byte, start1, start1_byte)
4249 || count_combining_before (BYTE_POS_ADDR (start1_byte),
4250 len1_byte, end2, start2_byte + len2_byte)
4251 || count_combining_after (BYTE_POS_ADDR (start1_byte),
4252 len1_byte, end2, start2_byte + len2_byte))
4253 emacs_abort ();
4254 }
4255 else
4256 {
4257 if (count_combining_before (BYTE_POS_ADDR (start2_byte),
4258 len2_byte, start1, start1_byte)
4259 || count_combining_before (BYTE_POS_ADDR (start1_byte),
4260 len1_byte, start2, start2_byte)
4261 || count_combining_after (BYTE_POS_ADDR (start2_byte),
4262 len2_byte, end1, start1_byte + len1_byte)
4263 || count_combining_after (BYTE_POS_ADDR (start1_byte),
4264 len1_byte, end2, start2_byte + len2_byte))
4265 emacs_abort ();
4266 }
4267 #endif
4268
4269 /* Hmmm... how about checking to see if the gap is large
4270 enough to use as the temporary storage? That would avoid an
4271 allocation... interesting. Later, don't fool with it now. */
4272
4273 if (end1 == start2) /* adjacent regions */
4274 {
4275 modify_text (start1, end2);
4276 record_change (start1, len1 + len2);
4277
4278 tmp_interval1 = copy_intervals (cur_intv, start1, len1);
4279 tmp_interval2 = copy_intervals (cur_intv, start2, len2);
4280 /* Don't use Fset_text_properties: that can cause GC, which can
4281 clobber objects stored in the tmp_intervals. */
4282 tmp_interval3 = validate_interval_range (buf, &startr1, &endr2, 0);
4283 if (tmp_interval3)
4284 set_text_properties_1 (startr1, endr2, Qnil, buf, tmp_interval3);
4285
4286 USE_SAFE_ALLOCA;
4287
4288 /* First region smaller than second. */
4289 if (len1_byte < len2_byte)
4290 {
4291 temp = SAFE_ALLOCA (len2_byte);
4292
4293 /* Don't precompute these addresses. We have to compute them
4294 at the last minute, because the relocating allocator might
4295 have moved the buffer around during the xmalloc. */
4296 start1_addr = BYTE_POS_ADDR (start1_byte);
4297 start2_addr = BYTE_POS_ADDR (start2_byte);
4298
4299 memcpy (temp, start2_addr, len2_byte);
4300 memcpy (start1_addr + len2_byte, start1_addr, len1_byte);
4301 memcpy (start1_addr, temp, len2_byte);
4302 }
4303 else
4304 /* First region not smaller than second. */
4305 {
4306 temp = SAFE_ALLOCA (len1_byte);
4307 start1_addr = BYTE_POS_ADDR (start1_byte);
4308 start2_addr = BYTE_POS_ADDR (start2_byte);
4309 memcpy (temp, start1_addr, len1_byte);
4310 memcpy (start1_addr, start2_addr, len2_byte);
4311 memcpy (start1_addr + len2_byte, temp, len1_byte);
4312 }
4313
4314 SAFE_FREE ();
4315 graft_intervals_into_buffer (tmp_interval1, start1 + len2,
4316 len1, current_buffer, 0);
4317 graft_intervals_into_buffer (tmp_interval2, start1,
4318 len2, current_buffer, 0);
4319 update_compositions (start1, start1 + len2, CHECK_BORDER);
4320 update_compositions (start1 + len2, end2, CHECK_TAIL);
4321 }
4322 /* Non-adjacent regions, because end1 != start2, bleagh... */
4323 else
4324 {
4325 len_mid = start2_byte - (start1_byte + len1_byte);
4326
4327 if (len1_byte == len2_byte)
4328 /* Regions are same size, though, how nice. */
4329 {
4330 USE_SAFE_ALLOCA;
4331
4332 modify_text (start1, end2);
4333 record_change (start1, len1);
4334 record_change (start2, len2);
4335 tmp_interval1 = copy_intervals (cur_intv, start1, len1);
4336 tmp_interval2 = copy_intervals (cur_intv, start2, len2);
4337
4338 tmp_interval3 = validate_interval_range (buf, &startr1, &endr1, 0);
4339 if (tmp_interval3)
4340 set_text_properties_1 (startr1, endr1, Qnil, buf, tmp_interval3);
4341
4342 tmp_interval3 = validate_interval_range (buf, &startr2, &endr2, 0);
4343 if (tmp_interval3)
4344 set_text_properties_1 (startr2, endr2, Qnil, buf, tmp_interval3);
4345
4346 temp = SAFE_ALLOCA (len1_byte);
4347 start1_addr = BYTE_POS_ADDR (start1_byte);
4348 start2_addr = BYTE_POS_ADDR (start2_byte);
4349 memcpy (temp, start1_addr, len1_byte);
4350 memcpy (start1_addr, start2_addr, len2_byte);
4351 memcpy (start2_addr, temp, len1_byte);
4352 SAFE_FREE ();
4353
4354 graft_intervals_into_buffer (tmp_interval1, start2,
4355 len1, current_buffer, 0);
4356 graft_intervals_into_buffer (tmp_interval2, start1,
4357 len2, current_buffer, 0);
4358 }
4359
4360 else if (len1_byte < len2_byte) /* Second region larger than first */
4361 /* Non-adjacent & unequal size, area between must also be shifted. */
4362 {
4363 USE_SAFE_ALLOCA;
4364
4365 modify_text (start1, end2);
4366 record_change (start1, (end2 - start1));
4367 tmp_interval1 = copy_intervals (cur_intv, start1, len1);
4368 tmp_interval_mid = copy_intervals (cur_intv, end1, len_mid);
4369 tmp_interval2 = copy_intervals (cur_intv, start2, len2);
4370
4371 tmp_interval3 = validate_interval_range (buf, &startr1, &endr2, 0);
4372 if (tmp_interval3)
4373 set_text_properties_1 (startr1, endr2, Qnil, buf, tmp_interval3);
4374
4375 /* holds region 2 */
4376 temp = SAFE_ALLOCA (len2_byte);
4377 start1_addr = BYTE_POS_ADDR (start1_byte);
4378 start2_addr = BYTE_POS_ADDR (start2_byte);
4379 memcpy (temp, start2_addr, len2_byte);
4380 memcpy (start1_addr + len_mid + len2_byte, start1_addr, len1_byte);
4381 memmove (start1_addr + len2_byte, start1_addr + len1_byte, len_mid);
4382 memcpy (start1_addr, temp, len2_byte);
4383 SAFE_FREE ();
4384
4385 graft_intervals_into_buffer (tmp_interval1, end2 - len1,
4386 len1, current_buffer, 0);
4387 graft_intervals_into_buffer (tmp_interval_mid, start1 + len2,
4388 len_mid, current_buffer, 0);
4389 graft_intervals_into_buffer (tmp_interval2, start1,
4390 len2, current_buffer, 0);
4391 }
4392 else
4393 /* Second region smaller than first. */
4394 {
4395 USE_SAFE_ALLOCA;
4396
4397 record_change (start1, (end2 - start1));
4398 modify_text (start1, end2);
4399
4400 tmp_interval1 = copy_intervals (cur_intv, start1, len1);
4401 tmp_interval_mid = copy_intervals (cur_intv, end1, len_mid);
4402 tmp_interval2 = copy_intervals (cur_intv, start2, len2);
4403
4404 tmp_interval3 = validate_interval_range (buf, &startr1, &endr2, 0);
4405 if (tmp_interval3)
4406 set_text_properties_1 (startr1, endr2, Qnil, buf, tmp_interval3);
4407
4408 /* holds region 1 */
4409 temp = SAFE_ALLOCA (len1_byte);
4410 start1_addr = BYTE_POS_ADDR (start1_byte);
4411 start2_addr = BYTE_POS_ADDR (start2_byte);
4412 memcpy (temp, start1_addr, len1_byte);
4413 memcpy (start1_addr, start2_addr, len2_byte);
4414 memmove (start1_addr + len2_byte, start1_addr + len1_byte, len_mid);
4415 memcpy (start1_addr + len2_byte + len_mid, temp, len1_byte);
4416 SAFE_FREE ();
4417
4418 graft_intervals_into_buffer (tmp_interval1, end2 - len1,
4419 len1, current_buffer, 0);
4420 graft_intervals_into_buffer (tmp_interval_mid, start1 + len2,
4421 len_mid, current_buffer, 0);
4422 graft_intervals_into_buffer (tmp_interval2, start1,
4423 len2, current_buffer, 0);
4424 }
4425
4426 update_compositions (start1, start1 + len2, CHECK_BORDER);
4427 update_compositions (end2 - len1, end2, CHECK_BORDER);
4428 }
4429
4430 /* When doing multiple transpositions, it might be nice
4431 to optimize this. Perhaps the markers in any one buffer
4432 should be organized in some sorted data tree. */
4433 if (NILP (leave_markers))
4434 {
4435 transpose_markers (start1, end1, start2, end2,
4436 start1_byte, start1_byte + len1_byte,
4437 start2_byte, start2_byte + len2_byte);
4438 fix_start_end_in_overlays (start1, end2);
4439 }
4440 else
4441 {
4442 /* The character positions of the markers remain intact, but we
4443 still need to update their byte positions, because the
4444 transposed regions might include multibyte sequences which
4445 make some original byte positions of the markers invalid. */
4446 adjust_markers_bytepos (start1, start1_byte, end2, end2_byte, 0);
4447 }
4448
4449 signal_after_change (start1, end2 - start1, end2 - start1);
4450 return Qnil;
4451 }
4452
4453
4454 void
syms_of_editfns(void)4455 syms_of_editfns (void)
4456 {
4457 DEFSYM (Qbuffer_access_fontify_functions, "buffer-access-fontify-functions");
4458 DEFSYM (Qwall, "wall");
4459 DEFSYM (Qpropertize, "propertize");
4460
4461 DEFVAR_LISP ("inhibit-field-text-motion", Vinhibit_field_text_motion,
4462 doc: /* Non-nil means text motion commands don't notice fields. */);
4463 Vinhibit_field_text_motion = Qnil;
4464
4465 DEFVAR_LISP ("buffer-access-fontify-functions",
4466 Vbuffer_access_fontify_functions,
4467 doc: /* List of functions called by `buffer-substring' to fontify if necessary.
4468 Each function is called with two arguments which specify the range
4469 of the buffer being accessed. */);
4470 Vbuffer_access_fontify_functions = Qnil;
4471
4472 {
4473 Lisp_Object obuf;
4474 obuf = Fcurrent_buffer ();
4475 /* Do this here, because init_buffer_once is too early--it won't work. */
4476 Fset_buffer (Vprin1_to_string_buffer);
4477 /* Make sure buffer-access-fontify-functions is nil in this buffer. */
4478 Fset (Fmake_local_variable (Qbuffer_access_fontify_functions), Qnil);
4479 Fset_buffer (obuf);
4480 }
4481
4482 DEFVAR_LISP ("buffer-access-fontified-property",
4483 Vbuffer_access_fontified_property,
4484 doc: /* Property which (if non-nil) indicates text has been fontified.
4485 `buffer-substring' need not call the `buffer-access-fontify-functions'
4486 functions if all the text being accessed has this property. */);
4487 Vbuffer_access_fontified_property = Qnil;
4488
4489 DEFVAR_LISP ("system-name", Vsystem_name,
4490 doc: /* The host name of the machine Emacs is running on. */);
4491 Vsystem_name = cached_system_name = Qnil;
4492
4493 DEFVAR_LISP ("user-full-name", Vuser_full_name,
4494 doc: /* The full name of the user logged in. */);
4495
4496 DEFVAR_LISP ("user-login-name", Vuser_login_name,
4497 doc: /* The user's name, taken from environment variables if possible. */);
4498 Vuser_login_name = Qnil;
4499
4500 DEFVAR_LISP ("user-real-login-name", Vuser_real_login_name,
4501 doc: /* The user's name, based upon the real uid only. */);
4502
4503 DEFVAR_LISP ("operating-system-release", Voperating_system_release,
4504 doc: /* The kernel version of the operating system on which Emacs is running.
4505 The value is a string. It can also be nil if Emacs doesn't
4506 know how to get the kernel version on the underlying OS. */);
4507
4508 DEFVAR_BOOL ("binary-as-unsigned",
4509 binary_as_unsigned,
4510 doc: /* Non-nil means `format' %x and %o treat integers as unsigned.
4511 This has machine-dependent results. Nil means to treat integers as
4512 signed, which is portable and is the default; for example, if N is a
4513 negative integer, (read (format "#x%x" N)) returns N only when this
4514 variable is nil.
4515
4516 This variable is experimental; email 32252@debbugs.gnu.org if you need
4517 it to be non-nil. */);
4518 binary_as_unsigned = false;
4519
4520 defsubr (&Spropertize);
4521 defsubr (&Schar_equal);
4522 defsubr (&Sgoto_char);
4523 defsubr (&Sstring_to_char);
4524 defsubr (&Schar_to_string);
4525 defsubr (&Sbyte_to_string);
4526 defsubr (&Sbuffer_substring);
4527 defsubr (&Sbuffer_substring_no_properties);
4528 defsubr (&Sbuffer_string);
4529 defsubr (&Sget_pos_property);
4530
4531 defsubr (&Spoint_marker);
4532 defsubr (&Smark_marker);
4533 defsubr (&Spoint);
4534 defsubr (&Sregion_beginning);
4535 defsubr (&Sregion_end);
4536
4537 /* Symbol for the text property used to mark fields. */
4538 DEFSYM (Qfield, "field");
4539
4540 /* A special value for Qfield properties. */
4541 DEFSYM (Qboundary, "boundary");
4542
4543 defsubr (&Sfield_beginning);
4544 defsubr (&Sfield_end);
4545 defsubr (&Sfield_string);
4546 defsubr (&Sfield_string_no_properties);
4547 defsubr (&Sdelete_field);
4548 defsubr (&Sconstrain_to_field);
4549
4550 defsubr (&Sline_beginning_position);
4551 defsubr (&Sline_end_position);
4552
4553 defsubr (&Ssave_excursion);
4554 defsubr (&Ssave_current_buffer);
4555
4556 defsubr (&Sbuffer_size);
4557 defsubr (&Spoint_max);
4558 defsubr (&Spoint_min);
4559 defsubr (&Spoint_min_marker);
4560 defsubr (&Spoint_max_marker);
4561 defsubr (&Sgap_position);
4562 defsubr (&Sgap_size);
4563 defsubr (&Sposition_bytes);
4564 defsubr (&Sbyte_to_position);
4565
4566 defsubr (&Sbobp);
4567 defsubr (&Seobp);
4568 defsubr (&Sbolp);
4569 defsubr (&Seolp);
4570 defsubr (&Sfollowing_char);
4571 defsubr (&Sprevious_char);
4572 defsubr (&Schar_after);
4573 defsubr (&Schar_before);
4574 defsubr (&Sinsert);
4575 defsubr (&Sinsert_before_markers);
4576 defsubr (&Sinsert_and_inherit);
4577 defsubr (&Sinsert_and_inherit_before_markers);
4578 defsubr (&Sinsert_char);
4579 defsubr (&Sinsert_byte);
4580
4581 defsubr (&Sngettext);
4582
4583 defsubr (&Suser_login_name);
4584 defsubr (&Sgroup_name);
4585 defsubr (&Suser_real_login_name);
4586 defsubr (&Suser_uid);
4587 defsubr (&Suser_real_uid);
4588 defsubr (&Sgroup_gid);
4589 defsubr (&Sgroup_real_gid);
4590 defsubr (&Suser_full_name);
4591 defsubr (&Semacs_pid);
4592 defsubr (&Ssystem_name);
4593 defsubr (&Smessage);
4594 defsubr (&Smessage_box);
4595 defsubr (&Smessage_or_box);
4596 defsubr (&Scurrent_message);
4597 defsubr (&Sformat);
4598 defsubr (&Sformat_message);
4599
4600 defsubr (&Sinsert_buffer_substring);
4601 defsubr (&Scompare_buffer_substrings);
4602 defsubr (&Sreplace_buffer_contents);
4603 defsubr (&Ssubst_char_in_region);
4604 defsubr (&Stranslate_region_internal);
4605 defsubr (&Sdelete_region);
4606 defsubr (&Sdelete_and_extract_region);
4607 defsubr (&Swiden);
4608 defsubr (&Snarrow_to_region);
4609 defsubr (&Ssave_restriction);
4610 defsubr (&Stranspose_regions);
4611 }
4612