* lisp/emacs-lisp/package.el: New quickstart feature
[emacs.git] / src / editfns.c
blob7e35fe879728023a1798fe337b47f17f7ef1350d
1 /* Lisp functions pertaining to editing. -*- coding: utf-8 -*-
3 Copyright (C) 1985-1987, 1989, 1993-2018 Free Software Foundation, Inc.
5 This file is part of GNU Emacs.
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.
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.
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/>. */
21 #include <config.h>
22 #include <sys/types.h>
23 #include <stdio.h>
25 #ifdef HAVE_PWD_H
26 #include <pwd.h>
27 #include <grp.h>
28 #endif
30 #include <unistd.h>
32 #ifdef HAVE_SYS_UTSNAME_H
33 #include <sys/utsname.h>
34 #endif
36 #include "lisp.h"
38 /* systime.h includes <sys/time.h> which, on some systems, is required
39 for <sys/resource.h>; thus systime.h must be included before
40 <sys/resource.h> */
41 #include "systime.h"
43 #if defined HAVE_SYS_RESOURCE_H
44 #include <sys/resource.h>
45 #endif
47 #include <errno.h>
48 #include <float.h>
49 #include <limits.h>
51 #ifdef HAVE_TIMEZONE_T
52 # include <sys/param.h>
53 # if defined __NetBSD_Version__ && __NetBSD_Version__ < 700000000
54 # define HAVE_TZALLOC_BUG true
55 # endif
56 #endif
57 #ifndef HAVE_TZALLOC_BUG
58 # define HAVE_TZALLOC_BUG false
59 #endif
61 #include <c-ctype.h>
62 #include <intprops.h>
63 #include <stdlib.h>
64 #include <strftime.h>
65 #include <verify.h>
67 #include "composite.h"
68 #include "intervals.h"
69 #include "ptr-bounds.h"
70 #include "character.h"
71 #include "buffer.h"
72 #include "coding.h"
73 #include "window.h"
74 #include "blockinput.h"
76 #define TM_YEAR_BASE 1900
78 #ifdef WINDOWSNT
79 extern Lisp_Object w32_get_internal_run_time (void);
80 #endif
82 static struct lisp_time lisp_time_struct (Lisp_Object, int *);
83 static Lisp_Object format_time_string (char const *, ptrdiff_t, struct timespec,
84 Lisp_Object, struct tm *);
85 static long int tm_gmtoff (struct tm *);
86 static int tm_diff (struct tm *, struct tm *);
87 static void update_buffer_properties (ptrdiff_t, ptrdiff_t);
88 static Lisp_Object styled_format (ptrdiff_t, Lisp_Object *, bool);
90 #ifndef HAVE_TM_GMTOFF
91 # define HAVE_TM_GMTOFF false
92 #endif
94 enum { tzeqlen = sizeof "TZ=" - 1 };
96 /* Time zones equivalent to current local time and to UTC, respectively. */
97 static timezone_t local_tz;
98 static timezone_t const utc_tz = 0;
100 /* The cached value of Vsystem_name. This is used only to compare it
101 to Vsystem_name, so it need not be visible to the GC. */
102 static Lisp_Object cached_system_name;
104 static void
105 init_and_cache_system_name (void)
107 init_system_name ();
108 cached_system_name = Vsystem_name;
111 static struct tm *
112 emacs_localtime_rz (timezone_t tz, time_t const *t, struct tm *tm)
114 tm = localtime_rz (tz, t, tm);
115 if (!tm && errno == ENOMEM)
116 memory_full (SIZE_MAX);
117 return tm;
120 static time_t
121 emacs_mktime_z (timezone_t tz, struct tm *tm)
123 errno = 0;
124 time_t t = mktime_z (tz, tm);
125 if (t == (time_t) -1 && errno == ENOMEM)
126 memory_full (SIZE_MAX);
127 return t;
130 static _Noreturn void
131 invalid_time_zone_specification (Lisp_Object zone)
133 xsignal2 (Qerror, build_string ("Invalid time zone specification"), zone);
136 /* Free a timezone, except do not free the time zone for local time.
137 Freeing utc_tz is also a no-op. */
138 static void
139 xtzfree (timezone_t tz)
141 if (tz != local_tz)
142 tzfree (tz);
145 /* Convert the Lisp time zone rule ZONE to a timezone_t object.
146 The returned value either is 0, or is LOCAL_TZ, or is newly allocated.
147 If SETTZ, set Emacs local time to the time zone rule; otherwise,
148 the caller should eventually pass the returned value to xtzfree. */
149 static timezone_t
150 tzlookup (Lisp_Object zone, bool settz)
152 static char const tzbuf_format[] = "<%+.*"pI"d>%s%"pI"d:%02d:%02d";
153 char const *trailing_tzbuf_format = tzbuf_format + sizeof "<%+.*"pI"d" - 1;
154 char tzbuf[sizeof tzbuf_format + 2 * INT_STRLEN_BOUND (EMACS_INT)];
155 char const *zone_string;
156 timezone_t new_tz;
158 if (NILP (zone))
159 return local_tz;
160 else if (EQ (zone, Qt) || EQ (zone, make_number (0)))
162 zone_string = "UTC0";
163 new_tz = utc_tz;
165 else
167 bool plain_integer = INTEGERP (zone);
169 if (EQ (zone, Qwall))
170 zone_string = 0;
171 else if (STRINGP (zone))
172 zone_string = SSDATA (ENCODE_SYSTEM (zone));
173 else if (plain_integer || (CONSP (zone) && INTEGERP (XCAR (zone))
174 && CONSP (XCDR (zone))))
176 Lisp_Object abbr;
177 if (!plain_integer)
179 abbr = XCAR (XCDR (zone));
180 zone = XCAR (zone);
183 EMACS_INT abszone = eabs (XINT (zone)), hour = abszone / (60 * 60);
184 int hour_remainder = abszone % (60 * 60);
185 int min = hour_remainder / 60, sec = hour_remainder % 60;
187 if (plain_integer)
189 int prec = 2;
190 EMACS_INT numzone = hour;
191 if (hour_remainder != 0)
193 prec += 2, numzone = 100 * numzone + min;
194 if (sec != 0)
195 prec += 2, numzone = 100 * numzone + sec;
197 sprintf (tzbuf, tzbuf_format, prec,
198 XINT (zone) < 0 ? -numzone : numzone,
199 &"-"[XINT (zone) < 0], hour, min, sec);
200 zone_string = tzbuf;
202 else
204 AUTO_STRING (leading, "<");
205 AUTO_STRING_WITH_LEN (trailing, tzbuf,
206 sprintf (tzbuf, trailing_tzbuf_format,
207 &"-"[XINT (zone) < 0],
208 hour, min, sec));
209 zone_string = SSDATA (concat3 (leading, ENCODE_SYSTEM (abbr),
210 trailing));
213 else
214 invalid_time_zone_specification (zone);
216 new_tz = tzalloc (zone_string);
218 if (HAVE_TZALLOC_BUG && !new_tz && errno != ENOMEM && plain_integer
219 && XINT (zone) % (60 * 60) == 0)
221 /* tzalloc mishandles POSIX strings; fall back on tzdb if
222 possible (Bug#30738). */
223 sprintf (tzbuf, "Etc/GMT%+"pI"d", - (XINT (zone) / (60 * 60)));
224 new_tz = tzalloc (zone_string);
227 if (!new_tz)
229 if (errno == ENOMEM)
230 memory_full (SIZE_MAX);
231 invalid_time_zone_specification (zone);
235 if (settz)
237 block_input ();
238 emacs_setenv_TZ (zone_string);
239 tzset ();
240 timezone_t old_tz = local_tz;
241 local_tz = new_tz;
242 tzfree (old_tz);
243 unblock_input ();
246 return new_tz;
249 void
250 init_editfns (bool dumping)
252 #if !defined CANNOT_DUMP
253 /* A valid but unlikely setting for the TZ environment variable.
254 It is OK (though a bit slower) if the user chooses this value. */
255 static char dump_tz_string[] = "TZ=UtC0";
256 #endif
258 const char *user_name;
259 register char *p;
260 struct passwd *pw; /* password entry for the current user */
261 Lisp_Object tem;
263 /* Set up system_name even when dumping. */
264 init_and_cache_system_name ();
266 #ifndef CANNOT_DUMP
267 /* When just dumping out, set the time zone to a known unlikely value
268 and skip the rest of this function. */
269 if (dumping)
271 xputenv (dump_tz_string);
272 tzset ();
273 return;
275 #endif
277 char *tz = getenv ("TZ");
279 #if !defined CANNOT_DUMP
280 /* If the execution TZ happens to be the same as the dump TZ,
281 change it to some other value and then change it back,
282 to force the underlying implementation to reload the TZ info.
283 This is needed on implementations that load TZ info from files,
284 since the TZ file contents may differ between dump and execution. */
285 if (tz && strcmp (tz, &dump_tz_string[tzeqlen]) == 0)
287 ++*tz;
288 tzset ();
289 --*tz;
291 #endif
293 /* Set the time zone rule now, so that the call to putenv is done
294 before multiple threads are active. */
295 tzlookup (tz ? build_string (tz) : Qwall, true);
297 pw = getpwuid (getuid ());
298 #ifdef MSDOS
299 /* We let the real user name default to "root" because that's quite
300 accurate on MS-DOS and because it lets Emacs find the init file.
301 (The DVX libraries override the Djgpp libraries here.) */
302 Vuser_real_login_name = build_string (pw ? pw->pw_name : "root");
303 #else
304 Vuser_real_login_name = build_string (pw ? pw->pw_name : "unknown");
305 #endif
307 /* Get the effective user name, by consulting environment variables,
308 or the effective uid if those are unset. */
309 user_name = getenv ("LOGNAME");
310 if (!user_name)
311 #ifdef WINDOWSNT
312 user_name = getenv ("USERNAME"); /* it's USERNAME on NT */
313 #else /* WINDOWSNT */
314 user_name = getenv ("USER");
315 #endif /* WINDOWSNT */
316 if (!user_name)
318 pw = getpwuid (geteuid ());
319 user_name = pw ? pw->pw_name : "unknown";
321 Vuser_login_name = build_string (user_name);
323 /* If the user name claimed in the environment vars differs from
324 the real uid, use the claimed name to find the full name. */
325 tem = Fstring_equal (Vuser_login_name, Vuser_real_login_name);
326 if (! NILP (tem))
327 tem = Vuser_login_name;
328 else
330 uid_t euid = geteuid ();
331 tem = make_fixnum_or_float (euid);
333 Vuser_full_name = Fuser_full_name (tem);
335 p = getenv ("NAME");
336 if (p)
337 Vuser_full_name = build_string (p);
338 else if (NILP (Vuser_full_name))
339 Vuser_full_name = build_string ("unknown");
341 #ifdef HAVE_SYS_UTSNAME_H
343 struct utsname uts;
344 uname (&uts);
345 Voperating_system_release = build_string (uts.release);
347 #else
348 Voperating_system_release = Qnil;
349 #endif
352 DEFUN ("char-to-string", Fchar_to_string, Schar_to_string, 1, 1, 0,
353 doc: /* Convert arg CHAR to a string containing that character.
354 usage: (char-to-string CHAR) */)
355 (Lisp_Object character)
357 int c, len;
358 unsigned char str[MAX_MULTIBYTE_LENGTH];
360 CHECK_CHARACTER (character);
361 c = XFASTINT (character);
363 len = CHAR_STRING (c, str);
364 return make_string_from_bytes ((char *) str, 1, len);
367 DEFUN ("byte-to-string", Fbyte_to_string, Sbyte_to_string, 1, 1, 0,
368 doc: /* Convert arg BYTE to a unibyte string containing that byte. */)
369 (Lisp_Object byte)
371 unsigned char b;
372 CHECK_NUMBER (byte);
373 if (XINT (byte) < 0 || XINT (byte) > 255)
374 error ("Invalid byte");
375 b = XINT (byte);
376 return make_string_from_bytes ((char *) &b, 1, 1);
379 DEFUN ("string-to-char", Fstring_to_char, Sstring_to_char, 1, 1, 0,
380 doc: /* Return the first character in STRING. */)
381 (register Lisp_Object string)
383 register Lisp_Object val;
384 CHECK_STRING (string);
385 if (SCHARS (string))
387 if (STRING_MULTIBYTE (string))
388 XSETFASTINT (val, STRING_CHAR (SDATA (string)));
389 else
390 XSETFASTINT (val, SREF (string, 0));
392 else
393 XSETFASTINT (val, 0);
394 return val;
397 DEFUN ("point", Fpoint, Spoint, 0, 0, 0,
398 doc: /* Return value of point, as an integer.
399 Beginning of buffer is position (point-min). */)
400 (void)
402 Lisp_Object temp;
403 XSETFASTINT (temp, PT);
404 return temp;
407 DEFUN ("point-marker", Fpoint_marker, Spoint_marker, 0, 0, 0,
408 doc: /* Return value of point, as a marker object. */)
409 (void)
411 return build_marker (current_buffer, PT, PT_BYTE);
414 DEFUN ("goto-char", Fgoto_char, Sgoto_char, 1, 1, "NGoto char: ",
415 doc: /* Set point to POSITION, a number or marker.
416 Beginning of buffer is position (point-min), end is (point-max).
418 The return value is POSITION. */)
419 (register Lisp_Object position)
421 if (MARKERP (position))
422 set_point_from_marker (position);
423 else if (INTEGERP (position))
424 SET_PT (clip_to_bounds (BEGV, XINT (position), ZV));
425 else
426 wrong_type_argument (Qinteger_or_marker_p, position);
427 return position;
431 /* Return the start or end position of the region.
432 BEGINNINGP means return the start.
433 If there is no region active, signal an error. */
435 static Lisp_Object
436 region_limit (bool beginningp)
438 Lisp_Object m;
440 if (!NILP (Vtransient_mark_mode)
441 && NILP (Vmark_even_if_inactive)
442 && NILP (BVAR (current_buffer, mark_active)))
443 xsignal0 (Qmark_inactive);
445 m = Fmarker_position (BVAR (current_buffer, mark));
446 if (NILP (m))
447 error ("The mark is not set now, so there is no region");
449 /* Clip to the current narrowing (bug#11770). */
450 return make_number ((PT < XFASTINT (m)) == beginningp
451 ? PT
452 : clip_to_bounds (BEGV, XFASTINT (m), ZV));
455 DEFUN ("region-beginning", Fregion_beginning, Sregion_beginning, 0, 0, 0,
456 doc: /* Return the integer value of point or mark, whichever is smaller. */)
457 (void)
459 return region_limit (1);
462 DEFUN ("region-end", Fregion_end, Sregion_end, 0, 0, 0,
463 doc: /* Return the integer value of point or mark, whichever is larger. */)
464 (void)
466 return region_limit (0);
469 DEFUN ("mark-marker", Fmark_marker, Smark_marker, 0, 0, 0,
470 doc: /* Return this buffer's mark, as a marker object.
471 Watch out! Moving this marker changes the mark position.
472 If you set the marker not to point anywhere, the buffer will have no mark. */)
473 (void)
475 return BVAR (current_buffer, mark);
479 /* Find all the overlays in the current buffer that touch position POS.
480 Return the number found, and store them in a vector in VEC
481 of length LEN. */
483 static ptrdiff_t
484 overlays_around (EMACS_INT pos, Lisp_Object *vec, ptrdiff_t len)
486 Lisp_Object overlay, start, end;
487 struct Lisp_Overlay *tail;
488 ptrdiff_t startpos, endpos;
489 ptrdiff_t idx = 0;
491 for (tail = current_buffer->overlays_before; tail; tail = tail->next)
493 XSETMISC (overlay, tail);
495 end = OVERLAY_END (overlay);
496 endpos = OVERLAY_POSITION (end);
497 if (endpos < pos)
498 break;
499 start = OVERLAY_START (overlay);
500 startpos = OVERLAY_POSITION (start);
501 if (startpos <= pos)
503 if (idx < len)
504 vec[idx] = overlay;
505 /* Keep counting overlays even if we can't return them all. */
506 idx++;
510 for (tail = current_buffer->overlays_after; tail; tail = tail->next)
512 XSETMISC (overlay, tail);
514 start = OVERLAY_START (overlay);
515 startpos = OVERLAY_POSITION (start);
516 if (pos < startpos)
517 break;
518 end = OVERLAY_END (overlay);
519 endpos = OVERLAY_POSITION (end);
520 if (pos <= endpos)
522 if (idx < len)
523 vec[idx] = overlay;
524 idx++;
528 return idx;
531 DEFUN ("get-pos-property", Fget_pos_property, Sget_pos_property, 2, 3, 0,
532 doc: /* Return the value of POSITION's property PROP, in OBJECT.
533 Almost identical to `get-char-property' except for the following difference:
534 Whereas `get-char-property' returns the property of the char at (i.e. right
535 after) POSITION, this pays attention to properties's stickiness and overlays's
536 advancement settings, in order to find the property of POSITION itself,
537 i.e. the property that a char would inherit if it were inserted
538 at POSITION. */)
539 (Lisp_Object position, register Lisp_Object prop, Lisp_Object object)
541 CHECK_NUMBER_COERCE_MARKER (position);
543 if (NILP (object))
544 XSETBUFFER (object, current_buffer);
545 else if (WINDOWP (object))
546 object = XWINDOW (object)->contents;
548 if (!BUFFERP (object))
549 /* pos-property only makes sense in buffers right now, since strings
550 have no overlays and no notion of insertion for which stickiness
551 could be obeyed. */
552 return Fget_text_property (position, prop, object);
553 else
555 EMACS_INT posn = XINT (position);
556 ptrdiff_t noverlays;
557 Lisp_Object *overlay_vec, tem;
558 struct buffer *obuf = current_buffer;
559 USE_SAFE_ALLOCA;
561 set_buffer_temp (XBUFFER (object));
563 /* First try with room for 40 overlays. */
564 Lisp_Object overlay_vecbuf[40];
565 noverlays = ARRAYELTS (overlay_vecbuf);
566 overlay_vec = overlay_vecbuf;
567 noverlays = overlays_around (posn, overlay_vec, noverlays);
569 /* If there are more than 40,
570 make enough space for all, and try again. */
571 if (ARRAYELTS (overlay_vecbuf) < noverlays)
573 SAFE_ALLOCA_LISP (overlay_vec, noverlays);
574 noverlays = overlays_around (posn, overlay_vec, noverlays);
576 noverlays = sort_overlays (overlay_vec, noverlays, NULL);
578 set_buffer_temp (obuf);
580 /* Now check the overlays in order of decreasing priority. */
581 while (--noverlays >= 0)
583 Lisp_Object ol = overlay_vec[noverlays];
584 tem = Foverlay_get (ol, prop);
585 if (!NILP (tem))
587 /* Check the overlay is indeed active at point. */
588 Lisp_Object start = OVERLAY_START (ol), finish = OVERLAY_END (ol);
589 if ((OVERLAY_POSITION (start) == posn
590 && XMARKER (start)->insertion_type == 1)
591 || (OVERLAY_POSITION (finish) == posn
592 && XMARKER (finish)->insertion_type == 0))
593 ; /* The overlay will not cover a char inserted at point. */
594 else
596 SAFE_FREE ();
597 return tem;
601 SAFE_FREE ();
603 { /* Now check the text properties. */
604 int stickiness = text_property_stickiness (prop, position, object);
605 if (stickiness > 0)
606 return Fget_text_property (position, prop, object);
607 else if (stickiness < 0
608 && XINT (position) > BUF_BEGV (XBUFFER (object)))
609 return Fget_text_property (make_number (XINT (position) - 1),
610 prop, object);
611 else
612 return Qnil;
617 /* Find the field surrounding POS in *BEG and *END. If POS is nil,
618 the value of point is used instead. If BEG or END is null,
619 means don't store the beginning or end of the field.
621 BEG_LIMIT and END_LIMIT serve to limit the ranged of the returned
622 results; they do not effect boundary behavior.
624 If MERGE_AT_BOUNDARY is non-nil, then if POS is at the very first
625 position of a field, then the beginning of the previous field is
626 returned instead of the beginning of POS's field (since the end of a
627 field is actually also the beginning of the next input field, this
628 behavior is sometimes useful). Additionally in the MERGE_AT_BOUNDARY
629 non-nil case, if two fields are separated by a field with the special
630 value `boundary', and POS lies within it, then the two separated
631 fields are considered to be adjacent, and POS between them, when
632 finding the beginning and ending of the "merged" field.
634 Either BEG or END may be 0, in which case the corresponding value
635 is not stored. */
637 static void
638 find_field (Lisp_Object pos, Lisp_Object merge_at_boundary,
639 Lisp_Object beg_limit,
640 ptrdiff_t *beg, Lisp_Object end_limit, ptrdiff_t *end)
642 /* Fields right before and after the point. */
643 Lisp_Object before_field, after_field;
644 /* True if POS counts as the start of a field. */
645 bool at_field_start = 0;
646 /* True if POS counts as the end of a field. */
647 bool at_field_end = 0;
649 if (NILP (pos))
650 XSETFASTINT (pos, PT);
651 else
652 CHECK_NUMBER_COERCE_MARKER (pos);
654 after_field
655 = get_char_property_and_overlay (pos, Qfield, Qnil, NULL);
656 before_field
657 = (XFASTINT (pos) > BEGV
658 ? get_char_property_and_overlay (make_number (XINT (pos) - 1),
659 Qfield, Qnil, NULL)
660 /* Using nil here would be a more obvious choice, but it would
661 fail when the buffer starts with a non-sticky field. */
662 : after_field);
664 /* See if we need to handle the case where MERGE_AT_BOUNDARY is nil
665 and POS is at beginning of a field, which can also be interpreted
666 as the end of the previous field. Note that the case where if
667 MERGE_AT_BOUNDARY is non-nil (see function comment) is actually the
668 more natural one; then we avoid treating the beginning of a field
669 specially. */
670 if (NILP (merge_at_boundary))
672 Lisp_Object field = Fget_pos_property (pos, Qfield, Qnil);
673 if (!EQ (field, after_field))
674 at_field_end = 1;
675 if (!EQ (field, before_field))
676 at_field_start = 1;
677 if (NILP (field) && at_field_start && at_field_end)
678 /* If an inserted char would have a nil field while the surrounding
679 text is non-nil, we're probably not looking at a
680 zero-length field, but instead at a non-nil field that's
681 not intended for editing (such as comint's prompts). */
682 at_field_end = at_field_start = 0;
685 /* Note about special `boundary' fields:
687 Consider the case where the point (`.') is between the fields `x' and `y':
689 xxxx.yyyy
691 In this situation, if merge_at_boundary is non-nil, consider the
692 `x' and `y' fields as forming one big merged field, and so the end
693 of the field is the end of `y'.
695 However, if `x' and `y' are separated by a special `boundary' field
696 (a field with a `field' char-property of 'boundary), then ignore
697 this special field when merging adjacent fields. Here's the same
698 situation, but with a `boundary' field between the `x' and `y' fields:
700 xxx.BBBByyyy
702 Here, if point is at the end of `x', the beginning of `y', or
703 anywhere in-between (within the `boundary' field), merge all
704 three fields and consider the beginning as being the beginning of
705 the `x' field, and the end as being the end of the `y' field. */
707 if (beg)
709 if (at_field_start)
710 /* POS is at the edge of a field, and we should consider it as
711 the beginning of the following field. */
712 *beg = XFASTINT (pos);
713 else
714 /* Find the previous field boundary. */
716 Lisp_Object p = pos;
717 if (!NILP (merge_at_boundary) && EQ (before_field, Qboundary))
718 /* Skip a `boundary' field. */
719 p = Fprevious_single_char_property_change (p, Qfield, Qnil,
720 beg_limit);
722 p = Fprevious_single_char_property_change (p, Qfield, Qnil,
723 beg_limit);
724 *beg = NILP (p) ? BEGV : XFASTINT (p);
728 if (end)
730 if (at_field_end)
731 /* POS is at the edge of a field, and we should consider it as
732 the end of the previous field. */
733 *end = XFASTINT (pos);
734 else
735 /* Find the next field boundary. */
737 if (!NILP (merge_at_boundary) && EQ (after_field, Qboundary))
738 /* Skip a `boundary' field. */
739 pos = Fnext_single_char_property_change (pos, Qfield, Qnil,
740 end_limit);
742 pos = Fnext_single_char_property_change (pos, Qfield, Qnil,
743 end_limit);
744 *end = NILP (pos) ? ZV : XFASTINT (pos);
750 DEFUN ("delete-field", Fdelete_field, Sdelete_field, 0, 1, 0,
751 doc: /* Delete the field surrounding POS.
752 A field is a region of text with the same `field' property.
753 If POS is nil, the value of point is used for POS. */)
754 (Lisp_Object pos)
756 ptrdiff_t beg, end;
757 find_field (pos, Qnil, Qnil, &beg, Qnil, &end);
758 if (beg != end)
759 del_range (beg, end);
760 return Qnil;
763 DEFUN ("field-string", Ffield_string, Sfield_string, 0, 1, 0,
764 doc: /* Return the contents of the field surrounding POS as a string.
765 A field is a region of text with the same `field' property.
766 If POS is nil, the value of point is used for POS. */)
767 (Lisp_Object pos)
769 ptrdiff_t beg, end;
770 find_field (pos, Qnil, Qnil, &beg, Qnil, &end);
771 return make_buffer_string (beg, end, 1);
774 DEFUN ("field-string-no-properties", Ffield_string_no_properties, Sfield_string_no_properties, 0, 1, 0,
775 doc: /* Return the contents of the field around POS, without text properties.
776 A field is a region of text with the same `field' property.
777 If POS is nil, the value of point is used for POS. */)
778 (Lisp_Object pos)
780 ptrdiff_t beg, end;
781 find_field (pos, Qnil, Qnil, &beg, Qnil, &end);
782 return make_buffer_string (beg, end, 0);
785 DEFUN ("field-beginning", Ffield_beginning, Sfield_beginning, 0, 3, 0,
786 doc: /* Return the beginning of the field surrounding POS.
787 A field is a region of text with the same `field' property.
788 If POS is nil, the value of point is used for POS.
789 If ESCAPE-FROM-EDGE is non-nil and POS is at the beginning of its
790 field, then the beginning of the *previous* field is returned.
791 If LIMIT is non-nil, it is a buffer position; if the beginning of the field
792 is before LIMIT, then LIMIT will be returned instead. */)
793 (Lisp_Object pos, Lisp_Object escape_from_edge, Lisp_Object limit)
795 ptrdiff_t beg;
796 find_field (pos, escape_from_edge, limit, &beg, Qnil, 0);
797 return make_number (beg);
800 DEFUN ("field-end", Ffield_end, Sfield_end, 0, 3, 0,
801 doc: /* Return the end of the field surrounding POS.
802 A field is a region of text with the same `field' property.
803 If POS is nil, the value of point is used for POS.
804 If ESCAPE-FROM-EDGE is non-nil and POS is at the end of its field,
805 then the end of the *following* field is returned.
806 If LIMIT is non-nil, it is a buffer position; if the end of the field
807 is after LIMIT, then LIMIT will be returned instead. */)
808 (Lisp_Object pos, Lisp_Object escape_from_edge, Lisp_Object limit)
810 ptrdiff_t end;
811 find_field (pos, escape_from_edge, Qnil, 0, limit, &end);
812 return make_number (end);
815 DEFUN ("constrain-to-field", Fconstrain_to_field, Sconstrain_to_field, 2, 5, 0,
816 doc: /* Return the position closest to NEW-POS that is in the same field as OLD-POS.
817 A field is a region of text with the same `field' property.
819 If NEW-POS is nil, then use the current point instead, and move point
820 to the resulting constrained position, in addition to returning that
821 position.
823 If OLD-POS is at the boundary of two fields, then the allowable
824 positions for NEW-POS depends on the value of the optional argument
825 ESCAPE-FROM-EDGE: If ESCAPE-FROM-EDGE is nil, then NEW-POS is
826 constrained to the field that has the same `field' char-property
827 as any new characters inserted at OLD-POS, whereas if ESCAPE-FROM-EDGE
828 is non-nil, NEW-POS is constrained to the union of the two adjacent
829 fields. Additionally, if two fields are separated by another field with
830 the special value `boundary', then any point within this special field is
831 also considered to be `on the boundary'.
833 If the optional argument ONLY-IN-LINE is non-nil and constraining
834 NEW-POS would move it to a different line, NEW-POS is returned
835 unconstrained. This is useful for commands that move by line, like
836 \\[next-line] or \\[beginning-of-line], which should generally respect field boundaries
837 only in the case where they can still move to the right line.
839 If the optional argument INHIBIT-CAPTURE-PROPERTY is non-nil, and OLD-POS has
840 a non-nil property of that name, then any field boundaries are ignored.
842 Field boundaries are not noticed if `inhibit-field-text-motion' is non-nil. */)
843 (Lisp_Object new_pos, Lisp_Object old_pos, Lisp_Object escape_from_edge,
844 Lisp_Object only_in_line, Lisp_Object inhibit_capture_property)
846 /* If non-zero, then the original point, before re-positioning. */
847 ptrdiff_t orig_point = 0;
848 bool fwd;
849 Lisp_Object prev_old, prev_new;
851 if (NILP (new_pos))
852 /* Use the current point, and afterwards, set it. */
854 orig_point = PT;
855 XSETFASTINT (new_pos, PT);
858 CHECK_NUMBER_COERCE_MARKER (new_pos);
859 CHECK_NUMBER_COERCE_MARKER (old_pos);
861 fwd = (XINT (new_pos) > XINT (old_pos));
863 prev_old = make_number (XINT (old_pos) - 1);
864 prev_new = make_number (XINT (new_pos) - 1);
866 if (NILP (Vinhibit_field_text_motion)
867 && !EQ (new_pos, old_pos)
868 && (!NILP (Fget_char_property (new_pos, Qfield, Qnil))
869 || !NILP (Fget_char_property (old_pos, Qfield, Qnil))
870 /* To recognize field boundaries, we must also look at the
871 previous positions; we could use `Fget_pos_property'
872 instead, but in itself that would fail inside non-sticky
873 fields (like comint prompts). */
874 || (XFASTINT (new_pos) > BEGV
875 && !NILP (Fget_char_property (prev_new, Qfield, Qnil)))
876 || (XFASTINT (old_pos) > BEGV
877 && !NILP (Fget_char_property (prev_old, Qfield, Qnil))))
878 && (NILP (inhibit_capture_property)
879 /* Field boundaries are again a problem; but now we must
880 decide the case exactly, so we need to call
881 `get_pos_property' as well. */
882 || (NILP (Fget_pos_property (old_pos, inhibit_capture_property, Qnil))
883 && (XFASTINT (old_pos) <= BEGV
884 || NILP (Fget_char_property
885 (old_pos, inhibit_capture_property, Qnil))
886 || NILP (Fget_char_property
887 (prev_old, inhibit_capture_property, Qnil))))))
888 /* It is possible that NEW_POS is not within the same field as
889 OLD_POS; try to move NEW_POS so that it is. */
891 ptrdiff_t shortage;
892 Lisp_Object field_bound;
894 if (fwd)
895 field_bound = Ffield_end (old_pos, escape_from_edge, new_pos);
896 else
897 field_bound = Ffield_beginning (old_pos, escape_from_edge, new_pos);
899 if (/* See if ESCAPE_FROM_EDGE caused FIELD_BOUND to jump to the
900 other side of NEW_POS, which would mean that NEW_POS is
901 already acceptable, and it's not necessary to constrain it
902 to FIELD_BOUND. */
903 ((XFASTINT (field_bound) < XFASTINT (new_pos)) ? fwd : !fwd)
904 /* NEW_POS should be constrained, but only if either
905 ONLY_IN_LINE is nil (in which case any constraint is OK),
906 or NEW_POS and FIELD_BOUND are on the same line (in which
907 case the constraint is OK even if ONLY_IN_LINE is non-nil). */
908 && (NILP (only_in_line)
909 /* This is the ONLY_IN_LINE case, check that NEW_POS and
910 FIELD_BOUND are on the same line by seeing whether
911 there's an intervening newline or not. */
912 || (find_newline (XFASTINT (new_pos), -1,
913 XFASTINT (field_bound), -1,
914 fwd ? -1 : 1, &shortage, NULL, 1),
915 shortage != 0)))
916 /* Constrain NEW_POS to FIELD_BOUND. */
917 new_pos = field_bound;
919 if (orig_point && XFASTINT (new_pos) != orig_point)
920 /* The NEW_POS argument was originally nil, so automatically set PT. */
921 SET_PT (XFASTINT (new_pos));
924 return new_pos;
928 DEFUN ("line-beginning-position",
929 Fline_beginning_position, Sline_beginning_position, 0, 1, 0,
930 doc: /* Return the character position of the first character on the current line.
931 With optional argument N, scan forward N - 1 lines first.
932 If the scan reaches the end of the buffer, return that position.
934 This function ignores text display directionality; it returns the
935 position of the first character in logical order, i.e. the smallest
936 character position on the line.
938 This function constrains the returned position to the current field
939 unless that position would be on a different line than the original,
940 unconstrained result. If N is nil or 1, and a front-sticky field
941 starts at point, the scan stops as soon as it starts. To ignore field
942 boundaries, bind `inhibit-field-text-motion' to t.
944 This function does not move point. */)
945 (Lisp_Object n)
947 ptrdiff_t charpos, bytepos;
949 if (NILP (n))
950 XSETFASTINT (n, 1);
951 else
952 CHECK_NUMBER (n);
954 scan_newline_from_point (XINT (n) - 1, &charpos, &bytepos);
956 /* Return END constrained to the current input field. */
957 return Fconstrain_to_field (make_number (charpos), make_number (PT),
958 XINT (n) != 1 ? Qt : Qnil,
959 Qt, Qnil);
962 DEFUN ("line-end-position", Fline_end_position, Sline_end_position, 0, 1, 0,
963 doc: /* Return the character position of the last character on the current line.
964 With argument N not nil or 1, move forward N - 1 lines first.
965 If scan reaches end of buffer, return that position.
967 This function ignores text display directionality; it returns the
968 position of the last character in logical order, i.e. the largest
969 character position on the line.
971 This function constrains the returned position to the current field
972 unless that would be on a different line than the original,
973 unconstrained result. If N is nil or 1, and a rear-sticky field ends
974 at point, the scan stops as soon as it starts. To ignore field
975 boundaries bind `inhibit-field-text-motion' to t.
977 This function does not move point. */)
978 (Lisp_Object n)
980 ptrdiff_t clipped_n;
981 ptrdiff_t end_pos;
982 ptrdiff_t orig = PT;
984 if (NILP (n))
985 XSETFASTINT (n, 1);
986 else
987 CHECK_NUMBER (n);
989 clipped_n = clip_to_bounds (PTRDIFF_MIN + 1, XINT (n), PTRDIFF_MAX);
990 end_pos = find_before_next_newline (orig, 0, clipped_n - (clipped_n <= 0),
991 NULL);
993 /* Return END_POS constrained to the current input field. */
994 return Fconstrain_to_field (make_number (end_pos), make_number (orig),
995 Qnil, Qt, Qnil);
998 /* Save current buffer state for `save-excursion' special form.
999 We (ab)use Lisp_Misc_Save_Value to allow explicit free and so
1000 offload some work from GC. */
1002 Lisp_Object
1003 save_excursion_save (void)
1005 return make_save_obj_obj_obj_obj
1006 (Fpoint_marker (),
1007 Qnil,
1008 /* Selected window if current buffer is shown in it, nil otherwise. */
1009 (EQ (XWINDOW (selected_window)->contents, Fcurrent_buffer ())
1010 ? selected_window : Qnil),
1011 Qnil);
1014 /* Restore saved buffer before leaving `save-excursion' special form. */
1016 void
1017 save_excursion_restore (Lisp_Object info)
1019 Lisp_Object tem, tem1;
1021 tem = Fmarker_buffer (XSAVE_OBJECT (info, 0));
1022 /* If we're unwinding to top level, saved buffer may be deleted. This
1023 means that all of its markers are unchained and so tem is nil. */
1024 if (NILP (tem))
1025 goto out;
1027 Fset_buffer (tem);
1029 /* Point marker. */
1030 tem = XSAVE_OBJECT (info, 0);
1031 Fgoto_char (tem);
1032 unchain_marker (XMARKER (tem));
1034 /* If buffer was visible in a window, and a different window was
1035 selected, and the old selected window is still showing this
1036 buffer, restore point in that window. */
1037 tem = XSAVE_OBJECT (info, 2);
1038 if (WINDOWP (tem)
1039 && !EQ (tem, selected_window)
1040 && (tem1 = XWINDOW (tem)->contents,
1041 (/* Window is live... */
1042 BUFFERP (tem1)
1043 /* ...and it shows the current buffer. */
1044 && XBUFFER (tem1) == current_buffer)))
1045 Fset_window_point (tem, make_number (PT));
1047 out:
1049 free_misc (info);
1052 DEFUN ("save-excursion", Fsave_excursion, Ssave_excursion, 0, UNEVALLED, 0,
1053 doc: /* Save point, and current buffer; execute BODY; restore those things.
1054 Executes BODY just like `progn'.
1055 The values of point and the current buffer are restored
1056 even in case of abnormal exit (throw or error).
1058 If you only want to save the current buffer but not point,
1059 then just use `save-current-buffer', or even `with-current-buffer'.
1061 Before Emacs 25.1, `save-excursion' used to save the mark state.
1062 To save the mark state as well as point and the current buffer, use
1063 `save-mark-and-excursion'.
1065 usage: (save-excursion &rest BODY) */)
1066 (Lisp_Object args)
1068 register Lisp_Object val;
1069 ptrdiff_t count = SPECPDL_INDEX ();
1071 record_unwind_protect (save_excursion_restore, save_excursion_save ());
1073 val = Fprogn (args);
1074 return unbind_to (count, val);
1077 DEFUN ("save-current-buffer", Fsave_current_buffer, Ssave_current_buffer, 0, UNEVALLED, 0,
1078 doc: /* Record which buffer is current; execute BODY; make that buffer current.
1079 BODY is executed just like `progn'.
1080 usage: (save-current-buffer &rest BODY) */)
1081 (Lisp_Object args)
1083 ptrdiff_t count = SPECPDL_INDEX ();
1085 record_unwind_current_buffer ();
1086 return unbind_to (count, Fprogn (args));
1089 DEFUN ("buffer-size", Fbuffer_size, Sbuffer_size, 0, 1, 0,
1090 doc: /* Return the number of characters in the current buffer.
1091 If BUFFER is not nil, return the number of characters in that buffer
1092 instead.
1094 This does not take narrowing into account; to count the number of
1095 characters in the accessible portion of the current buffer, use
1096 `(- (point-max) (point-min))', and to count the number of characters
1097 in some other BUFFER, use
1098 `(with-current-buffer BUFFER (- (point-max) (point-min)))'. */)
1099 (Lisp_Object buffer)
1101 if (NILP (buffer))
1102 return make_number (Z - BEG);
1103 else
1105 CHECK_BUFFER (buffer);
1106 return make_number (BUF_Z (XBUFFER (buffer))
1107 - BUF_BEG (XBUFFER (buffer)));
1111 DEFUN ("point-min", Fpoint_min, Spoint_min, 0, 0, 0,
1112 doc: /* Return the minimum permissible value of point in the current buffer.
1113 This is 1, unless narrowing (a buffer restriction) is in effect. */)
1114 (void)
1116 Lisp_Object temp;
1117 XSETFASTINT (temp, BEGV);
1118 return temp;
1121 DEFUN ("point-min-marker", Fpoint_min_marker, Spoint_min_marker, 0, 0, 0,
1122 doc: /* Return a marker to the minimum permissible value of point in this buffer.
1123 This is the beginning, unless narrowing (a buffer restriction) is in effect. */)
1124 (void)
1126 return build_marker (current_buffer, BEGV, BEGV_BYTE);
1129 DEFUN ("point-max", Fpoint_max, Spoint_max, 0, 0, 0,
1130 doc: /* Return the maximum permissible value of point in the current buffer.
1131 This is (1+ (buffer-size)), unless narrowing (a buffer restriction)
1132 is in effect, in which case it is less. */)
1133 (void)
1135 Lisp_Object temp;
1136 XSETFASTINT (temp, ZV);
1137 return temp;
1140 DEFUN ("point-max-marker", Fpoint_max_marker, Spoint_max_marker, 0, 0, 0,
1141 doc: /* Return a marker to the maximum permissible value of point in this buffer.
1142 This is (1+ (buffer-size)), unless narrowing (a buffer restriction)
1143 is in effect, in which case it is less. */)
1144 (void)
1146 return build_marker (current_buffer, ZV, ZV_BYTE);
1149 DEFUN ("gap-position", Fgap_position, Sgap_position, 0, 0, 0,
1150 doc: /* Return the position of the gap, in the current buffer.
1151 See also `gap-size'. */)
1152 (void)
1154 Lisp_Object temp;
1155 XSETFASTINT (temp, GPT);
1156 return temp;
1159 DEFUN ("gap-size", Fgap_size, Sgap_size, 0, 0, 0,
1160 doc: /* Return the size of the current buffer's gap.
1161 See also `gap-position'. */)
1162 (void)
1164 Lisp_Object temp;
1165 XSETFASTINT (temp, GAP_SIZE);
1166 return temp;
1169 DEFUN ("position-bytes", Fposition_bytes, Sposition_bytes, 1, 1, 0,
1170 doc: /* Return the byte position for character position POSITION.
1171 If POSITION is out of range, the value is nil. */)
1172 (Lisp_Object position)
1174 CHECK_NUMBER_COERCE_MARKER (position);
1175 if (XINT (position) < BEG || XINT (position) > Z)
1176 return Qnil;
1177 return make_number (CHAR_TO_BYTE (XINT (position)));
1180 DEFUN ("byte-to-position", Fbyte_to_position, Sbyte_to_position, 1, 1, 0,
1181 doc: /* Return the character position for byte position BYTEPOS.
1182 If BYTEPOS is out of range, the value is nil. */)
1183 (Lisp_Object bytepos)
1185 ptrdiff_t pos_byte;
1187 CHECK_NUMBER (bytepos);
1188 pos_byte = XINT (bytepos);
1189 if (pos_byte < BEG_BYTE || pos_byte > Z_BYTE)
1190 return Qnil;
1191 if (Z != Z_BYTE)
1192 /* There are multibyte characters in the buffer.
1193 The argument of BYTE_TO_CHAR must be a byte position at
1194 a character boundary, so search for the start of the current
1195 character. */
1196 while (!CHAR_HEAD_P (FETCH_BYTE (pos_byte)))
1197 pos_byte--;
1198 return make_number (BYTE_TO_CHAR (pos_byte));
1201 DEFUN ("following-char", Ffollowing_char, Sfollowing_char, 0, 0, 0,
1202 doc: /* Return the character following point, as a number.
1203 At the end of the buffer or accessible region, return 0. */)
1204 (void)
1206 Lisp_Object temp;
1207 if (PT >= ZV)
1208 XSETFASTINT (temp, 0);
1209 else
1210 XSETFASTINT (temp, FETCH_CHAR (PT_BYTE));
1211 return temp;
1214 DEFUN ("preceding-char", Fprevious_char, Sprevious_char, 0, 0, 0,
1215 doc: /* Return the character preceding point, as a number.
1216 At the beginning of the buffer or accessible region, return 0. */)
1217 (void)
1219 Lisp_Object temp;
1220 if (PT <= BEGV)
1221 XSETFASTINT (temp, 0);
1222 else if (!NILP (BVAR (current_buffer, enable_multibyte_characters)))
1224 ptrdiff_t pos = PT_BYTE;
1225 DEC_POS (pos);
1226 XSETFASTINT (temp, FETCH_CHAR (pos));
1228 else
1229 XSETFASTINT (temp, FETCH_BYTE (PT_BYTE - 1));
1230 return temp;
1233 DEFUN ("bobp", Fbobp, Sbobp, 0, 0, 0,
1234 doc: /* Return t if point is at the beginning of the buffer.
1235 If the buffer is narrowed, this means the beginning of the narrowed part. */)
1236 (void)
1238 if (PT == BEGV)
1239 return Qt;
1240 return Qnil;
1243 DEFUN ("eobp", Feobp, Seobp, 0, 0, 0,
1244 doc: /* Return t if point is at the end of the buffer.
1245 If the buffer is narrowed, this means the end of the narrowed part. */)
1246 (void)
1248 if (PT == ZV)
1249 return Qt;
1250 return Qnil;
1253 DEFUN ("bolp", Fbolp, Sbolp, 0, 0, 0,
1254 doc: /* Return t if point is at the beginning of a line. */)
1255 (void)
1257 if (PT == BEGV || FETCH_BYTE (PT_BYTE - 1) == '\n')
1258 return Qt;
1259 return Qnil;
1262 DEFUN ("eolp", Feolp, Seolp, 0, 0, 0,
1263 doc: /* Return t if point is at the end of a line.
1264 `End of a line' includes point being at the end of the buffer. */)
1265 (void)
1267 if (PT == ZV || FETCH_BYTE (PT_BYTE) == '\n')
1268 return Qt;
1269 return Qnil;
1272 DEFUN ("char-after", Fchar_after, Schar_after, 0, 1, 0,
1273 doc: /* Return character in current buffer at position POS.
1274 POS is an integer or a marker and defaults to point.
1275 If POS is out of range, the value is nil. */)
1276 (Lisp_Object pos)
1278 register ptrdiff_t pos_byte;
1280 if (NILP (pos))
1282 pos_byte = PT_BYTE;
1283 if (pos_byte < BEGV_BYTE || pos_byte >= ZV_BYTE)
1284 return Qnil;
1286 else if (MARKERP (pos))
1288 pos_byte = marker_byte_position (pos);
1289 if (pos_byte < BEGV_BYTE || pos_byte >= ZV_BYTE)
1290 return Qnil;
1292 else
1294 CHECK_NUMBER_COERCE_MARKER (pos);
1295 if (XINT (pos) < BEGV || XINT (pos) >= ZV)
1296 return Qnil;
1298 pos_byte = CHAR_TO_BYTE (XINT (pos));
1301 return make_number (FETCH_CHAR (pos_byte));
1304 DEFUN ("char-before", Fchar_before, Schar_before, 0, 1, 0,
1305 doc: /* Return character in current buffer preceding position POS.
1306 POS is an integer or a marker and defaults to point.
1307 If POS is out of range, the value is nil. */)
1308 (Lisp_Object pos)
1310 register Lisp_Object val;
1311 register ptrdiff_t pos_byte;
1313 if (NILP (pos))
1315 pos_byte = PT_BYTE;
1316 XSETFASTINT (pos, PT);
1319 if (MARKERP (pos))
1321 pos_byte = marker_byte_position (pos);
1323 if (pos_byte <= BEGV_BYTE || pos_byte > ZV_BYTE)
1324 return Qnil;
1326 else
1328 CHECK_NUMBER_COERCE_MARKER (pos);
1330 if (XINT (pos) <= BEGV || XINT (pos) > ZV)
1331 return Qnil;
1333 pos_byte = CHAR_TO_BYTE (XINT (pos));
1336 if (!NILP (BVAR (current_buffer, enable_multibyte_characters)))
1338 DEC_POS (pos_byte);
1339 XSETFASTINT (val, FETCH_CHAR (pos_byte));
1341 else
1343 pos_byte--;
1344 XSETFASTINT (val, FETCH_BYTE (pos_byte));
1346 return val;
1349 DEFUN ("user-login-name", Fuser_login_name, Suser_login_name, 0, 1, 0,
1350 doc: /* Return the name under which the user logged in, as a string.
1351 This is based on the effective uid, not the real uid.
1352 Also, if the environment variables LOGNAME or USER are set,
1353 that determines the value of this function.
1355 If optional argument UID is an integer or a float, return the login name
1356 of the user with that uid, or nil if there is no such user. */)
1357 (Lisp_Object uid)
1359 struct passwd *pw;
1360 uid_t id;
1362 /* Set up the user name info if we didn't do it before.
1363 (That can happen if Emacs is dumpable
1364 but you decide to run `temacs -l loadup' and not dump. */
1365 if (NILP (Vuser_login_name))
1366 init_editfns (false);
1368 if (NILP (uid))
1369 return Vuser_login_name;
1371 CONS_TO_INTEGER (uid, uid_t, id);
1372 block_input ();
1373 pw = getpwuid (id);
1374 unblock_input ();
1375 return (pw ? build_string (pw->pw_name) : Qnil);
1378 DEFUN ("user-real-login-name", Fuser_real_login_name, Suser_real_login_name,
1379 0, 0, 0,
1380 doc: /* Return the name of the user's real uid, as a string.
1381 This ignores the environment variables LOGNAME and USER, so it differs from
1382 `user-login-name' when running under `su'. */)
1383 (void)
1385 /* Set up the user name info if we didn't do it before.
1386 (That can happen if Emacs is dumpable
1387 but you decide to run `temacs -l loadup' and not dump. */
1388 if (NILP (Vuser_login_name))
1389 init_editfns (false);
1390 return Vuser_real_login_name;
1393 DEFUN ("user-uid", Fuser_uid, Suser_uid, 0, 0, 0,
1394 doc: /* Return the effective uid of Emacs.
1395 Value is an integer or a float, depending on the value. */)
1396 (void)
1398 uid_t euid = geteuid ();
1399 return make_fixnum_or_float (euid);
1402 DEFUN ("user-real-uid", Fuser_real_uid, Suser_real_uid, 0, 0, 0,
1403 doc: /* Return the real uid of Emacs.
1404 Value is an integer or a float, depending on the value. */)
1405 (void)
1407 uid_t uid = getuid ();
1408 return make_fixnum_or_float (uid);
1411 DEFUN ("group-gid", Fgroup_gid, Sgroup_gid, 0, 0, 0,
1412 doc: /* Return the effective gid of Emacs.
1413 Value is an integer or a float, depending on the value. */)
1414 (void)
1416 gid_t egid = getegid ();
1417 return make_fixnum_or_float (egid);
1420 DEFUN ("group-real-gid", Fgroup_real_gid, Sgroup_real_gid, 0, 0, 0,
1421 doc: /* Return the real gid of Emacs.
1422 Value is an integer or a float, depending on the value. */)
1423 (void)
1425 gid_t gid = getgid ();
1426 return make_fixnum_or_float (gid);
1429 DEFUN ("user-full-name", Fuser_full_name, Suser_full_name, 0, 1, 0,
1430 doc: /* Return the full name of the user logged in, as a string.
1431 If the full name corresponding to Emacs's userid is not known,
1432 return "unknown".
1434 If optional argument UID is an integer or float, return the full name
1435 of the user with that uid, or nil if there is no such user.
1436 If UID is a string, return the full name of the user with that login
1437 name, or nil if there is no such user. */)
1438 (Lisp_Object uid)
1440 struct passwd *pw;
1441 register char *p, *q;
1442 Lisp_Object full;
1444 if (NILP (uid))
1445 return Vuser_full_name;
1446 else if (NUMBERP (uid))
1448 uid_t u;
1449 CONS_TO_INTEGER (uid, uid_t, u);
1450 block_input ();
1451 pw = getpwuid (u);
1452 unblock_input ();
1454 else if (STRINGP (uid))
1456 block_input ();
1457 pw = getpwnam (SSDATA (uid));
1458 unblock_input ();
1460 else
1461 error ("Invalid UID specification");
1463 if (!pw)
1464 return Qnil;
1466 p = USER_FULL_NAME;
1467 /* Chop off everything after the first comma. */
1468 q = strchr (p, ',');
1469 full = make_string (p, q ? q - p : strlen (p));
1471 #ifdef AMPERSAND_FULL_NAME
1472 p = SSDATA (full);
1473 q = strchr (p, '&');
1474 /* Substitute the login name for the &, upcasing the first character. */
1475 if (q)
1477 Lisp_Object login = Fuser_login_name (make_number (pw->pw_uid));
1478 USE_SAFE_ALLOCA;
1479 char *r = SAFE_ALLOCA (strlen (p) + SBYTES (login) + 1);
1480 memcpy (r, p, q - p);
1481 char *s = lispstpcpy (&r[q - p], login);
1482 r[q - p] = upcase ((unsigned char) r[q - p]);
1483 strcpy (s, q + 1);
1484 full = build_string (r);
1485 SAFE_FREE ();
1487 #endif /* AMPERSAND_FULL_NAME */
1489 return full;
1492 DEFUN ("system-name", Fsystem_name, Ssystem_name, 0, 0, 0,
1493 doc: /* Return the host name of the machine you are running on, as a string. */)
1494 (void)
1496 if (EQ (Vsystem_name, cached_system_name))
1497 init_and_cache_system_name ();
1498 return Vsystem_name;
1501 DEFUN ("emacs-pid", Femacs_pid, Semacs_pid, 0, 0, 0,
1502 doc: /* Return the process ID of Emacs, as a number. */)
1503 (void)
1505 pid_t pid = getpid ();
1506 return make_fixnum_or_float (pid);
1511 #ifndef TIME_T_MIN
1512 # define TIME_T_MIN TYPE_MINIMUM (time_t)
1513 #endif
1514 #ifndef TIME_T_MAX
1515 # define TIME_T_MAX TYPE_MAXIMUM (time_t)
1516 #endif
1518 /* Report that a time value is out of range for Emacs. */
1519 void
1520 time_overflow (void)
1522 error ("Specified time is not representable");
1525 static _Noreturn void
1526 invalid_time (void)
1528 error ("Invalid time specification");
1531 /* Check a return value compatible with that of decode_time_components. */
1532 static void
1533 check_time_validity (int validity)
1535 if (validity <= 0)
1537 if (validity < 0)
1538 time_overflow ();
1539 else
1540 invalid_time ();
1544 /* Return the upper part of the time T (everything but the bottom 16 bits). */
1545 static EMACS_INT
1546 hi_time (time_t t)
1548 time_t hi = t >> LO_TIME_BITS;
1549 if (FIXNUM_OVERFLOW_P (hi))
1550 time_overflow ();
1551 return hi;
1554 /* Return the bottom bits of the time T. */
1555 static int
1556 lo_time (time_t t)
1558 return t & ((1 << LO_TIME_BITS) - 1);
1561 DEFUN ("current-time", Fcurrent_time, Scurrent_time, 0, 0, 0,
1562 doc: /* Return the current time, as the number of seconds since 1970-01-01 00:00:00.
1563 The time is returned as a list of integers (HIGH LOW USEC PSEC).
1564 HIGH has the most significant bits of the seconds, while LOW has the
1565 least significant 16 bits. USEC and PSEC are the microsecond and
1566 picosecond counts. */)
1567 (void)
1569 return make_lisp_time (current_timespec ());
1572 static struct lisp_time
1573 time_add (struct lisp_time ta, struct lisp_time tb)
1575 EMACS_INT hi = ta.hi + tb.hi;
1576 int lo = ta.lo + tb.lo;
1577 int us = ta.us + tb.us;
1578 int ps = ta.ps + tb.ps;
1579 us += (1000000 <= ps);
1580 ps -= (1000000 <= ps) * 1000000;
1581 lo += (1000000 <= us);
1582 us -= (1000000 <= us) * 1000000;
1583 hi += (1 << LO_TIME_BITS <= lo);
1584 lo -= (1 << LO_TIME_BITS <= lo) << LO_TIME_BITS;
1585 return (struct lisp_time) { hi, lo, us, ps };
1588 static struct lisp_time
1589 time_subtract (struct lisp_time ta, struct lisp_time tb)
1591 EMACS_INT hi = ta.hi - tb.hi;
1592 int lo = ta.lo - tb.lo;
1593 int us = ta.us - tb.us;
1594 int ps = ta.ps - tb.ps;
1595 us -= (ps < 0);
1596 ps += (ps < 0) * 1000000;
1597 lo -= (us < 0);
1598 us += (us < 0) * 1000000;
1599 hi -= (lo < 0);
1600 lo += (lo < 0) << LO_TIME_BITS;
1601 return (struct lisp_time) { hi, lo, us, ps };
1604 static Lisp_Object
1605 time_arith (Lisp_Object a, Lisp_Object b,
1606 struct lisp_time (*op) (struct lisp_time, struct lisp_time))
1608 int alen, blen;
1609 struct lisp_time ta = lisp_time_struct (a, &alen);
1610 struct lisp_time tb = lisp_time_struct (b, &blen);
1611 struct lisp_time t = op (ta, tb);
1612 if (FIXNUM_OVERFLOW_P (t.hi))
1613 time_overflow ();
1614 Lisp_Object val = Qnil;
1616 switch (max (alen, blen))
1618 default:
1619 val = Fcons (make_number (t.ps), val);
1620 FALLTHROUGH;
1621 case 3:
1622 val = Fcons (make_number (t.us), val);
1623 FALLTHROUGH;
1624 case 2:
1625 val = Fcons (make_number (t.lo), val);
1626 val = Fcons (make_number (t.hi), val);
1627 break;
1630 return val;
1633 DEFUN ("time-add", Ftime_add, Stime_add, 2, 2, 0,
1634 doc: /* Return the sum of two time values A and B, as a time value.
1635 A nil value for either argument stands for the current time.
1636 See `current-time-string' for the various forms of a time value. */)
1637 (Lisp_Object a, Lisp_Object b)
1639 return time_arith (a, b, time_add);
1642 DEFUN ("time-subtract", Ftime_subtract, Stime_subtract, 2, 2, 0,
1643 doc: /* Return the difference between two time values A and B, as a time value.
1644 Use `float-time' to convert the difference into elapsed seconds.
1645 A nil value for either argument stands for the current time.
1646 See `current-time-string' for the various forms of a time value. */)
1647 (Lisp_Object a, Lisp_Object b)
1649 return time_arith (a, b, time_subtract);
1652 DEFUN ("time-less-p", Ftime_less_p, Stime_less_p, 2, 2, 0,
1653 doc: /* Return non-nil if time value T1 is earlier than time value T2.
1654 A nil value for either argument stands for the current time.
1655 See `current-time-string' for the various forms of a time value. */)
1656 (Lisp_Object t1, Lisp_Object t2)
1658 int t1len, t2len;
1659 struct lisp_time a = lisp_time_struct (t1, &t1len);
1660 struct lisp_time b = lisp_time_struct (t2, &t2len);
1661 return ((a.hi != b.hi ? a.hi < b.hi
1662 : a.lo != b.lo ? a.lo < b.lo
1663 : a.us != b.us ? a.us < b.us
1664 : a.ps < b.ps)
1665 ? Qt : Qnil);
1669 DEFUN ("get-internal-run-time", Fget_internal_run_time, Sget_internal_run_time,
1670 0, 0, 0,
1671 doc: /* Return the current run time used by Emacs.
1672 The time is returned as a list (HIGH LOW USEC PSEC), using the same
1673 style as (current-time).
1675 On systems that can't determine the run time, `get-internal-run-time'
1676 does the same thing as `current-time'. */)
1677 (void)
1679 #ifdef HAVE_GETRUSAGE
1680 struct rusage usage;
1681 time_t secs;
1682 int usecs;
1684 if (getrusage (RUSAGE_SELF, &usage) < 0)
1685 /* This shouldn't happen. What action is appropriate? */
1686 xsignal0 (Qerror);
1688 /* Sum up user time and system time. */
1689 secs = usage.ru_utime.tv_sec + usage.ru_stime.tv_sec;
1690 usecs = usage.ru_utime.tv_usec + usage.ru_stime.tv_usec;
1691 if (usecs >= 1000000)
1693 usecs -= 1000000;
1694 secs++;
1696 return make_lisp_time (make_timespec (secs, usecs * 1000));
1697 #else /* ! HAVE_GETRUSAGE */
1698 #ifdef WINDOWSNT
1699 return w32_get_internal_run_time ();
1700 #else /* ! WINDOWSNT */
1701 return Fcurrent_time ();
1702 #endif /* WINDOWSNT */
1703 #endif /* HAVE_GETRUSAGE */
1707 /* Make a Lisp list that represents the Emacs time T. T may be an
1708 invalid time, with a slightly negative tv_nsec value such as
1709 UNKNOWN_MODTIME_NSECS; in that case, the Lisp list contains a
1710 correspondingly negative picosecond count. */
1711 Lisp_Object
1712 make_lisp_time (struct timespec t)
1714 time_t s = t.tv_sec;
1715 int ns = t.tv_nsec;
1716 return list4i (hi_time (s), lo_time (s), ns / 1000, ns % 1000 * 1000);
1719 /* Decode a Lisp list SPECIFIED_TIME that represents a time.
1720 Set *PHIGH, *PLOW, *PUSEC, *PPSEC to its parts; do not check their values.
1721 Return 2, 3, or 4 to indicate the effective length of SPECIFIED_TIME
1722 if successful, 0 if unsuccessful. */
1723 static int
1724 disassemble_lisp_time (Lisp_Object specified_time, Lisp_Object *phigh,
1725 Lisp_Object *plow, Lisp_Object *pusec,
1726 Lisp_Object *ppsec)
1728 Lisp_Object high = make_number (0);
1729 Lisp_Object low = specified_time;
1730 Lisp_Object usec = make_number (0);
1731 Lisp_Object psec = make_number (0);
1732 int len = 4;
1734 if (CONSP (specified_time))
1736 high = XCAR (specified_time);
1737 low = XCDR (specified_time);
1738 if (CONSP (low))
1740 Lisp_Object low_tail = XCDR (low);
1741 low = XCAR (low);
1742 if (CONSP (low_tail))
1744 usec = XCAR (low_tail);
1745 low_tail = XCDR (low_tail);
1746 if (CONSP (low_tail))
1747 psec = XCAR (low_tail);
1748 else
1749 len = 3;
1751 else if (!NILP (low_tail))
1753 usec = low_tail;
1754 len = 3;
1756 else
1757 len = 2;
1759 else
1760 len = 2;
1762 /* When combining components, require LOW to be an integer,
1763 as otherwise it would be a pain to add up times. */
1764 if (! INTEGERP (low))
1765 return 0;
1767 else if (INTEGERP (specified_time))
1768 len = 2;
1770 *phigh = high;
1771 *plow = low;
1772 *pusec = usec;
1773 *ppsec = psec;
1774 return len;
1777 /* Convert T into an Emacs time *RESULT, truncating toward minus infinity.
1778 Return true if T is in range, false otherwise. */
1779 static bool
1780 decode_float_time (double t, struct lisp_time *result)
1782 double lo_multiplier = 1 << LO_TIME_BITS;
1783 double emacs_time_min = MOST_NEGATIVE_FIXNUM * lo_multiplier;
1784 if (! (emacs_time_min <= t && t < -emacs_time_min))
1785 return false;
1787 double small_t = t / lo_multiplier;
1788 EMACS_INT hi = small_t;
1789 double t_sans_hi = t - hi * lo_multiplier;
1790 int lo = t_sans_hi;
1791 long double fracps = (t_sans_hi - lo) * 1e12L;
1792 #ifdef INT_FAST64_MAX
1793 int_fast64_t ifracps = fracps;
1794 int us = ifracps / 1000000;
1795 int ps = ifracps % 1000000;
1796 #else
1797 int us = fracps / 1e6L;
1798 int ps = fracps - us * 1e6L;
1799 #endif
1800 us -= (ps < 0);
1801 ps += (ps < 0) * 1000000;
1802 lo -= (us < 0);
1803 us += (us < 0) * 1000000;
1804 hi -= (lo < 0);
1805 lo += (lo < 0) << LO_TIME_BITS;
1806 result->hi = hi;
1807 result->lo = lo;
1808 result->us = us;
1809 result->ps = ps;
1810 return true;
1813 /* From the time components HIGH, LOW, USEC and PSEC taken from a Lisp
1814 list, generate the corresponding time value.
1815 If LOW is floating point, the other components should be zero.
1817 If RESULT is not null, store into *RESULT the converted time.
1818 If *DRESULT is not null, store into *DRESULT the number of
1819 seconds since the start of the POSIX Epoch.
1821 Return 1 if successful, 0 if the components are of the
1822 wrong type, and -1 if the time is out of range. */
1824 decode_time_components (Lisp_Object high, Lisp_Object low, Lisp_Object usec,
1825 Lisp_Object psec,
1826 struct lisp_time *result, double *dresult)
1828 EMACS_INT hi, lo, us, ps;
1829 if (! (INTEGERP (high)
1830 && INTEGERP (usec) && INTEGERP (psec)))
1831 return 0;
1832 if (! INTEGERP (low))
1834 if (FLOATP (low))
1836 double t = XFLOAT_DATA (low);
1837 if (result && ! decode_float_time (t, result))
1838 return -1;
1839 if (dresult)
1840 *dresult = t;
1841 return 1;
1843 else if (NILP (low))
1845 struct timespec now = current_timespec ();
1846 if (result)
1848 result->hi = hi_time (now.tv_sec);
1849 result->lo = lo_time (now.tv_sec);
1850 result->us = now.tv_nsec / 1000;
1851 result->ps = now.tv_nsec % 1000 * 1000;
1853 if (dresult)
1854 *dresult = now.tv_sec + now.tv_nsec / 1e9;
1855 return 1;
1857 else
1858 return 0;
1861 hi = XINT (high);
1862 lo = XINT (low);
1863 us = XINT (usec);
1864 ps = XINT (psec);
1866 /* Normalize out-of-range lower-order components by carrying
1867 each overflow into the next higher-order component. */
1868 us += ps / 1000000 - (ps % 1000000 < 0);
1869 lo += us / 1000000 - (us % 1000000 < 0);
1870 hi += lo >> LO_TIME_BITS;
1871 ps = ps % 1000000 + 1000000 * (ps % 1000000 < 0);
1872 us = us % 1000000 + 1000000 * (us % 1000000 < 0);
1873 lo &= (1 << LO_TIME_BITS) - 1;
1875 if (result)
1877 if (FIXNUM_OVERFLOW_P (hi))
1878 return -1;
1879 result->hi = hi;
1880 result->lo = lo;
1881 result->us = us;
1882 result->ps = ps;
1885 if (dresult)
1887 double dhi = hi;
1888 *dresult = (us * 1e6 + ps) / 1e12 + lo + dhi * (1 << LO_TIME_BITS);
1891 return 1;
1894 struct timespec
1895 lisp_to_timespec (struct lisp_time t)
1897 if (! ((TYPE_SIGNED (time_t) ? TIME_T_MIN >> LO_TIME_BITS <= t.hi : 0 <= t.hi)
1898 && t.hi <= TIME_T_MAX >> LO_TIME_BITS))
1899 return invalid_timespec ();
1900 time_t s = (t.hi << LO_TIME_BITS) + t.lo;
1901 int ns = t.us * 1000 + t.ps / 1000;
1902 return make_timespec (s, ns);
1905 /* Decode a Lisp list SPECIFIED_TIME that represents a time.
1906 Store its effective length into *PLEN.
1907 If SPECIFIED_TIME is nil, use the current time.
1908 Signal an error if SPECIFIED_TIME does not represent a time. */
1909 static struct lisp_time
1910 lisp_time_struct (Lisp_Object specified_time, int *plen)
1912 Lisp_Object high, low, usec, psec;
1913 struct lisp_time t;
1914 int len = disassemble_lisp_time (specified_time, &high, &low, &usec, &psec);
1915 if (!len)
1916 invalid_time ();
1917 int val = decode_time_components (high, low, usec, psec, &t, 0);
1918 check_time_validity (val);
1919 *plen = len;
1920 return t;
1923 /* Like lisp_time_struct, except return a struct timespec.
1924 Discard any low-order digits. */
1925 struct timespec
1926 lisp_time_argument (Lisp_Object specified_time)
1928 int len;
1929 struct lisp_time lt = lisp_time_struct (specified_time, &len);
1930 struct timespec t = lisp_to_timespec (lt);
1931 if (! timespec_valid_p (t))
1932 time_overflow ();
1933 return t;
1936 /* Like lisp_time_argument, except decode only the seconds part,
1937 and do not check the subseconds part. */
1938 static time_t
1939 lisp_seconds_argument (Lisp_Object specified_time)
1941 Lisp_Object high, low, usec, psec;
1942 struct lisp_time t;
1944 int val = disassemble_lisp_time (specified_time, &high, &low, &usec, &psec);
1945 if (val != 0)
1947 val = decode_time_components (high, low, make_number (0),
1948 make_number (0), &t, 0);
1949 if (0 < val
1950 && ! ((TYPE_SIGNED (time_t)
1951 ? TIME_T_MIN >> LO_TIME_BITS <= t.hi
1952 : 0 <= t.hi)
1953 && t.hi <= TIME_T_MAX >> LO_TIME_BITS))
1954 val = -1;
1956 check_time_validity (val);
1957 return (t.hi << LO_TIME_BITS) + t.lo;
1960 DEFUN ("float-time", Ffloat_time, Sfloat_time, 0, 1, 0,
1961 doc: /* Return the current time, as a float number of seconds since the epoch.
1962 If SPECIFIED-TIME is given, it is the time to convert to float
1963 instead of the current time. The argument should have the form
1964 \(HIGH LOW) or (HIGH LOW USEC) or (HIGH LOW USEC PSEC). Thus,
1965 you can use times from `current-time' and from `file-attributes'.
1966 SPECIFIED-TIME can also have the form (HIGH . LOW), but this is
1967 considered obsolete.
1969 WARNING: Since the result is floating point, it may not be exact.
1970 If precise time stamps are required, use either `current-time',
1971 or (if you need time as a string) `format-time-string'. */)
1972 (Lisp_Object specified_time)
1974 double t;
1975 Lisp_Object high, low, usec, psec;
1976 if (! (disassemble_lisp_time (specified_time, &high, &low, &usec, &psec)
1977 && decode_time_components (high, low, usec, psec, 0, &t)))
1978 invalid_time ();
1979 return make_float (t);
1982 /* Write information into buffer S of size MAXSIZE, according to the
1983 FORMAT of length FORMAT_LEN, using time information taken from *TP.
1984 Use the time zone specified by TZ.
1985 Use NS as the number of nanoseconds in the %N directive.
1986 Return the number of bytes written, not including the terminating
1987 '\0'. If S is NULL, nothing will be written anywhere; so to
1988 determine how many bytes would be written, use NULL for S and
1989 ((size_t) -1) for MAXSIZE.
1991 This function behaves like nstrftime, except it allows null
1992 bytes in FORMAT and it does not support nanoseconds. */
1993 static size_t
1994 emacs_nmemftime (char *s, size_t maxsize, const char *format,
1995 size_t format_len, const struct tm *tp, timezone_t tz, int ns)
1997 size_t total = 0;
1999 /* Loop through all the null-terminated strings in the format
2000 argument. Normally there's just one null-terminated string, but
2001 there can be arbitrarily many, concatenated together, if the
2002 format contains '\0' bytes. nstrftime stops at the first
2003 '\0' byte so we must invoke it separately for each such string. */
2004 for (;;)
2006 size_t len;
2007 size_t result;
2009 if (s)
2010 s[0] = '\1';
2012 result = nstrftime (s, maxsize, format, tp, tz, ns);
2014 if (s)
2016 if (result == 0 && s[0] != '\0')
2017 return 0;
2018 s += result + 1;
2021 maxsize -= result + 1;
2022 total += result;
2023 len = strlen (format);
2024 if (len == format_len)
2025 return total;
2026 total++;
2027 format += len + 1;
2028 format_len -= len + 1;
2032 DEFUN ("format-time-string", Fformat_time_string, Sformat_time_string, 1, 3, 0,
2033 doc: /* Use FORMAT-STRING to format the time TIME, or now if omitted or nil.
2034 TIME is specified as (HIGH LOW USEC PSEC), as returned by
2035 `current-time' or `file-attributes'. It can also be a single integer
2036 number of seconds since the epoch. The obsolete form (HIGH . LOW) is
2037 also still accepted.
2039 The optional ZONE is omitted or nil for Emacs local time, t for
2040 Universal Time, `wall' for system wall clock time, or a string as in
2041 the TZ environment variable. It can also be a list (as from
2042 `current-time-zone') or an integer (as from `decode-time') applied
2043 without consideration for daylight saving time.
2045 The value is a copy of FORMAT-STRING, but with certain constructs replaced
2046 by text that describes the specified date and time in TIME:
2048 %Y is the year, %y within the century, %C the century.
2049 %G is the year corresponding to the ISO week, %g within the century.
2050 %m is the numeric month.
2051 %b and %h are the locale's abbreviated month name, %B the full name.
2052 (%h is not supported on MS-Windows.)
2053 %d is the day of the month, zero-padded, %e is blank-padded.
2054 %u is the numeric day of week from 1 (Monday) to 7, %w from 0 (Sunday) to 6.
2055 %a is the locale's abbreviated name of the day of week, %A the full name.
2056 %U is the week number starting on Sunday, %W starting on Monday,
2057 %V according to ISO 8601.
2058 %j is the day of the year.
2060 %H is the hour on a 24-hour clock, %I is on a 12-hour clock, %k is like %H
2061 only blank-padded, %l is like %I blank-padded.
2062 %p is the locale's equivalent of either AM or PM.
2063 %q is the calendar quarter (1–4).
2064 %M is the minute (00-59).
2065 %S is the second (00-59; 00-60 on platforms with leap seconds)
2066 %s is the number of seconds since 1970-01-01 00:00:00 +0000.
2067 %N is the nanosecond, %6N the microsecond, %3N the millisecond, etc.
2068 %Z is the time zone abbreviation, %z is the numeric form.
2070 %c is the locale's date and time format.
2071 %x is the locale's "preferred" date format.
2072 %D is like "%m/%d/%y".
2073 %F is the ISO 8601 date format (like "%Y-%m-%d").
2075 %R is like "%H:%M", %T is like "%H:%M:%S", %r is like "%I:%M:%S %p".
2076 %X is the locale's "preferred" time format.
2078 Finally, %n is a newline, %t is a tab, %% is a literal %, and
2079 unrecognized %-sequences stand for themselves.
2081 Certain flags and modifiers are available with some format controls.
2082 The flags are `_', `-', `^' and `#'. For certain characters X,
2083 %_X is like %X, but padded with blanks; %-X is like %X,
2084 but without padding. %^X is like %X, but with all textual
2085 characters up-cased; %#X is like %X, but with letter-case of
2086 all textual characters reversed.
2087 %NX (where N stands for an integer) is like %X,
2088 but takes up at least N (a number) positions.
2089 The modifiers are `E' and `O'. For certain characters X,
2090 %EX is a locale's alternative version of %X;
2091 %OX is like %X, but uses the locale's number symbols.
2093 For example, to produce full ISO 8601 format, use "%FT%T%z".
2095 usage: (format-time-string FORMAT-STRING &optional TIME ZONE) */)
2096 (Lisp_Object format_string, Lisp_Object timeval, Lisp_Object zone)
2098 struct timespec t = lisp_time_argument (timeval);
2099 struct tm tm;
2101 CHECK_STRING (format_string);
2102 format_string = code_convert_string_norecord (format_string,
2103 Vlocale_coding_system, 1);
2104 return format_time_string (SSDATA (format_string), SBYTES (format_string),
2105 t, zone, &tm);
2108 static Lisp_Object
2109 format_time_string (char const *format, ptrdiff_t formatlen,
2110 struct timespec t, Lisp_Object zone, struct tm *tmp)
2112 char buffer[4000];
2113 char *buf = buffer;
2114 ptrdiff_t size = sizeof buffer;
2115 size_t len;
2116 int ns = t.tv_nsec;
2117 USE_SAFE_ALLOCA;
2119 timezone_t tz = tzlookup (zone, false);
2120 /* On some systems, like 32-bit MinGW, tv_sec of struct timespec is
2121 a 64-bit type, but time_t is a 32-bit type. emacs_localtime_rz
2122 expects a pointer to time_t value. */
2123 time_t tsec = t.tv_sec;
2124 tmp = emacs_localtime_rz (tz, &tsec, tmp);
2125 if (! tmp)
2127 xtzfree (tz);
2128 time_overflow ();
2130 synchronize_system_time_locale ();
2132 while (true)
2134 buf[0] = '\1';
2135 len = emacs_nmemftime (buf, size, format, formatlen, tmp, tz, ns);
2136 if ((0 < len && len < size) || (len == 0 && buf[0] == '\0'))
2137 break;
2139 /* Buffer was too small, so make it bigger and try again. */
2140 len = emacs_nmemftime (NULL, SIZE_MAX, format, formatlen, tmp, tz, ns);
2141 if (STRING_BYTES_BOUND <= len)
2143 xtzfree (tz);
2144 string_overflow ();
2146 size = len + 1;
2147 buf = SAFE_ALLOCA (size);
2150 xtzfree (tz);
2151 AUTO_STRING_WITH_LEN (bufstring, buf, len);
2152 Lisp_Object result = code_convert_string_norecord (bufstring,
2153 Vlocale_coding_system, 0);
2154 SAFE_FREE ();
2155 return result;
2158 DEFUN ("decode-time", Fdecode_time, Sdecode_time, 0, 2, 0,
2159 doc: /* Decode a time value as (SEC MINUTE HOUR DAY MONTH YEAR DOW DST UTCOFF).
2160 The optional TIME should be a list of (HIGH LOW . IGNORED),
2161 as from `current-time' and `file-attributes', or nil to use the
2162 current time. It can also be a single integer number of seconds since
2163 the epoch. The obsolete form (HIGH . LOW) is also still accepted.
2165 The optional ZONE is omitted or nil for Emacs local time, t for
2166 Universal Time, `wall' for system wall clock time, or a string as in
2167 the TZ environment variable. It can also be a list (as from
2168 `current-time-zone') or an integer (the UTC offset in seconds) applied
2169 without consideration for daylight saving time.
2171 The list has the following nine members: SEC is an integer between 0
2172 and 60; SEC is 60 for a leap second, which only some operating systems
2173 support. MINUTE is an integer between 0 and 59. HOUR is an integer
2174 between 0 and 23. DAY is an integer between 1 and 31. MONTH is an
2175 integer between 1 and 12. YEAR is an integer indicating the
2176 four-digit year. DOW is the day of week, an integer between 0 and 6,
2177 where 0 is Sunday. DST is t if daylight saving time is in effect,
2178 otherwise nil. UTCOFF is an integer indicating the UTC offset in
2179 seconds, i.e., the number of seconds east of Greenwich. (Note that
2180 Common Lisp has different meanings for DOW and UTCOFF.)
2182 usage: (decode-time &optional TIME ZONE) */)
2183 (Lisp_Object specified_time, Lisp_Object zone)
2185 time_t time_spec = lisp_seconds_argument (specified_time);
2186 struct tm local_tm, gmt_tm;
2187 timezone_t tz = tzlookup (zone, false);
2188 struct tm *tm = emacs_localtime_rz (tz, &time_spec, &local_tm);
2189 xtzfree (tz);
2191 if (! (tm
2192 && MOST_NEGATIVE_FIXNUM - TM_YEAR_BASE <= local_tm.tm_year
2193 && local_tm.tm_year <= MOST_POSITIVE_FIXNUM - TM_YEAR_BASE))
2194 time_overflow ();
2196 /* Avoid overflow when INT_MAX < EMACS_INT_MAX. */
2197 EMACS_INT tm_year_base = TM_YEAR_BASE;
2199 return CALLN (Flist,
2200 make_number (local_tm.tm_sec),
2201 make_number (local_tm.tm_min),
2202 make_number (local_tm.tm_hour),
2203 make_number (local_tm.tm_mday),
2204 make_number (local_tm.tm_mon + 1),
2205 make_number (local_tm.tm_year + tm_year_base),
2206 make_number (local_tm.tm_wday),
2207 local_tm.tm_isdst ? Qt : Qnil,
2208 (HAVE_TM_GMTOFF
2209 ? make_number (tm_gmtoff (&local_tm))
2210 : gmtime_r (&time_spec, &gmt_tm)
2211 ? make_number (tm_diff (&local_tm, &gmt_tm))
2212 : Qnil));
2215 /* Return OBJ - OFFSET, checking that OBJ is a valid fixnum and that
2216 the result is representable as an int. */
2217 static int
2218 check_tm_member (Lisp_Object obj, int offset)
2220 CHECK_NUMBER (obj);
2221 EMACS_INT n = XINT (obj);
2222 int result;
2223 if (INT_SUBTRACT_WRAPV (n, offset, &result))
2224 time_overflow ();
2225 return result;
2228 DEFUN ("encode-time", Fencode_time, Sencode_time, 6, MANY, 0,
2229 doc: /* Convert SECOND, MINUTE, HOUR, DAY, MONTH, YEAR and ZONE to internal time.
2230 This is the reverse operation of `decode-time', which see.
2232 The optional ZONE is omitted or nil for Emacs local time, t for
2233 Universal Time, `wall' for system wall clock time, or a string as in
2234 the TZ environment variable. It can also be a list (as from
2235 `current-time-zone') or an integer (as from `decode-time') applied
2236 without consideration for daylight saving time.
2238 You can pass more than 7 arguments; then the first six arguments
2239 are used as SECOND through YEAR, and the *last* argument is used as ZONE.
2240 The intervening arguments are ignored.
2241 This feature lets (apply \\='encode-time (decode-time ...)) work.
2243 Out-of-range values for SECOND, MINUTE, HOUR, DAY, or MONTH are allowed;
2244 for example, a DAY of 0 means the day preceding the given month.
2245 Year numbers less than 100 are treated just like other year numbers.
2246 If you want them to stand for years in this century, you must do that yourself.
2248 Years before 1970 are not guaranteed to work. On some systems,
2249 year values as low as 1901 do work.
2251 usage: (encode-time SECOND MINUTE HOUR DAY MONTH YEAR &optional ZONE) */)
2252 (ptrdiff_t nargs, Lisp_Object *args)
2254 time_t value;
2255 struct tm tm;
2256 Lisp_Object zone = (nargs > 6 ? args[nargs - 1] : Qnil);
2258 tm.tm_sec = check_tm_member (args[0], 0);
2259 tm.tm_min = check_tm_member (args[1], 0);
2260 tm.tm_hour = check_tm_member (args[2], 0);
2261 tm.tm_mday = check_tm_member (args[3], 0);
2262 tm.tm_mon = check_tm_member (args[4], 1);
2263 tm.tm_year = check_tm_member (args[5], TM_YEAR_BASE);
2264 tm.tm_isdst = -1;
2266 timezone_t tz = tzlookup (zone, false);
2267 value = emacs_mktime_z (tz, &tm);
2268 xtzfree (tz);
2270 if (value == (time_t) -1)
2271 time_overflow ();
2273 return list2i (hi_time (value), lo_time (value));
2276 DEFUN ("current-time-string", Fcurrent_time_string, Scurrent_time_string,
2277 0, 2, 0,
2278 doc: /* Return the current local time, as a human-readable string.
2279 Programs can use this function to decode a time,
2280 since the number of columns in each field is fixed
2281 if the year is in the range 1000-9999.
2282 The format is `Sun Sep 16 01:03:52 1973'.
2283 However, see also the functions `decode-time' and `format-time-string'
2284 which provide a much more powerful and general facility.
2286 If SPECIFIED-TIME is given, it is a time to format instead of the
2287 current time. The argument should have the form (HIGH LOW . IGNORED).
2288 Thus, you can use times obtained from `current-time' and from
2289 `file-attributes'. SPECIFIED-TIME can also be a single integer number
2290 of seconds since the epoch. The obsolete form (HIGH . LOW) is also
2291 still accepted.
2293 The optional ZONE is omitted or nil for Emacs local time, t for
2294 Universal Time, `wall' for system wall clock time, or a string as in
2295 the TZ environment variable. It can also be a list (as from
2296 `current-time-zone') or an integer (as from `decode-time') applied
2297 without consideration for daylight saving time. */)
2298 (Lisp_Object specified_time, Lisp_Object zone)
2300 time_t value = lisp_seconds_argument (specified_time);
2301 timezone_t tz = tzlookup (zone, false);
2303 /* Convert to a string in ctime format, except without the trailing
2304 newline, and without the 4-digit year limit. Don't use asctime
2305 or ctime, as they might dump core if the year is outside the
2306 range -999 .. 9999. */
2307 struct tm tm;
2308 struct tm *tmp = emacs_localtime_rz (tz, &value, &tm);
2309 xtzfree (tz);
2310 if (! tmp)
2311 time_overflow ();
2313 static char const wday_name[][4] =
2314 { "Sun", "Mon", "Tue", "Wed", "Thu", "Fri", "Sat" };
2315 static char const mon_name[][4] =
2316 { "Jan", "Feb", "Mar", "Apr", "May", "Jun",
2317 "Jul", "Aug", "Sep", "Oct", "Nov", "Dec" };
2318 printmax_t year_base = TM_YEAR_BASE;
2319 char buf[sizeof "Mon Apr 30 12:49:17 " + INT_STRLEN_BOUND (int) + 1];
2320 int len = sprintf (buf, "%s %s%3d %02d:%02d:%02d %"pMd,
2321 wday_name[tm.tm_wday], mon_name[tm.tm_mon], tm.tm_mday,
2322 tm.tm_hour, tm.tm_min, tm.tm_sec,
2323 tm.tm_year + year_base);
2325 return make_unibyte_string (buf, len);
2328 /* Yield A - B, measured in seconds.
2329 This function is copied from the GNU C Library. */
2330 static int
2331 tm_diff (struct tm *a, struct tm *b)
2333 /* Compute intervening leap days correctly even if year is negative.
2334 Take care to avoid int overflow in leap day calculations,
2335 but it's OK to assume that A and B are close to each other. */
2336 int a4 = (a->tm_year >> 2) + (TM_YEAR_BASE >> 2) - ! (a->tm_year & 3);
2337 int b4 = (b->tm_year >> 2) + (TM_YEAR_BASE >> 2) - ! (b->tm_year & 3);
2338 int a100 = a4 / 25 - (a4 % 25 < 0);
2339 int b100 = b4 / 25 - (b4 % 25 < 0);
2340 int a400 = a100 >> 2;
2341 int b400 = b100 >> 2;
2342 int intervening_leap_days = (a4 - b4) - (a100 - b100) + (a400 - b400);
2343 int years = a->tm_year - b->tm_year;
2344 int days = (365 * years + intervening_leap_days
2345 + (a->tm_yday - b->tm_yday));
2346 return (60 * (60 * (24 * days + (a->tm_hour - b->tm_hour))
2347 + (a->tm_min - b->tm_min))
2348 + (a->tm_sec - b->tm_sec));
2351 /* Yield A's UTC offset, or an unspecified value if unknown. */
2352 static long int
2353 tm_gmtoff (struct tm *a)
2355 #if HAVE_TM_GMTOFF
2356 return a->tm_gmtoff;
2357 #else
2358 return 0;
2359 #endif
2362 DEFUN ("current-time-zone", Fcurrent_time_zone, Scurrent_time_zone, 0, 2, 0,
2363 doc: /* Return the offset and name for the local time zone.
2364 This returns a list of the form (OFFSET NAME).
2365 OFFSET is an integer number of seconds ahead of UTC (east of Greenwich).
2366 A negative value means west of Greenwich.
2367 NAME is a string giving the name of the time zone.
2368 If SPECIFIED-TIME is given, the time zone offset is determined from it
2369 instead of using the current time. The argument should have the form
2370 \(HIGH LOW . IGNORED). Thus, you can use times obtained from
2371 `current-time' and from `file-attributes'. SPECIFIED-TIME can also be
2372 a single integer number of seconds since the epoch. The obsolete form
2373 (HIGH . LOW) is also still accepted.
2375 The optional ZONE is omitted or nil for Emacs local time, t for
2376 Universal Time, `wall' for system wall clock time, or a string as in
2377 the TZ environment variable. It can also be a list (as from
2378 `current-time-zone') or an integer (as from `decode-time') applied
2379 without consideration for daylight saving time.
2381 Some operating systems cannot provide all this information to Emacs;
2382 in this case, `current-time-zone' returns a list containing nil for
2383 the data it can't find. */)
2384 (Lisp_Object specified_time, Lisp_Object zone)
2386 struct timespec value;
2387 struct tm local_tm, gmt_tm;
2388 Lisp_Object zone_offset, zone_name;
2390 zone_offset = Qnil;
2391 value = make_timespec (lisp_seconds_argument (specified_time), 0);
2392 zone_name = format_time_string ("%Z", sizeof "%Z" - 1, value,
2393 zone, &local_tm);
2395 /* gmtime_r expects a pointer to time_t, but tv_sec of struct
2396 timespec on some systems (MinGW) is a 64-bit field. */
2397 time_t tsec = value.tv_sec;
2398 if (HAVE_TM_GMTOFF || gmtime_r (&tsec, &gmt_tm))
2400 long int offset = (HAVE_TM_GMTOFF
2401 ? tm_gmtoff (&local_tm)
2402 : tm_diff (&local_tm, &gmt_tm));
2403 zone_offset = make_number (offset);
2404 if (SCHARS (zone_name) == 0)
2406 /* No local time zone name is available; use numeric zone instead. */
2407 long int hour = offset / 3600;
2408 int min_sec = offset % 3600;
2409 int amin_sec = min_sec < 0 ? - min_sec : min_sec;
2410 int min = amin_sec / 60;
2411 int sec = amin_sec % 60;
2412 int min_prec = min_sec ? 2 : 0;
2413 int sec_prec = sec ? 2 : 0;
2414 char buf[sizeof "+0000" + INT_STRLEN_BOUND (long int)];
2415 zone_name = make_formatted_string (buf, "%c%.2ld%.*d%.*d",
2416 (offset < 0 ? '-' : '+'),
2417 hour, min_prec, min, sec_prec, sec);
2421 return list2 (zone_offset, zone_name);
2424 DEFUN ("set-time-zone-rule", Fset_time_zone_rule, Sset_time_zone_rule, 1, 1, 0,
2425 doc: /* Set the Emacs local time zone using TZ, a string specifying a time zone rule.
2426 If TZ is nil or `wall', use system wall clock time; this differs from
2427 the usual Emacs convention where nil means current local time. If TZ
2428 is t, use Universal Time. If TZ is a list (as from
2429 `current-time-zone') or an integer (as from `decode-time'), use the
2430 specified time zone without consideration for daylight saving time.
2432 Instead of calling this function, you typically want something else.
2433 To temporarily use a different time zone rule for just one invocation
2434 of `decode-time', `encode-time', or `format-time-string', pass the
2435 function a ZONE argument. To change local time consistently
2436 throughout Emacs, call (setenv "TZ" TZ): this changes both the
2437 environment of the Emacs process and the variable
2438 `process-environment', whereas `set-time-zone-rule' affects only the
2439 former. */)
2440 (Lisp_Object tz)
2442 tzlookup (NILP (tz) ? Qwall : tz, true);
2443 return Qnil;
2446 /* A buffer holding a string of the form "TZ=value", intended
2447 to be part of the environment. If TZ is supposed to be unset,
2448 the buffer string is "tZ=". */
2449 static char *tzvalbuf;
2451 /* Get the local time zone rule. */
2452 char *
2453 emacs_getenv_TZ (void)
2455 return tzvalbuf[0] == 'T' ? tzvalbuf + tzeqlen : 0;
2458 /* Set the local time zone rule to TZSTRING, which can be null to
2459 denote wall clock time. Do not record the setting in LOCAL_TZ.
2461 This function is not thread-safe, in theory because putenv is not,
2462 but mostly because of the static storage it updates. Other threads
2463 that invoke localtime etc. may be adversely affected while this
2464 function is executing. */
2467 emacs_setenv_TZ (const char *tzstring)
2469 static ptrdiff_t tzvalbufsize;
2470 ptrdiff_t tzstringlen = tzstring ? strlen (tzstring) : 0;
2471 char *tzval = tzvalbuf;
2472 bool new_tzvalbuf = tzvalbufsize <= tzeqlen + tzstringlen;
2474 if (new_tzvalbuf)
2476 /* Do not attempt to free the old tzvalbuf, since another thread
2477 may be using it. In practice, the first allocation is large
2478 enough and memory does not leak. */
2479 tzval = xpalloc (NULL, &tzvalbufsize,
2480 tzeqlen + tzstringlen - tzvalbufsize + 1, -1, 1);
2481 tzvalbuf = tzval;
2482 tzval[1] = 'Z';
2483 tzval[2] = '=';
2486 if (tzstring)
2488 /* Modify TZVAL in place. Although this is dicey in a
2489 multithreaded environment, we know of no portable alternative.
2490 Calling putenv or setenv could crash some other thread. */
2491 tzval[0] = 'T';
2492 strcpy (tzval + tzeqlen, tzstring);
2494 else
2496 /* Turn 'TZ=whatever' into an empty environment variable 'tZ='.
2497 Although this is also dicey, calling unsetenv here can crash Emacs.
2498 See Bug#8705. */
2499 tzval[0] = 't';
2500 tzval[tzeqlen] = 0;
2504 #ifndef WINDOWSNT
2505 /* Modifying *TZVAL merely requires calling tzset (which is the
2506 caller's responsibility). However, modifying TZVAL requires
2507 calling putenv; although this is not thread-safe, in practice this
2508 runs only on startup when there is only one thread. */
2509 bool need_putenv = new_tzvalbuf;
2510 #else
2511 /* MS-Windows 'putenv' copies the argument string into a block it
2512 allocates, so modifying *TZVAL will not change the environment.
2513 However, the other threads run by Emacs on MS-Windows never call
2514 'xputenv' or 'putenv' or 'unsetenv', so the original cause for the
2515 dicey in-place modification technique doesn't exist there in the
2516 first place. */
2517 bool need_putenv = true;
2518 #endif
2519 if (need_putenv)
2520 xputenv (tzval);
2522 return 0;
2525 /* Insert NARGS Lisp objects in the array ARGS by calling INSERT_FUNC
2526 (if a type of object is Lisp_Int) or INSERT_FROM_STRING_FUNC (if a
2527 type of object is Lisp_String). INHERIT is passed to
2528 INSERT_FROM_STRING_FUNC as the last argument. */
2530 static void
2531 general_insert_function (void (*insert_func)
2532 (const char *, ptrdiff_t),
2533 void (*insert_from_string_func)
2534 (Lisp_Object, ptrdiff_t, ptrdiff_t,
2535 ptrdiff_t, ptrdiff_t, bool),
2536 bool inherit, ptrdiff_t nargs, Lisp_Object *args)
2538 ptrdiff_t argnum;
2539 Lisp_Object val;
2541 for (argnum = 0; argnum < nargs; argnum++)
2543 val = args[argnum];
2544 if (CHARACTERP (val))
2546 int c = XFASTINT (val);
2547 unsigned char str[MAX_MULTIBYTE_LENGTH];
2548 int len;
2550 if (!NILP (BVAR (current_buffer, enable_multibyte_characters)))
2551 len = CHAR_STRING (c, str);
2552 else
2554 str[0] = CHAR_TO_BYTE8 (c);
2555 len = 1;
2557 (*insert_func) ((char *) str, len);
2559 else if (STRINGP (val))
2561 (*insert_from_string_func) (val, 0, 0,
2562 SCHARS (val),
2563 SBYTES (val),
2564 inherit);
2566 else
2567 wrong_type_argument (Qchar_or_string_p, val);
2571 void
2572 insert1 (Lisp_Object arg)
2574 Finsert (1, &arg);
2578 DEFUN ("insert", Finsert, Sinsert, 0, MANY, 0,
2579 doc: /* Insert the arguments, either strings or characters, at point.
2580 Point and after-insertion markers move forward to end up
2581 after the inserted text.
2582 Any other markers at the point of insertion remain before the text.
2584 If the current buffer is multibyte, unibyte strings are converted
2585 to multibyte for insertion (see `string-make-multibyte').
2586 If the current buffer is unibyte, multibyte strings are converted
2587 to unibyte for insertion (see `string-make-unibyte').
2589 When operating on binary data, it may be necessary to preserve the
2590 original bytes of a unibyte string when inserting it into a multibyte
2591 buffer; to accomplish this, apply `string-as-multibyte' to the string
2592 and insert the result.
2594 usage: (insert &rest ARGS) */)
2595 (ptrdiff_t nargs, Lisp_Object *args)
2597 general_insert_function (insert, insert_from_string, 0, nargs, args);
2598 return Qnil;
2601 DEFUN ("insert-and-inherit", Finsert_and_inherit, Sinsert_and_inherit,
2602 0, MANY, 0,
2603 doc: /* Insert the arguments at point, inheriting properties from adjoining text.
2604 Point and after-insertion markers move forward to end up
2605 after the inserted text.
2606 Any other markers at the point of insertion remain before the text.
2608 If the current buffer is multibyte, unibyte strings are converted
2609 to multibyte for insertion (see `unibyte-char-to-multibyte').
2610 If the current buffer is unibyte, multibyte strings are converted
2611 to unibyte for insertion.
2613 usage: (insert-and-inherit &rest ARGS) */)
2614 (ptrdiff_t nargs, Lisp_Object *args)
2616 general_insert_function (insert_and_inherit, insert_from_string, 1,
2617 nargs, args);
2618 return Qnil;
2621 DEFUN ("insert-before-markers", Finsert_before_markers, Sinsert_before_markers, 0, MANY, 0,
2622 doc: /* Insert strings or characters at point, relocating markers after the text.
2623 Point and markers move forward to end up after the inserted text.
2625 If the current buffer is multibyte, unibyte strings are converted
2626 to multibyte for insertion (see `unibyte-char-to-multibyte').
2627 If the current buffer is unibyte, multibyte strings are converted
2628 to unibyte for insertion.
2630 If an overlay begins at the insertion point, the inserted text falls
2631 outside the overlay; if a nonempty overlay ends at the insertion
2632 point, the inserted text falls inside that overlay.
2634 usage: (insert-before-markers &rest ARGS) */)
2635 (ptrdiff_t nargs, Lisp_Object *args)
2637 general_insert_function (insert_before_markers,
2638 insert_from_string_before_markers, 0,
2639 nargs, args);
2640 return Qnil;
2643 DEFUN ("insert-before-markers-and-inherit", Finsert_and_inherit_before_markers,
2644 Sinsert_and_inherit_before_markers, 0, MANY, 0,
2645 doc: /* Insert text at point, relocating markers and inheriting properties.
2646 Point and markers move forward to end up after the inserted text.
2648 If the current buffer is multibyte, unibyte strings are converted
2649 to multibyte for insertion (see `unibyte-char-to-multibyte').
2650 If the current buffer is unibyte, multibyte strings are converted
2651 to unibyte for insertion.
2653 usage: (insert-before-markers-and-inherit &rest ARGS) */)
2654 (ptrdiff_t nargs, Lisp_Object *args)
2656 general_insert_function (insert_before_markers_and_inherit,
2657 insert_from_string_before_markers, 1,
2658 nargs, args);
2659 return Qnil;
2662 DEFUN ("insert-char", Finsert_char, Sinsert_char, 1, 3,
2663 "(list (read-char-by-name \"Insert character (Unicode name or hex): \")\
2664 (prefix-numeric-value current-prefix-arg)\
2665 t))",
2666 doc: /* Insert COUNT copies of CHARACTER.
2667 Interactively, prompt for CHARACTER. You can specify CHARACTER in one
2668 of these ways:
2670 - As its Unicode character name, e.g. \"LATIN SMALL LETTER A\".
2671 Completion is available; if you type a substring of the name
2672 preceded by an asterisk `*', Emacs shows all names which include
2673 that substring, not necessarily at the beginning of the name.
2675 - As a hexadecimal code point, e.g. 263A. Note that code points in
2676 Emacs are equivalent to Unicode up to 10FFFF (which is the limit of
2677 the Unicode code space).
2679 - As a code point with a radix specified with #, e.g. #o21430
2680 (octal), #x2318 (hex), or #10r8984 (decimal).
2682 If called interactively, COUNT is given by the prefix argument. If
2683 omitted or nil, it defaults to 1.
2685 Inserting the character(s) relocates point and before-insertion
2686 markers in the same ways as the function `insert'.
2688 The optional third argument INHERIT, if non-nil, says to inherit text
2689 properties from adjoining text, if those properties are sticky. If
2690 called interactively, INHERIT is t. */)
2691 (Lisp_Object character, Lisp_Object count, Lisp_Object inherit)
2693 int i, stringlen;
2694 register ptrdiff_t n;
2695 int c, len;
2696 unsigned char str[MAX_MULTIBYTE_LENGTH];
2697 char string[4000];
2699 CHECK_CHARACTER (character);
2700 if (NILP (count))
2701 XSETFASTINT (count, 1);
2702 CHECK_NUMBER (count);
2703 c = XFASTINT (character);
2705 if (!NILP (BVAR (current_buffer, enable_multibyte_characters)))
2706 len = CHAR_STRING (c, str);
2707 else
2708 str[0] = c, len = 1;
2709 if (XINT (count) <= 0)
2710 return Qnil;
2711 if (BUF_BYTES_MAX / len < XINT (count))
2712 buffer_overflow ();
2713 n = XINT (count) * len;
2714 stringlen = min (n, sizeof string - sizeof string % len);
2715 for (i = 0; i < stringlen; i++)
2716 string[i] = str[i % len];
2717 while (n > stringlen)
2719 maybe_quit ();
2720 if (!NILP (inherit))
2721 insert_and_inherit (string, stringlen);
2722 else
2723 insert (string, stringlen);
2724 n -= stringlen;
2726 if (!NILP (inherit))
2727 insert_and_inherit (string, n);
2728 else
2729 insert (string, n);
2730 return Qnil;
2733 DEFUN ("insert-byte", Finsert_byte, Sinsert_byte, 2, 3, 0,
2734 doc: /* Insert COUNT (second arg) copies of BYTE (first arg).
2735 Both arguments are required.
2736 BYTE is a number of the range 0..255.
2738 If BYTE is 128..255 and the current buffer is multibyte, the
2739 corresponding eight-bit character is inserted.
2741 Point, and before-insertion markers, are relocated as in the function `insert'.
2742 The optional third arg INHERIT, if non-nil, says to inherit text properties
2743 from adjoining text, if those properties are sticky. */)
2744 (Lisp_Object byte, Lisp_Object count, Lisp_Object inherit)
2746 CHECK_NUMBER (byte);
2747 if (XINT (byte) < 0 || XINT (byte) > 255)
2748 args_out_of_range_3 (byte, make_number (0), make_number (255));
2749 if (XINT (byte) >= 128
2750 && ! NILP (BVAR (current_buffer, enable_multibyte_characters)))
2751 XSETFASTINT (byte, BYTE8_TO_CHAR (XINT (byte)));
2752 return Finsert_char (byte, count, inherit);
2756 /* Making strings from buffer contents. */
2758 /* Return a Lisp_String containing the text of the current buffer from
2759 START to END. If text properties are in use and the current buffer
2760 has properties in the range specified, the resulting string will also
2761 have them, if PROPS is true.
2763 We don't want to use plain old make_string here, because it calls
2764 make_uninit_string, which can cause the buffer arena to be
2765 compacted. make_string has no way of knowing that the data has
2766 been moved, and thus copies the wrong data into the string. This
2767 doesn't effect most of the other users of make_string, so it should
2768 be left as is. But we should use this function when conjuring
2769 buffer substrings. */
2771 Lisp_Object
2772 make_buffer_string (ptrdiff_t start, ptrdiff_t end, bool props)
2774 ptrdiff_t start_byte = CHAR_TO_BYTE (start);
2775 ptrdiff_t end_byte = CHAR_TO_BYTE (end);
2777 return make_buffer_string_both (start, start_byte, end, end_byte, props);
2780 /* Return a Lisp_String containing the text of the current buffer from
2781 START / START_BYTE to END / END_BYTE.
2783 If text properties are in use and the current buffer
2784 has properties in the range specified, the resulting string will also
2785 have them, if PROPS is true.
2787 We don't want to use plain old make_string here, because it calls
2788 make_uninit_string, which can cause the buffer arena to be
2789 compacted. make_string has no way of knowing that the data has
2790 been moved, and thus copies the wrong data into the string. This
2791 doesn't effect most of the other users of make_string, so it should
2792 be left as is. But we should use this function when conjuring
2793 buffer substrings. */
2795 Lisp_Object
2796 make_buffer_string_both (ptrdiff_t start, ptrdiff_t start_byte,
2797 ptrdiff_t end, ptrdiff_t end_byte, bool props)
2799 Lisp_Object result, tem, tem1;
2800 ptrdiff_t beg0, end0, beg1, end1, size;
2802 if (start_byte < GPT_BYTE && GPT_BYTE < end_byte)
2804 /* Two regions, before and after the gap. */
2805 beg0 = start_byte;
2806 end0 = GPT_BYTE;
2807 beg1 = GPT_BYTE + GAP_SIZE - BEG_BYTE;
2808 end1 = end_byte + GAP_SIZE - BEG_BYTE;
2810 else
2812 /* The only region. */
2813 beg0 = start_byte;
2814 end0 = end_byte;
2815 beg1 = -1;
2816 end1 = -1;
2819 if (! NILP (BVAR (current_buffer, enable_multibyte_characters)))
2820 result = make_uninit_multibyte_string (end - start, end_byte - start_byte);
2821 else
2822 result = make_uninit_string (end - start);
2824 size = end0 - beg0;
2825 memcpy (SDATA (result), BYTE_POS_ADDR (beg0), size);
2826 if (beg1 != -1)
2827 memcpy (SDATA (result) + size, BEG_ADDR + beg1, end1 - beg1);
2829 /* If desired, update and copy the text properties. */
2830 if (props)
2832 update_buffer_properties (start, end);
2834 tem = Fnext_property_change (make_number (start), Qnil, make_number (end));
2835 tem1 = Ftext_properties_at (make_number (start), Qnil);
2837 if (XINT (tem) != end || !NILP (tem1))
2838 copy_intervals_to_string (result, current_buffer, start,
2839 end - start);
2842 return result;
2845 /* Call Vbuffer_access_fontify_functions for the range START ... END
2846 in the current buffer, if necessary. */
2848 static void
2849 update_buffer_properties (ptrdiff_t start, ptrdiff_t end)
2851 /* If this buffer has some access functions,
2852 call them, specifying the range of the buffer being accessed. */
2853 if (!NILP (Vbuffer_access_fontify_functions))
2855 /* But don't call them if we can tell that the work
2856 has already been done. */
2857 if (!NILP (Vbuffer_access_fontified_property))
2859 Lisp_Object tem
2860 = Ftext_property_any (make_number (start), make_number (end),
2861 Vbuffer_access_fontified_property,
2862 Qnil, Qnil);
2863 if (NILP (tem))
2864 return;
2867 CALLN (Frun_hook_with_args, Qbuffer_access_fontify_functions,
2868 make_number (start), make_number (end));
2872 DEFUN ("buffer-substring", Fbuffer_substring, Sbuffer_substring, 2, 2, 0,
2873 doc: /* Return the contents of part of the current buffer as a string.
2874 The two arguments START and END are character positions;
2875 they can be in either order.
2876 The string returned is multibyte if the buffer is multibyte.
2878 This function copies the text properties of that part of the buffer
2879 into the result string; if you don't want the text properties,
2880 use `buffer-substring-no-properties' instead. */)
2881 (Lisp_Object start, Lisp_Object end)
2883 register ptrdiff_t b, e;
2885 validate_region (&start, &end);
2886 b = XINT (start);
2887 e = XINT (end);
2889 return make_buffer_string (b, e, 1);
2892 DEFUN ("buffer-substring-no-properties", Fbuffer_substring_no_properties,
2893 Sbuffer_substring_no_properties, 2, 2, 0,
2894 doc: /* Return the characters of part of the buffer, without the text properties.
2895 The two arguments START and END are character positions;
2896 they can be in either order. */)
2897 (Lisp_Object start, Lisp_Object end)
2899 register ptrdiff_t b, e;
2901 validate_region (&start, &end);
2902 b = XINT (start);
2903 e = XINT (end);
2905 return make_buffer_string (b, e, 0);
2908 DEFUN ("buffer-string", Fbuffer_string, Sbuffer_string, 0, 0, 0,
2909 doc: /* Return the contents of the current buffer as a string.
2910 If narrowing is in effect, this function returns only the visible part
2911 of the buffer. */)
2912 (void)
2914 return make_buffer_string_both (BEGV, BEGV_BYTE, ZV, ZV_BYTE, 1);
2917 DEFUN ("insert-buffer-substring", Finsert_buffer_substring, Sinsert_buffer_substring,
2918 1, 3, 0,
2919 doc: /* Insert before point a substring of the contents of BUFFER.
2920 BUFFER may be a buffer or a buffer name.
2921 Arguments START and END are character positions specifying the substring.
2922 They default to the values of (point-min) and (point-max) in BUFFER.
2924 Point and before-insertion markers move forward to end up after the
2925 inserted text.
2926 Any other markers at the point of insertion remain before the text.
2928 If the current buffer is multibyte and BUFFER is unibyte, or vice
2929 versa, strings are converted from unibyte to multibyte or vice versa
2930 using `string-make-multibyte' or `string-make-unibyte', which see. */)
2931 (Lisp_Object buffer, Lisp_Object start, Lisp_Object end)
2933 register EMACS_INT b, e, temp;
2934 register struct buffer *bp, *obuf;
2935 Lisp_Object buf;
2937 buf = Fget_buffer (buffer);
2938 if (NILP (buf))
2939 nsberror (buffer);
2940 bp = XBUFFER (buf);
2941 if (!BUFFER_LIVE_P (bp))
2942 error ("Selecting deleted buffer");
2944 if (NILP (start))
2945 b = BUF_BEGV (bp);
2946 else
2948 CHECK_NUMBER_COERCE_MARKER (start);
2949 b = XINT (start);
2951 if (NILP (end))
2952 e = BUF_ZV (bp);
2953 else
2955 CHECK_NUMBER_COERCE_MARKER (end);
2956 e = XINT (end);
2959 if (b > e)
2960 temp = b, b = e, e = temp;
2962 if (!(BUF_BEGV (bp) <= b && e <= BUF_ZV (bp)))
2963 args_out_of_range (start, end);
2965 obuf = current_buffer;
2966 set_buffer_internal_1 (bp);
2967 update_buffer_properties (b, e);
2968 set_buffer_internal_1 (obuf);
2970 insert_from_buffer (bp, b, e - b, 0);
2971 return Qnil;
2974 DEFUN ("compare-buffer-substrings", Fcompare_buffer_substrings, Scompare_buffer_substrings,
2975 6, 6, 0,
2976 doc: /* Compare two substrings of two buffers; return result as number.
2977 Return -N if first string is less after N-1 chars, +N if first string is
2978 greater after N-1 chars, or 0 if strings match.
2979 The first substring is in BUFFER1 from START1 to END1 and the second
2980 is in BUFFER2 from START2 to END2.
2981 All arguments may be nil. If BUFFER1 or BUFFER2 is nil, the current
2982 buffer is used. If START1 or START2 is nil, the value of `point-min'
2983 in the respective buffers is used. If END1 or END2 is nil, the value
2984 of `point-max' in the respective buffers is used.
2985 The value of `case-fold-search' in the current buffer
2986 determines whether case is significant or ignored. */)
2987 (Lisp_Object buffer1, Lisp_Object start1, Lisp_Object end1, Lisp_Object buffer2, Lisp_Object start2, Lisp_Object end2)
2989 register EMACS_INT begp1, endp1, begp2, endp2, temp;
2990 register struct buffer *bp1, *bp2;
2991 register Lisp_Object trt
2992 = (!NILP (BVAR (current_buffer, case_fold_search))
2993 ? BVAR (current_buffer, case_canon_table) : Qnil);
2994 ptrdiff_t chars = 0;
2995 ptrdiff_t i1, i2, i1_byte, i2_byte;
2997 /* Find the first buffer and its substring. */
2999 if (NILP (buffer1))
3000 bp1 = current_buffer;
3001 else
3003 Lisp_Object buf1;
3004 buf1 = Fget_buffer (buffer1);
3005 if (NILP (buf1))
3006 nsberror (buffer1);
3007 bp1 = XBUFFER (buf1);
3008 if (!BUFFER_LIVE_P (bp1))
3009 error ("Selecting deleted buffer");
3012 if (NILP (start1))
3013 begp1 = BUF_BEGV (bp1);
3014 else
3016 CHECK_NUMBER_COERCE_MARKER (start1);
3017 begp1 = XINT (start1);
3019 if (NILP (end1))
3020 endp1 = BUF_ZV (bp1);
3021 else
3023 CHECK_NUMBER_COERCE_MARKER (end1);
3024 endp1 = XINT (end1);
3027 if (begp1 > endp1)
3028 temp = begp1, begp1 = endp1, endp1 = temp;
3030 if (!(BUF_BEGV (bp1) <= begp1
3031 && begp1 <= endp1
3032 && endp1 <= BUF_ZV (bp1)))
3033 args_out_of_range (start1, end1);
3035 /* Likewise for second substring. */
3037 if (NILP (buffer2))
3038 bp2 = current_buffer;
3039 else
3041 Lisp_Object buf2;
3042 buf2 = Fget_buffer (buffer2);
3043 if (NILP (buf2))
3044 nsberror (buffer2);
3045 bp2 = XBUFFER (buf2);
3046 if (!BUFFER_LIVE_P (bp2))
3047 error ("Selecting deleted buffer");
3050 if (NILP (start2))
3051 begp2 = BUF_BEGV (bp2);
3052 else
3054 CHECK_NUMBER_COERCE_MARKER (start2);
3055 begp2 = XINT (start2);
3057 if (NILP (end2))
3058 endp2 = BUF_ZV (bp2);
3059 else
3061 CHECK_NUMBER_COERCE_MARKER (end2);
3062 endp2 = XINT (end2);
3065 if (begp2 > endp2)
3066 temp = begp2, begp2 = endp2, endp2 = temp;
3068 if (!(BUF_BEGV (bp2) <= begp2
3069 && begp2 <= endp2
3070 && endp2 <= BUF_ZV (bp2)))
3071 args_out_of_range (start2, end2);
3073 i1 = begp1;
3074 i2 = begp2;
3075 i1_byte = buf_charpos_to_bytepos (bp1, i1);
3076 i2_byte = buf_charpos_to_bytepos (bp2, i2);
3078 while (i1 < endp1 && i2 < endp2)
3080 /* When we find a mismatch, we must compare the
3081 characters, not just the bytes. */
3082 int c1, c2;
3084 if (! NILP (BVAR (bp1, enable_multibyte_characters)))
3086 c1 = BUF_FETCH_MULTIBYTE_CHAR (bp1, i1_byte);
3087 BUF_INC_POS (bp1, i1_byte);
3088 i1++;
3090 else
3092 c1 = BUF_FETCH_BYTE (bp1, i1);
3093 MAKE_CHAR_MULTIBYTE (c1);
3094 i1++;
3097 if (! NILP (BVAR (bp2, enable_multibyte_characters)))
3099 c2 = BUF_FETCH_MULTIBYTE_CHAR (bp2, i2_byte);
3100 BUF_INC_POS (bp2, i2_byte);
3101 i2++;
3103 else
3105 c2 = BUF_FETCH_BYTE (bp2, i2);
3106 MAKE_CHAR_MULTIBYTE (c2);
3107 i2++;
3110 if (!NILP (trt))
3112 c1 = char_table_translate (trt, c1);
3113 c2 = char_table_translate (trt, c2);
3116 if (c1 != c2)
3117 return make_number (c1 < c2 ? -1 - chars : chars + 1);
3119 chars++;
3120 rarely_quit (chars);
3123 /* The strings match as far as they go.
3124 If one is shorter, that one is less. */
3125 if (chars < endp1 - begp1)
3126 return make_number (chars + 1);
3127 else if (chars < endp2 - begp2)
3128 return make_number (- chars - 1);
3130 /* Same length too => they are equal. */
3131 return make_number (0);
3135 /* Set up necessary definitions for diffseq.h; see comments in
3136 diffseq.h for explanation. */
3138 #undef ELEMENT
3139 #undef EQUAL
3141 #define XVECREF_YVECREF_EQUAL(ctx, xoff, yoff) \
3142 buffer_chars_equal ((ctx), (xoff), (yoff))
3144 #define OFFSET ptrdiff_t
3146 #define EXTRA_CONTEXT_FIELDS \
3147 /* Buffers to compare. */ \
3148 struct buffer *buffer_a; \
3149 struct buffer *buffer_b; \
3150 /* Bit vectors recording for each character whether it was deleted
3151 or inserted. */ \
3152 unsigned char *deletions; \
3153 unsigned char *insertions;
3155 #define NOTE_DELETE(ctx, xoff) set_bit ((ctx)->deletions, (xoff))
3156 #define NOTE_INSERT(ctx, yoff) set_bit ((ctx)->insertions, (yoff))
3158 struct context;
3159 static void set_bit (unsigned char *, OFFSET);
3160 static bool bit_is_set (const unsigned char *, OFFSET);
3161 static bool buffer_chars_equal (struct context *, OFFSET, OFFSET);
3163 #include "minmax.h"
3164 #include "diffseq.h"
3166 DEFUN ("replace-buffer-contents", Freplace_buffer_contents,
3167 Sreplace_buffer_contents, 1, 1, "bSource buffer: ",
3168 doc: /* Replace accessible portion of current buffer with that of SOURCE.
3169 SOURCE can be a buffer or a string that names a buffer.
3170 Interactively, prompt for SOURCE.
3171 As far as possible the replacement is non-destructive, i.e. existing
3172 buffer contents, markers, properties, and overlays in the current
3173 buffer stay intact. */)
3174 (Lisp_Object source)
3176 struct buffer *a = current_buffer;
3177 Lisp_Object source_buffer = Fget_buffer (source);
3178 if (NILP (source_buffer))
3179 nsberror (source);
3180 struct buffer *b = XBUFFER (source_buffer);
3181 if (! BUFFER_LIVE_P (b))
3182 error ("Selecting deleted buffer");
3183 if (a == b)
3184 error ("Cannot replace a buffer with itself");
3186 ptrdiff_t min_a = BEGV;
3187 ptrdiff_t min_b = BUF_BEGV (b);
3188 ptrdiff_t size_a = ZV - min_a;
3189 ptrdiff_t size_b = BUF_ZV (b) - min_b;
3190 eassume (size_a >= 0);
3191 eassume (size_b >= 0);
3192 bool a_empty = size_a == 0;
3193 bool b_empty = size_b == 0;
3195 /* Handle trivial cases where at least one accessible portion is
3196 empty. */
3198 if (a_empty && b_empty)
3199 return Qnil;
3201 if (a_empty)
3202 return Finsert_buffer_substring (source, Qnil, Qnil);
3204 if (b_empty)
3206 del_range_both (BEGV, BEGV_BYTE, ZV, ZV_BYTE, true);
3207 return Qnil;
3210 /* FIXME: It is not documented how to initialize the contents of the
3211 context structure. This code cargo-cults from the existing
3212 caller in src/analyze.c of GNU Diffutils, which appears to
3213 work. */
3215 ptrdiff_t diags = size_a + size_b + 3;
3216 ptrdiff_t *buffer;
3217 USE_SAFE_ALLOCA;
3218 SAFE_NALLOCA (buffer, 2, diags);
3219 /* Micro-optimization: Casting to size_t generates much better
3220 code. */
3221 ptrdiff_t del_bytes = (size_t) size_a / CHAR_BIT + 1;
3222 ptrdiff_t ins_bytes = (size_t) size_b / CHAR_BIT + 1;
3223 struct context ctx = {
3224 .buffer_a = a,
3225 .buffer_b = b,
3226 .deletions = SAFE_ALLOCA (del_bytes),
3227 .insertions = SAFE_ALLOCA (ins_bytes),
3228 .fdiag = buffer + size_b + 1,
3229 .bdiag = buffer + diags + size_b + 1,
3230 /* FIXME: Find a good number for .too_expensive. */
3231 .too_expensive = 1000000,
3233 memclear (ctx.deletions, del_bytes);
3234 memclear (ctx.insertions, ins_bytes);
3235 /* compareseq requires indices to be zero-based. We add BEGV back
3236 later. */
3237 bool early_abort = compareseq (0, size_a, 0, size_b, false, &ctx);
3238 /* Since we didn’t define EARLY_ABORT, we should never abort
3239 early. */
3240 eassert (! early_abort);
3241 SAFE_FREE ();
3243 Fundo_boundary ();
3244 ptrdiff_t count = SPECPDL_INDEX ();
3245 record_unwind_protect (save_excursion_restore, save_excursion_save ());
3247 ptrdiff_t i = size_a;
3248 ptrdiff_t j = size_b;
3249 /* Walk backwards through the lists of changes. This was also
3250 cargo-culted from src/analyze.c in GNU Diffutils. Because we
3251 walk backwards, we don’t have to keep the positions in sync. */
3252 while (i >= 0 || j >= 0)
3254 /* Check whether there is a change (insertion or deletion)
3255 before the current position. */
3256 if ((i > 0 && bit_is_set (ctx.deletions, i - 1)) ||
3257 (j > 0 && bit_is_set (ctx.insertions, j - 1)))
3259 ptrdiff_t end_a = min_a + i;
3260 ptrdiff_t end_b = min_b + j;
3261 /* Find the beginning of the current change run. */
3262 while (i > 0 && bit_is_set (ctx.deletions, i - 1))
3263 --i;
3264 while (j > 0 && bit_is_set (ctx.insertions, j - 1))
3265 --j;
3266 ptrdiff_t beg_a = min_a + i;
3267 ptrdiff_t beg_b = min_b + j;
3268 eassert (beg_a >= BEGV);
3269 eassert (beg_b >= BUF_BEGV (b));
3270 eassert (beg_a <= end_a);
3271 eassert (beg_b <= end_b);
3272 eassert (end_a <= ZV);
3273 eassert (end_b <= BUF_ZV (b));
3274 eassert (beg_a < end_a || beg_b < end_b);
3275 if (beg_a < end_a)
3276 del_range (beg_a, end_a);
3277 if (beg_b < end_b)
3279 SET_PT (beg_a);
3280 Finsert_buffer_substring (source, make_natnum (beg_b),
3281 make_natnum (end_b));
3284 --i;
3285 --j;
3288 return unbind_to (count, Qnil);
3291 static void
3292 set_bit (unsigned char *a, ptrdiff_t i)
3294 eassert (i >= 0);
3295 /* Micro-optimization: Casting to size_t generates much better
3296 code. */
3297 size_t j = i;
3298 a[j / CHAR_BIT] |= (1 << (j % CHAR_BIT));
3301 static bool
3302 bit_is_set (const unsigned char *a, ptrdiff_t i)
3304 eassert (i >= 0);
3305 /* Micro-optimization: Casting to size_t generates much better
3306 code. */
3307 size_t j = i;
3308 return a[j / CHAR_BIT] & (1 << (j % CHAR_BIT));
3311 /* Return true if the characters at position POS_A of buffer
3312 CTX->buffer_a and at position POS_B of buffer CTX->buffer_b are
3313 equal. POS_A and POS_B are zero-based. Text properties are
3314 ignored. */
3316 static bool
3317 buffer_chars_equal (struct context *ctx,
3318 ptrdiff_t pos_a, ptrdiff_t pos_b)
3320 eassert (pos_a >= 0);
3321 pos_a += BUF_BEGV (ctx->buffer_a);
3322 eassert (pos_a >= BUF_BEGV (ctx->buffer_a));
3323 eassert (pos_a < BUF_ZV (ctx->buffer_a));
3325 eassert (pos_b >= 0);
3326 pos_b += BUF_BEGV (ctx->buffer_b);
3327 eassert (pos_b >= BUF_BEGV (ctx->buffer_b));
3328 eassert (pos_b < BUF_ZV (ctx->buffer_b));
3330 return BUF_FETCH_CHAR_AS_MULTIBYTE (ctx->buffer_a, pos_a)
3331 == BUF_FETCH_CHAR_AS_MULTIBYTE (ctx->buffer_b, pos_b);
3335 static void
3336 subst_char_in_region_unwind (Lisp_Object arg)
3338 bset_undo_list (current_buffer, arg);
3341 static void
3342 subst_char_in_region_unwind_1 (Lisp_Object arg)
3344 bset_filename (current_buffer, arg);
3347 DEFUN ("subst-char-in-region", Fsubst_char_in_region,
3348 Ssubst_char_in_region, 4, 5, 0,
3349 doc: /* From START to END, replace FROMCHAR with TOCHAR each time it occurs.
3350 If optional arg NOUNDO is non-nil, don't record this change for undo
3351 and don't mark the buffer as really changed.
3352 Both characters must have the same length of multi-byte form. */)
3353 (Lisp_Object start, Lisp_Object end, Lisp_Object fromchar, Lisp_Object tochar, Lisp_Object noundo)
3355 register ptrdiff_t pos, pos_byte, stop, i, len, end_byte;
3356 /* Keep track of the first change in the buffer:
3357 if 0 we haven't found it yet.
3358 if < 0 we've found it and we've run the before-change-function.
3359 if > 0 we've actually performed it and the value is its position. */
3360 ptrdiff_t changed = 0;
3361 unsigned char fromstr[MAX_MULTIBYTE_LENGTH], tostr[MAX_MULTIBYTE_LENGTH];
3362 unsigned char *p;
3363 ptrdiff_t count = SPECPDL_INDEX ();
3364 #define COMBINING_NO 0
3365 #define COMBINING_BEFORE 1
3366 #define COMBINING_AFTER 2
3367 #define COMBINING_BOTH (COMBINING_BEFORE | COMBINING_AFTER)
3368 int maybe_byte_combining = COMBINING_NO;
3369 ptrdiff_t last_changed = 0;
3370 bool multibyte_p
3371 = !NILP (BVAR (current_buffer, enable_multibyte_characters));
3372 int fromc, toc;
3374 restart:
3376 validate_region (&start, &end);
3377 CHECK_CHARACTER (fromchar);
3378 CHECK_CHARACTER (tochar);
3379 fromc = XFASTINT (fromchar);
3380 toc = XFASTINT (tochar);
3382 if (multibyte_p)
3384 len = CHAR_STRING (fromc, fromstr);
3385 if (CHAR_STRING (toc, tostr) != len)
3386 error ("Characters in `subst-char-in-region' have different byte-lengths");
3387 if (!ASCII_CHAR_P (*tostr))
3389 /* If *TOSTR is in the range 0x80..0x9F and TOCHAR is not a
3390 complete multibyte character, it may be combined with the
3391 after bytes. If it is in the range 0xA0..0xFF, it may be
3392 combined with the before and after bytes. */
3393 if (!CHAR_HEAD_P (*tostr))
3394 maybe_byte_combining = COMBINING_BOTH;
3395 else if (BYTES_BY_CHAR_HEAD (*tostr) > len)
3396 maybe_byte_combining = COMBINING_AFTER;
3399 else
3401 len = 1;
3402 fromstr[0] = fromc;
3403 tostr[0] = toc;
3406 pos = XINT (start);
3407 pos_byte = CHAR_TO_BYTE (pos);
3408 stop = CHAR_TO_BYTE (XINT (end));
3409 end_byte = stop;
3411 /* If we don't want undo, turn off putting stuff on the list.
3412 That's faster than getting rid of things,
3413 and it prevents even the entry for a first change.
3414 Also inhibit locking the file. */
3415 if (!changed && !NILP (noundo))
3417 record_unwind_protect (subst_char_in_region_unwind,
3418 BVAR (current_buffer, undo_list));
3419 bset_undo_list (current_buffer, Qt);
3420 /* Don't do file-locking. */
3421 record_unwind_protect (subst_char_in_region_unwind_1,
3422 BVAR (current_buffer, filename));
3423 bset_filename (current_buffer, Qnil);
3426 if (pos_byte < GPT_BYTE)
3427 stop = min (stop, GPT_BYTE);
3428 while (1)
3430 ptrdiff_t pos_byte_next = pos_byte;
3432 if (pos_byte >= stop)
3434 if (pos_byte >= end_byte) break;
3435 stop = end_byte;
3437 p = BYTE_POS_ADDR (pos_byte);
3438 if (multibyte_p)
3439 INC_POS (pos_byte_next);
3440 else
3441 ++pos_byte_next;
3442 if (pos_byte_next - pos_byte == len
3443 && p[0] == fromstr[0]
3444 && (len == 1
3445 || (p[1] == fromstr[1]
3446 && (len == 2 || (p[2] == fromstr[2]
3447 && (len == 3 || p[3] == fromstr[3]))))))
3449 if (changed < 0)
3450 /* We've already seen this and run the before-change-function;
3451 this time we only need to record the actual position. */
3452 changed = pos;
3453 else if (!changed)
3455 changed = -1;
3456 modify_text (pos, XINT (end));
3458 if (! NILP (noundo))
3460 if (MODIFF - 1 == SAVE_MODIFF)
3461 SAVE_MODIFF++;
3462 if (MODIFF - 1 == BUF_AUTOSAVE_MODIFF (current_buffer))
3463 BUF_AUTOSAVE_MODIFF (current_buffer)++;
3466 /* The before-change-function may have moved the gap
3467 or even modified the buffer so we should start over. */
3468 goto restart;
3471 /* Take care of the case where the new character
3472 combines with neighboring bytes. */
3473 if (maybe_byte_combining
3474 && (maybe_byte_combining == COMBINING_AFTER
3475 ? (pos_byte_next < Z_BYTE
3476 && ! CHAR_HEAD_P (FETCH_BYTE (pos_byte_next)))
3477 : ((pos_byte_next < Z_BYTE
3478 && ! CHAR_HEAD_P (FETCH_BYTE (pos_byte_next)))
3479 || (pos_byte > BEG_BYTE
3480 && ! ASCII_CHAR_P (FETCH_BYTE (pos_byte - 1))))))
3482 Lisp_Object tem, string;
3484 tem = BVAR (current_buffer, undo_list);
3486 /* Make a multibyte string containing this single character. */
3487 string = make_multibyte_string ((char *) tostr, 1, len);
3488 /* replace_range is less efficient, because it moves the gap,
3489 but it handles combining correctly. */
3490 replace_range (pos, pos + 1, string,
3491 0, 0, 1, 0);
3492 pos_byte_next = CHAR_TO_BYTE (pos);
3493 if (pos_byte_next > pos_byte)
3494 /* Before combining happened. We should not increment
3495 POS. So, to cancel the later increment of POS,
3496 decrease it now. */
3497 pos--;
3498 else
3499 INC_POS (pos_byte_next);
3501 if (! NILP (noundo))
3502 bset_undo_list (current_buffer, tem);
3504 else
3506 if (NILP (noundo))
3507 record_change (pos, 1);
3508 for (i = 0; i < len; i++) *p++ = tostr[i];
3510 last_changed = pos + 1;
3512 pos_byte = pos_byte_next;
3513 pos++;
3516 if (changed > 0)
3518 signal_after_change (changed,
3519 last_changed - changed, last_changed - changed);
3520 update_compositions (changed, last_changed, CHECK_ALL);
3523 unbind_to (count, Qnil);
3524 return Qnil;
3528 static Lisp_Object check_translation (ptrdiff_t, ptrdiff_t, ptrdiff_t,
3529 Lisp_Object);
3531 /* Helper function for Ftranslate_region_internal.
3533 Check if a character sequence at POS (POS_BYTE) matches an element
3534 of VAL. VAL is a list (([FROM-CHAR ...] . TO) ...). If a matching
3535 element is found, return it. Otherwise return Qnil. */
3537 static Lisp_Object
3538 check_translation (ptrdiff_t pos, ptrdiff_t pos_byte, ptrdiff_t end,
3539 Lisp_Object val)
3541 int initial_buf[16];
3542 int *buf = initial_buf;
3543 ptrdiff_t buf_size = ARRAYELTS (initial_buf);
3544 int *bufalloc = 0;
3545 ptrdiff_t buf_used = 0;
3546 Lisp_Object result = Qnil;
3548 for (; CONSP (val); val = XCDR (val))
3550 Lisp_Object elt;
3551 ptrdiff_t len, i;
3553 elt = XCAR (val);
3554 if (! CONSP (elt))
3555 continue;
3556 elt = XCAR (elt);
3557 if (! VECTORP (elt))
3558 continue;
3559 len = ASIZE (elt);
3560 if (len <= end - pos)
3562 for (i = 0; i < len; i++)
3564 if (buf_used <= i)
3566 unsigned char *p = BYTE_POS_ADDR (pos_byte);
3567 int len1;
3569 if (buf_used == buf_size)
3571 bufalloc = xpalloc (bufalloc, &buf_size, 1, -1,
3572 sizeof *bufalloc);
3573 if (buf == initial_buf)
3574 memcpy (bufalloc, buf, sizeof initial_buf);
3575 buf = bufalloc;
3577 buf[buf_used++] = STRING_CHAR_AND_LENGTH (p, len1);
3578 pos_byte += len1;
3580 if (XINT (AREF (elt, i)) != buf[i])
3581 break;
3583 if (i == len)
3585 result = XCAR (val);
3586 break;
3591 xfree (bufalloc);
3592 return result;
3596 DEFUN ("translate-region-internal", Ftranslate_region_internal,
3597 Stranslate_region_internal, 3, 3, 0,
3598 doc: /* Internal use only.
3599 From START to END, translate characters according to TABLE.
3600 TABLE is a string or a char-table; the Nth character in it is the
3601 mapping for the character with code N.
3602 It returns the number of characters changed. */)
3603 (Lisp_Object start, Lisp_Object end, register Lisp_Object table)
3605 register unsigned char *tt; /* Trans table. */
3606 register int nc; /* New character. */
3607 int cnt; /* Number of changes made. */
3608 ptrdiff_t size; /* Size of translate table. */
3609 ptrdiff_t pos, pos_byte, end_pos;
3610 bool multibyte = !NILP (BVAR (current_buffer, enable_multibyte_characters));
3611 bool string_multibyte UNINIT;
3613 validate_region (&start, &end);
3614 if (CHAR_TABLE_P (table))
3616 if (! EQ (XCHAR_TABLE (table)->purpose, Qtranslation_table))
3617 error ("Not a translation table");
3618 size = MAX_CHAR;
3619 tt = NULL;
3621 else
3623 CHECK_STRING (table);
3625 if (! multibyte && (SCHARS (table) < SBYTES (table)))
3626 table = string_make_unibyte (table);
3627 string_multibyte = SCHARS (table) < SBYTES (table);
3628 size = SBYTES (table);
3629 tt = SDATA (table);
3632 pos = XINT (start);
3633 pos_byte = CHAR_TO_BYTE (pos);
3634 end_pos = XINT (end);
3635 modify_text (pos, end_pos);
3637 cnt = 0;
3638 for (; pos < end_pos; )
3640 unsigned char *p = BYTE_POS_ADDR (pos_byte);
3641 unsigned char *str UNINIT;
3642 unsigned char buf[MAX_MULTIBYTE_LENGTH];
3643 int len, str_len;
3644 int oc;
3645 Lisp_Object val;
3647 if (multibyte)
3648 oc = STRING_CHAR_AND_LENGTH (p, len);
3649 else
3650 oc = *p, len = 1;
3651 if (oc < size)
3653 if (tt)
3655 /* Reload as signal_after_change in last iteration may GC. */
3656 tt = SDATA (table);
3657 if (string_multibyte)
3659 str = tt + string_char_to_byte (table, oc);
3660 nc = STRING_CHAR_AND_LENGTH (str, str_len);
3662 else
3664 nc = tt[oc];
3665 if (! ASCII_CHAR_P (nc) && multibyte)
3667 str_len = BYTE8_STRING (nc, buf);
3668 str = buf;
3670 else
3672 str_len = 1;
3673 str = tt + oc;
3677 else
3679 nc = oc;
3680 val = CHAR_TABLE_REF (table, oc);
3681 if (CHARACTERP (val))
3683 nc = XFASTINT (val);
3684 str_len = CHAR_STRING (nc, buf);
3685 str = buf;
3687 else if (VECTORP (val) || (CONSP (val)))
3689 /* VAL is [TO_CHAR ...] or (([FROM-CHAR ...] . TO) ...)
3690 where TO is TO-CHAR or [TO-CHAR ...]. */
3691 nc = -1;
3695 if (nc != oc && nc >= 0)
3697 /* Simple one char to one char translation. */
3698 if (len != str_len)
3700 Lisp_Object string;
3702 /* This is less efficient, because it moves the gap,
3703 but it should handle multibyte characters correctly. */
3704 string = make_multibyte_string ((char *) str, 1, str_len);
3705 replace_range (pos, pos + 1, string, 1, 0, 1, 0);
3706 len = str_len;
3708 else
3710 record_change (pos, 1);
3711 while (str_len-- > 0)
3712 *p++ = *str++;
3713 signal_after_change (pos, 1, 1);
3714 update_compositions (pos, pos + 1, CHECK_BORDER);
3716 ++cnt;
3718 else if (nc < 0)
3720 Lisp_Object string;
3722 if (CONSP (val))
3724 val = check_translation (pos, pos_byte, end_pos, val);
3725 if (NILP (val))
3727 pos_byte += len;
3728 pos++;
3729 continue;
3731 /* VAL is ([FROM-CHAR ...] . TO). */
3732 len = ASIZE (XCAR (val));
3733 val = XCDR (val);
3735 else
3736 len = 1;
3738 if (VECTORP (val))
3740 string = Fconcat (1, &val);
3742 else
3744 string = Fmake_string (make_number (1), val, Qnil);
3746 replace_range (pos, pos + len, string, 1, 0, 1, 0);
3747 pos_byte += SBYTES (string);
3748 pos += SCHARS (string);
3749 cnt += SCHARS (string);
3750 end_pos += SCHARS (string) - len;
3751 continue;
3754 pos_byte += len;
3755 pos++;
3758 return make_number (cnt);
3761 DEFUN ("delete-region", Fdelete_region, Sdelete_region, 2, 2, "r",
3762 doc: /* Delete the text between START and END.
3763 If called interactively, delete the region between point and mark.
3764 This command deletes buffer text without modifying the kill ring. */)
3765 (Lisp_Object start, Lisp_Object end)
3767 validate_region (&start, &end);
3768 del_range (XINT (start), XINT (end));
3769 return Qnil;
3772 DEFUN ("delete-and-extract-region", Fdelete_and_extract_region,
3773 Sdelete_and_extract_region, 2, 2, 0,
3774 doc: /* Delete the text between START and END and return it. */)
3775 (Lisp_Object start, Lisp_Object end)
3777 validate_region (&start, &end);
3778 if (XINT (start) == XINT (end))
3779 return empty_unibyte_string;
3780 return del_range_1 (XINT (start), XINT (end), 1, 1);
3783 DEFUN ("widen", Fwiden, Swiden, 0, 0, "",
3784 doc: /* Remove restrictions (narrowing) from current buffer.
3785 This allows the buffer's full text to be seen and edited. */)
3786 (void)
3788 if (BEG != BEGV || Z != ZV)
3789 current_buffer->clip_changed = 1;
3790 BEGV = BEG;
3791 BEGV_BYTE = BEG_BYTE;
3792 SET_BUF_ZV_BOTH (current_buffer, Z, Z_BYTE);
3793 /* Changing the buffer bounds invalidates any recorded current column. */
3794 invalidate_current_column ();
3795 return Qnil;
3798 DEFUN ("narrow-to-region", Fnarrow_to_region, Snarrow_to_region, 2, 2, "r",
3799 doc: /* Restrict editing in this buffer to the current region.
3800 The rest of the text becomes temporarily invisible and untouchable
3801 but is not deleted; if you save the buffer in a file, the invisible
3802 text is included in the file. \\[widen] makes all visible again.
3803 See also `save-restriction'.
3805 When calling from a program, pass two arguments; positions (integers
3806 or markers) bounding the text that should remain visible. */)
3807 (register Lisp_Object start, Lisp_Object end)
3809 CHECK_NUMBER_COERCE_MARKER (start);
3810 CHECK_NUMBER_COERCE_MARKER (end);
3812 if (XINT (start) > XINT (end))
3814 Lisp_Object tem;
3815 tem = start; start = end; end = tem;
3818 if (!(BEG <= XINT (start) && XINT (start) <= XINT (end) && XINT (end) <= Z))
3819 args_out_of_range (start, end);
3821 if (BEGV != XFASTINT (start) || ZV != XFASTINT (end))
3822 current_buffer->clip_changed = 1;
3824 SET_BUF_BEGV (current_buffer, XFASTINT (start));
3825 SET_BUF_ZV (current_buffer, XFASTINT (end));
3826 if (PT < XFASTINT (start))
3827 SET_PT (XFASTINT (start));
3828 if (PT > XFASTINT (end))
3829 SET_PT (XFASTINT (end));
3830 /* Changing the buffer bounds invalidates any recorded current column. */
3831 invalidate_current_column ();
3832 return Qnil;
3835 Lisp_Object
3836 save_restriction_save (void)
3838 if (BEGV == BEG && ZV == Z)
3839 /* The common case that the buffer isn't narrowed.
3840 We return just the buffer object, which save_restriction_restore
3841 recognizes as meaning `no restriction'. */
3842 return Fcurrent_buffer ();
3843 else
3844 /* We have to save a restriction, so return a pair of markers, one
3845 for the beginning and one for the end. */
3847 Lisp_Object beg, end;
3849 beg = build_marker (current_buffer, BEGV, BEGV_BYTE);
3850 end = build_marker (current_buffer, ZV, ZV_BYTE);
3852 /* END must move forward if text is inserted at its exact location. */
3853 XMARKER (end)->insertion_type = 1;
3855 return Fcons (beg, end);
3859 void
3860 save_restriction_restore (Lisp_Object data)
3862 struct buffer *cur = NULL;
3863 struct buffer *buf = (CONSP (data)
3864 ? XMARKER (XCAR (data))->buffer
3865 : XBUFFER (data));
3867 if (buf && buf != current_buffer && !NILP (BVAR (buf, pt_marker)))
3868 { /* If `buf' uses markers to keep track of PT, BEGV, and ZV (as
3869 is the case if it is or has an indirect buffer), then make
3870 sure it is current before we update BEGV, so
3871 set_buffer_internal takes care of managing those markers. */
3872 cur = current_buffer;
3873 set_buffer_internal (buf);
3876 if (CONSP (data))
3877 /* A pair of marks bounding a saved restriction. */
3879 struct Lisp_Marker *beg = XMARKER (XCAR (data));
3880 struct Lisp_Marker *end = XMARKER (XCDR (data));
3881 eassert (buf == end->buffer);
3883 if (buf /* Verify marker still points to a buffer. */
3884 && (beg->charpos != BUF_BEGV (buf) || end->charpos != BUF_ZV (buf)))
3885 /* The restriction has changed from the saved one, so restore
3886 the saved restriction. */
3888 ptrdiff_t pt = BUF_PT (buf);
3890 SET_BUF_BEGV_BOTH (buf, beg->charpos, beg->bytepos);
3891 SET_BUF_ZV_BOTH (buf, end->charpos, end->bytepos);
3893 if (pt < beg->charpos || pt > end->charpos)
3894 /* The point is outside the new visible range, move it inside. */
3895 SET_BUF_PT_BOTH (buf,
3896 clip_to_bounds (beg->charpos, pt, end->charpos),
3897 clip_to_bounds (beg->bytepos, BUF_PT_BYTE (buf),
3898 end->bytepos));
3900 buf->clip_changed = 1; /* Remember that the narrowing changed. */
3902 /* These aren't needed anymore, so don't wait for GC. */
3903 free_marker (XCAR (data));
3904 free_marker (XCDR (data));
3905 free_cons (XCONS (data));
3907 else
3908 /* A buffer, which means that there was no old restriction. */
3910 if (buf /* Verify marker still points to a buffer. */
3911 && (BUF_BEGV (buf) != BUF_BEG (buf) || BUF_ZV (buf) != BUF_Z (buf)))
3912 /* The buffer has been narrowed, get rid of the narrowing. */
3914 SET_BUF_BEGV_BOTH (buf, BUF_BEG (buf), BUF_BEG_BYTE (buf));
3915 SET_BUF_ZV_BOTH (buf, BUF_Z (buf), BUF_Z_BYTE (buf));
3917 buf->clip_changed = 1; /* Remember that the narrowing changed. */
3921 /* Changing the buffer bounds invalidates any recorded current column. */
3922 invalidate_current_column ();
3924 if (cur)
3925 set_buffer_internal (cur);
3928 DEFUN ("save-restriction", Fsave_restriction, Ssave_restriction, 0, UNEVALLED, 0,
3929 doc: /* Execute BODY, saving and restoring current buffer's restrictions.
3930 The buffer's restrictions make parts of the beginning and end invisible.
3931 \(They are set up with `narrow-to-region' and eliminated with `widen'.)
3932 This special form, `save-restriction', saves the current buffer's restrictions
3933 when it is entered, and restores them when it is exited.
3934 So any `narrow-to-region' within BODY lasts only until the end of the form.
3935 The old restrictions settings are restored
3936 even in case of abnormal exit (throw or error).
3938 The value returned is the value of the last form in BODY.
3940 Note: if you are using both `save-excursion' and `save-restriction',
3941 use `save-excursion' outermost:
3942 (save-excursion (save-restriction ...))
3944 usage: (save-restriction &rest BODY) */)
3945 (Lisp_Object body)
3947 register Lisp_Object val;
3948 ptrdiff_t count = SPECPDL_INDEX ();
3950 record_unwind_protect (save_restriction_restore, save_restriction_save ());
3951 val = Fprogn (body);
3952 return unbind_to (count, val);
3955 DEFUN ("message", Fmessage, Smessage, 1, MANY, 0,
3956 doc: /* Display a message at the bottom of the screen.
3957 The message also goes into the `*Messages*' buffer, if `message-log-max'
3958 is non-nil. (In keyboard macros, that's all it does.)
3959 Return the message.
3961 In batch mode, the message is printed to the standard error stream,
3962 followed by a newline.
3964 The first argument is a format control string, and the rest are data
3965 to be formatted under control of the string. Percent sign (%), grave
3966 accent (\\=`) and apostrophe (\\=') are special in the format; see
3967 `format-message' for details. To display STRING without special
3968 treatment, use (message "%s" STRING).
3970 If the first argument is nil or the empty string, the function clears
3971 any existing message; this lets the minibuffer contents show. See
3972 also `current-message'.
3974 usage: (message FORMAT-STRING &rest ARGS) */)
3975 (ptrdiff_t nargs, Lisp_Object *args)
3977 if (NILP (args[0])
3978 || (STRINGP (args[0])
3979 && SBYTES (args[0]) == 0))
3981 message1 (0);
3982 return args[0];
3984 else
3986 Lisp_Object val = Fformat_message (nargs, args);
3987 message3 (val);
3988 return val;
3992 DEFUN ("message-box", Fmessage_box, Smessage_box, 1, MANY, 0,
3993 doc: /* Display a message, in a dialog box if possible.
3994 If a dialog box is not available, use the echo area.
3995 The first argument is a format control string, and the rest are data
3996 to be formatted under control of the string. See `format-message' for
3997 details.
3999 If the first argument is nil or the empty string, clear any existing
4000 message; let the minibuffer contents show.
4002 usage: (message-box FORMAT-STRING &rest ARGS) */)
4003 (ptrdiff_t nargs, Lisp_Object *args)
4005 if (NILP (args[0]))
4007 message1 (0);
4008 return Qnil;
4010 else
4012 Lisp_Object val = Fformat_message (nargs, args);
4013 Lisp_Object pane, menu;
4015 pane = list1 (Fcons (build_string ("OK"), Qt));
4016 menu = Fcons (val, pane);
4017 Fx_popup_dialog (Qt, menu, Qt);
4018 return val;
4022 DEFUN ("message-or-box", Fmessage_or_box, Smessage_or_box, 1, MANY, 0,
4023 doc: /* Display a message in a dialog box or in the echo area.
4024 If this command was invoked with the mouse, use a dialog box if
4025 `use-dialog-box' is non-nil.
4026 Otherwise, use the echo area.
4027 The first argument is a format control string, and the rest are data
4028 to be formatted under control of the string. See `format-message' for
4029 details.
4031 If the first argument is nil or the empty string, clear any existing
4032 message; let the minibuffer contents show.
4034 usage: (message-or-box FORMAT-STRING &rest ARGS) */)
4035 (ptrdiff_t nargs, Lisp_Object *args)
4037 if ((NILP (last_nonmenu_event) || CONSP (last_nonmenu_event))
4038 && use_dialog_box)
4039 return Fmessage_box (nargs, args);
4040 return Fmessage (nargs, args);
4043 DEFUN ("current-message", Fcurrent_message, Scurrent_message, 0, 0, 0,
4044 doc: /* Return the string currently displayed in the echo area, or nil if none. */)
4045 (void)
4047 return current_message ();
4051 DEFUN ("propertize", Fpropertize, Spropertize, 1, MANY, 0,
4052 doc: /* Return a copy of STRING with text properties added.
4053 First argument is the string to copy.
4054 Remaining arguments form a sequence of PROPERTY VALUE pairs for text
4055 properties to add to the result.
4056 usage: (propertize STRING &rest PROPERTIES) */)
4057 (ptrdiff_t nargs, Lisp_Object *args)
4059 Lisp_Object properties, string;
4060 ptrdiff_t i;
4062 /* Number of args must be odd. */
4063 if ((nargs & 1) == 0)
4064 error ("Wrong number of arguments");
4066 properties = string = Qnil;
4068 /* First argument must be a string. */
4069 CHECK_STRING (args[0]);
4070 string = Fcopy_sequence (args[0]);
4072 for (i = 1; i < nargs; i += 2)
4073 properties = Fcons (args[i], Fcons (args[i + 1], properties));
4075 Fadd_text_properties (make_number (0),
4076 make_number (SCHARS (string)),
4077 properties, string);
4078 return string;
4081 /* Convert the prefix of STR from ASCII decimal digits to a number.
4082 Set *STR_END to the address of the first non-digit. Return the
4083 number, or PTRDIFF_MAX on overflow. Return 0 if there is no number.
4084 This is like strtol for ptrdiff_t and base 10 and C locale,
4085 except without negative numbers or errno. */
4087 static ptrdiff_t
4088 str2num (char *str, char **str_end)
4090 ptrdiff_t n = 0;
4091 for (; c_isdigit (*str); str++)
4092 if (INT_MULTIPLY_WRAPV (n, 10, &n) || INT_ADD_WRAPV (n, *str - '0', &n))
4093 n = PTRDIFF_MAX;
4094 *str_end = str;
4095 return n;
4098 DEFUN ("format", Fformat, Sformat, 1, MANY, 0,
4099 doc: /* Format a string out of a format-string and arguments.
4100 The first argument is a format control string.
4101 The other arguments are substituted into it to make the result, a string.
4103 The format control string may contain %-sequences meaning to substitute
4104 the next available argument, or the argument explicitly specified:
4106 %s means print a string argument. Actually, prints any object, with `princ'.
4107 %d means print as signed number in decimal.
4108 %o means print as unsigned number in octal, %x as unsigned number in hex.
4109 %X is like %x, but uses upper case.
4110 %e means print a number in exponential notation.
4111 %f means print a number in decimal-point notation.
4112 %g means print a number in exponential notation if the exponent would be
4113 less than -4 or greater than or equal to the precision (default: 6);
4114 otherwise it prints in decimal-point notation.
4115 %c means print a number as a single character.
4116 %S means print any object as an s-expression (using `prin1').
4118 The argument used for %d, %o, %x, %e, %f, %g or %c must be a number.
4119 Use %% to put a single % into the output.
4121 A %-sequence other than %% may contain optional field number, flag,
4122 width, and precision specifiers, as follows:
4124 %<field><flags><width><precision>character
4126 where field is [0-9]+ followed by a literal dollar "$", flags is
4127 [+ #-0]+, width is [0-9]+, and precision is a literal period "."
4128 followed by [0-9]+.
4130 If a %-sequence is numbered with a field with positive value N, the
4131 Nth argument is substituted instead of the next one. A format can
4132 contain either numbered or unnumbered %-sequences but not both, except
4133 that %% can be mixed with numbered %-sequences.
4135 The + flag character inserts a + before any positive number, while a
4136 space inserts a space before any positive number; these flags only
4137 affect %d, %e, %f, and %g sequences, and the + flag takes precedence.
4138 The - and 0 flags affect the width specifier, as described below.
4140 The # flag means to use an alternate display form for %o, %x, %X, %e,
4141 %f, and %g sequences: for %o, it ensures that the result begins with
4142 \"0\"; for %x and %X, it prefixes the result with \"0x\" or \"0X\";
4143 for %e and %f, it causes a decimal point to be included even if the
4144 precision is zero; for %g, it causes a decimal point to be
4145 included even if the precision is zero, and also forces trailing
4146 zeros after the decimal point to be left in place.
4148 The width specifier supplies a lower limit for the length of the
4149 printed representation. The padding, if any, normally goes on the
4150 left, but it goes on the right if the - flag is present. The padding
4151 character is normally a space, but it is 0 if the 0 flag is present.
4152 The 0 flag is ignored if the - flag is present, or the format sequence
4153 is something other than %d, %e, %f, and %g.
4155 For %e and %f sequences, the number after the "." in the precision
4156 specifier says how many decimal places to show; if zero, the decimal
4157 point itself is omitted. For %g, the precision specifies how many
4158 significant digits to print; zero or omitted are treated as 1.
4159 For %s and %S, the precision specifier truncates the string to the
4160 given width.
4162 Text properties, if any, are copied from the format-string to the
4163 produced text.
4165 usage: (format STRING &rest OBJECTS) */)
4166 (ptrdiff_t nargs, Lisp_Object *args)
4168 return styled_format (nargs, args, false);
4171 DEFUN ("format-message", Fformat_message, Sformat_message, 1, MANY, 0,
4172 doc: /* Format a string out of a format-string and arguments.
4173 The first argument is a format control string.
4174 The other arguments are substituted into it to make the result, a string.
4176 This acts like `format', except it also replaces each grave accent (\\=`)
4177 by a left quote, and each apostrophe (\\=') by a right quote. The left
4178 and right quote replacement characters are specified by
4179 `text-quoting-style'.
4181 usage: (format-message STRING &rest OBJECTS) */)
4182 (ptrdiff_t nargs, Lisp_Object *args)
4184 return styled_format (nargs, args, true);
4187 /* Implement ‘format-message’ if MESSAGE is true, ‘format’ otherwise. */
4189 static Lisp_Object
4190 styled_format (ptrdiff_t nargs, Lisp_Object *args, bool message)
4192 ptrdiff_t n; /* The number of the next arg to substitute. */
4193 char initial_buffer[4000];
4194 char *buf = initial_buffer;
4195 ptrdiff_t bufsize = sizeof initial_buffer;
4196 ptrdiff_t max_bufsize = STRING_BYTES_BOUND + 1;
4197 char *p;
4198 ptrdiff_t buf_save_value_index UNINIT;
4199 char *format, *end;
4200 ptrdiff_t nchars;
4201 /* When we make a multibyte string, we must pay attention to the
4202 byte combining problem, i.e., a byte may be combined with a
4203 multibyte character of the previous string. This flag tells if we
4204 must consider such a situation or not. */
4205 bool maybe_combine_byte;
4206 Lisp_Object val;
4207 bool arg_intervals = false;
4208 USE_SAFE_ALLOCA;
4209 sa_avail -= sizeof initial_buffer;
4211 /* Information recorded for each format spec. */
4212 struct info
4214 /* The corresponding argument, converted to string if conversion
4215 was needed. */
4216 Lisp_Object argument;
4218 /* The start and end bytepos in the output string. */
4219 ptrdiff_t start, end;
4221 /* Whether the argument is a string with intervals. */
4222 bool_bf intervals : 1;
4223 } *info;
4225 CHECK_STRING (args[0]);
4226 char *format_start = SSDATA (args[0]);
4227 bool multibyte_format = STRING_MULTIBYTE (args[0]);
4228 ptrdiff_t formatlen = SBYTES (args[0]);
4230 /* Upper bound on number of format specs. Each uses at least 2 chars. */
4231 ptrdiff_t nspec_bound = SCHARS (args[0]) >> 1;
4233 /* Allocate the info and discarded tables. */
4234 ptrdiff_t info_size, alloca_size;
4235 if (INT_MULTIPLY_WRAPV (nspec_bound, sizeof *info, &info_size)
4236 || INT_ADD_WRAPV (formatlen, info_size, &alloca_size)
4237 || SIZE_MAX < alloca_size)
4238 memory_full (SIZE_MAX);
4239 info = SAFE_ALLOCA (alloca_size);
4240 /* discarded[I] is 1 if byte I of the format
4241 string was not copied into the output.
4242 It is 2 if byte I was not the first byte of its character. */
4243 char *discarded = (char *) &info[nspec_bound];
4244 info = ptr_bounds_clip (info, info_size);
4245 discarded = ptr_bounds_clip (discarded, formatlen);
4246 memset (discarded, 0, formatlen);
4248 /* Try to determine whether the result should be multibyte.
4249 This is not always right; sometimes the result needs to be multibyte
4250 because of an object that we will pass through prin1.
4251 or because a grave accent or apostrophe is requoted,
4252 and in that case, we won't know it here. */
4254 /* True if the output should be a multibyte string,
4255 which is true if any of the inputs is one. */
4256 bool multibyte = multibyte_format;
4257 for (ptrdiff_t i = 1; !multibyte && i < nargs; i++)
4258 if (STRINGP (args[i]) && STRING_MULTIBYTE (args[i]))
4259 multibyte = true;
4261 int quoting_style = message ? text_quoting_style () : -1;
4263 ptrdiff_t ispec;
4264 ptrdiff_t nspec = 0;
4266 /* True if a string needs to be allocated to hold the result. */
4267 bool new_result = false;
4269 /* If we start out planning a unibyte result,
4270 then discover it has to be multibyte, we jump back to retry. */
4271 retry:
4273 p = buf;
4274 nchars = 0;
4276 /* N is the argument index, ISPEC is the specification index. */
4277 n = 0;
4278 ispec = 0;
4280 /* Scan the format and store result in BUF. */
4281 format = format_start;
4282 end = format + formatlen;
4283 maybe_combine_byte = false;
4285 while (format != end)
4287 /* The values of N, ISPEC, and FORMAT when the loop body is
4288 entered. */
4289 ptrdiff_t n0 = n;
4290 ptrdiff_t ispec0 = ispec;
4291 char *format0 = format;
4292 char const *convsrc = format;
4293 unsigned char format_char = *format++;
4295 /* Bytes needed to represent the output of this conversion. */
4296 ptrdiff_t convbytes = 1;
4298 if (format_char == '%')
4300 /* General format specifications look like
4302 '%' [field-number] [flags] [field-width] [precision] format
4304 where
4306 field-number ::= [0-9]+ '$'
4307 flags ::= [-+0# ]+
4308 field-width ::= [0-9]+
4309 precision ::= '.' [0-9]*
4311 If present, a field-number specifies the argument number
4312 to substitute. Otherwise, the next argument is taken.
4314 If a field-width is specified, it specifies to which width
4315 the output should be padded with blanks, if the output
4316 string is shorter than field-width.
4318 If precision is specified, it specifies the number of
4319 digits to print after the '.' for floats, or the max.
4320 number of chars to print from a string. */
4322 ptrdiff_t num;
4323 char *num_end;
4324 if (c_isdigit (*format))
4326 num = str2num (format, &num_end);
4327 if (*num_end == '$')
4329 n = num - 1;
4330 format = num_end + 1;
4334 bool minus_flag = false;
4335 bool plus_flag = false;
4336 bool space_flag = false;
4337 bool sharp_flag = false;
4338 bool zero_flag = false;
4340 for (; ; format++)
4342 switch (*format)
4344 case '-': minus_flag = true; continue;
4345 case '+': plus_flag = true; continue;
4346 case ' ': space_flag = true; continue;
4347 case '#': sharp_flag = true; continue;
4348 case '0': zero_flag = true; continue;
4350 break;
4353 /* Ignore flags when sprintf ignores them. */
4354 space_flag &= ! plus_flag;
4355 zero_flag &= ! minus_flag;
4357 num = str2num (format, &num_end);
4358 if (max_bufsize <= num)
4359 string_overflow ();
4360 ptrdiff_t field_width = num;
4362 bool precision_given = *num_end == '.';
4363 ptrdiff_t precision = (precision_given
4364 ? str2num (num_end + 1, &num_end)
4365 : PTRDIFF_MAX);
4366 format = num_end;
4368 if (format == end)
4369 error ("Format string ends in middle of format specifier");
4371 char conversion = *format++;
4372 memset (&discarded[format0 - format_start], 1,
4373 format - format0 - (conversion == '%'));
4374 if (conversion == '%')
4376 new_result = true;
4377 goto copy_char;
4380 ++n;
4381 if (! (n < nargs))
4382 error ("Not enough arguments for format string");
4384 struct info *spec = &info[ispec++];
4385 if (nspec < ispec)
4387 spec->argument = args[n];
4388 spec->intervals = false;
4389 nspec = ispec;
4391 Lisp_Object arg = spec->argument;
4393 /* For 'S', prin1 the argument, and then treat like 's'.
4394 For 's', princ any argument that is not a string or
4395 symbol. But don't do this conversion twice, which might
4396 happen after retrying. */
4397 if ((conversion == 'S'
4398 || (conversion == 's'
4399 && ! STRINGP (arg) && ! SYMBOLP (arg))))
4401 if (EQ (arg, args[n]))
4403 Lisp_Object noescape = conversion == 'S' ? Qnil : Qt;
4404 spec->argument = arg = Fprin1_to_string (arg, noescape);
4405 if (STRING_MULTIBYTE (arg) && ! multibyte)
4407 multibyte = true;
4408 goto retry;
4411 conversion = 's';
4413 else if (conversion == 'c')
4415 if (INTEGERP (arg) && ! ASCII_CHAR_P (XINT (arg)))
4417 if (!multibyte)
4419 multibyte = true;
4420 goto retry;
4422 spec->argument = arg = Fchar_to_string (arg);
4425 if (!EQ (arg, args[n]))
4426 conversion = 's';
4427 zero_flag = false;
4430 if (SYMBOLP (arg))
4432 spec->argument = arg = SYMBOL_NAME (arg);
4433 if (STRING_MULTIBYTE (arg) && ! multibyte)
4435 multibyte = true;
4436 goto retry;
4440 bool float_conversion
4441 = conversion == 'e' || conversion == 'f' || conversion == 'g';
4443 if (conversion == 's')
4445 if (format == end && format - format_start == 2
4446 && ! string_intervals (args[0]))
4448 val = arg;
4449 goto return_val;
4452 /* handle case (precision[n] >= 0) */
4454 ptrdiff_t prec = -1;
4455 if (precision_given)
4456 prec = precision;
4458 /* lisp_string_width ignores a precision of 0, but GNU
4459 libc functions print 0 characters when the precision
4460 is 0. Imitate libc behavior here. Changing
4461 lisp_string_width is the right thing, and will be
4462 done, but meanwhile we work with it. */
4464 ptrdiff_t width, nbytes;
4465 ptrdiff_t nchars_string;
4466 if (prec == 0)
4467 width = nchars_string = nbytes = 0;
4468 else
4470 ptrdiff_t nch, nby;
4471 width = lisp_string_width (arg, prec, &nch, &nby);
4472 if (prec < 0)
4474 nchars_string = SCHARS (arg);
4475 nbytes = SBYTES (arg);
4477 else
4479 nchars_string = nch;
4480 nbytes = nby;
4484 convbytes = nbytes;
4485 if (convbytes && multibyte && ! STRING_MULTIBYTE (arg))
4486 convbytes = count_size_as_multibyte (SDATA (arg), nbytes);
4488 ptrdiff_t padding
4489 = width < field_width ? field_width - width : 0;
4491 if (max_bufsize - padding <= convbytes)
4492 string_overflow ();
4493 convbytes += padding;
4494 if (convbytes <= buf + bufsize - p)
4496 if (! minus_flag)
4498 memset (p, ' ', padding);
4499 p += padding;
4500 nchars += padding;
4502 spec->start = nchars;
4504 if (p > buf
4505 && multibyte
4506 && !ASCII_CHAR_P (*((unsigned char *) p - 1))
4507 && STRING_MULTIBYTE (arg)
4508 && !CHAR_HEAD_P (SREF (arg, 0)))
4509 maybe_combine_byte = true;
4511 p += copy_text (SDATA (arg), (unsigned char *) p,
4512 nbytes,
4513 STRING_MULTIBYTE (arg), multibyte);
4515 nchars += nchars_string;
4517 if (minus_flag)
4519 memset (p, ' ', padding);
4520 p += padding;
4521 nchars += padding;
4523 spec->end = nchars;
4525 /* If this argument has text properties, record where
4526 in the result string it appears. */
4527 if (string_intervals (arg))
4528 spec->intervals = arg_intervals = true;
4530 new_result = true;
4531 continue;
4534 else if (! (conversion == 'c' || conversion == 'd'
4535 || float_conversion || conversion == 'i'
4536 || conversion == 'o' || conversion == 'x'
4537 || conversion == 'X'))
4538 error ("Invalid format operation %%%c",
4539 STRING_CHAR ((unsigned char *) format - 1));
4540 else if (! (INTEGERP (arg) || (FLOATP (arg) && conversion != 'c')))
4541 error ("Format specifier doesn't match argument type");
4542 else
4544 enum
4546 /* Lower bound on the number of bits per
4547 base-FLT_RADIX digit. */
4548 DIG_BITS_LBOUND = FLT_RADIX < 16 ? 1 : 4,
4550 /* 1 if integers should be formatted as long doubles,
4551 because they may be so large that there is a rounding
4552 error when converting them to double, and long doubles
4553 are wider than doubles. */
4554 INT_AS_LDBL = (DIG_BITS_LBOUND * DBL_MANT_DIG < FIXNUM_BITS - 1
4555 && DBL_MANT_DIG < LDBL_MANT_DIG),
4557 /* Maximum precision for a %f conversion such that the
4558 trailing output digit might be nonzero. Any precision
4559 larger than this will not yield useful information. */
4560 USEFUL_PRECISION_MAX =
4561 ((1 - LDBL_MIN_EXP)
4562 * (FLT_RADIX == 2 || FLT_RADIX == 10 ? 1
4563 : FLT_RADIX == 16 ? 4
4564 : -1)),
4566 /* Maximum number of bytes generated by any format, if
4567 precision is no more than USEFUL_PRECISION_MAX.
4568 On all practical hosts, %f is the worst case. */
4569 SPRINTF_BUFSIZE =
4570 sizeof "-." + (LDBL_MAX_10_EXP + 1) + USEFUL_PRECISION_MAX,
4572 /* Length of pM (that is, of pMd without the
4573 trailing "d"). */
4574 pMlen = sizeof pMd - 2
4576 verify (USEFUL_PRECISION_MAX > 0);
4578 /* Avoid undefined behavior in underlying sprintf. */
4579 if (conversion == 'd' || conversion == 'i')
4580 sharp_flag = false;
4582 /* Create the copy of the conversion specification, with
4583 any width and precision removed, with ".*" inserted,
4584 with "L" possibly inserted for floating-point formats,
4585 and with pM inserted for integer formats.
4586 At most two flags F can be specified at once. */
4587 char convspec[sizeof "%FF.*d" + max (INT_AS_LDBL, pMlen)];
4588 char *f = convspec;
4589 *f++ = '%';
4590 /* MINUS_FLAG and ZERO_FLAG are dealt with later. */
4591 *f = '+'; f += plus_flag;
4592 *f = ' '; f += space_flag;
4593 *f = '#'; f += sharp_flag;
4594 *f++ = '.';
4595 *f++ = '*';
4596 if (float_conversion)
4598 if (INT_AS_LDBL)
4600 *f = 'L';
4601 f += INTEGERP (arg);
4604 else if (conversion != 'c')
4606 memcpy (f, pMd, pMlen);
4607 f += pMlen;
4608 zero_flag &= ! precision_given;
4610 *f++ = conversion;
4611 *f = '\0';
4613 int prec = -1;
4614 if (precision_given)
4615 prec = min (precision, USEFUL_PRECISION_MAX);
4617 /* Use sprintf to format this number into sprintf_buf. Omit
4618 padding and excess precision, though, because sprintf limits
4619 output length to INT_MAX.
4621 There are four types of conversion: double, unsigned
4622 char (passed as int), wide signed int, and wide
4623 unsigned int. Treat them separately because the
4624 sprintf ABI is sensitive to which type is passed. Be
4625 careful about integer overflow, NaNs, infinities, and
4626 conversions; for example, the min and max macros are
4627 not suitable here. */
4628 char sprintf_buf[SPRINTF_BUFSIZE];
4629 ptrdiff_t sprintf_bytes;
4630 if (float_conversion)
4632 if (INT_AS_LDBL && INTEGERP (arg))
4634 /* Although long double may have a rounding error if
4635 DIG_BITS_LBOUND * LDBL_MANT_DIG < FIXNUM_BITS - 1,
4636 it is more accurate than plain 'double'. */
4637 long double x = XINT (arg);
4638 sprintf_bytes = sprintf (sprintf_buf, convspec, prec, x);
4640 else
4641 sprintf_bytes = sprintf (sprintf_buf, convspec, prec,
4642 XFLOATINT (arg));
4644 else if (conversion == 'c')
4646 /* Don't use sprintf here, as it might mishandle prec. */
4647 sprintf_buf[0] = XINT (arg);
4648 sprintf_bytes = prec != 0;
4649 sprintf_buf[sprintf_bytes] = '\0';
4651 else if (conversion == 'd' || conversion == 'i')
4653 if (INTEGERP (arg))
4655 printmax_t x = XINT (arg);
4656 sprintf_bytes = sprintf (sprintf_buf, convspec, prec, x);
4658 else
4660 strcpy (f - pMlen - 1, "f");
4661 double x = XFLOAT_DATA (arg);
4662 sprintf_bytes = sprintf (sprintf_buf, convspec, 0, x);
4663 char c0 = sprintf_buf[0];
4664 bool signedp = ! ('0' <= c0 && c0 <= '9');
4665 prec = min (precision, sprintf_bytes - signedp);
4668 else
4670 /* Don't sign-extend for octal or hex printing. */
4671 uprintmax_t x;
4672 if (INTEGERP (arg))
4673 x = XUINT (arg);
4674 else
4676 double d = XFLOAT_DATA (arg);
4677 double uprintmax = TYPE_MAXIMUM (uprintmax_t);
4678 if (! (0 <= d && d < uprintmax + 1))
4679 xsignal1 (Qoverflow_error, arg);
4680 x = d;
4682 sprintf_bytes = sprintf (sprintf_buf, convspec, prec, x);
4685 /* Now the length of the formatted item is known, except it omits
4686 padding and excess precision. Deal with excess precision
4687 first. This happens when the format specifies ridiculously
4688 large precision, or when %d or %i formats a float that would
4689 ordinarily need fewer digits than a specified precision. */
4690 ptrdiff_t excess_precision
4691 = precision_given ? precision - prec : 0;
4692 ptrdiff_t leading_zeros = 0, trailing_zeros = 0;
4693 if (excess_precision)
4695 if (float_conversion)
4697 if ((conversion == 'g' && ! sharp_flag)
4698 || ! ('0' <= sprintf_buf[sprintf_bytes - 1]
4699 && sprintf_buf[sprintf_bytes - 1] <= '9'))
4700 excess_precision = 0;
4701 else
4703 if (conversion == 'g')
4705 char *dot = strchr (sprintf_buf, '.');
4706 if (!dot)
4707 excess_precision = 0;
4710 trailing_zeros = excess_precision;
4712 else
4713 leading_zeros = excess_precision;
4716 /* Compute the total bytes needed for this item, including
4717 excess precision and padding. */
4718 ptrdiff_t numwidth;
4719 if (INT_ADD_WRAPV (sprintf_bytes, excess_precision, &numwidth))
4720 numwidth = PTRDIFF_MAX;
4721 ptrdiff_t padding
4722 = numwidth < field_width ? field_width - numwidth : 0;
4723 if (max_bufsize - sprintf_bytes <= excess_precision
4724 || max_bufsize - padding <= numwidth)
4725 string_overflow ();
4726 convbytes = numwidth + padding;
4728 if (convbytes <= buf + bufsize - p)
4730 /* Copy the formatted item from sprintf_buf into buf,
4731 inserting padding and excess-precision zeros. */
4733 char *src = sprintf_buf;
4734 char src0 = src[0];
4735 int exponent_bytes = 0;
4736 bool signedp = src0 == '-' || src0 == '+' || src0 == ' ';
4737 int prefix_bytes = (signedp
4738 + ((src[signedp] == '0'
4739 && (src[signedp + 1] == 'x'
4740 || src[signedp + 1] == 'X'))
4741 ? 2 : 0));
4742 if (zero_flag)
4744 unsigned char after_prefix = src[prefix_bytes];
4745 if (0 <= char_hexdigit (after_prefix))
4747 leading_zeros += padding;
4748 padding = 0;
4752 if (excess_precision
4753 && (conversion == 'e' || conversion == 'g'))
4755 char *e = strchr (src, 'e');
4756 if (e)
4757 exponent_bytes = src + sprintf_bytes - e;
4760 spec->start = nchars;
4761 if (! minus_flag)
4763 memset (p, ' ', padding);
4764 p += padding;
4765 nchars += padding;
4768 memcpy (p, src, prefix_bytes);
4769 p += prefix_bytes;
4770 src += prefix_bytes;
4771 memset (p, '0', leading_zeros);
4772 p += leading_zeros;
4773 int significand_bytes
4774 = sprintf_bytes - prefix_bytes - exponent_bytes;
4775 memcpy (p, src, significand_bytes);
4776 p += significand_bytes;
4777 src += significand_bytes;
4778 memset (p, '0', trailing_zeros);
4779 p += trailing_zeros;
4780 memcpy (p, src, exponent_bytes);
4781 p += exponent_bytes;
4783 nchars += leading_zeros + sprintf_bytes + trailing_zeros;
4785 if (minus_flag)
4787 memset (p, ' ', padding);
4788 p += padding;
4789 nchars += padding;
4791 spec->end = nchars;
4793 new_result = true;
4794 continue;
4798 else
4800 unsigned char str[MAX_MULTIBYTE_LENGTH];
4802 if ((format_char == '`' || format_char == '\'')
4803 && quoting_style == CURVE_QUOTING_STYLE)
4805 if (! multibyte)
4807 multibyte = true;
4808 goto retry;
4810 convsrc = format_char == '`' ? uLSQM : uRSQM;
4811 convbytes = 3;
4812 new_result = true;
4814 else if (format_char == '`' && quoting_style == STRAIGHT_QUOTING_STYLE)
4816 convsrc = "'";
4817 new_result = true;
4819 else
4821 /* Copy a single character from format to buf. */
4822 if (multibyte_format)
4824 /* Copy a whole multibyte character. */
4825 if (p > buf
4826 && !ASCII_CHAR_P (*((unsigned char *) p - 1))
4827 && !CHAR_HEAD_P (format_char))
4828 maybe_combine_byte = true;
4830 while (! CHAR_HEAD_P (*format))
4831 format++;
4833 convbytes = format - format0;
4834 memset (&discarded[format0 + 1 - format_start], 2,
4835 convbytes - 1);
4837 else if (multibyte && !ASCII_CHAR_P (format_char))
4839 int c = BYTE8_TO_CHAR (format_char);
4840 convbytes = CHAR_STRING (c, str);
4841 convsrc = (char *) str;
4842 new_result = true;
4846 copy_char:
4847 if (convbytes <= buf + bufsize - p)
4849 memcpy (p, convsrc, convbytes);
4850 p += convbytes;
4851 nchars++;
4852 continue;
4856 /* There wasn't enough room to store this conversion or single
4857 character. CONVBYTES says how much room is needed. Allocate
4858 enough room (and then some) and do it again. */
4860 ptrdiff_t used = p - buf;
4861 if (max_bufsize - used < convbytes)
4862 string_overflow ();
4863 bufsize = used + convbytes;
4864 bufsize = bufsize < max_bufsize / 2 ? bufsize * 2 : max_bufsize;
4866 if (buf == initial_buffer)
4868 buf = xmalloc (bufsize);
4869 sa_must_free = true;
4870 buf_save_value_index = SPECPDL_INDEX ();
4871 record_unwind_protect_ptr (xfree, buf);
4872 memcpy (buf, initial_buffer, used);
4874 else
4876 buf = xrealloc (buf, bufsize);
4877 set_unwind_protect_ptr (buf_save_value_index, xfree, buf);
4880 p = buf + used;
4881 format = format0;
4882 n = n0;
4883 ispec = ispec0;
4886 if (bufsize < p - buf)
4887 emacs_abort ();
4889 if (! new_result)
4891 val = args[0];
4892 goto return_val;
4895 if (maybe_combine_byte)
4896 nchars = multibyte_chars_in_text ((unsigned char *) buf, p - buf);
4897 val = make_specified_string (buf, nchars, p - buf, multibyte);
4899 /* If the format string has text properties, or any of the string
4900 arguments has text properties, set up text properties of the
4901 result string. */
4903 if (string_intervals (args[0]) || arg_intervals)
4905 /* Add text properties from the format string. */
4906 Lisp_Object len = make_number (SCHARS (args[0]));
4907 Lisp_Object props = text_property_list (args[0], make_number (0),
4908 len, Qnil);
4909 if (CONSP (props))
4911 ptrdiff_t bytepos = 0, position = 0, translated = 0;
4912 ptrdiff_t fieldn = 0;
4914 /* Adjust the bounds of each text property
4915 to the proper start and end in the output string. */
4917 /* Put the positions in PROPS in increasing order, so that
4918 we can do (effectively) one scan through the position
4919 space of the format string. */
4920 props = Fnreverse (props);
4922 /* BYTEPOS is the byte position in the format string,
4923 POSITION is the untranslated char position in it,
4924 TRANSLATED is the translated char position in BUF,
4925 and ARGN is the number of the next arg we will come to. */
4926 for (Lisp_Object list = props; CONSP (list); list = XCDR (list))
4928 Lisp_Object item = XCAR (list);
4930 /* First adjust the property start position. */
4931 ptrdiff_t pos = XINT (XCAR (item));
4933 /* Advance BYTEPOS, POSITION, TRANSLATED and ARGN
4934 up to this position. */
4935 for (; position < pos; bytepos++)
4937 if (! discarded[bytepos])
4938 position++, translated++;
4939 else if (discarded[bytepos] == 1)
4941 position++;
4942 if (fieldn < nspec && translated == info[fieldn].start)
4944 translated += info[fieldn].end - info[fieldn].start;
4945 fieldn++;
4950 XSETCAR (item, make_number (translated));
4952 /* Likewise adjust the property end position. */
4953 pos = XINT (XCAR (XCDR (item)));
4955 for (; position < pos; bytepos++)
4957 if (! discarded[bytepos])
4958 position++, translated++;
4959 else if (discarded[bytepos] == 1)
4961 position++;
4962 if (fieldn < nspec && translated == info[fieldn].start)
4964 translated += info[fieldn].end - info[fieldn].start;
4965 fieldn++;
4970 XSETCAR (XCDR (item), make_number (translated));
4973 add_text_properties_from_list (val, props, make_number (0));
4976 /* Add text properties from arguments. */
4977 if (arg_intervals)
4978 for (ptrdiff_t i = 0; i < nspec; i++)
4979 if (info[i].intervals)
4981 len = make_number (SCHARS (info[i].argument));
4982 Lisp_Object new_len = make_number (info[i].end - info[i].start);
4983 props = text_property_list (info[i].argument,
4984 make_number (0), len, Qnil);
4985 props = extend_property_ranges (props, len, new_len);
4986 /* If successive arguments have properties, be sure that
4987 the value of `composition' property be the copy. */
4988 if (1 < i && info[i - 1].end)
4989 make_composition_value_copy (props);
4990 add_text_properties_from_list (val, props,
4991 make_number (info[i].start));
4995 return_val:
4996 /* If we allocated BUF or INFO with malloc, free it too. */
4997 SAFE_FREE ();
4999 return val;
5002 DEFUN ("char-equal", Fchar_equal, Schar_equal, 2, 2, 0,
5003 doc: /* Return t if two characters match, optionally ignoring case.
5004 Both arguments must be characters (i.e. integers).
5005 Case is ignored if `case-fold-search' is non-nil in the current buffer. */)
5006 (register Lisp_Object c1, Lisp_Object c2)
5008 int i1, i2;
5009 /* Check they're chars, not just integers, otherwise we could get array
5010 bounds violations in downcase. */
5011 CHECK_CHARACTER (c1);
5012 CHECK_CHARACTER (c2);
5014 if (XINT (c1) == XINT (c2))
5015 return Qt;
5016 if (NILP (BVAR (current_buffer, case_fold_search)))
5017 return Qnil;
5019 i1 = XFASTINT (c1);
5020 i2 = XFASTINT (c2);
5022 /* FIXME: It is possible to compare multibyte characters even when
5023 the current buffer is unibyte. Unfortunately this is ambiguous
5024 for characters between 128 and 255, as they could be either
5025 eight-bit raw bytes or Latin-1 characters. Assume the former for
5026 now. See Bug#17011, and also see casefiddle.c's casify_object,
5027 which has a similar problem. */
5028 if (NILP (BVAR (current_buffer, enable_multibyte_characters)))
5030 if (SINGLE_BYTE_CHAR_P (i1))
5031 i1 = UNIBYTE_TO_CHAR (i1);
5032 if (SINGLE_BYTE_CHAR_P (i2))
5033 i2 = UNIBYTE_TO_CHAR (i2);
5036 return (downcase (i1) == downcase (i2) ? Qt : Qnil);
5039 /* Transpose the markers in two regions of the current buffer, and
5040 adjust the ones between them if necessary (i.e.: if the regions
5041 differ in size).
5043 START1, END1 are the character positions of the first region.
5044 START1_BYTE, END1_BYTE are the byte positions.
5045 START2, END2 are the character positions of the second region.
5046 START2_BYTE, END2_BYTE are the byte positions.
5048 Traverses the entire marker list of the buffer to do so, adding an
5049 appropriate amount to some, subtracting from some, and leaving the
5050 rest untouched. Most of this is copied from adjust_markers in insdel.c.
5052 It's the caller's job to ensure that START1 <= END1 <= START2 <= END2. */
5054 static void
5055 transpose_markers (ptrdiff_t start1, ptrdiff_t end1,
5056 ptrdiff_t start2, ptrdiff_t end2,
5057 ptrdiff_t start1_byte, ptrdiff_t end1_byte,
5058 ptrdiff_t start2_byte, ptrdiff_t end2_byte)
5060 register ptrdiff_t amt1, amt1_byte, amt2, amt2_byte, diff, diff_byte, mpos;
5061 register struct Lisp_Marker *marker;
5063 /* Update point as if it were a marker. */
5064 if (PT < start1)
5066 else if (PT < end1)
5067 TEMP_SET_PT_BOTH (PT + (end2 - end1),
5068 PT_BYTE + (end2_byte - end1_byte));
5069 else if (PT < start2)
5070 TEMP_SET_PT_BOTH (PT + (end2 - start2) - (end1 - start1),
5071 (PT_BYTE + (end2_byte - start2_byte)
5072 - (end1_byte - start1_byte)));
5073 else if (PT < end2)
5074 TEMP_SET_PT_BOTH (PT - (start2 - start1),
5075 PT_BYTE - (start2_byte - start1_byte));
5077 /* We used to adjust the endpoints here to account for the gap, but that
5078 isn't good enough. Even if we assume the caller has tried to move the
5079 gap out of our way, it might still be at start1 exactly, for example;
5080 and that places it `inside' the interval, for our purposes. The amount
5081 of adjustment is nontrivial if there's a `denormalized' marker whose
5082 position is between GPT and GPT + GAP_SIZE, so it's simpler to leave
5083 the dirty work to Fmarker_position, below. */
5085 /* The difference between the region's lengths */
5086 diff = (end2 - start2) - (end1 - start1);
5087 diff_byte = (end2_byte - start2_byte) - (end1_byte - start1_byte);
5089 /* For shifting each marker in a region by the length of the other
5090 region plus the distance between the regions. */
5091 amt1 = (end2 - start2) + (start2 - end1);
5092 amt2 = (end1 - start1) + (start2 - end1);
5093 amt1_byte = (end2_byte - start2_byte) + (start2_byte - end1_byte);
5094 amt2_byte = (end1_byte - start1_byte) + (start2_byte - end1_byte);
5096 for (marker = BUF_MARKERS (current_buffer); marker; marker = marker->next)
5098 mpos = marker->bytepos;
5099 if (mpos >= start1_byte && mpos < end2_byte)
5101 if (mpos < end1_byte)
5102 mpos += amt1_byte;
5103 else if (mpos < start2_byte)
5104 mpos += diff_byte;
5105 else
5106 mpos -= amt2_byte;
5107 marker->bytepos = mpos;
5109 mpos = marker->charpos;
5110 if (mpos >= start1 && mpos < end2)
5112 if (mpos < end1)
5113 mpos += amt1;
5114 else if (mpos < start2)
5115 mpos += diff;
5116 else
5117 mpos -= amt2;
5119 marker->charpos = mpos;
5123 DEFUN ("transpose-regions", Ftranspose_regions, Stranspose_regions, 4, 5,
5124 "(if (< (length mark-ring) 2)\
5125 (error \"Other region must be marked before transposing two regions\")\
5126 (let* ((num (if current-prefix-arg\
5127 (prefix-numeric-value current-prefix-arg)\
5128 0))\
5129 (ring-length (length mark-ring))\
5130 (eltnum (mod num ring-length))\
5131 (eltnum2 (mod (1+ num) ring-length)))\
5132 (list (point) (mark) (elt mark-ring eltnum) (elt mark-ring eltnum2))))",
5133 doc: /* Transpose region STARTR1 to ENDR1 with STARTR2 to ENDR2.
5134 The regions should not be overlapping, because the size of the buffer is
5135 never changed in a transposition.
5137 Optional fifth arg LEAVE-MARKERS, if non-nil, means don't update
5138 any markers that happen to be located in the regions.
5140 Transposing beyond buffer boundaries is an error.
5142 Interactively, STARTR1 and ENDR1 are point and mark; STARTR2 and ENDR2
5143 are the last two marks pushed to the mark ring; LEAVE-MARKERS is nil.
5144 If a prefix argument N is given, STARTR2 and ENDR2 are the two
5145 successive marks N entries back in the mark ring. A negative prefix
5146 argument instead counts forward from the oldest mark in the mark
5147 ring. */)
5148 (Lisp_Object startr1, Lisp_Object endr1, Lisp_Object startr2, Lisp_Object endr2, Lisp_Object leave_markers)
5150 register ptrdiff_t start1, end1, start2, end2;
5151 ptrdiff_t start1_byte, start2_byte, len1_byte, len2_byte, end2_byte;
5152 ptrdiff_t gap, len1, len_mid, len2;
5153 unsigned char *start1_addr, *start2_addr, *temp;
5155 INTERVAL cur_intv, tmp_interval1, tmp_interval_mid, tmp_interval2, tmp_interval3;
5156 Lisp_Object buf;
5158 XSETBUFFER (buf, current_buffer);
5159 cur_intv = buffer_intervals (current_buffer);
5161 validate_region (&startr1, &endr1);
5162 validate_region (&startr2, &endr2);
5164 start1 = XFASTINT (startr1);
5165 end1 = XFASTINT (endr1);
5166 start2 = XFASTINT (startr2);
5167 end2 = XFASTINT (endr2);
5168 gap = GPT;
5170 /* Swap the regions if they're reversed. */
5171 if (start2 < end1)
5173 register ptrdiff_t glumph = start1;
5174 start1 = start2;
5175 start2 = glumph;
5176 glumph = end1;
5177 end1 = end2;
5178 end2 = glumph;
5181 len1 = end1 - start1;
5182 len2 = end2 - start2;
5184 if (start2 < end1)
5185 error ("Transposed regions overlap");
5186 /* Nothing to change for adjacent regions with one being empty */
5187 else if ((start1 == end1 || start2 == end2) && end1 == start2)
5188 return Qnil;
5190 /* The possibilities are:
5191 1. Adjacent (contiguous) regions, or separate but equal regions
5192 (no, really equal, in this case!), or
5193 2. Separate regions of unequal size.
5195 The worst case is usually No. 2. It means that (aside from
5196 potential need for getting the gap out of the way), there also
5197 needs to be a shifting of the text between the two regions. So
5198 if they are spread far apart, we are that much slower... sigh. */
5200 /* It must be pointed out that the really studly thing to do would
5201 be not to move the gap at all, but to leave it in place and work
5202 around it if necessary. This would be extremely efficient,
5203 especially considering that people are likely to do
5204 transpositions near where they are working interactively, which
5205 is exactly where the gap would be found. However, such code
5206 would be much harder to write and to read. So, if you are
5207 reading this comment and are feeling squirrely, by all means have
5208 a go! I just didn't feel like doing it, so I will simply move
5209 the gap the minimum distance to get it out of the way, and then
5210 deal with an unbroken array. */
5212 start1_byte = CHAR_TO_BYTE (start1);
5213 end2_byte = CHAR_TO_BYTE (end2);
5215 /* Make sure the gap won't interfere, by moving it out of the text
5216 we will operate on. */
5217 if (start1 < gap && gap < end2)
5219 if (gap - start1 < end2 - gap)
5220 move_gap_both (start1, start1_byte);
5221 else
5222 move_gap_both (end2, end2_byte);
5225 start2_byte = CHAR_TO_BYTE (start2);
5226 len1_byte = CHAR_TO_BYTE (end1) - start1_byte;
5227 len2_byte = end2_byte - start2_byte;
5229 #ifdef BYTE_COMBINING_DEBUG
5230 if (end1 == start2)
5232 if (count_combining_before (BYTE_POS_ADDR (start2_byte),
5233 len2_byte, start1, start1_byte)
5234 || count_combining_before (BYTE_POS_ADDR (start1_byte),
5235 len1_byte, end2, start2_byte + len2_byte)
5236 || count_combining_after (BYTE_POS_ADDR (start1_byte),
5237 len1_byte, end2, start2_byte + len2_byte))
5238 emacs_abort ();
5240 else
5242 if (count_combining_before (BYTE_POS_ADDR (start2_byte),
5243 len2_byte, start1, start1_byte)
5244 || count_combining_before (BYTE_POS_ADDR (start1_byte),
5245 len1_byte, start2, start2_byte)
5246 || count_combining_after (BYTE_POS_ADDR (start2_byte),
5247 len2_byte, end1, start1_byte + len1_byte)
5248 || count_combining_after (BYTE_POS_ADDR (start1_byte),
5249 len1_byte, end2, start2_byte + len2_byte))
5250 emacs_abort ();
5252 #endif
5254 /* Hmmm... how about checking to see if the gap is large
5255 enough to use as the temporary storage? That would avoid an
5256 allocation... interesting. Later, don't fool with it now. */
5258 /* Working without memmove, for portability (sigh), so must be
5259 careful of overlapping subsections of the array... */
5261 if (end1 == start2) /* adjacent regions */
5263 modify_text (start1, end2);
5264 record_change (start1, len1 + len2);
5266 tmp_interval1 = copy_intervals (cur_intv, start1, len1);
5267 tmp_interval2 = copy_intervals (cur_intv, start2, len2);
5268 /* Don't use Fset_text_properties: that can cause GC, which can
5269 clobber objects stored in the tmp_intervals. */
5270 tmp_interval3 = validate_interval_range (buf, &startr1, &endr2, 0);
5271 if (tmp_interval3)
5272 set_text_properties_1 (startr1, endr2, Qnil, buf, tmp_interval3);
5274 USE_SAFE_ALLOCA;
5276 /* First region smaller than second. */
5277 if (len1_byte < len2_byte)
5279 temp = SAFE_ALLOCA (len2_byte);
5281 /* Don't precompute these addresses. We have to compute them
5282 at the last minute, because the relocating allocator might
5283 have moved the buffer around during the xmalloc. */
5284 start1_addr = BYTE_POS_ADDR (start1_byte);
5285 start2_addr = BYTE_POS_ADDR (start2_byte);
5287 memcpy (temp, start2_addr, len2_byte);
5288 memcpy (start1_addr + len2_byte, start1_addr, len1_byte);
5289 memcpy (start1_addr, temp, len2_byte);
5291 else
5292 /* First region not smaller than second. */
5294 temp = SAFE_ALLOCA (len1_byte);
5295 start1_addr = BYTE_POS_ADDR (start1_byte);
5296 start2_addr = BYTE_POS_ADDR (start2_byte);
5297 memcpy (temp, start1_addr, len1_byte);
5298 memcpy (start1_addr, start2_addr, len2_byte);
5299 memcpy (start1_addr + len2_byte, temp, len1_byte);
5302 SAFE_FREE ();
5303 graft_intervals_into_buffer (tmp_interval1, start1 + len2,
5304 len1, current_buffer, 0);
5305 graft_intervals_into_buffer (tmp_interval2, start1,
5306 len2, current_buffer, 0);
5307 update_compositions (start1, start1 + len2, CHECK_BORDER);
5308 update_compositions (start1 + len2, end2, CHECK_TAIL);
5310 /* Non-adjacent regions, because end1 != start2, bleagh... */
5311 else
5313 len_mid = start2_byte - (start1_byte + len1_byte);
5315 if (len1_byte == len2_byte)
5316 /* Regions are same size, though, how nice. */
5318 USE_SAFE_ALLOCA;
5320 modify_text (start1, end2);
5321 record_change (start1, len1);
5322 record_change (start2, len2);
5323 tmp_interval1 = copy_intervals (cur_intv, start1, len1);
5324 tmp_interval2 = copy_intervals (cur_intv, start2, len2);
5326 tmp_interval3 = validate_interval_range (buf, &startr1, &endr1, 0);
5327 if (tmp_interval3)
5328 set_text_properties_1 (startr1, endr1, Qnil, buf, tmp_interval3);
5330 tmp_interval3 = validate_interval_range (buf, &startr2, &endr2, 0);
5331 if (tmp_interval3)
5332 set_text_properties_1 (startr2, endr2, Qnil, buf, tmp_interval3);
5334 temp = SAFE_ALLOCA (len1_byte);
5335 start1_addr = BYTE_POS_ADDR (start1_byte);
5336 start2_addr = BYTE_POS_ADDR (start2_byte);
5337 memcpy (temp, start1_addr, len1_byte);
5338 memcpy (start1_addr, start2_addr, len2_byte);
5339 memcpy (start2_addr, temp, len1_byte);
5340 SAFE_FREE ();
5342 graft_intervals_into_buffer (tmp_interval1, start2,
5343 len1, current_buffer, 0);
5344 graft_intervals_into_buffer (tmp_interval2, start1,
5345 len2, current_buffer, 0);
5348 else if (len1_byte < len2_byte) /* Second region larger than first */
5349 /* Non-adjacent & unequal size, area between must also be shifted. */
5351 USE_SAFE_ALLOCA;
5353 modify_text (start1, end2);
5354 record_change (start1, (end2 - start1));
5355 tmp_interval1 = copy_intervals (cur_intv, start1, len1);
5356 tmp_interval_mid = copy_intervals (cur_intv, end1, len_mid);
5357 tmp_interval2 = copy_intervals (cur_intv, start2, len2);
5359 tmp_interval3 = validate_interval_range (buf, &startr1, &endr2, 0);
5360 if (tmp_interval3)
5361 set_text_properties_1 (startr1, endr2, Qnil, buf, tmp_interval3);
5363 /* holds region 2 */
5364 temp = SAFE_ALLOCA (len2_byte);
5365 start1_addr = BYTE_POS_ADDR (start1_byte);
5366 start2_addr = BYTE_POS_ADDR (start2_byte);
5367 memcpy (temp, start2_addr, len2_byte);
5368 memcpy (start1_addr + len_mid + len2_byte, start1_addr, len1_byte);
5369 memmove (start1_addr + len2_byte, start1_addr + len1_byte, len_mid);
5370 memcpy (start1_addr, temp, len2_byte);
5371 SAFE_FREE ();
5373 graft_intervals_into_buffer (tmp_interval1, end2 - len1,
5374 len1, current_buffer, 0);
5375 graft_intervals_into_buffer (tmp_interval_mid, start1 + len2,
5376 len_mid, current_buffer, 0);
5377 graft_intervals_into_buffer (tmp_interval2, start1,
5378 len2, current_buffer, 0);
5380 else
5381 /* Second region smaller than first. */
5383 USE_SAFE_ALLOCA;
5385 record_change (start1, (end2 - start1));
5386 modify_text (start1, end2);
5388 tmp_interval1 = copy_intervals (cur_intv, start1, len1);
5389 tmp_interval_mid = copy_intervals (cur_intv, end1, len_mid);
5390 tmp_interval2 = copy_intervals (cur_intv, start2, len2);
5392 tmp_interval3 = validate_interval_range (buf, &startr1, &endr2, 0);
5393 if (tmp_interval3)
5394 set_text_properties_1 (startr1, endr2, Qnil, buf, tmp_interval3);
5396 /* holds region 1 */
5397 temp = SAFE_ALLOCA (len1_byte);
5398 start1_addr = BYTE_POS_ADDR (start1_byte);
5399 start2_addr = BYTE_POS_ADDR (start2_byte);
5400 memcpy (temp, start1_addr, len1_byte);
5401 memcpy (start1_addr, start2_addr, len2_byte);
5402 memmove (start1_addr + len2_byte, start1_addr + len1_byte, len_mid);
5403 memcpy (start1_addr + len2_byte + len_mid, temp, len1_byte);
5404 SAFE_FREE ();
5406 graft_intervals_into_buffer (tmp_interval1, end2 - len1,
5407 len1, current_buffer, 0);
5408 graft_intervals_into_buffer (tmp_interval_mid, start1 + len2,
5409 len_mid, current_buffer, 0);
5410 graft_intervals_into_buffer (tmp_interval2, start1,
5411 len2, current_buffer, 0);
5414 update_compositions (start1, start1 + len2, CHECK_BORDER);
5415 update_compositions (end2 - len1, end2, CHECK_BORDER);
5418 /* When doing multiple transpositions, it might be nice
5419 to optimize this. Perhaps the markers in any one buffer
5420 should be organized in some sorted data tree. */
5421 if (NILP (leave_markers))
5423 transpose_markers (start1, end1, start2, end2,
5424 start1_byte, start1_byte + len1_byte,
5425 start2_byte, start2_byte + len2_byte);
5426 fix_start_end_in_overlays (start1, end2);
5428 else
5430 /* The character positions of the markers remain intact, but we
5431 still need to update their byte positions, because the
5432 transposed regions might include multibyte sequences which
5433 make some original byte positions of the markers invalid. */
5434 adjust_markers_bytepos (start1, start1_byte, end2, end2_byte, 0);
5437 signal_after_change (start1, end2 - start1, end2 - start1);
5438 return Qnil;
5442 void
5443 syms_of_editfns (void)
5445 DEFSYM (Qbuffer_access_fontify_functions, "buffer-access-fontify-functions");
5446 DEFSYM (Qwall, "wall");
5448 DEFVAR_LISP ("inhibit-field-text-motion", Vinhibit_field_text_motion,
5449 doc: /* Non-nil means text motion commands don't notice fields. */);
5450 Vinhibit_field_text_motion = Qnil;
5452 DEFVAR_LISP ("buffer-access-fontify-functions",
5453 Vbuffer_access_fontify_functions,
5454 doc: /* List of functions called by `buffer-substring' to fontify if necessary.
5455 Each function is called with two arguments which specify the range
5456 of the buffer being accessed. */);
5457 Vbuffer_access_fontify_functions = Qnil;
5460 Lisp_Object obuf;
5461 obuf = Fcurrent_buffer ();
5462 /* Do this here, because init_buffer_once is too early--it won't work. */
5463 Fset_buffer (Vprin1_to_string_buffer);
5464 /* Make sure buffer-access-fontify-functions is nil in this buffer. */
5465 Fset (Fmake_local_variable (Qbuffer_access_fontify_functions), Qnil);
5466 Fset_buffer (obuf);
5469 DEFVAR_LISP ("buffer-access-fontified-property",
5470 Vbuffer_access_fontified_property,
5471 doc: /* Property which (if non-nil) indicates text has been fontified.
5472 `buffer-substring' need not call the `buffer-access-fontify-functions'
5473 functions if all the text being accessed has this property. */);
5474 Vbuffer_access_fontified_property = Qnil;
5476 DEFVAR_LISP ("system-name", Vsystem_name,
5477 doc: /* The host name of the machine Emacs is running on. */);
5478 Vsystem_name = cached_system_name = Qnil;
5480 DEFVAR_LISP ("user-full-name", Vuser_full_name,
5481 doc: /* The full name of the user logged in. */);
5483 DEFVAR_LISP ("user-login-name", Vuser_login_name,
5484 doc: /* The user's name, taken from environment variables if possible. */);
5485 Vuser_login_name = Qnil;
5487 DEFVAR_LISP ("user-real-login-name", Vuser_real_login_name,
5488 doc: /* The user's name, based upon the real uid only. */);
5490 DEFVAR_LISP ("operating-system-release", Voperating_system_release,
5491 doc: /* The release of the operating system Emacs is running on. */);
5493 defsubr (&Spropertize);
5494 defsubr (&Schar_equal);
5495 defsubr (&Sgoto_char);
5496 defsubr (&Sstring_to_char);
5497 defsubr (&Schar_to_string);
5498 defsubr (&Sbyte_to_string);
5499 defsubr (&Sbuffer_substring);
5500 defsubr (&Sbuffer_substring_no_properties);
5501 defsubr (&Sbuffer_string);
5502 defsubr (&Sget_pos_property);
5504 defsubr (&Spoint_marker);
5505 defsubr (&Smark_marker);
5506 defsubr (&Spoint);
5507 defsubr (&Sregion_beginning);
5508 defsubr (&Sregion_end);
5510 /* Symbol for the text property used to mark fields. */
5511 DEFSYM (Qfield, "field");
5513 /* A special value for Qfield properties. */
5514 DEFSYM (Qboundary, "boundary");
5516 defsubr (&Sfield_beginning);
5517 defsubr (&Sfield_end);
5518 defsubr (&Sfield_string);
5519 defsubr (&Sfield_string_no_properties);
5520 defsubr (&Sdelete_field);
5521 defsubr (&Sconstrain_to_field);
5523 defsubr (&Sline_beginning_position);
5524 defsubr (&Sline_end_position);
5526 defsubr (&Ssave_excursion);
5527 defsubr (&Ssave_current_buffer);
5529 defsubr (&Sbuffer_size);
5530 defsubr (&Spoint_max);
5531 defsubr (&Spoint_min);
5532 defsubr (&Spoint_min_marker);
5533 defsubr (&Spoint_max_marker);
5534 defsubr (&Sgap_position);
5535 defsubr (&Sgap_size);
5536 defsubr (&Sposition_bytes);
5537 defsubr (&Sbyte_to_position);
5539 defsubr (&Sbobp);
5540 defsubr (&Seobp);
5541 defsubr (&Sbolp);
5542 defsubr (&Seolp);
5543 defsubr (&Sfollowing_char);
5544 defsubr (&Sprevious_char);
5545 defsubr (&Schar_after);
5546 defsubr (&Schar_before);
5547 defsubr (&Sinsert);
5548 defsubr (&Sinsert_before_markers);
5549 defsubr (&Sinsert_and_inherit);
5550 defsubr (&Sinsert_and_inherit_before_markers);
5551 defsubr (&Sinsert_char);
5552 defsubr (&Sinsert_byte);
5554 defsubr (&Suser_login_name);
5555 defsubr (&Suser_real_login_name);
5556 defsubr (&Suser_uid);
5557 defsubr (&Suser_real_uid);
5558 defsubr (&Sgroup_gid);
5559 defsubr (&Sgroup_real_gid);
5560 defsubr (&Suser_full_name);
5561 defsubr (&Semacs_pid);
5562 defsubr (&Scurrent_time);
5563 defsubr (&Stime_add);
5564 defsubr (&Stime_subtract);
5565 defsubr (&Stime_less_p);
5566 defsubr (&Sget_internal_run_time);
5567 defsubr (&Sformat_time_string);
5568 defsubr (&Sfloat_time);
5569 defsubr (&Sdecode_time);
5570 defsubr (&Sencode_time);
5571 defsubr (&Scurrent_time_string);
5572 defsubr (&Scurrent_time_zone);
5573 defsubr (&Sset_time_zone_rule);
5574 defsubr (&Ssystem_name);
5575 defsubr (&Smessage);
5576 defsubr (&Smessage_box);
5577 defsubr (&Smessage_or_box);
5578 defsubr (&Scurrent_message);
5579 defsubr (&Sformat);
5580 defsubr (&Sformat_message);
5582 defsubr (&Sinsert_buffer_substring);
5583 defsubr (&Scompare_buffer_substrings);
5584 defsubr (&Sreplace_buffer_contents);
5585 defsubr (&Ssubst_char_in_region);
5586 defsubr (&Stranslate_region_internal);
5587 defsubr (&Sdelete_region);
5588 defsubr (&Sdelete_and_extract_region);
5589 defsubr (&Swiden);
5590 defsubr (&Snarrow_to_region);
5591 defsubr (&Ssave_restriction);
5592 defsubr (&Stranspose_regions);