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