diff options
Diffstat (limited to 'src/editfns.c')
| -rw-r--r-- | src/editfns.c | 1165 |
1 files changed, 668 insertions, 497 deletions
diff --git a/src/editfns.c b/src/editfns.c index 081ea0b3b7c..47509c23d04 100644 --- a/src/editfns.c +++ b/src/editfns.c @@ -47,6 +47,17 @@ along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. */ #include <errno.h> #include <float.h> #include <limits.h> +#include <math.h> + +#ifdef HAVE_TIMEZONE_T +# include <sys/param.h> +# if defined __NetBSD_Version__ && __NetBSD_Version__ < 700000000 +# define HAVE_TZALLOC_BUG true +# endif +#endif +#ifndef HAVE_TZALLOC_BUG +# define HAVE_TZALLOC_BUG false +#endif #include <c-ctype.h> #include <intprops.h> @@ -56,6 +67,7 @@ along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. */ #include "composite.h" #include "intervals.h" +#include "ptr-bounds.h" #include "character.h" #include "buffer.h" #include "coding.h" @@ -116,14 +128,10 @@ emacs_mktime_z (timezone_t tz, struct tm *tm) return t; } -/* Allocate a timezone, signaling on failure. */ -static timezone_t -xtzalloc (char const *name) +static _Noreturn void +invalid_time_zone_specification (Lisp_Object zone) { - timezone_t tz = tzalloc (name); - if (!tz) - memory_full (SIZE_MAX); - return tz; + xsignal2 (Qerror, build_string ("Invalid time zone specification"), zone); } /* Free a timezone, except do not free the time zone for local time. @@ -150,30 +158,30 @@ tzlookup (Lisp_Object zone, bool settz) if (NILP (zone)) return local_tz; - else if (EQ (zone, Qt)) + else if (EQ (zone, Qt) || EQ (zone, make_fixnum (0))) { zone_string = "UTC0"; new_tz = utc_tz; } else { - bool plain_integer = INTEGERP (zone); + bool plain_integer = FIXNUMP (zone); if (EQ (zone, Qwall)) zone_string = 0; else if (STRINGP (zone)) zone_string = SSDATA (ENCODE_SYSTEM (zone)); - else if (plain_integer || (CONSP (zone) && INTEGERP (XCAR (zone)) + else if (plain_integer || (CONSP (zone) && FIXNUMP (XCAR (zone)) && CONSP (XCDR (zone)))) { - Lisp_Object abbr; + Lisp_Object abbr UNINIT; if (!plain_integer) { abbr = XCAR (XCDR (zone)); zone = XCAR (zone); } - EMACS_INT abszone = eabs (XINT (zone)), hour = abszone / (60 * 60); + EMACS_INT abszone = eabs (XFIXNUM (zone)), hour = abszone / (60 * 60); int hour_remainder = abszone % (60 * 60); int min = hour_remainder / 60, sec = hour_remainder % 60; @@ -188,8 +196,8 @@ tzlookup (Lisp_Object zone, bool settz) prec += 2, numzone = 100 * numzone + sec; } sprintf (tzbuf, tzbuf_format, prec, - XINT (zone) < 0 ? -numzone : numzone, - &"-"[XINT (zone) < 0], hour, min, sec); + XFIXNUM (zone) < 0 ? -numzone : numzone, + &"-"[XFIXNUM (zone) < 0], hour, min, sec); zone_string = tzbuf; } else @@ -197,16 +205,32 @@ tzlookup (Lisp_Object zone, bool settz) AUTO_STRING (leading, "<"); AUTO_STRING_WITH_LEN (trailing, tzbuf, sprintf (tzbuf, trailing_tzbuf_format, - &"-"[XINT (zone) < 0], + &"-"[XFIXNUM (zone) < 0], hour, min, sec)); zone_string = SSDATA (concat3 (leading, ENCODE_SYSTEM (abbr), trailing)); } } else - xsignal2 (Qerror, build_string ("Invalid time zone specification"), - zone); - new_tz = xtzalloc (zone_string); + invalid_time_zone_specification (zone); + + new_tz = tzalloc (zone_string); + + if (HAVE_TZALLOC_BUG && !new_tz && errno != ENOMEM && plain_integer + && XFIXNUM (zone) % (60 * 60) == 0) + { + /* tzalloc mishandles POSIX strings; fall back on tzdb if + possible (Bug#30738). */ + sprintf (tzbuf, "Etc/GMT%+"pI"d", - (XFIXNUM (zone) / (60 * 60))); + new_tz = tzalloc (zone_string); + } + + if (!new_tz) + { + if (errno == ENOMEM) + memory_full (SIZE_MAX); + invalid_time_zone_specification (zone); + } } if (settz) @@ -305,7 +329,7 @@ init_editfns (bool dumping) else { uid_t euid = geteuid (); - tem = make_fixnum_or_float (euid); + tem = INT_TO_INTEGER (euid); } Vuser_full_name = Fuser_full_name (tem); @@ -335,7 +359,7 @@ usage: (char-to-string CHAR) */) unsigned char str[MAX_MULTIBYTE_LENGTH]; CHECK_CHARACTER (character); - c = XFASTINT (character); + c = XFIXNAT (character); len = CHAR_STRING (c, str); return make_string_from_bytes ((char *) str, 1, len); @@ -346,10 +370,10 @@ DEFUN ("byte-to-string", Fbyte_to_string, Sbyte_to_string, 1, 1, 0, (Lisp_Object byte) { unsigned char b; - CHECK_NUMBER (byte); - if (XINT (byte) < 0 || XINT (byte) > 255) + CHECK_FIXNUM (byte); + if (XFIXNUM (byte) < 0 || XFIXNUM (byte) > 255) error ("Invalid byte"); - b = XINT (byte); + b = XFIXNUM (byte); return make_string_from_bytes ((char *) &b, 1, 1); } @@ -397,8 +421,8 @@ The return value is POSITION. */) { if (MARKERP (position)) set_point_from_marker (position); - else if (INTEGERP (position)) - SET_PT (clip_to_bounds (BEGV, XINT (position), ZV)); + else if (FIXNUMP (position)) + SET_PT (clip_to_bounds (BEGV, XFIXNUM (position), ZV)); else wrong_type_argument (Qinteger_or_marker_p, position); return position; @@ -424,9 +448,9 @@ region_limit (bool beginningp) error ("The mark is not set now, so there is no region"); /* Clip to the current narrowing (bug#11770). */ - return make_number ((PT < XFASTINT (m)) == beginningp + return make_fixnum ((PT < XFIXNAT (m)) == beginningp ? PT - : clip_to_bounds (BEGV, XFASTINT (m), ZV)); + : clip_to_bounds (BEGV, XFIXNAT (m), ZV)); } DEFUN ("region-beginning", Fregion_beginning, Sregion_beginning, 0, 0, 0, @@ -460,21 +484,18 @@ If you set the marker not to point anywhere, the buffer will have no mark. */) static ptrdiff_t overlays_around (EMACS_INT pos, Lisp_Object *vec, ptrdiff_t len) { - Lisp_Object overlay, start, end; - struct Lisp_Overlay *tail; - ptrdiff_t startpos, endpos; ptrdiff_t idx = 0; - for (tail = current_buffer->overlays_before; tail; tail = tail->next) + for (struct Lisp_Overlay *tail = current_buffer->overlays_before; + tail; tail = tail->next) { - XSETMISC (overlay, tail); - - end = OVERLAY_END (overlay); - endpos = OVERLAY_POSITION (end); + Lisp_Object overlay = make_lisp_ptr (tail, Lisp_Vectorlike); + Lisp_Object end = OVERLAY_END (overlay); + ptrdiff_t endpos = OVERLAY_POSITION (end); if (endpos < pos) break; - start = OVERLAY_START (overlay); - startpos = OVERLAY_POSITION (start); + Lisp_Object start = OVERLAY_START (overlay); + ptrdiff_t startpos = OVERLAY_POSITION (start); if (startpos <= pos) { if (idx < len) @@ -484,16 +505,16 @@ overlays_around (EMACS_INT pos, Lisp_Object *vec, ptrdiff_t len) } } - for (tail = current_buffer->overlays_after; tail; tail = tail->next) + for (struct Lisp_Overlay *tail = current_buffer->overlays_after; + tail; tail = tail->next) { - XSETMISC (overlay, tail); - - start = OVERLAY_START (overlay); - startpos = OVERLAY_POSITION (start); + Lisp_Object overlay = make_lisp_ptr (tail, Lisp_Vectorlike); + Lisp_Object start = OVERLAY_START (overlay); + ptrdiff_t startpos = OVERLAY_POSITION (start); if (pos < startpos) break; - end = OVERLAY_END (overlay); - endpos = OVERLAY_POSITION (end); + Lisp_Object end = OVERLAY_END (overlay); + ptrdiff_t endpos = OVERLAY_POSITION (end); if (pos <= endpos) { if (idx < len) @@ -515,7 +536,7 @@ i.e. the property that a char would inherit if it were inserted at POSITION. */) (Lisp_Object position, register Lisp_Object prop, Lisp_Object object) { - CHECK_NUMBER_COERCE_MARKER (position); + CHECK_FIXNUM_COERCE_MARKER (position); if (NILP (object)) XSETBUFFER (object, current_buffer); @@ -529,7 +550,7 @@ at POSITION. */) return Fget_text_property (position, prop, object); else { - EMACS_INT posn = XINT (position); + EMACS_INT posn = XFIXNUM (position); ptrdiff_t noverlays; Lisp_Object *overlay_vec, tem; struct buffer *obuf = current_buffer; @@ -582,8 +603,8 @@ at POSITION. */) if (stickiness > 0) return Fget_text_property (position, prop, object); else if (stickiness < 0 - && XINT (position) > BUF_BEGV (XBUFFER (object))) - return Fget_text_property (make_number (XINT (position) - 1), + && XFIXNUM (position) > BUF_BEGV (XBUFFER (object))) + return Fget_text_property (make_fixnum (XFIXNUM (position) - 1), prop, object); else return Qnil; @@ -626,13 +647,13 @@ find_field (Lisp_Object pos, Lisp_Object merge_at_boundary, if (NILP (pos)) XSETFASTINT (pos, PT); else - CHECK_NUMBER_COERCE_MARKER (pos); + CHECK_FIXNUM_COERCE_MARKER (pos); after_field = get_char_property_and_overlay (pos, Qfield, Qnil, NULL); before_field - = (XFASTINT (pos) > BEGV - ? get_char_property_and_overlay (make_number (XINT (pos) - 1), + = (XFIXNAT (pos) > BEGV + ? get_char_property_and_overlay (make_fixnum (XFIXNUM (pos) - 1), Qfield, Qnil, NULL) /* Using nil here would be a more obvious choice, but it would fail when the buffer starts with a non-sticky field. */ @@ -686,7 +707,7 @@ find_field (Lisp_Object pos, Lisp_Object merge_at_boundary, if (at_field_start) /* POS is at the edge of a field, and we should consider it as the beginning of the following field. */ - *beg = XFASTINT (pos); + *beg = XFIXNAT (pos); else /* Find the previous field boundary. */ { @@ -698,7 +719,7 @@ find_field (Lisp_Object pos, Lisp_Object merge_at_boundary, p = Fprevious_single_char_property_change (p, Qfield, Qnil, beg_limit); - *beg = NILP (p) ? BEGV : XFASTINT (p); + *beg = NILP (p) ? BEGV : XFIXNAT (p); } } @@ -707,7 +728,7 @@ find_field (Lisp_Object pos, Lisp_Object merge_at_boundary, if (at_field_end) /* POS is at the edge of a field, and we should consider it as the end of the previous field. */ - *end = XFASTINT (pos); + *end = XFIXNAT (pos); else /* Find the next field boundary. */ { @@ -718,7 +739,7 @@ find_field (Lisp_Object pos, Lisp_Object merge_at_boundary, pos = Fnext_single_char_property_change (pos, Qfield, Qnil, end_limit); - *end = NILP (pos) ? ZV : XFASTINT (pos); + *end = NILP (pos) ? ZV : XFIXNAT (pos); } } } @@ -771,7 +792,7 @@ is before LIMIT, then LIMIT will be returned instead. */) { ptrdiff_t beg; find_field (pos, escape_from_edge, limit, &beg, Qnil, 0); - return make_number (beg); + return make_fixnum (beg); } DEFUN ("field-end", Ffield_end, Sfield_end, 0, 3, 0, @@ -786,7 +807,7 @@ is after LIMIT, then LIMIT will be returned instead. */) { ptrdiff_t end; find_field (pos, escape_from_edge, Qnil, 0, limit, &end); - return make_number (end); + return make_fixnum (end); } DEFUN ("constrain-to-field", Fconstrain_to_field, Sconstrain_to_field, 2, 5, 0, @@ -832,13 +853,13 @@ Field boundaries are not noticed if `inhibit-field-text-motion' is non-nil. */) XSETFASTINT (new_pos, PT); } - CHECK_NUMBER_COERCE_MARKER (new_pos); - CHECK_NUMBER_COERCE_MARKER (old_pos); + CHECK_FIXNUM_COERCE_MARKER (new_pos); + CHECK_FIXNUM_COERCE_MARKER (old_pos); - fwd = (XINT (new_pos) > XINT (old_pos)); + fwd = (XFIXNUM (new_pos) > XFIXNUM (old_pos)); - prev_old = make_number (XINT (old_pos) - 1); - prev_new = make_number (XINT (new_pos) - 1); + prev_old = make_fixnum (XFIXNUM (old_pos) - 1); + prev_new = make_fixnum (XFIXNUM (new_pos) - 1); if (NILP (Vinhibit_field_text_motion) && !EQ (new_pos, old_pos) @@ -848,16 +869,16 @@ Field boundaries are not noticed if `inhibit-field-text-motion' is non-nil. */) previous positions; we could use `Fget_pos_property' instead, but in itself that would fail inside non-sticky fields (like comint prompts). */ - || (XFASTINT (new_pos) > BEGV + || (XFIXNAT (new_pos) > BEGV && !NILP (Fget_char_property (prev_new, Qfield, Qnil))) - || (XFASTINT (old_pos) > BEGV + || (XFIXNAT (old_pos) > BEGV && !NILP (Fget_char_property (prev_old, Qfield, Qnil)))) && (NILP (inhibit_capture_property) /* Field boundaries are again a problem; but now we must decide the case exactly, so we need to call `get_pos_property' as well. */ || (NILP (Fget_pos_property (old_pos, inhibit_capture_property, Qnil)) - && (XFASTINT (old_pos) <= BEGV + && (XFIXNAT (old_pos) <= BEGV || NILP (Fget_char_property (old_pos, inhibit_capture_property, Qnil)) || NILP (Fget_char_property @@ -877,7 +898,7 @@ Field boundaries are not noticed if `inhibit-field-text-motion' is non-nil. */) other side of NEW_POS, which would mean that NEW_POS is already acceptable, and it's not necessary to constrain it to FIELD_BOUND. */ - ((XFASTINT (field_bound) < XFASTINT (new_pos)) ? fwd : !fwd) + ((XFIXNAT (field_bound) < XFIXNAT (new_pos)) ? fwd : !fwd) /* NEW_POS should be constrained, but only if either ONLY_IN_LINE is nil (in which case any constraint is OK), or NEW_POS and FIELD_BOUND are on the same line (in which @@ -886,16 +907,16 @@ Field boundaries are not noticed if `inhibit-field-text-motion' is non-nil. */) /* This is the ONLY_IN_LINE case, check that NEW_POS and FIELD_BOUND are on the same line by seeing whether there's an intervening newline or not. */ - || (find_newline (XFASTINT (new_pos), -1, - XFASTINT (field_bound), -1, + || (find_newline (XFIXNAT (new_pos), -1, + XFIXNAT (field_bound), -1, fwd ? -1 : 1, &shortage, NULL, 1), shortage != 0))) /* Constrain NEW_POS to FIELD_BOUND. */ new_pos = field_bound; - if (orig_point && XFASTINT (new_pos) != orig_point) + if (orig_point && XFIXNAT (new_pos) != orig_point) /* The NEW_POS argument was originally nil, so automatically set PT. */ - SET_PT (XFASTINT (new_pos)); + SET_PT (XFIXNAT (new_pos)); } return new_pos; @@ -926,13 +947,13 @@ This function does not move point. */) if (NILP (n)) XSETFASTINT (n, 1); else - CHECK_NUMBER (n); + CHECK_FIXNUM (n); - scan_newline_from_point (XINT (n) - 1, &charpos, &bytepos); + scan_newline_from_point (XFIXNUM (n) - 1, &charpos, &bytepos); /* Return END constrained to the current input field. */ - return Fconstrain_to_field (make_number (charpos), make_number (PT), - XINT (n) != 1 ? Qt : Qnil, + return Fconstrain_to_field (make_fixnum (charpos), make_fixnum (PT), + XFIXNUM (n) != 1 ? Qt : Qnil, Qt, Qnil); } @@ -961,69 +982,57 @@ This function does not move point. */) if (NILP (n)) XSETFASTINT (n, 1); else - CHECK_NUMBER (n); + CHECK_FIXNUM (n); - clipped_n = clip_to_bounds (PTRDIFF_MIN + 1, XINT (n), PTRDIFF_MAX); + clipped_n = clip_to_bounds (PTRDIFF_MIN + 1, XFIXNUM (n), PTRDIFF_MAX); end_pos = find_before_next_newline (orig, 0, clipped_n - (clipped_n <= 0), NULL); /* Return END_POS constrained to the current input field. */ - return Fconstrain_to_field (make_number (end_pos), make_number (orig), + return Fconstrain_to_field (make_fixnum (end_pos), make_fixnum (orig), Qnil, Qt, Qnil); } -/* Save current buffer state for `save-excursion' special form. - We (ab)use Lisp_Misc_Save_Value to allow explicit free and so - offload some work from GC. */ +/* Save current buffer state for save-excursion special form. */ -Lisp_Object -save_excursion_save (void) +void +save_excursion_save (union specbinding *pdl) { - return make_save_obj_obj_obj_obj - (Fpoint_marker (), - Qnil, - /* Selected window if current buffer is shown in it, nil otherwise. */ - (EQ (XWINDOW (selected_window)->contents, Fcurrent_buffer ()) - ? selected_window : Qnil), - Qnil); + eassert (pdl->unwind_excursion.kind == SPECPDL_UNWIND_EXCURSION); + pdl->unwind_excursion.marker = Fpoint_marker (); + /* Selected window if current buffer is shown in it, nil otherwise. */ + pdl->unwind_excursion.window + = (EQ (XWINDOW (selected_window)->contents, Fcurrent_buffer ()) + ? selected_window : Qnil); } /* Restore saved buffer before leaving `save-excursion' special form. */ void -save_excursion_restore (Lisp_Object info) +save_excursion_restore (Lisp_Object marker, Lisp_Object window) { - Lisp_Object tem, tem1; - - tem = Fmarker_buffer (XSAVE_OBJECT (info, 0)); + Lisp_Object buffer = Fmarker_buffer (marker); /* If we're unwinding to top level, saved buffer may be deleted. This - means that all of its markers are unchained and so tem is nil. */ - if (NILP (tem)) - goto out; + means that all of its markers are unchained and so BUFFER is nil. */ + if (NILP (buffer)) + return; - Fset_buffer (tem); + Fset_buffer (buffer); /* Point marker. */ - tem = XSAVE_OBJECT (info, 0); - Fgoto_char (tem); - unchain_marker (XMARKER (tem)); + Fgoto_char (marker); + unchain_marker (XMARKER (marker)); /* If buffer was visible in a window, and a different window was selected, and the old selected window is still showing this buffer, restore point in that window. */ - tem = XSAVE_OBJECT (info, 2); - if (WINDOWP (tem) - && !EQ (tem, selected_window) - && (tem1 = XWINDOW (tem)->contents, - (/* Window is live... */ - BUFFERP (tem1) - /* ...and it shows the current buffer. */ - && XBUFFER (tem1) == current_buffer))) - Fset_window_point (tem, make_number (PT)); - - out: - - free_misc (info); + if (WINDOWP (window) && !EQ (window, selected_window)) + { + /* Set window point if WINDOW is live and shows the current buffer. */ + Lisp_Object contents = XWINDOW (window)->contents; + if (BUFFERP (contents) && XBUFFER (contents) == current_buffer) + Fset_window_point (window, make_fixnum (PT)); + } } DEFUN ("save-excursion", Fsave_excursion, Ssave_excursion, 0, UNEVALLED, 0, @@ -1045,7 +1054,7 @@ usage: (save-excursion &rest BODY) */) register Lisp_Object val; ptrdiff_t count = SPECPDL_INDEX (); - record_unwind_protect (save_excursion_restore, save_excursion_save ()); + record_unwind_protect_excursion (); val = Fprogn (args); return unbind_to (count, val); @@ -1076,11 +1085,11 @@ in some other BUFFER, use (Lisp_Object buffer) { if (NILP (buffer)) - return make_number (Z - BEG); + return make_fixnum (Z - BEG); else { CHECK_BUFFER (buffer); - return make_number (BUF_Z (XBUFFER (buffer)) + return make_fixnum (BUF_Z (XBUFFER (buffer)) - BUF_BEG (XBUFFER (buffer))); } } @@ -1148,10 +1157,10 @@ DEFUN ("position-bytes", Fposition_bytes, Sposition_bytes, 1, 1, 0, If POSITION is out of range, the value is nil. */) (Lisp_Object position) { - CHECK_NUMBER_COERCE_MARKER (position); - if (XINT (position) < BEG || XINT (position) > Z) + CHECK_FIXNUM_COERCE_MARKER (position); + if (XFIXNUM (position) < BEG || XFIXNUM (position) > Z) return Qnil; - return make_number (CHAR_TO_BYTE (XINT (position))); + return make_fixnum (CHAR_TO_BYTE (XFIXNUM (position))); } DEFUN ("byte-to-position", Fbyte_to_position, Sbyte_to_position, 1, 1, 0, @@ -1161,8 +1170,8 @@ If BYTEPOS is out of range, the value is nil. */) { ptrdiff_t pos_byte; - CHECK_NUMBER (bytepos); - pos_byte = XINT (bytepos); + CHECK_FIXNUM (bytepos); + pos_byte = XFIXNUM (bytepos); if (pos_byte < BEG_BYTE || pos_byte > Z_BYTE) return Qnil; if (Z != Z_BYTE) @@ -1172,7 +1181,7 @@ If BYTEPOS is out of range, the value is nil. */) character. */ while (!CHAR_HEAD_P (FETCH_BYTE (pos_byte))) pos_byte--; - return make_number (BYTE_TO_CHAR (pos_byte)); + return make_fixnum (BYTE_TO_CHAR (pos_byte)); } DEFUN ("following-char", Ffollowing_char, Sfollowing_char, 0, 0, 0, @@ -1257,10 +1266,10 @@ If POS is out of range, the value is nil. */) if (NILP (pos)) { pos_byte = PT_BYTE; - XSETFASTINT (pos, PT); + if (pos_byte < BEGV_BYTE || pos_byte >= ZV_BYTE) + return Qnil; } - - if (MARKERP (pos)) + else if (MARKERP (pos)) { pos_byte = marker_byte_position (pos); if (pos_byte < BEGV_BYTE || pos_byte >= ZV_BYTE) @@ -1268,14 +1277,14 @@ If POS is out of range, the value is nil. */) } else { - CHECK_NUMBER_COERCE_MARKER (pos); - if (XINT (pos) < BEGV || XINT (pos) >= ZV) + CHECK_FIXNUM_COERCE_MARKER (pos); + if (XFIXNUM (pos) < BEGV || XFIXNUM (pos) >= ZV) return Qnil; - pos_byte = CHAR_TO_BYTE (XINT (pos)); + pos_byte = CHAR_TO_BYTE (XFIXNUM (pos)); } - return make_number (FETCH_CHAR (pos_byte)); + return make_fixnum (FETCH_CHAR (pos_byte)); } DEFUN ("char-before", Fchar_before, Schar_before, 0, 1, 0, @@ -1302,12 +1311,12 @@ If POS is out of range, the value is nil. */) } else { - CHECK_NUMBER_COERCE_MARKER (pos); + CHECK_FIXNUM_COERCE_MARKER (pos); - if (XINT (pos) <= BEGV || XINT (pos) > ZV) + if (XFIXNUM (pos) <= BEGV || XFIXNUM (pos) > ZV) return Qnil; - pos_byte = CHAR_TO_BYTE (XINT (pos)); + pos_byte = CHAR_TO_BYTE (XFIXNUM (pos)); } if (!NILP (BVAR (current_buffer, enable_multibyte_characters))) @@ -1329,7 +1338,7 @@ This is based on the effective uid, not the real uid. Also, if the environment variables LOGNAME or USER are set, that determines the value of this function. -If optional argument UID is an integer or a float, return the login name +If optional argument UID is an integer, return the login name of the user with that uid, or nil if there is no such user. */) (Lisp_Object uid) { @@ -1369,38 +1378,38 @@ This ignores the environment variables LOGNAME and USER, so it differs from DEFUN ("user-uid", Fuser_uid, Suser_uid, 0, 0, 0, doc: /* Return the effective uid of Emacs. -Value is an integer or a float, depending on the value. */) +Value is a fixnum, if it's small enough, otherwise a bignum. */) (void) { uid_t euid = geteuid (); - return make_fixnum_or_float (euid); + return INT_TO_INTEGER (euid); } DEFUN ("user-real-uid", Fuser_real_uid, Suser_real_uid, 0, 0, 0, doc: /* Return the real uid of Emacs. -Value is an integer or a float, depending on the value. */) +Value is a fixnum, if it's small enough, otherwise a bignum. */) (void) { uid_t uid = getuid (); - return make_fixnum_or_float (uid); + return INT_TO_INTEGER (uid); } DEFUN ("group-gid", Fgroup_gid, Sgroup_gid, 0, 0, 0, doc: /* Return the effective gid of Emacs. -Value is an integer or a float, depending on the value. */) +Value is a fixnum, if it's small enough, otherwise a bignum. */) (void) { gid_t egid = getegid (); - return make_fixnum_or_float (egid); + return INT_TO_INTEGER (egid); } DEFUN ("group-real-gid", Fgroup_real_gid, Sgroup_real_gid, 0, 0, 0, doc: /* Return the real gid of Emacs. -Value is an integer or a float, depending on the value. */) +Value is a fixnum, if it's small enough, otherwise a bignum. */) (void) { gid_t gid = getgid (); - return make_fixnum_or_float (gid); + return INT_TO_INTEGER (gid); } DEFUN ("user-full-name", Fuser_full_name, Suser_full_name, 0, 1, 0, @@ -1408,7 +1417,7 @@ DEFUN ("user-full-name", Fuser_full_name, Suser_full_name, 0, 1, 0, If the full name corresponding to Emacs's userid is not known, return "unknown". -If optional argument UID is an integer or float, return the full name +If optional argument UID is an integer, return the full name of the user with that uid, or nil if there is no such user. If UID is a string, return the full name of the user with that login name, or nil if there is no such user. */) @@ -1451,7 +1460,7 @@ name, or nil if there is no such user. */) /* Substitute the login name for the &, upcasing the first character. */ if (q) { - Lisp_Object login = Fuser_login_name (make_number (pw->pw_uid)); + Lisp_Object login = Fuser_login_name (make_fixnum (pw->pw_uid)); USE_SAFE_ALLOCA; char *r = SAFE_ALLOCA (strlen (p) + SBYTES (login) + 1); memcpy (r, p, q - p); @@ -1476,11 +1485,12 @@ DEFUN ("system-name", Fsystem_name, Ssystem_name, 0, 0, 0, } DEFUN ("emacs-pid", Femacs_pid, Semacs_pid, 0, 0, 0, - doc: /* Return the process ID of Emacs, as a number. */) + doc: /* Return the process ID of Emacs, as a number. +Value is a fixnum, if it's small enough, otherwise a bignum. */) (void) { pid_t pid = getpid (); - return make_fixnum_or_float (pid); + return INT_TO_INTEGER (pid); } @@ -1579,13 +1589,21 @@ time_subtract (struct lisp_time ta, struct lisp_time tb) } static Lisp_Object -time_arith (Lisp_Object a, Lisp_Object b, - struct lisp_time (*op) (struct lisp_time, struct lisp_time)) +time_arith (Lisp_Object a, Lisp_Object b, bool subtract) { + if (FLOATP (a) && !isfinite (XFLOAT_DATA (a))) + { + double da = XFLOAT_DATA (a); + double db = XFLOAT_DATA (Ffloat_time (b)); + return make_float (subtract ? da - db : da + db); + } + if (FLOATP (b) && !isfinite (XFLOAT_DATA (b))) + return subtract ? make_float (-XFLOAT_DATA (b)) : b; + int alen, blen; struct lisp_time ta = lisp_time_struct (a, &alen); struct lisp_time tb = lisp_time_struct (b, &blen); - struct lisp_time t = op (ta, tb); + struct lisp_time t = (subtract ? time_subtract : time_add) (ta, tb); if (FIXNUM_OVERFLOW_P (t.hi)) time_overflow (); Lisp_Object val = Qnil; @@ -1593,14 +1611,14 @@ time_arith (Lisp_Object a, Lisp_Object b, switch (max (alen, blen)) { default: - val = Fcons (make_number (t.ps), val); + val = Fcons (make_fixnum (t.ps), val); FALLTHROUGH; case 3: - val = Fcons (make_number (t.us), val); + val = Fcons (make_fixnum (t.us), val); FALLTHROUGH; case 2: - val = Fcons (make_number (t.lo), val); - val = Fcons (make_number (t.hi), val); + val = Fcons (make_fixnum (t.lo), val); + val = Fcons (make_fixnum (t.hi), val); break; } @@ -1613,7 +1631,7 @@ A nil value for either argument stands for the current time. See `current-time-string' for the various forms of a time value. */) (Lisp_Object a, Lisp_Object b) { - return time_arith (a, b, time_add); + return time_arith (a, b, false); } DEFUN ("time-subtract", Ftime_subtract, Stime_subtract, 2, 2, 0, @@ -1623,7 +1641,30 @@ A nil value for either argument stands for the current time. See `current-time-string' for the various forms of a time value. */) (Lisp_Object a, Lisp_Object b) { - return time_arith (a, b, time_subtract); + return time_arith (a, b, true); +} + +/* Return negative, 0, positive if a < b, a == b, a > b respectively. + Return positive if either a or b is a NaN; this is good enough + for the current callers. */ +static int +time_cmp (Lisp_Object a, Lisp_Object b) +{ + if ((FLOATP (a) && !isfinite (XFLOAT_DATA (a))) + || (FLOATP (b) && !isfinite (XFLOAT_DATA (b)))) + { + double da = FLOATP (a) ? XFLOAT_DATA (a) : 0; + double db = FLOATP (b) ? XFLOAT_DATA (b) : 0; + return da < db ? -1 : da != db; + } + + int alen, blen; + struct lisp_time ta = lisp_time_struct (a, &alen); + struct lisp_time tb = lisp_time_struct (b, &blen); + return (ta.hi != tb.hi ? (ta.hi < tb.hi ? -1 : 1) + : ta.lo != tb.lo ? (ta.lo < tb.lo ? -1 : 1) + : ta.us != tb.us ? (ta.us < tb.us ? -1 : 1) + : ta.ps < tb.ps ? -1 : ta.ps != tb.ps); } DEFUN ("time-less-p", Ftime_less_p, Stime_less_p, 2, 2, 0, @@ -1632,22 +1673,23 @@ A nil value for either argument stands for the current time. See `current-time-string' for the various forms of a time value. */) (Lisp_Object t1, Lisp_Object t2) { - int t1len, t2len; - struct lisp_time a = lisp_time_struct (t1, &t1len); - struct lisp_time b = lisp_time_struct (t2, &t2len); - return ((a.hi != b.hi ? a.hi < b.hi - : a.lo != b.lo ? a.lo < b.lo - : a.us != b.us ? a.us < b.us - : a.ps < b.ps) - ? Qt : Qnil); + return time_cmp (t1, t2) < 0 ? Qt : Qnil; +} + +DEFUN ("time-equal-p", Ftime_equal_p, Stime_equal_p, 2, 2, 0, + doc: /* Return non-nil if T1 and T2 are equal time values. +A nil value for either argument stands for the current time. +See `current-time-string' for the various forms of a time value. */) + (Lisp_Object t1, Lisp_Object t2) +{ + return time_cmp (t1, t2) == 0 ? Qt : Qnil; } DEFUN ("get-internal-run-time", Fget_internal_run_time, Sget_internal_run_time, 0, 0, 0, doc: /* Return the current run time used by Emacs. -The time is returned as a list (HIGH LOW USEC PSEC), using the same -style as (current-time). +The time is returned as in the style of `current-time'. On systems that can't determine the run time, `get-internal-run-time' does the same thing as `current-time'. */) @@ -1702,10 +1744,10 @@ disassemble_lisp_time (Lisp_Object specified_time, Lisp_Object *phigh, Lisp_Object *plow, Lisp_Object *pusec, Lisp_Object *ppsec) { - Lisp_Object high = make_number (0); + Lisp_Object high = make_fixnum (0); Lisp_Object low = specified_time; - Lisp_Object usec = make_number (0); - Lisp_Object psec = make_number (0); + Lisp_Object usec = make_fixnum (0); + Lisp_Object psec = make_fixnum (0); int len = 4; if (CONSP (specified_time)) @@ -1802,9 +1844,10 @@ decode_time_components (Lisp_Object high, Lisp_Object low, Lisp_Object usec, Lisp_Object psec, struct lisp_time *result, double *dresult) { - EMACS_INT hi, lo, us, ps; - if (! (INTEGERP (high) - && INTEGERP (usec) && INTEGERP (psec))) + EMACS_INT hi, us, ps; + intmax_t lo; + if (! (FIXNUMP (high) + && FIXNUMP (usec) && FIXNUMP (psec))) return 0; if (! INTEGERP (low)) { @@ -1835,16 +1878,18 @@ decode_time_components (Lisp_Object high, Lisp_Object low, Lisp_Object usec, return 0; } - hi = XINT (high); - lo = XINT (low); - us = XINT (usec); - ps = XINT (psec); + hi = XFIXNUM (high); + if (! integer_to_intmax (low, &lo)) + return -1; + us = XFIXNUM (usec); + ps = XFIXNUM (psec); /* Normalize out-of-range lower-order components by carrying each overflow into the next higher-order component. */ us += ps / 1000000 - (ps % 1000000 < 0); lo += us / 1000000 - (us % 1000000 < 0); - hi += lo >> LO_TIME_BITS; + if (INT_ADD_WRAPV (lo >> LO_TIME_BITS, hi, &hi)) + return -1; ps = ps % 1000000 + 1000000 * (ps % 1000000 < 0); us = us % 1000000 + 1000000 * (us % 1000000 < 0); lo &= (1 << LO_TIME_BITS) - 1; @@ -1921,8 +1966,8 @@ lisp_seconds_argument (Lisp_Object specified_time) int val = disassemble_lisp_time (specified_time, &high, &low, &usec, &psec); if (val != 0) { - val = decode_time_components (high, low, make_number (0), - make_number (0), &t, 0); + val = decode_time_components (high, low, make_fixnum (0), + make_fixnum (0), &t, 0); if (0 < val && ! ((TYPE_SIGNED (time_t) ? TIME_T_MIN >> LO_TIME_BITS <= t.hi @@ -2152,7 +2197,8 @@ between 0 and 23. DAY is an integer between 1 and 31. MONTH is an integer between 1 and 12. YEAR is an integer indicating the four-digit year. DOW is the day of week, an integer between 0 and 6, where 0 is Sunday. DST is t if daylight saving time is in effect, -otherwise nil. UTCOFF is an integer indicating the UTC offset in +nil if it is not in effect, and -1 if this information is +not available. UTCOFF is an integer indicating the UTC offset in seconds, i.e., the number of seconds east of Greenwich. (Note that Common Lisp has different meanings for DOW and UTCOFF.) @@ -2174,18 +2220,19 @@ usage: (decode-time &optional TIME ZONE) */) EMACS_INT tm_year_base = TM_YEAR_BASE; return CALLN (Flist, - make_number (local_tm.tm_sec), - make_number (local_tm.tm_min), - make_number (local_tm.tm_hour), - make_number (local_tm.tm_mday), - make_number (local_tm.tm_mon + 1), - make_number (local_tm.tm_year + tm_year_base), - make_number (local_tm.tm_wday), - local_tm.tm_isdst ? Qt : Qnil, + make_fixnum (local_tm.tm_sec), + make_fixnum (local_tm.tm_min), + make_fixnum (local_tm.tm_hour), + make_fixnum (local_tm.tm_mday), + make_fixnum (local_tm.tm_mon + 1), + make_fixnum (local_tm.tm_year + tm_year_base), + make_fixnum (local_tm.tm_wday), + (local_tm.tm_isdst < 0 ? make_fixnum (-1) + : local_tm.tm_isdst == 0 ? Qnil : Qt), (HAVE_TM_GMTOFF - ? make_number (tm_gmtoff (&local_tm)) + ? make_fixnum (tm_gmtoff (&local_tm)) : gmtime_r (&time_spec, &gmt_tm) - ? make_number (tm_diff (&local_tm, &gmt_tm)) + ? make_fixnum (tm_diff (&local_tm, &gmt_tm)) : Qnil)); } @@ -2194,8 +2241,8 @@ usage: (decode-time &optional TIME ZONE) */) static int check_tm_member (Lisp_Object obj, int offset) { - CHECK_NUMBER (obj); - EMACS_INT n = XINT (obj); + CHECK_FIXNUM (obj); + EMACS_INT n = XFIXNUM (obj); int result; if (INT_SUBTRACT_WRAPV (n, offset, &result)) time_overflow (); @@ -2377,7 +2424,7 @@ the data it can't find. */) long int offset = (HAVE_TM_GMTOFF ? tm_gmtoff (&local_tm) : tm_diff (&local_tm, &gmt_tm)); - zone_offset = make_number (offset); + zone_offset = make_fixnum (offset); if (SCHARS (zone_name) == 0) { /* No local time zone name is available; use numeric zone instead. */ @@ -2520,7 +2567,7 @@ general_insert_function (void (*insert_func) val = args[argnum]; if (CHARACTERP (val)) { - int c = XFASTINT (val); + int c = XFIXNAT (val); unsigned char str[MAX_MULTIBYTE_LENGTH]; int len; @@ -2676,18 +2723,18 @@ called interactively, INHERIT is t. */) CHECK_CHARACTER (character); if (NILP (count)) XSETFASTINT (count, 1); - CHECK_NUMBER (count); - c = XFASTINT (character); + CHECK_FIXNUM (count); + c = XFIXNAT (character); if (!NILP (BVAR (current_buffer, enable_multibyte_characters))) len = CHAR_STRING (c, str); else str[0] = c, len = 1; - if (XINT (count) <= 0) + if (XFIXNUM (count) <= 0) return Qnil; - if (BUF_BYTES_MAX / len < XINT (count)) + if (BUF_BYTES_MAX / len < XFIXNUM (count)) buffer_overflow (); - n = XINT (count) * len; + n = XFIXNUM (count) * len; stringlen = min (n, sizeof string - sizeof string % len); for (i = 0; i < stringlen; i++) string[i] = str[i % len]; @@ -2720,12 +2767,12 @@ The optional third arg INHERIT, if non-nil, says to inherit text properties from adjoining text, if those properties are sticky. */) (Lisp_Object byte, Lisp_Object count, Lisp_Object inherit) { - CHECK_NUMBER (byte); - if (XINT (byte) < 0 || XINT (byte) > 255) - args_out_of_range_3 (byte, make_number (0), make_number (255)); - if (XINT (byte) >= 128 + CHECK_FIXNUM (byte); + if (XFIXNUM (byte) < 0 || XFIXNUM (byte) > 255) + args_out_of_range_3 (byte, make_fixnum (0), make_fixnum (255)); + if (XFIXNUM (byte) >= 128 && ! NILP (BVAR (current_buffer, enable_multibyte_characters))) - XSETFASTINT (byte, BYTE8_TO_CHAR (XINT (byte))); + XSETFASTINT (byte, BYTE8_TO_CHAR (XFIXNUM (byte))); return Finsert_char (byte, count, inherit); } @@ -2808,10 +2855,10 @@ make_buffer_string_both (ptrdiff_t start, ptrdiff_t start_byte, { update_buffer_properties (start, end); - tem = Fnext_property_change (make_number (start), Qnil, make_number (end)); - tem1 = Ftext_properties_at (make_number (start), Qnil); + tem = Fnext_property_change (make_fixnum (start), Qnil, make_fixnum (end)); + tem1 = Ftext_properties_at (make_fixnum (start), Qnil); - if (XINT (tem) != end || !NILP (tem1)) + if (XFIXNUM (tem) != end || !NILP (tem1)) copy_intervals_to_string (result, current_buffer, start, end - start); } @@ -2834,7 +2881,7 @@ update_buffer_properties (ptrdiff_t start, ptrdiff_t end) if (!NILP (Vbuffer_access_fontified_property)) { Lisp_Object tem - = Ftext_property_any (make_number (start), make_number (end), + = Ftext_property_any (make_fixnum (start), make_fixnum (end), Vbuffer_access_fontified_property, Qnil, Qnil); if (NILP (tem)) @@ -2842,7 +2889,7 @@ update_buffer_properties (ptrdiff_t start, ptrdiff_t end) } CALLN (Frun_hook_with_args, Qbuffer_access_fontify_functions, - make_number (start), make_number (end)); + make_fixnum (start), make_fixnum (end)); } } @@ -2860,8 +2907,8 @@ use `buffer-substring-no-properties' instead. */) register ptrdiff_t b, e; validate_region (&start, &end); - b = XINT (start); - e = XINT (end); + b = XFIXNUM (start); + e = XFIXNUM (end); return make_buffer_string (b, e, 1); } @@ -2876,8 +2923,8 @@ they can be in either order. */) register ptrdiff_t b, e; validate_region (&start, &end); - b = XINT (start); - e = XINT (end); + b = XFIXNUM (start); + e = XFIXNUM (end); return make_buffer_string (b, e, 0); } @@ -2922,15 +2969,15 @@ using `string-make-multibyte' or `string-make-unibyte', which see. */) b = BUF_BEGV (bp); else { - CHECK_NUMBER_COERCE_MARKER (start); - b = XINT (start); + CHECK_FIXNUM_COERCE_MARKER (start); + b = XFIXNUM (start); } if (NILP (end)) e = BUF_ZV (bp); else { - CHECK_NUMBER_COERCE_MARKER (end); - e = XINT (end); + CHECK_FIXNUM_COERCE_MARKER (end); + e = XFIXNUM (end); } if (b > e) @@ -2990,15 +3037,15 @@ determines whether case is significant or ignored. */) begp1 = BUF_BEGV (bp1); else { - CHECK_NUMBER_COERCE_MARKER (start1); - begp1 = XINT (start1); + CHECK_FIXNUM_COERCE_MARKER (start1); + begp1 = XFIXNUM (start1); } if (NILP (end1)) endp1 = BUF_ZV (bp1); else { - CHECK_NUMBER_COERCE_MARKER (end1); - endp1 = XINT (end1); + CHECK_FIXNUM_COERCE_MARKER (end1); + endp1 = XFIXNUM (end1); } if (begp1 > endp1) @@ -3028,15 +3075,15 @@ determines whether case is significant or ignored. */) begp2 = BUF_BEGV (bp2); else { - CHECK_NUMBER_COERCE_MARKER (start2); - begp2 = XINT (start2); + CHECK_FIXNUM_COERCE_MARKER (start2); + begp2 = XFIXNUM (start2); } if (NILP (end2)) endp2 = BUF_ZV (bp2); else { - CHECK_NUMBER_COERCE_MARKER (end2); - endp2 = XINT (end2); + CHECK_FIXNUM_COERCE_MARKER (end2); + endp2 = XFIXNUM (end2); } if (begp2 > endp2) @@ -3091,7 +3138,7 @@ determines whether case is significant or ignored. */) } if (c1 != c2) - return make_number (c1 < c2 ? -1 - chars : chars + 1); + return make_fixnum (c1 < c2 ? -1 - chars : chars + 1); chars++; rarely_quit (chars); @@ -3100,12 +3147,12 @@ determines whether case is significant or ignored. */) /* The strings match as far as they go. If one is shorter, that one is less. */ if (chars < endp1 - begp1) - return make_number (chars + 1); + return make_fixnum (chars + 1); else if (chars < endp2 - begp2) - return make_number (- chars - 1); + return make_fixnum (- chars - 1); /* Same length too => they are equal. */ - return make_number (0); + return make_fixnum (0); } @@ -3195,6 +3242,8 @@ differences between the two buffers. */) return Qnil; } + ptrdiff_t count = SPECPDL_INDEX (); + /* FIXME: It is not documented how to initialize the contents of the context structure. This code cargo-cults from the existing caller in src/analyze.c of GNU Diffutils, which appears to @@ -3235,8 +3284,7 @@ differences between the two buffers. */) Fundo_boundary (); bool modification_hooks_inhibited = false; - ptrdiff_t count = SPECPDL_INDEX (); - record_unwind_protect (save_excursion_restore, save_excursion_save ()); + record_unwind_protect_excursion (); /* We are going to make a lot of small modifications, and having the modification hooks called for each of them will slow us down. @@ -3285,15 +3333,14 @@ differences between the two buffers. */) if (beg_b < end_b) { SET_PT (beg_a); - Finsert_buffer_substring (source, make_natnum (beg_b), - make_natnum (end_b)); + Finsert_buffer_substring (source, make_fixed_natnum (beg_b), + make_fixed_natnum (end_b)); } } --i; --j; } - unbind_to (count, Qnil); - SAFE_FREE (); + SAFE_FREE_UNBIND_TO (count, Qnil); rbc_quitcounter = 0; if (modification_hooks_inhibited) @@ -3414,8 +3461,8 @@ Both characters must have the same length of multi-byte form. */) validate_region (&start, &end); CHECK_CHARACTER (fromchar); CHECK_CHARACTER (tochar); - fromc = XFASTINT (fromchar); - toc = XFASTINT (tochar); + fromc = XFIXNAT (fromchar); + toc = XFIXNAT (tochar); if (multibyte_p) { @@ -3441,9 +3488,9 @@ Both characters must have the same length of multi-byte form. */) tostr[0] = toc; } - pos = XINT (start); + pos = XFIXNUM (start); pos_byte = CHAR_TO_BYTE (pos); - stop = CHAR_TO_BYTE (XINT (end)); + stop = CHAR_TO_BYTE (XFIXNUM (end)); end_byte = stop; /* If we don't want undo, turn off putting stuff on the list. @@ -3491,7 +3538,7 @@ Both characters must have the same length of multi-byte form. */) else if (!changed) { changed = -1; - modify_text (pos, XINT (end)); + modify_text (pos, XFIXNUM (end)); if (! NILP (noundo)) { @@ -3558,8 +3605,7 @@ Both characters must have the same length of multi-byte form. */) update_compositions (changed, last_changed, CHECK_ALL); } - unbind_to (count, Qnil); - return Qnil; + return unbind_to (count, Qnil); } @@ -3615,7 +3661,7 @@ check_translation (ptrdiff_t pos, ptrdiff_t pos_byte, ptrdiff_t end, buf[buf_used++] = STRING_CHAR_AND_LENGTH (p, len1); pos_byte += len1; } - if (XINT (AREF (elt, i)) != buf[i]) + if (XFIXNUM (AREF (elt, i)) != buf[i]) break; } if (i == len) @@ -3667,9 +3713,9 @@ It returns the number of characters changed. */) tt = SDATA (table); } - pos = XINT (start); + pos = XFIXNUM (start); pos_byte = CHAR_TO_BYTE (pos); - end_pos = XINT (end); + end_pos = XFIXNUM (end); modify_text (pos, end_pos); cnt = 0; @@ -3718,7 +3764,7 @@ It returns the number of characters changed. */) val = CHAR_TABLE_REF (table, oc); if (CHARACTERP (val)) { - nc = XFASTINT (val); + nc = XFIXNAT (val); str_len = CHAR_STRING (nc, buf); str = buf; } @@ -3779,7 +3825,7 @@ It returns the number of characters changed. */) } else { - string = Fmake_string (make_number (1), val); + string = Fmake_string (make_fixnum (1), val, Qnil); } replace_range (pos, pos + len, string, 1, 0, 1, 0); pos_byte += SBYTES (string); @@ -3793,7 +3839,7 @@ It returns the number of characters changed. */) pos++; } - return make_number (cnt); + return make_fixnum (cnt); } DEFUN ("delete-region", Fdelete_region, Sdelete_region, 2, 2, "r", @@ -3803,7 +3849,7 @@ This command deletes buffer text without modifying the kill ring. */) (Lisp_Object start, Lisp_Object end) { validate_region (&start, &end); - del_range (XINT (start), XINT (end)); + del_range (XFIXNUM (start), XFIXNUM (end)); return Qnil; } @@ -3813,9 +3859,9 @@ DEFUN ("delete-and-extract-region", Fdelete_and_extract_region, (Lisp_Object start, Lisp_Object end) { validate_region (&start, &end); - if (XINT (start) == XINT (end)) + if (XFIXNUM (start) == XFIXNUM (end)) return empty_unibyte_string; - return del_range_1 (XINT (start), XINT (end), 1, 1); + return del_range_1 (XFIXNUM (start), XFIXNUM (end), 1, 1); } DEFUN ("widen", Fwiden, Swiden, 0, 0, "", @@ -3844,27 +3890,27 @@ When calling from a program, pass two arguments; positions (integers or markers) bounding the text that should remain visible. */) (register Lisp_Object start, Lisp_Object end) { - CHECK_NUMBER_COERCE_MARKER (start); - CHECK_NUMBER_COERCE_MARKER (end); + CHECK_FIXNUM_COERCE_MARKER (start); + CHECK_FIXNUM_COERCE_MARKER (end); - if (XINT (start) > XINT (end)) + if (XFIXNUM (start) > XFIXNUM (end)) { Lisp_Object tem; tem = start; start = end; end = tem; } - if (!(BEG <= XINT (start) && XINT (start) <= XINT (end) && XINT (end) <= Z)) + if (!(BEG <= XFIXNUM (start) && XFIXNUM (start) <= XFIXNUM (end) && XFIXNUM (end) <= Z)) args_out_of_range (start, end); - if (BEGV != XFASTINT (start) || ZV != XFASTINT (end)) + if (BEGV != XFIXNAT (start) || ZV != XFIXNAT (end)) current_buffer->clip_changed = 1; - SET_BUF_BEGV (current_buffer, XFASTINT (start)); - SET_BUF_ZV (current_buffer, XFASTINT (end)); - if (PT < XFASTINT (start)) - SET_PT (XFASTINT (start)); - if (PT > XFASTINT (end)) - SET_PT (XFASTINT (end)); + SET_BUF_BEGV (current_buffer, XFIXNAT (start)); + SET_BUF_ZV (current_buffer, XFIXNAT (end)); + if (PT < XFIXNAT (start)) + SET_PT (XFIXNAT (start)); + if (PT > XFIXNAT (end)) + SET_PT (XFIXNAT (end)); /* Changing the buffer bounds invalidates any recorded current column. */ invalidate_current_column (); return Qnil; @@ -4110,8 +4156,8 @@ usage: (propertize STRING &rest PROPERTIES) */) for (i = 1; i < nargs; i += 2) properties = Fcons (args[i], Fcons (args[i + 1], properties)); - Fadd_text_properties (make_number (0), - make_number (SCHARS (string)), + Fadd_text_properties (make_fixnum (0), + make_fixnum (SCHARS (string)), properties, string); return string; } @@ -4171,14 +4217,14 @@ Nth argument is substituted instead of the next one. A format can contain either numbered or unnumbered %-sequences but not both, except that %% can be mixed with numbered %-sequences. -The + flag character inserts a + before any positive number, while a -space inserts a space before any positive number; these flags only -affect %d, %e, %f, and %g sequences, and the + flag takes precedence. +The + flag character inserts a + before any nonnegative number, while a +space inserts a space before any nonnegative number; these flags +affect only numeric %-sequences, and the + flag takes precedence. The - and 0 flags affect the width specifier, as described below. The # flag means to use an alternate display form for %o, %x, %X, %e, %f, and %g sequences: for %o, it ensures that the result begins with -\"0\"; for %x and %X, it prefixes the result with \"0x\" or \"0X\"; +\"0\"; for %x and %X, it prefixes nonzero results with \"0x\" or \"0X\"; for %e and %f, it causes a decimal point to be included even if the precision is zero; for %g, it causes a decimal point to be included even if the precision is zero, and also forces trailing @@ -4228,8 +4274,26 @@ usage: (format-message STRING &rest OBJECTS) */) static Lisp_Object styled_format (ptrdiff_t nargs, Lisp_Object *args, bool message) { + enum + { + /* Maximum precision for a %f conversion such that the trailing + output digit might be nonzero. Any precision larger than this + will not yield useful information. */ + USEFUL_PRECISION_MAX = ((1 - LDBL_MIN_EXP) + * (FLT_RADIX == 2 || FLT_RADIX == 10 ? 1 + : FLT_RADIX == 16 ? 4 + : -1)), + + /* Maximum number of bytes (including terminating null) generated + by any format, if precision is no more than USEFUL_PRECISION_MAX. + On all practical hosts, %Lf is the worst case. */ + SPRINTF_BUFSIZE = (sizeof "-." + (LDBL_MAX_10_EXP + 1) + + USEFUL_PRECISION_MAX) + }; + verify (USEFUL_PRECISION_MAX > 0); + ptrdiff_t n; /* The number of the next arg to substitute. */ - char initial_buffer[4000]; + char initial_buffer[1000 + SPRINTF_BUFSIZE]; char *buf = initial_buffer; ptrdiff_t bufsize = sizeof initial_buffer; ptrdiff_t max_bufsize = STRING_BYTES_BOUND + 1; @@ -4273,9 +4337,9 @@ styled_format (ptrdiff_t nargs, Lisp_Object *args, bool message) ptrdiff_t nspec_bound = SCHARS (args[0]) >> 1; /* Allocate the info and discarded tables. */ - ptrdiff_t alloca_size; - if (INT_MULTIPLY_WRAPV (nspec_bound, sizeof *info, &alloca_size) - || INT_ADD_WRAPV (formatlen, alloca_size, &alloca_size) + ptrdiff_t info_size, alloca_size; + if (INT_MULTIPLY_WRAPV (nspec_bound, sizeof *info, &info_size) + || INT_ADD_WRAPV (formatlen, info_size, &alloca_size) || SIZE_MAX < alloca_size) memory_full (SIZE_MAX); info = SAFE_ALLOCA (alloca_size); @@ -4283,6 +4347,8 @@ styled_format (ptrdiff_t nargs, Lisp_Object *args, bool message) string was not copied into the output. It is 2 if byte I was not the first byte of its character. */ char *discarded = (char *) &info[nspec_bound]; + info = ptr_bounds_clip (info, info_size); + discarded = ptr_bounds_clip (discarded, formatlen); memset (discarded, 0, formatlen); /* Try to determine whether the result should be multibyte. @@ -4332,8 +4398,14 @@ styled_format (ptrdiff_t nargs, Lisp_Object *args, bool message) char const *convsrc = format; unsigned char format_char = *format++; - /* Bytes needed to represent the output of this conversion. */ + /* Number of bytes to be preallocated for the next directive's + output. At the end of each iteration this is at least + CONVBYTES_ROOM, and is greater if the current directive + output was so large that it will be retried after buffer + reallocation. */ ptrdiff_t convbytes = 1; + enum { CONVBYTES_ROOM = SPRINTF_BUFSIZE - 1 }; + eassert (p <= buf + bufsize - SPRINTF_BUFSIZE); if (format_char == '%') { @@ -4453,7 +4525,7 @@ styled_format (ptrdiff_t nargs, Lisp_Object *args, bool message) } else if (conversion == 'c') { - if (INTEGERP (arg) && ! ASCII_CHAR_P (XINT (arg))) + if (FIXNUMP (arg) && ! ASCII_CHAR_P (XFIXNUM (arg))) { if (!multibyte) { @@ -4569,7 +4641,7 @@ styled_format (ptrdiff_t nargs, Lisp_Object *args, bool message) spec->intervals = arg_intervals = true; new_result = true; - continue; + convbytes = CONVBYTES_ROOM; } } else if (! (conversion == 'c' || conversion == 'd' @@ -4578,43 +4650,13 @@ styled_format (ptrdiff_t nargs, Lisp_Object *args, bool message) || conversion == 'X')) error ("Invalid format operation %%%c", STRING_CHAR ((unsigned char *) format - 1)); - else if (! (INTEGERP (arg) || (FLOATP (arg) && conversion != 'c'))) + else if (! (FIXNUMP (arg) || ((BIGNUMP (arg) || FLOATP (arg)) + && conversion != 'c'))) error ("Format specifier doesn't match argument type"); else { - enum - { - /* Lower bound on the number of bits per - base-FLT_RADIX digit. */ - DIG_BITS_LBOUND = FLT_RADIX < 16 ? 1 : 4, - - /* 1 if integers should be formatted as long doubles, - because they may be so large that there is a rounding - error when converting them to double, and long doubles - are wider than doubles. */ - INT_AS_LDBL = (DIG_BITS_LBOUND * DBL_MANT_DIG < FIXNUM_BITS - 1 - && DBL_MANT_DIG < LDBL_MANT_DIG), - - /* Maximum precision for a %f conversion such that the - trailing output digit might be nonzero. Any precision - larger than this will not yield useful information. */ - USEFUL_PRECISION_MAX = - ((1 - LDBL_MIN_EXP) - * (FLT_RADIX == 2 || FLT_RADIX == 10 ? 1 - : FLT_RADIX == 16 ? 4 - : -1)), - - /* Maximum number of bytes generated by any format, if - precision is no more than USEFUL_PRECISION_MAX. - On all practical hosts, %f is the worst case. */ - SPRINTF_BUFSIZE = - sizeof "-." + (LDBL_MAX_10_EXP + 1) + USEFUL_PRECISION_MAX, - - /* Length of pM (that is, of pMd without the - trailing "d"). */ - pMlen = sizeof pMd - 2 - }; - verify (USEFUL_PRECISION_MAX > 0); + /* Length of pM (that is, of pMd without the trailing "d"). */ + enum { pMlen = sizeof pMd - 2 }; /* Avoid undefined behavior in underlying sprintf. */ if (conversion == 'd' || conversion == 'i') @@ -4625,219 +4667,308 @@ styled_format (ptrdiff_t nargs, Lisp_Object *args, bool message) with "L" possibly inserted for floating-point formats, and with pM inserted for integer formats. At most two flags F can be specified at once. */ - char convspec[sizeof "%FF.*d" + max (INT_AS_LDBL, pMlen)]; - { - char *f = convspec; - *f++ = '%'; - /* MINUS_FLAG and ZERO_FLAG are dealt with later. */ - *f = '+'; f += plus_flag; - *f = ' '; f += space_flag; - *f = '#'; f += sharp_flag; - *f++ = '.'; - *f++ = '*'; - if (float_conversion) - { - if (INT_AS_LDBL) - { - *f = 'L'; - f += INTEGERP (arg); - } - } - else if (conversion != 'c') - { - memcpy (f, pMd, pMlen); - f += pMlen; - zero_flag &= ! precision_given; - } - *f++ = conversion; - *f = '\0'; - } + char convspec[sizeof "%FF.*d" + max (sizeof "L" - 1, pMlen)]; + char *f = convspec; + *f++ = '%'; + /* MINUS_FLAG and ZERO_FLAG are dealt with later. */ + *f = '+'; f += plus_flag; + *f = ' '; f += space_flag; + *f = '#'; f += sharp_flag; + *f++ = '.'; + *f++ = '*'; + if (! (float_conversion || conversion == 'c')) + { + memcpy (f, pMd, pMlen); + f += pMlen; + zero_flag &= ! precision_given; + } + *f++ = conversion; + *f = '\0'; int prec = -1; if (precision_given) prec = min (precision, USEFUL_PRECISION_MAX); - /* Use sprintf to format this number into sprintf_buf. Omit + /* Characters to be inserted after spaces and before + leading zeros. This can occur with bignums, since + bignum_to_string does only leading '-'. */ + char prefix[sizeof "-0x" - 1]; + int prefixlen = 0; + + /* Use sprintf or bignum_to_string to format this number. Omit padding and excess precision, though, because sprintf limits - output length to INT_MAX. + output length to INT_MAX and bignum_to_string doesn't + do padding or precision. - There are four types of conversion: double, unsigned + Use five sprintf conversions: double, long double, unsigned char (passed as int), wide signed int, and wide unsigned int. Treat them separately because the sprintf ABI is sensitive to which type is passed. Be careful about integer overflow, NaNs, infinities, and conversions; for example, the min and max macros are not suitable here. */ - char sprintf_buf[SPRINTF_BUFSIZE]; ptrdiff_t sprintf_bytes; if (float_conversion) { - if (INT_AS_LDBL && INTEGERP (arg)) + /* Format as a long double if the arg is an integer + that would lose less information than when formatting + it as a double. Otherwise, format as a double; + this is likely to be faster and better-tested. */ + + bool format_as_long_double = false; + double darg; + long double ldarg; + + if (FLOATP (arg)) + darg = XFLOAT_DATA (arg); + else + { + bool format_bignum_as_double = false; + if (LDBL_MANT_DIG <= DBL_MANT_DIG) + { + if (FIXNUMP (arg)) + darg = XFIXNUM (arg); + else + format_bignum_as_double = true; + } + else + { + if (INTEGERP (arg)) + { + intmax_t iarg; + uintmax_t uarg; + if (integer_to_intmax (arg, &iarg)) + ldarg = iarg; + else if (integer_to_uintmax (arg, &uarg)) + ldarg = uarg; + else + format_bignum_as_double = true; + } + if (!format_bignum_as_double) + { + darg = ldarg; + format_as_long_double = darg != ldarg; + } + } + if (format_bignum_as_double) + darg = bignum_to_double (arg); + } + + if (format_as_long_double) { - /* Although long double may have a rounding error if - DIG_BITS_LBOUND * LDBL_MANT_DIG < FIXNUM_BITS - 1, - it is more accurate than plain 'double'. */ - long double x = XINT (arg); - sprintf_bytes = sprintf (sprintf_buf, convspec, prec, x); + f[-1] = 'L'; + *f++ = conversion; + *f = '\0'; + sprintf_bytes = sprintf (p, convspec, prec, ldarg); } else - sprintf_bytes = sprintf (sprintf_buf, convspec, prec, - XFLOATINT (arg)); + sprintf_bytes = sprintf (p, convspec, prec, darg); } else if (conversion == 'c') { /* Don't use sprintf here, as it might mishandle prec. */ - sprintf_buf[0] = XINT (arg); + p[0] = XFIXNUM (arg); + p[1] = '\0'; sprintf_bytes = prec != 0; } + else if (BIGNUMP (arg)) + { + int base = ((conversion == 'd' || conversion == 'i') ? 10 + : conversion == 'o' ? 8 : 16); + sprintf_bytes = bignum_bufsize (arg, base); + if (sprintf_bytes <= buf + bufsize - p) + { + int signedbase = conversion == 'X' ? -base : base; + sprintf_bytes = bignum_to_c_string (p, sprintf_bytes, + arg, signedbase); + bool negative = p[0] == '-'; + prec = min (precision, sprintf_bytes - prefixlen); + prefix[prefixlen] = plus_flag ? '+' : ' '; + prefixlen += (plus_flag | space_flag) & !negative; + prefix[prefixlen] = '0'; + prefix[prefixlen + 1] = conversion; + prefixlen += sharp_flag && base == 16 ? 2 : 0; + } + } else if (conversion == 'd' || conversion == 'i') { - /* For float, maybe we should use "%1.0f" - instead so it also works for values outside - the integer range. */ - printmax_t x; - if (INTEGERP (arg)) - x = XINT (arg); + if (FIXNUMP (arg)) + { + printmax_t x = XFIXNUM (arg); + sprintf_bytes = sprintf (p, convspec, prec, x); + } else { - double d = XFLOAT_DATA (arg); - if (d < 0) - { - x = TYPE_MINIMUM (printmax_t); - if (x < d) - x = d; - } - else - { - x = TYPE_MAXIMUM (printmax_t); - if (d < x) - x = d; - } + strcpy (f - pMlen - 1, "f"); + double x = XFLOAT_DATA (arg); + + /* Truncate and then convert -0 to 0, to be more + consistent with %x etc.; see Bug#31938. */ + x = trunc (x); + x = x ? x : 0; + + sprintf_bytes = sprintf (p, convspec, 0, x); + bool signedp = ! c_isdigit (p[0]); + prec = min (precision, sprintf_bytes - signedp); } - sprintf_bytes = sprintf (sprintf_buf, convspec, prec, x); } else { - /* Don't sign-extend for octal or hex printing. */ uprintmax_t x; - if (INTEGERP (arg)) - x = XUINT (arg); - else + bool negative; + if (FIXNUMP (arg)) { - double d = XFLOAT_DATA (arg); - if (d < 0) - x = 0; + if (binary_as_unsigned) + { + x = XUFIXNUM (arg); + negative = false; + } else { - x = TYPE_MAXIMUM (uprintmax_t); - if (d < x) - x = d; + EMACS_INT i = XFIXNUM (arg); + negative = i < 0; + x = negative ? -i : i; } } - sprintf_bytes = sprintf (sprintf_buf, convspec, prec, x); + else + { + double d = XFLOAT_DATA (arg); + double uprintmax = TYPE_MAXIMUM (uprintmax_t); + if (! (0 <= d && d < uprintmax + 1)) + xsignal1 (Qoverflow_error, arg); + x = d; + negative = false; + } + p[0] = negative ? '-' : plus_flag ? '+' : ' '; + bool signedp = negative | plus_flag | space_flag; + sprintf_bytes = sprintf (p + signedp, convspec, prec, x); + sprintf_bytes += signedp; } /* Now the length of the formatted item is known, except it omits padding and excess precision. Deal with excess precision - first. This happens only when the format specifies - ridiculously large precision. */ + first. This happens when the format specifies ridiculously + large precision, or when %d or %i formats a float that would + ordinarily need fewer digits than a specified precision, + or when a bignum is formatted using an integer format + with enough precision. */ ptrdiff_t excess_precision = precision_given ? precision - prec : 0; - ptrdiff_t leading_zeros = 0, trailing_zeros = 0; - if (excess_precision) + ptrdiff_t trailing_zeros = 0; + if (excess_precision != 0 && float_conversion) { - if (float_conversion) - { - if ((conversion == 'g' && ! sharp_flag) - || ! ('0' <= sprintf_buf[sprintf_bytes - 1] - && sprintf_buf[sprintf_bytes - 1] <= '9')) - excess_precision = 0; - else - { - if (conversion == 'g') - { - char *dot = strchr (sprintf_buf, '.'); - if (!dot) - excess_precision = 0; - } - } - trailing_zeros = excess_precision; - } - else - leading_zeros = excess_precision; + if (! c_isdigit (p[sprintf_bytes - 1]) + || (conversion == 'g' + && ! (sharp_flag && strchr (p, '.')))) + excess_precision = 0; + trailing_zeros = excess_precision; } + ptrdiff_t leading_zeros = excess_precision - trailing_zeros; /* Compute the total bytes needed for this item, including excess precision and padding. */ ptrdiff_t numwidth; - if (INT_ADD_WRAPV (sprintf_bytes, excess_precision, &numwidth)) + if (INT_ADD_WRAPV (prefixlen + sprintf_bytes, excess_precision, + &numwidth)) numwidth = PTRDIFF_MAX; ptrdiff_t padding = numwidth < field_width ? field_width - numwidth : 0; - if (max_bufsize - sprintf_bytes <= excess_precision + if (max_bufsize - (prefixlen + sprintf_bytes) <= excess_precision || max_bufsize - padding <= numwidth) string_overflow (); convbytes = numwidth + padding; if (convbytes <= buf + bufsize - p) { - /* Copy the formatted item from sprintf_buf into buf, - inserting padding and excess-precision zeros. */ - - char *src = sprintf_buf; - char src0 = src[0]; - int exponent_bytes = 0; - bool signedp = src0 == '-' || src0 == '+' || src0 == ' '; - unsigned char after_sign = src[signedp]; - if (zero_flag && 0 <= char_hexdigit (after_sign)) + bool signedp = p[0] == '-' || p[0] == '+' || p[0] == ' '; + int beglen = (signedp + + ((p[signedp] == '0' + && (p[signedp + 1] == 'x' + || p[signedp + 1] == 'X')) + ? 2 : 0)); + eassert (prefixlen == 0 || beglen == 0 + || (beglen == 1 && p[0] == '-' + && ! (prefix[0] == '-' || prefix[0] == '+' + || prefix[0] == ' '))); + if (zero_flag && 0 <= char_hexdigit (p[beglen])) { leading_zeros += padding; padding = 0; } + if (leading_zeros == 0 && sharp_flag && conversion == 'o' + && p[beglen] != '0') + { + leading_zeros++; + padding -= padding != 0; + } - if (excess_precision + int endlen = 0; + if (trailing_zeros && (conversion == 'e' || conversion == 'g')) { - char *e = strchr (src, 'e'); + char *e = strchr (p, 'e'); if (e) - exponent_bytes = src + sprintf_bytes - e; + endlen = p + sprintf_bytes - e; } - spec->start = nchars; - if (! minus_flag) - { - memset (p, ' ', padding); - p += padding; - nchars += padding; - } + ptrdiff_t midlen = sprintf_bytes - beglen - endlen; + ptrdiff_t leading_padding = minus_flag ? 0 : padding; + ptrdiff_t trailing_padding = padding - leading_padding; - *p = src0; - src += signedp; - p += signedp; - memset (p, '0', leading_zeros); - p += leading_zeros; - int significand_bytes - = sprintf_bytes - signedp - exponent_bytes; - memcpy (p, src, significand_bytes); - p += significand_bytes; - src += significand_bytes; - memset (p, '0', trailing_zeros); - p += trailing_zeros; - memcpy (p, src, exponent_bytes); - p += exponent_bytes; - - nchars += leading_zeros + sprintf_bytes + trailing_zeros; + /* Insert padding and excess-precision zeros. The output + contains the following components, in left-to-right order: - if (minus_flag) + LEADING_PADDING spaces. + BEGLEN bytes taken from the start of sprintf output. + PREFIXLEN bytes taken from the start of the prefix array. + LEADING_ZEROS zeros. + MIDLEN bytes taken from the middle of sprintf output. + TRAILING_ZEROS zeros. + ENDLEN bytes taken from the end of sprintf output. + TRAILING_PADDING spaces. + + The sprintf output is taken from the buffer starting at + P and continuing for SPRINTF_BYTES bytes. */ + + ptrdiff_t incr + = (padding + leading_zeros + prefixlen + + sprintf_bytes + trailing_zeros); + + /* Optimize for the typical case with padding or zeros. */ + if (incr != sprintf_bytes) { - memset (p, ' ', padding); - p += padding; - nchars += padding; + /* Move data to make room to insert spaces and '0's. + As this may entail overlapping moves, process + the output right-to-left and use memmove. + With any luck this code is rarely executed. */ + char *src = p + sprintf_bytes; + char *dst = p + incr; + dst -= trailing_padding; + memset (dst, ' ', trailing_padding); + src -= endlen; + dst -= endlen; + memmove (dst, src, endlen); + dst -= trailing_zeros; + memset (dst, '0', trailing_zeros); + src -= midlen; + dst -= midlen; + memmove (dst, src, midlen); + dst -= leading_zeros; + memset (dst, '0', leading_zeros); + dst -= prefixlen; + memcpy (dst, prefix, prefixlen); + src -= beglen; + dst -= beglen; + memmove (dst, src, beglen); + dst -= leading_padding; + memset (dst, ' ', leading_padding); } - spec->end = nchars; + p += incr; + spec->start = nchars; + spec->end = nchars += incr; new_result = true; - continue; + convbytes = CONVBYTES_ROOM; } } } @@ -4890,43 +5021,51 @@ styled_format (ptrdiff_t nargs, Lisp_Object *args, bool message) } copy_char: - if (convbytes <= buf + bufsize - p) - { - memcpy (p, convsrc, convbytes); - p += convbytes; - nchars++; - continue; - } + memcpy (p, convsrc, convbytes); + p += convbytes; + nchars++; + convbytes = CONVBYTES_ROOM; } - /* There wasn't enough room to store this conversion or single - character. CONVBYTES says how much room is needed. Allocate - enough room (and then some) and do it again. */ - ptrdiff_t used = p - buf; - if (max_bufsize - used < convbytes) + ptrdiff_t buflen_needed; + if (INT_ADD_WRAPV (used, convbytes, &buflen_needed)) string_overflow (); - bufsize = used + convbytes; - bufsize = bufsize < max_bufsize / 2 ? bufsize * 2 : max_bufsize; - - if (buf == initial_buffer) - { - buf = xmalloc (bufsize); - sa_must_free = true; - buf_save_value_index = SPECPDL_INDEX (); - record_unwind_protect_ptr (xfree, buf); - memcpy (buf, initial_buffer, used); - } - else + if (bufsize <= buflen_needed) { - buf = xrealloc (buf, bufsize); - set_unwind_protect_ptr (buf_save_value_index, xfree, buf); - } + if (max_bufsize <= buflen_needed) + string_overflow (); + + /* Either there wasn't enough room to store this conversion, + or there won't be enough room to do a sprintf the next + time through the loop. Allocate enough room (and then some). */ + + bufsize = (buflen_needed <= max_bufsize / 2 + ? buflen_needed * 2 : max_bufsize); + + if (buf == initial_buffer) + { + buf = xmalloc (bufsize); + buf_save_value_index = SPECPDL_INDEX (); + record_unwind_protect_ptr (xfree, buf); + memcpy (buf, initial_buffer, used); + } + else + { + buf = xrealloc (buf, bufsize); + set_unwind_protect_ptr (buf_save_value_index, xfree, buf); + } - p = buf + used; - format = format0; - n = n0; - ispec = ispec0; + p = buf + used; + if (convbytes != CONVBYTES_ROOM) + { + /* There wasn't enough room for this conversion; do it over. */ + eassert (CONVBYTES_ROOM < convbytes); + format = format0; + n = n0; + ispec = ispec0; + } + } } if (bufsize < p - buf) @@ -4949,8 +5088,8 @@ styled_format (ptrdiff_t nargs, Lisp_Object *args, bool message) if (string_intervals (args[0]) || arg_intervals) { /* Add text properties from the format string. */ - Lisp_Object len = make_number (SCHARS (args[0])); - Lisp_Object props = text_property_list (args[0], make_number (0), + Lisp_Object len = make_fixnum (SCHARS (args[0])); + Lisp_Object props = text_property_list (args[0], make_fixnum (0), len, Qnil); if (CONSP (props)) { @@ -4974,7 +5113,7 @@ styled_format (ptrdiff_t nargs, Lisp_Object *args, bool message) Lisp_Object item = XCAR (list); /* First adjust the property start position. */ - ptrdiff_t pos = XINT (XCAR (item)); + ptrdiff_t pos = XFIXNUM (XCAR (item)); /* Advance BYTEPOS, POSITION, TRANSLATED and ARGN up to this position. */ @@ -4995,10 +5134,10 @@ styled_format (ptrdiff_t nargs, Lisp_Object *args, bool message) } } - XSETCAR (item, make_number (translated)); + XSETCAR (item, make_fixnum (translated)); /* Likewise adjust the property end position. */ - pos = XINT (XCAR (XCDR (item))); + pos = XFIXNUM (XCAR (XCDR (item))); for (; position < pos; bytepos++) { @@ -5017,10 +5156,10 @@ styled_format (ptrdiff_t nargs, Lisp_Object *args, bool message) } } - XSETCAR (XCDR (item), make_number (translated)); + XSETCAR (XCDR (item), make_fixnum (translated)); } - add_text_properties_from_list (val, props, make_number (0)); + add_text_properties_from_list (val, props, make_fixnum (0)); } /* Add text properties from arguments. */ @@ -5028,17 +5167,17 @@ styled_format (ptrdiff_t nargs, Lisp_Object *args, bool message) for (ptrdiff_t i = 0; i < nspec; i++) if (info[i].intervals) { - len = make_number (SCHARS (info[i].argument)); - Lisp_Object new_len = make_number (info[i].end - info[i].start); + len = make_fixnum (SCHARS (info[i].argument)); + Lisp_Object new_len = make_fixnum (info[i].end - info[i].start); props = text_property_list (info[i].argument, - make_number (0), len, Qnil); + make_fixnum (0), len, Qnil); props = extend_property_ranges (props, len, new_len); /* If successive arguments have properties, be sure that the value of `composition' property be the copy. */ if (1 < i && info[i - 1].end) make_composition_value_copy (props); add_text_properties_from_list (val, props, - make_number (info[i].start)); + make_fixnum (info[i].start)); } } @@ -5061,13 +5200,13 @@ Case is ignored if `case-fold-search' is non-nil in the current buffer. */) CHECK_CHARACTER (c1); CHECK_CHARACTER (c2); - if (XINT (c1) == XINT (c2)) + if (XFIXNUM (c1) == XFIXNUM (c2)) return Qt; if (NILP (BVAR (current_buffer, case_fold_search))) return Qnil; - i1 = XFASTINT (c1); - i2 = XFASTINT (c2); + i1 = XFIXNAT (c1); + i2 = XFIXNAT (c2); /* FIXME: It is possible to compare multibyte characters even when the current buffer is unibyte. Unfortunately this is ambiguous @@ -5170,7 +5309,16 @@ transpose_markers (ptrdiff_t start1, ptrdiff_t end1, } } -DEFUN ("transpose-regions", Ftranspose_regions, Stranspose_regions, 4, 5, 0, +DEFUN ("transpose-regions", Ftranspose_regions, Stranspose_regions, 4, 5, + "(if (< (length mark-ring) 2)\ + (error \"Other region must be marked before transposing two regions\")\ + (let* ((num (if current-prefix-arg\ + (prefix-numeric-value current-prefix-arg)\ + 0))\ + (ring-length (length mark-ring))\ + (eltnum (mod num ring-length))\ + (eltnum2 (mod (1+ num) ring-length)))\ + (list (point) (mark) (elt mark-ring eltnum) (elt mark-ring eltnum2))))", doc: /* Transpose region STARTR1 to ENDR1 with STARTR2 to ENDR2. The regions should not be overlapping, because the size of the buffer is never changed in a transposition. @@ -5178,7 +5326,14 @@ never changed in a transposition. Optional fifth arg LEAVE-MARKERS, if non-nil, means don't update any markers that happen to be located in the regions. -Transposing beyond buffer boundaries is an error. */) +Transposing beyond buffer boundaries is an error. + +Interactively, STARTR1 and ENDR1 are point and mark; STARTR2 and ENDR2 +are the last two marks pushed to the mark ring; LEAVE-MARKERS is nil. +If a prefix argument N is given, STARTR2 and ENDR2 are the two +successive marks N entries back in the mark ring. A negative prefix +argument instead counts forward from the oldest mark in the mark +ring. */) (Lisp_Object startr1, Lisp_Object endr1, Lisp_Object startr2, Lisp_Object endr2, Lisp_Object leave_markers) { register ptrdiff_t start1, end1, start2, end2; @@ -5195,10 +5350,10 @@ Transposing beyond buffer boundaries is an error. */) validate_region (&startr1, &endr1); validate_region (&startr2, &endr2); - start1 = XFASTINT (startr1); - end1 = XFASTINT (endr1); - start2 = XFASTINT (startr2); - end2 = XFASTINT (endr2); + start1 = XFIXNAT (startr1); + end1 = XFIXNAT (endr1); + start2 = XFIXNAT (startr2); + end2 = XFIXNAT (endr2); gap = GPT; /* Swap the regions if they're reversed. */ @@ -5351,8 +5506,7 @@ Transposing beyond buffer boundaries is an error. */) { USE_SAFE_ALLOCA; - modify_text (start1, end1); - modify_text (start2, end2); + modify_text (start1, end2); record_change (start1, len1); record_change (start2, len2); tmp_interval1 = copy_intervals (cur_intv, start1, len1); @@ -5525,6 +5679,22 @@ functions if all the text being accessed has this property. */); DEFVAR_LISP ("operating-system-release", Voperating_system_release, doc: /* The release of the operating system Emacs is running on. */); + DEFVAR_BOOL ("binary-as-unsigned", + binary_as_unsigned, + doc: /* Non-nil means `format' %x and %o treat integers as unsigned. +This has machine-dependent results. Nil means to treat integers as +signed, which is portable; for example, if N is a negative integer, +(read (format "#x%x") N) returns N only when this variable is nil. + +This variable is experimental; email 32252@debbugs.gnu.org if you need +it to be non-nil. */); + /* For now, default to true if bignums exist, false in traditional Emacs. */ +#ifdef lisp_h_FIXNUMP + binary_as_unsigned = false; +#else + binary_as_unsigned = true; +#endif + defsubr (&Spropertize); defsubr (&Schar_equal); defsubr (&Sgoto_char); @@ -5597,6 +5767,7 @@ functions if all the text being accessed has this property. */); defsubr (&Scurrent_time); defsubr (&Stime_add); defsubr (&Stime_subtract); + defsubr (&Stime_equal_p); defsubr (&Stime_less_p); defsubr (&Sget_internal_run_time); defsubr (&Sformat_time_string); |