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