* lisp/url/url-handlers.el: No need for subr-x at run-time.
[emacs.git] / src / fns.c
blob94b9d984f0dbbd49489c1cba1401b223cca79762
1 /* Random utility Lisp functions.
3 Copyright (C) 1985-1987, 1993-1995, 1997-2018 Free Software Foundation,
4 Inc.
6 This file is part of GNU Emacs.
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.
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.
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/>. */
21 #include <config.h>
23 #include <stdlib.h>
24 #include <unistd.h>
25 #include <filevercmp.h>
26 #include <intprops.h>
27 #include <vla.h>
28 #include <errno.h>
30 #include "lisp.h"
31 #include "character.h"
32 #include "coding.h"
33 #include "composite.h"
34 #include "buffer.h"
35 #include "intervals.h"
36 #include "window.h"
37 #include "puresize.h"
38 #include "gnutls.h"
40 #if defined WINDOWSNT && defined HAVE_GNUTLS3
41 # define gnutls_rnd w32_gnutls_rnd
42 #endif
44 static void sort_vector_copy (Lisp_Object, ptrdiff_t,
45 Lisp_Object *restrict, Lisp_Object *restrict);
46 enum equal_kind { EQUAL_NO_QUIT, EQUAL_PLAIN, EQUAL_INCLUDING_PROPERTIES };
47 static bool internal_equal (Lisp_Object, Lisp_Object,
48 enum equal_kind, int, Lisp_Object);
50 DEFUN ("identity", Fidentity, Sidentity, 1, 1, 0,
51 doc: /* Return the argument unchanged. */
52 attributes: const)
53 (Lisp_Object arg)
55 return arg;
58 DEFUN ("random", Frandom, Srandom, 0, 1, 0,
59 doc: /* Return a pseudo-random number.
60 All integers representable in Lisp, i.e. between `most-negative-fixnum'
61 and `most-positive-fixnum', inclusive, are equally likely.
63 With positive integer LIMIT, return random number in interval [0,LIMIT).
64 With argument t, set the random number seed from the system's entropy
65 pool if available, otherwise from less-random volatile data such as the time.
66 With a string argument, set the seed based on the string's contents.
67 Other values of LIMIT are ignored.
69 See Info node `(elisp)Random Numbers' for more details. */)
70 (Lisp_Object limit)
72 EMACS_INT val;
74 if (EQ (limit, Qt))
75 init_random ();
76 else if (STRINGP (limit))
77 seed_random (SSDATA (limit), SBYTES (limit));
79 val = get_random ();
80 if (INTEGERP (limit) && 0 < XINT (limit))
81 while (true)
83 /* Return the remainder, except reject the rare case where
84 get_random returns a number so close to INTMASK that the
85 remainder isn't random. */
86 EMACS_INT remainder = val % XINT (limit);
87 if (val - remainder <= INTMASK - XINT (limit) + 1)
88 return make_number (remainder);
89 val = get_random ();
91 return make_number (val);
94 /* Random data-structure functions. */
96 DEFUN ("length", Flength, Slength, 1, 1, 0,
97 doc: /* Return the length of vector, list or string SEQUENCE.
98 A byte-code function object is also allowed.
99 If the string contains multibyte characters, this is not necessarily
100 the number of bytes in the string; it is the number of characters.
101 To get the number of bytes, use `string-bytes'. */)
102 (register Lisp_Object sequence)
104 register Lisp_Object val;
106 if (STRINGP (sequence))
107 XSETFASTINT (val, SCHARS (sequence));
108 else if (VECTORP (sequence))
109 XSETFASTINT (val, ASIZE (sequence));
110 else if (CHAR_TABLE_P (sequence))
111 XSETFASTINT (val, MAX_CHAR);
112 else if (BOOL_VECTOR_P (sequence))
113 XSETFASTINT (val, bool_vector_size (sequence));
114 else if (COMPILEDP (sequence) || RECORDP (sequence))
115 XSETFASTINT (val, PVSIZE (sequence));
116 else if (CONSP (sequence))
118 intptr_t i = 0;
119 FOR_EACH_TAIL (sequence)
120 i++;
121 CHECK_LIST_END (sequence, sequence);
122 if (MOST_POSITIVE_FIXNUM < i)
123 error ("List too long");
124 val = make_number (i);
126 else if (NILP (sequence))
127 XSETFASTINT (val, 0);
128 else
129 wrong_type_argument (Qsequencep, sequence);
131 return val;
134 DEFUN ("safe-length", Fsafe_length, Ssafe_length, 1, 1, 0,
135 doc: /* Return the length of a list, but avoid error or infinite loop.
136 This function never gets an error. If LIST is not really a list,
137 it returns 0. If LIST is circular, it returns a finite value
138 which is at least the number of distinct elements. */)
139 (Lisp_Object list)
141 intptr_t len = 0;
142 FOR_EACH_TAIL_SAFE (list)
143 len++;
144 return make_fixnum_or_float (len);
147 DEFUN ("string-bytes", Fstring_bytes, Sstring_bytes, 1, 1, 0,
148 doc: /* Return the number of bytes in STRING.
149 If STRING is multibyte, this may be greater than the length of STRING. */)
150 (Lisp_Object string)
152 CHECK_STRING (string);
153 return make_number (SBYTES (string));
156 DEFUN ("string-equal", Fstring_equal, Sstring_equal, 2, 2, 0,
157 doc: /* Return t if two strings have identical contents.
158 Case is significant, but text properties are ignored.
159 Symbols are also allowed; their print names are used instead. */)
160 (register Lisp_Object s1, Lisp_Object s2)
162 if (SYMBOLP (s1))
163 s1 = SYMBOL_NAME (s1);
164 if (SYMBOLP (s2))
165 s2 = SYMBOL_NAME (s2);
166 CHECK_STRING (s1);
167 CHECK_STRING (s2);
169 if (SCHARS (s1) != SCHARS (s2)
170 || SBYTES (s1) != SBYTES (s2)
171 || memcmp (SDATA (s1), SDATA (s2), SBYTES (s1)))
172 return Qnil;
173 return Qt;
176 DEFUN ("compare-strings", Fcompare_strings, Scompare_strings, 6, 7, 0,
177 doc: /* Compare the contents of two strings, converting to multibyte if needed.
178 The arguments START1, END1, START2, and END2, if non-nil, are
179 positions specifying which parts of STR1 or STR2 to compare. In
180 string STR1, compare the part between START1 (inclusive) and END1
181 \(exclusive). If START1 is nil, it defaults to 0, the beginning of
182 the string; if END1 is nil, it defaults to the length of the string.
183 Likewise, in string STR2, compare the part between START2 and END2.
184 Like in `substring', negative values are counted from the end.
186 The strings are compared by the numeric values of their characters.
187 For instance, STR1 is "less than" STR2 if its first differing
188 character has a smaller numeric value. If IGNORE-CASE is non-nil,
189 characters are converted to upper-case before comparing them. Unibyte
190 strings are converted to multibyte for comparison.
192 The value is t if the strings (or specified portions) match.
193 If string STR1 is less, the value is a negative number N;
194 - 1 - N is the number of characters that match at the beginning.
195 If string STR1 is greater, the value is a positive number N;
196 N - 1 is the number of characters that match at the beginning. */)
197 (Lisp_Object str1, Lisp_Object start1, Lisp_Object end1, Lisp_Object str2,
198 Lisp_Object start2, Lisp_Object end2, Lisp_Object ignore_case)
200 ptrdiff_t from1, to1, from2, to2, i1, i1_byte, i2, i2_byte;
202 CHECK_STRING (str1);
203 CHECK_STRING (str2);
205 /* For backward compatibility, silently bring too-large positive end
206 values into range. */
207 if (INTEGERP (end1) && SCHARS (str1) < XINT (end1))
208 end1 = make_number (SCHARS (str1));
209 if (INTEGERP (end2) && SCHARS (str2) < XINT (end2))
210 end2 = make_number (SCHARS (str2));
212 validate_subarray (str1, start1, end1, SCHARS (str1), &from1, &to1);
213 validate_subarray (str2, start2, end2, SCHARS (str2), &from2, &to2);
215 i1 = from1;
216 i2 = from2;
218 i1_byte = string_char_to_byte (str1, i1);
219 i2_byte = string_char_to_byte (str2, i2);
221 while (i1 < to1 && i2 < to2)
223 /* When we find a mismatch, we must compare the
224 characters, not just the bytes. */
225 int c1, c2;
227 FETCH_STRING_CHAR_AS_MULTIBYTE_ADVANCE (c1, str1, i1, i1_byte);
228 FETCH_STRING_CHAR_AS_MULTIBYTE_ADVANCE (c2, str2, i2, i2_byte);
230 if (c1 == c2)
231 continue;
233 if (! NILP (ignore_case))
235 c1 = XINT (Fupcase (make_number (c1)));
236 c2 = XINT (Fupcase (make_number (c2)));
239 if (c1 == c2)
240 continue;
242 /* Note that I1 has already been incremented
243 past the character that we are comparing;
244 hence we don't add or subtract 1 here. */
245 if (c1 < c2)
246 return make_number (- i1 + from1);
247 else
248 return make_number (i1 - from1);
251 if (i1 < to1)
252 return make_number (i1 - from1 + 1);
253 if (i2 < to2)
254 return make_number (- i1 + from1 - 1);
256 return Qt;
259 DEFUN ("string-lessp", Fstring_lessp, Sstring_lessp, 2, 2, 0,
260 doc: /* Return non-nil if STRING1 is less than STRING2 in lexicographic order.
261 Case is significant.
262 Symbols are also allowed; their print names are used instead. */)
263 (register Lisp_Object string1, Lisp_Object string2)
265 register ptrdiff_t end;
266 register ptrdiff_t i1, i1_byte, i2, i2_byte;
268 if (SYMBOLP (string1))
269 string1 = SYMBOL_NAME (string1);
270 if (SYMBOLP (string2))
271 string2 = SYMBOL_NAME (string2);
272 CHECK_STRING (string1);
273 CHECK_STRING (string2);
275 i1 = i1_byte = i2 = i2_byte = 0;
277 end = SCHARS (string1);
278 if (end > SCHARS (string2))
279 end = SCHARS (string2);
281 while (i1 < end)
283 /* When we find a mismatch, we must compare the
284 characters, not just the bytes. */
285 int c1, c2;
287 FETCH_STRING_CHAR_ADVANCE (c1, string1, i1, i1_byte);
288 FETCH_STRING_CHAR_ADVANCE (c2, string2, i2, i2_byte);
290 if (c1 != c2)
291 return c1 < c2 ? Qt : Qnil;
293 return i1 < SCHARS (string2) ? Qt : Qnil;
296 DEFUN ("string-version-lessp", Fstring_version_lessp,
297 Sstring_version_lessp, 2, 2, 0,
298 doc: /* Return non-nil if S1 is less than S2, as version strings.
300 This function compares version strings S1 and S2:
301 1) By prefix lexicographically.
302 2) Then by version (similarly to version comparison of Debian's dpkg).
303 Leading zeros in version numbers are ignored.
304 3) If both prefix and version are equal, compare as ordinary strings.
306 For example, \"foo2.png\" compares less than \"foo12.png\".
307 Case is significant.
308 Symbols are also allowed; their print names are used instead. */)
309 (Lisp_Object string1, Lisp_Object string2)
311 if (SYMBOLP (string1))
312 string1 = SYMBOL_NAME (string1);
313 if (SYMBOLP (string2))
314 string2 = SYMBOL_NAME (string2);
315 CHECK_STRING (string1);
316 CHECK_STRING (string2);
318 char *p1 = SSDATA (string1);
319 char *p2 = SSDATA (string2);
320 char *lim1 = p1 + SBYTES (string1);
321 char *lim2 = p2 + SBYTES (string2);
322 int cmp;
324 while ((cmp = filevercmp (p1, p2)) == 0)
326 /* If the strings are identical through their first null bytes,
327 skip past identical prefixes and try again. */
328 ptrdiff_t size = strlen (p1) + 1;
329 p1 += size;
330 p2 += size;
331 if (lim1 < p1)
332 return lim2 < p2 ? Qnil : Qt;
333 if (lim2 < p2)
334 return Qnil;
337 return cmp < 0 ? Qt : Qnil;
340 DEFUN ("string-collate-lessp", Fstring_collate_lessp, Sstring_collate_lessp, 2, 4, 0,
341 doc: /* Return t if first arg string is less than second in collation order.
342 Symbols are also allowed; their print names are used instead.
344 This function obeys the conventions for collation order in your
345 locale settings. For example, punctuation and whitespace characters
346 might be considered less significant for sorting:
348 \(sort \\='("11" "12" "1 1" "1 2" "1.1" "1.2") \\='string-collate-lessp)
349 => ("11" "1 1" "1.1" "12" "1 2" "1.2")
351 The optional argument LOCALE, a string, overrides the setting of your
352 current locale identifier for collation. The value is system
353 dependent; a LOCALE \"en_US.UTF-8\" is applicable on POSIX systems,
354 while it would be, e.g., \"enu_USA.1252\" on MS-Windows systems.
356 If IGNORE-CASE is non-nil, characters are converted to lower-case
357 before comparing them.
359 To emulate Unicode-compliant collation on MS-Windows systems,
360 bind `w32-collate-ignore-punctuation' to a non-nil value, since
361 the codeset part of the locale cannot be \"UTF-8\" on MS-Windows.
363 If your system does not support a locale environment, this function
364 behaves like `string-lessp'. */)
365 (Lisp_Object s1, Lisp_Object s2, Lisp_Object locale, Lisp_Object ignore_case)
367 #if defined __STDC_ISO_10646__ || defined WINDOWSNT
368 /* Check parameters. */
369 if (SYMBOLP (s1))
370 s1 = SYMBOL_NAME (s1);
371 if (SYMBOLP (s2))
372 s2 = SYMBOL_NAME (s2);
373 CHECK_STRING (s1);
374 CHECK_STRING (s2);
375 if (!NILP (locale))
376 CHECK_STRING (locale);
378 return (str_collate (s1, s2, locale, ignore_case) < 0) ? Qt : Qnil;
380 #else /* !__STDC_ISO_10646__, !WINDOWSNT */
381 return Fstring_lessp (s1, s2);
382 #endif /* !__STDC_ISO_10646__, !WINDOWSNT */
385 DEFUN ("string-collate-equalp", Fstring_collate_equalp, Sstring_collate_equalp, 2, 4, 0,
386 doc: /* Return t if two strings have identical contents.
387 Symbols are also allowed; their print names are used instead.
389 This function obeys the conventions for collation order in your locale
390 settings. For example, characters with different coding points but
391 the same meaning might be considered as equal, like different grave
392 accent Unicode characters:
394 \(string-collate-equalp (string ?\\uFF40) (string ?\\u1FEF))
395 => t
397 The optional argument LOCALE, a string, overrides the setting of your
398 current locale identifier for collation. The value is system
399 dependent; a LOCALE \"en_US.UTF-8\" is applicable on POSIX systems,
400 while it would be \"enu_USA.1252\" on MS Windows systems.
402 If IGNORE-CASE is non-nil, characters are converted to lower-case
403 before comparing them.
405 To emulate Unicode-compliant collation on MS-Windows systems,
406 bind `w32-collate-ignore-punctuation' to a non-nil value, since
407 the codeset part of the locale cannot be \"UTF-8\" on MS-Windows.
409 If your system does not support a locale environment, this function
410 behaves like `string-equal'.
412 Do NOT use this function to compare file names for equality. */)
413 (Lisp_Object s1, Lisp_Object s2, Lisp_Object locale, Lisp_Object ignore_case)
415 #if defined __STDC_ISO_10646__ || defined WINDOWSNT
416 /* Check parameters. */
417 if (SYMBOLP (s1))
418 s1 = SYMBOL_NAME (s1);
419 if (SYMBOLP (s2))
420 s2 = SYMBOL_NAME (s2);
421 CHECK_STRING (s1);
422 CHECK_STRING (s2);
423 if (!NILP (locale))
424 CHECK_STRING (locale);
426 return (str_collate (s1, s2, locale, ignore_case) == 0) ? Qt : Qnil;
428 #else /* !__STDC_ISO_10646__, !WINDOWSNT */
429 return Fstring_equal (s1, s2);
430 #endif /* !__STDC_ISO_10646__, !WINDOWSNT */
433 static Lisp_Object concat (ptrdiff_t nargs, Lisp_Object *args,
434 enum Lisp_Type target_type, bool last_special);
436 /* ARGSUSED */
437 Lisp_Object
438 concat2 (Lisp_Object s1, Lisp_Object s2)
440 return concat (2, ((Lisp_Object []) {s1, s2}), Lisp_String, 0);
443 /* ARGSUSED */
444 Lisp_Object
445 concat3 (Lisp_Object s1, Lisp_Object s2, Lisp_Object s3)
447 return concat (3, ((Lisp_Object []) {s1, s2, s3}), Lisp_String, 0);
450 DEFUN ("append", Fappend, Sappend, 0, MANY, 0,
451 doc: /* Concatenate all the arguments and make the result a list.
452 The result is a list whose elements are the elements of all the arguments.
453 Each argument may be a list, vector or string.
454 The last argument is not copied, just used as the tail of the new list.
455 usage: (append &rest SEQUENCES) */)
456 (ptrdiff_t nargs, Lisp_Object *args)
458 return concat (nargs, args, Lisp_Cons, 1);
461 DEFUN ("concat", Fconcat, Sconcat, 0, MANY, 0,
462 doc: /* Concatenate all the arguments and make the result a string.
463 The result is a string whose elements are the elements of all the arguments.
464 Each argument may be a string or a list or vector of characters (integers).
465 usage: (concat &rest SEQUENCES) */)
466 (ptrdiff_t nargs, Lisp_Object *args)
468 return concat (nargs, args, Lisp_String, 0);
471 DEFUN ("vconcat", Fvconcat, Svconcat, 0, MANY, 0,
472 doc: /* Concatenate all the arguments and make the result a vector.
473 The result is a vector whose elements are the elements of all the arguments.
474 Each argument may be a list, vector or string.
475 usage: (vconcat &rest SEQUENCES) */)
476 (ptrdiff_t nargs, Lisp_Object *args)
478 return concat (nargs, args, Lisp_Vectorlike, 0);
482 DEFUN ("copy-sequence", Fcopy_sequence, Scopy_sequence, 1, 1, 0,
483 doc: /* Return a copy of a list, vector, string, char-table or record.
484 The elements of a list, vector or record are not copied; they are
485 shared with the original.
486 If the original sequence is empty, this function may return
487 the same empty object instead of its copy. */)
488 (Lisp_Object arg)
490 if (NILP (arg)) return arg;
492 if (RECORDP (arg))
494 return Frecord (PVSIZE (arg), XVECTOR (arg)->contents);
497 if (CHAR_TABLE_P (arg))
499 return copy_char_table (arg);
502 if (BOOL_VECTOR_P (arg))
504 EMACS_INT nbits = bool_vector_size (arg);
505 ptrdiff_t nbytes = bool_vector_bytes (nbits);
506 Lisp_Object val = make_uninit_bool_vector (nbits);
507 memcpy (bool_vector_data (val), bool_vector_data (arg), nbytes);
508 return val;
511 if (!CONSP (arg) && !VECTORP (arg) && !STRINGP (arg))
512 wrong_type_argument (Qsequencep, arg);
514 return concat (1, &arg, XTYPE (arg), 0);
517 /* This structure holds information of an argument of `concat' that is
518 a string and has text properties to be copied. */
519 struct textprop_rec
521 ptrdiff_t argnum; /* refer to ARGS (arguments of `concat') */
522 ptrdiff_t from; /* refer to ARGS[argnum] (argument string) */
523 ptrdiff_t to; /* refer to VAL (the target string) */
526 static Lisp_Object
527 concat (ptrdiff_t nargs, Lisp_Object *args,
528 enum Lisp_Type target_type, bool last_special)
530 Lisp_Object val;
531 Lisp_Object tail;
532 Lisp_Object this;
533 ptrdiff_t toindex;
534 ptrdiff_t toindex_byte = 0;
535 EMACS_INT result_len;
536 EMACS_INT result_len_byte;
537 ptrdiff_t argnum;
538 Lisp_Object last_tail;
539 Lisp_Object prev;
540 bool some_multibyte;
541 /* When we make a multibyte string, we can't copy text properties
542 while concatenating each string because the length of resulting
543 string can't be decided until we finish the whole concatenation.
544 So, we record strings that have text properties to be copied
545 here, and copy the text properties after the concatenation. */
546 struct textprop_rec *textprops = NULL;
547 /* Number of elements in textprops. */
548 ptrdiff_t num_textprops = 0;
549 USE_SAFE_ALLOCA;
551 tail = Qnil;
553 /* In append, the last arg isn't treated like the others */
554 if (last_special && nargs > 0)
556 nargs--;
557 last_tail = args[nargs];
559 else
560 last_tail = Qnil;
562 /* Check each argument. */
563 for (argnum = 0; argnum < nargs; argnum++)
565 this = args[argnum];
566 if (!(CONSP (this) || NILP (this) || VECTORP (this) || STRINGP (this)
567 || COMPILEDP (this) || BOOL_VECTOR_P (this)))
568 wrong_type_argument (Qsequencep, this);
571 /* Compute total length in chars of arguments in RESULT_LEN.
572 If desired output is a string, also compute length in bytes
573 in RESULT_LEN_BYTE, and determine in SOME_MULTIBYTE
574 whether the result should be a multibyte string. */
575 result_len_byte = 0;
576 result_len = 0;
577 some_multibyte = 0;
578 for (argnum = 0; argnum < nargs; argnum++)
580 EMACS_INT len;
581 this = args[argnum];
582 len = XFASTINT (Flength (this));
583 if (target_type == Lisp_String)
585 /* We must count the number of bytes needed in the string
586 as well as the number of characters. */
587 ptrdiff_t i;
588 Lisp_Object ch;
589 int c;
590 ptrdiff_t this_len_byte;
592 if (VECTORP (this) || COMPILEDP (this))
593 for (i = 0; i < len; i++)
595 ch = AREF (this, i);
596 CHECK_CHARACTER (ch);
597 c = XFASTINT (ch);
598 this_len_byte = CHAR_BYTES (c);
599 if (STRING_BYTES_BOUND - result_len_byte < this_len_byte)
600 string_overflow ();
601 result_len_byte += this_len_byte;
602 if (! ASCII_CHAR_P (c) && ! CHAR_BYTE8_P (c))
603 some_multibyte = 1;
605 else if (BOOL_VECTOR_P (this) && bool_vector_size (this) > 0)
606 wrong_type_argument (Qintegerp, Faref (this, make_number (0)));
607 else if (CONSP (this))
608 for (; CONSP (this); this = XCDR (this))
610 ch = XCAR (this);
611 CHECK_CHARACTER (ch);
612 c = XFASTINT (ch);
613 this_len_byte = CHAR_BYTES (c);
614 if (STRING_BYTES_BOUND - result_len_byte < this_len_byte)
615 string_overflow ();
616 result_len_byte += this_len_byte;
617 if (! ASCII_CHAR_P (c) && ! CHAR_BYTE8_P (c))
618 some_multibyte = 1;
620 else if (STRINGP (this))
622 if (STRING_MULTIBYTE (this))
624 some_multibyte = 1;
625 this_len_byte = SBYTES (this);
627 else
628 this_len_byte = count_size_as_multibyte (SDATA (this),
629 SCHARS (this));
630 if (STRING_BYTES_BOUND - result_len_byte < this_len_byte)
631 string_overflow ();
632 result_len_byte += this_len_byte;
636 result_len += len;
637 if (MOST_POSITIVE_FIXNUM < result_len)
638 memory_full (SIZE_MAX);
641 if (! some_multibyte)
642 result_len_byte = result_len;
644 /* Create the output object. */
645 if (target_type == Lisp_Cons)
646 val = Fmake_list (make_number (result_len), Qnil);
647 else if (target_type == Lisp_Vectorlike)
648 val = Fmake_vector (make_number (result_len), Qnil);
649 else if (some_multibyte)
650 val = make_uninit_multibyte_string (result_len, result_len_byte);
651 else
652 val = make_uninit_string (result_len);
654 /* In `append', if all but last arg are nil, return last arg. */
655 if (target_type == Lisp_Cons && EQ (val, Qnil))
656 return last_tail;
658 /* Copy the contents of the args into the result. */
659 if (CONSP (val))
660 tail = val, toindex = -1; /* -1 in toindex is flag we are making a list */
661 else
662 toindex = 0, toindex_byte = 0;
664 prev = Qnil;
665 if (STRINGP (val))
666 SAFE_NALLOCA (textprops, 1, nargs);
668 for (argnum = 0; argnum < nargs; argnum++)
670 Lisp_Object thislen;
671 ptrdiff_t thisleni = 0;
672 register ptrdiff_t thisindex = 0;
673 register ptrdiff_t thisindex_byte = 0;
675 this = args[argnum];
676 if (!CONSP (this))
677 thislen = Flength (this), thisleni = XINT (thislen);
679 /* Between strings of the same kind, copy fast. */
680 if (STRINGP (this) && STRINGP (val)
681 && STRING_MULTIBYTE (this) == some_multibyte)
683 ptrdiff_t thislen_byte = SBYTES (this);
685 memcpy (SDATA (val) + toindex_byte, SDATA (this), SBYTES (this));
686 if (string_intervals (this))
688 textprops[num_textprops].argnum = argnum;
689 textprops[num_textprops].from = 0;
690 textprops[num_textprops++].to = toindex;
692 toindex_byte += thislen_byte;
693 toindex += thisleni;
695 /* Copy a single-byte string to a multibyte string. */
696 else if (STRINGP (this) && STRINGP (val))
698 if (string_intervals (this))
700 textprops[num_textprops].argnum = argnum;
701 textprops[num_textprops].from = 0;
702 textprops[num_textprops++].to = toindex;
704 toindex_byte += copy_text (SDATA (this),
705 SDATA (val) + toindex_byte,
706 SCHARS (this), 0, 1);
707 toindex += thisleni;
709 else
710 /* Copy element by element. */
711 while (1)
713 register Lisp_Object elt;
715 /* Fetch next element of `this' arg into `elt', or break if
716 `this' is exhausted. */
717 if (NILP (this)) break;
718 if (CONSP (this))
719 elt = XCAR (this), this = XCDR (this);
720 else if (thisindex >= thisleni)
721 break;
722 else if (STRINGP (this))
724 int c;
725 if (STRING_MULTIBYTE (this))
726 FETCH_STRING_CHAR_ADVANCE_NO_CHECK (c, this,
727 thisindex,
728 thisindex_byte);
729 else
731 c = SREF (this, thisindex); thisindex++;
732 if (some_multibyte && !ASCII_CHAR_P (c))
733 c = BYTE8_TO_CHAR (c);
735 XSETFASTINT (elt, c);
737 else if (BOOL_VECTOR_P (this))
739 elt = bool_vector_ref (this, thisindex);
740 thisindex++;
742 else
744 elt = AREF (this, thisindex);
745 thisindex++;
748 /* Store this element into the result. */
749 if (toindex < 0)
751 XSETCAR (tail, elt);
752 prev = tail;
753 tail = XCDR (tail);
755 else if (VECTORP (val))
757 ASET (val, toindex, elt);
758 toindex++;
760 else
762 int c;
763 CHECK_CHARACTER (elt);
764 c = XFASTINT (elt);
765 if (some_multibyte)
766 toindex_byte += CHAR_STRING (c, SDATA (val) + toindex_byte);
767 else
768 SSET (val, toindex_byte++, c);
769 toindex++;
773 if (!NILP (prev))
774 XSETCDR (prev, last_tail);
776 if (num_textprops > 0)
778 Lisp_Object props;
779 ptrdiff_t last_to_end = -1;
781 for (argnum = 0; argnum < num_textprops; argnum++)
783 this = args[textprops[argnum].argnum];
784 props = text_property_list (this,
785 make_number (0),
786 make_number (SCHARS (this)),
787 Qnil);
788 /* If successive arguments have properties, be sure that the
789 value of `composition' property be the copy. */
790 if (last_to_end == textprops[argnum].to)
791 make_composition_value_copy (props);
792 add_text_properties_from_list (val, props,
793 make_number (textprops[argnum].to));
794 last_to_end = textprops[argnum].to + SCHARS (this);
798 SAFE_FREE ();
799 return val;
802 static Lisp_Object string_char_byte_cache_string;
803 static ptrdiff_t string_char_byte_cache_charpos;
804 static ptrdiff_t string_char_byte_cache_bytepos;
806 void
807 clear_string_char_byte_cache (void)
809 string_char_byte_cache_string = Qnil;
812 /* Return the byte index corresponding to CHAR_INDEX in STRING. */
814 ptrdiff_t
815 string_char_to_byte (Lisp_Object string, ptrdiff_t char_index)
817 ptrdiff_t i_byte;
818 ptrdiff_t best_below, best_below_byte;
819 ptrdiff_t best_above, best_above_byte;
821 best_below = best_below_byte = 0;
822 best_above = SCHARS (string);
823 best_above_byte = SBYTES (string);
824 if (best_above == best_above_byte)
825 return char_index;
827 if (EQ (string, string_char_byte_cache_string))
829 if (string_char_byte_cache_charpos < char_index)
831 best_below = string_char_byte_cache_charpos;
832 best_below_byte = string_char_byte_cache_bytepos;
834 else
836 best_above = string_char_byte_cache_charpos;
837 best_above_byte = string_char_byte_cache_bytepos;
841 if (char_index - best_below < best_above - char_index)
843 unsigned char *p = SDATA (string) + best_below_byte;
845 while (best_below < char_index)
847 p += BYTES_BY_CHAR_HEAD (*p);
848 best_below++;
850 i_byte = p - SDATA (string);
852 else
854 unsigned char *p = SDATA (string) + best_above_byte;
856 while (best_above > char_index)
858 p--;
859 while (!CHAR_HEAD_P (*p)) p--;
860 best_above--;
862 i_byte = p - SDATA (string);
865 string_char_byte_cache_bytepos = i_byte;
866 string_char_byte_cache_charpos = char_index;
867 string_char_byte_cache_string = string;
869 return i_byte;
872 /* Return the character index corresponding to BYTE_INDEX in STRING. */
874 ptrdiff_t
875 string_byte_to_char (Lisp_Object string, ptrdiff_t byte_index)
877 ptrdiff_t i, i_byte;
878 ptrdiff_t best_below, best_below_byte;
879 ptrdiff_t best_above, best_above_byte;
881 best_below = best_below_byte = 0;
882 best_above = SCHARS (string);
883 best_above_byte = SBYTES (string);
884 if (best_above == best_above_byte)
885 return byte_index;
887 if (EQ (string, string_char_byte_cache_string))
889 if (string_char_byte_cache_bytepos < byte_index)
891 best_below = string_char_byte_cache_charpos;
892 best_below_byte = string_char_byte_cache_bytepos;
894 else
896 best_above = string_char_byte_cache_charpos;
897 best_above_byte = string_char_byte_cache_bytepos;
901 if (byte_index - best_below_byte < best_above_byte - byte_index)
903 unsigned char *p = SDATA (string) + best_below_byte;
904 unsigned char *pend = SDATA (string) + byte_index;
906 while (p < pend)
908 p += BYTES_BY_CHAR_HEAD (*p);
909 best_below++;
911 i = best_below;
912 i_byte = p - SDATA (string);
914 else
916 unsigned char *p = SDATA (string) + best_above_byte;
917 unsigned char *pbeg = SDATA (string) + byte_index;
919 while (p > pbeg)
921 p--;
922 while (!CHAR_HEAD_P (*p)) p--;
923 best_above--;
925 i = best_above;
926 i_byte = p - SDATA (string);
929 string_char_byte_cache_bytepos = i_byte;
930 string_char_byte_cache_charpos = i;
931 string_char_byte_cache_string = string;
933 return i;
936 /* Convert STRING to a multibyte string. */
938 static Lisp_Object
939 string_make_multibyte (Lisp_Object string)
941 unsigned char *buf;
942 ptrdiff_t nbytes;
943 Lisp_Object ret;
944 USE_SAFE_ALLOCA;
946 if (STRING_MULTIBYTE (string))
947 return string;
949 nbytes = count_size_as_multibyte (SDATA (string),
950 SCHARS (string));
951 /* If all the chars are ASCII, they won't need any more bytes
952 once converted. In that case, we can return STRING itself. */
953 if (nbytes == SBYTES (string))
954 return string;
956 buf = SAFE_ALLOCA (nbytes);
957 copy_text (SDATA (string), buf, SBYTES (string),
958 0, 1);
960 ret = make_multibyte_string ((char *) buf, SCHARS (string), nbytes);
961 SAFE_FREE ();
963 return ret;
967 /* Convert STRING (if unibyte) to a multibyte string without changing
968 the number of characters. Characters 0200 trough 0237 are
969 converted to eight-bit characters. */
971 Lisp_Object
972 string_to_multibyte (Lisp_Object string)
974 unsigned char *buf;
975 ptrdiff_t nbytes;
976 Lisp_Object ret;
977 USE_SAFE_ALLOCA;
979 if (STRING_MULTIBYTE (string))
980 return string;
982 nbytes = count_size_as_multibyte (SDATA (string), SBYTES (string));
983 /* If all the chars are ASCII, they won't need any more bytes once
984 converted. */
985 if (nbytes == SBYTES (string))
986 return make_multibyte_string (SSDATA (string), nbytes, nbytes);
988 buf = SAFE_ALLOCA (nbytes);
989 memcpy (buf, SDATA (string), SBYTES (string));
990 str_to_multibyte (buf, nbytes, SBYTES (string));
992 ret = make_multibyte_string ((char *) buf, SCHARS (string), nbytes);
993 SAFE_FREE ();
995 return ret;
999 /* Convert STRING to a single-byte string. */
1001 Lisp_Object
1002 string_make_unibyte (Lisp_Object string)
1004 ptrdiff_t nchars;
1005 unsigned char *buf;
1006 Lisp_Object ret;
1007 USE_SAFE_ALLOCA;
1009 if (! STRING_MULTIBYTE (string))
1010 return string;
1012 nchars = SCHARS (string);
1014 buf = SAFE_ALLOCA (nchars);
1015 copy_text (SDATA (string), buf, SBYTES (string),
1016 1, 0);
1018 ret = make_unibyte_string ((char *) buf, nchars);
1019 SAFE_FREE ();
1021 return ret;
1024 DEFUN ("string-make-multibyte", Fstring_make_multibyte, Sstring_make_multibyte,
1025 1, 1, 0,
1026 doc: /* Return the multibyte equivalent of STRING.
1027 If STRING is unibyte and contains non-ASCII characters, the function
1028 `unibyte-char-to-multibyte' is used to convert each unibyte character
1029 to a multibyte character. In this case, the returned string is a
1030 newly created string with no text properties. If STRING is multibyte
1031 or entirely ASCII, it is returned unchanged. In particular, when
1032 STRING is unibyte and entirely ASCII, the returned string is unibyte.
1033 \(When the characters are all ASCII, Emacs primitives will treat the
1034 string the same way whether it is unibyte or multibyte.) */)
1035 (Lisp_Object string)
1037 CHECK_STRING (string);
1039 return string_make_multibyte (string);
1042 DEFUN ("string-make-unibyte", Fstring_make_unibyte, Sstring_make_unibyte,
1043 1, 1, 0,
1044 doc: /* Return the unibyte equivalent of STRING.
1045 Multibyte character codes are converted to unibyte according to
1046 `nonascii-translation-table' or, if that is nil, `nonascii-insert-offset'.
1047 If the lookup in the translation table fails, this function takes just
1048 the low 8 bits of each character. */)
1049 (Lisp_Object string)
1051 CHECK_STRING (string);
1053 return string_make_unibyte (string);
1056 DEFUN ("string-as-unibyte", Fstring_as_unibyte, Sstring_as_unibyte,
1057 1, 1, 0,
1058 doc: /* Return a unibyte string with the same individual bytes as STRING.
1059 If STRING is unibyte, the result is STRING itself.
1060 Otherwise it is a newly created string, with no text properties.
1061 If STRING is multibyte and contains a character of charset
1062 `eight-bit', it is converted to the corresponding single byte. */)
1063 (Lisp_Object string)
1065 CHECK_STRING (string);
1067 if (STRING_MULTIBYTE (string))
1069 unsigned char *str = (unsigned char *) xlispstrdup (string);
1070 ptrdiff_t bytes = str_as_unibyte (str, SBYTES (string));
1072 string = make_unibyte_string ((char *) str, bytes);
1073 xfree (str);
1075 return string;
1078 DEFUN ("string-as-multibyte", Fstring_as_multibyte, Sstring_as_multibyte,
1079 1, 1, 0,
1080 doc: /* Return a multibyte string with the same individual bytes as STRING.
1081 If STRING is multibyte, the result is STRING itself.
1082 Otherwise it is a newly created string, with no text properties.
1084 If STRING is unibyte and contains an individual 8-bit byte (i.e. not
1085 part of a correct utf-8 sequence), it is converted to the corresponding
1086 multibyte character of charset `eight-bit'.
1087 See also `string-to-multibyte'.
1089 Beware, this often doesn't really do what you think it does.
1090 It is similar to (decode-coding-string STRING \\='utf-8-emacs).
1091 If you're not sure, whether to use `string-as-multibyte' or
1092 `string-to-multibyte', use `string-to-multibyte'. */)
1093 (Lisp_Object string)
1095 CHECK_STRING (string);
1097 if (! STRING_MULTIBYTE (string))
1099 Lisp_Object new_string;
1100 ptrdiff_t nchars, nbytes;
1102 parse_str_as_multibyte (SDATA (string),
1103 SBYTES (string),
1104 &nchars, &nbytes);
1105 new_string = make_uninit_multibyte_string (nchars, nbytes);
1106 memcpy (SDATA (new_string), SDATA (string), SBYTES (string));
1107 if (nbytes != SBYTES (string))
1108 str_as_multibyte (SDATA (new_string), nbytes,
1109 SBYTES (string), NULL);
1110 string = new_string;
1111 set_string_intervals (string, NULL);
1113 return string;
1116 DEFUN ("string-to-multibyte", Fstring_to_multibyte, Sstring_to_multibyte,
1117 1, 1, 0,
1118 doc: /* Return a multibyte string with the same individual chars as STRING.
1119 If STRING is multibyte, the result is STRING itself.
1120 Otherwise it is a newly created string, with no text properties.
1122 If STRING is unibyte and contains an 8-bit byte, it is converted to
1123 the corresponding multibyte character of charset `eight-bit'.
1125 This differs from `string-as-multibyte' by converting each byte of a correct
1126 utf-8 sequence to an eight-bit character, not just bytes that don't form a
1127 correct sequence. */)
1128 (Lisp_Object string)
1130 CHECK_STRING (string);
1132 return string_to_multibyte (string);
1135 DEFUN ("string-to-unibyte", Fstring_to_unibyte, Sstring_to_unibyte,
1136 1, 1, 0,
1137 doc: /* Return a unibyte string with the same individual chars as STRING.
1138 If STRING is unibyte, the result is STRING itself.
1139 Otherwise it is a newly created string, with no text properties,
1140 where each `eight-bit' character is converted to the corresponding byte.
1141 If STRING contains a non-ASCII, non-`eight-bit' character,
1142 an error is signaled. */)
1143 (Lisp_Object string)
1145 CHECK_STRING (string);
1147 if (STRING_MULTIBYTE (string))
1149 ptrdiff_t chars = SCHARS (string);
1150 unsigned char *str = xmalloc (chars);
1151 ptrdiff_t converted = str_to_unibyte (SDATA (string), str, chars);
1153 if (converted < chars)
1154 error ("Can't convert the %"pD"dth character to unibyte", converted);
1155 string = make_unibyte_string ((char *) str, chars);
1156 xfree (str);
1158 return string;
1162 DEFUN ("copy-alist", Fcopy_alist, Scopy_alist, 1, 1, 0,
1163 doc: /* Return a copy of ALIST.
1164 This is an alist which represents the same mapping from objects to objects,
1165 but does not share the alist structure with ALIST.
1166 The objects mapped (cars and cdrs of elements of the alist)
1167 are shared, however.
1168 Elements of ALIST that are not conses are also shared. */)
1169 (Lisp_Object alist)
1171 if (NILP (alist))
1172 return alist;
1173 alist = concat (1, &alist, Lisp_Cons, false);
1174 for (Lisp_Object tem = alist; !NILP (tem); tem = XCDR (tem))
1176 Lisp_Object car = XCAR (tem);
1177 if (CONSP (car))
1178 XSETCAR (tem, Fcons (XCAR (car), XCDR (car)));
1180 return alist;
1183 /* Check that ARRAY can have a valid subarray [FROM..TO),
1184 given that its size is SIZE.
1185 If FROM is nil, use 0; if TO is nil, use SIZE.
1186 Count negative values backwards from the end.
1187 Set *IFROM and *ITO to the two indexes used. */
1189 void
1190 validate_subarray (Lisp_Object array, Lisp_Object from, Lisp_Object to,
1191 ptrdiff_t size, ptrdiff_t *ifrom, ptrdiff_t *ito)
1193 EMACS_INT f, t;
1195 if (INTEGERP (from))
1197 f = XINT (from);
1198 if (f < 0)
1199 f += size;
1201 else if (NILP (from))
1202 f = 0;
1203 else
1204 wrong_type_argument (Qintegerp, from);
1206 if (INTEGERP (to))
1208 t = XINT (to);
1209 if (t < 0)
1210 t += size;
1212 else if (NILP (to))
1213 t = size;
1214 else
1215 wrong_type_argument (Qintegerp, to);
1217 if (! (0 <= f && f <= t && t <= size))
1218 args_out_of_range_3 (array, from, to);
1220 *ifrom = f;
1221 *ito = t;
1224 DEFUN ("substring", Fsubstring, Ssubstring, 1, 3, 0,
1225 doc: /* Return a new string whose contents are a substring of STRING.
1226 The returned string consists of the characters between index FROM
1227 \(inclusive) and index TO (exclusive) of STRING. FROM and TO are
1228 zero-indexed: 0 means the first character of STRING. Negative values
1229 are counted from the end of STRING. If TO is nil, the substring runs
1230 to the end of STRING.
1232 The STRING argument may also be a vector. In that case, the return
1233 value is a new vector that contains the elements between index FROM
1234 \(inclusive) and index TO (exclusive) of that vector argument.
1236 With one argument, just copy STRING (with properties, if any). */)
1237 (Lisp_Object string, Lisp_Object from, Lisp_Object to)
1239 Lisp_Object res;
1240 ptrdiff_t size, ifrom, ito;
1242 size = CHECK_VECTOR_OR_STRING (string);
1243 validate_subarray (string, from, to, size, &ifrom, &ito);
1245 if (STRINGP (string))
1247 ptrdiff_t from_byte
1248 = !ifrom ? 0 : string_char_to_byte (string, ifrom);
1249 ptrdiff_t to_byte
1250 = ito == size ? SBYTES (string) : string_char_to_byte (string, ito);
1251 res = make_specified_string (SSDATA (string) + from_byte,
1252 ito - ifrom, to_byte - from_byte,
1253 STRING_MULTIBYTE (string));
1254 copy_text_properties (make_number (ifrom), make_number (ito),
1255 string, make_number (0), res, Qnil);
1257 else
1258 res = Fvector (ito - ifrom, aref_addr (string, ifrom));
1260 return res;
1264 DEFUN ("substring-no-properties", Fsubstring_no_properties, Ssubstring_no_properties, 1, 3, 0,
1265 doc: /* Return a substring of STRING, without text properties.
1266 It starts at index FROM and ends before TO.
1267 TO may be nil or omitted; then the substring runs to the end of STRING.
1268 If FROM is nil or omitted, the substring starts at the beginning of STRING.
1269 If FROM or TO is negative, it counts from the end.
1271 With one argument, just copy STRING without its properties. */)
1272 (Lisp_Object string, register Lisp_Object from, Lisp_Object to)
1274 ptrdiff_t from_char, to_char, from_byte, to_byte, size;
1276 CHECK_STRING (string);
1278 size = SCHARS (string);
1279 validate_subarray (string, from, to, size, &from_char, &to_char);
1281 from_byte = !from_char ? 0 : string_char_to_byte (string, from_char);
1282 to_byte =
1283 to_char == size ? SBYTES (string) : string_char_to_byte (string, to_char);
1284 return make_specified_string (SSDATA (string) + from_byte,
1285 to_char - from_char, to_byte - from_byte,
1286 STRING_MULTIBYTE (string));
1289 /* Extract a substring of STRING, giving start and end positions
1290 both in characters and in bytes. */
1292 Lisp_Object
1293 substring_both (Lisp_Object string, ptrdiff_t from, ptrdiff_t from_byte,
1294 ptrdiff_t to, ptrdiff_t to_byte)
1296 Lisp_Object res;
1297 ptrdiff_t size = CHECK_VECTOR_OR_STRING (string);
1299 if (!(0 <= from && from <= to && to <= size))
1300 args_out_of_range_3 (string, make_number (from), make_number (to));
1302 if (STRINGP (string))
1304 res = make_specified_string (SSDATA (string) + from_byte,
1305 to - from, to_byte - from_byte,
1306 STRING_MULTIBYTE (string));
1307 copy_text_properties (make_number (from), make_number (to),
1308 string, make_number (0), res, Qnil);
1310 else
1311 res = Fvector (to - from, aref_addr (string, from));
1313 return res;
1316 DEFUN ("nthcdr", Fnthcdr, Snthcdr, 2, 2, 0,
1317 doc: /* Take cdr N times on LIST, return the result. */)
1318 (Lisp_Object n, Lisp_Object list)
1320 CHECK_NUMBER (n);
1321 Lisp_Object tail = list;
1322 for (EMACS_INT num = XINT (n); 0 < num; num--)
1324 if (! CONSP (tail))
1326 CHECK_LIST_END (tail, list);
1327 return Qnil;
1329 tail = XCDR (tail);
1330 rarely_quit (num);
1332 return tail;
1335 DEFUN ("nth", Fnth, Snth, 2, 2, 0,
1336 doc: /* Return the Nth element of LIST.
1337 N counts from zero. If LIST is not that long, nil is returned. */)
1338 (Lisp_Object n, Lisp_Object list)
1340 return Fcar (Fnthcdr (n, list));
1343 DEFUN ("elt", Felt, Selt, 2, 2, 0,
1344 doc: /* Return element of SEQUENCE at index N. */)
1345 (register Lisp_Object sequence, Lisp_Object n)
1347 CHECK_NUMBER (n);
1348 if (CONSP (sequence) || NILP (sequence))
1349 return Fcar (Fnthcdr (n, sequence));
1351 /* Faref signals a "not array" error, so check here. */
1352 CHECK_ARRAY (sequence, Qsequencep);
1353 return Faref (sequence, n);
1356 DEFUN ("member", Fmember, Smember, 2, 2, 0,
1357 doc: /* Return non-nil if ELT is an element of LIST. Comparison done with `equal'.
1358 The value is actually the tail of LIST whose car is ELT. */)
1359 (Lisp_Object elt, Lisp_Object list)
1361 Lisp_Object tail = list;
1362 FOR_EACH_TAIL (tail)
1363 if (! NILP (Fequal (elt, XCAR (tail))))
1364 return tail;
1365 CHECK_LIST_END (tail, list);
1366 return Qnil;
1369 DEFUN ("memq", Fmemq, Smemq, 2, 2, 0,
1370 doc: /* Return non-nil if ELT is an element of LIST. Comparison done with `eq'.
1371 The value is actually the tail of LIST whose car is ELT. */)
1372 (Lisp_Object elt, Lisp_Object list)
1374 Lisp_Object tail = list;
1375 FOR_EACH_TAIL (tail)
1376 if (EQ (XCAR (tail), elt))
1377 return tail;
1378 CHECK_LIST_END (tail, list);
1379 return Qnil;
1382 DEFUN ("memql", Fmemql, Smemql, 2, 2, 0,
1383 doc: /* Return non-nil if ELT is an element of LIST. Comparison done with `eql'.
1384 The value is actually the tail of LIST whose car is ELT. */)
1385 (Lisp_Object elt, Lisp_Object list)
1387 if (!FLOATP (elt))
1388 return Fmemq (elt, list);
1390 Lisp_Object tail = list;
1391 FOR_EACH_TAIL (tail)
1393 Lisp_Object tem = XCAR (tail);
1394 if (FLOATP (tem) && equal_no_quit (elt, tem))
1395 return tail;
1397 CHECK_LIST_END (tail, list);
1398 return Qnil;
1401 DEFUN ("assq", Fassq, Sassq, 2, 2, 0,
1402 doc: /* Return non-nil if KEY is `eq' to the car of an element of LIST.
1403 The value is actually the first element of LIST whose car is KEY.
1404 Elements of LIST that are not conses are ignored. */)
1405 (Lisp_Object key, Lisp_Object list)
1407 Lisp_Object tail = list;
1408 FOR_EACH_TAIL (tail)
1409 if (CONSP (XCAR (tail)) && EQ (XCAR (XCAR (tail)), key))
1410 return XCAR (tail);
1411 CHECK_LIST_END (tail, list);
1412 return Qnil;
1415 /* Like Fassq but never report an error and do not allow quits.
1416 Use only on objects known to be non-circular lists. */
1418 Lisp_Object
1419 assq_no_quit (Lisp_Object key, Lisp_Object list)
1421 for (; ! NILP (list); list = XCDR (list))
1422 if (CONSP (XCAR (list)) && EQ (XCAR (XCAR (list)), key))
1423 return XCAR (list);
1424 return Qnil;
1427 DEFUN ("assoc", Fassoc, Sassoc, 2, 3, 0,
1428 doc: /* Return non-nil if KEY is equal to the car of an element of LIST.
1429 The value is actually the first element of LIST whose car equals KEY.
1431 Equality is defined by TESTFN if non-nil or by `equal' if nil. */)
1432 (Lisp_Object key, Lisp_Object list, Lisp_Object testfn)
1434 Lisp_Object tail = list;
1435 FOR_EACH_TAIL (tail)
1437 Lisp_Object car = XCAR (tail);
1438 if (CONSP (car)
1439 && (NILP (testfn)
1440 ? (EQ (XCAR (car), key) || !NILP (Fequal
1441 (XCAR (car), key)))
1442 : !NILP (call2 (testfn, XCAR (car), key))))
1443 return car;
1445 CHECK_LIST_END (tail, list);
1446 return Qnil;
1449 /* Like Fassoc but never report an error and do not allow quits.
1450 Use only on keys and lists known to be non-circular, and on keys
1451 that are not too deep and are not window configurations. */
1453 Lisp_Object
1454 assoc_no_quit (Lisp_Object key, Lisp_Object list)
1456 for (; ! NILP (list); list = XCDR (list))
1458 Lisp_Object car = XCAR (list);
1459 if (CONSP (car)
1460 && (EQ (XCAR (car), key) || equal_no_quit (XCAR (car), key)))
1461 return car;
1463 return Qnil;
1466 DEFUN ("rassq", Frassq, Srassq, 2, 2, 0,
1467 doc: /* Return non-nil if KEY is `eq' to the cdr of an element of LIST.
1468 The value is actually the first element of LIST whose cdr is KEY. */)
1469 (Lisp_Object key, Lisp_Object list)
1471 Lisp_Object tail = list;
1472 FOR_EACH_TAIL (tail)
1473 if (CONSP (XCAR (tail)) && EQ (XCDR (XCAR (tail)), key))
1474 return XCAR (tail);
1475 CHECK_LIST_END (tail, list);
1476 return Qnil;
1479 DEFUN ("rassoc", Frassoc, Srassoc, 2, 2, 0,
1480 doc: /* Return non-nil if KEY is `equal' to the cdr of an element of LIST.
1481 The value is actually the first element of LIST whose cdr equals KEY. */)
1482 (Lisp_Object key, Lisp_Object list)
1484 Lisp_Object tail = list;
1485 FOR_EACH_TAIL (tail)
1487 Lisp_Object car = XCAR (tail);
1488 if (CONSP (car)
1489 && (EQ (XCDR (car), key) || !NILP (Fequal (XCDR (car), key))))
1490 return car;
1492 CHECK_LIST_END (tail, list);
1493 return Qnil;
1496 DEFUN ("delq", Fdelq, Sdelq, 2, 2, 0,
1497 doc: /* Delete members of LIST which are `eq' to ELT, and return the result.
1498 More precisely, this function skips any members `eq' to ELT at the
1499 front of LIST, then removes members `eq' to ELT from the remaining
1500 sublist by modifying its list structure, then returns the resulting
1501 list.
1503 Write `(setq foo (delq element foo))' to be sure of correctly changing
1504 the value of a list `foo'. See also `remq', which does not modify the
1505 argument. */)
1506 (Lisp_Object elt, Lisp_Object list)
1508 Lisp_Object prev = Qnil, tail = list;
1510 FOR_EACH_TAIL (tail)
1512 Lisp_Object tem = XCAR (tail);
1513 if (EQ (elt, tem))
1515 if (NILP (prev))
1516 list = XCDR (tail);
1517 else
1518 Fsetcdr (prev, XCDR (tail));
1520 else
1521 prev = tail;
1523 CHECK_LIST_END (tail, list);
1524 return list;
1527 DEFUN ("delete", Fdelete, Sdelete, 2, 2, 0,
1528 doc: /* Delete members of SEQ which are `equal' to ELT, and return the result.
1529 SEQ must be a sequence (i.e. a list, a vector, or a string).
1530 The return value is a sequence of the same type.
1532 If SEQ is a list, this behaves like `delq', except that it compares
1533 with `equal' instead of `eq'. In particular, it may remove elements
1534 by altering the list structure.
1536 If SEQ is not a list, deletion is never performed destructively;
1537 instead this function creates and returns a new vector or string.
1539 Write `(setq foo (delete element foo))' to be sure of correctly
1540 changing the value of a sequence `foo'. */)
1541 (Lisp_Object elt, Lisp_Object seq)
1543 if (VECTORP (seq))
1545 ptrdiff_t i, n;
1547 for (i = n = 0; i < ASIZE (seq); ++i)
1548 if (NILP (Fequal (AREF (seq, i), elt)))
1549 ++n;
1551 if (n != ASIZE (seq))
1553 struct Lisp_Vector *p = allocate_vector (n);
1555 for (i = n = 0; i < ASIZE (seq); ++i)
1556 if (NILP (Fequal (AREF (seq, i), elt)))
1557 p->contents[n++] = AREF (seq, i);
1559 XSETVECTOR (seq, p);
1562 else if (STRINGP (seq))
1564 ptrdiff_t i, ibyte, nchars, nbytes, cbytes;
1565 int c;
1567 for (i = nchars = nbytes = ibyte = 0;
1568 i < SCHARS (seq);
1569 ++i, ibyte += cbytes)
1571 if (STRING_MULTIBYTE (seq))
1573 c = STRING_CHAR (SDATA (seq) + ibyte);
1574 cbytes = CHAR_BYTES (c);
1576 else
1578 c = SREF (seq, i);
1579 cbytes = 1;
1582 if (!INTEGERP (elt) || c != XINT (elt))
1584 ++nchars;
1585 nbytes += cbytes;
1589 if (nchars != SCHARS (seq))
1591 Lisp_Object tem;
1593 tem = make_uninit_multibyte_string (nchars, nbytes);
1594 if (!STRING_MULTIBYTE (seq))
1595 STRING_SET_UNIBYTE (tem);
1597 for (i = nchars = nbytes = ibyte = 0;
1598 i < SCHARS (seq);
1599 ++i, ibyte += cbytes)
1601 if (STRING_MULTIBYTE (seq))
1603 c = STRING_CHAR (SDATA (seq) + ibyte);
1604 cbytes = CHAR_BYTES (c);
1606 else
1608 c = SREF (seq, i);
1609 cbytes = 1;
1612 if (!INTEGERP (elt) || c != XINT (elt))
1614 unsigned char *from = SDATA (seq) + ibyte;
1615 unsigned char *to = SDATA (tem) + nbytes;
1616 ptrdiff_t n;
1618 ++nchars;
1619 nbytes += cbytes;
1621 for (n = cbytes; n--; )
1622 *to++ = *from++;
1626 seq = tem;
1629 else
1631 Lisp_Object prev = Qnil, tail = seq;
1633 FOR_EACH_TAIL (tail)
1635 if (!NILP (Fequal (elt, XCAR (tail))))
1637 if (NILP (prev))
1638 seq = XCDR (tail);
1639 else
1640 Fsetcdr (prev, XCDR (tail));
1642 else
1643 prev = tail;
1645 CHECK_LIST_END (tail, seq);
1648 return seq;
1651 DEFUN ("nreverse", Fnreverse, Snreverse, 1, 1, 0,
1652 doc: /* Reverse order of items in a list, vector or string SEQ.
1653 If SEQ is a list, it should be nil-terminated.
1654 This function may destructively modify SEQ to produce the value. */)
1655 (Lisp_Object seq)
1657 if (NILP (seq))
1658 return seq;
1659 else if (STRINGP (seq))
1660 return Freverse (seq);
1661 else if (CONSP (seq))
1663 Lisp_Object prev, tail, next;
1665 for (prev = Qnil, tail = seq; CONSP (tail); tail = next)
1667 next = XCDR (tail);
1668 /* If SEQ contains a cycle, attempting to reverse it
1669 in-place will inevitably come back to SEQ. */
1670 if (EQ (next, seq))
1671 circular_list (seq);
1672 Fsetcdr (tail, prev);
1673 prev = tail;
1675 CHECK_LIST_END (tail, seq);
1676 seq = prev;
1678 else if (VECTORP (seq))
1680 ptrdiff_t i, size = ASIZE (seq);
1682 for (i = 0; i < size / 2; i++)
1684 Lisp_Object tem = AREF (seq, i);
1685 ASET (seq, i, AREF (seq, size - i - 1));
1686 ASET (seq, size - i - 1, tem);
1689 else if (BOOL_VECTOR_P (seq))
1691 ptrdiff_t i, size = bool_vector_size (seq);
1693 for (i = 0; i < size / 2; i++)
1695 bool tem = bool_vector_bitref (seq, i);
1696 bool_vector_set (seq, i, bool_vector_bitref (seq, size - i - 1));
1697 bool_vector_set (seq, size - i - 1, tem);
1700 else
1701 wrong_type_argument (Qarrayp, seq);
1702 return seq;
1705 DEFUN ("reverse", Freverse, Sreverse, 1, 1, 0,
1706 doc: /* Return the reversed copy of list, vector, or string SEQ.
1707 See also the function `nreverse', which is used more often. */)
1708 (Lisp_Object seq)
1710 Lisp_Object new;
1712 if (NILP (seq))
1713 return Qnil;
1714 else if (CONSP (seq))
1716 new = Qnil;
1717 FOR_EACH_TAIL (seq)
1718 new = Fcons (XCAR (seq), new);
1719 CHECK_LIST_END (seq, seq);
1721 else if (VECTORP (seq))
1723 ptrdiff_t i, size = ASIZE (seq);
1725 new = make_uninit_vector (size);
1726 for (i = 0; i < size; i++)
1727 ASET (new, i, AREF (seq, size - i - 1));
1729 else if (BOOL_VECTOR_P (seq))
1731 ptrdiff_t i;
1732 EMACS_INT nbits = bool_vector_size (seq);
1734 new = make_uninit_bool_vector (nbits);
1735 for (i = 0; i < nbits; i++)
1736 bool_vector_set (new, i, bool_vector_bitref (seq, nbits - i - 1));
1738 else if (STRINGP (seq))
1740 ptrdiff_t size = SCHARS (seq), bytes = SBYTES (seq);
1742 if (size == bytes)
1744 ptrdiff_t i;
1746 new = make_uninit_string (size);
1747 for (i = 0; i < size; i++)
1748 SSET (new, i, SREF (seq, size - i - 1));
1750 else
1752 unsigned char *p, *q;
1754 new = make_uninit_multibyte_string (size, bytes);
1755 p = SDATA (seq), q = SDATA (new) + bytes;
1756 while (q > SDATA (new))
1758 int ch, len;
1760 ch = STRING_CHAR_AND_LENGTH (p, len);
1761 p += len, q -= len;
1762 CHAR_STRING (ch, q);
1766 else
1767 wrong_type_argument (Qsequencep, seq);
1768 return new;
1771 /* Sort LIST using PREDICATE, preserving original order of elements
1772 considered as equal. */
1774 static Lisp_Object
1775 sort_list (Lisp_Object list, Lisp_Object predicate)
1777 Lisp_Object front, back;
1778 Lisp_Object len, tem;
1779 EMACS_INT length;
1781 front = list;
1782 len = Flength (list);
1783 length = XINT (len);
1784 if (length < 2)
1785 return list;
1787 XSETINT (len, (length / 2) - 1);
1788 tem = Fnthcdr (len, list);
1789 back = Fcdr (tem);
1790 Fsetcdr (tem, Qnil);
1792 front = Fsort (front, predicate);
1793 back = Fsort (back, predicate);
1794 return merge (front, back, predicate);
1797 /* Using PRED to compare, return whether A and B are in order.
1798 Compare stably when A appeared before B in the input. */
1799 static bool
1800 inorder (Lisp_Object pred, Lisp_Object a, Lisp_Object b)
1802 return NILP (call2 (pred, b, a));
1805 /* Using PRED to compare, merge from ALEN-length A and BLEN-length B
1806 into DEST. Argument arrays must be nonempty and must not overlap,
1807 except that B might be the last part of DEST. */
1808 static void
1809 merge_vectors (Lisp_Object pred,
1810 ptrdiff_t alen, Lisp_Object const a[restrict VLA_ELEMS (alen)],
1811 ptrdiff_t blen, Lisp_Object const b[VLA_ELEMS (blen)],
1812 Lisp_Object dest[VLA_ELEMS (alen + blen)])
1814 eassume (0 < alen && 0 < blen);
1815 Lisp_Object const *alim = a + alen;
1816 Lisp_Object const *blim = b + blen;
1818 while (true)
1820 if (inorder (pred, a[0], b[0]))
1822 *dest++ = *a++;
1823 if (a == alim)
1825 if (dest != b)
1826 memcpy (dest, b, (blim - b) * sizeof *dest);
1827 return;
1830 else
1832 *dest++ = *b++;
1833 if (b == blim)
1835 memcpy (dest, a, (alim - a) * sizeof *dest);
1836 return;
1842 /* Using PRED to compare, sort LEN-length VEC in place, using TMP for
1843 temporary storage. LEN must be at least 2. */
1844 static void
1845 sort_vector_inplace (Lisp_Object pred, ptrdiff_t len,
1846 Lisp_Object vec[restrict VLA_ELEMS (len)],
1847 Lisp_Object tmp[restrict VLA_ELEMS (len >> 1)])
1849 eassume (2 <= len);
1850 ptrdiff_t halflen = len >> 1;
1851 sort_vector_copy (pred, halflen, vec, tmp);
1852 if (1 < len - halflen)
1853 sort_vector_inplace (pred, len - halflen, vec + halflen, vec);
1854 merge_vectors (pred, halflen, tmp, len - halflen, vec + halflen, vec);
1857 /* Using PRED to compare, sort from LEN-length SRC into DST.
1858 Len must be positive. */
1859 static void
1860 sort_vector_copy (Lisp_Object pred, ptrdiff_t len,
1861 Lisp_Object src[restrict VLA_ELEMS (len)],
1862 Lisp_Object dest[restrict VLA_ELEMS (len)])
1864 eassume (0 < len);
1865 ptrdiff_t halflen = len >> 1;
1866 if (halflen < 1)
1867 dest[0] = src[0];
1868 else
1870 if (1 < halflen)
1871 sort_vector_inplace (pred, halflen, src, dest);
1872 if (1 < len - halflen)
1873 sort_vector_inplace (pred, len - halflen, src + halflen, dest);
1874 merge_vectors (pred, halflen, src, len - halflen, src + halflen, dest);
1878 /* Sort VECTOR in place using PREDICATE, preserving original order of
1879 elements considered as equal. */
1881 static void
1882 sort_vector (Lisp_Object vector, Lisp_Object predicate)
1884 ptrdiff_t len = ASIZE (vector);
1885 if (len < 2)
1886 return;
1887 ptrdiff_t halflen = len >> 1;
1888 Lisp_Object *tmp;
1889 USE_SAFE_ALLOCA;
1890 SAFE_ALLOCA_LISP (tmp, halflen);
1891 for (ptrdiff_t i = 0; i < halflen; i++)
1892 tmp[i] = make_number (0);
1893 sort_vector_inplace (predicate, len, XVECTOR (vector)->contents, tmp);
1894 SAFE_FREE ();
1897 DEFUN ("sort", Fsort, Ssort, 2, 2, 0,
1898 doc: /* Sort SEQ, stably, comparing elements using PREDICATE.
1899 Returns the sorted sequence. SEQ should be a list or vector. SEQ is
1900 modified by side effects. PREDICATE is called with two elements of
1901 SEQ, and should return non-nil if the first element should sort before
1902 the second. */)
1903 (Lisp_Object seq, Lisp_Object predicate)
1905 if (CONSP (seq))
1906 seq = sort_list (seq, predicate);
1907 else if (VECTORP (seq))
1908 sort_vector (seq, predicate);
1909 else if (!NILP (seq))
1910 wrong_type_argument (Qsequencep, seq);
1911 return seq;
1914 Lisp_Object
1915 merge (Lisp_Object org_l1, Lisp_Object org_l2, Lisp_Object pred)
1917 Lisp_Object l1 = org_l1;
1918 Lisp_Object l2 = org_l2;
1919 Lisp_Object tail = Qnil;
1920 Lisp_Object value = Qnil;
1922 while (1)
1924 if (NILP (l1))
1926 if (NILP (tail))
1927 return l2;
1928 Fsetcdr (tail, l2);
1929 return value;
1931 if (NILP (l2))
1933 if (NILP (tail))
1934 return l1;
1935 Fsetcdr (tail, l1);
1936 return value;
1939 Lisp_Object tem;
1940 if (inorder (pred, Fcar (l1), Fcar (l2)))
1942 tem = l1;
1943 l1 = Fcdr (l1);
1944 org_l1 = l1;
1946 else
1948 tem = l2;
1949 l2 = Fcdr (l2);
1950 org_l2 = l2;
1952 if (NILP (tail))
1953 value = tem;
1954 else
1955 Fsetcdr (tail, tem);
1956 tail = tem;
1961 /* This does not check for quits. That is safe since it must terminate. */
1963 DEFUN ("plist-get", Fplist_get, Splist_get, 2, 2, 0,
1964 doc: /* Extract a value from a property list.
1965 PLIST is a property list, which is a list of the form
1966 \(PROP1 VALUE1 PROP2 VALUE2...). This function returns the value
1967 corresponding to the given PROP, or nil if PROP is not one of the
1968 properties on the list. This function never signals an error. */)
1969 (Lisp_Object plist, Lisp_Object prop)
1971 Lisp_Object tail = plist;
1972 FOR_EACH_TAIL_SAFE (tail)
1974 if (! CONSP (XCDR (tail)))
1975 break;
1976 if (EQ (prop, XCAR (tail)))
1977 return XCAR (XCDR (tail));
1978 tail = XCDR (tail);
1979 if (EQ (tail, li.tortoise))
1980 break;
1983 return Qnil;
1986 DEFUN ("get", Fget, Sget, 2, 2, 0,
1987 doc: /* Return the value of SYMBOL's PROPNAME property.
1988 This is the last value stored with `(put SYMBOL PROPNAME VALUE)'. */)
1989 (Lisp_Object symbol, Lisp_Object propname)
1991 CHECK_SYMBOL (symbol);
1992 Lisp_Object propval = Fplist_get (CDR (Fassq (symbol, Voverriding_plist_environment)),
1993 propname);
1994 if (!NILP (propval))
1995 return propval;
1996 return Fplist_get (XSYMBOL (symbol)->u.s.plist, propname);
1999 DEFUN ("plist-put", Fplist_put, Splist_put, 3, 3, 0,
2000 doc: /* Change value in PLIST of PROP to VAL.
2001 PLIST is a property list, which is a list of the form
2002 \(PROP1 VALUE1 PROP2 VALUE2 ...). PROP is a symbol and VAL is any object.
2003 If PROP is already a property on the list, its value is set to VAL,
2004 otherwise the new PROP VAL pair is added. The new plist is returned;
2005 use `(setq x (plist-put x prop val))' to be sure to use the new value.
2006 The PLIST is modified by side effects. */)
2007 (Lisp_Object plist, Lisp_Object prop, Lisp_Object val)
2009 Lisp_Object prev = Qnil, tail = plist;
2010 FOR_EACH_TAIL (tail)
2012 if (! CONSP (XCDR (tail)))
2013 break;
2015 if (EQ (prop, XCAR (tail)))
2017 Fsetcar (XCDR (tail), val);
2018 return plist;
2021 prev = tail;
2022 tail = XCDR (tail);
2023 if (EQ (tail, li.tortoise))
2024 circular_list (plist);
2026 CHECK_TYPE (NILP (tail), Qplistp, plist);
2027 Lisp_Object newcell
2028 = Fcons (prop, Fcons (val, NILP (prev) ? plist : XCDR (XCDR (prev))));
2029 if (NILP (prev))
2030 return newcell;
2031 Fsetcdr (XCDR (prev), newcell);
2032 return plist;
2035 DEFUN ("put", Fput, Sput, 3, 3, 0,
2036 doc: /* Store SYMBOL's PROPNAME property with value VALUE.
2037 It can be retrieved with `(get SYMBOL PROPNAME)'. */)
2038 (Lisp_Object symbol, Lisp_Object propname, Lisp_Object value)
2040 CHECK_SYMBOL (symbol);
2041 set_symbol_plist
2042 (symbol, Fplist_put (XSYMBOL (symbol)->u.s.plist, propname, value));
2043 return value;
2046 DEFUN ("lax-plist-get", Flax_plist_get, Slax_plist_get, 2, 2, 0,
2047 doc: /* Extract a value from a property list, comparing with `equal'.
2048 PLIST is a property list, which is a list of the form
2049 \(PROP1 VALUE1 PROP2 VALUE2...). This function returns the value
2050 corresponding to the given PROP, or nil if PROP is not
2051 one of the properties on the list. */)
2052 (Lisp_Object plist, Lisp_Object prop)
2054 Lisp_Object tail = plist;
2055 FOR_EACH_TAIL (tail)
2057 if (! CONSP (XCDR (tail)))
2058 break;
2059 if (! NILP (Fequal (prop, XCAR (tail))))
2060 return XCAR (XCDR (tail));
2061 tail = XCDR (tail);
2062 if (EQ (tail, li.tortoise))
2063 circular_list (plist);
2066 CHECK_TYPE (NILP (tail), Qplistp, plist);
2068 return Qnil;
2071 DEFUN ("lax-plist-put", Flax_plist_put, Slax_plist_put, 3, 3, 0,
2072 doc: /* Change value in PLIST of PROP to VAL, comparing with `equal'.
2073 PLIST is a property list, which is a list of the form
2074 \(PROP1 VALUE1 PROP2 VALUE2 ...). PROP and VAL are any objects.
2075 If PROP is already a property on the list, its value is set to VAL,
2076 otherwise the new PROP VAL pair is added. The new plist is returned;
2077 use `(setq x (lax-plist-put x prop val))' to be sure to use the new value.
2078 The PLIST is modified by side effects. */)
2079 (Lisp_Object plist, Lisp_Object prop, Lisp_Object val)
2081 Lisp_Object prev = Qnil, tail = plist;
2082 FOR_EACH_TAIL (tail)
2084 if (! CONSP (XCDR (tail)))
2085 break;
2087 if (! NILP (Fequal (prop, XCAR (tail))))
2089 Fsetcar (XCDR (tail), val);
2090 return plist;
2093 prev = tail;
2094 tail = XCDR (tail);
2095 if (EQ (tail, li.tortoise))
2096 circular_list (plist);
2098 CHECK_TYPE (NILP (tail), Qplistp, plist);
2099 Lisp_Object newcell = list2 (prop, val);
2100 if (NILP (prev))
2101 return newcell;
2102 Fsetcdr (XCDR (prev), newcell);
2103 return plist;
2106 DEFUN ("eql", Feql, Seql, 2, 2, 0,
2107 doc: /* Return t if the two args are the same Lisp object.
2108 Floating-point numbers of equal value are `eql', but they may not be `eq'. */)
2109 (Lisp_Object obj1, Lisp_Object obj2)
2111 if (FLOATP (obj1))
2112 return equal_no_quit (obj1, obj2) ? Qt : Qnil;
2113 else
2114 return EQ (obj1, obj2) ? Qt : Qnil;
2117 DEFUN ("equal", Fequal, Sequal, 2, 2, 0,
2118 doc: /* Return t if two Lisp objects have similar structure and contents.
2119 They must have the same data type.
2120 Conses are compared by comparing the cars and the cdrs.
2121 Vectors and strings are compared element by element.
2122 Numbers are compared by value, but integers cannot equal floats.
2123 (Use `=' if you want integers and floats to be able to be equal.)
2124 Symbols must match exactly. */)
2125 (Lisp_Object o1, Lisp_Object o2)
2127 return internal_equal (o1, o2, EQUAL_PLAIN, 0, Qnil) ? Qt : Qnil;
2130 DEFUN ("equal-including-properties", Fequal_including_properties, Sequal_including_properties, 2, 2, 0,
2131 doc: /* Return t if two Lisp objects have similar structure and contents.
2132 This is like `equal' except that it compares the text properties
2133 of strings. (`equal' ignores text properties.) */)
2134 (Lisp_Object o1, Lisp_Object o2)
2136 return (internal_equal (o1, o2, EQUAL_INCLUDING_PROPERTIES, 0, Qnil)
2137 ? Qt : Qnil);
2140 /* Return true if O1 and O2 are equal. Do not quit or check for cycles.
2141 Use this only on arguments that are cycle-free and not too large and
2142 are not window configurations. */
2144 bool
2145 equal_no_quit (Lisp_Object o1, Lisp_Object o2)
2147 return internal_equal (o1, o2, EQUAL_NO_QUIT, 0, Qnil);
2150 /* Return true if O1 and O2 are equal. EQUAL_KIND specifies what kind
2151 of equality test to use: if it is EQUAL_NO_QUIT, do not check for
2152 cycles or large arguments or quits; if EQUAL_PLAIN, do ordinary
2153 Lisp equality; and if EQUAL_INCLUDING_PROPERTIES, do
2154 equal-including-properties.
2156 If DEPTH is the current depth of recursion; signal an error if it
2157 gets too deep. HT is a hash table used to detect cycles; if nil,
2158 it has not been allocated yet. But ignore the last two arguments
2159 if EQUAL_KIND == EQUAL_NO_QUIT. */
2161 static bool
2162 internal_equal (Lisp_Object o1, Lisp_Object o2, enum equal_kind equal_kind,
2163 int depth, Lisp_Object ht)
2165 tail_recurse:
2166 if (depth > 10)
2168 eassert (equal_kind != EQUAL_NO_QUIT);
2169 if (depth > 200)
2170 error ("Stack overflow in equal");
2171 if (NILP (ht))
2172 ht = CALLN (Fmake_hash_table, QCtest, Qeq);
2173 switch (XTYPE (o1))
2175 case Lisp_Cons: case Lisp_Misc: case Lisp_Vectorlike:
2177 struct Lisp_Hash_Table *h = XHASH_TABLE (ht);
2178 EMACS_UINT hash;
2179 ptrdiff_t i = hash_lookup (h, o1, &hash);
2180 if (i >= 0)
2181 { /* `o1' was seen already. */
2182 Lisp_Object o2s = HASH_VALUE (h, i);
2183 if (!NILP (Fmemq (o2, o2s)))
2184 return true;
2185 else
2186 set_hash_value_slot (h, i, Fcons (o2, o2s));
2188 else
2189 hash_put (h, o1, Fcons (o2, Qnil), hash);
2191 default: ;
2195 if (EQ (o1, o2))
2196 return true;
2197 if (XTYPE (o1) != XTYPE (o2))
2198 return false;
2200 switch (XTYPE (o1))
2202 case Lisp_Float:
2204 double d1 = XFLOAT_DATA (o1);
2205 double d2 = XFLOAT_DATA (o2);
2206 /* If d is a NaN, then d != d. Two NaNs should be `equal' even
2207 though they are not =. */
2208 return d1 == d2 || (d1 != d1 && d2 != d2);
2211 case Lisp_Cons:
2212 if (equal_kind == EQUAL_NO_QUIT)
2213 for (; CONSP (o1); o1 = XCDR (o1))
2215 if (! CONSP (o2))
2216 return false;
2217 if (! equal_no_quit (XCAR (o1), XCAR (o2)))
2218 return false;
2219 o2 = XCDR (o2);
2220 if (EQ (XCDR (o1), o2))
2221 return true;
2223 else
2224 FOR_EACH_TAIL (o1)
2226 if (! CONSP (o2))
2227 return false;
2228 if (! internal_equal (XCAR (o1), XCAR (o2),
2229 equal_kind, depth + 1, ht))
2230 return false;
2231 o2 = XCDR (o2);
2232 if (EQ (XCDR (o1), o2))
2233 return true;
2235 depth++;
2236 goto tail_recurse;
2238 case Lisp_Misc:
2239 if (XMISCTYPE (o1) != XMISCTYPE (o2))
2240 return false;
2241 if (OVERLAYP (o1))
2243 if (!internal_equal (OVERLAY_START (o1), OVERLAY_START (o2),
2244 equal_kind, depth + 1, ht)
2245 || !internal_equal (OVERLAY_END (o1), OVERLAY_END (o2),
2246 equal_kind, depth + 1, ht))
2247 return false;
2248 o1 = XOVERLAY (o1)->plist;
2249 o2 = XOVERLAY (o2)->plist;
2250 depth++;
2251 goto tail_recurse;
2253 if (MARKERP (o1))
2255 return (XMARKER (o1)->buffer == XMARKER (o2)->buffer
2256 && (XMARKER (o1)->buffer == 0
2257 || XMARKER (o1)->bytepos == XMARKER (o2)->bytepos));
2259 break;
2261 case Lisp_Vectorlike:
2263 register int i;
2264 ptrdiff_t size = ASIZE (o1);
2265 /* Pseudovectors have the type encoded in the size field, so this test
2266 actually checks that the objects have the same type as well as the
2267 same size. */
2268 if (ASIZE (o2) != size)
2269 return false;
2270 /* Boolvectors are compared much like strings. */
2271 if (BOOL_VECTOR_P (o1))
2273 EMACS_INT size = bool_vector_size (o1);
2274 if (size != bool_vector_size (o2))
2275 return false;
2276 if (memcmp (bool_vector_data (o1), bool_vector_data (o2),
2277 bool_vector_bytes (size)))
2278 return false;
2279 return true;
2281 if (WINDOW_CONFIGURATIONP (o1))
2283 eassert (equal_kind != EQUAL_NO_QUIT);
2284 return compare_window_configurations (o1, o2, false);
2287 /* Aside from them, only true vectors, char-tables, compiled
2288 functions, and fonts (font-spec, font-entity, font-object)
2289 are sensible to compare, so eliminate the others now. */
2290 if (size & PSEUDOVECTOR_FLAG)
2292 if (((size & PVEC_TYPE_MASK) >> PSEUDOVECTOR_AREA_BITS)
2293 < PVEC_COMPILED)
2294 return false;
2295 size &= PSEUDOVECTOR_SIZE_MASK;
2297 for (i = 0; i < size; i++)
2299 Lisp_Object v1, v2;
2300 v1 = AREF (o1, i);
2301 v2 = AREF (o2, i);
2302 if (!internal_equal (v1, v2, equal_kind, depth + 1, ht))
2303 return false;
2305 return true;
2307 break;
2309 case Lisp_String:
2310 if (SCHARS (o1) != SCHARS (o2))
2311 return false;
2312 if (SBYTES (o1) != SBYTES (o2))
2313 return false;
2314 if (memcmp (SDATA (o1), SDATA (o2), SBYTES (o1)))
2315 return false;
2316 if (equal_kind == EQUAL_INCLUDING_PROPERTIES
2317 && !compare_string_intervals (o1, o2))
2318 return false;
2319 return true;
2321 default:
2322 break;
2325 return false;
2329 DEFUN ("fillarray", Ffillarray, Sfillarray, 2, 2, 0,
2330 doc: /* Store each element of ARRAY with ITEM.
2331 ARRAY is a vector, string, char-table, or bool-vector. */)
2332 (Lisp_Object array, Lisp_Object item)
2334 register ptrdiff_t size, idx;
2336 if (VECTORP (array))
2337 for (idx = 0, size = ASIZE (array); idx < size; idx++)
2338 ASET (array, idx, item);
2339 else if (CHAR_TABLE_P (array))
2341 int i;
2343 for (i = 0; i < (1 << CHARTAB_SIZE_BITS_0); i++)
2344 set_char_table_contents (array, i, item);
2345 set_char_table_defalt (array, item);
2347 else if (STRINGP (array))
2349 register unsigned char *p = SDATA (array);
2350 int charval;
2351 CHECK_CHARACTER (item);
2352 charval = XFASTINT (item);
2353 size = SCHARS (array);
2354 if (STRING_MULTIBYTE (array))
2356 unsigned char str[MAX_MULTIBYTE_LENGTH];
2357 int len = CHAR_STRING (charval, str);
2358 ptrdiff_t size_byte = SBYTES (array);
2359 ptrdiff_t product;
2361 if (INT_MULTIPLY_WRAPV (size, len, &product) || product != size_byte)
2362 error ("Attempt to change byte length of a string");
2363 for (idx = 0; idx < size_byte; idx++)
2364 *p++ = str[idx % len];
2366 else
2367 for (idx = 0; idx < size; idx++)
2368 p[idx] = charval;
2370 else if (BOOL_VECTOR_P (array))
2371 return bool_vector_fill (array, item);
2372 else
2373 wrong_type_argument (Qarrayp, array);
2374 return array;
2377 DEFUN ("clear-string", Fclear_string, Sclear_string,
2378 1, 1, 0,
2379 doc: /* Clear the contents of STRING.
2380 This makes STRING unibyte and may change its length. */)
2381 (Lisp_Object string)
2383 ptrdiff_t len;
2384 CHECK_STRING (string);
2385 len = SBYTES (string);
2386 memset (SDATA (string), 0, len);
2387 STRING_SET_CHARS (string, len);
2388 STRING_SET_UNIBYTE (string);
2389 return Qnil;
2392 /* ARGSUSED */
2393 Lisp_Object
2394 nconc2 (Lisp_Object s1, Lisp_Object s2)
2396 return CALLN (Fnconc, s1, s2);
2399 DEFUN ("nconc", Fnconc, Snconc, 0, MANY, 0,
2400 doc: /* Concatenate any number of lists by altering them.
2401 Only the last argument is not altered, and need not be a list.
2402 usage: (nconc &rest LISTS) */)
2403 (ptrdiff_t nargs, Lisp_Object *args)
2405 Lisp_Object val = Qnil;
2407 for (ptrdiff_t argnum = 0; argnum < nargs; argnum++)
2409 Lisp_Object tem = args[argnum];
2410 if (NILP (tem)) continue;
2412 if (NILP (val))
2413 val = tem;
2415 if (argnum + 1 == nargs) break;
2417 CHECK_CONS (tem);
2419 Lisp_Object tail;
2420 FOR_EACH_TAIL (tem)
2421 tail = tem;
2423 tem = args[argnum + 1];
2424 Fsetcdr (tail, tem);
2425 if (NILP (tem))
2426 args[argnum + 1] = tail;
2429 return val;
2432 /* This is the guts of all mapping functions.
2433 Apply FN to each element of SEQ, one by one, storing the results
2434 into elements of VALS, a C vector of Lisp_Objects. LENI is the
2435 length of VALS, which should also be the length of SEQ. Return the
2436 number of results; although this is normally LENI, it can be less
2437 if SEQ is made shorter as a side effect of FN. */
2439 static EMACS_INT
2440 mapcar1 (EMACS_INT leni, Lisp_Object *vals, Lisp_Object fn, Lisp_Object seq)
2442 Lisp_Object tail, dummy;
2443 EMACS_INT i;
2445 if (VECTORP (seq) || COMPILEDP (seq))
2447 for (i = 0; i < leni; i++)
2449 dummy = call1 (fn, AREF (seq, i));
2450 if (vals)
2451 vals[i] = dummy;
2454 else if (BOOL_VECTOR_P (seq))
2456 for (i = 0; i < leni; i++)
2458 dummy = call1 (fn, bool_vector_ref (seq, i));
2459 if (vals)
2460 vals[i] = dummy;
2463 else if (STRINGP (seq))
2465 ptrdiff_t i_byte;
2467 for (i = 0, i_byte = 0; i < leni;)
2469 int c;
2470 ptrdiff_t i_before = i;
2472 FETCH_STRING_CHAR_ADVANCE (c, seq, i, i_byte);
2473 XSETFASTINT (dummy, c);
2474 dummy = call1 (fn, dummy);
2475 if (vals)
2476 vals[i_before] = dummy;
2479 else /* Must be a list, since Flength did not get an error */
2481 tail = seq;
2482 for (i = 0; i < leni; i++)
2484 if (! CONSP (tail))
2485 return i;
2486 dummy = call1 (fn, XCAR (tail));
2487 if (vals)
2488 vals[i] = dummy;
2489 tail = XCDR (tail);
2493 return leni;
2496 DEFUN ("mapconcat", Fmapconcat, Smapconcat, 3, 3, 0,
2497 doc: /* Apply FUNCTION to each element of SEQUENCE, and concat the results as strings.
2498 In between each pair of results, stick in SEPARATOR. Thus, " " as
2499 SEPARATOR results in spaces between the values returned by FUNCTION.
2500 SEQUENCE may be a list, a vector, a bool-vector, or a string. */)
2501 (Lisp_Object function, Lisp_Object sequence, Lisp_Object separator)
2503 USE_SAFE_ALLOCA;
2504 EMACS_INT leni = XFASTINT (Flength (sequence));
2505 if (CHAR_TABLE_P (sequence))
2506 wrong_type_argument (Qlistp, sequence);
2507 EMACS_INT args_alloc = 2 * leni - 1;
2508 if (args_alloc < 0)
2509 return empty_unibyte_string;
2510 Lisp_Object *args;
2511 SAFE_ALLOCA_LISP (args, args_alloc);
2512 ptrdiff_t nmapped = mapcar1 (leni, args, function, sequence);
2513 ptrdiff_t nargs = 2 * nmapped - 1;
2515 for (ptrdiff_t i = nmapped - 1; i > 0; i--)
2516 args[i + i] = args[i];
2518 for (ptrdiff_t i = 1; i < nargs; i += 2)
2519 args[i] = separator;
2521 Lisp_Object ret = Fconcat (nargs, args);
2522 SAFE_FREE ();
2523 return ret;
2526 DEFUN ("mapcar", Fmapcar, Smapcar, 2, 2, 0,
2527 doc: /* Apply FUNCTION to each element of SEQUENCE, and make a list of the results.
2528 The result is a list just as long as SEQUENCE.
2529 SEQUENCE may be a list, a vector, a bool-vector, or a string. */)
2530 (Lisp_Object function, Lisp_Object sequence)
2532 USE_SAFE_ALLOCA;
2533 EMACS_INT leni = XFASTINT (Flength (sequence));
2534 if (CHAR_TABLE_P (sequence))
2535 wrong_type_argument (Qlistp, sequence);
2536 Lisp_Object *args;
2537 SAFE_ALLOCA_LISP (args, leni);
2538 ptrdiff_t nmapped = mapcar1 (leni, args, function, sequence);
2539 Lisp_Object ret = Flist (nmapped, args);
2540 SAFE_FREE ();
2541 return ret;
2544 DEFUN ("mapc", Fmapc, Smapc, 2, 2, 0,
2545 doc: /* Apply FUNCTION to each element of SEQUENCE for side effects only.
2546 Unlike `mapcar', don't accumulate the results. Return SEQUENCE.
2547 SEQUENCE may be a list, a vector, a bool-vector, or a string. */)
2548 (Lisp_Object function, Lisp_Object sequence)
2550 register EMACS_INT leni;
2552 leni = XFASTINT (Flength (sequence));
2553 if (CHAR_TABLE_P (sequence))
2554 wrong_type_argument (Qlistp, sequence);
2555 mapcar1 (leni, 0, function, sequence);
2557 return sequence;
2560 DEFUN ("mapcan", Fmapcan, Smapcan, 2, 2, 0,
2561 doc: /* Apply FUNCTION to each element of SEQUENCE, and concatenate
2562 the results by altering them (using `nconc').
2563 SEQUENCE may be a list, a vector, a bool-vector, or a string. */)
2564 (Lisp_Object function, Lisp_Object sequence)
2566 USE_SAFE_ALLOCA;
2567 EMACS_INT leni = XFASTINT (Flength (sequence));
2568 if (CHAR_TABLE_P (sequence))
2569 wrong_type_argument (Qlistp, sequence);
2570 Lisp_Object *args;
2571 SAFE_ALLOCA_LISP (args, leni);
2572 ptrdiff_t nmapped = mapcar1 (leni, args, function, sequence);
2573 Lisp_Object ret = Fnconc (nmapped, args);
2574 SAFE_FREE ();
2575 return ret;
2578 /* This is how C code calls `yes-or-no-p' and allows the user
2579 to redefine it. */
2581 Lisp_Object
2582 do_yes_or_no_p (Lisp_Object prompt)
2584 return call1 (intern ("yes-or-no-p"), prompt);
2587 DEFUN ("yes-or-no-p", Fyes_or_no_p, Syes_or_no_p, 1, 1, 0,
2588 doc: /* Ask user a yes-or-no question.
2589 Return t if answer is yes, and nil if the answer is no.
2590 PROMPT is the string to display to ask the question. It should end in
2591 a space; `yes-or-no-p' adds \"(yes or no) \" to it.
2593 The user must confirm the answer with RET, and can edit it until it
2594 has been confirmed.
2596 If dialog boxes are supported, a dialog box will be used
2597 if `last-nonmenu-event' is nil, and `use-dialog-box' is non-nil. */)
2598 (Lisp_Object prompt)
2600 Lisp_Object ans;
2602 CHECK_STRING (prompt);
2604 if ((NILP (last_nonmenu_event) || CONSP (last_nonmenu_event))
2605 && use_dialog_box && ! NILP (last_input_event))
2607 Lisp_Object pane, menu, obj;
2608 redisplay_preserve_echo_area (4);
2609 pane = list2 (Fcons (build_string ("Yes"), Qt),
2610 Fcons (build_string ("No"), Qnil));
2611 menu = Fcons (prompt, pane);
2612 obj = Fx_popup_dialog (Qt, menu, Qnil);
2613 return obj;
2616 AUTO_STRING (yes_or_no, "(yes or no) ");
2617 prompt = CALLN (Fconcat, prompt, yes_or_no);
2619 while (1)
2621 ans = Fdowncase (Fread_from_minibuffer (prompt, Qnil, Qnil, Qnil,
2622 Qyes_or_no_p_history, Qnil,
2623 Qnil));
2624 if (SCHARS (ans) == 3 && !strcmp (SSDATA (ans), "yes"))
2625 return Qt;
2626 if (SCHARS (ans) == 2 && !strcmp (SSDATA (ans), "no"))
2627 return Qnil;
2629 Fding (Qnil);
2630 Fdiscard_input ();
2631 message1 ("Please answer yes or no.");
2632 Fsleep_for (make_number (2), Qnil);
2636 DEFUN ("load-average", Fload_average, Sload_average, 0, 1, 0,
2637 doc: /* Return list of 1 minute, 5 minute and 15 minute load averages.
2639 Each of the three load averages is multiplied by 100, then converted
2640 to integer.
2642 When USE-FLOATS is non-nil, floats will be used instead of integers.
2643 These floats are not multiplied by 100.
2645 If the 5-minute or 15-minute load averages are not available, return a
2646 shortened list, containing only those averages which are available.
2648 An error is thrown if the load average can't be obtained. In some
2649 cases making it work would require Emacs being installed setuid or
2650 setgid so that it can read kernel information, and that usually isn't
2651 advisable. */)
2652 (Lisp_Object use_floats)
2654 double load_ave[3];
2655 int loads = getloadavg (load_ave, 3);
2656 Lisp_Object ret = Qnil;
2658 if (loads < 0)
2659 error ("load-average not implemented for this operating system");
2661 while (loads-- > 0)
2663 Lisp_Object load = (NILP (use_floats)
2664 ? make_number (100.0 * load_ave[loads])
2665 : make_float (load_ave[loads]));
2666 ret = Fcons (load, ret);
2669 return ret;
2672 DEFUN ("featurep", Ffeaturep, Sfeaturep, 1, 2, 0,
2673 doc: /* Return t if FEATURE is present in this Emacs.
2675 Use this to conditionalize execution of lisp code based on the
2676 presence or absence of Emacs or environment extensions.
2677 Use `provide' to declare that a feature is available. This function
2678 looks at the value of the variable `features'. The optional argument
2679 SUBFEATURE can be used to check a specific subfeature of FEATURE. */)
2680 (Lisp_Object feature, Lisp_Object subfeature)
2682 register Lisp_Object tem;
2683 CHECK_SYMBOL (feature);
2684 tem = Fmemq (feature, Vfeatures);
2685 if (!NILP (tem) && !NILP (subfeature))
2686 tem = Fmember (subfeature, Fget (feature, Qsubfeatures));
2687 return (NILP (tem)) ? Qnil : Qt;
2690 DEFUN ("provide", Fprovide, Sprovide, 1, 2, 0,
2691 doc: /* Announce that FEATURE is a feature of the current Emacs.
2692 The optional argument SUBFEATURES should be a list of symbols listing
2693 particular subfeatures supported in this version of FEATURE. */)
2694 (Lisp_Object feature, Lisp_Object subfeatures)
2696 register Lisp_Object tem;
2697 CHECK_SYMBOL (feature);
2698 CHECK_LIST (subfeatures);
2699 if (!NILP (Vautoload_queue))
2700 Vautoload_queue = Fcons (Fcons (make_number (0), Vfeatures),
2701 Vautoload_queue);
2702 tem = Fmemq (feature, Vfeatures);
2703 if (NILP (tem))
2704 Vfeatures = Fcons (feature, Vfeatures);
2705 if (!NILP (subfeatures))
2706 Fput (feature, Qsubfeatures, subfeatures);
2707 LOADHIST_ATTACH (Fcons (Qprovide, feature));
2709 /* Run any load-hooks for this file. */
2710 tem = Fassq (feature, Vafter_load_alist);
2711 if (CONSP (tem))
2712 Fmapc (Qfuncall, XCDR (tem));
2714 return feature;
2717 /* `require' and its subroutines. */
2719 /* List of features currently being require'd, innermost first. */
2721 static Lisp_Object require_nesting_list;
2723 static void
2724 require_unwind (Lisp_Object old_value)
2726 require_nesting_list = old_value;
2729 DEFUN ("require", Frequire, Srequire, 1, 3, 0,
2730 doc: /* If feature FEATURE is not loaded, load it from FILENAME.
2731 If FEATURE is not a member of the list `features', then the feature is
2732 not loaded; so load the file FILENAME.
2734 If FILENAME is omitted, the printname of FEATURE is used as the file
2735 name, and `load' will try to load this name appended with the suffix
2736 `.elc', `.el', or the system-dependent suffix for dynamic module
2737 files, in that order. The name without appended suffix will not be
2738 used. See `get-load-suffixes' for the complete list of suffixes.
2740 The directories in `load-path' are searched when trying to find the
2741 file name.
2743 If the optional third argument NOERROR is non-nil, then return nil if
2744 the file is not found instead of signaling an error. Normally the
2745 return value is FEATURE.
2747 The normal messages at start and end of loading FILENAME are
2748 suppressed. */)
2749 (Lisp_Object feature, Lisp_Object filename, Lisp_Object noerror)
2751 Lisp_Object tem;
2752 bool from_file = load_in_progress;
2754 CHECK_SYMBOL (feature);
2756 /* Record the presence of `require' in this file
2757 even if the feature specified is already loaded.
2758 But not more than once in any file,
2759 and not when we aren't loading or reading from a file. */
2760 if (!from_file)
2761 for (tem = Vcurrent_load_list; CONSP (tem); tem = XCDR (tem))
2762 if (NILP (XCDR (tem)) && STRINGP (XCAR (tem)))
2763 from_file = 1;
2765 if (from_file)
2767 tem = Fcons (Qrequire, feature);
2768 if (NILP (Fmember (tem, Vcurrent_load_list)))
2769 LOADHIST_ATTACH (tem);
2771 tem = Fmemq (feature, Vfeatures);
2773 if (NILP (tem))
2775 ptrdiff_t count = SPECPDL_INDEX ();
2776 int nesting = 0;
2778 /* This is to make sure that loadup.el gives a clear picture
2779 of what files are preloaded and when. */
2780 if (! NILP (Vpurify_flag))
2781 error ("(require %s) while preparing to dump",
2782 SDATA (SYMBOL_NAME (feature)));
2784 /* A certain amount of recursive `require' is legitimate,
2785 but if we require the same feature recursively 3 times,
2786 signal an error. */
2787 tem = require_nesting_list;
2788 while (! NILP (tem))
2790 if (! NILP (Fequal (feature, XCAR (tem))))
2791 nesting++;
2792 tem = XCDR (tem);
2794 if (nesting > 3)
2795 error ("Recursive `require' for feature `%s'",
2796 SDATA (SYMBOL_NAME (feature)));
2798 /* Update the list for any nested `require's that occur. */
2799 record_unwind_protect (require_unwind, require_nesting_list);
2800 require_nesting_list = Fcons (feature, require_nesting_list);
2802 /* Value saved here is to be restored into Vautoload_queue */
2803 record_unwind_protect (un_autoload, Vautoload_queue);
2804 Vautoload_queue = Qt;
2806 /* Load the file. */
2807 tem = Fload (NILP (filename) ? Fsymbol_name (feature) : filename,
2808 noerror, Qt, Qnil, (NILP (filename) ? Qt : Qnil));
2810 /* If load failed entirely, return nil. */
2811 if (NILP (tem))
2812 return unbind_to (count, Qnil);
2814 tem = Fmemq (feature, Vfeatures);
2815 if (NILP (tem))
2817 unsigned char *tem2 = SDATA (SYMBOL_NAME (feature));
2818 Lisp_Object tem3 = Fcar (Fcar (Vload_history));
2820 if (NILP (tem3))
2821 error ("Required feature `%s' was not provided", tem2);
2822 else
2823 /* Cf autoload-do-load. */
2824 error ("Loading file %s failed to provide feature `%s'",
2825 SDATA (tem3), tem2);
2828 /* Once loading finishes, don't undo it. */
2829 Vautoload_queue = Qt;
2830 feature = unbind_to (count, feature);
2833 return feature;
2836 /* Primitives for work of the "widget" library.
2837 In an ideal world, this section would not have been necessary.
2838 However, lisp function calls being as slow as they are, it turns
2839 out that some functions in the widget library (wid-edit.el) are the
2840 bottleneck of Widget operation. Here is their translation to C,
2841 for the sole reason of efficiency. */
2843 DEFUN ("plist-member", Fplist_member, Splist_member, 2, 2, 0,
2844 doc: /* Return non-nil if PLIST has the property PROP.
2845 PLIST is a property list, which is a list of the form
2846 \(PROP1 VALUE1 PROP2 VALUE2 ...). PROP is a symbol.
2847 Unlike `plist-get', this allows you to distinguish between a missing
2848 property and a property with the value nil.
2849 The value is actually the tail of PLIST whose car is PROP. */)
2850 (Lisp_Object plist, Lisp_Object prop)
2852 Lisp_Object tail = plist;
2853 FOR_EACH_TAIL (tail)
2855 if (EQ (XCAR (tail), prop))
2856 return tail;
2857 tail = XCDR (tail);
2858 if (! CONSP (tail))
2859 break;
2860 if (EQ (tail, li.tortoise))
2861 circular_list (tail);
2863 CHECK_TYPE (NILP (tail), Qplistp, plist);
2864 return Qnil;
2867 DEFUN ("widget-put", Fwidget_put, Swidget_put, 3, 3, 0,
2868 doc: /* In WIDGET, set PROPERTY to VALUE.
2869 The value can later be retrieved with `widget-get'. */)
2870 (Lisp_Object widget, Lisp_Object property, Lisp_Object value)
2872 CHECK_CONS (widget);
2873 XSETCDR (widget, Fplist_put (XCDR (widget), property, value));
2874 return value;
2877 DEFUN ("widget-get", Fwidget_get, Swidget_get, 2, 2, 0,
2878 doc: /* In WIDGET, get the value of PROPERTY.
2879 The value could either be specified when the widget was created, or
2880 later with `widget-put'. */)
2881 (Lisp_Object widget, Lisp_Object property)
2883 Lisp_Object tmp;
2885 while (1)
2887 if (NILP (widget))
2888 return Qnil;
2889 CHECK_CONS (widget);
2890 tmp = Fplist_member (XCDR (widget), property);
2891 if (CONSP (tmp))
2893 tmp = XCDR (tmp);
2894 return CAR (tmp);
2896 tmp = XCAR (widget);
2897 if (NILP (tmp))
2898 return Qnil;
2899 widget = Fget (tmp, Qwidget_type);
2903 DEFUN ("widget-apply", Fwidget_apply, Swidget_apply, 2, MANY, 0,
2904 doc: /* Apply the value of WIDGET's PROPERTY to the widget itself.
2905 ARGS are passed as extra arguments to the function.
2906 usage: (widget-apply WIDGET PROPERTY &rest ARGS) */)
2907 (ptrdiff_t nargs, Lisp_Object *args)
2909 Lisp_Object widget = args[0];
2910 Lisp_Object property = args[1];
2911 Lisp_Object propval = Fwidget_get (widget, property);
2912 Lisp_Object trailing_args = Flist (nargs - 2, args + 2);
2913 Lisp_Object result = CALLN (Fapply, propval, widget, trailing_args);
2914 return result;
2917 #ifdef HAVE_LANGINFO_CODESET
2918 #include <langinfo.h>
2919 #endif
2921 DEFUN ("locale-info", Flocale_info, Slocale_info, 1, 1, 0,
2922 doc: /* Access locale data ITEM for the current C locale, if available.
2923 ITEM should be one of the following:
2925 `codeset', returning the character set as a string (locale item CODESET);
2927 `days', returning a 7-element vector of day names (locale items DAY_n);
2929 `months', returning a 12-element vector of month names (locale items MON_n);
2931 `paper', returning a list (WIDTH HEIGHT) for the default paper size,
2932 both measured in millimeters (locale items PAPER_WIDTH, PAPER_HEIGHT).
2934 If the system can't provide such information through a call to
2935 `nl_langinfo', or if ITEM isn't from the list above, return nil.
2937 See also Info node `(libc)Locales'.
2939 The data read from the system are decoded using `locale-coding-system'. */)
2940 (Lisp_Object item)
2942 char *str = NULL;
2943 #ifdef HAVE_LANGINFO_CODESET
2944 if (EQ (item, Qcodeset))
2946 str = nl_langinfo (CODESET);
2947 return build_string (str);
2949 #ifdef DAY_1
2950 else if (EQ (item, Qdays)) /* e.g. for calendar-day-name-array */
2952 Lisp_Object v = Fmake_vector (make_number (7), Qnil);
2953 const int days[7] = {DAY_1, DAY_2, DAY_3, DAY_4, DAY_5, DAY_6, DAY_7};
2954 int i;
2955 synchronize_system_time_locale ();
2956 for (i = 0; i < 7; i++)
2958 str = nl_langinfo (days[i]);
2959 AUTO_STRING (val, str);
2960 /* Fixme: Is this coding system necessarily right, even if
2961 it is consistent with CODESET? If not, what to do? */
2962 ASET (v, i, code_convert_string_norecord (val, Vlocale_coding_system,
2963 0));
2965 return v;
2967 #endif /* DAY_1 */
2968 #ifdef MON_1
2969 else if (EQ (item, Qmonths)) /* e.g. for calendar-month-name-array */
2971 Lisp_Object v = Fmake_vector (make_number (12), Qnil);
2972 const int months[12] = {MON_1, MON_2, MON_3, MON_4, MON_5, MON_6, MON_7,
2973 MON_8, MON_9, MON_10, MON_11, MON_12};
2974 int i;
2975 synchronize_system_time_locale ();
2976 for (i = 0; i < 12; i++)
2978 str = nl_langinfo (months[i]);
2979 AUTO_STRING (val, str);
2980 ASET (v, i, code_convert_string_norecord (val, Vlocale_coding_system,
2981 0));
2983 return v;
2985 #endif /* MON_1 */
2986 /* LC_PAPER stuff isn't defined as accessible in glibc as of 2.3.1,
2987 but is in the locale files. This could be used by ps-print. */
2988 #ifdef PAPER_WIDTH
2989 else if (EQ (item, Qpaper))
2990 return list2i (nl_langinfo (PAPER_WIDTH), nl_langinfo (PAPER_HEIGHT));
2991 #endif /* PAPER_WIDTH */
2992 #endif /* HAVE_LANGINFO_CODESET*/
2993 return Qnil;
2996 /* base64 encode/decode functions (RFC 2045).
2997 Based on code from GNU recode. */
2999 #define MIME_LINE_LENGTH 76
3001 #define IS_ASCII(Character) \
3002 ((Character) < 128)
3003 #define IS_BASE64(Character) \
3004 (IS_ASCII (Character) && base64_char_to_value[Character] >= 0)
3005 #define IS_BASE64_IGNORABLE(Character) \
3006 ((Character) == ' ' || (Character) == '\t' || (Character) == '\n' \
3007 || (Character) == '\f' || (Character) == '\r')
3009 /* Used by base64_decode_1 to retrieve a non-base64-ignorable
3010 character or return retval if there are no characters left to
3011 process. */
3012 #define READ_QUADRUPLET_BYTE(retval) \
3013 do \
3015 if (i == length) \
3017 if (nchars_return) \
3018 *nchars_return = nchars; \
3019 return (retval); \
3021 c = from[i++]; \
3023 while (IS_BASE64_IGNORABLE (c))
3025 /* Table of characters coding the 64 values. */
3026 static const char base64_value_to_char[64] =
3028 'A', 'B', 'C', 'D', 'E', 'F', 'G', 'H', 'I', 'J', /* 0- 9 */
3029 'K', 'L', 'M', 'N', 'O', 'P', 'Q', 'R', 'S', 'T', /* 10-19 */
3030 'U', 'V', 'W', 'X', 'Y', 'Z', 'a', 'b', 'c', 'd', /* 20-29 */
3031 'e', 'f', 'g', 'h', 'i', 'j', 'k', 'l', 'm', 'n', /* 30-39 */
3032 'o', 'p', 'q', 'r', 's', 't', 'u', 'v', 'w', 'x', /* 40-49 */
3033 'y', 'z', '0', '1', '2', '3', '4', '5', '6', '7', /* 50-59 */
3034 '8', '9', '+', '/' /* 60-63 */
3037 /* Table of base64 values for first 128 characters. */
3038 static const short base64_char_to_value[128] =
3040 -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, /* 0- 9 */
3041 -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, /* 10- 19 */
3042 -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, /* 20- 29 */
3043 -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, /* 30- 39 */
3044 -1, -1, -1, 62, -1, -1, -1, 63, 52, 53, /* 40- 49 */
3045 54, 55, 56, 57, 58, 59, 60, 61, -1, -1, /* 50- 59 */
3046 -1, -1, -1, -1, -1, 0, 1, 2, 3, 4, /* 60- 69 */
3047 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, /* 70- 79 */
3048 15, 16, 17, 18, 19, 20, 21, 22, 23, 24, /* 80- 89 */
3049 25, -1, -1, -1, -1, -1, -1, 26, 27, 28, /* 90- 99 */
3050 29, 30, 31, 32, 33, 34, 35, 36, 37, 38, /* 100-109 */
3051 39, 40, 41, 42, 43, 44, 45, 46, 47, 48, /* 110-119 */
3052 49, 50, 51, -1, -1, -1, -1, -1 /* 120-127 */
3055 /* The following diagram shows the logical steps by which three octets
3056 get transformed into four base64 characters.
3058 .--------. .--------. .--------.
3059 |aaaaaabb| |bbbbcccc| |ccdddddd|
3060 `--------' `--------' `--------'
3061 6 2 4 4 2 6
3062 .--------+--------+--------+--------.
3063 |00aaaaaa|00bbbbbb|00cccccc|00dddddd|
3064 `--------+--------+--------+--------'
3066 .--------+--------+--------+--------.
3067 |AAAAAAAA|BBBBBBBB|CCCCCCCC|DDDDDDDD|
3068 `--------+--------+--------+--------'
3070 The octets are divided into 6 bit chunks, which are then encoded into
3071 base64 characters. */
3074 static ptrdiff_t base64_encode_1 (const char *, char *, ptrdiff_t, bool, bool);
3075 static ptrdiff_t base64_decode_1 (const char *, char *, ptrdiff_t, bool,
3076 ptrdiff_t *);
3078 DEFUN ("base64-encode-region", Fbase64_encode_region, Sbase64_encode_region,
3079 2, 3, "r",
3080 doc: /* Base64-encode the region between BEG and END.
3081 Return the length of the encoded text.
3082 Optional third argument NO-LINE-BREAK means do not break long lines
3083 into shorter lines. */)
3084 (Lisp_Object beg, Lisp_Object end, Lisp_Object no_line_break)
3086 char *encoded;
3087 ptrdiff_t allength, length;
3088 ptrdiff_t ibeg, iend, encoded_length;
3089 ptrdiff_t old_pos = PT;
3090 USE_SAFE_ALLOCA;
3092 validate_region (&beg, &end);
3094 ibeg = CHAR_TO_BYTE (XFASTINT (beg));
3095 iend = CHAR_TO_BYTE (XFASTINT (end));
3096 move_gap_both (XFASTINT (beg), ibeg);
3098 /* We need to allocate enough room for encoding the text.
3099 We need 33 1/3% more space, plus a newline every 76
3100 characters, and then we round up. */
3101 length = iend - ibeg;
3102 allength = length + length/3 + 1;
3103 allength += allength / MIME_LINE_LENGTH + 1 + 6;
3105 encoded = SAFE_ALLOCA (allength);
3106 encoded_length = base64_encode_1 ((char *) BYTE_POS_ADDR (ibeg),
3107 encoded, length, NILP (no_line_break),
3108 !NILP (BVAR (current_buffer, enable_multibyte_characters)));
3109 if (encoded_length > allength)
3110 emacs_abort ();
3112 if (encoded_length < 0)
3114 /* The encoding wasn't possible. */
3115 SAFE_FREE ();
3116 error ("Multibyte character in data for base64 encoding");
3119 /* Now we have encoded the region, so we insert the new contents
3120 and delete the old. (Insert first in order to preserve markers.) */
3121 SET_PT_BOTH (XFASTINT (beg), ibeg);
3122 insert (encoded, encoded_length);
3123 SAFE_FREE ();
3124 del_range_byte (ibeg + encoded_length, iend + encoded_length);
3126 /* If point was outside of the region, restore it exactly; else just
3127 move to the beginning of the region. */
3128 if (old_pos >= XFASTINT (end))
3129 old_pos += encoded_length - (XFASTINT (end) - XFASTINT (beg));
3130 else if (old_pos > XFASTINT (beg))
3131 old_pos = XFASTINT (beg);
3132 SET_PT (old_pos);
3134 /* We return the length of the encoded text. */
3135 return make_number (encoded_length);
3138 DEFUN ("base64-encode-string", Fbase64_encode_string, Sbase64_encode_string,
3139 1, 2, 0,
3140 doc: /* Base64-encode STRING and return the result.
3141 Optional second argument NO-LINE-BREAK means do not break long lines
3142 into shorter lines. */)
3143 (Lisp_Object string, Lisp_Object no_line_break)
3145 ptrdiff_t allength, length, encoded_length;
3146 char *encoded;
3147 Lisp_Object encoded_string;
3148 USE_SAFE_ALLOCA;
3150 CHECK_STRING (string);
3152 /* We need to allocate enough room for encoding the text.
3153 We need 33 1/3% more space, plus a newline every 76
3154 characters, and then we round up. */
3155 length = SBYTES (string);
3156 allength = length + length/3 + 1;
3157 allength += allength / MIME_LINE_LENGTH + 1 + 6;
3159 /* We need to allocate enough room for decoding the text. */
3160 encoded = SAFE_ALLOCA (allength);
3162 encoded_length = base64_encode_1 (SSDATA (string),
3163 encoded, length, NILP (no_line_break),
3164 STRING_MULTIBYTE (string));
3165 if (encoded_length > allength)
3166 emacs_abort ();
3168 if (encoded_length < 0)
3170 /* The encoding wasn't possible. */
3171 error ("Multibyte character in data for base64 encoding");
3174 encoded_string = make_unibyte_string (encoded, encoded_length);
3175 SAFE_FREE ();
3177 return encoded_string;
3180 static ptrdiff_t
3181 base64_encode_1 (const char *from, char *to, ptrdiff_t length,
3182 bool line_break, bool multibyte)
3184 int counter = 0;
3185 ptrdiff_t i = 0;
3186 char *e = to;
3187 int c;
3188 unsigned int value;
3189 int bytes;
3191 while (i < length)
3193 if (multibyte)
3195 c = STRING_CHAR_AND_LENGTH ((unsigned char *) from + i, bytes);
3196 if (CHAR_BYTE8_P (c))
3197 c = CHAR_TO_BYTE8 (c);
3198 else if (c >= 256)
3199 return -1;
3200 i += bytes;
3202 else
3203 c = from[i++];
3205 /* Wrap line every 76 characters. */
3207 if (line_break)
3209 if (counter < MIME_LINE_LENGTH / 4)
3210 counter++;
3211 else
3213 *e++ = '\n';
3214 counter = 1;
3218 /* Process first byte of a triplet. */
3220 *e++ = base64_value_to_char[0x3f & c >> 2];
3221 value = (0x03 & c) << 4;
3223 /* Process second byte of a triplet. */
3225 if (i == length)
3227 *e++ = base64_value_to_char[value];
3228 *e++ = '=';
3229 *e++ = '=';
3230 break;
3233 if (multibyte)
3235 c = STRING_CHAR_AND_LENGTH ((unsigned char *) from + i, bytes);
3236 if (CHAR_BYTE8_P (c))
3237 c = CHAR_TO_BYTE8 (c);
3238 else if (c >= 256)
3239 return -1;
3240 i += bytes;
3242 else
3243 c = from[i++];
3245 *e++ = base64_value_to_char[value | (0x0f & c >> 4)];
3246 value = (0x0f & c) << 2;
3248 /* Process third byte of a triplet. */
3250 if (i == length)
3252 *e++ = base64_value_to_char[value];
3253 *e++ = '=';
3254 break;
3257 if (multibyte)
3259 c = STRING_CHAR_AND_LENGTH ((unsigned char *) from + i, bytes);
3260 if (CHAR_BYTE8_P (c))
3261 c = CHAR_TO_BYTE8 (c);
3262 else if (c >= 256)
3263 return -1;
3264 i += bytes;
3266 else
3267 c = from[i++];
3269 *e++ = base64_value_to_char[value | (0x03 & c >> 6)];
3270 *e++ = base64_value_to_char[0x3f & c];
3273 return e - to;
3277 DEFUN ("base64-decode-region", Fbase64_decode_region, Sbase64_decode_region,
3278 2, 2, "r",
3279 doc: /* Base64-decode the region between BEG and END.
3280 Return the length of the decoded text.
3281 If the region can't be decoded, signal an error and don't modify the buffer. */)
3282 (Lisp_Object beg, Lisp_Object end)
3284 ptrdiff_t ibeg, iend, length, allength;
3285 char *decoded;
3286 ptrdiff_t old_pos = PT;
3287 ptrdiff_t decoded_length;
3288 ptrdiff_t inserted_chars;
3289 bool multibyte = !NILP (BVAR (current_buffer, enable_multibyte_characters));
3290 USE_SAFE_ALLOCA;
3292 validate_region (&beg, &end);
3294 ibeg = CHAR_TO_BYTE (XFASTINT (beg));
3295 iend = CHAR_TO_BYTE (XFASTINT (end));
3297 length = iend - ibeg;
3299 /* We need to allocate enough room for decoding the text. If we are
3300 working on a multibyte buffer, each decoded code may occupy at
3301 most two bytes. */
3302 allength = multibyte ? length * 2 : length;
3303 decoded = SAFE_ALLOCA (allength);
3305 move_gap_both (XFASTINT (beg), ibeg);
3306 decoded_length = base64_decode_1 ((char *) BYTE_POS_ADDR (ibeg),
3307 decoded, length,
3308 multibyte, &inserted_chars);
3309 if (decoded_length > allength)
3310 emacs_abort ();
3312 if (decoded_length < 0)
3314 /* The decoding wasn't possible. */
3315 error ("Invalid base64 data");
3318 /* Now we have decoded the region, so we insert the new contents
3319 and delete the old. (Insert first in order to preserve markers.) */
3320 TEMP_SET_PT_BOTH (XFASTINT (beg), ibeg);
3321 insert_1_both (decoded, inserted_chars, decoded_length, 0, 1, 0);
3322 signal_after_change (XFASTINT (beg), 0, inserted_chars);
3323 SAFE_FREE ();
3325 /* Delete the original text. */
3326 del_range_both (PT, PT_BYTE, XFASTINT (end) + inserted_chars,
3327 iend + decoded_length, 1);
3329 /* If point was outside of the region, restore it exactly; else just
3330 move to the beginning of the region. */
3331 if (old_pos >= XFASTINT (end))
3332 old_pos += inserted_chars - (XFASTINT (end) - XFASTINT (beg));
3333 else if (old_pos > XFASTINT (beg))
3334 old_pos = XFASTINT (beg);
3335 SET_PT (old_pos > ZV ? ZV : old_pos);
3337 return make_number (inserted_chars);
3340 DEFUN ("base64-decode-string", Fbase64_decode_string, Sbase64_decode_string,
3341 1, 1, 0,
3342 doc: /* Base64-decode STRING and return the result. */)
3343 (Lisp_Object string)
3345 char *decoded;
3346 ptrdiff_t length, decoded_length;
3347 Lisp_Object decoded_string;
3348 USE_SAFE_ALLOCA;
3350 CHECK_STRING (string);
3352 length = SBYTES (string);
3353 /* We need to allocate enough room for decoding the text. */
3354 decoded = SAFE_ALLOCA (length);
3356 /* The decoded result should be unibyte. */
3357 decoded_length = base64_decode_1 (SSDATA (string), decoded, length,
3358 0, NULL);
3359 if (decoded_length > length)
3360 emacs_abort ();
3361 else if (decoded_length >= 0)
3362 decoded_string = make_unibyte_string (decoded, decoded_length);
3363 else
3364 decoded_string = Qnil;
3366 SAFE_FREE ();
3367 if (!STRINGP (decoded_string))
3368 error ("Invalid base64 data");
3370 return decoded_string;
3373 /* Base64-decode the data at FROM of LENGTH bytes into TO. If
3374 MULTIBYTE, the decoded result should be in multibyte
3375 form. If NCHARS_RETURN is not NULL, store the number of produced
3376 characters in *NCHARS_RETURN. */
3378 static ptrdiff_t
3379 base64_decode_1 (const char *from, char *to, ptrdiff_t length,
3380 bool multibyte, ptrdiff_t *nchars_return)
3382 ptrdiff_t i = 0; /* Used inside READ_QUADRUPLET_BYTE */
3383 char *e = to;
3384 unsigned char c;
3385 unsigned long value;
3386 ptrdiff_t nchars = 0;
3388 while (1)
3390 /* Process first byte of a quadruplet. */
3392 READ_QUADRUPLET_BYTE (e-to);
3394 if (!IS_BASE64 (c))
3395 return -1;
3396 value = base64_char_to_value[c] << 18;
3398 /* Process second byte of a quadruplet. */
3400 READ_QUADRUPLET_BYTE (-1);
3402 if (!IS_BASE64 (c))
3403 return -1;
3404 value |= base64_char_to_value[c] << 12;
3406 c = (unsigned char) (value >> 16);
3407 if (multibyte && c >= 128)
3408 e += BYTE8_STRING (c, e);
3409 else
3410 *e++ = c;
3411 nchars++;
3413 /* Process third byte of a quadruplet. */
3415 READ_QUADRUPLET_BYTE (-1);
3417 if (c == '=')
3419 READ_QUADRUPLET_BYTE (-1);
3421 if (c != '=')
3422 return -1;
3423 continue;
3426 if (!IS_BASE64 (c))
3427 return -1;
3428 value |= base64_char_to_value[c] << 6;
3430 c = (unsigned char) (0xff & value >> 8);
3431 if (multibyte && c >= 128)
3432 e += BYTE8_STRING (c, e);
3433 else
3434 *e++ = c;
3435 nchars++;
3437 /* Process fourth byte of a quadruplet. */
3439 READ_QUADRUPLET_BYTE (-1);
3441 if (c == '=')
3442 continue;
3444 if (!IS_BASE64 (c))
3445 return -1;
3446 value |= base64_char_to_value[c];
3448 c = (unsigned char) (0xff & value);
3449 if (multibyte && c >= 128)
3450 e += BYTE8_STRING (c, e);
3451 else
3452 *e++ = c;
3453 nchars++;
3459 /***********************************************************************
3460 ***** *****
3461 ***** Hash Tables *****
3462 ***** *****
3463 ***********************************************************************/
3465 /* Implemented by gerd@gnu.org. This hash table implementation was
3466 inspired by CMUCL hash tables. */
3468 /* Ideas:
3470 1. For small tables, association lists are probably faster than
3471 hash tables because they have lower overhead.
3473 For uses of hash tables where the O(1) behavior of table
3474 operations is not a requirement, it might therefore be a good idea
3475 not to hash. Instead, we could just do a linear search in the
3476 key_and_value vector of the hash table. This could be done
3477 if a `:linear-search t' argument is given to make-hash-table. */
3480 /* The list of all weak hash tables. Don't staticpro this one. */
3482 static struct Lisp_Hash_Table *weak_hash_tables;
3485 /***********************************************************************
3486 Utilities
3487 ***********************************************************************/
3489 static void
3490 CHECK_HASH_TABLE (Lisp_Object x)
3492 CHECK_TYPE (HASH_TABLE_P (x), Qhash_table_p, x);
3495 static void
3496 set_hash_key_and_value (struct Lisp_Hash_Table *h, Lisp_Object key_and_value)
3498 h->key_and_value = key_and_value;
3500 static void
3501 set_hash_next (struct Lisp_Hash_Table *h, Lisp_Object next)
3503 h->next = next;
3505 static void
3506 set_hash_next_slot (struct Lisp_Hash_Table *h, ptrdiff_t idx, ptrdiff_t val)
3508 gc_aset (h->next, idx, make_number (val));
3510 static void
3511 set_hash_hash (struct Lisp_Hash_Table *h, Lisp_Object hash)
3513 h->hash = hash;
3515 static void
3516 set_hash_hash_slot (struct Lisp_Hash_Table *h, ptrdiff_t idx, Lisp_Object val)
3518 gc_aset (h->hash, idx, val);
3520 static void
3521 set_hash_index (struct Lisp_Hash_Table *h, Lisp_Object index)
3523 h->index = index;
3525 static void
3526 set_hash_index_slot (struct Lisp_Hash_Table *h, ptrdiff_t idx, ptrdiff_t val)
3528 gc_aset (h->index, idx, make_number (val));
3531 /* If OBJ is a Lisp hash table, return a pointer to its struct
3532 Lisp_Hash_Table. Otherwise, signal an error. */
3534 static struct Lisp_Hash_Table *
3535 check_hash_table (Lisp_Object obj)
3537 CHECK_HASH_TABLE (obj);
3538 return XHASH_TABLE (obj);
3542 /* Value is the next integer I >= N, N >= 0 which is "almost" a prime
3543 number. A number is "almost" a prime number if it is not divisible
3544 by any integer in the range 2 .. (NEXT_ALMOST_PRIME_LIMIT - 1). */
3546 EMACS_INT
3547 next_almost_prime (EMACS_INT n)
3549 verify (NEXT_ALMOST_PRIME_LIMIT == 11);
3550 for (n |= 1; ; n += 2)
3551 if (n % 3 != 0 && n % 5 != 0 && n % 7 != 0)
3552 return n;
3556 /* Find KEY in ARGS which has size NARGS. Don't consider indices for
3557 which USED[I] is non-zero. If found at index I in ARGS, set
3558 USED[I] and USED[I + 1] to 1, and return I + 1. Otherwise return
3559 0. This function is used to extract a keyword/argument pair from
3560 a DEFUN parameter list. */
3562 static ptrdiff_t
3563 get_key_arg (Lisp_Object key, ptrdiff_t nargs, Lisp_Object *args, char *used)
3565 ptrdiff_t i;
3567 for (i = 1; i < nargs; i++)
3568 if (!used[i - 1] && EQ (args[i - 1], key))
3570 used[i - 1] = 1;
3571 used[i] = 1;
3572 return i;
3575 return 0;
3579 /* Return a Lisp vector which has the same contents as VEC but has
3580 at least INCR_MIN more entries, where INCR_MIN is positive.
3581 If NITEMS_MAX is not -1, do not grow the vector to be any larger
3582 than NITEMS_MAX. New entries in the resulting vector are
3583 uninitialized. */
3585 static Lisp_Object
3586 larger_vecalloc (Lisp_Object vec, ptrdiff_t incr_min, ptrdiff_t nitems_max)
3588 struct Lisp_Vector *v;
3589 ptrdiff_t incr, incr_max, old_size, new_size;
3590 ptrdiff_t C_language_max = min (PTRDIFF_MAX, SIZE_MAX) / sizeof *v->contents;
3591 ptrdiff_t n_max = (0 <= nitems_max && nitems_max < C_language_max
3592 ? nitems_max : C_language_max);
3593 eassert (VECTORP (vec));
3594 eassert (0 < incr_min && -1 <= nitems_max);
3595 old_size = ASIZE (vec);
3596 incr_max = n_max - old_size;
3597 incr = max (incr_min, min (old_size >> 1, incr_max));
3598 if (incr_max < incr)
3599 memory_full (SIZE_MAX);
3600 new_size = old_size + incr;
3601 v = allocate_vector (new_size);
3602 memcpy (v->contents, XVECTOR (vec)->contents, old_size * sizeof *v->contents);
3603 XSETVECTOR (vec, v);
3604 return vec;
3607 /* Likewise, except set new entries in the resulting vector to nil. */
3609 Lisp_Object
3610 larger_vector (Lisp_Object vec, ptrdiff_t incr_min, ptrdiff_t nitems_max)
3612 ptrdiff_t old_size = ASIZE (vec);
3613 Lisp_Object v = larger_vecalloc (vec, incr_min, nitems_max);
3614 ptrdiff_t new_size = ASIZE (v);
3615 memclear (XVECTOR (v)->contents + old_size,
3616 (new_size - old_size) * word_size);
3617 return v;
3621 /***********************************************************************
3622 Low-level Functions
3623 ***********************************************************************/
3625 /* Return the index of the next entry in H following the one at IDX,
3626 or -1 if none. */
3628 static ptrdiff_t
3629 HASH_NEXT (struct Lisp_Hash_Table *h, ptrdiff_t idx)
3631 return XINT (AREF (h->next, idx));
3634 /* Return the index of the element in hash table H that is the start
3635 of the collision list at index IDX, or -1 if the list is empty. */
3637 static ptrdiff_t
3638 HASH_INDEX (struct Lisp_Hash_Table *h, ptrdiff_t idx)
3640 return XINT (AREF (h->index, idx));
3643 /* Compare KEY1 which has hash code HASH1 and KEY2 with hash code
3644 HASH2 in hash table H using `eql'. Value is true if KEY1 and
3645 KEY2 are the same. */
3647 static bool
3648 cmpfn_eql (struct hash_table_test *ht,
3649 Lisp_Object key1,
3650 Lisp_Object key2)
3652 return (FLOATP (key1)
3653 && FLOATP (key2)
3654 && XFLOAT_DATA (key1) == XFLOAT_DATA (key2));
3658 /* Compare KEY1 which has hash code HASH1 and KEY2 with hash code
3659 HASH2 in hash table H using `equal'. Value is true if KEY1 and
3660 KEY2 are the same. */
3662 static bool
3663 cmpfn_equal (struct hash_table_test *ht,
3664 Lisp_Object key1,
3665 Lisp_Object key2)
3667 return !NILP (Fequal (key1, key2));
3671 /* Compare KEY1 which has hash code HASH1, and KEY2 with hash code
3672 HASH2 in hash table H using H->user_cmp_function. Value is true
3673 if KEY1 and KEY2 are the same. */
3675 static bool
3676 cmpfn_user_defined (struct hash_table_test *ht,
3677 Lisp_Object key1,
3678 Lisp_Object key2)
3680 return !NILP (call2 (ht->user_cmp_function, key1, key2));
3683 /* Value is a hash code for KEY for use in hash table H which uses
3684 `eq' to compare keys. The hash code returned is guaranteed to fit
3685 in a Lisp integer. */
3687 static EMACS_UINT
3688 hashfn_eq (struct hash_table_test *ht, Lisp_Object key)
3690 return XHASH (key) ^ XTYPE (key);
3693 /* Value is a hash code for KEY for use in hash table H which uses
3694 `equal' to compare keys. The hash code returned is guaranteed to fit
3695 in a Lisp integer. */
3697 static EMACS_UINT
3698 hashfn_equal (struct hash_table_test *ht, Lisp_Object key)
3700 return sxhash (key, 0);
3703 /* Value is a hash code for KEY for use in hash table H which uses
3704 `eql' to compare keys. The hash code returned is guaranteed to fit
3705 in a Lisp integer. */
3707 static EMACS_UINT
3708 hashfn_eql (struct hash_table_test *ht, Lisp_Object key)
3710 return FLOATP (key) ? hashfn_equal (ht, key) : hashfn_eq (ht, key);
3713 /* Value is a hash code for KEY for use in hash table H which uses as
3714 user-defined function to compare keys. The hash code returned is
3715 guaranteed to fit in a Lisp integer. */
3717 static EMACS_UINT
3718 hashfn_user_defined (struct hash_table_test *ht, Lisp_Object key)
3720 Lisp_Object hash = call1 (ht->user_hash_function, key);
3721 return hashfn_eq (ht, hash);
3724 struct hash_table_test const
3725 hashtest_eq = { LISPSYM_INITIALLY (Qeq), LISPSYM_INITIALLY (Qnil),
3726 LISPSYM_INITIALLY (Qnil), 0, hashfn_eq },
3727 hashtest_eql = { LISPSYM_INITIALLY (Qeql), LISPSYM_INITIALLY (Qnil),
3728 LISPSYM_INITIALLY (Qnil), cmpfn_eql, hashfn_eql },
3729 hashtest_equal = { LISPSYM_INITIALLY (Qequal), LISPSYM_INITIALLY (Qnil),
3730 LISPSYM_INITIALLY (Qnil), cmpfn_equal, hashfn_equal };
3732 /* Allocate basically initialized hash table. */
3734 static struct Lisp_Hash_Table *
3735 allocate_hash_table (void)
3737 return ALLOCATE_PSEUDOVECTOR (struct Lisp_Hash_Table,
3738 count, PVEC_HASH_TABLE);
3741 /* An upper bound on the size of a hash table index. It must fit in
3742 ptrdiff_t and be a valid Emacs fixnum. */
3743 #define INDEX_SIZE_BOUND \
3744 ((ptrdiff_t) min (MOST_POSITIVE_FIXNUM, PTRDIFF_MAX / word_size))
3746 /* Create and initialize a new hash table.
3748 TEST specifies the test the hash table will use to compare keys.
3749 It must be either one of the predefined tests `eq', `eql' or
3750 `equal' or a symbol denoting a user-defined test named TEST with
3751 test and hash functions USER_TEST and USER_HASH.
3753 Give the table initial capacity SIZE, 0 <= SIZE <= MOST_POSITIVE_FIXNUM.
3755 If REHASH_SIZE is equal to a negative integer, this hash table's
3756 new size when it becomes full is computed by subtracting
3757 REHASH_SIZE from its old size. Otherwise it must be positive, and
3758 the table's new size is computed by multiplying its old size by
3759 REHASH_SIZE + 1.
3761 REHASH_THRESHOLD must be a float <= 1.0, and > 0. The table will
3762 be resized when the approximate ratio of table entries to table
3763 size exceeds REHASH_THRESHOLD.
3765 WEAK specifies the weakness of the table. If non-nil, it must be
3766 one of the symbols `key', `value', `key-or-value', or `key-and-value'.
3768 If PURECOPY is non-nil, the table can be copied to pure storage via
3769 `purecopy' when Emacs is being dumped. Such tables can no longer be
3770 changed after purecopy. */
3772 Lisp_Object
3773 make_hash_table (struct hash_table_test test, EMACS_INT size,
3774 float rehash_size, float rehash_threshold,
3775 Lisp_Object weak, bool pure)
3777 struct Lisp_Hash_Table *h;
3778 Lisp_Object table;
3779 EMACS_INT index_size;
3780 ptrdiff_t i;
3781 double index_float;
3783 /* Preconditions. */
3784 eassert (SYMBOLP (test.name));
3785 eassert (0 <= size && size <= MOST_POSITIVE_FIXNUM);
3786 eassert (rehash_size <= -1 || 0 < rehash_size);
3787 eassert (0 < rehash_threshold && rehash_threshold <= 1);
3789 if (size == 0)
3790 size = 1;
3792 double threshold = rehash_threshold;
3793 index_float = size / threshold;
3794 index_size = (index_float < INDEX_SIZE_BOUND + 1
3795 ? next_almost_prime (index_float)
3796 : INDEX_SIZE_BOUND + 1);
3797 if (INDEX_SIZE_BOUND < max (index_size, 2 * size))
3798 error ("Hash table too large");
3800 /* Allocate a table and initialize it. */
3801 h = allocate_hash_table ();
3803 /* Initialize hash table slots. */
3804 h->test = test;
3805 h->weak = weak;
3806 h->rehash_threshold = rehash_threshold;
3807 h->rehash_size = rehash_size;
3808 h->count = 0;
3809 h->key_and_value = Fmake_vector (make_number (2 * size), Qnil);
3810 h->hash = Fmake_vector (make_number (size), Qnil);
3811 h->next = Fmake_vector (make_number (size), make_number (-1));
3812 h->index = Fmake_vector (make_number (index_size), make_number (-1));
3813 h->pure = pure;
3815 /* Set up the free list. */
3816 for (i = 0; i < size - 1; ++i)
3817 set_hash_next_slot (h, i, i + 1);
3818 h->next_free = 0;
3820 XSET_HASH_TABLE (table, h);
3821 eassert (HASH_TABLE_P (table));
3822 eassert (XHASH_TABLE (table) == h);
3824 /* Maybe add this hash table to the list of all weak hash tables. */
3825 if (! NILP (weak))
3827 h->next_weak = weak_hash_tables;
3828 weak_hash_tables = h;
3831 return table;
3835 /* Return a copy of hash table H1. Keys and values are not copied,
3836 only the table itself is. */
3838 static Lisp_Object
3839 copy_hash_table (struct Lisp_Hash_Table *h1)
3841 Lisp_Object table;
3842 struct Lisp_Hash_Table *h2;
3844 h2 = allocate_hash_table ();
3845 *h2 = *h1;
3846 h2->key_and_value = Fcopy_sequence (h1->key_and_value);
3847 h2->hash = Fcopy_sequence (h1->hash);
3848 h2->next = Fcopy_sequence (h1->next);
3849 h2->index = Fcopy_sequence (h1->index);
3850 XSET_HASH_TABLE (table, h2);
3852 /* Maybe add this hash table to the list of all weak hash tables. */
3853 if (!NILP (h2->weak))
3855 h2->next_weak = h1->next_weak;
3856 h1->next_weak = h2;
3859 return table;
3863 /* Resize hash table H if it's too full. If H cannot be resized
3864 because it's already too large, throw an error. */
3866 static void
3867 maybe_resize_hash_table (struct Lisp_Hash_Table *h)
3869 if (h->next_free < 0)
3871 ptrdiff_t old_size = HASH_TABLE_SIZE (h);
3872 EMACS_INT new_size, index_size, nsize;
3873 ptrdiff_t i;
3874 double rehash_size = h->rehash_size;
3875 double index_float;
3877 if (rehash_size < 0)
3878 new_size = old_size - rehash_size;
3879 else
3881 double float_new_size = old_size * (rehash_size + 1);
3882 if (float_new_size < INDEX_SIZE_BOUND + 1)
3883 new_size = float_new_size;
3884 else
3885 new_size = INDEX_SIZE_BOUND + 1;
3887 if (new_size <= old_size)
3888 new_size = old_size + 1;
3889 double threshold = h->rehash_threshold;
3890 index_float = new_size / threshold;
3891 index_size = (index_float < INDEX_SIZE_BOUND + 1
3892 ? next_almost_prime (index_float)
3893 : INDEX_SIZE_BOUND + 1);
3894 nsize = max (index_size, 2 * new_size);
3895 if (INDEX_SIZE_BOUND < nsize)
3896 error ("Hash table too large to resize");
3898 #ifdef ENABLE_CHECKING
3899 if (HASH_TABLE_P (Vpurify_flag)
3900 && XHASH_TABLE (Vpurify_flag) == h)
3901 message ("Growing hash table to: %"pI"d", new_size);
3902 #endif
3904 set_hash_key_and_value (h, larger_vector (h->key_and_value,
3905 2 * (new_size - old_size), -1));
3906 set_hash_hash (h, larger_vector (h->hash, new_size - old_size, -1));
3907 set_hash_index (h, Fmake_vector (make_number (index_size),
3908 make_number (-1)));
3909 set_hash_next (h, larger_vecalloc (h->next, new_size - old_size, -1));
3911 /* Update the free list. Do it so that new entries are added at
3912 the end of the free list. This makes some operations like
3913 maphash faster. */
3914 for (i = old_size; i < new_size - 1; ++i)
3915 set_hash_next_slot (h, i, i + 1);
3916 set_hash_next_slot (h, i, -1);
3918 if (h->next_free < 0)
3919 h->next_free = old_size;
3920 else
3922 ptrdiff_t last = h->next_free;
3923 while (true)
3925 ptrdiff_t next = HASH_NEXT (h, last);
3926 if (next < 0)
3927 break;
3928 last = next;
3930 set_hash_next_slot (h, last, old_size);
3933 /* Rehash. */
3934 for (i = 0; i < old_size; ++i)
3935 if (!NILP (HASH_HASH (h, i)))
3937 EMACS_UINT hash_code = XUINT (HASH_HASH (h, i));
3938 ptrdiff_t start_of_bucket = hash_code % ASIZE (h->index);
3939 set_hash_next_slot (h, i, HASH_INDEX (h, start_of_bucket));
3940 set_hash_index_slot (h, start_of_bucket, i);
3946 /* Lookup KEY in hash table H. If HASH is non-null, return in *HASH
3947 the hash code of KEY. Value is the index of the entry in H
3948 matching KEY, or -1 if not found. */
3950 ptrdiff_t
3951 hash_lookup (struct Lisp_Hash_Table *h, Lisp_Object key, EMACS_UINT *hash)
3953 EMACS_UINT hash_code;
3954 ptrdiff_t start_of_bucket, i;
3956 hash_code = h->test.hashfn (&h->test, key);
3957 eassert ((hash_code & ~INTMASK) == 0);
3958 if (hash)
3959 *hash = hash_code;
3961 start_of_bucket = hash_code % ASIZE (h->index);
3963 for (i = HASH_INDEX (h, start_of_bucket); 0 <= i; i = HASH_NEXT (h, i))
3964 if (EQ (key, HASH_KEY (h, i))
3965 || (h->test.cmpfn
3966 && hash_code == XUINT (HASH_HASH (h, i))
3967 && h->test.cmpfn (&h->test, key, HASH_KEY (h, i))))
3968 break;
3970 return i;
3974 /* Put an entry into hash table H that associates KEY with VALUE.
3975 HASH is a previously computed hash code of KEY.
3976 Value is the index of the entry in H matching KEY. */
3978 ptrdiff_t
3979 hash_put (struct Lisp_Hash_Table *h, Lisp_Object key, Lisp_Object value,
3980 EMACS_UINT hash)
3982 ptrdiff_t start_of_bucket, i;
3984 eassert ((hash & ~INTMASK) == 0);
3986 /* Increment count after resizing because resizing may fail. */
3987 maybe_resize_hash_table (h);
3988 h->count++;
3990 /* Store key/value in the key_and_value vector. */
3991 i = h->next_free;
3992 h->next_free = HASH_NEXT (h, i);
3993 set_hash_key_slot (h, i, key);
3994 set_hash_value_slot (h, i, value);
3996 /* Remember its hash code. */
3997 set_hash_hash_slot (h, i, make_number (hash));
3999 /* Add new entry to its collision chain. */
4000 start_of_bucket = hash % ASIZE (h->index);
4001 set_hash_next_slot (h, i, HASH_INDEX (h, start_of_bucket));
4002 set_hash_index_slot (h, start_of_bucket, i);
4003 return i;
4007 /* Remove the entry matching KEY from hash table H, if there is one. */
4009 void
4010 hash_remove_from_table (struct Lisp_Hash_Table *h, Lisp_Object key)
4012 EMACS_UINT hash_code = h->test.hashfn (&h->test, key);
4013 eassert ((hash_code & ~INTMASK) == 0);
4014 ptrdiff_t start_of_bucket = hash_code % ASIZE (h->index);
4015 ptrdiff_t prev = -1;
4017 for (ptrdiff_t i = HASH_INDEX (h, start_of_bucket);
4018 0 <= i;
4019 i = HASH_NEXT (h, i))
4021 if (EQ (key, HASH_KEY (h, i))
4022 || (h->test.cmpfn
4023 && hash_code == XUINT (HASH_HASH (h, i))
4024 && h->test.cmpfn (&h->test, key, HASH_KEY (h, i))))
4026 /* Take entry out of collision chain. */
4027 if (prev < 0)
4028 set_hash_index_slot (h, start_of_bucket, HASH_NEXT (h, i));
4029 else
4030 set_hash_next_slot (h, prev, HASH_NEXT (h, i));
4032 /* Clear slots in key_and_value and add the slots to
4033 the free list. */
4034 set_hash_key_slot (h, i, Qnil);
4035 set_hash_value_slot (h, i, Qnil);
4036 set_hash_hash_slot (h, i, Qnil);
4037 set_hash_next_slot (h, i, h->next_free);
4038 h->next_free = i;
4039 h->count--;
4040 eassert (h->count >= 0);
4041 break;
4044 prev = i;
4049 /* Clear hash table H. */
4051 static void
4052 hash_clear (struct Lisp_Hash_Table *h)
4054 if (h->count > 0)
4056 ptrdiff_t i, size = HASH_TABLE_SIZE (h);
4058 for (i = 0; i < size; ++i)
4060 set_hash_next_slot (h, i, i < size - 1 ? i + 1 : -1);
4061 set_hash_key_slot (h, i, Qnil);
4062 set_hash_value_slot (h, i, Qnil);
4063 set_hash_hash_slot (h, i, Qnil);
4066 for (i = 0; i < ASIZE (h->index); ++i)
4067 ASET (h->index, i, make_number (-1));
4069 h->next_free = 0;
4070 h->count = 0;
4076 /************************************************************************
4077 Weak Hash Tables
4078 ************************************************************************/
4080 /* Sweep weak hash table H. REMOVE_ENTRIES_P means remove
4081 entries from the table that don't survive the current GC.
4082 !REMOVE_ENTRIES_P means mark entries that are in use. Value is
4083 true if anything was marked. */
4085 static bool
4086 sweep_weak_table (struct Lisp_Hash_Table *h, bool remove_entries_p)
4088 ptrdiff_t n = gc_asize (h->index);
4089 bool marked = false;
4091 for (ptrdiff_t bucket = 0; bucket < n; ++bucket)
4093 /* Follow collision chain, removing entries that
4094 don't survive this garbage collection. */
4095 ptrdiff_t prev = -1;
4096 ptrdiff_t next;
4097 for (ptrdiff_t i = HASH_INDEX (h, bucket); 0 <= i; i = next)
4099 bool key_known_to_survive_p = survives_gc_p (HASH_KEY (h, i));
4100 bool value_known_to_survive_p = survives_gc_p (HASH_VALUE (h, i));
4101 bool remove_p;
4103 if (EQ (h->weak, Qkey))
4104 remove_p = !key_known_to_survive_p;
4105 else if (EQ (h->weak, Qvalue))
4106 remove_p = !value_known_to_survive_p;
4107 else if (EQ (h->weak, Qkey_or_value))
4108 remove_p = !(key_known_to_survive_p || value_known_to_survive_p);
4109 else if (EQ (h->weak, Qkey_and_value))
4110 remove_p = !(key_known_to_survive_p && value_known_to_survive_p);
4111 else
4112 emacs_abort ();
4114 next = HASH_NEXT (h, i);
4116 if (remove_entries_p)
4118 if (remove_p)
4120 /* Take out of collision chain. */
4121 if (prev < 0)
4122 set_hash_index_slot (h, bucket, next);
4123 else
4124 set_hash_next_slot (h, prev, next);
4126 /* Add to free list. */
4127 set_hash_next_slot (h, i, h->next_free);
4128 h->next_free = i;
4130 /* Clear key, value, and hash. */
4131 set_hash_key_slot (h, i, Qnil);
4132 set_hash_value_slot (h, i, Qnil);
4133 set_hash_hash_slot (h, i, Qnil);
4135 h->count--;
4137 else
4139 prev = i;
4142 else
4144 if (!remove_p)
4146 /* Make sure key and value survive. */
4147 if (!key_known_to_survive_p)
4149 mark_object (HASH_KEY (h, i));
4150 marked = 1;
4153 if (!value_known_to_survive_p)
4155 mark_object (HASH_VALUE (h, i));
4156 marked = 1;
4163 return marked;
4166 /* Remove elements from weak hash tables that don't survive the
4167 current garbage collection. Remove weak tables that don't survive
4168 from Vweak_hash_tables. Called from gc_sweep. */
4170 NO_INLINE /* For better stack traces */
4171 void
4172 sweep_weak_hash_tables (void)
4174 struct Lisp_Hash_Table *h, *used, *next;
4175 bool marked;
4177 /* Mark all keys and values that are in use. Keep on marking until
4178 there is no more change. This is necessary for cases like
4179 value-weak table A containing an entry X -> Y, where Y is used in a
4180 key-weak table B, Z -> Y. If B comes after A in the list of weak
4181 tables, X -> Y might be removed from A, although when looking at B
4182 one finds that it shouldn't. */
4185 marked = 0;
4186 for (h = weak_hash_tables; h; h = h->next_weak)
4188 if (h->header.size & ARRAY_MARK_FLAG)
4189 marked |= sweep_weak_table (h, 0);
4192 while (marked);
4194 /* Remove tables and entries that aren't used. */
4195 for (h = weak_hash_tables, used = NULL; h; h = next)
4197 next = h->next_weak;
4199 if (h->header.size & ARRAY_MARK_FLAG)
4201 /* TABLE is marked as used. Sweep its contents. */
4202 if (h->count > 0)
4203 sweep_weak_table (h, 1);
4205 /* Add table to the list of used weak hash tables. */
4206 h->next_weak = used;
4207 used = h;
4211 weak_hash_tables = used;
4216 /***********************************************************************
4217 Hash Code Computation
4218 ***********************************************************************/
4220 /* Maximum depth up to which to dive into Lisp structures. */
4222 #define SXHASH_MAX_DEPTH 3
4224 /* Maximum length up to which to take list and vector elements into
4225 account. */
4227 #define SXHASH_MAX_LEN 7
4229 /* Return a hash for string PTR which has length LEN. The hash value
4230 can be any EMACS_UINT value. */
4232 EMACS_UINT
4233 hash_string (char const *ptr, ptrdiff_t len)
4235 char const *p = ptr;
4236 char const *end = p + len;
4237 unsigned char c;
4238 EMACS_UINT hash = 0;
4240 while (p != end)
4242 c = *p++;
4243 hash = sxhash_combine (hash, c);
4246 return hash;
4249 /* Return a hash for string PTR which has length LEN. The hash
4250 code returned is guaranteed to fit in a Lisp integer. */
4252 static EMACS_UINT
4253 sxhash_string (char const *ptr, ptrdiff_t len)
4255 EMACS_UINT hash = hash_string (ptr, len);
4256 return SXHASH_REDUCE (hash);
4259 /* Return a hash for the floating point value VAL. */
4261 static EMACS_UINT
4262 sxhash_float (double val)
4264 EMACS_UINT hash = 0;
4265 enum {
4266 WORDS_PER_DOUBLE = (sizeof val / sizeof hash
4267 + (sizeof val % sizeof hash != 0))
4269 union {
4270 double val;
4271 EMACS_UINT word[WORDS_PER_DOUBLE];
4272 } u;
4273 int i;
4274 u.val = val;
4275 memset (&u.val + 1, 0, sizeof u - sizeof u.val);
4276 for (i = 0; i < WORDS_PER_DOUBLE; i++)
4277 hash = sxhash_combine (hash, u.word[i]);
4278 return SXHASH_REDUCE (hash);
4281 /* Return a hash for list LIST. DEPTH is the current depth in the
4282 list. We don't recurse deeper than SXHASH_MAX_DEPTH in it. */
4284 static EMACS_UINT
4285 sxhash_list (Lisp_Object list, int depth)
4287 EMACS_UINT hash = 0;
4288 int i;
4290 if (depth < SXHASH_MAX_DEPTH)
4291 for (i = 0;
4292 CONSP (list) && i < SXHASH_MAX_LEN;
4293 list = XCDR (list), ++i)
4295 EMACS_UINT hash2 = sxhash (XCAR (list), depth + 1);
4296 hash = sxhash_combine (hash, hash2);
4299 if (!NILP (list))
4301 EMACS_UINT hash2 = sxhash (list, depth + 1);
4302 hash = sxhash_combine (hash, hash2);
4305 return SXHASH_REDUCE (hash);
4309 /* Return a hash for (pseudo)vector VECTOR. DEPTH is the current depth in
4310 the Lisp structure. */
4312 static EMACS_UINT
4313 sxhash_vector (Lisp_Object vec, int depth)
4315 EMACS_UINT hash = ASIZE (vec);
4316 int i, n;
4318 n = min (SXHASH_MAX_LEN, hash & PSEUDOVECTOR_FLAG ? PVSIZE (vec) : hash);
4319 for (i = 0; i < n; ++i)
4321 EMACS_UINT hash2 = sxhash (AREF (vec, i), depth + 1);
4322 hash = sxhash_combine (hash, hash2);
4325 return SXHASH_REDUCE (hash);
4328 /* Return a hash for bool-vector VECTOR. */
4330 static EMACS_UINT
4331 sxhash_bool_vector (Lisp_Object vec)
4333 EMACS_INT size = bool_vector_size (vec);
4334 EMACS_UINT hash = size;
4335 int i, n;
4337 n = min (SXHASH_MAX_LEN, bool_vector_words (size));
4338 for (i = 0; i < n; ++i)
4339 hash = sxhash_combine (hash, bool_vector_data (vec)[i]);
4341 return SXHASH_REDUCE (hash);
4345 /* Return a hash code for OBJ. DEPTH is the current depth in the Lisp
4346 structure. Value is an unsigned integer clipped to INTMASK. */
4348 EMACS_UINT
4349 sxhash (Lisp_Object obj, int depth)
4351 EMACS_UINT hash;
4353 if (depth > SXHASH_MAX_DEPTH)
4354 return 0;
4356 switch (XTYPE (obj))
4358 case_Lisp_Int:
4359 hash = XUINT (obj);
4360 break;
4362 case Lisp_Misc:
4363 case Lisp_Symbol:
4364 hash = XHASH (obj);
4365 break;
4367 case Lisp_String:
4368 hash = sxhash_string (SSDATA (obj), SBYTES (obj));
4369 break;
4371 /* This can be everything from a vector to an overlay. */
4372 case Lisp_Vectorlike:
4373 if (VECTORP (obj) || RECORDP (obj))
4374 /* According to the CL HyperSpec, two arrays are equal only if
4375 they are `eq', except for strings and bit-vectors. In
4376 Emacs, this works differently. We have to compare element
4377 by element. Same for records. */
4378 hash = sxhash_vector (obj, depth);
4379 else if (BOOL_VECTOR_P (obj))
4380 hash = sxhash_bool_vector (obj);
4381 else
4382 /* Others are `equal' if they are `eq', so let's take their
4383 address as hash. */
4384 hash = XHASH (obj);
4385 break;
4387 case Lisp_Cons:
4388 hash = sxhash_list (obj, depth);
4389 break;
4391 case Lisp_Float:
4392 hash = sxhash_float (XFLOAT_DATA (obj));
4393 break;
4395 default:
4396 emacs_abort ();
4399 return hash;
4404 /***********************************************************************
4405 Lisp Interface
4406 ***********************************************************************/
4408 DEFUN ("sxhash-eq", Fsxhash_eq, Ssxhash_eq, 1, 1, 0,
4409 doc: /* Return an integer hash code for OBJ suitable for `eq'.
4410 If (eq A B), then (= (sxhash-eq A) (sxhash-eq B)). */)
4411 (Lisp_Object obj)
4413 return make_number (hashfn_eq (NULL, obj));
4416 DEFUN ("sxhash-eql", Fsxhash_eql, Ssxhash_eql, 1, 1, 0,
4417 doc: /* Return an integer hash code for OBJ suitable for `eql'.
4418 If (eql A B), then (= (sxhash-eql A) (sxhash-eql B)). */)
4419 (Lisp_Object obj)
4421 return make_number (hashfn_eql (NULL, obj));
4424 DEFUN ("sxhash-equal", Fsxhash_equal, Ssxhash_equal, 1, 1, 0,
4425 doc: /* Return an integer hash code for OBJ suitable for `equal'.
4426 If (equal A B), then (= (sxhash-equal A) (sxhash-equal B)). */)
4427 (Lisp_Object obj)
4429 return make_number (hashfn_equal (NULL, obj));
4432 DEFUN ("make-hash-table", Fmake_hash_table, Smake_hash_table, 0, MANY, 0,
4433 doc: /* Create and return a new hash table.
4435 Arguments are specified as keyword/argument pairs. The following
4436 arguments are defined:
4438 :test TEST -- TEST must be a symbol that specifies how to compare
4439 keys. Default is `eql'. Predefined are the tests `eq', `eql', and
4440 `equal'. User-supplied test and hash functions can be specified via
4441 `define-hash-table-test'.
4443 :size SIZE -- A hint as to how many elements will be put in the table.
4444 Default is 65.
4446 :rehash-size REHASH-SIZE - Indicates how to expand the table when it
4447 fills up. If REHASH-SIZE is an integer, increase the size by that
4448 amount. If it is a float, it must be > 1.0, and the new size is the
4449 old size multiplied by that factor. Default is 1.5.
4451 :rehash-threshold THRESHOLD -- THRESHOLD must a float > 0, and <= 1.0.
4452 Resize the hash table when the ratio (table entries / table size)
4453 exceeds an approximation to THRESHOLD. Default is 0.8125.
4455 :weakness WEAK -- WEAK must be one of nil, t, `key', `value',
4456 `key-or-value', or `key-and-value'. If WEAK is not nil, the table
4457 returned is a weak table. Key/value pairs are removed from a weak
4458 hash table when there are no non-weak references pointing to their
4459 key, value, one of key or value, or both key and value, depending on
4460 WEAK. WEAK t is equivalent to `key-and-value'. Default value of WEAK
4461 is nil.
4463 :purecopy PURECOPY -- If PURECOPY is non-nil, the table can be copied
4464 to pure storage when Emacs is being dumped, making the contents of the
4465 table read only. Any further changes to purified tables will result
4466 in an error.
4468 usage: (make-hash-table &rest KEYWORD-ARGS) */)
4469 (ptrdiff_t nargs, Lisp_Object *args)
4471 Lisp_Object test, weak;
4472 bool pure;
4473 struct hash_table_test testdesc;
4474 ptrdiff_t i;
4475 USE_SAFE_ALLOCA;
4477 /* The vector `used' is used to keep track of arguments that
4478 have been consumed. */
4479 char *used = SAFE_ALLOCA (nargs * sizeof *used);
4480 memset (used, 0, nargs * sizeof *used);
4482 /* See if there's a `:test TEST' among the arguments. */
4483 i = get_key_arg (QCtest, nargs, args, used);
4484 test = i ? args[i] : Qeql;
4485 if (EQ (test, Qeq))
4486 testdesc = hashtest_eq;
4487 else if (EQ (test, Qeql))
4488 testdesc = hashtest_eql;
4489 else if (EQ (test, Qequal))
4490 testdesc = hashtest_equal;
4491 else
4493 /* See if it is a user-defined test. */
4494 Lisp_Object prop;
4496 prop = Fget (test, Qhash_table_test);
4497 if (!CONSP (prop) || !CONSP (XCDR (prop)))
4498 signal_error ("Invalid hash table test", test);
4499 testdesc.name = test;
4500 testdesc.user_cmp_function = XCAR (prop);
4501 testdesc.user_hash_function = XCAR (XCDR (prop));
4502 testdesc.hashfn = hashfn_user_defined;
4503 testdesc.cmpfn = cmpfn_user_defined;
4506 /* See if there's a `:purecopy PURECOPY' argument. */
4507 i = get_key_arg (QCpurecopy, nargs, args, used);
4508 pure = i && !NILP (args[i]);
4509 /* See if there's a `:size SIZE' argument. */
4510 i = get_key_arg (QCsize, nargs, args, used);
4511 Lisp_Object size_arg = i ? args[i] : Qnil;
4512 EMACS_INT size;
4513 if (NILP (size_arg))
4514 size = DEFAULT_HASH_SIZE;
4515 else if (NATNUMP (size_arg))
4516 size = XFASTINT (size_arg);
4517 else
4518 signal_error ("Invalid hash table size", size_arg);
4520 /* Look for `:rehash-size SIZE'. */
4521 float rehash_size;
4522 i = get_key_arg (QCrehash_size, nargs, args, used);
4523 if (!i)
4524 rehash_size = DEFAULT_REHASH_SIZE;
4525 else if (INTEGERP (args[i]) && 0 < XINT (args[i]))
4526 rehash_size = - XINT (args[i]);
4527 else if (FLOATP (args[i]) && 0 < (float) (XFLOAT_DATA (args[i]) - 1))
4528 rehash_size = (float) (XFLOAT_DATA (args[i]) - 1);
4529 else
4530 signal_error ("Invalid hash table rehash size", args[i]);
4532 /* Look for `:rehash-threshold THRESHOLD'. */
4533 i = get_key_arg (QCrehash_threshold, nargs, args, used);
4534 float rehash_threshold = (!i ? DEFAULT_REHASH_THRESHOLD
4535 : !FLOATP (args[i]) ? 0
4536 : (float) XFLOAT_DATA (args[i]));
4537 if (! (0 < rehash_threshold && rehash_threshold <= 1))
4538 signal_error ("Invalid hash table rehash threshold", args[i]);
4540 /* Look for `:weakness WEAK'. */
4541 i = get_key_arg (QCweakness, nargs, args, used);
4542 weak = i ? args[i] : Qnil;
4543 if (EQ (weak, Qt))
4544 weak = Qkey_and_value;
4545 if (!NILP (weak)
4546 && !EQ (weak, Qkey)
4547 && !EQ (weak, Qvalue)
4548 && !EQ (weak, Qkey_or_value)
4549 && !EQ (weak, Qkey_and_value))
4550 signal_error ("Invalid hash table weakness", weak);
4552 /* Now, all args should have been used up, or there's a problem. */
4553 for (i = 0; i < nargs; ++i)
4554 if (!used[i])
4555 signal_error ("Invalid argument list", args[i]);
4557 SAFE_FREE ();
4558 return make_hash_table (testdesc, size, rehash_size, rehash_threshold, weak,
4559 pure);
4563 DEFUN ("copy-hash-table", Fcopy_hash_table, Scopy_hash_table, 1, 1, 0,
4564 doc: /* Return a copy of hash table TABLE. */)
4565 (Lisp_Object table)
4567 return copy_hash_table (check_hash_table (table));
4571 DEFUN ("hash-table-count", Fhash_table_count, Shash_table_count, 1, 1, 0,
4572 doc: /* Return the number of elements in TABLE. */)
4573 (Lisp_Object table)
4575 return make_number (check_hash_table (table)->count);
4579 DEFUN ("hash-table-rehash-size", Fhash_table_rehash_size,
4580 Shash_table_rehash_size, 1, 1, 0,
4581 doc: /* Return the current rehash size of TABLE. */)
4582 (Lisp_Object table)
4584 double rehash_size = check_hash_table (table)->rehash_size;
4585 if (rehash_size < 0)
4587 EMACS_INT s = -rehash_size;
4588 return make_number (min (s, MOST_POSITIVE_FIXNUM));
4590 else
4591 return make_float (rehash_size + 1);
4595 DEFUN ("hash-table-rehash-threshold", Fhash_table_rehash_threshold,
4596 Shash_table_rehash_threshold, 1, 1, 0,
4597 doc: /* Return the current rehash threshold of TABLE. */)
4598 (Lisp_Object table)
4600 return make_float (check_hash_table (table)->rehash_threshold);
4604 DEFUN ("hash-table-size", Fhash_table_size, Shash_table_size, 1, 1, 0,
4605 doc: /* Return the size of TABLE.
4606 The size can be used as an argument to `make-hash-table' to create
4607 a hash table than can hold as many elements as TABLE holds
4608 without need for resizing. */)
4609 (Lisp_Object table)
4611 struct Lisp_Hash_Table *h = check_hash_table (table);
4612 return make_number (HASH_TABLE_SIZE (h));
4616 DEFUN ("hash-table-test", Fhash_table_test, Shash_table_test, 1, 1, 0,
4617 doc: /* Return the test TABLE uses. */)
4618 (Lisp_Object table)
4620 return check_hash_table (table)->test.name;
4624 DEFUN ("hash-table-weakness", Fhash_table_weakness, Shash_table_weakness,
4625 1, 1, 0,
4626 doc: /* Return the weakness of TABLE. */)
4627 (Lisp_Object table)
4629 return check_hash_table (table)->weak;
4633 DEFUN ("hash-table-p", Fhash_table_p, Shash_table_p, 1, 1, 0,
4634 doc: /* Return t if OBJ is a Lisp hash table object. */)
4635 (Lisp_Object obj)
4637 return HASH_TABLE_P (obj) ? Qt : Qnil;
4641 DEFUN ("clrhash", Fclrhash, Sclrhash, 1, 1, 0,
4642 doc: /* Clear hash table TABLE and return it. */)
4643 (Lisp_Object table)
4645 struct Lisp_Hash_Table *h = check_hash_table (table);
4646 CHECK_IMPURE (table, h);
4647 hash_clear (h);
4648 /* Be compatible with XEmacs. */
4649 return table;
4653 DEFUN ("gethash", Fgethash, Sgethash, 2, 3, 0,
4654 doc: /* Look up KEY in TABLE and return its associated value.
4655 If KEY is not found, return DFLT which defaults to nil. */)
4656 (Lisp_Object key, Lisp_Object table, Lisp_Object dflt)
4658 struct Lisp_Hash_Table *h = check_hash_table (table);
4659 ptrdiff_t i = hash_lookup (h, key, NULL);
4660 return i >= 0 ? HASH_VALUE (h, i) : dflt;
4664 DEFUN ("puthash", Fputhash, Sputhash, 3, 3, 0,
4665 doc: /* Associate KEY with VALUE in hash table TABLE.
4666 If KEY is already present in table, replace its current value with
4667 VALUE. In any case, return VALUE. */)
4668 (Lisp_Object key, Lisp_Object value, Lisp_Object table)
4670 struct Lisp_Hash_Table *h = check_hash_table (table);
4671 CHECK_IMPURE (table, h);
4673 ptrdiff_t i;
4674 EMACS_UINT hash;
4675 i = hash_lookup (h, key, &hash);
4676 if (i >= 0)
4677 set_hash_value_slot (h, i, value);
4678 else
4679 hash_put (h, key, value, hash);
4681 return value;
4685 DEFUN ("remhash", Fremhash, Sremhash, 2, 2, 0,
4686 doc: /* Remove KEY from TABLE. */)
4687 (Lisp_Object key, Lisp_Object table)
4689 struct Lisp_Hash_Table *h = check_hash_table (table);
4690 CHECK_IMPURE (table, h);
4691 hash_remove_from_table (h, key);
4692 return Qnil;
4696 DEFUN ("maphash", Fmaphash, Smaphash, 2, 2, 0,
4697 doc: /* Call FUNCTION for all entries in hash table TABLE.
4698 FUNCTION is called with two arguments, KEY and VALUE.
4699 `maphash' always returns nil. */)
4700 (Lisp_Object function, Lisp_Object table)
4702 struct Lisp_Hash_Table *h = check_hash_table (table);
4704 for (ptrdiff_t i = 0; i < HASH_TABLE_SIZE (h); ++i)
4705 if (!NILP (HASH_HASH (h, i)))
4706 call2 (function, HASH_KEY (h, i), HASH_VALUE (h, i));
4708 return Qnil;
4712 DEFUN ("define-hash-table-test", Fdefine_hash_table_test,
4713 Sdefine_hash_table_test, 3, 3, 0,
4714 doc: /* Define a new hash table test with name NAME, a symbol.
4716 In hash tables created with NAME specified as test, use TEST to
4717 compare keys, and HASH for computing hash codes of keys.
4719 TEST must be a function taking two arguments and returning non-nil if
4720 both arguments are the same. HASH must be a function taking one
4721 argument and returning an object that is the hash code of the argument.
4722 It should be the case that if (eq (funcall HASH x1) (funcall HASH x2))
4723 returns nil, then (funcall TEST x1 x2) also returns nil. */)
4724 (Lisp_Object name, Lisp_Object test, Lisp_Object hash)
4726 return Fput (name, Qhash_table_test, list2 (test, hash));
4731 /************************************************************************
4732 MD5, SHA-1, and SHA-2
4733 ************************************************************************/
4735 #include "md5.h"
4736 #include "sha1.h"
4737 #include "sha256.h"
4738 #include "sha512.h"
4740 static Lisp_Object
4741 make_digest_string (Lisp_Object digest, int digest_size)
4743 unsigned char *p = SDATA (digest);
4745 for (int i = digest_size - 1; i >= 0; i--)
4747 static char const hexdigit[16] = "0123456789abcdef";
4748 int p_i = p[i];
4749 p[2 * i] = hexdigit[p_i >> 4];
4750 p[2 * i + 1] = hexdigit[p_i & 0xf];
4752 return digest;
4755 DEFUN ("secure-hash-algorithms", Fsecure_hash_algorithms,
4756 Ssecure_hash_algorithms, 0, 0, 0,
4757 doc: /* Return a list of all the supported `secure_hash' algorithms. */)
4758 (void)
4760 return listn (CONSTYPE_HEAP, 6,
4761 Qmd5,
4762 Qsha1,
4763 Qsha224,
4764 Qsha256,
4765 Qsha384,
4766 Qsha512);
4769 /* Extract data from a string or a buffer. SPEC is a list of
4770 (BUFFER-OR-STRING-OR-SYMBOL START END CODING-SYSTEM NOERROR) which behave as
4771 specified with `secure-hash' and in Info node
4772 `(elisp)Format of GnuTLS Cryptography Inputs'. */
4773 char *
4774 extract_data_from_object (Lisp_Object spec,
4775 ptrdiff_t *start_byte,
4776 ptrdiff_t *end_byte)
4778 Lisp_Object object = XCAR (spec);
4780 if (CONSP (spec)) spec = XCDR (spec);
4781 Lisp_Object start = CAR_SAFE (spec);
4783 if (CONSP (spec)) spec = XCDR (spec);
4784 Lisp_Object end = CAR_SAFE (spec);
4786 if (CONSP (spec)) spec = XCDR (spec);
4787 Lisp_Object coding_system = CAR_SAFE (spec);
4789 if (CONSP (spec)) spec = XCDR (spec);
4790 Lisp_Object noerror = CAR_SAFE (spec);
4792 if (STRINGP (object))
4794 if (NILP (coding_system))
4796 /* Decide the coding-system to encode the data with. */
4798 if (STRING_MULTIBYTE (object))
4799 /* use default, we can't guess correct value */
4800 coding_system = preferred_coding_system ();
4801 else
4802 coding_system = Qraw_text;
4805 if (NILP (Fcoding_system_p (coding_system)))
4807 /* Invalid coding system. */
4809 if (!NILP (noerror))
4810 coding_system = Qraw_text;
4811 else
4812 xsignal1 (Qcoding_system_error, coding_system);
4815 if (STRING_MULTIBYTE (object))
4816 object = code_convert_string (object, coding_system, Qnil, 1, 0, 1);
4818 ptrdiff_t size = SCHARS (object), start_char, end_char;
4819 validate_subarray (object, start, end, size, &start_char, &end_char);
4821 *start_byte = !start_char ? 0 : string_char_to_byte (object, start_char);
4822 *end_byte = (end_char == size
4823 ? SBYTES (object)
4824 : string_char_to_byte (object, end_char));
4826 else if (BUFFERP (object))
4828 struct buffer *prev = current_buffer;
4829 EMACS_INT b, e;
4831 record_unwind_current_buffer ();
4833 struct buffer *bp = XBUFFER (object);
4834 set_buffer_internal (bp);
4836 if (NILP (start))
4837 b = BEGV;
4838 else
4840 CHECK_NUMBER_COERCE_MARKER (start);
4841 b = XINT (start);
4844 if (NILP (end))
4845 e = ZV;
4846 else
4848 CHECK_NUMBER_COERCE_MARKER (end);
4849 e = XINT (end);
4852 if (b > e)
4854 EMACS_INT temp = b;
4855 b = e;
4856 e = temp;
4859 if (!(BEGV <= b && e <= ZV))
4860 args_out_of_range (start, end);
4862 if (NILP (coding_system))
4864 /* Decide the coding-system to encode the data with.
4865 See fileio.c:Fwrite-region */
4867 if (!NILP (Vcoding_system_for_write))
4868 coding_system = Vcoding_system_for_write;
4869 else
4871 bool force_raw_text = 0;
4873 coding_system = BVAR (XBUFFER (object), buffer_file_coding_system);
4874 if (NILP (coding_system)
4875 || NILP (Flocal_variable_p (Qbuffer_file_coding_system, Qnil)))
4877 coding_system = Qnil;
4878 if (NILP (BVAR (current_buffer, enable_multibyte_characters)))
4879 force_raw_text = 1;
4882 if (NILP (coding_system) && !NILP (Fbuffer_file_name (object)))
4884 /* Check file-coding-system-alist. */
4885 Lisp_Object val = CALLN (Ffind_operation_coding_system,
4886 Qwrite_region, start, end,
4887 Fbuffer_file_name (object));
4888 if (CONSP (val) && !NILP (XCDR (val)))
4889 coding_system = XCDR (val);
4892 if (NILP (coding_system)
4893 && !NILP (BVAR (XBUFFER (object), buffer_file_coding_system)))
4895 /* If we still have not decided a coding system, use the
4896 default value of buffer-file-coding-system. */
4897 coding_system = BVAR (XBUFFER (object), buffer_file_coding_system);
4900 if (!force_raw_text
4901 && !NILP (Ffboundp (Vselect_safe_coding_system_function)))
4902 /* Confirm that VAL can surely encode the current region. */
4903 coding_system = call4 (Vselect_safe_coding_system_function,
4904 make_number (b), make_number (e),
4905 coding_system, Qnil);
4907 if (force_raw_text)
4908 coding_system = Qraw_text;
4911 if (NILP (Fcoding_system_p (coding_system)))
4913 /* Invalid coding system. */
4915 if (!NILP (noerror))
4916 coding_system = Qraw_text;
4917 else
4918 xsignal1 (Qcoding_system_error, coding_system);
4922 object = make_buffer_string (b, e, 0);
4923 set_buffer_internal (prev);
4924 /* Discard the unwind protect for recovering the current
4925 buffer. */
4926 specpdl_ptr--;
4928 if (STRING_MULTIBYTE (object))
4929 object = code_convert_string (object, coding_system, Qnil, 1, 0, 0);
4930 *start_byte = 0;
4931 *end_byte = SBYTES (object);
4933 else if (EQ (object, Qiv_auto))
4935 #ifdef HAVE_GNUTLS3
4936 /* Format: (iv-auto REQUIRED-LENGTH). */
4938 if (! NATNUMP (start))
4939 error ("Without a length, `iv-auto' can't be used; see ELisp manual");
4940 else
4942 EMACS_INT start_hold = XFASTINT (start);
4943 object = make_uninit_string (start_hold);
4944 gnutls_rnd (GNUTLS_RND_NONCE, SSDATA (object), start_hold);
4946 *start_byte = 0;
4947 *end_byte = start_hold;
4949 #else
4950 error ("GnuTLS is not available, so `iv-auto' can't be used");
4951 #endif
4954 if (!STRINGP (object))
4955 signal_error ("Invalid object argument",
4956 NILP (object) ? build_string ("nil") : object);
4957 return SSDATA (object);
4961 /* ALGORITHM is a symbol: md5, sha1, sha224 and so on. */
4963 static Lisp_Object
4964 secure_hash (Lisp_Object algorithm, Lisp_Object object, Lisp_Object start,
4965 Lisp_Object end, Lisp_Object coding_system, Lisp_Object noerror,
4966 Lisp_Object binary)
4968 ptrdiff_t start_byte, end_byte;
4969 int digest_size;
4970 void *(*hash_func) (const char *, size_t, void *);
4971 Lisp_Object digest;
4973 CHECK_SYMBOL (algorithm);
4975 Lisp_Object spec = list5 (object, start, end, coding_system, noerror);
4977 const char *input = extract_data_from_object (spec, &start_byte, &end_byte);
4979 if (input == NULL)
4980 error ("secure_hash: failed to extract data from object, aborting!");
4982 if (EQ (algorithm, Qmd5))
4984 digest_size = MD5_DIGEST_SIZE;
4985 hash_func = md5_buffer;
4987 else if (EQ (algorithm, Qsha1))
4989 digest_size = SHA1_DIGEST_SIZE;
4990 hash_func = sha1_buffer;
4992 else if (EQ (algorithm, Qsha224))
4994 digest_size = SHA224_DIGEST_SIZE;
4995 hash_func = sha224_buffer;
4997 else if (EQ (algorithm, Qsha256))
4999 digest_size = SHA256_DIGEST_SIZE;
5000 hash_func = sha256_buffer;
5002 else if (EQ (algorithm, Qsha384))
5004 digest_size = SHA384_DIGEST_SIZE;
5005 hash_func = sha384_buffer;
5007 else if (EQ (algorithm, Qsha512))
5009 digest_size = SHA512_DIGEST_SIZE;
5010 hash_func = sha512_buffer;
5012 else
5013 error ("Invalid algorithm arg: %s", SDATA (Fsymbol_name (algorithm)));
5015 /* allocate 2 x digest_size so that it can be re-used to hold the
5016 hexified value */
5017 digest = make_uninit_string (digest_size * 2);
5019 hash_func (input + start_byte,
5020 end_byte - start_byte,
5021 SSDATA (digest));
5023 if (NILP (binary))
5024 return make_digest_string (digest, digest_size);
5025 else
5026 return make_unibyte_string (SSDATA (digest), digest_size);
5029 DEFUN ("md5", Fmd5, Smd5, 1, 5, 0,
5030 doc: /* Return MD5 message digest of OBJECT, a buffer or string.
5032 A message digest is a cryptographic checksum of a document, and the
5033 algorithm to calculate it is defined in RFC 1321.
5035 The two optional arguments START and END are character positions
5036 specifying for which part of OBJECT the message digest should be
5037 computed. If nil or omitted, the digest is computed for the whole
5038 OBJECT.
5040 The MD5 message digest is computed from the result of encoding the
5041 text in a coding system, not directly from the internal Emacs form of
5042 the text. The optional fourth argument CODING-SYSTEM specifies which
5043 coding system to encode the text with. It should be the same coding
5044 system that you used or will use when actually writing the text into a
5045 file.
5047 If CODING-SYSTEM is nil or omitted, the default depends on OBJECT. If
5048 OBJECT is a buffer, the default for CODING-SYSTEM is whatever coding
5049 system would be chosen by default for writing this text into a file.
5051 If OBJECT is a string, the most preferred coding system (see the
5052 command `prefer-coding-system') is used.
5054 If NOERROR is non-nil, silently assume the `raw-text' coding if the
5055 guesswork fails. Normally, an error is signaled in such case. */)
5056 (Lisp_Object object, Lisp_Object start, Lisp_Object end, Lisp_Object coding_system, Lisp_Object noerror)
5058 return secure_hash (Qmd5, object, start, end, coding_system, noerror, Qnil);
5061 DEFUN ("secure-hash", Fsecure_hash, Ssecure_hash, 2, 5, 0,
5062 doc: /* Return the secure hash of OBJECT, a buffer or string.
5063 ALGORITHM is a symbol specifying the hash to use:
5064 md5, sha1, sha224, sha256, sha384 or sha512.
5066 The two optional arguments START and END are positions specifying for
5067 which part of OBJECT to compute the hash. If nil or omitted, uses the
5068 whole OBJECT.
5070 The full list of algorithms can be obtained with `secure-hash-algorithms'.
5072 If BINARY is non-nil, returns a string in binary form. */)
5073 (Lisp_Object algorithm, Lisp_Object object, Lisp_Object start, Lisp_Object end, Lisp_Object binary)
5075 return secure_hash (algorithm, object, start, end, Qnil, Qnil, binary);
5078 DEFUN ("buffer-hash", Fbuffer_hash, Sbuffer_hash, 0, 1, 0,
5079 doc: /* Return a hash of the contents of BUFFER-OR-NAME.
5080 This hash is performed on the raw internal format of the buffer,
5081 disregarding any coding systems. If nil, use the current buffer. */ )
5082 (Lisp_Object buffer_or_name)
5084 Lisp_Object buffer;
5085 struct buffer *b;
5086 struct sha1_ctx ctx;
5088 if (NILP (buffer_or_name))
5089 buffer = Fcurrent_buffer ();
5090 else
5091 buffer = Fget_buffer (buffer_or_name);
5092 if (NILP (buffer))
5093 nsberror (buffer_or_name);
5095 b = XBUFFER (buffer);
5096 sha1_init_ctx (&ctx);
5098 /* Process the first part of the buffer. */
5099 sha1_process_bytes (BUF_BEG_ADDR (b),
5100 BUF_GPT_BYTE (b) - BUF_BEG_BYTE (b),
5101 &ctx);
5103 /* If the gap is before the end of the buffer, process the last half
5104 of the buffer. */
5105 if (BUF_GPT_BYTE (b) < BUF_Z_BYTE (b))
5106 sha1_process_bytes (BUF_GAP_END_ADDR (b),
5107 BUF_Z_ADDR (b) - BUF_GAP_END_ADDR (b),
5108 &ctx);
5110 Lisp_Object digest = make_uninit_string (SHA1_DIGEST_SIZE * 2);
5111 sha1_finish_ctx (&ctx, SSDATA (digest));
5112 return make_digest_string (digest, SHA1_DIGEST_SIZE);
5116 void
5117 syms_of_fns (void)
5119 /* Hash table stuff. */
5120 DEFSYM (Qhash_table_p, "hash-table-p");
5121 DEFSYM (Qeq, "eq");
5122 DEFSYM (Qeql, "eql");
5123 DEFSYM (Qequal, "equal");
5124 DEFSYM (QCtest, ":test");
5125 DEFSYM (QCsize, ":size");
5126 DEFSYM (QCpurecopy, ":purecopy");
5127 DEFSYM (QCrehash_size, ":rehash-size");
5128 DEFSYM (QCrehash_threshold, ":rehash-threshold");
5129 DEFSYM (QCweakness, ":weakness");
5130 DEFSYM (Qkey, "key");
5131 DEFSYM (Qvalue, "value");
5132 DEFSYM (Qhash_table_test, "hash-table-test");
5133 DEFSYM (Qkey_or_value, "key-or-value");
5134 DEFSYM (Qkey_and_value, "key-and-value");
5136 defsubr (&Ssxhash_eq);
5137 defsubr (&Ssxhash_eql);
5138 defsubr (&Ssxhash_equal);
5139 defsubr (&Smake_hash_table);
5140 defsubr (&Scopy_hash_table);
5141 defsubr (&Shash_table_count);
5142 defsubr (&Shash_table_rehash_size);
5143 defsubr (&Shash_table_rehash_threshold);
5144 defsubr (&Shash_table_size);
5145 defsubr (&Shash_table_test);
5146 defsubr (&Shash_table_weakness);
5147 defsubr (&Shash_table_p);
5148 defsubr (&Sclrhash);
5149 defsubr (&Sgethash);
5150 defsubr (&Sputhash);
5151 defsubr (&Sremhash);
5152 defsubr (&Smaphash);
5153 defsubr (&Sdefine_hash_table_test);
5155 /* Crypto and hashing stuff. */
5156 DEFSYM (Qiv_auto, "iv-auto");
5158 DEFSYM (Qmd5, "md5");
5159 DEFSYM (Qsha1, "sha1");
5160 DEFSYM (Qsha224, "sha224");
5161 DEFSYM (Qsha256, "sha256");
5162 DEFSYM (Qsha384, "sha384");
5163 DEFSYM (Qsha512, "sha512");
5165 /* Miscellaneous stuff. */
5167 DEFSYM (Qstring_lessp, "string-lessp");
5168 DEFSYM (Qprovide, "provide");
5169 DEFSYM (Qrequire, "require");
5170 DEFSYM (Qyes_or_no_p_history, "yes-or-no-p-history");
5171 DEFSYM (Qcursor_in_echo_area, "cursor-in-echo-area");
5172 DEFSYM (Qwidget_type, "widget-type");
5174 DEFVAR_LISP ("overriding-plist-environment", Voverriding_plist_environment,
5175 doc: /* An alist that overrides the plists of the symbols which it lists.
5176 Used by the byte-compiler to apply `define-symbol-prop' during
5177 compilation. */);
5178 Voverriding_plist_environment = Qnil;
5179 DEFSYM (Qoverriding_plist_environment, "overriding-plist-environment");
5181 staticpro (&string_char_byte_cache_string);
5182 string_char_byte_cache_string = Qnil;
5184 require_nesting_list = Qnil;
5185 staticpro (&require_nesting_list);
5187 Fset (Qyes_or_no_p_history, Qnil);
5189 DEFVAR_LISP ("features", Vfeatures,
5190 doc: /* A list of symbols which are the features of the executing Emacs.
5191 Used by `featurep' and `require', and altered by `provide'. */);
5192 Vfeatures = list1 (Qemacs);
5193 DEFSYM (Qfeatures, "features");
5194 /* Let people use lexically scoped vars named `features'. */
5195 Fmake_var_non_special (Qfeatures);
5196 DEFSYM (Qsubfeatures, "subfeatures");
5197 DEFSYM (Qfuncall, "funcall");
5198 DEFSYM (Qplistp, "plistp");
5200 #ifdef HAVE_LANGINFO_CODESET
5201 DEFSYM (Qcodeset, "codeset");
5202 DEFSYM (Qdays, "days");
5203 DEFSYM (Qmonths, "months");
5204 DEFSYM (Qpaper, "paper");
5205 #endif /* HAVE_LANGINFO_CODESET */
5207 DEFVAR_BOOL ("use-dialog-box", use_dialog_box,
5208 doc: /* Non-nil means mouse commands use dialog boxes to ask questions.
5209 This applies to `y-or-n-p' and `yes-or-no-p' questions asked by commands
5210 invoked by mouse clicks and mouse menu items.
5212 On some platforms, file selection dialogs are also enabled if this is
5213 non-nil. */);
5214 use_dialog_box = 1;
5216 DEFVAR_BOOL ("use-file-dialog", use_file_dialog,
5217 doc: /* Non-nil means mouse commands use a file dialog to ask for files.
5218 This applies to commands from menus and tool bar buttons even when
5219 they are initiated from the keyboard. If `use-dialog-box' is nil,
5220 that disables the use of a file dialog, regardless of the value of
5221 this variable. */);
5222 use_file_dialog = 1;
5224 defsubr (&Sidentity);
5225 defsubr (&Srandom);
5226 defsubr (&Slength);
5227 defsubr (&Ssafe_length);
5228 defsubr (&Sstring_bytes);
5229 defsubr (&Sstring_equal);
5230 defsubr (&Scompare_strings);
5231 defsubr (&Sstring_lessp);
5232 defsubr (&Sstring_version_lessp);
5233 defsubr (&Sstring_collate_lessp);
5234 defsubr (&Sstring_collate_equalp);
5235 defsubr (&Sappend);
5236 defsubr (&Sconcat);
5237 defsubr (&Svconcat);
5238 defsubr (&Scopy_sequence);
5239 defsubr (&Sstring_make_multibyte);
5240 defsubr (&Sstring_make_unibyte);
5241 defsubr (&Sstring_as_multibyte);
5242 defsubr (&Sstring_as_unibyte);
5243 defsubr (&Sstring_to_multibyte);
5244 defsubr (&Sstring_to_unibyte);
5245 defsubr (&Scopy_alist);
5246 defsubr (&Ssubstring);
5247 defsubr (&Ssubstring_no_properties);
5248 defsubr (&Snthcdr);
5249 defsubr (&Snth);
5250 defsubr (&Selt);
5251 defsubr (&Smember);
5252 defsubr (&Smemq);
5253 defsubr (&Smemql);
5254 defsubr (&Sassq);
5255 defsubr (&Sassoc);
5256 defsubr (&Srassq);
5257 defsubr (&Srassoc);
5258 defsubr (&Sdelq);
5259 defsubr (&Sdelete);
5260 defsubr (&Snreverse);
5261 defsubr (&Sreverse);
5262 defsubr (&Ssort);
5263 defsubr (&Splist_get);
5264 defsubr (&Sget);
5265 defsubr (&Splist_put);
5266 defsubr (&Sput);
5267 defsubr (&Slax_plist_get);
5268 defsubr (&Slax_plist_put);
5269 defsubr (&Seql);
5270 defsubr (&Sequal);
5271 defsubr (&Sequal_including_properties);
5272 defsubr (&Sfillarray);
5273 defsubr (&Sclear_string);
5274 defsubr (&Snconc);
5275 defsubr (&Smapcar);
5276 defsubr (&Smapc);
5277 defsubr (&Smapcan);
5278 defsubr (&Smapconcat);
5279 defsubr (&Syes_or_no_p);
5280 defsubr (&Sload_average);
5281 defsubr (&Sfeaturep);
5282 defsubr (&Srequire);
5283 defsubr (&Sprovide);
5284 defsubr (&Splist_member);
5285 defsubr (&Swidget_put);
5286 defsubr (&Swidget_get);
5287 defsubr (&Swidget_apply);
5288 defsubr (&Sbase64_encode_region);
5289 defsubr (&Sbase64_decode_region);
5290 defsubr (&Sbase64_encode_string);
5291 defsubr (&Sbase64_decode_string);
5292 defsubr (&Smd5);
5293 defsubr (&Ssecure_hash_algorithms);
5294 defsubr (&Ssecure_hash);
5295 defsubr (&Sbuffer_hash);
5296 defsubr (&Slocale_info);