root/src/editfns.c

DEFINITIONS

1. init_and_cache_system_name
2. init_editfns
3. DEFUN
4. DEFUN
5. DEFUN
6. DEFUN
7. DEFUN
8. DEFUN
9. region_limit
10. DEFUN
11. DEFUN
12. DEFUN
13. overlays_around
14. find_field
15. DEFUN
16. DEFUN
17. DEFUN
18. bol
19. DEFUN
20. DEFUN
21. eol
22. DEFUN
23. DEFUN
24. save_excursion_save
25. save_excursion_restore
26. DEFUN
27. DEFUN
28. DEFUN
29. DEFUN
30. DEFUN
31. DEFUN
32. DEFUN
33. DEFUN
34. DEFUN
35. DEFUN
36. DEFUN
37. DEFUN
38. DEFUN
39. DEFUN
40. DEFUN
41. DEFUN
42. DEFUN
43. DEFUN
44. DEFUN
45. DEFUN
46. DEFUN
47. DEFUN
48. DEFUN
49. DEFUN
50. DEFUN
51. DEFUN
52. DEFUN
53. DEFUN
54. DEFUN
55. general_insert_function
56. insert1
57. make_buffer_string
58. make_buffer_string_both
59. update_buffer_properties
60. DEFUN
61. set_bit
62. bit_is_set
63. buffer_chars_equal
64. compareseq_early_abort
65. subst_char_in_region_unwind
66. subst_char_in_region_unwind_1
67. check_translation
68. labeled_restrictions_add
69. labeled_restrictions_remove
70. labeled_restrictions_get_bound
71. labeled_restrictions_peek_label
72. labeled_restrictions_push
73. labeled_restrictions_pop
74. labeled_restrictions_remove_in_current_buffer
75. unwind_reset_outermost_restriction
76. reset_outermost_restrictions
77. labeled_restrictions_save
78. labeled_restrictions_restore
79. unwind_labeled_narrow_to_region
80. labeled_narrow_to_region
81. DEFUN
82. DEFUN
83. save_restriction_save_1
84. save_restriction_restore_1
85. save_restriction_save
86. save_restriction_restore
87. DEFUN
88. DEFUN
89. str2num
90. styled_format
91. transpose_markers
92. syms_of_editfns

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