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