Make CC Mode load cl-lib rather than cl in Emacs 26.
[emacs.git] / src / fns.c
blob6610d2a6d0e1e54cb9ebed9b03db666cb451cf97
1 /* Random utility Lisp functions.
3 Copyright (C) 1985-1987, 1993-1995, 1997-2017 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 <http://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"
39 static void sort_vector_copy (Lisp_Object, ptrdiff_t,
40 Lisp_Object *restrict, Lisp_Object *restrict);
41 enum equal_kind { EQUAL_NO_QUIT, EQUAL_PLAIN, EQUAL_INCLUDING_PROPERTIES };
42 static bool internal_equal (Lisp_Object, Lisp_Object,
43 enum equal_kind, int, Lisp_Object);
45 DEFUN ("identity", Fidentity, Sidentity, 1, 1, 0,
46 doc: /* Return the argument unchanged. */
47 attributes: const)
48 (Lisp_Object arg)
50 return arg;
53 DEFUN ("random", Frandom, Srandom, 0, 1, 0,
54 doc: /* Return a pseudo-random number.
55 All integers representable in Lisp, i.e. between `most-negative-fixnum'
56 and `most-positive-fixnum', inclusive, are equally likely.
58 With positive integer LIMIT, return random number in interval [0,LIMIT).
59 With argument t, set the random number seed from the system's entropy
60 pool if available, otherwise from less-random volatile data such as the time.
61 With a string argument, set the seed based on the string's contents.
62 Other values of LIMIT are ignored.
64 See Info node `(elisp)Random Numbers' for more details. */)
65 (Lisp_Object limit)
67 EMACS_INT val;
69 if (EQ (limit, Qt))
70 init_random ();
71 else if (STRINGP (limit))
72 seed_random (SSDATA (limit), SBYTES (limit));
74 val = get_random ();
75 if (INTEGERP (limit) && 0 < XINT (limit))
76 while (true)
78 /* Return the remainder, except reject the rare case where
79 get_random returns a number so close to INTMASK that the
80 remainder isn't random. */
81 EMACS_INT remainder = val % XINT (limit);
82 if (val - remainder <= INTMASK - XINT (limit) + 1)
83 return make_number (remainder);
84 val = get_random ();
86 return make_number (val);
89 /* Random data-structure functions. */
91 DEFUN ("length", Flength, Slength, 1, 1, 0,
92 doc: /* Return the length of vector, list or string SEQUENCE.
93 A byte-code function object is also allowed.
94 If the string contains multibyte characters, this is not necessarily
95 the number of bytes in the string; it is the number of characters.
96 To get the number of bytes, use `string-bytes'. */)
97 (register Lisp_Object sequence)
99 register Lisp_Object val;
101 if (STRINGP (sequence))
102 XSETFASTINT (val, SCHARS (sequence));
103 else if (VECTORP (sequence))
104 XSETFASTINT (val, ASIZE (sequence));
105 else if (CHAR_TABLE_P (sequence))
106 XSETFASTINT (val, MAX_CHAR);
107 else if (BOOL_VECTOR_P (sequence))
108 XSETFASTINT (val, bool_vector_size (sequence));
109 else if (COMPILEDP (sequence) || RECORDP (sequence))
110 XSETFASTINT (val, PVSIZE (sequence));
111 else if (CONSP (sequence))
113 intptr_t i = 0;
114 FOR_EACH_TAIL (sequence)
115 i++;
116 CHECK_LIST_END (sequence, sequence);
117 if (MOST_POSITIVE_FIXNUM < i)
118 error ("List too long");
119 val = make_number (i);
121 else if (NILP (sequence))
122 XSETFASTINT (val, 0);
123 else
124 wrong_type_argument (Qsequencep, sequence);
126 return val;
129 DEFUN ("safe-length", Fsafe_length, Ssafe_length, 1, 1, 0,
130 doc: /* Return the length of a list, but avoid error or infinite loop.
131 This function never gets an error. If LIST is not really a list,
132 it returns 0. If LIST is circular, it returns a finite value
133 which is at least the number of distinct elements. */)
134 (Lisp_Object list)
136 intptr_t len = 0;
137 FOR_EACH_TAIL_SAFE (list)
138 len++;
139 return make_fixnum_or_float (len);
142 DEFUN ("string-bytes", Fstring_bytes, Sstring_bytes, 1, 1, 0,
143 doc: /* Return the number of bytes in STRING.
144 If STRING is multibyte, this may be greater than the length of STRING. */)
145 (Lisp_Object string)
147 CHECK_STRING (string);
148 return make_number (SBYTES (string));
151 DEFUN ("string-equal", Fstring_equal, Sstring_equal, 2, 2, 0,
152 doc: /* Return t if two strings have identical contents.
153 Case is significant, but text properties are ignored.
154 Symbols are also allowed; their print names are used instead. */)
155 (register Lisp_Object s1, Lisp_Object s2)
157 if (SYMBOLP (s1))
158 s1 = SYMBOL_NAME (s1);
159 if (SYMBOLP (s2))
160 s2 = SYMBOL_NAME (s2);
161 CHECK_STRING (s1);
162 CHECK_STRING (s2);
164 if (SCHARS (s1) != SCHARS (s2)
165 || SBYTES (s1) != SBYTES (s2)
166 || memcmp (SDATA (s1), SDATA (s2), SBYTES (s1)))
167 return Qnil;
168 return Qt;
171 DEFUN ("compare-strings", Fcompare_strings, Scompare_strings, 6, 7, 0,
172 doc: /* Compare the contents of two strings, converting to multibyte if needed.
173 The arguments START1, END1, START2, and END2, if non-nil, are
174 positions specifying which parts of STR1 or STR2 to compare. In
175 string STR1, compare the part between START1 (inclusive) and END1
176 \(exclusive). If START1 is nil, it defaults to 0, the beginning of
177 the string; if END1 is nil, it defaults to the length of the string.
178 Likewise, in string STR2, compare the part between START2 and END2.
179 Like in `substring', negative values are counted from the end.
181 The strings are compared by the numeric values of their characters.
182 For instance, STR1 is "less than" STR2 if its first differing
183 character has a smaller numeric value. If IGNORE-CASE is non-nil,
184 characters are converted to upper-case before comparing them. Unibyte
185 strings are converted to multibyte for comparison.
187 The value is t if the strings (or specified portions) match.
188 If string STR1 is less, the value is a negative number N;
189 - 1 - N is the number of characters that match at the beginning.
190 If string STR1 is greater, the value is a positive number N;
191 N - 1 is the number of characters that match at the beginning. */)
192 (Lisp_Object str1, Lisp_Object start1, Lisp_Object end1, Lisp_Object str2,
193 Lisp_Object start2, Lisp_Object end2, Lisp_Object ignore_case)
195 ptrdiff_t from1, to1, from2, to2, i1, i1_byte, i2, i2_byte;
197 CHECK_STRING (str1);
198 CHECK_STRING (str2);
200 /* For backward compatibility, silently bring too-large positive end
201 values into range. */
202 if (INTEGERP (end1) && SCHARS (str1) < XINT (end1))
203 end1 = make_number (SCHARS (str1));
204 if (INTEGERP (end2) && SCHARS (str2) < XINT (end2))
205 end2 = make_number (SCHARS (str2));
207 validate_subarray (str1, start1, end1, SCHARS (str1), &from1, &to1);
208 validate_subarray (str2, start2, end2, SCHARS (str2), &from2, &to2);
210 i1 = from1;
211 i2 = from2;
213 i1_byte = string_char_to_byte (str1, i1);
214 i2_byte = string_char_to_byte (str2, i2);
216 while (i1 < to1 && i2 < to2)
218 /* When we find a mismatch, we must compare the
219 characters, not just the bytes. */
220 int c1, c2;
222 FETCH_STRING_CHAR_AS_MULTIBYTE_ADVANCE (c1, str1, i1, i1_byte);
223 FETCH_STRING_CHAR_AS_MULTIBYTE_ADVANCE (c2, str2, i2, i2_byte);
225 if (c1 == c2)
226 continue;
228 if (! NILP (ignore_case))
230 c1 = XINT (Fupcase (make_number (c1)));
231 c2 = XINT (Fupcase (make_number (c2)));
234 if (c1 == c2)
235 continue;
237 /* Note that I1 has already been incremented
238 past the character that we are comparing;
239 hence we don't add or subtract 1 here. */
240 if (c1 < c2)
241 return make_number (- i1 + from1);
242 else
243 return make_number (i1 - from1);
246 if (i1 < to1)
247 return make_number (i1 - from1 + 1);
248 if (i2 < to2)
249 return make_number (- i1 + from1 - 1);
251 return Qt;
254 DEFUN ("string-lessp", Fstring_lessp, Sstring_lessp, 2, 2, 0,
255 doc: /* Return non-nil if STRING1 is less than STRING2 in lexicographic order.
256 Case is significant.
257 Symbols are also allowed; their print names are used instead. */)
258 (register Lisp_Object string1, Lisp_Object string2)
260 register ptrdiff_t end;
261 register ptrdiff_t i1, i1_byte, i2, i2_byte;
263 if (SYMBOLP (string1))
264 string1 = SYMBOL_NAME (string1);
265 if (SYMBOLP (string2))
266 string2 = SYMBOL_NAME (string2);
267 CHECK_STRING (string1);
268 CHECK_STRING (string2);
270 i1 = i1_byte = i2 = i2_byte = 0;
272 end = SCHARS (string1);
273 if (end > SCHARS (string2))
274 end = SCHARS (string2);
276 while (i1 < end)
278 /* When we find a mismatch, we must compare the
279 characters, not just the bytes. */
280 int c1, c2;
282 FETCH_STRING_CHAR_ADVANCE (c1, string1, i1, i1_byte);
283 FETCH_STRING_CHAR_ADVANCE (c2, string2, i2, i2_byte);
285 if (c1 != c2)
286 return c1 < c2 ? Qt : Qnil;
288 return i1 < SCHARS (string2) ? Qt : Qnil;
291 DEFUN ("string-version-lessp", Fstring_version_lessp,
292 Sstring_version_lessp, 2, 2, 0,
293 doc: /* Return non-nil if S1 is less than S2, as version strings.
295 This function compares version strings S1 and S2:
296 1) By prefix lexicographically.
297 2) Then by version (similarly to version comparison of Debian's dpkg).
298 Leading zeros in version numbers are ignored.
299 3) If both prefix and version are equal, compare as ordinary strings.
301 For example, \"foo2.png\" compares less than \"foo12.png\".
302 Case is significant.
303 Symbols are also allowed; their print names are used instead. */)
304 (Lisp_Object string1, Lisp_Object string2)
306 if (SYMBOLP (string1))
307 string1 = SYMBOL_NAME (string1);
308 if (SYMBOLP (string2))
309 string2 = SYMBOL_NAME (string2);
310 CHECK_STRING (string1);
311 CHECK_STRING (string2);
313 char *p1 = SSDATA (string1);
314 char *p2 = SSDATA (string2);
315 char *lim1 = p1 + SBYTES (string1);
316 char *lim2 = p2 + SBYTES (string2);
317 int cmp;
319 while ((cmp = filevercmp (p1, p2)) == 0)
321 /* If the strings are identical through their first null bytes,
322 skip past identical prefixes and try again. */
323 ptrdiff_t size = strlen (p1) + 1;
324 p1 += size;
325 p2 += size;
326 if (lim1 < p1)
327 return lim2 < p2 ? Qnil : Qt;
328 if (lim2 < p2)
329 return Qnil;
332 return cmp < 0 ? Qt : Qnil;
335 DEFUN ("string-collate-lessp", Fstring_collate_lessp, Sstring_collate_lessp, 2, 4, 0,
336 doc: /* Return t if first arg string is less than second in collation order.
337 Symbols are also allowed; their print names are used instead.
339 This function obeys the conventions for collation order in your
340 locale settings. For example, punctuation and whitespace characters
341 might be considered less significant for sorting:
343 \(sort \\='("11" "12" "1 1" "1 2" "1.1" "1.2") \\='string-collate-lessp)
344 => ("11" "1 1" "1.1" "12" "1 2" "1.2")
346 The optional argument LOCALE, a string, overrides the setting of your
347 current locale identifier for collation. The value is system
348 dependent; a LOCALE \"en_US.UTF-8\" is applicable on POSIX systems,
349 while it would be, e.g., \"enu_USA.1252\" on MS-Windows systems.
351 If IGNORE-CASE is non-nil, characters are converted to lower-case
352 before comparing them.
354 To emulate Unicode-compliant collation on MS-Windows systems,
355 bind `w32-collate-ignore-punctuation' to a non-nil value, since
356 the codeset part of the locale cannot be \"UTF-8\" on MS-Windows.
358 If your system does not support a locale environment, this function
359 behaves like `string-lessp'. */)
360 (Lisp_Object s1, Lisp_Object s2, Lisp_Object locale, Lisp_Object ignore_case)
362 #if defined __STDC_ISO_10646__ || defined WINDOWSNT
363 /* Check parameters. */
364 if (SYMBOLP (s1))
365 s1 = SYMBOL_NAME (s1);
366 if (SYMBOLP (s2))
367 s2 = SYMBOL_NAME (s2);
368 CHECK_STRING (s1);
369 CHECK_STRING (s2);
370 if (!NILP (locale))
371 CHECK_STRING (locale);
373 return (str_collate (s1, s2, locale, ignore_case) < 0) ? Qt : Qnil;
375 #else /* !__STDC_ISO_10646__, !WINDOWSNT */
376 return Fstring_lessp (s1, s2);
377 #endif /* !__STDC_ISO_10646__, !WINDOWSNT */
380 DEFUN ("string-collate-equalp", Fstring_collate_equalp, Sstring_collate_equalp, 2, 4, 0,
381 doc: /* Return t if two strings have identical contents.
382 Symbols are also allowed; their print names are used instead.
384 This function obeys the conventions for collation order in your locale
385 settings. For example, characters with different coding points but
386 the same meaning might be considered as equal, like different grave
387 accent Unicode characters:
389 \(string-collate-equalp (string ?\\uFF40) (string ?\\u1FEF))
390 => t
392 The optional argument LOCALE, a string, overrides the setting of your
393 current locale identifier for collation. The value is system
394 dependent; a LOCALE \"en_US.UTF-8\" is applicable on POSIX systems,
395 while it would be \"enu_USA.1252\" on MS Windows systems.
397 If IGNORE-CASE is non-nil, characters are converted to lower-case
398 before comparing them.
400 To emulate Unicode-compliant collation on MS-Windows systems,
401 bind `w32-collate-ignore-punctuation' to a non-nil value, since
402 the codeset part of the locale cannot be \"UTF-8\" on MS-Windows.
404 If your system does not support a locale environment, this function
405 behaves like `string-equal'.
407 Do NOT use this function to compare file names for equality. */)
408 (Lisp_Object s1, Lisp_Object s2, Lisp_Object locale, Lisp_Object ignore_case)
410 #if defined __STDC_ISO_10646__ || defined WINDOWSNT
411 /* Check parameters. */
412 if (SYMBOLP (s1))
413 s1 = SYMBOL_NAME (s1);
414 if (SYMBOLP (s2))
415 s2 = SYMBOL_NAME (s2);
416 CHECK_STRING (s1);
417 CHECK_STRING (s2);
418 if (!NILP (locale))
419 CHECK_STRING (locale);
421 return (str_collate (s1, s2, locale, ignore_case) == 0) ? Qt : Qnil;
423 #else /* !__STDC_ISO_10646__, !WINDOWSNT */
424 return Fstring_equal (s1, s2);
425 #endif /* !__STDC_ISO_10646__, !WINDOWSNT */
428 static Lisp_Object concat (ptrdiff_t nargs, Lisp_Object *args,
429 enum Lisp_Type target_type, bool last_special);
431 /* ARGSUSED */
432 Lisp_Object
433 concat2 (Lisp_Object s1, Lisp_Object s2)
435 return concat (2, ((Lisp_Object []) {s1, s2}), Lisp_String, 0);
438 /* ARGSUSED */
439 Lisp_Object
440 concat3 (Lisp_Object s1, Lisp_Object s2, Lisp_Object s3)
442 return concat (3, ((Lisp_Object []) {s1, s2, s3}), Lisp_String, 0);
445 DEFUN ("append", Fappend, Sappend, 0, MANY, 0,
446 doc: /* Concatenate all the arguments and make the result a list.
447 The result is a list whose elements are the elements of all the arguments.
448 Each argument may be a list, vector or string.
449 The last argument is not copied, just used as the tail of the new list.
450 usage: (append &rest SEQUENCES) */)
451 (ptrdiff_t nargs, Lisp_Object *args)
453 return concat (nargs, args, Lisp_Cons, 1);
456 DEFUN ("concat", Fconcat, Sconcat, 0, MANY, 0,
457 doc: /* Concatenate all the arguments and make the result a string.
458 The result is a string whose elements are the elements of all the arguments.
459 Each argument may be a string or a list or vector of characters (integers).
460 usage: (concat &rest SEQUENCES) */)
461 (ptrdiff_t nargs, Lisp_Object *args)
463 return concat (nargs, args, Lisp_String, 0);
466 DEFUN ("vconcat", Fvconcat, Svconcat, 0, MANY, 0,
467 doc: /* Concatenate all the arguments and make the result a vector.
468 The result is a vector whose elements are the elements of all the arguments.
469 Each argument may be a list, vector or string.
470 usage: (vconcat &rest SEQUENCES) */)
471 (ptrdiff_t nargs, Lisp_Object *args)
473 return concat (nargs, args, Lisp_Vectorlike, 0);
477 DEFUN ("copy-sequence", Fcopy_sequence, Scopy_sequence, 1, 1, 0,
478 doc: /* Return a copy of a list, vector, string, char-table or record.
479 The elements of a list, vector or record are not copied; they are
480 shared with the original. */)
481 (Lisp_Object arg)
483 if (NILP (arg)) return arg;
485 if (RECORDP (arg))
487 return Frecord (PVSIZE (arg), XVECTOR (arg)->contents);
490 if (CHAR_TABLE_P (arg))
492 return copy_char_table (arg);
495 if (BOOL_VECTOR_P (arg))
497 EMACS_INT nbits = bool_vector_size (arg);
498 ptrdiff_t nbytes = bool_vector_bytes (nbits);
499 Lisp_Object val = make_uninit_bool_vector (nbits);
500 memcpy (bool_vector_data (val), bool_vector_data (arg), nbytes);
501 return val;
504 if (!CONSP (arg) && !VECTORP (arg) && !STRINGP (arg))
505 wrong_type_argument (Qsequencep, arg);
507 return concat (1, &arg, XTYPE (arg), 0);
510 /* This structure holds information of an argument of `concat' that is
511 a string and has text properties to be copied. */
512 struct textprop_rec
514 ptrdiff_t argnum; /* refer to ARGS (arguments of `concat') */
515 ptrdiff_t from; /* refer to ARGS[argnum] (argument string) */
516 ptrdiff_t to; /* refer to VAL (the target string) */
519 static Lisp_Object
520 concat (ptrdiff_t nargs, Lisp_Object *args,
521 enum Lisp_Type target_type, bool last_special)
523 Lisp_Object val;
524 Lisp_Object tail;
525 Lisp_Object this;
526 ptrdiff_t toindex;
527 ptrdiff_t toindex_byte = 0;
528 EMACS_INT result_len;
529 EMACS_INT result_len_byte;
530 ptrdiff_t argnum;
531 Lisp_Object last_tail;
532 Lisp_Object prev;
533 bool some_multibyte;
534 /* When we make a multibyte string, we can't copy text properties
535 while concatenating each string because the length of resulting
536 string can't be decided until we finish the whole concatenation.
537 So, we record strings that have text properties to be copied
538 here, and copy the text properties after the concatenation. */
539 struct textprop_rec *textprops = NULL;
540 /* Number of elements in textprops. */
541 ptrdiff_t num_textprops = 0;
542 USE_SAFE_ALLOCA;
544 tail = Qnil;
546 /* In append, the last arg isn't treated like the others */
547 if (last_special && nargs > 0)
549 nargs--;
550 last_tail = args[nargs];
552 else
553 last_tail = Qnil;
555 /* Check each argument. */
556 for (argnum = 0; argnum < nargs; argnum++)
558 this = args[argnum];
559 if (!(CONSP (this) || NILP (this) || VECTORP (this) || STRINGP (this)
560 || COMPILEDP (this) || BOOL_VECTOR_P (this)))
561 wrong_type_argument (Qsequencep, this);
564 /* Compute total length in chars of arguments in RESULT_LEN.
565 If desired output is a string, also compute length in bytes
566 in RESULT_LEN_BYTE, and determine in SOME_MULTIBYTE
567 whether the result should be a multibyte string. */
568 result_len_byte = 0;
569 result_len = 0;
570 some_multibyte = 0;
571 for (argnum = 0; argnum < nargs; argnum++)
573 EMACS_INT len;
574 this = args[argnum];
575 len = XFASTINT (Flength (this));
576 if (target_type == Lisp_String)
578 /* We must count the number of bytes needed in the string
579 as well as the number of characters. */
580 ptrdiff_t i;
581 Lisp_Object ch;
582 int c;
583 ptrdiff_t this_len_byte;
585 if (VECTORP (this) || COMPILEDP (this))
586 for (i = 0; i < len; i++)
588 ch = AREF (this, i);
589 CHECK_CHARACTER (ch);
590 c = XFASTINT (ch);
591 this_len_byte = CHAR_BYTES (c);
592 if (STRING_BYTES_BOUND - result_len_byte < this_len_byte)
593 string_overflow ();
594 result_len_byte += this_len_byte;
595 if (! ASCII_CHAR_P (c) && ! CHAR_BYTE8_P (c))
596 some_multibyte = 1;
598 else if (BOOL_VECTOR_P (this) && bool_vector_size (this) > 0)
599 wrong_type_argument (Qintegerp, Faref (this, make_number (0)));
600 else if (CONSP (this))
601 for (; CONSP (this); this = XCDR (this))
603 ch = XCAR (this);
604 CHECK_CHARACTER (ch);
605 c = XFASTINT (ch);
606 this_len_byte = CHAR_BYTES (c);
607 if (STRING_BYTES_BOUND - result_len_byte < this_len_byte)
608 string_overflow ();
609 result_len_byte += this_len_byte;
610 if (! ASCII_CHAR_P (c) && ! CHAR_BYTE8_P (c))
611 some_multibyte = 1;
613 else if (STRINGP (this))
615 if (STRING_MULTIBYTE (this))
617 some_multibyte = 1;
618 this_len_byte = SBYTES (this);
620 else
621 this_len_byte = count_size_as_multibyte (SDATA (this),
622 SCHARS (this));
623 if (STRING_BYTES_BOUND - result_len_byte < this_len_byte)
624 string_overflow ();
625 result_len_byte += this_len_byte;
629 result_len += len;
630 if (MOST_POSITIVE_FIXNUM < result_len)
631 memory_full (SIZE_MAX);
634 if (! some_multibyte)
635 result_len_byte = result_len;
637 /* Create the output object. */
638 if (target_type == Lisp_Cons)
639 val = Fmake_list (make_number (result_len), Qnil);
640 else if (target_type == Lisp_Vectorlike)
641 val = Fmake_vector (make_number (result_len), Qnil);
642 else if (some_multibyte)
643 val = make_uninit_multibyte_string (result_len, result_len_byte);
644 else
645 val = make_uninit_string (result_len);
647 /* In `append', if all but last arg are nil, return last arg. */
648 if (target_type == Lisp_Cons && EQ (val, Qnil))
649 return last_tail;
651 /* Copy the contents of the args into the result. */
652 if (CONSP (val))
653 tail = val, toindex = -1; /* -1 in toindex is flag we are making a list */
654 else
655 toindex = 0, toindex_byte = 0;
657 prev = Qnil;
658 if (STRINGP (val))
659 SAFE_NALLOCA (textprops, 1, nargs);
661 for (argnum = 0; argnum < nargs; argnum++)
663 Lisp_Object thislen;
664 ptrdiff_t thisleni = 0;
665 register ptrdiff_t thisindex = 0;
666 register ptrdiff_t thisindex_byte = 0;
668 this = args[argnum];
669 if (!CONSP (this))
670 thislen = Flength (this), thisleni = XINT (thislen);
672 /* Between strings of the same kind, copy fast. */
673 if (STRINGP (this) && STRINGP (val)
674 && STRING_MULTIBYTE (this) == some_multibyte)
676 ptrdiff_t thislen_byte = SBYTES (this);
678 memcpy (SDATA (val) + toindex_byte, SDATA (this), SBYTES (this));
679 if (string_intervals (this))
681 textprops[num_textprops].argnum = argnum;
682 textprops[num_textprops].from = 0;
683 textprops[num_textprops++].to = toindex;
685 toindex_byte += thislen_byte;
686 toindex += thisleni;
688 /* Copy a single-byte string to a multibyte string. */
689 else if (STRINGP (this) && STRINGP (val))
691 if (string_intervals (this))
693 textprops[num_textprops].argnum = argnum;
694 textprops[num_textprops].from = 0;
695 textprops[num_textprops++].to = toindex;
697 toindex_byte += copy_text (SDATA (this),
698 SDATA (val) + toindex_byte,
699 SCHARS (this), 0, 1);
700 toindex += thisleni;
702 else
703 /* Copy element by element. */
704 while (1)
706 register Lisp_Object elt;
708 /* Fetch next element of `this' arg into `elt', or break if
709 `this' is exhausted. */
710 if (NILP (this)) break;
711 if (CONSP (this))
712 elt = XCAR (this), this = XCDR (this);
713 else if (thisindex >= thisleni)
714 break;
715 else if (STRINGP (this))
717 int c;
718 if (STRING_MULTIBYTE (this))
719 FETCH_STRING_CHAR_ADVANCE_NO_CHECK (c, this,
720 thisindex,
721 thisindex_byte);
722 else
724 c = SREF (this, thisindex); thisindex++;
725 if (some_multibyte && !ASCII_CHAR_P (c))
726 c = BYTE8_TO_CHAR (c);
728 XSETFASTINT (elt, c);
730 else if (BOOL_VECTOR_P (this))
732 elt = bool_vector_ref (this, thisindex);
733 thisindex++;
735 else
737 elt = AREF (this, thisindex);
738 thisindex++;
741 /* Store this element into the result. */
742 if (toindex < 0)
744 XSETCAR (tail, elt);
745 prev = tail;
746 tail = XCDR (tail);
748 else if (VECTORP (val))
750 ASET (val, toindex, elt);
751 toindex++;
753 else
755 int c;
756 CHECK_CHARACTER (elt);
757 c = XFASTINT (elt);
758 if (some_multibyte)
759 toindex_byte += CHAR_STRING (c, SDATA (val) + toindex_byte);
760 else
761 SSET (val, toindex_byte++, c);
762 toindex++;
766 if (!NILP (prev))
767 XSETCDR (prev, last_tail);
769 if (num_textprops > 0)
771 Lisp_Object props;
772 ptrdiff_t last_to_end = -1;
774 for (argnum = 0; argnum < num_textprops; argnum++)
776 this = args[textprops[argnum].argnum];
777 props = text_property_list (this,
778 make_number (0),
779 make_number (SCHARS (this)),
780 Qnil);
781 /* If successive arguments have properties, be sure that the
782 value of `composition' property be the copy. */
783 if (last_to_end == textprops[argnum].to)
784 make_composition_value_copy (props);
785 add_text_properties_from_list (val, props,
786 make_number (textprops[argnum].to));
787 last_to_end = textprops[argnum].to + SCHARS (this);
791 SAFE_FREE ();
792 return val;
795 static Lisp_Object string_char_byte_cache_string;
796 static ptrdiff_t string_char_byte_cache_charpos;
797 static ptrdiff_t string_char_byte_cache_bytepos;
799 void
800 clear_string_char_byte_cache (void)
802 string_char_byte_cache_string = Qnil;
805 /* Return the byte index corresponding to CHAR_INDEX in STRING. */
807 ptrdiff_t
808 string_char_to_byte (Lisp_Object string, ptrdiff_t char_index)
810 ptrdiff_t i_byte;
811 ptrdiff_t best_below, best_below_byte;
812 ptrdiff_t best_above, best_above_byte;
814 best_below = best_below_byte = 0;
815 best_above = SCHARS (string);
816 best_above_byte = SBYTES (string);
817 if (best_above == best_above_byte)
818 return char_index;
820 if (EQ (string, string_char_byte_cache_string))
822 if (string_char_byte_cache_charpos < char_index)
824 best_below = string_char_byte_cache_charpos;
825 best_below_byte = string_char_byte_cache_bytepos;
827 else
829 best_above = string_char_byte_cache_charpos;
830 best_above_byte = string_char_byte_cache_bytepos;
834 if (char_index - best_below < best_above - char_index)
836 unsigned char *p = SDATA (string) + best_below_byte;
838 while (best_below < char_index)
840 p += BYTES_BY_CHAR_HEAD (*p);
841 best_below++;
843 i_byte = p - SDATA (string);
845 else
847 unsigned char *p = SDATA (string) + best_above_byte;
849 while (best_above > char_index)
851 p--;
852 while (!CHAR_HEAD_P (*p)) p--;
853 best_above--;
855 i_byte = p - SDATA (string);
858 string_char_byte_cache_bytepos = i_byte;
859 string_char_byte_cache_charpos = char_index;
860 string_char_byte_cache_string = string;
862 return i_byte;
865 /* Return the character index corresponding to BYTE_INDEX in STRING. */
867 ptrdiff_t
868 string_byte_to_char (Lisp_Object string, ptrdiff_t byte_index)
870 ptrdiff_t i, i_byte;
871 ptrdiff_t best_below, best_below_byte;
872 ptrdiff_t best_above, best_above_byte;
874 best_below = best_below_byte = 0;
875 best_above = SCHARS (string);
876 best_above_byte = SBYTES (string);
877 if (best_above == best_above_byte)
878 return byte_index;
880 if (EQ (string, string_char_byte_cache_string))
882 if (string_char_byte_cache_bytepos < byte_index)
884 best_below = string_char_byte_cache_charpos;
885 best_below_byte = string_char_byte_cache_bytepos;
887 else
889 best_above = string_char_byte_cache_charpos;
890 best_above_byte = string_char_byte_cache_bytepos;
894 if (byte_index - best_below_byte < best_above_byte - byte_index)
896 unsigned char *p = SDATA (string) + best_below_byte;
897 unsigned char *pend = SDATA (string) + byte_index;
899 while (p < pend)
901 p += BYTES_BY_CHAR_HEAD (*p);
902 best_below++;
904 i = best_below;
905 i_byte = p - SDATA (string);
907 else
909 unsigned char *p = SDATA (string) + best_above_byte;
910 unsigned char *pbeg = SDATA (string) + byte_index;
912 while (p > pbeg)
914 p--;
915 while (!CHAR_HEAD_P (*p)) p--;
916 best_above--;
918 i = best_above;
919 i_byte = p - SDATA (string);
922 string_char_byte_cache_bytepos = i_byte;
923 string_char_byte_cache_charpos = i;
924 string_char_byte_cache_string = string;
926 return i;
929 /* Convert STRING to a multibyte string. */
931 static Lisp_Object
932 string_make_multibyte (Lisp_Object string)
934 unsigned char *buf;
935 ptrdiff_t nbytes;
936 Lisp_Object ret;
937 USE_SAFE_ALLOCA;
939 if (STRING_MULTIBYTE (string))
940 return string;
942 nbytes = count_size_as_multibyte (SDATA (string),
943 SCHARS (string));
944 /* If all the chars are ASCII, they won't need any more bytes
945 once converted. In that case, we can return STRING itself. */
946 if (nbytes == SBYTES (string))
947 return string;
949 buf = SAFE_ALLOCA (nbytes);
950 copy_text (SDATA (string), buf, SBYTES (string),
951 0, 1);
953 ret = make_multibyte_string ((char *) buf, SCHARS (string), nbytes);
954 SAFE_FREE ();
956 return ret;
960 /* Convert STRING (if unibyte) to a multibyte string without changing
961 the number of characters. Characters 0200 trough 0237 are
962 converted to eight-bit characters. */
964 Lisp_Object
965 string_to_multibyte (Lisp_Object string)
967 unsigned char *buf;
968 ptrdiff_t nbytes;
969 Lisp_Object ret;
970 USE_SAFE_ALLOCA;
972 if (STRING_MULTIBYTE (string))
973 return string;
975 nbytes = count_size_as_multibyte (SDATA (string), SBYTES (string));
976 /* If all the chars are ASCII, they won't need any more bytes once
977 converted. */
978 if (nbytes == SBYTES (string))
979 return make_multibyte_string (SSDATA (string), nbytes, nbytes);
981 buf = SAFE_ALLOCA (nbytes);
982 memcpy (buf, SDATA (string), SBYTES (string));
983 str_to_multibyte (buf, nbytes, SBYTES (string));
985 ret = make_multibyte_string ((char *) buf, SCHARS (string), nbytes);
986 SAFE_FREE ();
988 return ret;
992 /* Convert STRING to a single-byte string. */
994 Lisp_Object
995 string_make_unibyte (Lisp_Object string)
997 ptrdiff_t nchars;
998 unsigned char *buf;
999 Lisp_Object ret;
1000 USE_SAFE_ALLOCA;
1002 if (! STRING_MULTIBYTE (string))
1003 return string;
1005 nchars = SCHARS (string);
1007 buf = SAFE_ALLOCA (nchars);
1008 copy_text (SDATA (string), buf, SBYTES (string),
1009 1, 0);
1011 ret = make_unibyte_string ((char *) buf, nchars);
1012 SAFE_FREE ();
1014 return ret;
1017 DEFUN ("string-make-multibyte", Fstring_make_multibyte, Sstring_make_multibyte,
1018 1, 1, 0,
1019 doc: /* Return the multibyte equivalent of STRING.
1020 If STRING is unibyte and contains non-ASCII characters, the function
1021 `unibyte-char-to-multibyte' is used to convert each unibyte character
1022 to a multibyte character. In this case, the returned string is a
1023 newly created string with no text properties. If STRING is multibyte
1024 or entirely ASCII, it is returned unchanged. In particular, when
1025 STRING is unibyte and entirely ASCII, the returned string is unibyte.
1026 \(When the characters are all ASCII, Emacs primitives will treat the
1027 string the same way whether it is unibyte or multibyte.) */)
1028 (Lisp_Object string)
1030 CHECK_STRING (string);
1032 return string_make_multibyte (string);
1035 DEFUN ("string-make-unibyte", Fstring_make_unibyte, Sstring_make_unibyte,
1036 1, 1, 0,
1037 doc: /* Return the unibyte equivalent of STRING.
1038 Multibyte character codes are converted to unibyte according to
1039 `nonascii-translation-table' or, if that is nil, `nonascii-insert-offset'.
1040 If the lookup in the translation table fails, this function takes just
1041 the low 8 bits of each character. */)
1042 (Lisp_Object string)
1044 CHECK_STRING (string);
1046 return string_make_unibyte (string);
1049 DEFUN ("string-as-unibyte", Fstring_as_unibyte, Sstring_as_unibyte,
1050 1, 1, 0,
1051 doc: /* Return a unibyte string with the same individual bytes as STRING.
1052 If STRING is unibyte, the result is STRING itself.
1053 Otherwise it is a newly created string, with no text properties.
1054 If STRING is multibyte and contains a character of charset
1055 `eight-bit', it is converted to the corresponding single byte. */)
1056 (Lisp_Object string)
1058 CHECK_STRING (string);
1060 if (STRING_MULTIBYTE (string))
1062 unsigned char *str = (unsigned char *) xlispstrdup (string);
1063 ptrdiff_t bytes = str_as_unibyte (str, SBYTES (string));
1065 string = make_unibyte_string ((char *) str, bytes);
1066 xfree (str);
1068 return string;
1071 DEFUN ("string-as-multibyte", Fstring_as_multibyte, Sstring_as_multibyte,
1072 1, 1, 0,
1073 doc: /* Return a multibyte string with the same individual bytes as STRING.
1074 If STRING is multibyte, the result is STRING itself.
1075 Otherwise it is a newly created string, with no text properties.
1077 If STRING is unibyte and contains an individual 8-bit byte (i.e. not
1078 part of a correct utf-8 sequence), it is converted to the corresponding
1079 multibyte character of charset `eight-bit'.
1080 See also `string-to-multibyte'.
1082 Beware, this often doesn't really do what you think it does.
1083 It is similar to (decode-coding-string STRING \\='utf-8-emacs).
1084 If you're not sure, whether to use `string-as-multibyte' or
1085 `string-to-multibyte', use `string-to-multibyte'. */)
1086 (Lisp_Object string)
1088 CHECK_STRING (string);
1090 if (! STRING_MULTIBYTE (string))
1092 Lisp_Object new_string;
1093 ptrdiff_t nchars, nbytes;
1095 parse_str_as_multibyte (SDATA (string),
1096 SBYTES (string),
1097 &nchars, &nbytes);
1098 new_string = make_uninit_multibyte_string (nchars, nbytes);
1099 memcpy (SDATA (new_string), SDATA (string), SBYTES (string));
1100 if (nbytes != SBYTES (string))
1101 str_as_multibyte (SDATA (new_string), nbytes,
1102 SBYTES (string), NULL);
1103 string = new_string;
1104 set_string_intervals (string, NULL);
1106 return string;
1109 DEFUN ("string-to-multibyte", Fstring_to_multibyte, Sstring_to_multibyte,
1110 1, 1, 0,
1111 doc: /* Return a multibyte string with the same individual chars as STRING.
1112 If STRING is multibyte, the result is STRING itself.
1113 Otherwise it is a newly created string, with no text properties.
1115 If STRING is unibyte and contains an 8-bit byte, it is converted to
1116 the corresponding multibyte character of charset `eight-bit'.
1118 This differs from `string-as-multibyte' by converting each byte of a correct
1119 utf-8 sequence to an eight-bit character, not just bytes that don't form a
1120 correct sequence. */)
1121 (Lisp_Object string)
1123 CHECK_STRING (string);
1125 return string_to_multibyte (string);
1128 DEFUN ("string-to-unibyte", Fstring_to_unibyte, Sstring_to_unibyte,
1129 1, 1, 0,
1130 doc: /* Return a unibyte string with the same individual chars as STRING.
1131 If STRING is unibyte, the result is STRING itself.
1132 Otherwise it is a newly created string, with no text properties,
1133 where each `eight-bit' character is converted to the corresponding byte.
1134 If STRING contains a non-ASCII, non-`eight-bit' character,
1135 an error is signaled. */)
1136 (Lisp_Object string)
1138 CHECK_STRING (string);
1140 if (STRING_MULTIBYTE (string))
1142 ptrdiff_t chars = SCHARS (string);
1143 unsigned char *str = xmalloc (chars);
1144 ptrdiff_t converted = str_to_unibyte (SDATA (string), str, chars);
1146 if (converted < chars)
1147 error ("Can't convert the %"pD"dth character to unibyte", converted);
1148 string = make_unibyte_string ((char *) str, chars);
1149 xfree (str);
1151 return string;
1155 DEFUN ("copy-alist", Fcopy_alist, Scopy_alist, 1, 1, 0,
1156 doc: /* Return a copy of ALIST.
1157 This is an alist which represents the same mapping from objects to objects,
1158 but does not share the alist structure with ALIST.
1159 The objects mapped (cars and cdrs of elements of the alist)
1160 are shared, however.
1161 Elements of ALIST that are not conses are also shared. */)
1162 (Lisp_Object alist)
1164 if (NILP (alist))
1165 return alist;
1166 alist = concat (1, &alist, Lisp_Cons, false);
1167 for (Lisp_Object tem = alist; !NILP (tem); tem = XCDR (tem))
1169 Lisp_Object car = XCAR (tem);
1170 if (CONSP (car))
1171 XSETCAR (tem, Fcons (XCAR (car), XCDR (car)));
1173 return alist;
1176 /* Check that ARRAY can have a valid subarray [FROM..TO),
1177 given that its size is SIZE.
1178 If FROM is nil, use 0; if TO is nil, use SIZE.
1179 Count negative values backwards from the end.
1180 Set *IFROM and *ITO to the two indexes used. */
1182 void
1183 validate_subarray (Lisp_Object array, Lisp_Object from, Lisp_Object to,
1184 ptrdiff_t size, ptrdiff_t *ifrom, ptrdiff_t *ito)
1186 EMACS_INT f, t;
1188 if (INTEGERP (from))
1190 f = XINT (from);
1191 if (f < 0)
1192 f += size;
1194 else if (NILP (from))
1195 f = 0;
1196 else
1197 wrong_type_argument (Qintegerp, from);
1199 if (INTEGERP (to))
1201 t = XINT (to);
1202 if (t < 0)
1203 t += size;
1205 else if (NILP (to))
1206 t = size;
1207 else
1208 wrong_type_argument (Qintegerp, to);
1210 if (! (0 <= f && f <= t && t <= size))
1211 args_out_of_range_3 (array, from, to);
1213 *ifrom = f;
1214 *ito = t;
1217 DEFUN ("substring", Fsubstring, Ssubstring, 1, 3, 0,
1218 doc: /* Return a new string whose contents are a substring of STRING.
1219 The returned string consists of the characters between index FROM
1220 \(inclusive) and index TO (exclusive) of STRING. FROM and TO are
1221 zero-indexed: 0 means the first character of STRING. Negative values
1222 are counted from the end of STRING. If TO is nil, the substring runs
1223 to the end of STRING.
1225 The STRING argument may also be a vector. In that case, the return
1226 value is a new vector that contains the elements between index FROM
1227 \(inclusive) and index TO (exclusive) of that vector argument.
1229 With one argument, just copy STRING (with properties, if any). */)
1230 (Lisp_Object string, Lisp_Object from, Lisp_Object to)
1232 Lisp_Object res;
1233 ptrdiff_t size, ifrom, ito;
1235 size = CHECK_VECTOR_OR_STRING (string);
1236 validate_subarray (string, from, to, size, &ifrom, &ito);
1238 if (STRINGP (string))
1240 ptrdiff_t from_byte
1241 = !ifrom ? 0 : string_char_to_byte (string, ifrom);
1242 ptrdiff_t to_byte
1243 = ito == size ? SBYTES (string) : string_char_to_byte (string, ito);
1244 res = make_specified_string (SSDATA (string) + from_byte,
1245 ito - ifrom, to_byte - from_byte,
1246 STRING_MULTIBYTE (string));
1247 copy_text_properties (make_number (ifrom), make_number (ito),
1248 string, make_number (0), res, Qnil);
1250 else
1251 res = Fvector (ito - ifrom, aref_addr (string, ifrom));
1253 return res;
1257 DEFUN ("substring-no-properties", Fsubstring_no_properties, Ssubstring_no_properties, 1, 3, 0,
1258 doc: /* Return a substring of STRING, without text properties.
1259 It starts at index FROM and ends before TO.
1260 TO may be nil or omitted; then the substring runs to the end of STRING.
1261 If FROM is nil or omitted, the substring starts at the beginning of STRING.
1262 If FROM or TO is negative, it counts from the end.
1264 With one argument, just copy STRING without its properties. */)
1265 (Lisp_Object string, register Lisp_Object from, Lisp_Object to)
1267 ptrdiff_t from_char, to_char, from_byte, to_byte, size;
1269 CHECK_STRING (string);
1271 size = SCHARS (string);
1272 validate_subarray (string, from, to, size, &from_char, &to_char);
1274 from_byte = !from_char ? 0 : string_char_to_byte (string, from_char);
1275 to_byte =
1276 to_char == size ? SBYTES (string) : string_char_to_byte (string, to_char);
1277 return make_specified_string (SSDATA (string) + from_byte,
1278 to_char - from_char, to_byte - from_byte,
1279 STRING_MULTIBYTE (string));
1282 /* Extract a substring of STRING, giving start and end positions
1283 both in characters and in bytes. */
1285 Lisp_Object
1286 substring_both (Lisp_Object string, ptrdiff_t from, ptrdiff_t from_byte,
1287 ptrdiff_t to, ptrdiff_t to_byte)
1289 Lisp_Object res;
1290 ptrdiff_t size = CHECK_VECTOR_OR_STRING (string);
1292 if (!(0 <= from && from <= to && to <= size))
1293 args_out_of_range_3 (string, make_number (from), make_number (to));
1295 if (STRINGP (string))
1297 res = make_specified_string (SSDATA (string) + from_byte,
1298 to - from, to_byte - from_byte,
1299 STRING_MULTIBYTE (string));
1300 copy_text_properties (make_number (from), make_number (to),
1301 string, make_number (0), res, Qnil);
1303 else
1304 res = Fvector (to - from, aref_addr (string, from));
1306 return res;
1309 DEFUN ("nthcdr", Fnthcdr, Snthcdr, 2, 2, 0,
1310 doc: /* Take cdr N times on LIST, return the result. */)
1311 (Lisp_Object n, Lisp_Object list)
1313 CHECK_NUMBER (n);
1314 Lisp_Object tail = list;
1315 for (EMACS_INT num = XINT (n); 0 < num; num--)
1317 if (! CONSP (tail))
1319 CHECK_LIST_END (tail, list);
1320 return Qnil;
1322 tail = XCDR (tail);
1323 rarely_quit (num);
1325 return tail;
1328 DEFUN ("nth", Fnth, Snth, 2, 2, 0,
1329 doc: /* Return the Nth element of LIST.
1330 N counts from zero. If LIST is not that long, nil is returned. */)
1331 (Lisp_Object n, Lisp_Object list)
1333 return Fcar (Fnthcdr (n, list));
1336 DEFUN ("elt", Felt, Selt, 2, 2, 0,
1337 doc: /* Return element of SEQUENCE at index N. */)
1338 (register Lisp_Object sequence, Lisp_Object n)
1340 CHECK_NUMBER (n);
1341 if (CONSP (sequence) || NILP (sequence))
1342 return Fcar (Fnthcdr (n, sequence));
1344 /* Faref signals a "not array" error, so check here. */
1345 CHECK_ARRAY (sequence, Qsequencep);
1346 return Faref (sequence, n);
1349 DEFUN ("member", Fmember, Smember, 2, 2, 0,
1350 doc: /* Return non-nil if ELT is an element of LIST. Comparison done with `equal'.
1351 The value is actually the tail of LIST whose car is ELT. */)
1352 (Lisp_Object elt, Lisp_Object list)
1354 Lisp_Object tail = list;
1355 FOR_EACH_TAIL (tail)
1356 if (! NILP (Fequal (elt, XCAR (tail))))
1357 return tail;
1358 CHECK_LIST_END (tail, list);
1359 return Qnil;
1362 DEFUN ("memq", Fmemq, Smemq, 2, 2, 0,
1363 doc: /* Return non-nil if ELT is an element of LIST. Comparison done with `eq'.
1364 The value is actually the tail of LIST whose car is ELT. */)
1365 (Lisp_Object elt, Lisp_Object list)
1367 Lisp_Object tail = list;
1368 FOR_EACH_TAIL (tail)
1369 if (EQ (XCAR (tail), elt))
1370 return tail;
1371 CHECK_LIST_END (tail, list);
1372 return Qnil;
1375 DEFUN ("memql", Fmemql, Smemql, 2, 2, 0,
1376 doc: /* Return non-nil if ELT is an element of LIST. Comparison done with `eql'.
1377 The value is actually the tail of LIST whose car is ELT. */)
1378 (Lisp_Object elt, Lisp_Object list)
1380 if (!FLOATP (elt))
1381 return Fmemq (elt, list);
1383 Lisp_Object tail = list;
1384 FOR_EACH_TAIL (tail)
1386 Lisp_Object tem = XCAR (tail);
1387 if (FLOATP (tem) && equal_no_quit (elt, tem))
1388 return tail;
1390 CHECK_LIST_END (tail, list);
1391 return Qnil;
1394 DEFUN ("assq", Fassq, Sassq, 2, 2, 0,
1395 doc: /* Return non-nil if KEY is `eq' to the car of an element of LIST.
1396 The value is actually the first element of LIST whose car is KEY.
1397 Elements of LIST that are not conses are ignored. */)
1398 (Lisp_Object key, Lisp_Object list)
1400 Lisp_Object tail = list;
1401 FOR_EACH_TAIL (tail)
1402 if (CONSP (XCAR (tail)) && EQ (XCAR (XCAR (tail)), key))
1403 return XCAR (tail);
1404 CHECK_LIST_END (tail, list);
1405 return Qnil;
1408 /* Like Fassq but never report an error and do not allow quits.
1409 Use only on objects known to be non-circular lists. */
1411 Lisp_Object
1412 assq_no_quit (Lisp_Object key, Lisp_Object list)
1414 for (; ! NILP (list); list = XCDR (list))
1415 if (CONSP (XCAR (list)) && EQ (XCAR (XCAR (list)), key))
1416 return XCAR (list);
1417 return Qnil;
1420 DEFUN ("assoc", Fassoc, Sassoc, 2, 2, 0,
1421 doc: /* Return non-nil if KEY is `equal' to the car of an element of LIST.
1422 The value is actually the first element of LIST whose car equals KEY. */)
1423 (Lisp_Object key, Lisp_Object list)
1425 Lisp_Object tail = list;
1426 FOR_EACH_TAIL (tail)
1428 Lisp_Object car = XCAR (tail);
1429 if (CONSP (car)
1430 && (EQ (XCAR (car), key) || !NILP (Fequal (XCAR (car), key))))
1431 return car;
1433 CHECK_LIST_END (tail, list);
1434 return Qnil;
1437 /* Like Fassoc but never report an error and do not allow quits.
1438 Use only on keys and lists known to be non-circular, and on keys
1439 that are not too deep and are not window configurations. */
1441 Lisp_Object
1442 assoc_no_quit (Lisp_Object key, Lisp_Object list)
1444 for (; ! NILP (list); list = XCDR (list))
1446 Lisp_Object car = XCAR (list);
1447 if (CONSP (car)
1448 && (EQ (XCAR (car), key) || equal_no_quit (XCAR (car), key)))
1449 return car;
1451 return Qnil;
1454 DEFUN ("rassq", Frassq, Srassq, 2, 2, 0,
1455 doc: /* Return non-nil if KEY is `eq' to the cdr of an element of LIST.
1456 The value is actually the first element of LIST whose cdr is KEY. */)
1457 (Lisp_Object key, Lisp_Object list)
1459 Lisp_Object tail = list;
1460 FOR_EACH_TAIL (tail)
1461 if (CONSP (XCAR (tail)) && EQ (XCDR (XCAR (tail)), key))
1462 return XCAR (tail);
1463 CHECK_LIST_END (tail, list);
1464 return Qnil;
1467 DEFUN ("rassoc", Frassoc, Srassoc, 2, 2, 0,
1468 doc: /* Return non-nil if KEY is `equal' to the cdr of an element of LIST.
1469 The value is actually the first element of LIST whose cdr equals KEY. */)
1470 (Lisp_Object key, Lisp_Object list)
1472 Lisp_Object tail = list;
1473 FOR_EACH_TAIL (tail)
1475 Lisp_Object car = XCAR (tail);
1476 if (CONSP (car)
1477 && (EQ (XCDR (car), key) || !NILP (Fequal (XCDR (car), key))))
1478 return car;
1480 CHECK_LIST_END (tail, list);
1481 return Qnil;
1484 DEFUN ("delq", Fdelq, Sdelq, 2, 2, 0,
1485 doc: /* Delete members of LIST which are `eq' to ELT, and return the result.
1486 More precisely, this function skips any members `eq' to ELT at the
1487 front of LIST, then removes members `eq' to ELT from the remaining
1488 sublist by modifying its list structure, then returns the resulting
1489 list.
1491 Write `(setq foo (delq element foo))' to be sure of correctly changing
1492 the value of a list `foo'. See also `remq', which does not modify the
1493 argument. */)
1494 (Lisp_Object elt, Lisp_Object list)
1496 Lisp_Object prev = Qnil, tail = list;
1498 FOR_EACH_TAIL (tail)
1500 Lisp_Object tem = XCAR (tail);
1501 if (EQ (elt, tem))
1503 if (NILP (prev))
1504 list = XCDR (tail);
1505 else
1506 Fsetcdr (prev, XCDR (tail));
1508 else
1509 prev = tail;
1511 CHECK_LIST_END (tail, list);
1512 return list;
1515 DEFUN ("delete", Fdelete, Sdelete, 2, 2, 0,
1516 doc: /* Delete members of SEQ which are `equal' to ELT, and return the result.
1517 SEQ must be a sequence (i.e. a list, a vector, or a string).
1518 The return value is a sequence of the same type.
1520 If SEQ is a list, this behaves like `delq', except that it compares
1521 with `equal' instead of `eq'. In particular, it may remove elements
1522 by altering the list structure.
1524 If SEQ is not a list, deletion is never performed destructively;
1525 instead this function creates and returns a new vector or string.
1527 Write `(setq foo (delete element foo))' to be sure of correctly
1528 changing the value of a sequence `foo'. */)
1529 (Lisp_Object elt, Lisp_Object seq)
1531 if (VECTORP (seq))
1533 ptrdiff_t i, n;
1535 for (i = n = 0; i < ASIZE (seq); ++i)
1536 if (NILP (Fequal (AREF (seq, i), elt)))
1537 ++n;
1539 if (n != ASIZE (seq))
1541 struct Lisp_Vector *p = allocate_vector (n);
1543 for (i = n = 0; i < ASIZE (seq); ++i)
1544 if (NILP (Fequal (AREF (seq, i), elt)))
1545 p->contents[n++] = AREF (seq, i);
1547 XSETVECTOR (seq, p);
1550 else if (STRINGP (seq))
1552 ptrdiff_t i, ibyte, nchars, nbytes, cbytes;
1553 int c;
1555 for (i = nchars = nbytes = ibyte = 0;
1556 i < SCHARS (seq);
1557 ++i, ibyte += cbytes)
1559 if (STRING_MULTIBYTE (seq))
1561 c = STRING_CHAR (SDATA (seq) + ibyte);
1562 cbytes = CHAR_BYTES (c);
1564 else
1566 c = SREF (seq, i);
1567 cbytes = 1;
1570 if (!INTEGERP (elt) || c != XINT (elt))
1572 ++nchars;
1573 nbytes += cbytes;
1577 if (nchars != SCHARS (seq))
1579 Lisp_Object tem;
1581 tem = make_uninit_multibyte_string (nchars, nbytes);
1582 if (!STRING_MULTIBYTE (seq))
1583 STRING_SET_UNIBYTE (tem);
1585 for (i = nchars = nbytes = ibyte = 0;
1586 i < SCHARS (seq);
1587 ++i, ibyte += cbytes)
1589 if (STRING_MULTIBYTE (seq))
1591 c = STRING_CHAR (SDATA (seq) + ibyte);
1592 cbytes = CHAR_BYTES (c);
1594 else
1596 c = SREF (seq, i);
1597 cbytes = 1;
1600 if (!INTEGERP (elt) || c != XINT (elt))
1602 unsigned char *from = SDATA (seq) + ibyte;
1603 unsigned char *to = SDATA (tem) + nbytes;
1604 ptrdiff_t n;
1606 ++nchars;
1607 nbytes += cbytes;
1609 for (n = cbytes; n--; )
1610 *to++ = *from++;
1614 seq = tem;
1617 else
1619 Lisp_Object prev = Qnil, tail = seq;
1621 FOR_EACH_TAIL (tail)
1623 if (!NILP (Fequal (elt, XCAR (tail))))
1625 if (NILP (prev))
1626 seq = XCDR (tail);
1627 else
1628 Fsetcdr (prev, XCDR (tail));
1630 else
1631 prev = tail;
1633 CHECK_LIST_END (tail, seq);
1636 return seq;
1639 DEFUN ("nreverse", Fnreverse, Snreverse, 1, 1, 0,
1640 doc: /* Reverse order of items in a list, vector or string SEQ.
1641 If SEQ is a list, it should be nil-terminated.
1642 This function may destructively modify SEQ to produce the value. */)
1643 (Lisp_Object seq)
1645 if (NILP (seq))
1646 return seq;
1647 else if (STRINGP (seq))
1648 return Freverse (seq);
1649 else if (CONSP (seq))
1651 Lisp_Object prev, tail, next;
1653 for (prev = Qnil, tail = seq; CONSP (tail); tail = next)
1655 next = XCDR (tail);
1656 /* If SEQ contains a cycle, attempting to reverse it
1657 in-place will inevitably come back to SEQ. */
1658 if (EQ (next, seq))
1659 circular_list (seq);
1660 Fsetcdr (tail, prev);
1661 prev = tail;
1663 CHECK_LIST_END (tail, seq);
1664 seq = prev;
1666 else if (VECTORP (seq))
1668 ptrdiff_t i, size = ASIZE (seq);
1670 for (i = 0; i < size / 2; i++)
1672 Lisp_Object tem = AREF (seq, i);
1673 ASET (seq, i, AREF (seq, size - i - 1));
1674 ASET (seq, size - i - 1, tem);
1677 else if (BOOL_VECTOR_P (seq))
1679 ptrdiff_t i, size = bool_vector_size (seq);
1681 for (i = 0; i < size / 2; i++)
1683 bool tem = bool_vector_bitref (seq, i);
1684 bool_vector_set (seq, i, bool_vector_bitref (seq, size - i - 1));
1685 bool_vector_set (seq, size - i - 1, tem);
1688 else
1689 wrong_type_argument (Qarrayp, seq);
1690 return seq;
1693 DEFUN ("reverse", Freverse, Sreverse, 1, 1, 0,
1694 doc: /* Return the reversed copy of list, vector, or string SEQ.
1695 See also the function `nreverse', which is used more often. */)
1696 (Lisp_Object seq)
1698 Lisp_Object new;
1700 if (NILP (seq))
1701 return Qnil;
1702 else if (CONSP (seq))
1704 new = Qnil;
1705 FOR_EACH_TAIL (seq)
1706 new = Fcons (XCAR (seq), new);
1707 CHECK_LIST_END (seq, seq);
1709 else if (VECTORP (seq))
1711 ptrdiff_t i, size = ASIZE (seq);
1713 new = make_uninit_vector (size);
1714 for (i = 0; i < size; i++)
1715 ASET (new, i, AREF (seq, size - i - 1));
1717 else if (BOOL_VECTOR_P (seq))
1719 ptrdiff_t i;
1720 EMACS_INT nbits = bool_vector_size (seq);
1722 new = make_uninit_bool_vector (nbits);
1723 for (i = 0; i < nbits; i++)
1724 bool_vector_set (new, i, bool_vector_bitref (seq, nbits - i - 1));
1726 else if (STRINGP (seq))
1728 ptrdiff_t size = SCHARS (seq), bytes = SBYTES (seq);
1730 if (size == bytes)
1732 ptrdiff_t i;
1734 new = make_uninit_string (size);
1735 for (i = 0; i < size; i++)
1736 SSET (new, i, SREF (seq, size - i - 1));
1738 else
1740 unsigned char *p, *q;
1742 new = make_uninit_multibyte_string (size, bytes);
1743 p = SDATA (seq), q = SDATA (new) + bytes;
1744 while (q > SDATA (new))
1746 int ch, len;
1748 ch = STRING_CHAR_AND_LENGTH (p, len);
1749 p += len, q -= len;
1750 CHAR_STRING (ch, q);
1754 else
1755 wrong_type_argument (Qsequencep, seq);
1756 return new;
1759 /* Sort LIST using PREDICATE, preserving original order of elements
1760 considered as equal. */
1762 static Lisp_Object
1763 sort_list (Lisp_Object list, Lisp_Object predicate)
1765 Lisp_Object front, back;
1766 Lisp_Object len, tem;
1767 EMACS_INT length;
1769 front = list;
1770 len = Flength (list);
1771 length = XINT (len);
1772 if (length < 2)
1773 return list;
1775 XSETINT (len, (length / 2) - 1);
1776 tem = Fnthcdr (len, list);
1777 back = Fcdr (tem);
1778 Fsetcdr (tem, Qnil);
1780 front = Fsort (front, predicate);
1781 back = Fsort (back, predicate);
1782 return merge (front, back, predicate);
1785 /* Using PRED to compare, return whether A and B are in order.
1786 Compare stably when A appeared before B in the input. */
1787 static bool
1788 inorder (Lisp_Object pred, Lisp_Object a, Lisp_Object b)
1790 return NILP (call2 (pred, b, a));
1793 /* Using PRED to compare, merge from ALEN-length A and BLEN-length B
1794 into DEST. Argument arrays must be nonempty and must not overlap,
1795 except that B might be the last part of DEST. */
1796 static void
1797 merge_vectors (Lisp_Object pred,
1798 ptrdiff_t alen, Lisp_Object const a[restrict VLA_ELEMS (alen)],
1799 ptrdiff_t blen, Lisp_Object const b[VLA_ELEMS (blen)],
1800 Lisp_Object dest[VLA_ELEMS (alen + blen)])
1802 eassume (0 < alen && 0 < blen);
1803 Lisp_Object const *alim = a + alen;
1804 Lisp_Object const *blim = b + blen;
1806 while (true)
1808 if (inorder (pred, a[0], b[0]))
1810 *dest++ = *a++;
1811 if (a == alim)
1813 if (dest != b)
1814 memcpy (dest, b, (blim - b) * sizeof *dest);
1815 return;
1818 else
1820 *dest++ = *b++;
1821 if (b == blim)
1823 memcpy (dest, a, (alim - a) * sizeof *dest);
1824 return;
1830 /* Using PRED to compare, sort LEN-length VEC in place, using TMP for
1831 temporary storage. LEN must be at least 2. */
1832 static void
1833 sort_vector_inplace (Lisp_Object pred, ptrdiff_t len,
1834 Lisp_Object vec[restrict VLA_ELEMS (len)],
1835 Lisp_Object tmp[restrict VLA_ELEMS (len >> 1)])
1837 eassume (2 <= len);
1838 ptrdiff_t halflen = len >> 1;
1839 sort_vector_copy (pred, halflen, vec, tmp);
1840 if (1 < len - halflen)
1841 sort_vector_inplace (pred, len - halflen, vec + halflen, vec);
1842 merge_vectors (pred, halflen, tmp, len - halflen, vec + halflen, vec);
1845 /* Using PRED to compare, sort from LEN-length SRC into DST.
1846 Len must be positive. */
1847 static void
1848 sort_vector_copy (Lisp_Object pred, ptrdiff_t len,
1849 Lisp_Object src[restrict VLA_ELEMS (len)],
1850 Lisp_Object dest[restrict VLA_ELEMS (len)])
1852 eassume (0 < len);
1853 ptrdiff_t halflen = len >> 1;
1854 if (halflen < 1)
1855 dest[0] = src[0];
1856 else
1858 if (1 < halflen)
1859 sort_vector_inplace (pred, halflen, src, dest);
1860 if (1 < len - halflen)
1861 sort_vector_inplace (pred, len - halflen, src + halflen, dest);
1862 merge_vectors (pred, halflen, src, len - halflen, src + halflen, dest);
1866 /* Sort VECTOR in place using PREDICATE, preserving original order of
1867 elements considered as equal. */
1869 static void
1870 sort_vector (Lisp_Object vector, Lisp_Object predicate)
1872 ptrdiff_t len = ASIZE (vector);
1873 if (len < 2)
1874 return;
1875 ptrdiff_t halflen = len >> 1;
1876 Lisp_Object *tmp;
1877 USE_SAFE_ALLOCA;
1878 SAFE_ALLOCA_LISP (tmp, halflen);
1879 for (ptrdiff_t i = 0; i < halflen; i++)
1880 tmp[i] = make_number (0);
1881 sort_vector_inplace (predicate, len, XVECTOR (vector)->contents, tmp);
1882 SAFE_FREE ();
1885 DEFUN ("sort", Fsort, Ssort, 2, 2, 0,
1886 doc: /* Sort SEQ, stably, comparing elements using PREDICATE.
1887 Returns the sorted sequence. SEQ should be a list or vector. SEQ is
1888 modified by side effects. PREDICATE is called with two elements of
1889 SEQ, and should return non-nil if the first element should sort before
1890 the second. */)
1891 (Lisp_Object seq, Lisp_Object predicate)
1893 if (CONSP (seq))
1894 seq = sort_list (seq, predicate);
1895 else if (VECTORP (seq))
1896 sort_vector (seq, predicate);
1897 else if (!NILP (seq))
1898 wrong_type_argument (Qsequencep, seq);
1899 return seq;
1902 Lisp_Object
1903 merge (Lisp_Object org_l1, Lisp_Object org_l2, Lisp_Object pred)
1905 Lisp_Object l1 = org_l1;
1906 Lisp_Object l2 = org_l2;
1907 Lisp_Object tail = Qnil;
1908 Lisp_Object value = Qnil;
1910 while (1)
1912 if (NILP (l1))
1914 if (NILP (tail))
1915 return l2;
1916 Fsetcdr (tail, l2);
1917 return value;
1919 if (NILP (l2))
1921 if (NILP (tail))
1922 return l1;
1923 Fsetcdr (tail, l1);
1924 return value;
1927 Lisp_Object tem;
1928 if (inorder (pred, Fcar (l1), Fcar (l2)))
1930 tem = l1;
1931 l1 = Fcdr (l1);
1932 org_l1 = l1;
1934 else
1936 tem = l2;
1937 l2 = Fcdr (l2);
1938 org_l2 = l2;
1940 if (NILP (tail))
1941 value = tem;
1942 else
1943 Fsetcdr (tail, tem);
1944 tail = tem;
1949 /* This does not check for quits. That is safe since it must terminate. */
1951 DEFUN ("plist-get", Fplist_get, Splist_get, 2, 2, 0,
1952 doc: /* Extract a value from a property list.
1953 PLIST is a property list, which is a list of the form
1954 \(PROP1 VALUE1 PROP2 VALUE2...). This function returns the value
1955 corresponding to the given PROP, or nil if PROP is not one of the
1956 properties on the list. This function never signals an error. */)
1957 (Lisp_Object plist, Lisp_Object prop)
1959 Lisp_Object tail = plist;
1960 FOR_EACH_TAIL_SAFE (tail)
1962 if (! CONSP (XCDR (tail)))
1963 break;
1964 if (EQ (prop, XCAR (tail)))
1965 return XCAR (XCDR (tail));
1966 tail = XCDR (tail);
1967 if (EQ (tail, li.tortoise))
1968 break;
1971 return Qnil;
1974 DEFUN ("get", Fget, Sget, 2, 2, 0,
1975 doc: /* Return the value of SYMBOL's PROPNAME property.
1976 This is the last value stored with `(put SYMBOL PROPNAME VALUE)'. */)
1977 (Lisp_Object symbol, Lisp_Object propname)
1979 CHECK_SYMBOL (symbol);
1980 return Fplist_get (XSYMBOL (symbol)->plist, propname);
1983 DEFUN ("plist-put", Fplist_put, Splist_put, 3, 3, 0,
1984 doc: /* Change value in PLIST of PROP to VAL.
1985 PLIST is a property list, which is a list of the form
1986 \(PROP1 VALUE1 PROP2 VALUE2 ...). PROP is a symbol and VAL is any object.
1987 If PROP is already a property on the list, its value is set to VAL,
1988 otherwise the new PROP VAL pair is added. The new plist is returned;
1989 use `(setq x (plist-put x prop val))' to be sure to use the new value.
1990 The PLIST is modified by side effects. */)
1991 (Lisp_Object plist, Lisp_Object prop, Lisp_Object val)
1993 Lisp_Object prev = Qnil, tail = plist;
1994 FOR_EACH_TAIL (tail)
1996 if (! CONSP (XCDR (tail)))
1997 break;
1999 if (EQ (prop, XCAR (tail)))
2001 Fsetcar (XCDR (tail), val);
2002 return plist;
2005 prev = tail;
2006 tail = XCDR (tail);
2007 if (EQ (tail, li.tortoise))
2008 circular_list (plist);
2010 CHECK_LIST_END (tail, plist);
2011 Lisp_Object newcell
2012 = Fcons (prop, Fcons (val, NILP (prev) ? plist : XCDR (XCDR (prev))));
2013 if (NILP (prev))
2014 return newcell;
2015 Fsetcdr (XCDR (prev), newcell);
2016 return plist;
2019 DEFUN ("put", Fput, Sput, 3, 3, 0,
2020 doc: /* Store SYMBOL's PROPNAME property with value VALUE.
2021 It can be retrieved with `(get SYMBOL PROPNAME)'. */)
2022 (Lisp_Object symbol, Lisp_Object propname, Lisp_Object value)
2024 CHECK_SYMBOL (symbol);
2025 set_symbol_plist
2026 (symbol, Fplist_put (XSYMBOL (symbol)->plist, propname, value));
2027 return value;
2030 DEFUN ("lax-plist-get", Flax_plist_get, Slax_plist_get, 2, 2, 0,
2031 doc: /* Extract a value from a property list, comparing with `equal'.
2032 PLIST is a property list, which is a list of the form
2033 \(PROP1 VALUE1 PROP2 VALUE2...). This function returns the value
2034 corresponding to the given PROP, or nil if PROP is not
2035 one of the properties on the list. */)
2036 (Lisp_Object plist, Lisp_Object prop)
2038 Lisp_Object tail = plist;
2039 FOR_EACH_TAIL (tail)
2041 if (! CONSP (XCDR (tail)))
2042 break;
2043 if (! NILP (Fequal (prop, XCAR (tail))))
2044 return XCAR (XCDR (tail));
2045 tail = XCDR (tail);
2046 if (EQ (tail, li.tortoise))
2047 circular_list (plist);
2050 CHECK_LIST_END (tail, plist);
2052 return Qnil;
2055 DEFUN ("lax-plist-put", Flax_plist_put, Slax_plist_put, 3, 3, 0,
2056 doc: /* Change value in PLIST of PROP to VAL, comparing with `equal'.
2057 PLIST is a property list, which is a list of the form
2058 \(PROP1 VALUE1 PROP2 VALUE2 ...). PROP and VAL are any objects.
2059 If PROP is already a property on the list, its value is set to VAL,
2060 otherwise the new PROP VAL pair is added. The new plist is returned;
2061 use `(setq x (lax-plist-put x prop val))' to be sure to use the new value.
2062 The PLIST is modified by side effects. */)
2063 (Lisp_Object plist, Lisp_Object prop, Lisp_Object val)
2065 Lisp_Object prev = Qnil, tail = plist;
2066 FOR_EACH_TAIL (tail)
2068 if (! CONSP (XCDR (tail)))
2069 break;
2071 if (! NILP (Fequal (prop, XCAR (tail))))
2073 Fsetcar (XCDR (tail), val);
2074 return plist;
2077 prev = tail;
2078 tail = XCDR (tail);
2079 if (EQ (tail, li.tortoise))
2080 circular_list (plist);
2082 CHECK_LIST_END (tail, plist);
2083 Lisp_Object newcell = list2 (prop, val);
2084 if (NILP (prev))
2085 return newcell;
2086 Fsetcdr (XCDR (prev), newcell);
2087 return plist;
2090 DEFUN ("eql", Feql, Seql, 2, 2, 0,
2091 doc: /* Return t if the two args are the same Lisp object.
2092 Floating-point numbers of equal value are `eql', but they may not be `eq'. */)
2093 (Lisp_Object obj1, Lisp_Object obj2)
2095 if (FLOATP (obj1))
2096 return equal_no_quit (obj1, obj2) ? Qt : Qnil;
2097 else
2098 return EQ (obj1, obj2) ? Qt : Qnil;
2101 DEFUN ("equal", Fequal, Sequal, 2, 2, 0,
2102 doc: /* Return t if two Lisp objects have similar structure and contents.
2103 They must have the same data type.
2104 Conses are compared by comparing the cars and the cdrs.
2105 Vectors and strings are compared element by element.
2106 Numbers are compared by value, but integers cannot equal floats.
2107 (Use `=' if you want integers and floats to be able to be equal.)
2108 Symbols must match exactly. */)
2109 (Lisp_Object o1, Lisp_Object o2)
2111 return internal_equal (o1, o2, EQUAL_PLAIN, 0, Qnil) ? Qt : Qnil;
2114 DEFUN ("equal-including-properties", Fequal_including_properties, Sequal_including_properties, 2, 2, 0,
2115 doc: /* Return t if two Lisp objects have similar structure and contents.
2116 This is like `equal' except that it compares the text properties
2117 of strings. (`equal' ignores text properties.) */)
2118 (Lisp_Object o1, Lisp_Object o2)
2120 return (internal_equal (o1, o2, EQUAL_INCLUDING_PROPERTIES, 0, Qnil)
2121 ? Qt : Qnil);
2124 /* Return true if O1 and O2 are equal. Do not quit or check for cycles.
2125 Use this only on arguments that are cycle-free and not too large and
2126 are not window configurations. */
2128 bool
2129 equal_no_quit (Lisp_Object o1, Lisp_Object o2)
2131 return internal_equal (o1, o2, EQUAL_NO_QUIT, 0, Qnil);
2134 /* Return true if O1 and O2 are equal. EQUAL_KIND specifies what kind
2135 of equality test to use: if it is EQUAL_NO_QUIT, do not check for
2136 cycles or large arguments or quits; if EQUAL_PLAIN, do ordinary
2137 Lisp equality; and if EQUAL_INCLUDING_PROPERTIES, do
2138 equal-including-properties.
2140 If DEPTH is the current depth of recursion; signal an error if it
2141 gets too deep. HT is a hash table used to detect cycles; if nil,
2142 it has not been allocated yet. But ignore the last two arguments
2143 if EQUAL_KIND == EQUAL_NO_QUIT. */
2145 static bool
2146 internal_equal (Lisp_Object o1, Lisp_Object o2, enum equal_kind equal_kind,
2147 int depth, Lisp_Object ht)
2149 tail_recurse:
2150 if (depth > 10)
2152 eassert (equal_kind != EQUAL_NO_QUIT);
2153 if (depth > 200)
2154 error ("Stack overflow in equal");
2155 if (NILP (ht))
2156 ht = CALLN (Fmake_hash_table, QCtest, Qeq);
2157 switch (XTYPE (o1))
2159 case Lisp_Cons: case Lisp_Misc: case Lisp_Vectorlike:
2161 struct Lisp_Hash_Table *h = XHASH_TABLE (ht);
2162 EMACS_UINT hash;
2163 ptrdiff_t i = hash_lookup (h, o1, &hash);
2164 if (i >= 0)
2165 { /* `o1' was seen already. */
2166 Lisp_Object o2s = HASH_VALUE (h, i);
2167 if (!NILP (Fmemq (o2, o2s)))
2168 return true;
2169 else
2170 set_hash_value_slot (h, i, Fcons (o2, o2s));
2172 else
2173 hash_put (h, o1, Fcons (o2, Qnil), hash);
2175 default: ;
2179 if (EQ (o1, o2))
2180 return true;
2181 if (XTYPE (o1) != XTYPE (o2))
2182 return false;
2184 switch (XTYPE (o1))
2186 case Lisp_Float:
2188 double d1 = XFLOAT_DATA (o1);
2189 double d2 = XFLOAT_DATA (o2);
2190 /* If d is a NaN, then d != d. Two NaNs should be `equal' even
2191 though they are not =. */
2192 return d1 == d2 || (d1 != d1 && d2 != d2);
2195 case Lisp_Cons:
2196 if (equal_kind == EQUAL_NO_QUIT)
2197 for (; CONSP (o1); o1 = XCDR (o1))
2199 if (! CONSP (o2))
2200 return false;
2201 if (! equal_no_quit (XCAR (o1), XCAR (o2)))
2202 return false;
2203 o2 = XCDR (o2);
2204 if (EQ (XCDR (o1), o2))
2205 return true;
2207 else
2208 FOR_EACH_TAIL (o1)
2210 if (! CONSP (o2))
2211 return false;
2212 if (! internal_equal (XCAR (o1), XCAR (o2),
2213 equal_kind, depth + 1, ht))
2214 return false;
2215 o2 = XCDR (o2);
2216 if (EQ (XCDR (o1), o2))
2217 return true;
2219 depth++;
2220 goto tail_recurse;
2222 case Lisp_Misc:
2223 if (XMISCTYPE (o1) != XMISCTYPE (o2))
2224 return false;
2225 if (OVERLAYP (o1))
2227 if (!internal_equal (OVERLAY_START (o1), OVERLAY_START (o2),
2228 equal_kind, depth + 1, ht)
2229 || !internal_equal (OVERLAY_END (o1), OVERLAY_END (o2),
2230 equal_kind, depth + 1, ht))
2231 return false;
2232 o1 = XOVERLAY (o1)->plist;
2233 o2 = XOVERLAY (o2)->plist;
2234 depth++;
2235 goto tail_recurse;
2237 if (MARKERP (o1))
2239 return (XMARKER (o1)->buffer == XMARKER (o2)->buffer
2240 && (XMARKER (o1)->buffer == 0
2241 || XMARKER (o1)->bytepos == XMARKER (o2)->bytepos));
2243 break;
2245 case Lisp_Vectorlike:
2247 register int i;
2248 ptrdiff_t size = ASIZE (o1);
2249 /* Pseudovectors have the type encoded in the size field, so this test
2250 actually checks that the objects have the same type as well as the
2251 same size. */
2252 if (ASIZE (o2) != size)
2253 return false;
2254 /* Boolvectors are compared much like strings. */
2255 if (BOOL_VECTOR_P (o1))
2257 EMACS_INT size = bool_vector_size (o1);
2258 if (size != bool_vector_size (o2))
2259 return false;
2260 if (memcmp (bool_vector_data (o1), bool_vector_data (o2),
2261 bool_vector_bytes (size)))
2262 return false;
2263 return true;
2265 if (WINDOW_CONFIGURATIONP (o1))
2267 eassert (equal_kind != EQUAL_NO_QUIT);
2268 return compare_window_configurations (o1, o2, false);
2271 /* Aside from them, only true vectors, char-tables, compiled
2272 functions, and fonts (font-spec, font-entity, font-object)
2273 are sensible to compare, so eliminate the others now. */
2274 if (size & PSEUDOVECTOR_FLAG)
2276 if (((size & PVEC_TYPE_MASK) >> PSEUDOVECTOR_AREA_BITS)
2277 < PVEC_COMPILED)
2278 return false;
2279 size &= PSEUDOVECTOR_SIZE_MASK;
2281 for (i = 0; i < size; i++)
2283 Lisp_Object v1, v2;
2284 v1 = AREF (o1, i);
2285 v2 = AREF (o2, i);
2286 if (!internal_equal (v1, v2, equal_kind, depth + 1, ht))
2287 return false;
2289 return true;
2291 break;
2293 case Lisp_String:
2294 if (SCHARS (o1) != SCHARS (o2))
2295 return false;
2296 if (SBYTES (o1) != SBYTES (o2))
2297 return false;
2298 if (memcmp (SDATA (o1), SDATA (o2), SBYTES (o1)))
2299 return false;
2300 if (equal_kind == EQUAL_INCLUDING_PROPERTIES
2301 && !compare_string_intervals (o1, o2))
2302 return false;
2303 return true;
2305 default:
2306 break;
2309 return false;
2313 DEFUN ("fillarray", Ffillarray, Sfillarray, 2, 2, 0,
2314 doc: /* Store each element of ARRAY with ITEM.
2315 ARRAY is a vector, string, char-table, or bool-vector. */)
2316 (Lisp_Object array, Lisp_Object item)
2318 register ptrdiff_t size, idx;
2320 if (VECTORP (array))
2321 for (idx = 0, size = ASIZE (array); idx < size; idx++)
2322 ASET (array, idx, item);
2323 else if (CHAR_TABLE_P (array))
2325 int i;
2327 for (i = 0; i < (1 << CHARTAB_SIZE_BITS_0); i++)
2328 set_char_table_contents (array, i, item);
2329 set_char_table_defalt (array, item);
2331 else if (STRINGP (array))
2333 register unsigned char *p = SDATA (array);
2334 int charval;
2335 CHECK_CHARACTER (item);
2336 charval = XFASTINT (item);
2337 size = SCHARS (array);
2338 if (STRING_MULTIBYTE (array))
2340 unsigned char str[MAX_MULTIBYTE_LENGTH];
2341 int len = CHAR_STRING (charval, str);
2342 ptrdiff_t size_byte = SBYTES (array);
2343 ptrdiff_t product;
2345 if (INT_MULTIPLY_WRAPV (size, len, &product) || product != size_byte)
2346 error ("Attempt to change byte length of a string");
2347 for (idx = 0; idx < size_byte; idx++)
2348 *p++ = str[idx % len];
2350 else
2351 for (idx = 0; idx < size; idx++)
2352 p[idx] = charval;
2354 else if (BOOL_VECTOR_P (array))
2355 return bool_vector_fill (array, item);
2356 else
2357 wrong_type_argument (Qarrayp, array);
2358 return array;
2361 DEFUN ("clear-string", Fclear_string, Sclear_string,
2362 1, 1, 0,
2363 doc: /* Clear the contents of STRING.
2364 This makes STRING unibyte and may change its length. */)
2365 (Lisp_Object string)
2367 ptrdiff_t len;
2368 CHECK_STRING (string);
2369 len = SBYTES (string);
2370 memset (SDATA (string), 0, len);
2371 STRING_SET_CHARS (string, len);
2372 STRING_SET_UNIBYTE (string);
2373 return Qnil;
2376 /* ARGSUSED */
2377 Lisp_Object
2378 nconc2 (Lisp_Object s1, Lisp_Object s2)
2380 return CALLN (Fnconc, s1, s2);
2383 DEFUN ("nconc", Fnconc, Snconc, 0, MANY, 0,
2384 doc: /* Concatenate any number of lists by altering them.
2385 Only the last argument is not altered, and need not be a list.
2386 usage: (nconc &rest LISTS) */)
2387 (ptrdiff_t nargs, Lisp_Object *args)
2389 Lisp_Object val = Qnil;
2391 for (ptrdiff_t argnum = 0; argnum < nargs; argnum++)
2393 Lisp_Object tem = args[argnum];
2394 if (NILP (tem)) continue;
2396 if (NILP (val))
2397 val = tem;
2399 if (argnum + 1 == nargs) break;
2401 CHECK_CONS (tem);
2403 Lisp_Object tail;
2404 FOR_EACH_TAIL (tem)
2405 tail = tem;
2407 tem = args[argnum + 1];
2408 Fsetcdr (tail, tem);
2409 if (NILP (tem))
2410 args[argnum + 1] = tail;
2413 return val;
2416 /* This is the guts of all mapping functions.
2417 Apply FN to each element of SEQ, one by one, storing the results
2418 into elements of VALS, a C vector of Lisp_Objects. LENI is the
2419 length of VALS, which should also be the length of SEQ. Return the
2420 number of results; although this is normally LENI, it can be less
2421 if SEQ is made shorter as a side effect of FN. */
2423 static EMACS_INT
2424 mapcar1 (EMACS_INT leni, Lisp_Object *vals, Lisp_Object fn, Lisp_Object seq)
2426 Lisp_Object tail, dummy;
2427 EMACS_INT i;
2429 if (VECTORP (seq) || COMPILEDP (seq))
2431 for (i = 0; i < leni; i++)
2433 dummy = call1 (fn, AREF (seq, i));
2434 if (vals)
2435 vals[i] = dummy;
2438 else if (BOOL_VECTOR_P (seq))
2440 for (i = 0; i < leni; i++)
2442 dummy = call1 (fn, bool_vector_ref (seq, i));
2443 if (vals)
2444 vals[i] = dummy;
2447 else if (STRINGP (seq))
2449 ptrdiff_t i_byte;
2451 for (i = 0, i_byte = 0; i < leni;)
2453 int c;
2454 ptrdiff_t i_before = i;
2456 FETCH_STRING_CHAR_ADVANCE (c, seq, i, i_byte);
2457 XSETFASTINT (dummy, c);
2458 dummy = call1 (fn, dummy);
2459 if (vals)
2460 vals[i_before] = dummy;
2463 else /* Must be a list, since Flength did not get an error */
2465 tail = seq;
2466 for (i = 0; i < leni; i++)
2468 if (! CONSP (tail))
2469 return i;
2470 dummy = call1 (fn, XCAR (tail));
2471 if (vals)
2472 vals[i] = dummy;
2473 tail = XCDR (tail);
2477 return leni;
2480 DEFUN ("mapconcat", Fmapconcat, Smapconcat, 3, 3, 0,
2481 doc: /* Apply FUNCTION to each element of SEQUENCE, and concat the results as strings.
2482 In between each pair of results, stick in SEPARATOR. Thus, " " as
2483 SEPARATOR results in spaces between the values returned by FUNCTION.
2484 SEQUENCE may be a list, a vector, a bool-vector, or a string. */)
2485 (Lisp_Object function, Lisp_Object sequence, Lisp_Object separator)
2487 USE_SAFE_ALLOCA;
2488 EMACS_INT leni = XFASTINT (Flength (sequence));
2489 if (CHAR_TABLE_P (sequence))
2490 wrong_type_argument (Qlistp, sequence);
2491 EMACS_INT args_alloc = 2 * leni - 1;
2492 if (args_alloc < 0)
2493 return empty_unibyte_string;
2494 Lisp_Object *args;
2495 SAFE_ALLOCA_LISP (args, args_alloc);
2496 ptrdiff_t nmapped = mapcar1 (leni, args, function, sequence);
2497 ptrdiff_t nargs = 2 * nmapped - 1;
2499 for (ptrdiff_t i = nmapped - 1; i > 0; i--)
2500 args[i + i] = args[i];
2502 for (ptrdiff_t i = 1; i < nargs; i += 2)
2503 args[i] = separator;
2505 Lisp_Object ret = Fconcat (nargs, args);
2506 SAFE_FREE ();
2507 return ret;
2510 DEFUN ("mapcar", Fmapcar, Smapcar, 2, 2, 0,
2511 doc: /* Apply FUNCTION to each element of SEQUENCE, and make a list of the results.
2512 The result is a list just as long as SEQUENCE.
2513 SEQUENCE may be a list, a vector, a bool-vector, or a string. */)
2514 (Lisp_Object function, Lisp_Object sequence)
2516 USE_SAFE_ALLOCA;
2517 EMACS_INT leni = XFASTINT (Flength (sequence));
2518 if (CHAR_TABLE_P (sequence))
2519 wrong_type_argument (Qlistp, sequence);
2520 Lisp_Object *args;
2521 SAFE_ALLOCA_LISP (args, leni);
2522 ptrdiff_t nmapped = mapcar1 (leni, args, function, sequence);
2523 Lisp_Object ret = Flist (nmapped, args);
2524 SAFE_FREE ();
2525 return ret;
2528 DEFUN ("mapc", Fmapc, Smapc, 2, 2, 0,
2529 doc: /* Apply FUNCTION to each element of SEQUENCE for side effects only.
2530 Unlike `mapcar', don't accumulate the results. Return SEQUENCE.
2531 SEQUENCE may be a list, a vector, a bool-vector, or a string. */)
2532 (Lisp_Object function, Lisp_Object sequence)
2534 register EMACS_INT leni;
2536 leni = XFASTINT (Flength (sequence));
2537 if (CHAR_TABLE_P (sequence))
2538 wrong_type_argument (Qlistp, sequence);
2539 mapcar1 (leni, 0, function, sequence);
2541 return sequence;
2544 DEFUN ("mapcan", Fmapcan, Smapcan, 2, 2, 0,
2545 doc: /* Apply FUNCTION to each element of SEQUENCE, and concatenate
2546 the results by altering them (using `nconc').
2547 SEQUENCE may be a list, a vector, a bool-vector, or a string. */)
2548 (Lisp_Object function, Lisp_Object sequence)
2550 USE_SAFE_ALLOCA;
2551 EMACS_INT leni = XFASTINT (Flength (sequence));
2552 if (CHAR_TABLE_P (sequence))
2553 wrong_type_argument (Qlistp, sequence);
2554 Lisp_Object *args;
2555 SAFE_ALLOCA_LISP (args, leni);
2556 ptrdiff_t nmapped = mapcar1 (leni, args, function, sequence);
2557 Lisp_Object ret = Fnconc (nmapped, args);
2558 SAFE_FREE ();
2559 return ret;
2562 /* This is how C code calls `yes-or-no-p' and allows the user
2563 to redefine it. */
2565 Lisp_Object
2566 do_yes_or_no_p (Lisp_Object prompt)
2568 return call1 (intern ("yes-or-no-p"), prompt);
2571 DEFUN ("yes-or-no-p", Fyes_or_no_p, Syes_or_no_p, 1, 1, 0,
2572 doc: /* Ask user a yes-or-no question.
2573 Return t if answer is yes, and nil if the answer is no.
2574 PROMPT is the string to display to ask the question. It should end in
2575 a space; `yes-or-no-p' adds \"(yes or no) \" to it.
2577 The user must confirm the answer with RET, and can edit it until it
2578 has been confirmed.
2580 If dialog boxes are supported, a dialog box will be used
2581 if `last-nonmenu-event' is nil, and `use-dialog-box' is non-nil. */)
2582 (Lisp_Object prompt)
2584 Lisp_Object ans;
2586 CHECK_STRING (prompt);
2588 if ((NILP (last_nonmenu_event) || CONSP (last_nonmenu_event))
2589 && use_dialog_box && ! NILP (last_input_event))
2591 Lisp_Object pane, menu, obj;
2592 redisplay_preserve_echo_area (4);
2593 pane = list2 (Fcons (build_string ("Yes"), Qt),
2594 Fcons (build_string ("No"), Qnil));
2595 menu = Fcons (prompt, pane);
2596 obj = Fx_popup_dialog (Qt, menu, Qnil);
2597 return obj;
2600 AUTO_STRING (yes_or_no, "(yes or no) ");
2601 prompt = CALLN (Fconcat, prompt, yes_or_no);
2603 while (1)
2605 ans = Fdowncase (Fread_from_minibuffer (prompt, Qnil, Qnil, Qnil,
2606 Qyes_or_no_p_history, Qnil,
2607 Qnil));
2608 if (SCHARS (ans) == 3 && !strcmp (SSDATA (ans), "yes"))
2609 return Qt;
2610 if (SCHARS (ans) == 2 && !strcmp (SSDATA (ans), "no"))
2611 return Qnil;
2613 Fding (Qnil);
2614 Fdiscard_input ();
2615 message1 ("Please answer yes or no.");
2616 Fsleep_for (make_number (2), Qnil);
2620 DEFUN ("load-average", Fload_average, Sload_average, 0, 1, 0,
2621 doc: /* Return list of 1 minute, 5 minute and 15 minute load averages.
2623 Each of the three load averages is multiplied by 100, then converted
2624 to integer.
2626 When USE-FLOATS is non-nil, floats will be used instead of integers.
2627 These floats are not multiplied by 100.
2629 If the 5-minute or 15-minute load averages are not available, return a
2630 shortened list, containing only those averages which are available.
2632 An error is thrown if the load average can't be obtained. In some
2633 cases making it work would require Emacs being installed setuid or
2634 setgid so that it can read kernel information, and that usually isn't
2635 advisable. */)
2636 (Lisp_Object use_floats)
2638 double load_ave[3];
2639 int loads = getloadavg (load_ave, 3);
2640 Lisp_Object ret = Qnil;
2642 if (loads < 0)
2643 error ("load-average not implemented for this operating system");
2645 while (loads-- > 0)
2647 Lisp_Object load = (NILP (use_floats)
2648 ? make_number (100.0 * load_ave[loads])
2649 : make_float (load_ave[loads]));
2650 ret = Fcons (load, ret);
2653 return ret;
2656 DEFUN ("featurep", Ffeaturep, Sfeaturep, 1, 2, 0,
2657 doc: /* Return t if FEATURE is present in this Emacs.
2659 Use this to conditionalize execution of lisp code based on the
2660 presence or absence of Emacs or environment extensions.
2661 Use `provide' to declare that a feature is available. This function
2662 looks at the value of the variable `features'. The optional argument
2663 SUBFEATURE can be used to check a specific subfeature of FEATURE. */)
2664 (Lisp_Object feature, Lisp_Object subfeature)
2666 register Lisp_Object tem;
2667 CHECK_SYMBOL (feature);
2668 tem = Fmemq (feature, Vfeatures);
2669 if (!NILP (tem) && !NILP (subfeature))
2670 tem = Fmember (subfeature, Fget (feature, Qsubfeatures));
2671 return (NILP (tem)) ? Qnil : Qt;
2674 DEFUN ("provide", Fprovide, Sprovide, 1, 2, 0,
2675 doc: /* Announce that FEATURE is a feature of the current Emacs.
2676 The optional argument SUBFEATURES should be a list of symbols listing
2677 particular subfeatures supported in this version of FEATURE. */)
2678 (Lisp_Object feature, Lisp_Object subfeatures)
2680 register Lisp_Object tem;
2681 CHECK_SYMBOL (feature);
2682 CHECK_LIST (subfeatures);
2683 if (!NILP (Vautoload_queue))
2684 Vautoload_queue = Fcons (Fcons (make_number (0), Vfeatures),
2685 Vautoload_queue);
2686 tem = Fmemq (feature, Vfeatures);
2687 if (NILP (tem))
2688 Vfeatures = Fcons (feature, Vfeatures);
2689 if (!NILP (subfeatures))
2690 Fput (feature, Qsubfeatures, subfeatures);
2691 LOADHIST_ATTACH (Fcons (Qprovide, feature));
2693 /* Run any load-hooks for this file. */
2694 tem = Fassq (feature, Vafter_load_alist);
2695 if (CONSP (tem))
2696 Fmapc (Qfuncall, XCDR (tem));
2698 return feature;
2701 /* `require' and its subroutines. */
2703 /* List of features currently being require'd, innermost first. */
2705 static Lisp_Object require_nesting_list;
2707 static void
2708 require_unwind (Lisp_Object old_value)
2710 require_nesting_list = old_value;
2713 DEFUN ("require", Frequire, Srequire, 1, 3, 0,
2714 doc: /* If feature FEATURE is not loaded, load it from FILENAME.
2715 If FEATURE is not a member of the list `features', then the feature is
2716 not loaded; so load the file FILENAME.
2718 If FILENAME is omitted, the printname of FEATURE is used as the file
2719 name, and `load' will try to load this name appended with the suffix
2720 `.elc', `.el', or the system-dependent suffix for dynamic module
2721 files, in that order. The name without appended suffix will not be
2722 used. See `get-load-suffixes' for the complete list of suffixes.
2724 The directories in `load-path' are searched when trying to find the
2725 file name.
2727 If the optional third argument NOERROR is non-nil, then return nil if
2728 the file is not found instead of signaling an error. Normally the
2729 return value is FEATURE.
2731 The normal messages at start and end of loading FILENAME are
2732 suppressed. */)
2733 (Lisp_Object feature, Lisp_Object filename, Lisp_Object noerror)
2735 Lisp_Object tem;
2736 bool from_file = load_in_progress;
2738 CHECK_SYMBOL (feature);
2740 /* Record the presence of `require' in this file
2741 even if the feature specified is already loaded.
2742 But not more than once in any file,
2743 and not when we aren't loading or reading from a file. */
2744 if (!from_file)
2745 for (tem = Vcurrent_load_list; CONSP (tem); tem = XCDR (tem))
2746 if (NILP (XCDR (tem)) && STRINGP (XCAR (tem)))
2747 from_file = 1;
2749 if (from_file)
2751 tem = Fcons (Qrequire, feature);
2752 if (NILP (Fmember (tem, Vcurrent_load_list)))
2753 LOADHIST_ATTACH (tem);
2755 tem = Fmemq (feature, Vfeatures);
2757 if (NILP (tem))
2759 ptrdiff_t count = SPECPDL_INDEX ();
2760 int nesting = 0;
2762 /* This is to make sure that loadup.el gives a clear picture
2763 of what files are preloaded and when. */
2764 if (! NILP (Vpurify_flag))
2765 error ("(require %s) while preparing to dump",
2766 SDATA (SYMBOL_NAME (feature)));
2768 /* A certain amount of recursive `require' is legitimate,
2769 but if we require the same feature recursively 3 times,
2770 signal an error. */
2771 tem = require_nesting_list;
2772 while (! NILP (tem))
2774 if (! NILP (Fequal (feature, XCAR (tem))))
2775 nesting++;
2776 tem = XCDR (tem);
2778 if (nesting > 3)
2779 error ("Recursive `require' for feature `%s'",
2780 SDATA (SYMBOL_NAME (feature)));
2782 /* Update the list for any nested `require's that occur. */
2783 record_unwind_protect (require_unwind, require_nesting_list);
2784 require_nesting_list = Fcons (feature, require_nesting_list);
2786 /* Value saved here is to be restored into Vautoload_queue */
2787 record_unwind_protect (un_autoload, Vautoload_queue);
2788 Vautoload_queue = Qt;
2790 /* Load the file. */
2791 tem = Fload (NILP (filename) ? Fsymbol_name (feature) : filename,
2792 noerror, Qt, Qnil, (NILP (filename) ? Qt : Qnil));
2794 /* If load failed entirely, return nil. */
2795 if (NILP (tem))
2796 return unbind_to (count, Qnil);
2798 tem = Fmemq (feature, Vfeatures);
2799 if (NILP (tem))
2801 unsigned char *tem2 = SDATA (SYMBOL_NAME (feature));
2802 Lisp_Object tem3 = Fcar (Fcar (Vload_history));
2804 if (NILP (tem3))
2805 error ("Required feature `%s' was not provided", tem2);
2806 else
2807 /* Cf autoload-do-load. */
2808 error ("Loading file %s failed to provide feature `%s'",
2809 SDATA (tem3), tem2);
2812 /* Once loading finishes, don't undo it. */
2813 Vautoload_queue = Qt;
2814 feature = unbind_to (count, feature);
2817 return feature;
2820 /* Primitives for work of the "widget" library.
2821 In an ideal world, this section would not have been necessary.
2822 However, lisp function calls being as slow as they are, it turns
2823 out that some functions in the widget library (wid-edit.el) are the
2824 bottleneck of Widget operation. Here is their translation to C,
2825 for the sole reason of efficiency. */
2827 DEFUN ("plist-member", Fplist_member, Splist_member, 2, 2, 0,
2828 doc: /* Return non-nil if PLIST has the property PROP.
2829 PLIST is a property list, which is a list of the form
2830 \(PROP1 VALUE1 PROP2 VALUE2 ...). PROP is a symbol.
2831 Unlike `plist-get', this allows you to distinguish between a missing
2832 property and a property with the value nil.
2833 The value is actually the tail of PLIST whose car is PROP. */)
2834 (Lisp_Object plist, Lisp_Object prop)
2836 Lisp_Object tail = plist;
2837 FOR_EACH_TAIL (tail)
2839 if (EQ (XCAR (tail), prop))
2840 return tail;
2841 tail = XCDR (tail);
2842 if (! CONSP (tail))
2843 break;
2844 if (EQ (tail, li.tortoise))
2845 circular_list (tail);
2847 CHECK_LIST_END (tail, plist);
2848 return Qnil;
2851 DEFUN ("widget-put", Fwidget_put, Swidget_put, 3, 3, 0,
2852 doc: /* In WIDGET, set PROPERTY to VALUE.
2853 The value can later be retrieved with `widget-get'. */)
2854 (Lisp_Object widget, Lisp_Object property, Lisp_Object value)
2856 CHECK_CONS (widget);
2857 XSETCDR (widget, Fplist_put (XCDR (widget), property, value));
2858 return value;
2861 DEFUN ("widget-get", Fwidget_get, Swidget_get, 2, 2, 0,
2862 doc: /* In WIDGET, get the value of PROPERTY.
2863 The value could either be specified when the widget was created, or
2864 later with `widget-put'. */)
2865 (Lisp_Object widget, Lisp_Object property)
2867 Lisp_Object tmp;
2869 while (1)
2871 if (NILP (widget))
2872 return Qnil;
2873 CHECK_CONS (widget);
2874 tmp = Fplist_member (XCDR (widget), property);
2875 if (CONSP (tmp))
2877 tmp = XCDR (tmp);
2878 return CAR (tmp);
2880 tmp = XCAR (widget);
2881 if (NILP (tmp))
2882 return Qnil;
2883 widget = Fget (tmp, Qwidget_type);
2887 DEFUN ("widget-apply", Fwidget_apply, Swidget_apply, 2, MANY, 0,
2888 doc: /* Apply the value of WIDGET's PROPERTY to the widget itself.
2889 ARGS are passed as extra arguments to the function.
2890 usage: (widget-apply WIDGET PROPERTY &rest ARGS) */)
2891 (ptrdiff_t nargs, Lisp_Object *args)
2893 Lisp_Object widget = args[0];
2894 Lisp_Object property = args[1];
2895 Lisp_Object propval = Fwidget_get (widget, property);
2896 Lisp_Object trailing_args = Flist (nargs - 2, args + 2);
2897 Lisp_Object result = CALLN (Fapply, propval, widget, trailing_args);
2898 return result;
2901 #ifdef HAVE_LANGINFO_CODESET
2902 #include <langinfo.h>
2903 #endif
2905 DEFUN ("locale-info", Flocale_info, Slocale_info, 1, 1, 0,
2906 doc: /* Access locale data ITEM for the current C locale, if available.
2907 ITEM should be one of the following:
2909 `codeset', returning the character set as a string (locale item CODESET);
2911 `days', returning a 7-element vector of day names (locale items DAY_n);
2913 `months', returning a 12-element vector of month names (locale items MON_n);
2915 `paper', returning a list (WIDTH HEIGHT) for the default paper size,
2916 both measured in millimeters (locale items PAPER_WIDTH, PAPER_HEIGHT).
2918 If the system can't provide such information through a call to
2919 `nl_langinfo', or if ITEM isn't from the list above, return nil.
2921 See also Info node `(libc)Locales'.
2923 The data read from the system are decoded using `locale-coding-system'. */)
2924 (Lisp_Object item)
2926 char *str = NULL;
2927 #ifdef HAVE_LANGINFO_CODESET
2928 if (EQ (item, Qcodeset))
2930 str = nl_langinfo (CODESET);
2931 return build_string (str);
2933 #ifdef DAY_1
2934 else if (EQ (item, Qdays)) /* e.g. for calendar-day-name-array */
2936 Lisp_Object v = Fmake_vector (make_number (7), Qnil);
2937 const int days[7] = {DAY_1, DAY_2, DAY_3, DAY_4, DAY_5, DAY_6, DAY_7};
2938 int i;
2939 synchronize_system_time_locale ();
2940 for (i = 0; i < 7; i++)
2942 str = nl_langinfo (days[i]);
2943 AUTO_STRING (val, str);
2944 /* Fixme: Is this coding system necessarily right, even if
2945 it is consistent with CODESET? If not, what to do? */
2946 ASET (v, i, code_convert_string_norecord (val, Vlocale_coding_system,
2947 0));
2949 return v;
2951 #endif /* DAY_1 */
2952 #ifdef MON_1
2953 else if (EQ (item, Qmonths)) /* e.g. for calendar-month-name-array */
2955 Lisp_Object v = Fmake_vector (make_number (12), Qnil);
2956 const int months[12] = {MON_1, MON_2, MON_3, MON_4, MON_5, MON_6, MON_7,
2957 MON_8, MON_9, MON_10, MON_11, MON_12};
2958 int i;
2959 synchronize_system_time_locale ();
2960 for (i = 0; i < 12; i++)
2962 str = nl_langinfo (months[i]);
2963 AUTO_STRING (val, str);
2964 ASET (v, i, code_convert_string_norecord (val, Vlocale_coding_system,
2965 0));
2967 return v;
2969 #endif /* MON_1 */
2970 /* LC_PAPER stuff isn't defined as accessible in glibc as of 2.3.1,
2971 but is in the locale files. This could be used by ps-print. */
2972 #ifdef PAPER_WIDTH
2973 else if (EQ (item, Qpaper))
2974 return list2i (nl_langinfo (PAPER_WIDTH), nl_langinfo (PAPER_HEIGHT));
2975 #endif /* PAPER_WIDTH */
2976 #endif /* HAVE_LANGINFO_CODESET*/
2977 return Qnil;
2980 /* base64 encode/decode functions (RFC 2045).
2981 Based on code from GNU recode. */
2983 #define MIME_LINE_LENGTH 76
2985 #define IS_ASCII(Character) \
2986 ((Character) < 128)
2987 #define IS_BASE64(Character) \
2988 (IS_ASCII (Character) && base64_char_to_value[Character] >= 0)
2989 #define IS_BASE64_IGNORABLE(Character) \
2990 ((Character) == ' ' || (Character) == '\t' || (Character) == '\n' \
2991 || (Character) == '\f' || (Character) == '\r')
2993 /* Used by base64_decode_1 to retrieve a non-base64-ignorable
2994 character or return retval if there are no characters left to
2995 process. */
2996 #define READ_QUADRUPLET_BYTE(retval) \
2997 do \
2999 if (i == length) \
3001 if (nchars_return) \
3002 *nchars_return = nchars; \
3003 return (retval); \
3005 c = from[i++]; \
3007 while (IS_BASE64_IGNORABLE (c))
3009 /* Table of characters coding the 64 values. */
3010 static const char base64_value_to_char[64] =
3012 'A', 'B', 'C', 'D', 'E', 'F', 'G', 'H', 'I', 'J', /* 0- 9 */
3013 'K', 'L', 'M', 'N', 'O', 'P', 'Q', 'R', 'S', 'T', /* 10-19 */
3014 'U', 'V', 'W', 'X', 'Y', 'Z', 'a', 'b', 'c', 'd', /* 20-29 */
3015 'e', 'f', 'g', 'h', 'i', 'j', 'k', 'l', 'm', 'n', /* 30-39 */
3016 'o', 'p', 'q', 'r', 's', 't', 'u', 'v', 'w', 'x', /* 40-49 */
3017 'y', 'z', '0', '1', '2', '3', '4', '5', '6', '7', /* 50-59 */
3018 '8', '9', '+', '/' /* 60-63 */
3021 /* Table of base64 values for first 128 characters. */
3022 static const short base64_char_to_value[128] =
3024 -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, /* 0- 9 */
3025 -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, /* 10- 19 */
3026 -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, /* 20- 29 */
3027 -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, /* 30- 39 */
3028 -1, -1, -1, 62, -1, -1, -1, 63, 52, 53, /* 40- 49 */
3029 54, 55, 56, 57, 58, 59, 60, 61, -1, -1, /* 50- 59 */
3030 -1, -1, -1, -1, -1, 0, 1, 2, 3, 4, /* 60- 69 */
3031 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, /* 70- 79 */
3032 15, 16, 17, 18, 19, 20, 21, 22, 23, 24, /* 80- 89 */
3033 25, -1, -1, -1, -1, -1, -1, 26, 27, 28, /* 90- 99 */
3034 29, 30, 31, 32, 33, 34, 35, 36, 37, 38, /* 100-109 */
3035 39, 40, 41, 42, 43, 44, 45, 46, 47, 48, /* 110-119 */
3036 49, 50, 51, -1, -1, -1, -1, -1 /* 120-127 */
3039 /* The following diagram shows the logical steps by which three octets
3040 get transformed into four base64 characters.
3042 .--------. .--------. .--------.
3043 |aaaaaabb| |bbbbcccc| |ccdddddd|
3044 `--------' `--------' `--------'
3045 6 2 4 4 2 6
3046 .--------+--------+--------+--------.
3047 |00aaaaaa|00bbbbbb|00cccccc|00dddddd|
3048 `--------+--------+--------+--------'
3050 .--------+--------+--------+--------.
3051 |AAAAAAAA|BBBBBBBB|CCCCCCCC|DDDDDDDD|
3052 `--------+--------+--------+--------'
3054 The octets are divided into 6 bit chunks, which are then encoded into
3055 base64 characters. */
3058 static ptrdiff_t base64_encode_1 (const char *, char *, ptrdiff_t, bool, bool);
3059 static ptrdiff_t base64_decode_1 (const char *, char *, ptrdiff_t, bool,
3060 ptrdiff_t *);
3062 DEFUN ("base64-encode-region", Fbase64_encode_region, Sbase64_encode_region,
3063 2, 3, "r",
3064 doc: /* Base64-encode the region between BEG and END.
3065 Return the length of the encoded text.
3066 Optional third argument NO-LINE-BREAK means do not break long lines
3067 into shorter lines. */)
3068 (Lisp_Object beg, Lisp_Object end, Lisp_Object no_line_break)
3070 char *encoded;
3071 ptrdiff_t allength, length;
3072 ptrdiff_t ibeg, iend, encoded_length;
3073 ptrdiff_t old_pos = PT;
3074 USE_SAFE_ALLOCA;
3076 validate_region (&beg, &end);
3078 ibeg = CHAR_TO_BYTE (XFASTINT (beg));
3079 iend = CHAR_TO_BYTE (XFASTINT (end));
3080 move_gap_both (XFASTINT (beg), ibeg);
3082 /* We need to allocate enough room for encoding the text.
3083 We need 33 1/3% more space, plus a newline every 76
3084 characters, and then we round up. */
3085 length = iend - ibeg;
3086 allength = length + length/3 + 1;
3087 allength += allength / MIME_LINE_LENGTH + 1 + 6;
3089 encoded = SAFE_ALLOCA (allength);
3090 encoded_length = base64_encode_1 ((char *) BYTE_POS_ADDR (ibeg),
3091 encoded, length, NILP (no_line_break),
3092 !NILP (BVAR (current_buffer, enable_multibyte_characters)));
3093 if (encoded_length > allength)
3094 emacs_abort ();
3096 if (encoded_length < 0)
3098 /* The encoding wasn't possible. */
3099 SAFE_FREE ();
3100 error ("Multibyte character in data for base64 encoding");
3103 /* Now we have encoded the region, so we insert the new contents
3104 and delete the old. (Insert first in order to preserve markers.) */
3105 SET_PT_BOTH (XFASTINT (beg), ibeg);
3106 insert (encoded, encoded_length);
3107 SAFE_FREE ();
3108 del_range_byte (ibeg + encoded_length, iend + encoded_length);
3110 /* If point was outside of the region, restore it exactly; else just
3111 move to the beginning of the region. */
3112 if (old_pos >= XFASTINT (end))
3113 old_pos += encoded_length - (XFASTINT (end) - XFASTINT (beg));
3114 else if (old_pos > XFASTINT (beg))
3115 old_pos = XFASTINT (beg);
3116 SET_PT (old_pos);
3118 /* We return the length of the encoded text. */
3119 return make_number (encoded_length);
3122 DEFUN ("base64-encode-string", Fbase64_encode_string, Sbase64_encode_string,
3123 1, 2, 0,
3124 doc: /* Base64-encode STRING and return the result.
3125 Optional second argument NO-LINE-BREAK means do not break long lines
3126 into shorter lines. */)
3127 (Lisp_Object string, Lisp_Object no_line_break)
3129 ptrdiff_t allength, length, encoded_length;
3130 char *encoded;
3131 Lisp_Object encoded_string;
3132 USE_SAFE_ALLOCA;
3134 CHECK_STRING (string);
3136 /* We need to allocate enough room for encoding the text.
3137 We need 33 1/3% more space, plus a newline every 76
3138 characters, and then we round up. */
3139 length = SBYTES (string);
3140 allength = length + length/3 + 1;
3141 allength += allength / MIME_LINE_LENGTH + 1 + 6;
3143 /* We need to allocate enough room for decoding the text. */
3144 encoded = SAFE_ALLOCA (allength);
3146 encoded_length = base64_encode_1 (SSDATA (string),
3147 encoded, length, NILP (no_line_break),
3148 STRING_MULTIBYTE (string));
3149 if (encoded_length > allength)
3150 emacs_abort ();
3152 if (encoded_length < 0)
3154 /* The encoding wasn't possible. */
3155 error ("Multibyte character in data for base64 encoding");
3158 encoded_string = make_unibyte_string (encoded, encoded_length);
3159 SAFE_FREE ();
3161 return encoded_string;
3164 static ptrdiff_t
3165 base64_encode_1 (const char *from, char *to, ptrdiff_t length,
3166 bool line_break, bool multibyte)
3168 int counter = 0;
3169 ptrdiff_t i = 0;
3170 char *e = to;
3171 int c;
3172 unsigned int value;
3173 int bytes;
3175 while (i < length)
3177 if (multibyte)
3179 c = STRING_CHAR_AND_LENGTH ((unsigned char *) from + i, bytes);
3180 if (CHAR_BYTE8_P (c))
3181 c = CHAR_TO_BYTE8 (c);
3182 else if (c >= 256)
3183 return -1;
3184 i += bytes;
3186 else
3187 c = from[i++];
3189 /* Wrap line every 76 characters. */
3191 if (line_break)
3193 if (counter < MIME_LINE_LENGTH / 4)
3194 counter++;
3195 else
3197 *e++ = '\n';
3198 counter = 1;
3202 /* Process first byte of a triplet. */
3204 *e++ = base64_value_to_char[0x3f & c >> 2];
3205 value = (0x03 & c) << 4;
3207 /* Process second byte of a triplet. */
3209 if (i == length)
3211 *e++ = base64_value_to_char[value];
3212 *e++ = '=';
3213 *e++ = '=';
3214 break;
3217 if (multibyte)
3219 c = STRING_CHAR_AND_LENGTH ((unsigned char *) from + i, bytes);
3220 if (CHAR_BYTE8_P (c))
3221 c = CHAR_TO_BYTE8 (c);
3222 else if (c >= 256)
3223 return -1;
3224 i += bytes;
3226 else
3227 c = from[i++];
3229 *e++ = base64_value_to_char[value | (0x0f & c >> 4)];
3230 value = (0x0f & c) << 2;
3232 /* Process third byte of a triplet. */
3234 if (i == length)
3236 *e++ = base64_value_to_char[value];
3237 *e++ = '=';
3238 break;
3241 if (multibyte)
3243 c = STRING_CHAR_AND_LENGTH ((unsigned char *) from + i, bytes);
3244 if (CHAR_BYTE8_P (c))
3245 c = CHAR_TO_BYTE8 (c);
3246 else if (c >= 256)
3247 return -1;
3248 i += bytes;
3250 else
3251 c = from[i++];
3253 *e++ = base64_value_to_char[value | (0x03 & c >> 6)];
3254 *e++ = base64_value_to_char[0x3f & c];
3257 return e - to;
3261 DEFUN ("base64-decode-region", Fbase64_decode_region, Sbase64_decode_region,
3262 2, 2, "r",
3263 doc: /* Base64-decode the region between BEG and END.
3264 Return the length of the decoded text.
3265 If the region can't be decoded, signal an error and don't modify the buffer. */)
3266 (Lisp_Object beg, Lisp_Object end)
3268 ptrdiff_t ibeg, iend, length, allength;
3269 char *decoded;
3270 ptrdiff_t old_pos = PT;
3271 ptrdiff_t decoded_length;
3272 ptrdiff_t inserted_chars;
3273 bool multibyte = !NILP (BVAR (current_buffer, enable_multibyte_characters));
3274 USE_SAFE_ALLOCA;
3276 validate_region (&beg, &end);
3278 ibeg = CHAR_TO_BYTE (XFASTINT (beg));
3279 iend = CHAR_TO_BYTE (XFASTINT (end));
3281 length = iend - ibeg;
3283 /* We need to allocate enough room for decoding the text. If we are
3284 working on a multibyte buffer, each decoded code may occupy at
3285 most two bytes. */
3286 allength = multibyte ? length * 2 : length;
3287 decoded = SAFE_ALLOCA (allength);
3289 move_gap_both (XFASTINT (beg), ibeg);
3290 decoded_length = base64_decode_1 ((char *) BYTE_POS_ADDR (ibeg),
3291 decoded, length,
3292 multibyte, &inserted_chars);
3293 if (decoded_length > allength)
3294 emacs_abort ();
3296 if (decoded_length < 0)
3298 /* The decoding wasn't possible. */
3299 error ("Invalid base64 data");
3302 /* Now we have decoded the region, so we insert the new contents
3303 and delete the old. (Insert first in order to preserve markers.) */
3304 TEMP_SET_PT_BOTH (XFASTINT (beg), ibeg);
3305 insert_1_both (decoded, inserted_chars, decoded_length, 0, 1, 0);
3306 SAFE_FREE ();
3308 /* Delete the original text. */
3309 del_range_both (PT, PT_BYTE, XFASTINT (end) + inserted_chars,
3310 iend + decoded_length, 1);
3312 /* If point was outside of the region, restore it exactly; else just
3313 move to the beginning of the region. */
3314 if (old_pos >= XFASTINT (end))
3315 old_pos += inserted_chars - (XFASTINT (end) - XFASTINT (beg));
3316 else if (old_pos > XFASTINT (beg))
3317 old_pos = XFASTINT (beg);
3318 SET_PT (old_pos > ZV ? ZV : old_pos);
3320 return make_number (inserted_chars);
3323 DEFUN ("base64-decode-string", Fbase64_decode_string, Sbase64_decode_string,
3324 1, 1, 0,
3325 doc: /* Base64-decode STRING and return the result. */)
3326 (Lisp_Object string)
3328 char *decoded;
3329 ptrdiff_t length, decoded_length;
3330 Lisp_Object decoded_string;
3331 USE_SAFE_ALLOCA;
3333 CHECK_STRING (string);
3335 length = SBYTES (string);
3336 /* We need to allocate enough room for decoding the text. */
3337 decoded = SAFE_ALLOCA (length);
3339 /* The decoded result should be unibyte. */
3340 decoded_length = base64_decode_1 (SSDATA (string), decoded, length,
3341 0, NULL);
3342 if (decoded_length > length)
3343 emacs_abort ();
3344 else if (decoded_length >= 0)
3345 decoded_string = make_unibyte_string (decoded, decoded_length);
3346 else
3347 decoded_string = Qnil;
3349 SAFE_FREE ();
3350 if (!STRINGP (decoded_string))
3351 error ("Invalid base64 data");
3353 return decoded_string;
3356 /* Base64-decode the data at FROM of LENGTH bytes into TO. If
3357 MULTIBYTE, the decoded result should be in multibyte
3358 form. If NCHARS_RETURN is not NULL, store the number of produced
3359 characters in *NCHARS_RETURN. */
3361 static ptrdiff_t
3362 base64_decode_1 (const char *from, char *to, ptrdiff_t length,
3363 bool multibyte, ptrdiff_t *nchars_return)
3365 ptrdiff_t i = 0; /* Used inside READ_QUADRUPLET_BYTE */
3366 char *e = to;
3367 unsigned char c;
3368 unsigned long value;
3369 ptrdiff_t nchars = 0;
3371 while (1)
3373 /* Process first byte of a quadruplet. */
3375 READ_QUADRUPLET_BYTE (e-to);
3377 if (!IS_BASE64 (c))
3378 return -1;
3379 value = base64_char_to_value[c] << 18;
3381 /* Process second byte of a quadruplet. */
3383 READ_QUADRUPLET_BYTE (-1);
3385 if (!IS_BASE64 (c))
3386 return -1;
3387 value |= base64_char_to_value[c] << 12;
3389 c = (unsigned char) (value >> 16);
3390 if (multibyte && c >= 128)
3391 e += BYTE8_STRING (c, e);
3392 else
3393 *e++ = c;
3394 nchars++;
3396 /* Process third byte of a quadruplet. */
3398 READ_QUADRUPLET_BYTE (-1);
3400 if (c == '=')
3402 READ_QUADRUPLET_BYTE (-1);
3404 if (c != '=')
3405 return -1;
3406 continue;
3409 if (!IS_BASE64 (c))
3410 return -1;
3411 value |= base64_char_to_value[c] << 6;
3413 c = (unsigned char) (0xff & value >> 8);
3414 if (multibyte && c >= 128)
3415 e += BYTE8_STRING (c, e);
3416 else
3417 *e++ = c;
3418 nchars++;
3420 /* Process fourth byte of a quadruplet. */
3422 READ_QUADRUPLET_BYTE (-1);
3424 if (c == '=')
3425 continue;
3427 if (!IS_BASE64 (c))
3428 return -1;
3429 value |= base64_char_to_value[c];
3431 c = (unsigned char) (0xff & value);
3432 if (multibyte && c >= 128)
3433 e += BYTE8_STRING (c, e);
3434 else
3435 *e++ = c;
3436 nchars++;
3442 /***********************************************************************
3443 ***** *****
3444 ***** Hash Tables *****
3445 ***** *****
3446 ***********************************************************************/
3448 /* Implemented by gerd@gnu.org. This hash table implementation was
3449 inspired by CMUCL hash tables. */
3451 /* Ideas:
3453 1. For small tables, association lists are probably faster than
3454 hash tables because they have lower overhead.
3456 For uses of hash tables where the O(1) behavior of table
3457 operations is not a requirement, it might therefore be a good idea
3458 not to hash. Instead, we could just do a linear search in the
3459 key_and_value vector of the hash table. This could be done
3460 if a `:linear-search t' argument is given to make-hash-table. */
3463 /* The list of all weak hash tables. Don't staticpro this one. */
3465 static struct Lisp_Hash_Table *weak_hash_tables;
3468 /***********************************************************************
3469 Utilities
3470 ***********************************************************************/
3472 static void
3473 CHECK_HASH_TABLE (Lisp_Object x)
3475 CHECK_TYPE (HASH_TABLE_P (x), Qhash_table_p, x);
3478 static void
3479 set_hash_key_and_value (struct Lisp_Hash_Table *h, Lisp_Object key_and_value)
3481 h->key_and_value = key_and_value;
3483 static void
3484 set_hash_next (struct Lisp_Hash_Table *h, Lisp_Object next)
3486 h->next = next;
3488 static void
3489 set_hash_next_slot (struct Lisp_Hash_Table *h, ptrdiff_t idx, ptrdiff_t val)
3491 gc_aset (h->next, idx, make_number (val));
3493 static void
3494 set_hash_hash (struct Lisp_Hash_Table *h, Lisp_Object hash)
3496 h->hash = hash;
3498 static void
3499 set_hash_hash_slot (struct Lisp_Hash_Table *h, ptrdiff_t idx, Lisp_Object val)
3501 gc_aset (h->hash, idx, val);
3503 static void
3504 set_hash_index (struct Lisp_Hash_Table *h, Lisp_Object index)
3506 h->index = index;
3508 static void
3509 set_hash_index_slot (struct Lisp_Hash_Table *h, ptrdiff_t idx, ptrdiff_t val)
3511 gc_aset (h->index, idx, make_number (val));
3514 /* If OBJ is a Lisp hash table, return a pointer to its struct
3515 Lisp_Hash_Table. Otherwise, signal an error. */
3517 static struct Lisp_Hash_Table *
3518 check_hash_table (Lisp_Object obj)
3520 CHECK_HASH_TABLE (obj);
3521 return XHASH_TABLE (obj);
3525 /* Value is the next integer I >= N, N >= 0 which is "almost" a prime
3526 number. A number is "almost" a prime number if it is not divisible
3527 by any integer in the range 2 .. (NEXT_ALMOST_PRIME_LIMIT - 1). */
3529 EMACS_INT
3530 next_almost_prime (EMACS_INT n)
3532 verify (NEXT_ALMOST_PRIME_LIMIT == 11);
3533 for (n |= 1; ; n += 2)
3534 if (n % 3 != 0 && n % 5 != 0 && n % 7 != 0)
3535 return n;
3539 /* Find KEY in ARGS which has size NARGS. Don't consider indices for
3540 which USED[I] is non-zero. If found at index I in ARGS, set
3541 USED[I] and USED[I + 1] to 1, and return I + 1. Otherwise return
3542 0. This function is used to extract a keyword/argument pair from
3543 a DEFUN parameter list. */
3545 static ptrdiff_t
3546 get_key_arg (Lisp_Object key, ptrdiff_t nargs, Lisp_Object *args, char *used)
3548 ptrdiff_t i;
3550 for (i = 1; i < nargs; i++)
3551 if (!used[i - 1] && EQ (args[i - 1], key))
3553 used[i - 1] = 1;
3554 used[i] = 1;
3555 return i;
3558 return 0;
3562 /* Return a Lisp vector which has the same contents as VEC but has
3563 at least INCR_MIN more entries, where INCR_MIN is positive.
3564 If NITEMS_MAX is not -1, do not grow the vector to be any larger
3565 than NITEMS_MAX. New entries in the resulting vector are
3566 uninitialized. */
3568 static Lisp_Object
3569 larger_vecalloc (Lisp_Object vec, ptrdiff_t incr_min, ptrdiff_t nitems_max)
3571 struct Lisp_Vector *v;
3572 ptrdiff_t incr, incr_max, old_size, new_size;
3573 ptrdiff_t C_language_max = min (PTRDIFF_MAX, SIZE_MAX) / sizeof *v->contents;
3574 ptrdiff_t n_max = (0 <= nitems_max && nitems_max < C_language_max
3575 ? nitems_max : C_language_max);
3576 eassert (VECTORP (vec));
3577 eassert (0 < incr_min && -1 <= nitems_max);
3578 old_size = ASIZE (vec);
3579 incr_max = n_max - old_size;
3580 incr = max (incr_min, min (old_size >> 1, incr_max));
3581 if (incr_max < incr)
3582 memory_full (SIZE_MAX);
3583 new_size = old_size + incr;
3584 v = allocate_vector (new_size);
3585 memcpy (v->contents, XVECTOR (vec)->contents, old_size * sizeof *v->contents);
3586 XSETVECTOR (vec, v);
3587 return vec;
3590 /* Likewise, except set new entries in the resulting vector to nil. */
3592 Lisp_Object
3593 larger_vector (Lisp_Object vec, ptrdiff_t incr_min, ptrdiff_t nitems_max)
3595 ptrdiff_t old_size = ASIZE (vec);
3596 Lisp_Object v = larger_vecalloc (vec, incr_min, nitems_max);
3597 ptrdiff_t new_size = ASIZE (v);
3598 memclear (XVECTOR (v)->contents + old_size,
3599 (new_size - old_size) * word_size);
3600 return v;
3604 /***********************************************************************
3605 Low-level Functions
3606 ***********************************************************************/
3608 /* Return the index of the next entry in H following the one at IDX,
3609 or -1 if none. */
3611 static ptrdiff_t
3612 HASH_NEXT (struct Lisp_Hash_Table *h, ptrdiff_t idx)
3614 return XINT (AREF (h->next, idx));
3617 /* Return the index of the element in hash table H that is the start
3618 of the collision list at index IDX, or -1 if the list is empty. */
3620 static ptrdiff_t
3621 HASH_INDEX (struct Lisp_Hash_Table *h, ptrdiff_t idx)
3623 return XINT (AREF (h->index, idx));
3626 /* Compare KEY1 which has hash code HASH1 and KEY2 with hash code
3627 HASH2 in hash table H using `eql'. Value is true if KEY1 and
3628 KEY2 are the same. */
3630 static bool
3631 cmpfn_eql (struct hash_table_test *ht,
3632 Lisp_Object key1,
3633 Lisp_Object key2)
3635 return (FLOATP (key1)
3636 && FLOATP (key2)
3637 && XFLOAT_DATA (key1) == XFLOAT_DATA (key2));
3641 /* Compare KEY1 which has hash code HASH1 and KEY2 with hash code
3642 HASH2 in hash table H using `equal'. Value is true if KEY1 and
3643 KEY2 are the same. */
3645 static bool
3646 cmpfn_equal (struct hash_table_test *ht,
3647 Lisp_Object key1,
3648 Lisp_Object key2)
3650 return !NILP (Fequal (key1, key2));
3654 /* Compare KEY1 which has hash code HASH1, and KEY2 with hash code
3655 HASH2 in hash table H using H->user_cmp_function. Value is true
3656 if KEY1 and KEY2 are the same. */
3658 static bool
3659 cmpfn_user_defined (struct hash_table_test *ht,
3660 Lisp_Object key1,
3661 Lisp_Object key2)
3663 return !NILP (call2 (ht->user_cmp_function, key1, key2));
3666 /* Value is a hash code for KEY for use in hash table H which uses
3667 `eq' to compare keys. The hash code returned is guaranteed to fit
3668 in a Lisp integer. */
3670 static EMACS_UINT
3671 hashfn_eq (struct hash_table_test *ht, Lisp_Object key)
3673 return XHASH (key) ^ XTYPE (key);
3676 /* Value is a hash code for KEY for use in hash table H which uses
3677 `equal' to compare keys. The hash code returned is guaranteed to fit
3678 in a Lisp integer. */
3680 static EMACS_UINT
3681 hashfn_equal (struct hash_table_test *ht, Lisp_Object key)
3683 return sxhash (key, 0);
3686 /* Value is a hash code for KEY for use in hash table H which uses
3687 `eql' to compare keys. The hash code returned is guaranteed to fit
3688 in a Lisp integer. */
3690 static EMACS_UINT
3691 hashfn_eql (struct hash_table_test *ht, Lisp_Object key)
3693 return FLOATP (key) ? hashfn_equal (ht, key) : hashfn_eq (ht, key);
3696 /* Value is a hash code for KEY for use in hash table H which uses as
3697 user-defined function to compare keys. The hash code returned is
3698 guaranteed to fit in a Lisp integer. */
3700 static EMACS_UINT
3701 hashfn_user_defined (struct hash_table_test *ht, Lisp_Object key)
3703 Lisp_Object hash = call1 (ht->user_hash_function, key);
3704 return hashfn_eq (ht, hash);
3707 struct hash_table_test const
3708 hashtest_eq = { LISPSYM_INITIALLY (Qeq), LISPSYM_INITIALLY (Qnil),
3709 LISPSYM_INITIALLY (Qnil), 0, hashfn_eq },
3710 hashtest_eql = { LISPSYM_INITIALLY (Qeql), LISPSYM_INITIALLY (Qnil),
3711 LISPSYM_INITIALLY (Qnil), cmpfn_eql, hashfn_eql },
3712 hashtest_equal = { LISPSYM_INITIALLY (Qequal), LISPSYM_INITIALLY (Qnil),
3713 LISPSYM_INITIALLY (Qnil), cmpfn_equal, hashfn_equal };
3715 /* Allocate basically initialized hash table. */
3717 static struct Lisp_Hash_Table *
3718 allocate_hash_table (void)
3720 return ALLOCATE_PSEUDOVECTOR (struct Lisp_Hash_Table,
3721 count, PVEC_HASH_TABLE);
3724 /* An upper bound on the size of a hash table index. It must fit in
3725 ptrdiff_t and be a valid Emacs fixnum. */
3726 #define INDEX_SIZE_BOUND \
3727 ((ptrdiff_t) min (MOST_POSITIVE_FIXNUM, PTRDIFF_MAX / word_size))
3729 /* Create and initialize a new hash table.
3731 TEST specifies the test the hash table will use to compare keys.
3732 It must be either one of the predefined tests `eq', `eql' or
3733 `equal' or a symbol denoting a user-defined test named TEST with
3734 test and hash functions USER_TEST and USER_HASH.
3736 Give the table initial capacity SIZE, 0 <= SIZE <= MOST_POSITIVE_FIXNUM.
3738 If REHASH_SIZE is equal to a negative integer, this hash table's
3739 new size when it becomes full is computed by subtracting
3740 REHASH_SIZE from its old size. Otherwise it must be positive, and
3741 the table's new size is computed by multiplying its old size by
3742 REHASH_SIZE + 1.
3744 REHASH_THRESHOLD must be a float <= 1.0, and > 0. The table will
3745 be resized when the approximate ratio of table entries to table
3746 size exceeds REHASH_THRESHOLD.
3748 WEAK specifies the weakness of the table. If non-nil, it must be
3749 one of the symbols `key', `value', `key-or-value', or `key-and-value'.
3751 If PURECOPY is non-nil, the table can be copied to pure storage via
3752 `purecopy' when Emacs is being dumped. Such tables can no longer be
3753 changed after purecopy. */
3755 Lisp_Object
3756 make_hash_table (struct hash_table_test test, EMACS_INT size,
3757 float rehash_size, float rehash_threshold,
3758 Lisp_Object weak, bool pure)
3760 struct Lisp_Hash_Table *h;
3761 Lisp_Object table;
3762 EMACS_INT index_size;
3763 ptrdiff_t i;
3764 double index_float;
3766 /* Preconditions. */
3767 eassert (SYMBOLP (test.name));
3768 eassert (0 <= size && size <= MOST_POSITIVE_FIXNUM);
3769 eassert (rehash_size <= -1 || 0 < rehash_size);
3770 eassert (0 < rehash_threshold && rehash_threshold <= 1);
3772 if (size == 0)
3773 size = 1;
3775 double threshold = rehash_threshold;
3776 index_float = size / threshold;
3777 index_size = (index_float < INDEX_SIZE_BOUND + 1
3778 ? next_almost_prime (index_float)
3779 : INDEX_SIZE_BOUND + 1);
3780 if (INDEX_SIZE_BOUND < max (index_size, 2 * size))
3781 error ("Hash table too large");
3783 /* Allocate a table and initialize it. */
3784 h = allocate_hash_table ();
3786 /* Initialize hash table slots. */
3787 h->test = test;
3788 h->weak = weak;
3789 h->rehash_threshold = rehash_threshold;
3790 h->rehash_size = rehash_size;
3791 h->count = 0;
3792 h->key_and_value = Fmake_vector (make_number (2 * size), Qnil);
3793 h->hash = Fmake_vector (make_number (size), Qnil);
3794 h->next = Fmake_vector (make_number (size), make_number (-1));
3795 h->index = Fmake_vector (make_number (index_size), make_number (-1));
3796 h->pure = pure;
3798 /* Set up the free list. */
3799 for (i = 0; i < size - 1; ++i)
3800 set_hash_next_slot (h, i, i + 1);
3801 h->next_free = 0;
3803 XSET_HASH_TABLE (table, h);
3804 eassert (HASH_TABLE_P (table));
3805 eassert (XHASH_TABLE (table) == h);
3807 /* Maybe add this hash table to the list of all weak hash tables. */
3808 if (! NILP (weak))
3810 h->next_weak = weak_hash_tables;
3811 weak_hash_tables = h;
3814 return table;
3818 /* Return a copy of hash table H1. Keys and values are not copied,
3819 only the table itself is. */
3821 static Lisp_Object
3822 copy_hash_table (struct Lisp_Hash_Table *h1)
3824 Lisp_Object table;
3825 struct Lisp_Hash_Table *h2;
3827 h2 = allocate_hash_table ();
3828 *h2 = *h1;
3829 h2->key_and_value = Fcopy_sequence (h1->key_and_value);
3830 h2->hash = Fcopy_sequence (h1->hash);
3831 h2->next = Fcopy_sequence (h1->next);
3832 h2->index = Fcopy_sequence (h1->index);
3833 XSET_HASH_TABLE (table, h2);
3835 /* Maybe add this hash table to the list of all weak hash tables. */
3836 if (!NILP (h2->weak))
3838 h2->next_weak = h1->next_weak;
3839 h1->next_weak = h2;
3842 return table;
3846 /* Resize hash table H if it's too full. If H cannot be resized
3847 because it's already too large, throw an error. */
3849 static void
3850 maybe_resize_hash_table (struct Lisp_Hash_Table *h)
3852 if (h->next_free < 0)
3854 ptrdiff_t old_size = HASH_TABLE_SIZE (h);
3855 EMACS_INT new_size, index_size, nsize;
3856 ptrdiff_t i;
3857 double rehash_size = h->rehash_size;
3858 double index_float;
3860 if (rehash_size < 0)
3861 new_size = old_size - rehash_size;
3862 else
3864 double float_new_size = old_size * (rehash_size + 1);
3865 if (float_new_size < INDEX_SIZE_BOUND + 1)
3866 new_size = float_new_size;
3867 else
3868 new_size = INDEX_SIZE_BOUND + 1;
3870 if (new_size <= old_size)
3871 new_size = old_size + 1;
3872 double threshold = h->rehash_threshold;
3873 index_float = new_size / threshold;
3874 index_size = (index_float < INDEX_SIZE_BOUND + 1
3875 ? next_almost_prime (index_float)
3876 : INDEX_SIZE_BOUND + 1);
3877 nsize = max (index_size, 2 * new_size);
3878 if (INDEX_SIZE_BOUND < nsize)
3879 error ("Hash table too large to resize");
3881 #ifdef ENABLE_CHECKING
3882 if (HASH_TABLE_P (Vpurify_flag)
3883 && XHASH_TABLE (Vpurify_flag) == h)
3884 message ("Growing hash table to: %"pI"d", new_size);
3885 #endif
3887 set_hash_key_and_value (h, larger_vector (h->key_and_value,
3888 2 * (new_size - old_size), -1));
3889 set_hash_hash (h, larger_vector (h->hash, new_size - old_size, -1));
3890 set_hash_index (h, Fmake_vector (make_number (index_size),
3891 make_number (-1)));
3892 set_hash_next (h, larger_vecalloc (h->next, new_size - old_size, -1));
3894 /* Update the free list. Do it so that new entries are added at
3895 the end of the free list. This makes some operations like
3896 maphash faster. */
3897 for (i = old_size; i < new_size - 1; ++i)
3898 set_hash_next_slot (h, i, i + 1);
3899 set_hash_next_slot (h, i, -1);
3901 if (h->next_free < 0)
3902 h->next_free = old_size;
3903 else
3905 ptrdiff_t last = h->next_free;
3906 while (true)
3908 ptrdiff_t next = HASH_NEXT (h, last);
3909 if (next < 0)
3910 break;
3911 last = next;
3913 set_hash_next_slot (h, last, old_size);
3916 /* Rehash. */
3917 for (i = 0; i < old_size; ++i)
3918 if (!NILP (HASH_HASH (h, i)))
3920 EMACS_UINT hash_code = XUINT (HASH_HASH (h, i));
3921 ptrdiff_t start_of_bucket = hash_code % ASIZE (h->index);
3922 set_hash_next_slot (h, i, HASH_INDEX (h, start_of_bucket));
3923 set_hash_index_slot (h, start_of_bucket, i);
3929 /* Lookup KEY in hash table H. If HASH is non-null, return in *HASH
3930 the hash code of KEY. Value is the index of the entry in H
3931 matching KEY, or -1 if not found. */
3933 ptrdiff_t
3934 hash_lookup (struct Lisp_Hash_Table *h, Lisp_Object key, EMACS_UINT *hash)
3936 EMACS_UINT hash_code;
3937 ptrdiff_t start_of_bucket, i;
3939 hash_code = h->test.hashfn (&h->test, key);
3940 eassert ((hash_code & ~INTMASK) == 0);
3941 if (hash)
3942 *hash = hash_code;
3944 start_of_bucket = hash_code % ASIZE (h->index);
3946 for (i = HASH_INDEX (h, start_of_bucket); 0 <= i; i = HASH_NEXT (h, i))
3947 if (EQ (key, HASH_KEY (h, i))
3948 || (h->test.cmpfn
3949 && hash_code == XUINT (HASH_HASH (h, i))
3950 && h->test.cmpfn (&h->test, key, HASH_KEY (h, i))))
3951 break;
3953 return i;
3957 /* Put an entry into hash table H that associates KEY with VALUE.
3958 HASH is a previously computed hash code of KEY.
3959 Value is the index of the entry in H matching KEY. */
3961 ptrdiff_t
3962 hash_put (struct Lisp_Hash_Table *h, Lisp_Object key, Lisp_Object value,
3963 EMACS_UINT hash)
3965 ptrdiff_t start_of_bucket, i;
3967 eassert ((hash & ~INTMASK) == 0);
3969 /* Increment count after resizing because resizing may fail. */
3970 maybe_resize_hash_table (h);
3971 h->count++;
3973 /* Store key/value in the key_and_value vector. */
3974 i = h->next_free;
3975 h->next_free = HASH_NEXT (h, i);
3976 set_hash_key_slot (h, i, key);
3977 set_hash_value_slot (h, i, value);
3979 /* Remember its hash code. */
3980 set_hash_hash_slot (h, i, make_number (hash));
3982 /* Add new entry to its collision chain. */
3983 start_of_bucket = hash % ASIZE (h->index);
3984 set_hash_next_slot (h, i, HASH_INDEX (h, start_of_bucket));
3985 set_hash_index_slot (h, start_of_bucket, i);
3986 return i;
3990 /* Remove the entry matching KEY from hash table H, if there is one. */
3992 void
3993 hash_remove_from_table (struct Lisp_Hash_Table *h, Lisp_Object key)
3995 EMACS_UINT hash_code = h->test.hashfn (&h->test, key);
3996 eassert ((hash_code & ~INTMASK) == 0);
3997 ptrdiff_t start_of_bucket = hash_code % ASIZE (h->index);
3998 ptrdiff_t prev = -1;
4000 for (ptrdiff_t i = HASH_INDEX (h, start_of_bucket);
4001 0 <= i;
4002 i = HASH_NEXT (h, i))
4004 if (EQ (key, HASH_KEY (h, i))
4005 || (h->test.cmpfn
4006 && hash_code == XUINT (HASH_HASH (h, i))
4007 && h->test.cmpfn (&h->test, key, HASH_KEY (h, i))))
4009 /* Take entry out of collision chain. */
4010 if (prev < 0)
4011 set_hash_index_slot (h, start_of_bucket, HASH_NEXT (h, i));
4012 else
4013 set_hash_next_slot (h, prev, HASH_NEXT (h, i));
4015 /* Clear slots in key_and_value and add the slots to
4016 the free list. */
4017 set_hash_key_slot (h, i, Qnil);
4018 set_hash_value_slot (h, i, Qnil);
4019 set_hash_hash_slot (h, i, Qnil);
4020 set_hash_next_slot (h, i, h->next_free);
4021 h->next_free = i;
4022 h->count--;
4023 eassert (h->count >= 0);
4024 break;
4027 prev = i;
4032 /* Clear hash table H. */
4034 static void
4035 hash_clear (struct Lisp_Hash_Table *h)
4037 if (h->count > 0)
4039 ptrdiff_t i, size = HASH_TABLE_SIZE (h);
4041 for (i = 0; i < size; ++i)
4043 set_hash_next_slot (h, i, i < size - 1 ? i + 1 : -1);
4044 set_hash_key_slot (h, i, Qnil);
4045 set_hash_value_slot (h, i, Qnil);
4046 set_hash_hash_slot (h, i, Qnil);
4049 for (i = 0; i < ASIZE (h->index); ++i)
4050 ASET (h->index, i, make_number (-1));
4052 h->next_free = 0;
4053 h->count = 0;
4059 /************************************************************************
4060 Weak Hash Tables
4061 ************************************************************************/
4063 /* Sweep weak hash table H. REMOVE_ENTRIES_P means remove
4064 entries from the table that don't survive the current GC.
4065 !REMOVE_ENTRIES_P means mark entries that are in use. Value is
4066 true if anything was marked. */
4068 static bool
4069 sweep_weak_table (struct Lisp_Hash_Table *h, bool remove_entries_p)
4071 ptrdiff_t n = gc_asize (h->index);
4072 bool marked = false;
4074 for (ptrdiff_t bucket = 0; bucket < n; ++bucket)
4076 /* Follow collision chain, removing entries that
4077 don't survive this garbage collection. */
4078 ptrdiff_t prev = -1;
4079 ptrdiff_t next;
4080 for (ptrdiff_t i = HASH_INDEX (h, bucket); 0 <= i; i = next)
4082 bool key_known_to_survive_p = survives_gc_p (HASH_KEY (h, i));
4083 bool value_known_to_survive_p = survives_gc_p (HASH_VALUE (h, i));
4084 bool remove_p;
4086 if (EQ (h->weak, Qkey))
4087 remove_p = !key_known_to_survive_p;
4088 else if (EQ (h->weak, Qvalue))
4089 remove_p = !value_known_to_survive_p;
4090 else if (EQ (h->weak, Qkey_or_value))
4091 remove_p = !(key_known_to_survive_p || value_known_to_survive_p);
4092 else if (EQ (h->weak, Qkey_and_value))
4093 remove_p = !(key_known_to_survive_p && value_known_to_survive_p);
4094 else
4095 emacs_abort ();
4097 next = HASH_NEXT (h, i);
4099 if (remove_entries_p)
4101 if (remove_p)
4103 /* Take out of collision chain. */
4104 if (prev < 0)
4105 set_hash_index_slot (h, bucket, next);
4106 else
4107 set_hash_next_slot (h, prev, next);
4109 /* Add to free list. */
4110 set_hash_next_slot (h, i, h->next_free);
4111 h->next_free = i;
4113 /* Clear key, value, and hash. */
4114 set_hash_key_slot (h, i, Qnil);
4115 set_hash_value_slot (h, i, Qnil);
4116 set_hash_hash_slot (h, i, Qnil);
4118 h->count--;
4120 else
4122 prev = i;
4125 else
4127 if (!remove_p)
4129 /* Make sure key and value survive. */
4130 if (!key_known_to_survive_p)
4132 mark_object (HASH_KEY (h, i));
4133 marked = 1;
4136 if (!value_known_to_survive_p)
4138 mark_object (HASH_VALUE (h, i));
4139 marked = 1;
4146 return marked;
4149 /* Remove elements from weak hash tables that don't survive the
4150 current garbage collection. Remove weak tables that don't survive
4151 from Vweak_hash_tables. Called from gc_sweep. */
4153 NO_INLINE /* For better stack traces */
4154 void
4155 sweep_weak_hash_tables (void)
4157 struct Lisp_Hash_Table *h, *used, *next;
4158 bool marked;
4160 /* Mark all keys and values that are in use. Keep on marking until
4161 there is no more change. This is necessary for cases like
4162 value-weak table A containing an entry X -> Y, where Y is used in a
4163 key-weak table B, Z -> Y. If B comes after A in the list of weak
4164 tables, X -> Y might be removed from A, although when looking at B
4165 one finds that it shouldn't. */
4168 marked = 0;
4169 for (h = weak_hash_tables; h; h = h->next_weak)
4171 if (h->header.size & ARRAY_MARK_FLAG)
4172 marked |= sweep_weak_table (h, 0);
4175 while (marked);
4177 /* Remove tables and entries that aren't used. */
4178 for (h = weak_hash_tables, used = NULL; h; h = next)
4180 next = h->next_weak;
4182 if (h->header.size & ARRAY_MARK_FLAG)
4184 /* TABLE is marked as used. Sweep its contents. */
4185 if (h->count > 0)
4186 sweep_weak_table (h, 1);
4188 /* Add table to the list of used weak hash tables. */
4189 h->next_weak = used;
4190 used = h;
4194 weak_hash_tables = used;
4199 /***********************************************************************
4200 Hash Code Computation
4201 ***********************************************************************/
4203 /* Maximum depth up to which to dive into Lisp structures. */
4205 #define SXHASH_MAX_DEPTH 3
4207 /* Maximum length up to which to take list and vector elements into
4208 account. */
4210 #define SXHASH_MAX_LEN 7
4212 /* Return a hash for string PTR which has length LEN. The hash value
4213 can be any EMACS_UINT value. */
4215 EMACS_UINT
4216 hash_string (char const *ptr, ptrdiff_t len)
4218 char const *p = ptr;
4219 char const *end = p + len;
4220 unsigned char c;
4221 EMACS_UINT hash = 0;
4223 while (p != end)
4225 c = *p++;
4226 hash = sxhash_combine (hash, c);
4229 return hash;
4232 /* Return a hash for string PTR which has length LEN. The hash
4233 code returned is guaranteed to fit in a Lisp integer. */
4235 static EMACS_UINT
4236 sxhash_string (char const *ptr, ptrdiff_t len)
4238 EMACS_UINT hash = hash_string (ptr, len);
4239 return SXHASH_REDUCE (hash);
4242 /* Return a hash for the floating point value VAL. */
4244 static EMACS_UINT
4245 sxhash_float (double val)
4247 EMACS_UINT hash = 0;
4248 enum {
4249 WORDS_PER_DOUBLE = (sizeof val / sizeof hash
4250 + (sizeof val % sizeof hash != 0))
4252 union {
4253 double val;
4254 EMACS_UINT word[WORDS_PER_DOUBLE];
4255 } u;
4256 int i;
4257 u.val = val;
4258 memset (&u.val + 1, 0, sizeof u - sizeof u.val);
4259 for (i = 0; i < WORDS_PER_DOUBLE; i++)
4260 hash = sxhash_combine (hash, u.word[i]);
4261 return SXHASH_REDUCE (hash);
4264 /* Return a hash for list LIST. DEPTH is the current depth in the
4265 list. We don't recurse deeper than SXHASH_MAX_DEPTH in it. */
4267 static EMACS_UINT
4268 sxhash_list (Lisp_Object list, int depth)
4270 EMACS_UINT hash = 0;
4271 int i;
4273 if (depth < SXHASH_MAX_DEPTH)
4274 for (i = 0;
4275 CONSP (list) && i < SXHASH_MAX_LEN;
4276 list = XCDR (list), ++i)
4278 EMACS_UINT hash2 = sxhash (XCAR (list), depth + 1);
4279 hash = sxhash_combine (hash, hash2);
4282 if (!NILP (list))
4284 EMACS_UINT hash2 = sxhash (list, depth + 1);
4285 hash = sxhash_combine (hash, hash2);
4288 return SXHASH_REDUCE (hash);
4292 /* Return a hash for (pseudo)vector VECTOR. DEPTH is the current depth in
4293 the Lisp structure. */
4295 static EMACS_UINT
4296 sxhash_vector (Lisp_Object vec, int depth)
4298 EMACS_UINT hash = ASIZE (vec);
4299 int i, n;
4301 n = min (SXHASH_MAX_LEN, hash & PSEUDOVECTOR_FLAG ? PVSIZE (vec) : hash);
4302 for (i = 0; i < n; ++i)
4304 EMACS_UINT hash2 = sxhash (AREF (vec, i), depth + 1);
4305 hash = sxhash_combine (hash, hash2);
4308 return SXHASH_REDUCE (hash);
4311 /* Return a hash for bool-vector VECTOR. */
4313 static EMACS_UINT
4314 sxhash_bool_vector (Lisp_Object vec)
4316 EMACS_INT size = bool_vector_size (vec);
4317 EMACS_UINT hash = size;
4318 int i, n;
4320 n = min (SXHASH_MAX_LEN, bool_vector_words (size));
4321 for (i = 0; i < n; ++i)
4322 hash = sxhash_combine (hash, bool_vector_data (vec)[i]);
4324 return SXHASH_REDUCE (hash);
4328 /* Return a hash code for OBJ. DEPTH is the current depth in the Lisp
4329 structure. Value is an unsigned integer clipped to INTMASK. */
4331 EMACS_UINT
4332 sxhash (Lisp_Object obj, int depth)
4334 EMACS_UINT hash;
4336 if (depth > SXHASH_MAX_DEPTH)
4337 return 0;
4339 switch (XTYPE (obj))
4341 case_Lisp_Int:
4342 hash = XUINT (obj);
4343 break;
4345 case Lisp_Misc:
4346 case Lisp_Symbol:
4347 hash = XHASH (obj);
4348 break;
4350 case Lisp_String:
4351 hash = sxhash_string (SSDATA (obj), SBYTES (obj));
4352 break;
4354 /* This can be everything from a vector to an overlay. */
4355 case Lisp_Vectorlike:
4356 if (VECTORP (obj) || RECORDP (obj))
4357 /* According to the CL HyperSpec, two arrays are equal only if
4358 they are `eq', except for strings and bit-vectors. In
4359 Emacs, this works differently. We have to compare element
4360 by element. Same for records. */
4361 hash = sxhash_vector (obj, depth);
4362 else if (BOOL_VECTOR_P (obj))
4363 hash = sxhash_bool_vector (obj);
4364 else
4365 /* Others are `equal' if they are `eq', so let's take their
4366 address as hash. */
4367 hash = XHASH (obj);
4368 break;
4370 case Lisp_Cons:
4371 hash = sxhash_list (obj, depth);
4372 break;
4374 case Lisp_Float:
4375 hash = sxhash_float (XFLOAT_DATA (obj));
4376 break;
4378 default:
4379 emacs_abort ();
4382 return hash;
4387 /***********************************************************************
4388 Lisp Interface
4389 ***********************************************************************/
4391 DEFUN ("sxhash-eq", Fsxhash_eq, Ssxhash_eq, 1, 1, 0,
4392 doc: /* Return an integer hash code for OBJ suitable for `eq'.
4393 If (eq A B), then (= (sxhash-eq A) (sxhash-eq B)). */)
4394 (Lisp_Object obj)
4396 return make_number (hashfn_eq (NULL, obj));
4399 DEFUN ("sxhash-eql", Fsxhash_eql, Ssxhash_eql, 1, 1, 0,
4400 doc: /* Return an integer hash code for OBJ suitable for `eql'.
4401 If (eql A B), then (= (sxhash-eql A) (sxhash-eql B)). */)
4402 (Lisp_Object obj)
4404 return make_number (hashfn_eql (NULL, obj));
4407 DEFUN ("sxhash-equal", Fsxhash_equal, Ssxhash_equal, 1, 1, 0,
4408 doc: /* Return an integer hash code for OBJ suitable for `equal'.
4409 If (equal A B), then (= (sxhash-equal A) (sxhash-equal B)). */)
4410 (Lisp_Object obj)
4412 return make_number (hashfn_equal (NULL, obj));
4415 DEFUN ("make-hash-table", Fmake_hash_table, Smake_hash_table, 0, MANY, 0,
4416 doc: /* Create and return a new hash table.
4418 Arguments are specified as keyword/argument pairs. The following
4419 arguments are defined:
4421 :test TEST -- TEST must be a symbol that specifies how to compare
4422 keys. Default is `eql'. Predefined are the tests `eq', `eql', and
4423 `equal'. User-supplied test and hash functions can be specified via
4424 `define-hash-table-test'.
4426 :size SIZE -- A hint as to how many elements will be put in the table.
4427 Default is 65.
4429 :rehash-size REHASH-SIZE - Indicates how to expand the table when it
4430 fills up. If REHASH-SIZE is an integer, increase the size by that
4431 amount. If it is a float, it must be > 1.0, and the new size is the
4432 old size multiplied by that factor. Default is 1.5.
4434 :rehash-threshold THRESHOLD -- THRESHOLD must a float > 0, and <= 1.0.
4435 Resize the hash table when the ratio (table entries / table size)
4436 exceeds an approximation to THRESHOLD. Default is 0.8125.
4438 :weakness WEAK -- WEAK must be one of nil, t, `key', `value',
4439 `key-or-value', or `key-and-value'. If WEAK is not nil, the table
4440 returned is a weak table. Key/value pairs are removed from a weak
4441 hash table when there are no non-weak references pointing to their
4442 key, value, one of key or value, or both key and value, depending on
4443 WEAK. WEAK t is equivalent to `key-and-value'. Default value of WEAK
4444 is nil.
4446 :purecopy PURECOPY -- If PURECOPY is non-nil, the table can be copied
4447 to pure storage when Emacs is being dumped, making the contents of the
4448 table read only. Any further changes to purified tables will result
4449 in an error.
4451 usage: (make-hash-table &rest KEYWORD-ARGS) */)
4452 (ptrdiff_t nargs, Lisp_Object *args)
4454 Lisp_Object test, weak;
4455 bool pure;
4456 struct hash_table_test testdesc;
4457 ptrdiff_t i;
4458 USE_SAFE_ALLOCA;
4460 /* The vector `used' is used to keep track of arguments that
4461 have been consumed. */
4462 char *used = SAFE_ALLOCA (nargs * sizeof *used);
4463 memset (used, 0, nargs * sizeof *used);
4465 /* See if there's a `:test TEST' among the arguments. */
4466 i = get_key_arg (QCtest, nargs, args, used);
4467 test = i ? args[i] : Qeql;
4468 if (EQ (test, Qeq))
4469 testdesc = hashtest_eq;
4470 else if (EQ (test, Qeql))
4471 testdesc = hashtest_eql;
4472 else if (EQ (test, Qequal))
4473 testdesc = hashtest_equal;
4474 else
4476 /* See if it is a user-defined test. */
4477 Lisp_Object prop;
4479 prop = Fget (test, Qhash_table_test);
4480 if (!CONSP (prop) || !CONSP (XCDR (prop)))
4481 signal_error ("Invalid hash table test", test);
4482 testdesc.name = test;
4483 testdesc.user_cmp_function = XCAR (prop);
4484 testdesc.user_hash_function = XCAR (XCDR (prop));
4485 testdesc.hashfn = hashfn_user_defined;
4486 testdesc.cmpfn = cmpfn_user_defined;
4489 /* See if there's a `:purecopy PURECOPY' argument. */
4490 i = get_key_arg (QCpurecopy, nargs, args, used);
4491 pure = i && !NILP (args[i]);
4492 /* See if there's a `:size SIZE' argument. */
4493 i = get_key_arg (QCsize, nargs, args, used);
4494 Lisp_Object size_arg = i ? args[i] : Qnil;
4495 EMACS_INT size;
4496 if (NILP (size_arg))
4497 size = DEFAULT_HASH_SIZE;
4498 else if (NATNUMP (size_arg))
4499 size = XFASTINT (size_arg);
4500 else
4501 signal_error ("Invalid hash table size", size_arg);
4503 /* Look for `:rehash-size SIZE'. */
4504 float rehash_size;
4505 i = get_key_arg (QCrehash_size, nargs, args, used);
4506 if (!i)
4507 rehash_size = DEFAULT_REHASH_SIZE;
4508 else if (INTEGERP (args[i]) && 0 < XINT (args[i]))
4509 rehash_size = - XINT (args[i]);
4510 else if (FLOATP (args[i]) && 0 < (float) (XFLOAT_DATA (args[i]) - 1))
4511 rehash_size = (float) (XFLOAT_DATA (args[i]) - 1);
4512 else
4513 signal_error ("Invalid hash table rehash size", args[i]);
4515 /* Look for `:rehash-threshold THRESHOLD'. */
4516 i = get_key_arg (QCrehash_threshold, nargs, args, used);
4517 float rehash_threshold = (!i ? DEFAULT_REHASH_THRESHOLD
4518 : !FLOATP (args[i]) ? 0
4519 : (float) XFLOAT_DATA (args[i]));
4520 if (! (0 < rehash_threshold && rehash_threshold <= 1))
4521 signal_error ("Invalid hash table rehash threshold", args[i]);
4523 /* Look for `:weakness WEAK'. */
4524 i = get_key_arg (QCweakness, nargs, args, used);
4525 weak = i ? args[i] : Qnil;
4526 if (EQ (weak, Qt))
4527 weak = Qkey_and_value;
4528 if (!NILP (weak)
4529 && !EQ (weak, Qkey)
4530 && !EQ (weak, Qvalue)
4531 && !EQ (weak, Qkey_or_value)
4532 && !EQ (weak, Qkey_and_value))
4533 signal_error ("Invalid hash table weakness", weak);
4535 /* Now, all args should have been used up, or there's a problem. */
4536 for (i = 0; i < nargs; ++i)
4537 if (!used[i])
4538 signal_error ("Invalid argument list", args[i]);
4540 SAFE_FREE ();
4541 return make_hash_table (testdesc, size, rehash_size, rehash_threshold, weak,
4542 pure);
4546 DEFUN ("copy-hash-table", Fcopy_hash_table, Scopy_hash_table, 1, 1, 0,
4547 doc: /* Return a copy of hash table TABLE. */)
4548 (Lisp_Object table)
4550 return copy_hash_table (check_hash_table (table));
4554 DEFUN ("hash-table-count", Fhash_table_count, Shash_table_count, 1, 1, 0,
4555 doc: /* Return the number of elements in TABLE. */)
4556 (Lisp_Object table)
4558 return make_number (check_hash_table (table)->count);
4562 DEFUN ("hash-table-rehash-size", Fhash_table_rehash_size,
4563 Shash_table_rehash_size, 1, 1, 0,
4564 doc: /* Return the current rehash size of TABLE. */)
4565 (Lisp_Object table)
4567 double rehash_size = check_hash_table (table)->rehash_size;
4568 if (rehash_size < 0)
4570 EMACS_INT s = -rehash_size;
4571 return make_number (min (s, MOST_POSITIVE_FIXNUM));
4573 else
4574 return make_float (rehash_size + 1);
4578 DEFUN ("hash-table-rehash-threshold", Fhash_table_rehash_threshold,
4579 Shash_table_rehash_threshold, 1, 1, 0,
4580 doc: /* Return the current rehash threshold of TABLE. */)
4581 (Lisp_Object table)
4583 return make_float (check_hash_table (table)->rehash_threshold);
4587 DEFUN ("hash-table-size", Fhash_table_size, Shash_table_size, 1, 1, 0,
4588 doc: /* Return the size of TABLE.
4589 The size can be used as an argument to `make-hash-table' to create
4590 a hash table than can hold as many elements as TABLE holds
4591 without need for resizing. */)
4592 (Lisp_Object table)
4594 struct Lisp_Hash_Table *h = check_hash_table (table);
4595 return make_number (HASH_TABLE_SIZE (h));
4599 DEFUN ("hash-table-test", Fhash_table_test, Shash_table_test, 1, 1, 0,
4600 doc: /* Return the test TABLE uses. */)
4601 (Lisp_Object table)
4603 return check_hash_table (table)->test.name;
4607 DEFUN ("hash-table-weakness", Fhash_table_weakness, Shash_table_weakness,
4608 1, 1, 0,
4609 doc: /* Return the weakness of TABLE. */)
4610 (Lisp_Object table)
4612 return check_hash_table (table)->weak;
4616 DEFUN ("hash-table-p", Fhash_table_p, Shash_table_p, 1, 1, 0,
4617 doc: /* Return t if OBJ is a Lisp hash table object. */)
4618 (Lisp_Object obj)
4620 return HASH_TABLE_P (obj) ? Qt : Qnil;
4624 DEFUN ("clrhash", Fclrhash, Sclrhash, 1, 1, 0,
4625 doc: /* Clear hash table TABLE and return it. */)
4626 (Lisp_Object table)
4628 struct Lisp_Hash_Table *h = check_hash_table (table);
4629 CHECK_IMPURE (table, h);
4630 hash_clear (h);
4631 /* Be compatible with XEmacs. */
4632 return table;
4636 DEFUN ("gethash", Fgethash, Sgethash, 2, 3, 0,
4637 doc: /* Look up KEY in TABLE and return its associated value.
4638 If KEY is not found, return DFLT which defaults to nil. */)
4639 (Lisp_Object key, Lisp_Object table, Lisp_Object dflt)
4641 struct Lisp_Hash_Table *h = check_hash_table (table);
4642 ptrdiff_t i = hash_lookup (h, key, NULL);
4643 return i >= 0 ? HASH_VALUE (h, i) : dflt;
4647 DEFUN ("puthash", Fputhash, Sputhash, 3, 3, 0,
4648 doc: /* Associate KEY with VALUE in hash table TABLE.
4649 If KEY is already present in table, replace its current value with
4650 VALUE. In any case, return VALUE. */)
4651 (Lisp_Object key, Lisp_Object value, Lisp_Object table)
4653 struct Lisp_Hash_Table *h = check_hash_table (table);
4654 CHECK_IMPURE (table, h);
4656 ptrdiff_t i;
4657 EMACS_UINT hash;
4658 i = hash_lookup (h, key, &hash);
4659 if (i >= 0)
4660 set_hash_value_slot (h, i, value);
4661 else
4662 hash_put (h, key, value, hash);
4664 return value;
4668 DEFUN ("remhash", Fremhash, Sremhash, 2, 2, 0,
4669 doc: /* Remove KEY from TABLE. */)
4670 (Lisp_Object key, Lisp_Object table)
4672 struct Lisp_Hash_Table *h = check_hash_table (table);
4673 CHECK_IMPURE (table, h);
4674 hash_remove_from_table (h, key);
4675 return Qnil;
4679 DEFUN ("maphash", Fmaphash, Smaphash, 2, 2, 0,
4680 doc: /* Call FUNCTION for all entries in hash table TABLE.
4681 FUNCTION is called with two arguments, KEY and VALUE.
4682 `maphash' always returns nil. */)
4683 (Lisp_Object function, Lisp_Object table)
4685 struct Lisp_Hash_Table *h = check_hash_table (table);
4687 for (ptrdiff_t i = 0; i < HASH_TABLE_SIZE (h); ++i)
4688 if (!NILP (HASH_HASH (h, i)))
4689 call2 (function, HASH_KEY (h, i), HASH_VALUE (h, i));
4691 return Qnil;
4695 DEFUN ("define-hash-table-test", Fdefine_hash_table_test,
4696 Sdefine_hash_table_test, 3, 3, 0,
4697 doc: /* Define a new hash table test with name NAME, a symbol.
4699 In hash tables created with NAME specified as test, use TEST to
4700 compare keys, and HASH for computing hash codes of keys.
4702 TEST must be a function taking two arguments and returning non-nil if
4703 both arguments are the same. HASH must be a function taking one
4704 argument and returning an object that is the hash code of the argument.
4705 It should be the case that if (eq (funcall HASH x1) (funcall HASH x2))
4706 returns nil, then (funcall TEST x1 x2) also returns nil. */)
4707 (Lisp_Object name, Lisp_Object test, Lisp_Object hash)
4709 return Fput (name, Qhash_table_test, list2 (test, hash));
4714 /************************************************************************
4715 MD5, SHA-1, and SHA-2
4716 ************************************************************************/
4718 #include "md5.h"
4719 #include "sha1.h"
4720 #include "sha256.h"
4721 #include "sha512.h"
4723 static Lisp_Object
4724 make_digest_string (Lisp_Object digest, int digest_size)
4726 unsigned char *p = SDATA (digest);
4728 for (int i = digest_size - 1; i >= 0; i--)
4730 static char const hexdigit[16] = "0123456789abcdef";
4731 int p_i = p[i];
4732 p[2 * i] = hexdigit[p_i >> 4];
4733 p[2 * i + 1] = hexdigit[p_i & 0xf];
4735 return digest;
4738 /* ALGORITHM is a symbol: md5, sha1, sha224 and so on. */
4740 static Lisp_Object
4741 secure_hash (Lisp_Object algorithm, Lisp_Object object, Lisp_Object start,
4742 Lisp_Object end, Lisp_Object coding_system, Lisp_Object noerror,
4743 Lisp_Object binary)
4745 ptrdiff_t size, start_char = 0, start_byte, end_char = 0, end_byte;
4746 register EMACS_INT b, e;
4747 register struct buffer *bp;
4748 EMACS_INT temp;
4749 int digest_size;
4750 void *(*hash_func) (const char *, size_t, void *);
4751 Lisp_Object digest;
4753 CHECK_SYMBOL (algorithm);
4755 if (STRINGP (object))
4757 if (NILP (coding_system))
4759 /* Decide the coding-system to encode the data with. */
4761 if (STRING_MULTIBYTE (object))
4762 /* use default, we can't guess correct value */
4763 coding_system = preferred_coding_system ();
4764 else
4765 coding_system = Qraw_text;
4768 if (NILP (Fcoding_system_p (coding_system)))
4770 /* Invalid coding system. */
4772 if (!NILP (noerror))
4773 coding_system = Qraw_text;
4774 else
4775 xsignal1 (Qcoding_system_error, coding_system);
4778 if (STRING_MULTIBYTE (object))
4779 object = code_convert_string (object, coding_system, Qnil, 1, 0, 1);
4781 size = SCHARS (object);
4782 validate_subarray (object, start, end, size, &start_char, &end_char);
4784 start_byte = !start_char ? 0 : string_char_to_byte (object, start_char);
4785 end_byte = (end_char == size
4786 ? SBYTES (object)
4787 : string_char_to_byte (object, end_char));
4789 else
4791 struct buffer *prev = current_buffer;
4793 record_unwind_current_buffer ();
4795 CHECK_BUFFER (object);
4797 bp = XBUFFER (object);
4798 set_buffer_internal (bp);
4800 if (NILP (start))
4801 b = BEGV;
4802 else
4804 CHECK_NUMBER_COERCE_MARKER (start);
4805 b = XINT (start);
4808 if (NILP (end))
4809 e = ZV;
4810 else
4812 CHECK_NUMBER_COERCE_MARKER (end);
4813 e = XINT (end);
4816 if (b > e)
4817 temp = b, b = e, e = temp;
4819 if (!(BEGV <= b && e <= ZV))
4820 args_out_of_range (start, end);
4822 if (NILP (coding_system))
4824 /* Decide the coding-system to encode the data with.
4825 See fileio.c:Fwrite-region */
4827 if (!NILP (Vcoding_system_for_write))
4828 coding_system = Vcoding_system_for_write;
4829 else
4831 bool force_raw_text = 0;
4833 coding_system = BVAR (XBUFFER (object), buffer_file_coding_system);
4834 if (NILP (coding_system)
4835 || NILP (Flocal_variable_p (Qbuffer_file_coding_system, Qnil)))
4837 coding_system = Qnil;
4838 if (NILP (BVAR (current_buffer, enable_multibyte_characters)))
4839 force_raw_text = 1;
4842 if (NILP (coding_system) && !NILP (Fbuffer_file_name (object)))
4844 /* Check file-coding-system-alist. */
4845 Lisp_Object val = CALLN (Ffind_operation_coding_system,
4846 Qwrite_region, start, end,
4847 Fbuffer_file_name (object));
4848 if (CONSP (val) && !NILP (XCDR (val)))
4849 coding_system = XCDR (val);
4852 if (NILP (coding_system)
4853 && !NILP (BVAR (XBUFFER (object), buffer_file_coding_system)))
4855 /* If we still have not decided a coding system, use the
4856 default value of buffer-file-coding-system. */
4857 coding_system = BVAR (XBUFFER (object), buffer_file_coding_system);
4860 if (!force_raw_text
4861 && !NILP (Ffboundp (Vselect_safe_coding_system_function)))
4862 /* Confirm that VAL can surely encode the current region. */
4863 coding_system = call4 (Vselect_safe_coding_system_function,
4864 make_number (b), make_number (e),
4865 coding_system, Qnil);
4867 if (force_raw_text)
4868 coding_system = Qraw_text;
4871 if (NILP (Fcoding_system_p (coding_system)))
4873 /* Invalid coding system. */
4875 if (!NILP (noerror))
4876 coding_system = Qraw_text;
4877 else
4878 xsignal1 (Qcoding_system_error, coding_system);
4882 object = make_buffer_string (b, e, 0);
4883 set_buffer_internal (prev);
4884 /* Discard the unwind protect for recovering the current
4885 buffer. */
4886 specpdl_ptr--;
4888 if (STRING_MULTIBYTE (object))
4889 object = code_convert_string (object, coding_system, Qnil, 1, 0, 0);
4890 start_byte = 0;
4891 end_byte = SBYTES (object);
4894 if (EQ (algorithm, Qmd5))
4896 digest_size = MD5_DIGEST_SIZE;
4897 hash_func = md5_buffer;
4899 else if (EQ (algorithm, Qsha1))
4901 digest_size = SHA1_DIGEST_SIZE;
4902 hash_func = sha1_buffer;
4904 else if (EQ (algorithm, Qsha224))
4906 digest_size = SHA224_DIGEST_SIZE;
4907 hash_func = sha224_buffer;
4909 else if (EQ (algorithm, Qsha256))
4911 digest_size = SHA256_DIGEST_SIZE;
4912 hash_func = sha256_buffer;
4914 else if (EQ (algorithm, Qsha384))
4916 digest_size = SHA384_DIGEST_SIZE;
4917 hash_func = sha384_buffer;
4919 else if (EQ (algorithm, Qsha512))
4921 digest_size = SHA512_DIGEST_SIZE;
4922 hash_func = sha512_buffer;
4924 else
4925 error ("Invalid algorithm arg: %s", SDATA (Fsymbol_name (algorithm)));
4927 /* allocate 2 x digest_size so that it can be re-used to hold the
4928 hexified value */
4929 digest = make_uninit_string (digest_size * 2);
4931 hash_func (SSDATA (object) + start_byte,
4932 end_byte - start_byte,
4933 SSDATA (digest));
4935 if (NILP (binary))
4936 return make_digest_string (digest, digest_size);
4937 else
4938 return make_unibyte_string (SSDATA (digest), digest_size);
4941 DEFUN ("md5", Fmd5, Smd5, 1, 5, 0,
4942 doc: /* Return MD5 message digest of OBJECT, a buffer or string.
4944 A message digest is a cryptographic checksum of a document, and the
4945 algorithm to calculate it is defined in RFC 1321.
4947 The two optional arguments START and END are character positions
4948 specifying for which part of OBJECT the message digest should be
4949 computed. If nil or omitted, the digest is computed for the whole
4950 OBJECT.
4952 The MD5 message digest is computed from the result of encoding the
4953 text in a coding system, not directly from the internal Emacs form of
4954 the text. The optional fourth argument CODING-SYSTEM specifies which
4955 coding system to encode the text with. It should be the same coding
4956 system that you used or will use when actually writing the text into a
4957 file.
4959 If CODING-SYSTEM is nil or omitted, the default depends on OBJECT. If
4960 OBJECT is a buffer, the default for CODING-SYSTEM is whatever coding
4961 system would be chosen by default for writing this text into a file.
4963 If OBJECT is a string, the most preferred coding system (see the
4964 command `prefer-coding-system') is used.
4966 If NOERROR is non-nil, silently assume the `raw-text' coding if the
4967 guesswork fails. Normally, an error is signaled in such case. */)
4968 (Lisp_Object object, Lisp_Object start, Lisp_Object end, Lisp_Object coding_system, Lisp_Object noerror)
4970 return secure_hash (Qmd5, object, start, end, coding_system, noerror, Qnil);
4973 DEFUN ("secure-hash", Fsecure_hash, Ssecure_hash, 2, 5, 0,
4974 doc: /* Return the secure hash of OBJECT, a buffer or string.
4975 ALGORITHM is a symbol specifying the hash to use:
4976 md5, sha1, sha224, sha256, sha384 or sha512.
4978 The two optional arguments START and END are positions specifying for
4979 which part of OBJECT to compute the hash. If nil or omitted, uses the
4980 whole OBJECT.
4982 If BINARY is non-nil, returns a string in binary form. */)
4983 (Lisp_Object algorithm, Lisp_Object object, Lisp_Object start, Lisp_Object end, Lisp_Object binary)
4985 return secure_hash (algorithm, object, start, end, Qnil, Qnil, binary);
4988 DEFUN ("buffer-hash", Fbuffer_hash, Sbuffer_hash, 0, 1, 0,
4989 doc: /* Return a hash of the contents of BUFFER-OR-NAME.
4990 This hash is performed on the raw internal format of the buffer,
4991 disregarding any coding systems. If nil, use the current buffer. */ )
4992 (Lisp_Object buffer_or_name)
4994 Lisp_Object buffer;
4995 struct buffer *b;
4996 struct sha1_ctx ctx;
4998 if (NILP (buffer_or_name))
4999 buffer = Fcurrent_buffer ();
5000 else
5001 buffer = Fget_buffer (buffer_or_name);
5002 if (NILP (buffer))
5003 nsberror (buffer_or_name);
5005 b = XBUFFER (buffer);
5006 sha1_init_ctx (&ctx);
5008 /* Process the first part of the buffer. */
5009 sha1_process_bytes (BUF_BEG_ADDR (b),
5010 BUF_GPT_BYTE (b) - BUF_BEG_BYTE (b),
5011 &ctx);
5013 /* If the gap is before the end of the buffer, process the last half
5014 of the buffer. */
5015 if (BUF_GPT_BYTE (b) < BUF_Z_BYTE (b))
5016 sha1_process_bytes (BUF_GAP_END_ADDR (b),
5017 BUF_Z_ADDR (b) - BUF_GAP_END_ADDR (b),
5018 &ctx);
5020 Lisp_Object digest = make_uninit_string (SHA1_DIGEST_SIZE * 2);
5021 sha1_finish_ctx (&ctx, SSDATA (digest));
5022 return make_digest_string (digest, SHA1_DIGEST_SIZE);
5026 void
5027 syms_of_fns (void)
5029 DEFSYM (Qmd5, "md5");
5030 DEFSYM (Qsha1, "sha1");
5031 DEFSYM (Qsha224, "sha224");
5032 DEFSYM (Qsha256, "sha256");
5033 DEFSYM (Qsha384, "sha384");
5034 DEFSYM (Qsha512, "sha512");
5036 /* Hash table stuff. */
5037 DEFSYM (Qhash_table_p, "hash-table-p");
5038 DEFSYM (Qeq, "eq");
5039 DEFSYM (Qeql, "eql");
5040 DEFSYM (Qequal, "equal");
5041 DEFSYM (QCtest, ":test");
5042 DEFSYM (QCsize, ":size");
5043 DEFSYM (QCpurecopy, ":purecopy");
5044 DEFSYM (QCrehash_size, ":rehash-size");
5045 DEFSYM (QCrehash_threshold, ":rehash-threshold");
5046 DEFSYM (QCweakness, ":weakness");
5047 DEFSYM (Qkey, "key");
5048 DEFSYM (Qvalue, "value");
5049 DEFSYM (Qhash_table_test, "hash-table-test");
5050 DEFSYM (Qkey_or_value, "key-or-value");
5051 DEFSYM (Qkey_and_value, "key-and-value");
5053 defsubr (&Ssxhash_eq);
5054 defsubr (&Ssxhash_eql);
5055 defsubr (&Ssxhash_equal);
5056 defsubr (&Smake_hash_table);
5057 defsubr (&Scopy_hash_table);
5058 defsubr (&Shash_table_count);
5059 defsubr (&Shash_table_rehash_size);
5060 defsubr (&Shash_table_rehash_threshold);
5061 defsubr (&Shash_table_size);
5062 defsubr (&Shash_table_test);
5063 defsubr (&Shash_table_weakness);
5064 defsubr (&Shash_table_p);
5065 defsubr (&Sclrhash);
5066 defsubr (&Sgethash);
5067 defsubr (&Sputhash);
5068 defsubr (&Sremhash);
5069 defsubr (&Smaphash);
5070 defsubr (&Sdefine_hash_table_test);
5072 DEFSYM (Qstring_lessp, "string-lessp");
5073 DEFSYM (Qprovide, "provide");
5074 DEFSYM (Qrequire, "require");
5075 DEFSYM (Qyes_or_no_p_history, "yes-or-no-p-history");
5076 DEFSYM (Qcursor_in_echo_area, "cursor-in-echo-area");
5077 DEFSYM (Qwidget_type, "widget-type");
5079 staticpro (&string_char_byte_cache_string);
5080 string_char_byte_cache_string = Qnil;
5082 require_nesting_list = Qnil;
5083 staticpro (&require_nesting_list);
5085 Fset (Qyes_or_no_p_history, Qnil);
5087 DEFVAR_LISP ("features", Vfeatures,
5088 doc: /* A list of symbols which are the features of the executing Emacs.
5089 Used by `featurep' and `require', and altered by `provide'. */);
5090 Vfeatures = list1 (Qemacs);
5091 DEFSYM (Qfeatures, "features");
5092 /* Let people use lexically scoped vars named `features'. */
5093 Fmake_var_non_special (Qfeatures);
5094 DEFSYM (Qsubfeatures, "subfeatures");
5095 DEFSYM (Qfuncall, "funcall");
5097 #ifdef HAVE_LANGINFO_CODESET
5098 DEFSYM (Qcodeset, "codeset");
5099 DEFSYM (Qdays, "days");
5100 DEFSYM (Qmonths, "months");
5101 DEFSYM (Qpaper, "paper");
5102 #endif /* HAVE_LANGINFO_CODESET */
5104 DEFVAR_BOOL ("use-dialog-box", use_dialog_box,
5105 doc: /* Non-nil means mouse commands use dialog boxes to ask questions.
5106 This applies to `y-or-n-p' and `yes-or-no-p' questions asked by commands
5107 invoked by mouse clicks and mouse menu items.
5109 On some platforms, file selection dialogs are also enabled if this is
5110 non-nil. */);
5111 use_dialog_box = 1;
5113 DEFVAR_BOOL ("use-file-dialog", use_file_dialog,
5114 doc: /* Non-nil means mouse commands use a file dialog to ask for files.
5115 This applies to commands from menus and tool bar buttons even when
5116 they are initiated from the keyboard. If `use-dialog-box' is nil,
5117 that disables the use of a file dialog, regardless of the value of
5118 this variable. */);
5119 use_file_dialog = 1;
5121 defsubr (&Sidentity);
5122 defsubr (&Srandom);
5123 defsubr (&Slength);
5124 defsubr (&Ssafe_length);
5125 defsubr (&Sstring_bytes);
5126 defsubr (&Sstring_equal);
5127 defsubr (&Scompare_strings);
5128 defsubr (&Sstring_lessp);
5129 defsubr (&Sstring_version_lessp);
5130 defsubr (&Sstring_collate_lessp);
5131 defsubr (&Sstring_collate_equalp);
5132 defsubr (&Sappend);
5133 defsubr (&Sconcat);
5134 defsubr (&Svconcat);
5135 defsubr (&Scopy_sequence);
5136 defsubr (&Sstring_make_multibyte);
5137 defsubr (&Sstring_make_unibyte);
5138 defsubr (&Sstring_as_multibyte);
5139 defsubr (&Sstring_as_unibyte);
5140 defsubr (&Sstring_to_multibyte);
5141 defsubr (&Sstring_to_unibyte);
5142 defsubr (&Scopy_alist);
5143 defsubr (&Ssubstring);
5144 defsubr (&Ssubstring_no_properties);
5145 defsubr (&Snthcdr);
5146 defsubr (&Snth);
5147 defsubr (&Selt);
5148 defsubr (&Smember);
5149 defsubr (&Smemq);
5150 defsubr (&Smemql);
5151 defsubr (&Sassq);
5152 defsubr (&Sassoc);
5153 defsubr (&Srassq);
5154 defsubr (&Srassoc);
5155 defsubr (&Sdelq);
5156 defsubr (&Sdelete);
5157 defsubr (&Snreverse);
5158 defsubr (&Sreverse);
5159 defsubr (&Ssort);
5160 defsubr (&Splist_get);
5161 defsubr (&Sget);
5162 defsubr (&Splist_put);
5163 defsubr (&Sput);
5164 defsubr (&Slax_plist_get);
5165 defsubr (&Slax_plist_put);
5166 defsubr (&Seql);
5167 defsubr (&Sequal);
5168 defsubr (&Sequal_including_properties);
5169 defsubr (&Sfillarray);
5170 defsubr (&Sclear_string);
5171 defsubr (&Snconc);
5172 defsubr (&Smapcar);
5173 defsubr (&Smapc);
5174 defsubr (&Smapcan);
5175 defsubr (&Smapconcat);
5176 defsubr (&Syes_or_no_p);
5177 defsubr (&Sload_average);
5178 defsubr (&Sfeaturep);
5179 defsubr (&Srequire);
5180 defsubr (&Sprovide);
5181 defsubr (&Splist_member);
5182 defsubr (&Swidget_put);
5183 defsubr (&Swidget_get);
5184 defsubr (&Swidget_apply);
5185 defsubr (&Sbase64_encode_region);
5186 defsubr (&Sbase64_decode_region);
5187 defsubr (&Sbase64_encode_string);
5188 defsubr (&Sbase64_decode_string);
5189 defsubr (&Smd5);
5190 defsubr (&Ssecure_hash);
5191 defsubr (&Sbuffer_hash);
5192 defsubr (&Slocale_info);