aboutsummaryrefslogtreecommitdiffstats
path: root/src/editfns.c
diff options
context:
space:
mode:
authorStefan Monnier2022-09-25 16:15:16 -0400
committerStefan Monnier2022-09-25 16:15:16 -0400
commit650c20f1ca4e07591a727e1cfcc74b3363d15985 (patch)
tree85d11f6437cde22f410c25e0e5f71a3131ebd07d /src/editfns.c
parent8869332684c2302b5ba1ead4568bbc7ba1c0183e (diff)
parent4b85ae6a24380fb67a3315eaec9233f17a872473 (diff)
downloademacs-650c20f1ca4e07591a727e1cfcc74b3363d15985.tar.gz
emacs-650c20f1ca4e07591a727e1cfcc74b3363d15985.zip
Merge 'master' into noverlay
Diffstat (limited to 'src/editfns.c')
-rw-r--r--src/editfns.c2977
1 files changed, 1064 insertions, 1913 deletions
diff --git a/src/editfns.c b/src/editfns.c
index 8628b1b2d49..1af6ea1b11d 100644
--- a/src/editfns.c
+++ b/src/editfns.c
@@ -1,6 +1,6 @@
1/* Lisp functions pertaining to editing. -*- coding: utf-8 -*- 1/* Lisp functions pertaining to editing. -*- coding: utf-8 -*-
2 2
3Copyright (C) 1985-1987, 1989, 1993-2017 Free Software Foundation, Inc. 3Copyright (C) 1985-2022 Free Software Foundation, Inc.
4 4
5This file is part of GNU Emacs. 5This file is part of GNU Emacs.
6 6
@@ -35,55 +35,28 @@ along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. */
35 35
36#include "lisp.h" 36#include "lisp.h"
37 37
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"
42
43#if defined HAVE_SYS_RESOURCE_H
44#include <sys/resource.h>
45#endif
46
47#include <errno.h>
48#include <float.h> 38#include <float.h>
49#include <limits.h> 39#include <limits.h>
40#include <math.h>
50 41
51#include <c-ctype.h> 42#include <c-ctype.h>
52#include <intprops.h> 43#include <intprops.h>
53#include <stdlib.h> 44#include <stdlib.h>
54#include <strftime.h>
55#include <verify.h> 45#include <verify.h>
56 46
57#include "composite.h" 47#include "composite.h"
58#include "intervals.h" 48#include "intervals.h"
49#include "systime.h"
59#include "character.h" 50#include "character.h"
60#include "buffer.h" 51#include "buffer.h"
61#include "coding.h"
62#include "window.h" 52#include "window.h"
63#include "blockinput.h" 53#include "blockinput.h"
64 54
65#define TM_YEAR_BASE 1900
66
67#ifdef WINDOWSNT 55#ifdef WINDOWSNT
68extern Lisp_Object w32_get_internal_run_time (void); 56# include "w32common.h"
69#endif 57#endif
70
71static struct lisp_time lisp_time_struct (Lisp_Object, int *);
72static Lisp_Object format_time_string (char const *, ptrdiff_t, struct timespec,
73 Lisp_Object, struct tm *);
74static long int tm_gmtoff (struct tm *);
75static int tm_diff (struct tm *, struct tm *);
76static void update_buffer_properties (ptrdiff_t, ptrdiff_t); 58static void update_buffer_properties (ptrdiff_t, ptrdiff_t);
77 59static Lisp_Object styled_format (ptrdiff_t, Lisp_Object *, bool);
78#ifndef HAVE_TM_GMTOFF
79# define HAVE_TM_GMTOFF false
80#endif
81
82enum { tzeqlen = sizeof "TZ=" - 1 };
83
84/* Time zones equivalent to current local time and to UTC, respectively. */
85static timezone_t local_tz;
86static timezone_t const utc_tz = 0;
87 60
88/* The cached value of Vsystem_name. This is used only to compare it 61/* The cached value of Vsystem_name. This is used only to compare it
89 to Vsystem_name, so it need not be visible to the GC. */ 62 to Vsystem_name, so it need not be visible to the GC. */
@@ -96,141 +69,9 @@ init_and_cache_system_name (void)
96 cached_system_name = Vsystem_name; 69 cached_system_name = Vsystem_name;
97} 70}
98 71
99static struct tm *
100emacs_localtime_rz (timezone_t tz, time_t const *t, struct tm *tm)
101{
102 tm = localtime_rz (tz, t, tm);
103 if (!tm && errno == ENOMEM)
104 memory_full (SIZE_MAX);
105 return tm;
106}
107
108static time_t
109emacs_mktime_z (timezone_t tz, struct tm *tm)
110{
111 errno = 0;
112 time_t t = mktime_z (tz, tm);
113 if (t == (time_t) -1 && errno == ENOMEM)
114 memory_full (SIZE_MAX);
115 return t;
116}
117
118/* Allocate a timezone, signaling on failure. */
119static timezone_t
120xtzalloc (char const *name)
121{
122 timezone_t tz = tzalloc (name);
123 if (!tz)
124 memory_full (SIZE_MAX);
125 return tz;
126}
127
128/* Free a timezone, except do not free the time zone for local time.
129 Freeing utc_tz is also a no-op. */
130static void
131xtzfree (timezone_t tz)
132{
133 if (tz != local_tz)
134 tzfree (tz);
135}
136
137/* Convert the Lisp time zone rule ZONE to a timezone_t object.
138 The returned value either is 0, or is LOCAL_TZ, or is newly allocated.
139 If SETTZ, set Emacs local time to the time zone rule; otherwise,
140 the caller should eventually pass the returned value to xtzfree. */
141static timezone_t
142tzlookup (Lisp_Object zone, bool settz)
143{
144 static char const tzbuf_format[] = "<%+.*"pI"d>%s%"pI"d:%02d:%02d";
145 char const *trailing_tzbuf_format = tzbuf_format + sizeof "<%+.*"pI"d" - 1;
146 char tzbuf[sizeof tzbuf_format + 2 * INT_STRLEN_BOUND (EMACS_INT)];
147 char const *zone_string;
148 timezone_t new_tz;
149
150 if (NILP (zone))
151 return local_tz;
152 else if (EQ (zone, Qt))
153 {
154 zone_string = "UTC0";
155 new_tz = utc_tz;
156 }
157 else
158 {
159 bool plain_integer = INTEGERP (zone);
160
161 if (EQ (zone, Qwall))
162 zone_string = 0;
163 else if (STRINGP (zone))
164 zone_string = SSDATA (ENCODE_SYSTEM (zone));
165 else if (plain_integer || (CONSP (zone) && INTEGERP (XCAR (zone))
166 && CONSP (XCDR (zone))))
167 {
168 Lisp_Object abbr;
169 if (!plain_integer)
170 {
171 abbr = XCAR (XCDR (zone));
172 zone = XCAR (zone);
173 }
174
175 EMACS_INT abszone = eabs (XINT (zone)), hour = abszone / (60 * 60);
176 int hour_remainder = abszone % (60 * 60);
177 int min = hour_remainder / 60, sec = hour_remainder % 60;
178
179 if (plain_integer)
180 {
181 int prec = 2;
182 EMACS_INT numzone = hour;
183 if (hour_remainder != 0)
184 {
185 prec += 2, numzone = 100 * numzone + min;
186 if (sec != 0)
187 prec += 2, numzone = 100 * numzone + sec;
188 }
189 sprintf (tzbuf, tzbuf_format, prec,
190 XINT (zone) < 0 ? -numzone : numzone,
191 &"-"[XINT (zone) < 0], hour, min, sec);
192 zone_string = tzbuf;
193 }
194 else
195 {
196 AUTO_STRING (leading, "<");
197 AUTO_STRING_WITH_LEN (trailing, tzbuf,
198 sprintf (tzbuf, trailing_tzbuf_format,
199 &"-"[XINT (zone) < 0],
200 hour, min, sec));
201 zone_string = SSDATA (concat3 (leading, ENCODE_SYSTEM (abbr),
202 trailing));
203 }
204 }
205 else
206 xsignal2 (Qerror, build_string ("Invalid time zone specification"),
207 zone);
208 new_tz = xtzalloc (zone_string);
209 }
210
211 if (settz)
212 {
213 block_input ();
214 emacs_setenv_TZ (zone_string);
215 tzset ();
216 timezone_t old_tz = local_tz;
217 local_tz = new_tz;
218 tzfree (old_tz);
219 unblock_input ();
220 }
221
222 return new_tz;
223}
224
225void 72void
226init_editfns (bool dumping) 73init_editfns (void)
227{ 74{
228#if !defined CANNOT_DUMP
229 /* A valid but unlikely setting for the TZ environment variable.
230 It is OK (though a bit slower) if the user chooses this value. */
231 static char dump_tz_string[] = "TZ=UtC0";
232#endif
233
234 const char *user_name; 75 const char *user_name;
235 register char *p; 76 register char *p;
236 struct passwd *pw; /* password entry for the current user */ 77 struct passwd *pw; /* password entry for the current user */
@@ -239,37 +80,6 @@ init_editfns (bool dumping)
239 /* Set up system_name even when dumping. */ 80 /* Set up system_name even when dumping. */
240 init_and_cache_system_name (); 81 init_and_cache_system_name ();
241 82
242#ifndef CANNOT_DUMP
243 /* When just dumping out, set the time zone to a known unlikely value
244 and skip the rest of this function. */
245 if (dumping)
246 {
247 xputenv (dump_tz_string);
248 tzset ();
249 return;
250 }
251#endif
252
253 char *tz = getenv ("TZ");
254
255#if !defined CANNOT_DUMP
256 /* If the execution TZ happens to be the same as the dump TZ,
257 change it to some other value and then change it back,
258 to force the underlying implementation to reload the TZ info.
259 This is needed on implementations that load TZ info from files,
260 since the TZ file contents may differ between dump and execution. */
261 if (tz && strcmp (tz, &dump_tz_string[tzeqlen]) == 0)
262 {
263 ++*tz;
264 tzset ();
265 --*tz;
266 }
267#endif
268
269 /* Set the time zone rule now, so that the call to putenv is done
270 before multiple threads are active. */
271 tzlookup (tz ? build_string (tz) : Qwall, true);
272
273 pw = getpwuid (getuid ()); 83 pw = getpwuid (getuid ());
274#ifdef MSDOS 84#ifdef MSDOS
275 /* We let the real user name default to "root" because that's quite 85 /* We let the real user name default to "root" because that's quite
@@ -304,7 +114,7 @@ init_editfns (bool dumping)
304 else 114 else
305 { 115 {
306 uid_t euid = geteuid (); 116 uid_t euid = geteuid ();
307 tem = make_fixnum_or_float (euid); 117 tem = INT_TO_INTEGER (euid);
308 } 118 }
309 Vuser_full_name = Fuser_full_name (tem); 119 Vuser_full_name = Fuser_full_name (tem);
310 120
@@ -314,12 +124,14 @@ init_editfns (bool dumping)
314 else if (NILP (Vuser_full_name)) 124 else if (NILP (Vuser_full_name))
315 Vuser_full_name = build_string ("unknown"); 125 Vuser_full_name = build_string ("unknown");
316 126
317#ifdef HAVE_SYS_UTSNAME_H 127#if defined HAVE_SYS_UTSNAME_H
318 { 128 {
319 struct utsname uts; 129 struct utsname uts;
320 uname (&uts); 130 uname (&uts);
321 Voperating_system_release = build_string (uts.release); 131 Voperating_system_release = build_string (uts.release);
322 } 132 }
133#elif defined WINDOWSNT
134 Voperating_system_release = build_string (w32_version_string ());
323#else 135#else
324 Voperating_system_release = Qnil; 136 Voperating_system_release = Qnil;
325#endif 137#endif
@@ -334,7 +146,7 @@ usage: (char-to-string CHAR) */)
334 unsigned char str[MAX_MULTIBYTE_LENGTH]; 146 unsigned char str[MAX_MULTIBYTE_LENGTH];
335 147
336 CHECK_CHARACTER (character); 148 CHECK_CHARACTER (character);
337 c = XFASTINT (character); 149 c = XFIXNAT (character);
338 150
339 len = CHAR_STRING (c, str); 151 len = CHAR_STRING (c, str);
340 return make_string_from_bytes ((char *) str, 1, len); 152 return make_string_from_bytes ((char *) str, 1, len);
@@ -345,29 +157,23 @@ DEFUN ("byte-to-string", Fbyte_to_string, Sbyte_to_string, 1, 1, 0,
345 (Lisp_Object byte) 157 (Lisp_Object byte)
346{ 158{
347 unsigned char b; 159 unsigned char b;
348 CHECK_NUMBER (byte); 160 CHECK_FIXNUM (byte);
349 if (XINT (byte) < 0 || XINT (byte) > 255) 161 if (XFIXNUM (byte) < 0 || XFIXNUM (byte) > 255)
350 error ("Invalid byte"); 162 error ("Invalid byte");
351 b = XINT (byte); 163 b = XFIXNUM (byte);
352 return make_string_from_bytes ((char *) &b, 1, 1); 164 return make_unibyte_string ((char *) &b, 1);
353} 165}
354 166
355DEFUN ("string-to-char", Fstring_to_char, Sstring_to_char, 1, 1, 0, 167DEFUN ("string-to-char", Fstring_to_char, Sstring_to_char, 1, 1, 0,
356 doc: /* Return the first character in STRING. */) 168 doc: /* Return the first character in STRING. */)
357 (register Lisp_Object string) 169 (Lisp_Object string)
358{ 170{
359 register Lisp_Object val;
360 CHECK_STRING (string); 171 CHECK_STRING (string);
361 if (SCHARS (string)) 172
362 { 173 /* This returns zero if STRING is empty. */
363 if (STRING_MULTIBYTE (string)) 174 return make_fixnum (STRING_MULTIBYTE (string)
364 XSETFASTINT (val, STRING_CHAR (SDATA (string))); 175 ? STRING_CHAR (SDATA (string))
365 else 176 : SREF (string, 0));
366 XSETFASTINT (val, SREF (string, 0));
367 }
368 else
369 XSETFASTINT (val, 0);
370 return val;
371} 177}
372 178
373DEFUN ("point", Fpoint, Spoint, 0, 0, 0, 179DEFUN ("point", Fpoint, Spoint, 0, 0, 0,
@@ -387,17 +193,22 @@ DEFUN ("point-marker", Fpoint_marker, Spoint_marker, 0, 0, 0,
387 return build_marker (current_buffer, PT, PT_BYTE); 193 return build_marker (current_buffer, PT, PT_BYTE);
388} 194}
389 195
390DEFUN ("goto-char", Fgoto_char, Sgoto_char, 1, 1, "NGoto char: ", 196DEFUN ("goto-char", Fgoto_char, Sgoto_char, 1, 1,
197 "(goto-char--read-natnum-interactive \"Go to char: \")",
391 doc: /* Set point to POSITION, a number or marker. 198 doc: /* Set point to POSITION, a number or marker.
392Beginning of buffer is position (point-min), end is (point-max). 199Beginning of buffer is position (point-min), end is (point-max).
393 200
394The return value is POSITION. */) 201The return value is POSITION.
202
203If called interactively, a numeric prefix argument specifies
204POSITION; without a numeric prefix argument, read POSITION from the
205minibuffer. The default value is the number at point (if any). */)
395 (register Lisp_Object position) 206 (register Lisp_Object position)
396{ 207{
397 if (MARKERP (position)) 208 if (MARKERP (position))
398 set_point_from_marker (position); 209 set_point_from_marker (position);
399 else if (INTEGERP (position)) 210 else if (FIXNUMP (position))
400 SET_PT (clip_to_bounds (BEGV, XINT (position), ZV)); 211 SET_PT (clip_to_bounds (BEGV, XFIXNUM (position), ZV));
401 else 212 else
402 wrong_type_argument (Qinteger_or_marker_p, position); 213 wrong_type_argument (Qinteger_or_marker_p, position);
403 return position; 214 return position;
@@ -423,9 +234,9 @@ region_limit (bool beginningp)
423 error ("The mark is not set now, so there is no region"); 234 error ("The mark is not set now, so there is no region");
424 235
425 /* Clip to the current narrowing (bug#11770). */ 236 /* Clip to the current narrowing (bug#11770). */
426 return make_number ((PT < XFASTINT (m)) == beginningp 237 return make_fixnum ((PT < XFIXNAT (m)) == beginningp
427 ? PT 238 ? PT
428 : clip_to_bounds (BEGV, XFASTINT (m), ZV)); 239 : clip_to_bounds (BEGV, XFIXNAT (m), ZV));
429} 240}
430 241
431DEFUN ("region-beginning", Fregion_beginning, Sregion_beginning, 0, 0, 0, 242DEFUN ("region-beginning", Fregion_beginning, Sregion_beginning, 0, 0, 0,
@@ -472,7 +283,7 @@ i.e. the property that a char would inherit if it were inserted
472at POSITION. */) 283at POSITION. */)
473 (Lisp_Object position, register Lisp_Object prop, Lisp_Object object) 284 (Lisp_Object position, register Lisp_Object prop, Lisp_Object object)
474{ 285{
475 CHECK_NUMBER_COERCE_MARKER (position); 286 CHECK_FIXNUM_COERCE_MARKER (position);
476 287
477 if (NILP (object)) 288 if (NILP (object))
478 XSETBUFFER (object, current_buffer); 289 XSETBUFFER (object, current_buffer);
@@ -486,7 +297,7 @@ at POSITION. */)
486 return Fget_text_property (position, prop, object); 297 return Fget_text_property (position, prop, object);
487 else 298 else
488 { 299 {
489 EMACS_INT posn = XINT (position); 300 EMACS_INT posn = XFIXNUM (position);
490 ptrdiff_t noverlays; 301 ptrdiff_t noverlays;
491 Lisp_Object *overlay_vec, tem; 302 Lisp_Object *overlay_vec, tem;
492 struct buffer *obuf = current_buffer; 303 struct buffer *obuf = current_buffer;
@@ -538,8 +349,8 @@ at POSITION. */)
538 if (stickiness > 0) 349 if (stickiness > 0)
539 return Fget_text_property (position, prop, object); 350 return Fget_text_property (position, prop, object);
540 else if (stickiness < 0 351 else if (stickiness < 0
541 && XINT (position) > BUF_BEGV (XBUFFER (object))) 352 && XFIXNUM (position) > BUF_BEGV (XBUFFER (object)))
542 return Fget_text_property (make_number (XINT (position) - 1), 353 return Fget_text_property (make_fixnum (XFIXNUM (position) - 1),
543 prop, object); 354 prop, object);
544 else 355 else
545 return Qnil; 356 return Qnil;
@@ -582,13 +393,13 @@ find_field (Lisp_Object pos, Lisp_Object merge_at_boundary,
582 if (NILP (pos)) 393 if (NILP (pos))
583 XSETFASTINT (pos, PT); 394 XSETFASTINT (pos, PT);
584 else 395 else
585 CHECK_NUMBER_COERCE_MARKER (pos); 396 CHECK_FIXNUM_COERCE_MARKER (pos);
586 397
587 after_field 398 after_field
588 = get_char_property_and_overlay (pos, Qfield, Qnil, NULL); 399 = get_char_property_and_overlay (pos, Qfield, Qnil, NULL);
589 before_field 400 before_field
590 = (XFASTINT (pos) > BEGV 401 = (XFIXNAT (pos) > BEGV
591 ? get_char_property_and_overlay (make_number (XINT (pos) - 1), 402 ? get_char_property_and_overlay (make_fixnum (XFIXNUM (pos) - 1),
592 Qfield, Qnil, NULL) 403 Qfield, Qnil, NULL)
593 /* Using nil here would be a more obvious choice, but it would 404 /* Using nil here would be a more obvious choice, but it would
594 fail when the buffer starts with a non-sticky field. */ 405 fail when the buffer starts with a non-sticky field. */
@@ -642,7 +453,7 @@ find_field (Lisp_Object pos, Lisp_Object merge_at_boundary,
642 if (at_field_start) 453 if (at_field_start)
643 /* POS is at the edge of a field, and we should consider it as 454 /* POS is at the edge of a field, and we should consider it as
644 the beginning of the following field. */ 455 the beginning of the following field. */
645 *beg = XFASTINT (pos); 456 *beg = XFIXNAT (pos);
646 else 457 else
647 /* Find the previous field boundary. */ 458 /* Find the previous field boundary. */
648 { 459 {
@@ -654,7 +465,7 @@ find_field (Lisp_Object pos, Lisp_Object merge_at_boundary,
654 465
655 p = Fprevious_single_char_property_change (p, Qfield, Qnil, 466 p = Fprevious_single_char_property_change (p, Qfield, Qnil,
656 beg_limit); 467 beg_limit);
657 *beg = NILP (p) ? BEGV : XFASTINT (p); 468 *beg = NILP (p) ? BEGV : XFIXNAT (p);
658 } 469 }
659 } 470 }
660 471
@@ -663,7 +474,7 @@ find_field (Lisp_Object pos, Lisp_Object merge_at_boundary,
663 if (at_field_end) 474 if (at_field_end)
664 /* POS is at the edge of a field, and we should consider it as 475 /* POS is at the edge of a field, and we should consider it as
665 the end of the previous field. */ 476 the end of the previous field. */
666 *end = XFASTINT (pos); 477 *end = XFIXNAT (pos);
667 else 478 else
668 /* Find the next field boundary. */ 479 /* Find the next field boundary. */
669 { 480 {
@@ -674,7 +485,7 @@ find_field (Lisp_Object pos, Lisp_Object merge_at_boundary,
674 485
675 pos = Fnext_single_char_property_change (pos, Qfield, Qnil, 486 pos = Fnext_single_char_property_change (pos, Qfield, Qnil,
676 end_limit); 487 end_limit);
677 *end = NILP (pos) ? ZV : XFASTINT (pos); 488 *end = NILP (pos) ? ZV : XFIXNAT (pos);
678 } 489 }
679 } 490 }
680} 491}
@@ -727,7 +538,7 @@ is before LIMIT, then LIMIT will be returned instead. */)
727{ 538{
728 ptrdiff_t beg; 539 ptrdiff_t beg;
729 find_field (pos, escape_from_edge, limit, &beg, Qnil, 0); 540 find_field (pos, escape_from_edge, limit, &beg, Qnil, 0);
730 return make_number (beg); 541 return make_fixnum (beg);
731} 542}
732 543
733DEFUN ("field-end", Ffield_end, Sfield_end, 0, 3, 0, 544DEFUN ("field-end", Ffield_end, Sfield_end, 0, 3, 0,
@@ -742,7 +553,7 @@ is after LIMIT, then LIMIT will be returned instead. */)
742{ 553{
743 ptrdiff_t end; 554 ptrdiff_t end;
744 find_field (pos, escape_from_edge, Qnil, 0, limit, &end); 555 find_field (pos, escape_from_edge, Qnil, 0, limit, &end);
745 return make_number (end); 556 return make_fixnum (end);
746} 557}
747 558
748DEFUN ("constrain-to-field", Fconstrain_to_field, Sconstrain_to_field, 2, 5, 0, 559DEFUN ("constrain-to-field", Fconstrain_to_field, Sconstrain_to_field, 2, 5, 0,
@@ -788,32 +599,32 @@ Field boundaries are not noticed if `inhibit-field-text-motion' is non-nil. */)
788 XSETFASTINT (new_pos, PT); 599 XSETFASTINT (new_pos, PT);
789 } 600 }
790 601
791 CHECK_NUMBER_COERCE_MARKER (new_pos); 602 CHECK_FIXNUM_COERCE_MARKER (new_pos);
792 CHECK_NUMBER_COERCE_MARKER (old_pos); 603 CHECK_FIXNUM_COERCE_MARKER (old_pos);
793 604
794 fwd = (XINT (new_pos) > XINT (old_pos)); 605 fwd = (XFIXNUM (new_pos) > XFIXNUM (old_pos));
795 606
796 prev_old = make_number (XINT (old_pos) - 1); 607 prev_old = make_fixnum (XFIXNUM (old_pos) - 1);
797 prev_new = make_number (XINT (new_pos) - 1); 608 prev_new = make_fixnum (XFIXNUM (new_pos) - 1);
798 609
799 if (NILP (Vinhibit_field_text_motion) 610 if (NILP (Vinhibit_field_text_motion)
800 && !EQ (new_pos, old_pos) 611 && !BASE_EQ (new_pos, old_pos)
801 && (!NILP (Fget_char_property (new_pos, Qfield, Qnil)) 612 && (!NILP (Fget_char_property (new_pos, Qfield, Qnil))
802 || !NILP (Fget_char_property (old_pos, Qfield, Qnil)) 613 || !NILP (Fget_char_property (old_pos, Qfield, Qnil))
803 /* To recognize field boundaries, we must also look at the 614 /* To recognize field boundaries, we must also look at the
804 previous positions; we could use `Fget_pos_property' 615 previous positions; we could use `Fget_pos_property'
805 instead, but in itself that would fail inside non-sticky 616 instead, but in itself that would fail inside non-sticky
806 fields (like comint prompts). */ 617 fields (like comint prompts). */
807 || (XFASTINT (new_pos) > BEGV 618 || (XFIXNAT (new_pos) > BEGV
808 && !NILP (Fget_char_property (prev_new, Qfield, Qnil))) 619 && !NILP (Fget_char_property (prev_new, Qfield, Qnil)))
809 || (XFASTINT (old_pos) > BEGV 620 || (XFIXNAT (old_pos) > BEGV
810 && !NILP (Fget_char_property (prev_old, Qfield, Qnil)))) 621 && !NILP (Fget_char_property (prev_old, Qfield, Qnil))))
811 && (NILP (inhibit_capture_property) 622 && (NILP (inhibit_capture_property)
812 /* Field boundaries are again a problem; but now we must 623 /* Field boundaries are again a problem; but now we must
813 decide the case exactly, so we need to call 624 decide the case exactly, so we need to call
814 `get_pos_property' as well. */ 625 `get_pos_property' as well. */
815 || (NILP (Fget_pos_property (old_pos, inhibit_capture_property, Qnil)) 626 || (NILP (Fget_pos_property (old_pos, inhibit_capture_property, Qnil))
816 && (XFASTINT (old_pos) <= BEGV 627 && (XFIXNAT (old_pos) <= BEGV
817 || NILP (Fget_char_property 628 || NILP (Fget_char_property
818 (old_pos, inhibit_capture_property, Qnil)) 629 (old_pos, inhibit_capture_property, Qnil))
819 || NILP (Fget_char_property 630 || NILP (Fget_char_property
@@ -821,7 +632,7 @@ Field boundaries are not noticed if `inhibit-field-text-motion' is non-nil. */)
821 /* It is possible that NEW_POS is not within the same field as 632 /* It is possible that NEW_POS is not within the same field as
822 OLD_POS; try to move NEW_POS so that it is. */ 633 OLD_POS; try to move NEW_POS so that it is. */
823 { 634 {
824 ptrdiff_t shortage; 635 ptrdiff_t counted;
825 Lisp_Object field_bound; 636 Lisp_Object field_bound;
826 637
827 if (fwd) 638 if (fwd)
@@ -833,7 +644,7 @@ Field boundaries are not noticed if `inhibit-field-text-motion' is non-nil. */)
833 other side of NEW_POS, which would mean that NEW_POS is 644 other side of NEW_POS, which would mean that NEW_POS is
834 already acceptable, and it's not necessary to constrain it 645 already acceptable, and it's not necessary to constrain it
835 to FIELD_BOUND. */ 646 to FIELD_BOUND. */
836 ((XFASTINT (field_bound) < XFASTINT (new_pos)) ? fwd : !fwd) 647 ((XFIXNAT (field_bound) < XFIXNAT (new_pos)) ? fwd : !fwd)
837 /* NEW_POS should be constrained, but only if either 648 /* NEW_POS should be constrained, but only if either
838 ONLY_IN_LINE is nil (in which case any constraint is OK), 649 ONLY_IN_LINE is nil (in which case any constraint is OK),
839 or NEW_POS and FIELD_BOUND are on the same line (in which 650 or NEW_POS and FIELD_BOUND are on the same line (in which
@@ -842,34 +653,65 @@ Field boundaries are not noticed if `inhibit-field-text-motion' is non-nil. */)
842 /* This is the ONLY_IN_LINE case, check that NEW_POS and 653 /* This is the ONLY_IN_LINE case, check that NEW_POS and
843 FIELD_BOUND are on the same line by seeing whether 654 FIELD_BOUND are on the same line by seeing whether
844 there's an intervening newline or not. */ 655 there's an intervening newline or not. */
845 || (find_newline (XFASTINT (new_pos), -1, 656 || (find_newline (XFIXNAT (new_pos), -1,
846 XFASTINT (field_bound), -1, 657 XFIXNAT (field_bound), -1,
847 fwd ? -1 : 1, &shortage, NULL, 1), 658 fwd ? -1 : 1, &counted, NULL, 1),
848 shortage != 0))) 659 counted == 0)))
849 /* Constrain NEW_POS to FIELD_BOUND. */ 660 /* Constrain NEW_POS to FIELD_BOUND. */
850 new_pos = field_bound; 661 new_pos = field_bound;
851 662
852 if (orig_point && XFASTINT (new_pos) != orig_point) 663 if (orig_point && XFIXNAT (new_pos) != orig_point)
853 /* The NEW_POS argument was originally nil, so automatically set PT. */ 664 /* The NEW_POS argument was originally nil, so automatically set PT. */
854 SET_PT (XFASTINT (new_pos)); 665 SET_PT (XFIXNAT (new_pos));
855 } 666 }
856 667
857 return new_pos; 668 return new_pos;
858} 669}
859 670
860 671
861DEFUN ("line-beginning-position", 672static ptrdiff_t
862 Fline_beginning_position, Sline_beginning_position, 0, 1, 0, 673bol (Lisp_Object n, ptrdiff_t *out_count)
863 doc: /* Return the character position of the first character on the current line. 674{
675 ptrdiff_t bytepos, charpos, count;
676
677 if (NILP (n))
678 count = 0;
679 else if (FIXNUMP (n))
680 count = clip_to_bounds (-BUF_BYTES_MAX, XFIXNUM (n) - 1, BUF_BYTES_MAX);
681 else
682 {
683 CHECK_INTEGER (n);
684 count = NILP (Fnatnump (n)) ? -BUF_BYTES_MAX : BUF_BYTES_MAX;
685 }
686 if (out_count)
687 *out_count = count;
688 scan_newline_from_point (count, &charpos, &bytepos);
689 return charpos;
690}
691
692DEFUN ("pos-bol", Fpos_bol, Spos_bol, 0, 1, 0,
693 doc: /* Return the position of the first character on the current line.
864With optional argument N, scan forward N - 1 lines first. 694With optional argument N, scan forward N - 1 lines first.
865If the scan reaches the end of the buffer, return that position. 695If the scan reaches the end of the buffer, return that position.
866 696
867This function ignores text display directionality; it returns the 697This function ignores text display directionality; it returns the
868position of the first character in logical order, i.e. the smallest 698position of the first character in logical order, i.e. the smallest
869character position on the line. 699character position on the logical line. See `vertical-motion' for
700movement by screen lines.
701
702This function does not move point. Also see `line-beginning-position'. */)
703 (Lisp_Object n)
704{
705 return make_fixnum (bol (n, NULL));
706}
707
708DEFUN ("line-beginning-position",
709 Fline_beginning_position, Sline_beginning_position, 0, 1, 0,
710 doc: /* Return the position of the first character in the current line/field.
711This function is like `pos-bol' (which see), but respects fields.
870 712
871This function constrains the returned position to the current field 713This function constrains the returned position to the current field
872unless that position would be on a different line than the original, 714unless that position would be on a different line from the original,
873unconstrained result. If N is nil or 1, and a front-sticky field 715unconstrained result. If N is nil or 1, and a front-sticky field
874starts at point, the scan stops as soon as it starts. To ignore field 716starts at point, the scan stops as soon as it starts. To ignore field
875boundaries, bind `inhibit-field-text-motion' to t. 717boundaries, bind `inhibit-field-text-motion' to t.
@@ -877,23 +719,33 @@ boundaries, bind `inhibit-field-text-motion' to t.
877This function does not move point. */) 719This function does not move point. */)
878 (Lisp_Object n) 720 (Lisp_Object n)
879{ 721{
880 ptrdiff_t charpos, bytepos; 722 ptrdiff_t count, charpos = bol (n, &count);
723 /* Return END constrained to the current input field. */
724 return Fconstrain_to_field (make_fixnum (charpos), make_fixnum (PT),
725 count != 0 ? Qt : Qnil,
726 Qt, Qnil);
727}
728
729static ptrdiff_t
730eol (Lisp_Object n)
731{
732 ptrdiff_t count;
881 733
882 if (NILP (n)) 734 if (NILP (n))
883 XSETFASTINT (n, 1); 735 count = 1;
736 else if (FIXNUMP (n))
737 count = clip_to_bounds (-BUF_BYTES_MAX, XFIXNUM (n), BUF_BYTES_MAX);
884 else 738 else
885 CHECK_NUMBER (n); 739 {
886 740 CHECK_INTEGER (n);
887 scan_newline_from_point (XINT (n) - 1, &charpos, &bytepos); 741 count = NILP (Fnatnump (n)) ? -BUF_BYTES_MAX : BUF_BYTES_MAX;
888 742 }
889 /* Return END constrained to the current input field. */ 743 return find_before_next_newline (PT, 0, count - (count <= 0),
890 return Fconstrain_to_field (make_number (charpos), make_number (PT), 744 NULL);
891 XINT (n) != 1 ? Qt : Qnil,
892 Qt, Qnil);
893} 745}
894 746
895DEFUN ("line-end-position", Fline_end_position, Sline_end_position, 0, 1, 0, 747DEFUN ("pos-eol", Fpos_eol, Spos_eol, 0, 1, 0,
896 doc: /* Return the character position of the last character on the current line. 748 doc: /* Return the position of the last character on the current line.
897With argument N not nil or 1, move forward N - 1 lines first. 749With argument N not nil or 1, move forward N - 1 lines first.
898If scan reaches end of buffer, return that position. 750If scan reaches end of buffer, return that position.
899 751
@@ -901,8 +753,21 @@ This function ignores text display directionality; it returns the
901position of the last character in logical order, i.e. the largest 753position of the last character in logical order, i.e. the largest
902character position on the line. 754character position on the line.
903 755
756This function does not move point. Also see `line-end-position'. */)
757 (Lisp_Object n)
758{
759 return make_fixnum (eol (n));
760}
761
762DEFUN ("line-end-position", Fline_end_position, Sline_end_position, 0, 1, 0,
763 doc: /* Return the position of the last character in the current line/field.
764With argument N not nil or 1, move forward N - 1 lines first.
765If scan reaches end of buffer, return that position.
766
767This function is like `pos-eol' (which see), but respects fields.
768
904This function constrains the returned position to the current field 769This function constrains the returned position to the current field
905unless that would be on a different line than the original, 770unless that would be on a different line from the original,
906unconstrained result. If N is nil or 1, and a rear-sticky field ends 771unconstrained result. If N is nil or 1, and a rear-sticky field ends
907at point, the scan stops as soon as it starts. To ignore field 772at point, the scan stops as soon as it starts. To ignore field
908boundaries bind `inhibit-field-text-motion' to t. 773boundaries bind `inhibit-field-text-motion' to t.
@@ -910,76 +775,51 @@ boundaries bind `inhibit-field-text-motion' to t.
910This function does not move point. */) 775This function does not move point. */)
911 (Lisp_Object n) 776 (Lisp_Object n)
912{ 777{
913 ptrdiff_t clipped_n;
914 ptrdiff_t end_pos;
915 ptrdiff_t orig = PT;
916
917 if (NILP (n))
918 XSETFASTINT (n, 1);
919 else
920 CHECK_NUMBER (n);
921
922 clipped_n = clip_to_bounds (PTRDIFF_MIN + 1, XINT (n), PTRDIFF_MAX);
923 end_pos = find_before_next_newline (orig, 0, clipped_n - (clipped_n <= 0),
924 NULL);
925
926 /* Return END_POS constrained to the current input field. */ 778 /* Return END_POS constrained to the current input field. */
927 return Fconstrain_to_field (make_number (end_pos), make_number (orig), 779 return Fconstrain_to_field (make_fixnum (eol (n)), make_fixnum (PT),
928 Qnil, Qt, Qnil); 780 Qnil, Qt, Qnil);
929} 781}
930 782
931/* Save current buffer state for `save-excursion' special form. 783/* Save current buffer state for save-excursion special form. */
932 We (ab)use Lisp_Misc_Save_Value to allow explicit free and so
933 offload some work from GC. */
934 784
935Lisp_Object 785void
936save_excursion_save (void) 786save_excursion_save (union specbinding *pdl)
937{ 787{
938 return make_save_obj_obj_obj_obj 788 eassert (pdl->unwind_excursion.kind == SPECPDL_UNWIND_EXCURSION);
939 (Fpoint_marker (), 789 pdl->unwind_excursion.marker = Fpoint_marker ();
940 Qnil, 790 /* Selected window if current buffer is shown in it, nil otherwise. */
941 /* Selected window if current buffer is shown in it, nil otherwise. */ 791 pdl->unwind_excursion.window
942 (EQ (XWINDOW (selected_window)->contents, Fcurrent_buffer ()) 792 = (BASE_EQ (XWINDOW (selected_window)->contents, Fcurrent_buffer ())
943 ? selected_window : Qnil), 793 ? selected_window : Qnil);
944 Qnil);
945} 794}
946 795
947/* Restore saved buffer before leaving `save-excursion' special form. */ 796/* Restore saved buffer before leaving `save-excursion' special form. */
948 797
949void 798void
950save_excursion_restore (Lisp_Object info) 799save_excursion_restore (Lisp_Object marker, Lisp_Object window)
951{ 800{
952 Lisp_Object tem, tem1; 801 Lisp_Object buffer = Fmarker_buffer (marker);
953
954 tem = Fmarker_buffer (XSAVE_OBJECT (info, 0));
955 /* If we're unwinding to top level, saved buffer may be deleted. This 802 /* If we're unwinding to top level, saved buffer may be deleted. This
956 means that all of its markers are unchained and so tem is nil. */ 803 means that all of its markers are unchained and so BUFFER is nil. */
957 if (NILP (tem)) 804 if (NILP (buffer))
958 goto out; 805 return;
959 806
960 Fset_buffer (tem); 807 Fset_buffer (buffer);
961 808
962 /* Point marker. */ 809 /* Point marker. */
963 tem = XSAVE_OBJECT (info, 0); 810 Fgoto_char (marker);
964 Fgoto_char (tem); 811 unchain_marker (XMARKER (marker));
965 unchain_marker (XMARKER (tem));
966 812
967 /* If buffer was visible in a window, and a different window was 813 /* If buffer was visible in a window, and a different window was
968 selected, and the old selected window is still showing this 814 selected, and the old selected window is still showing this
969 buffer, restore point in that window. */ 815 buffer, restore point in that window. */
970 tem = XSAVE_OBJECT (info, 2); 816 if (WINDOWP (window) && !BASE_EQ (window, selected_window))
971 if (WINDOWP (tem) 817 {
972 && !EQ (tem, selected_window) 818 /* Set window point if WINDOW is live and shows the current buffer. */
973 && (tem1 = XWINDOW (tem)->contents, 819 Lisp_Object contents = XWINDOW (window)->contents;
974 (/* Window is live... */ 820 if (BUFFERP (contents) && XBUFFER (contents) == current_buffer)
975 BUFFERP (tem1) 821 Fset_window_point (window, make_fixnum (PT));
976 /* ...and it shows the current buffer. */ 822 }
977 && XBUFFER (tem1) == current_buffer)))
978 Fset_window_point (tem, make_number (PT));
979
980 out:
981
982 free_misc (info);
983} 823}
984 824
985DEFUN ("save-excursion", Fsave_excursion, Ssave_excursion, 0, UNEVALLED, 0, 825DEFUN ("save-excursion", Fsave_excursion, Ssave_excursion, 0, UNEVALLED, 0,
@@ -992,16 +832,16 @@ If you only want to save the current buffer but not point,
992then just use `save-current-buffer', or even `with-current-buffer'. 832then just use `save-current-buffer', or even `with-current-buffer'.
993 833
994Before Emacs 25.1, `save-excursion' used to save the mark state. 834Before Emacs 25.1, `save-excursion' used to save the mark state.
995To save the marker state as well as the point and buffer, use 835To save the mark state as well as point and the current buffer, use
996`save-mark-and-excursion'. 836`save-mark-and-excursion'.
997 837
998usage: (save-excursion &rest BODY) */) 838usage: (save-excursion &rest BODY) */)
999 (Lisp_Object args) 839 (Lisp_Object args)
1000{ 840{
1001 register Lisp_Object val; 841 register Lisp_Object val;
1002 ptrdiff_t count = SPECPDL_INDEX (); 842 specpdl_ref count = SPECPDL_INDEX ();
1003 843
1004 record_unwind_protect (save_excursion_restore, save_excursion_save ()); 844 record_unwind_protect_excursion ();
1005 845
1006 val = Fprogn (args); 846 val = Fprogn (args);
1007 return unbind_to (count, val); 847 return unbind_to (count, val);
@@ -1013,7 +853,7 @@ BODY is executed just like `progn'.
1013usage: (save-current-buffer &rest BODY) */) 853usage: (save-current-buffer &rest BODY) */)
1014 (Lisp_Object args) 854 (Lisp_Object args)
1015{ 855{
1016 ptrdiff_t count = SPECPDL_INDEX (); 856 specpdl_ref count = SPECPDL_INDEX ();
1017 857
1018 record_unwind_current_buffer (); 858 record_unwind_current_buffer ();
1019 return unbind_to (count, Fprogn (args)); 859 return unbind_to (count, Fprogn (args));
@@ -1027,16 +867,16 @@ instead.
1027This does not take narrowing into account; to count the number of 867This does not take narrowing into account; to count the number of
1028characters in the accessible portion of the current buffer, use 868characters in the accessible portion of the current buffer, use
1029`(- (point-max) (point-min))', and to count the number of characters 869`(- (point-max) (point-min))', and to count the number of characters
1030in some other BUFFER, use 870in the accessible portion of some other BUFFER, use
1031`(with-current-buffer BUFFER (- (point-max) (point-min)))'. */) 871`(with-current-buffer BUFFER (- (point-max) (point-min)))'. */)
1032 (Lisp_Object buffer) 872 (Lisp_Object buffer)
1033{ 873{
1034 if (NILP (buffer)) 874 if (NILP (buffer))
1035 return make_number (Z - BEG); 875 return make_fixnum (Z - BEG);
1036 else 876 else
1037 { 877 {
1038 CHECK_BUFFER (buffer); 878 CHECK_BUFFER (buffer);
1039 return make_number (BUF_Z (XBUFFER (buffer)) 879 return make_fixnum (BUF_Z (XBUFFER (buffer))
1040 - BUF_BEG (XBUFFER (buffer))); 880 - BUF_BEG (XBUFFER (buffer)));
1041 } 881 }
1042} 882}
@@ -1104,10 +944,10 @@ DEFUN ("position-bytes", Fposition_bytes, Sposition_bytes, 1, 1, 0,
1104If POSITION is out of range, the value is nil. */) 944If POSITION is out of range, the value is nil. */)
1105 (Lisp_Object position) 945 (Lisp_Object position)
1106{ 946{
1107 CHECK_NUMBER_COERCE_MARKER (position); 947 EMACS_INT pos = fix_position (position);
1108 if (XINT (position) < BEG || XINT (position) > Z) 948 if (! (BEG <= pos && pos <= Z))
1109 return Qnil; 949 return Qnil;
1110 return make_number (CHAR_TO_BYTE (XINT (position))); 950 return make_fixnum (CHAR_TO_BYTE (pos));
1111} 951}
1112 952
1113DEFUN ("byte-to-position", Fbyte_to_position, Sbyte_to_position, 1, 1, 0, 953DEFUN ("byte-to-position", Fbyte_to_position, Sbyte_to_position, 1, 1, 0,
@@ -1117,8 +957,8 @@ If BYTEPOS is out of range, the value is nil. */)
1117{ 957{
1118 ptrdiff_t pos_byte; 958 ptrdiff_t pos_byte;
1119 959
1120 CHECK_NUMBER (bytepos); 960 CHECK_FIXNUM (bytepos);
1121 pos_byte = XINT (bytepos); 961 pos_byte = XFIXNUM (bytepos);
1122 if (pos_byte < BEG_BYTE || pos_byte > Z_BYTE) 962 if (pos_byte < BEG_BYTE || pos_byte > Z_BYTE)
1123 return Qnil; 963 return Qnil;
1124 if (Z != Z_BYTE) 964 if (Z != Z_BYTE)
@@ -1128,7 +968,7 @@ If BYTEPOS is out of range, the value is nil. */)
1128 character. */ 968 character. */
1129 while (!CHAR_HEAD_P (FETCH_BYTE (pos_byte))) 969 while (!CHAR_HEAD_P (FETCH_BYTE (pos_byte)))
1130 pos_byte--; 970 pos_byte--;
1131 return make_number (BYTE_TO_CHAR (pos_byte)); 971 return make_fixnum (BYTE_TO_CHAR (pos_byte));
1132} 972}
1133 973
1134DEFUN ("following-char", Ffollowing_char, Sfollowing_char, 0, 0, 0, 974DEFUN ("following-char", Ffollowing_char, Sfollowing_char, 0, 0, 0,
@@ -1155,7 +995,7 @@ At the beginning of the buffer or accessible region, return 0. */)
1155 else if (!NILP (BVAR (current_buffer, enable_multibyte_characters))) 995 else if (!NILP (BVAR (current_buffer, enable_multibyte_characters)))
1156 { 996 {
1157 ptrdiff_t pos = PT_BYTE; 997 ptrdiff_t pos = PT_BYTE;
1158 DEC_POS (pos); 998 pos -= prev_char_len (pos);
1159 XSETFASTINT (temp, FETCH_CHAR (pos)); 999 XSETFASTINT (temp, FETCH_CHAR (pos));
1160 } 1000 }
1161 else 1001 else
@@ -1224,14 +1064,14 @@ If POS is out of range, the value is nil. */)
1224 } 1064 }
1225 else 1065 else
1226 { 1066 {
1227 CHECK_NUMBER_COERCE_MARKER (pos); 1067 EMACS_INT p = fix_position (pos);
1228 if (XINT (pos) < BEGV || XINT (pos) >= ZV) 1068 if (! (BEGV <= p && p < ZV))
1229 return Qnil; 1069 return Qnil;
1230 1070
1231 pos_byte = CHAR_TO_BYTE (XINT (pos)); 1071 pos_byte = CHAR_TO_BYTE (p);
1232 } 1072 }
1233 1073
1234 return make_number (FETCH_CHAR (pos_byte)); 1074 return make_fixnum (FETCH_CHAR (pos_byte));
1235} 1075}
1236 1076
1237DEFUN ("char-before", Fchar_before, Schar_before, 0, 1, 0, 1077DEFUN ("char-before", Fchar_before, Schar_before, 0, 1, 0,
@@ -1258,17 +1098,17 @@ If POS is out of range, the value is nil. */)
1258 } 1098 }
1259 else 1099 else
1260 { 1100 {
1261 CHECK_NUMBER_COERCE_MARKER (pos); 1101 EMACS_INT p = fix_position (pos);
1262 1102
1263 if (XINT (pos) <= BEGV || XINT (pos) > ZV) 1103 if (! (BEGV < p && p <= ZV))
1264 return Qnil; 1104 return Qnil;
1265 1105
1266 pos_byte = CHAR_TO_BYTE (XINT (pos)); 1106 pos_byte = CHAR_TO_BYTE (p);
1267 } 1107 }
1268 1108
1269 if (!NILP (BVAR (current_buffer, enable_multibyte_characters))) 1109 if (!NILP (BVAR (current_buffer, enable_multibyte_characters)))
1270 { 1110 {
1271 DEC_POS (pos_byte); 1111 pos_byte -= prev_char_len (pos_byte);
1272 XSETFASTINT (val, FETCH_CHAR (pos_byte)); 1112 XSETFASTINT (val, FETCH_CHAR (pos_byte));
1273 } 1113 }
1274 else 1114 else
@@ -1285,7 +1125,7 @@ This is based on the effective uid, not the real uid.
1285Also, if the environment variables LOGNAME or USER are set, 1125Also, if the environment variables LOGNAME or USER are set,
1286that determines the value of this function. 1126that determines the value of this function.
1287 1127
1288If optional argument UID is an integer or a float, return the login name 1128If optional argument UID is an integer, return the login name
1289of the user with that uid, or nil if there is no such user. */) 1129of the user with that uid, or nil if there is no such user. */)
1290 (Lisp_Object uid) 1130 (Lisp_Object uid)
1291{ 1131{
@@ -1296,7 +1136,7 @@ of the user with that uid, or nil if there is no such user. */)
1296 (That can happen if Emacs is dumpable 1136 (That can happen if Emacs is dumpable
1297 but you decide to run `temacs -l loadup' and not dump. */ 1137 but you decide to run `temacs -l loadup' and not dump. */
1298 if (NILP (Vuser_login_name)) 1138 if (NILP (Vuser_login_name))
1299 init_editfns (false); 1139 init_editfns ();
1300 1140
1301 if (NILP (uid)) 1141 if (NILP (uid))
1302 return Vuser_login_name; 1142 return Vuser_login_name;
@@ -1319,44 +1159,58 @@ This ignores the environment variables LOGNAME and USER, so it differs from
1319 (That can happen if Emacs is dumpable 1159 (That can happen if Emacs is dumpable
1320 but you decide to run `temacs -l loadup' and not dump. */ 1160 but you decide to run `temacs -l loadup' and not dump. */
1321 if (NILP (Vuser_login_name)) 1161 if (NILP (Vuser_login_name))
1322 init_editfns (false); 1162 init_editfns ();
1323 return Vuser_real_login_name; 1163 return Vuser_real_login_name;
1324} 1164}
1325 1165
1326DEFUN ("user-uid", Fuser_uid, Suser_uid, 0, 0, 0, 1166DEFUN ("user-uid", Fuser_uid, Suser_uid, 0, 0, 0,
1327 doc: /* Return the effective uid of Emacs. 1167 doc: /* Return the effective uid of Emacs, as an integer. */)
1328Value is an integer or a float, depending on the value. */)
1329 (void) 1168 (void)
1330{ 1169{
1331 uid_t euid = geteuid (); 1170 uid_t euid = geteuid ();
1332 return make_fixnum_or_float (euid); 1171 return INT_TO_INTEGER (euid);
1333} 1172}
1334 1173
1335DEFUN ("user-real-uid", Fuser_real_uid, Suser_real_uid, 0, 0, 0, 1174DEFUN ("user-real-uid", Fuser_real_uid, Suser_real_uid, 0, 0, 0,
1336 doc: /* Return the real uid of Emacs. 1175 doc: /* Return the real uid of Emacs, as an integer. */)
1337Value is an integer or a float, depending on the value. */)
1338 (void) 1176 (void)
1339{ 1177{
1340 uid_t uid = getuid (); 1178 uid_t uid = getuid ();
1341 return make_fixnum_or_float (uid); 1179 return INT_TO_INTEGER (uid);
1180}
1181
1182DEFUN ("group-name", Fgroup_name, Sgroup_name, 1, 1, 0,
1183 doc: /* Return the name of the group whose numeric group ID is GID.
1184The argument GID should be an integer or a float.
1185Return nil if a group with such GID does not exists or is not known. */)
1186 (Lisp_Object gid)
1187{
1188 struct group *gr;
1189 gid_t id;
1190
1191 if (!NUMBERP (gid) && !CONSP (gid))
1192 error ("Invalid GID specification");
1193 CONS_TO_INTEGER (gid, gid_t, id);
1194 block_input ();
1195 gr = getgrgid (id);
1196 unblock_input ();
1197 return gr ? build_string (gr->gr_name) : Qnil;
1342} 1198}
1343 1199
1344DEFUN ("group-gid", Fgroup_gid, Sgroup_gid, 0, 0, 0, 1200DEFUN ("group-gid", Fgroup_gid, Sgroup_gid, 0, 0, 0,
1345 doc: /* Return the effective gid of Emacs. 1201 doc: /* Return the effective gid of Emacs, as an integer. */)
1346Value is an integer or a float, depending on the value. */)
1347 (void) 1202 (void)
1348{ 1203{
1349 gid_t egid = getegid (); 1204 gid_t egid = getegid ();
1350 return make_fixnum_or_float (egid); 1205 return INT_TO_INTEGER (egid);
1351} 1206}
1352 1207
1353DEFUN ("group-real-gid", Fgroup_real_gid, Sgroup_real_gid, 0, 0, 0, 1208DEFUN ("group-real-gid", Fgroup_real_gid, Sgroup_real_gid, 0, 0, 0,
1354 doc: /* Return the real gid of Emacs. 1209 doc: /* Return the real gid of Emacs, as an integer. */)
1355Value is an integer or a float, depending on the value. */)
1356 (void) 1210 (void)
1357{ 1211{
1358 gid_t gid = getgid (); 1212 gid_t gid = getgid ();
1359 return make_fixnum_or_float (gid); 1213 return INT_TO_INTEGER (gid);
1360} 1214}
1361 1215
1362DEFUN ("user-full-name", Fuser_full_name, Suser_full_name, 0, 1, 0, 1216DEFUN ("user-full-name", Fuser_full_name, Suser_full_name, 0, 1, 0,
@@ -1364,10 +1218,14 @@ DEFUN ("user-full-name", Fuser_full_name, Suser_full_name, 0, 1, 0,
1364If the full name corresponding to Emacs's userid is not known, 1218If the full name corresponding to Emacs's userid is not known,
1365return "unknown". 1219return "unknown".
1366 1220
1367If optional argument UID is an integer or float, return the full name 1221If optional argument UID is an integer, return the full name
1368of the user with that uid, or nil if there is no such user. 1222of the user with that uid, or nil if there is no such user.
1369If UID is a string, return the full name of the user with that login 1223If UID is a string, return the full name of the user with that login
1370name, or nil if there is no such user. */) 1224name, or nil if there is no such user.
1225
1226If the full name includes commas, remove everything starting with
1227the first comma, because the \\='gecos\\=' field of the \\='/etc/passwd\\=' file
1228is in general a comma-separated list. */)
1371 (Lisp_Object uid) 1229 (Lisp_Object uid)
1372{ 1230{
1373 struct passwd *pw; 1231 struct passwd *pw;
@@ -1397,7 +1255,8 @@ name, or nil if there is no such user. */)
1397 return Qnil; 1255 return Qnil;
1398 1256
1399 p = USER_FULL_NAME; 1257 p = USER_FULL_NAME;
1400 /* Chop off everything after the first comma. */ 1258 /* Chop off everything after the first comma, since 'pw_gecos' is a
1259 comma-separated list. */
1401 q = strchr (p, ','); 1260 q = strchr (p, ',');
1402 full = make_string (p, q ? q - p : strlen (p)); 1261 full = make_string (p, q ? q - p : strlen (p));
1403 1262
@@ -1407,15 +1266,18 @@ name, or nil if there is no such user. */)
1407 /* Substitute the login name for the &, upcasing the first character. */ 1266 /* Substitute the login name for the &, upcasing the first character. */
1408 if (q) 1267 if (q)
1409 { 1268 {
1410 Lisp_Object login = Fuser_login_name (make_number (pw->pw_uid)); 1269 Lisp_Object login = Fuser_login_name (INT_TO_INTEGER (pw->pw_uid));
1411 USE_SAFE_ALLOCA; 1270 if (!NILP (login))
1412 char *r = SAFE_ALLOCA (strlen (p) + SBYTES (login) + 1); 1271 {
1413 memcpy (r, p, q - p); 1272 USE_SAFE_ALLOCA;
1414 char *s = lispstpcpy (&r[q - p], login); 1273 char *r = SAFE_ALLOCA (strlen (p) + SBYTES (login) + 1);
1415 r[q - p] = upcase ((unsigned char) r[q - p]); 1274 memcpy (r, p, q - p);
1416 strcpy (s, q + 1); 1275 char *s = lispstpcpy (&r[q - p], login);
1417 full = build_string (r); 1276 r[q - p] = upcase ((unsigned char) r[q - p]);
1418 SAFE_FREE (); 1277 strcpy (s, q + 1);
1278 full = build_string (r);
1279 SAFE_FREE ();
1280 }
1419 } 1281 }
1420#endif /* AMPERSAND_FULL_NAME */ 1282#endif /* AMPERSAND_FULL_NAME */
1421 1283
@@ -1432,1027 +1294,13 @@ DEFUN ("system-name", Fsystem_name, Ssystem_name, 0, 0, 0,
1432} 1294}
1433 1295
1434DEFUN ("emacs-pid", Femacs_pid, Semacs_pid, 0, 0, 0, 1296DEFUN ("emacs-pid", Femacs_pid, Semacs_pid, 0, 0, 0,
1435 doc: /* Return the process ID of Emacs, as a number. */) 1297 doc: /* Return the process ID of Emacs, as an integer. */)
1436 (void) 1298 (void)
1437{ 1299{
1438 pid_t pid = getpid (); 1300 pid_t pid = getpid ();
1439 return make_fixnum_or_float (pid); 1301 return INT_TO_INTEGER (pid);
1440}
1441
1442
1443
1444#ifndef TIME_T_MIN
1445# define TIME_T_MIN TYPE_MINIMUM (time_t)
1446#endif
1447#ifndef TIME_T_MAX
1448# define TIME_T_MAX TYPE_MAXIMUM (time_t)
1449#endif
1450
1451/* Report that a time value is out of range for Emacs. */
1452void
1453time_overflow (void)
1454{
1455 error ("Specified time is not representable");
1456}
1457
1458static _Noreturn void
1459invalid_time (void)
1460{
1461 error ("Invalid time specification");
1462}
1463
1464/* Check a return value compatible with that of decode_time_components. */
1465static void
1466check_time_validity (int validity)
1467{
1468 if (validity <= 0)
1469 {
1470 if (validity < 0)
1471 time_overflow ();
1472 else
1473 invalid_time ();
1474 }
1475}
1476
1477/* Return the upper part of the time T (everything but the bottom 16 bits). */
1478static EMACS_INT
1479hi_time (time_t t)
1480{
1481 time_t hi = t >> LO_TIME_BITS;
1482 if (FIXNUM_OVERFLOW_P (hi))
1483 time_overflow ();
1484 return hi;
1485}
1486
1487/* Return the bottom bits of the time T. */
1488static int
1489lo_time (time_t t)
1490{
1491 return t & ((1 << LO_TIME_BITS) - 1);
1492}
1493
1494DEFUN ("current-time", Fcurrent_time, Scurrent_time, 0, 0, 0,
1495 doc: /* Return the current time, as the number of seconds since 1970-01-01 00:00:00.
1496The time is returned as a list of integers (HIGH LOW USEC PSEC).
1497HIGH has the most significant bits of the seconds, while LOW has the
1498least significant 16 bits. USEC and PSEC are the microsecond and
1499picosecond counts. */)
1500 (void)
1501{
1502 return make_lisp_time (current_timespec ());
1503}
1504
1505static struct lisp_time
1506time_add (struct lisp_time ta, struct lisp_time tb)
1507{
1508 EMACS_INT hi = ta.hi + tb.hi;
1509 int lo = ta.lo + tb.lo;
1510 int us = ta.us + tb.us;
1511 int ps = ta.ps + tb.ps;
1512 us += (1000000 <= ps);
1513 ps -= (1000000 <= ps) * 1000000;
1514 lo += (1000000 <= us);
1515 us -= (1000000 <= us) * 1000000;
1516 hi += (1 << LO_TIME_BITS <= lo);
1517 lo -= (1 << LO_TIME_BITS <= lo) << LO_TIME_BITS;
1518 return (struct lisp_time) { hi, lo, us, ps };
1519}
1520
1521static struct lisp_time
1522time_subtract (struct lisp_time ta, struct lisp_time tb)
1523{
1524 EMACS_INT hi = ta.hi - tb.hi;
1525 int lo = ta.lo - tb.lo;
1526 int us = ta.us - tb.us;
1527 int ps = ta.ps - tb.ps;
1528 us -= (ps < 0);
1529 ps += (ps < 0) * 1000000;
1530 lo -= (us < 0);
1531 us += (us < 0) * 1000000;
1532 hi -= (lo < 0);
1533 lo += (lo < 0) << LO_TIME_BITS;
1534 return (struct lisp_time) { hi, lo, us, ps };
1535}
1536
1537static Lisp_Object
1538time_arith (Lisp_Object a, Lisp_Object b,
1539 struct lisp_time (*op) (struct lisp_time, struct lisp_time))
1540{
1541 int alen, blen;
1542 struct lisp_time ta = lisp_time_struct (a, &alen);
1543 struct lisp_time tb = lisp_time_struct (b, &blen);
1544 struct lisp_time t = op (ta, tb);
1545 if (FIXNUM_OVERFLOW_P (t.hi))
1546 time_overflow ();
1547 Lisp_Object val = Qnil;
1548
1549 switch (max (alen, blen))
1550 {
1551 default:
1552 val = Fcons (make_number (t.ps), val);
1553 FALLTHROUGH;
1554 case 3:
1555 val = Fcons (make_number (t.us), val);
1556 FALLTHROUGH;
1557 case 2:
1558 val = Fcons (make_number (t.lo), val);
1559 val = Fcons (make_number (t.hi), val);
1560 break;
1561 }
1562
1563 return val;
1564}
1565
1566DEFUN ("time-add", Ftime_add, Stime_add, 2, 2, 0,
1567 doc: /* Return the sum of two time values A and B, as a time value.
1568A nil value for either argument stands for the current time.
1569See `current-time-string' for the various forms of a time value. */)
1570 (Lisp_Object a, Lisp_Object b)
1571{
1572 return time_arith (a, b, time_add);
1573}
1574
1575DEFUN ("time-subtract", Ftime_subtract, Stime_subtract, 2, 2, 0,
1576 doc: /* Return the difference between two time values A and B, as a time value.
1577Use `float-time' to convert the difference into elapsed seconds.
1578A nil value for either argument stands for the current time.
1579See `current-time-string' for the various forms of a time value. */)
1580 (Lisp_Object a, Lisp_Object b)
1581{
1582 return time_arith (a, b, time_subtract);
1583} 1302}
1584 1303
1585DEFUN ("time-less-p", Ftime_less_p, Stime_less_p, 2, 2, 0,
1586 doc: /* Return non-nil if time value T1 is earlier than time value T2.
1587A nil value for either argument stands for the current time.
1588See `current-time-string' for the various forms of a time value. */)
1589 (Lisp_Object t1, Lisp_Object t2)
1590{
1591 int t1len, t2len;
1592 struct lisp_time a = lisp_time_struct (t1, &t1len);
1593 struct lisp_time b = lisp_time_struct (t2, &t2len);
1594 return ((a.hi != b.hi ? a.hi < b.hi
1595 : a.lo != b.lo ? a.lo < b.lo
1596 : a.us != b.us ? a.us < b.us
1597 : a.ps < b.ps)
1598 ? Qt : Qnil);
1599}
1600
1601
1602DEFUN ("get-internal-run-time", Fget_internal_run_time, Sget_internal_run_time,
1603 0, 0, 0,
1604 doc: /* Return the current run time used by Emacs.
1605The time is returned as a list (HIGH LOW USEC PSEC), using the same
1606style as (current-time).
1607
1608On systems that can't determine the run time, `get-internal-run-time'
1609does the same thing as `current-time'. */)
1610 (void)
1611{
1612#ifdef HAVE_GETRUSAGE
1613 struct rusage usage;
1614 time_t secs;
1615 int usecs;
1616
1617 if (getrusage (RUSAGE_SELF, &usage) < 0)
1618 /* This shouldn't happen. What action is appropriate? */
1619 xsignal0 (Qerror);
1620
1621 /* Sum up user time and system time. */
1622 secs = usage.ru_utime.tv_sec + usage.ru_stime.tv_sec;
1623 usecs = usage.ru_utime.tv_usec + usage.ru_stime.tv_usec;
1624 if (usecs >= 1000000)
1625 {
1626 usecs -= 1000000;
1627 secs++;
1628 }
1629 return make_lisp_time (make_timespec (secs, usecs * 1000));
1630#else /* ! HAVE_GETRUSAGE */
1631#ifdef WINDOWSNT
1632 return w32_get_internal_run_time ();
1633#else /* ! WINDOWSNT */
1634 return Fcurrent_time ();
1635#endif /* WINDOWSNT */
1636#endif /* HAVE_GETRUSAGE */
1637}
1638
1639
1640/* Make a Lisp list that represents the Emacs time T. T may be an
1641 invalid time, with a slightly negative tv_nsec value such as
1642 UNKNOWN_MODTIME_NSECS; in that case, the Lisp list contains a
1643 correspondingly negative picosecond count. */
1644Lisp_Object
1645make_lisp_time (struct timespec t)
1646{
1647 time_t s = t.tv_sec;
1648 int ns = t.tv_nsec;
1649 return list4i (hi_time (s), lo_time (s), ns / 1000, ns % 1000 * 1000);
1650}
1651
1652/* Decode a Lisp list SPECIFIED_TIME that represents a time.
1653 Set *PHIGH, *PLOW, *PUSEC, *PPSEC to its parts; do not check their values.
1654 Return 2, 3, or 4 to indicate the effective length of SPECIFIED_TIME
1655 if successful, 0 if unsuccessful. */
1656static int
1657disassemble_lisp_time (Lisp_Object specified_time, Lisp_Object *phigh,
1658 Lisp_Object *plow, Lisp_Object *pusec,
1659 Lisp_Object *ppsec)
1660{
1661 Lisp_Object high = make_number (0);
1662 Lisp_Object low = specified_time;
1663 Lisp_Object usec = make_number (0);
1664 Lisp_Object psec = make_number (0);
1665 int len = 4;
1666
1667 if (CONSP (specified_time))
1668 {
1669 high = XCAR (specified_time);
1670 low = XCDR (specified_time);
1671 if (CONSP (low))
1672 {
1673 Lisp_Object low_tail = XCDR (low);
1674 low = XCAR (low);
1675 if (CONSP (low_tail))
1676 {
1677 usec = XCAR (low_tail);
1678 low_tail = XCDR (low_tail);
1679 if (CONSP (low_tail))
1680 psec = XCAR (low_tail);
1681 else
1682 len = 3;
1683 }
1684 else if (!NILP (low_tail))
1685 {
1686 usec = low_tail;
1687 len = 3;
1688 }
1689 else
1690 len = 2;
1691 }
1692 else
1693 len = 2;
1694
1695 /* When combining components, require LOW to be an integer,
1696 as otherwise it would be a pain to add up times. */
1697 if (! INTEGERP (low))
1698 return 0;
1699 }
1700 else if (INTEGERP (specified_time))
1701 len = 2;
1702
1703 *phigh = high;
1704 *plow = low;
1705 *pusec = usec;
1706 *ppsec = psec;
1707 return len;
1708}
1709
1710/* Convert T into an Emacs time *RESULT, truncating toward minus infinity.
1711 Return true if T is in range, false otherwise. */
1712static bool
1713decode_float_time (double t, struct lisp_time *result)
1714{
1715 double lo_multiplier = 1 << LO_TIME_BITS;
1716 double emacs_time_min = MOST_NEGATIVE_FIXNUM * lo_multiplier;
1717 if (! (emacs_time_min <= t && t < -emacs_time_min))
1718 return false;
1719
1720 double small_t = t / lo_multiplier;
1721 EMACS_INT hi = small_t;
1722 double t_sans_hi = t - hi * lo_multiplier;
1723 int lo = t_sans_hi;
1724 long double fracps = (t_sans_hi - lo) * 1e12L;
1725#ifdef INT_FAST64_MAX
1726 int_fast64_t ifracps = fracps;
1727 int us = ifracps / 1000000;
1728 int ps = ifracps % 1000000;
1729#else
1730 int us = fracps / 1e6L;
1731 int ps = fracps - us * 1e6L;
1732#endif
1733 us -= (ps < 0);
1734 ps += (ps < 0) * 1000000;
1735 lo -= (us < 0);
1736 us += (us < 0) * 1000000;
1737 hi -= (lo < 0);
1738 lo += (lo < 0) << LO_TIME_BITS;
1739 result->hi = hi;
1740 result->lo = lo;
1741 result->us = us;
1742 result->ps = ps;
1743 return true;
1744}
1745
1746/* From the time components HIGH, LOW, USEC and PSEC taken from a Lisp
1747 list, generate the corresponding time value.
1748 If LOW is floating point, the other components should be zero.
1749
1750 If RESULT is not null, store into *RESULT the converted time.
1751 If *DRESULT is not null, store into *DRESULT the number of
1752 seconds since the start of the POSIX Epoch.
1753
1754 Return 1 if successful, 0 if the components are of the
1755 wrong type, and -1 if the time is out of range. */
1756int
1757decode_time_components (Lisp_Object high, Lisp_Object low, Lisp_Object usec,
1758 Lisp_Object psec,
1759 struct lisp_time *result, double *dresult)
1760{
1761 EMACS_INT hi, lo, us, ps;
1762 if (! (INTEGERP (high)
1763 && INTEGERP (usec) && INTEGERP (psec)))
1764 return 0;
1765 if (! INTEGERP (low))
1766 {
1767 if (FLOATP (low))
1768 {
1769 double t = XFLOAT_DATA (low);
1770 if (result && ! decode_float_time (t, result))
1771 return -1;
1772 if (dresult)
1773 *dresult = t;
1774 return 1;
1775 }
1776 else if (NILP (low))
1777 {
1778 struct timespec now = current_timespec ();
1779 if (result)
1780 {
1781 result->hi = hi_time (now.tv_sec);
1782 result->lo = lo_time (now.tv_sec);
1783 result->us = now.tv_nsec / 1000;
1784 result->ps = now.tv_nsec % 1000 * 1000;
1785 }
1786 if (dresult)
1787 *dresult = now.tv_sec + now.tv_nsec / 1e9;
1788 return 1;
1789 }
1790 else
1791 return 0;
1792 }
1793
1794 hi = XINT (high);
1795 lo = XINT (low);
1796 us = XINT (usec);
1797 ps = XINT (psec);
1798
1799 /* Normalize out-of-range lower-order components by carrying
1800 each overflow into the next higher-order component. */
1801 us += ps / 1000000 - (ps % 1000000 < 0);
1802 lo += us / 1000000 - (us % 1000000 < 0);
1803 hi += lo >> LO_TIME_BITS;
1804 ps = ps % 1000000 + 1000000 * (ps % 1000000 < 0);
1805 us = us % 1000000 + 1000000 * (us % 1000000 < 0);
1806 lo &= (1 << LO_TIME_BITS) - 1;
1807
1808 if (result)
1809 {
1810 if (FIXNUM_OVERFLOW_P (hi))
1811 return -1;
1812 result->hi = hi;
1813 result->lo = lo;
1814 result->us = us;
1815 result->ps = ps;
1816 }
1817
1818 if (dresult)
1819 {
1820 double dhi = hi;
1821 *dresult = (us * 1e6 + ps) / 1e12 + lo + dhi * (1 << LO_TIME_BITS);
1822 }
1823
1824 return 1;
1825}
1826
1827struct timespec
1828lisp_to_timespec (struct lisp_time t)
1829{
1830 if (! ((TYPE_SIGNED (time_t) ? TIME_T_MIN >> LO_TIME_BITS <= t.hi : 0 <= t.hi)
1831 && t.hi <= TIME_T_MAX >> LO_TIME_BITS))
1832 return invalid_timespec ();
1833 time_t s = (t.hi << LO_TIME_BITS) + t.lo;
1834 int ns = t.us * 1000 + t.ps / 1000;
1835 return make_timespec (s, ns);
1836}
1837
1838/* Decode a Lisp list SPECIFIED_TIME that represents a time.
1839 Store its effective length into *PLEN.
1840 If SPECIFIED_TIME is nil, use the current time.
1841 Signal an error if SPECIFIED_TIME does not represent a time. */
1842static struct lisp_time
1843lisp_time_struct (Lisp_Object specified_time, int *plen)
1844{
1845 Lisp_Object high, low, usec, psec;
1846 struct lisp_time t;
1847 int len = disassemble_lisp_time (specified_time, &high, &low, &usec, &psec);
1848 if (!len)
1849 invalid_time ();
1850 int val = decode_time_components (high, low, usec, psec, &t, 0);
1851 check_time_validity (val);
1852 *plen = len;
1853 return t;
1854}
1855
1856/* Like lisp_time_struct, except return a struct timespec.
1857 Discard any low-order digits. */
1858struct timespec
1859lisp_time_argument (Lisp_Object specified_time)
1860{
1861 int len;
1862 struct lisp_time lt = lisp_time_struct (specified_time, &len);
1863 struct timespec t = lisp_to_timespec (lt);
1864 if (! timespec_valid_p (t))
1865 time_overflow ();
1866 return t;
1867}
1868
1869/* Like lisp_time_argument, except decode only the seconds part,
1870 and do not check the subseconds part. */
1871static time_t
1872lisp_seconds_argument (Lisp_Object specified_time)
1873{
1874 Lisp_Object high, low, usec, psec;
1875 struct lisp_time t;
1876
1877 int val = disassemble_lisp_time (specified_time, &high, &low, &usec, &psec);
1878 if (val != 0)
1879 {
1880 val = decode_time_components (high, low, make_number (0),
1881 make_number (0), &t, 0);
1882 if (0 < val
1883 && ! ((TYPE_SIGNED (time_t)
1884 ? TIME_T_MIN >> LO_TIME_BITS <= t.hi
1885 : 0 <= t.hi)
1886 && t.hi <= TIME_T_MAX >> LO_TIME_BITS))
1887 val = -1;
1888 }
1889 check_time_validity (val);
1890 return (t.hi << LO_TIME_BITS) + t.lo;
1891}
1892
1893DEFUN ("float-time", Ffloat_time, Sfloat_time, 0, 1, 0,
1894 doc: /* Return the current time, as a float number of seconds since the epoch.
1895If SPECIFIED-TIME is given, it is the time to convert to float
1896instead of the current time. The argument should have the form
1897\(HIGH LOW) or (HIGH LOW USEC) or (HIGH LOW USEC PSEC). Thus,
1898you can use times from `current-time' and from `file-attributes'.
1899SPECIFIED-TIME can also have the form (HIGH . LOW), but this is
1900considered obsolete.
1901
1902WARNING: Since the result is floating point, it may not be exact.
1903If precise time stamps are required, use either `current-time',
1904or (if you need time as a string) `format-time-string'. */)
1905 (Lisp_Object specified_time)
1906{
1907 double t;
1908 Lisp_Object high, low, usec, psec;
1909 if (! (disassemble_lisp_time (specified_time, &high, &low, &usec, &psec)
1910 && decode_time_components (high, low, usec, psec, 0, &t)))
1911 invalid_time ();
1912 return make_float (t);
1913}
1914
1915/* Write information into buffer S of size MAXSIZE, according to the
1916 FORMAT of length FORMAT_LEN, using time information taken from *TP.
1917 Use the time zone specified by TZ.
1918 Use NS as the number of nanoseconds in the %N directive.
1919 Return the number of bytes written, not including the terminating
1920 '\0'. If S is NULL, nothing will be written anywhere; so to
1921 determine how many bytes would be written, use NULL for S and
1922 ((size_t) -1) for MAXSIZE.
1923
1924 This function behaves like nstrftime, except it allows null
1925 bytes in FORMAT and it does not support nanoseconds. */
1926static size_t
1927emacs_nmemftime (char *s, size_t maxsize, const char *format,
1928 size_t format_len, const struct tm *tp, timezone_t tz, int ns)
1929{
1930 size_t total = 0;
1931
1932 /* Loop through all the null-terminated strings in the format
1933 argument. Normally there's just one null-terminated string, but
1934 there can be arbitrarily many, concatenated together, if the
1935 format contains '\0' bytes. nstrftime stops at the first
1936 '\0' byte so we must invoke it separately for each such string. */
1937 for (;;)
1938 {
1939 size_t len;
1940 size_t result;
1941
1942 if (s)
1943 s[0] = '\1';
1944
1945 result = nstrftime (s, maxsize, format, tp, tz, ns);
1946
1947 if (s)
1948 {
1949 if (result == 0 && s[0] != '\0')
1950 return 0;
1951 s += result + 1;
1952 }
1953
1954 maxsize -= result + 1;
1955 total += result;
1956 len = strlen (format);
1957 if (len == format_len)
1958 return total;
1959 total++;
1960 format += len + 1;
1961 format_len -= len + 1;
1962 }
1963}
1964
1965DEFUN ("format-time-string", Fformat_time_string, Sformat_time_string, 1, 3, 0,
1966 doc: /* Use FORMAT-STRING to format the time TIME, or now if omitted or nil.
1967TIME is specified as (HIGH LOW USEC PSEC), as returned by
1968`current-time' or `file-attributes'. It can also be a single integer
1969number of seconds since the epoch. The obsolete form (HIGH . LOW) is
1970also still accepted.
1971
1972The optional ZONE is omitted or nil for Emacs local time, t for
1973Universal Time, `wall' for system wall clock time, or a string as in
1974the TZ environment variable. It can also be a list (as from
1975`current-time-zone') or an integer (as from `decode-time') applied
1976without consideration for daylight saving time.
1977
1978The value is a copy of FORMAT-STRING, but with certain constructs replaced
1979by text that describes the specified date and time in TIME:
1980
1981%Y is the year, %y within the century, %C the century.
1982%G is the year corresponding to the ISO week, %g within the century.
1983%m is the numeric month.
1984%b and %h are the locale's abbreviated month name, %B the full name.
1985 (%h is not supported on MS-Windows.)
1986%d is the day of the month, zero-padded, %e is blank-padded.
1987%u is the numeric day of week from 1 (Monday) to 7, %w from 0 (Sunday) to 6.
1988%a is the locale's abbreviated name of the day of week, %A the full name.
1989%U is the week number starting on Sunday, %W starting on Monday,
1990 %V according to ISO 8601.
1991%j is the day of the year.
1992
1993%H is the hour on a 24-hour clock, %I is on a 12-hour clock, %k is like %H
1994 only blank-padded, %l is like %I blank-padded.
1995%p is the locale's equivalent of either AM or PM.
1996%q is the calendar quarter (1–4).
1997%M is the minute.
1998%S is the second.
1999%N is the nanosecond, %6N the microsecond, %3N the millisecond, etc.
2000%Z is the time zone name, %z is the numeric form.
2001%s is the number of seconds since 1970-01-01 00:00:00 +0000.
2002
2003%c is the locale's date and time format.
2004%x is the locale's "preferred" date format.
2005%D is like "%m/%d/%y".
2006%F is the ISO 8601 date format (like "%Y-%m-%d").
2007
2008%R is like "%H:%M", %T is like "%H:%M:%S", %r is like "%I:%M:%S %p".
2009%X is the locale's "preferred" time format.
2010
2011Finally, %n is a newline, %t is a tab, %% is a literal %.
2012
2013Certain flags and modifiers are available with some format controls.
2014The flags are `_', `-', `^' and `#'. For certain characters X,
2015%_X is like %X, but padded with blanks; %-X is like %X,
2016but without padding. %^X is like %X, but with all textual
2017characters up-cased; %#X is like %X, but with letter-case of
2018all textual characters reversed.
2019%NX (where N stands for an integer) is like %X,
2020but takes up at least N (a number) positions.
2021The modifiers are `E' and `O'. For certain characters X,
2022%EX is a locale's alternative version of %X;
2023%OX is like %X, but uses the locale's number symbols.
2024
2025For example, to produce full ISO 8601 format, use "%FT%T%z".
2026
2027usage: (format-time-string FORMAT-STRING &optional TIME ZONE) */)
2028 (Lisp_Object format_string, Lisp_Object timeval, Lisp_Object zone)
2029{
2030 struct timespec t = lisp_time_argument (timeval);
2031 struct tm tm;
2032
2033 CHECK_STRING (format_string);
2034 format_string = code_convert_string_norecord (format_string,
2035 Vlocale_coding_system, 1);
2036 return format_time_string (SSDATA (format_string), SBYTES (format_string),
2037 t, zone, &tm);
2038}
2039
2040static Lisp_Object
2041format_time_string (char const *format, ptrdiff_t formatlen,
2042 struct timespec t, Lisp_Object zone, struct tm *tmp)
2043{
2044 char buffer[4000];
2045 char *buf = buffer;
2046 ptrdiff_t size = sizeof buffer;
2047 size_t len;
2048 int ns = t.tv_nsec;
2049 USE_SAFE_ALLOCA;
2050
2051 timezone_t tz = tzlookup (zone, false);
2052 /* On some systems, like 32-bit MinGW, tv_sec of struct timespec is
2053 a 64-bit type, but time_t is a 32-bit type. emacs_localtime_rz
2054 expects a pointer to time_t value. */
2055 time_t tsec = t.tv_sec;
2056 tmp = emacs_localtime_rz (tz, &tsec, tmp);
2057 if (! tmp)
2058 {
2059 xtzfree (tz);
2060 time_overflow ();
2061 }
2062 synchronize_system_time_locale ();
2063
2064 while (true)
2065 {
2066 buf[0] = '\1';
2067 len = emacs_nmemftime (buf, size, format, formatlen, tmp, tz, ns);
2068 if ((0 < len && len < size) || (len == 0 && buf[0] == '\0'))
2069 break;
2070
2071 /* Buffer was too small, so make it bigger and try again. */
2072 len = emacs_nmemftime (NULL, SIZE_MAX, format, formatlen, tmp, tz, ns);
2073 if (STRING_BYTES_BOUND <= len)
2074 {
2075 xtzfree (tz);
2076 string_overflow ();
2077 }
2078 size = len + 1;
2079 buf = SAFE_ALLOCA (size);
2080 }
2081
2082 xtzfree (tz);
2083 AUTO_STRING_WITH_LEN (bufstring, buf, len);
2084 Lisp_Object result = code_convert_string_norecord (bufstring,
2085 Vlocale_coding_system, 0);
2086 SAFE_FREE ();
2087 return result;
2088}
2089
2090DEFUN ("decode-time", Fdecode_time, Sdecode_time, 0, 2, 0,
2091 doc: /* Decode a time value as (SEC MINUTE HOUR DAY MONTH YEAR DOW DST UTCOFF).
2092The optional TIME should be a list of (HIGH LOW . IGNORED),
2093as from `current-time' and `file-attributes', or nil to use the
2094current time. It can also be a single integer number of seconds since
2095the epoch. The obsolete form (HIGH . LOW) is also still accepted.
2096
2097The optional ZONE is omitted or nil for Emacs local time, t for
2098Universal Time, `wall' for system wall clock time, or a string as in
2099the TZ environment variable. It can also be a list (as from
2100`current-time-zone') or an integer (the UTC offset in seconds) applied
2101without consideration for daylight saving time.
2102
2103The list has the following nine members: SEC is an integer between 0
2104and 60; SEC is 60 for a leap second, which only some operating systems
2105support. MINUTE is an integer between 0 and 59. HOUR is an integer
2106between 0 and 23. DAY is an integer between 1 and 31. MONTH is an
2107integer between 1 and 12. YEAR is an integer indicating the
2108four-digit year. DOW is the day of week, an integer between 0 and 6,
2109where 0 is Sunday. DST is t if daylight saving time is in effect,
2110otherwise nil. UTCOFF is an integer indicating the UTC offset in
2111seconds, i.e., the number of seconds east of Greenwich. (Note that
2112Common Lisp has different meanings for DOW and UTCOFF.)
2113
2114usage: (decode-time &optional TIME ZONE) */)
2115 (Lisp_Object specified_time, Lisp_Object zone)
2116{
2117 time_t time_spec = lisp_seconds_argument (specified_time);
2118 struct tm local_tm, gmt_tm;
2119 timezone_t tz = tzlookup (zone, false);
2120 struct tm *tm = emacs_localtime_rz (tz, &time_spec, &local_tm);
2121 xtzfree (tz);
2122
2123 if (! (tm
2124 && MOST_NEGATIVE_FIXNUM - TM_YEAR_BASE <= local_tm.tm_year
2125 && local_tm.tm_year <= MOST_POSITIVE_FIXNUM - TM_YEAR_BASE))
2126 time_overflow ();
2127
2128 /* Avoid overflow when INT_MAX < EMACS_INT_MAX. */
2129 EMACS_INT tm_year_base = TM_YEAR_BASE;
2130
2131 return CALLN (Flist,
2132 make_number (local_tm.tm_sec),
2133 make_number (local_tm.tm_min),
2134 make_number (local_tm.tm_hour),
2135 make_number (local_tm.tm_mday),
2136 make_number (local_tm.tm_mon + 1),
2137 make_number (local_tm.tm_year + tm_year_base),
2138 make_number (local_tm.tm_wday),
2139 local_tm.tm_isdst ? Qt : Qnil,
2140 (HAVE_TM_GMTOFF
2141 ? make_number (tm_gmtoff (&local_tm))
2142 : gmtime_r (&time_spec, &gmt_tm)
2143 ? make_number (tm_diff (&local_tm, &gmt_tm))
2144 : Qnil));
2145}
2146
2147/* Return OBJ - OFFSET, checking that OBJ is a valid fixnum and that
2148 the result is representable as an int. */
2149static int
2150check_tm_member (Lisp_Object obj, int offset)
2151{
2152 CHECK_NUMBER (obj);
2153 EMACS_INT n = XINT (obj);
2154 int result;
2155 if (INT_SUBTRACT_WRAPV (n, offset, &result))
2156 time_overflow ();
2157 return result;
2158}
2159
2160DEFUN ("encode-time", Fencode_time, Sencode_time, 6, MANY, 0,
2161 doc: /* Convert SECOND, MINUTE, HOUR, DAY, MONTH, YEAR and ZONE to internal time.
2162This is the reverse operation of `decode-time', which see.
2163
2164The optional ZONE is omitted or nil for Emacs local time, t for
2165Universal Time, `wall' for system wall clock time, or a string as in
2166the TZ environment variable. It can also be a list (as from
2167`current-time-zone') or an integer (as from `decode-time') applied
2168without consideration for daylight saving time.
2169
2170You can pass more than 7 arguments; then the first six arguments
2171are used as SECOND through YEAR, and the *last* argument is used as ZONE.
2172The intervening arguments are ignored.
2173This feature lets (apply \\='encode-time (decode-time ...)) work.
2174
2175Out-of-range values for SECOND, MINUTE, HOUR, DAY, or MONTH are allowed;
2176for example, a DAY of 0 means the day preceding the given month.
2177Year numbers less than 100 are treated just like other year numbers.
2178If you want them to stand for years in this century, you must do that yourself.
2179
2180Years before 1970 are not guaranteed to work. On some systems,
2181year values as low as 1901 do work.
2182
2183usage: (encode-time SECOND MINUTE HOUR DAY MONTH YEAR &optional ZONE) */)
2184 (ptrdiff_t nargs, Lisp_Object *args)
2185{
2186 time_t value;
2187 struct tm tm;
2188 Lisp_Object zone = (nargs > 6 ? args[nargs - 1] : Qnil);
2189
2190 tm.tm_sec = check_tm_member (args[0], 0);
2191 tm.tm_min = check_tm_member (args[1], 0);
2192 tm.tm_hour = check_tm_member (args[2], 0);
2193 tm.tm_mday = check_tm_member (args[3], 0);
2194 tm.tm_mon = check_tm_member (args[4], 1);
2195 tm.tm_year = check_tm_member (args[5], TM_YEAR_BASE);
2196 tm.tm_isdst = -1;
2197
2198 timezone_t tz = tzlookup (zone, false);
2199 value = emacs_mktime_z (tz, &tm);
2200 xtzfree (tz);
2201
2202 if (value == (time_t) -1)
2203 time_overflow ();
2204
2205 return list2i (hi_time (value), lo_time (value));
2206}
2207
2208DEFUN ("current-time-string", Fcurrent_time_string, Scurrent_time_string,
2209 0, 2, 0,
2210 doc: /* Return the current local time, as a human-readable string.
2211Programs can use this function to decode a time,
2212since the number of columns in each field is fixed
2213if the year is in the range 1000-9999.
2214The format is `Sun Sep 16 01:03:52 1973'.
2215However, see also the functions `decode-time' and `format-time-string'
2216which provide a much more powerful and general facility.
2217
2218If SPECIFIED-TIME is given, it is a time to format instead of the
2219current time. The argument should have the form (HIGH LOW . IGNORED).
2220Thus, you can use times obtained from `current-time' and from
2221`file-attributes'. SPECIFIED-TIME can also be a single integer number
2222of seconds since the epoch. The obsolete form (HIGH . LOW) is also
2223still accepted.
2224
2225The optional ZONE is omitted or nil for Emacs local time, t for
2226Universal Time, `wall' for system wall clock time, or a string as in
2227the TZ environment variable. It can also be a list (as from
2228`current-time-zone') or an integer (as from `decode-time') applied
2229without consideration for daylight saving time. */)
2230 (Lisp_Object specified_time, Lisp_Object zone)
2231{
2232 time_t value = lisp_seconds_argument (specified_time);
2233 timezone_t tz = tzlookup (zone, false);
2234
2235 /* Convert to a string in ctime format, except without the trailing
2236 newline, and without the 4-digit year limit. Don't use asctime
2237 or ctime, as they might dump core if the year is outside the
2238 range -999 .. 9999. */
2239 struct tm tm;
2240 struct tm *tmp = emacs_localtime_rz (tz, &value, &tm);
2241 xtzfree (tz);
2242 if (! tmp)
2243 time_overflow ();
2244
2245 static char const wday_name[][4] =
2246 { "Sun", "Mon", "Tue", "Wed", "Thu", "Fri", "Sat" };
2247 static char const mon_name[][4] =
2248 { "Jan", "Feb", "Mar", "Apr", "May", "Jun",
2249 "Jul", "Aug", "Sep", "Oct", "Nov", "Dec" };
2250 printmax_t year_base = TM_YEAR_BASE;
2251 char buf[sizeof "Mon Apr 30 12:49:17 " + INT_STRLEN_BOUND (int) + 1];
2252 int len = sprintf (buf, "%s %s%3d %02d:%02d:%02d %"pMd,
2253 wday_name[tm.tm_wday], mon_name[tm.tm_mon], tm.tm_mday,
2254 tm.tm_hour, tm.tm_min, tm.tm_sec,
2255 tm.tm_year + year_base);
2256
2257 return make_unibyte_string (buf, len);
2258}
2259
2260/* Yield A - B, measured in seconds.
2261 This function is copied from the GNU C Library. */
2262static int
2263tm_diff (struct tm *a, struct tm *b)
2264{
2265 /* Compute intervening leap days correctly even if year is negative.
2266 Take care to avoid int overflow in leap day calculations,
2267 but it's OK to assume that A and B are close to each other. */
2268 int a4 = (a->tm_year >> 2) + (TM_YEAR_BASE >> 2) - ! (a->tm_year & 3);
2269 int b4 = (b->tm_year >> 2) + (TM_YEAR_BASE >> 2) - ! (b->tm_year & 3);
2270 int a100 = a4 / 25 - (a4 % 25 < 0);
2271 int b100 = b4 / 25 - (b4 % 25 < 0);
2272 int a400 = a100 >> 2;
2273 int b400 = b100 >> 2;
2274 int intervening_leap_days = (a4 - b4) - (a100 - b100) + (a400 - b400);
2275 int years = a->tm_year - b->tm_year;
2276 int days = (365 * years + intervening_leap_days
2277 + (a->tm_yday - b->tm_yday));
2278 return (60 * (60 * (24 * days + (a->tm_hour - b->tm_hour))
2279 + (a->tm_min - b->tm_min))
2280 + (a->tm_sec - b->tm_sec));
2281}
2282
2283/* Yield A's UTC offset, or an unspecified value if unknown. */
2284static long int
2285tm_gmtoff (struct tm *a)
2286{
2287#if HAVE_TM_GMTOFF
2288 return a->tm_gmtoff;
2289#else
2290 return 0;
2291#endif
2292}
2293
2294DEFUN ("current-time-zone", Fcurrent_time_zone, Scurrent_time_zone, 0, 2, 0,
2295 doc: /* Return the offset and name for the local time zone.
2296This returns a list of the form (OFFSET NAME).
2297OFFSET is an integer number of seconds ahead of UTC (east of Greenwich).
2298 A negative value means west of Greenwich.
2299NAME is a string giving the name of the time zone.
2300If SPECIFIED-TIME is given, the time zone offset is determined from it
2301instead of using the current time. The argument should have the form
2302\(HIGH LOW . IGNORED). Thus, you can use times obtained from
2303`current-time' and from `file-attributes'. SPECIFIED-TIME can also be
2304a single integer number of seconds since the epoch. The obsolete form
2305(HIGH . LOW) is also still accepted.
2306
2307The optional ZONE is omitted or nil for Emacs local time, t for
2308Universal Time, `wall' for system wall clock time, or a string as in
2309the TZ environment variable. It can also be a list (as from
2310`current-time-zone') or an integer (as from `decode-time') applied
2311without consideration for daylight saving time.
2312
2313Some operating systems cannot provide all this information to Emacs;
2314in this case, `current-time-zone' returns a list containing nil for
2315the data it can't find. */)
2316 (Lisp_Object specified_time, Lisp_Object zone)
2317{
2318 struct timespec value;
2319 struct tm local_tm, gmt_tm;
2320 Lisp_Object zone_offset, zone_name;
2321
2322 zone_offset = Qnil;
2323 value = make_timespec (lisp_seconds_argument (specified_time), 0);
2324 zone_name = format_time_string ("%Z", sizeof "%Z" - 1, value,
2325 zone, &local_tm);
2326
2327 /* gmtime_r expects a pointer to time_t, but tv_sec of struct
2328 timespec on some systems (MinGW) is a 64-bit field. */
2329 time_t tsec = value.tv_sec;
2330 if (HAVE_TM_GMTOFF || gmtime_r (&tsec, &gmt_tm))
2331 {
2332 long int offset = (HAVE_TM_GMTOFF
2333 ? tm_gmtoff (&local_tm)
2334 : tm_diff (&local_tm, &gmt_tm));
2335 zone_offset = make_number (offset);
2336 if (SCHARS (zone_name) == 0)
2337 {
2338 /* No local time zone name is available; use numeric zone instead. */
2339 long int hour = offset / 3600;
2340 int min_sec = offset % 3600;
2341 int amin_sec = min_sec < 0 ? - min_sec : min_sec;
2342 int min = amin_sec / 60;
2343 int sec = amin_sec % 60;
2344 int min_prec = min_sec ? 2 : 0;
2345 int sec_prec = sec ? 2 : 0;
2346 char buf[sizeof "+0000" + INT_STRLEN_BOUND (long int)];
2347 zone_name = make_formatted_string (buf, "%c%.2ld%.*d%.*d",
2348 (offset < 0 ? '-' : '+'),
2349 hour, min_prec, min, sec_prec, sec);
2350 }
2351 }
2352
2353 return list2 (zone_offset, zone_name);
2354}
2355
2356DEFUN ("set-time-zone-rule", Fset_time_zone_rule, Sset_time_zone_rule, 1, 1, 0,
2357 doc: /* Set the Emacs local time zone using TZ, a string specifying a time zone rule.
2358If TZ is nil or `wall', use system wall clock time; this differs from
2359the usual Emacs convention where nil means current local time. If TZ
2360is t, use Universal Time. If TZ is a list (as from
2361`current-time-zone') or an integer (as from `decode-time'), use the
2362specified time zone without consideration for daylight saving time.
2363
2364Instead of calling this function, you typically want something else.
2365To temporarily use a different time zone rule for just one invocation
2366of `decode-time', `encode-time', or `format-time-string', pass the
2367function a ZONE argument. To change local time consistently
2368throughout Emacs, call (setenv "TZ" TZ): this changes both the
2369environment of the Emacs process and the variable
2370`process-environment', whereas `set-time-zone-rule' affects only the
2371former. */)
2372 (Lisp_Object tz)
2373{
2374 tzlookup (NILP (tz) ? Qwall : tz, true);
2375 return Qnil;
2376}
2377
2378/* A buffer holding a string of the form "TZ=value", intended
2379 to be part of the environment. If TZ is supposed to be unset,
2380 the buffer string is "tZ=". */
2381 static char *tzvalbuf;
2382
2383/* Get the local time zone rule. */
2384char *
2385emacs_getenv_TZ (void)
2386{
2387 return tzvalbuf[0] == 'T' ? tzvalbuf + tzeqlen : 0;
2388}
2389
2390/* Set the local time zone rule to TZSTRING, which can be null to
2391 denote wall clock time. Do not record the setting in LOCAL_TZ.
2392
2393 This function is not thread-safe, in theory because putenv is not,
2394 but mostly because of the static storage it updates. Other threads
2395 that invoke localtime etc. may be adversely affected while this
2396 function is executing. */
2397
2398int
2399emacs_setenv_TZ (const char *tzstring)
2400{
2401 static ptrdiff_t tzvalbufsize;
2402 ptrdiff_t tzstringlen = tzstring ? strlen (tzstring) : 0;
2403 char *tzval = tzvalbuf;
2404 bool new_tzvalbuf = tzvalbufsize <= tzeqlen + tzstringlen;
2405
2406 if (new_tzvalbuf)
2407 {
2408 /* Do not attempt to free the old tzvalbuf, since another thread
2409 may be using it. In practice, the first allocation is large
2410 enough and memory does not leak. */
2411 tzval = xpalloc (NULL, &tzvalbufsize,
2412 tzeqlen + tzstringlen - tzvalbufsize + 1, -1, 1);
2413 tzvalbuf = tzval;
2414 tzval[1] = 'Z';
2415 tzval[2] = '=';
2416 }
2417
2418 if (tzstring)
2419 {
2420 /* Modify TZVAL in place. Although this is dicey in a
2421 multithreaded environment, we know of no portable alternative.
2422 Calling putenv or setenv could crash some other thread. */
2423 tzval[0] = 'T';
2424 strcpy (tzval + tzeqlen, tzstring);
2425 }
2426 else
2427 {
2428 /* Turn 'TZ=whatever' into an empty environment variable 'tZ='.
2429 Although this is also dicey, calling unsetenv here can crash Emacs.
2430 See Bug#8705. */
2431 tzval[0] = 't';
2432 tzval[tzeqlen] = 0;
2433 }
2434
2435
2436#ifndef WINDOWSNT
2437 /* Modifying *TZVAL merely requires calling tzset (which is the
2438 caller's responsibility). However, modifying TZVAL requires
2439 calling putenv; although this is not thread-safe, in practice this
2440 runs only on startup when there is only one thread. */
2441 bool need_putenv = new_tzvalbuf;
2442#else
2443 /* MS-Windows 'putenv' copies the argument string into a block it
2444 allocates, so modifying *TZVAL will not change the environment.
2445 However, the other threads run by Emacs on MS-Windows never call
2446 'xputenv' or 'putenv' or 'unsetenv', so the original cause for the
2447 dicey in-place modification technique doesn't exist there in the
2448 first place. */
2449 bool need_putenv = true;
2450#endif
2451 if (need_putenv)
2452 xputenv (tzval);
2453
2454 return 0;
2455}
2456 1304
2457/* Insert NARGS Lisp objects in the array ARGS by calling INSERT_FUNC 1305/* Insert NARGS Lisp objects in the array ARGS by calling INSERT_FUNC
2458 (if a type of object is Lisp_Int) or INSERT_FROM_STRING_FUNC (if a 1306 (if a type of object is Lisp_Int) or INSERT_FROM_STRING_FUNC (if a
@@ -2475,7 +1323,7 @@ general_insert_function (void (*insert_func)
2475 val = args[argnum]; 1323 val = args[argnum];
2476 if (CHARACTERP (val)) 1324 if (CHARACTERP (val))
2477 { 1325 {
2478 int c = XFASTINT (val); 1326 int c = XFIXNAT (val);
2479 unsigned char str[MAX_MULTIBYTE_LENGTH]; 1327 unsigned char str[MAX_MULTIBYTE_LENGTH];
2480 int len; 1328 int len;
2481 1329
@@ -2596,8 +1444,8 @@ DEFUN ("insert-char", Finsert_char, Sinsert_char, 1, 3,
2596 (prefix-numeric-value current-prefix-arg)\ 1444 (prefix-numeric-value current-prefix-arg)\
2597 t))", 1445 t))",
2598 doc: /* Insert COUNT copies of CHARACTER. 1446 doc: /* Insert COUNT copies of CHARACTER.
2599Interactively, prompt for CHARACTER. You can specify CHARACTER in one 1447Interactively, prompt for CHARACTER using `read-char-by-name'.
2600of these ways: 1448You can specify CHARACTER in one of these ways:
2601 1449
2602 - As its Unicode character name, e.g. \"LATIN SMALL LETTER A\". 1450 - As its Unicode character name, e.g. \"LATIN SMALL LETTER A\".
2603 Completion is available; if you type a substring of the name 1451 Completion is available; if you type a substring of the name
@@ -2631,18 +1479,19 @@ called interactively, INHERIT is t. */)
2631 CHECK_CHARACTER (character); 1479 CHECK_CHARACTER (character);
2632 if (NILP (count)) 1480 if (NILP (count))
2633 XSETFASTINT (count, 1); 1481 XSETFASTINT (count, 1);
2634 CHECK_NUMBER (count); 1482 else
2635 c = XFASTINT (character); 1483 CHECK_FIXNUM (count);
1484 c = XFIXNAT (character);
2636 1485
2637 if (!NILP (BVAR (current_buffer, enable_multibyte_characters))) 1486 if (!NILP (BVAR (current_buffer, enable_multibyte_characters)))
2638 len = CHAR_STRING (c, str); 1487 len = CHAR_STRING (c, str);
2639 else 1488 else
2640 str[0] = c, len = 1; 1489 str[0] = c, len = 1;
2641 if (XINT (count) <= 0) 1490 if (XFIXNUM (count) <= 0)
2642 return Qnil; 1491 return Qnil;
2643 if (BUF_BYTES_MAX / len < XINT (count)) 1492 if (BUF_BYTES_MAX / len < XFIXNUM (count))
2644 buffer_overflow (); 1493 buffer_overflow ();
2645 n = XINT (count) * len; 1494 n = XFIXNUM (count) * len;
2646 stringlen = min (n, sizeof string - sizeof string % len); 1495 stringlen = min (n, sizeof string - sizeof string % len);
2647 for (i = 0; i < stringlen; i++) 1496 for (i = 0; i < stringlen; i++)
2648 string[i] = str[i % len]; 1497 string[i] = str[i % len];
@@ -2675,12 +1524,12 @@ The optional third arg INHERIT, if non-nil, says to inherit text properties
2675from adjoining text, if those properties are sticky. */) 1524from adjoining text, if those properties are sticky. */)
2676 (Lisp_Object byte, Lisp_Object count, Lisp_Object inherit) 1525 (Lisp_Object byte, Lisp_Object count, Lisp_Object inherit)
2677{ 1526{
2678 CHECK_NUMBER (byte); 1527 CHECK_FIXNUM (byte);
2679 if (XINT (byte) < 0 || XINT (byte) > 255) 1528 if (XFIXNUM (byte) < 0 || XFIXNUM (byte) > 255)
2680 args_out_of_range_3 (byte, make_number (0), make_number (255)); 1529 args_out_of_range_3 (byte, make_fixnum (0), make_fixnum (255));
2681 if (XINT (byte) >= 128 1530 if (XFIXNUM (byte) >= 128
2682 && ! NILP (BVAR (current_buffer, enable_multibyte_characters))) 1531 && ! NILP (BVAR (current_buffer, enable_multibyte_characters)))
2683 XSETFASTINT (byte, BYTE8_TO_CHAR (XINT (byte))); 1532 XSETFASTINT (byte, BYTE8_TO_CHAR (XFIXNUM (byte)));
2684 return Finsert_char (byte, count, inherit); 1533 return Finsert_char (byte, count, inherit);
2685} 1534}
2686 1535
@@ -2696,7 +1545,7 @@ from adjoining text, if those properties are sticky. */)
2696 make_uninit_string, which can cause the buffer arena to be 1545 make_uninit_string, which can cause the buffer arena to be
2697 compacted. make_string has no way of knowing that the data has 1546 compacted. make_string has no way of knowing that the data has
2698 been moved, and thus copies the wrong data into the string. This 1547 been moved, and thus copies the wrong data into the string. This
2699 doesn't effect most of the other users of make_string, so it should 1548 doesn't affect most of the other users of make_string, so it should
2700 be left as is. But we should use this function when conjuring 1549 be left as is. But we should use this function when conjuring
2701 buffer substrings. */ 1550 buffer substrings. */
2702 1551
@@ -2763,10 +1612,10 @@ make_buffer_string_both (ptrdiff_t start, ptrdiff_t start_byte,
2763 { 1612 {
2764 update_buffer_properties (start, end); 1613 update_buffer_properties (start, end);
2765 1614
2766 tem = Fnext_property_change (make_number (start), Qnil, make_number (end)); 1615 tem = Fnext_property_change (make_fixnum (start), Qnil, make_fixnum (end));
2767 tem1 = Ftext_properties_at (make_number (start), Qnil); 1616 tem1 = Ftext_properties_at (make_fixnum (start), Qnil);
2768 1617
2769 if (XINT (tem) != end || !NILP (tem1)) 1618 if (XFIXNUM (tem) != end || !NILP (tem1))
2770 copy_intervals_to_string (result, current_buffer, start, 1619 copy_intervals_to_string (result, current_buffer, start,
2771 end - start); 1620 end - start);
2772 } 1621 }
@@ -2789,7 +1638,7 @@ update_buffer_properties (ptrdiff_t start, ptrdiff_t end)
2789 if (!NILP (Vbuffer_access_fontified_property)) 1638 if (!NILP (Vbuffer_access_fontified_property))
2790 { 1639 {
2791 Lisp_Object tem 1640 Lisp_Object tem
2792 = Ftext_property_any (make_number (start), make_number (end), 1641 = Ftext_property_any (make_fixnum (start), make_fixnum (end),
2793 Vbuffer_access_fontified_property, 1642 Vbuffer_access_fontified_property,
2794 Qnil, Qnil); 1643 Qnil, Qnil);
2795 if (NILP (tem)) 1644 if (NILP (tem))
@@ -2797,7 +1646,7 @@ update_buffer_properties (ptrdiff_t start, ptrdiff_t end)
2797 } 1646 }
2798 1647
2799 CALLN (Frun_hook_with_args, Qbuffer_access_fontify_functions, 1648 CALLN (Frun_hook_with_args, Qbuffer_access_fontify_functions,
2800 make_number (start), make_number (end)); 1649 make_fixnum (start), make_fixnum (end));
2801 } 1650 }
2802} 1651}
2803 1652
@@ -2815,8 +1664,8 @@ use `buffer-substring-no-properties' instead. */)
2815 register ptrdiff_t b, e; 1664 register ptrdiff_t b, e;
2816 1665
2817 validate_region (&start, &end); 1666 validate_region (&start, &end);
2818 b = XINT (start); 1667 b = XFIXNUM (start);
2819 e = XINT (end); 1668 e = XFIXNUM (end);
2820 1669
2821 return make_buffer_string (b, e, 1); 1670 return make_buffer_string (b, e, 1);
2822} 1671}
@@ -2831,8 +1680,8 @@ they can be in either order. */)
2831 register ptrdiff_t b, e; 1680 register ptrdiff_t b, e;
2832 1681
2833 validate_region (&start, &end); 1682 validate_region (&start, &end);
2834 b = XINT (start); 1683 b = XFIXNUM (start);
2835 e = XINT (end); 1684 e = XFIXNUM (end);
2836 1685
2837 return make_buffer_string (b, e, 0); 1686 return make_buffer_string (b, e, 0);
2838} 1687}
@@ -2840,7 +1689,11 @@ they can be in either order. */)
2840DEFUN ("buffer-string", Fbuffer_string, Sbuffer_string, 0, 0, 0, 1689DEFUN ("buffer-string", Fbuffer_string, Sbuffer_string, 0, 0, 0,
2841 doc: /* Return the contents of the current buffer as a string. 1690 doc: /* Return the contents of the current buffer as a string.
2842If narrowing is in effect, this function returns only the visible part 1691If narrowing is in effect, this function returns only the visible part
2843of the buffer. */) 1692of the buffer.
1693
1694This function copies the text properties of that part of the buffer
1695into the result string; if you don’t want the text properties,
1696use `buffer-substring-no-properties' instead. */)
2844 (void) 1697 (void)
2845{ 1698{
2846 return make_buffer_string_both (BEGV, BEGV_BYTE, ZV, ZV_BYTE, 1); 1699 return make_buffer_string_both (BEGV, BEGV_BYTE, ZV, ZV_BYTE, 1);
@@ -2873,21 +1726,8 @@ using `string-make-multibyte' or `string-make-unibyte', which see. */)
2873 if (!BUFFER_LIVE_P (bp)) 1726 if (!BUFFER_LIVE_P (bp))
2874 error ("Selecting deleted buffer"); 1727 error ("Selecting deleted buffer");
2875 1728
2876 if (NILP (start)) 1729 b = !NILP (start) ? fix_position (start) : BUF_BEGV (bp);
2877 b = BUF_BEGV (bp); 1730 e = !NILP (end) ? fix_position (end) : BUF_ZV (bp);
2878 else
2879 {
2880 CHECK_NUMBER_COERCE_MARKER (start);
2881 b = XINT (start);
2882 }
2883 if (NILP (end))
2884 e = BUF_ZV (bp);
2885 else
2886 {
2887 CHECK_NUMBER_COERCE_MARKER (end);
2888 e = XINT (end);
2889 }
2890
2891 if (b > e) 1731 if (b > e)
2892 temp = b, b = e, e = temp; 1732 temp = b, b = e, e = temp;
2893 1733
@@ -2941,21 +1781,8 @@ determines whether case is significant or ignored. */)
2941 error ("Selecting deleted buffer"); 1781 error ("Selecting deleted buffer");
2942 } 1782 }
2943 1783
2944 if (NILP (start1)) 1784 begp1 = !NILP (start1) ? fix_position (start1) : BUF_BEGV (bp1);
2945 begp1 = BUF_BEGV (bp1); 1785 endp1 = !NILP (end1) ? fix_position (end1) : BUF_ZV (bp1);
2946 else
2947 {
2948 CHECK_NUMBER_COERCE_MARKER (start1);
2949 begp1 = XINT (start1);
2950 }
2951 if (NILP (end1))
2952 endp1 = BUF_ZV (bp1);
2953 else
2954 {
2955 CHECK_NUMBER_COERCE_MARKER (end1);
2956 endp1 = XINT (end1);
2957 }
2958
2959 if (begp1 > endp1) 1786 if (begp1 > endp1)
2960 temp = begp1, begp1 = endp1, endp1 = temp; 1787 temp = begp1, begp1 = endp1, endp1 = temp;
2961 1788
@@ -2979,21 +1806,8 @@ determines whether case is significant or ignored. */)
2979 error ("Selecting deleted buffer"); 1806 error ("Selecting deleted buffer");
2980 } 1807 }
2981 1808
2982 if (NILP (start2)) 1809 begp2 = !NILP (start2) ? fix_position (start2) : BUF_BEGV (bp2);
2983 begp2 = BUF_BEGV (bp2); 1810 endp2 = !NILP (end2) ? fix_position (end2) : BUF_ZV (bp2);
2984 else
2985 {
2986 CHECK_NUMBER_COERCE_MARKER (start2);
2987 begp2 = XINT (start2);
2988 }
2989 if (NILP (end2))
2990 endp2 = BUF_ZV (bp2);
2991 else
2992 {
2993 CHECK_NUMBER_COERCE_MARKER (end2);
2994 endp2 = XINT (end2);
2995 }
2996
2997 if (begp2 > endp2) 1811 if (begp2 > endp2)
2998 temp = begp2, begp2 = endp2, endp2 = temp; 1812 temp = begp2, begp2 = endp2, endp2 = temp;
2999 1813
@@ -3016,26 +1830,24 @@ determines whether case is significant or ignored. */)
3016 if (! NILP (BVAR (bp1, enable_multibyte_characters))) 1830 if (! NILP (BVAR (bp1, enable_multibyte_characters)))
3017 { 1831 {
3018 c1 = BUF_FETCH_MULTIBYTE_CHAR (bp1, i1_byte); 1832 c1 = BUF_FETCH_MULTIBYTE_CHAR (bp1, i1_byte);
3019 BUF_INC_POS (bp1, i1_byte); 1833 i1_byte += buf_next_char_len (bp1, i1_byte);
3020 i1++; 1834 i1++;
3021 } 1835 }
3022 else 1836 else
3023 { 1837 {
3024 c1 = BUF_FETCH_BYTE (bp1, i1); 1838 c1 = make_char_multibyte (BUF_FETCH_BYTE (bp1, i1));
3025 MAKE_CHAR_MULTIBYTE (c1);
3026 i1++; 1839 i1++;
3027 } 1840 }
3028 1841
3029 if (! NILP (BVAR (bp2, enable_multibyte_characters))) 1842 if (! NILP (BVAR (bp2, enable_multibyte_characters)))
3030 { 1843 {
3031 c2 = BUF_FETCH_MULTIBYTE_CHAR (bp2, i2_byte); 1844 c2 = BUF_FETCH_MULTIBYTE_CHAR (bp2, i2_byte);
3032 BUF_INC_POS (bp2, i2_byte); 1845 i2_byte += buf_next_char_len (bp2, i2_byte);
3033 i2++; 1846 i2++;
3034 } 1847 }
3035 else 1848 else
3036 { 1849 {
3037 c2 = BUF_FETCH_BYTE (bp2, i2); 1850 c2 = make_char_multibyte (BUF_FETCH_BYTE (bp2, i2));
3038 MAKE_CHAR_MULTIBYTE (c2);
3039 i2++; 1851 i2++;
3040 } 1852 }
3041 1853
@@ -3046,7 +1858,7 @@ determines whether case is significant or ignored. */)
3046 } 1858 }
3047 1859
3048 if (c1 != c2) 1860 if (c1 != c2)
3049 return make_number (c1 < c2 ? -1 - chars : chars + 1); 1861 return make_fixnum (c1 < c2 ? -1 - chars : chars + 1);
3050 1862
3051 chars++; 1863 chars++;
3052 rarely_quit (chars); 1864 rarely_quit (chars);
@@ -3055,12 +1867,12 @@ determines whether case is significant or ignored. */)
3055 /* The strings match as far as they go. 1867 /* The strings match as far as they go.
3056 If one is shorter, that one is less. */ 1868 If one is shorter, that one is less. */
3057 if (chars < endp1 - begp1) 1869 if (chars < endp1 - begp1)
3058 return make_number (chars + 1); 1870 return make_fixnum (chars + 1);
3059 else if (chars < endp2 - begp2) 1871 else if (chars < endp2 - begp2)
3060 return make_number (- chars - 1); 1872 return make_fixnum (- chars - 1);
3061 1873
3062 /* Same length too => they are equal. */ 1874 /* Same length too => they are equal. */
3063 return make_number (0); 1875 return make_fixnum (0);
3064} 1876}
3065 1877
3066 1878
@@ -3069,6 +1881,7 @@ determines whether case is significant or ignored. */)
3069 1881
3070#undef ELEMENT 1882#undef ELEMENT
3071#undef EQUAL 1883#undef EQUAL
1884#define USE_HEURISTIC
3072 1885
3073#define XVECREF_YVECREF_EQUAL(ctx, xoff, yoff) \ 1886#define XVECREF_YVECREF_EQUAL(ctx, xoff, yoff) \
3074 buffer_chars_equal ((ctx), (xoff), (yoff)) 1887 buffer_chars_equal ((ctx), (xoff), (yoff))
@@ -3079,31 +1892,63 @@ determines whether case is significant or ignored. */)
3079 /* Buffers to compare. */ \ 1892 /* Buffers to compare. */ \
3080 struct buffer *buffer_a; \ 1893 struct buffer *buffer_a; \
3081 struct buffer *buffer_b; \ 1894 struct buffer *buffer_b; \
1895 /* BEGV of each buffer */ \
1896 ptrdiff_t beg_a; \
1897 ptrdiff_t beg_b; \
1898 /* Whether each buffer is unibyte/plain-ASCII or not. */ \
1899 bool a_unibyte; \
1900 bool b_unibyte; \
3082 /* Bit vectors recording for each character whether it was deleted 1901 /* Bit vectors recording for each character whether it was deleted
3083 or inserted. */ \ 1902 or inserted. */ \
3084 unsigned char *deletions; \ 1903 unsigned char *deletions; \
3085 unsigned char *insertions; 1904 unsigned char *insertions; \
1905 struct timespec time_limit; \
1906 sys_jmp_buf jmp; \
1907 unsigned short quitcounter;
3086 1908
3087#define NOTE_DELETE(ctx, xoff) set_bit ((ctx)->deletions, (xoff)) 1909#define NOTE_DELETE(ctx, xoff) set_bit ((ctx)->deletions, xoff)
3088#define NOTE_INSERT(ctx, yoff) set_bit ((ctx)->insertions, (yoff)) 1910#define NOTE_INSERT(ctx, yoff) set_bit ((ctx)->insertions, yoff)
1911#define EARLY_ABORT(ctx) compareseq_early_abort (ctx)
3089 1912
3090struct context; 1913struct context;
3091static void set_bit (unsigned char *, OFFSET); 1914static void set_bit (unsigned char *, OFFSET);
3092static bool bit_is_set (const unsigned char *, OFFSET); 1915static bool bit_is_set (const unsigned char *, OFFSET);
3093static bool buffer_chars_equal (struct context *, OFFSET, OFFSET); 1916static bool buffer_chars_equal (struct context *, OFFSET, OFFSET);
1917static bool compareseq_early_abort (struct context *);
3094 1918
3095#include "minmax.h" 1919#include "minmax.h"
3096#include "diffseq.h" 1920#include "diffseq.h"
3097 1921
3098DEFUN ("replace-buffer-contents", Freplace_buffer_contents, 1922DEFUN ("replace-buffer-contents", Freplace_buffer_contents,
3099 Sreplace_buffer_contents, 1, 1, "bSource buffer: ", 1923 Sreplace_buffer_contents, 1, 3, "bSource buffer: ",
3100 doc: /* Replace accessible portion of current buffer with that of SOURCE. 1924 doc: /* Replace accessible portion of current buffer with that of SOURCE.
3101SOURCE can be a buffer or a string that names a buffer. 1925SOURCE can be a buffer or a string that names a buffer.
3102Interactively, prompt for SOURCE. 1926Interactively, prompt for SOURCE.
1927
3103As far as possible the replacement is non-destructive, i.e. existing 1928As far as possible the replacement is non-destructive, i.e. existing
3104buffer contents, markers, properties, and overlays in the current 1929buffer contents, markers, properties, and overlays in the current
3105buffer stay intact. */) 1930buffer stay intact.
3106 (Lisp_Object source) 1931
1932Because this function can be very slow if there is a large number of
1933differences between the two buffers, there are two optional arguments
1934mitigating this issue.
1935
1936The MAX-SECS argument, if given, defines a hard limit on the time used
1937for comparing the buffers. If it takes longer than MAX-SECS, the
1938function falls back to a plain `delete-region' and
1939`insert-buffer-substring'. (Note that the checks are not performed
1940too evenly over time, so in some cases it may run a bit longer than
1941allowed).
1942
1943The optional argument MAX-COSTS defines the quality of the difference
1944computation. If the actual costs exceed this limit, heuristics are
1945used to provide a faster but suboptimal solution. The default value
1946is 1000000.
1947
1948This function returns t if a non-destructive replacement could be
1949performed. Otherwise, i.e., if MAX-SECS was exceeded, it returns
1950nil. */)
1951 (Lisp_Object source, Lisp_Object max_secs, Lisp_Object max_costs)
3107{ 1952{
3108 struct buffer *a = current_buffer; 1953 struct buffer *a = current_buffer;
3109 Lisp_Object source_buffer = Fget_buffer (source); 1954 Lisp_Object source_buffer = Fget_buffer (source);
@@ -3115,6 +1960,28 @@ buffer stay intact. */)
3115 if (a == b) 1960 if (a == b)
3116 error ("Cannot replace a buffer with itself"); 1961 error ("Cannot replace a buffer with itself");
3117 1962
1963 ptrdiff_t too_expensive;
1964 if (NILP (max_costs))
1965 too_expensive = 1000000;
1966 else if (FIXNUMP (max_costs))
1967 too_expensive = clip_to_bounds (0, XFIXNUM (max_costs), PTRDIFF_MAX);
1968 else
1969 {
1970 CHECK_INTEGER (max_costs);
1971 too_expensive = NILP (Fnatnump (max_costs)) ? 0 : PTRDIFF_MAX;
1972 }
1973
1974 struct timespec time_limit = make_timespec (0, -1);
1975 if (!NILP (max_secs))
1976 {
1977 struct timespec
1978 tlim = timespec_add (current_timespec (),
1979 lisp_time_argument (max_secs)),
1980 tmax = make_timespec (TYPE_MAXIMUM (time_t), TIMESPEC_HZ - 1);
1981 if (timespec_cmp (tlim, tmax) < 0)
1982 time_limit = tlim;
1983 }
1984
3118 ptrdiff_t min_a = BEGV; 1985 ptrdiff_t min_a = BEGV;
3119 ptrdiff_t min_b = BUF_BEGV (b); 1986 ptrdiff_t min_b = BUF_BEGV (b);
3120 ptrdiff_t size_a = ZV - min_a; 1987 ptrdiff_t size_a = ZV - min_a;
@@ -3128,53 +1995,87 @@ buffer stay intact. */)
3128 empty. */ 1995 empty. */
3129 1996
3130 if (a_empty && b_empty) 1997 if (a_empty && b_empty)
3131 return Qnil; 1998 return Qt;
3132 1999
3133 if (a_empty) 2000 if (a_empty)
3134 return Finsert_buffer_substring (source, Qnil, Qnil); 2001 {
2002 Finsert_buffer_substring (source, Qnil, Qnil);
2003 return Qt;
2004 }
3135 2005
3136 if (b_empty) 2006 if (b_empty)
3137 { 2007 {
3138 del_range_both (BEGV, BEGV_BYTE, ZV, ZV_BYTE, true); 2008 del_range_both (BEGV, BEGV_BYTE, ZV, ZV_BYTE, true);
3139 return Qnil; 2009 return Qt;
3140 } 2010 }
3141 2011
3142 /* FIXME: It is not documented how to initialize the contents of the 2012 specpdl_ref count = SPECPDL_INDEX ();
3143 context structure. This code cargo-cults from the existing 2013
3144 caller in src/analyze.c of GNU Diffutils, which appears to
3145 work. */
3146 2014
3147 ptrdiff_t diags = size_a + size_b + 3; 2015 ptrdiff_t diags = size_a + size_b + 3;
2016 ptrdiff_t del_bytes = size_a / CHAR_BIT + 1;
2017 ptrdiff_t ins_bytes = size_b / CHAR_BIT + 1;
3148 ptrdiff_t *buffer; 2018 ptrdiff_t *buffer;
2019 ptrdiff_t bytes_needed;
2020 if (INT_MULTIPLY_WRAPV (diags, 2 * sizeof *buffer, &bytes_needed)
2021 || INT_ADD_WRAPV (del_bytes + ins_bytes, bytes_needed, &bytes_needed))
2022 memory_full (SIZE_MAX);
3149 USE_SAFE_ALLOCA; 2023 USE_SAFE_ALLOCA;
3150 SAFE_NALLOCA (buffer, 2, diags); 2024 buffer = SAFE_ALLOCA (bytes_needed);
3151 /* Micro-optimization: Casting to size_t generates much better 2025 unsigned char *deletions_insertions = memset (buffer + 2 * diags, 0,
3152 code. */ 2026 del_bytes + ins_bytes);
3153 ptrdiff_t del_bytes = (size_t) size_a / CHAR_BIT + 1; 2027
3154 ptrdiff_t ins_bytes = (size_t) size_b / CHAR_BIT + 1; 2028 /* FIXME: It is not documented how to initialize the contents of the
2029 context structure. This code cargo-cults from the existing
2030 caller in src/analyze.c of GNU Diffutils, which appears to
2031 work. */
3155 struct context ctx = { 2032 struct context ctx = {
3156 .buffer_a = a, 2033 .buffer_a = a,
3157 .buffer_b = b, 2034 .buffer_b = b,
3158 .deletions = SAFE_ALLOCA (del_bytes), 2035 .beg_a = min_a,
3159 .insertions = SAFE_ALLOCA (ins_bytes), 2036 .beg_b = min_b,
2037 .a_unibyte = BUF_ZV (a) == BUF_ZV_BYTE (a),
2038 .b_unibyte = BUF_ZV (b) == BUF_ZV_BYTE (b),
2039 .deletions = deletions_insertions,
2040 .insertions = deletions_insertions + del_bytes,
3160 .fdiag = buffer + size_b + 1, 2041 .fdiag = buffer + size_b + 1,
3161 .bdiag = buffer + diags + size_b + 1, 2042 .bdiag = buffer + diags + size_b + 1,
3162 /* FIXME: Find a good number for .too_expensive. */ 2043 .heuristic = true,
3163 .too_expensive = 1000000, 2044 .too_expensive = too_expensive,
2045 .time_limit = time_limit,
3164 }; 2046 };
3165 memclear (ctx.deletions, del_bytes); 2047
3166 memclear (ctx.insertions, ins_bytes);
3167 /* compareseq requires indices to be zero-based. We add BEGV back 2048 /* compareseq requires indices to be zero-based. We add BEGV back
3168 later. */ 2049 later. */
3169 bool early_abort = compareseq (0, size_a, 0, size_b, false, &ctx); 2050 bool early_abort;
3170 /* Since we didn’t define EARLY_ABORT, we should never abort 2051 if (! sys_setjmp (ctx.jmp))
3171 early. */ 2052 early_abort = compareseq (0, size_a, 0, size_b, false, &ctx);
3172 eassert (! early_abort); 2053 else
3173 SAFE_FREE (); 2054 early_abort = true;
2055
2056 if (early_abort)
2057 {
2058 del_range (min_a, ZV);
2059 Finsert_buffer_substring (source, Qnil,Qnil);
2060 SAFE_FREE_UNBIND_TO (count, Qnil);
2061 return Qnil;
2062 }
3174 2063
3175 Fundo_boundary (); 2064 Fundo_boundary ();
3176 ptrdiff_t count = SPECPDL_INDEX (); 2065 bool modification_hooks_inhibited = false;
3177 record_unwind_protect (save_excursion_restore, save_excursion_save ()); 2066 record_unwind_protect_excursion ();
2067
2068 /* We are going to make a lot of small modifications, and having the
2069 modification hooks called for each of them will slow us down.
2070 Instead, we announce a single modification for the entire
2071 modified region. But don't do that if the caller inhibited
2072 modification hooks, because then they don't want that. */
2073 if (!inhibit_modification_hooks)
2074 {
2075 prepare_to_modify_buffer (BEGV, ZV, NULL);
2076 specbind (Qinhibit_modification_hooks, Qt);
2077 modification_hooks_inhibited = true;
2078 }
3178 2079
3179 ptrdiff_t i = size_a; 2080 ptrdiff_t i = size_a;
3180 ptrdiff_t j = size_b; 2081 ptrdiff_t j = size_b;
@@ -3183,10 +2084,12 @@ buffer stay intact. */)
3183 walk backwards, we don’t have to keep the positions in sync. */ 2084 walk backwards, we don’t have to keep the positions in sync. */
3184 while (i >= 0 || j >= 0) 2085 while (i >= 0 || j >= 0)
3185 { 2086 {
2087 rarely_quit (++ctx.quitcounter);
2088
3186 /* Check whether there is a change (insertion or deletion) 2089 /* Check whether there is a change (insertion or deletion)
3187 before the current position. */ 2090 before the current position. */
3188 if ((i > 0 && bit_is_set (ctx.deletions, i - 1)) || 2091 if ((i > 0 && bit_is_set (ctx.deletions, i - 1))
3189 (j > 0 && bit_is_set (ctx.insertions, j - 1))) 2092 || (j > 0 && bit_is_set (ctx.insertions, j - 1)))
3190 { 2093 {
3191 ptrdiff_t end_a = min_a + i; 2094 ptrdiff_t end_a = min_a + i;
3192 ptrdiff_t end_b = min_b + j; 2095 ptrdiff_t end_b = min_b + j;
@@ -3195,72 +2098,111 @@ buffer stay intact. */)
3195 --i; 2098 --i;
3196 while (j > 0 && bit_is_set (ctx.insertions, j - 1)) 2099 while (j > 0 && bit_is_set (ctx.insertions, j - 1))
3197 --j; 2100 --j;
2101
3198 ptrdiff_t beg_a = min_a + i; 2102 ptrdiff_t beg_a = min_a + i;
3199 ptrdiff_t beg_b = min_b + j; 2103 ptrdiff_t beg_b = min_b + j;
3200 eassert (beg_a >= BEGV);
3201 eassert (beg_b >= BUF_BEGV (b));
3202 eassert (beg_a <= end_a); 2104 eassert (beg_a <= end_a);
3203 eassert (beg_b <= end_b); 2105 eassert (beg_b <= end_b);
3204 eassert (end_a <= ZV);
3205 eassert (end_b <= BUF_ZV (b));
3206 eassert (beg_a < end_a || beg_b < end_b); 2106 eassert (beg_a < end_a || beg_b < end_b);
3207 if (beg_a < end_a) 2107 if (beg_a < end_a)
3208 del_range (beg_a, end_a); 2108 del_range (beg_a, end_a);
3209 if (beg_b < end_b) 2109 if (beg_b < end_b)
3210 { 2110 {
3211 SET_PT (beg_a); 2111 SET_PT (beg_a);
3212 Finsert_buffer_substring (source, make_natnum (beg_b), 2112 Finsert_buffer_substring (source, make_fixed_natnum (beg_b),
3213 make_natnum (end_b)); 2113 make_fixed_natnum (end_b));
3214 } 2114 }
3215 } 2115 }
3216 --i; 2116 --i;
3217 --j; 2117 --j;
3218 } 2118 }
3219 2119
3220 return unbind_to (count, Qnil); 2120 SAFE_FREE_UNBIND_TO (count, Qnil);
2121
2122 if (modification_hooks_inhibited)
2123 {
2124 signal_after_change (BEGV, size_a, ZV - BEGV);
2125 update_compositions (BEGV, ZV, CHECK_INSIDE);
2126 /* We've locked the buffer's file above in
2127 prepare_to_modify_buffer; if the buffer is unchanged at this
2128 point, i.e. no insertions or deletions have been made, unlock
2129 the file now. */
2130 if (SAVE_MODIFF == MODIFF
2131 && STRINGP (BVAR (a, file_truename)))
2132 Funlock_file (BVAR (a, file_truename));
2133 }
2134
2135 return Qt;
3221} 2136}
3222 2137
3223static void 2138static void
3224set_bit (unsigned char *a, ptrdiff_t i) 2139set_bit (unsigned char *a, ptrdiff_t i)
3225{ 2140{
3226 eassert (i >= 0); 2141 eassume (0 <= i);
3227 /* Micro-optimization: Casting to size_t generates much better 2142 a[i / CHAR_BIT] |= (1 << (i % CHAR_BIT));
3228 code. */
3229 size_t j = i;
3230 a[j / CHAR_BIT] |= (1 << (j % CHAR_BIT));
3231} 2143}
3232 2144
3233static bool 2145static bool
3234bit_is_set (const unsigned char *a, ptrdiff_t i) 2146bit_is_set (const unsigned char *a, ptrdiff_t i)
3235{ 2147{
3236 eassert (i >= 0); 2148 eassume (0 <= i);
3237 /* Micro-optimization: Casting to size_t generates much better 2149 return a[i / CHAR_BIT] & (1 << (i % CHAR_BIT));
3238 code. */
3239 size_t j = i;
3240 return a[j / CHAR_BIT] & (1 << (j % CHAR_BIT));
3241} 2150}
3242 2151
3243/* Return true if the characters at position POS_A of buffer 2152/* Return true if the characters at position POS_A of buffer
3244 CTX->buffer_a and at position POS_B of buffer CTX->buffer_b are 2153 CTX->buffer_a and at position POS_B of buffer CTX->buffer_b are
3245 equal. POS_A and POS_B are zero-based. Text properties are 2154 equal. POS_A and POS_B are zero-based. Text properties are
3246 ignored. */ 2155 ignored.
2156
2157 Implementation note: this function is called inside the inner-most
2158 loops of compareseq, so it absolutely must be optimized for speed,
2159 every last bit of it. E.g., each additional use of BEGV or such
2160 likes will slow down replace-buffer-contents by dozens of percents,
2161 because builtin_lisp_symbol will be called one more time in the
2162 innermost loop. */
3247 2163
3248static bool 2164static bool
3249buffer_chars_equal (struct context *ctx, 2165buffer_chars_equal (struct context *ctx,
3250 ptrdiff_t pos_a, ptrdiff_t pos_b) 2166 ptrdiff_t pos_a, ptrdiff_t pos_b)
3251{ 2167{
3252 eassert (pos_a >= 0); 2168 if (!++ctx->quitcounter)
3253 pos_a += BUF_BEGV (ctx->buffer_a); 2169 {
3254 eassert (pos_a >= BUF_BEGV (ctx->buffer_a)); 2170 maybe_quit ();
3255 eassert (pos_a < BUF_ZV (ctx->buffer_a)); 2171 if (compareseq_early_abort (ctx))
3256 2172 sys_longjmp (ctx->jmp, 1);
3257 eassert (pos_b >= 0); 2173 }
3258 pos_b += BUF_BEGV (ctx->buffer_b); 2174
3259 eassert (pos_b >= BUF_BEGV (ctx->buffer_b)); 2175 pos_a += ctx->beg_a;
3260 eassert (pos_b < BUF_ZV (ctx->buffer_b)); 2176 pos_b += ctx->beg_b;
3261 2177
3262 return BUF_FETCH_CHAR_AS_MULTIBYTE (ctx->buffer_a, pos_a) 2178 ptrdiff_t bpos_a =
3263 == BUF_FETCH_CHAR_AS_MULTIBYTE (ctx->buffer_b, pos_b); 2179 ctx->a_unibyte ? pos_a : buf_charpos_to_bytepos (ctx->buffer_a, pos_a);
2180 ptrdiff_t bpos_b =
2181 ctx->b_unibyte ? pos_b : buf_charpos_to_bytepos (ctx->buffer_b, pos_b);
2182
2183 /* We make the below a series of specific test to avoid using
2184 BUF_FETCH_CHAR_AS_MULTIBYTE, which references Lisp symbols, and
2185 is therefore significantly slower (see the note in the commentary
2186 to this function). */
2187 if (ctx->a_unibyte && ctx->b_unibyte)
2188 return BUF_FETCH_BYTE (ctx->buffer_a, bpos_a)
2189 == BUF_FETCH_BYTE (ctx->buffer_b, bpos_b);
2190 if (ctx->a_unibyte && !ctx->b_unibyte)
2191 return UNIBYTE_TO_CHAR (BUF_FETCH_BYTE (ctx->buffer_a, bpos_a))
2192 == BUF_FETCH_MULTIBYTE_CHAR (ctx->buffer_b, bpos_b);
2193 if (!ctx->a_unibyte && ctx->b_unibyte)
2194 return BUF_FETCH_MULTIBYTE_CHAR (ctx->buffer_a, bpos_a)
2195 == UNIBYTE_TO_CHAR (BUF_FETCH_BYTE (ctx->buffer_b, bpos_b));
2196 return BUF_FETCH_MULTIBYTE_CHAR (ctx->buffer_a, bpos_a)
2197 == BUF_FETCH_MULTIBYTE_CHAR (ctx->buffer_b, bpos_b);
2198}
2199
2200static bool
2201compareseq_early_abort (struct context *ctx)
2202{
2203 if (ctx->time_limit.tv_nsec < 0)
2204 return false;
2205 return timespec_cmp (ctx->time_limit, current_timespec ()) < 0;
3264} 2206}
3265 2207
3266 2208
@@ -3292,7 +2234,7 @@ Both characters must have the same length of multi-byte form. */)
3292 ptrdiff_t changed = 0; 2234 ptrdiff_t changed = 0;
3293 unsigned char fromstr[MAX_MULTIBYTE_LENGTH], tostr[MAX_MULTIBYTE_LENGTH]; 2235 unsigned char fromstr[MAX_MULTIBYTE_LENGTH], tostr[MAX_MULTIBYTE_LENGTH];
3294 unsigned char *p; 2236 unsigned char *p;
3295 ptrdiff_t count = SPECPDL_INDEX (); 2237 specpdl_ref count = SPECPDL_INDEX ();
3296#define COMBINING_NO 0 2238#define COMBINING_NO 0
3297#define COMBINING_BEFORE 1 2239#define COMBINING_BEFORE 1
3298#define COMBINING_AFTER 2 2240#define COMBINING_AFTER 2
@@ -3308,8 +2250,8 @@ Both characters must have the same length of multi-byte form. */)
3308 validate_region (&start, &end); 2250 validate_region (&start, &end);
3309 CHECK_CHARACTER (fromchar); 2251 CHECK_CHARACTER (fromchar);
3310 CHECK_CHARACTER (tochar); 2252 CHECK_CHARACTER (tochar);
3311 fromc = XFASTINT (fromchar); 2253 fromc = XFIXNAT (fromchar);
3312 toc = XFASTINT (tochar); 2254 toc = XFIXNAT (tochar);
3313 2255
3314 if (multibyte_p) 2256 if (multibyte_p)
3315 { 2257 {
@@ -3335,9 +2277,9 @@ Both characters must have the same length of multi-byte form. */)
3335 tostr[0] = toc; 2277 tostr[0] = toc;
3336 } 2278 }
3337 2279
3338 pos = XINT (start); 2280 pos = XFIXNUM (start);
3339 pos_byte = CHAR_TO_BYTE (pos); 2281 pos_byte = CHAR_TO_BYTE (pos);
3340 stop = CHAR_TO_BYTE (XINT (end)); 2282 stop = CHAR_TO_BYTE (XFIXNUM (end));
3341 end_byte = stop; 2283 end_byte = stop;
3342 2284
3343 /* If we don't want undo, turn off putting stuff on the list. 2285 /* If we don't want undo, turn off putting stuff on the list.
@@ -3368,7 +2310,7 @@ Both characters must have the same length of multi-byte form. */)
3368 } 2310 }
3369 p = BYTE_POS_ADDR (pos_byte); 2311 p = BYTE_POS_ADDR (pos_byte);
3370 if (multibyte_p) 2312 if (multibyte_p)
3371 INC_POS (pos_byte_next); 2313 pos_byte_next += next_char_len (pos_byte_next);
3372 else 2314 else
3373 ++pos_byte_next; 2315 ++pos_byte_next;
3374 if (pos_byte_next - pos_byte == len 2316 if (pos_byte_next - pos_byte == len
@@ -3385,14 +2327,15 @@ Both characters must have the same length of multi-byte form. */)
3385 else if (!changed) 2327 else if (!changed)
3386 { 2328 {
3387 changed = -1; 2329 changed = -1;
3388 modify_text (pos, XINT (end)); 2330 modify_text (pos, XFIXNUM (end));
3389 2331
3390 if (! NILP (noundo)) 2332 if (! NILP (noundo))
3391 { 2333 {
3392 if (MODIFF - 1 == SAVE_MODIFF) 2334 modiff_count m = MODIFF;
3393 SAVE_MODIFF++; 2335 if (SAVE_MODIFF == m - 1)
3394 if (MODIFF - 1 == BUF_AUTOSAVE_MODIFF (current_buffer)) 2336 SAVE_MODIFF = m;
3395 BUF_AUTOSAVE_MODIFF (current_buffer)++; 2337 if (BUF_AUTOSAVE_MODIFF (current_buffer) == m - 1)
2338 BUF_AUTOSAVE_MODIFF (current_buffer) = m;
3396 } 2339 }
3397 2340
3398 /* The before-change-function may have moved the gap 2341 /* The before-change-function may have moved the gap
@@ -3420,7 +2363,7 @@ Both characters must have the same length of multi-byte form. */)
3420 /* replace_range is less efficient, because it moves the gap, 2363 /* replace_range is less efficient, because it moves the gap,
3421 but it handles combining correctly. */ 2364 but it handles combining correctly. */
3422 replace_range (pos, pos + 1, string, 2365 replace_range (pos, pos + 1, string,
3423 0, 0, 1, 0); 2366 false, false, true, false, false);
3424 pos_byte_next = CHAR_TO_BYTE (pos); 2367 pos_byte_next = CHAR_TO_BYTE (pos);
3425 if (pos_byte_next > pos_byte) 2368 if (pos_byte_next > pos_byte)
3426 /* Before combining happened. We should not increment 2369 /* Before combining happened. We should not increment
@@ -3428,7 +2371,7 @@ Both characters must have the same length of multi-byte form. */)
3428 decrease it now. */ 2371 decrease it now. */
3429 pos--; 2372 pos--;
3430 else 2373 else
3431 INC_POS (pos_byte_next); 2374 pos_byte_next += next_char_len (pos_byte_next);
3432 2375
3433 if (! NILP (noundo)) 2376 if (! NILP (noundo))
3434 bset_undo_list (current_buffer, tem); 2377 bset_undo_list (current_buffer, tem);
@@ -3452,8 +2395,7 @@ Both characters must have the same length of multi-byte form. */)
3452 update_compositions (changed, last_changed, CHECK_ALL); 2395 update_compositions (changed, last_changed, CHECK_ALL);
3453 } 2396 }
3454 2397
3455 unbind_to (count, Qnil); 2398 return unbind_to (count, Qnil);
3456 return Qnil;
3457} 2399}
3458 2400
3459 2401
@@ -3506,10 +2448,10 @@ check_translation (ptrdiff_t pos, ptrdiff_t pos_byte, ptrdiff_t end,
3506 memcpy (bufalloc, buf, sizeof initial_buf); 2448 memcpy (bufalloc, buf, sizeof initial_buf);
3507 buf = bufalloc; 2449 buf = bufalloc;
3508 } 2450 }
3509 buf[buf_used++] = STRING_CHAR_AND_LENGTH (p, len1); 2451 buf[buf_used++] = string_char_and_length (p, &len1);
3510 pos_byte += len1; 2452 pos_byte += len1;
3511 } 2453 }
3512 if (XINT (AREF (elt, i)) != buf[i]) 2454 if (XFIXNUM (AREF (elt, i)) != buf[i])
3513 break; 2455 break;
3514 } 2456 }
3515 if (i == len) 2457 if (i == len)
@@ -3532,64 +2474,57 @@ From START to END, translate characters according to TABLE.
3532TABLE is a string or a char-table; the Nth character in it is the 2474TABLE is a string or a char-table; the Nth character in it is the
3533mapping for the character with code N. 2475mapping for the character with code N.
3534It returns the number of characters changed. */) 2476It returns the number of characters changed. */)
3535 (Lisp_Object start, Lisp_Object end, register Lisp_Object table) 2477 (Lisp_Object start, Lisp_Object end, Lisp_Object table)
3536{ 2478{
3537 register unsigned char *tt; /* Trans table. */ 2479 int translatable_chars = MAX_CHAR + 1;
3538 register int nc; /* New character. */
3539 int cnt; /* Number of changes made. */
3540 ptrdiff_t size; /* Size of translate table. */
3541 ptrdiff_t pos, pos_byte, end_pos;
3542 bool multibyte = !NILP (BVAR (current_buffer, enable_multibyte_characters)); 2480 bool multibyte = !NILP (BVAR (current_buffer, enable_multibyte_characters));
3543 bool string_multibyte UNINIT; 2481 bool string_multibyte UNINIT;
3544 2482
3545 validate_region (&start, &end); 2483 validate_region (&start, &end);
3546 if (CHAR_TABLE_P (table)) 2484 if (STRINGP (table))
3547 {
3548 if (! EQ (XCHAR_TABLE (table)->purpose, Qtranslation_table))
3549 error ("Not a translation table");
3550 size = MAX_CHAR;
3551 tt = NULL;
3552 }
3553 else
3554 { 2485 {
3555 CHECK_STRING (table); 2486 if (! multibyte)
3556
3557 if (! multibyte && (SCHARS (table) < SBYTES (table)))
3558 table = string_make_unibyte (table); 2487 table = string_make_unibyte (table);
3559 string_multibyte = SCHARS (table) < SBYTES (table); 2488 translatable_chars = min (translatable_chars, SBYTES (table));
3560 size = SBYTES (table); 2489 string_multibyte = STRING_MULTIBYTE (table);
3561 tt = SDATA (table);
3562 } 2490 }
2491 else if (! (CHAR_TABLE_P (table)
2492 && EQ (XCHAR_TABLE (table)->purpose, Qtranslation_table)))
2493 error ("Not a translation table");
3563 2494
3564 pos = XINT (start); 2495 ptrdiff_t pos = XFIXNUM (start);
3565 pos_byte = CHAR_TO_BYTE (pos); 2496 ptrdiff_t pos_byte = CHAR_TO_BYTE (pos);
3566 end_pos = XINT (end); 2497 ptrdiff_t end_pos = XFIXNUM (end);
3567 modify_text (pos, end_pos); 2498 modify_text (pos, end_pos);
3568 2499
3569 cnt = 0; 2500 ptrdiff_t characters_changed = 0;
3570 for (; pos < end_pos; ) 2501
2502 while (pos < end_pos)
3571 { 2503 {
3572 unsigned char *p = BYTE_POS_ADDR (pos_byte); 2504 unsigned char *p = BYTE_POS_ADDR (pos_byte);
3573 unsigned char *str UNINIT; 2505 unsigned char *str UNINIT;
3574 unsigned char buf[MAX_MULTIBYTE_LENGTH]; 2506 unsigned char buf[MAX_MULTIBYTE_LENGTH];
3575 int len, str_len; 2507 int len, oc;
3576 int oc;
3577 Lisp_Object val;
3578 2508
3579 if (multibyte) 2509 if (multibyte)
3580 oc = STRING_CHAR_AND_LENGTH (p, len); 2510 oc = string_char_and_length (p, &len);
3581 else 2511 else
3582 oc = *p, len = 1; 2512 oc = *p, len = 1;
3583 if (oc < size) 2513 if (oc < translatable_chars)
3584 { 2514 {
3585 if (tt) 2515 int nc; /* New character. */
2516 int str_len UNINIT;
2517 Lisp_Object val;
2518
2519 if (STRINGP (table))
3586 { 2520 {
3587 /* Reload as signal_after_change in last iteration may GC. */ 2521 /* Reload as signal_after_change in last iteration may GC. */
3588 tt = SDATA (table); 2522 unsigned char *tt = SDATA (table);
2523
3589 if (string_multibyte) 2524 if (string_multibyte)
3590 { 2525 {
3591 str = tt + string_char_to_byte (table, oc); 2526 str = tt + string_char_to_byte (table, oc);
3592 nc = STRING_CHAR_AND_LENGTH (str, str_len); 2527 nc = string_char_and_length (str, &str_len);
3593 } 2528 }
3594 else 2529 else
3595 { 2530 {
@@ -3612,7 +2547,7 @@ It returns the number of characters changed. */)
3612 val = CHAR_TABLE_REF (table, oc); 2547 val = CHAR_TABLE_REF (table, oc);
3613 if (CHARACTERP (val)) 2548 if (CHARACTERP (val))
3614 { 2549 {
3615 nc = XFASTINT (val); 2550 nc = XFIXNAT (val);
3616 str_len = CHAR_STRING (nc, buf); 2551 str_len = CHAR_STRING (nc, buf);
3617 str = buf; 2552 str = buf;
3618 } 2553 }
@@ -3634,7 +2569,8 @@ It returns the number of characters changed. */)
3634 /* This is less efficient, because it moves the gap, 2569 /* This is less efficient, because it moves the gap,
3635 but it should handle multibyte characters correctly. */ 2570 but it should handle multibyte characters correctly. */
3636 string = make_multibyte_string ((char *) str, 1, str_len); 2571 string = make_multibyte_string ((char *) str, 1, str_len);
3637 replace_range (pos, pos + 1, string, 1, 0, 1, 0); 2572 replace_range (pos, pos + 1, string,
2573 true, false, true, false, false);
3638 len = str_len; 2574 len = str_len;
3639 } 2575 }
3640 else 2576 else
@@ -3645,12 +2581,10 @@ It returns the number of characters changed. */)
3645 signal_after_change (pos, 1, 1); 2581 signal_after_change (pos, 1, 1);
3646 update_compositions (pos, pos + 1, CHECK_BORDER); 2582 update_compositions (pos, pos + 1, CHECK_BORDER);
3647 } 2583 }
3648 ++cnt; 2584 characters_changed++;
3649 } 2585 }
3650 else if (nc < 0) 2586 else if (nc < 0)
3651 { 2587 {
3652 Lisp_Object string;
3653
3654 if (CONSP (val)) 2588 if (CONSP (val))
3655 { 2589 {
3656 val = check_translation (pos, pos_byte, end_pos, val); 2590 val = check_translation (pos, pos_byte, end_pos, val);
@@ -3667,18 +2601,15 @@ It returns the number of characters changed. */)
3667 else 2601 else
3668 len = 1; 2602 len = 1;
3669 2603
3670 if (VECTORP (val)) 2604 Lisp_Object string
3671 { 2605 = (VECTORP (val)
3672 string = Fconcat (1, &val); 2606 ? Fconcat (1, &val)
3673 } 2607 : Fmake_string (make_fixnum (1), val, Qnil));
3674 else 2608 replace_range (pos, pos + len, string, true, false, true, false,
3675 { 2609 false);
3676 string = Fmake_string (make_number (1), val);
3677 }
3678 replace_range (pos, pos + len, string, 1, 0, 1, 0);
3679 pos_byte += SBYTES (string); 2610 pos_byte += SBYTES (string);
3680 pos += SCHARS (string); 2611 pos += SCHARS (string);
3681 cnt += SCHARS (string); 2612 characters_changed += SCHARS (string);
3682 end_pos += SCHARS (string) - len; 2613 end_pos += SCHARS (string) - len;
3683 continue; 2614 continue;
3684 } 2615 }
@@ -3687,7 +2618,7 @@ It returns the number of characters changed. */)
3687 pos++; 2618 pos++;
3688 } 2619 }
3689 2620
3690 return make_number (cnt); 2621 return make_fixnum (characters_changed);
3691} 2622}
3692 2623
3693DEFUN ("delete-region", Fdelete_region, Sdelete_region, 2, 2, "r", 2624DEFUN ("delete-region", Fdelete_region, Sdelete_region, 2, 2, "r",
@@ -3697,7 +2628,7 @@ This command deletes buffer text without modifying the kill ring. */)
3697 (Lisp_Object start, Lisp_Object end) 2628 (Lisp_Object start, Lisp_Object end)
3698{ 2629{
3699 validate_region (&start, &end); 2630 validate_region (&start, &end);
3700 del_range (XINT (start), XINT (end)); 2631 del_range (XFIXNUM (start), XFIXNUM (end));
3701 return Qnil; 2632 return Qnil;
3702} 2633}
3703 2634
@@ -3707,16 +2638,24 @@ DEFUN ("delete-and-extract-region", Fdelete_and_extract_region,
3707 (Lisp_Object start, Lisp_Object end) 2638 (Lisp_Object start, Lisp_Object end)
3708{ 2639{
3709 validate_region (&start, &end); 2640 validate_region (&start, &end);
3710 if (XINT (start) == XINT (end)) 2641 if (XFIXNUM (start) == XFIXNUM (end))
3711 return empty_unibyte_string; 2642 return empty_unibyte_string;
3712 return del_range_1 (XINT (start), XINT (end), 1, 1); 2643 return del_range_1 (XFIXNUM (start), XFIXNUM (end), 1, 1);
3713} 2644}
3714 2645
3715DEFUN ("widen", Fwiden, Swiden, 0, 0, "", 2646DEFUN ("widen", Fwiden, Swiden, 0, 0, "",
3716 doc: /* Remove restrictions (narrowing) from current buffer. 2647 doc: /* Remove restrictions (narrowing) from current buffer.
3717This allows the buffer's full text to be seen and edited. */) 2648This allows the buffer's full text to be seen and edited.
2649
2650Note that, when the current buffer contains one or more lines whose
2651length is above `long-line-threshold', Emacs may decide to leave, for
2652performance reasons, the accessible portion of the buffer unchanged
2653after this function is called from low-level hooks, such as
2654`jit-lock-functions' or `post-command-hook'. */)
3718 (void) 2655 (void)
3719{ 2656{
2657 if (! NILP (Vrestrictions_locked))
2658 return Qnil;
3720 if (BEG != BEGV || Z != ZV) 2659 if (BEG != BEGV || Z != ZV)
3721 current_buffer->clip_changed = 1; 2660 current_buffer->clip_changed = 1;
3722 BEGV = BEG; 2661 BEGV = BEG;
@@ -3727,43 +2666,91 @@ This allows the buffer's full text to be seen and edited. */)
3727 return Qnil; 2666 return Qnil;
3728} 2667}
3729 2668
3730DEFUN ("narrow-to-region", Fnarrow_to_region, Snarrow_to_region, 2, 2, "r", 2669static void
3731 doc: /* Restrict editing in this buffer to the current region. 2670unwind_locked_begv (Lisp_Object point_min)
3732The rest of the text becomes temporarily invisible and untouchable 2671{
3733but is not deleted; if you save the buffer in a file, the invisible 2672 SET_BUF_BEGV (current_buffer, XFIXNUM (point_min));
3734text is included in the file. \\[widen] makes all visible again. 2673}
3735See also `save-restriction'.
3736 2674
3737When calling from a program, pass two arguments; positions (integers 2675static void
3738or markers) bounding the text that should remain visible. */) 2676unwind_locked_zv (Lisp_Object point_max)
3739 (register Lisp_Object start, Lisp_Object end)
3740{ 2677{
3741 CHECK_NUMBER_COERCE_MARKER (start); 2678 SET_BUF_ZV (current_buffer, XFIXNUM (point_max));
3742 CHECK_NUMBER_COERCE_MARKER (end); 2679}
3743 2680
3744 if (XINT (start) > XINT (end)) 2681/* Internal function for Fnarrow_to_region, meant to be used with a
2682 third argument 'true', in which case it should be followed by "specbind
2683 (Qrestrictions_locked, Qt)". */
2684Lisp_Object
2685narrow_to_region_internal (Lisp_Object start, Lisp_Object end, bool lock)
2686{
2687 EMACS_INT s = fix_position (start), e = fix_position (end);
2688
2689 if (e < s)
3745 { 2690 {
3746 Lisp_Object tem; 2691 EMACS_INT tem = s; s = e; e = tem;
3747 tem = start; start = end; end = tem;
3748 } 2692 }
3749 2693
3750 if (!(BEG <= XINT (start) && XINT (start) <= XINT (end) && XINT (end) <= Z)) 2694 if (lock)
3751 args_out_of_range (start, end); 2695 {
2696 if (!(BEGV <= s && s <= e && e <= ZV))
2697 args_out_of_range (start, end);
3752 2698
3753 if (BEGV != XFASTINT (start) || ZV != XFASTINT (end)) 2699 if (BEGV != s || ZV != e)
3754 current_buffer->clip_changed = 1; 2700 current_buffer->clip_changed = 1;
2701
2702 record_unwind_protect (restore_point_unwind, Fpoint_marker ());
2703 record_unwind_protect (unwind_locked_begv, Fpoint_min ());
2704 record_unwind_protect (unwind_locked_zv, Fpoint_max ());
2705
2706 SET_BUF_BEGV (current_buffer, s);
2707 SET_BUF_ZV (current_buffer, e);
2708 }
2709 else
2710 {
2711 if (! NILP (Vrestrictions_locked))
2712 return Qnil;
2713
2714 if (!(BEG <= s && s <= e && e <= Z))
2715 args_out_of_range (start, end);
2716
2717 if (BEGV != s || ZV != e)
2718 current_buffer->clip_changed = 1;
3755 2719
3756 SET_BUF_BEGV (current_buffer, XFASTINT (start)); 2720 SET_BUF_BEGV (current_buffer, s);
3757 SET_BUF_ZV (current_buffer, XFASTINT (end)); 2721 SET_BUF_ZV (current_buffer, e);
3758 if (PT < XFASTINT (start)) 2722 }
3759 SET_PT (XFASTINT (start)); 2723
3760 if (PT > XFASTINT (end)) 2724 if (PT < s)
3761 SET_PT (XFASTINT (end)); 2725 SET_PT (s);
2726 if (e < PT)
2727 SET_PT (e);
3762 /* Changing the buffer bounds invalidates any recorded current column. */ 2728 /* Changing the buffer bounds invalidates any recorded current column. */
3763 invalidate_current_column (); 2729 invalidate_current_column ();
3764 return Qnil; 2730 return Qnil;
3765} 2731}
3766 2732
2733DEFUN ("narrow-to-region", Fnarrow_to_region, Snarrow_to_region, 2, 2, "r",
2734 doc: /* Restrict editing in this buffer to the current region.
2735The rest of the text becomes temporarily invisible and untouchable
2736but is not deleted; if you save the buffer in a file, the invisible
2737text is included in the file. \\[widen] makes all visible again.
2738See also `save-restriction'.
2739
2740When calling from Lisp, pass two arguments START and END:
2741positions (integers or markers) bounding the text that should
2742remain visible.
2743
2744Note that, when the current buffer contains one or more lines whose
2745length is above `long-line-threshold', Emacs may decide to leave, for
2746performance reasons, the accessible portion of the buffer unchanged
2747after this function is called from low-level hooks, such as
2748`jit-lock-functions' or `post-command-hook'. */)
2749 (Lisp_Object start, Lisp_Object end)
2750{
2751 return narrow_to_region_internal (start, end, false);
2752}
2753
3767Lisp_Object 2754Lisp_Object
3768save_restriction_save (void) 2755save_restriction_save (void)
3769{ 2756{
@@ -3831,9 +2818,9 @@ save_restriction_restore (Lisp_Object data)
3831 2818
3832 buf->clip_changed = 1; /* Remember that the narrowing changed. */ 2819 buf->clip_changed = 1; /* Remember that the narrowing changed. */
3833 } 2820 }
3834 /* These aren't needed anymore, so don't wait for GC. */ 2821 /* Detach the markers, and free the cons instead of waiting for GC. */
3835 free_marker (XCAR (data)); 2822 detach_marker (XCAR (data));
3836 free_marker (XCDR (data)); 2823 detach_marker (XCDR (data));
3837 free_cons (XCONS (data)); 2824 free_cons (XCONS (data));
3838 } 2825 }
3839 else 2826 else
@@ -3877,13 +2864,32 @@ usage: (save-restriction &rest BODY) */)
3877 (Lisp_Object body) 2864 (Lisp_Object body)
3878{ 2865{
3879 register Lisp_Object val; 2866 register Lisp_Object val;
3880 ptrdiff_t count = SPECPDL_INDEX (); 2867 specpdl_ref count = SPECPDL_INDEX ();
3881 2868
3882 record_unwind_protect (save_restriction_restore, save_restriction_save ()); 2869 record_unwind_protect (save_restriction_restore, save_restriction_save ());
3883 val = Fprogn (body); 2870 val = Fprogn (body);
3884 return unbind_to (count, val); 2871 return unbind_to (count, val);
3885} 2872}
3886 2873
2874/* i18n (internationalization). */
2875
2876DEFUN ("ngettext", Fngettext, Sngettext, 3, 3, 0,
2877 doc: /* Return the translation of MSGID (plural MSGID-PLURAL) depending on N.
2878MSGID is the singular form of the string to be converted;
2879use it as the key for the search in the translation catalog.
2880MSGID-PLURAL is the plural form. Use N to select the proper translation.
2881If no message catalog is found, MSGID is returned if N is equal to 1,
2882otherwise MSGID-PLURAL. */)
2883 (Lisp_Object msgid, Lisp_Object msgid_plural, Lisp_Object n)
2884{
2885 CHECK_STRING (msgid);
2886 CHECK_STRING (msgid_plural);
2887 CHECK_INTEGER (n);
2888
2889 /* Placeholder implementation until we get our act together. */
2890 return BASE_EQ (n, make_fixnum (1)) ? msgid : msgid_plural;
2891}
2892
3887DEFUN ("message", Fmessage, Smessage, 1, MANY, 0, 2893DEFUN ("message", Fmessage, Smessage, 1, MANY, 0,
3888 doc: /* Display a message at the bottom of the screen. 2894 doc: /* Display a message at the bottom of the screen.
3889The message also goes into the `*Messages*' buffer, if `message-log-max' 2895The message also goes into the `*Messages*' buffer, if `message-log-max'
@@ -3915,7 +2921,7 @@ usage: (message FORMAT-STRING &rest ARGS) */)
3915 } 2921 }
3916 else 2922 else
3917 { 2923 {
3918 Lisp_Object val = styled_format (nargs, args, true, false); 2924 Lisp_Object val = Fformat_message (nargs, args);
3919 message3 (val); 2925 message3 (val);
3920 return val; 2926 return val;
3921 } 2927 }
@@ -3941,7 +2947,7 @@ usage: (message-box FORMAT-STRING &rest ARGS) */)
3941 } 2947 }
3942 else 2948 else
3943 { 2949 {
3944 Lisp_Object val = styled_format (nargs, args, true, false); 2950 Lisp_Object val = Fformat_message (nargs, args);
3945 Lisp_Object pane, menu; 2951 Lisp_Object pane, menu;
3946 2952
3947 pane = list1 (Fcons (build_string ("OK"), Qt)); 2953 pane = list1 (Fcons (build_string ("OK"), Qt));
@@ -3985,6 +2991,8 @@ DEFUN ("propertize", Fpropertize, Spropertize, 1, MANY, 0,
3985First argument is the string to copy. 2991First argument is the string to copy.
3986Remaining arguments form a sequence of PROPERTY VALUE pairs for text 2992Remaining arguments form a sequence of PROPERTY VALUE pairs for text
3987properties to add to the result. 2993properties to add to the result.
2994
2995See Info node `(elisp) Text Properties' for more information.
3988usage: (propertize STRING &rest PROPERTIES) */) 2996usage: (propertize STRING &rest PROPERTIES) */)
3989 (ptrdiff_t nargs, Lisp_Object *args) 2997 (ptrdiff_t nargs, Lisp_Object *args)
3990{ 2998{
@@ -3993,7 +3001,7 @@ usage: (propertize STRING &rest PROPERTIES) */)
3993 3001
3994 /* Number of args must be odd. */ 3002 /* Number of args must be odd. */
3995 if ((nargs & 1) == 0) 3003 if ((nargs & 1) == 0)
3996 error ("Wrong number of arguments"); 3004 xsignal2 (Qwrong_number_of_arguments, Qpropertize, make_fixnum (nargs));
3997 3005
3998 properties = string = Qnil; 3006 properties = string = Qnil;
3999 3007
@@ -4004,8 +3012,8 @@ usage: (propertize STRING &rest PROPERTIES) */)
4004 for (i = 1; i < nargs; i += 2) 3012 for (i = 1; i < nargs; i += 2)
4005 properties = Fcons (args[i], Fcons (args[i + 1], properties)); 3013 properties = Fcons (args[i], Fcons (args[i + 1], properties));
4006 3014
4007 Fadd_text_properties (make_number (0), 3015 Fadd_text_properties (make_fixnum (0),
4008 make_number (SCHARS (string)), 3016 make_fixnum (SCHARS (string)),
4009 properties, string); 3017 properties, string);
4010 return string; 3018 return string;
4011} 3019}
@@ -4037,7 +3045,8 @@ the next available argument, or the argument explicitly specified:
4037 3045
4038%s means print a string argument. Actually, prints any object, with `princ'. 3046%s means print a string argument. Actually, prints any object, with `princ'.
4039%d means print as signed number in decimal. 3047%d means print as signed number in decimal.
4040%o means print as unsigned number in octal, %x as unsigned number in hex. 3048%o means print a number in octal.
3049%x means print a number in hex.
4041%X is like %x, but uses upper case. 3050%X is like %x, but uses upper case.
4042%e means print a number in exponential notation. 3051%e means print a number in exponential notation.
4043%f means print a number in decimal-point notation. 3052%f means print a number in decimal-point notation.
@@ -4048,6 +3057,8 @@ the next available argument, or the argument explicitly specified:
4048%S means print any object as an s-expression (using `prin1'). 3057%S means print any object as an s-expression (using `prin1').
4049 3058
4050The argument used for %d, %o, %x, %e, %f, %g or %c must be a number. 3059The argument used for %d, %o, %x, %e, %f, %g or %c must be a number.
3060%o, %x, and %X treat arguments as unsigned if `binary-as-unsigned' is t
3061 (this is experimental; email 32252@debbugs.gnu.org if you need it).
4051Use %% to put a single % into the output. 3062Use %% to put a single % into the output.
4052 3063
4053A %-sequence other than %% may contain optional field number, flag, 3064A %-sequence other than %% may contain optional field number, flag,
@@ -4056,7 +3067,7 @@ width, and precision specifiers, as follows:
4056 %<field><flags><width><precision>character 3067 %<field><flags><width><precision>character
4057 3068
4058where field is [0-9]+ followed by a literal dollar "$", flags is 3069where field is [0-9]+ followed by a literal dollar "$", flags is
4059[+ #-0]+, width is [0-9]+, and precision is a literal period "." 3070[+ #0-]+, width is [0-9]+, and precision is a literal period "."
4060followed by [0-9]+. 3071followed by [0-9]+.
4061 3072
4062If a %-sequence is numbered with a field with positive value N, the 3073If a %-sequence is numbered with a field with positive value N, the
@@ -4064,17 +3075,17 @@ Nth argument is substituted instead of the next one. A format can
4064contain either numbered or unnumbered %-sequences but not both, except 3075contain either numbered or unnumbered %-sequences but not both, except
4065that %% can be mixed with numbered %-sequences. 3076that %% can be mixed with numbered %-sequences.
4066 3077
4067The + flag character inserts a + before any positive number, while a 3078The + flag character inserts a + before any nonnegative number, while a
4068space inserts a space before any positive number; these flags only 3079space inserts a space before any nonnegative number; these flags
4069affect %d, %e, %f, and %g sequences, and the + flag takes precedence. 3080affect only numeric %-sequences, and the + flag takes precedence.
4070The - and 0 flags affect the width specifier, as described below. 3081The - and 0 flags affect the width specifier, as described below.
4071 3082
4072The # flag means to use an alternate display form for %o, %x, %X, %e, 3083The # flag means to use an alternate display form for %o, %x, %X, %e,
4073%f, and %g sequences: for %o, it ensures that the result begins with 3084%f, and %g sequences: for %o, it ensures that the result begins with
4074\"0\"; for %x and %X, it prefixes the result with \"0x\" or \"0X\"; 3085\"0\"; for %x and %X, it prefixes nonzero results with \"0x\" or \"0X\";
4075for %e and %f, it causes a decimal point to be included even if the 3086for %e and %f, it causes a decimal point to be included even if the
4076the precision is zero; for %g, it causes a decimal point to be 3087precision is zero; for %g, it causes a decimal point to be
4077included even if the the precision is zero, and also forces trailing 3088included even if the precision is zero, and also forces trailing
4078zeros after the decimal point to be left in place. 3089zeros after the decimal point to be left in place.
4079 3090
4080The width specifier supplies a lower limit for the length of the 3091The width specifier supplies a lower limit for the length of the
@@ -4082,7 +3093,7 @@ printed representation. The padding, if any, normally goes on the
4082left, but it goes on the right if the - flag is present. The padding 3093left, but it goes on the right if the - flag is present. The padding
4083character is normally a space, but it is 0 if the 0 flag is present. 3094character is normally a space, but it is 0 if the 0 flag is present.
4084The 0 flag is ignored if the - flag is present, or the format sequence 3095The 0 flag is ignored if the - flag is present, or the format sequence
4085is something other than %d, %e, %f, and %g. 3096is something other than %d, %o, %x, %e, %f, and %g.
4086 3097
4087For %e and %f sequences, the number after the "." in the precision 3098For %e and %f sequences, the number after the "." in the precision
4088specifier says how many decimal places to show; if zero, the decimal 3099specifier says how many decimal places to show; if zero, the decimal
@@ -4097,7 +3108,7 @@ produced text.
4097usage: (format STRING &rest OBJECTS) */) 3108usage: (format STRING &rest OBJECTS) */)
4098 (ptrdiff_t nargs, Lisp_Object *args) 3109 (ptrdiff_t nargs, Lisp_Object *args)
4099{ 3110{
4100 return styled_format (nargs, args, false, true); 3111 return styled_format (nargs, args, false);
4101} 3112}
4102 3113
4103DEFUN ("format-message", Fformat_message, Sformat_message, 1, MANY, 0, 3114DEFUN ("format-message", Fformat_message, Sformat_message, 1, MANY, 0,
@@ -4113,24 +3124,39 @@ and right quote replacement characters are specified by
4113usage: (format-message STRING &rest OBJECTS) */) 3124usage: (format-message STRING &rest OBJECTS) */)
4114 (ptrdiff_t nargs, Lisp_Object *args) 3125 (ptrdiff_t nargs, Lisp_Object *args)
4115{ 3126{
4116 return styled_format (nargs, args, true, true); 3127 return styled_format (nargs, args, true);
4117} 3128}
4118 3129
4119/* Implement ‘format-message’ if MESSAGE is true, ‘format’ otherwise. 3130/* Implement ‘format-message’ if MESSAGE is true, ‘format’ otherwise. */
4120 If NEW_RESULT, the result is a new string; otherwise, the result
4121 may be one of the arguments. */
4122 3131
4123Lisp_Object 3132static Lisp_Object
4124styled_format (ptrdiff_t nargs, Lisp_Object *args, bool message, 3133styled_format (ptrdiff_t nargs, Lisp_Object *args, bool message)
4125 bool new_result)
4126{ 3134{
3135 enum
3136 {
3137 /* Maximum precision for a %f conversion such that the trailing
3138 output digit might be nonzero. Any precision larger than this
3139 will not yield useful information. */
3140 USEFUL_PRECISION_MAX = ((1 - LDBL_MIN_EXP)
3141 * (FLT_RADIX == 2 || FLT_RADIX == 10 ? 1
3142 : FLT_RADIX == 16 ? 4
3143 : -1)),
3144
3145 /* Maximum number of bytes (including terminating null) generated
3146 by any format, if precision is no more than USEFUL_PRECISION_MAX.
3147 On all practical hosts, %Lf is the worst case. */
3148 SPRINTF_BUFSIZE = (sizeof "-." + (LDBL_MAX_10_EXP + 1)
3149 + USEFUL_PRECISION_MAX)
3150 };
3151 verify (USEFUL_PRECISION_MAX > 0);
3152
4127 ptrdiff_t n; /* The number of the next arg to substitute. */ 3153 ptrdiff_t n; /* The number of the next arg to substitute. */
4128 char initial_buffer[4000]; 3154 char initial_buffer[1000 + SPRINTF_BUFSIZE];
4129 char *buf = initial_buffer; 3155 char *buf = initial_buffer;
4130 ptrdiff_t bufsize = sizeof initial_buffer; 3156 ptrdiff_t bufsize = sizeof initial_buffer;
4131 ptrdiff_t max_bufsize = STRING_BYTES_BOUND + 1; 3157 ptrdiff_t max_bufsize = STRING_BYTES_BOUND + 1;
4132 char *p; 3158 char *p;
4133 ptrdiff_t buf_save_value_index UNINIT; 3159 specpdl_ref buf_save_value_index UNINIT;
4134 char *format, *end; 3160 char *format, *end;
4135 ptrdiff_t nchars; 3161 ptrdiff_t nchars;
4136 /* When we make a multibyte string, we must pay attention to the 3162 /* When we make a multibyte string, we must pay attention to the
@@ -4138,6 +3164,7 @@ styled_format (ptrdiff_t nargs, Lisp_Object *args, bool message,
4138 multibyte character of the previous string. This flag tells if we 3164 multibyte character of the previous string. This flag tells if we
4139 must consider such a situation or not. */ 3165 must consider such a situation or not. */
4140 bool maybe_combine_byte; 3166 bool maybe_combine_byte;
3167 Lisp_Object val;
4141 bool arg_intervals = false; 3168 bool arg_intervals = false;
4142 USE_SAFE_ALLOCA; 3169 USE_SAFE_ALLOCA;
4143 sa_avail -= sizeof initial_buffer; 3170 sa_avail -= sizeof initial_buffer;
@@ -4152,8 +3179,8 @@ styled_format (ptrdiff_t nargs, Lisp_Object *args, bool message,
4152 /* The start and end bytepos in the output string. */ 3179 /* The start and end bytepos in the output string. */
4153 ptrdiff_t start, end; 3180 ptrdiff_t start, end;
4154 3181
4155 /* Whether the argument is a newly created string. */ 3182 /* The start bytepos of the spec in the format string. */
4156 bool_bf new_string : 1; 3183 ptrdiff_t fbeg;
4157 3184
4158 /* Whether the argument is a string with intervals. */ 3185 /* Whether the argument is a string with intervals. */
4159 bool_bf intervals : 1; 3186 bool_bf intervals : 1;
@@ -4163,14 +3190,15 @@ styled_format (ptrdiff_t nargs, Lisp_Object *args, bool message,
4163 char *format_start = SSDATA (args[0]); 3190 char *format_start = SSDATA (args[0]);
4164 bool multibyte_format = STRING_MULTIBYTE (args[0]); 3191 bool multibyte_format = STRING_MULTIBYTE (args[0]);
4165 ptrdiff_t formatlen = SBYTES (args[0]); 3192 ptrdiff_t formatlen = SBYTES (args[0]);
3193 bool fmt_props = !!string_intervals (args[0]);
4166 3194
4167 /* Upper bound on number of format specs. Each uses at least 2 chars. */ 3195 /* Upper bound on number of format specs. Each uses at least 2 chars. */
4168 ptrdiff_t nspec_bound = SCHARS (args[0]) >> 1; 3196 ptrdiff_t nspec_bound = SCHARS (args[0]) >> 1;
4169 3197
4170 /* Allocate the info and discarded tables. */ 3198 /* Allocate the info and discarded tables. */
4171 ptrdiff_t alloca_size; 3199 ptrdiff_t info_size, alloca_size;
4172 if (INT_MULTIPLY_WRAPV (nspec_bound, sizeof *info, &alloca_size) 3200 if (INT_MULTIPLY_WRAPV (nspec_bound, sizeof *info, &info_size)
4173 || INT_ADD_WRAPV (formatlen, alloca_size, &alloca_size) 3201 || INT_ADD_WRAPV (formatlen, info_size, &alloca_size)
4174 || SIZE_MAX < alloca_size) 3202 || SIZE_MAX < alloca_size)
4175 memory_full (SIZE_MAX); 3203 memory_full (SIZE_MAX);
4176 info = SAFE_ALLOCA (alloca_size); 3204 info = SAFE_ALLOCA (alloca_size);
@@ -4193,11 +3221,14 @@ styled_format (ptrdiff_t nargs, Lisp_Object *args, bool message,
4193 if (STRINGP (args[i]) && STRING_MULTIBYTE (args[i])) 3221 if (STRINGP (args[i]) && STRING_MULTIBYTE (args[i]))
4194 multibyte = true; 3222 multibyte = true;
4195 3223
4196 int quoting_style = message ? text_quoting_style () : -1; 3224 Lisp_Object quoting_style = message ? Ftext_quoting_style () : Qnil;
4197 3225
4198 ptrdiff_t ispec; 3226 ptrdiff_t ispec;
4199 ptrdiff_t nspec = 0; 3227 ptrdiff_t nspec = 0;
4200 3228
3229 /* True if a string needs to be allocated to hold the result. */
3230 bool new_result = false;
3231
4201 /* If we start out planning a unibyte result, 3232 /* If we start out planning a unibyte result,
4202 then discover it has to be multibyte, we jump back to retry. */ 3233 then discover it has to be multibyte, we jump back to retry. */
4203 retry: 3234 retry:
@@ -4224,8 +3255,14 @@ styled_format (ptrdiff_t nargs, Lisp_Object *args, bool message,
4224 char const *convsrc = format; 3255 char const *convsrc = format;
4225 unsigned char format_char = *format++; 3256 unsigned char format_char = *format++;
4226 3257
4227 /* Bytes needed to represent the output of this conversion. */ 3258 /* Number of bytes to be preallocated for the next directive's
3259 output. At the end of each iteration this is at least
3260 CONVBYTES_ROOM, and is greater if the current directive
3261 output was so large that it will be retried after buffer
3262 reallocation. */
4228 ptrdiff_t convbytes = 1; 3263 ptrdiff_t convbytes = 1;
3264 enum { CONVBYTES_ROOM = SPRINTF_BUFSIZE - 1 };
3265 eassert (p <= buf + bufsize - SPRINTF_BUFSIZE);
4229 3266
4230 if (format_char == '%') 3267 if (format_char == '%')
4231 { 3268 {
@@ -4303,6 +3340,7 @@ styled_format (ptrdiff_t nargs, Lisp_Object *args, bool message,
4303 char conversion = *format++; 3340 char conversion = *format++;
4304 memset (&discarded[format0 - format_start], 1, 3341 memset (&discarded[format0 - format_start], 1,
4305 format - format0 - (conversion == '%')); 3342 format - format0 - (conversion == '%'));
3343 info[ispec].fbeg = format0 - format_start;
4306 if (conversion == '%') 3344 if (conversion == '%')
4307 { 3345 {
4308 new_result = true; 3346 new_result = true;
@@ -4317,7 +3355,6 @@ styled_format (ptrdiff_t nargs, Lisp_Object *args, bool message,
4317 if (nspec < ispec) 3355 if (nspec < ispec)
4318 { 3356 {
4319 spec->argument = args[n]; 3357 spec->argument = args[n];
4320 spec->new_string = false;
4321 spec->intervals = false; 3358 spec->intervals = false;
4322 nspec = ispec; 3359 nspec = ispec;
4323 } 3360 }
@@ -4334,8 +3371,7 @@ styled_format (ptrdiff_t nargs, Lisp_Object *args, bool message,
4334 if (EQ (arg, args[n])) 3371 if (EQ (arg, args[n]))
4335 { 3372 {
4336 Lisp_Object noescape = conversion == 'S' ? Qnil : Qt; 3373 Lisp_Object noescape = conversion == 'S' ? Qnil : Qt;
4337 spec->argument = arg = Fprin1_to_string (arg, noescape); 3374 spec->argument = arg = Fprin1_to_string (arg, noescape, Qnil);
4338 spec->new_string = true;
4339 if (STRING_MULTIBYTE (arg) && ! multibyte) 3375 if (STRING_MULTIBYTE (arg) && ! multibyte)
4340 { 3376 {
4341 multibyte = true; 3377 multibyte = true;
@@ -4346,7 +3382,7 @@ styled_format (ptrdiff_t nargs, Lisp_Object *args, bool message,
4346 } 3382 }
4347 else if (conversion == 'c') 3383 else if (conversion == 'c')
4348 { 3384 {
4349 if (INTEGERP (arg) && ! ASCII_CHAR_P (XINT (arg))) 3385 if (FIXNUMP (arg) && ! ASCII_CHAR_P (XFIXNUM (arg)))
4350 { 3386 {
4351 if (!multibyte) 3387 if (!multibyte)
4352 { 3388 {
@@ -4354,7 +3390,6 @@ styled_format (ptrdiff_t nargs, Lisp_Object *args, bool message,
4354 goto retry; 3390 goto retry;
4355 } 3391 }
4356 spec->argument = arg = Fchar_to_string (arg); 3392 spec->argument = arg = Fchar_to_string (arg);
4357 spec->new_string = true;
4358 } 3393 }
4359 3394
4360 if (!EQ (arg, args[n])) 3395 if (!EQ (arg, args[n]))
@@ -4378,9 +3413,11 @@ styled_format (ptrdiff_t nargs, Lisp_Object *args, bool message,
4378 if (conversion == 's') 3413 if (conversion == 's')
4379 { 3414 {
4380 if (format == end && format - format_start == 2 3415 if (format == end && format - format_start == 2
4381 && (!new_result || spec->new_string)
4382 && ! string_intervals (args[0])) 3416 && ! string_intervals (args[0]))
4383 return arg; 3417 {
3418 val = arg;
3419 goto return_val;
3420 }
4384 3421
4385 /* handle case (precision[n] >= 0) */ 3422 /* handle case (precision[n] >= 0) */
4386 3423
@@ -4401,12 +3438,11 @@ styled_format (ptrdiff_t nargs, Lisp_Object *args, bool message,
4401 else 3438 else
4402 { 3439 {
4403 ptrdiff_t nch, nby; 3440 ptrdiff_t nch, nby;
4404 width = lisp_string_width (arg, prec, &nch, &nby); 3441 nchars_string = SCHARS (arg);
3442 width = lisp_string_width (arg, 0, nchars_string, prec,
3443 &nch, &nby, false);
4405 if (prec < 0) 3444 if (prec < 0)
4406 { 3445 nbytes = SBYTES (arg);
4407 nchars_string = SCHARS (arg);
4408 nbytes = SBYTES (arg);
4409 }
4410 else 3446 else
4411 { 3447 {
4412 nchars_string = nch; 3448 nchars_string = nch;
@@ -4426,13 +3462,20 @@ styled_format (ptrdiff_t nargs, Lisp_Object *args, bool message,
4426 convbytes += padding; 3462 convbytes += padding;
4427 if (convbytes <= buf + bufsize - p) 3463 if (convbytes <= buf + bufsize - p)
4428 { 3464 {
3465 /* If the format spec has properties, we should account
3466 for the padding on the left in the info[] array. */
3467 if (fmt_props)
3468 spec->start = nchars;
4429 if (! minus_flag) 3469 if (! minus_flag)
4430 { 3470 {
4431 memset (p, ' ', padding); 3471 memset (p, ' ', padding);
4432 p += padding; 3472 p += padding;
4433 nchars += padding; 3473 nchars += padding;
4434 } 3474 }
4435 spec->start = nchars; 3475 /* If the properties will come from the argument, we
3476 don't extend them to the left due to padding. */
3477 if (!fmt_props)
3478 spec->start = nchars;
4436 3479
4437 if (p > buf 3480 if (p > buf
4438 && multibyte 3481 && multibyte
@@ -4461,7 +3504,7 @@ styled_format (ptrdiff_t nargs, Lisp_Object *args, bool message,
4461 spec->intervals = arg_intervals = true; 3504 spec->intervals = arg_intervals = true;
4462 3505
4463 new_result = true; 3506 new_result = true;
4464 continue; 3507 convbytes = CONVBYTES_ROOM;
4465 } 3508 }
4466 } 3509 }
4467 else if (! (conversion == 'c' || conversion == 'd' 3510 else if (! (conversion == 'c' || conversion == 'd'
@@ -4470,43 +3513,13 @@ styled_format (ptrdiff_t nargs, Lisp_Object *args, bool message,
4470 || conversion == 'X')) 3513 || conversion == 'X'))
4471 error ("Invalid format operation %%%c", 3514 error ("Invalid format operation %%%c",
4472 STRING_CHAR ((unsigned char *) format - 1)); 3515 STRING_CHAR ((unsigned char *) format - 1));
4473 else if (! (INTEGERP (arg) || (FLOATP (arg) && conversion != 'c'))) 3516 else if (! (FIXNUMP (arg) || ((BIGNUMP (arg) || FLOATP (arg))
3517 && conversion != 'c')))
4474 error ("Format specifier doesn't match argument type"); 3518 error ("Format specifier doesn't match argument type");
4475 else 3519 else
4476 { 3520 {
4477 enum 3521 /* Length of PRIdMAX without the trailing "d". */
4478 { 3522 enum { pMlen = sizeof PRIdMAX - 2 };
4479 /* Lower bound on the number of bits per
4480 base-FLT_RADIX digit. */
4481 DIG_BITS_LBOUND = FLT_RADIX < 16 ? 1 : 4,
4482
4483 /* 1 if integers should be formatted as long doubles,
4484 because they may be so large that there is a rounding
4485 error when converting them to double, and long doubles
4486 are wider than doubles. */
4487 INT_AS_LDBL = (DIG_BITS_LBOUND * DBL_MANT_DIG < FIXNUM_BITS - 1
4488 && DBL_MANT_DIG < LDBL_MANT_DIG),
4489
4490 /* Maximum precision for a %f conversion such that the
4491 trailing output digit might be nonzero. Any precision
4492 larger than this will not yield useful information. */
4493 USEFUL_PRECISION_MAX =
4494 ((1 - LDBL_MIN_EXP)
4495 * (FLT_RADIX == 2 || FLT_RADIX == 10 ? 1
4496 : FLT_RADIX == 16 ? 4
4497 : -1)),
4498
4499 /* Maximum number of bytes generated by any format, if
4500 precision is no more than USEFUL_PRECISION_MAX.
4501 On all practical hosts, %f is the worst case. */
4502 SPRINTF_BUFSIZE =
4503 sizeof "-." + (LDBL_MAX_10_EXP + 1) + USEFUL_PRECISION_MAX,
4504
4505 /* Length of pM (that is, of pMd without the
4506 trailing "d"). */
4507 pMlen = sizeof pMd - 2
4508 };
4509 verify (USEFUL_PRECISION_MAX > 0);
4510 3523
4511 /* Avoid undefined behavior in underlying sprintf. */ 3524 /* Avoid undefined behavior in underlying sprintf. */
4512 if (conversion == 'd' || conversion == 'i') 3525 if (conversion == 'd' || conversion == 'i')
@@ -4515,221 +3528,317 @@ styled_format (ptrdiff_t nargs, Lisp_Object *args, bool message,
4515 /* Create the copy of the conversion specification, with 3528 /* Create the copy of the conversion specification, with
4516 any width and precision removed, with ".*" inserted, 3529 any width and precision removed, with ".*" inserted,
4517 with "L" possibly inserted for floating-point formats, 3530 with "L" possibly inserted for floating-point formats,
4518 and with pM inserted for integer formats. 3531 and with PRIdMAX (sans "d") inserted for integer formats.
4519 At most two flags F can be specified at once. */ 3532 At most two flags F can be specified at once. */
4520 char convspec[sizeof "%FF.*d" + max (INT_AS_LDBL, pMlen)]; 3533 char convspec[sizeof "%FF.*d" + max (sizeof "L" - 1, pMlen)];
4521 { 3534 char *f = convspec;
4522 char *f = convspec; 3535 *f++ = '%';
4523 *f++ = '%'; 3536 /* MINUS_FLAG and ZERO_FLAG are dealt with later. */
4524 /* MINUS_FLAG and ZERO_FLAG are dealt with later. */ 3537 *f = '+'; f += plus_flag;
4525 *f = '+'; f += plus_flag; 3538 *f = ' '; f += space_flag;
4526 *f = ' '; f += space_flag; 3539 *f = '#'; f += sharp_flag;
4527 *f = '#'; f += sharp_flag; 3540 *f++ = '.';
4528 *f++ = '.'; 3541 *f++ = '*';
4529 *f++ = '*'; 3542 if (! (float_conversion || conversion == 'c'))
4530 if (float_conversion) 3543 {
4531 { 3544 memcpy (f, PRIdMAX, pMlen);
4532 if (INT_AS_LDBL) 3545 f += pMlen;
4533 { 3546 zero_flag &= ! precision_given;
4534 *f = 'L'; 3547 }
4535 f += INTEGERP (arg); 3548 *f++ = conversion;
4536 } 3549 *f = '\0';
4537 }
4538 else if (conversion != 'c')
4539 {
4540 memcpy (f, pMd, pMlen);
4541 f += pMlen;
4542 zero_flag &= ! precision_given;
4543 }
4544 *f++ = conversion;
4545 *f = '\0';
4546 }
4547 3550
4548 int prec = -1; 3551 int prec = -1;
4549 if (precision_given) 3552 if (precision_given)
4550 prec = min (precision, USEFUL_PRECISION_MAX); 3553 prec = min (precision, USEFUL_PRECISION_MAX);
4551 3554
4552 /* Use sprintf to format this number into sprintf_buf. Omit 3555 /* Characters to be inserted after spaces and before
3556 leading zeros. This can occur with bignums, since
3557 bignum_to_string does only leading '-'. */
3558 char prefix[sizeof "-0x" - 1];
3559 int prefixlen = 0;
3560
3561 /* Use sprintf or bignum_to_string to format this number. Omit
4553 padding and excess precision, though, because sprintf limits 3562 padding and excess precision, though, because sprintf limits
4554 output length to INT_MAX. 3563 output length to INT_MAX and bignum_to_string doesn't
3564 do padding or precision.
4555 3565
4556 There are four types of conversion: double, unsigned 3566 Use five sprintf conversions: double, long double, unsigned
4557 char (passed as int), wide signed int, and wide 3567 char (passed as int), wide signed int, and wide
4558 unsigned int. Treat them separately because the 3568 unsigned int. Treat them separately because the
4559 sprintf ABI is sensitive to which type is passed. Be 3569 sprintf ABI is sensitive to which type is passed. Be
4560 careful about integer overflow, NaNs, infinities, and 3570 careful about integer overflow, NaNs, infinities, and
4561 conversions; for example, the min and max macros are 3571 conversions; for example, the min and max macros are
4562 not suitable here. */ 3572 not suitable here. */
4563 char sprintf_buf[SPRINTF_BUFSIZE];
4564 ptrdiff_t sprintf_bytes; 3573 ptrdiff_t sprintf_bytes;
4565 if (float_conversion) 3574 if (float_conversion)
4566 { 3575 {
4567 if (INT_AS_LDBL && INTEGERP (arg)) 3576 /* Format as a long double if the arg is an integer
3577 that would lose less information than when formatting
3578 it as a double. Otherwise, format as a double;
3579 this is likely to be faster and better-tested. */
3580
3581 bool format_as_long_double = false;
3582 double darg;
3583 long double ldarg UNINIT;
3584
3585 if (FLOATP (arg))
3586 darg = XFLOAT_DATA (arg);
3587 else
4568 { 3588 {
4569 /* Although long double may have a rounding error if 3589 bool format_bignum_as_double = false;
4570 DIG_BITS_LBOUND * LDBL_MANT_DIG < FIXNUM_BITS - 1, 3590 if (LDBL_MANT_DIG <= DBL_MANT_DIG)
4571 it is more accurate than plain 'double'. */ 3591 {
4572 long double x = XINT (arg); 3592 if (FIXNUMP (arg))
4573 sprintf_bytes = sprintf (sprintf_buf, convspec, prec, x); 3593 darg = XFIXNUM (arg);
3594 else
3595 format_bignum_as_double = true;
3596 }
3597 else
3598 {
3599 if (INTEGERP (arg))
3600 {
3601 intmax_t iarg;
3602 uintmax_t uarg;
3603 if (integer_to_intmax (arg, &iarg))
3604 ldarg = iarg;
3605 else if (integer_to_uintmax (arg, &uarg))
3606 ldarg = uarg;
3607 else
3608 format_bignum_as_double = true;
3609 }
3610 if (!format_bignum_as_double)
3611 {
3612 darg = ldarg;
3613 format_as_long_double = darg != ldarg;
3614 }
3615 }
3616 if (format_bignum_as_double)
3617 darg = bignum_to_double (arg);
3618 }
3619
3620 if (format_as_long_double)
3621 {
3622 f[-1] = 'L';
3623 *f++ = conversion;
3624 *f = '\0';
3625 sprintf_bytes = sprintf (p, convspec, prec, ldarg);
4574 } 3626 }
4575 else 3627 else
4576 sprintf_bytes = sprintf (sprintf_buf, convspec, prec, 3628 sprintf_bytes = sprintf (p, convspec, prec, darg);
4577 XFLOATINT (arg));
4578 } 3629 }
4579 else if (conversion == 'c') 3630 else if (conversion == 'c')
4580 { 3631 {
4581 /* Don't use sprintf here, as it might mishandle prec. */ 3632 /* Don't use sprintf here, as it might mishandle prec. */
4582 sprintf_buf[0] = XINT (arg); 3633 p[0] = XFIXNUM (arg);
3634 p[1] = '\0';
4583 sprintf_bytes = prec != 0; 3635 sprintf_bytes = prec != 0;
4584 } 3636 }
3637 else if (BIGNUMP (arg))
3638 bignum_arg:
3639 {
3640 int base = ((conversion == 'd' || conversion == 'i') ? 10
3641 : conversion == 'o' ? 8 : 16);
3642 sprintf_bytes = bignum_bufsize (arg, base);
3643 if (sprintf_bytes <= buf + bufsize - p)
3644 {
3645 int signedbase = conversion == 'X' ? -base : base;
3646 sprintf_bytes = bignum_to_c_string (p, sprintf_bytes,
3647 arg, signedbase);
3648 bool negative = p[0] == '-';
3649 prec = min (precision, sprintf_bytes - prefixlen);
3650 prefix[prefixlen] = plus_flag ? '+' : ' ';
3651 prefixlen += (plus_flag | space_flag) & !negative;
3652 prefix[prefixlen] = '0';
3653 prefix[prefixlen + 1] = conversion;
3654 prefixlen += sharp_flag && base == 16 ? 2 : 0;
3655 }
3656 }
4585 else if (conversion == 'd' || conversion == 'i') 3657 else if (conversion == 'd' || conversion == 'i')
4586 { 3658 {
4587 /* For float, maybe we should use "%1.0f" 3659 if (FIXNUMP (arg))
4588 instead so it also works for values outside 3660 {
4589 the integer range. */ 3661 intmax_t x = XFIXNUM (arg);
4590 printmax_t x; 3662 sprintf_bytes = sprintf (p, convspec, prec, x);
4591 if (INTEGERP (arg)) 3663 }
4592 x = XINT (arg);
4593 else 3664 else
4594 { 3665 {
4595 double d = XFLOAT_DATA (arg); 3666 strcpy (f - pMlen - 1, "f");
4596 if (d < 0) 3667 double x = XFLOAT_DATA (arg);
3668
3669 /* Truncate and then convert -0 to 0, to be more
3670 consistent with %x etc.; see Bug#31938. */
3671 x = trunc (x);
3672 x = x ? x : 0;
3673
3674 sprintf_bytes = sprintf (p, convspec, 0, x);
3675 bool signedp = ! c_isdigit (p[0]);
3676 prec = min (precision, sprintf_bytes - signedp);
3677 }
3678 }
3679 else
3680 {
3681 uintmax_t x;
3682 bool negative;
3683 if (FIXNUMP (arg))
3684 {
3685 if (binary_as_unsigned)
4597 { 3686 {
4598 x = TYPE_MINIMUM (printmax_t); 3687 x = XUFIXNUM (arg);
4599 if (x < d) 3688 negative = false;
4600 x = d;
4601 } 3689 }
4602 else 3690 else
4603 { 3691 {
4604 x = TYPE_MAXIMUM (printmax_t); 3692 EMACS_INT i = XFIXNUM (arg);
4605 if (d < x) 3693 negative = i < 0;
4606 x = d; 3694 x = negative ? -i : i;
4607 } 3695 }
4608 } 3696 }
4609 sprintf_bytes = sprintf (sprintf_buf, convspec, prec, x);
4610 }
4611 else
4612 {
4613 /* Don't sign-extend for octal or hex printing. */
4614 uprintmax_t x;
4615 if (INTEGERP (arg))
4616 x = XUINT (arg);
4617 else 3697 else
4618 { 3698 {
4619 double d = XFLOAT_DATA (arg); 3699 double d = XFLOAT_DATA (arg);
4620 if (d < 0) 3700 double abs_d = fabs (d);
4621 x = 0; 3701 if (abs_d < UINTMAX_MAX + 1.0)
3702 {
3703 negative = d <= -1;
3704 x = abs_d;
3705 }
4622 else 3706 else
4623 { 3707 {
4624 x = TYPE_MAXIMUM (uprintmax_t); 3708 arg = double_to_integer (d);
4625 if (d < x) 3709 goto bignum_arg;
4626 x = d;
4627 } 3710 }
4628 } 3711 }
4629 sprintf_bytes = sprintf (sprintf_buf, convspec, prec, x); 3712 p[0] = negative ? '-' : plus_flag ? '+' : ' ';
3713 bool signedp = negative | plus_flag | space_flag;
3714 sprintf_bytes = sprintf (p + signedp, convspec, prec, x);
3715 sprintf_bytes += signedp;
4630 } 3716 }
4631 3717
4632 /* Now the length of the formatted item is known, except it omits 3718 /* Now the length of the formatted item is known, except it omits
4633 padding and excess precision. Deal with excess precision 3719 padding and excess precision. Deal with excess precision
4634 first. This happens only when the format specifies 3720 first. This happens when the format specifies ridiculously
4635 ridiculously large precision. */ 3721 large precision, or when %d or %i formats a float that would
3722 ordinarily need fewer digits than a specified precision,
3723 or when a bignum is formatted using an integer format
3724 with enough precision. */
4636 ptrdiff_t excess_precision 3725 ptrdiff_t excess_precision
4637 = precision_given ? precision - prec : 0; 3726 = precision_given ? precision - prec : 0;
4638 ptrdiff_t leading_zeros = 0, trailing_zeros = 0; 3727 ptrdiff_t trailing_zeros = 0;
4639 if (excess_precision) 3728 if (excess_precision != 0 && float_conversion)
4640 { 3729 {
4641 if (float_conversion) 3730 if (! c_isdigit (p[sprintf_bytes - 1])
4642 { 3731 || (conversion == 'g'
4643 if ((conversion == 'g' && ! sharp_flag) 3732 && ! (sharp_flag && strchr (p, '.'))))
4644 || ! ('0' <= sprintf_buf[sprintf_bytes - 1] 3733 excess_precision = 0;
4645 && sprintf_buf[sprintf_bytes - 1] <= '9')) 3734 trailing_zeros = excess_precision;
4646 excess_precision = 0;
4647 else
4648 {
4649 if (conversion == 'g')
4650 {
4651 char *dot = strchr (sprintf_buf, '.');
4652 if (!dot)
4653 excess_precision = 0;
4654 }
4655 }
4656 trailing_zeros = excess_precision;
4657 }
4658 else
4659 leading_zeros = excess_precision;
4660 } 3735 }
3736 ptrdiff_t leading_zeros = excess_precision - trailing_zeros;
4661 3737
4662 /* Compute the total bytes needed for this item, including 3738 /* Compute the total bytes needed for this item, including
4663 excess precision and padding. */ 3739 excess precision and padding. */
4664 ptrdiff_t numwidth; 3740 ptrdiff_t numwidth;
4665 if (INT_ADD_WRAPV (sprintf_bytes, excess_precision, &numwidth)) 3741 if (INT_ADD_WRAPV (prefixlen + sprintf_bytes, excess_precision,
3742 &numwidth))
4666 numwidth = PTRDIFF_MAX; 3743 numwidth = PTRDIFF_MAX;
4667 ptrdiff_t padding 3744 ptrdiff_t padding
4668 = numwidth < field_width ? field_width - numwidth : 0; 3745 = numwidth < field_width ? field_width - numwidth : 0;
4669 if (max_bufsize - sprintf_bytes <= excess_precision 3746 if (max_bufsize - (prefixlen + sprintf_bytes) <= excess_precision
4670 || max_bufsize - padding <= numwidth) 3747 || max_bufsize - padding <= numwidth)
4671 string_overflow (); 3748 string_overflow ();
4672 convbytes = numwidth + padding; 3749 convbytes = numwidth + padding;
4673 3750
4674 if (convbytes <= buf + bufsize - p) 3751 if (convbytes <= buf + bufsize - p)
4675 { 3752 {
4676 /* Copy the formatted item from sprintf_buf into buf, 3753 bool signedp = p[0] == '-' || p[0] == '+' || p[0] == ' ';
4677 inserting padding and excess-precision zeros. */ 3754 int beglen = (signedp
4678 3755 + ((p[signedp] == '0'
4679 char *src = sprintf_buf; 3756 && (p[signedp + 1] == 'x'
4680 char src0 = src[0]; 3757 || p[signedp + 1] == 'X'))
4681 int exponent_bytes = 0; 3758 ? 2 : 0));
4682 bool signedp = src0 == '-' || src0 == '+' || src0 == ' '; 3759 eassert (prefixlen == 0 || beglen == 0
4683 unsigned char after_sign = src[signedp]; 3760 || (beglen == 1 && p[0] == '-'
4684 if (zero_flag && 0 <= char_hexdigit (after_sign)) 3761 && ! (prefix[0] == '-' || prefix[0] == '+'
3762 || prefix[0] == ' ')));
3763 if (zero_flag && 0 <= char_hexdigit (p[beglen]))
4685 { 3764 {
4686 leading_zeros += padding; 3765 leading_zeros += padding;
4687 padding = 0; 3766 padding = 0;
4688 } 3767 }
3768 if (leading_zeros == 0 && sharp_flag && conversion == 'o'
3769 && p[beglen] != '0')
3770 {
3771 leading_zeros++;
3772 padding -= padding != 0;
3773 }
4689 3774
4690 if (excess_precision 3775 int endlen = 0;
3776 if (trailing_zeros
4691 && (conversion == 'e' || conversion == 'g')) 3777 && (conversion == 'e' || conversion == 'g'))
4692 { 3778 {
4693 char *e = strchr (src, 'e'); 3779 char *e = strchr (p, 'e');
4694 if (e) 3780 if (e)
4695 exponent_bytes = src + sprintf_bytes - e; 3781 endlen = p + sprintf_bytes - e;
4696 } 3782 }
4697 3783
4698 spec->start = nchars; 3784 ptrdiff_t midlen = sprintf_bytes - beglen - endlen;
4699 if (! minus_flag) 3785 ptrdiff_t leading_padding = minus_flag ? 0 : padding;
4700 { 3786 ptrdiff_t trailing_padding = padding - leading_padding;
4701 memset (p, ' ', padding);
4702 p += padding;
4703 nchars += padding;
4704 }
4705 3787
4706 *p = src0; 3788 /* Insert padding and excess-precision zeros. The output
4707 src += signedp; 3789 contains the following components, in left-to-right order:
4708 p += signedp;
4709 memset (p, '0', leading_zeros);
4710 p += leading_zeros;
4711 int significand_bytes
4712 = sprintf_bytes - signedp - exponent_bytes;
4713 memcpy (p, src, significand_bytes);
4714 p += significand_bytes;
4715 src += significand_bytes;
4716 memset (p, '0', trailing_zeros);
4717 p += trailing_zeros;
4718 memcpy (p, src, exponent_bytes);
4719 p += exponent_bytes;
4720
4721 nchars += leading_zeros + sprintf_bytes + trailing_zeros;
4722 3790
4723 if (minus_flag) 3791 LEADING_PADDING spaces.
3792 BEGLEN bytes taken from the start of sprintf output.
3793 PREFIXLEN bytes taken from the start of the prefix array.
3794 LEADING_ZEROS zeros.
3795 MIDLEN bytes taken from the middle of sprintf output.
3796 TRAILING_ZEROS zeros.
3797 ENDLEN bytes taken from the end of sprintf output.
3798 TRAILING_PADDING spaces.
3799
3800 The sprintf output is taken from the buffer starting at
3801 P and continuing for SPRINTF_BYTES bytes. */
3802
3803 ptrdiff_t incr
3804 = (padding + leading_zeros + prefixlen
3805 + sprintf_bytes + trailing_zeros);
3806
3807 /* Optimize for the typical case with padding or zeros. */
3808 if (incr != sprintf_bytes)
4724 { 3809 {
4725 memset (p, ' ', padding); 3810 /* Move data to make room to insert spaces and '0's.
4726 p += padding; 3811 As this may entail overlapping moves, process
4727 nchars += padding; 3812 the output right-to-left and use memmove.
3813 With any luck this code is rarely executed. */
3814 char *src = p + sprintf_bytes;
3815 char *dst = p + incr;
3816 dst -= trailing_padding;
3817 memset (dst, ' ', trailing_padding);
3818 src -= endlen;
3819 dst -= endlen;
3820 memmove (dst, src, endlen);
3821 dst -= trailing_zeros;
3822 memset (dst, '0', trailing_zeros);
3823 src -= midlen;
3824 dst -= midlen;
3825 memmove (dst, src, midlen);
3826 dst -= leading_zeros;
3827 memset (dst, '0', leading_zeros);
3828 dst -= prefixlen;
3829 memcpy (dst, prefix, prefixlen);
3830 src -= beglen;
3831 dst -= beglen;
3832 memmove (dst, src, beglen);
3833 dst -= leading_padding;
3834 memset (dst, ' ', leading_padding);
4728 } 3835 }
4729 spec->end = nchars;
4730 3836
3837 p += incr;
3838 spec->start = nchars;
3839 spec->end = nchars += incr;
4731 new_result = true; 3840 new_result = true;
4732 continue; 3841 convbytes = CONVBYTES_ROOM;
4733 } 3842 }
4734 } 3843 }
4735 } 3844 }
@@ -4738,7 +3847,7 @@ styled_format (ptrdiff_t nargs, Lisp_Object *args, bool message,
4738 unsigned char str[MAX_MULTIBYTE_LENGTH]; 3847 unsigned char str[MAX_MULTIBYTE_LENGTH];
4739 3848
4740 if ((format_char == '`' || format_char == '\'') 3849 if ((format_char == '`' || format_char == '\'')
4741 && quoting_style == CURVE_QUOTING_STYLE) 3850 && EQ (quoting_style, Qcurve))
4742 { 3851 {
4743 if (! multibyte) 3852 if (! multibyte)
4744 { 3853 {
@@ -4749,7 +3858,7 @@ styled_format (ptrdiff_t nargs, Lisp_Object *args, bool message,
4749 convbytes = 3; 3858 convbytes = 3;
4750 new_result = true; 3859 new_result = true;
4751 } 3860 }
4752 else if (format_char == '`' && quoting_style == STRAIGHT_QUOTING_STYLE) 3861 else if (format_char == '`' && EQ (quoting_style, Qstraight))
4753 { 3862 {
4754 convsrc = "'"; 3863 convsrc = "'";
4755 new_result = true; 3864 new_result = true;
@@ -4782,54 +3891,65 @@ styled_format (ptrdiff_t nargs, Lisp_Object *args, bool message,
4782 } 3891 }
4783 3892
4784 copy_char: 3893 copy_char:
4785 if (convbytes <= buf + bufsize - p) 3894 memcpy (p, convsrc, convbytes);
4786 { 3895 p += convbytes;
4787 memcpy (p, convsrc, convbytes); 3896 nchars++;
4788 p += convbytes; 3897 convbytes = CONVBYTES_ROOM;
4789 nchars++;
4790 continue;
4791 }
4792 } 3898 }
4793 3899
4794 /* There wasn't enough room to store this conversion or single
4795 character. CONVBYTES says how much room is needed. Allocate
4796 enough room (and then some) and do it again. */
4797
4798 ptrdiff_t used = p - buf; 3900 ptrdiff_t used = p - buf;
4799 if (max_bufsize - used < convbytes) 3901 ptrdiff_t buflen_needed;
3902 if (INT_ADD_WRAPV (used, convbytes, &buflen_needed))
4800 string_overflow (); 3903 string_overflow ();
4801 bufsize = used + convbytes; 3904 if (bufsize <= buflen_needed)
4802 bufsize = bufsize < max_bufsize / 2 ? bufsize * 2 : max_bufsize;
4803
4804 if (buf == initial_buffer)
4805 { 3905 {
4806 buf = xmalloc (bufsize); 3906 if (max_bufsize <= buflen_needed)
4807 sa_must_free = true; 3907 string_overflow ();
4808 buf_save_value_index = SPECPDL_INDEX (); 3908
4809 record_unwind_protect_ptr (xfree, buf); 3909 /* Either there wasn't enough room to store this conversion,
4810 memcpy (buf, initial_buffer, used); 3910 or there won't be enough room to do a sprintf the next
4811 } 3911 time through the loop. Allocate enough room (and then some). */
4812 else 3912
4813 { 3913 bufsize = (buflen_needed <= max_bufsize / 2
4814 buf = xrealloc (buf, bufsize); 3914 ? buflen_needed * 2 : max_bufsize);
4815 set_unwind_protect_ptr (buf_save_value_index, xfree, buf); 3915
4816 } 3916 if (buf == initial_buffer)
3917 {
3918 buf = xmalloc (bufsize);
3919 buf_save_value_index = SPECPDL_INDEX ();
3920 record_unwind_protect_ptr (xfree, buf);
3921 memcpy (buf, initial_buffer, used);
3922 }
3923 else
3924 {
3925 buf = xrealloc (buf, bufsize);
3926 set_unwind_protect_ptr (buf_save_value_index, xfree, buf);
3927 }
4817 3928
4818 p = buf + used; 3929 p = buf + used;
4819 format = format0; 3930 if (convbytes != CONVBYTES_ROOM)
4820 n = n0; 3931 {
4821 ispec = ispec0; 3932 /* There wasn't enough room for this conversion; do it over. */
3933 eassert (CONVBYTES_ROOM < convbytes);
3934 format = format0;
3935 n = n0;
3936 ispec = ispec0;
3937 }
3938 }
4822 } 3939 }
4823 3940
4824 if (bufsize < p - buf) 3941 if (bufsize < p - buf)
4825 emacs_abort (); 3942 emacs_abort ();
4826 3943
4827 if (! new_result) 3944 if (! new_result)
4828 return args[0]; 3945 {
3946 val = args[0];
3947 goto return_val;
3948 }
4829 3949
4830 if (maybe_combine_byte) 3950 if (maybe_combine_byte)
4831 nchars = multibyte_chars_in_text ((unsigned char *) buf, p - buf); 3951 nchars = multibyte_chars_in_text ((unsigned char *) buf, p - buf);
4832 Lisp_Object val = make_specified_string (buf, nchars, p - buf, multibyte); 3952 val = make_specified_string (buf, nchars, p - buf, multibyte);
4833 3953
4834 /* If the format string has text properties, or any of the string 3954 /* If the format string has text properties, or any of the string
4835 arguments has text properties, set up text properties of the 3955 arguments has text properties, set up text properties of the
@@ -4838,8 +3958,8 @@ styled_format (ptrdiff_t nargs, Lisp_Object *args, bool message,
4838 if (string_intervals (args[0]) || arg_intervals) 3958 if (string_intervals (args[0]) || arg_intervals)
4839 { 3959 {
4840 /* Add text properties from the format string. */ 3960 /* Add text properties from the format string. */
4841 Lisp_Object len = make_number (SCHARS (args[0])); 3961 Lisp_Object len = make_fixnum (SCHARS (args[0]));
4842 Lisp_Object props = text_property_list (args[0], make_number (0), 3962 Lisp_Object props = text_property_list (args[0], make_fixnum (0),
4843 len, Qnil); 3963 len, Qnil);
4844 if (CONSP (props)) 3964 if (CONSP (props))
4845 { 3965 {
@@ -4863,7 +3983,7 @@ styled_format (ptrdiff_t nargs, Lisp_Object *args, bool message,
4863 Lisp_Object item = XCAR (list); 3983 Lisp_Object item = XCAR (list);
4864 3984
4865 /* First adjust the property start position. */ 3985 /* First adjust the property start position. */
4866 ptrdiff_t pos = XINT (XCAR (item)); 3986 ptrdiff_t pos = XFIXNUM (XCAR (item));
4867 3987
4868 /* Advance BYTEPOS, POSITION, TRANSLATED and ARGN 3988 /* Advance BYTEPOS, POSITION, TRANSLATED and ARGN
4869 up to this position. */ 3989 up to this position. */
@@ -4874,7 +3994,9 @@ styled_format (ptrdiff_t nargs, Lisp_Object *args, bool message,
4874 else if (discarded[bytepos] == 1) 3994 else if (discarded[bytepos] == 1)
4875 { 3995 {
4876 position++; 3996 position++;
4877 if (translated == info[fieldn].start) 3997 if (fieldn < nspec
3998 && bytepos >= info[fieldn].fbeg
3999 && translated == info[fieldn].start)
4878 { 4000 {
4879 translated += info[fieldn].end - info[fieldn].start; 4001 translated += info[fieldn].end - info[fieldn].start;
4880 fieldn++; 4002 fieldn++;
@@ -4882,10 +4004,10 @@ styled_format (ptrdiff_t nargs, Lisp_Object *args, bool message,
4882 } 4004 }
4883 } 4005 }
4884 4006
4885 XSETCAR (item, make_number (translated)); 4007 XSETCAR (item, make_fixnum (translated));
4886 4008
4887 /* Likewise adjust the property end position. */ 4009 /* Likewise adjust the property end position. */
4888 pos = XINT (XCAR (XCDR (item))); 4010 pos = XFIXNUM (XCAR (XCDR (item)));
4889 4011
4890 for (; position < pos; bytepos++) 4012 for (; position < pos; bytepos++)
4891 { 4013 {
@@ -4894,7 +4016,9 @@ styled_format (ptrdiff_t nargs, Lisp_Object *args, bool message,
4894 else if (discarded[bytepos] == 1) 4016 else if (discarded[bytepos] == 1)
4895 { 4017 {
4896 position++; 4018 position++;
4897 if (translated == info[fieldn].start) 4019 if (fieldn < nspec
4020 && bytepos >= info[fieldn].fbeg
4021 && translated == info[fieldn].start)
4898 { 4022 {
4899 translated += info[fieldn].end - info[fieldn].start; 4023 translated += info[fieldn].end - info[fieldn].start;
4900 fieldn++; 4024 fieldn++;
@@ -4902,10 +4026,10 @@ styled_format (ptrdiff_t nargs, Lisp_Object *args, bool message,
4902 } 4026 }
4903 } 4027 }
4904 4028
4905 XSETCAR (XCDR (item), make_number (translated)); 4029 XSETCAR (XCDR (item), make_fixnum (translated));
4906 } 4030 }
4907 4031
4908 add_text_properties_from_list (val, props, make_number (0)); 4032 add_text_properties_from_list (val, props, make_fixnum (0));
4909 } 4033 }
4910 4034
4911 /* Add text properties from arguments. */ 4035 /* Add text properties from arguments. */
@@ -4913,20 +4037,21 @@ styled_format (ptrdiff_t nargs, Lisp_Object *args, bool message,
4913 for (ptrdiff_t i = 0; i < nspec; i++) 4037 for (ptrdiff_t i = 0; i < nspec; i++)
4914 if (info[i].intervals) 4038 if (info[i].intervals)
4915 { 4039 {
4916 len = make_number (SCHARS (info[i].argument)); 4040 len = make_fixnum (SCHARS (info[i].argument));
4917 Lisp_Object new_len = make_number (info[i].end - info[i].start); 4041 Lisp_Object new_len = make_fixnum (info[i].end - info[i].start);
4918 props = text_property_list (info[i].argument, 4042 props = text_property_list (info[i].argument,
4919 make_number (0), len, Qnil); 4043 make_fixnum (0), len, Qnil);
4920 props = extend_property_ranges (props, len, new_len); 4044 props = extend_property_ranges (props, len, new_len);
4921 /* If successive arguments have properties, be sure that 4045 /* If successive arguments have properties, be sure that
4922 the value of `composition' property be the copy. */ 4046 the value of `composition' property be the copy. */
4923 if (1 < i && info[i - 1].end) 4047 if (1 < i && info[i - 1].end)
4924 make_composition_value_copy (props); 4048 make_composition_value_copy (props);
4925 add_text_properties_from_list (val, props, 4049 add_text_properties_from_list (val, props,
4926 make_number (info[i].start)); 4050 make_fixnum (info[i].start));
4927 } 4051 }
4928 } 4052 }
4929 4053
4054 return_val:
4930 /* If we allocated BUF or INFO with malloc, free it too. */ 4055 /* If we allocated BUF or INFO with malloc, free it too. */
4931 SAFE_FREE (); 4056 SAFE_FREE ();
4932 4057
@@ -4945,13 +4070,13 @@ Case is ignored if `case-fold-search' is non-nil in the current buffer. */)
4945 CHECK_CHARACTER (c1); 4070 CHECK_CHARACTER (c1);
4946 CHECK_CHARACTER (c2); 4071 CHECK_CHARACTER (c2);
4947 4072
4948 if (XINT (c1) == XINT (c2)) 4073 if (XFIXNUM (c1) == XFIXNUM (c2))
4949 return Qt; 4074 return Qt;
4950 if (NILP (BVAR (current_buffer, case_fold_search))) 4075 if (NILP (BVAR (current_buffer, case_fold_search)))
4951 return Qnil; 4076 return Qnil;
4952 4077
4953 i1 = XFASTINT (c1); 4078 i1 = XFIXNAT (c1);
4954 i2 = XFASTINT (c2); 4079 i2 = XFIXNAT (c2);
4955 4080
4956 /* FIXME: It is possible to compare multibyte characters even when 4081 /* FIXME: It is possible to compare multibyte characters even when
4957 the current buffer is unibyte. Unfortunately this is ambiguous 4082 the current buffer is unibyte. Unfortunately this is ambiguous
@@ -5054,7 +4179,16 @@ transpose_markers (ptrdiff_t start1, ptrdiff_t end1,
5054 } 4179 }
5055} 4180}
5056 4181
5057DEFUN ("transpose-regions", Ftranspose_regions, Stranspose_regions, 4, 5, 0, 4182DEFUN ("transpose-regions", Ftranspose_regions, Stranspose_regions, 4, 5,
4183 "(if (< (length mark-ring) 2)\
4184 (error \"Other region must be marked before transposing two regions\")\
4185 (let* ((num (if current-prefix-arg\
4186 (prefix-numeric-value current-prefix-arg)\
4187 0))\
4188 (ring-length (length mark-ring))\
4189 (eltnum (mod num ring-length))\
4190 (eltnum2 (mod (1+ num) ring-length)))\
4191 (list (point) (mark) (elt mark-ring eltnum) (elt mark-ring eltnum2))))",
5058 doc: /* Transpose region STARTR1 to ENDR1 with STARTR2 to ENDR2. 4192 doc: /* Transpose region STARTR1 to ENDR1 with STARTR2 to ENDR2.
5059The regions should not be overlapping, because the size of the buffer is 4193The regions should not be overlapping, because the size of the buffer is
5060never changed in a transposition. 4194never changed in a transposition.
@@ -5062,7 +4196,14 @@ never changed in a transposition.
5062Optional fifth arg LEAVE-MARKERS, if non-nil, means don't update 4196Optional fifth arg LEAVE-MARKERS, if non-nil, means don't update
5063any markers that happen to be located in the regions. 4197any markers that happen to be located in the regions.
5064 4198
5065Transposing beyond buffer boundaries is an error. */) 4199Transposing beyond buffer boundaries is an error.
4200
4201Interactively, STARTR1 and ENDR1 are point and mark; STARTR2 and ENDR2
4202are the last two marks pushed to the mark ring; LEAVE-MARKERS is nil.
4203If a prefix argument N is given, STARTR2 and ENDR2 are the two
4204successive marks N entries back in the mark ring. A negative prefix
4205argument instead counts forward from the oldest mark in the mark
4206ring. */)
5066 (Lisp_Object startr1, Lisp_Object endr1, Lisp_Object startr2, Lisp_Object endr2, Lisp_Object leave_markers) 4207 (Lisp_Object startr1, Lisp_Object endr1, Lisp_Object startr2, Lisp_Object endr2, Lisp_Object leave_markers)
5067{ 4208{
5068 register ptrdiff_t start1, end1, start2, end2; 4209 register ptrdiff_t start1, end1, start2, end2;
@@ -5079,10 +4220,10 @@ Transposing beyond buffer boundaries is an error. */)
5079 validate_region (&startr1, &endr1); 4220 validate_region (&startr1, &endr1);
5080 validate_region (&startr2, &endr2); 4221 validate_region (&startr2, &endr2);
5081 4222
5082 start1 = XFASTINT (startr1); 4223 start1 = XFIXNAT (startr1);
5083 end1 = XFASTINT (endr1); 4224 end1 = XFIXNAT (endr1);
5084 start2 = XFASTINT (startr2); 4225 start2 = XFIXNAT (startr2);
5085 end2 = XFASTINT (endr2); 4226 end2 = XFIXNAT (endr2);
5086 gap = GPT; 4227 gap = GPT;
5087 4228
5088 /* Swap the regions if they're reversed. */ 4229 /* Swap the regions if they're reversed. */
@@ -5173,9 +4314,6 @@ Transposing beyond buffer boundaries is an error. */)
5173 enough to use as the temporary storage? That would avoid an 4314 enough to use as the temporary storage? That would avoid an
5174 allocation... interesting. Later, don't fool with it now. */ 4315 allocation... interesting. Later, don't fool with it now. */
5175 4316
5176 /* Working without memmove, for portability (sigh), so must be
5177 careful of overlapping subsections of the array... */
5178
5179 if (end1 == start2) /* adjacent regions */ 4317 if (end1 == start2) /* adjacent regions */
5180 { 4318 {
5181 modify_text (start1, end2); 4319 modify_text (start1, end2);
@@ -5235,8 +4373,7 @@ Transposing beyond buffer boundaries is an error. */)
5235 { 4373 {
5236 USE_SAFE_ALLOCA; 4374 USE_SAFE_ALLOCA;
5237 4375
5238 modify_text (start1, end1); 4376 modify_text (start1, end2);
5239 modify_text (start2, end2);
5240 record_change (start1, len1); 4377 record_change (start1, len1);
5241 record_change (start2, len2); 4378 record_change (start2, len2);
5242 tmp_interval1 = copy_intervals (cur_intv, start1, len1); 4379 tmp_interval1 = copy_intervals (cur_intv, start1, len1);
@@ -5362,6 +4499,7 @@ syms_of_editfns (void)
5362{ 4499{
5363 DEFSYM (Qbuffer_access_fontify_functions, "buffer-access-fontify-functions"); 4500 DEFSYM (Qbuffer_access_fontify_functions, "buffer-access-fontify-functions");
5364 DEFSYM (Qwall, "wall"); 4501 DEFSYM (Qwall, "wall");
4502 DEFSYM (Qpropertize, "propertize");
5365 4503
5366 DEFVAR_LISP ("inhibit-field-text-motion", Vinhibit_field_text_motion, 4504 DEFVAR_LISP ("inhibit-field-text-motion", Vinhibit_field_text_motion,
5367 doc: /* Non-nil means text motion commands don't notice fields. */); 4505 doc: /* Non-nil means text motion commands don't notice fields. */);
@@ -5406,7 +4544,27 @@ functions if all the text being accessed has this property. */);
5406 doc: /* The user's name, based upon the real uid only. */); 4544 doc: /* The user's name, based upon the real uid only. */);
5407 4545
5408 DEFVAR_LISP ("operating-system-release", Voperating_system_release, 4546 DEFVAR_LISP ("operating-system-release", Voperating_system_release,
5409 doc: /* The release of the operating system Emacs is running on. */); 4547 doc: /* The kernel version of the operating system on which Emacs is running.
4548The value is a string. It can also be nil if Emacs doesn't
4549know how to get the kernel version on the underlying OS. */);
4550
4551 DEFVAR_BOOL ("binary-as-unsigned",
4552 binary_as_unsigned,
4553 doc: /* Non-nil means `format' %x and %o treat integers as unsigned.
4554This has machine-dependent results. Nil means to treat integers as
4555signed, which is portable and is the default; for example, if N is a
4556negative integer, (read (format "#x%x" N)) returns N only when this
4557variable is nil.
4558
4559This variable is experimental; email 32252@debbugs.gnu.org if you need
4560it to be non-nil. */);
4561 binary_as_unsigned = false;
4562
4563 DEFSYM (Qrestrictions_locked, "restrictions-locked");
4564 DEFVAR_LISP ("restrictions-locked", Vrestrictions_locked,
4565 doc: /* If non-nil, restrictions are currently locked. */);
4566 Vrestrictions_locked = Qnil;
4567 Funintern (Qrestrictions_locked, Qnil);
5410 4568
5411 defsubr (&Spropertize); 4569 defsubr (&Spropertize);
5412 defsubr (&Schar_equal); 4570 defsubr (&Schar_equal);
@@ -5440,6 +4598,8 @@ functions if all the text being accessed has this property. */);
5440 4598
5441 defsubr (&Sline_beginning_position); 4599 defsubr (&Sline_beginning_position);
5442 defsubr (&Sline_end_position); 4600 defsubr (&Sline_end_position);
4601 defsubr (&Spos_bol);
4602 defsubr (&Spos_eol);
5443 4603
5444 defsubr (&Ssave_excursion); 4604 defsubr (&Ssave_excursion);
5445 defsubr (&Ssave_current_buffer); 4605 defsubr (&Ssave_current_buffer);
@@ -5469,7 +4629,10 @@ functions if all the text being accessed has this property. */);
5469 defsubr (&Sinsert_char); 4629 defsubr (&Sinsert_char);
5470 defsubr (&Sinsert_byte); 4630 defsubr (&Sinsert_byte);
5471 4631
4632 defsubr (&Sngettext);
4633
5472 defsubr (&Suser_login_name); 4634 defsubr (&Suser_login_name);
4635 defsubr (&Sgroup_name);
5473 defsubr (&Suser_real_login_name); 4636 defsubr (&Suser_real_login_name);
5474 defsubr (&Suser_uid); 4637 defsubr (&Suser_uid);
5475 defsubr (&Suser_real_uid); 4638 defsubr (&Suser_real_uid);
@@ -5477,18 +4640,6 @@ functions if all the text being accessed has this property. */);
5477 defsubr (&Sgroup_real_gid); 4640 defsubr (&Sgroup_real_gid);
5478 defsubr (&Suser_full_name); 4641 defsubr (&Suser_full_name);
5479 defsubr (&Semacs_pid); 4642 defsubr (&Semacs_pid);
5480 defsubr (&Scurrent_time);
5481 defsubr (&Stime_add);
5482 defsubr (&Stime_subtract);
5483 defsubr (&Stime_less_p);
5484 defsubr (&Sget_internal_run_time);
5485 defsubr (&Sformat_time_string);
5486 defsubr (&Sfloat_time);
5487 defsubr (&Sdecode_time);
5488 defsubr (&Sencode_time);
5489 defsubr (&Scurrent_time_string);
5490 defsubr (&Scurrent_time_zone);
5491 defsubr (&Sset_time_zone_rule);
5492 defsubr (&Ssystem_name); 4643 defsubr (&Ssystem_name);
5493 defsubr (&Smessage); 4644 defsubr (&Smessage);
5494 defsubr (&Smessage_box); 4645 defsubr (&Smessage_box);