Fix a minor problem with mouse-face on mode line
[emacs.git] / src / fns.c
blob51f61d23881a5097f2a9f56dc8dfc2f6ef82144a
1 /* Random utility Lisp functions.
3 Copyright (C) 1985-1987, 1993-1995, 1997-2015 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
11 (at 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 <unistd.h>
24 #include <time.h>
26 #include <intprops.h>
27 #include <vla.h>
29 #include "lisp.h"
30 #include "commands.h"
31 #include "character.h"
32 #include "coding.h"
33 #include "buffer.h"
34 #include "keyboard.h"
35 #include "keymap.h"
36 #include "intervals.h"
37 #include "frame.h"
38 #include "window.h"
39 #include "blockinput.h"
40 #if defined (HAVE_X_WINDOWS)
41 #include "xterm.h"
42 #endif
44 static void sort_vector_copy (Lisp_Object, ptrdiff_t,
45 Lisp_Object [restrict], Lisp_Object [restrict]);
46 static bool internal_equal (Lisp_Object, Lisp_Object, int, bool, Lisp_Object);
48 DEFUN ("identity", Fidentity, Sidentity, 1, 1, 0,
49 doc: /* Return the argument unchanged. */
50 attributes: const)
51 (Lisp_Object arg)
53 return arg;
56 DEFUN ("random", Frandom, Srandom, 0, 1, 0,
57 doc: /* Return a pseudo-random number.
58 All integers representable in Lisp, i.e. between `most-negative-fixnum'
59 and `most-positive-fixnum', inclusive, are equally likely.
61 With positive integer LIMIT, return random number in interval [0,LIMIT).
62 With argument t, set the random number seed from the current time and pid.
63 With a string argument, set the seed based on the string's contents.
64 Other values of LIMIT are ignored.
66 See Info node `(elisp)Random Numbers' for more details. */)
67 (Lisp_Object limit)
69 EMACS_INT val;
71 if (EQ (limit, Qt))
72 init_random ();
73 else if (STRINGP (limit))
74 seed_random (SSDATA (limit), SBYTES (limit));
76 val = get_random ();
77 if (INTEGERP (limit) && 0 < XINT (limit))
78 while (true)
80 /* Return the remainder, except reject the rare case where
81 get_random returns a number so close to INTMASK that the
82 remainder isn't random. */
83 EMACS_INT remainder = val % XINT (limit);
84 if (val - remainder <= INTMASK - XINT (limit) + 1)
85 return make_number (remainder);
86 val = get_random ();
88 return make_number (val);
91 /* Heuristic on how many iterations of a tight loop can be safely done
92 before it's time to do a QUIT. This must be a power of 2. */
93 enum { QUIT_COUNT_HEURISTIC = 1 << 16 };
95 /* Random data-structure functions. */
97 static void
98 CHECK_LIST_END (Lisp_Object x, Lisp_Object y)
100 CHECK_TYPE (NILP (x), Qlistp, y);
103 DEFUN ("length", Flength, Slength, 1, 1, 0,
104 doc: /* Return the length of vector, list or string SEQUENCE.
105 A byte-code function object is also allowed.
106 If the string contains multibyte characters, this is not necessarily
107 the number of bytes in the string; it is the number of characters.
108 To get the number of bytes, use `string-bytes'. */)
109 (register Lisp_Object sequence)
111 register Lisp_Object val;
113 if (STRINGP (sequence))
114 XSETFASTINT (val, SCHARS (sequence));
115 else if (VECTORP (sequence))
116 XSETFASTINT (val, ASIZE (sequence));
117 else if (CHAR_TABLE_P (sequence))
118 XSETFASTINT (val, MAX_CHAR);
119 else if (BOOL_VECTOR_P (sequence))
120 XSETFASTINT (val, bool_vector_size (sequence));
121 else if (COMPILEDP (sequence))
122 XSETFASTINT (val, ASIZE (sequence) & PSEUDOVECTOR_SIZE_MASK);
123 else if (CONSP (sequence))
125 EMACS_INT i = 0;
129 ++i;
130 if ((i & (QUIT_COUNT_HEURISTIC - 1)) == 0)
132 if (MOST_POSITIVE_FIXNUM < i)
133 error ("List too long");
134 QUIT;
136 sequence = XCDR (sequence);
138 while (CONSP (sequence));
140 CHECK_LIST_END (sequence, sequence);
142 val = make_number (i);
144 else if (NILP (sequence))
145 XSETFASTINT (val, 0);
146 else
147 wrong_type_argument (Qsequencep, sequence);
149 return val;
152 DEFUN ("safe-length", Fsafe_length, Ssafe_length, 1, 1, 0,
153 doc: /* Return the length of a list, but avoid error or infinite loop.
154 This function never gets an error. If LIST is not really a list,
155 it returns 0. If LIST is circular, it returns a finite value
156 which is at least the number of distinct elements. */)
157 (Lisp_Object list)
159 Lisp_Object tail, halftail;
160 double hilen = 0;
161 uintmax_t lolen = 1;
163 if (! CONSP (list))
164 return make_number (0);
166 /* halftail is used to detect circular lists. */
167 for (tail = halftail = list; ; )
169 tail = XCDR (tail);
170 if (! CONSP (tail))
171 break;
172 if (EQ (tail, halftail))
173 break;
174 lolen++;
175 if ((lolen & 1) == 0)
177 halftail = XCDR (halftail);
178 if ((lolen & (QUIT_COUNT_HEURISTIC - 1)) == 0)
180 QUIT;
181 if (lolen == 0)
182 hilen += UINTMAX_MAX + 1.0;
187 /* If the length does not fit into a fixnum, return a float.
188 On all known practical machines this returns an upper bound on
189 the true length. */
190 return hilen ? make_float (hilen + lolen) : make_fixnum_or_float (lolen);
193 DEFUN ("string-bytes", Fstring_bytes, Sstring_bytes, 1, 1, 0,
194 doc: /* Return the number of bytes in STRING.
195 If STRING is multibyte, this may be greater than the length of STRING. */)
196 (Lisp_Object string)
198 CHECK_STRING (string);
199 return make_number (SBYTES (string));
202 DEFUN ("string-equal", Fstring_equal, Sstring_equal, 2, 2, 0,
203 doc: /* Return t if two strings have identical contents.
204 Case is significant, but text properties are ignored.
205 Symbols are also allowed; their print names are used instead. */)
206 (register Lisp_Object s1, Lisp_Object s2)
208 if (SYMBOLP (s1))
209 s1 = SYMBOL_NAME (s1);
210 if (SYMBOLP (s2))
211 s2 = SYMBOL_NAME (s2);
212 CHECK_STRING (s1);
213 CHECK_STRING (s2);
215 if (SCHARS (s1) != SCHARS (s2)
216 || SBYTES (s1) != SBYTES (s2)
217 || memcmp (SDATA (s1), SDATA (s2), SBYTES (s1)))
218 return Qnil;
219 return Qt;
222 DEFUN ("compare-strings", Fcompare_strings, Scompare_strings, 6, 7, 0,
223 doc: /* Compare the contents of two strings, converting to multibyte if needed.
224 The arguments START1, END1, START2, and END2, if non-nil, are
225 positions specifying which parts of STR1 or STR2 to compare. In
226 string STR1, compare the part between START1 (inclusive) and END1
227 \(exclusive). If START1 is nil, it defaults to 0, the beginning of
228 the string; if END1 is nil, it defaults to the length of the string.
229 Likewise, in string STR2, compare the part between START2 and END2.
230 Like in `substring', negative values are counted from the end.
232 The strings are compared by the numeric values of their characters.
233 For instance, STR1 is "less than" STR2 if its first differing
234 character has a smaller numeric value. If IGNORE-CASE is non-nil,
235 characters are converted to lower-case before comparing them. Unibyte
236 strings are converted to multibyte for comparison.
238 The value is t if the strings (or specified portions) match.
239 If string STR1 is less, the value is a negative number N;
240 - 1 - N is the number of characters that match at the beginning.
241 If string STR1 is greater, the value is a positive number N;
242 N - 1 is the number of characters that match at the beginning. */)
243 (Lisp_Object str1, Lisp_Object start1, Lisp_Object end1, Lisp_Object str2,
244 Lisp_Object start2, Lisp_Object end2, Lisp_Object ignore_case)
246 ptrdiff_t from1, to1, from2, to2, i1, i1_byte, i2, i2_byte;
248 CHECK_STRING (str1);
249 CHECK_STRING (str2);
251 /* For backward compatibility, silently bring too-large positive end
252 values into range. */
253 if (INTEGERP (end1) && SCHARS (str1) < XINT (end1))
254 end1 = make_number (SCHARS (str1));
255 if (INTEGERP (end2) && SCHARS (str2) < XINT (end2))
256 end2 = make_number (SCHARS (str2));
258 validate_subarray (str1, start1, end1, SCHARS (str1), &from1, &to1);
259 validate_subarray (str2, start2, end2, SCHARS (str2), &from2, &to2);
261 i1 = from1;
262 i2 = from2;
264 i1_byte = string_char_to_byte (str1, i1);
265 i2_byte = string_char_to_byte (str2, i2);
267 while (i1 < to1 && i2 < to2)
269 /* When we find a mismatch, we must compare the
270 characters, not just the bytes. */
271 int c1, c2;
273 FETCH_STRING_CHAR_AS_MULTIBYTE_ADVANCE (c1, str1, i1, i1_byte);
274 FETCH_STRING_CHAR_AS_MULTIBYTE_ADVANCE (c2, str2, i2, i2_byte);
276 if (c1 == c2)
277 continue;
279 if (! NILP (ignore_case))
281 c1 = XINT (Fupcase (make_number (c1)));
282 c2 = XINT (Fupcase (make_number (c2)));
285 if (c1 == c2)
286 continue;
288 /* Note that I1 has already been incremented
289 past the character that we are comparing;
290 hence we don't add or subtract 1 here. */
291 if (c1 < c2)
292 return make_number (- i1 + from1);
293 else
294 return make_number (i1 - from1);
297 if (i1 < to1)
298 return make_number (i1 - from1 + 1);
299 if (i2 < to2)
300 return make_number (- i1 + from1 - 1);
302 return Qt;
305 DEFUN ("string-lessp", Fstring_lessp, Sstring_lessp, 2, 2, 0,
306 doc: /* Return t if first arg string is less than second in lexicographic order.
307 Case is significant.
308 Symbols are also allowed; their print names are used instead. */)
309 (register Lisp_Object s1, Lisp_Object s2)
311 register ptrdiff_t end;
312 register ptrdiff_t i1, i1_byte, i2, i2_byte;
314 if (SYMBOLP (s1))
315 s1 = SYMBOL_NAME (s1);
316 if (SYMBOLP (s2))
317 s2 = SYMBOL_NAME (s2);
318 CHECK_STRING (s1);
319 CHECK_STRING (s2);
321 i1 = i1_byte = i2 = i2_byte = 0;
323 end = SCHARS (s1);
324 if (end > SCHARS (s2))
325 end = SCHARS (s2);
327 while (i1 < end)
329 /* When we find a mismatch, we must compare the
330 characters, not just the bytes. */
331 int c1, c2;
333 FETCH_STRING_CHAR_ADVANCE (c1, s1, i1, i1_byte);
334 FETCH_STRING_CHAR_ADVANCE (c2, s2, i2, i2_byte);
336 if (c1 != c2)
337 return c1 < c2 ? Qt : Qnil;
339 return i1 < SCHARS (s2) ? Qt : Qnil;
342 DEFUN ("string-collate-lessp", Fstring_collate_lessp, Sstring_collate_lessp, 2, 4, 0,
343 doc: /* Return t if first arg string is less than second in collation order.
344 Symbols are also allowed; their print names are used instead.
346 This function obeys the conventions for collation order in your
347 locale settings. For example, punctuation and whitespace characters
348 might be considered less significant for sorting:
350 \(sort '\("11" "12" "1 1" "1 2" "1.1" "1.2") 'string-collate-lessp)
351 => \("11" "1 1" "1.1" "12" "1 2" "1.2")
353 The optional argument LOCALE, a string, overrides the setting of your
354 current locale identifier for collation. The value is system
355 dependent; a LOCALE \"en_US.UTF-8\" is applicable on POSIX systems,
356 while it would be, e.g., \"enu_USA.1252\" on MS-Windows systems.
358 If IGNORE-CASE is non-nil, characters are converted to lower-case
359 before comparing them.
361 To emulate Unicode-compliant collation on MS-Windows systems,
362 bind `w32-collate-ignore-punctuation' to a non-nil value, since
363 the codeset part of the locale cannot be \"UTF-8\" on MS-Windows.
365 If your system does not support a locale environment, this function
366 behaves like `string-lessp'. */)
367 (Lisp_Object s1, Lisp_Object s2, Lisp_Object locale, Lisp_Object ignore_case)
369 #if defined __STDC_ISO_10646__ || defined WINDOWSNT
370 /* Check parameters. */
371 if (SYMBOLP (s1))
372 s1 = SYMBOL_NAME (s1);
373 if (SYMBOLP (s2))
374 s2 = SYMBOL_NAME (s2);
375 CHECK_STRING (s1);
376 CHECK_STRING (s2);
377 if (!NILP (locale))
378 CHECK_STRING (locale);
380 return (str_collate (s1, s2, locale, ignore_case) < 0) ? Qt : Qnil;
382 #else /* !__STDC_ISO_10646__, !WINDOWSNT */
383 return Fstring_lessp (s1, s2);
384 #endif /* !__STDC_ISO_10646__, !WINDOWSNT */
387 DEFUN ("string-collate-equalp", Fstring_collate_equalp, Sstring_collate_equalp, 2, 4, 0,
388 doc: /* Return t if two strings have identical contents.
389 Symbols are also allowed; their print names are used instead.
391 This function obeys the conventions for collation order in your locale
392 settings. For example, characters with different coding points but
393 the same meaning might be considered as equal, like different grave
394 accent Unicode characters:
396 \(string-collate-equalp \(string ?\\uFF40) \(string ?\\u1FEF))
397 => t
399 The optional argument LOCALE, a string, overrides the setting of your
400 current locale identifier for collation. The value is system
401 dependent; a LOCALE \"en_US.UTF-8\" is applicable on POSIX systems,
402 while it would be \"enu_USA.1252\" on MS Windows systems.
404 If IGNORE-CASE is non-nil, characters are converted to lower-case
405 before comparing them.
407 To emulate Unicode-compliant collation on MS-Windows systems,
408 bind `w32-collate-ignore-punctuation' to a non-nil value, since
409 the codeset part of the locale cannot be \"UTF-8\" on MS-Windows.
411 If your system does not support a locale environment, this function
412 behaves like `string-equal'.
414 Do NOT use this function to compare file names for equality, only
415 for sorting them. */)
416 (Lisp_Object s1, Lisp_Object s2, Lisp_Object locale, Lisp_Object ignore_case)
418 #if defined __STDC_ISO_10646__ || defined WINDOWSNT
419 /* Check parameters. */
420 if (SYMBOLP (s1))
421 s1 = SYMBOL_NAME (s1);
422 if (SYMBOLP (s2))
423 s2 = SYMBOL_NAME (s2);
424 CHECK_STRING (s1);
425 CHECK_STRING (s2);
426 if (!NILP (locale))
427 CHECK_STRING (locale);
429 return (str_collate (s1, s2, locale, ignore_case) == 0) ? Qt : Qnil;
431 #else /* !__STDC_ISO_10646__, !WINDOWSNT */
432 return Fstring_equal (s1, s2);
433 #endif /* !__STDC_ISO_10646__, !WINDOWSNT */
436 static Lisp_Object concat (ptrdiff_t nargs, Lisp_Object *args,
437 enum Lisp_Type target_type, bool last_special);
439 /* ARGSUSED */
440 Lisp_Object
441 concat2 (Lisp_Object s1, Lisp_Object s2)
443 return concat (2, ((Lisp_Object []) {s1, s2}), Lisp_String, 0);
446 /* ARGSUSED */
447 Lisp_Object
448 concat3 (Lisp_Object s1, Lisp_Object s2, Lisp_Object s3)
450 return concat (3, ((Lisp_Object []) {s1, s2, s3}), Lisp_String, 0);
453 DEFUN ("append", Fappend, Sappend, 0, MANY, 0,
454 doc: /* Concatenate all the arguments and make the result a list.
455 The result is a list whose elements are the elements of all the arguments.
456 Each argument may be a list, vector or string.
457 The last argument is not copied, just used as the tail of the new list.
458 usage: (append &rest SEQUENCES) */)
459 (ptrdiff_t nargs, Lisp_Object *args)
461 return concat (nargs, args, Lisp_Cons, 1);
464 DEFUN ("concat", Fconcat, Sconcat, 0, MANY, 0,
465 doc: /* Concatenate all the arguments and make the result a string.
466 The result is a string whose elements are the elements of all the arguments.
467 Each argument may be a string or a list or vector of characters (integers).
468 usage: (concat &rest SEQUENCES) */)
469 (ptrdiff_t nargs, Lisp_Object *args)
471 return concat (nargs, args, Lisp_String, 0);
474 DEFUN ("vconcat", Fvconcat, Svconcat, 0, MANY, 0,
475 doc: /* Concatenate all the arguments and make the result a vector.
476 The result is a vector whose elements are the elements of all the arguments.
477 Each argument may be a list, vector or string.
478 usage: (vconcat &rest SEQUENCES) */)
479 (ptrdiff_t nargs, Lisp_Object *args)
481 return concat (nargs, args, Lisp_Vectorlike, 0);
485 DEFUN ("copy-sequence", Fcopy_sequence, Scopy_sequence, 1, 1, 0,
486 doc: /* Return a copy of a list, vector, string or char-table.
487 The elements of a list or vector are not copied; they are shared
488 with the original. */)
489 (Lisp_Object arg)
491 if (NILP (arg)) return arg;
493 if (CHAR_TABLE_P (arg))
495 return copy_char_table (arg);
498 if (BOOL_VECTOR_P (arg))
500 EMACS_INT nbits = bool_vector_size (arg);
501 ptrdiff_t nbytes = bool_vector_bytes (nbits);
502 Lisp_Object val = make_uninit_bool_vector (nbits);
503 memcpy (bool_vector_data (val), bool_vector_data (arg), nbytes);
504 return val;
507 if (!CONSP (arg) && !VECTORP (arg) && !STRINGP (arg))
508 wrong_type_argument (Qsequencep, arg);
510 return concat (1, &arg, XTYPE (arg), 0);
513 /* This structure holds information of an argument of `concat' that is
514 a string and has text properties to be copied. */
515 struct textprop_rec
517 ptrdiff_t argnum; /* refer to ARGS (arguments of `concat') */
518 ptrdiff_t from; /* refer to ARGS[argnum] (argument string) */
519 ptrdiff_t to; /* refer to VAL (the target string) */
522 static Lisp_Object
523 concat (ptrdiff_t nargs, Lisp_Object *args,
524 enum Lisp_Type target_type, bool last_special)
526 Lisp_Object val;
527 Lisp_Object tail;
528 Lisp_Object this;
529 ptrdiff_t toindex;
530 ptrdiff_t toindex_byte = 0;
531 EMACS_INT result_len;
532 EMACS_INT result_len_byte;
533 ptrdiff_t argnum;
534 Lisp_Object last_tail;
535 Lisp_Object prev;
536 bool some_multibyte;
537 /* When we make a multibyte string, we can't copy text properties
538 while concatenating each string because the length of resulting
539 string can't be decided until we finish the whole concatenation.
540 So, we record strings that have text properties to be copied
541 here, and copy the text properties after the concatenation. */
542 struct textprop_rec *textprops = NULL;
543 /* Number of elements in textprops. */
544 ptrdiff_t num_textprops = 0;
545 USE_SAFE_ALLOCA;
547 tail = Qnil;
549 /* In append, the last arg isn't treated like the others */
550 if (last_special && nargs > 0)
552 nargs--;
553 last_tail = args[nargs];
555 else
556 last_tail = Qnil;
558 /* Check each argument. */
559 for (argnum = 0; argnum < nargs; argnum++)
561 this = args[argnum];
562 if (!(CONSP (this) || NILP (this) || VECTORP (this) || STRINGP (this)
563 || COMPILEDP (this) || BOOL_VECTOR_P (this)))
564 wrong_type_argument (Qsequencep, this);
567 /* Compute total length in chars of arguments in RESULT_LEN.
568 If desired output is a string, also compute length in bytes
569 in RESULT_LEN_BYTE, and determine in SOME_MULTIBYTE
570 whether the result should be a multibyte string. */
571 result_len_byte = 0;
572 result_len = 0;
573 some_multibyte = 0;
574 for (argnum = 0; argnum < nargs; argnum++)
576 EMACS_INT len;
577 this = args[argnum];
578 len = XFASTINT (Flength (this));
579 if (target_type == Lisp_String)
581 /* We must count the number of bytes needed in the string
582 as well as the number of characters. */
583 ptrdiff_t i;
584 Lisp_Object ch;
585 int c;
586 ptrdiff_t this_len_byte;
588 if (VECTORP (this) || COMPILEDP (this))
589 for (i = 0; i < len; i++)
591 ch = AREF (this, i);
592 CHECK_CHARACTER (ch);
593 c = XFASTINT (ch);
594 this_len_byte = CHAR_BYTES (c);
595 if (STRING_BYTES_BOUND - result_len_byte < this_len_byte)
596 string_overflow ();
597 result_len_byte += this_len_byte;
598 if (! ASCII_CHAR_P (c) && ! CHAR_BYTE8_P (c))
599 some_multibyte = 1;
601 else if (BOOL_VECTOR_P (this) && bool_vector_size (this) > 0)
602 wrong_type_argument (Qintegerp, Faref (this, make_number (0)));
603 else if (CONSP (this))
604 for (; CONSP (this); this = XCDR (this))
606 ch = XCAR (this);
607 CHECK_CHARACTER (ch);
608 c = XFASTINT (ch);
609 this_len_byte = CHAR_BYTES (c);
610 if (STRING_BYTES_BOUND - result_len_byte < this_len_byte)
611 string_overflow ();
612 result_len_byte += this_len_byte;
613 if (! ASCII_CHAR_P (c) && ! CHAR_BYTE8_P (c))
614 some_multibyte = 1;
616 else if (STRINGP (this))
618 if (STRING_MULTIBYTE (this))
620 some_multibyte = 1;
621 this_len_byte = SBYTES (this);
623 else
624 this_len_byte = count_size_as_multibyte (SDATA (this),
625 SCHARS (this));
626 if (STRING_BYTES_BOUND - result_len_byte < this_len_byte)
627 string_overflow ();
628 result_len_byte += this_len_byte;
632 result_len += len;
633 if (MOST_POSITIVE_FIXNUM < result_len)
634 memory_full (SIZE_MAX);
637 if (! some_multibyte)
638 result_len_byte = result_len;
640 /* Create the output object. */
641 if (target_type == Lisp_Cons)
642 val = Fmake_list (make_number (result_len), Qnil);
643 else if (target_type == Lisp_Vectorlike)
644 val = Fmake_vector (make_number (result_len), Qnil);
645 else if (some_multibyte)
646 val = make_uninit_multibyte_string (result_len, result_len_byte);
647 else
648 val = make_uninit_string (result_len);
650 /* In `append', if all but last arg are nil, return last arg. */
651 if (target_type == Lisp_Cons && EQ (val, Qnil))
652 return last_tail;
654 /* Copy the contents of the args into the result. */
655 if (CONSP (val))
656 tail = val, toindex = -1; /* -1 in toindex is flag we are making a list */
657 else
658 toindex = 0, toindex_byte = 0;
660 prev = Qnil;
661 if (STRINGP (val))
662 SAFE_NALLOCA (textprops, 1, nargs);
664 for (argnum = 0; argnum < nargs; argnum++)
666 Lisp_Object thislen;
667 ptrdiff_t thisleni = 0;
668 register ptrdiff_t thisindex = 0;
669 register ptrdiff_t thisindex_byte = 0;
671 this = args[argnum];
672 if (!CONSP (this))
673 thislen = Flength (this), thisleni = XINT (thislen);
675 /* Between strings of the same kind, copy fast. */
676 if (STRINGP (this) && STRINGP (val)
677 && STRING_MULTIBYTE (this) == some_multibyte)
679 ptrdiff_t thislen_byte = SBYTES (this);
681 memcpy (SDATA (val) + toindex_byte, SDATA (this), SBYTES (this));
682 if (string_intervals (this))
684 textprops[num_textprops].argnum = argnum;
685 textprops[num_textprops].from = 0;
686 textprops[num_textprops++].to = toindex;
688 toindex_byte += thislen_byte;
689 toindex += thisleni;
691 /* Copy a single-byte string to a multibyte string. */
692 else if (STRINGP (this) && STRINGP (val))
694 if (string_intervals (this))
696 textprops[num_textprops].argnum = argnum;
697 textprops[num_textprops].from = 0;
698 textprops[num_textprops++].to = toindex;
700 toindex_byte += copy_text (SDATA (this),
701 SDATA (val) + toindex_byte,
702 SCHARS (this), 0, 1);
703 toindex += thisleni;
705 else
706 /* Copy element by element. */
707 while (1)
709 register Lisp_Object elt;
711 /* Fetch next element of `this' arg into `elt', or break if
712 `this' is exhausted. */
713 if (NILP (this)) break;
714 if (CONSP (this))
715 elt = XCAR (this), this = XCDR (this);
716 else if (thisindex >= thisleni)
717 break;
718 else if (STRINGP (this))
720 int c;
721 if (STRING_MULTIBYTE (this))
722 FETCH_STRING_CHAR_ADVANCE_NO_CHECK (c, this,
723 thisindex,
724 thisindex_byte);
725 else
727 c = SREF (this, thisindex); thisindex++;
728 if (some_multibyte && !ASCII_CHAR_P (c))
729 c = BYTE8_TO_CHAR (c);
731 XSETFASTINT (elt, c);
733 else if (BOOL_VECTOR_P (this))
735 elt = bool_vector_ref (this, thisindex);
736 thisindex++;
738 else
740 elt = AREF (this, thisindex);
741 thisindex++;
744 /* Store this element into the result. */
745 if (toindex < 0)
747 XSETCAR (tail, elt);
748 prev = tail;
749 tail = XCDR (tail);
751 else if (VECTORP (val))
753 ASET (val, toindex, elt);
754 toindex++;
756 else
758 int c;
759 CHECK_CHARACTER (elt);
760 c = XFASTINT (elt);
761 if (some_multibyte)
762 toindex_byte += CHAR_STRING (c, SDATA (val) + toindex_byte);
763 else
764 SSET (val, toindex_byte++, c);
765 toindex++;
769 if (!NILP (prev))
770 XSETCDR (prev, last_tail);
772 if (num_textprops > 0)
774 Lisp_Object props;
775 ptrdiff_t last_to_end = -1;
777 for (argnum = 0; argnum < num_textprops; argnum++)
779 this = args[textprops[argnum].argnum];
780 props = text_property_list (this,
781 make_number (0),
782 make_number (SCHARS (this)),
783 Qnil);
784 /* If successive arguments have properties, be sure that the
785 value of `composition' property be the copy. */
786 if (last_to_end == textprops[argnum].to)
787 make_composition_value_copy (props);
788 add_text_properties_from_list (val, props,
789 make_number (textprops[argnum].to));
790 last_to_end = textprops[argnum].to + SCHARS (this);
794 SAFE_FREE ();
795 return val;
798 static Lisp_Object string_char_byte_cache_string;
799 static ptrdiff_t string_char_byte_cache_charpos;
800 static ptrdiff_t string_char_byte_cache_bytepos;
802 void
803 clear_string_char_byte_cache (void)
805 string_char_byte_cache_string = Qnil;
808 /* Return the byte index corresponding to CHAR_INDEX in STRING. */
810 ptrdiff_t
811 string_char_to_byte (Lisp_Object string, ptrdiff_t char_index)
813 ptrdiff_t i_byte;
814 ptrdiff_t best_below, best_below_byte;
815 ptrdiff_t best_above, best_above_byte;
817 best_below = best_below_byte = 0;
818 best_above = SCHARS (string);
819 best_above_byte = SBYTES (string);
820 if (best_above == best_above_byte)
821 return char_index;
823 if (EQ (string, string_char_byte_cache_string))
825 if (string_char_byte_cache_charpos < char_index)
827 best_below = string_char_byte_cache_charpos;
828 best_below_byte = string_char_byte_cache_bytepos;
830 else
832 best_above = string_char_byte_cache_charpos;
833 best_above_byte = string_char_byte_cache_bytepos;
837 if (char_index - best_below < best_above - char_index)
839 unsigned char *p = SDATA (string) + best_below_byte;
841 while (best_below < char_index)
843 p += BYTES_BY_CHAR_HEAD (*p);
844 best_below++;
846 i_byte = p - SDATA (string);
848 else
850 unsigned char *p = SDATA (string) + best_above_byte;
852 while (best_above > char_index)
854 p--;
855 while (!CHAR_HEAD_P (*p)) p--;
856 best_above--;
858 i_byte = p - SDATA (string);
861 string_char_byte_cache_bytepos = i_byte;
862 string_char_byte_cache_charpos = char_index;
863 string_char_byte_cache_string = string;
865 return i_byte;
868 /* Return the character index corresponding to BYTE_INDEX in STRING. */
870 ptrdiff_t
871 string_byte_to_char (Lisp_Object string, ptrdiff_t byte_index)
873 ptrdiff_t i, i_byte;
874 ptrdiff_t best_below, best_below_byte;
875 ptrdiff_t best_above, best_above_byte;
877 best_below = best_below_byte = 0;
878 best_above = SCHARS (string);
879 best_above_byte = SBYTES (string);
880 if (best_above == best_above_byte)
881 return byte_index;
883 if (EQ (string, string_char_byte_cache_string))
885 if (string_char_byte_cache_bytepos < byte_index)
887 best_below = string_char_byte_cache_charpos;
888 best_below_byte = string_char_byte_cache_bytepos;
890 else
892 best_above = string_char_byte_cache_charpos;
893 best_above_byte = string_char_byte_cache_bytepos;
897 if (byte_index - best_below_byte < best_above_byte - byte_index)
899 unsigned char *p = SDATA (string) + best_below_byte;
900 unsigned char *pend = SDATA (string) + byte_index;
902 while (p < pend)
904 p += BYTES_BY_CHAR_HEAD (*p);
905 best_below++;
907 i = best_below;
908 i_byte = p - SDATA (string);
910 else
912 unsigned char *p = SDATA (string) + best_above_byte;
913 unsigned char *pbeg = SDATA (string) + byte_index;
915 while (p > pbeg)
917 p--;
918 while (!CHAR_HEAD_P (*p)) p--;
919 best_above--;
921 i = best_above;
922 i_byte = p - SDATA (string);
925 string_char_byte_cache_bytepos = i_byte;
926 string_char_byte_cache_charpos = i;
927 string_char_byte_cache_string = string;
929 return i;
932 /* Convert STRING to a multibyte string. */
934 static Lisp_Object
935 string_make_multibyte (Lisp_Object string)
937 unsigned char *buf;
938 ptrdiff_t nbytes;
939 Lisp_Object ret;
940 USE_SAFE_ALLOCA;
942 if (STRING_MULTIBYTE (string))
943 return string;
945 nbytes = count_size_as_multibyte (SDATA (string),
946 SCHARS (string));
947 /* If all the chars are ASCII, they won't need any more bytes
948 once converted. In that case, we can return STRING itself. */
949 if (nbytes == SBYTES (string))
950 return string;
952 buf = SAFE_ALLOCA (nbytes);
953 copy_text (SDATA (string), buf, SBYTES (string),
954 0, 1);
956 ret = make_multibyte_string ((char *) buf, SCHARS (string), nbytes);
957 SAFE_FREE ();
959 return ret;
963 /* Convert STRING (if unibyte) to a multibyte string without changing
964 the number of characters. Characters 0200 trough 0237 are
965 converted to eight-bit characters. */
967 Lisp_Object
968 string_to_multibyte (Lisp_Object string)
970 unsigned char *buf;
971 ptrdiff_t nbytes;
972 Lisp_Object ret;
973 USE_SAFE_ALLOCA;
975 if (STRING_MULTIBYTE (string))
976 return string;
978 nbytes = count_size_as_multibyte (SDATA (string), SBYTES (string));
979 /* If all the chars are ASCII, they won't need any more bytes once
980 converted. */
981 if (nbytes == SBYTES (string))
982 return make_multibyte_string (SSDATA (string), nbytes, nbytes);
984 buf = SAFE_ALLOCA (nbytes);
985 memcpy (buf, SDATA (string), SBYTES (string));
986 str_to_multibyte (buf, nbytes, SBYTES (string));
988 ret = make_multibyte_string ((char *) buf, SCHARS (string), nbytes);
989 SAFE_FREE ();
991 return ret;
995 /* Convert STRING to a single-byte string. */
997 Lisp_Object
998 string_make_unibyte (Lisp_Object string)
1000 ptrdiff_t nchars;
1001 unsigned char *buf;
1002 Lisp_Object ret;
1003 USE_SAFE_ALLOCA;
1005 if (! STRING_MULTIBYTE (string))
1006 return string;
1008 nchars = SCHARS (string);
1010 buf = SAFE_ALLOCA (nchars);
1011 copy_text (SDATA (string), buf, SBYTES (string),
1012 1, 0);
1014 ret = make_unibyte_string ((char *) buf, nchars);
1015 SAFE_FREE ();
1017 return ret;
1020 DEFUN ("string-make-multibyte", Fstring_make_multibyte, Sstring_make_multibyte,
1021 1, 1, 0,
1022 doc: /* Return the multibyte equivalent of STRING.
1023 If STRING is unibyte and contains non-ASCII characters, the function
1024 `unibyte-char-to-multibyte' is used to convert each unibyte character
1025 to a multibyte character. In this case, the returned string is a
1026 newly created string with no text properties. If STRING is multibyte
1027 or entirely ASCII, it is returned unchanged. In particular, when
1028 STRING is unibyte and entirely ASCII, the returned string is unibyte.
1029 \(When the characters are all ASCII, Emacs primitives will treat the
1030 string the same way whether it is unibyte or multibyte.) */)
1031 (Lisp_Object string)
1033 CHECK_STRING (string);
1035 return string_make_multibyte (string);
1038 DEFUN ("string-make-unibyte", Fstring_make_unibyte, Sstring_make_unibyte,
1039 1, 1, 0,
1040 doc: /* Return the unibyte equivalent of STRING.
1041 Multibyte character codes are converted to unibyte according to
1042 `nonascii-translation-table' or, if that is nil, `nonascii-insert-offset'.
1043 If the lookup in the translation table fails, this function takes just
1044 the low 8 bits of each character. */)
1045 (Lisp_Object string)
1047 CHECK_STRING (string);
1049 return string_make_unibyte (string);
1052 DEFUN ("string-as-unibyte", Fstring_as_unibyte, Sstring_as_unibyte,
1053 1, 1, 0,
1054 doc: /* Return a unibyte string with the same individual bytes as STRING.
1055 If STRING is unibyte, the result is STRING itself.
1056 Otherwise it is a newly created string, with no text properties.
1057 If STRING is multibyte and contains a character of charset
1058 `eight-bit', it is converted to the corresponding single byte. */)
1059 (Lisp_Object string)
1061 CHECK_STRING (string);
1063 if (STRING_MULTIBYTE (string))
1065 unsigned char *str = (unsigned char *) xlispstrdup (string);
1066 ptrdiff_t bytes = str_as_unibyte (str, SBYTES (string));
1068 string = make_unibyte_string ((char *) str, bytes);
1069 xfree (str);
1071 return string;
1074 DEFUN ("string-as-multibyte", Fstring_as_multibyte, Sstring_as_multibyte,
1075 1, 1, 0,
1076 doc: /* Return a multibyte string with the same individual bytes as STRING.
1077 If STRING is multibyte, the result is STRING itself.
1078 Otherwise it is a newly created string, with no text properties.
1080 If STRING is unibyte and contains an individual 8-bit byte (i.e. not
1081 part of a correct utf-8 sequence), it is converted to the corresponding
1082 multibyte character of charset `eight-bit'.
1083 See also `string-to-multibyte'.
1085 Beware, this often doesn't really do what you think it does.
1086 It is similar to (decode-coding-string STRING 'utf-8-emacs).
1087 If you're not sure, whether to use `string-as-multibyte' or
1088 `string-to-multibyte', use `string-to-multibyte'. */)
1089 (Lisp_Object string)
1091 CHECK_STRING (string);
1093 if (! STRING_MULTIBYTE (string))
1095 Lisp_Object new_string;
1096 ptrdiff_t nchars, nbytes;
1098 parse_str_as_multibyte (SDATA (string),
1099 SBYTES (string),
1100 &nchars, &nbytes);
1101 new_string = make_uninit_multibyte_string (nchars, nbytes);
1102 memcpy (SDATA (new_string), SDATA (string), SBYTES (string));
1103 if (nbytes != SBYTES (string))
1104 str_as_multibyte (SDATA (new_string), nbytes,
1105 SBYTES (string), NULL);
1106 string = new_string;
1107 set_string_intervals (string, NULL);
1109 return string;
1112 DEFUN ("string-to-multibyte", Fstring_to_multibyte, Sstring_to_multibyte,
1113 1, 1, 0,
1114 doc: /* Return a multibyte string with the same individual chars as STRING.
1115 If STRING is multibyte, the result is STRING itself.
1116 Otherwise it is a newly created string, with no text properties.
1118 If STRING is unibyte and contains an 8-bit byte, it is converted to
1119 the corresponding multibyte character of charset `eight-bit'.
1121 This differs from `string-as-multibyte' by converting each byte of a correct
1122 utf-8 sequence to an eight-bit character, not just bytes that don't form a
1123 correct sequence. */)
1124 (Lisp_Object string)
1126 CHECK_STRING (string);
1128 return string_to_multibyte (string);
1131 DEFUN ("string-to-unibyte", Fstring_to_unibyte, Sstring_to_unibyte,
1132 1, 1, 0,
1133 doc: /* Return a unibyte string with the same individual chars as STRING.
1134 If STRING is unibyte, the result is STRING itself.
1135 Otherwise it is a newly created string, with no text properties,
1136 where each `eight-bit' character is converted to the corresponding byte.
1137 If STRING contains a non-ASCII, non-`eight-bit' character,
1138 an error is signaled. */)
1139 (Lisp_Object string)
1141 CHECK_STRING (string);
1143 if (STRING_MULTIBYTE (string))
1145 ptrdiff_t chars = SCHARS (string);
1146 unsigned char *str = xmalloc (chars);
1147 ptrdiff_t converted = str_to_unibyte (SDATA (string), str, chars);
1149 if (converted < chars)
1150 error ("Can't convert the %"pD"dth character to unibyte", converted);
1151 string = make_unibyte_string ((char *) str, chars);
1152 xfree (str);
1154 return string;
1158 DEFUN ("copy-alist", Fcopy_alist, Scopy_alist, 1, 1, 0,
1159 doc: /* Return a copy of ALIST.
1160 This is an alist which represents the same mapping from objects to objects,
1161 but does not share the alist structure with ALIST.
1162 The objects mapped (cars and cdrs of elements of the alist)
1163 are shared, however.
1164 Elements of ALIST that are not conses are also shared. */)
1165 (Lisp_Object alist)
1167 register Lisp_Object tem;
1169 CHECK_LIST (alist);
1170 if (NILP (alist))
1171 return alist;
1172 alist = concat (1, &alist, Lisp_Cons, 0);
1173 for (tem = alist; CONSP (tem); tem = XCDR (tem))
1175 register Lisp_Object car;
1176 car = XCAR (tem);
1178 if (CONSP (car))
1179 XSETCAR (tem, Fcons (XCAR (car), XCDR (car)));
1181 return alist;
1184 /* Check that ARRAY can have a valid subarray [FROM..TO),
1185 given that its size is SIZE.
1186 If FROM is nil, use 0; if TO is nil, use SIZE.
1187 Count negative values backwards from the end.
1188 Set *IFROM and *ITO to the two indexes used. */
1190 void
1191 validate_subarray (Lisp_Object array, Lisp_Object from, Lisp_Object to,
1192 ptrdiff_t size, ptrdiff_t *ifrom, ptrdiff_t *ito)
1194 EMACS_INT f, t;
1196 if (INTEGERP (from))
1198 f = XINT (from);
1199 if (f < 0)
1200 f += size;
1202 else if (NILP (from))
1203 f = 0;
1204 else
1205 wrong_type_argument (Qintegerp, from);
1207 if (INTEGERP (to))
1209 t = XINT (to);
1210 if (t < 0)
1211 t += size;
1213 else if (NILP (to))
1214 t = size;
1215 else
1216 wrong_type_argument (Qintegerp, to);
1218 if (! (0 <= f && f <= t && t <= size))
1219 args_out_of_range_3 (array, from, to);
1221 *ifrom = f;
1222 *ito = t;
1225 DEFUN ("substring", Fsubstring, Ssubstring, 1, 3, 0,
1226 doc: /* Return a new string whose contents are a substring of STRING.
1227 The returned string consists of the characters between index FROM
1228 \(inclusive) and index TO (exclusive) of STRING. FROM and TO are
1229 zero-indexed: 0 means the first character of STRING. Negative values
1230 are counted from the end of STRING. If TO is nil, the substring runs
1231 to the end of STRING.
1233 The STRING argument may also be a vector. In that case, the return
1234 value is a new vector that contains the elements between index FROM
1235 \(inclusive) and index TO (exclusive) of that vector argument.
1237 With one argument, just copy STRING (with properties, if any). */)
1238 (Lisp_Object string, Lisp_Object from, Lisp_Object to)
1240 Lisp_Object res;
1241 ptrdiff_t size, ifrom, ito;
1243 size = CHECK_VECTOR_OR_STRING (string);
1244 validate_subarray (string, from, to, size, &ifrom, &ito);
1246 if (STRINGP (string))
1248 ptrdiff_t from_byte
1249 = !ifrom ? 0 : string_char_to_byte (string, ifrom);
1250 ptrdiff_t to_byte
1251 = ito == size ? SBYTES (string) : string_char_to_byte (string, ito);
1252 res = make_specified_string (SSDATA (string) + from_byte,
1253 ito - ifrom, to_byte - from_byte,
1254 STRING_MULTIBYTE (string));
1255 copy_text_properties (make_number (ifrom), make_number (ito),
1256 string, make_number (0), res, Qnil);
1258 else
1259 res = Fvector (ito - ifrom, aref_addr (string, ifrom));
1261 return res;
1265 DEFUN ("substring-no-properties", Fsubstring_no_properties, Ssubstring_no_properties, 1, 3, 0,
1266 doc: /* Return a substring of STRING, without text properties.
1267 It starts at index FROM and ends before TO.
1268 TO may be nil or omitted; then the substring runs to the end of STRING.
1269 If FROM is nil or omitted, the substring starts at the beginning of STRING.
1270 If FROM or TO is negative, it counts from the end.
1272 With one argument, just copy STRING without its properties. */)
1273 (Lisp_Object string, register Lisp_Object from, Lisp_Object to)
1275 ptrdiff_t from_char, to_char, from_byte, to_byte, size;
1277 CHECK_STRING (string);
1279 size = SCHARS (string);
1280 validate_subarray (string, from, to, size, &from_char, &to_char);
1282 from_byte = !from_char ? 0 : string_char_to_byte (string, from_char);
1283 to_byte =
1284 to_char == size ? SBYTES (string) : string_char_to_byte (string, to_char);
1285 return make_specified_string (SSDATA (string) + from_byte,
1286 to_char - from_char, to_byte - from_byte,
1287 STRING_MULTIBYTE (string));
1290 /* Extract a substring of STRING, giving start and end positions
1291 both in characters and in bytes. */
1293 Lisp_Object
1294 substring_both (Lisp_Object string, ptrdiff_t from, ptrdiff_t from_byte,
1295 ptrdiff_t to, ptrdiff_t to_byte)
1297 Lisp_Object res;
1298 ptrdiff_t size = CHECK_VECTOR_OR_STRING (string);
1300 if (!(0 <= from && from <= to && to <= size))
1301 args_out_of_range_3 (string, make_number (from), make_number (to));
1303 if (STRINGP (string))
1305 res = make_specified_string (SSDATA (string) + from_byte,
1306 to - from, to_byte - from_byte,
1307 STRING_MULTIBYTE (string));
1308 copy_text_properties (make_number (from), make_number (to),
1309 string, make_number (0), res, Qnil);
1311 else
1312 res = Fvector (to - from, aref_addr (string, from));
1314 return res;
1317 DEFUN ("nthcdr", Fnthcdr, Snthcdr, 2, 2, 0,
1318 doc: /* Take cdr N times on LIST, return the result. */)
1319 (Lisp_Object n, Lisp_Object list)
1321 EMACS_INT i, num;
1322 CHECK_NUMBER (n);
1323 num = XINT (n);
1324 for (i = 0; i < num && !NILP (list); i++)
1326 QUIT;
1327 CHECK_LIST_CONS (list, list);
1328 list = XCDR (list);
1330 return list;
1333 DEFUN ("nth", Fnth, Snth, 2, 2, 0,
1334 doc: /* Return the Nth element of LIST.
1335 N counts from zero. If LIST is not that long, nil is returned. */)
1336 (Lisp_Object n, Lisp_Object list)
1338 return Fcar (Fnthcdr (n, list));
1341 DEFUN ("elt", Felt, Selt, 2, 2, 0,
1342 doc: /* Return element of SEQUENCE at index N. */)
1343 (register Lisp_Object sequence, Lisp_Object n)
1345 CHECK_NUMBER (n);
1346 if (CONSP (sequence) || NILP (sequence))
1347 return Fcar (Fnthcdr (n, sequence));
1349 /* Faref signals a "not array" error, so check here. */
1350 CHECK_ARRAY (sequence, Qsequencep);
1351 return Faref (sequence, n);
1354 DEFUN ("member", Fmember, Smember, 2, 2, 0,
1355 doc: /* Return non-nil if ELT is an element of LIST. Comparison done with `equal'.
1356 The value is actually the tail of LIST whose car is ELT. */)
1357 (register Lisp_Object elt, Lisp_Object list)
1359 register Lisp_Object tail;
1360 for (tail = list; CONSP (tail); tail = XCDR (tail))
1362 register Lisp_Object tem;
1363 CHECK_LIST_CONS (tail, list);
1364 tem = XCAR (tail);
1365 if (! NILP (Fequal (elt, tem)))
1366 return tail;
1367 QUIT;
1369 return Qnil;
1372 DEFUN ("memq", Fmemq, Smemq, 2, 2, 0,
1373 doc: /* Return non-nil if ELT is an element of LIST. Comparison done with `eq'.
1374 The value is actually the tail of LIST whose car is ELT. */)
1375 (register Lisp_Object elt, Lisp_Object list)
1377 while (1)
1379 if (!CONSP (list) || EQ (XCAR (list), elt))
1380 break;
1382 list = XCDR (list);
1383 if (!CONSP (list) || EQ (XCAR (list), elt))
1384 break;
1386 list = XCDR (list);
1387 if (!CONSP (list) || EQ (XCAR (list), elt))
1388 break;
1390 list = XCDR (list);
1391 QUIT;
1394 CHECK_LIST (list);
1395 return list;
1398 DEFUN ("memql", Fmemql, Smemql, 2, 2, 0,
1399 doc: /* Return non-nil if ELT is an element of LIST. Comparison done with `eql'.
1400 The value is actually the tail of LIST whose car is ELT. */)
1401 (register Lisp_Object elt, Lisp_Object list)
1403 register Lisp_Object tail;
1405 if (!FLOATP (elt))
1406 return Fmemq (elt, list);
1408 for (tail = list; CONSP (tail); tail = XCDR (tail))
1410 register Lisp_Object tem;
1411 CHECK_LIST_CONS (tail, list);
1412 tem = XCAR (tail);
1413 if (FLOATP (tem) && internal_equal (elt, tem, 0, 0, Qnil))
1414 return tail;
1415 QUIT;
1417 return Qnil;
1420 DEFUN ("assq", Fassq, Sassq, 2, 2, 0,
1421 doc: /* Return non-nil if KEY is `eq' to the car of an element of LIST.
1422 The value is actually the first element of LIST whose car is KEY.
1423 Elements of LIST that are not conses are ignored. */)
1424 (Lisp_Object key, Lisp_Object list)
1426 while (1)
1428 if (!CONSP (list)
1429 || (CONSP (XCAR (list))
1430 && EQ (XCAR (XCAR (list)), key)))
1431 break;
1433 list = XCDR (list);
1434 if (!CONSP (list)
1435 || (CONSP (XCAR (list))
1436 && EQ (XCAR (XCAR (list)), key)))
1437 break;
1439 list = XCDR (list);
1440 if (!CONSP (list)
1441 || (CONSP (XCAR (list))
1442 && EQ (XCAR (XCAR (list)), key)))
1443 break;
1445 list = XCDR (list);
1446 QUIT;
1449 return CAR (list);
1452 /* Like Fassq but never report an error and do not allow quits.
1453 Use only on lists known never to be circular. */
1455 Lisp_Object
1456 assq_no_quit (Lisp_Object key, Lisp_Object list)
1458 while (CONSP (list)
1459 && (!CONSP (XCAR (list))
1460 || !EQ (XCAR (XCAR (list)), key)))
1461 list = XCDR (list);
1463 return CAR_SAFE (list);
1466 DEFUN ("assoc", Fassoc, Sassoc, 2, 2, 0,
1467 doc: /* Return non-nil if KEY is `equal' to the car of an element of LIST.
1468 The value is actually the first element of LIST whose car equals KEY. */)
1469 (Lisp_Object key, Lisp_Object list)
1471 Lisp_Object car;
1473 while (1)
1475 if (!CONSP (list)
1476 || (CONSP (XCAR (list))
1477 && (car = XCAR (XCAR (list)),
1478 EQ (car, key) || !NILP (Fequal (car, key)))))
1479 break;
1481 list = XCDR (list);
1482 if (!CONSP (list)
1483 || (CONSP (XCAR (list))
1484 && (car = XCAR (XCAR (list)),
1485 EQ (car, key) || !NILP (Fequal (car, key)))))
1486 break;
1488 list = XCDR (list);
1489 if (!CONSP (list)
1490 || (CONSP (XCAR (list))
1491 && (car = XCAR (XCAR (list)),
1492 EQ (car, key) || !NILP (Fequal (car, key)))))
1493 break;
1495 list = XCDR (list);
1496 QUIT;
1499 return CAR (list);
1502 /* Like Fassoc but never report an error and do not allow quits.
1503 Use only on lists known never to be circular. */
1505 Lisp_Object
1506 assoc_no_quit (Lisp_Object key, Lisp_Object list)
1508 while (CONSP (list)
1509 && (!CONSP (XCAR (list))
1510 || (!EQ (XCAR (XCAR (list)), key)
1511 && NILP (Fequal (XCAR (XCAR (list)), key)))))
1512 list = XCDR (list);
1514 return CONSP (list) ? XCAR (list) : Qnil;
1517 DEFUN ("rassq", Frassq, Srassq, 2, 2, 0,
1518 doc: /* Return non-nil if KEY is `eq' to the cdr of an element of LIST.
1519 The value is actually the first element of LIST whose cdr is KEY. */)
1520 (register Lisp_Object key, Lisp_Object list)
1522 while (1)
1524 if (!CONSP (list)
1525 || (CONSP (XCAR (list))
1526 && EQ (XCDR (XCAR (list)), key)))
1527 break;
1529 list = XCDR (list);
1530 if (!CONSP (list)
1531 || (CONSP (XCAR (list))
1532 && EQ (XCDR (XCAR (list)), key)))
1533 break;
1535 list = XCDR (list);
1536 if (!CONSP (list)
1537 || (CONSP (XCAR (list))
1538 && EQ (XCDR (XCAR (list)), key)))
1539 break;
1541 list = XCDR (list);
1542 QUIT;
1545 return CAR (list);
1548 DEFUN ("rassoc", Frassoc, Srassoc, 2, 2, 0,
1549 doc: /* Return non-nil if KEY is `equal' to the cdr of an element of LIST.
1550 The value is actually the first element of LIST whose cdr equals KEY. */)
1551 (Lisp_Object key, Lisp_Object list)
1553 Lisp_Object cdr;
1555 while (1)
1557 if (!CONSP (list)
1558 || (CONSP (XCAR (list))
1559 && (cdr = XCDR (XCAR (list)),
1560 EQ (cdr, key) || !NILP (Fequal (cdr, key)))))
1561 break;
1563 list = XCDR (list);
1564 if (!CONSP (list)
1565 || (CONSP (XCAR (list))
1566 && (cdr = XCDR (XCAR (list)),
1567 EQ (cdr, key) || !NILP (Fequal (cdr, key)))))
1568 break;
1570 list = XCDR (list);
1571 if (!CONSP (list)
1572 || (CONSP (XCAR (list))
1573 && (cdr = XCDR (XCAR (list)),
1574 EQ (cdr, key) || !NILP (Fequal (cdr, key)))))
1575 break;
1577 list = XCDR (list);
1578 QUIT;
1581 return CAR (list);
1584 DEFUN ("delq", Fdelq, Sdelq, 2, 2, 0,
1585 doc: /* Delete members of LIST which are `eq' to ELT, and return the result.
1586 More precisely, this function skips any members `eq' to ELT at the
1587 front of LIST, then removes members `eq' to ELT from the remaining
1588 sublist by modifying its list structure, then returns the resulting
1589 list.
1591 Write `(setq foo (delq element foo))' to be sure of correctly changing
1592 the value of a list `foo'. */)
1593 (register Lisp_Object elt, Lisp_Object list)
1595 Lisp_Object tail, tortoise, prev = Qnil;
1596 bool skip;
1598 FOR_EACH_TAIL (tail, list, tortoise, skip)
1600 Lisp_Object tem = XCAR (tail);
1601 if (EQ (elt, tem))
1603 if (NILP (prev))
1604 list = XCDR (tail);
1605 else
1606 Fsetcdr (prev, XCDR (tail));
1608 else
1609 prev = tail;
1611 return list;
1614 DEFUN ("delete", Fdelete, Sdelete, 2, 2, 0,
1615 doc: /* Delete members of SEQ which are `equal' to ELT, and return the result.
1616 SEQ must be a sequence (i.e. a list, a vector, or a string).
1617 The return value is a sequence of the same type.
1619 If SEQ is a list, this behaves like `delq', except that it compares
1620 with `equal' instead of `eq'. In particular, it may remove elements
1621 by altering the list structure.
1623 If SEQ is not a list, deletion is never performed destructively;
1624 instead this function creates and returns a new vector or string.
1626 Write `(setq foo (delete element foo))' to be sure of correctly
1627 changing the value of a sequence `foo'. */)
1628 (Lisp_Object elt, Lisp_Object seq)
1630 if (VECTORP (seq))
1632 ptrdiff_t i, n;
1634 for (i = n = 0; i < ASIZE (seq); ++i)
1635 if (NILP (Fequal (AREF (seq, i), elt)))
1636 ++n;
1638 if (n != ASIZE (seq))
1640 struct Lisp_Vector *p = allocate_vector (n);
1642 for (i = n = 0; i < ASIZE (seq); ++i)
1643 if (NILP (Fequal (AREF (seq, i), elt)))
1644 p->contents[n++] = AREF (seq, i);
1646 XSETVECTOR (seq, p);
1649 else if (STRINGP (seq))
1651 ptrdiff_t i, ibyte, nchars, nbytes, cbytes;
1652 int c;
1654 for (i = nchars = nbytes = ibyte = 0;
1655 i < SCHARS (seq);
1656 ++i, ibyte += cbytes)
1658 if (STRING_MULTIBYTE (seq))
1660 c = STRING_CHAR (SDATA (seq) + ibyte);
1661 cbytes = CHAR_BYTES (c);
1663 else
1665 c = SREF (seq, i);
1666 cbytes = 1;
1669 if (!INTEGERP (elt) || c != XINT (elt))
1671 ++nchars;
1672 nbytes += cbytes;
1676 if (nchars != SCHARS (seq))
1678 Lisp_Object tem;
1680 tem = make_uninit_multibyte_string (nchars, nbytes);
1681 if (!STRING_MULTIBYTE (seq))
1682 STRING_SET_UNIBYTE (tem);
1684 for (i = nchars = nbytes = ibyte = 0;
1685 i < SCHARS (seq);
1686 ++i, ibyte += cbytes)
1688 if (STRING_MULTIBYTE (seq))
1690 c = STRING_CHAR (SDATA (seq) + ibyte);
1691 cbytes = CHAR_BYTES (c);
1693 else
1695 c = SREF (seq, i);
1696 cbytes = 1;
1699 if (!INTEGERP (elt) || c != XINT (elt))
1701 unsigned char *from = SDATA (seq) + ibyte;
1702 unsigned char *to = SDATA (tem) + nbytes;
1703 ptrdiff_t n;
1705 ++nchars;
1706 nbytes += cbytes;
1708 for (n = cbytes; n--; )
1709 *to++ = *from++;
1713 seq = tem;
1716 else
1718 Lisp_Object tail, prev;
1720 for (tail = seq, prev = Qnil; CONSP (tail); tail = XCDR (tail))
1722 CHECK_LIST_CONS (tail, seq);
1724 if (!NILP (Fequal (elt, XCAR (tail))))
1726 if (NILP (prev))
1727 seq = XCDR (tail);
1728 else
1729 Fsetcdr (prev, XCDR (tail));
1731 else
1732 prev = tail;
1733 QUIT;
1737 return seq;
1740 DEFUN ("nreverse", Fnreverse, Snreverse, 1, 1, 0,
1741 doc: /* Reverse order of items in a list, vector or string SEQ.
1742 If SEQ is a list, it should be nil-terminated.
1743 This function may destructively modify SEQ to produce the value. */)
1744 (Lisp_Object seq)
1746 if (NILP (seq))
1747 return seq;
1748 else if (STRINGP (seq))
1749 return Freverse (seq);
1750 else if (CONSP (seq))
1752 Lisp_Object prev, tail, next;
1754 for (prev = Qnil, tail = seq; !NILP (tail); tail = next)
1756 QUIT;
1757 CHECK_LIST_CONS (tail, tail);
1758 next = XCDR (tail);
1759 Fsetcdr (tail, prev);
1760 prev = tail;
1762 seq = prev;
1764 else if (VECTORP (seq))
1766 ptrdiff_t i, size = ASIZE (seq);
1768 for (i = 0; i < size / 2; i++)
1770 Lisp_Object tem = AREF (seq, i);
1771 ASET (seq, i, AREF (seq, size - i - 1));
1772 ASET (seq, size - i - 1, tem);
1775 else if (BOOL_VECTOR_P (seq))
1777 ptrdiff_t i, size = bool_vector_size (seq);
1779 for (i = 0; i < size / 2; i++)
1781 bool tem = bool_vector_bitref (seq, i);
1782 bool_vector_set (seq, i, bool_vector_bitref (seq, size - i - 1));
1783 bool_vector_set (seq, size - i - 1, tem);
1786 else
1787 wrong_type_argument (Qarrayp, seq);
1788 return seq;
1791 DEFUN ("reverse", Freverse, Sreverse, 1, 1, 0,
1792 doc: /* Return the reversed copy of list, vector, or string SEQ.
1793 See also the function `nreverse', which is used more often. */)
1794 (Lisp_Object seq)
1796 Lisp_Object new;
1798 if (NILP (seq))
1799 return Qnil;
1800 else if (CONSP (seq))
1802 for (new = Qnil; CONSP (seq); seq = XCDR (seq))
1804 QUIT;
1805 new = Fcons (XCAR (seq), new);
1807 CHECK_LIST_END (seq, seq);
1809 else if (VECTORP (seq))
1811 ptrdiff_t i, size = ASIZE (seq);
1813 new = make_uninit_vector (size);
1814 for (i = 0; i < size; i++)
1815 ASET (new, i, AREF (seq, size - i - 1));
1817 else if (BOOL_VECTOR_P (seq))
1819 ptrdiff_t i;
1820 EMACS_INT nbits = bool_vector_size (seq);
1822 new = make_uninit_bool_vector (nbits);
1823 for (i = 0; i < nbits; i++)
1824 bool_vector_set (new, i, bool_vector_bitref (seq, nbits - i - 1));
1826 else if (STRINGP (seq))
1828 ptrdiff_t size = SCHARS (seq), bytes = SBYTES (seq);
1830 if (size == bytes)
1832 ptrdiff_t i;
1834 new = make_uninit_string (size);
1835 for (i = 0; i < size; i++)
1836 SSET (new, i, SREF (seq, size - i - 1));
1838 else
1840 unsigned char *p, *q;
1842 new = make_uninit_multibyte_string (size, bytes);
1843 p = SDATA (seq), q = SDATA (new) + bytes;
1844 while (q > SDATA (new))
1846 int ch, len;
1848 ch = STRING_CHAR_AND_LENGTH (p, len);
1849 p += len, q -= len;
1850 CHAR_STRING (ch, q);
1854 else
1855 wrong_type_argument (Qsequencep, seq);
1856 return new;
1859 /* Sort LIST using PREDICATE, preserving original order of elements
1860 considered as equal. */
1862 static Lisp_Object
1863 sort_list (Lisp_Object list, Lisp_Object predicate)
1865 Lisp_Object front, back;
1866 register Lisp_Object len, tem;
1867 struct gcpro gcpro1, gcpro2;
1868 EMACS_INT length;
1870 front = list;
1871 len = Flength (list);
1872 length = XINT (len);
1873 if (length < 2)
1874 return list;
1876 XSETINT (len, (length / 2) - 1);
1877 tem = Fnthcdr (len, list);
1878 back = Fcdr (tem);
1879 Fsetcdr (tem, Qnil);
1881 GCPRO2 (front, back);
1882 front = Fsort (front, predicate);
1883 back = Fsort (back, predicate);
1884 UNGCPRO;
1885 return merge (front, back, predicate);
1888 /* Using PRED to compare, return whether A and B are in order.
1889 Compare stably when A appeared before B in the input. */
1890 static bool
1891 inorder (Lisp_Object pred, Lisp_Object a, Lisp_Object b)
1893 return NILP (call2 (pred, b, a));
1896 /* Using PRED to compare, merge from ALEN-length A and BLEN-length B
1897 into DEST. Argument arrays must be nonempty and must not overlap,
1898 except that B might be the last part of DEST. */
1899 static void
1900 merge_vectors (Lisp_Object pred,
1901 ptrdiff_t alen, Lisp_Object const a[restrict VLA_ELEMS (alen)],
1902 ptrdiff_t blen, Lisp_Object const b[VLA_ELEMS (blen)],
1903 Lisp_Object dest[VLA_ELEMS (alen + blen)])
1905 eassume (0 < alen && 0 < blen);
1906 Lisp_Object const *alim = a + alen;
1907 Lisp_Object const *blim = b + blen;
1909 while (true)
1911 if (inorder (pred, a[0], b[0]))
1913 *dest++ = *a++;
1914 if (a == alim)
1916 if (dest != b)
1917 memcpy (dest, b, (blim - b) * sizeof *dest);
1918 return;
1921 else
1923 *dest++ = *b++;
1924 if (b == blim)
1926 memcpy (dest, a, (alim - a) * sizeof *dest);
1927 return;
1933 /* Using PRED to compare, sort LEN-length VEC in place, using TMP for
1934 temporary storage. LEN must be at least 2. */
1935 static void
1936 sort_vector_inplace (Lisp_Object pred, ptrdiff_t len,
1937 Lisp_Object vec[restrict VLA_ELEMS (len)],
1938 Lisp_Object tmp[restrict VLA_ELEMS (len >> 1)])
1940 eassume (2 <= len);
1941 ptrdiff_t halflen = len >> 1;
1942 sort_vector_copy (pred, halflen, vec, tmp);
1943 if (1 < len - halflen)
1944 sort_vector_inplace (pred, len - halflen, vec + halflen, vec);
1945 merge_vectors (pred, halflen, tmp, len - halflen, vec + halflen, vec);
1948 /* Using PRED to compare, sort from LEN-length SRC into DST.
1949 Len must be positive. */
1950 static void
1951 sort_vector_copy (Lisp_Object pred, ptrdiff_t len,
1952 Lisp_Object src[restrict VLA_ELEMS (len)],
1953 Lisp_Object dest[restrict VLA_ELEMS (len)])
1955 eassume (0 < len);
1956 ptrdiff_t halflen = len >> 1;
1957 if (halflen < 1)
1958 dest[0] = src[0];
1959 else
1961 if (1 < halflen)
1962 sort_vector_inplace (pred, halflen, src, dest);
1963 if (1 < len - halflen)
1964 sort_vector_inplace (pred, len - halflen, src + halflen, dest);
1965 merge_vectors (pred, halflen, src, len - halflen, src + halflen, dest);
1969 /* Sort VECTOR in place using PREDICATE, preserving original order of
1970 elements considered as equal. */
1972 static void
1973 sort_vector (Lisp_Object vector, Lisp_Object predicate)
1975 ptrdiff_t len = ASIZE (vector);
1976 if (len < 2)
1977 return;
1978 ptrdiff_t halflen = len >> 1;
1979 Lisp_Object *tmp;
1980 struct gcpro gcpro1, gcpro2;
1981 GCPRO2 (vector, predicate);
1982 USE_SAFE_ALLOCA;
1983 SAFE_ALLOCA_LISP (tmp, halflen);
1984 for (ptrdiff_t i = 0; i < halflen; i++)
1985 tmp[i] = make_number (0);
1986 sort_vector_inplace (predicate, len, XVECTOR (vector)->contents, tmp);
1987 SAFE_FREE ();
1988 UNGCPRO;
1991 DEFUN ("sort", Fsort, Ssort, 2, 2, 0,
1992 doc: /* Sort SEQ, stably, comparing elements using PREDICATE.
1993 Returns the sorted sequence. SEQ should be a list or vector. SEQ is
1994 modified by side effects. PREDICATE is called with two elements of
1995 SEQ, and should return non-nil if the first element should sort before
1996 the second. */)
1997 (Lisp_Object seq, Lisp_Object predicate)
1999 if (CONSP (seq))
2000 seq = sort_list (seq, predicate);
2001 else if (VECTORP (seq))
2002 sort_vector (seq, predicate);
2003 else if (!NILP (seq))
2004 wrong_type_argument (Qsequencep, seq);
2005 return seq;
2008 Lisp_Object
2009 merge (Lisp_Object org_l1, Lisp_Object org_l2, Lisp_Object pred)
2011 Lisp_Object value;
2012 register Lisp_Object tail;
2013 Lisp_Object tem;
2014 register Lisp_Object l1, l2;
2015 struct gcpro gcpro1, gcpro2, gcpro3, gcpro4;
2017 l1 = org_l1;
2018 l2 = org_l2;
2019 tail = Qnil;
2020 value = Qnil;
2022 /* It is sufficient to protect org_l1 and org_l2.
2023 When l1 and l2 are updated, we copy the new values
2024 back into the org_ vars. */
2025 GCPRO4 (org_l1, org_l2, pred, value);
2027 while (1)
2029 if (NILP (l1))
2031 UNGCPRO;
2032 if (NILP (tail))
2033 return l2;
2034 Fsetcdr (tail, l2);
2035 return value;
2037 if (NILP (l2))
2039 UNGCPRO;
2040 if (NILP (tail))
2041 return l1;
2042 Fsetcdr (tail, l1);
2043 return value;
2045 if (inorder (pred, Fcar (l1), Fcar (l2)))
2047 tem = l1;
2048 l1 = Fcdr (l1);
2049 org_l1 = l1;
2051 else
2053 tem = l2;
2054 l2 = Fcdr (l2);
2055 org_l2 = l2;
2057 if (NILP (tail))
2058 value = tem;
2059 else
2060 Fsetcdr (tail, tem);
2061 tail = tem;
2066 /* This does not check for quits. That is safe since it must terminate. */
2068 DEFUN ("plist-get", Fplist_get, Splist_get, 2, 2, 0,
2069 doc: /* Extract a value from a property list.
2070 PLIST is a property list, which is a list of the form
2071 \(PROP1 VALUE1 PROP2 VALUE2...). This function returns the value
2072 corresponding to the given PROP, or nil if PROP is not one of the
2073 properties on the list. This function never signals an error. */)
2074 (Lisp_Object plist, Lisp_Object prop)
2076 Lisp_Object tail, halftail;
2078 /* halftail is used to detect circular lists. */
2079 tail = halftail = plist;
2080 while (CONSP (tail) && CONSP (XCDR (tail)))
2082 if (EQ (prop, XCAR (tail)))
2083 return XCAR (XCDR (tail));
2085 tail = XCDR (XCDR (tail));
2086 halftail = XCDR (halftail);
2087 if (EQ (tail, halftail))
2088 break;
2091 return Qnil;
2094 DEFUN ("get", Fget, Sget, 2, 2, 0,
2095 doc: /* Return the value of SYMBOL's PROPNAME property.
2096 This is the last value stored with `(put SYMBOL PROPNAME VALUE)'. */)
2097 (Lisp_Object symbol, Lisp_Object propname)
2099 CHECK_SYMBOL (symbol);
2100 return Fplist_get (XSYMBOL (symbol)->plist, propname);
2103 DEFUN ("plist-put", Fplist_put, Splist_put, 3, 3, 0,
2104 doc: /* Change value in PLIST of PROP to VAL.
2105 PLIST is a property list, which is a list of the form
2106 \(PROP1 VALUE1 PROP2 VALUE2 ...). PROP is a symbol and VAL is any object.
2107 If PROP is already a property on the list, its value is set to VAL,
2108 otherwise the new PROP VAL pair is added. The new plist is returned;
2109 use `(setq x (plist-put x prop val))' to be sure to use the new value.
2110 The PLIST is modified by side effects. */)
2111 (Lisp_Object plist, register Lisp_Object prop, Lisp_Object val)
2113 register Lisp_Object tail, prev;
2114 Lisp_Object newcell;
2115 prev = Qnil;
2116 for (tail = plist; CONSP (tail) && CONSP (XCDR (tail));
2117 tail = XCDR (XCDR (tail)))
2119 if (EQ (prop, XCAR (tail)))
2121 Fsetcar (XCDR (tail), val);
2122 return plist;
2125 prev = tail;
2126 QUIT;
2128 newcell = Fcons (prop, Fcons (val, NILP (prev) ? plist : XCDR (XCDR (prev))));
2129 if (NILP (prev))
2130 return newcell;
2131 else
2132 Fsetcdr (XCDR (prev), newcell);
2133 return plist;
2136 DEFUN ("put", Fput, Sput, 3, 3, 0,
2137 doc: /* Store SYMBOL's PROPNAME property with value VALUE.
2138 It can be retrieved with `(get SYMBOL PROPNAME)'. */)
2139 (Lisp_Object symbol, Lisp_Object propname, Lisp_Object value)
2141 CHECK_SYMBOL (symbol);
2142 set_symbol_plist
2143 (symbol, Fplist_put (XSYMBOL (symbol)->plist, propname, value));
2144 return value;
2147 DEFUN ("lax-plist-get", Flax_plist_get, Slax_plist_get, 2, 2, 0,
2148 doc: /* Extract a value from a property list, comparing with `equal'.
2149 PLIST is a property list, which is a list of the form
2150 \(PROP1 VALUE1 PROP2 VALUE2...). This function returns the value
2151 corresponding to the given PROP, or nil if PROP is not
2152 one of the properties on the list. */)
2153 (Lisp_Object plist, Lisp_Object prop)
2155 Lisp_Object tail;
2157 for (tail = plist;
2158 CONSP (tail) && CONSP (XCDR (tail));
2159 tail = XCDR (XCDR (tail)))
2161 if (! NILP (Fequal (prop, XCAR (tail))))
2162 return XCAR (XCDR (tail));
2164 QUIT;
2167 CHECK_LIST_END (tail, prop);
2169 return Qnil;
2172 DEFUN ("lax-plist-put", Flax_plist_put, Slax_plist_put, 3, 3, 0,
2173 doc: /* Change value in PLIST of PROP to VAL, comparing with `equal'.
2174 PLIST is a property list, which is a list of the form
2175 \(PROP1 VALUE1 PROP2 VALUE2 ...). PROP and VAL are any objects.
2176 If PROP is already a property on the list, its value is set to VAL,
2177 otherwise the new PROP VAL pair is added. The new plist is returned;
2178 use `(setq x (lax-plist-put x prop val))' to be sure to use the new value.
2179 The PLIST is modified by side effects. */)
2180 (Lisp_Object plist, register Lisp_Object prop, Lisp_Object val)
2182 register Lisp_Object tail, prev;
2183 Lisp_Object newcell;
2184 prev = Qnil;
2185 for (tail = plist; CONSP (tail) && CONSP (XCDR (tail));
2186 tail = XCDR (XCDR (tail)))
2188 if (! NILP (Fequal (prop, XCAR (tail))))
2190 Fsetcar (XCDR (tail), val);
2191 return plist;
2194 prev = tail;
2195 QUIT;
2197 newcell = list2 (prop, val);
2198 if (NILP (prev))
2199 return newcell;
2200 else
2201 Fsetcdr (XCDR (prev), newcell);
2202 return plist;
2205 DEFUN ("eql", Feql, Seql, 2, 2, 0,
2206 doc: /* Return t if the two args are the same Lisp object.
2207 Floating-point numbers of equal value are `eql', but they may not be `eq'. */)
2208 (Lisp_Object obj1, Lisp_Object obj2)
2210 if (FLOATP (obj1))
2211 return internal_equal (obj1, obj2, 0, 0, Qnil) ? Qt : Qnil;
2212 else
2213 return EQ (obj1, obj2) ? Qt : Qnil;
2216 DEFUN ("equal", Fequal, Sequal, 2, 2, 0,
2217 doc: /* Return t if two Lisp objects have similar structure and contents.
2218 They must have the same data type.
2219 Conses are compared by comparing the cars and the cdrs.
2220 Vectors and strings are compared element by element.
2221 Numbers are compared by value, but integers cannot equal floats.
2222 (Use `=' if you want integers and floats to be able to be equal.)
2223 Symbols must match exactly. */)
2224 (register Lisp_Object o1, Lisp_Object o2)
2226 return internal_equal (o1, o2, 0, 0, Qnil) ? Qt : Qnil;
2229 DEFUN ("equal-including-properties", Fequal_including_properties, Sequal_including_properties, 2, 2, 0,
2230 doc: /* Return t if two Lisp objects have similar structure and contents.
2231 This is like `equal' except that it compares the text properties
2232 of strings. (`equal' ignores text properties.) */)
2233 (register Lisp_Object o1, Lisp_Object o2)
2235 return internal_equal (o1, o2, 0, 1, Qnil) ? Qt : Qnil;
2238 /* DEPTH is current depth of recursion. Signal an error if it
2239 gets too deep.
2240 PROPS means compare string text properties too. */
2242 static bool
2243 internal_equal (Lisp_Object o1, Lisp_Object o2, int depth, bool props,
2244 Lisp_Object ht)
2246 if (depth > 10)
2248 if (depth > 200)
2249 error ("Stack overflow in equal");
2250 if (NILP (ht))
2251 ht = CALLN (Fmake_hash_table, QCtest, Qeq);
2252 switch (XTYPE (o1))
2254 case Lisp_Cons: case Lisp_Misc: case Lisp_Vectorlike:
2256 struct Lisp_Hash_Table *h = XHASH_TABLE (ht);
2257 EMACS_UINT hash;
2258 ptrdiff_t i = hash_lookup (h, o1, &hash);
2259 if (i >= 0)
2260 { /* `o1' was seen already. */
2261 Lisp_Object o2s = HASH_VALUE (h, i);
2262 if (!NILP (Fmemq (o2, o2s)))
2263 return 1;
2264 else
2265 set_hash_value_slot (h, i, Fcons (o2, o2s));
2267 else
2268 hash_put (h, o1, Fcons (o2, Qnil), hash);
2270 default: ;
2274 tail_recurse:
2275 QUIT;
2276 if (EQ (o1, o2))
2277 return 1;
2278 if (XTYPE (o1) != XTYPE (o2))
2279 return 0;
2281 switch (XTYPE (o1))
2283 case Lisp_Float:
2285 double d1, d2;
2287 d1 = extract_float (o1);
2288 d2 = extract_float (o2);
2289 /* If d is a NaN, then d != d. Two NaNs should be `equal' even
2290 though they are not =. */
2291 return d1 == d2 || (d1 != d1 && d2 != d2);
2294 case Lisp_Cons:
2295 if (!internal_equal (XCAR (o1), XCAR (o2), depth + 1, props, ht))
2296 return 0;
2297 o1 = XCDR (o1);
2298 o2 = XCDR (o2);
2299 /* FIXME: This inf-loops in a circular list! */
2300 goto tail_recurse;
2302 case Lisp_Misc:
2303 if (XMISCTYPE (o1) != XMISCTYPE (o2))
2304 return 0;
2305 if (OVERLAYP (o1))
2307 if (!internal_equal (OVERLAY_START (o1), OVERLAY_START (o2),
2308 depth + 1, props, ht)
2309 || !internal_equal (OVERLAY_END (o1), OVERLAY_END (o2),
2310 depth + 1, props, ht))
2311 return 0;
2312 o1 = XOVERLAY (o1)->plist;
2313 o2 = XOVERLAY (o2)->plist;
2314 goto tail_recurse;
2316 if (MARKERP (o1))
2318 return (XMARKER (o1)->buffer == XMARKER (o2)->buffer
2319 && (XMARKER (o1)->buffer == 0
2320 || XMARKER (o1)->bytepos == XMARKER (o2)->bytepos));
2322 break;
2324 case Lisp_Vectorlike:
2326 register int i;
2327 ptrdiff_t size = ASIZE (o1);
2328 /* Pseudovectors have the type encoded in the size field, so this test
2329 actually checks that the objects have the same type as well as the
2330 same size. */
2331 if (ASIZE (o2) != size)
2332 return 0;
2333 /* Boolvectors are compared much like strings. */
2334 if (BOOL_VECTOR_P (o1))
2336 EMACS_INT size = bool_vector_size (o1);
2337 if (size != bool_vector_size (o2))
2338 return 0;
2339 if (memcmp (bool_vector_data (o1), bool_vector_data (o2),
2340 bool_vector_bytes (size)))
2341 return 0;
2342 return 1;
2344 if (WINDOW_CONFIGURATIONP (o1))
2345 return compare_window_configurations (o1, o2, 0);
2347 /* Aside from them, only true vectors, char-tables, compiled
2348 functions, and fonts (font-spec, font-entity, font-object)
2349 are sensible to compare, so eliminate the others now. */
2350 if (size & PSEUDOVECTOR_FLAG)
2352 if (((size & PVEC_TYPE_MASK) >> PSEUDOVECTOR_AREA_BITS)
2353 < PVEC_COMPILED)
2354 return 0;
2355 size &= PSEUDOVECTOR_SIZE_MASK;
2357 for (i = 0; i < size; i++)
2359 Lisp_Object v1, v2;
2360 v1 = AREF (o1, i);
2361 v2 = AREF (o2, i);
2362 if (!internal_equal (v1, v2, depth + 1, props, ht))
2363 return 0;
2365 return 1;
2367 break;
2369 case Lisp_String:
2370 if (SCHARS (o1) != SCHARS (o2))
2371 return 0;
2372 if (SBYTES (o1) != SBYTES (o2))
2373 return 0;
2374 if (memcmp (SDATA (o1), SDATA (o2), SBYTES (o1)))
2375 return 0;
2376 if (props && !compare_string_intervals (o1, o2))
2377 return 0;
2378 return 1;
2380 default:
2381 break;
2384 return 0;
2388 DEFUN ("fillarray", Ffillarray, Sfillarray, 2, 2, 0,
2389 doc: /* Store each element of ARRAY with ITEM.
2390 ARRAY is a vector, string, char-table, or bool-vector. */)
2391 (Lisp_Object array, Lisp_Object item)
2393 register ptrdiff_t size, idx;
2395 if (VECTORP (array))
2396 for (idx = 0, size = ASIZE (array); idx < size; idx++)
2397 ASET (array, idx, item);
2398 else if (CHAR_TABLE_P (array))
2400 int i;
2402 for (i = 0; i < (1 << CHARTAB_SIZE_BITS_0); i++)
2403 set_char_table_contents (array, i, item);
2404 set_char_table_defalt (array, item);
2406 else if (STRINGP (array))
2408 register unsigned char *p = SDATA (array);
2409 int charval;
2410 CHECK_CHARACTER (item);
2411 charval = XFASTINT (item);
2412 size = SCHARS (array);
2413 if (STRING_MULTIBYTE (array))
2415 unsigned char str[MAX_MULTIBYTE_LENGTH];
2416 int len = CHAR_STRING (charval, str);
2417 ptrdiff_t size_byte = SBYTES (array);
2419 if (INT_MULTIPLY_OVERFLOW (SCHARS (array), len)
2420 || SCHARS (array) * len != size_byte)
2421 error ("Attempt to change byte length of a string");
2422 for (idx = 0; idx < size_byte; idx++)
2423 *p++ = str[idx % len];
2425 else
2426 for (idx = 0; idx < size; idx++)
2427 p[idx] = charval;
2429 else if (BOOL_VECTOR_P (array))
2430 return bool_vector_fill (array, item);
2431 else
2432 wrong_type_argument (Qarrayp, array);
2433 return array;
2436 DEFUN ("clear-string", Fclear_string, Sclear_string,
2437 1, 1, 0,
2438 doc: /* Clear the contents of STRING.
2439 This makes STRING unibyte and may change its length. */)
2440 (Lisp_Object string)
2442 ptrdiff_t len;
2443 CHECK_STRING (string);
2444 len = SBYTES (string);
2445 memset (SDATA (string), 0, len);
2446 STRING_SET_CHARS (string, len);
2447 STRING_SET_UNIBYTE (string);
2448 return Qnil;
2451 /* ARGSUSED */
2452 Lisp_Object
2453 nconc2 (Lisp_Object s1, Lisp_Object s2)
2455 return CALLN (Fnconc, s1, s2);
2458 DEFUN ("nconc", Fnconc, Snconc, 0, MANY, 0,
2459 doc: /* Concatenate any number of lists by altering them.
2460 Only the last argument is not altered, and need not be a list.
2461 usage: (nconc &rest LISTS) */)
2462 (ptrdiff_t nargs, Lisp_Object *args)
2464 ptrdiff_t argnum;
2465 register Lisp_Object tail, tem, val;
2467 val = tail = Qnil;
2469 for (argnum = 0; argnum < nargs; argnum++)
2471 tem = args[argnum];
2472 if (NILP (tem)) continue;
2474 if (NILP (val))
2475 val = tem;
2477 if (argnum + 1 == nargs) break;
2479 CHECK_LIST_CONS (tem, tem);
2481 while (CONSP (tem))
2483 tail = tem;
2484 tem = XCDR (tail);
2485 QUIT;
2488 tem = args[argnum + 1];
2489 Fsetcdr (tail, tem);
2490 if (NILP (tem))
2491 args[argnum + 1] = tail;
2494 return val;
2497 /* This is the guts of all mapping functions.
2498 Apply FN to each element of SEQ, one by one,
2499 storing the results into elements of VALS, a C vector of Lisp_Objects.
2500 LENI is the length of VALS, which should also be the length of SEQ. */
2502 static void
2503 mapcar1 (EMACS_INT leni, Lisp_Object *vals, Lisp_Object fn, Lisp_Object seq)
2505 Lisp_Object tail, dummy;
2506 EMACS_INT i;
2507 struct gcpro gcpro1, gcpro2, gcpro3;
2509 if (vals)
2511 /* Don't let vals contain any garbage when GC happens. */
2512 memclear (vals, leni * word_size);
2514 GCPRO3 (dummy, fn, seq);
2515 gcpro1.var = vals;
2516 gcpro1.nvars = leni;
2518 else
2519 GCPRO2 (fn, seq);
2520 /* We need not explicitly protect `tail' because it is used only on lists, and
2521 1) lists are not relocated and 2) the list is marked via `seq' so will not
2522 be freed */
2524 if (VECTORP (seq) || COMPILEDP (seq))
2526 for (i = 0; i < leni; i++)
2528 dummy = call1 (fn, AREF (seq, i));
2529 if (vals)
2530 vals[i] = dummy;
2533 else if (BOOL_VECTOR_P (seq))
2535 for (i = 0; i < leni; i++)
2537 dummy = call1 (fn, bool_vector_ref (seq, i));
2538 if (vals)
2539 vals[i] = dummy;
2542 else if (STRINGP (seq))
2544 ptrdiff_t i_byte;
2546 for (i = 0, i_byte = 0; i < leni;)
2548 int c;
2549 ptrdiff_t i_before = i;
2551 FETCH_STRING_CHAR_ADVANCE (c, seq, i, i_byte);
2552 XSETFASTINT (dummy, c);
2553 dummy = call1 (fn, dummy);
2554 if (vals)
2555 vals[i_before] = dummy;
2558 else /* Must be a list, since Flength did not get an error */
2560 tail = seq;
2561 for (i = 0; i < leni && CONSP (tail); i++)
2563 dummy = call1 (fn, XCAR (tail));
2564 if (vals)
2565 vals[i] = dummy;
2566 tail = XCDR (tail);
2570 UNGCPRO;
2573 DEFUN ("mapconcat", Fmapconcat, Smapconcat, 3, 3, 0,
2574 doc: /* Apply FUNCTION to each element of SEQUENCE, and concat the results as strings.
2575 In between each pair of results, stick in SEPARATOR. Thus, " " as
2576 SEPARATOR results in spaces between the values returned by FUNCTION.
2577 SEQUENCE may be a list, a vector, a bool-vector, or a string. */)
2578 (Lisp_Object function, Lisp_Object sequence, Lisp_Object separator)
2580 Lisp_Object len;
2581 register EMACS_INT leni;
2582 EMACS_INT nargs;
2583 ptrdiff_t i;
2584 register Lisp_Object *args;
2585 struct gcpro gcpro1;
2586 Lisp_Object ret;
2587 USE_SAFE_ALLOCA;
2589 len = Flength (sequence);
2590 if (CHAR_TABLE_P (sequence))
2591 wrong_type_argument (Qlistp, sequence);
2592 leni = XINT (len);
2593 nargs = leni + leni - 1;
2594 if (nargs < 0) return empty_unibyte_string;
2596 SAFE_ALLOCA_LISP (args, nargs);
2598 GCPRO1 (separator);
2599 mapcar1 (leni, args, function, sequence);
2600 UNGCPRO;
2602 for (i = leni - 1; i > 0; i--)
2603 args[i + i] = args[i];
2605 for (i = 1; i < nargs; i += 2)
2606 args[i] = separator;
2608 ret = Fconcat (nargs, args);
2609 SAFE_FREE ();
2611 return ret;
2614 DEFUN ("mapcar", Fmapcar, Smapcar, 2, 2, 0,
2615 doc: /* Apply FUNCTION to each element of SEQUENCE, and make a list of the results.
2616 The result is a list just as long as SEQUENCE.
2617 SEQUENCE may be a list, a vector, a bool-vector, or a string. */)
2618 (Lisp_Object function, Lisp_Object sequence)
2620 register Lisp_Object len;
2621 register EMACS_INT leni;
2622 register Lisp_Object *args;
2623 Lisp_Object ret;
2624 USE_SAFE_ALLOCA;
2626 len = Flength (sequence);
2627 if (CHAR_TABLE_P (sequence))
2628 wrong_type_argument (Qlistp, sequence);
2629 leni = XFASTINT (len);
2631 SAFE_ALLOCA_LISP (args, leni);
2633 mapcar1 (leni, args, function, sequence);
2635 ret = Flist (leni, args);
2636 SAFE_FREE ();
2638 return ret;
2641 DEFUN ("mapc", Fmapc, Smapc, 2, 2, 0,
2642 doc: /* Apply FUNCTION to each element of SEQUENCE for side effects only.
2643 Unlike `mapcar', don't accumulate the results. Return SEQUENCE.
2644 SEQUENCE may be a list, a vector, a bool-vector, or a string. */)
2645 (Lisp_Object function, Lisp_Object sequence)
2647 register EMACS_INT leni;
2649 leni = XFASTINT (Flength (sequence));
2650 if (CHAR_TABLE_P (sequence))
2651 wrong_type_argument (Qlistp, sequence);
2652 mapcar1 (leni, 0, function, sequence);
2654 return sequence;
2657 /* This is how C code calls `yes-or-no-p' and allows the user
2658 to redefined it.
2660 Anything that calls this function must protect from GC! */
2662 Lisp_Object
2663 do_yes_or_no_p (Lisp_Object prompt)
2665 return call1 (intern ("yes-or-no-p"), prompt);
2668 /* Anything that calls this function must protect from GC! */
2670 DEFUN ("yes-or-no-p", Fyes_or_no_p, Syes_or_no_p, 1, 1, 0,
2671 doc: /* Ask user a yes-or-no question.
2672 Return t if answer is yes, and nil if the answer is no.
2673 PROMPT is the string to display to ask the question. It should end in
2674 a space; `yes-or-no-p' adds \"(yes or no) \" to it.
2676 The user must confirm the answer with RET, and can edit it until it
2677 has been confirmed.
2679 If dialog boxes are supported, a dialog box will be used
2680 if `last-nonmenu-event' is nil, and `use-dialog-box' is non-nil. */)
2681 (Lisp_Object prompt)
2683 Lisp_Object ans;
2684 struct gcpro gcpro1;
2686 CHECK_STRING (prompt);
2688 if ((NILP (last_nonmenu_event) || CONSP (last_nonmenu_event))
2689 && use_dialog_box)
2691 Lisp_Object pane, menu, obj;
2692 redisplay_preserve_echo_area (4);
2693 pane = list2 (Fcons (build_string ("Yes"), Qt),
2694 Fcons (build_string ("No"), Qnil));
2695 GCPRO1 (pane);
2696 menu = Fcons (prompt, pane);
2697 obj = Fx_popup_dialog (Qt, menu, Qnil);
2698 UNGCPRO;
2699 return obj;
2702 AUTO_STRING (yes_or_no, "(yes or no) ");
2703 prompt = CALLN (Fconcat, prompt, yes_or_no);
2704 GCPRO1 (prompt);
2706 while (1)
2708 ans = Fdowncase (Fread_from_minibuffer (prompt, Qnil, Qnil, Qnil,
2709 Qyes_or_no_p_history, Qnil,
2710 Qnil));
2711 if (SCHARS (ans) == 3 && !strcmp (SSDATA (ans), "yes"))
2713 UNGCPRO;
2714 return Qt;
2716 if (SCHARS (ans) == 2 && !strcmp (SSDATA (ans), "no"))
2718 UNGCPRO;
2719 return Qnil;
2722 Fding (Qnil);
2723 Fdiscard_input ();
2724 message1 ("Please answer yes or no.");
2725 Fsleep_for (make_number (2), Qnil);
2729 DEFUN ("load-average", Fload_average, Sload_average, 0, 1, 0,
2730 doc: /* Return list of 1 minute, 5 minute and 15 minute load averages.
2732 Each of the three load averages is multiplied by 100, then converted
2733 to integer.
2735 When USE-FLOATS is non-nil, floats will be used instead of integers.
2736 These floats are not multiplied by 100.
2738 If the 5-minute or 15-minute load averages are not available, return a
2739 shortened list, containing only those averages which are available.
2741 An error is thrown if the load average can't be obtained. In some
2742 cases making it work would require Emacs being installed setuid or
2743 setgid so that it can read kernel information, and that usually isn't
2744 advisable. */)
2745 (Lisp_Object use_floats)
2747 double load_ave[3];
2748 int loads = getloadavg (load_ave, 3);
2749 Lisp_Object ret = Qnil;
2751 if (loads < 0)
2752 error ("load-average not implemented for this operating system");
2754 while (loads-- > 0)
2756 Lisp_Object load = (NILP (use_floats)
2757 ? make_number (100.0 * load_ave[loads])
2758 : make_float (load_ave[loads]));
2759 ret = Fcons (load, ret);
2762 return ret;
2765 DEFUN ("featurep", Ffeaturep, Sfeaturep, 1, 2, 0,
2766 doc: /* Return t if FEATURE is present in this Emacs.
2768 Use this to conditionalize execution of lisp code based on the
2769 presence or absence of Emacs or environment extensions.
2770 Use `provide' to declare that a feature is available. This function
2771 looks at the value of the variable `features'. The optional argument
2772 SUBFEATURE can be used to check a specific subfeature of FEATURE. */)
2773 (Lisp_Object feature, Lisp_Object subfeature)
2775 register Lisp_Object tem;
2776 CHECK_SYMBOL (feature);
2777 tem = Fmemq (feature, Vfeatures);
2778 if (!NILP (tem) && !NILP (subfeature))
2779 tem = Fmember (subfeature, Fget (feature, Qsubfeatures));
2780 return (NILP (tem)) ? Qnil : Qt;
2783 DEFUN ("provide", Fprovide, Sprovide, 1, 2, 0,
2784 doc: /* Announce that FEATURE is a feature of the current Emacs.
2785 The optional argument SUBFEATURES should be a list of symbols listing
2786 particular subfeatures supported in this version of FEATURE. */)
2787 (Lisp_Object feature, Lisp_Object subfeatures)
2789 register Lisp_Object tem;
2790 CHECK_SYMBOL (feature);
2791 CHECK_LIST (subfeatures);
2792 if (!NILP (Vautoload_queue))
2793 Vautoload_queue = Fcons (Fcons (make_number (0), Vfeatures),
2794 Vautoload_queue);
2795 tem = Fmemq (feature, Vfeatures);
2796 if (NILP (tem))
2797 Vfeatures = Fcons (feature, Vfeatures);
2798 if (!NILP (subfeatures))
2799 Fput (feature, Qsubfeatures, subfeatures);
2800 LOADHIST_ATTACH (Fcons (Qprovide, feature));
2802 /* Run any load-hooks for this file. */
2803 tem = Fassq (feature, Vafter_load_alist);
2804 if (CONSP (tem))
2805 Fmapc (Qfuncall, XCDR (tem));
2807 return feature;
2810 /* `require' and its subroutines. */
2812 /* List of features currently being require'd, innermost first. */
2814 static Lisp_Object require_nesting_list;
2816 static void
2817 require_unwind (Lisp_Object old_value)
2819 require_nesting_list = old_value;
2822 DEFUN ("require", Frequire, Srequire, 1, 3, 0,
2823 doc: /* If feature FEATURE is not loaded, load it from FILENAME.
2824 If FEATURE is not a member of the list `features', then the feature
2825 is not loaded; so load the file FILENAME.
2826 If FILENAME is omitted, the printname of FEATURE is used as the file name,
2827 and `load' will try to load this name appended with the suffix `.elc' or
2828 `.el', in that order. The name without appended suffix will not be used.
2829 See `get-load-suffixes' for the complete list of suffixes.
2830 If the optional third argument NOERROR is non-nil,
2831 then return nil if the file is not found instead of signaling an error.
2832 Normally the return value is FEATURE.
2833 The normal messages at start and end of loading FILENAME are suppressed. */)
2834 (Lisp_Object feature, Lisp_Object filename, Lisp_Object noerror)
2836 Lisp_Object tem;
2837 struct gcpro gcpro1, gcpro2;
2838 bool from_file = load_in_progress;
2840 CHECK_SYMBOL (feature);
2842 /* Record the presence of `require' in this file
2843 even if the feature specified is already loaded.
2844 But not more than once in any file,
2845 and not when we aren't loading or reading from a file. */
2846 if (!from_file)
2847 for (tem = Vcurrent_load_list; CONSP (tem); tem = XCDR (tem))
2848 if (NILP (XCDR (tem)) && STRINGP (XCAR (tem)))
2849 from_file = 1;
2851 if (from_file)
2853 tem = Fcons (Qrequire, feature);
2854 if (NILP (Fmember (tem, Vcurrent_load_list)))
2855 LOADHIST_ATTACH (tem);
2857 tem = Fmemq (feature, Vfeatures);
2859 if (NILP (tem))
2861 ptrdiff_t count = SPECPDL_INDEX ();
2862 int nesting = 0;
2864 /* This is to make sure that loadup.el gives a clear picture
2865 of what files are preloaded and when. */
2866 if (! NILP (Vpurify_flag))
2867 error ("(require %s) while preparing to dump",
2868 SDATA (SYMBOL_NAME (feature)));
2870 /* A certain amount of recursive `require' is legitimate,
2871 but if we require the same feature recursively 3 times,
2872 signal an error. */
2873 tem = require_nesting_list;
2874 while (! NILP (tem))
2876 if (! NILP (Fequal (feature, XCAR (tem))))
2877 nesting++;
2878 tem = XCDR (tem);
2880 if (nesting > 3)
2881 error ("Recursive `require' for feature `%s'",
2882 SDATA (SYMBOL_NAME (feature)));
2884 /* Update the list for any nested `require's that occur. */
2885 record_unwind_protect (require_unwind, require_nesting_list);
2886 require_nesting_list = Fcons (feature, require_nesting_list);
2888 /* Value saved here is to be restored into Vautoload_queue */
2889 record_unwind_protect (un_autoload, Vautoload_queue);
2890 Vautoload_queue = Qt;
2892 /* Load the file. */
2893 GCPRO2 (feature, filename);
2894 tem = Fload (NILP (filename) ? Fsymbol_name (feature) : filename,
2895 noerror, Qt, Qnil, (NILP (filename) ? Qt : Qnil));
2896 UNGCPRO;
2898 /* If load failed entirely, return nil. */
2899 if (NILP (tem))
2900 return unbind_to (count, Qnil);
2902 tem = Fmemq (feature, Vfeatures);
2903 if (NILP (tem))
2904 error ("Required feature `%s' was not provided",
2905 SDATA (SYMBOL_NAME (feature)));
2907 /* Once loading finishes, don't undo it. */
2908 Vautoload_queue = Qt;
2909 feature = unbind_to (count, feature);
2912 return feature;
2915 /* Primitives for work of the "widget" library.
2916 In an ideal world, this section would not have been necessary.
2917 However, lisp function calls being as slow as they are, it turns
2918 out that some functions in the widget library (wid-edit.el) are the
2919 bottleneck of Widget operation. Here is their translation to C,
2920 for the sole reason of efficiency. */
2922 DEFUN ("plist-member", Fplist_member, Splist_member, 2, 2, 0,
2923 doc: /* Return non-nil if PLIST has the property PROP.
2924 PLIST is a property list, which is a list of the form
2925 \(PROP1 VALUE1 PROP2 VALUE2 ...\). PROP is a symbol.
2926 Unlike `plist-get', this allows you to distinguish between a missing
2927 property and a property with the value nil.
2928 The value is actually the tail of PLIST whose car is PROP. */)
2929 (Lisp_Object plist, Lisp_Object prop)
2931 while (CONSP (plist) && !EQ (XCAR (plist), prop))
2933 QUIT;
2934 plist = XCDR (plist);
2935 plist = CDR (plist);
2937 return plist;
2940 DEFUN ("widget-put", Fwidget_put, Swidget_put, 3, 3, 0,
2941 doc: /* In WIDGET, set PROPERTY to VALUE.
2942 The value can later be retrieved with `widget-get'. */)
2943 (Lisp_Object widget, Lisp_Object property, Lisp_Object value)
2945 CHECK_CONS (widget);
2946 XSETCDR (widget, Fplist_put (XCDR (widget), property, value));
2947 return value;
2950 DEFUN ("widget-get", Fwidget_get, Swidget_get, 2, 2, 0,
2951 doc: /* In WIDGET, get the value of PROPERTY.
2952 The value could either be specified when the widget was created, or
2953 later with `widget-put'. */)
2954 (Lisp_Object widget, Lisp_Object property)
2956 Lisp_Object tmp;
2958 while (1)
2960 if (NILP (widget))
2961 return Qnil;
2962 CHECK_CONS (widget);
2963 tmp = Fplist_member (XCDR (widget), property);
2964 if (CONSP (tmp))
2966 tmp = XCDR (tmp);
2967 return CAR (tmp);
2969 tmp = XCAR (widget);
2970 if (NILP (tmp))
2971 return Qnil;
2972 widget = Fget (tmp, Qwidget_type);
2976 DEFUN ("widget-apply", Fwidget_apply, Swidget_apply, 2, MANY, 0,
2977 doc: /* Apply the value of WIDGET's PROPERTY to the widget itself.
2978 ARGS are passed as extra arguments to the function.
2979 usage: (widget-apply WIDGET PROPERTY &rest ARGS) */)
2980 (ptrdiff_t nargs, Lisp_Object *args)
2982 /* This function can GC. */
2983 struct gcpro gcpro1, gcpro2;
2984 Lisp_Object widget = args[0];
2985 Lisp_Object property = args[1];
2986 Lisp_Object propval = Fwidget_get (widget, property);
2987 Lisp_Object trailing_args = Flist (nargs - 2, args + 2);
2988 GCPRO2 (propval, trailing_args);
2989 Lisp_Object result = CALLN (Fapply, propval, widget, trailing_args);
2990 UNGCPRO;
2991 return result;
2994 #ifdef HAVE_LANGINFO_CODESET
2995 #include <langinfo.h>
2996 #endif
2998 DEFUN ("locale-info", Flocale_info, Slocale_info, 1, 1, 0,
2999 doc: /* Access locale data ITEM for the current C locale, if available.
3000 ITEM should be one of the following:
3002 `codeset', returning the character set as a string (locale item CODESET);
3004 `days', returning a 7-element vector of day names (locale items DAY_n);
3006 `months', returning a 12-element vector of month names (locale items MON_n);
3008 `paper', returning a list (WIDTH HEIGHT) for the default paper size,
3009 both measured in millimeters (locale items PAPER_WIDTH, PAPER_HEIGHT).
3011 If the system can't provide such information through a call to
3012 `nl_langinfo', or if ITEM isn't from the list above, return nil.
3014 See also Info node `(libc)Locales'.
3016 The data read from the system are decoded using `locale-coding-system'. */)
3017 (Lisp_Object item)
3019 char *str = NULL;
3020 #ifdef HAVE_LANGINFO_CODESET
3021 Lisp_Object val;
3022 if (EQ (item, Qcodeset))
3024 str = nl_langinfo (CODESET);
3025 return build_string (str);
3027 #ifdef DAY_1
3028 else if (EQ (item, Qdays)) /* e.g. for calendar-day-name-array */
3030 Lisp_Object v = Fmake_vector (make_number (7), Qnil);
3031 const int days[7] = {DAY_1, DAY_2, DAY_3, DAY_4, DAY_5, DAY_6, DAY_7};
3032 int i;
3033 struct gcpro gcpro1;
3034 GCPRO1 (v);
3035 synchronize_system_time_locale ();
3036 for (i = 0; i < 7; i++)
3038 str = nl_langinfo (days[i]);
3039 val = build_unibyte_string (str);
3040 /* Fixme: Is this coding system necessarily right, even if
3041 it is consistent with CODESET? If not, what to do? */
3042 ASET (v, i, code_convert_string_norecord (val, Vlocale_coding_system,
3043 0));
3045 UNGCPRO;
3046 return v;
3048 #endif /* DAY_1 */
3049 #ifdef MON_1
3050 else if (EQ (item, Qmonths)) /* e.g. for calendar-month-name-array */
3052 Lisp_Object v = Fmake_vector (make_number (12), Qnil);
3053 const int months[12] = {MON_1, MON_2, MON_3, MON_4, MON_5, MON_6, MON_7,
3054 MON_8, MON_9, MON_10, MON_11, MON_12};
3055 int i;
3056 struct gcpro gcpro1;
3057 GCPRO1 (v);
3058 synchronize_system_time_locale ();
3059 for (i = 0; i < 12; i++)
3061 str = nl_langinfo (months[i]);
3062 val = build_unibyte_string (str);
3063 ASET (v, i, code_convert_string_norecord (val, Vlocale_coding_system,
3064 0));
3066 UNGCPRO;
3067 return v;
3069 #endif /* MON_1 */
3070 /* LC_PAPER stuff isn't defined as accessible in glibc as of 2.3.1,
3071 but is in the locale files. This could be used by ps-print. */
3072 #ifdef PAPER_WIDTH
3073 else if (EQ (item, Qpaper))
3074 return list2i (nl_langinfo (PAPER_WIDTH), nl_langinfo (PAPER_HEIGHT));
3075 #endif /* PAPER_WIDTH */
3076 #endif /* HAVE_LANGINFO_CODESET*/
3077 return Qnil;
3080 /* base64 encode/decode functions (RFC 2045).
3081 Based on code from GNU recode. */
3083 #define MIME_LINE_LENGTH 76
3085 #define IS_ASCII(Character) \
3086 ((Character) < 128)
3087 #define IS_BASE64(Character) \
3088 (IS_ASCII (Character) && base64_char_to_value[Character] >= 0)
3089 #define IS_BASE64_IGNORABLE(Character) \
3090 ((Character) == ' ' || (Character) == '\t' || (Character) == '\n' \
3091 || (Character) == '\f' || (Character) == '\r')
3093 /* Used by base64_decode_1 to retrieve a non-base64-ignorable
3094 character or return retval if there are no characters left to
3095 process. */
3096 #define READ_QUADRUPLET_BYTE(retval) \
3097 do \
3099 if (i == length) \
3101 if (nchars_return) \
3102 *nchars_return = nchars; \
3103 return (retval); \
3105 c = from[i++]; \
3107 while (IS_BASE64_IGNORABLE (c))
3109 /* Table of characters coding the 64 values. */
3110 static const char base64_value_to_char[64] =
3112 'A', 'B', 'C', 'D', 'E', 'F', 'G', 'H', 'I', 'J', /* 0- 9 */
3113 'K', 'L', 'M', 'N', 'O', 'P', 'Q', 'R', 'S', 'T', /* 10-19 */
3114 'U', 'V', 'W', 'X', 'Y', 'Z', 'a', 'b', 'c', 'd', /* 20-29 */
3115 'e', 'f', 'g', 'h', 'i', 'j', 'k', 'l', 'm', 'n', /* 30-39 */
3116 'o', 'p', 'q', 'r', 's', 't', 'u', 'v', 'w', 'x', /* 40-49 */
3117 'y', 'z', '0', '1', '2', '3', '4', '5', '6', '7', /* 50-59 */
3118 '8', '9', '+', '/' /* 60-63 */
3121 /* Table of base64 values for first 128 characters. */
3122 static const short base64_char_to_value[128] =
3124 -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, /* 0- 9 */
3125 -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, /* 10- 19 */
3126 -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, /* 20- 29 */
3127 -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, /* 30- 39 */
3128 -1, -1, -1, 62, -1, -1, -1, 63, 52, 53, /* 40- 49 */
3129 54, 55, 56, 57, 58, 59, 60, 61, -1, -1, /* 50- 59 */
3130 -1, -1, -1, -1, -1, 0, 1, 2, 3, 4, /* 60- 69 */
3131 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, /* 70- 79 */
3132 15, 16, 17, 18, 19, 20, 21, 22, 23, 24, /* 80- 89 */
3133 25, -1, -1, -1, -1, -1, -1, 26, 27, 28, /* 90- 99 */
3134 29, 30, 31, 32, 33, 34, 35, 36, 37, 38, /* 100-109 */
3135 39, 40, 41, 42, 43, 44, 45, 46, 47, 48, /* 110-119 */
3136 49, 50, 51, -1, -1, -1, -1, -1 /* 120-127 */
3139 /* The following diagram shows the logical steps by which three octets
3140 get transformed into four base64 characters.
3142 .--------. .--------. .--------.
3143 |aaaaaabb| |bbbbcccc| |ccdddddd|
3144 `--------' `--------' `--------'
3145 6 2 4 4 2 6
3146 .--------+--------+--------+--------.
3147 |00aaaaaa|00bbbbbb|00cccccc|00dddddd|
3148 `--------+--------+--------+--------'
3150 .--------+--------+--------+--------.
3151 |AAAAAAAA|BBBBBBBB|CCCCCCCC|DDDDDDDD|
3152 `--------+--------+--------+--------'
3154 The octets are divided into 6 bit chunks, which are then encoded into
3155 base64 characters. */
3158 static ptrdiff_t base64_encode_1 (const char *, char *, ptrdiff_t, bool, bool);
3159 static ptrdiff_t base64_decode_1 (const char *, char *, ptrdiff_t, bool,
3160 ptrdiff_t *);
3162 DEFUN ("base64-encode-region", Fbase64_encode_region, Sbase64_encode_region,
3163 2, 3, "r",
3164 doc: /* Base64-encode the region between BEG and END.
3165 Return the length of the encoded text.
3166 Optional third argument NO-LINE-BREAK means do not break long lines
3167 into shorter lines. */)
3168 (Lisp_Object beg, Lisp_Object end, Lisp_Object no_line_break)
3170 char *encoded;
3171 ptrdiff_t allength, length;
3172 ptrdiff_t ibeg, iend, encoded_length;
3173 ptrdiff_t old_pos = PT;
3174 USE_SAFE_ALLOCA;
3176 validate_region (&beg, &end);
3178 ibeg = CHAR_TO_BYTE (XFASTINT (beg));
3179 iend = CHAR_TO_BYTE (XFASTINT (end));
3180 move_gap_both (XFASTINT (beg), ibeg);
3182 /* We need to allocate enough room for encoding the text.
3183 We need 33 1/3% more space, plus a newline every 76
3184 characters, and then we round up. */
3185 length = iend - ibeg;
3186 allength = length + length/3 + 1;
3187 allength += allength / MIME_LINE_LENGTH + 1 + 6;
3189 encoded = SAFE_ALLOCA (allength);
3190 encoded_length = base64_encode_1 ((char *) BYTE_POS_ADDR (ibeg),
3191 encoded, length, NILP (no_line_break),
3192 !NILP (BVAR (current_buffer, enable_multibyte_characters)));
3193 if (encoded_length > allength)
3194 emacs_abort ();
3196 if (encoded_length < 0)
3198 /* The encoding wasn't possible. */
3199 SAFE_FREE ();
3200 error ("Multibyte character in data for base64 encoding");
3203 /* Now we have encoded the region, so we insert the new contents
3204 and delete the old. (Insert first in order to preserve markers.) */
3205 SET_PT_BOTH (XFASTINT (beg), ibeg);
3206 insert (encoded, encoded_length);
3207 SAFE_FREE ();
3208 del_range_byte (ibeg + encoded_length, iend + encoded_length, 1);
3210 /* If point was outside of the region, restore it exactly; else just
3211 move to the beginning of the region. */
3212 if (old_pos >= XFASTINT (end))
3213 old_pos += encoded_length - (XFASTINT (end) - XFASTINT (beg));
3214 else if (old_pos > XFASTINT (beg))
3215 old_pos = XFASTINT (beg);
3216 SET_PT (old_pos);
3218 /* We return the length of the encoded text. */
3219 return make_number (encoded_length);
3222 DEFUN ("base64-encode-string", Fbase64_encode_string, Sbase64_encode_string,
3223 1, 2, 0,
3224 doc: /* Base64-encode STRING and return the result.
3225 Optional second argument NO-LINE-BREAK means do not break long lines
3226 into shorter lines. */)
3227 (Lisp_Object string, Lisp_Object no_line_break)
3229 ptrdiff_t allength, length, encoded_length;
3230 char *encoded;
3231 Lisp_Object encoded_string;
3232 USE_SAFE_ALLOCA;
3234 CHECK_STRING (string);
3236 /* We need to allocate enough room for encoding the text.
3237 We need 33 1/3% more space, plus a newline every 76
3238 characters, and then we round up. */
3239 length = SBYTES (string);
3240 allength = length + length/3 + 1;
3241 allength += allength / MIME_LINE_LENGTH + 1 + 6;
3243 /* We need to allocate enough room for decoding the text. */
3244 encoded = SAFE_ALLOCA (allength);
3246 encoded_length = base64_encode_1 (SSDATA (string),
3247 encoded, length, NILP (no_line_break),
3248 STRING_MULTIBYTE (string));
3249 if (encoded_length > allength)
3250 emacs_abort ();
3252 if (encoded_length < 0)
3254 /* The encoding wasn't possible. */
3255 error ("Multibyte character in data for base64 encoding");
3258 encoded_string = make_unibyte_string (encoded, encoded_length);
3259 SAFE_FREE ();
3261 return encoded_string;
3264 static ptrdiff_t
3265 base64_encode_1 (const char *from, char *to, ptrdiff_t length,
3266 bool line_break, bool multibyte)
3268 int counter = 0;
3269 ptrdiff_t i = 0;
3270 char *e = to;
3271 int c;
3272 unsigned int value;
3273 int bytes;
3275 while (i < length)
3277 if (multibyte)
3279 c = STRING_CHAR_AND_LENGTH ((unsigned char *) from + i, bytes);
3280 if (CHAR_BYTE8_P (c))
3281 c = CHAR_TO_BYTE8 (c);
3282 else if (c >= 256)
3283 return -1;
3284 i += bytes;
3286 else
3287 c = from[i++];
3289 /* Wrap line every 76 characters. */
3291 if (line_break)
3293 if (counter < MIME_LINE_LENGTH / 4)
3294 counter++;
3295 else
3297 *e++ = '\n';
3298 counter = 1;
3302 /* Process first byte of a triplet. */
3304 *e++ = base64_value_to_char[0x3f & c >> 2];
3305 value = (0x03 & c) << 4;
3307 /* Process second byte of a triplet. */
3309 if (i == length)
3311 *e++ = base64_value_to_char[value];
3312 *e++ = '=';
3313 *e++ = '=';
3314 break;
3317 if (multibyte)
3319 c = STRING_CHAR_AND_LENGTH ((unsigned char *) from + i, bytes);
3320 if (CHAR_BYTE8_P (c))
3321 c = CHAR_TO_BYTE8 (c);
3322 else if (c >= 256)
3323 return -1;
3324 i += bytes;
3326 else
3327 c = from[i++];
3329 *e++ = base64_value_to_char[value | (0x0f & c >> 4)];
3330 value = (0x0f & c) << 2;
3332 /* Process third byte of a triplet. */
3334 if (i == length)
3336 *e++ = base64_value_to_char[value];
3337 *e++ = '=';
3338 break;
3341 if (multibyte)
3343 c = STRING_CHAR_AND_LENGTH ((unsigned char *) from + i, bytes);
3344 if (CHAR_BYTE8_P (c))
3345 c = CHAR_TO_BYTE8 (c);
3346 else if (c >= 256)
3347 return -1;
3348 i += bytes;
3350 else
3351 c = from[i++];
3353 *e++ = base64_value_to_char[value | (0x03 & c >> 6)];
3354 *e++ = base64_value_to_char[0x3f & c];
3357 return e - to;
3361 DEFUN ("base64-decode-region", Fbase64_decode_region, Sbase64_decode_region,
3362 2, 2, "r",
3363 doc: /* Base64-decode the region between BEG and END.
3364 Return the length of the decoded text.
3365 If the region can't be decoded, signal an error and don't modify the buffer. */)
3366 (Lisp_Object beg, Lisp_Object end)
3368 ptrdiff_t ibeg, iend, length, allength;
3369 char *decoded;
3370 ptrdiff_t old_pos = PT;
3371 ptrdiff_t decoded_length;
3372 ptrdiff_t inserted_chars;
3373 bool multibyte = !NILP (BVAR (current_buffer, enable_multibyte_characters));
3374 USE_SAFE_ALLOCA;
3376 validate_region (&beg, &end);
3378 ibeg = CHAR_TO_BYTE (XFASTINT (beg));
3379 iend = CHAR_TO_BYTE (XFASTINT (end));
3381 length = iend - ibeg;
3383 /* We need to allocate enough room for decoding the text. If we are
3384 working on a multibyte buffer, each decoded code may occupy at
3385 most two bytes. */
3386 allength = multibyte ? length * 2 : length;
3387 decoded = SAFE_ALLOCA (allength);
3389 move_gap_both (XFASTINT (beg), ibeg);
3390 decoded_length = base64_decode_1 ((char *) BYTE_POS_ADDR (ibeg),
3391 decoded, length,
3392 multibyte, &inserted_chars);
3393 if (decoded_length > allength)
3394 emacs_abort ();
3396 if (decoded_length < 0)
3398 /* The decoding wasn't possible. */
3399 error ("Invalid base64 data");
3402 /* Now we have decoded the region, so we insert the new contents
3403 and delete the old. (Insert first in order to preserve markers.) */
3404 TEMP_SET_PT_BOTH (XFASTINT (beg), ibeg);
3405 insert_1_both (decoded, inserted_chars, decoded_length, 0, 1, 0);
3406 SAFE_FREE ();
3408 /* Delete the original text. */
3409 del_range_both (PT, PT_BYTE, XFASTINT (end) + inserted_chars,
3410 iend + decoded_length, 1);
3412 /* If point was outside of the region, restore it exactly; else just
3413 move to the beginning of the region. */
3414 if (old_pos >= XFASTINT (end))
3415 old_pos += inserted_chars - (XFASTINT (end) - XFASTINT (beg));
3416 else if (old_pos > XFASTINT (beg))
3417 old_pos = XFASTINT (beg);
3418 SET_PT (old_pos > ZV ? ZV : old_pos);
3420 return make_number (inserted_chars);
3423 DEFUN ("base64-decode-string", Fbase64_decode_string, Sbase64_decode_string,
3424 1, 1, 0,
3425 doc: /* Base64-decode STRING and return the result. */)
3426 (Lisp_Object string)
3428 char *decoded;
3429 ptrdiff_t length, decoded_length;
3430 Lisp_Object decoded_string;
3431 USE_SAFE_ALLOCA;
3433 CHECK_STRING (string);
3435 length = SBYTES (string);
3436 /* We need to allocate enough room for decoding the text. */
3437 decoded = SAFE_ALLOCA (length);
3439 /* The decoded result should be unibyte. */
3440 decoded_length = base64_decode_1 (SSDATA (string), decoded, length,
3441 0, NULL);
3442 if (decoded_length > length)
3443 emacs_abort ();
3444 else if (decoded_length >= 0)
3445 decoded_string = make_unibyte_string (decoded, decoded_length);
3446 else
3447 decoded_string = Qnil;
3449 SAFE_FREE ();
3450 if (!STRINGP (decoded_string))
3451 error ("Invalid base64 data");
3453 return decoded_string;
3456 /* Base64-decode the data at FROM of LENGTH bytes into TO. If
3457 MULTIBYTE, the decoded result should be in multibyte
3458 form. If NCHARS_RETURN is not NULL, store the number of produced
3459 characters in *NCHARS_RETURN. */
3461 static ptrdiff_t
3462 base64_decode_1 (const char *from, char *to, ptrdiff_t length,
3463 bool multibyte, ptrdiff_t *nchars_return)
3465 ptrdiff_t i = 0; /* Used inside READ_QUADRUPLET_BYTE */
3466 char *e = to;
3467 unsigned char c;
3468 unsigned long value;
3469 ptrdiff_t nchars = 0;
3471 while (1)
3473 /* Process first byte of a quadruplet. */
3475 READ_QUADRUPLET_BYTE (e-to);
3477 if (!IS_BASE64 (c))
3478 return -1;
3479 value = base64_char_to_value[c] << 18;
3481 /* Process second byte of a quadruplet. */
3483 READ_QUADRUPLET_BYTE (-1);
3485 if (!IS_BASE64 (c))
3486 return -1;
3487 value |= base64_char_to_value[c] << 12;
3489 c = (unsigned char) (value >> 16);
3490 if (multibyte && c >= 128)
3491 e += BYTE8_STRING (c, e);
3492 else
3493 *e++ = c;
3494 nchars++;
3496 /* Process third byte of a quadruplet. */
3498 READ_QUADRUPLET_BYTE (-1);
3500 if (c == '=')
3502 READ_QUADRUPLET_BYTE (-1);
3504 if (c != '=')
3505 return -1;
3506 continue;
3509 if (!IS_BASE64 (c))
3510 return -1;
3511 value |= base64_char_to_value[c] << 6;
3513 c = (unsigned char) (0xff & value >> 8);
3514 if (multibyte && c >= 128)
3515 e += BYTE8_STRING (c, e);
3516 else
3517 *e++ = c;
3518 nchars++;
3520 /* Process fourth byte of a quadruplet. */
3522 READ_QUADRUPLET_BYTE (-1);
3524 if (c == '=')
3525 continue;
3527 if (!IS_BASE64 (c))
3528 return -1;
3529 value |= base64_char_to_value[c];
3531 c = (unsigned char) (0xff & value);
3532 if (multibyte && c >= 128)
3533 e += BYTE8_STRING (c, e);
3534 else
3535 *e++ = c;
3536 nchars++;
3542 /***********************************************************************
3543 ***** *****
3544 ***** Hash Tables *****
3545 ***** *****
3546 ***********************************************************************/
3548 /* Implemented by gerd@gnu.org. This hash table implementation was
3549 inspired by CMUCL hash tables. */
3551 /* Ideas:
3553 1. For small tables, association lists are probably faster than
3554 hash tables because they have lower overhead.
3556 For uses of hash tables where the O(1) behavior of table
3557 operations is not a requirement, it might therefore be a good idea
3558 not to hash. Instead, we could just do a linear search in the
3559 key_and_value vector of the hash table. This could be done
3560 if a `:linear-search t' argument is given to make-hash-table. */
3563 /* The list of all weak hash tables. Don't staticpro this one. */
3565 static struct Lisp_Hash_Table *weak_hash_tables;
3568 /***********************************************************************
3569 Utilities
3570 ***********************************************************************/
3572 static void
3573 CHECK_HASH_TABLE (Lisp_Object x)
3575 CHECK_TYPE (HASH_TABLE_P (x), Qhash_table_p, x);
3578 static void
3579 set_hash_key_and_value (struct Lisp_Hash_Table *h, Lisp_Object key_and_value)
3581 h->key_and_value = key_and_value;
3583 static void
3584 set_hash_next (struct Lisp_Hash_Table *h, Lisp_Object next)
3586 h->next = next;
3588 static void
3589 set_hash_next_slot (struct Lisp_Hash_Table *h, ptrdiff_t idx, Lisp_Object val)
3591 gc_aset (h->next, idx, val);
3593 static void
3594 set_hash_hash (struct Lisp_Hash_Table *h, Lisp_Object hash)
3596 h->hash = hash;
3598 static void
3599 set_hash_hash_slot (struct Lisp_Hash_Table *h, ptrdiff_t idx, Lisp_Object val)
3601 gc_aset (h->hash, idx, val);
3603 static void
3604 set_hash_index (struct Lisp_Hash_Table *h, Lisp_Object index)
3606 h->index = index;
3608 static void
3609 set_hash_index_slot (struct Lisp_Hash_Table *h, ptrdiff_t idx, Lisp_Object val)
3611 gc_aset (h->index, idx, val);
3614 /* If OBJ is a Lisp hash table, return a pointer to its struct
3615 Lisp_Hash_Table. Otherwise, signal an error. */
3617 static struct Lisp_Hash_Table *
3618 check_hash_table (Lisp_Object obj)
3620 CHECK_HASH_TABLE (obj);
3621 return XHASH_TABLE (obj);
3625 /* Value is the next integer I >= N, N >= 0 which is "almost" a prime
3626 number. A number is "almost" a prime number if it is not divisible
3627 by any integer in the range 2 .. (NEXT_ALMOST_PRIME_LIMIT - 1). */
3629 EMACS_INT
3630 next_almost_prime (EMACS_INT n)
3632 verify (NEXT_ALMOST_PRIME_LIMIT == 11);
3633 for (n |= 1; ; n += 2)
3634 if (n % 3 != 0 && n % 5 != 0 && n % 7 != 0)
3635 return n;
3639 /* Find KEY in ARGS which has size NARGS. Don't consider indices for
3640 which USED[I] is non-zero. If found at index I in ARGS, set
3641 USED[I] and USED[I + 1] to 1, and return I + 1. Otherwise return
3642 0. This function is used to extract a keyword/argument pair from
3643 a DEFUN parameter list. */
3645 static ptrdiff_t
3646 get_key_arg (Lisp_Object key, ptrdiff_t nargs, Lisp_Object *args, char *used)
3648 ptrdiff_t i;
3650 for (i = 1; i < nargs; i++)
3651 if (!used[i - 1] && EQ (args[i - 1], key))
3653 used[i - 1] = 1;
3654 used[i] = 1;
3655 return i;
3658 return 0;
3662 /* Return a Lisp vector which has the same contents as VEC but has
3663 at least INCR_MIN more entries, where INCR_MIN is positive.
3664 If NITEMS_MAX is not -1, do not grow the vector to be any larger
3665 than NITEMS_MAX. Entries in the resulting
3666 vector that are not copied from VEC are set to nil. */
3668 Lisp_Object
3669 larger_vector (Lisp_Object vec, ptrdiff_t incr_min, ptrdiff_t nitems_max)
3671 struct Lisp_Vector *v;
3672 ptrdiff_t incr, incr_max, old_size, new_size;
3673 ptrdiff_t C_language_max = min (PTRDIFF_MAX, SIZE_MAX) / sizeof *v->contents;
3674 ptrdiff_t n_max = (0 <= nitems_max && nitems_max < C_language_max
3675 ? nitems_max : C_language_max);
3676 eassert (VECTORP (vec));
3677 eassert (0 < incr_min && -1 <= nitems_max);
3678 old_size = ASIZE (vec);
3679 incr_max = n_max - old_size;
3680 incr = max (incr_min, min (old_size >> 1, incr_max));
3681 if (incr_max < incr)
3682 memory_full (SIZE_MAX);
3683 new_size = old_size + incr;
3684 v = allocate_vector (new_size);
3685 memcpy (v->contents, XVECTOR (vec)->contents, old_size * sizeof *v->contents);
3686 memclear (v->contents + old_size, incr * word_size);
3687 XSETVECTOR (vec, v);
3688 return vec;
3692 /***********************************************************************
3693 Low-level Functions
3694 ***********************************************************************/
3696 static struct hash_table_test hashtest_eq;
3697 struct hash_table_test hashtest_eql, hashtest_equal;
3699 /* Compare KEY1 which has hash code HASH1 and KEY2 with hash code
3700 HASH2 in hash table H using `eql'. Value is true if KEY1 and
3701 KEY2 are the same. */
3703 static bool
3704 cmpfn_eql (struct hash_table_test *ht,
3705 Lisp_Object key1,
3706 Lisp_Object key2)
3708 return (FLOATP (key1)
3709 && FLOATP (key2)
3710 && XFLOAT_DATA (key1) == XFLOAT_DATA (key2));
3714 /* Compare KEY1 which has hash code HASH1 and KEY2 with hash code
3715 HASH2 in hash table H using `equal'. Value is true if KEY1 and
3716 KEY2 are the same. */
3718 static bool
3719 cmpfn_equal (struct hash_table_test *ht,
3720 Lisp_Object key1,
3721 Lisp_Object key2)
3723 return !NILP (Fequal (key1, key2));
3727 /* Compare KEY1 which has hash code HASH1, and KEY2 with hash code
3728 HASH2 in hash table H using H->user_cmp_function. Value is true
3729 if KEY1 and KEY2 are the same. */
3731 static bool
3732 cmpfn_user_defined (struct hash_table_test *ht,
3733 Lisp_Object key1,
3734 Lisp_Object key2)
3736 return !NILP (call2 (ht->user_cmp_function, key1, key2));
3740 /* Value is a hash code for KEY for use in hash table H which uses
3741 `eq' to compare keys. The hash code returned is guaranteed to fit
3742 in a Lisp integer. */
3744 static EMACS_UINT
3745 hashfn_eq (struct hash_table_test *ht, Lisp_Object key)
3747 EMACS_UINT hash = XHASH (key) ^ XTYPE (key);
3748 return hash;
3751 /* Value is a hash code for KEY for use in hash table H which uses
3752 `eql' to compare keys. The hash code returned is guaranteed to fit
3753 in a Lisp integer. */
3755 static EMACS_UINT
3756 hashfn_eql (struct hash_table_test *ht, Lisp_Object key)
3758 EMACS_UINT hash;
3759 if (FLOATP (key))
3760 hash = sxhash (key, 0);
3761 else
3762 hash = XHASH (key) ^ XTYPE (key);
3763 return hash;
3766 /* Value is a hash code for KEY for use in hash table H which uses
3767 `equal' to compare keys. The hash code returned is guaranteed to fit
3768 in a Lisp integer. */
3770 static EMACS_UINT
3771 hashfn_equal (struct hash_table_test *ht, Lisp_Object key)
3773 EMACS_UINT hash = sxhash (key, 0);
3774 return hash;
3777 /* Value is a hash code for KEY for use in hash table H which uses as
3778 user-defined function to compare keys. The hash code returned is
3779 guaranteed to fit in a Lisp integer. */
3781 static EMACS_UINT
3782 hashfn_user_defined (struct hash_table_test *ht, Lisp_Object key)
3784 Lisp_Object hash = call1 (ht->user_hash_function, key);
3785 return hashfn_eq (ht, hash);
3788 /* Allocate basically initialized hash table. */
3790 static struct Lisp_Hash_Table *
3791 allocate_hash_table (void)
3793 return ALLOCATE_PSEUDOVECTOR (struct Lisp_Hash_Table,
3794 count, PVEC_HASH_TABLE);
3797 /* An upper bound on the size of a hash table index. It must fit in
3798 ptrdiff_t and be a valid Emacs fixnum. */
3799 #define INDEX_SIZE_BOUND \
3800 ((ptrdiff_t) min (MOST_POSITIVE_FIXNUM, PTRDIFF_MAX / word_size))
3802 /* Create and initialize a new hash table.
3804 TEST specifies the test the hash table will use to compare keys.
3805 It must be either one of the predefined tests `eq', `eql' or
3806 `equal' or a symbol denoting a user-defined test named TEST with
3807 test and hash functions USER_TEST and USER_HASH.
3809 Give the table initial capacity SIZE, SIZE >= 0, an integer.
3811 If REHASH_SIZE is an integer, it must be > 0, and this hash table's
3812 new size when it becomes full is computed by adding REHASH_SIZE to
3813 its old size. If REHASH_SIZE is a float, it must be > 1.0, and the
3814 table's new size is computed by multiplying its old size with
3815 REHASH_SIZE.
3817 REHASH_THRESHOLD must be a float <= 1.0, and > 0. The table will
3818 be resized when the ratio of (number of entries in the table) /
3819 (table size) is >= REHASH_THRESHOLD.
3821 WEAK specifies the weakness of the table. If non-nil, it must be
3822 one of the symbols `key', `value', `key-or-value', or `key-and-value'. */
3824 Lisp_Object
3825 make_hash_table (struct hash_table_test test,
3826 Lisp_Object size, Lisp_Object rehash_size,
3827 Lisp_Object rehash_threshold, Lisp_Object weak)
3829 struct Lisp_Hash_Table *h;
3830 Lisp_Object table;
3831 EMACS_INT index_size, sz;
3832 ptrdiff_t i;
3833 double index_float;
3835 /* Preconditions. */
3836 eassert (SYMBOLP (test.name));
3837 eassert (INTEGERP (size) && XINT (size) >= 0);
3838 eassert ((INTEGERP (rehash_size) && XINT (rehash_size) > 0)
3839 || (FLOATP (rehash_size) && 1 < XFLOAT_DATA (rehash_size)));
3840 eassert (FLOATP (rehash_threshold)
3841 && 0 < XFLOAT_DATA (rehash_threshold)
3842 && XFLOAT_DATA (rehash_threshold) <= 1.0);
3844 if (XFASTINT (size) == 0)
3845 size = make_number (1);
3847 sz = XFASTINT (size);
3848 index_float = sz / XFLOAT_DATA (rehash_threshold);
3849 index_size = (index_float < INDEX_SIZE_BOUND + 1
3850 ? next_almost_prime (index_float)
3851 : INDEX_SIZE_BOUND + 1);
3852 if (INDEX_SIZE_BOUND < max (index_size, 2 * sz))
3853 error ("Hash table too large");
3855 /* Allocate a table and initialize it. */
3856 h = allocate_hash_table ();
3858 /* Initialize hash table slots. */
3859 h->test = test;
3860 h->weak = weak;
3861 h->rehash_threshold = rehash_threshold;
3862 h->rehash_size = rehash_size;
3863 h->count = 0;
3864 h->key_and_value = Fmake_vector (make_number (2 * sz), Qnil);
3865 h->hash = Fmake_vector (size, Qnil);
3866 h->next = Fmake_vector (size, Qnil);
3867 h->index = Fmake_vector (make_number (index_size), Qnil);
3869 /* Set up the free list. */
3870 for (i = 0; i < sz - 1; ++i)
3871 set_hash_next_slot (h, i, make_number (i + 1));
3872 h->next_free = make_number (0);
3874 XSET_HASH_TABLE (table, h);
3875 eassert (HASH_TABLE_P (table));
3876 eassert (XHASH_TABLE (table) == h);
3878 /* Maybe add this hash table to the list of all weak hash tables. */
3879 if (NILP (h->weak))
3880 h->next_weak = NULL;
3881 else
3883 h->next_weak = weak_hash_tables;
3884 weak_hash_tables = h;
3887 return table;
3891 /* Return a copy of hash table H1. Keys and values are not copied,
3892 only the table itself is. */
3894 static Lisp_Object
3895 copy_hash_table (struct Lisp_Hash_Table *h1)
3897 Lisp_Object table;
3898 struct Lisp_Hash_Table *h2;
3900 h2 = allocate_hash_table ();
3901 *h2 = *h1;
3902 h2->key_and_value = Fcopy_sequence (h1->key_and_value);
3903 h2->hash = Fcopy_sequence (h1->hash);
3904 h2->next = Fcopy_sequence (h1->next);
3905 h2->index = Fcopy_sequence (h1->index);
3906 XSET_HASH_TABLE (table, h2);
3908 /* Maybe add this hash table to the list of all weak hash tables. */
3909 if (!NILP (h2->weak))
3911 h2->next_weak = weak_hash_tables;
3912 weak_hash_tables = h2;
3915 return table;
3919 /* Resize hash table H if it's too full. If H cannot be resized
3920 because it's already too large, throw an error. */
3922 static void
3923 maybe_resize_hash_table (struct Lisp_Hash_Table *h)
3925 if (NILP (h->next_free))
3927 ptrdiff_t old_size = HASH_TABLE_SIZE (h);
3928 EMACS_INT new_size, index_size, nsize;
3929 ptrdiff_t i;
3930 double index_float;
3932 if (INTEGERP (h->rehash_size))
3933 new_size = old_size + XFASTINT (h->rehash_size);
3934 else
3936 double float_new_size = old_size * XFLOAT_DATA (h->rehash_size);
3937 if (float_new_size < INDEX_SIZE_BOUND + 1)
3939 new_size = float_new_size;
3940 if (new_size <= old_size)
3941 new_size = old_size + 1;
3943 else
3944 new_size = INDEX_SIZE_BOUND + 1;
3946 index_float = new_size / XFLOAT_DATA (h->rehash_threshold);
3947 index_size = (index_float < INDEX_SIZE_BOUND + 1
3948 ? next_almost_prime (index_float)
3949 : INDEX_SIZE_BOUND + 1);
3950 nsize = max (index_size, 2 * new_size);
3951 if (INDEX_SIZE_BOUND < nsize)
3952 error ("Hash table too large to resize");
3954 #ifdef ENABLE_CHECKING
3955 if (HASH_TABLE_P (Vpurify_flag)
3956 && XHASH_TABLE (Vpurify_flag) == h)
3957 CALLN (Fmessage, build_string ("Growing hash table to: %d"),
3958 make_number (new_size));
3959 #endif
3961 set_hash_key_and_value (h, larger_vector (h->key_and_value,
3962 2 * (new_size - old_size), -1));
3963 set_hash_next (h, larger_vector (h->next, new_size - old_size, -1));
3964 set_hash_hash (h, larger_vector (h->hash, new_size - old_size, -1));
3965 set_hash_index (h, Fmake_vector (make_number (index_size), Qnil));
3967 /* Update the free list. Do it so that new entries are added at
3968 the end of the free list. This makes some operations like
3969 maphash faster. */
3970 for (i = old_size; i < new_size - 1; ++i)
3971 set_hash_next_slot (h, i, make_number (i + 1));
3973 if (!NILP (h->next_free))
3975 Lisp_Object last, next;
3977 last = h->next_free;
3978 while (next = HASH_NEXT (h, XFASTINT (last)),
3979 !NILP (next))
3980 last = next;
3982 set_hash_next_slot (h, XFASTINT (last), make_number (old_size));
3984 else
3985 XSETFASTINT (h->next_free, old_size);
3987 /* Rehash. */
3988 for (i = 0; i < old_size; ++i)
3989 if (!NILP (HASH_HASH (h, i)))
3991 EMACS_UINT hash_code = XUINT (HASH_HASH (h, i));
3992 ptrdiff_t start_of_bucket = hash_code % ASIZE (h->index);
3993 set_hash_next_slot (h, i, HASH_INDEX (h, start_of_bucket));
3994 set_hash_index_slot (h, start_of_bucket, make_number (i));
4000 /* Lookup KEY in hash table H. If HASH is non-null, return in *HASH
4001 the hash code of KEY. Value is the index of the entry in H
4002 matching KEY, or -1 if not found. */
4004 ptrdiff_t
4005 hash_lookup (struct Lisp_Hash_Table *h, Lisp_Object key, EMACS_UINT *hash)
4007 EMACS_UINT hash_code;
4008 ptrdiff_t start_of_bucket;
4009 Lisp_Object idx;
4011 hash_code = h->test.hashfn (&h->test, key);
4012 eassert ((hash_code & ~INTMASK) == 0);
4013 if (hash)
4014 *hash = hash_code;
4016 start_of_bucket = hash_code % ASIZE (h->index);
4017 idx = HASH_INDEX (h, start_of_bucket);
4019 /* We need not gcpro idx since it's either an integer or nil. */
4020 while (!NILP (idx))
4022 ptrdiff_t i = XFASTINT (idx);
4023 if (EQ (key, HASH_KEY (h, i))
4024 || (h->test.cmpfn
4025 && hash_code == XUINT (HASH_HASH (h, i))
4026 && h->test.cmpfn (&h->test, key, HASH_KEY (h, i))))
4027 break;
4028 idx = HASH_NEXT (h, i);
4031 return NILP (idx) ? -1 : XFASTINT (idx);
4035 /* Put an entry into hash table H that associates KEY with VALUE.
4036 HASH is a previously computed hash code of KEY.
4037 Value is the index of the entry in H matching KEY. */
4039 ptrdiff_t
4040 hash_put (struct Lisp_Hash_Table *h, Lisp_Object key, Lisp_Object value,
4041 EMACS_UINT hash)
4043 ptrdiff_t start_of_bucket, i;
4045 eassert ((hash & ~INTMASK) == 0);
4047 /* Increment count after resizing because resizing may fail. */
4048 maybe_resize_hash_table (h);
4049 h->count++;
4051 /* Store key/value in the key_and_value vector. */
4052 i = XFASTINT (h->next_free);
4053 h->next_free = HASH_NEXT (h, i);
4054 set_hash_key_slot (h, i, key);
4055 set_hash_value_slot (h, i, value);
4057 /* Remember its hash code. */
4058 set_hash_hash_slot (h, i, make_number (hash));
4060 /* Add new entry to its collision chain. */
4061 start_of_bucket = hash % ASIZE (h->index);
4062 set_hash_next_slot (h, i, HASH_INDEX (h, start_of_bucket));
4063 set_hash_index_slot (h, start_of_bucket, make_number (i));
4064 return i;
4068 /* Remove the entry matching KEY from hash table H, if there is one. */
4070 static void
4071 hash_remove_from_table (struct Lisp_Hash_Table *h, Lisp_Object key)
4073 EMACS_UINT hash_code;
4074 ptrdiff_t start_of_bucket;
4075 Lisp_Object idx, prev;
4077 hash_code = h->test.hashfn (&h->test, key);
4078 eassert ((hash_code & ~INTMASK) == 0);
4079 start_of_bucket = hash_code % ASIZE (h->index);
4080 idx = HASH_INDEX (h, start_of_bucket);
4081 prev = Qnil;
4083 /* We need not gcpro idx, prev since they're either integers or nil. */
4084 while (!NILP (idx))
4086 ptrdiff_t i = XFASTINT (idx);
4088 if (EQ (key, HASH_KEY (h, i))
4089 || (h->test.cmpfn
4090 && hash_code == XUINT (HASH_HASH (h, i))
4091 && h->test.cmpfn (&h->test, key, HASH_KEY (h, i))))
4093 /* Take entry out of collision chain. */
4094 if (NILP (prev))
4095 set_hash_index_slot (h, start_of_bucket, HASH_NEXT (h, i));
4096 else
4097 set_hash_next_slot (h, XFASTINT (prev), HASH_NEXT (h, i));
4099 /* Clear slots in key_and_value and add the slots to
4100 the free list. */
4101 set_hash_key_slot (h, i, Qnil);
4102 set_hash_value_slot (h, i, Qnil);
4103 set_hash_hash_slot (h, i, Qnil);
4104 set_hash_next_slot (h, i, h->next_free);
4105 h->next_free = make_number (i);
4106 h->count--;
4107 eassert (h->count >= 0);
4108 break;
4110 else
4112 prev = idx;
4113 idx = HASH_NEXT (h, i);
4119 /* Clear hash table H. */
4121 static void
4122 hash_clear (struct Lisp_Hash_Table *h)
4124 if (h->count > 0)
4126 ptrdiff_t i, size = HASH_TABLE_SIZE (h);
4128 for (i = 0; i < size; ++i)
4130 set_hash_next_slot (h, i, i < size - 1 ? make_number (i + 1) : Qnil);
4131 set_hash_key_slot (h, i, Qnil);
4132 set_hash_value_slot (h, i, Qnil);
4133 set_hash_hash_slot (h, i, Qnil);
4136 for (i = 0; i < ASIZE (h->index); ++i)
4137 ASET (h->index, i, Qnil);
4139 h->next_free = make_number (0);
4140 h->count = 0;
4146 /************************************************************************
4147 Weak Hash Tables
4148 ************************************************************************/
4150 /* Sweep weak hash table H. REMOVE_ENTRIES_P means remove
4151 entries from the table that don't survive the current GC.
4152 !REMOVE_ENTRIES_P means mark entries that are in use. Value is
4153 true if anything was marked. */
4155 static bool
4156 sweep_weak_table (struct Lisp_Hash_Table *h, bool remove_entries_p)
4158 ptrdiff_t bucket, n;
4159 bool marked;
4161 n = ASIZE (h->index) & ~ARRAY_MARK_FLAG;
4162 marked = 0;
4164 for (bucket = 0; bucket < n; ++bucket)
4166 Lisp_Object idx, next, prev;
4168 /* Follow collision chain, removing entries that
4169 don't survive this garbage collection. */
4170 prev = Qnil;
4171 for (idx = HASH_INDEX (h, bucket); !NILP (idx); idx = next)
4173 ptrdiff_t i = XFASTINT (idx);
4174 bool key_known_to_survive_p = survives_gc_p (HASH_KEY (h, i));
4175 bool value_known_to_survive_p = survives_gc_p (HASH_VALUE (h, i));
4176 bool remove_p;
4178 if (EQ (h->weak, Qkey))
4179 remove_p = !key_known_to_survive_p;
4180 else if (EQ (h->weak, Qvalue))
4181 remove_p = !value_known_to_survive_p;
4182 else if (EQ (h->weak, Qkey_or_value))
4183 remove_p = !(key_known_to_survive_p || value_known_to_survive_p);
4184 else if (EQ (h->weak, Qkey_and_value))
4185 remove_p = !(key_known_to_survive_p && value_known_to_survive_p);
4186 else
4187 emacs_abort ();
4189 next = HASH_NEXT (h, i);
4191 if (remove_entries_p)
4193 if (remove_p)
4195 /* Take out of collision chain. */
4196 if (NILP (prev))
4197 set_hash_index_slot (h, bucket, next);
4198 else
4199 set_hash_next_slot (h, XFASTINT (prev), next);
4201 /* Add to free list. */
4202 set_hash_next_slot (h, i, h->next_free);
4203 h->next_free = idx;
4205 /* Clear key, value, and hash. */
4206 set_hash_key_slot (h, i, Qnil);
4207 set_hash_value_slot (h, i, Qnil);
4208 set_hash_hash_slot (h, i, Qnil);
4210 h->count--;
4212 else
4214 prev = idx;
4217 else
4219 if (!remove_p)
4221 /* Make sure key and value survive. */
4222 if (!key_known_to_survive_p)
4224 mark_object (HASH_KEY (h, i));
4225 marked = 1;
4228 if (!value_known_to_survive_p)
4230 mark_object (HASH_VALUE (h, i));
4231 marked = 1;
4238 return marked;
4241 /* Remove elements from weak hash tables that don't survive the
4242 current garbage collection. Remove weak tables that don't survive
4243 from Vweak_hash_tables. Called from gc_sweep. */
4245 NO_INLINE /* For better stack traces */
4246 void
4247 sweep_weak_hash_tables (void)
4249 struct Lisp_Hash_Table *h, *used, *next;
4250 bool marked;
4252 /* Mark all keys and values that are in use. Keep on marking until
4253 there is no more change. This is necessary for cases like
4254 value-weak table A containing an entry X -> Y, where Y is used in a
4255 key-weak table B, Z -> Y. If B comes after A in the list of weak
4256 tables, X -> Y might be removed from A, although when looking at B
4257 one finds that it shouldn't. */
4260 marked = 0;
4261 for (h = weak_hash_tables; h; h = h->next_weak)
4263 if (h->header.size & ARRAY_MARK_FLAG)
4264 marked |= sweep_weak_table (h, 0);
4267 while (marked);
4269 /* Remove tables and entries that aren't used. */
4270 for (h = weak_hash_tables, used = NULL; h; h = next)
4272 next = h->next_weak;
4274 if (h->header.size & ARRAY_MARK_FLAG)
4276 /* TABLE is marked as used. Sweep its contents. */
4277 if (h->count > 0)
4278 sweep_weak_table (h, 1);
4280 /* Add table to the list of used weak hash tables. */
4281 h->next_weak = used;
4282 used = h;
4286 weak_hash_tables = used;
4291 /***********************************************************************
4292 Hash Code Computation
4293 ***********************************************************************/
4295 /* Maximum depth up to which to dive into Lisp structures. */
4297 #define SXHASH_MAX_DEPTH 3
4299 /* Maximum length up to which to take list and vector elements into
4300 account. */
4302 #define SXHASH_MAX_LEN 7
4304 /* Return a hash for string PTR which has length LEN. The hash value
4305 can be any EMACS_UINT value. */
4307 EMACS_UINT
4308 hash_string (char const *ptr, ptrdiff_t len)
4310 char const *p = ptr;
4311 char const *end = p + len;
4312 unsigned char c;
4313 EMACS_UINT hash = 0;
4315 while (p != end)
4317 c = *p++;
4318 hash = sxhash_combine (hash, c);
4321 return hash;
4324 /* Return a hash for string PTR which has length LEN. The hash
4325 code returned is guaranteed to fit in a Lisp integer. */
4327 static EMACS_UINT
4328 sxhash_string (char const *ptr, ptrdiff_t len)
4330 EMACS_UINT hash = hash_string (ptr, len);
4331 return SXHASH_REDUCE (hash);
4334 /* Return a hash for the floating point value VAL. */
4336 static EMACS_UINT
4337 sxhash_float (double val)
4339 EMACS_UINT hash = 0;
4340 enum {
4341 WORDS_PER_DOUBLE = (sizeof val / sizeof hash
4342 + (sizeof val % sizeof hash != 0))
4344 union {
4345 double val;
4346 EMACS_UINT word[WORDS_PER_DOUBLE];
4347 } u;
4348 int i;
4349 u.val = val;
4350 memset (&u.val + 1, 0, sizeof u - sizeof u.val);
4351 for (i = 0; i < WORDS_PER_DOUBLE; i++)
4352 hash = sxhash_combine (hash, u.word[i]);
4353 return SXHASH_REDUCE (hash);
4356 /* Return a hash for list LIST. DEPTH is the current depth in the
4357 list. We don't recurse deeper than SXHASH_MAX_DEPTH in it. */
4359 static EMACS_UINT
4360 sxhash_list (Lisp_Object list, int depth)
4362 EMACS_UINT hash = 0;
4363 int i;
4365 if (depth < SXHASH_MAX_DEPTH)
4366 for (i = 0;
4367 CONSP (list) && i < SXHASH_MAX_LEN;
4368 list = XCDR (list), ++i)
4370 EMACS_UINT hash2 = sxhash (XCAR (list), depth + 1);
4371 hash = sxhash_combine (hash, hash2);
4374 if (!NILP (list))
4376 EMACS_UINT hash2 = sxhash (list, depth + 1);
4377 hash = sxhash_combine (hash, hash2);
4380 return SXHASH_REDUCE (hash);
4384 /* Return a hash for vector VECTOR. DEPTH is the current depth in
4385 the Lisp structure. */
4387 static EMACS_UINT
4388 sxhash_vector (Lisp_Object vec, int depth)
4390 EMACS_UINT hash = ASIZE (vec);
4391 int i, n;
4393 n = min (SXHASH_MAX_LEN, ASIZE (vec));
4394 for (i = 0; i < n; ++i)
4396 EMACS_UINT hash2 = sxhash (AREF (vec, i), depth + 1);
4397 hash = sxhash_combine (hash, hash2);
4400 return SXHASH_REDUCE (hash);
4403 /* Return a hash for bool-vector VECTOR. */
4405 static EMACS_UINT
4406 sxhash_bool_vector (Lisp_Object vec)
4408 EMACS_INT size = bool_vector_size (vec);
4409 EMACS_UINT hash = size;
4410 int i, n;
4412 n = min (SXHASH_MAX_LEN, bool_vector_words (size));
4413 for (i = 0; i < n; ++i)
4414 hash = sxhash_combine (hash, bool_vector_data (vec)[i]);
4416 return SXHASH_REDUCE (hash);
4420 /* Return a hash code for OBJ. DEPTH is the current depth in the Lisp
4421 structure. Value is an unsigned integer clipped to INTMASK. */
4423 EMACS_UINT
4424 sxhash (Lisp_Object obj, int depth)
4426 EMACS_UINT hash;
4428 if (depth > SXHASH_MAX_DEPTH)
4429 return 0;
4431 switch (XTYPE (obj))
4433 case_Lisp_Int:
4434 hash = XUINT (obj);
4435 break;
4437 case Lisp_Misc:
4438 case Lisp_Symbol:
4439 hash = XHASH (obj);
4440 break;
4442 case Lisp_String:
4443 hash = sxhash_string (SSDATA (obj), SBYTES (obj));
4444 break;
4446 /* This can be everything from a vector to an overlay. */
4447 case Lisp_Vectorlike:
4448 if (VECTORP (obj))
4449 /* According to the CL HyperSpec, two arrays are equal only if
4450 they are `eq', except for strings and bit-vectors. In
4451 Emacs, this works differently. We have to compare element
4452 by element. */
4453 hash = sxhash_vector (obj, depth);
4454 else if (BOOL_VECTOR_P (obj))
4455 hash = sxhash_bool_vector (obj);
4456 else
4457 /* Others are `equal' if they are `eq', so let's take their
4458 address as hash. */
4459 hash = XHASH (obj);
4460 break;
4462 case Lisp_Cons:
4463 hash = sxhash_list (obj, depth);
4464 break;
4466 case Lisp_Float:
4467 hash = sxhash_float (XFLOAT_DATA (obj));
4468 break;
4470 default:
4471 emacs_abort ();
4474 return hash;
4479 /***********************************************************************
4480 Lisp Interface
4481 ***********************************************************************/
4484 DEFUN ("sxhash", Fsxhash, Ssxhash, 1, 1, 0,
4485 doc: /* Compute a hash code for OBJ and return it as integer. */)
4486 (Lisp_Object obj)
4488 EMACS_UINT hash = sxhash (obj, 0);
4489 return make_number (hash);
4493 DEFUN ("make-hash-table", Fmake_hash_table, Smake_hash_table, 0, MANY, 0,
4494 doc: /* Create and return a new hash table.
4496 Arguments are specified as keyword/argument pairs. The following
4497 arguments are defined:
4499 :test TEST -- TEST must be a symbol that specifies how to compare
4500 keys. Default is `eql'. Predefined are the tests `eq', `eql', and
4501 `equal'. User-supplied test and hash functions can be specified via
4502 `define-hash-table-test'.
4504 :size SIZE -- A hint as to how many elements will be put in the table.
4505 Default is 65.
4507 :rehash-size REHASH-SIZE - Indicates how to expand the table when it
4508 fills up. If REHASH-SIZE is an integer, increase the size by that
4509 amount. If it is a float, it must be > 1.0, and the new size is the
4510 old size multiplied by that factor. Default is 1.5.
4512 :rehash-threshold THRESHOLD -- THRESHOLD must a float > 0, and <= 1.0.
4513 Resize the hash table when the ratio (number of entries / table size)
4514 is greater than or equal to THRESHOLD. Default is 0.8.
4516 :weakness WEAK -- WEAK must be one of nil, t, `key', `value',
4517 `key-or-value', or `key-and-value'. If WEAK is not nil, the table
4518 returned is a weak table. Key/value pairs are removed from a weak
4519 hash table when there are no non-weak references pointing to their
4520 key, value, one of key or value, or both key and value, depending on
4521 WEAK. WEAK t is equivalent to `key-and-value'. Default value of WEAK
4522 is nil.
4524 usage: (make-hash-table &rest KEYWORD-ARGS) */)
4525 (ptrdiff_t nargs, Lisp_Object *args)
4527 Lisp_Object test, size, rehash_size, rehash_threshold, weak;
4528 struct hash_table_test testdesc;
4529 ptrdiff_t i;
4530 USE_SAFE_ALLOCA;
4532 /* The vector `used' is used to keep track of arguments that
4533 have been consumed. */
4534 char *used = SAFE_ALLOCA (nargs * sizeof *used);
4535 memset (used, 0, nargs * sizeof *used);
4537 /* See if there's a `:test TEST' among the arguments. */
4538 i = get_key_arg (QCtest, nargs, args, used);
4539 test = i ? args[i] : Qeql;
4540 if (EQ (test, Qeq))
4541 testdesc = hashtest_eq;
4542 else if (EQ (test, Qeql))
4543 testdesc = hashtest_eql;
4544 else if (EQ (test, Qequal))
4545 testdesc = hashtest_equal;
4546 else
4548 /* See if it is a user-defined test. */
4549 Lisp_Object prop;
4551 prop = Fget (test, Qhash_table_test);
4552 if (!CONSP (prop) || !CONSP (XCDR (prop)))
4553 signal_error ("Invalid hash table test", test);
4554 testdesc.name = test;
4555 testdesc.user_cmp_function = XCAR (prop);
4556 testdesc.user_hash_function = XCAR (XCDR (prop));
4557 testdesc.hashfn = hashfn_user_defined;
4558 testdesc.cmpfn = cmpfn_user_defined;
4561 /* See if there's a `:size SIZE' argument. */
4562 i = get_key_arg (QCsize, nargs, args, used);
4563 size = i ? args[i] : Qnil;
4564 if (NILP (size))
4565 size = make_number (DEFAULT_HASH_SIZE);
4566 else if (!INTEGERP (size) || XINT (size) < 0)
4567 signal_error ("Invalid hash table size", size);
4569 /* Look for `:rehash-size SIZE'. */
4570 i = get_key_arg (QCrehash_size, nargs, args, used);
4571 rehash_size = i ? args[i] : make_float (DEFAULT_REHASH_SIZE);
4572 if (! ((INTEGERP (rehash_size) && 0 < XINT (rehash_size))
4573 || (FLOATP (rehash_size) && 1 < XFLOAT_DATA (rehash_size))))
4574 signal_error ("Invalid hash table rehash size", rehash_size);
4576 /* Look for `:rehash-threshold THRESHOLD'. */
4577 i = get_key_arg (QCrehash_threshold, nargs, args, used);
4578 rehash_threshold = i ? args[i] : make_float (DEFAULT_REHASH_THRESHOLD);
4579 if (! (FLOATP (rehash_threshold)
4580 && 0 < XFLOAT_DATA (rehash_threshold)
4581 && XFLOAT_DATA (rehash_threshold) <= 1))
4582 signal_error ("Invalid hash table rehash threshold", rehash_threshold);
4584 /* Look for `:weakness WEAK'. */
4585 i = get_key_arg (QCweakness, nargs, args, used);
4586 weak = i ? args[i] : Qnil;
4587 if (EQ (weak, Qt))
4588 weak = Qkey_and_value;
4589 if (!NILP (weak)
4590 && !EQ (weak, Qkey)
4591 && !EQ (weak, Qvalue)
4592 && !EQ (weak, Qkey_or_value)
4593 && !EQ (weak, Qkey_and_value))
4594 signal_error ("Invalid hash table weakness", weak);
4596 /* Now, all args should have been used up, or there's a problem. */
4597 for (i = 0; i < nargs; ++i)
4598 if (!used[i])
4599 signal_error ("Invalid argument list", args[i]);
4601 SAFE_FREE ();
4602 return make_hash_table (testdesc, size, rehash_size, rehash_threshold, weak);
4606 DEFUN ("copy-hash-table", Fcopy_hash_table, Scopy_hash_table, 1, 1, 0,
4607 doc: /* Return a copy of hash table TABLE. */)
4608 (Lisp_Object table)
4610 return copy_hash_table (check_hash_table (table));
4614 DEFUN ("hash-table-count", Fhash_table_count, Shash_table_count, 1, 1, 0,
4615 doc: /* Return the number of elements in TABLE. */)
4616 (Lisp_Object table)
4618 return make_number (check_hash_table (table)->count);
4622 DEFUN ("hash-table-rehash-size", Fhash_table_rehash_size,
4623 Shash_table_rehash_size, 1, 1, 0,
4624 doc: /* Return the current rehash size of TABLE. */)
4625 (Lisp_Object table)
4627 return check_hash_table (table)->rehash_size;
4631 DEFUN ("hash-table-rehash-threshold", Fhash_table_rehash_threshold,
4632 Shash_table_rehash_threshold, 1, 1, 0,
4633 doc: /* Return the current rehash threshold of TABLE. */)
4634 (Lisp_Object table)
4636 return check_hash_table (table)->rehash_threshold;
4640 DEFUN ("hash-table-size", Fhash_table_size, Shash_table_size, 1, 1, 0,
4641 doc: /* Return the size of TABLE.
4642 The size can be used as an argument to `make-hash-table' to create
4643 a hash table than can hold as many elements as TABLE holds
4644 without need for resizing. */)
4645 (Lisp_Object table)
4647 struct Lisp_Hash_Table *h = check_hash_table (table);
4648 return make_number (HASH_TABLE_SIZE (h));
4652 DEFUN ("hash-table-test", Fhash_table_test, Shash_table_test, 1, 1, 0,
4653 doc: /* Return the test TABLE uses. */)
4654 (Lisp_Object table)
4656 return check_hash_table (table)->test.name;
4660 DEFUN ("hash-table-weakness", Fhash_table_weakness, Shash_table_weakness,
4661 1, 1, 0,
4662 doc: /* Return the weakness of TABLE. */)
4663 (Lisp_Object table)
4665 return check_hash_table (table)->weak;
4669 DEFUN ("hash-table-p", Fhash_table_p, Shash_table_p, 1, 1, 0,
4670 doc: /* Return t if OBJ is a Lisp hash table object. */)
4671 (Lisp_Object obj)
4673 return HASH_TABLE_P (obj) ? Qt : Qnil;
4677 DEFUN ("clrhash", Fclrhash, Sclrhash, 1, 1, 0,
4678 doc: /* Clear hash table TABLE and return it. */)
4679 (Lisp_Object table)
4681 hash_clear (check_hash_table (table));
4682 /* Be compatible with XEmacs. */
4683 return table;
4687 DEFUN ("gethash", Fgethash, Sgethash, 2, 3, 0,
4688 doc: /* Look up KEY in TABLE and return its associated value.
4689 If KEY is not found, return DFLT which defaults to nil. */)
4690 (Lisp_Object key, Lisp_Object table, Lisp_Object dflt)
4692 struct Lisp_Hash_Table *h = check_hash_table (table);
4693 ptrdiff_t i = hash_lookup (h, key, NULL);
4694 return i >= 0 ? HASH_VALUE (h, i) : dflt;
4698 DEFUN ("puthash", Fputhash, Sputhash, 3, 3, 0,
4699 doc: /* Associate KEY with VALUE in hash table TABLE.
4700 If KEY is already present in table, replace its current value with
4701 VALUE. In any case, return VALUE. */)
4702 (Lisp_Object key, Lisp_Object value, Lisp_Object table)
4704 struct Lisp_Hash_Table *h = check_hash_table (table);
4705 ptrdiff_t i;
4706 EMACS_UINT hash;
4708 i = hash_lookup (h, key, &hash);
4709 if (i >= 0)
4710 set_hash_value_slot (h, i, value);
4711 else
4712 hash_put (h, key, value, hash);
4714 return value;
4718 DEFUN ("remhash", Fremhash, Sremhash, 2, 2, 0,
4719 doc: /* Remove KEY from TABLE. */)
4720 (Lisp_Object key, Lisp_Object table)
4722 struct Lisp_Hash_Table *h = check_hash_table (table);
4723 hash_remove_from_table (h, key);
4724 return Qnil;
4728 DEFUN ("maphash", Fmaphash, Smaphash, 2, 2, 0,
4729 doc: /* Call FUNCTION for all entries in hash table TABLE.
4730 FUNCTION is called with two arguments, KEY and VALUE.
4731 `maphash' always returns nil. */)
4732 (Lisp_Object function, Lisp_Object table)
4734 struct Lisp_Hash_Table *h = check_hash_table (table);
4736 for (ptrdiff_t i = 0; i < HASH_TABLE_SIZE (h); ++i)
4737 if (!NILP (HASH_HASH (h, i)))
4738 call2 (function, HASH_KEY (h, i), HASH_VALUE (h, i));
4740 return Qnil;
4744 DEFUN ("define-hash-table-test", Fdefine_hash_table_test,
4745 Sdefine_hash_table_test, 3, 3, 0,
4746 doc: /* Define a new hash table test with name NAME, a symbol.
4748 In hash tables created with NAME specified as test, use TEST to
4749 compare keys, and HASH for computing hash codes of keys.
4751 TEST must be a function taking two arguments and returning non-nil if
4752 both arguments are the same. HASH must be a function taking one
4753 argument and returning an object that is the hash code of the argument.
4754 It should be the case that if (eq (funcall HASH x1) (funcall HASH x2))
4755 returns nil, then (funcall TEST x1 x2) also returns nil. */)
4756 (Lisp_Object name, Lisp_Object test, Lisp_Object hash)
4758 return Fput (name, Qhash_table_test, list2 (test, hash));
4763 /************************************************************************
4764 MD5, SHA-1, and SHA-2
4765 ************************************************************************/
4767 #include "md5.h"
4768 #include "sha1.h"
4769 #include "sha256.h"
4770 #include "sha512.h"
4772 /* ALGORITHM is a symbol: md5, sha1, sha224 and so on. */
4774 static Lisp_Object
4775 secure_hash (Lisp_Object algorithm, Lisp_Object object, Lisp_Object start,
4776 Lisp_Object end, Lisp_Object coding_system, Lisp_Object noerror,
4777 Lisp_Object binary)
4779 int i;
4780 ptrdiff_t size, start_char = 0, start_byte, end_char = 0, end_byte;
4781 register EMACS_INT b, e;
4782 register struct buffer *bp;
4783 EMACS_INT temp;
4784 int digest_size;
4785 void *(*hash_func) (const char *, size_t, void *);
4786 Lisp_Object digest;
4788 CHECK_SYMBOL (algorithm);
4790 if (STRINGP (object))
4792 if (NILP (coding_system))
4794 /* Decide the coding-system to encode the data with. */
4796 if (STRING_MULTIBYTE (object))
4797 /* use default, we can't guess correct value */
4798 coding_system = preferred_coding_system ();
4799 else
4800 coding_system = Qraw_text;
4803 if (NILP (Fcoding_system_p (coding_system)))
4805 /* Invalid coding system. */
4807 if (!NILP (noerror))
4808 coding_system = Qraw_text;
4809 else
4810 xsignal1 (Qcoding_system_error, coding_system);
4813 if (STRING_MULTIBYTE (object))
4814 object = code_convert_string (object, coding_system, Qnil, 1, 0, 1);
4816 size = SCHARS (object);
4817 validate_subarray (object, start, end, size, &start_char, &end_char);
4819 start_byte = !start_char ? 0 : string_char_to_byte (object, start_char);
4820 end_byte = (end_char == size
4821 ? SBYTES (object)
4822 : string_char_to_byte (object, end_char));
4824 else
4826 struct buffer *prev = current_buffer;
4828 record_unwind_current_buffer ();
4830 CHECK_BUFFER (object);
4832 bp = XBUFFER (object);
4833 set_buffer_internal (bp);
4835 if (NILP (start))
4836 b = BEGV;
4837 else
4839 CHECK_NUMBER_COERCE_MARKER (start);
4840 b = XINT (start);
4843 if (NILP (end))
4844 e = ZV;
4845 else
4847 CHECK_NUMBER_COERCE_MARKER (end);
4848 e = XINT (end);
4851 if (b > e)
4852 temp = b, b = e, e = temp;
4854 if (!(BEGV <= b && e <= ZV))
4855 args_out_of_range (start, end);
4857 if (NILP (coding_system))
4859 /* Decide the coding-system to encode the data with.
4860 See fileio.c:Fwrite-region */
4862 if (!NILP (Vcoding_system_for_write))
4863 coding_system = Vcoding_system_for_write;
4864 else
4866 bool force_raw_text = 0;
4868 coding_system = BVAR (XBUFFER (object), buffer_file_coding_system);
4869 if (NILP (coding_system)
4870 || NILP (Flocal_variable_p (Qbuffer_file_coding_system, Qnil)))
4872 coding_system = Qnil;
4873 if (NILP (BVAR (current_buffer, enable_multibyte_characters)))
4874 force_raw_text = 1;
4877 if (NILP (coding_system) && !NILP (Fbuffer_file_name (object)))
4879 /* Check file-coding-system-alist. */
4880 Lisp_Object val = CALLN (Ffind_operation_coding_system,
4881 Qwrite_region, start, end,
4882 Fbuffer_file_name (object));
4883 if (CONSP (val) && !NILP (XCDR (val)))
4884 coding_system = XCDR (val);
4887 if (NILP (coding_system)
4888 && !NILP (BVAR (XBUFFER (object), buffer_file_coding_system)))
4890 /* If we still have not decided a coding system, use the
4891 default value of buffer-file-coding-system. */
4892 coding_system = BVAR (XBUFFER (object), buffer_file_coding_system);
4895 if (!force_raw_text
4896 && !NILP (Ffboundp (Vselect_safe_coding_system_function)))
4897 /* Confirm that VAL can surely encode the current region. */
4898 coding_system = call4 (Vselect_safe_coding_system_function,
4899 make_number (b), make_number (e),
4900 coding_system, Qnil);
4902 if (force_raw_text)
4903 coding_system = Qraw_text;
4906 if (NILP (Fcoding_system_p (coding_system)))
4908 /* Invalid coding system. */
4910 if (!NILP (noerror))
4911 coding_system = Qraw_text;
4912 else
4913 xsignal1 (Qcoding_system_error, coding_system);
4917 object = make_buffer_string (b, e, 0);
4918 set_buffer_internal (prev);
4919 /* Discard the unwind protect for recovering the current
4920 buffer. */
4921 specpdl_ptr--;
4923 if (STRING_MULTIBYTE (object))
4924 object = code_convert_string (object, coding_system, Qnil, 1, 0, 0);
4925 start_byte = 0;
4926 end_byte = SBYTES (object);
4929 if (EQ (algorithm, Qmd5))
4931 digest_size = MD5_DIGEST_SIZE;
4932 hash_func = md5_buffer;
4934 else if (EQ (algorithm, Qsha1))
4936 digest_size = SHA1_DIGEST_SIZE;
4937 hash_func = sha1_buffer;
4939 else if (EQ (algorithm, Qsha224))
4941 digest_size = SHA224_DIGEST_SIZE;
4942 hash_func = sha224_buffer;
4944 else if (EQ (algorithm, Qsha256))
4946 digest_size = SHA256_DIGEST_SIZE;
4947 hash_func = sha256_buffer;
4949 else if (EQ (algorithm, Qsha384))
4951 digest_size = SHA384_DIGEST_SIZE;
4952 hash_func = sha384_buffer;
4954 else if (EQ (algorithm, Qsha512))
4956 digest_size = SHA512_DIGEST_SIZE;
4957 hash_func = sha512_buffer;
4959 else
4960 error ("Invalid algorithm arg: %s", SDATA (Fsymbol_name (algorithm)));
4962 /* allocate 2 x digest_size so that it can be re-used to hold the
4963 hexified value */
4964 digest = make_uninit_string (digest_size * 2);
4966 hash_func (SSDATA (object) + start_byte,
4967 end_byte - start_byte,
4968 SSDATA (digest));
4970 if (NILP (binary))
4972 unsigned char *p = SDATA (digest);
4973 for (i = digest_size - 1; i >= 0; i--)
4975 static char const hexdigit[16] = "0123456789abcdef";
4976 int p_i = p[i];
4977 p[2 * i] = hexdigit[p_i >> 4];
4978 p[2 * i + 1] = hexdigit[p_i & 0xf];
4980 return digest;
4982 else
4983 return make_unibyte_string (SSDATA (digest), digest_size);
4986 DEFUN ("md5", Fmd5, Smd5, 1, 5, 0,
4987 doc: /* Return MD5 message digest of OBJECT, a buffer or string.
4989 A message digest is a cryptographic checksum of a document, and the
4990 algorithm to calculate it is defined in RFC 1321.
4992 The two optional arguments START and END are character positions
4993 specifying for which part of OBJECT the message digest should be
4994 computed. If nil or omitted, the digest is computed for the whole
4995 OBJECT.
4997 The MD5 message digest is computed from the result of encoding the
4998 text in a coding system, not directly from the internal Emacs form of
4999 the text. The optional fourth argument CODING-SYSTEM specifies which
5000 coding system to encode the text with. It should be the same coding
5001 system that you used or will use when actually writing the text into a
5002 file.
5004 If CODING-SYSTEM is nil or omitted, the default depends on OBJECT. If
5005 OBJECT is a buffer, the default for CODING-SYSTEM is whatever coding
5006 system would be chosen by default for writing this text into a file.
5008 If OBJECT is a string, the most preferred coding system (see the
5009 command `prefer-coding-system') is used.
5011 If NOERROR is non-nil, silently assume the `raw-text' coding if the
5012 guesswork fails. Normally, an error is signaled in such case. */)
5013 (Lisp_Object object, Lisp_Object start, Lisp_Object end, Lisp_Object coding_system, Lisp_Object noerror)
5015 return secure_hash (Qmd5, object, start, end, coding_system, noerror, Qnil);
5018 DEFUN ("secure-hash", Fsecure_hash, Ssecure_hash, 2, 5, 0,
5019 doc: /* Return the secure hash of OBJECT, a buffer or string.
5020 ALGORITHM is a symbol specifying the hash to use:
5021 md5, sha1, sha224, sha256, sha384 or sha512.
5023 The two optional arguments START and END are positions specifying for
5024 which part of OBJECT to compute the hash. If nil or omitted, uses the
5025 whole OBJECT.
5027 If BINARY is non-nil, returns a string in binary form. */)
5028 (Lisp_Object algorithm, Lisp_Object object, Lisp_Object start, Lisp_Object end, Lisp_Object binary)
5030 return secure_hash (algorithm, object, start, end, Qnil, Qnil, binary);
5033 void
5034 syms_of_fns (void)
5036 DEFSYM (Qmd5, "md5");
5037 DEFSYM (Qsha1, "sha1");
5038 DEFSYM (Qsha224, "sha224");
5039 DEFSYM (Qsha256, "sha256");
5040 DEFSYM (Qsha384, "sha384");
5041 DEFSYM (Qsha512, "sha512");
5043 /* Hash table stuff. */
5044 DEFSYM (Qhash_table_p, "hash-table-p");
5045 DEFSYM (Qeq, "eq");
5046 DEFSYM (Qeql, "eql");
5047 DEFSYM (Qequal, "equal");
5048 DEFSYM (QCtest, ":test");
5049 DEFSYM (QCsize, ":size");
5050 DEFSYM (QCrehash_size, ":rehash-size");
5051 DEFSYM (QCrehash_threshold, ":rehash-threshold");
5052 DEFSYM (QCweakness, ":weakness");
5053 DEFSYM (Qkey, "key");
5054 DEFSYM (Qvalue, "value");
5055 DEFSYM (Qhash_table_test, "hash-table-test");
5056 DEFSYM (Qkey_or_value, "key-or-value");
5057 DEFSYM (Qkey_and_value, "key-and-value");
5059 defsubr (&Ssxhash);
5060 defsubr (&Smake_hash_table);
5061 defsubr (&Scopy_hash_table);
5062 defsubr (&Shash_table_count);
5063 defsubr (&Shash_table_rehash_size);
5064 defsubr (&Shash_table_rehash_threshold);
5065 defsubr (&Shash_table_size);
5066 defsubr (&Shash_table_test);
5067 defsubr (&Shash_table_weakness);
5068 defsubr (&Shash_table_p);
5069 defsubr (&Sclrhash);
5070 defsubr (&Sgethash);
5071 defsubr (&Sputhash);
5072 defsubr (&Sremhash);
5073 defsubr (&Smaphash);
5074 defsubr (&Sdefine_hash_table_test);
5076 DEFSYM (Qstring_lessp, "string-lessp");
5077 DEFSYM (Qstring_collate_lessp, "string-collate-lessp");
5078 DEFSYM (Qstring_collate_equalp, "string-collate-equalp");
5079 DEFSYM (Qprovide, "provide");
5080 DEFSYM (Qrequire, "require");
5081 DEFSYM (Qyes_or_no_p_history, "yes-or-no-p-history");
5082 DEFSYM (Qcursor_in_echo_area, "cursor-in-echo-area");
5083 DEFSYM (Qwidget_type, "widget-type");
5085 staticpro (&string_char_byte_cache_string);
5086 string_char_byte_cache_string = Qnil;
5088 require_nesting_list = Qnil;
5089 staticpro (&require_nesting_list);
5091 Fset (Qyes_or_no_p_history, Qnil);
5093 DEFVAR_LISP ("features", Vfeatures,
5094 doc: /* A list of symbols which are the features of the executing Emacs.
5095 Used by `featurep' and `require', and altered by `provide'. */);
5096 Vfeatures = list1 (Qemacs);
5097 DEFSYM (Qsubfeatures, "subfeatures");
5098 DEFSYM (Qfuncall, "funcall");
5100 #ifdef HAVE_LANGINFO_CODESET
5101 DEFSYM (Qcodeset, "codeset");
5102 DEFSYM (Qdays, "days");
5103 DEFSYM (Qmonths, "months");
5104 DEFSYM (Qpaper, "paper");
5105 #endif /* HAVE_LANGINFO_CODESET */
5107 DEFVAR_BOOL ("use-dialog-box", use_dialog_box,
5108 doc: /* Non-nil means mouse commands use dialog boxes to ask questions.
5109 This applies to `y-or-n-p' and `yes-or-no-p' questions asked by commands
5110 invoked by mouse clicks and mouse menu items.
5112 On some platforms, file selection dialogs are also enabled if this is
5113 non-nil. */);
5114 use_dialog_box = 1;
5116 DEFVAR_BOOL ("use-file-dialog", use_file_dialog,
5117 doc: /* Non-nil means mouse commands use a file dialog to ask for files.
5118 This applies to commands from menus and tool bar buttons even when
5119 they are initiated from the keyboard. If `use-dialog-box' is nil,
5120 that disables the use of a file dialog, regardless of the value of
5121 this variable. */);
5122 use_file_dialog = 1;
5124 defsubr (&Sidentity);
5125 defsubr (&Srandom);
5126 defsubr (&Slength);
5127 defsubr (&Ssafe_length);
5128 defsubr (&Sstring_bytes);
5129 defsubr (&Sstring_equal);
5130 defsubr (&Scompare_strings);
5131 defsubr (&Sstring_lessp);
5132 defsubr (&Sstring_collate_lessp);
5133 defsubr (&Sstring_collate_equalp);
5134 defsubr (&Sappend);
5135 defsubr (&Sconcat);
5136 defsubr (&Svconcat);
5137 defsubr (&Scopy_sequence);
5138 defsubr (&Sstring_make_multibyte);
5139 defsubr (&Sstring_make_unibyte);
5140 defsubr (&Sstring_as_multibyte);
5141 defsubr (&Sstring_as_unibyte);
5142 defsubr (&Sstring_to_multibyte);
5143 defsubr (&Sstring_to_unibyte);
5144 defsubr (&Scopy_alist);
5145 defsubr (&Ssubstring);
5146 defsubr (&Ssubstring_no_properties);
5147 defsubr (&Snthcdr);
5148 defsubr (&Snth);
5149 defsubr (&Selt);
5150 defsubr (&Smember);
5151 defsubr (&Smemq);
5152 defsubr (&Smemql);
5153 defsubr (&Sassq);
5154 defsubr (&Sassoc);
5155 defsubr (&Srassq);
5156 defsubr (&Srassoc);
5157 defsubr (&Sdelq);
5158 defsubr (&Sdelete);
5159 defsubr (&Snreverse);
5160 defsubr (&Sreverse);
5161 defsubr (&Ssort);
5162 defsubr (&Splist_get);
5163 defsubr (&Sget);
5164 defsubr (&Splist_put);
5165 defsubr (&Sput);
5166 defsubr (&Slax_plist_get);
5167 defsubr (&Slax_plist_put);
5168 defsubr (&Seql);
5169 defsubr (&Sequal);
5170 defsubr (&Sequal_including_properties);
5171 defsubr (&Sfillarray);
5172 defsubr (&Sclear_string);
5173 defsubr (&Snconc);
5174 defsubr (&Smapcar);
5175 defsubr (&Smapc);
5176 defsubr (&Smapconcat);
5177 defsubr (&Syes_or_no_p);
5178 defsubr (&Sload_average);
5179 defsubr (&Sfeaturep);
5180 defsubr (&Srequire);
5181 defsubr (&Sprovide);
5182 defsubr (&Splist_member);
5183 defsubr (&Swidget_put);
5184 defsubr (&Swidget_get);
5185 defsubr (&Swidget_apply);
5186 defsubr (&Sbase64_encode_region);
5187 defsubr (&Sbase64_decode_region);
5188 defsubr (&Sbase64_encode_string);
5189 defsubr (&Sbase64_decode_string);
5190 defsubr (&Smd5);
5191 defsubr (&Ssecure_hash);
5192 defsubr (&Slocale_info);
5194 hashtest_eq.name = Qeq;
5195 hashtest_eq.user_hash_function = Qnil;
5196 hashtest_eq.user_cmp_function = Qnil;
5197 hashtest_eq.cmpfn = 0;
5198 hashtest_eq.hashfn = hashfn_eq;
5200 hashtest_eql.name = Qeql;
5201 hashtest_eql.user_hash_function = Qnil;
5202 hashtest_eql.user_cmp_function = Qnil;
5203 hashtest_eql.cmpfn = cmpfn_eql;
5204 hashtest_eql.hashfn = hashfn_eql;
5206 hashtest_equal.name = Qequal;
5207 hashtest_equal.user_hash_function = Qnil;
5208 hashtest_equal.user_cmp_function = Qnil;
5209 hashtest_equal.cmpfn = cmpfn_equal;
5210 hashtest_equal.hashfn = hashfn_equal;