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