root/src/fns.c

DEFINITIONS

1. DEFUN
2. get_random_fixnum
3. DEFUN
4. list_length
5. DEFUN
6. DEFUN
7. length_internal
8. DEFUN
9. DEFUN
10. load_unaligned_size_t
11. concat2
12. concat3
13. DEFUN
14. concat_to_string
15. concat_to_list
16. concat_to_vector
17. clear_string_char_byte_cache
18. string_char_to_byte
19. string_byte_to_char
20. string_to_multibyte
21. string_make_unibyte
22. DEFUN
23. DEFUN
24. DEFUN
25. DEFUN
26. DEFUN
27. DEFUN
28. DEFUN
29. validate_subarray
30. substring_both
31. same_float
32. eq_comparable_value
33. assq_no_quit
34. assq_no_signal
35. assoc_no_quit
36. DEFUN
37. DEFUN
38. sort_list
39. sort_vector
40. merge
41. merge_c
42. plist_get
43. plist_put
44. plist_member
45. equal_no_quit
46. internal_equal
47. DEFUN
48. nconc2
49. mapcar1
50. do_yes_or_no_p
51. DEFUN
52. DEFUN
53. require_unwind
54. DEFUN
55. base64_encode_region_1
56. base64_encode_string_1
57. base64_encode_1
58. base64_decode_1
59. CHECK_HASH_TABLE
60. set_hash_next_slot
61. set_hash_hash_slot
62. set_hash_index_slot
63. check_hash_table
64. next_almost_prime
65. get_key_arg
66. larger_vecalloc
67. larger_vector
68. HASH_NEXT
69. HASH_INDEX
70. restore_mutability
71. hash_table_user_defined_call
72. cmpfn_eql
73. cmpfn_equal
74. cmpfn_user_defined
75. hashfn_eq
76. hashfn_equal
77. hashfn_eql
78. hashfn_user_defined
79. allocate_hash_table
80. hash_index_size
81. make_hash_table
82. copy_hash_table
83. maybe_resize_hash_table
84. hash_table_rehash
85. hash_lookup
86. check_mutable_hash_table
87. collect_interval
88. hash_put
89. hash_remove_from_table
90. hash_clear
91. sweep_weak_table
92. hash_string
93. sxhash_string
94. sxhash_float
95. sxhash_list
96. sxhash_vector
97. sxhash_bool_vector
98. sxhash_bignum
99. sxhash
100. sxhash_obj
101. DEFUN
102. DEFUN
103. DEFUN
104. DEFUN
105. DEFUN
106. DEFUN
107. DEFUN
108. DEFUN
109. DEFUN
110. DEFUN
111. DEFUN
112. DEFUN
113. DEFUN
114. hexbuf_digest
115. make_digest_string
116. DEFUN
117. extract_data_from_object
118. secure_hash
119. DEFUN
120. DEFUN
121. DEFUN
122. syms_of_fns

     1 /* Random utility Lisp functions.
     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 #include <config.h>
    21 
    22 #include <stdlib.h>
    23 #include <sys/random.h>
    24 #include <unistd.h>
    25 #include <filevercmp.h>
    26 #include <intprops.h>
    27 #include <vla.h>
    28 #include <errno.h>
    29 #include <ctype.h>
    30 
    31 #include "lisp.h"
    32 #include "bignum.h"
    33 #include "character.h"
    34 #include "coding.h"
    35 #include "composite.h"
    36 #include "buffer.h"
    37 #include "intervals.h"
    38 #include "window.h"
    39 #include "puresize.h"
    40 #include "gnutls.h"
    41 
    42 #ifdef HAVE_TREE_SITTER
    43 #include "treesit.h"
    44 #endif
    45 
    46 enum equal_kind { EQUAL_NO_QUIT, EQUAL_PLAIN, EQUAL_INCLUDING_PROPERTIES };
    47 static bool internal_equal (Lisp_Object, Lisp_Object,
    48                             enum equal_kind, int, Lisp_Object);
    49 static EMACS_UINT sxhash_obj (Lisp_Object, int);
    50 
    51 DEFUN ("identity", Fidentity, Sidentity, 1, 1, 0,
    52        doc: /* Return the ARGUMENT unchanged.  */
    53        attributes: const)
    54   (Lisp_Object argument)
    55 {
    56   return argument;
    57 }
    58 
    59 /* Return a random Lisp fixnum I in the range 0 <= I < LIM,
    60    where LIM is taken from a positive fixnum.  */
    61 static Lisp_Object
    62 get_random_fixnum (EMACS_INT lim)
    63 {
    64   /* Return the remainder of a random integer R (in range 0..INTMASK)
    65      divided by LIM, except reject the rare case where R is so close
    66      to INTMASK that the remainder isn't random.  */
    67   EMACS_INT difflim = INTMASK - lim + 1, diff, remainder;
    68   do
    69     {
    70       EMACS_INT r = get_random ();
    71       remainder = r % lim;
    72       diff = r - remainder;
    73     }
    74   while (difflim < diff);
    75 
    76   return make_fixnum (remainder);
    77 }
    78 
    79 DEFUN ("random", Frandom, Srandom, 0, 1, 0,
    80        doc: /* Return a pseudo-random integer.
    81 By default, return a fixnum; all fixnums are equally likely.
    82 With positive integer LIMIT, return random integer in interval [0,LIMIT).
    83 With argument t, set the random number seed from the system's entropy
    84 pool if available, otherwise from less-random volatile data such as the time.
    85 With a string argument, set the seed based on the string's contents.
    86 
    87 See Info node `(elisp)Random Numbers' for more details.  */)
    88   (Lisp_Object limit)
    89 {
    90   if (EQ (limit, Qt))
    91     init_random ();
    92   else if (STRINGP (limit))
    93     seed_random (SSDATA (limit), SBYTES (limit));
    94   else if (FIXNUMP (limit))
    95     {
    96       EMACS_INT lim = XFIXNUM (limit);
    97       if (lim <= 0)
    98         xsignal1 (Qargs_out_of_range, limit);
    99       return get_random_fixnum (lim);
   100     }
   101   else if (BIGNUMP (limit))
   102     {
   103       struct Lisp_Bignum *lim = XBIGNUM (limit);
   104       if (mpz_sgn (*bignum_val (lim)) <= 0)
   105         xsignal1 (Qargs_out_of_range, limit);
   106       return get_random_bignum (lim);
   107     }
   108 
   109   return make_ufixnum (get_random ());
   110 }
   111 
   112 /* Random data-structure functions.  */
   113 
   114 /* Return LIST's length.  Signal an error if LIST is not a proper list.  */
   115 
   116 ptrdiff_t
   117 list_length (Lisp_Object list)
   118 {
   119   intptr_t i = 0;
   120   FOR_EACH_TAIL (list)
   121     i++;
   122   CHECK_LIST_END (list, list);
   123   return i;
   124 }
   125 
   126 
   127 DEFUN ("length", Flength, Slength, 1, 1, 0,
   128        doc: /* Return the length of vector, list or string SEQUENCE.
   129 A byte-code function object is also allowed.
   130 
   131 If the string contains multibyte characters, this is not necessarily
   132 the number of bytes in the string; it is the number of characters.
   133 To get the number of bytes, use `string-bytes'.
   134 
   135 If the length of a list is being computed to compare to a (small)
   136 number, the `length<', `length>' and `length=' functions may be more
   137 efficient.  */)
   138   (Lisp_Object sequence)
   139 {
   140   EMACS_INT val;
   141 
   142   if (STRINGP (sequence))
   143     val = SCHARS (sequence);
   144   else if (VECTORP (sequence))
   145     val = ASIZE (sequence);
   146   else if (CHAR_TABLE_P (sequence))
   147     val = MAX_CHAR;
   148   else if (BOOL_VECTOR_P (sequence))
   149     val = bool_vector_size (sequence);
   150   else if (COMPILEDP (sequence) || RECORDP (sequence))
   151     val = PVSIZE (sequence);
   152   else if (CONSP (sequence))
   153     val = list_length (sequence);
   154   else if (NILP (sequence))
   155     val = 0;
   156   else
   157     wrong_type_argument (Qsequencep, sequence);
   158 
   159   return make_fixnum (val);
   160 }
   161 
   162 DEFUN ("safe-length", Fsafe_length, Ssafe_length, 1, 1, 0,
   163        doc: /* Return the length of a list, but avoid error or infinite loop.
   164 This function never gets an error.  If LIST is not really a list,
   165 it returns 0.  If LIST is circular, it returns an integer that is at
   166 least the number of distinct elements.  */)
   167   (Lisp_Object list)
   168 {
   169   intptr_t len = 0;
   170   FOR_EACH_TAIL_SAFE (list)
   171     len++;
   172   return make_fixnum (len);
   173 }
   174 
   175 static inline
   176 EMACS_INT length_internal (Lisp_Object sequence, int len)
   177 {
   178   /* If LENGTH is short (arbitrarily chosen cut-off point), use a
   179      fast loop that doesn't care about whether SEQUENCE is
   180      circular or not. */
   181   if (len < 0xffff)
   182     while (CONSP (sequence))
   183       {
   184         if (--len <= 0)
   185           return -1;
   186         sequence = XCDR (sequence);
   187       }
   188   /* Signal an error on circular lists. */
   189   else
   190     FOR_EACH_TAIL (sequence)
   191       if (--len <= 0)
   192         return -1;
   193   return len;
   194 }
   195 
   196 DEFUN ("length<", Flength_less, Slength_less, 2, 2, 0,
   197        doc: /* Return non-nil if SEQUENCE is shorter than LENGTH.
   198 See `length' for allowed values of SEQUENCE and how elements are
   199 counted.  */)
   200   (Lisp_Object sequence, Lisp_Object length)
   201 {
   202   CHECK_FIXNUM (length);
   203   EMACS_INT len = XFIXNUM (length);
   204 
   205   if (CONSP (sequence))
   206     return length_internal (sequence, len) == -1? Qnil: Qt;
   207   else
   208     return XFIXNUM (Flength (sequence)) < len? Qt: Qnil;
   209 }
   210 
   211 DEFUN ("length>", Flength_greater, Slength_greater, 2, 2, 0,
   212        doc: /* Return non-nil if SEQUENCE is longer than LENGTH.
   213 See `length' for allowed values of SEQUENCE and how elements are
   214 counted.  */)
   215   (Lisp_Object sequence, Lisp_Object length)
   216 {
   217   CHECK_FIXNUM (length);
   218   EMACS_INT len = XFIXNUM (length);
   219 
   220   if (CONSP (sequence))
   221     return length_internal (sequence, len + 1) == -1? Qt: Qnil;
   222   else
   223     return XFIXNUM (Flength (sequence)) > len? Qt: Qnil;
   224 }
   225 
   226 DEFUN ("length=", Flength_equal, Slength_equal, 2, 2, 0,
   227        doc: /* Return non-nil if SEQUENCE has length equal to LENGTH.
   228 See `length' for allowed values of SEQUENCE and how elements are
   229 counted.  */)
   230   (Lisp_Object sequence, Lisp_Object length)
   231 {
   232   CHECK_FIXNUM (length);
   233   EMACS_INT len = XFIXNUM (length);
   234 
   235   if (len < 0)
   236     return Qnil;
   237 
   238   if (CONSP (sequence))
   239     return length_internal (sequence, len + 1) == 1? Qt: Qnil;
   240   else
   241     return XFIXNUM (Flength (sequence)) == len? Qt: Qnil;
   242 }
   243 
   244 DEFUN ("proper-list-p", Fproper_list_p, Sproper_list_p, 1, 1, 0,
   245        doc: /* Return OBJECT's length if it is a proper list, nil otherwise.
   246 A proper list is neither circular nor dotted (i.e., its last cdr is nil).  */
   247        attributes: const)
   248   (Lisp_Object object)
   249 {
   250   intptr_t len = 0;
   251   Lisp_Object last_tail = object;
   252   Lisp_Object tail = object;
   253   FOR_EACH_TAIL_SAFE (tail)
   254     {
   255       len++;
   256       rarely_quit (len);
   257       last_tail = XCDR (tail);
   258     }
   259   if (!NILP (last_tail))
   260     return Qnil;
   261   return make_fixnum (len);
   262 }
   263 
   264 DEFUN ("string-bytes", Fstring_bytes, Sstring_bytes, 1, 1, 0,
   265        doc: /* Return the number of bytes in STRING.
   266 If STRING is multibyte, this may be greater than the length of STRING.  */)
   267   (Lisp_Object string)
   268 {
   269   CHECK_STRING (string);
   270   return make_fixnum (SBYTES (string));
   271 }
   272 
   273 DEFUN ("string-distance", Fstring_distance, Sstring_distance, 2, 3, 0,
   274        doc: /* Return Levenshtein distance between STRING1 and STRING2.
   275 The distance is the number of deletions, insertions, and substitutions
   276 required to transform STRING1 into STRING2.
   277 If BYTECOMPARE is nil or omitted, compute distance in terms of characters.
   278 If BYTECOMPARE is non-nil, compute distance in terms of bytes.
   279 Letter-case is significant, but text properties are ignored. */)
   280   (Lisp_Object string1, Lisp_Object string2, Lisp_Object bytecompare)
   281 
   282 {
   283   CHECK_STRING (string1);
   284   CHECK_STRING (string2);
   285 
   286   bool use_byte_compare =
   287     !NILP (bytecompare)
   288     || (!STRING_MULTIBYTE (string1) && !STRING_MULTIBYTE (string2));
   289   ptrdiff_t len1 = use_byte_compare ? SBYTES (string1) : SCHARS (string1);
   290   ptrdiff_t len2 = use_byte_compare ? SBYTES (string2) : SCHARS (string2);
   291   ptrdiff_t x, y, lastdiag, olddiag;
   292 
   293   USE_SAFE_ALLOCA;
   294   ptrdiff_t *column = SAFE_ALLOCA ((len1 + 1) * sizeof (ptrdiff_t));
   295   for (y = 0; y <= len1; y++)
   296     column[y] = y;
   297 
   298   if (use_byte_compare)
   299     {
   300       char *s1 = SSDATA (string1);
   301       char *s2 = SSDATA (string2);
   302 
   303       for (x = 1; x <= len2; x++)
   304         {
   305           column[0] = x;
   306           for (y = 1, lastdiag = x - 1; y <= len1; y++)
   307             {
   308               olddiag = column[y];
   309               column[y] = min (min (column[y] + 1, column[y-1] + 1),
   310                                lastdiag + (s1[y-1] == s2[x-1] ? 0 : 1));
   311               lastdiag = olddiag;
   312             }
   313         }
   314     }
   315   else
   316     {
   317       int c1, c2;
   318       ptrdiff_t i1, i1_byte, i2 = 0, i2_byte = 0;
   319       for (x = 1; x <= len2; x++)
   320         {
   321           column[0] = x;
   322           c2 = fetch_string_char_advance (string2, &i2, &i2_byte);
   323           i1 = i1_byte = 0;
   324           for (y = 1, lastdiag = x - 1; y <= len1; y++)
   325             {
   326               olddiag = column[y];
   327               c1 = fetch_string_char_advance (string1, &i1, &i1_byte);
   328               column[y] = min (min (column[y] + 1, column[y-1] + 1),
   329                                lastdiag + (c1 == c2 ? 0 : 1));
   330               lastdiag = olddiag;
   331             }
   332         }
   333     }
   334 
   335   SAFE_FREE ();
   336   return make_fixnum (column[len1]);
   337 }
   338 
   339 DEFUN ("string-equal", Fstring_equal, Sstring_equal, 2, 2, 0,
   340        doc: /* Return t if two strings have identical contents.
   341 Case is significant, but text properties are ignored.
   342 Symbols are also allowed; their print names are used instead.
   343 
   344 See also `string-equal-ignore-case'.  */)
   345   (register Lisp_Object s1, Lisp_Object s2)
   346 {
   347   if (SYMBOLP (s1))
   348     s1 = SYMBOL_NAME (s1);
   349   if (SYMBOLP (s2))
   350     s2 = SYMBOL_NAME (s2);
   351   CHECK_STRING (s1);
   352   CHECK_STRING (s2);
   353 
   354   if (SCHARS (s1) != SCHARS (s2)
   355       || SBYTES (s1) != SBYTES (s2)
   356       || memcmp (SDATA (s1), SDATA (s2), SBYTES (s1)))
   357     return Qnil;
   358   return Qt;
   359 }
   360 
   361 DEFUN ("compare-strings", Fcompare_strings, Scompare_strings, 6, 7, 0,
   362        doc: /* Compare the contents of two strings, converting to multibyte if needed.
   363 The arguments START1, END1, START2, and END2, if non-nil, are
   364 positions specifying which parts of STR1 or STR2 to compare.  In
   365 string STR1, compare the part between START1 (inclusive) and END1
   366 \(exclusive).  If START1 is nil, it defaults to 0, the beginning of
   367 the string; if END1 is nil, it defaults to the length of the string.
   368 Likewise, in string STR2, compare the part between START2 and END2.
   369 Like in `substring', negative values are counted from the end.
   370 
   371 The strings are compared by the numeric values of their characters.
   372 For instance, STR1 is "less than" STR2 if its first differing
   373 character has a smaller numeric value.  If IGNORE-CASE is non-nil,
   374 characters are converted to upper-case before comparing them.  Unibyte
   375 strings are converted to multibyte for comparison.
   376 
   377 The value is t if the strings (or specified portions) match.
   378 If string STR1 is less, the value is a negative number N;
   379   - 1 - N is the number of characters that match at the beginning.
   380 If string STR1 is greater, the value is a positive number N;
   381   N - 1 is the number of characters that match at the beginning.  */)
   382   (Lisp_Object str1, Lisp_Object start1, Lisp_Object end1, Lisp_Object str2,
   383    Lisp_Object start2, Lisp_Object end2, Lisp_Object ignore_case)
   384 {
   385   ptrdiff_t from1, to1, from2, to2, i1, i1_byte, i2, i2_byte;
   386 
   387   CHECK_STRING (str1);
   388   CHECK_STRING (str2);
   389 
   390   /* For backward compatibility, silently bring too-large positive end
   391      values into range.  */
   392   if (FIXNUMP (end1) && SCHARS (str1) < XFIXNUM (end1))
   393     end1 = make_fixnum (SCHARS (str1));
   394   if (FIXNUMP (end2) && SCHARS (str2) < XFIXNUM (end2))
   395     end2 = make_fixnum (SCHARS (str2));
   396 
   397   validate_subarray (str1, start1, end1, SCHARS (str1), &from1, &to1);
   398   validate_subarray (str2, start2, end2, SCHARS (str2), &from2, &to2);
   399 
   400   i1 = from1;
   401   i2 = from2;
   402 
   403   i1_byte = string_char_to_byte (str1, i1);
   404   i2_byte = string_char_to_byte (str2, i2);
   405 
   406   while (i1 < to1 && i2 < to2)
   407     {
   408       /* When we find a mismatch, we must compare the
   409          characters, not just the bytes.  */
   410       int c1 = fetch_string_char_as_multibyte_advance (str1, &i1, &i1_byte);
   411       int c2 = fetch_string_char_as_multibyte_advance (str2, &i2, &i2_byte);
   412 
   413       if (c1 == c2)
   414         continue;
   415 
   416       if (! NILP (ignore_case))
   417         {
   418           c1 = XFIXNUM (Fupcase (make_fixnum (c1)));
   419           c2 = XFIXNUM (Fupcase (make_fixnum (c2)));
   420         }
   421 
   422       if (c1 == c2)
   423         continue;
   424 
   425       /* Note that I1 has already been incremented
   426          past the character that we are comparing;
   427          hence we don't add or subtract 1 here.  */
   428       if (c1 < c2)
   429         return make_fixnum (- i1 + from1);
   430       else
   431         return make_fixnum (i1 - from1);
   432     }
   433 
   434   if (i1 < to1)
   435     return make_fixnum (i1 - from1 + 1);
   436   if (i2 < to2)
   437     return make_fixnum (- i1 + from1 - 1);
   438 
   439   return Qt;
   440 }
   441 
   442 /* Check whether the platform allows access to unaligned addresses for
   443    size_t integers without trapping or undue penalty (a few cycles is OK),
   444    and that a word-sized memcpy can be used to generate such an access.
   445 
   446    This whitelist is incomplete but since it is only used to improve
   447    performance, omitting cases is safe.  */
   448 #if (defined __x86_64__|| defined __amd64__             \
   449      || defined __i386__ || defined __i386              \
   450      || defined __arm64__ || defined __aarch64__        \
   451      || defined __powerpc__ || defined __powerpc        \
   452      || defined __ppc__ || defined __ppc                \
   453      || defined __s390__ || defined __s390x__)          \
   454   && defined __OPTIMIZE__
   455 #define HAVE_FAST_UNALIGNED_ACCESS 1
   456 #else
   457 #define HAVE_FAST_UNALIGNED_ACCESS 0
   458 #endif
   459 
   460 /* Load a word from a possibly unaligned address.  */
   461 static inline size_t
   462 load_unaligned_size_t (const void *p)
   463 {
   464   size_t x;
   465   memcpy (&x, p, sizeof x);
   466   return x;
   467 }
   468 
   469 DEFUN ("string-lessp", Fstring_lessp, Sstring_lessp, 2, 2, 0,
   470        doc: /* Return non-nil if STRING1 is less than STRING2 in lexicographic order.
   471 Case is significant.
   472 Symbols are also allowed; their print names are used instead.  */)
   473   (Lisp_Object string1, Lisp_Object string2)
   474 {
   475   if (SYMBOLP (string1))
   476     string1 = SYMBOL_NAME (string1);
   477   else
   478     CHECK_STRING (string1);
   479   if (SYMBOLP (string2))
   480     string2 = SYMBOL_NAME (string2);
   481   else
   482     CHECK_STRING (string2);
   483 
   484   ptrdiff_t n = min (SCHARS (string1), SCHARS (string2));
   485 
   486   if ((!STRING_MULTIBYTE (string1) || SCHARS (string1) == SBYTES (string1))
   487       && (!STRING_MULTIBYTE (string2) || SCHARS (string2) == SBYTES (string2)))
   488     {
   489       /* Each argument is either unibyte or all-ASCII multibyte:
   490          we can compare bytewise.  */
   491       int d = memcmp (SSDATA (string1), SSDATA (string2), n);
   492       return d < 0 || (d == 0 && n < SCHARS (string2)) ? Qt : Qnil;
   493     }
   494   else if (STRING_MULTIBYTE (string1) && STRING_MULTIBYTE (string2))
   495     {
   496       /* Two arbitrary multibyte strings: we cannot use memcmp because
   497          the encoding for raw bytes would sort those between U+007F and U+0080
   498          which isn't where we want them.
   499          Instead, we skip the longest common prefix and look at
   500          what follows.  */
   501       ptrdiff_t nb1 = SBYTES (string1);
   502       ptrdiff_t nb2 = SBYTES (string2);
   503       ptrdiff_t nb = min (nb1, nb2);
   504       ptrdiff_t b = 0;
   505 
   506       /* String data is normally allocated with word alignment, but
   507          there are exceptions (notably pure strings) so we restrict the
   508          wordwise skipping to safe architectures.  */
   509       if (HAVE_FAST_UNALIGNED_ACCESS)
   510         {
   511           /* First compare entire machine words.  */
   512           int ws = sizeof (size_t);
   513           const char *w1 = SSDATA (string1);
   514           const char *w2 = SSDATA (string2);
   515           while (b < nb - ws + 1 &&    load_unaligned_size_t (w1 + b)
   516                                     == load_unaligned_size_t (w2 + b))
   517             b += ws;
   518         }
   519 
   520       /* Scan forward to the differing byte.  */
   521       while (b < nb && SREF (string1, b) == SREF (string2, b))
   522         b++;
   523 
   524       if (b >= nb)
   525         /* One string is a prefix of the other.  */
   526         return b < nb2 ? Qt : Qnil;
   527 
   528       /* Now back up to the start of the differing characters:
   529          it's the last byte not having the bit pattern 10xxxxxx.  */
   530       while ((SREF (string1, b) & 0xc0) == 0x80)
   531         b--;
   532 
   533       /* Compare the differing characters.  */
   534       ptrdiff_t i1 = 0, i2 = 0;
   535       ptrdiff_t i1_byte = b, i2_byte = b;
   536       int c1 = fetch_string_char_advance_no_check (string1, &i1, &i1_byte);
   537       int c2 = fetch_string_char_advance_no_check (string2, &i2, &i2_byte);
   538       return c1 < c2 ? Qt : Qnil;
   539     }
   540   else if (STRING_MULTIBYTE (string1))
   541     {
   542       /* string1 multibyte, string2 unibyte */
   543       ptrdiff_t i1 = 0, i1_byte = 0, i2 = 0;
   544       while (i1 < n)
   545         {
   546           int c1 = fetch_string_char_advance_no_check (string1, &i1, &i1_byte);
   547           int c2 = SREF (string2, i2++);
   548           if (c1 != c2)
   549             return c1 < c2 ? Qt : Qnil;
   550         }
   551       return i1 < SCHARS (string2) ? Qt : Qnil;
   552     }
   553   else
   554     {
   555       /* string1 unibyte, string2 multibyte */
   556       ptrdiff_t i1 = 0, i2 = 0, i2_byte = 0;
   557       while (i1 < n)
   558         {
   559           int c1 = SREF (string1, i1++);
   560           int c2 = fetch_string_char_advance_no_check (string2, &i2, &i2_byte);
   561           if (c1 != c2)
   562             return c1 < c2 ? Qt : Qnil;
   563         }
   564       return i1 < SCHARS (string2) ? Qt : Qnil;
   565     }
   566 }
   567 
   568 DEFUN ("string-version-lessp", Fstring_version_lessp,
   569        Sstring_version_lessp, 2, 2, 0,
   570        doc: /* Return non-nil if S1 is less than S2, as version strings.
   571 
   572 This function compares version strings S1 and S2:
   573    1) By prefix lexicographically.
   574    2) Then by version (similarly to version comparison of Debian's dpkg).
   575       Leading zeros in version numbers are ignored.
   576    3) If both prefix and version are equal, compare as ordinary strings.
   577 
   578 For example, \"foo2.png\" compares less than \"foo12.png\".
   579 Case is significant.
   580 Symbols are also allowed; their print names are used instead.  */)
   581   (Lisp_Object string1, Lisp_Object string2)
   582 {
   583   if (SYMBOLP (string1))
   584     string1 = SYMBOL_NAME (string1);
   585   if (SYMBOLP (string2))
   586     string2 = SYMBOL_NAME (string2);
   587   CHECK_STRING (string1);
   588   CHECK_STRING (string2);
   589   int cmp = filenvercmp (SSDATA (string1), SBYTES (string1),
   590                          SSDATA (string2), SBYTES (string2));
   591   return cmp < 0 ? Qt : Qnil;
   592 }
   593 
   594 DEFUN ("string-collate-lessp", Fstring_collate_lessp, Sstring_collate_lessp, 2, 4, 0,
   595        doc: /* Return t if first arg string is less than second in collation order.
   596 Symbols are also allowed; their print names are used instead.
   597 
   598 This function obeys the conventions for collation order in your
   599 locale settings.  For example, punctuation and whitespace characters
   600 might be considered less significant for sorting:
   601 
   602 \(sort \\='("11" "12" "1 1" "1 2" "1.1" "1.2") \\='string-collate-lessp)
   603   => ("11" "1 1" "1.1" "12" "1 2" "1.2")
   604 
   605 The optional argument LOCALE, a string, overrides the setting of your
   606 current locale identifier for collation.  The value is system
   607 dependent; a LOCALE \"en_US.UTF-8\" is applicable on POSIX systems,
   608 while it would be, e.g., \"enu_USA.1252\" on MS-Windows systems.
   609 
   610 If IGNORE-CASE is non-nil, characters are converted to lower-case
   611 before comparing them.
   612 
   613 To emulate Unicode-compliant collation on MS-Windows systems,
   614 bind `w32-collate-ignore-punctuation' to a non-nil value, since
   615 the codeset part of the locale cannot be \"UTF-8\" on MS-Windows.
   616 
   617 Some operating systems do not implement correct collation (in specific
   618 locale environments or at all).  Then, this functions falls back to
   619 case-sensitive `string-lessp' and IGNORE-CASE argument is ignored.  */)
   620   (Lisp_Object s1, Lisp_Object s2, Lisp_Object locale, Lisp_Object ignore_case)
   621 {
   622 #if defined __STDC_ISO_10646__ || defined WINDOWSNT
   623   /* Check parameters.  */
   624   if (SYMBOLP (s1))
   625     s1 = SYMBOL_NAME (s1);
   626   if (SYMBOLP (s2))
   627     s2 = SYMBOL_NAME (s2);
   628   CHECK_STRING (s1);
   629   CHECK_STRING (s2);
   630   if (!NILP (locale))
   631     CHECK_STRING (locale);
   632 
   633   return (str_collate (s1, s2, locale, ignore_case) < 0) ? Qt : Qnil;
   634 
   635 #else  /* !__STDC_ISO_10646__, !WINDOWSNT */
   636   return Fstring_lessp (s1, s2);
   637 #endif /* !__STDC_ISO_10646__, !WINDOWSNT */
   638 }
   639 
   640 DEFUN ("string-collate-equalp", Fstring_collate_equalp, Sstring_collate_equalp, 2, 4, 0,
   641        doc: /* Return t if two strings have identical contents.
   642 Symbols are also allowed; their print names are used instead.
   643 
   644 This function obeys the conventions for collation order in your locale
   645 settings.  For example, characters with different coding points but
   646 the same meaning might be considered as equal, like different grave
   647 accent Unicode characters:
   648 
   649 \(string-collate-equalp (string ?\\uFF40) (string ?\\u1FEF))
   650   => t
   651 
   652 The optional argument LOCALE, a string, overrides the setting of your
   653 current locale identifier for collation.  The value is system
   654 dependent; a LOCALE \"en_US.UTF-8\" is applicable on POSIX systems,
   655 while it would be \"enu_USA.1252\" on MS Windows systems.
   656 
   657 If IGNORE-CASE is non-nil, characters are converted to lower-case
   658 before comparing them.
   659 
   660 To emulate Unicode-compliant collation on MS-Windows systems,
   661 bind `w32-collate-ignore-punctuation' to a non-nil value, since
   662 the codeset part of the locale cannot be \"UTF-8\" on MS-Windows.
   663 
   664 If your system does not support a locale environment, this function
   665 behaves like `string-equal', and in that case the IGNORE-CASE argument
   666 is ignored.
   667 
   668 Do NOT use this function to compare file names for equality.  */)
   669   (Lisp_Object s1, Lisp_Object s2, Lisp_Object locale, Lisp_Object ignore_case)
   670 {
   671 #if defined __STDC_ISO_10646__ || defined WINDOWSNT
   672   /* Check parameters.  */
   673   if (SYMBOLP (s1))
   674     s1 = SYMBOL_NAME (s1);
   675   if (SYMBOLP (s2))
   676     s2 = SYMBOL_NAME (s2);
   677   CHECK_STRING (s1);
   678   CHECK_STRING (s2);
   679   if (!NILP (locale))
   680     CHECK_STRING (locale);
   681 
   682   return (str_collate (s1, s2, locale, ignore_case) == 0) ? Qt : Qnil;
   683 
   684 #else  /* !__STDC_ISO_10646__, !WINDOWSNT */
   685   return Fstring_equal (s1, s2);
   686 #endif /* !__STDC_ISO_10646__, !WINDOWSNT */
   687 }
   688 
   689 static Lisp_Object concat_to_list (ptrdiff_t nargs, Lisp_Object *args,
   690                                    Lisp_Object last_tail);
   691 static Lisp_Object concat_to_vector (ptrdiff_t nargs, Lisp_Object *args);
   692 static Lisp_Object concat_to_string (ptrdiff_t nargs, Lisp_Object *args);
   693 
   694 Lisp_Object
   695 concat2 (Lisp_Object s1, Lisp_Object s2)
   696 {
   697   return concat_to_string (2, ((Lisp_Object []) {s1, s2}));
   698 }
   699 
   700 Lisp_Object
   701 concat3 (Lisp_Object s1, Lisp_Object s2, Lisp_Object s3)
   702 {
   703   return concat_to_string (3, ((Lisp_Object []) {s1, s2, s3}));
   704 }
   705 
   706 DEFUN ("append", Fappend, Sappend, 0, MANY, 0,
   707        doc: /* Concatenate all the arguments and make the result a list.
   708 The result is a list whose elements are the elements of all the arguments.
   709 Each argument may be a list, vector or string.
   710 
   711 All arguments except the last argument are copied.  The last argument
   712 is just used as the tail of the new list.
   713 
   714 usage: (append &rest SEQUENCES)  */)
   715   (ptrdiff_t nargs, Lisp_Object *args)
   716 {
   717   if (nargs == 0)
   718     return Qnil;
   719   return concat_to_list (nargs - 1, args, args[nargs - 1]);
   720 }
   721 
   722 DEFUN ("concat", Fconcat, Sconcat, 0, MANY, 0,
   723        doc: /* Concatenate all the arguments and make the result a string.
   724 The result is a string whose elements are the elements of all the arguments.
   725 Each argument may be a string or a list or vector of characters (integers).
   726 
   727 Values of the `composition' property of the result are not guaranteed
   728 to be `eq'.
   729 usage: (concat &rest SEQUENCES)  */)
   730   (ptrdiff_t nargs, Lisp_Object *args)
   731 {
   732   return concat_to_string (nargs, args);
   733 }
   734 
   735 DEFUN ("vconcat", Fvconcat, Svconcat, 0, MANY, 0,
   736        doc: /* Concatenate all the arguments and make the result a vector.
   737 The result is a vector whose elements are the elements of all the arguments.
   738 Each argument may be a list, vector or string.
   739 usage: (vconcat &rest SEQUENCES)   */)
   740   (ptrdiff_t nargs, Lisp_Object *args)
   741 {
   742   return concat_to_vector (nargs, args);
   743 }
   744 
   745 
   746 DEFUN ("copy-sequence", Fcopy_sequence, Scopy_sequence, 1, 1, 0,
   747        doc: /* Return a copy of a list, vector, string, char-table or record.
   748 The elements of a list, vector or record are not copied; they are
   749 shared with the original.
   750 If the original sequence is empty, this function may return
   751 the same empty object instead of its copy.  */)
   752   (Lisp_Object arg)
   753 {
   754   if (NILP (arg)) return arg;
   755 
   756   if (CONSP (arg))
   757     {
   758       Lisp_Object val = Fcons (XCAR (arg), Qnil);
   759       Lisp_Object prev = val;
   760       Lisp_Object tail = XCDR (arg);
   761       FOR_EACH_TAIL (tail)
   762         {
   763           Lisp_Object c = Fcons (XCAR (tail), Qnil);
   764           XSETCDR (prev, c);
   765           prev = c;
   766         }
   767       CHECK_LIST_END (tail, tail);
   768       return val;
   769     }
   770 
   771   if (STRINGP (arg))
   772     {
   773       ptrdiff_t bytes = SBYTES (arg);
   774       ptrdiff_t chars = SCHARS (arg);
   775       Lisp_Object val = STRING_MULTIBYTE (arg)
   776         ? make_uninit_multibyte_string (chars, bytes)
   777         : make_uninit_string (bytes);
   778       memcpy (SDATA (val), SDATA (arg), bytes);
   779       INTERVAL ivs = string_intervals (arg);
   780       if (ivs)
   781         {
   782           INTERVAL copy = copy_intervals (ivs, 0, chars);
   783           set_interval_object (copy, val);
   784           set_string_intervals (val, copy);
   785         }
   786       return val;
   787     }
   788 
   789   if (VECTORP (arg))
   790     return Fvector (ASIZE (arg), XVECTOR (arg)->contents);
   791 
   792   if (RECORDP (arg))
   793     return Frecord (PVSIZE (arg), XVECTOR (arg)->contents);
   794 
   795   if (CHAR_TABLE_P (arg))
   796     return copy_char_table (arg);
   797 
   798   if (BOOL_VECTOR_P (arg))
   799     {
   800       EMACS_INT nbits = bool_vector_size (arg);
   801       ptrdiff_t nbytes = bool_vector_bytes (nbits);
   802       Lisp_Object val = make_uninit_bool_vector (nbits);
   803       memcpy (bool_vector_data (val), bool_vector_data (arg), nbytes);
   804       return val;
   805     }
   806 
   807   wrong_type_argument (Qsequencep, arg);
   808 }
   809 
   810 /* This structure holds information of an argument of `concat_to_string'
   811    that is a string and has text properties to be copied.  */
   812 struct textprop_rec
   813 {
   814   ptrdiff_t argnum;             /* refer to ARGS (arguments of `concat') */
   815   ptrdiff_t to;                 /* refer to VAL (the target string) */
   816 };
   817 
   818 static Lisp_Object
   819 concat_to_string (ptrdiff_t nargs, Lisp_Object *args)
   820 {
   821   USE_SAFE_ALLOCA;
   822 
   823   /* Check types and compute total length in chars of arguments in RESULT_LEN,
   824      length in bytes in RESULT_LEN_BYTE, and determine in DEST_MULTIBYTE
   825      whether the result should be a multibyte string.  */
   826   EMACS_INT result_len = 0;
   827   EMACS_INT result_len_byte = 0;
   828   bool dest_multibyte = false;
   829   bool some_unibyte = false;
   830   for (ptrdiff_t i = 0; i < nargs; i++)
   831     {
   832       Lisp_Object arg = args[i];
   833       EMACS_INT len;
   834 
   835       /* We must count the number of bytes needed in the string
   836          as well as the number of characters.  */
   837 
   838       if (STRINGP (arg))
   839         {
   840           ptrdiff_t arg_len_byte = SBYTES (arg);
   841           len = SCHARS (arg);
   842           if (STRING_MULTIBYTE (arg))
   843             dest_multibyte = true;
   844           else
   845             some_unibyte = true;
   846           if (STRING_BYTES_BOUND - result_len_byte < arg_len_byte)
   847             string_overflow ();
   848           result_len_byte += arg_len_byte;
   849         }
   850       else if (VECTORP (arg))
   851         {
   852           len = ASIZE (arg);
   853           ptrdiff_t arg_len_byte = 0;
   854           for (ptrdiff_t j = 0; j < len; j++)
   855             {
   856               Lisp_Object ch = AREF (arg, j);
   857               CHECK_CHARACTER (ch);
   858               int c = XFIXNAT (ch);
   859               arg_len_byte += CHAR_BYTES (c);
   860               if (!ASCII_CHAR_P (c) && !CHAR_BYTE8_P (c))
   861                 dest_multibyte = true;
   862             }
   863           if (STRING_BYTES_BOUND - result_len_byte < arg_len_byte)
   864             string_overflow ();
   865           result_len_byte += arg_len_byte;
   866         }
   867       else if (NILP (arg))
   868         continue;
   869       else if (CONSP (arg))
   870         {
   871           len = XFIXNAT (Flength (arg));
   872           ptrdiff_t arg_len_byte = 0;
   873           for (; CONSP (arg); arg = XCDR (arg))
   874             {
   875               Lisp_Object ch = XCAR (arg);
   876               CHECK_CHARACTER (ch);
   877               int c = XFIXNAT (ch);
   878               arg_len_byte += CHAR_BYTES (c);
   879               if (!ASCII_CHAR_P (c) && !CHAR_BYTE8_P (c))
   880                 dest_multibyte = true;
   881             }
   882           if (STRING_BYTES_BOUND - result_len_byte < arg_len_byte)
   883             string_overflow ();
   884           result_len_byte += arg_len_byte;
   885         }
   886       else
   887         wrong_type_argument (Qsequencep, arg);
   888 
   889       result_len += len;
   890       if (MOST_POSITIVE_FIXNUM < result_len)
   891         memory_full (SIZE_MAX);
   892     }
   893 
   894   if (dest_multibyte && some_unibyte)
   895     {
   896       /* Non-ASCII characters in unibyte strings take two bytes when
   897          converted to multibyte -- count them and adjust the total.  */
   898       for (ptrdiff_t i = 0; i < nargs; i++)
   899         {
   900           Lisp_Object arg = args[i];
   901           if (STRINGP (arg) && !STRING_MULTIBYTE (arg))
   902             {
   903               ptrdiff_t bytes = SCHARS (arg);
   904               const unsigned char *s = SDATA (arg);
   905               ptrdiff_t nonascii = 0;
   906               for (ptrdiff_t j = 0; j < bytes; j++)
   907                 nonascii += s[j] >> 7;
   908               if (STRING_BYTES_BOUND - result_len_byte < nonascii)
   909                 string_overflow ();
   910               result_len_byte += nonascii;
   911             }
   912         }
   913     }
   914 
   915   if (!dest_multibyte)
   916     result_len_byte = result_len;
   917 
   918   /* Create the output object.  */
   919   Lisp_Object result = dest_multibyte
   920     ? make_uninit_multibyte_string (result_len, result_len_byte)
   921     : make_uninit_string (result_len);
   922 
   923   /* Copy the contents of the args into the result.  */
   924   ptrdiff_t toindex = 0;
   925   ptrdiff_t toindex_byte = 0;
   926 
   927   /* When we make a multibyte string, we can't copy text properties
   928      while concatenating each string because the length of resulting
   929      string can't be decided until we finish the whole concatenation.
   930      So, we record strings that have text properties to be copied
   931      here, and copy the text properties after the concatenation.  */
   932   struct textprop_rec *textprops;
   933   /* Number of elements in textprops.  */
   934   ptrdiff_t num_textprops = 0;
   935   SAFE_NALLOCA (textprops, 1, nargs);
   936 
   937   for (ptrdiff_t i = 0; i < nargs; i++)
   938     {
   939       Lisp_Object arg = args[i];
   940       if (STRINGP (arg))
   941         {
   942           if (string_intervals (arg))
   943             {
   944               textprops[num_textprops].argnum = i;
   945               textprops[num_textprops].to = toindex;
   946               num_textprops++;
   947             }
   948           ptrdiff_t nchars = SCHARS (arg);
   949           if (STRING_MULTIBYTE (arg) == dest_multibyte)
   950             {
   951               /* Between strings of the same kind, copy fast.  */
   952               ptrdiff_t arg_len_byte = SBYTES (arg);
   953               memcpy (SDATA (result) + toindex_byte, SDATA (arg), arg_len_byte);
   954               toindex_byte += arg_len_byte;
   955             }
   956           else
   957             {
   958               /* Copy a single-byte string to a multibyte string.  */
   959               toindex_byte += str_to_multibyte (SDATA (result) + toindex_byte,
   960                                                 SDATA (arg), nchars);
   961             }
   962           toindex += nchars;
   963         }
   964       else if (VECTORP (arg))
   965         {
   966           ptrdiff_t len = ASIZE (arg);
   967           for (ptrdiff_t j = 0; j < len; j++)
   968             {
   969               int c = XFIXNAT (AREF (arg, j));
   970               if (dest_multibyte)
   971                 toindex_byte += CHAR_STRING (c, SDATA (result) + toindex_byte);
   972               else
   973                 SSET (result, toindex_byte++, c);
   974               toindex++;
   975             }
   976         }
   977       else
   978         for (Lisp_Object tail = arg; !NILP (tail); tail = XCDR (tail))
   979           {
   980             int c = XFIXNAT (XCAR (tail));
   981             if (dest_multibyte)
   982               toindex_byte += CHAR_STRING (c, SDATA (result) + toindex_byte);
   983             else
   984               SSET (result, toindex_byte++, c);
   985             toindex++;
   986           }
   987     }
   988 
   989   if (num_textprops > 0)
   990     {
   991       ptrdiff_t last_to_end = -1;
   992       for (ptrdiff_t i = 0; i < num_textprops; i++)
   993         {
   994           Lisp_Object arg = args[textprops[i].argnum];
   995           Lisp_Object props = text_property_list (arg,
   996                                                   make_fixnum (0),
   997                                                   make_fixnum (SCHARS (arg)),
   998                                                   Qnil);
   999           /* If successive arguments have properties, be sure that the
  1000              value of `composition' property be the copy.  */
  1001           if (last_to_end == textprops[i].to)
  1002             make_composition_value_copy (props);
  1003           add_text_properties_from_list (result, props,
  1004                                          make_fixnum (textprops[i].to));
  1005           last_to_end = textprops[i].to + SCHARS (arg);
  1006         }
  1007     }
  1008 
  1009   SAFE_FREE ();
  1010   return result;
  1011 }
  1012 
  1013 /* Concatenate sequences into a list. */
  1014 Lisp_Object
  1015 concat_to_list (ptrdiff_t nargs, Lisp_Object *args, Lisp_Object last_tail)
  1016 {
  1017   /* Copy the contents of the args into the result.  */
  1018   Lisp_Object result = Qnil;
  1019   Lisp_Object last = Qnil;      /* Last cons in result if nonempty.  */
  1020 
  1021   for (ptrdiff_t i = 0; i < nargs; i++)
  1022     {
  1023       Lisp_Object arg = args[i];
  1024       /* List arguments are treated specially since this is the common case.  */
  1025       if (CONSP (arg))
  1026         {
  1027           Lisp_Object head = Fcons (XCAR (arg), Qnil);
  1028           Lisp_Object prev = head;
  1029           arg = XCDR (arg);
  1030           FOR_EACH_TAIL (arg)
  1031             {
  1032               Lisp_Object next = Fcons (XCAR (arg), Qnil);
  1033               XSETCDR (prev, next);
  1034               prev = next;
  1035             }
  1036           CHECK_LIST_END (arg, arg);
  1037           if (NILP (result))
  1038             result = head;
  1039           else
  1040             XSETCDR (last, head);
  1041           last = prev;
  1042         }
  1043       else if (NILP (arg))
  1044         ;
  1045       else if (VECTORP (arg) || STRINGP (arg)
  1046                || BOOL_VECTOR_P (arg) || COMPILEDP (arg))
  1047         {
  1048           ptrdiff_t arglen = XFIXNUM (Flength (arg));
  1049           ptrdiff_t argindex_byte = 0;
  1050 
  1051           /* Copy element by element.  */
  1052           for (ptrdiff_t argindex = 0; argindex < arglen; argindex++)
  1053             {
  1054               /* Fetch next element of `arg' arg into `elt', or break if
  1055                  `arg' is exhausted. */
  1056               Lisp_Object elt;
  1057               if (STRINGP (arg))
  1058                 {
  1059                   int c;
  1060                   if (STRING_MULTIBYTE (arg))
  1061                     {
  1062                       ptrdiff_t char_idx = argindex;
  1063                       c = fetch_string_char_advance_no_check (arg, &char_idx,
  1064                                                               &argindex_byte);
  1065                     }
  1066                   else
  1067                     c = SREF (arg, argindex);
  1068                   elt = make_fixed_natnum (c);
  1069                 }
  1070               else if (BOOL_VECTOR_P (arg))
  1071                 elt = bool_vector_ref (arg, argindex);
  1072               else
  1073                 elt = AREF (arg, argindex);
  1074 
  1075               /* Store this element into the result.  */
  1076               Lisp_Object node = Fcons (elt, Qnil);
  1077               if (NILP (result))
  1078                 result = node;
  1079               else
  1080                 XSETCDR (last, node);
  1081               last = node;
  1082             }
  1083         }
  1084       else
  1085         wrong_type_argument (Qsequencep, arg);
  1086     }
  1087 
  1088   if (NILP (result))
  1089     result = last_tail;
  1090   else
  1091     XSETCDR (last, last_tail);
  1092 
  1093   return result;
  1094 }
  1095 
  1096 /* Concatenate sequences into a vector.  */
  1097 Lisp_Object
  1098 concat_to_vector (ptrdiff_t nargs, Lisp_Object *args)
  1099 {
  1100   /* Check argument types and compute total length of arguments.  */
  1101   EMACS_INT result_len = 0;
  1102   for (ptrdiff_t i = 0; i < nargs; i++)
  1103     {
  1104       Lisp_Object arg = args[i];
  1105       if (!(VECTORP (arg) || CONSP (arg) || NILP (arg) || STRINGP (arg)
  1106             || BOOL_VECTOR_P (arg) || COMPILEDP (arg)))
  1107         wrong_type_argument (Qsequencep, arg);
  1108       EMACS_INT len = XFIXNAT (Flength (arg));
  1109       result_len += len;
  1110       if (MOST_POSITIVE_FIXNUM < result_len)
  1111         memory_full (SIZE_MAX);
  1112     }
  1113 
  1114   /* Create the output vector.  */
  1115   Lisp_Object result = make_uninit_vector (result_len);
  1116   Lisp_Object *dst = XVECTOR (result)->contents;
  1117 
  1118   /* Copy the contents of the args into the result.  */
  1119 
  1120   for (ptrdiff_t i = 0; i < nargs; i++)
  1121     {
  1122       Lisp_Object arg = args[i];
  1123       if (VECTORP (arg))
  1124         {
  1125           ptrdiff_t size = ASIZE (arg);
  1126           memcpy (dst, XVECTOR (arg)->contents, size * sizeof *dst);
  1127           dst += size;
  1128         }
  1129       else if (CONSP (arg))
  1130         do
  1131           {
  1132             *dst++ = XCAR (arg);
  1133             arg = XCDR (arg);
  1134           }
  1135         while (!NILP (arg));
  1136       else if (NILP (arg))
  1137         ;
  1138       else if (STRINGP (arg))
  1139         {
  1140           ptrdiff_t size = SCHARS (arg);
  1141           if (STRING_MULTIBYTE (arg))
  1142             {
  1143               ptrdiff_t byte = 0;
  1144               for (ptrdiff_t i = 0; i < size;)
  1145                 {
  1146                   int c = fetch_string_char_advance_no_check (arg, &i, &byte);
  1147                   *dst++ = make_fixnum (c);
  1148                 }
  1149             }
  1150           else
  1151             for (ptrdiff_t i = 0; i < size; i++)
  1152               *dst++ = make_fixnum (SREF (arg, i));
  1153         }
  1154       else if (BOOL_VECTOR_P (arg))
  1155         {
  1156           ptrdiff_t size = bool_vector_size (arg);
  1157           for (ptrdiff_t i = 0; i < size; i++)
  1158             *dst++ = bool_vector_ref (arg, i);
  1159         }
  1160       else
  1161         {
  1162           eassert (COMPILEDP (arg));
  1163           ptrdiff_t size = PVSIZE (arg);
  1164           memcpy (dst, XVECTOR (arg)->contents, size * sizeof *dst);
  1165           dst += size;
  1166         }
  1167     }
  1168   eassert (dst == XVECTOR (result)->contents + result_len);
  1169 
  1170   return result;
  1171 }
  1172 
  1173 static Lisp_Object string_char_byte_cache_string;
  1174 static ptrdiff_t string_char_byte_cache_charpos;
  1175 static ptrdiff_t string_char_byte_cache_bytepos;
  1176 
  1177 void
  1178 clear_string_char_byte_cache (void)
  1179 {
  1180   string_char_byte_cache_string = Qnil;
  1181 }
  1182 
  1183 /* Return the byte index corresponding to CHAR_INDEX in STRING.  */
  1184 
  1185 ptrdiff_t
  1186 string_char_to_byte (Lisp_Object string, ptrdiff_t char_index)
  1187 {
  1188   ptrdiff_t i_byte;
  1189   ptrdiff_t best_below, best_below_byte;
  1190   ptrdiff_t best_above, best_above_byte;
  1191 
  1192   best_below = best_below_byte = 0;
  1193   best_above = SCHARS (string);
  1194   best_above_byte = SBYTES (string);
  1195   if (best_above == best_above_byte)
  1196     return char_index;
  1197 
  1198   if (BASE_EQ (string, string_char_byte_cache_string))
  1199     {
  1200       if (string_char_byte_cache_charpos < char_index)
  1201         {
  1202           best_below = string_char_byte_cache_charpos;
  1203           best_below_byte = string_char_byte_cache_bytepos;
  1204         }
  1205       else
  1206         {
  1207           best_above = string_char_byte_cache_charpos;
  1208           best_above_byte = string_char_byte_cache_bytepos;
  1209         }
  1210     }
  1211 
  1212   if (char_index - best_below < best_above - char_index)
  1213     {
  1214       unsigned char *p = SDATA (string) + best_below_byte;
  1215 
  1216       while (best_below < char_index)
  1217         {
  1218           p += BYTES_BY_CHAR_HEAD (*p);
  1219           best_below++;
  1220         }
  1221       i_byte = p - SDATA (string);
  1222     }
  1223   else
  1224     {
  1225       unsigned char *p = SDATA (string) + best_above_byte;
  1226 
  1227       while (best_above > char_index)
  1228         {
  1229           p--;
  1230           while (!CHAR_HEAD_P (*p)) p--;
  1231           best_above--;
  1232         }
  1233       i_byte = p - SDATA (string);
  1234     }
  1235 
  1236   string_char_byte_cache_bytepos = i_byte;
  1237   string_char_byte_cache_charpos = char_index;
  1238   string_char_byte_cache_string = string;
  1239 
  1240   return i_byte;
  1241 }
  1242 
  1243 /* Return the character index corresponding to BYTE_INDEX in STRING.  */
  1244 
  1245 ptrdiff_t
  1246 string_byte_to_char (Lisp_Object string, ptrdiff_t byte_index)
  1247 {
  1248   ptrdiff_t i, i_byte;
  1249   ptrdiff_t best_below, best_below_byte;
  1250   ptrdiff_t best_above, best_above_byte;
  1251 
  1252   best_below = best_below_byte = 0;
  1253   best_above = SCHARS (string);
  1254   best_above_byte = SBYTES (string);
  1255   if (best_above == best_above_byte)
  1256     return byte_index;
  1257 
  1258   if (BASE_EQ (string, string_char_byte_cache_string))
  1259     {
  1260       if (string_char_byte_cache_bytepos < byte_index)
  1261         {
  1262           best_below = string_char_byte_cache_charpos;
  1263           best_below_byte = string_char_byte_cache_bytepos;
  1264         }
  1265       else
  1266         {
  1267           best_above = string_char_byte_cache_charpos;
  1268           best_above_byte = string_char_byte_cache_bytepos;
  1269         }
  1270     }
  1271 
  1272   if (byte_index - best_below_byte < best_above_byte - byte_index)
  1273     {
  1274       unsigned char *p = SDATA (string) + best_below_byte;
  1275       unsigned char *pend = SDATA (string) + byte_index;
  1276 
  1277       while (p < pend)
  1278         {
  1279           p += BYTES_BY_CHAR_HEAD (*p);
  1280           best_below++;
  1281         }
  1282       i = best_below;
  1283       i_byte = p - SDATA (string);
  1284     }
  1285   else
  1286     {
  1287       unsigned char *p = SDATA (string) + best_above_byte;
  1288       unsigned char *pbeg = SDATA (string) + byte_index;
  1289 
  1290       while (p > pbeg)
  1291         {
  1292           p--;
  1293           while (!CHAR_HEAD_P (*p)) p--;
  1294           best_above--;
  1295         }
  1296       i = best_above;
  1297       i_byte = p - SDATA (string);
  1298     }
  1299 
  1300   string_char_byte_cache_bytepos = i_byte;
  1301   string_char_byte_cache_charpos = i;
  1302   string_char_byte_cache_string = string;
  1303 
  1304   return i;
  1305 }
  1306 
  1307 /* Convert STRING (if unibyte) to a multibyte string without changing
  1308    the number of characters.  Characters 0x80..0xff are interpreted as
  1309    raw bytes. */
  1310 
  1311 Lisp_Object
  1312 string_to_multibyte (Lisp_Object string)
  1313 {
  1314   if (STRING_MULTIBYTE (string))
  1315     return string;
  1316 
  1317   ptrdiff_t nchars = SCHARS (string);
  1318   ptrdiff_t nbytes = count_size_as_multibyte (SDATA (string), nchars);
  1319   /* If all the chars are ASCII, they won't need any more bytes once
  1320      converted.  */
  1321   if (nbytes == nchars)
  1322     return make_multibyte_string (SSDATA (string), nbytes, nbytes);
  1323 
  1324   Lisp_Object ret = make_uninit_multibyte_string (nchars, nbytes);
  1325   str_to_multibyte (SDATA (ret), SDATA (string), nchars);
  1326   return ret;
  1327 }
  1328 
  1329 
  1330 /* Convert STRING to a single-byte string.  */
  1331 
  1332 Lisp_Object
  1333 string_make_unibyte (Lisp_Object string)
  1334 {
  1335   ptrdiff_t nchars;
  1336   unsigned char *buf;
  1337   Lisp_Object ret;
  1338   USE_SAFE_ALLOCA;
  1339 
  1340   if (! STRING_MULTIBYTE (string))
  1341     return string;
  1342 
  1343   nchars = SCHARS (string);
  1344 
  1345   buf = SAFE_ALLOCA (nchars);
  1346   copy_text (SDATA (string), buf, SBYTES (string),
  1347              1, 0);
  1348 
  1349   ret = make_unibyte_string ((char *) buf, nchars);
  1350   SAFE_FREE ();
  1351 
  1352   return ret;
  1353 }
  1354 
  1355 DEFUN ("string-make-multibyte", Fstring_make_multibyte, Sstring_make_multibyte,
  1356        1, 1, 0,
  1357        doc: /* Return the multibyte equivalent of STRING.
  1358 If STRING is unibyte and contains non-ASCII characters, the function
  1359 `unibyte-char-to-multibyte' is used to convert each unibyte character
  1360 to a multibyte character.  In this case, the returned string is a
  1361 newly created string with no text properties.  If STRING is multibyte
  1362 or entirely ASCII, it is returned unchanged.  In particular, when
  1363 STRING is unibyte and entirely ASCII, the returned string is unibyte.
  1364 \(When the characters are all ASCII, Emacs primitives will treat the
  1365 string the same way whether it is unibyte or multibyte.)  */)
  1366   (Lisp_Object string)
  1367 {
  1368   CHECK_STRING (string);
  1369 
  1370   if (STRING_MULTIBYTE (string))
  1371     return string;
  1372 
  1373   ptrdiff_t nchars = SCHARS (string);
  1374   ptrdiff_t nbytes = count_size_as_multibyte (SDATA (string), nchars);
  1375   if (nbytes == nchars)
  1376     return string;
  1377 
  1378   Lisp_Object ret = make_uninit_multibyte_string (nchars, nbytes);
  1379   str_to_multibyte (SDATA (ret), SDATA (string), nchars);
  1380   return ret;
  1381 }
  1382 
  1383 DEFUN ("string-make-unibyte", Fstring_make_unibyte, Sstring_make_unibyte,
  1384        1, 1, 0,
  1385        doc: /* Return the unibyte equivalent of STRING.
  1386 Multibyte character codes above 255 are converted to unibyte
  1387 by taking just the low 8 bits of each character's code.  */)
  1388   (Lisp_Object string)
  1389 {
  1390   CHECK_STRING (string);
  1391 
  1392   return string_make_unibyte (string);
  1393 }
  1394 
  1395 DEFUN ("string-as-unibyte", Fstring_as_unibyte, Sstring_as_unibyte,
  1396        1, 1, 0,
  1397        doc: /* Return a unibyte string with the same individual bytes as STRING.
  1398 If STRING is unibyte, the result is STRING itself.
  1399 Otherwise it is a newly created string, with no text properties.
  1400 If STRING is multibyte and contains a character of charset
  1401 `eight-bit', it is converted to the corresponding single byte.  */)
  1402   (Lisp_Object string)
  1403 {
  1404   CHECK_STRING (string);
  1405 
  1406   if (STRING_MULTIBYTE (string))
  1407     {
  1408       unsigned char *str = (unsigned char *) xlispstrdup (string);
  1409       ptrdiff_t bytes = str_as_unibyte (str, SBYTES (string));
  1410 
  1411       string = make_unibyte_string ((char *) str, bytes);
  1412       xfree (str);
  1413     }
  1414   return string;
  1415 }
  1416 
  1417 DEFUN ("string-as-multibyte", Fstring_as_multibyte, Sstring_as_multibyte,
  1418        1, 1, 0,
  1419        doc: /* Return a multibyte string with the same individual bytes as STRING.
  1420 If STRING is multibyte, the result is STRING itself.
  1421 Otherwise it is a newly created string, with no text properties.
  1422 
  1423 If STRING is unibyte and contains an individual 8-bit byte (i.e. not
  1424 part of a correct utf-8 sequence), it is converted to the corresponding
  1425 multibyte character of charset `eight-bit'.
  1426 See also `string-to-multibyte'.
  1427 
  1428 Beware, this often doesn't really do what you think it does.
  1429 It is similar to (decode-coding-string STRING \\='utf-8-emacs).
  1430 If you're not sure, whether to use `string-as-multibyte' or
  1431 `string-to-multibyte', use `string-to-multibyte'.  */)
  1432   (Lisp_Object string)
  1433 {
  1434   CHECK_STRING (string);
  1435 
  1436   if (! STRING_MULTIBYTE (string))
  1437     {
  1438       Lisp_Object new_string;
  1439       ptrdiff_t nchars, nbytes;
  1440 
  1441       parse_str_as_multibyte (SDATA (string),
  1442                               SBYTES (string),
  1443                               &nchars, &nbytes);
  1444       new_string = make_uninit_multibyte_string (nchars, nbytes);
  1445       memcpy (SDATA (new_string), SDATA (string), SBYTES (string));
  1446       if (nbytes != SBYTES (string))
  1447         str_as_multibyte (SDATA (new_string), nbytes,
  1448                           SBYTES (string), NULL);
  1449       string = new_string;
  1450       set_string_intervals (string, NULL);
  1451     }
  1452   return string;
  1453 }
  1454 
  1455 DEFUN ("string-to-multibyte", Fstring_to_multibyte, Sstring_to_multibyte,
  1456        1, 1, 0,
  1457        doc: /* Return a multibyte string with the same individual chars as STRING.
  1458 If STRING is multibyte, the result is STRING itself.
  1459 Otherwise it is a newly created string, with no text properties.
  1460 
  1461 If STRING is unibyte and contains an 8-bit byte, it is converted to
  1462 the corresponding multibyte character of charset `eight-bit'.
  1463 
  1464 This differs from `string-as-multibyte' by converting each byte of a correct
  1465 utf-8 sequence to an eight-bit character, not just bytes that don't form a
  1466 correct sequence.  */)
  1467   (Lisp_Object string)
  1468 {
  1469   CHECK_STRING (string);
  1470 
  1471   return string_to_multibyte (string);
  1472 }
  1473 
  1474 DEFUN ("string-to-unibyte", Fstring_to_unibyte, Sstring_to_unibyte,
  1475        1, 1, 0,
  1476        doc: /* Return a unibyte string with the same individual chars as STRING.
  1477 If STRING is unibyte, the result is STRING itself.
  1478 Otherwise it is a newly created string, with no text properties,
  1479 where each `eight-bit' character is converted to the corresponding byte.
  1480 If STRING contains a non-ASCII, non-`eight-bit' character,
  1481 an error is signaled.  */)
  1482   (Lisp_Object string)
  1483 {
  1484   CHECK_STRING (string);
  1485   if (!STRING_MULTIBYTE (string))
  1486     return string;
  1487 
  1488   ptrdiff_t chars = SCHARS (string);
  1489   Lisp_Object ret = make_uninit_string (chars);
  1490   unsigned char *src = SDATA (string);
  1491   unsigned char *dst = SDATA (ret);
  1492   for (ptrdiff_t i = 0; i < chars; i++)
  1493     {
  1494       unsigned char b = *src++;
  1495       if (b <= 0x7f)
  1496         *dst++ = b;                                      /* ASCII */
  1497       else if (CHAR_BYTE8_HEAD_P (b))
  1498         *dst++ = 0x80 | (b & 1) << 6 | (*src++ & 0x3f);  /* raw byte */
  1499       else
  1500         error ("Cannot convert character at index %"pD"d to unibyte", i);
  1501     }
  1502   return ret;
  1503 }
  1504 
  1505 
  1506 DEFUN ("copy-alist", Fcopy_alist, Scopy_alist, 1, 1, 0,
  1507        doc: /* Return a copy of ALIST.
  1508 This is an alist which represents the same mapping from objects to objects,
  1509 but does not share the alist structure with ALIST.
  1510 The objects mapped (cars and cdrs of elements of the alist)
  1511 are shared, however.
  1512 Elements of ALIST that are not conses are also shared.  */)
  1513   (Lisp_Object alist)
  1514 {
  1515   CHECK_LIST (alist);
  1516   if (NILP (alist))
  1517     return alist;
  1518   alist = Fcopy_sequence (alist);
  1519   for (Lisp_Object tem = alist; !NILP (tem); tem = XCDR (tem))
  1520     {
  1521       Lisp_Object car = XCAR (tem);
  1522       if (CONSP (car))
  1523         XSETCAR (tem, Fcons (XCAR (car), XCDR (car)));
  1524     }
  1525   return alist;
  1526 }
  1527 
  1528 /* Check that ARRAY can have a valid subarray [FROM..TO),
  1529    given that its size is SIZE.
  1530    If FROM is nil, use 0; if TO is nil, use SIZE.
  1531    Count negative values backwards from the end.
  1532    Set *IFROM and *ITO to the two indexes used.  */
  1533 
  1534 void
  1535 validate_subarray (Lisp_Object array, Lisp_Object from, Lisp_Object to,
  1536                    ptrdiff_t size, ptrdiff_t *ifrom, ptrdiff_t *ito)
  1537 {
  1538   EMACS_INT f, t;
  1539 
  1540   if (FIXNUMP (from))
  1541     {
  1542       f = XFIXNUM (from);
  1543       if (f < 0)
  1544         f += size;
  1545     }
  1546   else if (NILP (from))
  1547     f = 0;
  1548   else
  1549     wrong_type_argument (Qintegerp, from);
  1550 
  1551   if (FIXNUMP (to))
  1552     {
  1553       t = XFIXNUM (to);
  1554       if (t < 0)
  1555         t += size;
  1556     }
  1557   else if (NILP (to))
  1558     t = size;
  1559   else
  1560     wrong_type_argument (Qintegerp, to);
  1561 
  1562   if (! (0 <= f && f <= t && t <= size))
  1563     args_out_of_range_3 (array, from, to);
  1564 
  1565   *ifrom = f;
  1566   *ito = t;
  1567 }
  1568 
  1569 DEFUN ("substring", Fsubstring, Ssubstring, 1, 3, 0,
  1570        doc: /* Return a new string whose contents are a substring of STRING.
  1571 The returned string consists of the characters between index FROM
  1572 \(inclusive) and index TO (exclusive) of STRING.  FROM and TO are
  1573 zero-indexed: 0 means the first character of STRING.  Negative values
  1574 are counted from the end of STRING.  If TO is nil, the substring runs
  1575 to the end of STRING.
  1576 
  1577 The STRING argument may also be a vector.  In that case, the return
  1578 value is a new vector that contains the elements between index FROM
  1579 \(inclusive) and index TO (exclusive) of that vector argument.
  1580 
  1581 With one argument, just copy STRING (with properties, if any).  */)
  1582   (Lisp_Object string, Lisp_Object from, Lisp_Object to)
  1583 {
  1584   Lisp_Object res;
  1585   ptrdiff_t size, ifrom, ito;
  1586 
  1587   size = CHECK_VECTOR_OR_STRING (string);
  1588   validate_subarray (string, from, to, size, &ifrom, &ito);
  1589 
  1590   if (STRINGP (string))
  1591     {
  1592       ptrdiff_t from_byte
  1593         = !ifrom ? 0 : string_char_to_byte (string, ifrom);
  1594       ptrdiff_t to_byte
  1595         = ito == size ? SBYTES (string) : string_char_to_byte (string, ito);
  1596       res = make_specified_string (SSDATA (string) + from_byte,
  1597                                    ito - ifrom, to_byte - from_byte,
  1598                                    STRING_MULTIBYTE (string));
  1599       copy_text_properties (make_fixnum (ifrom), make_fixnum (ito),
  1600                             string, make_fixnum (0), res, Qnil);
  1601     }
  1602   else
  1603     res = Fvector (ito - ifrom, aref_addr (string, ifrom));
  1604 
  1605   return res;
  1606 }
  1607 
  1608 
  1609 DEFUN ("substring-no-properties", Fsubstring_no_properties, Ssubstring_no_properties, 1, 3, 0,
  1610        doc: /* Return a substring of STRING, without text properties.
  1611 It starts at index FROM and ends before TO.
  1612 TO may be nil or omitted; then the substring runs to the end of STRING.
  1613 If FROM is nil or omitted, the substring starts at the beginning of STRING.
  1614 If FROM or TO is negative, it counts from the end.
  1615 
  1616 With one argument, just copy STRING without its properties.  */)
  1617   (Lisp_Object string, register Lisp_Object from, Lisp_Object to)
  1618 {
  1619   ptrdiff_t from_char, to_char, from_byte, to_byte, size;
  1620 
  1621   CHECK_STRING (string);
  1622 
  1623   size = SCHARS (string);
  1624   validate_subarray (string, from, to, size, &from_char, &to_char);
  1625 
  1626   from_byte = !from_char ? 0 : string_char_to_byte (string, from_char);
  1627   to_byte =
  1628     to_char == size ? SBYTES (string) : string_char_to_byte (string, to_char);
  1629   return make_specified_string (SSDATA (string) + from_byte,
  1630                                 to_char - from_char, to_byte - from_byte,
  1631                                 STRING_MULTIBYTE (string));
  1632 }
  1633 
  1634 /* Extract a substring of STRING, giving start and end positions
  1635    both in characters and in bytes.  */
  1636 
  1637 Lisp_Object
  1638 substring_both (Lisp_Object string, ptrdiff_t from, ptrdiff_t from_byte,
  1639                 ptrdiff_t to, ptrdiff_t to_byte)
  1640 {
  1641   Lisp_Object res;
  1642   ptrdiff_t size = CHECK_VECTOR_OR_STRING (string);
  1643 
  1644   if (!(0 <= from && from <= to && to <= size))
  1645     args_out_of_range_3 (string, make_fixnum (from), make_fixnum (to));
  1646 
  1647   if (STRINGP (string))
  1648     {
  1649       res = make_specified_string (SSDATA (string) + from_byte,
  1650                                    to - from, to_byte - from_byte,
  1651                                    STRING_MULTIBYTE (string));
  1652       copy_text_properties (make_fixnum (from), make_fixnum (to),
  1653                             string, make_fixnum (0), res, Qnil);
  1654     }
  1655   else
  1656     res = Fvector (to - from, aref_addr (string, from));
  1657 
  1658   return res;
  1659 }
  1660 
  1661 DEFUN ("take", Ftake, Stake, 2, 2, 0,
  1662        doc: /* Return the first N elements of LIST.
  1663 If N is zero or negative, return nil.
  1664 If N is greater or equal to the length of LIST, return LIST (or a copy).  */)
  1665   (Lisp_Object n, Lisp_Object list)
  1666 {
  1667   EMACS_INT m;
  1668   if (FIXNUMP (n))
  1669     {
  1670       m = XFIXNUM (n);
  1671       if (m <= 0)
  1672         return Qnil;
  1673     }
  1674   else if (BIGNUMP (n))
  1675     {
  1676       if (mpz_sgn (*xbignum_val (n)) < 0)
  1677         return Qnil;
  1678       m = MOST_POSITIVE_FIXNUM;
  1679     }
  1680   else
  1681     wrong_type_argument (Qintegerp, n);
  1682   CHECK_LIST (list);
  1683   if (NILP (list))
  1684     return Qnil;
  1685   Lisp_Object ret = Fcons (XCAR (list), Qnil);
  1686   Lisp_Object prev = ret;
  1687   m--;
  1688   list = XCDR (list);
  1689   while (m > 0 && CONSP (list))
  1690     {
  1691       Lisp_Object p = Fcons (XCAR (list), Qnil);
  1692       XSETCDR (prev, p);
  1693       prev = p;
  1694       m--;
  1695       list = XCDR (list);
  1696     }
  1697   if (m > 0 && !NILP (list))
  1698     wrong_type_argument (Qlistp, list);
  1699   return ret;
  1700 }
  1701 
  1702 DEFUN ("ntake", Fntake, Sntake, 2, 2, 0,
  1703        doc: /* Modify LIST to keep only the first N elements.
  1704 If N is zero or negative, return nil.
  1705 If N is greater or equal to the length of LIST, return LIST unmodified.
  1706 Otherwise, return LIST after truncating it.  */)
  1707   (Lisp_Object n, Lisp_Object list)
  1708 {
  1709   EMACS_INT m;
  1710   if (FIXNUMP (n))
  1711     {
  1712       m = XFIXNUM (n);
  1713       if (m <= 0)
  1714         return Qnil;
  1715     }
  1716   else if (BIGNUMP (n))
  1717     {
  1718       if (mpz_sgn (*xbignum_val (n)) < 0)
  1719         return Qnil;
  1720       m = MOST_POSITIVE_FIXNUM;
  1721     }
  1722   else
  1723     wrong_type_argument (Qintegerp, n);
  1724   CHECK_LIST (list);
  1725   Lisp_Object tail = list;
  1726   --m;
  1727   while (m > 0 && CONSP (tail))
  1728     {
  1729       tail = XCDR (tail);
  1730       m--;
  1731     }
  1732   if (CONSP (tail))
  1733     XSETCDR (tail, Qnil);
  1734   else if (!NILP (tail))
  1735     wrong_type_argument (Qlistp, list);
  1736   return list;
  1737 }
  1738 
  1739 DEFUN ("nthcdr", Fnthcdr, Snthcdr, 2, 2, 0,
  1740        doc: /* Take cdr N times on LIST, return the result.  */)
  1741   (Lisp_Object n, Lisp_Object list)
  1742 {
  1743   Lisp_Object tail = list;
  1744 
  1745   CHECK_INTEGER (n);
  1746 
  1747   /* A huge but in-range EMACS_INT that can be substituted for a
  1748      positive bignum while counting down.  It does not introduce
  1749      miscounts because a list or cycle cannot possibly be this long,
  1750      and any counting error is fixed up later.  */
  1751   EMACS_INT large_num = EMACS_INT_MAX;
  1752 
  1753   EMACS_INT num;
  1754   if (FIXNUMP (n))
  1755     {
  1756       num = XFIXNUM (n);
  1757 
  1758       /* Speed up small lists by omitting circularity and quit checking.  */
  1759       if (num <= SMALL_LIST_LEN_MAX)
  1760         {
  1761           for (; 0 < num; num--, tail = XCDR (tail))
  1762             if (! CONSP (tail))
  1763               {
  1764                 CHECK_LIST_END (tail, list);
  1765                 return Qnil;
  1766               }
  1767           return tail;
  1768         }
  1769     }
  1770   else
  1771     {
  1772       if (mpz_sgn (*xbignum_val (n)) < 0)
  1773         return tail;
  1774       num = large_num;
  1775     }
  1776 
  1777   EMACS_INT tortoise_num = num;
  1778   Lisp_Object saved_tail = tail;
  1779   FOR_EACH_TAIL_SAFE (tail)
  1780     {
  1781       /* If the tortoise just jumped (which is rare),
  1782          update TORTOISE_NUM accordingly.  */
  1783       if (BASE_EQ (tail, li.tortoise))
  1784         tortoise_num = num;
  1785 
  1786       saved_tail = XCDR (tail);
  1787       num--;
  1788       if (num == 0)
  1789         return saved_tail;
  1790       rarely_quit (num);
  1791     }
  1792 
  1793   tail = saved_tail;
  1794   if (! CONSP (tail))
  1795     {
  1796       CHECK_LIST_END (tail, list);
  1797       return Qnil;
  1798     }
  1799 
  1800   /* TAIL is part of a cycle.  Reduce NUM modulo the cycle length to
  1801      avoid going around this cycle repeatedly.  */
  1802   intptr_t cycle_length = tortoise_num - num;
  1803   if (! FIXNUMP (n))
  1804     {
  1805       /* Undo any error introduced when LARGE_NUM was substituted for
  1806          N, by adding N - LARGE_NUM to NUM, using arithmetic modulo
  1807          CYCLE_LENGTH.  */
  1808       /* Add N mod CYCLE_LENGTH to NUM.  */
  1809       if (cycle_length <= ULONG_MAX)
  1810         num += mpz_tdiv_ui (*xbignum_val (n), cycle_length);
  1811       else
  1812         {
  1813           mpz_set_intmax (mpz[0], cycle_length);
  1814           mpz_tdiv_r (mpz[0], *xbignum_val (n), mpz[0]);
  1815           intptr_t iz;
  1816           mpz_export (&iz, NULL, -1, sizeof iz, 0, 0, mpz[0]);
  1817           num += iz;
  1818         }
  1819       num += cycle_length - large_num % cycle_length;
  1820     }
  1821   num %= cycle_length;
  1822 
  1823   /* One last time through the cycle.  */
  1824   for (; 0 < num; num--)
  1825     {
  1826       tail = XCDR (tail);
  1827       rarely_quit (num);
  1828     }
  1829   return tail;
  1830 }
  1831 
  1832 DEFUN ("nth", Fnth, Snth, 2, 2, 0,
  1833        doc: /* Return the Nth element of LIST.
  1834 N counts from zero.  If LIST is not that long, nil is returned.  */)
  1835   (Lisp_Object n, Lisp_Object list)
  1836 {
  1837   return Fcar (Fnthcdr (n, list));
  1838 }
  1839 
  1840 DEFUN ("elt", Felt, Selt, 2, 2, 0,
  1841        doc: /* Return element of SEQUENCE at index N.  */)
  1842   (Lisp_Object sequence, Lisp_Object n)
  1843 {
  1844   if (CONSP (sequence) || NILP (sequence))
  1845     return Fcar (Fnthcdr (n, sequence));
  1846 
  1847   /* Faref signals a "not array" error, so check here.  */
  1848   CHECK_ARRAY (sequence, Qsequencep);
  1849   return Faref (sequence, n);
  1850 }
  1851 
  1852 enum { WORDS_PER_DOUBLE = (sizeof (double) / sizeof (EMACS_UINT)
  1853                           + (sizeof (double) % sizeof (EMACS_UINT) != 0)) };
  1854 union double_and_words
  1855 {
  1856   double val;
  1857   EMACS_UINT word[WORDS_PER_DOUBLE];
  1858 };
  1859 
  1860 /* Return true if the floats X and Y have the same value.
  1861    This looks at X's and Y's representation, since (unlike '==')
  1862    it returns true if X and Y are the same NaN.  */
  1863 static bool
  1864 same_float (Lisp_Object x, Lisp_Object y)
  1865 {
  1866   union double_and_words
  1867     xu = { .val = XFLOAT_DATA (x) },
  1868     yu = { .val = XFLOAT_DATA (y) };
  1869   EMACS_UINT neql = 0;
  1870   for (int i = 0; i < WORDS_PER_DOUBLE; i++)
  1871     neql |= xu.word[i] ^ yu.word[i];
  1872   return !neql;
  1873 }
  1874 
  1875 /* True if X can be compared using `eq'.
  1876    This predicate is approximative, for maximum speed.  */
  1877 static bool
  1878 eq_comparable_value (Lisp_Object x)
  1879 {
  1880   return SYMBOLP (x) || FIXNUMP (x);
  1881 }
  1882 
  1883 DEFUN ("member", Fmember, Smember, 2, 2, 0,
  1884        doc: /* Return non-nil if ELT is an element of LIST.  Comparison done with `equal'.
  1885 The value is actually the tail of LIST whose car is ELT.  */)
  1886   (Lisp_Object elt, Lisp_Object list)
  1887 {
  1888   if (eq_comparable_value (elt))
  1889     return Fmemq (elt, list);
  1890   Lisp_Object tail = list;
  1891   FOR_EACH_TAIL (tail)
  1892     if (! NILP (Fequal (elt, XCAR (tail))))
  1893       return tail;
  1894   CHECK_LIST_END (tail, list);
  1895   return Qnil;
  1896 }
  1897 
  1898 DEFUN ("memq", Fmemq, Smemq, 2, 2, 0,
  1899        doc: /* Return non-nil if ELT is an element of LIST.  Comparison done with `eq'.
  1900 The value is actually the tail of LIST whose car is ELT.  */)
  1901   (Lisp_Object elt, Lisp_Object list)
  1902 {
  1903   Lisp_Object tail = list;
  1904   FOR_EACH_TAIL (tail)
  1905     if (EQ (XCAR (tail), elt))
  1906       return tail;
  1907   CHECK_LIST_END (tail, list);
  1908   return Qnil;
  1909 }
  1910 
  1911 DEFUN ("memql", Fmemql, Smemql, 2, 2, 0,
  1912        doc: /* Return non-nil if ELT is an element of LIST.  Comparison done with `eql'.
  1913 The value is actually the tail of LIST whose car is ELT.  */)
  1914   (Lisp_Object elt, Lisp_Object list)
  1915 {
  1916   Lisp_Object tail = list;
  1917 
  1918   if (FLOATP (elt))
  1919     {
  1920       FOR_EACH_TAIL (tail)
  1921         {
  1922           Lisp_Object tem = XCAR (tail);
  1923           if (FLOATP (tem) && same_float (elt, tem))
  1924             return tail;
  1925         }
  1926     }
  1927   else if (BIGNUMP (elt))
  1928     {
  1929       FOR_EACH_TAIL (tail)
  1930         {
  1931           Lisp_Object tem = XCAR (tail);
  1932           if (BIGNUMP (tem)
  1933               && mpz_cmp (*xbignum_val (elt), *xbignum_val (tem)) == 0)
  1934             return tail;
  1935         }
  1936     }
  1937   else
  1938     return Fmemq (elt, list);
  1939 
  1940   CHECK_LIST_END (tail, list);
  1941   return Qnil;
  1942 }
  1943 
  1944 DEFUN ("assq", Fassq, Sassq, 2, 2, 0,
  1945        doc: /* Return non-nil if KEY is `eq' to the car of an element of ALIST.
  1946 The value is actually the first element of ALIST whose car is KEY.
  1947 Elements of ALIST that are not conses are ignored.  */)
  1948   (Lisp_Object key, Lisp_Object alist)
  1949 {
  1950   Lisp_Object tail = alist;
  1951   FOR_EACH_TAIL (tail)
  1952     if (CONSP (XCAR (tail)) && EQ (XCAR (XCAR (tail)), key))
  1953       return XCAR (tail);
  1954   CHECK_LIST_END (tail, alist);
  1955   return Qnil;
  1956 }
  1957 
  1958 /* Like Fassq but never report an error and do not allow quits.
  1959    Use only on objects known to be non-circular lists.  */
  1960 
  1961 Lisp_Object
  1962 assq_no_quit (Lisp_Object key, Lisp_Object alist)
  1963 {
  1964   for (; ! NILP (alist); alist = XCDR (alist))
  1965     if (CONSP (XCAR (alist)) && EQ (XCAR (XCAR (alist)), key))
  1966       return XCAR (alist);
  1967   return Qnil;
  1968 }
  1969 
  1970 /* Assq but doesn't signal.  Unlike assq_no_quit, this function still
  1971    detects circular lists; like assq_no_quit, this function does not
  1972    allow quits and never signals.  If anything goes wrong, it returns
  1973    Qnil.  */
  1974 Lisp_Object
  1975 assq_no_signal (Lisp_Object key, Lisp_Object alist)
  1976 {
  1977   Lisp_Object tail = alist;
  1978   FOR_EACH_TAIL_SAFE (tail)
  1979     if (CONSP (XCAR (tail)) && EQ (XCAR (XCAR (tail)), key))
  1980       return XCAR (tail);
  1981   return Qnil;
  1982 }
  1983 
  1984 DEFUN ("assoc", Fassoc, Sassoc, 2, 3, 0,
  1985        doc: /* Return non-nil if KEY is equal to the car of an element of ALIST.
  1986 The value is actually the first element of ALIST whose car equals KEY.
  1987 
  1988 Equality is defined by the function TESTFN, defaulting to `equal'.
  1989 TESTFN is called with 2 arguments: a car of an alist element and KEY.  */)
  1990      (Lisp_Object key, Lisp_Object alist, Lisp_Object testfn)
  1991 {
  1992   if (eq_comparable_value (key) && NILP (testfn))
  1993     return Fassq (key, alist);
  1994   Lisp_Object tail = alist;
  1995   FOR_EACH_TAIL (tail)
  1996     {
  1997       Lisp_Object car = XCAR (tail);
  1998       if (CONSP (car)
  1999           && (NILP (testfn)
  2000               ? (EQ (XCAR (car), key) || !NILP (Fequal
  2001                                                 (XCAR (car), key)))
  2002               : !NILP (call2 (testfn, XCAR (car), key))))
  2003         return car;
  2004     }
  2005   CHECK_LIST_END (tail, alist);
  2006   return Qnil;
  2007 }
  2008 
  2009 /* Like Fassoc but never report an error and do not allow quits.
  2010    Use only on keys and lists known to be non-circular, and on keys
  2011    that are not too deep and are not window configurations.  */
  2012 
  2013 Lisp_Object
  2014 assoc_no_quit (Lisp_Object key, Lisp_Object alist)
  2015 {
  2016   for (; ! NILP (alist); alist = XCDR (alist))
  2017     {
  2018       Lisp_Object car = XCAR (alist);
  2019       if (CONSP (car)
  2020           && (EQ (XCAR (car), key) || equal_no_quit (XCAR (car), key)))
  2021         return car;
  2022     }
  2023   return Qnil;
  2024 }
  2025 
  2026 DEFUN ("rassq", Frassq, Srassq, 2, 2, 0,
  2027        doc: /* Return non-nil if KEY is `eq' to the cdr of an element of ALIST.
  2028 The value is actually the first element of ALIST whose cdr is KEY.  */)
  2029   (Lisp_Object key, Lisp_Object alist)
  2030 {
  2031   Lisp_Object tail = alist;
  2032   FOR_EACH_TAIL (tail)
  2033     if (CONSP (XCAR (tail)) && EQ (XCDR (XCAR (tail)), key))
  2034       return XCAR (tail);
  2035   CHECK_LIST_END (tail, alist);
  2036   return Qnil;
  2037 }
  2038 
  2039 DEFUN ("rassoc", Frassoc, Srassoc, 2, 2, 0,
  2040        doc: /* Return non-nil if KEY is `equal' to the cdr of an element of ALIST.
  2041 The value is actually the first element of ALIST whose cdr equals KEY.  */)
  2042   (Lisp_Object key, Lisp_Object alist)
  2043 {
  2044   if (eq_comparable_value (key))
  2045     return Frassq (key, alist);
  2046   Lisp_Object tail = alist;
  2047   FOR_EACH_TAIL (tail)
  2048     {
  2049       Lisp_Object car = XCAR (tail);
  2050       if (CONSP (car)
  2051           && (EQ (XCDR (car), key) || !NILP (Fequal (XCDR (car), key))))
  2052         return car;
  2053     }
  2054   CHECK_LIST_END (tail, alist);
  2055   return Qnil;
  2056 }
  2057 
  2058 DEFUN ("delq", Fdelq, Sdelq, 2, 2, 0,
  2059        doc: /* Delete members of LIST which are `eq' to ELT, and return the result.
  2060 More precisely, this function skips any members `eq' to ELT at the
  2061 front of LIST, then removes members `eq' to ELT from the remaining
  2062 sublist by modifying its list structure, then returns the resulting
  2063 list.
  2064 
  2065 Write `(setq foo (delq element foo))' to be sure of correctly changing
  2066 the value of a list `foo'.  See also `remq', which does not modify the
  2067 argument.  */)
  2068   (Lisp_Object elt, Lisp_Object list)
  2069 {
  2070   Lisp_Object prev = Qnil, tail = list;
  2071 
  2072   FOR_EACH_TAIL (tail)
  2073     {
  2074       Lisp_Object tem = XCAR (tail);
  2075       if (EQ (elt, tem))
  2076         {
  2077           if (NILP (prev))
  2078             list = XCDR (tail);
  2079           else
  2080             Fsetcdr (prev, XCDR (tail));
  2081         }
  2082       else
  2083         prev = tail;
  2084     }
  2085   CHECK_LIST_END (tail, list);
  2086   return list;
  2087 }
  2088 
  2089 DEFUN ("delete", Fdelete, Sdelete, 2, 2, 0,
  2090        doc: /* Delete members of SEQ which are `equal' to ELT, and return the result.
  2091 SEQ must be a sequence (i.e. a list, a vector, or a string).
  2092 The return value is a sequence of the same type.
  2093 
  2094 If SEQ is a list, this behaves like `delq', except that it compares
  2095 with `equal' instead of `eq'.  In particular, it may remove elements
  2096 by altering the list structure.
  2097 
  2098 If SEQ is not a list, deletion is never performed destructively;
  2099 instead this function creates and returns a new vector or string.
  2100 
  2101 Write `(setq foo (delete element foo))' to be sure of correctly
  2102 changing the value of a sequence `foo'.  See also `remove', which
  2103 does not modify the argument.  */)
  2104   (Lisp_Object elt, Lisp_Object seq)
  2105 {
  2106   if (VECTORP (seq))
  2107     {
  2108       ptrdiff_t n = 0;
  2109       ptrdiff_t size = ASIZE (seq);
  2110       USE_SAFE_ALLOCA;
  2111       Lisp_Object *kept = SAFE_ALLOCA (size * sizeof *kept);
  2112 
  2113       for (ptrdiff_t i = 0; i < size; i++)
  2114         {
  2115           kept[n] = AREF (seq, i);
  2116           n += NILP (Fequal (AREF (seq, i), elt));
  2117         }
  2118 
  2119       if (n != size)
  2120         seq = Fvector (n, kept);
  2121 
  2122       SAFE_FREE ();
  2123     }
  2124   else if (STRINGP (seq))
  2125     {
  2126       if (!CHARACTERP (elt))
  2127         return seq;
  2128 
  2129       ptrdiff_t i, ibyte, nchars, nbytes, cbytes;
  2130       int c;
  2131 
  2132       for (i = nchars = nbytes = ibyte = 0;
  2133            i < SCHARS (seq);
  2134            ++i, ibyte += cbytes)
  2135         {
  2136           if (STRING_MULTIBYTE (seq))
  2137             {
  2138               c = STRING_CHAR (SDATA (seq) + ibyte);
  2139               cbytes = CHAR_BYTES (c);
  2140             }
  2141           else
  2142             {
  2143               c = SREF (seq, i);
  2144               cbytes = 1;
  2145             }
  2146 
  2147           if (c != XFIXNUM (elt))
  2148             {
  2149               ++nchars;
  2150               nbytes += cbytes;
  2151             }
  2152         }
  2153 
  2154       if (nchars != SCHARS (seq))
  2155         {
  2156           Lisp_Object tem;
  2157 
  2158           tem = make_uninit_multibyte_string (nchars, nbytes);
  2159           if (!STRING_MULTIBYTE (seq))
  2160             STRING_SET_UNIBYTE (tem);
  2161 
  2162           for (i = nchars = nbytes = ibyte = 0;
  2163                i < SCHARS (seq);
  2164                ++i, ibyte += cbytes)
  2165             {
  2166               if (STRING_MULTIBYTE (seq))
  2167                 {
  2168                   c = STRING_CHAR (SDATA (seq) + ibyte);
  2169                   cbytes = CHAR_BYTES (c);
  2170                 }
  2171               else
  2172                 {
  2173                   c = SREF (seq, i);
  2174                   cbytes = 1;
  2175                 }
  2176 
  2177               if (c != XFIXNUM (elt))
  2178                 {
  2179                   unsigned char *from = SDATA (seq) + ibyte;
  2180                   unsigned char *to   = SDATA (tem) + nbytes;
  2181                   ptrdiff_t n;
  2182 
  2183                   ++nchars;
  2184                   nbytes += cbytes;
  2185 
  2186                   for (n = cbytes; n--; )
  2187                     *to++ = *from++;
  2188                 }
  2189             }
  2190 
  2191           seq = tem;
  2192         }
  2193     }
  2194   else
  2195     {
  2196       Lisp_Object prev = Qnil, tail = seq;
  2197 
  2198       FOR_EACH_TAIL (tail)
  2199         {
  2200           if (!NILP (Fequal (elt, XCAR (tail))))
  2201             {
  2202               if (NILP (prev))
  2203                 seq = XCDR (tail);
  2204               else
  2205                 Fsetcdr (prev, XCDR (tail));
  2206             }
  2207           else
  2208             prev = tail;
  2209         }
  2210       CHECK_LIST_END (tail, seq);
  2211     }
  2212 
  2213   return seq;
  2214 }
  2215 
  2216 DEFUN ("nreverse", Fnreverse, Snreverse, 1, 1, 0,
  2217        doc: /* Reverse order of items in a list, vector or string SEQ.
  2218 If SEQ is a list, it should be nil-terminated.
  2219 This function may destructively modify SEQ to produce the value.  */)
  2220   (Lisp_Object seq)
  2221 {
  2222   if (NILP (seq))
  2223     return seq;
  2224   else if (STRINGP (seq))
  2225     return Freverse (seq);
  2226   else if (CONSP (seq))
  2227     {
  2228       Lisp_Object prev, tail, next;
  2229 
  2230       for (prev = Qnil, tail = seq; CONSP (tail); tail = next)
  2231         {
  2232           next = XCDR (tail);
  2233           /* If SEQ contains a cycle, attempting to reverse it
  2234              in-place will inevitably come back to SEQ.  */
  2235           if (BASE_EQ (next, seq))
  2236             circular_list (seq);
  2237           Fsetcdr (tail, prev);
  2238           prev = tail;
  2239         }
  2240       CHECK_LIST_END (tail, seq);
  2241       seq = prev;
  2242     }
  2243   else if (VECTORP (seq))
  2244     {
  2245       ptrdiff_t i, size = ASIZE (seq);
  2246 
  2247       for (i = 0; i < size / 2; i++)
  2248         {
  2249           Lisp_Object tem = AREF (seq, i);
  2250           ASET (seq, i, AREF (seq, size - i - 1));
  2251           ASET (seq, size - i - 1, tem);
  2252         }
  2253     }
  2254   else if (BOOL_VECTOR_P (seq))
  2255     {
  2256       ptrdiff_t i, size = bool_vector_size (seq);
  2257 
  2258       for (i = 0; i < size / 2; i++)
  2259         {
  2260           bool tem = bool_vector_bitref (seq, i);
  2261           bool_vector_set (seq, i, bool_vector_bitref (seq, size - i - 1));
  2262           bool_vector_set (seq, size - i - 1, tem);
  2263         }
  2264     }
  2265   else
  2266     wrong_type_argument (Qarrayp, seq);
  2267   return seq;
  2268 }
  2269 
  2270 DEFUN ("reverse", Freverse, Sreverse, 1, 1, 0,
  2271        doc: /* Return the reversed copy of list, vector, or string SEQ.
  2272 See also the function `nreverse', which is used more often.  */)
  2273   (Lisp_Object seq)
  2274 {
  2275   Lisp_Object new;
  2276 
  2277   if (NILP (seq))
  2278     return Qnil;
  2279   else if (CONSP (seq))
  2280     {
  2281       new = Qnil;
  2282       FOR_EACH_TAIL (seq)
  2283         new = Fcons (XCAR (seq), new);
  2284       CHECK_LIST_END (seq, seq);
  2285     }
  2286   else if (VECTORP (seq))
  2287     {
  2288       ptrdiff_t i, size = ASIZE (seq);
  2289 
  2290       new = make_uninit_vector (size);
  2291       for (i = 0; i < size; i++)
  2292         ASET (new, i, AREF (seq, size - i - 1));
  2293     }
  2294   else if (BOOL_VECTOR_P (seq))
  2295     {
  2296       ptrdiff_t i;
  2297       EMACS_INT nbits = bool_vector_size (seq);
  2298 
  2299       new = make_uninit_bool_vector (nbits);
  2300       for (i = 0; i < nbits; i++)
  2301         bool_vector_set (new, i, bool_vector_bitref (seq, nbits - i - 1));
  2302     }
  2303   else if (STRINGP (seq))
  2304     {
  2305       ptrdiff_t size = SCHARS (seq), bytes = SBYTES (seq);
  2306 
  2307       if (size == bytes)
  2308         {
  2309           ptrdiff_t i;
  2310 
  2311           new = make_uninit_string (size);
  2312           for (i = 0; i < size; i++)
  2313             SSET (new, i, SREF (seq, size - i - 1));
  2314         }
  2315       else
  2316         {
  2317           unsigned char *p, *q;
  2318 
  2319           new = make_uninit_multibyte_string (size, bytes);
  2320           p = SDATA (seq), q = SDATA (new) + bytes;
  2321           while (q > SDATA (new))
  2322             {
  2323               int len, ch = string_char_and_length (p, &len);
  2324               p += len, q -= len;
  2325               CHAR_STRING (ch, q);
  2326             }
  2327         }
  2328     }
  2329   else
  2330     wrong_type_argument (Qsequencep, seq);
  2331   return new;
  2332 }
  2333 
  2334 
  2335 /* Stably sort LIST ordered by PREDICATE using the TIMSORT
  2336    algorithm. This converts the list to a vector, sorts the vector,
  2337    and returns the result converted back to a list.  The input list is
  2338    destructively reused to hold the sorted result.  */
  2339 
  2340 static Lisp_Object
  2341 sort_list (Lisp_Object list, Lisp_Object predicate)
  2342 {
  2343   ptrdiff_t length = list_length (list);
  2344   if (length < 2)
  2345     return list;
  2346   else
  2347     {
  2348       Lisp_Object *result;
  2349       USE_SAFE_ALLOCA;
  2350       SAFE_ALLOCA_LISP (result, length);
  2351       Lisp_Object tail = list;
  2352       for (ptrdiff_t i = 0; i < length; i++)
  2353         {
  2354           result[i] = Fcar (tail);
  2355           tail = XCDR (tail);
  2356         }
  2357       tim_sort (predicate, result, length);
  2358 
  2359       ptrdiff_t i = 0;
  2360       tail = list;
  2361       while (CONSP (tail))
  2362         {
  2363           XSETCAR (tail, result[i]);
  2364           tail = XCDR (tail);
  2365           i++;
  2366         }
  2367       SAFE_FREE ();
  2368       return list;
  2369     }
  2370 }
  2371 
  2372 /* Stably sort VECTOR ordered by PREDICATE using the TIMSORT
  2373    algorithm.  */
  2374 
  2375 static void
  2376 sort_vector (Lisp_Object vector, Lisp_Object predicate)
  2377 {
  2378   ptrdiff_t length = ASIZE (vector);
  2379   if (length < 2)
  2380     return;
  2381 
  2382   tim_sort (predicate, XVECTOR (vector)->contents, length);
  2383 }
  2384 
  2385 DEFUN ("sort", Fsort, Ssort, 2, 2, 0,
  2386        doc: /* Sort SEQ, stably, comparing elements using PREDICATE.
  2387 Returns the sorted sequence.  SEQ should be a list or vector.  SEQ is
  2388 modified by side effects.  PREDICATE is called with two elements of
  2389 SEQ, and should return non-nil if the first element should sort before
  2390 the second.  */)
  2391   (Lisp_Object seq, Lisp_Object predicate)
  2392 {
  2393   if (CONSP (seq))
  2394     seq = sort_list (seq, predicate);
  2395   else if (VECTORP (seq))
  2396     sort_vector (seq, predicate);
  2397   else if (!NILP (seq))
  2398     wrong_type_argument (Qlist_or_vector_p, seq);
  2399   return seq;
  2400 }
  2401 
  2402 Lisp_Object
  2403 merge (Lisp_Object org_l1, Lisp_Object org_l2, Lisp_Object pred)
  2404 {
  2405   Lisp_Object l1 = org_l1;
  2406   Lisp_Object l2 = org_l2;
  2407   Lisp_Object tail = Qnil;
  2408   Lisp_Object value = Qnil;
  2409 
  2410   while (1)
  2411     {
  2412       if (NILP (l1))
  2413         {
  2414           if (NILP (tail))
  2415             return l2;
  2416           Fsetcdr (tail, l2);
  2417           return value;
  2418         }
  2419       if (NILP (l2))
  2420         {
  2421           if (NILP (tail))
  2422             return l1;
  2423           Fsetcdr (tail, l1);
  2424           return value;
  2425         }
  2426 
  2427       Lisp_Object tem;
  2428       if (!NILP (call2 (pred, Fcar (l1), Fcar (l2))))
  2429         {
  2430           tem = l1;
  2431           l1 = Fcdr (l1);
  2432           org_l1 = l1;
  2433         }
  2434       else
  2435         {
  2436           tem = l2;
  2437           l2 = Fcdr (l2);
  2438           org_l2 = l2;
  2439         }
  2440       if (NILP (tail))
  2441         value = tem;
  2442       else
  2443         Fsetcdr (tail, tem);
  2444       tail = tem;
  2445     }
  2446 }
  2447 
  2448 Lisp_Object
  2449 merge_c (Lisp_Object org_l1, Lisp_Object org_l2, bool (*less) (Lisp_Object, Lisp_Object))
  2450 {
  2451   Lisp_Object l1 = org_l1;
  2452   Lisp_Object l2 = org_l2;
  2453   Lisp_Object tail = Qnil;
  2454   Lisp_Object value = Qnil;
  2455 
  2456   while (1)
  2457     {
  2458       if (NILP (l1))
  2459         {
  2460           if (NILP (tail))
  2461             return l2;
  2462           Fsetcdr (tail, l2);
  2463           return value;
  2464         }
  2465       if (NILP (l2))
  2466         {
  2467           if (NILP (tail))
  2468             return l1;
  2469           Fsetcdr (tail, l1);
  2470           return value;
  2471         }
  2472 
  2473       Lisp_Object tem;
  2474       if (less (Fcar (l1), Fcar (l2)))
  2475         {
  2476           tem = l1;
  2477           l1 = Fcdr (l1);
  2478           org_l1 = l1;
  2479         }
  2480       else
  2481         {
  2482           tem = l2;
  2483           l2 = Fcdr (l2);
  2484           org_l2 = l2;
  2485         }
  2486       if (NILP (tail))
  2487         value = tem;
  2488       else
  2489         Fsetcdr (tail, tem);
  2490       tail = tem;
  2491     }
  2492 }
  2493 
  2494 
  2495 /* This does not check for quits.  That is safe since it must terminate.  */
  2496 
  2497 DEFUN ("plist-get", Fplist_get, Splist_get, 2, 3, 0,
  2498        doc: /* Extract a value from a property list.
  2499 PLIST is a property list, which is a list of the form
  2500 \(PROP1 VALUE1 PROP2 VALUE2...).
  2501 
  2502 This function returns the value corresponding to the given PROP, or
  2503 nil if PROP is not one of the properties on the list.  The comparison
  2504 with PROP is done using PREDICATE, which defaults to `eq'.
  2505 
  2506 This function doesn't signal an error if PLIST is invalid.  */)
  2507   (Lisp_Object plist, Lisp_Object prop, Lisp_Object predicate)
  2508 {
  2509   if (NILP (predicate))
  2510     return plist_get (plist, prop);
  2511 
  2512   Lisp_Object tail = plist;
  2513   FOR_EACH_TAIL_SAFE (tail)
  2514     {
  2515       if (! CONSP (XCDR (tail)))
  2516         break;
  2517       if (!NILP (call2 (predicate, XCAR (tail), prop)))
  2518         return XCAR (XCDR (tail));
  2519       tail = XCDR (tail);
  2520     }
  2521 
  2522   return Qnil;
  2523 }
  2524 
  2525 /* Faster version of Fplist_get that works with EQ only.  */
  2526 Lisp_Object
  2527 plist_get (Lisp_Object plist, Lisp_Object prop)
  2528 {
  2529   Lisp_Object tail = plist;
  2530   FOR_EACH_TAIL_SAFE (tail)
  2531     {
  2532       if (! CONSP (XCDR (tail)))
  2533         break;
  2534       if (EQ (XCAR (tail), prop))
  2535         return XCAR (XCDR (tail));
  2536       tail = XCDR (tail);
  2537     }
  2538   return Qnil;
  2539 }
  2540 
  2541 DEFUN ("get", Fget, Sget, 2, 2, 0,
  2542        doc: /* Return the value of SYMBOL's PROPNAME property.
  2543 This is the last value stored with `(put SYMBOL PROPNAME VALUE)'.  */)
  2544   (Lisp_Object symbol, Lisp_Object propname)
  2545 {
  2546   CHECK_SYMBOL (symbol);
  2547   Lisp_Object propval = plist_get (CDR (Fassq (symbol,
  2548                                                Voverriding_plist_environment)),
  2549                                    propname);
  2550   if (!NILP (propval))
  2551     return propval;
  2552   return plist_get (XSYMBOL (symbol)->u.s.plist, propname);
  2553 }
  2554 
  2555 DEFUN ("plist-put", Fplist_put, Splist_put, 3, 4, 0,
  2556        doc: /* Change value in PLIST of PROP to VAL.
  2557 PLIST is a property list, which is a list of the form
  2558 \(PROP1 VALUE1 PROP2 VALUE2 ...).
  2559 
  2560 The comparison with PROP is done using PREDICATE, which defaults to `eq'.
  2561 
  2562 If PROP is already a property on the list, its value is set to VAL,
  2563 otherwise the new PROP VAL pair is added.  The new plist is returned;
  2564 use `(setq x (plist-put x prop val))' to be sure to use the new value.
  2565 The PLIST is modified by side effects.  */)
  2566   (Lisp_Object plist, Lisp_Object prop, Lisp_Object val, Lisp_Object predicate)
  2567 {
  2568   if (NILP (predicate))
  2569     return plist_put (plist, prop, val);
  2570   Lisp_Object prev = Qnil, tail = plist;
  2571   FOR_EACH_TAIL (tail)
  2572     {
  2573       if (! CONSP (XCDR (tail)))
  2574         break;
  2575 
  2576       if (!NILP (call2 (predicate, XCAR (tail), prop)))
  2577         {
  2578           Fsetcar (XCDR (tail), val);
  2579           return plist;
  2580         }
  2581 
  2582       prev = tail;
  2583       tail = XCDR (tail);
  2584     }
  2585   CHECK_TYPE (NILP (tail), Qplistp, plist);
  2586   Lisp_Object newcell
  2587     = Fcons (prop, Fcons (val, NILP (prev) ? plist : XCDR (XCDR (prev))));
  2588   if (NILP (prev))
  2589     return newcell;
  2590   Fsetcdr (XCDR (prev), newcell);
  2591   return plist;
  2592 }
  2593 
  2594 /* Faster version of Fplist_put that works with EQ only.  */
  2595 Lisp_Object
  2596 plist_put (Lisp_Object plist, Lisp_Object prop, Lisp_Object val)
  2597 {
  2598   Lisp_Object prev = Qnil, tail = plist;
  2599   FOR_EACH_TAIL (tail)
  2600     {
  2601       if (! CONSP (XCDR (tail)))
  2602         break;
  2603 
  2604       if (EQ (XCAR (tail), prop))
  2605         {
  2606           Fsetcar (XCDR (tail), val);
  2607           return plist;
  2608         }
  2609 
  2610       prev = tail;
  2611       tail = XCDR (tail);
  2612     }
  2613   CHECK_TYPE (NILP (tail), Qplistp, plist);
  2614   Lisp_Object newcell
  2615     = Fcons (prop, Fcons (val, NILP (prev) ? plist : XCDR (XCDR (prev))));
  2616   if (NILP (prev))
  2617     return newcell;
  2618   Fsetcdr (XCDR (prev), newcell);
  2619   return plist;
  2620 }
  2621 
  2622 DEFUN ("put", Fput, Sput, 3, 3, 0,
  2623        doc: /* Store SYMBOL's PROPNAME property with value VALUE.
  2624 It can be retrieved with `(get SYMBOL PROPNAME)'.  */)
  2625   (Lisp_Object symbol, Lisp_Object propname, Lisp_Object value)
  2626 {
  2627   CHECK_SYMBOL (symbol);
  2628   set_symbol_plist
  2629     (symbol, plist_put (XSYMBOL (symbol)->u.s.plist, propname, value));
  2630   return value;
  2631 }
  2632 
  2633 DEFUN ("plist-member", Fplist_member, Splist_member, 2, 3, 0,
  2634        doc: /* Return non-nil if PLIST has the property PROP.
  2635 PLIST is a property list, which is a list of the form
  2636 \(PROP1 VALUE1 PROP2 VALUE2 ...).
  2637 
  2638 The comparison with PROP is done using PREDICATE, which defaults to
  2639 `eq'.
  2640 
  2641 Unlike `plist-get', this allows you to distinguish between a missing
  2642 property and a property with the value nil.
  2643 The value is actually the tail of PLIST whose car is PROP.  */)
  2644   (Lisp_Object plist, Lisp_Object prop, Lisp_Object predicate)
  2645 {
  2646   if (NILP (predicate))
  2647     return plist_member (plist, prop);
  2648   Lisp_Object tail = plist;
  2649   FOR_EACH_TAIL (tail)
  2650     {
  2651       if (!NILP (call2 (predicate, XCAR (tail), prop)))
  2652         return tail;
  2653       tail = XCDR (tail);
  2654       if (! CONSP (tail))
  2655         break;
  2656     }
  2657   CHECK_TYPE (NILP (tail), Qplistp, plist);
  2658   return Qnil;
  2659 }
  2660 
  2661 /* Faster version of Fplist_member that works with EQ only.  */
  2662 Lisp_Object
  2663 plist_member (Lisp_Object plist, Lisp_Object prop)
  2664 {
  2665   Lisp_Object tail = plist;
  2666   FOR_EACH_TAIL (tail)
  2667     {
  2668       if (EQ (XCAR (tail), prop))
  2669         return tail;
  2670       tail = XCDR (tail);
  2671       if (! CONSP (tail))
  2672         break;
  2673     }
  2674   CHECK_TYPE (NILP (tail), Qplistp, plist);
  2675   return Qnil;
  2676 }
  2677 
  2678 DEFUN ("eql", Feql, Seql, 2, 2, 0,
  2679        doc: /* Return t if the two args are `eq' or are indistinguishable numbers.
  2680 Integers with the same value are `eql'.
  2681 Floating-point values with the same sign, exponent and fraction are `eql'.
  2682 This differs from numeric comparison: (eql 0.0 -0.0) returns nil and
  2683 \(eql 0.0e+NaN 0.0e+NaN) returns t, whereas `=' does the opposite.  */)
  2684   (Lisp_Object obj1, Lisp_Object obj2)
  2685 {
  2686   if (FLOATP (obj1))
  2687     return FLOATP (obj2) && same_float (obj1, obj2) ? Qt : Qnil;
  2688   else if (BIGNUMP (obj1))
  2689     return ((BIGNUMP (obj2)
  2690              && mpz_cmp (*xbignum_val (obj1), *xbignum_val (obj2)) == 0)
  2691             ? Qt : Qnil);
  2692   else
  2693     return EQ (obj1, obj2) ? Qt : Qnil;
  2694 }
  2695 
  2696 DEFUN ("equal", Fequal, Sequal, 2, 2, 0,
  2697        doc: /* Return t if two Lisp objects have similar structure and contents.
  2698 They must have the same data type.
  2699 Conses are compared by comparing the cars and the cdrs.
  2700 Vectors and strings are compared element by element.
  2701 Numbers are compared via `eql', so integers do not equal floats.
  2702 \(Use `=' if you want integers and floats to be able to be equal.)
  2703 Symbols must match exactly.  */)
  2704   (Lisp_Object o1, Lisp_Object o2)
  2705 {
  2706   return internal_equal (o1, o2, EQUAL_PLAIN, 0, Qnil) ? Qt : Qnil;
  2707 }
  2708 
  2709 DEFUN ("equal-including-properties", Fequal_including_properties, Sequal_including_properties, 2, 2, 0,
  2710        doc: /* Return t if two Lisp objects have similar structure and contents.
  2711 This is like `equal' except that it compares the text properties
  2712 of strings.  (`equal' ignores text properties.)  */)
  2713   (Lisp_Object o1, Lisp_Object o2)
  2714 {
  2715   return (internal_equal (o1, o2, EQUAL_INCLUDING_PROPERTIES, 0, Qnil)
  2716           ? Qt : Qnil);
  2717 }
  2718 
  2719 /* Return true if O1 and O2 are equal.  Do not quit or check for cycles.
  2720    Use this only on arguments that are cycle-free and not too large and
  2721    are not window configurations.  */
  2722 
  2723 bool
  2724 equal_no_quit (Lisp_Object o1, Lisp_Object o2)
  2725 {
  2726   return internal_equal (o1, o2, EQUAL_NO_QUIT, 0, Qnil);
  2727 }
  2728 
  2729 /* Return true if O1 and O2 are equal.  EQUAL_KIND specifies what kind
  2730    of equality test to use: if it is EQUAL_NO_QUIT, do not check for
  2731    cycles or large arguments or quits; if EQUAL_PLAIN, do ordinary
  2732    Lisp equality; and if EQUAL_INCLUDING_PROPERTIES, do
  2733    equal-including-properties.
  2734 
  2735    If DEPTH is the current depth of recursion; signal an error if it
  2736    gets too deep.  HT is a hash table used to detect cycles; if nil,
  2737    it has not been allocated yet.  But ignore the last two arguments
  2738    if EQUAL_KIND == EQUAL_NO_QUIT.  */
  2739 
  2740 static bool
  2741 internal_equal (Lisp_Object o1, Lisp_Object o2, enum equal_kind equal_kind,
  2742                 int depth, Lisp_Object ht)
  2743 {
  2744  tail_recurse:
  2745   if (depth > 10)
  2746     {
  2747       eassert (equal_kind != EQUAL_NO_QUIT);
  2748       if (depth > 200)
  2749         error ("Stack overflow in equal");
  2750       if (NILP (ht))
  2751         ht = CALLN (Fmake_hash_table, QCtest, Qeq);
  2752       switch (XTYPE (o1))
  2753         {
  2754         case Lisp_Cons: case Lisp_Vectorlike:
  2755           {
  2756             struct Lisp_Hash_Table *h = XHASH_TABLE (ht);
  2757             Lisp_Object hash;
  2758             ptrdiff_t i = hash_lookup (h, o1, &hash);
  2759             if (i >= 0)
  2760               { /* `o1' was seen already.  */
  2761                 Lisp_Object o2s = HASH_VALUE (h, i);
  2762                 if (!NILP (Fmemq (o2, o2s)))
  2763                   return true;
  2764                 else
  2765                   set_hash_value_slot (h, i, Fcons (o2, o2s));
  2766               }
  2767             else
  2768               hash_put (h, o1, Fcons (o2, Qnil), hash);
  2769           }
  2770         default: ;
  2771         }
  2772     }
  2773 
  2774   /* A symbol with position compares the contained symbol, and is
  2775      `equal' to the corresponding ordinary symbol.  */
  2776   if (SYMBOL_WITH_POS_P (o1))
  2777     o1 = SYMBOL_WITH_POS_SYM (o1);
  2778   if (SYMBOL_WITH_POS_P (o2))
  2779     o2 = SYMBOL_WITH_POS_SYM (o2);
  2780 
  2781   if (BASE_EQ (o1, o2))
  2782     return true;
  2783   if (XTYPE (o1) != XTYPE (o2))
  2784     return false;
  2785 
  2786   switch (XTYPE (o1))
  2787     {
  2788     case Lisp_Float:
  2789       return same_float (o1, o2);
  2790 
  2791     case Lisp_Cons:
  2792       if (equal_kind == EQUAL_NO_QUIT)
  2793         for (; CONSP (o1); o1 = XCDR (o1))
  2794           {
  2795             if (! CONSP (o2))
  2796               return false;
  2797             if (! equal_no_quit (XCAR (o1), XCAR (o2)))
  2798               return false;
  2799             o2 = XCDR (o2);
  2800             if (EQ (XCDR (o1), o2))
  2801               return true;
  2802           }
  2803       else
  2804         FOR_EACH_TAIL (o1)
  2805           {
  2806             if (! CONSP (o2))
  2807               return false;
  2808             if (! internal_equal (XCAR (o1), XCAR (o2),
  2809                                   equal_kind, depth + 1, ht))
  2810               return false;
  2811             o2 = XCDR (o2);
  2812             if (EQ (XCDR (o1), o2))
  2813               return true;
  2814           }
  2815       depth++;
  2816       goto tail_recurse;
  2817 
  2818     case Lisp_Vectorlike:
  2819       {
  2820         ptrdiff_t size = ASIZE (o1);
  2821         /* Pseudovectors have the type encoded in the size field, so this test
  2822            actually checks that the objects have the same type as well as the
  2823            same size.  */
  2824         if (ASIZE (o2) != size)
  2825           return false;
  2826 
  2827         /* Compare bignums, overlays, markers, and boolvectors
  2828            specially, by comparing their values.  */
  2829         if (BIGNUMP (o1))
  2830           return mpz_cmp (*xbignum_val (o1), *xbignum_val (o2)) == 0;
  2831         if (OVERLAYP (o1))
  2832           {
  2833             if (OVERLAY_BUFFER (o1) != OVERLAY_BUFFER (o2)
  2834                 || OVERLAY_START (o1) != OVERLAY_START (o2)
  2835                 || OVERLAY_END (o1) != OVERLAY_END (o2))
  2836               return false;
  2837             o1 = XOVERLAY (o1)->plist;
  2838             o2 = XOVERLAY (o2)->plist;
  2839             depth++;
  2840             goto tail_recurse;
  2841           }
  2842         if (MARKERP (o1))
  2843           {
  2844             return (XMARKER (o1)->buffer == XMARKER (o2)->buffer
  2845                     && (XMARKER (o1)->buffer == 0
  2846                         || XMARKER (o1)->bytepos == XMARKER (o2)->bytepos));
  2847           }
  2848         if (BOOL_VECTOR_P (o1))
  2849           {
  2850             EMACS_INT size = bool_vector_size (o1);
  2851             return (size == bool_vector_size (o2)
  2852                     && !memcmp (bool_vector_data (o1), bool_vector_data (o2),
  2853                                 bool_vector_bytes (size)));
  2854           }
  2855 
  2856 #ifdef HAVE_TREE_SITTER
  2857         if (TS_NODEP (o1))
  2858           return treesit_node_eq (o1, o2);
  2859 #endif
  2860 
  2861         /* Aside from them, only true vectors, char-tables, compiled
  2862            functions, and fonts (font-spec, font-entity, font-object)
  2863            are sensible to compare, so eliminate the others now.  */
  2864         if (size & PSEUDOVECTOR_FLAG)
  2865           {
  2866             if (((size & PVEC_TYPE_MASK) >> PSEUDOVECTOR_AREA_BITS)
  2867                 < PVEC_COMPILED)
  2868               return false;
  2869             size &= PSEUDOVECTOR_SIZE_MASK;
  2870           }
  2871         for (ptrdiff_t i = 0; i < size; i++)
  2872           {
  2873             Lisp_Object v1, v2;
  2874             v1 = AREF (o1, i);
  2875             v2 = AREF (o2, i);
  2876             if (!internal_equal (v1, v2, equal_kind, depth + 1, ht))
  2877               return false;
  2878           }
  2879         return true;
  2880       }
  2881       break;
  2882 
  2883     case Lisp_String:
  2884       return (SCHARS (o1) == SCHARS (o2)
  2885               && SBYTES (o1) == SBYTES (o2)
  2886               && !memcmp (SDATA (o1), SDATA (o2), SBYTES (o1))
  2887               && (equal_kind != EQUAL_INCLUDING_PROPERTIES
  2888                   || compare_string_intervals (o1, o2)));
  2889 
  2890     default:
  2891       break;
  2892     }
  2893 
  2894   return false;
  2895 }
  2896 
  2897 
  2898 DEFUN ("fillarray", Ffillarray, Sfillarray, 2, 2, 0,
  2899        doc: /* Store each element of ARRAY with ITEM.
  2900 ARRAY is a vector, string, char-table, or bool-vector.  */)
  2901   (Lisp_Object array, Lisp_Object item)
  2902 {
  2903   register ptrdiff_t size, idx;
  2904 
  2905   if (VECTORP (array))
  2906     for (idx = 0, size = ASIZE (array); idx < size; idx++)
  2907       ASET (array, idx, item);
  2908   else if (CHAR_TABLE_P (array))
  2909     {
  2910       int i;
  2911 
  2912       for (i = 0; i < (1 << CHARTAB_SIZE_BITS_0); i++)
  2913         set_char_table_contents (array, i, item);
  2914       set_char_table_defalt (array, item);
  2915     }
  2916   else if (STRINGP (array))
  2917     {
  2918       unsigned char *p = SDATA (array);
  2919       CHECK_CHARACTER (item);
  2920       int charval = XFIXNAT (item);
  2921       size = SCHARS (array);
  2922       if (size != 0)
  2923         {
  2924           CHECK_IMPURE (array, XSTRING (array));
  2925           unsigned char str[MAX_MULTIBYTE_LENGTH];
  2926           int len;
  2927           if (STRING_MULTIBYTE (array))
  2928             len = CHAR_STRING (charval, str);
  2929           else
  2930             {
  2931               str[0] = charval;
  2932               len = 1;
  2933             }
  2934 
  2935           ptrdiff_t size_byte = SBYTES (array);
  2936           if (len == 1 && size == size_byte)
  2937             memset (p, str[0], size);
  2938           else
  2939             {
  2940               ptrdiff_t product;
  2941               if (ckd_mul (&product, size, len) || product != size_byte)
  2942                 error ("Attempt to change byte length of a string");
  2943               for (idx = 0; idx < size_byte; idx++)
  2944                 *p++ = str[idx % len];
  2945             }
  2946         }
  2947     }
  2948   else if (BOOL_VECTOR_P (array))
  2949     return bool_vector_fill (array, item);
  2950   else
  2951     wrong_type_argument (Qarrayp, array);
  2952   return array;
  2953 }
  2954 
  2955 DEFUN ("clear-string", Fclear_string, Sclear_string,
  2956        1, 1, 0,
  2957        doc: /* Clear the contents of STRING.
  2958 This makes STRING unibyte and may change its length.  */)
  2959   (Lisp_Object string)
  2960 {
  2961   CHECK_STRING (string);
  2962   ptrdiff_t len = SBYTES (string);
  2963   if (len != 0 || STRING_MULTIBYTE (string))
  2964     {
  2965       CHECK_IMPURE (string, XSTRING (string));
  2966       memset (SDATA (string), 0, len);
  2967       STRING_SET_CHARS (string, len);
  2968       STRING_SET_UNIBYTE (string);
  2969     }
  2970   return Qnil;
  2971 }
  2972 
  2973 Lisp_Object
  2974 nconc2 (Lisp_Object s1, Lisp_Object s2)
  2975 {
  2976   return CALLN (Fnconc, s1, s2);
  2977 }
  2978 
  2979 DEFUN ("nconc", Fnconc, Snconc, 0, MANY, 0,
  2980        doc: /* Concatenate any number of lists by altering them.
  2981 Only the last argument is not altered, and need not be a list.
  2982 usage: (nconc &rest LISTS)  */)
  2983   (ptrdiff_t nargs, Lisp_Object *args)
  2984 {
  2985   Lisp_Object val = Qnil;
  2986 
  2987   for (ptrdiff_t argnum = 0; argnum < nargs; argnum++)
  2988     {
  2989       Lisp_Object tem = args[argnum];
  2990       if (NILP (tem)) continue;
  2991 
  2992       if (NILP (val))
  2993         val = tem;
  2994 
  2995       if (argnum + 1 == nargs) break;
  2996 
  2997       CHECK_CONS (tem);
  2998 
  2999       Lisp_Object tail UNINIT;
  3000       FOR_EACH_TAIL (tem)
  3001         tail = tem;
  3002 
  3003       tem = args[argnum + 1];
  3004       Fsetcdr (tail, tem);
  3005       if (NILP (tem))
  3006         args[argnum + 1] = tail;
  3007     }
  3008 
  3009   return val;
  3010 }
  3011 
  3012 /* This is the guts of all mapping functions.
  3013    Apply FN to each element of SEQ, one by one, storing the results
  3014    into elements of VALS, a C vector of Lisp_Objects.  LENI is the
  3015    length of VALS, which should also be the length of SEQ.  Return the
  3016    number of results; although this is normally LENI, it can be less
  3017    if SEQ is made shorter as a side effect of FN.  */
  3018 
  3019 static EMACS_INT
  3020 mapcar1 (EMACS_INT leni, Lisp_Object *vals, Lisp_Object fn, Lisp_Object seq)
  3021 {
  3022   if (NILP (seq))
  3023     return 0;
  3024   else if (CONSP (seq))
  3025     {
  3026       Lisp_Object tail = seq;
  3027       for (ptrdiff_t i = 0; i < leni; i++)
  3028         {
  3029           if (! CONSP (tail))
  3030             return i;
  3031           Lisp_Object dummy = call1 (fn, XCAR (tail));
  3032           if (vals)
  3033             vals[i] = dummy;
  3034           tail = XCDR (tail);
  3035         }
  3036     }
  3037   else if (VECTORP (seq) || COMPILEDP (seq))
  3038     {
  3039       for (ptrdiff_t i = 0; i < leni; i++)
  3040         {
  3041           Lisp_Object dummy = call1 (fn, AREF (seq, i));
  3042           if (vals)
  3043             vals[i] = dummy;
  3044         }
  3045     }
  3046   else if (STRINGP (seq))
  3047     {
  3048       ptrdiff_t i_byte = 0;
  3049 
  3050       for (ptrdiff_t i = 0; i < leni;)
  3051         {
  3052           ptrdiff_t i_before = i;
  3053           int c = fetch_string_char_advance (seq, &i, &i_byte);
  3054           Lisp_Object dummy = call1 (fn, make_fixnum (c));
  3055           if (vals)
  3056             vals[i_before] = dummy;
  3057         }
  3058     }
  3059   else
  3060     {
  3061       eassert (BOOL_VECTOR_P (seq));
  3062       for (EMACS_INT i = 0; i < leni; i++)
  3063         {
  3064           Lisp_Object dummy = call1 (fn, bool_vector_ref (seq, i));
  3065           if (vals)
  3066             vals[i] = dummy;
  3067         }
  3068     }
  3069 
  3070   return leni;
  3071 }
  3072 
  3073 DEFUN ("mapconcat", Fmapconcat, Smapconcat, 2, 3, 0,
  3074        doc: /* Apply FUNCTION to each element of SEQUENCE, and concat the results as strings.
  3075 In between each pair of results, stick in SEPARATOR.  Thus, " " as
  3076   SEPARATOR results in spaces between the values returned by FUNCTION.
  3077 
  3078 SEQUENCE may be a list, a vector, a bool-vector, or a string.
  3079 
  3080 Optional argument SEPARATOR must be a string, a vector, or a list of
  3081 characters; nil stands for the empty string.
  3082 
  3083 FUNCTION must be a function of one argument, and must return a value
  3084   that is a sequence of characters: either a string, or a vector or
  3085   list of numbers that are valid character codepoints.  */)
  3086   (Lisp_Object function, Lisp_Object sequence, Lisp_Object separator)
  3087 {
  3088   USE_SAFE_ALLOCA;
  3089   EMACS_INT leni = XFIXNAT (Flength (sequence));
  3090   if (CHAR_TABLE_P (sequence))
  3091     wrong_type_argument (Qlistp, sequence);
  3092   EMACS_INT args_alloc = 2 * leni - 1;
  3093   if (args_alloc < 0)
  3094     return empty_unibyte_string;
  3095   Lisp_Object *args;
  3096   SAFE_ALLOCA_LISP (args, args_alloc);
  3097   if (EQ (function, Qidentity))
  3098     {
  3099       /* Fast path when no function call is necessary.  */
  3100       if (CONSP (sequence))
  3101         {
  3102           Lisp_Object src = sequence;
  3103           Lisp_Object *dst = args;
  3104           do
  3105             {
  3106               *dst++ = XCAR (src);
  3107               src = XCDR (src);
  3108             }
  3109           while (!NILP (src));
  3110           goto concat;
  3111         }
  3112       else if (VECTORP (sequence))
  3113         {
  3114           memcpy (args, XVECTOR (sequence)->contents, leni * sizeof *args);
  3115           goto concat;
  3116         }
  3117     }
  3118   ptrdiff_t nmapped = mapcar1 (leni, args, function, sequence);
  3119   eassert (nmapped == leni);
  3120 
  3121  concat: ;
  3122   ptrdiff_t nargs = args_alloc;
  3123   if (NILP (separator) || (STRINGP (separator) && SCHARS (separator) == 0))
  3124     nargs = leni;
  3125   else
  3126     {
  3127       for (ptrdiff_t i = leni - 1; i > 0; i--)
  3128         args[i + i] = args[i];
  3129 
  3130       for (ptrdiff_t i = 1; i < nargs; i += 2)
  3131         args[i] = separator;
  3132     }
  3133 
  3134   Lisp_Object ret = Fconcat (nargs, args);
  3135   SAFE_FREE ();
  3136   return ret;
  3137 }
  3138 
  3139 DEFUN ("mapcar", Fmapcar, Smapcar, 2, 2, 0,
  3140        doc: /* Apply FUNCTION to each element of SEQUENCE, and make a list of the results.
  3141 The result is a list just as long as SEQUENCE.
  3142 SEQUENCE may be a list, a vector, a bool-vector, or a string.  */)
  3143   (Lisp_Object function, Lisp_Object sequence)
  3144 {
  3145   USE_SAFE_ALLOCA;
  3146   EMACS_INT leni = XFIXNAT (Flength (sequence));
  3147   if (CHAR_TABLE_P (sequence))
  3148     wrong_type_argument (Qlistp, sequence);
  3149   Lisp_Object *args;
  3150   SAFE_ALLOCA_LISP (args, leni);
  3151   ptrdiff_t nmapped = mapcar1 (leni, args, function, sequence);
  3152   Lisp_Object ret = Flist (nmapped, args);
  3153   SAFE_FREE ();
  3154   return ret;
  3155 }
  3156 
  3157 DEFUN ("mapc", Fmapc, Smapc, 2, 2, 0,
  3158        doc: /* Apply FUNCTION to each element of SEQUENCE for side effects only.
  3159 Unlike `mapcar', don't accumulate the results.  Return SEQUENCE.
  3160 SEQUENCE may be a list, a vector, a bool-vector, or a string.  */)
  3161   (Lisp_Object function, Lisp_Object sequence)
  3162 {
  3163   register EMACS_INT leni;
  3164 
  3165   leni = XFIXNAT (Flength (sequence));
  3166   if (CHAR_TABLE_P (sequence))
  3167     wrong_type_argument (Qlistp, sequence);
  3168   mapcar1 (leni, 0, function, sequence);
  3169 
  3170   return sequence;
  3171 }
  3172 
  3173 DEFUN ("mapcan", Fmapcan, Smapcan, 2, 2, 0,
  3174        doc: /* Apply FUNCTION to each element of SEQUENCE, and concatenate
  3175 the results by altering them (using `nconc').
  3176 SEQUENCE may be a list, a vector, a bool-vector, or a string. */)
  3177      (Lisp_Object function, Lisp_Object sequence)
  3178 {
  3179   USE_SAFE_ALLOCA;
  3180   EMACS_INT leni = XFIXNAT (Flength (sequence));
  3181   if (CHAR_TABLE_P (sequence))
  3182     wrong_type_argument (Qlistp, sequence);
  3183   Lisp_Object *args;
  3184   SAFE_ALLOCA_LISP (args, leni);
  3185   ptrdiff_t nmapped = mapcar1 (leni, args, function, sequence);
  3186   Lisp_Object ret = Fnconc (nmapped, args);
  3187   SAFE_FREE ();
  3188   return ret;
  3189 }
  3190 
  3191 /* This is how C code calls `yes-or-no-p' and allows the user
  3192    to redefine it.  */
  3193 
  3194 Lisp_Object
  3195 do_yes_or_no_p (Lisp_Object prompt)
  3196 {
  3197   return call1 (intern ("yes-or-no-p"), prompt);
  3198 }
  3199 
  3200 DEFUN ("yes-or-no-p", Fyes_or_no_p, Syes_or_no_p, 1, 1, 0,
  3201        doc: /* Ask user a yes-or-no question.
  3202 Return t if answer is yes, and nil if the answer is no.
  3203 
  3204 PROMPT is the string to display to ask the question; `yes-or-no-p'
  3205 appends `yes-or-no-prompt' (default \"(yes or no) \") to it.  If
  3206 PROMPT is a non-empty string, and it ends with a non-space character,
  3207 a space character will be appended to it.
  3208 
  3209 The user must confirm the answer with RET, and can edit it until it
  3210 has been confirmed.
  3211 
  3212 If the `use-short-answers' variable is non-nil, instead of asking for
  3213 \"yes\" or \"no\", this function will ask for \"y\" or \"n\" (and
  3214 ignore the value of `yes-or-no-prompt').
  3215 
  3216 If dialog boxes are supported, this function will use a dialog box
  3217 if `use-dialog-box' is non-nil and the last input event was produced
  3218 by a mouse, or by some window-system gesture, or via a menu.  */)
  3219   (Lisp_Object prompt)
  3220 {
  3221   Lisp_Object ans, val;
  3222 
  3223   CHECK_STRING (prompt);
  3224 
  3225   if (!NILP (last_input_event)
  3226       && (CONSP (last_nonmenu_event)
  3227           || (NILP (last_nonmenu_event) && CONSP (last_input_event))
  3228           || (val = find_symbol_value (Qfrom__tty_menu_p),
  3229               (!NILP (val) && !EQ (val, Qunbound))))
  3230       && use_dialog_box)
  3231     {
  3232       Lisp_Object pane, menu, obj;
  3233       redisplay_preserve_echo_area (4);
  3234       pane = list2 (Fcons (build_string ("Yes"), Qt),
  3235                     Fcons (build_string ("No"), Qnil));
  3236       menu = Fcons (prompt, pane);
  3237       obj = Fx_popup_dialog (Qt, menu, Qnil);
  3238       return obj;
  3239     }
  3240 
  3241   if (use_short_answers)
  3242     return call1 (intern ("y-or-n-p"), prompt);
  3243 
  3244   {
  3245     char *s = SSDATA (prompt);
  3246     ptrdiff_t len = strlen (s);
  3247     if ((len > 0) && !isspace (s[len - 1]))
  3248       prompt = CALLN (Fconcat, prompt, build_string (" "));
  3249   }
  3250   prompt = CALLN (Fconcat, prompt, Vyes_or_no_prompt);
  3251 
  3252   specpdl_ref count = SPECPDL_INDEX ();
  3253   specbind (Qenable_recursive_minibuffers, Qt);
  3254   /* Preserve the actual command that eventually called `yes-or-no-p'
  3255      (otherwise `repeat' will be repeating `exit-minibuffer').  */
  3256   specbind (Qreal_this_command, Vreal_this_command);
  3257 
  3258   while (1)
  3259     {
  3260       ans = Fdowncase (Fread_from_minibuffer (prompt, Qnil, Qnil, Qnil,
  3261                                               Qyes_or_no_p_history, Qnil,
  3262                                               Qnil));
  3263       if (SCHARS (ans) == 3 && !strcmp (SSDATA (ans), "yes"))
  3264         return unbind_to (count, Qt);
  3265       if (SCHARS (ans) == 2 && !strcmp (SSDATA (ans), "no"))
  3266         return unbind_to (count, Qnil);
  3267 
  3268       Fding (Qnil);
  3269       Fdiscard_input ();
  3270       message1 ("Please answer yes or no.");
  3271       Fsleep_for (make_fixnum (2), Qnil);
  3272     }
  3273 }
  3274 
  3275 DEFUN ("load-average", Fload_average, Sload_average, 0, 1, 0,
  3276        doc: /* Return list of 1 minute, 5 minute and 15 minute load averages.
  3277 
  3278 Each of the three load averages is multiplied by 100, then converted
  3279 to integer.
  3280 
  3281 When USE-FLOATS is non-nil, floats will be used instead of integers.
  3282 These floats are not multiplied by 100.
  3283 
  3284 If the 5-minute or 15-minute load averages are not available, return a
  3285 shortened list, containing only those averages which are available.
  3286 
  3287 An error is thrown if the load average can't be obtained.  In some
  3288 cases making it work would require Emacs being installed setuid or
  3289 setgid so that it can read kernel information, and that usually isn't
  3290 advisable.  */)
  3291   (Lisp_Object use_floats)
  3292 {
  3293   double load_ave[3];
  3294   int loads = getloadavg (load_ave, 3);
  3295   Lisp_Object ret = Qnil;
  3296 
  3297   if (loads < 0)
  3298     error ("load-average not implemented for this operating system");
  3299 
  3300   while (loads-- > 0)
  3301     {
  3302       Lisp_Object load = (NILP (use_floats)
  3303                           ? double_to_integer (100.0 * load_ave[loads])
  3304                           : make_float (load_ave[loads]));
  3305       ret = Fcons (load, ret);
  3306     }
  3307 
  3308   return ret;
  3309 }
  3310 
  3311 DEFUN ("featurep", Ffeaturep, Sfeaturep, 1, 2, 0,
  3312        doc: /* Return t if FEATURE is present in this Emacs.
  3313 
  3314 Use this to conditionalize execution of lisp code based on the
  3315 presence or absence of Emacs or environment extensions.
  3316 Use `provide' to declare that a feature is available.  This function
  3317 looks at the value of the variable `features'.  The optional argument
  3318 SUBFEATURE can be used to check a specific subfeature of FEATURE.  */)
  3319   (Lisp_Object feature, Lisp_Object subfeature)
  3320 {
  3321   register Lisp_Object tem;
  3322   CHECK_SYMBOL (feature);
  3323   tem = Fmemq (feature, Vfeatures);
  3324   if (!NILP (tem) && !NILP (subfeature))
  3325     tem = Fmember (subfeature, Fget (feature, Qsubfeatures));
  3326   return (NILP (tem)) ? Qnil : Qt;
  3327 }
  3328 
  3329 DEFUN ("provide", Fprovide, Sprovide, 1, 2, 0,
  3330        doc: /* Announce that FEATURE is a feature of the current Emacs.
  3331 The optional argument SUBFEATURES should be a list of symbols listing
  3332 particular subfeatures supported in this version of FEATURE.  */)
  3333   (Lisp_Object feature, Lisp_Object subfeatures)
  3334 {
  3335   register Lisp_Object tem;
  3336   CHECK_SYMBOL (feature);
  3337   CHECK_LIST (subfeatures);
  3338   if (!NILP (Vautoload_queue))
  3339     Vautoload_queue = Fcons (Fcons (make_fixnum (0), Vfeatures),
  3340                              Vautoload_queue);
  3341   tem = Fmemq (feature, Vfeatures);
  3342   if (NILP (tem))
  3343     Vfeatures = Fcons (feature, Vfeatures);
  3344   if (!NILP (subfeatures))
  3345     Fput (feature, Qsubfeatures, subfeatures);
  3346   LOADHIST_ATTACH (Fcons (Qprovide, feature));
  3347 
  3348   /* Run any load-hooks for this file.  */
  3349   tem = Fassq (feature, Vafter_load_alist);
  3350   if (CONSP (tem))
  3351     Fmapc (Qfuncall, XCDR (tem));
  3352 
  3353   return feature;
  3354 }
  3355 
  3356 /* `require' and its subroutines.  */
  3357 
  3358 /* List of features currently being require'd, innermost first.  */
  3359 
  3360 static Lisp_Object require_nesting_list;
  3361 
  3362 static void
  3363 require_unwind (Lisp_Object old_value)
  3364 {
  3365   require_nesting_list = old_value;
  3366 }
  3367 
  3368 DEFUN ("require", Frequire, Srequire, 1, 3, 0,
  3369        doc: /* If FEATURE is not already loaded, load it from FILENAME.
  3370 If FEATURE is not a member of the list `features', then the feature was
  3371 not yet loaded; so load it from file FILENAME.
  3372 
  3373 If FILENAME is omitted, the printname of FEATURE is used as the file
  3374 name, and `load' is called to try to load the file by that name, after
  3375 appending the suffix `.elc', `.el', or the system-dependent suffix for
  3376 dynamic module files, in that order; but the function will not try to
  3377 load the file without any suffix.  See `get-load-suffixes' for the
  3378 complete list of suffixes.
  3379 
  3380 To find the file, this function searches the directories in `load-path'.
  3381 
  3382 If the optional third argument NOERROR is non-nil, then, if
  3383 the file is not found, the function returns nil instead of signaling
  3384 an error.  Normally the return value is FEATURE.
  3385 
  3386 The normal messages issued by `load' at start and end of loading
  3387 FILENAME are suppressed.  */)
  3388   (Lisp_Object feature, Lisp_Object filename, Lisp_Object noerror)
  3389 {
  3390   Lisp_Object tem;
  3391   bool from_file = load_in_progress;
  3392 
  3393   CHECK_SYMBOL (feature);
  3394 
  3395   /* Record the presence of `require' in this file
  3396      even if the feature specified is already loaded.
  3397      But not more than once in any file,
  3398      and not when we aren't loading or reading from a file.  */
  3399   if (!from_file)
  3400     {
  3401       Lisp_Object tail = Vcurrent_load_list;
  3402       FOR_EACH_TAIL_SAFE (tail)
  3403         if (NILP (XCDR (tail)) && STRINGP (XCAR (tail)))
  3404           from_file = true;
  3405     }
  3406 
  3407   if (from_file)
  3408     {
  3409       tem = Fcons (Qrequire, feature);
  3410       if (NILP (Fmember (tem, Vcurrent_load_list)))
  3411         LOADHIST_ATTACH (tem);
  3412     }
  3413   tem = Fmemq (feature, Vfeatures);
  3414 
  3415   if (NILP (tem))
  3416     {
  3417       specpdl_ref count = SPECPDL_INDEX ();
  3418       int nesting = 0;
  3419 
  3420       /* This is to make sure that loadup.el gives a clear picture
  3421          of what files are preloaded and when.  */
  3422       if (will_dump_p () && !will_bootstrap_p ())
  3423         {
  3424           /* Avoid landing here recursively while outputting the
  3425              backtrace from the error.  */
  3426           gflags.will_dump_ = false;
  3427           error ("(require %s) while preparing to dump",
  3428                  SDATA (SYMBOL_NAME (feature)));
  3429         }
  3430 
  3431       /* A certain amount of recursive `require' is legitimate,
  3432          but if we require the same feature recursively 3 times,
  3433          signal an error.  */
  3434       tem = require_nesting_list;
  3435       while (! NILP (tem))
  3436         {
  3437           if (! NILP (Fequal (feature, XCAR (tem))))
  3438             nesting++;
  3439           tem = XCDR (tem);
  3440         }
  3441       if (nesting > 3)
  3442         error ("Recursive `require' for feature `%s'",
  3443                SDATA (SYMBOL_NAME (feature)));
  3444 
  3445       /* Update the list for any nested `require's that occur.  */
  3446       record_unwind_protect (require_unwind, require_nesting_list);
  3447       require_nesting_list = Fcons (feature, require_nesting_list);
  3448 
  3449       /* Load the file.  */
  3450       tem = load_with_autoload_queue
  3451         (NILP (filename) ? Fsymbol_name (feature) : filename,
  3452          noerror, Qt, Qnil, (NILP (filename) ? Qt : Qnil));
  3453 
  3454       /* If load failed entirely, return nil.  */
  3455       if (NILP (tem))
  3456         return unbind_to (count, Qnil);
  3457 
  3458       tem = Fmemq (feature, Vfeatures);
  3459       if (NILP (tem))
  3460         {
  3461           unsigned char *tem2 = SDATA (SYMBOL_NAME (feature));
  3462           Lisp_Object tem3 = Fcar (Fcar (Vload_history));
  3463 
  3464           if (NILP (tem3))
  3465             error ("Required feature `%s' was not provided", tem2);
  3466           else
  3467             /* Cf autoload-do-load.  */
  3468             error ("Loading file %s failed to provide feature `%s'",
  3469                    SDATA (tem3), tem2);
  3470         }
  3471 
  3472       feature = unbind_to (count, feature);
  3473     }
  3474 
  3475   return feature;
  3476 }
  3477 
  3478 /* Primitives for work of the "widget" library.
  3479    In an ideal world, this section would not have been necessary.
  3480    However, lisp function calls being as slow as they are, it turns
  3481    out that some functions in the widget library (wid-edit.el) are the
  3482    bottleneck of Widget operation.  Here is their translation to C,
  3483    for the sole reason of efficiency.  */
  3484 
  3485 DEFUN ("widget-put", Fwidget_put, Swidget_put, 3, 3, 0,
  3486        doc: /* In WIDGET, set PROPERTY to VALUE.
  3487 The value can later be retrieved with `widget-get'.  */)
  3488   (Lisp_Object widget, Lisp_Object property, Lisp_Object value)
  3489 {
  3490   CHECK_CONS (widget);
  3491   XSETCDR (widget, plist_put (XCDR (widget), property, value));
  3492   return value;
  3493 }
  3494 
  3495 DEFUN ("widget-get", Fwidget_get, Swidget_get, 2, 2, 0,
  3496        doc: /* In WIDGET, get the value of PROPERTY.
  3497 The value could either be specified when the widget was created, or
  3498 later with `widget-put'.  */)
  3499   (Lisp_Object widget, Lisp_Object property)
  3500 {
  3501   Lisp_Object tmp;
  3502 
  3503   while (1)
  3504     {
  3505       if (NILP (widget))
  3506         return Qnil;
  3507       CHECK_CONS (widget);
  3508       tmp = plist_member (XCDR (widget), property);
  3509       if (CONSP (tmp))
  3510         {
  3511           tmp = XCDR (tmp);
  3512           return CAR (tmp);
  3513         }
  3514       tmp = XCAR (widget);
  3515       if (NILP (tmp))
  3516         return Qnil;
  3517       widget = Fget (tmp, Qwidget_type);
  3518     }
  3519 }
  3520 
  3521 DEFUN ("widget-apply", Fwidget_apply, Swidget_apply, 2, MANY, 0,
  3522        doc: /* Apply the value of WIDGET's PROPERTY to the widget itself.
  3523 Return the result of applying the value of PROPERTY to WIDGET.
  3524 ARGS are passed as extra arguments to the function.
  3525 usage: (widget-apply WIDGET PROPERTY &rest ARGS)  */)
  3526   (ptrdiff_t nargs, Lisp_Object *args)
  3527 {
  3528   Lisp_Object widget = args[0];
  3529   Lisp_Object property = args[1];
  3530   Lisp_Object propval = Fwidget_get (widget, property);
  3531   Lisp_Object trailing_args = Flist (nargs - 2, args + 2);
  3532   Lisp_Object result = CALLN (Fapply, propval, widget, trailing_args);
  3533   return result;
  3534 }
  3535 
  3536 #ifdef HAVE_LANGINFO_CODESET
  3537 #include <langinfo.h>
  3538 #endif
  3539 
  3540 DEFUN ("locale-info", Flocale_info, Slocale_info, 1, 1, 0,
  3541        doc: /* Access locale data ITEM for the current C locale, if available.
  3542 ITEM should be one of the following:
  3543 
  3544 `codeset', returning the character set as a string (locale item CODESET);
  3545 
  3546 `days', returning a 7-element vector of day names (locale items DAY_n);
  3547 
  3548 `months', returning a 12-element vector of month names (locale items MON_n);
  3549 
  3550 `paper', returning a list of 2 integers (WIDTH HEIGHT) for the default
  3551   paper size, both measured in millimeters (locale items _NL_PAPER_WIDTH,
  3552   _NL_PAPER_HEIGHT).
  3553 
  3554 If the system can't provide such information through a call to
  3555 `nl_langinfo', or if ITEM isn't from the list above, return nil.
  3556 
  3557 See also Info node `(libc)Locales'.
  3558 
  3559 The data read from the system are decoded using `locale-coding-system'.  */)
  3560   (Lisp_Object item)
  3561 {
  3562   char *str = NULL;
  3563 
  3564   /* STR is apparently unused on Android.  */
  3565   ((void) str);
  3566 
  3567 #ifdef HAVE_LANGINFO_CODESET
  3568   if (EQ (item, Qcodeset))
  3569     {
  3570       str = nl_langinfo (CODESET);
  3571       return build_string (str);
  3572     }
  3573 # ifdef DAY_1
  3574   if (EQ (item, Qdays))  /* E.g., for calendar-day-name-array.  */
  3575     {
  3576       Lisp_Object v = make_nil_vector (7);
  3577       const int days[7] = {DAY_1, DAY_2, DAY_3, DAY_4, DAY_5, DAY_6, DAY_7};
  3578       int i;
  3579       synchronize_system_time_locale ();
  3580       for (i = 0; i < 7; i++)
  3581         {
  3582           str = nl_langinfo (days[i]);
  3583           AUTO_STRING (val, str);
  3584           /* Fixme: Is this coding system necessarily right, even if
  3585              it is consistent with CODESET?  If not, what to do?  */
  3586           ASET (v, i, code_convert_string_norecord (val, Vlocale_coding_system,
  3587                                                     0));
  3588         }
  3589       return v;
  3590     }
  3591 # endif
  3592 # ifdef MON_1
  3593   if (EQ (item, Qmonths))  /* E.g., for calendar-month-name-array.  */
  3594     {
  3595       Lisp_Object v = make_nil_vector (12);
  3596       const int months[12] = {MON_1, MON_2, MON_3, MON_4, MON_5, MON_6, MON_7,
  3597                               MON_8, MON_9, MON_10, MON_11, MON_12};
  3598       synchronize_system_time_locale ();
  3599       for (int i = 0; i < 12; i++)
  3600         {
  3601           str = nl_langinfo (months[i]);
  3602           AUTO_STRING (val, str);
  3603           ASET (v, i, code_convert_string_norecord (val, Vlocale_coding_system,
  3604                                                     0));
  3605         }
  3606       return v;
  3607     }
  3608 # endif
  3609 # ifdef HAVE_LANGINFO__NL_PAPER_WIDTH
  3610   if (EQ (item, Qpaper))
  3611     /* We have to cast twice here: first to a correctly-sized integer,
  3612        then to int, because that's what nl_langinfo is documented to
  3613        return for _NO_PAPER_{WIDTH,HEIGHT}.  The first cast doesn't
  3614        suffice because it could overflow an Emacs fixnum.  This can
  3615        happen when running under ASan, which fills allocated but
  3616        uninitialized memory with 0xBE bytes.  */
  3617     return list2i ((int) (intptr_t) nl_langinfo (_NL_PAPER_WIDTH),
  3618                    (int) (intptr_t) nl_langinfo (_NL_PAPER_HEIGHT));
  3619 # endif
  3620 #endif  /* HAVE_LANGINFO_CODESET*/
  3621   return Qnil;
  3622 }
  3623 
  3624 /* base64 encode/decode functions (RFC 2045).
  3625    Based on code from GNU recode. */
  3626 
  3627 #define MIME_LINE_LENGTH 76
  3628 
  3629 /* Tables of characters coding the 64 values.  */
  3630 static char const base64_value_to_char[2][64] =
  3631 {
  3632  /* base64 */
  3633  {
  3634   'A', 'B', 'C', 'D', 'E', 'F', 'G', 'H', 'I', 'J',     /*  0- 9 */
  3635   'K', 'L', 'M', 'N', 'O', 'P', 'Q', 'R', 'S', 'T',     /* 10-19 */
  3636   'U', 'V', 'W', 'X', 'Y', 'Z', 'a', 'b', 'c', 'd',     /* 20-29 */
  3637   'e', 'f', 'g', 'h', 'i', 'j', 'k', 'l', 'm', 'n',     /* 30-39 */
  3638   'o', 'p', 'q', 'r', 's', 't', 'u', 'v', 'w', 'x',     /* 40-49 */
  3639   'y', 'z', '0', '1', '2', '3', '4', '5', '6', '7',     /* 50-59 */
  3640   '8', '9', '+', '/'                                    /* 60-63 */
  3641  },
  3642  /* base64url */
  3643  {
  3644   'A', 'B', 'C', 'D', 'E', 'F', 'G', 'H', 'I', 'J',     /*  0- 9 */
  3645   'K', 'L', 'M', 'N', 'O', 'P', 'Q', 'R', 'S', 'T',     /* 10-19 */
  3646   'U', 'V', 'W', 'X', 'Y', 'Z', 'a', 'b', 'c', 'd',     /* 20-29 */
  3647   'e', 'f', 'g', 'h', 'i', 'j', 'k', 'l', 'm', 'n',     /* 30-39 */
  3648   'o', 'p', 'q', 'r', 's', 't', 'u', 'v', 'w', 'x',     /* 40-49 */
  3649   'y', 'z', '0', '1', '2', '3', '4', '5', '6', '7',     /* 50-59 */
  3650   '8', '9', '-', '_'                                    /* 60-63 */
  3651  }
  3652 };
  3653 
  3654 /* Tables of base64 values for bytes.  -1 means ignorable, 0 invalid,
  3655    positive means 1 + the represented value.  */
  3656 static signed char const base64_char_to_value[2][UCHAR_MAX] =
  3657 {
  3658  /* base64 */
  3659  {
  3660   ['\t']= -1, ['\n']= -1, ['\f']= -1, ['\r']= -1, [' '] = -1,
  3661   ['A'] =  1, ['B'] =  2, ['C'] =  3, ['D'] =  4, ['E'] =  5,
  3662   ['F'] =  6, ['G'] =  7, ['H'] =  8, ['I'] =  9, ['J'] = 10,
  3663   ['K'] = 11, ['L'] = 12, ['M'] = 13, ['N'] = 14, ['O'] = 15,
  3664   ['P'] = 16, ['Q'] = 17, ['R'] = 18, ['S'] = 19, ['T'] = 20,
  3665   ['U'] = 21, ['V'] = 22, ['W'] = 23, ['X'] = 24, ['Y'] = 25, ['Z'] = 26,
  3666   ['a'] = 27, ['b'] = 28, ['c'] = 29, ['d'] = 30, ['e'] = 31,
  3667   ['f'] = 32, ['g'] = 33, ['h'] = 34, ['i'] = 35, ['j'] = 36,
  3668   ['k'] = 37, ['l'] = 38, ['m'] = 39, ['n'] = 40, ['o'] = 41,
  3669   ['p'] = 42, ['q'] = 43, ['r'] = 44, ['s'] = 45, ['t'] = 46,
  3670   ['u'] = 47, ['v'] = 48, ['w'] = 49, ['x'] = 50, ['y'] = 51, ['z'] = 52,
  3671   ['0'] = 53, ['1'] = 54, ['2'] = 55, ['3'] = 56, ['4'] = 57,
  3672   ['5'] = 58, ['6'] = 59, ['7'] = 60, ['8'] = 61, ['9'] = 62,
  3673   ['+'] = 63, ['/'] = 64
  3674  },
  3675  /* base64url */
  3676  {
  3677   ['\t']= -1, ['\n']= -1, ['\f']= -1, ['\r']= -1, [' '] = -1,
  3678   ['A'] =  1, ['B'] =  2, ['C'] =  3, ['D'] =  4, ['E'] =  5,
  3679   ['F'] =  6, ['G'] =  7, ['H'] =  8, ['I'] =  9, ['J'] = 10,
  3680   ['K'] = 11, ['L'] = 12, ['M'] = 13, ['N'] = 14, ['O'] = 15,
  3681   ['P'] = 16, ['Q'] = 17, ['R'] = 18, ['S'] = 19, ['T'] = 20,
  3682   ['U'] = 21, ['V'] = 22, ['W'] = 23, ['X'] = 24, ['Y'] = 25, ['Z'] = 26,
  3683   ['a'] = 27, ['b'] = 28, ['c'] = 29, ['d'] = 30, ['e'] = 31,
  3684   ['f'] = 32, ['g'] = 33, ['h'] = 34, ['i'] = 35, ['j'] = 36,
  3685   ['k'] = 37, ['l'] = 38, ['m'] = 39, ['n'] = 40, ['o'] = 41,
  3686   ['p'] = 42, ['q'] = 43, ['r'] = 44, ['s'] = 45, ['t'] = 46,
  3687   ['u'] = 47, ['v'] = 48, ['w'] = 49, ['x'] = 50, ['y'] = 51, ['z'] = 52,
  3688   ['0'] = 53, ['1'] = 54, ['2'] = 55, ['3'] = 56, ['4'] = 57,
  3689   ['5'] = 58, ['6'] = 59, ['7'] = 60, ['8'] = 61, ['9'] = 62,
  3690   ['-'] = 63, ['_'] = 64
  3691  }
  3692 };
  3693 
  3694 /* The following diagram shows the logical steps by which three octets
  3695    get transformed into four base64 characters.
  3696 
  3697                  .--------.  .--------.  .--------.
  3698                  |aaaaaabb|  |bbbbcccc|  |ccdddddd|
  3699                  `--------'  `--------'  `--------'
  3700                     6   2      4   4       2   6
  3701                .--------+--------+--------+--------.
  3702                |00aaaaaa|00bbbbbb|00cccccc|00dddddd|
  3703                `--------+--------+--------+--------'
  3704 
  3705                .--------+--------+--------+--------.
  3706                |AAAAAAAA|BBBBBBBB|CCCCCCCC|DDDDDDDD|
  3707                `--------+--------+--------+--------'
  3708 
  3709    The octets are divided into 6 bit chunks, which are then encoded into
  3710    base64 characters.  */
  3711 
  3712 
  3713 static ptrdiff_t base64_encode_1 (const char *, char *, ptrdiff_t, bool, bool,
  3714                                   bool, bool);
  3715 static ptrdiff_t base64_decode_1 (const char *, char *, ptrdiff_t, bool,
  3716                                   bool, bool, ptrdiff_t *);
  3717 
  3718 static Lisp_Object base64_encode_region_1 (Lisp_Object, Lisp_Object, bool,
  3719                                            bool, bool);
  3720 
  3721 static Lisp_Object base64_encode_string_1 (Lisp_Object, bool,
  3722                                            bool, bool);
  3723 
  3724 
  3725 DEFUN ("base64-encode-region", Fbase64_encode_region, Sbase64_encode_region,
  3726        2, 3, "r",
  3727        doc: /* Base64-encode the region between BEG and END.
  3728 The data in the region is assumed to represent bytes, not text.  If
  3729 you want to base64-encode text, the text has to be converted into data
  3730 first by using `encode-coding-region' with the appropriate coding
  3731 system first.
  3732 
  3733 Return the length of the encoded data.
  3734 
  3735 Optional third argument NO-LINE-BREAK means do not break long lines
  3736 into shorter lines.  */)
  3737   (Lisp_Object beg, Lisp_Object end, Lisp_Object no_line_break)
  3738 {
  3739   return base64_encode_region_1 (beg, end, NILP (no_line_break), true, false);
  3740 }
  3741 
  3742 
  3743 DEFUN ("base64url-encode-region", Fbase64url_encode_region, Sbase64url_encode_region,
  3744        2, 3, "r",
  3745        doc: /* Base64url-encode the region between BEG and END.
  3746 Return the length of the encoded text.
  3747 Optional second argument NO-PAD means do not add padding char =.
  3748 
  3749 This produces the URL variant of base 64 encoding defined in RFC 4648.  */)
  3750   (Lisp_Object beg, Lisp_Object end, Lisp_Object no_pad)
  3751 {
  3752   return base64_encode_region_1 (beg, end, false, NILP(no_pad), true);
  3753 }
  3754 
  3755 static Lisp_Object
  3756 base64_encode_region_1 (Lisp_Object beg, Lisp_Object end, bool line_break,
  3757                         bool pad, bool base64url)
  3758 {
  3759   char *encoded;
  3760   ptrdiff_t allength, length;
  3761   ptrdiff_t ibeg, iend, encoded_length;
  3762   ptrdiff_t old_pos = PT;
  3763   USE_SAFE_ALLOCA;
  3764 
  3765   validate_region (&beg, &end);
  3766 
  3767   ibeg = CHAR_TO_BYTE (XFIXNAT (beg));
  3768   iend = CHAR_TO_BYTE (XFIXNAT (end));
  3769   move_gap_both (XFIXNAT (beg), ibeg);
  3770 
  3771   /* We need to allocate enough room for encoding the text.
  3772      We need 33 1/3% more space, plus a newline every 76
  3773      characters, and then we round up. */
  3774   length = iend - ibeg;
  3775   allength = length + length/3 + 1;
  3776   allength += allength / MIME_LINE_LENGTH + 1 + 6;
  3777 
  3778   encoded = SAFE_ALLOCA (allength);
  3779   encoded_length = base64_encode_1 ((char *) BYTE_POS_ADDR (ibeg),
  3780                                     encoded, length, line_break,
  3781                                     pad, base64url,
  3782                                     !NILP (BVAR (current_buffer, enable_multibyte_characters)));
  3783   if (encoded_length > allength)
  3784     emacs_abort ();
  3785 
  3786   if (encoded_length < 0)
  3787     {
  3788       /* The encoding wasn't possible. */
  3789       SAFE_FREE ();
  3790       error ("Multibyte character in data for base64 encoding");
  3791     }
  3792 
  3793   /* Now we have encoded the region, so we insert the new contents
  3794      and delete the old.  (Insert first in order to preserve markers.)  */
  3795   SET_PT_BOTH (XFIXNAT (beg), ibeg);
  3796   insert (encoded, encoded_length);
  3797   SAFE_FREE ();
  3798   del_range_byte (ibeg + encoded_length, iend + encoded_length);
  3799 
  3800   /* If point was outside of the region, restore it exactly; else just
  3801      move to the beginning of the region.  */
  3802   if (old_pos >= XFIXNAT (end))
  3803     old_pos += encoded_length - (XFIXNAT (end) - XFIXNAT (beg));
  3804   else if (old_pos > XFIXNAT (beg))
  3805     old_pos = XFIXNAT (beg);
  3806   SET_PT (old_pos);
  3807 
  3808   /* We return the length of the encoded text. */
  3809   return make_fixnum (encoded_length);
  3810 }
  3811 
  3812 DEFUN ("base64-encode-string", Fbase64_encode_string, Sbase64_encode_string,
  3813        1, 2, 0,
  3814        doc: /* Base64-encode STRING and return the result.
  3815 Optional second argument NO-LINE-BREAK means do not break long lines
  3816 into shorter lines.  */)
  3817   (Lisp_Object string, Lisp_Object no_line_break)
  3818 {
  3819 
  3820   return base64_encode_string_1 (string, NILP (no_line_break), true, false);
  3821 }
  3822 
  3823 DEFUN ("base64url-encode-string", Fbase64url_encode_string,
  3824        Sbase64url_encode_string, 1, 2, 0,
  3825        doc: /* Base64url-encode STRING and return the result.
  3826 Optional second argument NO-PAD means do not add padding char =.
  3827 
  3828 This produces the URL variant of base 64 encoding defined in RFC 4648.  */)
  3829   (Lisp_Object string, Lisp_Object no_pad)
  3830 {
  3831 
  3832   return base64_encode_string_1 (string, false, NILP(no_pad), true);
  3833 }
  3834 
  3835 static Lisp_Object
  3836 base64_encode_string_1 (Lisp_Object string, bool line_break,
  3837                         bool pad, bool base64url)
  3838 {
  3839   ptrdiff_t allength, length, encoded_length;
  3840   char *encoded;
  3841   Lisp_Object encoded_string;
  3842   USE_SAFE_ALLOCA;
  3843 
  3844   CHECK_STRING (string);
  3845 
  3846   /* We need to allocate enough room for encoding the text.
  3847      We need 33 1/3% more space, plus a newline every 76
  3848      characters, and then we round up. */
  3849   length = SBYTES (string);
  3850   allength = length + length/3 + 1;
  3851   allength += allength / MIME_LINE_LENGTH + 1 + 6;
  3852 
  3853   /* We need to allocate enough room for decoding the text. */
  3854   encoded = SAFE_ALLOCA (allength);
  3855 
  3856   encoded_length = base64_encode_1 (SSDATA (string),
  3857                                     encoded, length, line_break,
  3858                                     pad, base64url,
  3859                                     STRING_MULTIBYTE (string));
  3860   if (encoded_length > allength)
  3861     emacs_abort ();
  3862 
  3863   if (encoded_length < 0)
  3864     {
  3865       /* The encoding wasn't possible. */
  3866       error ("Multibyte character in data for base64 encoding");
  3867     }
  3868 
  3869   encoded_string = make_unibyte_string (encoded, encoded_length);
  3870   SAFE_FREE ();
  3871 
  3872   return encoded_string;
  3873 }
  3874 
  3875 static ptrdiff_t
  3876 base64_encode_1 (const char *from, char *to, ptrdiff_t length,
  3877                  bool line_break, bool pad, bool base64url,
  3878                  bool multibyte)
  3879 {
  3880   int counter = 0;
  3881   ptrdiff_t i = 0;
  3882   char *e = to;
  3883   int c;
  3884   unsigned int value;
  3885   int bytes;
  3886   char const *b64_value_to_char = base64_value_to_char[base64url];
  3887 
  3888   while (i < length)
  3889     {
  3890       if (multibyte)
  3891         {
  3892           c = string_char_and_length ((unsigned char *) from + i, &bytes);
  3893           if (CHAR_BYTE8_P (c))
  3894             c = CHAR_TO_BYTE8 (c);
  3895           else if (c >= 128)
  3896             return -1;
  3897           i += bytes;
  3898         }
  3899       else
  3900         c = from[i++];
  3901 
  3902       /* Wrap line every 76 characters.  */
  3903 
  3904       if (line_break)
  3905         {
  3906           if (counter < MIME_LINE_LENGTH / 4)
  3907             counter++;
  3908           else
  3909             {
  3910               *e++ = '\n';
  3911               counter = 1;
  3912             }
  3913         }
  3914 
  3915       /* Process first byte of a triplet.  */
  3916 
  3917       *e++ = b64_value_to_char[0x3f & c >> 2];
  3918       value = (0x03 & c) << 4;
  3919 
  3920       /* Process second byte of a triplet.  */
  3921 
  3922       if (i == length)
  3923         {
  3924           *e++ = b64_value_to_char[value];
  3925           if (pad)
  3926             {
  3927               *e++ = '=';
  3928               *e++ = '=';
  3929             }
  3930           break;
  3931         }
  3932 
  3933       if (multibyte)
  3934         {
  3935           c = string_char_and_length ((unsigned char *) from + i, &bytes);
  3936           if (CHAR_BYTE8_P (c))
  3937             c = CHAR_TO_BYTE8 (c);
  3938           else if (c >= 128)
  3939             return -1;
  3940           i += bytes;
  3941         }
  3942       else
  3943         c = from[i++];
  3944 
  3945       *e++ = b64_value_to_char[value | (0x0f & c >> 4)];
  3946       value = (0x0f & c) << 2;
  3947 
  3948       /* Process third byte of a triplet.  */
  3949 
  3950       if (i == length)
  3951         {
  3952           *e++ = b64_value_to_char[value];
  3953           if (pad)
  3954             *e++ = '=';
  3955           break;
  3956         }
  3957 
  3958       if (multibyte)
  3959         {
  3960           c = string_char_and_length ((unsigned char *) from + i, &bytes);
  3961           if (CHAR_BYTE8_P (c))
  3962             c = CHAR_TO_BYTE8 (c);
  3963           else if (c >= 128)
  3964             return -1;
  3965           i += bytes;
  3966         }
  3967       else
  3968         c = from[i++];
  3969 
  3970       *e++ = b64_value_to_char[value | (0x03 & c >> 6)];
  3971       *e++ = b64_value_to_char[0x3f & c];
  3972     }
  3973 
  3974   return e - to;
  3975 }
  3976 
  3977 
  3978 DEFUN ("base64-decode-region", Fbase64_decode_region, Sbase64_decode_region,
  3979        2, 4, "r",
  3980        doc: /* Base64-decode the region between BEG and END.
  3981 Return the length of the decoded data.
  3982 
  3983 Note that after calling this function, the data in the region will
  3984 represent bytes, not text.  If you want to end up with text, you have
  3985 to call `decode-coding-region' afterwards with an appropriate coding
  3986 system.
  3987 
  3988 If the region can't be decoded, signal an error and don't modify the buffer.
  3989 Optional third argument BASE64URL determines whether to use the URL variant
  3990 of the base 64 encoding, as defined in RFC 4648.
  3991 If optional fourth argument IGNORE-INVALID is non-nil invalid characters
  3992 are ignored instead of signaling an error.  */)
  3993      (Lisp_Object beg, Lisp_Object end, Lisp_Object base64url,
  3994       Lisp_Object ignore_invalid)
  3995 {
  3996   ptrdiff_t ibeg, iend, length, allength;
  3997   char *decoded;
  3998   ptrdiff_t old_pos = PT;
  3999   ptrdiff_t decoded_length;
  4000   ptrdiff_t inserted_chars;
  4001   bool multibyte = !NILP (BVAR (current_buffer, enable_multibyte_characters));
  4002   USE_SAFE_ALLOCA;
  4003 
  4004   validate_region (&beg, &end);
  4005 
  4006   ibeg = CHAR_TO_BYTE (XFIXNAT (beg));
  4007   iend = CHAR_TO_BYTE (XFIXNAT (end));
  4008 
  4009   length = iend - ibeg;
  4010 
  4011   /* We need to allocate enough room for decoding the text.  If we are
  4012      working on a multibyte buffer, each decoded code may occupy at
  4013      most two bytes.  */
  4014   allength = multibyte ? length * 2 : length;
  4015   decoded = SAFE_ALLOCA (allength);
  4016 
  4017   move_gap_both (XFIXNAT (beg), ibeg);
  4018   decoded_length = base64_decode_1 ((char *) BYTE_POS_ADDR (ibeg),
  4019                                     decoded, length, !NILP (base64url),
  4020                                     multibyte, !NILP (ignore_invalid),
  4021                                     &inserted_chars);
  4022   if (decoded_length > allength)
  4023     emacs_abort ();
  4024 
  4025   if (decoded_length < 0)
  4026     {
  4027       /* The decoding wasn't possible. */
  4028       error ("Invalid base64 data");
  4029     }
  4030 
  4031   /* Now we have decoded the region, so we insert the new contents
  4032      and delete the old.  (Insert first in order to preserve markers.)  */
  4033   TEMP_SET_PT_BOTH (XFIXNAT (beg), ibeg);
  4034   insert_1_both (decoded, inserted_chars, decoded_length, 0, 1, 0);
  4035   signal_after_change (XFIXNAT (beg), 0, inserted_chars);
  4036   SAFE_FREE ();
  4037 
  4038   /* Delete the original text.  */
  4039   del_range_both (PT, PT_BYTE, XFIXNAT (end) + inserted_chars,
  4040                   iend + decoded_length, 1);
  4041 
  4042   /* If point was outside of the region, restore it exactly; else just
  4043      move to the beginning of the region.  */
  4044   if (old_pos >= XFIXNAT (end))
  4045     old_pos += inserted_chars - (XFIXNAT (end) - XFIXNAT (beg));
  4046   else if (old_pos > XFIXNAT (beg))
  4047     old_pos = XFIXNAT (beg);
  4048   SET_PT (old_pos > ZV ? ZV : old_pos);
  4049 
  4050   return make_fixnum (inserted_chars);
  4051 }
  4052 
  4053 DEFUN ("base64-decode-string", Fbase64_decode_string, Sbase64_decode_string,
  4054        1, 3, 0,
  4055        doc: /* Base64-decode STRING and return the result as a string.
  4056 Optional argument BASE64URL determines whether to use the URL variant of
  4057 the base 64 encoding, as defined in RFC 4648.
  4058 If optional third argument IGNORE-INVALID is non-nil invalid characters are
  4059 ignored instead of signaling an error.  */)
  4060      (Lisp_Object string, Lisp_Object base64url, Lisp_Object ignore_invalid)
  4061 {
  4062   char *decoded;
  4063   ptrdiff_t length, decoded_length;
  4064   Lisp_Object decoded_string;
  4065   USE_SAFE_ALLOCA;
  4066 
  4067   CHECK_STRING (string);
  4068 
  4069   length = SBYTES (string);
  4070   /* We need to allocate enough room for decoding the text. */
  4071   decoded = SAFE_ALLOCA (length);
  4072 
  4073   /* The decoded result should be unibyte. */
  4074   ptrdiff_t decoded_chars;
  4075   decoded_length = base64_decode_1 (SSDATA (string), decoded, length,
  4076                                     !NILP (base64url), false,
  4077                                     !NILP (ignore_invalid), &decoded_chars);
  4078   if (decoded_length > length)
  4079     emacs_abort ();
  4080   else if (decoded_length >= 0)
  4081     decoded_string = make_unibyte_string (decoded, decoded_length);
  4082   else
  4083     decoded_string = Qnil;
  4084 
  4085   SAFE_FREE ();
  4086   if (!STRINGP (decoded_string))
  4087     error ("Invalid base64 data");
  4088 
  4089   return decoded_string;
  4090 }
  4091 
  4092 /* Base64-decode the data at FROM of LENGTH bytes into TO.  If
  4093    MULTIBYTE, the decoded result should be in multibyte
  4094    form.  If IGNORE_INVALID, ignore invalid base64 characters.
  4095    Store the number of produced characters in *NCHARS_RETURN.  */
  4096 
  4097 static ptrdiff_t
  4098 base64_decode_1 (const char *from, char *to, ptrdiff_t length,
  4099                  bool base64url, bool multibyte, bool ignore_invalid,
  4100                  ptrdiff_t *nchars_return)
  4101 {
  4102   char const *f = from;
  4103   char const *flim = from + length;
  4104   char *e = to;
  4105   ptrdiff_t nchars = 0;
  4106   signed char const *b64_char_to_value = base64_char_to_value[base64url];
  4107   unsigned char multibyte_bit = multibyte << 7;
  4108 
  4109   while (true)
  4110     {
  4111       unsigned char c;
  4112       int v1;
  4113 
  4114       /* Process first byte of a quadruplet. */
  4115 
  4116       do
  4117         {
  4118           if (f == flim)
  4119             {
  4120               *nchars_return = nchars;
  4121               return e - to;
  4122             }
  4123           c = *f++;
  4124           v1 = b64_char_to_value[c];
  4125         }
  4126       while (v1 < 0 || (v1 == 0 && ignore_invalid));
  4127 
  4128       if (v1 == 0)
  4129         return -1;
  4130       unsigned int value = (v1 - 1) << 18;
  4131 
  4132       /* Process second byte of a quadruplet.  */
  4133 
  4134       do
  4135         {
  4136           if (f == flim)
  4137             return -1;
  4138           c = *f++;
  4139           v1 = b64_char_to_value[c];
  4140         }
  4141       while (v1 < 0 || (v1 == 0 && ignore_invalid));
  4142 
  4143       if (v1 == 0)
  4144         return -1;
  4145       value += (v1 - 1) << 12;
  4146 
  4147       c = value >> 16 & 0xff;
  4148       if (c & multibyte_bit)
  4149         e += BYTE8_STRING (c, (unsigned char *) e);
  4150       else
  4151         *e++ = c;
  4152       nchars++;
  4153 
  4154       /* Process third byte of a quadruplet.  */
  4155 
  4156       do
  4157         {
  4158           if (f == flim)
  4159             {
  4160               if (!base64url && !ignore_invalid)
  4161                 return -1;
  4162               *nchars_return = nchars;
  4163               return e - to;
  4164             }
  4165           c = *f++;
  4166           v1 = b64_char_to_value[c];
  4167         }
  4168       while (v1 < 0 || (v1 == 0 && ignore_invalid));
  4169 
  4170       if (c == '=')
  4171         {
  4172           do
  4173             {
  4174               if (f == flim)
  4175                 return -1;
  4176               c = *f++;
  4177             }
  4178           while (b64_char_to_value[c] < 0);
  4179 
  4180           if (c != '=')
  4181             return -1;
  4182           continue;
  4183         }
  4184 
  4185       if (v1 == 0)
  4186         return -1;
  4187       value += (v1 - 1) << 6;
  4188 
  4189       c = value >> 8 & 0xff;
  4190       if (c & multibyte_bit)
  4191         e += BYTE8_STRING (c, (unsigned char *) e);
  4192       else
  4193         *e++ = c;
  4194       nchars++;
  4195 
  4196       /* Process fourth byte of a quadruplet.  */
  4197 
  4198       do
  4199         {
  4200           if (f == flim)
  4201             {
  4202               if (!base64url && !ignore_invalid)
  4203                 return -1;
  4204               *nchars_return = nchars;
  4205               return e - to;
  4206             }
  4207           c = *f++;
  4208           v1 = b64_char_to_value[c];
  4209         }
  4210       while (v1 < 0 || (v1 == 0 && ignore_invalid));
  4211 
  4212       if (c == '=')
  4213         continue;
  4214 
  4215       if (v1 == 0)
  4216         return -1;
  4217       value += v1 - 1;
  4218 
  4219       c = value & 0xff;
  4220       if (c & multibyte_bit)
  4221         e += BYTE8_STRING (c, (unsigned char *) e);
  4222       else
  4223         *e++ = c;
  4224       nchars++;
  4225     }
  4226 }
  4227 
  4228 
  4229 
  4230 /***********************************************************************
  4231  *****                                                             *****
  4232  *****                       Hash Tables                           *****
  4233  *****                                                             *****
  4234  ***********************************************************************/
  4235 
  4236 /* Implemented by gerd@gnu.org.  This hash table implementation was
  4237    inspired by CMUCL hash tables.  */
  4238 
  4239 /* Ideas:
  4240 
  4241    1. For small tables, association lists are probably faster than
  4242    hash tables because they have lower overhead.
  4243 
  4244    For uses of hash tables where the O(1) behavior of table
  4245    operations is not a requirement, it might therefore be a good idea
  4246    not to hash.  Instead, we could just do a linear search in the
  4247    key_and_value vector of the hash table.  This could be done
  4248    if a `:linear-search t' argument is given to make-hash-table.  */
  4249 
  4250 
  4251 
  4252 /***********************************************************************
  4253                                Utilities
  4254  ***********************************************************************/
  4255 
  4256 static void
  4257 CHECK_HASH_TABLE (Lisp_Object x)
  4258 {
  4259   CHECK_TYPE (HASH_TABLE_P (x), Qhash_table_p, x);
  4260 }
  4261 
  4262 static void
  4263 set_hash_next_slot (struct Lisp_Hash_Table *h, ptrdiff_t idx, ptrdiff_t val)
  4264 {
  4265   gc_aset (h->next, idx, make_fixnum (val));
  4266 }
  4267 static void
  4268 set_hash_hash_slot (struct Lisp_Hash_Table *h, ptrdiff_t idx, Lisp_Object val)
  4269 {
  4270   gc_aset (h->hash, idx, val);
  4271 }
  4272 static void
  4273 set_hash_index_slot (struct Lisp_Hash_Table *h, ptrdiff_t idx, ptrdiff_t val)
  4274 {
  4275   gc_aset (h->index, idx, make_fixnum (val));
  4276 }
  4277 
  4278 /* If OBJ is a Lisp hash table, return a pointer to its struct
  4279    Lisp_Hash_Table.  Otherwise, signal an error.  */
  4280 
  4281 static struct Lisp_Hash_Table *
  4282 check_hash_table (Lisp_Object obj)
  4283 {
  4284   CHECK_HASH_TABLE (obj);
  4285   return XHASH_TABLE (obj);
  4286 }
  4287 
  4288 
  4289 /* Value is the next integer I >= N, N >= 0 which is "almost" a prime
  4290    number.  A number is "almost" a prime number if it is not divisible
  4291    by any integer in the range 2 .. (NEXT_ALMOST_PRIME_LIMIT - 1).  */
  4292 
  4293 EMACS_INT
  4294 next_almost_prime (EMACS_INT n)
  4295 {
  4296   verify (NEXT_ALMOST_PRIME_LIMIT == 11);
  4297   for (n |= 1; ; n += 2)
  4298     if (n % 3 != 0 && n % 5 != 0 && n % 7 != 0)
  4299       return n;
  4300 }
  4301 
  4302 
  4303 /* Find KEY in ARGS which has size NARGS.  Don't consider indices for
  4304    which USED[I] is non-zero.  If found at index I in ARGS, set
  4305    USED[I] and USED[I + 1] to 1, and return I + 1.  Otherwise return
  4306    0.  This function is used to extract a keyword/argument pair from
  4307    a DEFUN parameter list.  */
  4308 
  4309 static ptrdiff_t
  4310 get_key_arg (Lisp_Object key, ptrdiff_t nargs, Lisp_Object *args, char *used)
  4311 {
  4312   ptrdiff_t i;
  4313 
  4314   for (i = 1; i < nargs; i++)
  4315     if (!used[i - 1] && EQ (args[i - 1], key))
  4316       {
  4317         used[i - 1] = 1;
  4318         used[i] = 1;
  4319         return i;
  4320       }
  4321 
  4322   return 0;
  4323 }
  4324 
  4325 
  4326 /* Return a Lisp vector which has the same contents as VEC but has
  4327    at least INCR_MIN more entries, where INCR_MIN is positive.
  4328    If NITEMS_MAX is not -1, do not grow the vector to be any larger
  4329    than NITEMS_MAX.  New entries in the resulting vector are
  4330    uninitialized.  */
  4331 
  4332 static Lisp_Object
  4333 larger_vecalloc (Lisp_Object vec, ptrdiff_t incr_min, ptrdiff_t nitems_max)
  4334 {
  4335   struct Lisp_Vector *v;
  4336   ptrdiff_t incr, incr_max, old_size, new_size;
  4337   ptrdiff_t C_language_max = min (PTRDIFF_MAX, SIZE_MAX) / sizeof *v->contents;
  4338   ptrdiff_t n_max = (0 <= nitems_max && nitems_max < C_language_max
  4339                      ? nitems_max : C_language_max);
  4340   eassert (VECTORP (vec));
  4341   eassert (0 < incr_min && -1 <= nitems_max);
  4342   old_size = ASIZE (vec);
  4343   incr_max = n_max - old_size;
  4344   incr = max (incr_min, min (old_size >> 1, incr_max));
  4345   if (incr_max < incr)
  4346     memory_full (SIZE_MAX);
  4347   new_size = old_size + incr;
  4348   v = allocate_vector (new_size);
  4349   memcpy (v->contents, XVECTOR (vec)->contents, old_size * sizeof *v->contents);
  4350   XSETVECTOR (vec, v);
  4351   return vec;
  4352 }
  4353 
  4354 /* Likewise, except set new entries in the resulting vector to nil.  */
  4355 
  4356 Lisp_Object
  4357 larger_vector (Lisp_Object vec, ptrdiff_t incr_min, ptrdiff_t nitems_max)
  4358 {
  4359   ptrdiff_t old_size = ASIZE (vec);
  4360   Lisp_Object v = larger_vecalloc (vec, incr_min, nitems_max);
  4361   ptrdiff_t new_size = ASIZE (v);
  4362   memclear (XVECTOR (v)->contents + old_size,
  4363             (new_size - old_size) * word_size);
  4364   return v;
  4365 }
  4366 
  4367 
  4368 /***********************************************************************
  4369                          Low-level Functions
  4370  ***********************************************************************/
  4371 
  4372 /* Return the index of the next entry in H following the one at IDX,
  4373    or -1 if none.  */
  4374 
  4375 static ptrdiff_t
  4376 HASH_NEXT (struct Lisp_Hash_Table *h, ptrdiff_t idx)
  4377 {
  4378   return XFIXNUM (AREF (h->next, idx));
  4379 }
  4380 
  4381 /* Return the index of the element in hash table H that is the start
  4382    of the collision list at index IDX, or -1 if the list is empty.  */
  4383 
  4384 static ptrdiff_t
  4385 HASH_INDEX (struct Lisp_Hash_Table *h, ptrdiff_t idx)
  4386 {
  4387   return XFIXNUM (AREF (h->index, idx));
  4388 }
  4389 
  4390 /* Restore a hash table's mutability after the critical section exits.  */
  4391 
  4392 static void
  4393 restore_mutability (void *ptr)
  4394 {
  4395   struct Lisp_Hash_Table *h = ptr;
  4396   h->mutable = true;
  4397 }
  4398 
  4399 /* Return the result of calling a user-defined hash or comparison
  4400    function ARGS[0] with arguments ARGS[1] through ARGS[NARGS - 1].
  4401    Signal an error if the function attempts to modify H, which
  4402    otherwise might lead to undefined behavior.  */
  4403 
  4404 static Lisp_Object
  4405 hash_table_user_defined_call (ptrdiff_t nargs, Lisp_Object *args,
  4406                               struct Lisp_Hash_Table *h)
  4407 {
  4408   if (!h->mutable)
  4409     return Ffuncall (nargs, args);
  4410   specpdl_ref count = inhibit_garbage_collection ();
  4411   record_unwind_protect_ptr (restore_mutability, h);
  4412   h->mutable = false;
  4413   return unbind_to (count, Ffuncall (nargs, args));
  4414 }
  4415 
  4416 /* Ignore H and compare KEY1 and KEY2 using 'eql'.
  4417    Value is true if KEY1 and KEY2 are the same.  */
  4418 
  4419 static Lisp_Object
  4420 cmpfn_eql (Lisp_Object key1, Lisp_Object key2, struct Lisp_Hash_Table *h)
  4421 {
  4422   return Feql (key1, key2);
  4423 }
  4424 
  4425 /* Ignore H and compare KEY1 and KEY2 using 'equal'.
  4426    Value is true if KEY1 and KEY2 are the same.  */
  4427 
  4428 static Lisp_Object
  4429 cmpfn_equal (Lisp_Object key1, Lisp_Object key2, struct Lisp_Hash_Table *h)
  4430 {
  4431   return Fequal (key1, key2);
  4432 }
  4433 
  4434 
  4435 /* Given H, compare KEY1 and KEY2 using H->user_cmp_function.
  4436    Value is true if KEY1 and KEY2 are the same.  */
  4437 
  4438 static Lisp_Object
  4439 cmpfn_user_defined (Lisp_Object key1, Lisp_Object key2,
  4440                     struct Lisp_Hash_Table *h)
  4441 {
  4442   Lisp_Object args[] = { h->test.user_cmp_function, key1, key2 };
  4443   return hash_table_user_defined_call (ARRAYELTS (args), args, h);
  4444 }
  4445 
  4446 /* Ignore H and return a hash code for KEY which uses 'eq' to compare keys.  */
  4447 
  4448 static Lisp_Object
  4449 hashfn_eq (Lisp_Object key, struct Lisp_Hash_Table *h)
  4450 {
  4451   if (symbols_with_pos_enabled && SYMBOL_WITH_POS_P (key))
  4452     key = SYMBOL_WITH_POS_SYM (key);
  4453   return make_ufixnum (XHASH (key) ^ XTYPE (key));
  4454 }
  4455 
  4456 /* Ignore H and return a hash code for KEY which uses 'equal' to compare keys.
  4457    The hash code is at most INTMASK.  */
  4458 
  4459 static Lisp_Object
  4460 hashfn_equal (Lisp_Object key, struct Lisp_Hash_Table *h)
  4461 {
  4462   return make_ufixnum (sxhash (key));
  4463 }
  4464 
  4465 /* Ignore H and return a hash code for KEY which uses 'eql' to compare keys.
  4466    The hash code is at most INTMASK.  */
  4467 
  4468 static Lisp_Object
  4469 hashfn_eql (Lisp_Object key, struct Lisp_Hash_Table *h)
  4470 {
  4471   return (FLOATP (key) || BIGNUMP (key) ? hashfn_equal : hashfn_eq) (key, h);
  4472 }
  4473 
  4474 /* Given H, return a hash code for KEY which uses a user-defined
  4475    function to compare keys.  */
  4476 
  4477 Lisp_Object
  4478 hashfn_user_defined (Lisp_Object key, struct Lisp_Hash_Table *h)
  4479 {
  4480   Lisp_Object args[] = { h->test.user_hash_function, key };
  4481   Lisp_Object hash = hash_table_user_defined_call (ARRAYELTS (args), args, h);
  4482   return FIXNUMP (hash) ? hash : make_ufixnum (sxhash (hash));
  4483 }
  4484 
  4485 struct hash_table_test const
  4486   hashtest_eq = { LISPSYM_INITIALLY (Qeq), LISPSYM_INITIALLY (Qnil),
  4487                   LISPSYM_INITIALLY (Qnil), 0, hashfn_eq },
  4488   hashtest_eql = { LISPSYM_INITIALLY (Qeql), LISPSYM_INITIALLY (Qnil),
  4489                    LISPSYM_INITIALLY (Qnil), cmpfn_eql, hashfn_eql },
  4490   hashtest_equal = { LISPSYM_INITIALLY (Qequal), LISPSYM_INITIALLY (Qnil),
  4491                      LISPSYM_INITIALLY (Qnil), cmpfn_equal, hashfn_equal };
  4492 
  4493 /* Allocate basically initialized hash table.  */
  4494 
  4495 static struct Lisp_Hash_Table *
  4496 allocate_hash_table (void)
  4497 {
  4498   return ALLOCATE_PSEUDOVECTOR (struct Lisp_Hash_Table,
  4499                                 index, PVEC_HASH_TABLE);
  4500 }
  4501 
  4502 /* An upper bound on the size of a hash table index.  It must fit in
  4503    ptrdiff_t and be a valid Emacs fixnum.  This is an upper bound on
  4504    VECTOR_ELTS_MAX (see alloc.c) and gets as close as we can without
  4505    violating modularity.  */
  4506 #define INDEX_SIZE_BOUND \
  4507   ((ptrdiff_t) min (MOST_POSITIVE_FIXNUM, \
  4508                     ((min (PTRDIFF_MAX, SIZE_MAX) \
  4509                       - header_size - GCALIGNMENT) \
  4510                      / word_size)))
  4511 
  4512 static ptrdiff_t
  4513 hash_index_size (struct Lisp_Hash_Table *h, ptrdiff_t size)
  4514 {
  4515   double threshold = h->rehash_threshold;
  4516   double index_float = size / threshold;
  4517   ptrdiff_t index_size = (index_float < INDEX_SIZE_BOUND + 1
  4518                           ? next_almost_prime (index_float)
  4519                           : INDEX_SIZE_BOUND + 1);
  4520   if (INDEX_SIZE_BOUND < index_size)
  4521     error ("Hash table too large");
  4522   return index_size;
  4523 }
  4524 
  4525 /* Create and initialize a new hash table.
  4526 
  4527    TEST specifies the test the hash table will use to compare keys.
  4528    It must be either one of the predefined tests `eq', `eql' or
  4529    `equal' or a symbol denoting a user-defined test named TEST with
  4530    test and hash functions USER_TEST and USER_HASH.
  4531 
  4532    Give the table initial capacity SIZE, 0 <= SIZE <= MOST_POSITIVE_FIXNUM.
  4533 
  4534    If REHASH_SIZE is equal to a negative integer, this hash table's
  4535    new size when it becomes full is computed by subtracting
  4536    REHASH_SIZE from its old size.  Otherwise it must be positive, and
  4537    the table's new size is computed by multiplying its old size by
  4538    REHASH_SIZE + 1.
  4539 
  4540    REHASH_THRESHOLD must be a float <= 1.0, and > 0.  The table will
  4541    be resized when the approximate ratio of table entries to table
  4542    size exceeds REHASH_THRESHOLD.
  4543 
  4544    WEAK specifies the weakness of the table.  If non-nil, it must be
  4545    one of the symbols `key', `value', `key-or-value', or `key-and-value'.
  4546 
  4547    If PURECOPY is non-nil, the table can be copied to pure storage via
  4548    `purecopy' when Emacs is being dumped. Such tables can no longer be
  4549    changed after purecopy.  */
  4550 
  4551 Lisp_Object
  4552 make_hash_table (struct hash_table_test test, EMACS_INT size,
  4553                  float rehash_size, float rehash_threshold,
  4554                  Lisp_Object weak, bool purecopy)
  4555 {
  4556   struct Lisp_Hash_Table *h;
  4557   Lisp_Object table;
  4558   ptrdiff_t i;
  4559 
  4560   /* Preconditions.  */
  4561   eassert (SYMBOLP (test.name));
  4562   eassert (0 <= size && size <= MOST_POSITIVE_FIXNUM);
  4563   eassert (rehash_size <= -1 || 0 < rehash_size);
  4564   eassert (0 < rehash_threshold && rehash_threshold <= 1);
  4565 
  4566   if (size == 0)
  4567     size = 1;
  4568 
  4569   /* Allocate a table and initialize it.  */
  4570   h = allocate_hash_table ();
  4571 
  4572   /* Initialize hash table slots.  */
  4573   h->test = test;
  4574   h->weak = weak;
  4575   h->rehash_threshold = rehash_threshold;
  4576   h->rehash_size = rehash_size;
  4577   h->count = 0;
  4578   h->key_and_value = make_vector (2 * size, Qunbound);
  4579   h->hash = make_nil_vector (size);
  4580   h->next = make_vector (size, make_fixnum (-1));
  4581   h->index = make_vector (hash_index_size (h, size), make_fixnum (-1));
  4582   h->next_weak = NULL;
  4583   h->purecopy = purecopy;
  4584   h->mutable = true;
  4585 
  4586   /* Set up the free list.  */
  4587   for (i = 0; i < size - 1; ++i)
  4588     set_hash_next_slot (h, i, i + 1);
  4589   h->next_free = 0;
  4590 
  4591   XSET_HASH_TABLE (table, h);
  4592   eassert (HASH_TABLE_P (table));
  4593   eassert (XHASH_TABLE (table) == h);
  4594 
  4595   return table;
  4596 }
  4597 
  4598 
  4599 /* Return a copy of hash table H1.  Keys and values are not copied,
  4600    only the table itself is.  */
  4601 
  4602 static Lisp_Object
  4603 copy_hash_table (struct Lisp_Hash_Table *h1)
  4604 {
  4605   Lisp_Object table;
  4606   struct Lisp_Hash_Table *h2;
  4607 
  4608   h2 = allocate_hash_table ();
  4609   *h2 = *h1;
  4610   h2->mutable = true;
  4611   h2->key_and_value = Fcopy_sequence (h1->key_and_value);
  4612   h2->hash = Fcopy_sequence (h1->hash);
  4613   h2->next = Fcopy_sequence (h1->next);
  4614   h2->index = Fcopy_sequence (h1->index);
  4615   XSET_HASH_TABLE (table, h2);
  4616 
  4617   return table;
  4618 }
  4619 
  4620 
  4621 /* Resize hash table H if it's too full.  If H cannot be resized
  4622    because it's already too large, throw an error.  */
  4623 
  4624 static void
  4625 maybe_resize_hash_table (struct Lisp_Hash_Table *h)
  4626 {
  4627   if (h->next_free < 0)
  4628     {
  4629       ptrdiff_t old_size = HASH_TABLE_SIZE (h);
  4630       EMACS_INT new_size;
  4631       double rehash_size = h->rehash_size;
  4632 
  4633       if (rehash_size < 0)
  4634         new_size = old_size - rehash_size;
  4635       else
  4636         {
  4637           double float_new_size = old_size * (rehash_size + 1);
  4638           if (float_new_size < EMACS_INT_MAX)
  4639             new_size = float_new_size;
  4640           else
  4641             new_size = EMACS_INT_MAX;
  4642         }
  4643       if (PTRDIFF_MAX < new_size)
  4644         new_size = PTRDIFF_MAX;
  4645       if (new_size <= old_size)
  4646         new_size = old_size + 1;
  4647 
  4648       /* Allocate all the new vectors before updating *H, to
  4649          avoid problems if memory is exhausted.  larger_vecalloc
  4650          finishes computing the size of the replacement vectors.  */
  4651       Lisp_Object next = larger_vecalloc (h->next, new_size - old_size,
  4652                                           new_size);
  4653       ptrdiff_t next_size = ASIZE (next);
  4654       for (ptrdiff_t i = old_size; i < next_size - 1; i++)
  4655         ASET (next, i, make_fixnum (i + 1));
  4656       ASET (next, next_size - 1, make_fixnum (-1));
  4657 
  4658       /* Build the new&larger key_and_value vector, making sure the new
  4659          fields are initialized to `unbound`.  */
  4660       Lisp_Object key_and_value
  4661         = larger_vecalloc (h->key_and_value, 2 * (next_size - old_size),
  4662                            2 * next_size);
  4663       for (ptrdiff_t i = 2 * old_size; i < 2 * next_size; i++)
  4664         ASET (key_and_value, i, Qunbound);
  4665 
  4666       Lisp_Object hash = larger_vector (h->hash, next_size - old_size,
  4667                                         next_size);
  4668       ptrdiff_t index_size = hash_index_size (h, next_size);
  4669       h->index = make_vector (index_size, make_fixnum (-1));
  4670       h->key_and_value = key_and_value;
  4671       h->hash = hash;
  4672       h->next = next;
  4673       h->next_free = old_size;
  4674 
  4675       /* Rehash.  */
  4676       for (ptrdiff_t i = 0; i < old_size; i++)
  4677         if (!NILP (HASH_HASH (h, i)))
  4678           {
  4679             EMACS_UINT hash_code = XUFIXNUM (HASH_HASH (h, i));
  4680             ptrdiff_t start_of_bucket = hash_code % ASIZE (h->index);
  4681             set_hash_next_slot (h, i, HASH_INDEX (h, start_of_bucket));
  4682             set_hash_index_slot (h, start_of_bucket, i);
  4683           }
  4684 
  4685 #ifdef ENABLE_CHECKING
  4686       if (HASH_TABLE_P (Vpurify_flag) && XHASH_TABLE (Vpurify_flag) == h)
  4687         message ("Growing hash table to: %"pD"d", next_size);
  4688 #endif
  4689     }
  4690 }
  4691 
  4692 /* Recompute the hashes (and hence also the "next" pointers).
  4693    Normally there's never a need to recompute hashes.
  4694    This is done only on first access to a hash-table loaded from
  4695    the "pdump", because the objects' addresses may have changed, thus
  4696    affecting their hashes.  */
  4697 void
  4698 hash_table_rehash (Lisp_Object hash)
  4699 {
  4700   struct Lisp_Hash_Table *h = XHASH_TABLE (hash);
  4701   ptrdiff_t i, count = h->count;
  4702 
  4703   /* Recompute the actual hash codes for each entry in the table.
  4704      Order is still invalid.  */
  4705   for (i = 0; i < count; i++)
  4706     {
  4707       Lisp_Object key = HASH_KEY (h, i);
  4708       Lisp_Object hash_code = h->test.hashfn (key, h);
  4709       ptrdiff_t start_of_bucket = XUFIXNUM (hash_code) % ASIZE (h->index);
  4710       set_hash_hash_slot (h, i, hash_code);
  4711       set_hash_next_slot (h, i, HASH_INDEX (h, start_of_bucket));
  4712       set_hash_index_slot (h, start_of_bucket, i);
  4713       eassert (HASH_NEXT (h, i) != i); /* Stop loops.  */
  4714     }
  4715 
  4716   ptrdiff_t size = ASIZE (h->next);
  4717   for (; i + 1 < size; i++)
  4718     set_hash_next_slot (h, i, i + 1);
  4719 }
  4720 
  4721 /* Lookup KEY in hash table H.  If HASH is non-null, return in *HASH
  4722    the hash code of KEY.  Value is the index of the entry in H
  4723    matching KEY, or -1 if not found.  */
  4724 
  4725 ptrdiff_t
  4726 hash_lookup (struct Lisp_Hash_Table *h, Lisp_Object key, Lisp_Object *hash)
  4727 {
  4728   ptrdiff_t start_of_bucket, i;
  4729 
  4730   Lisp_Object hash_code;
  4731   hash_code = h->test.hashfn (key, h);
  4732   if (hash)
  4733     *hash = hash_code;
  4734 
  4735   start_of_bucket = XUFIXNUM (hash_code) % ASIZE (h->index);
  4736 
  4737   for (i = HASH_INDEX (h, start_of_bucket); 0 <= i; i = HASH_NEXT (h, i))
  4738     if (EQ (key, HASH_KEY (h, i))
  4739         || (h->test.cmpfn
  4740             && EQ (hash_code, HASH_HASH (h, i))
  4741             && !NILP (h->test.cmpfn (key, HASH_KEY (h, i), h))))
  4742       break;
  4743 
  4744   return i;
  4745 }
  4746 
  4747 static void
  4748 check_mutable_hash_table (Lisp_Object obj, struct Lisp_Hash_Table *h)
  4749 {
  4750   if (!h->mutable)
  4751     signal_error ("hash table test modifies table", obj);
  4752   eassert (!PURE_P (h));
  4753 }
  4754 
  4755 static void
  4756 collect_interval (INTERVAL interval, Lisp_Object collector)
  4757 {
  4758   nconc2 (collector,
  4759           list1(list3 (make_fixnum (interval->position),
  4760                        make_fixnum (interval->position + LENGTH (interval)),
  4761                        interval->plist)));
  4762 }
  4763 
  4764 /* Put an entry into hash table H that associates KEY with VALUE.
  4765    HASH is a previously computed hash code of KEY.
  4766    Value is the index of the entry in H matching KEY.  */
  4767 
  4768 ptrdiff_t
  4769 hash_put (struct Lisp_Hash_Table *h, Lisp_Object key, Lisp_Object value,
  4770           Lisp_Object hash)
  4771 {
  4772   ptrdiff_t start_of_bucket, i;
  4773 
  4774   /* Increment count after resizing because resizing may fail.  */
  4775   maybe_resize_hash_table (h);
  4776   h->count++;
  4777 
  4778   /* Store key/value in the key_and_value vector.  */
  4779   i = h->next_free;
  4780   eassert (NILP (HASH_HASH (h, i)));
  4781   eassert (BASE_EQ (Qunbound, (HASH_KEY (h, i))));
  4782   h->next_free = HASH_NEXT (h, i);
  4783   set_hash_key_slot (h, i, key);
  4784   set_hash_value_slot (h, i, value);
  4785 
  4786   /* Remember its hash code.  */
  4787   set_hash_hash_slot (h, i, hash);
  4788 
  4789   /* Add new entry to its collision chain.  */
  4790   start_of_bucket = XUFIXNUM (hash) % ASIZE (h->index);
  4791   set_hash_next_slot (h, i, HASH_INDEX (h, start_of_bucket));
  4792   set_hash_index_slot (h, start_of_bucket, i);
  4793   return i;
  4794 }
  4795 
  4796 
  4797 /* Remove the entry matching KEY from hash table H, if there is one.  */
  4798 
  4799 void
  4800 hash_remove_from_table (struct Lisp_Hash_Table *h, Lisp_Object key)
  4801 {
  4802   Lisp_Object hash_code = h->test.hashfn (key, h);
  4803   ptrdiff_t start_of_bucket = XUFIXNUM (hash_code) % ASIZE (h->index);
  4804   ptrdiff_t prev = -1;
  4805 
  4806   for (ptrdiff_t i = HASH_INDEX (h, start_of_bucket);
  4807        0 <= i;
  4808        i = HASH_NEXT (h, i))
  4809     {
  4810       if (EQ (key, HASH_KEY (h, i))
  4811           || (h->test.cmpfn
  4812               && EQ (hash_code, HASH_HASH (h, i))
  4813               && !NILP (h->test.cmpfn (key, HASH_KEY (h, i), h))))
  4814         {
  4815           /* Take entry out of collision chain.  */
  4816           if (prev < 0)
  4817             set_hash_index_slot (h, start_of_bucket, HASH_NEXT (h, i));
  4818           else
  4819             set_hash_next_slot (h, prev, HASH_NEXT (h, i));
  4820 
  4821           /* Clear slots in key_and_value and add the slots to
  4822              the free list.  */
  4823           set_hash_key_slot (h, i, Qunbound);
  4824           set_hash_value_slot (h, i, Qnil);
  4825           set_hash_hash_slot (h, i, Qnil);
  4826           set_hash_next_slot (h, i, h->next_free);
  4827           h->next_free = i;
  4828           h->count--;
  4829           eassert (h->count >= 0);
  4830           break;
  4831         }
  4832 
  4833       prev = i;
  4834     }
  4835 }
  4836 
  4837 
  4838 /* Clear hash table H.  */
  4839 
  4840 static void
  4841 hash_clear (struct Lisp_Hash_Table *h)
  4842 {
  4843   if (h->count > 0)
  4844     {
  4845       ptrdiff_t size = HASH_TABLE_SIZE (h);
  4846       memclear (xvector_contents (h->hash), size * word_size);
  4847       for (ptrdiff_t i = 0; i < size; i++)
  4848         {
  4849           set_hash_next_slot (h, i, i < size - 1 ? i + 1 : -1);
  4850           set_hash_key_slot (h, i, Qunbound);
  4851           set_hash_value_slot (h, i, Qnil);
  4852         }
  4853 
  4854       for (ptrdiff_t i = 0; i < ASIZE (h->index); i++)
  4855         ASET (h->index, i, make_fixnum (-1));
  4856 
  4857       h->next_free = 0;
  4858       h->count = 0;
  4859     }
  4860 }
  4861 
  4862 
  4863 
  4864 /************************************************************************
  4865                            Weak Hash Tables
  4866  ************************************************************************/
  4867 
  4868 /* Sweep weak hash table H.  REMOVE_ENTRIES_P means remove
  4869    entries from the table that don't survive the current GC.
  4870    !REMOVE_ENTRIES_P means mark entries that are in use.  Value is
  4871    true if anything was marked.  */
  4872 
  4873 bool
  4874 sweep_weak_table (struct Lisp_Hash_Table *h, bool remove_entries_p)
  4875 {
  4876   ptrdiff_t n = gc_asize (h->index);
  4877   bool marked = false;
  4878 
  4879   for (ptrdiff_t bucket = 0; bucket < n; ++bucket)
  4880     {
  4881       /* Follow collision chain, removing entries that don't survive
  4882          this garbage collection.  */
  4883       ptrdiff_t prev = -1;
  4884       ptrdiff_t next;
  4885       for (ptrdiff_t i = HASH_INDEX (h, bucket); 0 <= i; i = next)
  4886         {
  4887           bool key_known_to_survive_p = survives_gc_p (HASH_KEY (h, i));
  4888           bool value_known_to_survive_p = survives_gc_p (HASH_VALUE (h, i));
  4889           bool remove_p;
  4890 
  4891           if (EQ (h->weak, Qkey))
  4892             remove_p = !key_known_to_survive_p;
  4893           else if (EQ (h->weak, Qvalue))
  4894             remove_p = !value_known_to_survive_p;
  4895           else if (EQ (h->weak, Qkey_or_value))
  4896             remove_p = !(key_known_to_survive_p || value_known_to_survive_p);
  4897           else if (EQ (h->weak, Qkey_and_value))
  4898             remove_p = !(key_known_to_survive_p && value_known_to_survive_p);
  4899           else
  4900             emacs_abort ();
  4901 
  4902           next = HASH_NEXT (h, i);
  4903 
  4904           if (remove_entries_p)
  4905             {
  4906               eassert (!remove_p
  4907                        == (key_known_to_survive_p && value_known_to_survive_p));
  4908               if (remove_p)
  4909                 {
  4910                   /* Take out of collision chain.  */
  4911                   if (prev < 0)
  4912                     set_hash_index_slot (h, bucket, next);
  4913                   else
  4914                     set_hash_next_slot (h, prev, next);
  4915 
  4916                   /* Add to free list.  */
  4917                   set_hash_next_slot (h, i, h->next_free);
  4918                   h->next_free = i;
  4919 
  4920                   /* Clear key, value, and hash.  */
  4921                   set_hash_key_slot (h, i, Qunbound);
  4922                   set_hash_value_slot (h, i, Qnil);
  4923                   if (!NILP (h->hash))
  4924                     set_hash_hash_slot (h, i, Qnil);
  4925 
  4926                   eassert (h->count != 0);
  4927                   h->count--;
  4928                 }
  4929               else
  4930                 {
  4931                   prev = i;
  4932                 }
  4933             }
  4934           else
  4935             {
  4936               if (!remove_p)
  4937                 {
  4938                   /* Make sure key and value survive.  */
  4939                   if (!key_known_to_survive_p)
  4940                     {
  4941                       mark_object (HASH_KEY (h, i));
  4942                       marked = true;
  4943                     }
  4944 
  4945                   if (!value_known_to_survive_p)
  4946                     {
  4947                       mark_object (HASH_VALUE (h, i));
  4948                       marked = true;
  4949                     }
  4950                 }
  4951             }
  4952         }
  4953     }
  4954 
  4955   return marked;
  4956 }
  4957 
  4958 
  4959 /***********************************************************************
  4960                         Hash Code Computation
  4961  ***********************************************************************/
  4962 
  4963 /* Maximum depth up to which to dive into Lisp structures.  */
  4964 
  4965 #define SXHASH_MAX_DEPTH 3
  4966 
  4967 /* Maximum length up to which to take list and vector elements into
  4968    account.  */
  4969 
  4970 #define SXHASH_MAX_LEN   7
  4971 
  4972 /* Return a hash for string PTR which has length LEN.  The hash value
  4973    can be any EMACS_UINT value.  */
  4974 
  4975 EMACS_UINT
  4976 hash_string (char const *ptr, ptrdiff_t len)
  4977 {
  4978   char const *p   = ptr;
  4979   char const *end = ptr + len;
  4980   EMACS_UINT hash = len;
  4981   /* At most 8 steps.  We could reuse SXHASH_MAX_LEN, of course,
  4982    * but dividing by 8 is cheaper.  */
  4983   ptrdiff_t step = sizeof hash + ((end - p) >> 3);
  4984 
  4985   while (p + sizeof hash <= end)
  4986     {
  4987       EMACS_UINT c;
  4988       /* We presume that the compiler will replace this `memcpy` with
  4989          a single load/move instruction when applicable.  */
  4990       memcpy (&c, p, sizeof hash);
  4991       p += step;
  4992       hash = sxhash_combine (hash, c);
  4993     }
  4994   /* A few last bytes may remain (smaller than an EMACS_UINT).  */
  4995   /* FIXME: We could do this without a loop, but it'd require
  4996      endian-dependent code :-(  */
  4997   while (p < end)
  4998     {
  4999       unsigned char c = *p++;
  5000       hash = sxhash_combine (hash, c);
  5001     }
  5002 
  5003   return hash;
  5004 }
  5005 
  5006 /* Return a hash for string PTR which has length LEN.  The hash
  5007    code returned is at most INTMASK.  */
  5008 
  5009 static EMACS_UINT
  5010 sxhash_string (char const *ptr, ptrdiff_t len)
  5011 {
  5012   EMACS_UINT hash = hash_string (ptr, len);
  5013   return SXHASH_REDUCE (hash);
  5014 }
  5015 
  5016 /* Return a hash for the floating point value VAL.  */
  5017 
  5018 static EMACS_UINT
  5019 sxhash_float (double val)
  5020 {
  5021   EMACS_UINT hash = 0;
  5022   union double_and_words u = { .val = val };
  5023   for (int i = 0; i < WORDS_PER_DOUBLE; i++)
  5024     hash = sxhash_combine (hash, u.word[i]);
  5025   return SXHASH_REDUCE (hash);
  5026 }
  5027 
  5028 /* Return a hash for list LIST.  DEPTH is the current depth in the
  5029    list.  We don't recurse deeper than SXHASH_MAX_DEPTH in it.  */
  5030 
  5031 static EMACS_UINT
  5032 sxhash_list (Lisp_Object list, int depth)
  5033 {
  5034   EMACS_UINT hash = 0;
  5035   int i;
  5036 
  5037   if (depth < SXHASH_MAX_DEPTH)
  5038     for (i = 0;
  5039          CONSP (list) && i < SXHASH_MAX_LEN;
  5040          list = XCDR (list), ++i)
  5041       {
  5042         EMACS_UINT hash2 = sxhash_obj (XCAR (list), depth + 1);
  5043         hash = sxhash_combine (hash, hash2);
  5044       }
  5045 
  5046   if (!NILP (list))
  5047     {
  5048       EMACS_UINT hash2 = sxhash_obj (list, depth + 1);
  5049       hash = sxhash_combine (hash, hash2);
  5050     }
  5051 
  5052   return SXHASH_REDUCE (hash);
  5053 }
  5054 
  5055 
  5056 /* Return a hash for (pseudo)vector VECTOR.  DEPTH is the current depth in
  5057    the Lisp structure.  */
  5058 
  5059 static EMACS_UINT
  5060 sxhash_vector (Lisp_Object vec, int depth)
  5061 {
  5062   EMACS_UINT hash = ASIZE (vec);
  5063   int i, n;
  5064 
  5065   n = min (SXHASH_MAX_LEN, hash & PSEUDOVECTOR_FLAG ? PVSIZE (vec) : hash);
  5066   for (i = 0; i < n; ++i)
  5067     {
  5068       EMACS_UINT hash2 = sxhash_obj (AREF (vec, i), depth + 1);
  5069       hash = sxhash_combine (hash, hash2);
  5070     }
  5071 
  5072   return SXHASH_REDUCE (hash);
  5073 }
  5074 
  5075 /* Return a hash for bool-vector VECTOR.  */
  5076 
  5077 static EMACS_UINT
  5078 sxhash_bool_vector (Lisp_Object vec)
  5079 {
  5080   EMACS_INT size = bool_vector_size (vec);
  5081   EMACS_UINT hash = size;
  5082   int i, n;
  5083 
  5084   n = min (SXHASH_MAX_LEN, bool_vector_words (size));
  5085   for (i = 0; i < n; ++i)
  5086     hash = sxhash_combine (hash, bool_vector_data (vec)[i]);
  5087 
  5088   return SXHASH_REDUCE (hash);
  5089 }
  5090 
  5091 /* Return a hash for a bignum.  */
  5092 
  5093 static EMACS_UINT
  5094 sxhash_bignum (Lisp_Object bignum)
  5095 {
  5096   mpz_t const *n = xbignum_val (bignum);
  5097   size_t i, nlimbs = mpz_size (*n);
  5098   EMACS_UINT hash = 0;
  5099 
  5100   for (i = 0; i < nlimbs; ++i)
  5101     hash = sxhash_combine (hash, mpz_getlimbn (*n, i));
  5102 
  5103   return SXHASH_REDUCE (hash);
  5104 }
  5105 
  5106 
  5107 /* Return a hash code for OBJ.  DEPTH is the current depth in the Lisp
  5108    structure.  Value is an unsigned integer clipped to INTMASK.  */
  5109 
  5110 EMACS_UINT
  5111 sxhash (Lisp_Object obj)
  5112 {
  5113   return sxhash_obj (obj, 0);
  5114 }
  5115 
  5116 static EMACS_UINT
  5117 sxhash_obj (Lisp_Object obj, int depth)
  5118 {
  5119   if (depth > SXHASH_MAX_DEPTH)
  5120     return 0;
  5121 
  5122   switch (XTYPE (obj))
  5123     {
  5124     case_Lisp_Int:
  5125       return XUFIXNUM (obj);
  5126 
  5127     case Lisp_Symbol:
  5128       return XHASH (obj);
  5129 
  5130     case Lisp_String:
  5131       return sxhash_string (SSDATA (obj), SBYTES (obj));
  5132 
  5133     case Lisp_Vectorlike:
  5134       {
  5135         enum pvec_type pvec_type = PSEUDOVECTOR_TYPE (XVECTOR (obj));
  5136         if (! (PVEC_NORMAL_VECTOR < pvec_type && pvec_type < PVEC_COMPILED))
  5137           {
  5138             /* According to the CL HyperSpec, two arrays are equal only if
  5139                they are 'eq', except for strings and bit-vectors.  In
  5140                Emacs, this works differently.  We have to compare element
  5141                by element.  Same for pseudovectors that internal_equal
  5142                examines the Lisp contents of.  */
  5143             return (SUB_CHAR_TABLE_P (obj)
  5144                     /* 'sxhash_vector' can't be applies to a sub-char-table and
  5145                       it's probably not worth looking into them anyway!  */
  5146                     ? 42
  5147                     : sxhash_vector (obj, depth));
  5148           }
  5149         /* FIXME: Use `switch`.  */
  5150         else if (pvec_type == PVEC_BIGNUM)
  5151           return sxhash_bignum (obj);
  5152         else if (pvec_type == PVEC_MARKER)
  5153           {
  5154             ptrdiff_t bytepos
  5155               = XMARKER (obj)->buffer ? XMARKER (obj)->bytepos : 0;
  5156             EMACS_UINT hash
  5157               = sxhash_combine ((intptr_t) XMARKER (obj)->buffer, bytepos);
  5158             return SXHASH_REDUCE (hash);
  5159           }
  5160         else if (pvec_type == PVEC_BOOL_VECTOR)
  5161           return sxhash_bool_vector (obj);
  5162         else if (pvec_type == PVEC_OVERLAY)
  5163           {
  5164             EMACS_UINT hash = OVERLAY_START (obj);
  5165             hash = sxhash_combine (hash, OVERLAY_END (obj));
  5166             hash = sxhash_combine (hash, sxhash_obj (XOVERLAY (obj)->plist, depth));
  5167             return SXHASH_REDUCE (hash);
  5168           }
  5169         else if (symbols_with_pos_enabled && pvec_type == PVEC_SYMBOL_WITH_POS)
  5170           return sxhash_obj (XSYMBOL_WITH_POS (obj)->sym, depth + 1);
  5171         else
  5172           /* Others are 'equal' if they are 'eq', so take their
  5173              address as hash.  */
  5174           return XHASH (obj);
  5175       }
  5176 
  5177     case Lisp_Cons:
  5178       return sxhash_list (obj, depth);
  5179 
  5180     case Lisp_Float:
  5181       return sxhash_float (XFLOAT_DATA (obj));
  5182 
  5183     default:
  5184       emacs_abort ();
  5185     }
  5186 }
  5187 
  5188 
  5189 
  5190 /***********************************************************************
  5191                             Lisp Interface
  5192  ***********************************************************************/
  5193 
  5194 DEFUN ("sxhash-eq", Fsxhash_eq, Ssxhash_eq, 1, 1, 0,
  5195        doc: /* Return an integer hash code for OBJ suitable for `eq'.
  5196 If (eq A B), then (= (sxhash-eq A) (sxhash-eq B)).
  5197 
  5198 Hash codes are not guaranteed to be preserved across Emacs sessions.  */)
  5199   (Lisp_Object obj)
  5200 {
  5201   return hashfn_eq (obj, NULL);
  5202 }
  5203 
  5204 DEFUN ("sxhash-eql", Fsxhash_eql, Ssxhash_eql, 1, 1, 0,
  5205        doc: /* Return an integer hash code for OBJ suitable for `eql'.
  5206 If (eql A B), then (= (sxhash-eql A) (sxhash-eql B)), but the opposite
  5207 isn't necessarily true.
  5208 
  5209 Hash codes are not guaranteed to be preserved across Emacs sessions.  */)
  5210   (Lisp_Object obj)
  5211 {
  5212   return hashfn_eql (obj, NULL);
  5213 }
  5214 
  5215 DEFUN ("sxhash-equal", Fsxhash_equal, Ssxhash_equal, 1, 1, 0,
  5216        doc: /* Return an integer hash code for OBJ suitable for `equal'.
  5217 If (equal A B), then (= (sxhash-equal A) (sxhash-equal B)), but the
  5218 opposite isn't necessarily true.
  5219 
  5220 Hash codes are not guaranteed to be preserved across Emacs sessions.  */)
  5221   (Lisp_Object obj)
  5222 {
  5223   return hashfn_equal (obj, NULL);
  5224 }
  5225 
  5226 DEFUN ("sxhash-equal-including-properties", Fsxhash_equal_including_properties,
  5227        Ssxhash_equal_including_properties, 1, 1, 0,
  5228        doc: /* Return an integer hash code for OBJ suitable for
  5229 `equal-including-properties'.
  5230 If (sxhash-equal-including-properties A B), then
  5231 (= (sxhash-equal-including-properties A) (sxhash-equal-including-properties B)).
  5232 
  5233 Hash codes are not guaranteed to be preserved across Emacs sessions.  */)
  5234   (Lisp_Object obj)
  5235 {
  5236   if (STRINGP (obj))
  5237     {
  5238       Lisp_Object collector = Fcons (Qnil, Qnil);
  5239       traverse_intervals (string_intervals (obj), 0, collect_interval,
  5240                           collector);
  5241       return
  5242         make_ufixnum (
  5243           SXHASH_REDUCE (sxhash_combine (sxhash (obj),
  5244                                          sxhash (CDR (collector)))));
  5245     }
  5246 
  5247   return hashfn_equal (obj, NULL);
  5248 }
  5249 
  5250 DEFUN ("make-hash-table", Fmake_hash_table, Smake_hash_table, 0, MANY, 0,
  5251        doc: /* Create and return a new hash table.
  5252 
  5253 Arguments are specified as keyword/argument pairs.  The following
  5254 arguments are defined:
  5255 
  5256 :test TEST -- TEST must be a symbol that specifies how to compare
  5257 keys.  Default is `eql'.  Predefined are the tests `eq', `eql', and
  5258 `equal'.  User-supplied test and hash functions can be specified via
  5259 `define-hash-table-test'.
  5260 
  5261 :size SIZE -- A hint as to how many elements will be put in the table.
  5262 Default is 65.
  5263 
  5264 :rehash-size REHASH-SIZE - Indicates how to expand the table when it
  5265 fills up.  If REHASH-SIZE is an integer, increase the size by that
  5266 amount.  If it is a float, it must be > 1.0, and the new size is the
  5267 old size multiplied by that factor.  Default is 1.5.
  5268 
  5269 :rehash-threshold THRESHOLD -- THRESHOLD must a float > 0, and <= 1.0.
  5270 Resize the hash table when the ratio (table entries / table size)
  5271 exceeds an approximation to THRESHOLD.  Default is 0.8125.
  5272 
  5273 :weakness WEAK -- WEAK must be one of nil, t, `key', `value',
  5274 `key-or-value', or `key-and-value'.  If WEAK is not nil, the table
  5275 returned is a weak table.  Key/value pairs are removed from a weak
  5276 hash table when there are no non-weak references pointing to their
  5277 key, value, one of key or value, or both key and value, depending on
  5278 WEAK.  WEAK t is equivalent to `key-and-value'.  Default value of WEAK
  5279 is nil.
  5280 
  5281 :purecopy PURECOPY -- If PURECOPY is non-nil, the table can be copied
  5282 to pure storage when Emacs is being dumped, making the contents of the
  5283 table read only. Any further changes to purified tables will result
  5284 in an error.
  5285 
  5286 usage: (make-hash-table &rest KEYWORD-ARGS)  */)
  5287   (ptrdiff_t nargs, Lisp_Object *args)
  5288 {
  5289   Lisp_Object test, weak;
  5290   bool purecopy;
  5291   struct hash_table_test testdesc;
  5292   ptrdiff_t i;
  5293   USE_SAFE_ALLOCA;
  5294 
  5295   /* The vector `used' is used to keep track of arguments that
  5296      have been consumed.  */
  5297   char *used = SAFE_ALLOCA (nargs * sizeof *used);
  5298   memset (used, 0, nargs * sizeof *used);
  5299 
  5300   /* See if there's a `:test TEST' among the arguments.  */
  5301   i = get_key_arg (QCtest, nargs, args, used);
  5302   test = i ? args[i] : Qeql;
  5303   if (EQ (test, Qeq))
  5304     testdesc = hashtest_eq;
  5305   else if (EQ (test, Qeql))
  5306     testdesc = hashtest_eql;
  5307   else if (EQ (test, Qequal))
  5308     testdesc = hashtest_equal;
  5309   else
  5310     {
  5311       /* See if it is a user-defined test.  */
  5312       Lisp_Object prop;
  5313 
  5314       prop = Fget (test, Qhash_table_test);
  5315       if (!CONSP (prop) || !CONSP (XCDR (prop)))
  5316         signal_error ("Invalid hash table test", test);
  5317       testdesc.name = test;
  5318       testdesc.user_cmp_function = XCAR (prop);
  5319       testdesc.user_hash_function = XCAR (XCDR (prop));
  5320       testdesc.hashfn = hashfn_user_defined;
  5321       testdesc.cmpfn = cmpfn_user_defined;
  5322     }
  5323 
  5324   /* See if there's a `:purecopy PURECOPY' argument.  */
  5325   i = get_key_arg (QCpurecopy, nargs, args, used);
  5326   purecopy = i && !NILP (args[i]);
  5327   /* See if there's a `:size SIZE' argument.  */
  5328   i = get_key_arg (QCsize, nargs, args, used);
  5329   Lisp_Object size_arg = i ? args[i] : Qnil;
  5330   EMACS_INT size;
  5331   if (NILP (size_arg))
  5332     size = DEFAULT_HASH_SIZE;
  5333   else if (FIXNATP (size_arg))
  5334     size = XFIXNAT (size_arg);
  5335   else
  5336     signal_error ("Invalid hash table size", size_arg);
  5337 
  5338   /* Look for `:rehash-size SIZE'.  */
  5339   float rehash_size;
  5340   i = get_key_arg (QCrehash_size, nargs, args, used);
  5341   if (!i)
  5342     rehash_size = DEFAULT_REHASH_SIZE;
  5343   else if (FIXNUMP (args[i]) && 0 < XFIXNUM (args[i]))
  5344     rehash_size = - XFIXNUM (args[i]);
  5345   else if (FLOATP (args[i]) && 0 < (float) (XFLOAT_DATA (args[i]) - 1))
  5346     rehash_size = (float) (XFLOAT_DATA (args[i]) - 1);
  5347   else
  5348     signal_error ("Invalid hash table rehash size", args[i]);
  5349 
  5350   /* Look for `:rehash-threshold THRESHOLD'.  */
  5351   i = get_key_arg (QCrehash_threshold, nargs, args, used);
  5352   float rehash_threshold = (!i ? DEFAULT_REHASH_THRESHOLD
  5353                             : !FLOATP (args[i]) ? 0
  5354                             : (float) XFLOAT_DATA (args[i]));
  5355   if (! (0 < rehash_threshold && rehash_threshold <= 1))
  5356     signal_error ("Invalid hash table rehash threshold", args[i]);
  5357 
  5358   /* Look for `:weakness WEAK'.  */
  5359   i = get_key_arg (QCweakness, nargs, args, used);
  5360   weak = i ? args[i] : Qnil;
  5361   if (EQ (weak, Qt))
  5362     weak = Qkey_and_value;
  5363   if (!NILP (weak)
  5364       && !EQ (weak, Qkey)
  5365       && !EQ (weak, Qvalue)
  5366       && !EQ (weak, Qkey_or_value)
  5367       && !EQ (weak, Qkey_and_value))
  5368     signal_error ("Invalid hash table weakness", weak);
  5369 
  5370   /* Now, all args should have been used up, or there's a problem.  */
  5371   for (i = 0; i < nargs; ++i)
  5372     if (!used[i])
  5373       signal_error ("Invalid argument list", args[i]);
  5374 
  5375   SAFE_FREE ();
  5376   return make_hash_table (testdesc, size, rehash_size, rehash_threshold, weak,
  5377                           purecopy);
  5378 }
  5379 
  5380 
  5381 DEFUN ("copy-hash-table", Fcopy_hash_table, Scopy_hash_table, 1, 1, 0,
  5382        doc: /* Return a copy of hash table TABLE.  */)
  5383   (Lisp_Object table)
  5384 {
  5385   return copy_hash_table (check_hash_table (table));
  5386 }
  5387 
  5388 
  5389 DEFUN ("hash-table-count", Fhash_table_count, Shash_table_count, 1, 1, 0,
  5390        doc: /* Return the number of elements in TABLE.  */)
  5391   (Lisp_Object table)
  5392 {
  5393   struct Lisp_Hash_Table *h = check_hash_table (table);
  5394   return make_fixnum (h->count);
  5395 }
  5396 
  5397 
  5398 DEFUN ("hash-table-rehash-size", Fhash_table_rehash_size,
  5399        Shash_table_rehash_size, 1, 1, 0,
  5400        doc: /* Return the current rehash size of TABLE.  */)
  5401   (Lisp_Object table)
  5402 {
  5403   double rehash_size = check_hash_table (table)->rehash_size;
  5404   if (rehash_size < 0)
  5405     {
  5406       EMACS_INT s = -rehash_size;
  5407       return make_fixnum (min (s, MOST_POSITIVE_FIXNUM));
  5408     }
  5409   else
  5410     return make_float (rehash_size + 1);
  5411 }
  5412 
  5413 
  5414 DEFUN ("hash-table-rehash-threshold", Fhash_table_rehash_threshold,
  5415        Shash_table_rehash_threshold, 1, 1, 0,
  5416        doc: /* Return the current rehash threshold of TABLE.  */)
  5417   (Lisp_Object table)
  5418 {
  5419   return make_float (check_hash_table (table)->rehash_threshold);
  5420 }
  5421 
  5422 
  5423 DEFUN ("hash-table-size", Fhash_table_size, Shash_table_size, 1, 1, 0,
  5424        doc: /* Return the size of TABLE.
  5425 The size can be used as an argument to `make-hash-table' to create
  5426 a hash table than can hold as many elements as TABLE holds
  5427 without need for resizing.  */)
  5428   (Lisp_Object table)
  5429 {
  5430   struct Lisp_Hash_Table *h = check_hash_table (table);
  5431   return make_fixnum (HASH_TABLE_SIZE (h));
  5432 }
  5433 
  5434 
  5435 DEFUN ("hash-table-test", Fhash_table_test, Shash_table_test, 1, 1, 0,
  5436        doc: /* Return the test TABLE uses.  */)
  5437   (Lisp_Object table)
  5438 {
  5439   return check_hash_table (table)->test.name;
  5440 }
  5441 
  5442 
  5443 DEFUN ("hash-table-weakness", Fhash_table_weakness, Shash_table_weakness,
  5444        1, 1, 0,
  5445        doc: /* Return the weakness of TABLE.  */)
  5446   (Lisp_Object table)
  5447 {
  5448   return check_hash_table (table)->weak;
  5449 }
  5450 
  5451 
  5452 DEFUN ("hash-table-p", Fhash_table_p, Shash_table_p, 1, 1, 0,
  5453        doc: /* Return t if OBJ is a Lisp hash table object.  */)
  5454   (Lisp_Object obj)
  5455 {
  5456   return HASH_TABLE_P (obj) ? Qt : Qnil;
  5457 }
  5458 
  5459 
  5460 DEFUN ("clrhash", Fclrhash, Sclrhash, 1, 1, 0,
  5461        doc: /* Clear hash table TABLE and return it.  */)
  5462   (Lisp_Object table)
  5463 {
  5464   struct Lisp_Hash_Table *h = check_hash_table (table);
  5465   check_mutable_hash_table (table, h);
  5466   hash_clear (h);
  5467   /* Be compatible with XEmacs.  */
  5468   return table;
  5469 }
  5470 
  5471 
  5472 DEFUN ("gethash", Fgethash, Sgethash, 2, 3, 0,
  5473        doc: /* Look up KEY in TABLE and return its associated value.
  5474 If KEY is not found, return DFLT which defaults to nil.  */)
  5475   (Lisp_Object key, Lisp_Object table, Lisp_Object dflt)
  5476 {
  5477   struct Lisp_Hash_Table *h = check_hash_table (table);
  5478   ptrdiff_t i = hash_lookup (h, key, NULL);
  5479   return i >= 0 ? HASH_VALUE (h, i) : dflt;
  5480 }
  5481 
  5482 
  5483 DEFUN ("puthash", Fputhash, Sputhash, 3, 3, 0,
  5484        doc: /* Associate KEY with VALUE in hash table TABLE.
  5485 If KEY is already present in table, replace its current value with
  5486 VALUE.  In any case, return VALUE.  */)
  5487   (Lisp_Object key, Lisp_Object value, Lisp_Object table)
  5488 {
  5489   struct Lisp_Hash_Table *h = check_hash_table (table);
  5490   check_mutable_hash_table (table, h);
  5491 
  5492   Lisp_Object hash;
  5493   ptrdiff_t i = hash_lookup (h, key, &hash);
  5494   if (i >= 0)
  5495     set_hash_value_slot (h, i, value);
  5496   else
  5497     hash_put (h, key, value, hash);
  5498 
  5499   return value;
  5500 }
  5501 
  5502 
  5503 DEFUN ("remhash", Fremhash, Sremhash, 2, 2, 0,
  5504        doc: /* Remove KEY from TABLE.  */)
  5505   (Lisp_Object key, Lisp_Object table)
  5506 {
  5507   struct Lisp_Hash_Table *h = check_hash_table (table);
  5508   check_mutable_hash_table (table, h);
  5509   hash_remove_from_table (h, key);
  5510   return Qnil;
  5511 }
  5512 
  5513 
  5514 DEFUN ("maphash", Fmaphash, Smaphash, 2, 2, 0,
  5515        doc: /* Call FUNCTION for all entries in hash table TABLE.
  5516 FUNCTION is called with two arguments, KEY and VALUE.
  5517 `maphash' always returns nil.  */)
  5518   (Lisp_Object function, Lisp_Object table)
  5519 {
  5520   struct Lisp_Hash_Table *h = check_hash_table (table);
  5521 
  5522   for (ptrdiff_t i = 0; i < HASH_TABLE_SIZE (h); ++i)
  5523     {
  5524       Lisp_Object k = HASH_KEY (h, i);
  5525       if (!BASE_EQ (k, Qunbound))
  5526         call2 (function, k, HASH_VALUE (h, i));
  5527     }
  5528 
  5529   return Qnil;
  5530 }
  5531 
  5532 
  5533 DEFUN ("define-hash-table-test", Fdefine_hash_table_test,
  5534        Sdefine_hash_table_test, 3, 3, 0,
  5535        doc: /* Define a new hash table test with name NAME, a symbol.
  5536 
  5537 In hash tables created with NAME specified as test, use TEST to
  5538 compare keys, and HASH for computing hash codes of keys.
  5539 
  5540 TEST must be a function taking two arguments and returning non-nil if
  5541 both arguments are the same.  HASH must be a function taking one
  5542 argument and returning an object that is the hash code of the argument.
  5543 It should be the case that if (eq (funcall HASH x1) (funcall HASH x2))
  5544 returns nil, then (funcall TEST x1 x2) also returns nil.  */)
  5545   (Lisp_Object name, Lisp_Object test, Lisp_Object hash)
  5546 {
  5547   return Fput (name, Qhash_table_test, list2 (test, hash));
  5548 }
  5549 
  5550 
  5551 
  5552 /************************************************************************
  5553                         MD5, SHA-1, and SHA-2
  5554  ************************************************************************/
  5555 
  5556 #include "md5.h"
  5557 #include "sha1.h"
  5558 #include "sha256.h"
  5559 #include "sha512.h"
  5560 
  5561 /* Store into HEXBUF an unterminated hexadecimal character string
  5562    representing DIGEST, which is binary data of size DIGEST_SIZE bytes.
  5563    HEXBUF might equal DIGEST.  */
  5564 void
  5565 hexbuf_digest (char *hexbuf, void const *digest, int digest_size)
  5566 {
  5567   unsigned char const *p = digest;
  5568 
  5569   for (int i = digest_size - 1; i >= 0; i--)
  5570     {
  5571       static char const hexdigit[16] = "0123456789abcdef";
  5572       int p_i = p[i];
  5573       hexbuf[2 * i] = hexdigit[p_i >> 4];
  5574       hexbuf[2 * i + 1] = hexdigit[p_i & 0xf];
  5575     }
  5576 }
  5577 
  5578 static Lisp_Object
  5579 make_digest_string (Lisp_Object digest, int digest_size)
  5580 {
  5581   hexbuf_digest (SSDATA (digest), SDATA (digest), digest_size);
  5582   return digest;
  5583 }
  5584 
  5585 DEFUN ("secure-hash-algorithms", Fsecure_hash_algorithms,
  5586        Ssecure_hash_algorithms, 0, 0, 0,
  5587        doc: /* Return a list of all the supported `secure-hash' algorithms. */)
  5588   (void)
  5589 {
  5590   return list (Qmd5, Qsha1, Qsha224, Qsha256, Qsha384, Qsha512);
  5591 }
  5592 
  5593 /* Extract data from a string or a buffer. SPEC is a list of
  5594 (BUFFER-OR-STRING-OR-SYMBOL START END CODING-SYSTEM NOERROR) which behave as
  5595 specified with `secure-hash' and in Info node
  5596 `(elisp)Format of GnuTLS Cryptography Inputs'.  */
  5597 char *
  5598 extract_data_from_object (Lisp_Object spec,
  5599                           ptrdiff_t *start_byte,
  5600                           ptrdiff_t *end_byte)
  5601 {
  5602   Lisp_Object object = XCAR (spec);
  5603 
  5604   if (CONSP (spec)) spec = XCDR (spec);
  5605   Lisp_Object start = CAR_SAFE (spec);
  5606 
  5607   if (CONSP (spec)) spec = XCDR (spec);
  5608   Lisp_Object end = CAR_SAFE (spec);
  5609 
  5610   if (CONSP (spec)) spec = XCDR (spec);
  5611   Lisp_Object coding_system = CAR_SAFE (spec);
  5612 
  5613   if (CONSP (spec)) spec = XCDR (spec);
  5614   Lisp_Object noerror = CAR_SAFE (spec);
  5615 
  5616   if (STRINGP (object))
  5617     {
  5618       if (NILP (coding_system))
  5619         {
  5620           /* Decide the coding-system to encode the data with.  */
  5621 
  5622           if (STRING_MULTIBYTE (object))
  5623             /* use default, we can't guess correct value */
  5624             coding_system = preferred_coding_system ();
  5625           else
  5626             coding_system = Qraw_text;
  5627         }
  5628 
  5629       if (NILP (Fcoding_system_p (coding_system)))
  5630         {
  5631           /* Invalid coding system.  */
  5632 
  5633           if (!NILP (noerror))
  5634             coding_system = Qraw_text;
  5635           else
  5636             xsignal1 (Qcoding_system_error, coding_system);
  5637         }
  5638 
  5639       if (STRING_MULTIBYTE (object))
  5640         object = code_convert_string (object, coding_system,
  5641                                       Qnil, true, false, true);
  5642 
  5643       ptrdiff_t size = SCHARS (object), start_char, end_char;
  5644       validate_subarray (object, start, end, size, &start_char, &end_char);
  5645 
  5646       *start_byte = !start_char ? 0 : string_char_to_byte (object, start_char);
  5647       *end_byte = (end_char == size
  5648                    ? SBYTES (object)
  5649                    : string_char_to_byte (object, end_char));
  5650     }
  5651   else if (BUFFERP (object))
  5652     {
  5653       struct buffer *prev = current_buffer;
  5654       EMACS_INT b, e;
  5655 
  5656       record_unwind_current_buffer ();
  5657 
  5658       struct buffer *bp = XBUFFER (object);
  5659       set_buffer_internal (bp);
  5660 
  5661       b = !NILP (start) ? fix_position (start) : BEGV;
  5662       e = !NILP (end) ? fix_position (end) : ZV;
  5663       if (b > e)
  5664         {
  5665           EMACS_INT temp = b;
  5666           b = e;
  5667           e = temp;
  5668         }
  5669 
  5670       if (!(BEGV <= b && e <= ZV))
  5671         args_out_of_range (start, end);
  5672 
  5673       if (NILP (coding_system))
  5674         {
  5675           /* Decide the coding-system to encode the data with.
  5676              See fileio.c:Fwrite-region */
  5677 
  5678           if (!NILP (Vcoding_system_for_write))
  5679             coding_system = Vcoding_system_for_write;
  5680           else
  5681             {
  5682               bool force_raw_text = false;
  5683 
  5684               coding_system = BVAR (XBUFFER (object), buffer_file_coding_system);
  5685               if (NILP (coding_system)
  5686                   || NILP (Flocal_variable_p (Qbuffer_file_coding_system, Qnil)))
  5687                 {
  5688                   coding_system = Qnil;
  5689                   if (NILP (BVAR (current_buffer, enable_multibyte_characters)))
  5690                     force_raw_text = true;
  5691                 }
  5692 
  5693               if (NILP (coding_system) && !NILP (Fbuffer_file_name (object)))
  5694                 {
  5695                   /* Check file-coding-system-alist.  */
  5696                   Lisp_Object val = CALLN (Ffind_operation_coding_system,
  5697                                            Qwrite_region,
  5698                                            make_fixnum (b), make_fixnum (e),
  5699                                            Fbuffer_file_name (object));
  5700                   if (CONSP (val) && !NILP (XCDR (val)))
  5701                     coding_system = XCDR (val);
  5702                 }
  5703 
  5704               if (NILP (coding_system)
  5705                   && !NILP (BVAR (XBUFFER (object), buffer_file_coding_system)))
  5706                 {
  5707                   /* If we still have not decided a coding system, use the
  5708                      default value of buffer-file-coding-system.  */
  5709                   coding_system = BVAR (XBUFFER (object), buffer_file_coding_system);
  5710                 }
  5711 
  5712               if (!force_raw_text
  5713                   && !NILP (Ffboundp (Vselect_safe_coding_system_function)))
  5714                 /* Confirm that VAL can surely encode the current region.  */
  5715                 coding_system = call4 (Vselect_safe_coding_system_function,
  5716                                        make_fixnum (b), make_fixnum (e),
  5717                                        coding_system, Qnil);
  5718 
  5719               if (force_raw_text)
  5720                 coding_system = Qraw_text;
  5721             }
  5722 
  5723           if (NILP (Fcoding_system_p (coding_system)))
  5724             {
  5725               /* Invalid coding system.  */
  5726 
  5727               if (!NILP (noerror))
  5728                 coding_system = Qraw_text;
  5729               else
  5730                 xsignal1 (Qcoding_system_error, coding_system);
  5731             }
  5732         }
  5733 
  5734       object = make_buffer_string (b, e, false);
  5735       set_buffer_internal (prev);
  5736       /* Discard the unwind protect for recovering the current
  5737          buffer.  */
  5738       specpdl_ptr--;
  5739 
  5740       if (STRING_MULTIBYTE (object))
  5741         object = code_convert_string (object, coding_system,
  5742                                       Qnil, true, false, false);
  5743       *start_byte = 0;
  5744       *end_byte = SBYTES (object);
  5745     }
  5746   else if (EQ (object, Qiv_auto))
  5747     {
  5748       /* Format: (iv-auto REQUIRED-LENGTH).  */
  5749 
  5750       if (! FIXNATP (start))
  5751         error ("Without a length, `iv-auto' can't be used; see ELisp manual");
  5752       else
  5753         {
  5754           EMACS_INT start_hold = XFIXNAT (start);
  5755           object = make_uninit_string (start_hold);
  5756           char *lim = SSDATA (object) + start_hold;
  5757           for (char *p = SSDATA (object); p < lim; p++)
  5758             {
  5759               ssize_t gotten = getrandom (p, lim - p, 0);
  5760               if (0 <= gotten)
  5761                 p += gotten;
  5762               else if (errno != EINTR)
  5763                 report_file_error ("Getting random data", Qnil);
  5764             }
  5765 
  5766           *start_byte = 0;
  5767           *end_byte = start_hold;
  5768         }
  5769     }
  5770 
  5771   if (!STRINGP (object))
  5772     signal_error ("Invalid object argument",
  5773                   NILP (object) ? build_string ("nil") : object);
  5774   return SSDATA (object);
  5775 }
  5776 
  5777 
  5778 /* ALGORITHM is a symbol: md5, sha1, sha224 and so on. */
  5779 
  5780 static Lisp_Object
  5781 secure_hash (Lisp_Object algorithm, Lisp_Object object, Lisp_Object start,
  5782              Lisp_Object end, Lisp_Object coding_system, Lisp_Object noerror,
  5783              Lisp_Object binary)
  5784 {
  5785   ptrdiff_t start_byte, end_byte;
  5786   int digest_size;
  5787   void *(*hash_func) (const char *, size_t, void *);
  5788   Lisp_Object digest;
  5789 
  5790   CHECK_SYMBOL (algorithm);
  5791 
  5792   Lisp_Object spec = list5 (object, start, end, coding_system, noerror);
  5793 
  5794   const char *input = extract_data_from_object (spec, &start_byte, &end_byte);
  5795 
  5796   if (input == NULL)
  5797     error ("secure_hash: failed to extract data from object, aborting!");
  5798 
  5799   if (EQ (algorithm, Qmd5))
  5800     {
  5801       digest_size = MD5_DIGEST_SIZE;
  5802       hash_func   = md5_buffer;
  5803     }
  5804   else if (EQ (algorithm, Qsha1))
  5805     {
  5806       digest_size = SHA1_DIGEST_SIZE;
  5807       hash_func   = sha1_buffer;
  5808     }
  5809   else if (EQ (algorithm, Qsha224))
  5810     {
  5811       digest_size = SHA224_DIGEST_SIZE;
  5812       hash_func   = sha224_buffer;
  5813     }
  5814   else if (EQ (algorithm, Qsha256))
  5815     {
  5816       digest_size = SHA256_DIGEST_SIZE;
  5817       hash_func   = sha256_buffer;
  5818     }
  5819   else if (EQ (algorithm, Qsha384))
  5820     {
  5821       digest_size = SHA384_DIGEST_SIZE;
  5822       hash_func   = sha384_buffer;
  5823     }
  5824   else if (EQ (algorithm, Qsha512))
  5825     {
  5826       digest_size = SHA512_DIGEST_SIZE;
  5827       hash_func   = sha512_buffer;
  5828     }
  5829   else
  5830     error ("Invalid algorithm arg: %s", SDATA (Fsymbol_name (algorithm)));
  5831 
  5832   /* allocate 2 x digest_size so that it can be re-used to hold the
  5833      hexified value */
  5834   digest = make_uninit_string (digest_size * 2);
  5835 
  5836   hash_func (input + start_byte,
  5837              end_byte - start_byte,
  5838              SSDATA (digest));
  5839 
  5840   if (NILP (binary))
  5841     return make_digest_string (digest, digest_size);
  5842   else
  5843     return make_unibyte_string (SSDATA (digest), digest_size);
  5844 }
  5845 
  5846 DEFUN ("md5", Fmd5, Smd5, 1, 5, 0,
  5847        doc: /* Return MD5 message digest of OBJECT, a buffer or string.
  5848 
  5849 A message digest is the string representation of the cryptographic checksum
  5850 of a document, and the algorithm to calculate it is defined in RFC 1321.
  5851 The MD5 digest is 32-character long.
  5852 
  5853 The two optional arguments START and END are character positions
  5854 specifying for which part of OBJECT the message digest should be
  5855 computed.  If nil or omitted, the digest is computed for the whole
  5856 OBJECT.
  5857 
  5858 The MD5 message digest is computed from the result of encoding the
  5859 text in a coding system, not directly from the internal Emacs form of
  5860 the text.  The optional fourth argument CODING-SYSTEM specifies which
  5861 coding system to encode the text with.  It should be the same coding
  5862 system that you used or will use when actually writing the text into a
  5863 file.
  5864 
  5865 If CODING-SYSTEM is nil or omitted, the default depends on OBJECT.  If
  5866 OBJECT is a buffer, the default for CODING-SYSTEM is whatever coding
  5867 system would be chosen by default for writing this text into a file.
  5868 
  5869 If OBJECT is a string, the most preferred coding system (see the
  5870 command `prefer-coding-system') is used.
  5871 
  5872 If NOERROR is non-nil, silently assume the `raw-text' coding if the
  5873 guesswork fails.  Normally, an error is signaled in such case.
  5874 
  5875 Note that MD5 is not collision resistant and should not be used for
  5876 anything security-related.  See `secure-hash' for alternatives.  */)
  5877   (Lisp_Object object, Lisp_Object start, Lisp_Object end, Lisp_Object coding_system, Lisp_Object noerror)
  5878 {
  5879   return secure_hash (Qmd5, object, start, end, coding_system, noerror, Qnil);
  5880 }
  5881 
  5882 DEFUN ("secure-hash", Fsecure_hash, Ssecure_hash, 2, 5, 0,
  5883        doc: /* Return the secure hash of OBJECT, a buffer or string.
  5884 ALGORITHM is a symbol specifying the hash to use:
  5885 - md5    corresponds to MD5, produces a 32-character signature
  5886 - sha1   corresponds to SHA-1, produces a 40-character signature
  5887 - sha224 corresponds to SHA-2 (SHA-224), produces a 56-character signature
  5888 - sha256 corresponds to SHA-2 (SHA-256), produces a 64-character signature
  5889 - sha384 corresponds to SHA-2 (SHA-384), produces a 96-character signature
  5890 - sha512 corresponds to SHA-2 (SHA-512), produces a 128-character signature
  5891 
  5892 The two optional arguments START and END are positions specifying for
  5893 which part of OBJECT to compute the hash.  If nil or omitted, uses the
  5894 whole OBJECT.
  5895 
  5896 The full list of algorithms can be obtained with `secure-hash-algorithms'.
  5897 
  5898 If BINARY is non-nil, returns a string in binary form.
  5899 
  5900 Note that MD5 and SHA-1 are not collision resistant and should not be
  5901 used for anything security-related.  For these applications, use one
  5902 of the other hash types instead, e.g. sha256 or sha512.  */)
  5903   (Lisp_Object algorithm, Lisp_Object object, Lisp_Object start, Lisp_Object end, Lisp_Object binary)
  5904 {
  5905   return secure_hash (algorithm, object, start, end, Qnil, Qnil, binary);
  5906 }
  5907 
  5908 DEFUN ("buffer-hash", Fbuffer_hash, Sbuffer_hash, 0, 1, 0,
  5909        doc: /* Return a hash of the contents of BUFFER-OR-NAME.
  5910 This hash is performed on the raw internal format of the buffer,
  5911 disregarding any coding systems.  If nil, use the current buffer.
  5912 
  5913 This function is useful for comparing two buffers running in the same
  5914 Emacs, but is not guaranteed to return the same hash between different
  5915 Emacs versions.  It should be somewhat more efficient on larger
  5916 buffers than `secure-hash' is, and should not allocate more memory.
  5917 
  5918 It should not be used for anything security-related.  See
  5919 `secure-hash' for these applications.  */ )
  5920   (Lisp_Object buffer_or_name)
  5921 {
  5922   Lisp_Object buffer;
  5923   struct buffer *b;
  5924   struct sha1_ctx ctx;
  5925 
  5926   if (NILP (buffer_or_name))
  5927     buffer = Fcurrent_buffer ();
  5928   else
  5929     buffer = Fget_buffer (buffer_or_name);
  5930   if (NILP (buffer))
  5931     nsberror (buffer_or_name);
  5932 
  5933   b = XBUFFER (buffer);
  5934   sha1_init_ctx (&ctx);
  5935 
  5936   /* Process the first part of the buffer. */
  5937   sha1_process_bytes (BUF_BEG_ADDR (b),
  5938                       BUF_GPT_BYTE (b) - BUF_BEG_BYTE (b),
  5939                       &ctx);
  5940 
  5941   /* If the gap is before the end of the buffer, process the last half
  5942      of the buffer. */
  5943   if (BUF_GPT_BYTE (b) < BUF_Z_BYTE (b))
  5944     sha1_process_bytes (BUF_GAP_END_ADDR (b),
  5945                         BUF_Z_ADDR (b) - BUF_GAP_END_ADDR (b),
  5946                         &ctx);
  5947 
  5948   Lisp_Object digest = make_uninit_string (SHA1_DIGEST_SIZE * 2);
  5949   sha1_finish_ctx (&ctx, SSDATA (digest));
  5950   return make_digest_string (digest, SHA1_DIGEST_SIZE);
  5951 }
  5952 
  5953 DEFUN ("buffer-line-statistics", Fbuffer_line_statistics,
  5954        Sbuffer_line_statistics, 0, 1, 0,
  5955        doc: /* Return data about lines in BUFFER.
  5956 The data is returned as a list, and the first element is the number of
  5957 lines in the buffer, the second is the length of the longest line, and
  5958 the third is the mean line length.  The lengths returned are in bytes, not
  5959 characters.  */ )
  5960   (Lisp_Object buffer_or_name)
  5961 {
  5962   Lisp_Object buffer;
  5963   ptrdiff_t lines = 0, longest = 0;
  5964   double mean = 0;
  5965   struct buffer *b;
  5966 
  5967   if (NILP (buffer_or_name))
  5968     buffer = Fcurrent_buffer ();
  5969   else
  5970     buffer = Fget_buffer (buffer_or_name);
  5971   if (NILP (buffer))
  5972     nsberror (buffer_or_name);
  5973 
  5974   b = XBUFFER (buffer);
  5975 
  5976   unsigned char *start = BUF_BEG_ADDR (b);
  5977   ptrdiff_t area = BUF_GPT_BYTE (b) - BUF_BEG_BYTE (b), pre_gap = 0;
  5978 
  5979   /* Process the first part of the buffer. */
  5980   while (area > 0)
  5981     {
  5982       unsigned char *n = memchr (start, '\n', area);
  5983 
  5984       if (n)
  5985         {
  5986           ptrdiff_t this_line = n - start;
  5987           if (this_line > longest)
  5988             longest = this_line;
  5989           lines++;
  5990           /* Blame Knuth. */
  5991           mean = mean + (this_line - mean) / lines;
  5992           area = area - this_line - 1;
  5993           start += this_line + 1;
  5994         }
  5995       else
  5996         {
  5997           /* Didn't have a newline here, so save the rest for the
  5998              post-gap calculation. */
  5999           pre_gap = area;
  6000           area = 0;
  6001         }
  6002     }
  6003 
  6004   /* If the gap is before the end of the buffer, process the last half
  6005      of the buffer. */
  6006   if (BUF_GPT_BYTE (b) < BUF_Z_BYTE (b))
  6007     {
  6008       start = BUF_GAP_END_ADDR (b);
  6009       area = BUF_Z_ADDR (b) - BUF_GAP_END_ADDR (b);
  6010 
  6011       while (area > 0)
  6012         {
  6013           unsigned char *n = memchr (start, '\n', area);
  6014           ptrdiff_t this_line = n? n - start + pre_gap: area + pre_gap;
  6015 
  6016           if (this_line > longest)
  6017             longest = this_line;
  6018           lines++;
  6019           /* Blame Knuth again. */
  6020           mean = mean + (this_line - mean) / lines;
  6021           area = area - this_line - 1;
  6022           start += this_line + 1;
  6023           pre_gap = 0;
  6024         }
  6025     }
  6026   else if (pre_gap > 0)
  6027     {
  6028       if (pre_gap > longest)
  6029         longest = pre_gap;
  6030       lines++;
  6031       mean = mean + (pre_gap - mean) / lines;
  6032     }
  6033 
  6034   return list3 (make_int (lines), make_int (longest), make_float (mean));
  6035 }
  6036 
  6037 DEFUN ("string-search", Fstring_search, Sstring_search, 2, 3, 0,
  6038        doc: /* Search for the string NEEDLE in the string HAYSTACK.
  6039 The return value is the position of the first occurrence of NEEDLE in
  6040 HAYSTACK, or nil if no match was found.
  6041 
  6042 The optional START-POS argument says where to start searching in
  6043 HAYSTACK and defaults to zero (start at the beginning).
  6044 It must be between zero and the length of HAYSTACK, inclusive.
  6045 
  6046 Case is always significant and text properties are ignored. */)
  6047   (register Lisp_Object needle, Lisp_Object haystack, Lisp_Object start_pos)
  6048 {
  6049   ptrdiff_t start_byte = 0, haybytes;
  6050   char *res, *haystart;
  6051   EMACS_INT start = 0;
  6052 
  6053   CHECK_STRING (needle);
  6054   CHECK_STRING (haystack);
  6055 
  6056   if (!NILP (start_pos))
  6057     {
  6058       CHECK_FIXNUM (start_pos);
  6059       start = XFIXNUM (start_pos);
  6060       if (start < 0 || start > SCHARS (haystack))
  6061         xsignal1 (Qargs_out_of_range, start_pos);
  6062       start_byte = string_char_to_byte (haystack, start);
  6063     }
  6064 
  6065   /* If NEEDLE is longer than (the remaining length of) haystack, then
  6066      we can't have a match, and return early.  */
  6067   if (SCHARS (needle) > SCHARS (haystack) - start)
  6068     return Qnil;
  6069 
  6070   haystart = SSDATA (haystack) + start_byte;
  6071   haybytes = SBYTES (haystack) - start_byte;
  6072 
  6073   /* We can do a direct byte-string search if both strings have the
  6074      same multibyteness, or if the needle consists of ASCII characters only.  */
  6075   if (STRING_MULTIBYTE (haystack)
  6076       ? (STRING_MULTIBYTE (needle)
  6077          || SCHARS (haystack) == SBYTES (haystack) || string_ascii_p (needle))
  6078       : (!STRING_MULTIBYTE (needle)
  6079          || SCHARS (needle) == SBYTES (needle)))
  6080     {
  6081       if (STRING_MULTIBYTE (haystack) && STRING_MULTIBYTE (needle)
  6082           && SCHARS (haystack) == SBYTES (haystack)
  6083           && SCHARS (needle) != SBYTES (needle))
  6084         /* Multibyte non-ASCII needle, multibyte ASCII haystack: impossible.  */
  6085         return Qnil;
  6086       else
  6087         res = memmem (haystart, haybytes,
  6088                       SSDATA (needle), SBYTES (needle));
  6089     }
  6090   else if (STRING_MULTIBYTE (haystack))  /* unibyte non-ASCII needle */
  6091     {
  6092       Lisp_Object multi_needle = string_to_multibyte (needle);
  6093       res = memmem (haystart, haybytes,
  6094                     SSDATA (multi_needle), SBYTES (multi_needle));
  6095     }
  6096   else              /* unibyte haystack, multibyte non-ASCII needle */
  6097     {
  6098       /* The only possible way we can find the multibyte needle in the
  6099          unibyte stack (since we know that the needle is non-ASCII) is
  6100          if they contain "raw bytes" (and no other non-ASCII chars.)  */
  6101       ptrdiff_t nbytes = SBYTES (needle);
  6102       for (ptrdiff_t i = 0; i < nbytes; i++)
  6103         {
  6104           int c = SREF (needle, i);
  6105           if (CHAR_BYTE8_HEAD_P (c))
  6106             i++;                /* Skip raw byte.  */
  6107           else if (!ASCII_CHAR_P (c))
  6108             return Qnil;  /* Found a char that can't be in the haystack.  */
  6109         }
  6110 
  6111       /* "Raw bytes" (aka eighth-bit) are represented differently in
  6112          multibyte and unibyte strings.  */
  6113       Lisp_Object uni_needle = Fstring_to_unibyte (needle);
  6114       res = memmem (haystart, haybytes,
  6115                     SSDATA (uni_needle), SBYTES (uni_needle));
  6116     }
  6117 
  6118   if (! res)
  6119     return Qnil;
  6120 
  6121   return make_int (string_byte_to_char (haystack, res - SSDATA (haystack)));
  6122 }
  6123 
  6124 DEFUN ("object-intervals", Fobject_intervals, Sobject_intervals, 1, 1, 0,
  6125        doc: /* Return a copy of the text properties of OBJECT.
  6126 OBJECT must be a buffer or a string.
  6127 
  6128 Altering this copy does not change the layout of the text properties
  6129 in OBJECT.  */)
  6130   (register Lisp_Object object)
  6131 {
  6132   Lisp_Object collector = Fcons (Qnil, Qnil);
  6133   INTERVAL intervals;
  6134 
  6135   if (STRINGP (object))
  6136     intervals = string_intervals (object);
  6137   else if (BUFFERP (object))
  6138     intervals = buffer_intervals (XBUFFER (object));
  6139   else
  6140     wrong_type_argument (Qbuffer_or_string_p, object);
  6141 
  6142   if (! intervals)
  6143     return Qnil;
  6144 
  6145   traverse_intervals (intervals, 0, collect_interval, collector);
  6146   return CDR (collector);
  6147 }
  6148 
  6149 DEFUN ("line-number-at-pos", Fline_number_at_pos,
  6150        Sline_number_at_pos, 0, 2, 0,
  6151        doc: /* Return the line number at POSITION in the current buffer.
  6152 If POSITION is nil or omitted, it defaults to point's position in the
  6153 current buffer.
  6154 
  6155 If the buffer is narrowed, the return value by default counts the lines
  6156 from the beginning of the accessible portion of the buffer.  But if the
  6157 second optional argument ABSOLUTE is non-nil, the value counts the lines
  6158 from the absolute start of the buffer, disregarding the narrowing.  */)
  6159   (register Lisp_Object position, Lisp_Object absolute)
  6160 {
  6161   ptrdiff_t pos_byte, start_byte = BEGV_BYTE;
  6162 
  6163   if (MARKERP (position))
  6164     {
  6165       /* We don't trust the byte position if the marker's buffer is
  6166          not the current buffer.  */
  6167       if (XMARKER (position)->buffer != current_buffer)
  6168         pos_byte = CHAR_TO_BYTE (marker_position (position));
  6169       else
  6170         pos_byte = marker_byte_position (position);
  6171     }
  6172   else if (NILP (position))
  6173     pos_byte = PT_BYTE;
  6174   else
  6175     {
  6176       CHECK_FIXNUM (position);
  6177       ptrdiff_t pos = XFIXNUM (position);
  6178       /* Check that POSITION is valid. */
  6179       if (pos < BEG || pos > Z)
  6180         args_out_of_range_3 (position, make_int (BEG), make_int (Z));
  6181       pos_byte = CHAR_TO_BYTE (pos);
  6182     }
  6183 
  6184   if (!NILP (absolute))
  6185     start_byte = BEG_BYTE;
  6186   else if (NILP (absolute))
  6187     pos_byte = clip_to_bounds (BEGV_BYTE, pos_byte, ZV_BYTE);
  6188 
  6189   /* Check that POSITION is valid. */
  6190   if (pos_byte < BEG_BYTE || pos_byte > Z_BYTE)
  6191     args_out_of_range_3 (make_int (BYTE_TO_CHAR (pos_byte)),
  6192                          make_int (BEG), make_int (Z));
  6193 
  6194   return make_int (count_lines (start_byte, pos_byte) + 1);
  6195 }
  6196 
  6197 
  6198 void
  6199 syms_of_fns (void)
  6200 {
  6201   /* Hash table stuff.  */
  6202   DEFSYM (Qhash_table_p, "hash-table-p");
  6203   DEFSYM (Qeq, "eq");
  6204   DEFSYM (Qeql, "eql");
  6205   DEFSYM (Qequal, "equal");
  6206   DEFSYM (QCtest, ":test");
  6207   DEFSYM (QCsize, ":size");
  6208   DEFSYM (QCpurecopy, ":purecopy");
  6209   DEFSYM (QCrehash_size, ":rehash-size");
  6210   DEFSYM (QCrehash_threshold, ":rehash-threshold");
  6211   DEFSYM (QCweakness, ":weakness");
  6212   DEFSYM (Qkey, "key");
  6213   DEFSYM (Qvalue, "value");
  6214   DEFSYM (Qhash_table_test, "hash-table-test");
  6215   DEFSYM (Qkey_or_value, "key-or-value");
  6216   DEFSYM (Qkey_and_value, "key-and-value");
  6217 
  6218   defsubr (&Ssxhash_eq);
  6219   defsubr (&Ssxhash_eql);
  6220   defsubr (&Ssxhash_equal);
  6221   defsubr (&Ssxhash_equal_including_properties);
  6222   defsubr (&Smake_hash_table);
  6223   defsubr (&Scopy_hash_table);
  6224   defsubr (&Shash_table_count);
  6225   defsubr (&Shash_table_rehash_size);
  6226   defsubr (&Shash_table_rehash_threshold);
  6227   defsubr (&Shash_table_size);
  6228   defsubr (&Shash_table_test);
  6229   defsubr (&Shash_table_weakness);
  6230   defsubr (&Shash_table_p);
  6231   defsubr (&Sclrhash);
  6232   defsubr (&Sgethash);
  6233   defsubr (&Sputhash);
  6234   defsubr (&Sremhash);
  6235   defsubr (&Smaphash);
  6236   defsubr (&Sdefine_hash_table_test);
  6237   defsubr (&Sstring_search);
  6238   defsubr (&Sobject_intervals);
  6239   defsubr (&Sline_number_at_pos);
  6240 
  6241   /* Crypto and hashing stuff.  */
  6242   DEFSYM (Qiv_auto, "iv-auto");
  6243 
  6244   DEFSYM (Qmd5,    "md5");
  6245   DEFSYM (Qsha1,   "sha1");
  6246   DEFSYM (Qsha224, "sha224");
  6247   DEFSYM (Qsha256, "sha256");
  6248   DEFSYM (Qsha384, "sha384");
  6249   DEFSYM (Qsha512, "sha512");
  6250 
  6251   /* Miscellaneous stuff.  */
  6252 
  6253   DEFSYM (Qstring_lessp, "string-lessp");
  6254   DEFSYM (Qprovide, "provide");
  6255   DEFSYM (Qrequire, "require");
  6256   DEFSYM (Qyes_or_no_p_history, "yes-or-no-p-history");
  6257   DEFSYM (Qcursor_in_echo_area, "cursor-in-echo-area");
  6258   DEFSYM (Qwidget_type, "widget-type");
  6259 
  6260   DEFVAR_LISP ("overriding-plist-environment", Voverriding_plist_environment,
  6261                doc: /* An alist that overrides the plists of the symbols which it lists.
  6262 Used by the byte-compiler to apply `define-symbol-prop' during
  6263 compilation.  */);
  6264   Voverriding_plist_environment = Qnil;
  6265   DEFSYM (Qoverriding_plist_environment, "overriding-plist-environment");
  6266 
  6267   staticpro (&string_char_byte_cache_string);
  6268   string_char_byte_cache_string = Qnil;
  6269 
  6270   require_nesting_list = Qnil;
  6271   staticpro (&require_nesting_list);
  6272 
  6273   Fset (Qyes_or_no_p_history, Qnil);
  6274 
  6275   DEFVAR_LISP ("features", Vfeatures,
  6276     doc: /* A list of symbols which are the features of the executing Emacs.
  6277 Used by `featurep' and `require', and altered by `provide'.  */);
  6278   Vfeatures = list1 (Qemacs);
  6279   DEFSYM (Qfeatures, "features");
  6280   /* Let people use lexically scoped vars named `features'.  */
  6281   Fmake_var_non_special (Qfeatures);
  6282   DEFSYM (Qsubfeatures, "subfeatures");
  6283   DEFSYM (Qfuncall, "funcall");
  6284   DEFSYM (Qplistp, "plistp");
  6285   DEFSYM (Qlist_or_vector_p, "list-or-vector-p");
  6286 
  6287 #ifdef HAVE_LANGINFO_CODESET
  6288   DEFSYM (Qcodeset, "codeset");
  6289   DEFSYM (Qdays, "days");
  6290   DEFSYM (Qmonths, "months");
  6291   DEFSYM (Qpaper, "paper");
  6292 #endif  /* HAVE_LANGINFO_CODESET */
  6293 
  6294   DEFVAR_BOOL ("use-dialog-box", use_dialog_box,
  6295     doc: /* Non-nil means mouse commands use dialog boxes to ask questions.
  6296 This applies to `y-or-n-p' and `yes-or-no-p' questions asked by commands
  6297 invoked by mouse clicks and mouse menu items.
  6298 
  6299 On some platforms, file selection dialogs are also enabled if this is
  6300 non-nil.  */);
  6301   use_dialog_box = true;
  6302 
  6303   DEFVAR_BOOL ("use-file-dialog", use_file_dialog,
  6304     doc: /* Non-nil means mouse commands use a file dialog to ask for files.
  6305 This applies to commands from menus and tool bar buttons even when
  6306 they are initiated from the keyboard.  If `use-dialog-box' is nil,
  6307 that disables the use of a file dialog, regardless of the value of
  6308 this variable.  */);
  6309   use_file_dialog = true;
  6310 
  6311   DEFVAR_BOOL ("use-short-answers", use_short_answers,
  6312     doc: /* Non-nil means `yes-or-no-p' uses shorter answers "y" or "n".
  6313 When non-nil, `yes-or-no-p' will use `y-or-n-p' to read the answer.
  6314 We recommend against setting this variable non-nil, because `yes-or-no-p'
  6315 is intended to be used when users are expected not to respond too
  6316 quickly, but to take their time and perhaps think about the answer.
  6317 The same variable also affects the function `read-answer'.  See also
  6318 `yes-or-no-prompt'.  */);
  6319   use_short_answers = false;
  6320 
  6321   DEFVAR_LISP ("yes-or-no-prompt", Vyes_or_no_prompt,
  6322     doc: /* String to append when `yes-or-no-p' asks a question.
  6323 For best results this should end in a space.  */);
  6324   Vyes_or_no_prompt = make_unibyte_string ("(yes or no) ", strlen ("(yes or no) "));
  6325 
  6326   defsubr (&Sidentity);
  6327   defsubr (&Srandom);
  6328   defsubr (&Slength);
  6329   defsubr (&Ssafe_length);
  6330   defsubr (&Slength_less);
  6331   defsubr (&Slength_greater);
  6332   defsubr (&Slength_equal);
  6333   defsubr (&Sproper_list_p);
  6334   defsubr (&Sstring_bytes);
  6335   defsubr (&Sstring_distance);
  6336   defsubr (&Sstring_equal);
  6337   defsubr (&Scompare_strings);
  6338   defsubr (&Sstring_lessp);
  6339   defsubr (&Sstring_version_lessp);
  6340   defsubr (&Sstring_collate_lessp);
  6341   defsubr (&Sstring_collate_equalp);
  6342   defsubr (&Sappend);
  6343   defsubr (&Sconcat);
  6344   defsubr (&Svconcat);
  6345   defsubr (&Scopy_sequence);
  6346   defsubr (&Sstring_make_multibyte);
  6347   defsubr (&Sstring_make_unibyte);
  6348   defsubr (&Sstring_as_multibyte);
  6349   defsubr (&Sstring_as_unibyte);
  6350   defsubr (&Sstring_to_multibyte);
  6351   defsubr (&Sstring_to_unibyte);
  6352   defsubr (&Scopy_alist);
  6353   defsubr (&Ssubstring);
  6354   defsubr (&Ssubstring_no_properties);
  6355   defsubr (&Stake);
  6356   defsubr (&Sntake);
  6357   defsubr (&Snthcdr);
  6358   defsubr (&Snth);
  6359   defsubr (&Selt);
  6360   defsubr (&Smember);
  6361   defsubr (&Smemq);
  6362   defsubr (&Smemql);
  6363   defsubr (&Sassq);
  6364   defsubr (&Sassoc);
  6365   defsubr (&Srassq);
  6366   defsubr (&Srassoc);
  6367   defsubr (&Sdelq);
  6368   defsubr (&Sdelete);
  6369   defsubr (&Snreverse);
  6370   defsubr (&Sreverse);
  6371   defsubr (&Ssort);
  6372   defsubr (&Splist_get);
  6373   defsubr (&Sget);
  6374   defsubr (&Splist_put);
  6375   defsubr (&Sput);
  6376   defsubr (&Seql);
  6377   defsubr (&Sequal);
  6378   defsubr (&Sequal_including_properties);
  6379   defsubr (&Sfillarray);
  6380   defsubr (&Sclear_string);
  6381   defsubr (&Snconc);
  6382   defsubr (&Smapcar);
  6383   defsubr (&Smapc);
  6384   defsubr (&Smapcan);
  6385   defsubr (&Smapconcat);
  6386   defsubr (&Syes_or_no_p);
  6387   defsubr (&Sload_average);
  6388   defsubr (&Sfeaturep);
  6389   defsubr (&Srequire);
  6390   defsubr (&Sprovide);
  6391   defsubr (&Splist_member);
  6392   defsubr (&Swidget_put);
  6393   defsubr (&Swidget_get);
  6394   defsubr (&Swidget_apply);
  6395   defsubr (&Sbase64_encode_region);
  6396   defsubr (&Sbase64_decode_region);
  6397   defsubr (&Sbase64_encode_string);
  6398   defsubr (&Sbase64_decode_string);
  6399   defsubr (&Sbase64url_encode_region);
  6400   defsubr (&Sbase64url_encode_string);
  6401   defsubr (&Smd5);
  6402   defsubr (&Ssecure_hash_algorithms);
  6403   defsubr (&Ssecure_hash);
  6404   defsubr (&Sbuffer_hash);
  6405   defsubr (&Slocale_info);
  6406   defsubr (&Sbuffer_line_statistics);
  6407 
  6408   DEFSYM (Qreal_this_command, "real-this-command");
  6409   DEFSYM (Qfrom__tty_menu_p, "from--tty-menu-p");
  6410 }