1 /* Random utility Lisp functions.
3 Copyright (C) 1985-1987, 1993-1995, 1997-2018 Free Software Foundation,
6 This file is part of GNU Emacs.
8 GNU Emacs is free software: you can redistribute it and/or modify
9 it under the terms of the GNU General Public License as published by
10 the Free Software Foundation, either version 3 of the License, or (at
11 your option) any later version.
13 GNU Emacs is distributed in the hope that it will be useful,
14 but WITHOUT ANY WARRANTY; without even the implied warranty of
15 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
16 GNU General Public License for more details.
18 You should have received a copy of the GNU General Public License
19 along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. */
25 #include <filevercmp.h>
31 #include "character.h"
33 #include "composite.h"
35 #include "intervals.h"
40 #if defined WINDOWSNT && defined HAVE_GNUTLS3
41 # define gnutls_rnd w32_gnutls_rnd
44 static void sort_vector_copy (Lisp_Object
, ptrdiff_t,
45 Lisp_Object
*restrict
, Lisp_Object
*restrict
);
46 enum equal_kind
{ EQUAL_NO_QUIT
, EQUAL_PLAIN
, EQUAL_INCLUDING_PROPERTIES
};
47 static bool internal_equal (Lisp_Object
, Lisp_Object
,
48 enum equal_kind
, int, Lisp_Object
);
50 DEFUN ("identity", Fidentity
, Sidentity
, 1, 1, 0,
51 doc
: /* Return the argument unchanged. */
58 DEFUN ("random", Frandom
, Srandom
, 0, 1, 0,
59 doc
: /* Return a pseudo-random number.
60 All integers representable in Lisp, i.e. between `most-negative-fixnum'
61 and `most-positive-fixnum', inclusive, are equally likely.
63 With positive integer LIMIT, return random number in interval [0,LIMIT).
64 With argument t, set the random number seed from the system's entropy
65 pool if available, otherwise from less-random volatile data such as the time.
66 With a string argument, set the seed based on the string's contents.
67 Other values of LIMIT are ignored.
69 See Info node `(elisp)Random Numbers' for more details. */)
76 else if (STRINGP (limit
))
77 seed_random (SSDATA (limit
), SBYTES (limit
));
80 if (INTEGERP (limit
) && 0 < XINT (limit
))
83 /* Return the remainder, except reject the rare case where
84 get_random returns a number so close to INTMASK that the
85 remainder isn't random. */
86 EMACS_INT remainder
= val
% XINT (limit
);
87 if (val
- remainder
<= INTMASK
- XINT (limit
) + 1)
88 return make_number (remainder
);
91 return make_number (val
);
94 /* Random data-structure functions. */
96 DEFUN ("length", Flength
, Slength
, 1, 1, 0,
97 doc
: /* Return the length of vector, list or string SEQUENCE.
98 A byte-code function object is also allowed.
99 If the string contains multibyte characters, this is not necessarily
100 the number of bytes in the string; it is the number of characters.
101 To get the number of bytes, use `string-bytes'. */)
102 (register Lisp_Object sequence
)
104 register Lisp_Object val
;
106 if (STRINGP (sequence
))
107 XSETFASTINT (val
, SCHARS (sequence
));
108 else if (VECTORP (sequence
))
109 XSETFASTINT (val
, ASIZE (sequence
));
110 else if (CHAR_TABLE_P (sequence
))
111 XSETFASTINT (val
, MAX_CHAR
);
112 else if (BOOL_VECTOR_P (sequence
))
113 XSETFASTINT (val
, bool_vector_size (sequence
));
114 else if (COMPILEDP (sequence
) || RECORDP (sequence
))
115 XSETFASTINT (val
, PVSIZE (sequence
));
116 else if (CONSP (sequence
))
119 FOR_EACH_TAIL (sequence
)
121 CHECK_LIST_END (sequence
, sequence
);
122 if (MOST_POSITIVE_FIXNUM
< i
)
123 error ("List too long");
124 val
= make_number (i
);
126 else if (NILP (sequence
))
127 XSETFASTINT (val
, 0);
129 wrong_type_argument (Qsequencep
, sequence
);
134 DEFUN ("safe-length", Fsafe_length
, Ssafe_length
, 1, 1, 0,
135 doc
: /* Return the length of a list, but avoid error or infinite loop.
136 This function never gets an error. If LIST is not really a list,
137 it returns 0. If LIST is circular, it returns a finite value
138 which is at least the number of distinct elements. */)
142 FOR_EACH_TAIL_SAFE (list
)
144 return make_fixnum_or_float (len
);
147 DEFUN ("string-bytes", Fstring_bytes
, Sstring_bytes
, 1, 1, 0,
148 doc
: /* Return the number of bytes in STRING.
149 If STRING is multibyte, this may be greater than the length of STRING. */)
152 CHECK_STRING (string
);
153 return make_number (SBYTES (string
));
156 DEFUN ("string-distance", Fstring_distance
, Sstring_distance
, 2, 3, 0,
157 doc
: /* Return Levenshtein distance between STRING1 and STRING2.
158 The distance is the number of deletions, insertions, and substitutions
159 required to transform STRING1 into STRING2.
160 If BYTECOMPARE is nil or omitted, compute distance in terms of characters.
161 If BYTECOMPARE is non-nil, compute distance in terms of bytes.
162 Letter-case is significant, but text properties are ignored. */)
163 (Lisp_Object string1
, Lisp_Object string2
, Lisp_Object bytecompare
)
166 CHECK_STRING (string1
);
167 CHECK_STRING (string2
);
169 bool use_byte_compare
=
171 || (!STRING_MULTIBYTE (string1
) && !STRING_MULTIBYTE (string2
));
172 ptrdiff_t len1
= use_byte_compare
? SBYTES (string1
) : SCHARS (string1
);
173 ptrdiff_t len2
= use_byte_compare
? SBYTES (string2
) : SCHARS (string2
);
174 ptrdiff_t x
, y
, lastdiag
, olddiag
;
177 ptrdiff_t *column
= SAFE_ALLOCA ((len1
+ 1) * sizeof (ptrdiff_t));
178 for (y
= 1; y
<= len1
; y
++)
181 if (use_byte_compare
)
183 char *s1
= SSDATA (string1
);
184 char *s2
= SSDATA (string2
);
186 for (x
= 1; x
<= len2
; x
++)
189 for (y
= 1, lastdiag
= x
- 1; y
<= len1
; y
++)
192 column
[y
] = min (min (column
[y
] + 1, column
[y
-1] + 1),
193 lastdiag
+ (s1
[y
-1] == s2
[x
-1] ? 0 : 1));
201 ptrdiff_t i1
, i1_byte
, i2
= 0, i2_byte
= 0;
202 for (x
= 1; x
<= len2
; x
++)
205 FETCH_STRING_CHAR_ADVANCE (c2
, string2
, i2
, i2_byte
);
207 for (y
= 1, lastdiag
= x
- 1; y
<= len1
; y
++)
210 FETCH_STRING_CHAR_ADVANCE (c1
, string1
, i1
, i1_byte
);
211 column
[y
] = min (min (column
[y
] + 1, column
[y
-1] + 1),
212 lastdiag
+ (c1
== c2
? 0 : 1));
219 return make_number (column
[len1
]);
222 DEFUN ("string-equal", Fstring_equal
, Sstring_equal
, 2, 2, 0,
223 doc
: /* Return t if two strings have identical contents.
224 Case is significant, but text properties are ignored.
225 Symbols are also allowed; their print names are used instead. */)
226 (register Lisp_Object s1
, Lisp_Object s2
)
229 s1
= SYMBOL_NAME (s1
);
231 s2
= SYMBOL_NAME (s2
);
235 if (SCHARS (s1
) != SCHARS (s2
)
236 || SBYTES (s1
) != SBYTES (s2
)
237 || memcmp (SDATA (s1
), SDATA (s2
), SBYTES (s1
)))
242 DEFUN ("compare-strings", Fcompare_strings
, Scompare_strings
, 6, 7, 0,
243 doc
: /* Compare the contents of two strings, converting to multibyte if needed.
244 The arguments START1, END1, START2, and END2, if non-nil, are
245 positions specifying which parts of STR1 or STR2 to compare. In
246 string STR1, compare the part between START1 (inclusive) and END1
247 \(exclusive). If START1 is nil, it defaults to 0, the beginning of
248 the string; if END1 is nil, it defaults to the length of the string.
249 Likewise, in string STR2, compare the part between START2 and END2.
250 Like in `substring', negative values are counted from the end.
252 The strings are compared by the numeric values of their characters.
253 For instance, STR1 is "less than" STR2 if its first differing
254 character has a smaller numeric value. If IGNORE-CASE is non-nil,
255 characters are converted to upper-case before comparing them. Unibyte
256 strings are converted to multibyte for comparison.
258 The value is t if the strings (or specified portions) match.
259 If string STR1 is less, the value is a negative number N;
260 - 1 - N is the number of characters that match at the beginning.
261 If string STR1 is greater, the value is a positive number N;
262 N - 1 is the number of characters that match at the beginning. */)
263 (Lisp_Object str1
, Lisp_Object start1
, Lisp_Object end1
, Lisp_Object str2
,
264 Lisp_Object start2
, Lisp_Object end2
, Lisp_Object ignore_case
)
266 ptrdiff_t from1
, to1
, from2
, to2
, i1
, i1_byte
, i2
, i2_byte
;
271 /* For backward compatibility, silently bring too-large positive end
272 values into range. */
273 if (INTEGERP (end1
) && SCHARS (str1
) < XINT (end1
))
274 end1
= make_number (SCHARS (str1
));
275 if (INTEGERP (end2
) && SCHARS (str2
) < XINT (end2
))
276 end2
= make_number (SCHARS (str2
));
278 validate_subarray (str1
, start1
, end1
, SCHARS (str1
), &from1
, &to1
);
279 validate_subarray (str2
, start2
, end2
, SCHARS (str2
), &from2
, &to2
);
284 i1_byte
= string_char_to_byte (str1
, i1
);
285 i2_byte
= string_char_to_byte (str2
, i2
);
287 while (i1
< to1
&& i2
< to2
)
289 /* When we find a mismatch, we must compare the
290 characters, not just the bytes. */
293 FETCH_STRING_CHAR_AS_MULTIBYTE_ADVANCE (c1
, str1
, i1
, i1_byte
);
294 FETCH_STRING_CHAR_AS_MULTIBYTE_ADVANCE (c2
, str2
, i2
, i2_byte
);
299 if (! NILP (ignore_case
))
301 c1
= XINT (Fupcase (make_number (c1
)));
302 c2
= XINT (Fupcase (make_number (c2
)));
308 /* Note that I1 has already been incremented
309 past the character that we are comparing;
310 hence we don't add or subtract 1 here. */
312 return make_number (- i1
+ from1
);
314 return make_number (i1
- from1
);
318 return make_number (i1
- from1
+ 1);
320 return make_number (- i1
+ from1
- 1);
325 DEFUN ("string-lessp", Fstring_lessp
, Sstring_lessp
, 2, 2, 0,
326 doc
: /* Return non-nil if STRING1 is less than STRING2 in lexicographic order.
328 Symbols are also allowed; their print names are used instead. */)
329 (register Lisp_Object string1
, Lisp_Object string2
)
331 register ptrdiff_t end
;
332 register ptrdiff_t i1
, i1_byte
, i2
, i2_byte
;
334 if (SYMBOLP (string1
))
335 string1
= SYMBOL_NAME (string1
);
336 if (SYMBOLP (string2
))
337 string2
= SYMBOL_NAME (string2
);
338 CHECK_STRING (string1
);
339 CHECK_STRING (string2
);
341 i1
= i1_byte
= i2
= i2_byte
= 0;
343 end
= SCHARS (string1
);
344 if (end
> SCHARS (string2
))
345 end
= SCHARS (string2
);
349 /* When we find a mismatch, we must compare the
350 characters, not just the bytes. */
353 FETCH_STRING_CHAR_ADVANCE (c1
, string1
, i1
, i1_byte
);
354 FETCH_STRING_CHAR_ADVANCE (c2
, string2
, i2
, i2_byte
);
357 return c1
< c2
? Qt
: Qnil
;
359 return i1
< SCHARS (string2
) ? Qt
: Qnil
;
362 DEFUN ("string-version-lessp", Fstring_version_lessp
,
363 Sstring_version_lessp
, 2, 2, 0,
364 doc
: /* Return non-nil if S1 is less than S2, as version strings.
366 This function compares version strings S1 and S2:
367 1) By prefix lexicographically.
368 2) Then by version (similarly to version comparison of Debian's dpkg).
369 Leading zeros in version numbers are ignored.
370 3) If both prefix and version are equal, compare as ordinary strings.
372 For example, \"foo2.png\" compares less than \"foo12.png\".
374 Symbols are also allowed; their print names are used instead. */)
375 (Lisp_Object string1
, Lisp_Object string2
)
377 if (SYMBOLP (string1
))
378 string1
= SYMBOL_NAME (string1
);
379 if (SYMBOLP (string2
))
380 string2
= SYMBOL_NAME (string2
);
381 CHECK_STRING (string1
);
382 CHECK_STRING (string2
);
384 char *p1
= SSDATA (string1
);
385 char *p2
= SSDATA (string2
);
386 char *lim1
= p1
+ SBYTES (string1
);
387 char *lim2
= p2
+ SBYTES (string2
);
390 while ((cmp
= filevercmp (p1
, p2
)) == 0)
392 /* If the strings are identical through their first null bytes,
393 skip past identical prefixes and try again. */
394 ptrdiff_t size
= strlen (p1
) + 1;
398 return lim2
< p2
? Qnil
: Qt
;
403 return cmp
< 0 ? Qt
: Qnil
;
406 DEFUN ("string-collate-lessp", Fstring_collate_lessp
, Sstring_collate_lessp
, 2, 4, 0,
407 doc
: /* Return t if first arg string is less than second in collation order.
408 Symbols are also allowed; their print names are used instead.
410 This function obeys the conventions for collation order in your
411 locale settings. For example, punctuation and whitespace characters
412 might be considered less significant for sorting:
414 \(sort \\='("11" "12" "1 1" "1 2" "1.1" "1.2") \\='string-collate-lessp)
415 => ("11" "1 1" "1.1" "12" "1 2" "1.2")
417 The optional argument LOCALE, a string, overrides the setting of your
418 current locale identifier for collation. The value is system
419 dependent; a LOCALE \"en_US.UTF-8\" is applicable on POSIX systems,
420 while it would be, e.g., \"enu_USA.1252\" on MS-Windows systems.
422 If IGNORE-CASE is non-nil, characters are converted to lower-case
423 before comparing them.
425 To emulate Unicode-compliant collation on MS-Windows systems,
426 bind `w32-collate-ignore-punctuation' to a non-nil value, since
427 the codeset part of the locale cannot be \"UTF-8\" on MS-Windows.
429 If your system does not support a locale environment, this function
430 behaves like `string-lessp'. */)
431 (Lisp_Object s1
, Lisp_Object s2
, Lisp_Object locale
, Lisp_Object ignore_case
)
433 #if defined __STDC_ISO_10646__ || defined WINDOWSNT
434 /* Check parameters. */
436 s1
= SYMBOL_NAME (s1
);
438 s2
= SYMBOL_NAME (s2
);
442 CHECK_STRING (locale
);
444 return (str_collate (s1
, s2
, locale
, ignore_case
) < 0) ? Qt
: Qnil
;
446 #else /* !__STDC_ISO_10646__, !WINDOWSNT */
447 return Fstring_lessp (s1
, s2
);
448 #endif /* !__STDC_ISO_10646__, !WINDOWSNT */
451 DEFUN ("string-collate-equalp", Fstring_collate_equalp
, Sstring_collate_equalp
, 2, 4, 0,
452 doc
: /* Return t if two strings have identical contents.
453 Symbols are also allowed; their print names are used instead.
455 This function obeys the conventions for collation order in your locale
456 settings. For example, characters with different coding points but
457 the same meaning might be considered as equal, like different grave
458 accent Unicode characters:
460 \(string-collate-equalp (string ?\\uFF40) (string ?\\u1FEF))
463 The optional argument LOCALE, a string, overrides the setting of your
464 current locale identifier for collation. The value is system
465 dependent; a LOCALE \"en_US.UTF-8\" is applicable on POSIX systems,
466 while it would be \"enu_USA.1252\" on MS Windows systems.
468 If IGNORE-CASE is non-nil, characters are converted to lower-case
469 before comparing them.
471 To emulate Unicode-compliant collation on MS-Windows systems,
472 bind `w32-collate-ignore-punctuation' to a non-nil value, since
473 the codeset part of the locale cannot be \"UTF-8\" on MS-Windows.
475 If your system does not support a locale environment, this function
476 behaves like `string-equal'.
478 Do NOT use this function to compare file names for equality. */)
479 (Lisp_Object s1
, Lisp_Object s2
, Lisp_Object locale
, Lisp_Object ignore_case
)
481 #if defined __STDC_ISO_10646__ || defined WINDOWSNT
482 /* Check parameters. */
484 s1
= SYMBOL_NAME (s1
);
486 s2
= SYMBOL_NAME (s2
);
490 CHECK_STRING (locale
);
492 return (str_collate (s1
, s2
, locale
, ignore_case
) == 0) ? Qt
: Qnil
;
494 #else /* !__STDC_ISO_10646__, !WINDOWSNT */
495 return Fstring_equal (s1
, s2
);
496 #endif /* !__STDC_ISO_10646__, !WINDOWSNT */
499 static Lisp_Object
concat (ptrdiff_t nargs
, Lisp_Object
*args
,
500 enum Lisp_Type target_type
, bool last_special
);
504 concat2 (Lisp_Object s1
, Lisp_Object s2
)
506 return concat (2, ((Lisp_Object
[]) {s1
, s2
}), Lisp_String
, 0);
511 concat3 (Lisp_Object s1
, Lisp_Object s2
, Lisp_Object s3
)
513 return concat (3, ((Lisp_Object
[]) {s1
, s2
, s3
}), Lisp_String
, 0);
516 DEFUN ("append", Fappend
, Sappend
, 0, MANY
, 0,
517 doc
: /* Concatenate all the arguments and make the result a list.
518 The result is a list whose elements are the elements of all the arguments.
519 Each argument may be a list, vector or string.
520 The last argument is not copied, just used as the tail of the new list.
521 usage: (append &rest SEQUENCES) */)
522 (ptrdiff_t nargs
, Lisp_Object
*args
)
524 return concat (nargs
, args
, Lisp_Cons
, 1);
527 DEFUN ("concat", Fconcat
, Sconcat
, 0, MANY
, 0,
528 doc
: /* Concatenate all the arguments and make the result a string.
529 The result is a string whose elements are the elements of all the arguments.
530 Each argument may be a string or a list or vector of characters (integers).
531 usage: (concat &rest SEQUENCES) */)
532 (ptrdiff_t nargs
, Lisp_Object
*args
)
534 return concat (nargs
, args
, Lisp_String
, 0);
537 DEFUN ("vconcat", Fvconcat
, Svconcat
, 0, MANY
, 0,
538 doc
: /* Concatenate all the arguments and make the result a vector.
539 The result is a vector whose elements are the elements of all the arguments.
540 Each argument may be a list, vector or string.
541 usage: (vconcat &rest SEQUENCES) */)
542 (ptrdiff_t nargs
, Lisp_Object
*args
)
544 return concat (nargs
, args
, Lisp_Vectorlike
, 0);
548 DEFUN ("copy-sequence", Fcopy_sequence
, Scopy_sequence
, 1, 1, 0,
549 doc
: /* Return a copy of a list, vector, string, char-table or record.
550 The elements of a list, vector or record are not copied; they are
551 shared with the original.
552 If the original sequence is empty, this function may return
553 the same empty object instead of its copy. */)
556 if (NILP (arg
)) return arg
;
560 return Frecord (PVSIZE (arg
), XVECTOR (arg
)->contents
);
563 if (CHAR_TABLE_P (arg
))
565 return copy_char_table (arg
);
568 if (BOOL_VECTOR_P (arg
))
570 EMACS_INT nbits
= bool_vector_size (arg
);
571 ptrdiff_t nbytes
= bool_vector_bytes (nbits
);
572 Lisp_Object val
= make_uninit_bool_vector (nbits
);
573 memcpy (bool_vector_data (val
), bool_vector_data (arg
), nbytes
);
577 if (!CONSP (arg
) && !VECTORP (arg
) && !STRINGP (arg
))
578 wrong_type_argument (Qsequencep
, arg
);
580 return concat (1, &arg
, XTYPE (arg
), 0);
583 /* This structure holds information of an argument of `concat' that is
584 a string and has text properties to be copied. */
587 ptrdiff_t argnum
; /* refer to ARGS (arguments of `concat') */
588 ptrdiff_t from
; /* refer to ARGS[argnum] (argument string) */
589 ptrdiff_t to
; /* refer to VAL (the target string) */
593 concat (ptrdiff_t nargs
, Lisp_Object
*args
,
594 enum Lisp_Type target_type
, bool last_special
)
600 ptrdiff_t toindex_byte
= 0;
601 EMACS_INT result_len
;
602 EMACS_INT result_len_byte
;
604 Lisp_Object last_tail
;
607 /* When we make a multibyte string, we can't copy text properties
608 while concatenating each string because the length of resulting
609 string can't be decided until we finish the whole concatenation.
610 So, we record strings that have text properties to be copied
611 here, and copy the text properties after the concatenation. */
612 struct textprop_rec
*textprops
= NULL
;
613 /* Number of elements in textprops. */
614 ptrdiff_t num_textprops
= 0;
619 /* In append, the last arg isn't treated like the others */
620 if (last_special
&& nargs
> 0)
623 last_tail
= args
[nargs
];
628 /* Check each argument. */
629 for (argnum
= 0; argnum
< nargs
; argnum
++)
632 if (!(CONSP (this) || NILP (this) || VECTORP (this) || STRINGP (this)
633 || COMPILEDP (this) || BOOL_VECTOR_P (this)))
634 wrong_type_argument (Qsequencep
, this);
637 /* Compute total length in chars of arguments in RESULT_LEN.
638 If desired output is a string, also compute length in bytes
639 in RESULT_LEN_BYTE, and determine in SOME_MULTIBYTE
640 whether the result should be a multibyte string. */
644 for (argnum
= 0; argnum
< nargs
; argnum
++)
648 len
= XFASTINT (Flength (this));
649 if (target_type
== Lisp_String
)
651 /* We must count the number of bytes needed in the string
652 as well as the number of characters. */
656 ptrdiff_t this_len_byte
;
658 if (VECTORP (this) || COMPILEDP (this))
659 for (i
= 0; i
< len
; i
++)
662 CHECK_CHARACTER (ch
);
664 this_len_byte
= CHAR_BYTES (c
);
665 if (STRING_BYTES_BOUND
- result_len_byte
< this_len_byte
)
667 result_len_byte
+= this_len_byte
;
668 if (! ASCII_CHAR_P (c
) && ! CHAR_BYTE8_P (c
))
671 else if (BOOL_VECTOR_P (this) && bool_vector_size (this) > 0)
672 wrong_type_argument (Qintegerp
, Faref (this, make_number (0)));
673 else if (CONSP (this))
674 for (; CONSP (this); this = XCDR (this))
677 CHECK_CHARACTER (ch
);
679 this_len_byte
= CHAR_BYTES (c
);
680 if (STRING_BYTES_BOUND
- result_len_byte
< this_len_byte
)
682 result_len_byte
+= this_len_byte
;
683 if (! ASCII_CHAR_P (c
) && ! CHAR_BYTE8_P (c
))
686 else if (STRINGP (this))
688 if (STRING_MULTIBYTE (this))
691 this_len_byte
= SBYTES (this);
694 this_len_byte
= count_size_as_multibyte (SDATA (this),
696 if (STRING_BYTES_BOUND
- result_len_byte
< this_len_byte
)
698 result_len_byte
+= this_len_byte
;
703 if (MOST_POSITIVE_FIXNUM
< result_len
)
704 memory_full (SIZE_MAX
);
707 if (! some_multibyte
)
708 result_len_byte
= result_len
;
710 /* Create the output object. */
711 if (target_type
== Lisp_Cons
)
712 val
= Fmake_list (make_number (result_len
), Qnil
);
713 else if (target_type
== Lisp_Vectorlike
)
714 val
= Fmake_vector (make_number (result_len
), Qnil
);
715 else if (some_multibyte
)
716 val
= make_uninit_multibyte_string (result_len
, result_len_byte
);
718 val
= make_uninit_string (result_len
);
720 /* In `append', if all but last arg are nil, return last arg. */
721 if (target_type
== Lisp_Cons
&& NILP (val
))
724 /* Copy the contents of the args into the result. */
726 tail
= val
, toindex
= -1; /* -1 in toindex is flag we are making a list */
728 toindex
= 0, toindex_byte
= 0;
732 SAFE_NALLOCA (textprops
, 1, nargs
);
734 for (argnum
= 0; argnum
< nargs
; argnum
++)
737 ptrdiff_t thisleni
= 0;
738 register ptrdiff_t thisindex
= 0;
739 register ptrdiff_t thisindex_byte
= 0;
743 thislen
= Flength (this), thisleni
= XINT (thislen
);
745 /* Between strings of the same kind, copy fast. */
746 if (STRINGP (this) && STRINGP (val
)
747 && STRING_MULTIBYTE (this) == some_multibyte
)
749 ptrdiff_t thislen_byte
= SBYTES (this);
751 memcpy (SDATA (val
) + toindex_byte
, SDATA (this), SBYTES (this));
752 if (string_intervals (this))
754 textprops
[num_textprops
].argnum
= argnum
;
755 textprops
[num_textprops
].from
= 0;
756 textprops
[num_textprops
++].to
= toindex
;
758 toindex_byte
+= thislen_byte
;
761 /* Copy a single-byte string to a multibyte string. */
762 else if (STRINGP (this) && STRINGP (val
))
764 if (string_intervals (this))
766 textprops
[num_textprops
].argnum
= argnum
;
767 textprops
[num_textprops
].from
= 0;
768 textprops
[num_textprops
++].to
= toindex
;
770 toindex_byte
+= copy_text (SDATA (this),
771 SDATA (val
) + toindex_byte
,
772 SCHARS (this), 0, 1);
776 /* Copy element by element. */
779 register Lisp_Object elt
;
781 /* Fetch next element of `this' arg into `elt', or break if
782 `this' is exhausted. */
783 if (NILP (this)) break;
785 elt
= XCAR (this), this = XCDR (this);
786 else if (thisindex
>= thisleni
)
788 else if (STRINGP (this))
791 if (STRING_MULTIBYTE (this))
792 FETCH_STRING_CHAR_ADVANCE_NO_CHECK (c
, this,
797 c
= SREF (this, thisindex
); thisindex
++;
798 if (some_multibyte
&& !ASCII_CHAR_P (c
))
799 c
= BYTE8_TO_CHAR (c
);
801 XSETFASTINT (elt
, c
);
803 else if (BOOL_VECTOR_P (this))
805 elt
= bool_vector_ref (this, thisindex
);
810 elt
= AREF (this, thisindex
);
814 /* Store this element into the result. */
821 else if (VECTORP (val
))
823 ASET (val
, toindex
, elt
);
829 CHECK_CHARACTER (elt
);
832 toindex_byte
+= CHAR_STRING (c
, SDATA (val
) + toindex_byte
);
834 SSET (val
, toindex_byte
++, c
);
840 XSETCDR (prev
, last_tail
);
842 if (num_textprops
> 0)
845 ptrdiff_t last_to_end
= -1;
847 for (argnum
= 0; argnum
< num_textprops
; argnum
++)
849 this = args
[textprops
[argnum
].argnum
];
850 props
= text_property_list (this,
852 make_number (SCHARS (this)),
854 /* If successive arguments have properties, be sure that the
855 value of `composition' property be the copy. */
856 if (last_to_end
== textprops
[argnum
].to
)
857 make_composition_value_copy (props
);
858 add_text_properties_from_list (val
, props
,
859 make_number (textprops
[argnum
].to
));
860 last_to_end
= textprops
[argnum
].to
+ SCHARS (this);
868 static Lisp_Object string_char_byte_cache_string
;
869 static ptrdiff_t string_char_byte_cache_charpos
;
870 static ptrdiff_t string_char_byte_cache_bytepos
;
873 clear_string_char_byte_cache (void)
875 string_char_byte_cache_string
= Qnil
;
878 /* Return the byte index corresponding to CHAR_INDEX in STRING. */
881 string_char_to_byte (Lisp_Object string
, ptrdiff_t char_index
)
884 ptrdiff_t best_below
, best_below_byte
;
885 ptrdiff_t best_above
, best_above_byte
;
887 best_below
= best_below_byte
= 0;
888 best_above
= SCHARS (string
);
889 best_above_byte
= SBYTES (string
);
890 if (best_above
== best_above_byte
)
893 if (EQ (string
, string_char_byte_cache_string
))
895 if (string_char_byte_cache_charpos
< char_index
)
897 best_below
= string_char_byte_cache_charpos
;
898 best_below_byte
= string_char_byte_cache_bytepos
;
902 best_above
= string_char_byte_cache_charpos
;
903 best_above_byte
= string_char_byte_cache_bytepos
;
907 if (char_index
- best_below
< best_above
- char_index
)
909 unsigned char *p
= SDATA (string
) + best_below_byte
;
911 while (best_below
< char_index
)
913 p
+= BYTES_BY_CHAR_HEAD (*p
);
916 i_byte
= p
- SDATA (string
);
920 unsigned char *p
= SDATA (string
) + best_above_byte
;
922 while (best_above
> char_index
)
925 while (!CHAR_HEAD_P (*p
)) p
--;
928 i_byte
= p
- SDATA (string
);
931 string_char_byte_cache_bytepos
= i_byte
;
932 string_char_byte_cache_charpos
= char_index
;
933 string_char_byte_cache_string
= string
;
938 /* Return the character index corresponding to BYTE_INDEX in STRING. */
941 string_byte_to_char (Lisp_Object string
, ptrdiff_t byte_index
)
944 ptrdiff_t best_below
, best_below_byte
;
945 ptrdiff_t best_above
, best_above_byte
;
947 best_below
= best_below_byte
= 0;
948 best_above
= SCHARS (string
);
949 best_above_byte
= SBYTES (string
);
950 if (best_above
== best_above_byte
)
953 if (EQ (string
, string_char_byte_cache_string
))
955 if (string_char_byte_cache_bytepos
< byte_index
)
957 best_below
= string_char_byte_cache_charpos
;
958 best_below_byte
= string_char_byte_cache_bytepos
;
962 best_above
= string_char_byte_cache_charpos
;
963 best_above_byte
= string_char_byte_cache_bytepos
;
967 if (byte_index
- best_below_byte
< best_above_byte
- byte_index
)
969 unsigned char *p
= SDATA (string
) + best_below_byte
;
970 unsigned char *pend
= SDATA (string
) + byte_index
;
974 p
+= BYTES_BY_CHAR_HEAD (*p
);
978 i_byte
= p
- SDATA (string
);
982 unsigned char *p
= SDATA (string
) + best_above_byte
;
983 unsigned char *pbeg
= SDATA (string
) + byte_index
;
988 while (!CHAR_HEAD_P (*p
)) p
--;
992 i_byte
= p
- SDATA (string
);
995 string_char_byte_cache_bytepos
= i_byte
;
996 string_char_byte_cache_charpos
= i
;
997 string_char_byte_cache_string
= string
;
1002 /* Convert STRING to a multibyte string. */
1005 string_make_multibyte (Lisp_Object string
)
1012 if (STRING_MULTIBYTE (string
))
1015 nbytes
= count_size_as_multibyte (SDATA (string
),
1017 /* If all the chars are ASCII, they won't need any more bytes
1018 once converted. In that case, we can return STRING itself. */
1019 if (nbytes
== SBYTES (string
))
1022 buf
= SAFE_ALLOCA (nbytes
);
1023 copy_text (SDATA (string
), buf
, SBYTES (string
),
1026 ret
= make_multibyte_string ((char *) buf
, SCHARS (string
), nbytes
);
1033 /* Convert STRING (if unibyte) to a multibyte string without changing
1034 the number of characters. Characters 0200 trough 0237 are
1035 converted to eight-bit characters. */
1038 string_to_multibyte (Lisp_Object string
)
1045 if (STRING_MULTIBYTE (string
))
1048 nbytes
= count_size_as_multibyte (SDATA (string
), SBYTES (string
));
1049 /* If all the chars are ASCII, they won't need any more bytes once
1051 if (nbytes
== SBYTES (string
))
1052 return make_multibyte_string (SSDATA (string
), nbytes
, nbytes
);
1054 buf
= SAFE_ALLOCA (nbytes
);
1055 memcpy (buf
, SDATA (string
), SBYTES (string
));
1056 str_to_multibyte (buf
, nbytes
, SBYTES (string
));
1058 ret
= make_multibyte_string ((char *) buf
, SCHARS (string
), nbytes
);
1065 /* Convert STRING to a single-byte string. */
1068 string_make_unibyte (Lisp_Object string
)
1075 if (! STRING_MULTIBYTE (string
))
1078 nchars
= SCHARS (string
);
1080 buf
= SAFE_ALLOCA (nchars
);
1081 copy_text (SDATA (string
), buf
, SBYTES (string
),
1084 ret
= make_unibyte_string ((char *) buf
, nchars
);
1090 DEFUN ("string-make-multibyte", Fstring_make_multibyte
, Sstring_make_multibyte
,
1092 doc
: /* Return the multibyte equivalent of STRING.
1093 If STRING is unibyte and contains non-ASCII characters, the function
1094 `unibyte-char-to-multibyte' is used to convert each unibyte character
1095 to a multibyte character. In this case, the returned string is a
1096 newly created string with no text properties. If STRING is multibyte
1097 or entirely ASCII, it is returned unchanged. In particular, when
1098 STRING is unibyte and entirely ASCII, the returned string is unibyte.
1099 \(When the characters are all ASCII, Emacs primitives will treat the
1100 string the same way whether it is unibyte or multibyte.) */)
1101 (Lisp_Object string
)
1103 CHECK_STRING (string
);
1105 return string_make_multibyte (string
);
1108 DEFUN ("string-make-unibyte", Fstring_make_unibyte
, Sstring_make_unibyte
,
1110 doc
: /* Return the unibyte equivalent of STRING.
1111 Multibyte character codes are converted to unibyte according to
1112 `nonascii-translation-table' or, if that is nil, `nonascii-insert-offset'.
1113 If the lookup in the translation table fails, this function takes just
1114 the low 8 bits of each character. */)
1115 (Lisp_Object string
)
1117 CHECK_STRING (string
);
1119 return string_make_unibyte (string
);
1122 DEFUN ("string-as-unibyte", Fstring_as_unibyte
, Sstring_as_unibyte
,
1124 doc
: /* Return a unibyte string with the same individual bytes as STRING.
1125 If STRING is unibyte, the result is STRING itself.
1126 Otherwise it is a newly created string, with no text properties.
1127 If STRING is multibyte and contains a character of charset
1128 `eight-bit', it is converted to the corresponding single byte. */)
1129 (Lisp_Object string
)
1131 CHECK_STRING (string
);
1133 if (STRING_MULTIBYTE (string
))
1135 unsigned char *str
= (unsigned char *) xlispstrdup (string
);
1136 ptrdiff_t bytes
= str_as_unibyte (str
, SBYTES (string
));
1138 string
= make_unibyte_string ((char *) str
, bytes
);
1144 DEFUN ("string-as-multibyte", Fstring_as_multibyte
, Sstring_as_multibyte
,
1146 doc
: /* Return a multibyte string with the same individual bytes as STRING.
1147 If STRING is multibyte, the result is STRING itself.
1148 Otherwise it is a newly created string, with no text properties.
1150 If STRING is unibyte and contains an individual 8-bit byte (i.e. not
1151 part of a correct utf-8 sequence), it is converted to the corresponding
1152 multibyte character of charset `eight-bit'.
1153 See also `string-to-multibyte'.
1155 Beware, this often doesn't really do what you think it does.
1156 It is similar to (decode-coding-string STRING \\='utf-8-emacs).
1157 If you're not sure, whether to use `string-as-multibyte' or
1158 `string-to-multibyte', use `string-to-multibyte'. */)
1159 (Lisp_Object string
)
1161 CHECK_STRING (string
);
1163 if (! STRING_MULTIBYTE (string
))
1165 Lisp_Object new_string
;
1166 ptrdiff_t nchars
, nbytes
;
1168 parse_str_as_multibyte (SDATA (string
),
1171 new_string
= make_uninit_multibyte_string (nchars
, nbytes
);
1172 memcpy (SDATA (new_string
), SDATA (string
), SBYTES (string
));
1173 if (nbytes
!= SBYTES (string
))
1174 str_as_multibyte (SDATA (new_string
), nbytes
,
1175 SBYTES (string
), NULL
);
1176 string
= new_string
;
1177 set_string_intervals (string
, NULL
);
1182 DEFUN ("string-to-multibyte", Fstring_to_multibyte
, Sstring_to_multibyte
,
1184 doc
: /* Return a multibyte string with the same individual chars as STRING.
1185 If STRING is multibyte, the result is STRING itself.
1186 Otherwise it is a newly created string, with no text properties.
1188 If STRING is unibyte and contains an 8-bit byte, it is converted to
1189 the corresponding multibyte character of charset `eight-bit'.
1191 This differs from `string-as-multibyte' by converting each byte of a correct
1192 utf-8 sequence to an eight-bit character, not just bytes that don't form a
1193 correct sequence. */)
1194 (Lisp_Object string
)
1196 CHECK_STRING (string
);
1198 return string_to_multibyte (string
);
1201 DEFUN ("string-to-unibyte", Fstring_to_unibyte
, Sstring_to_unibyte
,
1203 doc
: /* Return a unibyte string with the same individual chars as STRING.
1204 If STRING is unibyte, the result is STRING itself.
1205 Otherwise it is a newly created string, with no text properties,
1206 where each `eight-bit' character is converted to the corresponding byte.
1207 If STRING contains a non-ASCII, non-`eight-bit' character,
1208 an error is signaled. */)
1209 (Lisp_Object string
)
1211 CHECK_STRING (string
);
1213 if (STRING_MULTIBYTE (string
))
1215 ptrdiff_t chars
= SCHARS (string
);
1216 unsigned char *str
= xmalloc (chars
);
1217 ptrdiff_t converted
= str_to_unibyte (SDATA (string
), str
, chars
);
1219 if (converted
< chars
)
1220 error ("Can't convert the %"pD
"dth character to unibyte", converted
);
1221 string
= make_unibyte_string ((char *) str
, chars
);
1228 DEFUN ("copy-alist", Fcopy_alist
, Scopy_alist
, 1, 1, 0,
1229 doc
: /* Return a copy of ALIST.
1230 This is an alist which represents the same mapping from objects to objects,
1231 but does not share the alist structure with ALIST.
1232 The objects mapped (cars and cdrs of elements of the alist)
1233 are shared, however.
1234 Elements of ALIST that are not conses are also shared. */)
1239 alist
= concat (1, &alist
, Lisp_Cons
, false);
1240 for (Lisp_Object tem
= alist
; !NILP (tem
); tem
= XCDR (tem
))
1242 Lisp_Object car
= XCAR (tem
);
1244 XSETCAR (tem
, Fcons (XCAR (car
), XCDR (car
)));
1249 /* Check that ARRAY can have a valid subarray [FROM..TO),
1250 given that its size is SIZE.
1251 If FROM is nil, use 0; if TO is nil, use SIZE.
1252 Count negative values backwards from the end.
1253 Set *IFROM and *ITO to the two indexes used. */
1256 validate_subarray (Lisp_Object array
, Lisp_Object from
, Lisp_Object to
,
1257 ptrdiff_t size
, ptrdiff_t *ifrom
, ptrdiff_t *ito
)
1261 if (INTEGERP (from
))
1267 else if (NILP (from
))
1270 wrong_type_argument (Qintegerp
, from
);
1281 wrong_type_argument (Qintegerp
, to
);
1283 if (! (0 <= f
&& f
<= t
&& t
<= size
))
1284 args_out_of_range_3 (array
, from
, to
);
1290 DEFUN ("substring", Fsubstring
, Ssubstring
, 1, 3, 0,
1291 doc
: /* Return a new string whose contents are a substring of STRING.
1292 The returned string consists of the characters between index FROM
1293 \(inclusive) and index TO (exclusive) of STRING. FROM and TO are
1294 zero-indexed: 0 means the first character of STRING. Negative values
1295 are counted from the end of STRING. If TO is nil, the substring runs
1296 to the end of STRING.
1298 The STRING argument may also be a vector. In that case, the return
1299 value is a new vector that contains the elements between index FROM
1300 \(inclusive) and index TO (exclusive) of that vector argument.
1302 With one argument, just copy STRING (with properties, if any). */)
1303 (Lisp_Object string
, Lisp_Object from
, Lisp_Object to
)
1306 ptrdiff_t size
, ifrom
, ito
;
1308 size
= CHECK_VECTOR_OR_STRING (string
);
1309 validate_subarray (string
, from
, to
, size
, &ifrom
, &ito
);
1311 if (STRINGP (string
))
1314 = !ifrom
? 0 : string_char_to_byte (string
, ifrom
);
1316 = ito
== size
? SBYTES (string
) : string_char_to_byte (string
, ito
);
1317 res
= make_specified_string (SSDATA (string
) + from_byte
,
1318 ito
- ifrom
, to_byte
- from_byte
,
1319 STRING_MULTIBYTE (string
));
1320 copy_text_properties (make_number (ifrom
), make_number (ito
),
1321 string
, make_number (0), res
, Qnil
);
1324 res
= Fvector (ito
- ifrom
, aref_addr (string
, ifrom
));
1330 DEFUN ("substring-no-properties", Fsubstring_no_properties
, Ssubstring_no_properties
, 1, 3, 0,
1331 doc
: /* Return a substring of STRING, without text properties.
1332 It starts at index FROM and ends before TO.
1333 TO may be nil or omitted; then the substring runs to the end of STRING.
1334 If FROM is nil or omitted, the substring starts at the beginning of STRING.
1335 If FROM or TO is negative, it counts from the end.
1337 With one argument, just copy STRING without its properties. */)
1338 (Lisp_Object string
, register Lisp_Object from
, Lisp_Object to
)
1340 ptrdiff_t from_char
, to_char
, from_byte
, to_byte
, size
;
1342 CHECK_STRING (string
);
1344 size
= SCHARS (string
);
1345 validate_subarray (string
, from
, to
, size
, &from_char
, &to_char
);
1347 from_byte
= !from_char
? 0 : string_char_to_byte (string
, from_char
);
1349 to_char
== size
? SBYTES (string
) : string_char_to_byte (string
, to_char
);
1350 return make_specified_string (SSDATA (string
) + from_byte
,
1351 to_char
- from_char
, to_byte
- from_byte
,
1352 STRING_MULTIBYTE (string
));
1355 /* Extract a substring of STRING, giving start and end positions
1356 both in characters and in bytes. */
1359 substring_both (Lisp_Object string
, ptrdiff_t from
, ptrdiff_t from_byte
,
1360 ptrdiff_t to
, ptrdiff_t to_byte
)
1363 ptrdiff_t size
= CHECK_VECTOR_OR_STRING (string
);
1365 if (!(0 <= from
&& from
<= to
&& to
<= size
))
1366 args_out_of_range_3 (string
, make_number (from
), make_number (to
));
1368 if (STRINGP (string
))
1370 res
= make_specified_string (SSDATA (string
) + from_byte
,
1371 to
- from
, to_byte
- from_byte
,
1372 STRING_MULTIBYTE (string
));
1373 copy_text_properties (make_number (from
), make_number (to
),
1374 string
, make_number (0), res
, Qnil
);
1377 res
= Fvector (to
- from
, aref_addr (string
, from
));
1382 DEFUN ("nthcdr", Fnthcdr
, Snthcdr
, 2, 2, 0,
1383 doc
: /* Take cdr N times on LIST, return the result. */)
1384 (Lisp_Object n
, Lisp_Object list
)
1387 Lisp_Object tail
= list
;
1388 for (EMACS_INT num
= XINT (n
); 0 < num
; num
--)
1392 CHECK_LIST_END (tail
, list
);
1401 DEFUN ("nth", Fnth
, Snth
, 2, 2, 0,
1402 doc
: /* Return the Nth element of LIST.
1403 N counts from zero. If LIST is not that long, nil is returned. */)
1404 (Lisp_Object n
, Lisp_Object list
)
1406 return Fcar (Fnthcdr (n
, list
));
1409 DEFUN ("elt", Felt
, Selt
, 2, 2, 0,
1410 doc
: /* Return element of SEQUENCE at index N. */)
1411 (register Lisp_Object sequence
, Lisp_Object n
)
1414 if (CONSP (sequence
) || NILP (sequence
))
1415 return Fcar (Fnthcdr (n
, sequence
));
1417 /* Faref signals a "not array" error, so check here. */
1418 CHECK_ARRAY (sequence
, Qsequencep
);
1419 return Faref (sequence
, n
);
1422 enum { WORDS_PER_DOUBLE
= (sizeof (double) / sizeof (EMACS_UINT
)
1423 + (sizeof (double) % sizeof (EMACS_UINT
) != 0)) };
1424 union double_and_words
1427 EMACS_UINT word
[WORDS_PER_DOUBLE
];
1430 /* Return true if X and Y are the same floating-point value.
1431 This looks at X's and Y's representation, since (unlike '==')
1432 it returns true if X and Y are the same NaN. */
1434 same_float (Lisp_Object x
, Lisp_Object y
)
1436 union double_and_words
1437 xu
= { .val
= XFLOAT_DATA (x
) },
1438 yu
= { .val
= XFLOAT_DATA (y
) };
1439 EMACS_UINT neql
= 0;
1440 for (int i
= 0; i
< WORDS_PER_DOUBLE
; i
++)
1441 neql
|= xu
.word
[i
] ^ yu
.word
[i
];
1445 DEFUN ("member", Fmember
, Smember
, 2, 2, 0,
1446 doc
: /* Return non-nil if ELT is an element of LIST. Comparison done with `equal'.
1447 The value is actually the tail of LIST whose car is ELT. */)
1448 (Lisp_Object elt
, Lisp_Object list
)
1450 Lisp_Object tail
= list
;
1451 FOR_EACH_TAIL (tail
)
1452 if (! NILP (Fequal (elt
, XCAR (tail
))))
1454 CHECK_LIST_END (tail
, list
);
1458 DEFUN ("memq", Fmemq
, Smemq
, 2, 2, 0,
1459 doc
: /* Return non-nil if ELT is an element of LIST. Comparison done with `eq'.
1460 The value is actually the tail of LIST whose car is ELT. */)
1461 (Lisp_Object elt
, Lisp_Object list
)
1463 Lisp_Object tail
= list
;
1464 FOR_EACH_TAIL (tail
)
1465 if (EQ (XCAR (tail
), elt
))
1467 CHECK_LIST_END (tail
, list
);
1471 DEFUN ("memql", Fmemql
, Smemql
, 2, 2, 0,
1472 doc
: /* Return non-nil if ELT is an element of LIST. Comparison done with `eql'.
1473 The value is actually the tail of LIST whose car is ELT. */)
1474 (Lisp_Object elt
, Lisp_Object list
)
1477 return Fmemq (elt
, list
);
1479 Lisp_Object tail
= list
;
1480 FOR_EACH_TAIL (tail
)
1482 Lisp_Object tem
= XCAR (tail
);
1483 if (FLOATP (tem
) && same_float (elt
, tem
))
1486 CHECK_LIST_END (tail
, list
);
1490 DEFUN ("assq", Fassq
, Sassq
, 2, 2, 0,
1491 doc
: /* Return non-nil if KEY is `eq' to the car of an element of LIST.
1492 The value is actually the first element of LIST whose car is KEY.
1493 Elements of LIST that are not conses are ignored. */)
1494 (Lisp_Object key
, Lisp_Object list
)
1496 Lisp_Object tail
= list
;
1497 FOR_EACH_TAIL (tail
)
1498 if (CONSP (XCAR (tail
)) && EQ (XCAR (XCAR (tail
)), key
))
1500 CHECK_LIST_END (tail
, list
);
1504 /* Like Fassq but never report an error and do not allow quits.
1505 Use only on objects known to be non-circular lists. */
1508 assq_no_quit (Lisp_Object key
, Lisp_Object list
)
1510 for (; ! NILP (list
); list
= XCDR (list
))
1511 if (CONSP (XCAR (list
)) && EQ (XCAR (XCAR (list
)), key
))
1516 DEFUN ("assoc", Fassoc
, Sassoc
, 2, 3, 0,
1517 doc
: /* Return non-nil if KEY is equal to the car of an element of LIST.
1518 The value is actually the first element of LIST whose car equals KEY.
1520 Equality is defined by TESTFN if non-nil or by `equal' if nil. */)
1521 (Lisp_Object key
, Lisp_Object list
, Lisp_Object testfn
)
1523 Lisp_Object tail
= list
;
1524 FOR_EACH_TAIL (tail
)
1526 Lisp_Object car
= XCAR (tail
);
1529 ? (EQ (XCAR (car
), key
) || !NILP (Fequal
1531 : !NILP (call2 (testfn
, XCAR (car
), key
))))
1534 CHECK_LIST_END (tail
, list
);
1538 /* Like Fassoc but never report an error and do not allow quits.
1539 Use only on keys and lists known to be non-circular, and on keys
1540 that are not too deep and are not window configurations. */
1543 assoc_no_quit (Lisp_Object key
, Lisp_Object list
)
1545 for (; ! NILP (list
); list
= XCDR (list
))
1547 Lisp_Object car
= XCAR (list
);
1549 && (EQ (XCAR (car
), key
) || equal_no_quit (XCAR (car
), key
)))
1555 DEFUN ("rassq", Frassq
, Srassq
, 2, 2, 0,
1556 doc
: /* Return non-nil if KEY is `eq' to the cdr of an element of LIST.
1557 The value is actually the first element of LIST whose cdr is KEY. */)
1558 (Lisp_Object key
, Lisp_Object list
)
1560 Lisp_Object tail
= list
;
1561 FOR_EACH_TAIL (tail
)
1562 if (CONSP (XCAR (tail
)) && EQ (XCDR (XCAR (tail
)), key
))
1564 CHECK_LIST_END (tail
, list
);
1568 DEFUN ("rassoc", Frassoc
, Srassoc
, 2, 2, 0,
1569 doc
: /* Return non-nil if KEY is `equal' to the cdr of an element of LIST.
1570 The value is actually the first element of LIST whose cdr equals KEY. */)
1571 (Lisp_Object key
, Lisp_Object list
)
1573 Lisp_Object tail
= list
;
1574 FOR_EACH_TAIL (tail
)
1576 Lisp_Object car
= XCAR (tail
);
1578 && (EQ (XCDR (car
), key
) || !NILP (Fequal (XCDR (car
), key
))))
1581 CHECK_LIST_END (tail
, list
);
1585 DEFUN ("delq", Fdelq
, Sdelq
, 2, 2, 0,
1586 doc
: /* Delete members of LIST which are `eq' to ELT, and return the result.
1587 More precisely, this function skips any members `eq' to ELT at the
1588 front of LIST, then removes members `eq' to ELT from the remaining
1589 sublist by modifying its list structure, then returns the resulting
1592 Write `(setq foo (delq element foo))' to be sure of correctly changing
1593 the value of a list `foo'. See also `remq', which does not modify the
1595 (Lisp_Object elt
, Lisp_Object list
)
1597 Lisp_Object prev
= Qnil
, tail
= list
;
1599 FOR_EACH_TAIL (tail
)
1601 Lisp_Object tem
= XCAR (tail
);
1607 Fsetcdr (prev
, XCDR (tail
));
1612 CHECK_LIST_END (tail
, list
);
1616 DEFUN ("delete", Fdelete
, Sdelete
, 2, 2, 0,
1617 doc
: /* Delete members of SEQ which are `equal' to ELT, and return the result.
1618 SEQ must be a sequence (i.e. a list, a vector, or a string).
1619 The return value is a sequence of the same type.
1621 If SEQ is a list, this behaves like `delq', except that it compares
1622 with `equal' instead of `eq'. In particular, it may remove elements
1623 by altering the list structure.
1625 If SEQ is not a list, deletion is never performed destructively;
1626 instead this function creates and returns a new vector or string.
1628 Write `(setq foo (delete element foo))' to be sure of correctly
1629 changing the value of a sequence `foo'. */)
1630 (Lisp_Object elt
, Lisp_Object seq
)
1636 for (i
= n
= 0; i
< ASIZE (seq
); ++i
)
1637 if (NILP (Fequal (AREF (seq
, i
), elt
)))
1640 if (n
!= ASIZE (seq
))
1642 struct Lisp_Vector
*p
= allocate_vector (n
);
1644 for (i
= n
= 0; i
< ASIZE (seq
); ++i
)
1645 if (NILP (Fequal (AREF (seq
, i
), elt
)))
1646 p
->contents
[n
++] = AREF (seq
, i
);
1648 XSETVECTOR (seq
, p
);
1651 else if (STRINGP (seq
))
1653 ptrdiff_t i
, ibyte
, nchars
, nbytes
, cbytes
;
1656 for (i
= nchars
= nbytes
= ibyte
= 0;
1658 ++i
, ibyte
+= cbytes
)
1660 if (STRING_MULTIBYTE (seq
))
1662 c
= STRING_CHAR (SDATA (seq
) + ibyte
);
1663 cbytes
= CHAR_BYTES (c
);
1671 if (!INTEGERP (elt
) || c
!= XINT (elt
))
1678 if (nchars
!= SCHARS (seq
))
1682 tem
= make_uninit_multibyte_string (nchars
, nbytes
);
1683 if (!STRING_MULTIBYTE (seq
))
1684 STRING_SET_UNIBYTE (tem
);
1686 for (i
= nchars
= nbytes
= ibyte
= 0;
1688 ++i
, ibyte
+= cbytes
)
1690 if (STRING_MULTIBYTE (seq
))
1692 c
= STRING_CHAR (SDATA (seq
) + ibyte
);
1693 cbytes
= CHAR_BYTES (c
);
1701 if (!INTEGERP (elt
) || c
!= XINT (elt
))
1703 unsigned char *from
= SDATA (seq
) + ibyte
;
1704 unsigned char *to
= SDATA (tem
) + nbytes
;
1710 for (n
= cbytes
; n
--; )
1720 Lisp_Object prev
= Qnil
, tail
= seq
;
1722 FOR_EACH_TAIL (tail
)
1724 if (!NILP (Fequal (elt
, XCAR (tail
))))
1729 Fsetcdr (prev
, XCDR (tail
));
1734 CHECK_LIST_END (tail
, 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. */)
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
; CONSP (tail
); tail
= next
)
1757 /* If SEQ contains a cycle, attempting to reverse it
1758 in-place will inevitably come back to SEQ. */
1760 circular_list (seq
);
1761 Fsetcdr (tail
, prev
);
1764 CHECK_LIST_END (tail
, seq
);
1767 else if (VECTORP (seq
))
1769 ptrdiff_t i
, size
= ASIZE (seq
);
1771 for (i
= 0; i
< size
/ 2; i
++)
1773 Lisp_Object tem
= AREF (seq
, i
);
1774 ASET (seq
, i
, AREF (seq
, size
- i
- 1));
1775 ASET (seq
, size
- i
- 1, tem
);
1778 else if (BOOL_VECTOR_P (seq
))
1780 ptrdiff_t i
, size
= bool_vector_size (seq
);
1782 for (i
= 0; i
< size
/ 2; i
++)
1784 bool tem
= bool_vector_bitref (seq
, i
);
1785 bool_vector_set (seq
, i
, bool_vector_bitref (seq
, size
- i
- 1));
1786 bool_vector_set (seq
, size
- i
- 1, tem
);
1790 wrong_type_argument (Qarrayp
, seq
);
1794 DEFUN ("reverse", Freverse
, Sreverse
, 1, 1, 0,
1795 doc
: /* Return the reversed copy of list, vector, or string SEQ.
1796 See also the function `nreverse', which is used more often. */)
1803 else if (CONSP (seq
))
1807 new = Fcons (XCAR (seq
), new);
1808 CHECK_LIST_END (seq
, seq
);
1810 else if (VECTORP (seq
))
1812 ptrdiff_t i
, size
= ASIZE (seq
);
1814 new = make_uninit_vector (size
);
1815 for (i
= 0; i
< size
; i
++)
1816 ASET (new, i
, AREF (seq
, size
- i
- 1));
1818 else if (BOOL_VECTOR_P (seq
))
1821 EMACS_INT nbits
= bool_vector_size (seq
);
1823 new = make_uninit_bool_vector (nbits
);
1824 for (i
= 0; i
< nbits
; i
++)
1825 bool_vector_set (new, i
, bool_vector_bitref (seq
, nbits
- i
- 1));
1827 else if (STRINGP (seq
))
1829 ptrdiff_t size
= SCHARS (seq
), bytes
= SBYTES (seq
);
1835 new = make_uninit_string (size
);
1836 for (i
= 0; i
< size
; i
++)
1837 SSET (new, i
, SREF (seq
, size
- i
- 1));
1841 unsigned char *p
, *q
;
1843 new = make_uninit_multibyte_string (size
, bytes
);
1844 p
= SDATA (seq
), q
= SDATA (new) + bytes
;
1845 while (q
> SDATA (new))
1849 ch
= STRING_CHAR_AND_LENGTH (p
, len
);
1851 CHAR_STRING (ch
, q
);
1856 wrong_type_argument (Qsequencep
, seq
);
1860 /* Sort LIST using PREDICATE, preserving original order of elements
1861 considered as equal. */
1864 sort_list (Lisp_Object list
, Lisp_Object predicate
)
1866 Lisp_Object front
, back
;
1867 Lisp_Object len
, tem
;
1871 len
= Flength (list
);
1872 length
= XINT (len
);
1876 XSETINT (len
, (length
/ 2) - 1);
1877 tem
= Fnthcdr (len
, list
);
1879 Fsetcdr (tem
, Qnil
);
1881 front
= Fsort (front
, predicate
);
1882 back
= Fsort (back
, predicate
);
1883 return merge (front
, back
, predicate
);
1886 /* Using PRED to compare, return whether A and B are in order.
1887 Compare stably when A appeared before B in the input. */
1889 inorder (Lisp_Object pred
, Lisp_Object a
, Lisp_Object b
)
1891 return NILP (call2 (pred
, b
, a
));
1894 /* Using PRED to compare, merge from ALEN-length A and BLEN-length B
1895 into DEST. Argument arrays must be nonempty and must not overlap,
1896 except that B might be the last part of DEST. */
1898 merge_vectors (Lisp_Object pred
,
1899 ptrdiff_t alen
, Lisp_Object
const a
[restrict
VLA_ELEMS (alen
)],
1900 ptrdiff_t blen
, Lisp_Object
const b
[VLA_ELEMS (blen
)],
1901 Lisp_Object dest
[VLA_ELEMS (alen
+ blen
)])
1903 eassume (0 < alen
&& 0 < blen
);
1904 Lisp_Object
const *alim
= a
+ alen
;
1905 Lisp_Object
const *blim
= b
+ blen
;
1909 if (inorder (pred
, a
[0], b
[0]))
1915 memcpy (dest
, b
, (blim
- b
) * sizeof *dest
);
1924 memcpy (dest
, a
, (alim
- a
) * sizeof *dest
);
1931 /* Using PRED to compare, sort LEN-length VEC in place, using TMP for
1932 temporary storage. LEN must be at least 2. */
1934 sort_vector_inplace (Lisp_Object pred
, ptrdiff_t len
,
1935 Lisp_Object vec
[restrict
VLA_ELEMS (len
)],
1936 Lisp_Object tmp
[restrict
VLA_ELEMS (len
>> 1)])
1939 ptrdiff_t halflen
= len
>> 1;
1940 sort_vector_copy (pred
, halflen
, vec
, tmp
);
1941 if (1 < len
- halflen
)
1942 sort_vector_inplace (pred
, len
- halflen
, vec
+ halflen
, vec
);
1943 merge_vectors (pred
, halflen
, tmp
, len
- halflen
, vec
+ halflen
, vec
);
1946 /* Using PRED to compare, sort from LEN-length SRC into DST.
1947 Len must be positive. */
1949 sort_vector_copy (Lisp_Object pred
, ptrdiff_t len
,
1950 Lisp_Object src
[restrict
VLA_ELEMS (len
)],
1951 Lisp_Object dest
[restrict
VLA_ELEMS (len
)])
1954 ptrdiff_t halflen
= len
>> 1;
1960 sort_vector_inplace (pred
, halflen
, src
, dest
);
1961 if (1 < len
- halflen
)
1962 sort_vector_inplace (pred
, len
- halflen
, src
+ halflen
, dest
);
1963 merge_vectors (pred
, halflen
, src
, len
- halflen
, src
+ halflen
, dest
);
1967 /* Sort VECTOR in place using PREDICATE, preserving original order of
1968 elements considered as equal. */
1971 sort_vector (Lisp_Object vector
, Lisp_Object predicate
)
1973 ptrdiff_t len
= ASIZE (vector
);
1976 ptrdiff_t halflen
= len
>> 1;
1979 SAFE_ALLOCA_LISP (tmp
, halflen
);
1980 for (ptrdiff_t i
= 0; i
< halflen
; i
++)
1981 tmp
[i
] = make_number (0);
1982 sort_vector_inplace (predicate
, len
, XVECTOR (vector
)->contents
, tmp
);
1986 DEFUN ("sort", Fsort
, Ssort
, 2, 2, 0,
1987 doc
: /* Sort SEQ, stably, comparing elements using PREDICATE.
1988 Returns the sorted sequence. SEQ should be a list or vector. SEQ is
1989 modified by side effects. PREDICATE is called with two elements of
1990 SEQ, and should return non-nil if the first element should sort before
1992 (Lisp_Object seq
, Lisp_Object predicate
)
1995 seq
= sort_list (seq
, predicate
);
1996 else if (VECTORP (seq
))
1997 sort_vector (seq
, predicate
);
1998 else if (!NILP (seq
))
1999 wrong_type_argument (Qsequencep
, seq
);
2004 merge (Lisp_Object org_l1
, Lisp_Object org_l2
, Lisp_Object pred
)
2006 Lisp_Object l1
= org_l1
;
2007 Lisp_Object l2
= org_l2
;
2008 Lisp_Object tail
= Qnil
;
2009 Lisp_Object value
= Qnil
;
2029 if (inorder (pred
, Fcar (l1
), Fcar (l2
)))
2044 Fsetcdr (tail
, tem
);
2050 /* This does not check for quits. That is safe since it must terminate. */
2052 DEFUN ("plist-get", Fplist_get
, Splist_get
, 2, 2, 0,
2053 doc
: /* Extract a value from a property list.
2054 PLIST is a property list, which is a list of the form
2055 \(PROP1 VALUE1 PROP2 VALUE2...). This function returns the value
2056 corresponding to the given PROP, or nil if PROP is not one of the
2057 properties on the list. This function never signals an error. */)
2058 (Lisp_Object plist
, Lisp_Object prop
)
2060 Lisp_Object tail
= plist
;
2061 FOR_EACH_TAIL_SAFE (tail
)
2063 if (! CONSP (XCDR (tail
)))
2065 if (EQ (prop
, XCAR (tail
)))
2066 return XCAR (XCDR (tail
));
2068 if (EQ (tail
, li
.tortoise
))
2075 DEFUN ("get", Fget
, Sget
, 2, 2, 0,
2076 doc
: /* Return the value of SYMBOL's PROPNAME property.
2077 This is the last value stored with `(put SYMBOL PROPNAME VALUE)'. */)
2078 (Lisp_Object symbol
, Lisp_Object propname
)
2080 CHECK_SYMBOL (symbol
);
2081 Lisp_Object propval
= Fplist_get (CDR (Fassq (symbol
, Voverriding_plist_environment
)),
2083 if (!NILP (propval
))
2085 return Fplist_get (XSYMBOL (symbol
)->u
.s
.plist
, propname
);
2088 DEFUN ("plist-put", Fplist_put
, Splist_put
, 3, 3, 0,
2089 doc
: /* Change value in PLIST of PROP to VAL.
2090 PLIST is a property list, which is a list of the form
2091 \(PROP1 VALUE1 PROP2 VALUE2 ...). PROP is a symbol and VAL is any object.
2092 If PROP is already a property on the list, its value is set to VAL,
2093 otherwise the new PROP VAL pair is added. The new plist is returned;
2094 use `(setq x (plist-put x prop val))' to be sure to use the new value.
2095 The PLIST is modified by side effects. */)
2096 (Lisp_Object plist
, Lisp_Object prop
, Lisp_Object val
)
2098 Lisp_Object prev
= Qnil
, tail
= plist
;
2099 FOR_EACH_TAIL (tail
)
2101 if (! CONSP (XCDR (tail
)))
2104 if (EQ (prop
, XCAR (tail
)))
2106 Fsetcar (XCDR (tail
), val
);
2112 if (EQ (tail
, li
.tortoise
))
2113 circular_list (plist
);
2115 CHECK_TYPE (NILP (tail
), Qplistp
, plist
);
2117 = Fcons (prop
, Fcons (val
, NILP (prev
) ? plist
: XCDR (XCDR (prev
))));
2120 Fsetcdr (XCDR (prev
), newcell
);
2124 DEFUN ("put", Fput
, Sput
, 3, 3, 0,
2125 doc
: /* Store SYMBOL's PROPNAME property with value VALUE.
2126 It can be retrieved with `(get SYMBOL PROPNAME)'. */)
2127 (Lisp_Object symbol
, Lisp_Object propname
, Lisp_Object value
)
2129 CHECK_SYMBOL (symbol
);
2131 (symbol
, Fplist_put (XSYMBOL (symbol
)->u
.s
.plist
, propname
, value
));
2135 DEFUN ("lax-plist-get", Flax_plist_get
, Slax_plist_get
, 2, 2, 0,
2136 doc
: /* Extract a value from a property list, comparing with `equal'.
2137 PLIST is a property list, which is a list of the form
2138 \(PROP1 VALUE1 PROP2 VALUE2...). This function returns the value
2139 corresponding to the given PROP, or nil if PROP is not
2140 one of the properties on the list. */)
2141 (Lisp_Object plist
, Lisp_Object prop
)
2143 Lisp_Object tail
= plist
;
2144 FOR_EACH_TAIL (tail
)
2146 if (! CONSP (XCDR (tail
)))
2148 if (! NILP (Fequal (prop
, XCAR (tail
))))
2149 return XCAR (XCDR (tail
));
2151 if (EQ (tail
, li
.tortoise
))
2152 circular_list (plist
);
2155 CHECK_TYPE (NILP (tail
), Qplistp
, plist
);
2160 DEFUN ("lax-plist-put", Flax_plist_put
, Slax_plist_put
, 3, 3, 0,
2161 doc
: /* Change value in PLIST of PROP to VAL, comparing with `equal'.
2162 PLIST is a property list, which is a list of the form
2163 \(PROP1 VALUE1 PROP2 VALUE2 ...). PROP and VAL are any objects.
2164 If PROP is already a property on the list, its value is set to VAL,
2165 otherwise the new PROP VAL pair is added. The new plist is returned;
2166 use `(setq x (lax-plist-put x prop val))' to be sure to use the new value.
2167 The PLIST is modified by side effects. */)
2168 (Lisp_Object plist
, Lisp_Object prop
, Lisp_Object val
)
2170 Lisp_Object prev
= Qnil
, tail
= plist
;
2171 FOR_EACH_TAIL (tail
)
2173 if (! CONSP (XCDR (tail
)))
2176 if (! NILP (Fequal (prop
, XCAR (tail
))))
2178 Fsetcar (XCDR (tail
), val
);
2184 if (EQ (tail
, li
.tortoise
))
2185 circular_list (plist
);
2187 CHECK_TYPE (NILP (tail
), Qplistp
, plist
);
2188 Lisp_Object newcell
= list2 (prop
, val
);
2191 Fsetcdr (XCDR (prev
), newcell
);
2195 DEFUN ("eql", Feql
, Seql
, 2, 2, 0,
2196 doc
: /* Return t if the two args are `eq' or are indistinguishable numbers.
2197 Floating-point values with the same sign, exponent and fraction are `eql'.
2198 This differs from numeric comparison: (eql 0.0 -0.0) returns nil and
2199 \(eql 0.0e+NaN 0.0e+NaN) returns t, whereas `=' does the opposite. */)
2200 (Lisp_Object obj1
, Lisp_Object obj2
)
2203 return FLOATP (obj2
) && same_float (obj1
, obj2
) ? Qt
: Qnil
;
2205 return EQ (obj1
, obj2
) ? Qt
: Qnil
;
2208 DEFUN ("equal", Fequal
, Sequal
, 2, 2, 0,
2209 doc
: /* Return t if two Lisp objects have similar structure and contents.
2210 They must have the same data type.
2211 Conses are compared by comparing the cars and the cdrs.
2212 Vectors and strings are compared element by element.
2213 Numbers are compared via `eql', so integers do not equal floats.
2214 \(Use `=' if you want integers and floats to be able to be equal.)
2215 Symbols must match exactly. */)
2216 (Lisp_Object o1
, Lisp_Object o2
)
2218 return internal_equal (o1
, o2
, EQUAL_PLAIN
, 0, Qnil
) ? Qt
: Qnil
;
2221 DEFUN ("equal-including-properties", Fequal_including_properties
, Sequal_including_properties
, 2, 2, 0,
2222 doc
: /* Return t if two Lisp objects have similar structure and contents.
2223 This is like `equal' except that it compares the text properties
2224 of strings. (`equal' ignores text properties.) */)
2225 (Lisp_Object o1
, Lisp_Object o2
)
2227 return (internal_equal (o1
, o2
, EQUAL_INCLUDING_PROPERTIES
, 0, Qnil
)
2231 /* Return true if O1 and O2 are equal. Do not quit or check for cycles.
2232 Use this only on arguments that are cycle-free and not too large and
2233 are not window configurations. */
2236 equal_no_quit (Lisp_Object o1
, Lisp_Object o2
)
2238 return internal_equal (o1
, o2
, EQUAL_NO_QUIT
, 0, Qnil
);
2241 /* Return true if O1 and O2 are equal. EQUAL_KIND specifies what kind
2242 of equality test to use: if it is EQUAL_NO_QUIT, do not check for
2243 cycles or large arguments or quits; if EQUAL_PLAIN, do ordinary
2244 Lisp equality; and if EQUAL_INCLUDING_PROPERTIES, do
2245 equal-including-properties.
2247 If DEPTH is the current depth of recursion; signal an error if it
2248 gets too deep. HT is a hash table used to detect cycles; if nil,
2249 it has not been allocated yet. But ignore the last two arguments
2250 if EQUAL_KIND == EQUAL_NO_QUIT. */
2253 internal_equal (Lisp_Object o1
, Lisp_Object o2
, enum equal_kind equal_kind
,
2254 int depth
, Lisp_Object ht
)
2259 eassert (equal_kind
!= EQUAL_NO_QUIT
);
2261 error ("Stack overflow in equal");
2263 ht
= CALLN (Fmake_hash_table
, QCtest
, Qeq
);
2266 case Lisp_Cons
: case Lisp_Misc
: case Lisp_Vectorlike
:
2268 struct Lisp_Hash_Table
*h
= XHASH_TABLE (ht
);
2270 ptrdiff_t i
= hash_lookup (h
, o1
, &hash
);
2272 { /* `o1' was seen already. */
2273 Lisp_Object o2s
= HASH_VALUE (h
, i
);
2274 if (!NILP (Fmemq (o2
, o2s
)))
2277 set_hash_value_slot (h
, i
, Fcons (o2
, o2s
));
2280 hash_put (h
, o1
, Fcons (o2
, Qnil
), hash
);
2288 if (XTYPE (o1
) != XTYPE (o2
))
2294 return same_float (o1
, o2
);
2297 if (equal_kind
== EQUAL_NO_QUIT
)
2298 for (; CONSP (o1
); o1
= XCDR (o1
))
2302 if (! equal_no_quit (XCAR (o1
), XCAR (o2
)))
2305 if (EQ (XCDR (o1
), o2
))
2313 if (! internal_equal (XCAR (o1
), XCAR (o2
),
2314 equal_kind
, depth
+ 1, ht
))
2317 if (EQ (XCDR (o1
), o2
))
2324 if (XMISCTYPE (o1
) != XMISCTYPE (o2
))
2328 if (!internal_equal (OVERLAY_START (o1
), OVERLAY_START (o2
),
2329 equal_kind
, depth
+ 1, ht
)
2330 || !internal_equal (OVERLAY_END (o1
), OVERLAY_END (o2
),
2331 equal_kind
, depth
+ 1, ht
))
2333 o1
= XOVERLAY (o1
)->plist
;
2334 o2
= XOVERLAY (o2
)->plist
;
2340 return (XMARKER (o1
)->buffer
== XMARKER (o2
)->buffer
2341 && (XMARKER (o1
)->buffer
== 0
2342 || XMARKER (o1
)->bytepos
== XMARKER (o2
)->bytepos
));
2346 case Lisp_Vectorlike
:
2349 ptrdiff_t size
= ASIZE (o1
);
2350 /* Pseudovectors have the type encoded in the size field, so this test
2351 actually checks that the objects have the same type as well as the
2353 if (ASIZE (o2
) != size
)
2355 /* Boolvectors are compared much like strings. */
2356 if (BOOL_VECTOR_P (o1
))
2358 EMACS_INT size
= bool_vector_size (o1
);
2359 if (size
!= bool_vector_size (o2
))
2361 if (memcmp (bool_vector_data (o1
), bool_vector_data (o2
),
2362 bool_vector_bytes (size
)))
2366 if (WINDOW_CONFIGURATIONP (o1
))
2368 eassert (equal_kind
!= EQUAL_NO_QUIT
);
2369 return compare_window_configurations (o1
, o2
, false);
2372 /* Aside from them, only true vectors, char-tables, compiled
2373 functions, and fonts (font-spec, font-entity, font-object)
2374 are sensible to compare, so eliminate the others now. */
2375 if (size
& PSEUDOVECTOR_FLAG
)
2377 if (((size
& PVEC_TYPE_MASK
) >> PSEUDOVECTOR_AREA_BITS
)
2380 size
&= PSEUDOVECTOR_SIZE_MASK
;
2382 for (i
= 0; i
< size
; i
++)
2387 if (!internal_equal (v1
, v2
, equal_kind
, depth
+ 1, ht
))
2395 if (SCHARS (o1
) != SCHARS (o2
))
2397 if (SBYTES (o1
) != SBYTES (o2
))
2399 if (memcmp (SDATA (o1
), SDATA (o2
), SBYTES (o1
)))
2401 if (equal_kind
== EQUAL_INCLUDING_PROPERTIES
2402 && !compare_string_intervals (o1
, o2
))
2414 DEFUN ("fillarray", Ffillarray
, Sfillarray
, 2, 2, 0,
2415 doc
: /* Store each element of ARRAY with ITEM.
2416 ARRAY is a vector, string, char-table, or bool-vector. */)
2417 (Lisp_Object array
, Lisp_Object item
)
2419 register ptrdiff_t size
, idx
;
2421 if (VECTORP (array
))
2422 for (idx
= 0, size
= ASIZE (array
); idx
< size
; idx
++)
2423 ASET (array
, idx
, item
);
2424 else if (CHAR_TABLE_P (array
))
2428 for (i
= 0; i
< (1 << CHARTAB_SIZE_BITS_0
); i
++)
2429 set_char_table_contents (array
, i
, item
);
2430 set_char_table_defalt (array
, item
);
2432 else if (STRINGP (array
))
2434 register unsigned char *p
= SDATA (array
);
2436 CHECK_CHARACTER (item
);
2437 charval
= XFASTINT (item
);
2438 size
= SCHARS (array
);
2439 if (STRING_MULTIBYTE (array
))
2441 unsigned char str
[MAX_MULTIBYTE_LENGTH
];
2442 int len
= CHAR_STRING (charval
, str
);
2443 ptrdiff_t size_byte
= SBYTES (array
);
2446 if (INT_MULTIPLY_WRAPV (size
, len
, &product
) || product
!= size_byte
)
2447 error ("Attempt to change byte length of a string");
2448 for (idx
= 0; idx
< size_byte
; idx
++)
2449 *p
++ = str
[idx
% len
];
2452 for (idx
= 0; idx
< size
; idx
++)
2455 else if (BOOL_VECTOR_P (array
))
2456 return bool_vector_fill (array
, item
);
2458 wrong_type_argument (Qarrayp
, array
);
2462 DEFUN ("clear-string", Fclear_string
, Sclear_string
,
2464 doc
: /* Clear the contents of STRING.
2465 This makes STRING unibyte and may change its length. */)
2466 (Lisp_Object string
)
2469 CHECK_STRING (string
);
2470 len
= SBYTES (string
);
2471 memset (SDATA (string
), 0, len
);
2472 STRING_SET_CHARS (string
, len
);
2473 STRING_SET_UNIBYTE (string
);
2479 nconc2 (Lisp_Object s1
, Lisp_Object s2
)
2481 return CALLN (Fnconc
, s1
, s2
);
2484 DEFUN ("nconc", Fnconc
, Snconc
, 0, MANY
, 0,
2485 doc
: /* Concatenate any number of lists by altering them.
2486 Only the last argument is not altered, and need not be a list.
2487 usage: (nconc &rest LISTS) */)
2488 (ptrdiff_t nargs
, Lisp_Object
*args
)
2490 Lisp_Object val
= Qnil
;
2492 for (ptrdiff_t argnum
= 0; argnum
< nargs
; argnum
++)
2494 Lisp_Object tem
= args
[argnum
];
2495 if (NILP (tem
)) continue;
2500 if (argnum
+ 1 == nargs
) break;
2508 tem
= args
[argnum
+ 1];
2509 Fsetcdr (tail
, tem
);
2511 args
[argnum
+ 1] = tail
;
2517 /* This is the guts of all mapping functions.
2518 Apply FN to each element of SEQ, one by one, storing the results
2519 into elements of VALS, a C vector of Lisp_Objects. LENI is the
2520 length of VALS, which should also be the length of SEQ. Return the
2521 number of results; although this is normally LENI, it can be less
2522 if SEQ is made shorter as a side effect of FN. */
2525 mapcar1 (EMACS_INT leni
, Lisp_Object
*vals
, Lisp_Object fn
, Lisp_Object seq
)
2527 Lisp_Object tail
, dummy
;
2530 if (VECTORP (seq
) || COMPILEDP (seq
))
2532 for (i
= 0; i
< leni
; i
++)
2534 dummy
= call1 (fn
, AREF (seq
, i
));
2539 else if (BOOL_VECTOR_P (seq
))
2541 for (i
= 0; i
< leni
; i
++)
2543 dummy
= call1 (fn
, bool_vector_ref (seq
, i
));
2548 else if (STRINGP (seq
))
2552 for (i
= 0, i_byte
= 0; i
< leni
;)
2555 ptrdiff_t i_before
= i
;
2557 FETCH_STRING_CHAR_ADVANCE (c
, seq
, i
, i_byte
);
2558 XSETFASTINT (dummy
, c
);
2559 dummy
= call1 (fn
, dummy
);
2561 vals
[i_before
] = dummy
;
2564 else /* Must be a list, since Flength did not get an error */
2567 for (i
= 0; i
< leni
; i
++)
2571 dummy
= call1 (fn
, XCAR (tail
));
2581 DEFUN ("mapconcat", Fmapconcat
, Smapconcat
, 3, 3, 0,
2582 doc
: /* Apply FUNCTION to each element of SEQUENCE, and concat the results as strings.
2583 In between each pair of results, stick in SEPARATOR. Thus, " " as
2584 SEPARATOR results in spaces between the values returned by FUNCTION.
2585 SEQUENCE may be a list, a vector, a bool-vector, or a string. */)
2586 (Lisp_Object function
, Lisp_Object sequence
, Lisp_Object separator
)
2589 EMACS_INT leni
= XFASTINT (Flength (sequence
));
2590 if (CHAR_TABLE_P (sequence
))
2591 wrong_type_argument (Qlistp
, sequence
);
2592 EMACS_INT args_alloc
= 2 * leni
- 1;
2594 return empty_unibyte_string
;
2596 SAFE_ALLOCA_LISP (args
, args_alloc
);
2597 ptrdiff_t nmapped
= mapcar1 (leni
, args
, function
, sequence
);
2598 ptrdiff_t nargs
= 2 * nmapped
- 1;
2600 for (ptrdiff_t i
= nmapped
- 1; i
> 0; i
--)
2601 args
[i
+ i
] = args
[i
];
2603 for (ptrdiff_t i
= 1; i
< nargs
; i
+= 2)
2604 args
[i
] = separator
;
2606 Lisp_Object ret
= Fconcat (nargs
, args
);
2611 DEFUN ("mapcar", Fmapcar
, Smapcar
, 2, 2, 0,
2612 doc
: /* Apply FUNCTION to each element of SEQUENCE, and make a list of the results.
2613 The result is a list just as long as SEQUENCE.
2614 SEQUENCE may be a list, a vector, a bool-vector, or a string. */)
2615 (Lisp_Object function
, Lisp_Object sequence
)
2618 EMACS_INT leni
= XFASTINT (Flength (sequence
));
2619 if (CHAR_TABLE_P (sequence
))
2620 wrong_type_argument (Qlistp
, sequence
);
2622 SAFE_ALLOCA_LISP (args
, leni
);
2623 ptrdiff_t nmapped
= mapcar1 (leni
, args
, function
, sequence
);
2624 Lisp_Object ret
= Flist (nmapped
, args
);
2629 DEFUN ("mapc", Fmapc
, Smapc
, 2, 2, 0,
2630 doc
: /* Apply FUNCTION to each element of SEQUENCE for side effects only.
2631 Unlike `mapcar', don't accumulate the results. Return SEQUENCE.
2632 SEQUENCE may be a list, a vector, a bool-vector, or a string. */)
2633 (Lisp_Object function
, Lisp_Object sequence
)
2635 register EMACS_INT leni
;
2637 leni
= XFASTINT (Flength (sequence
));
2638 if (CHAR_TABLE_P (sequence
))
2639 wrong_type_argument (Qlistp
, sequence
);
2640 mapcar1 (leni
, 0, function
, sequence
);
2645 DEFUN ("mapcan", Fmapcan
, Smapcan
, 2, 2, 0,
2646 doc
: /* Apply FUNCTION to each element of SEQUENCE, and concatenate
2647 the results by altering them (using `nconc').
2648 SEQUENCE may be a list, a vector, a bool-vector, or a string. */)
2649 (Lisp_Object function
, Lisp_Object sequence
)
2652 EMACS_INT leni
= XFASTINT (Flength (sequence
));
2653 if (CHAR_TABLE_P (sequence
))
2654 wrong_type_argument (Qlistp
, sequence
);
2656 SAFE_ALLOCA_LISP (args
, leni
);
2657 ptrdiff_t nmapped
= mapcar1 (leni
, args
, function
, sequence
);
2658 Lisp_Object ret
= Fnconc (nmapped
, args
);
2663 /* This is how C code calls `yes-or-no-p' and allows the user
2667 do_yes_or_no_p (Lisp_Object prompt
)
2669 return call1 (intern ("yes-or-no-p"), prompt
);
2672 DEFUN ("yes-or-no-p", Fyes_or_no_p
, Syes_or_no_p
, 1, 1, 0,
2673 doc
: /* Ask user a yes-or-no question.
2674 Return t if answer is yes, and nil if the answer is no.
2675 PROMPT is the string to display to ask the question. It should end in
2676 a space; `yes-or-no-p' adds \"(yes or no) \" to it.
2678 The user must confirm the answer with RET, and can edit it until it
2681 If dialog boxes are supported, a dialog box will be used
2682 if `last-nonmenu-event' is nil, and `use-dialog-box' is non-nil. */)
2683 (Lisp_Object prompt
)
2687 CHECK_STRING (prompt
);
2689 if ((NILP (last_nonmenu_event
) || CONSP (last_nonmenu_event
))
2690 && use_dialog_box
&& ! NILP (last_input_event
))
2692 Lisp_Object pane
, menu
, obj
;
2693 redisplay_preserve_echo_area (4);
2694 pane
= list2 (Fcons (build_string ("Yes"), Qt
),
2695 Fcons (build_string ("No"), Qnil
));
2696 menu
= Fcons (prompt
, pane
);
2697 obj
= Fx_popup_dialog (Qt
, menu
, Qnil
);
2701 AUTO_STRING (yes_or_no
, "(yes or no) ");
2702 prompt
= CALLN (Fconcat
, prompt
, yes_or_no
);
2706 ans
= Fdowncase (Fread_from_minibuffer (prompt
, Qnil
, Qnil
, Qnil
,
2707 Qyes_or_no_p_history
, Qnil
,
2709 if (SCHARS (ans
) == 3 && !strcmp (SSDATA (ans
), "yes"))
2711 if (SCHARS (ans
) == 2 && !strcmp (SSDATA (ans
), "no"))
2716 message1 ("Please answer yes or no.");
2717 Fsleep_for (make_number (2), Qnil
);
2721 DEFUN ("load-average", Fload_average
, Sload_average
, 0, 1, 0,
2722 doc
: /* Return list of 1 minute, 5 minute and 15 minute load averages.
2724 Each of the three load averages is multiplied by 100, then converted
2727 When USE-FLOATS is non-nil, floats will be used instead of integers.
2728 These floats are not multiplied by 100.
2730 If the 5-minute or 15-minute load averages are not available, return a
2731 shortened list, containing only those averages which are available.
2733 An error is thrown if the load average can't be obtained. In some
2734 cases making it work would require Emacs being installed setuid or
2735 setgid so that it can read kernel information, and that usually isn't
2737 (Lisp_Object use_floats
)
2740 int loads
= getloadavg (load_ave
, 3);
2741 Lisp_Object ret
= Qnil
;
2744 error ("load-average not implemented for this operating system");
2748 Lisp_Object load
= (NILP (use_floats
)
2749 ? make_number (100.0 * load_ave
[loads
])
2750 : make_float (load_ave
[loads
]));
2751 ret
= Fcons (load
, ret
);
2757 DEFUN ("featurep", Ffeaturep
, Sfeaturep
, 1, 2, 0,
2758 doc
: /* Return t if FEATURE is present in this Emacs.
2760 Use this to conditionalize execution of lisp code based on the
2761 presence or absence of Emacs or environment extensions.
2762 Use `provide' to declare that a feature is available. This function
2763 looks at the value of the variable `features'. The optional argument
2764 SUBFEATURE can be used to check a specific subfeature of FEATURE. */)
2765 (Lisp_Object feature
, Lisp_Object subfeature
)
2767 register Lisp_Object tem
;
2768 CHECK_SYMBOL (feature
);
2769 tem
= Fmemq (feature
, Vfeatures
);
2770 if (!NILP (tem
) && !NILP (subfeature
))
2771 tem
= Fmember (subfeature
, Fget (feature
, Qsubfeatures
));
2772 return (NILP (tem
)) ? Qnil
: Qt
;
2775 DEFUN ("provide", Fprovide
, Sprovide
, 1, 2, 0,
2776 doc
: /* Announce that FEATURE is a feature of the current Emacs.
2777 The optional argument SUBFEATURES should be a list of symbols listing
2778 particular subfeatures supported in this version of FEATURE. */)
2779 (Lisp_Object feature
, Lisp_Object subfeatures
)
2781 register Lisp_Object tem
;
2782 CHECK_SYMBOL (feature
);
2783 CHECK_LIST (subfeatures
);
2784 if (!NILP (Vautoload_queue
))
2785 Vautoload_queue
= Fcons (Fcons (make_number (0), Vfeatures
),
2787 tem
= Fmemq (feature
, Vfeatures
);
2789 Vfeatures
= Fcons (feature
, Vfeatures
);
2790 if (!NILP (subfeatures
))
2791 Fput (feature
, Qsubfeatures
, subfeatures
);
2792 LOADHIST_ATTACH (Fcons (Qprovide
, feature
));
2794 /* Run any load-hooks for this file. */
2795 tem
= Fassq (feature
, Vafter_load_alist
);
2797 Fmapc (Qfuncall
, XCDR (tem
));
2802 /* `require' and its subroutines. */
2804 /* List of features currently being require'd, innermost first. */
2806 static Lisp_Object require_nesting_list
;
2809 require_unwind (Lisp_Object old_value
)
2811 require_nesting_list
= old_value
;
2814 DEFUN ("require", Frequire
, Srequire
, 1, 3, 0,
2815 doc
: /* If feature FEATURE is not loaded, load it from FILENAME.
2816 If FEATURE is not a member of the list `features', then the feature is
2817 not loaded; so load the file FILENAME.
2819 If FILENAME is omitted, the printname of FEATURE is used as the file
2820 name, and `load' will try to load this name appended with the suffix
2821 `.elc', `.el', or the system-dependent suffix for dynamic module
2822 files, in that order. The name without appended suffix will not be
2823 used. See `get-load-suffixes' for the complete list of suffixes.
2825 The directories in `load-path' are searched when trying to find the
2828 If the optional third argument NOERROR is non-nil, then return nil if
2829 the file is not found instead of signaling an error. Normally the
2830 return value is FEATURE.
2832 The normal messages at start and end of loading FILENAME are
2834 (Lisp_Object feature
, Lisp_Object filename
, Lisp_Object noerror
)
2837 bool from_file
= load_in_progress
;
2839 CHECK_SYMBOL (feature
);
2841 /* Record the presence of `require' in this file
2842 even if the feature specified is already loaded.
2843 But not more than once in any file,
2844 and not when we aren't loading or reading from a file. */
2846 for (tem
= Vcurrent_load_list
; CONSP (tem
); tem
= XCDR (tem
))
2847 if (NILP (XCDR (tem
)) && STRINGP (XCAR (tem
)))
2852 tem
= Fcons (Qrequire
, feature
);
2853 if (NILP (Fmember (tem
, Vcurrent_load_list
)))
2854 LOADHIST_ATTACH (tem
);
2856 tem
= Fmemq (feature
, Vfeatures
);
2860 ptrdiff_t count
= SPECPDL_INDEX ();
2863 /* This is to make sure that loadup.el gives a clear picture
2864 of what files are preloaded and when. */
2865 if (! NILP (Vpurify_flag
))
2866 error ("(require %s) while preparing to dump",
2867 SDATA (SYMBOL_NAME (feature
)));
2869 /* A certain amount of recursive `require' is legitimate,
2870 but if we require the same feature recursively 3 times,
2872 tem
= require_nesting_list
;
2873 while (! NILP (tem
))
2875 if (! NILP (Fequal (feature
, XCAR (tem
))))
2880 error ("Recursive `require' for feature `%s'",
2881 SDATA (SYMBOL_NAME (feature
)));
2883 /* Update the list for any nested `require's that occur. */
2884 record_unwind_protect (require_unwind
, require_nesting_list
);
2885 require_nesting_list
= Fcons (feature
, require_nesting_list
);
2887 /* Value saved here is to be restored into Vautoload_queue */
2888 record_unwind_protect (un_autoload
, Vautoload_queue
);
2889 Vautoload_queue
= Qt
;
2891 /* Load the file. */
2892 tem
= Fload (NILP (filename
) ? Fsymbol_name (feature
) : filename
,
2893 noerror
, Qt
, Qnil
, (NILP (filename
) ? Qt
: Qnil
));
2895 /* If load failed entirely, return nil. */
2897 return unbind_to (count
, Qnil
);
2899 tem
= Fmemq (feature
, Vfeatures
);
2902 unsigned char *tem2
= SDATA (SYMBOL_NAME (feature
));
2903 Lisp_Object tem3
= Fcar (Fcar (Vload_history
));
2906 error ("Required feature `%s' was not provided", tem2
);
2908 /* Cf autoload-do-load. */
2909 error ("Loading file %s failed to provide feature `%s'",
2910 SDATA (tem3
), tem2
);
2913 /* Once loading finishes, don't undo it. */
2914 Vautoload_queue
= Qt
;
2915 feature
= unbind_to (count
, feature
);
2921 /* Primitives for work of the "widget" library.
2922 In an ideal world, this section would not have been necessary.
2923 However, lisp function calls being as slow as they are, it turns
2924 out that some functions in the widget library (wid-edit.el) are the
2925 bottleneck of Widget operation. Here is their translation to C,
2926 for the sole reason of efficiency. */
2928 DEFUN ("plist-member", Fplist_member
, Splist_member
, 2, 2, 0,
2929 doc
: /* Return non-nil if PLIST has the property PROP.
2930 PLIST is a property list, which is a list of the form
2931 \(PROP1 VALUE1 PROP2 VALUE2 ...). PROP is a symbol.
2932 Unlike `plist-get', this allows you to distinguish between a missing
2933 property and a property with the value nil.
2934 The value is actually the tail of PLIST whose car is PROP. */)
2935 (Lisp_Object plist
, Lisp_Object prop
)
2937 Lisp_Object tail
= plist
;
2938 FOR_EACH_TAIL (tail
)
2940 if (EQ (XCAR (tail
), prop
))
2945 if (EQ (tail
, li
.tortoise
))
2946 circular_list (tail
);
2948 CHECK_TYPE (NILP (tail
), Qplistp
, plist
);
2952 DEFUN ("widget-put", Fwidget_put
, Swidget_put
, 3, 3, 0,
2953 doc
: /* In WIDGET, set PROPERTY to VALUE.
2954 The value can later be retrieved with `widget-get'. */)
2955 (Lisp_Object widget
, Lisp_Object property
, Lisp_Object value
)
2957 CHECK_CONS (widget
);
2958 XSETCDR (widget
, Fplist_put (XCDR (widget
), property
, value
));
2962 DEFUN ("widget-get", Fwidget_get
, Swidget_get
, 2, 2, 0,
2963 doc
: /* In WIDGET, get the value of PROPERTY.
2964 The value could either be specified when the widget was created, or
2965 later with `widget-put'. */)
2966 (Lisp_Object widget
, Lisp_Object property
)
2974 CHECK_CONS (widget
);
2975 tmp
= Fplist_member (XCDR (widget
), property
);
2981 tmp
= XCAR (widget
);
2984 widget
= Fget (tmp
, Qwidget_type
);
2988 DEFUN ("widget-apply", Fwidget_apply
, Swidget_apply
, 2, MANY
, 0,
2989 doc
: /* Apply the value of WIDGET's PROPERTY to the widget itself.
2990 ARGS are passed as extra arguments to the function.
2991 usage: (widget-apply WIDGET PROPERTY &rest ARGS) */)
2992 (ptrdiff_t nargs
, Lisp_Object
*args
)
2994 Lisp_Object widget
= args
[0];
2995 Lisp_Object property
= args
[1];
2996 Lisp_Object propval
= Fwidget_get (widget
, property
);
2997 Lisp_Object trailing_args
= Flist (nargs
- 2, args
+ 2);
2998 Lisp_Object result
= CALLN (Fapply
, propval
, widget
, trailing_args
);
3002 #ifdef HAVE_LANGINFO_CODESET
3003 #include <langinfo.h>
3006 DEFUN ("locale-info", Flocale_info
, Slocale_info
, 1, 1, 0,
3007 doc
: /* Access locale data ITEM for the current C locale, if available.
3008 ITEM should be one of the following:
3010 `codeset', returning the character set as a string (locale item CODESET);
3012 `days', returning a 7-element vector of day names (locale items DAY_n);
3014 `months', returning a 12-element vector of month names (locale items MON_n);
3016 `paper', returning a list (WIDTH HEIGHT) for the default paper size,
3017 both measured in millimeters (locale items PAPER_WIDTH, PAPER_HEIGHT).
3019 If the system can't provide such information through a call to
3020 `nl_langinfo', or if ITEM isn't from the list above, return nil.
3022 See also Info node `(libc)Locales'.
3024 The data read from the system are decoded using `locale-coding-system'. */)
3028 #ifdef HAVE_LANGINFO_CODESET
3029 if (EQ (item
, Qcodeset
))
3031 str
= nl_langinfo (CODESET
);
3032 return build_string (str
);
3035 else if (EQ (item
, Qdays
)) /* e.g. for calendar-day-name-array */
3037 Lisp_Object v
= Fmake_vector (make_number (7), Qnil
);
3038 const int days
[7] = {DAY_1
, DAY_2
, DAY_3
, DAY_4
, DAY_5
, DAY_6
, DAY_7
};
3040 synchronize_system_time_locale ();
3041 for (i
= 0; i
< 7; i
++)
3043 str
= nl_langinfo (days
[i
]);
3044 AUTO_STRING (val
, str
);
3045 /* Fixme: Is this coding system necessarily right, even if
3046 it is consistent with CODESET? If not, what to do? */
3047 ASET (v
, i
, code_convert_string_norecord (val
, Vlocale_coding_system
,
3054 else if (EQ (item
, Qmonths
)) /* e.g. for calendar-month-name-array */
3056 Lisp_Object v
= Fmake_vector (make_number (12), Qnil
);
3057 const int months
[12] = {MON_1
, MON_2
, MON_3
, MON_4
, MON_5
, MON_6
, MON_7
,
3058 MON_8
, MON_9
, MON_10
, MON_11
, MON_12
};
3060 synchronize_system_time_locale ();
3061 for (i
= 0; i
< 12; i
++)
3063 str
= nl_langinfo (months
[i
]);
3064 AUTO_STRING (val
, str
);
3065 ASET (v
, i
, code_convert_string_norecord (val
, Vlocale_coding_system
,
3071 /* LC_PAPER stuff isn't defined as accessible in glibc as of 2.3.1,
3072 but is in the locale files. This could be used by ps-print. */
3074 else if (EQ (item
, Qpaper
))
3075 return list2i (nl_langinfo (PAPER_WIDTH
), nl_langinfo (PAPER_HEIGHT
));
3076 #endif /* PAPER_WIDTH */
3077 #endif /* HAVE_LANGINFO_CODESET*/
3081 /* base64 encode/decode functions (RFC 2045).
3082 Based on code from GNU recode. */
3084 #define MIME_LINE_LENGTH 76
3086 #define IS_ASCII(Character) \
3088 #define IS_BASE64(Character) \
3089 (IS_ASCII (Character) && base64_char_to_value[Character] >= 0)
3090 #define IS_BASE64_IGNORABLE(Character) \
3091 ((Character) == ' ' || (Character) == '\t' || (Character) == '\n' \
3092 || (Character) == '\f' || (Character) == '\r')
3094 /* Used by base64_decode_1 to retrieve a non-base64-ignorable
3095 character or return retval if there are no characters left to
3097 #define READ_QUADRUPLET_BYTE(retval) \
3102 if (nchars_return) \
3103 *nchars_return = nchars; \
3108 while (IS_BASE64_IGNORABLE (c))
3110 /* Table of characters coding the 64 values. */
3111 static const char base64_value_to_char
[64] =
3113 'A', 'B', 'C', 'D', 'E', 'F', 'G', 'H', 'I', 'J', /* 0- 9 */
3114 'K', 'L', 'M', 'N', 'O', 'P', 'Q', 'R', 'S', 'T', /* 10-19 */
3115 'U', 'V', 'W', 'X', 'Y', 'Z', 'a', 'b', 'c', 'd', /* 20-29 */
3116 'e', 'f', 'g', 'h', 'i', 'j', 'k', 'l', 'm', 'n', /* 30-39 */
3117 'o', 'p', 'q', 'r', 's', 't', 'u', 'v', 'w', 'x', /* 40-49 */
3118 'y', 'z', '0', '1', '2', '3', '4', '5', '6', '7', /* 50-59 */
3119 '8', '9', '+', '/' /* 60-63 */
3122 /* Table of base64 values for first 128 characters. */
3123 static const short base64_char_to_value
[128] =
3125 -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, /* 0- 9 */
3126 -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, /* 10- 19 */
3127 -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, /* 20- 29 */
3128 -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, /* 30- 39 */
3129 -1, -1, -1, 62, -1, -1, -1, 63, 52, 53, /* 40- 49 */
3130 54, 55, 56, 57, 58, 59, 60, 61, -1, -1, /* 50- 59 */
3131 -1, -1, -1, -1, -1, 0, 1, 2, 3, 4, /* 60- 69 */
3132 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, /* 70- 79 */
3133 15, 16, 17, 18, 19, 20, 21, 22, 23, 24, /* 80- 89 */
3134 25, -1, -1, -1, -1, -1, -1, 26, 27, 28, /* 90- 99 */
3135 29, 30, 31, 32, 33, 34, 35, 36, 37, 38, /* 100-109 */
3136 39, 40, 41, 42, 43, 44, 45, 46, 47, 48, /* 110-119 */
3137 49, 50, 51, -1, -1, -1, -1, -1 /* 120-127 */
3140 /* The following diagram shows the logical steps by which three octets
3141 get transformed into four base64 characters.
3143 .--------. .--------. .--------.
3144 |aaaaaabb| |bbbbcccc| |ccdddddd|
3145 `--------' `--------' `--------'
3147 .--------+--------+--------+--------.
3148 |00aaaaaa|00bbbbbb|00cccccc|00dddddd|
3149 `--------+--------+--------+--------'
3151 .--------+--------+--------+--------.
3152 |AAAAAAAA|BBBBBBBB|CCCCCCCC|DDDDDDDD|
3153 `--------+--------+--------+--------'
3155 The octets are divided into 6 bit chunks, which are then encoded into
3156 base64 characters. */
3159 static ptrdiff_t base64_encode_1 (const char *, char *, ptrdiff_t, bool, bool);
3160 static ptrdiff_t base64_decode_1 (const char *, char *, ptrdiff_t, bool,
3163 DEFUN ("base64-encode-region", Fbase64_encode_region
, Sbase64_encode_region
,
3165 doc
: /* Base64-encode the region between BEG and END.
3166 Return the length of the encoded text.
3167 Optional third argument NO-LINE-BREAK means do not break long lines
3168 into shorter lines. */)
3169 (Lisp_Object beg
, Lisp_Object end
, Lisp_Object no_line_break
)
3172 ptrdiff_t allength
, length
;
3173 ptrdiff_t ibeg
, iend
, encoded_length
;
3174 ptrdiff_t old_pos
= PT
;
3177 validate_region (&beg
, &end
);
3179 ibeg
= CHAR_TO_BYTE (XFASTINT (beg
));
3180 iend
= CHAR_TO_BYTE (XFASTINT (end
));
3181 move_gap_both (XFASTINT (beg
), ibeg
);
3183 /* We need to allocate enough room for encoding the text.
3184 We need 33 1/3% more space, plus a newline every 76
3185 characters, and then we round up. */
3186 length
= iend
- ibeg
;
3187 allength
= length
+ length
/3 + 1;
3188 allength
+= allength
/ MIME_LINE_LENGTH
+ 1 + 6;
3190 encoded
= SAFE_ALLOCA (allength
);
3191 encoded_length
= base64_encode_1 ((char *) BYTE_POS_ADDR (ibeg
),
3192 encoded
, length
, NILP (no_line_break
),
3193 !NILP (BVAR (current_buffer
, enable_multibyte_characters
)));
3194 if (encoded_length
> allength
)
3197 if (encoded_length
< 0)
3199 /* The encoding wasn't possible. */
3201 error ("Multibyte character in data for base64 encoding");
3204 /* Now we have encoded the region, so we insert the new contents
3205 and delete the old. (Insert first in order to preserve markers.) */
3206 SET_PT_BOTH (XFASTINT (beg
), ibeg
);
3207 insert (encoded
, encoded_length
);
3209 del_range_byte (ibeg
+ encoded_length
, iend
+ encoded_length
);
3211 /* If point was outside of the region, restore it exactly; else just
3212 move to the beginning of the region. */
3213 if (old_pos
>= XFASTINT (end
))
3214 old_pos
+= encoded_length
- (XFASTINT (end
) - XFASTINT (beg
));
3215 else if (old_pos
> XFASTINT (beg
))
3216 old_pos
= XFASTINT (beg
);
3219 /* We return the length of the encoded text. */
3220 return make_number (encoded_length
);
3223 DEFUN ("base64-encode-string", Fbase64_encode_string
, Sbase64_encode_string
,
3225 doc
: /* Base64-encode STRING and return the result.
3226 Optional second argument NO-LINE-BREAK means do not break long lines
3227 into shorter lines. */)
3228 (Lisp_Object string
, Lisp_Object no_line_break
)
3230 ptrdiff_t allength
, length
, encoded_length
;
3232 Lisp_Object encoded_string
;
3235 CHECK_STRING (string
);
3237 /* We need to allocate enough room for encoding the text.
3238 We need 33 1/3% more space, plus a newline every 76
3239 characters, and then we round up. */
3240 length
= SBYTES (string
);
3241 allength
= length
+ length
/3 + 1;
3242 allength
+= allength
/ MIME_LINE_LENGTH
+ 1 + 6;
3244 /* We need to allocate enough room for decoding the text. */
3245 encoded
= SAFE_ALLOCA (allength
);
3247 encoded_length
= base64_encode_1 (SSDATA (string
),
3248 encoded
, length
, NILP (no_line_break
),
3249 STRING_MULTIBYTE (string
));
3250 if (encoded_length
> allength
)
3253 if (encoded_length
< 0)
3255 /* The encoding wasn't possible. */
3256 error ("Multibyte character in data for base64 encoding");
3259 encoded_string
= make_unibyte_string (encoded
, encoded_length
);
3262 return encoded_string
;
3266 base64_encode_1 (const char *from
, char *to
, ptrdiff_t length
,
3267 bool line_break
, bool multibyte
)
3280 c
= STRING_CHAR_AND_LENGTH ((unsigned char *) from
+ i
, bytes
);
3281 if (CHAR_BYTE8_P (c
))
3282 c
= CHAR_TO_BYTE8 (c
);
3290 /* Wrap line every 76 characters. */
3294 if (counter
< MIME_LINE_LENGTH
/ 4)
3303 /* Process first byte of a triplet. */
3305 *e
++ = base64_value_to_char
[0x3f & c
>> 2];
3306 value
= (0x03 & c
) << 4;
3308 /* Process second byte of a triplet. */
3312 *e
++ = base64_value_to_char
[value
];
3320 c
= STRING_CHAR_AND_LENGTH ((unsigned char *) from
+ i
, bytes
);
3321 if (CHAR_BYTE8_P (c
))
3322 c
= CHAR_TO_BYTE8 (c
);
3330 *e
++ = base64_value_to_char
[value
| (0x0f & c
>> 4)];
3331 value
= (0x0f & c
) << 2;
3333 /* Process third byte of a triplet. */
3337 *e
++ = base64_value_to_char
[value
];
3344 c
= STRING_CHAR_AND_LENGTH ((unsigned char *) from
+ i
, bytes
);
3345 if (CHAR_BYTE8_P (c
))
3346 c
= CHAR_TO_BYTE8 (c
);
3354 *e
++ = base64_value_to_char
[value
| (0x03 & c
>> 6)];
3355 *e
++ = base64_value_to_char
[0x3f & c
];
3362 DEFUN ("base64-decode-region", Fbase64_decode_region
, Sbase64_decode_region
,
3364 doc
: /* Base64-decode the region between BEG and END.
3365 Return the length of the decoded text.
3366 If the region can't be decoded, signal an error and don't modify the buffer. */)
3367 (Lisp_Object beg
, Lisp_Object end
)
3369 ptrdiff_t ibeg
, iend
, length
, allength
;
3371 ptrdiff_t old_pos
= PT
;
3372 ptrdiff_t decoded_length
;
3373 ptrdiff_t inserted_chars
;
3374 bool multibyte
= !NILP (BVAR (current_buffer
, enable_multibyte_characters
));
3377 validate_region (&beg
, &end
);
3379 ibeg
= CHAR_TO_BYTE (XFASTINT (beg
));
3380 iend
= CHAR_TO_BYTE (XFASTINT (end
));
3382 length
= iend
- ibeg
;
3384 /* We need to allocate enough room for decoding the text. If we are
3385 working on a multibyte buffer, each decoded code may occupy at
3387 allength
= multibyte
? length
* 2 : length
;
3388 decoded
= SAFE_ALLOCA (allength
);
3390 move_gap_both (XFASTINT (beg
), ibeg
);
3391 decoded_length
= base64_decode_1 ((char *) BYTE_POS_ADDR (ibeg
),
3393 multibyte
, &inserted_chars
);
3394 if (decoded_length
> allength
)
3397 if (decoded_length
< 0)
3399 /* The decoding wasn't possible. */
3400 error ("Invalid base64 data");
3403 /* Now we have decoded the region, so we insert the new contents
3404 and delete the old. (Insert first in order to preserve markers.) */
3405 TEMP_SET_PT_BOTH (XFASTINT (beg
), ibeg
);
3406 insert_1_both (decoded
, inserted_chars
, decoded_length
, 0, 1, 0);
3407 signal_after_change (XFASTINT (beg
), 0, inserted_chars
);
3410 /* Delete the original text. */
3411 del_range_both (PT
, PT_BYTE
, XFASTINT (end
) + inserted_chars
,
3412 iend
+ decoded_length
, 1);
3414 /* If point was outside of the region, restore it exactly; else just
3415 move to the beginning of the region. */
3416 if (old_pos
>= XFASTINT (end
))
3417 old_pos
+= inserted_chars
- (XFASTINT (end
) - XFASTINT (beg
));
3418 else if (old_pos
> XFASTINT (beg
))
3419 old_pos
= XFASTINT (beg
);
3420 SET_PT (old_pos
> ZV
? ZV
: old_pos
);
3422 return make_number (inserted_chars
);
3425 DEFUN ("base64-decode-string", Fbase64_decode_string
, Sbase64_decode_string
,
3427 doc
: /* Base64-decode STRING and return the result. */)
3428 (Lisp_Object string
)
3431 ptrdiff_t length
, decoded_length
;
3432 Lisp_Object decoded_string
;
3435 CHECK_STRING (string
);
3437 length
= SBYTES (string
);
3438 /* We need to allocate enough room for decoding the text. */
3439 decoded
= SAFE_ALLOCA (length
);
3441 /* The decoded result should be unibyte. */
3442 decoded_length
= base64_decode_1 (SSDATA (string
), decoded
, length
,
3444 if (decoded_length
> length
)
3446 else if (decoded_length
>= 0)
3447 decoded_string
= make_unibyte_string (decoded
, decoded_length
);
3449 decoded_string
= Qnil
;
3452 if (!STRINGP (decoded_string
))
3453 error ("Invalid base64 data");
3455 return decoded_string
;
3458 /* Base64-decode the data at FROM of LENGTH bytes into TO. If
3459 MULTIBYTE, the decoded result should be in multibyte
3460 form. If NCHARS_RETURN is not NULL, store the number of produced
3461 characters in *NCHARS_RETURN. */
3464 base64_decode_1 (const char *from
, char *to
, ptrdiff_t length
,
3465 bool multibyte
, ptrdiff_t *nchars_return
)
3467 ptrdiff_t i
= 0; /* Used inside READ_QUADRUPLET_BYTE */
3470 unsigned long value
;
3471 ptrdiff_t nchars
= 0;
3475 /* Process first byte of a quadruplet. */
3477 READ_QUADRUPLET_BYTE (e
-to
);
3481 value
= base64_char_to_value
[c
] << 18;
3483 /* Process second byte of a quadruplet. */
3485 READ_QUADRUPLET_BYTE (-1);
3489 value
|= base64_char_to_value
[c
] << 12;
3491 c
= (unsigned char) (value
>> 16);
3492 if (multibyte
&& c
>= 128)
3493 e
+= BYTE8_STRING (c
, e
);
3498 /* Process third byte of a quadruplet. */
3500 READ_QUADRUPLET_BYTE (-1);
3504 READ_QUADRUPLET_BYTE (-1);
3513 value
|= base64_char_to_value
[c
] << 6;
3515 c
= (unsigned char) (0xff & value
>> 8);
3516 if (multibyte
&& c
>= 128)
3517 e
+= BYTE8_STRING (c
, e
);
3522 /* Process fourth byte of a quadruplet. */
3524 READ_QUADRUPLET_BYTE (-1);
3531 value
|= base64_char_to_value
[c
];
3533 c
= (unsigned char) (0xff & value
);
3534 if (multibyte
&& c
>= 128)
3535 e
+= BYTE8_STRING (c
, e
);
3544 /***********************************************************************
3546 ***** Hash Tables *****
3548 ***********************************************************************/
3550 /* Implemented by gerd@gnu.org. This hash table implementation was
3551 inspired by CMUCL hash tables. */
3555 1. For small tables, association lists are probably faster than
3556 hash tables because they have lower overhead.
3558 For uses of hash tables where the O(1) behavior of table
3559 operations is not a requirement, it might therefore be a good idea
3560 not to hash. Instead, we could just do a linear search in the
3561 key_and_value vector of the hash table. This could be done
3562 if a `:linear-search t' argument is given to make-hash-table. */
3565 /* The list of all weak hash tables. Don't staticpro this one. */
3567 static struct Lisp_Hash_Table
*weak_hash_tables
;
3570 /***********************************************************************
3572 ***********************************************************************/
3575 CHECK_HASH_TABLE (Lisp_Object x
)
3577 CHECK_TYPE (HASH_TABLE_P (x
), Qhash_table_p
, x
);
3581 set_hash_key_and_value (struct Lisp_Hash_Table
*h
, Lisp_Object key_and_value
)
3583 h
->key_and_value
= key_and_value
;
3586 set_hash_next (struct Lisp_Hash_Table
*h
, Lisp_Object next
)
3591 set_hash_next_slot (struct Lisp_Hash_Table
*h
, ptrdiff_t idx
, ptrdiff_t val
)
3593 gc_aset (h
->next
, idx
, make_number (val
));
3596 set_hash_hash (struct Lisp_Hash_Table
*h
, Lisp_Object hash
)
3601 set_hash_hash_slot (struct Lisp_Hash_Table
*h
, ptrdiff_t idx
, Lisp_Object val
)
3603 gc_aset (h
->hash
, idx
, val
);
3606 set_hash_index (struct Lisp_Hash_Table
*h
, Lisp_Object index
)
3611 set_hash_index_slot (struct Lisp_Hash_Table
*h
, ptrdiff_t idx
, ptrdiff_t val
)
3613 gc_aset (h
->index
, idx
, make_number (val
));
3616 /* If OBJ is a Lisp hash table, return a pointer to its struct
3617 Lisp_Hash_Table. Otherwise, signal an error. */
3619 static struct Lisp_Hash_Table
*
3620 check_hash_table (Lisp_Object obj
)
3622 CHECK_HASH_TABLE (obj
);
3623 return XHASH_TABLE (obj
);
3627 /* Value is the next integer I >= N, N >= 0 which is "almost" a prime
3628 number. A number is "almost" a prime number if it is not divisible
3629 by any integer in the range 2 .. (NEXT_ALMOST_PRIME_LIMIT - 1). */
3632 next_almost_prime (EMACS_INT n
)
3634 verify (NEXT_ALMOST_PRIME_LIMIT
== 11);
3635 for (n
|= 1; ; n
+= 2)
3636 if (n
% 3 != 0 && n
% 5 != 0 && n
% 7 != 0)
3641 /* Find KEY in ARGS which has size NARGS. Don't consider indices for
3642 which USED[I] is non-zero. If found at index I in ARGS, set
3643 USED[I] and USED[I + 1] to 1, and return I + 1. Otherwise return
3644 0. This function is used to extract a keyword/argument pair from
3645 a DEFUN parameter list. */
3648 get_key_arg (Lisp_Object key
, ptrdiff_t nargs
, Lisp_Object
*args
, char *used
)
3652 for (i
= 1; i
< nargs
; i
++)
3653 if (!used
[i
- 1] && EQ (args
[i
- 1], key
))
3664 /* Return a Lisp vector which has the same contents as VEC but has
3665 at least INCR_MIN more entries, where INCR_MIN is positive.
3666 If NITEMS_MAX is not -1, do not grow the vector to be any larger
3667 than NITEMS_MAX. New entries in the resulting vector are
3671 larger_vecalloc (Lisp_Object vec
, ptrdiff_t incr_min
, ptrdiff_t nitems_max
)
3673 struct Lisp_Vector
*v
;
3674 ptrdiff_t incr
, incr_max
, old_size
, new_size
;
3675 ptrdiff_t C_language_max
= min (PTRDIFF_MAX
, SIZE_MAX
) / sizeof *v
->contents
;
3676 ptrdiff_t n_max
= (0 <= nitems_max
&& nitems_max
< C_language_max
3677 ? nitems_max
: C_language_max
);
3678 eassert (VECTORP (vec
));
3679 eassert (0 < incr_min
&& -1 <= nitems_max
);
3680 old_size
= ASIZE (vec
);
3681 incr_max
= n_max
- old_size
;
3682 incr
= max (incr_min
, min (old_size
>> 1, incr_max
));
3683 if (incr_max
< incr
)
3684 memory_full (SIZE_MAX
);
3685 new_size
= old_size
+ incr
;
3686 v
= allocate_vector (new_size
);
3687 memcpy (v
->contents
, XVECTOR (vec
)->contents
, old_size
* sizeof *v
->contents
);
3688 XSETVECTOR (vec
, v
);
3692 /* Likewise, except set new entries in the resulting vector to nil. */
3695 larger_vector (Lisp_Object vec
, ptrdiff_t incr_min
, ptrdiff_t nitems_max
)
3697 ptrdiff_t old_size
= ASIZE (vec
);
3698 Lisp_Object v
= larger_vecalloc (vec
, incr_min
, nitems_max
);
3699 ptrdiff_t new_size
= ASIZE (v
);
3700 memclear (XVECTOR (v
)->contents
+ old_size
,
3701 (new_size
- old_size
) * word_size
);
3706 /***********************************************************************
3708 ***********************************************************************/
3710 /* Return the index of the next entry in H following the one at IDX,
3714 HASH_NEXT (struct Lisp_Hash_Table
*h
, ptrdiff_t idx
)
3716 return XINT (AREF (h
->next
, idx
));
3719 /* Return the index of the element in hash table H that is the start
3720 of the collision list at index IDX, or -1 if the list is empty. */
3723 HASH_INDEX (struct Lisp_Hash_Table
*h
, ptrdiff_t idx
)
3725 return XINT (AREF (h
->index
, idx
));
3728 /* Compare KEY1 and KEY2 in hash table HT using `eql'. Value is true
3729 if KEY1 and KEY2 are the same. KEY1 and KEY2 must not be eq. */
3732 cmpfn_eql (struct hash_table_test
*ht
,
3736 return FLOATP (key1
) && FLOATP (key2
) && same_float (key1
, key2
);
3740 /* Compare KEY1 and KEY2 in hash table HT using `equal'. Value is
3741 true if KEY1 and KEY2 are the same. */
3744 cmpfn_equal (struct hash_table_test
*ht
,
3748 return !NILP (Fequal (key1
, key2
));
3752 /* Compare KEY1 and KEY2 in hash table HT using HT->user_cmp_function.
3753 Value is true if KEY1 and KEY2 are the same. */
3756 cmpfn_user_defined (struct hash_table_test
*ht
,
3760 return !NILP (call2 (ht
->user_cmp_function
, key1
, key2
));
3763 /* Value is a hash code for KEY for use in hash table H which uses
3764 `eq' to compare keys. The hash code returned is guaranteed to fit
3765 in a Lisp integer. */
3768 hashfn_eq (struct hash_table_test
*ht
, Lisp_Object key
)
3770 return XHASH (key
) ^ XTYPE (key
);
3773 /* Value is a hash code for KEY for use in hash table H which uses
3774 `equal' to compare keys. The hash code returned is guaranteed to fit
3775 in a Lisp integer. */
3778 hashfn_equal (struct hash_table_test
*ht
, Lisp_Object key
)
3780 return sxhash (key
, 0);
3783 /* Value is a hash code for KEY for use in hash table H which uses
3784 `eql' to compare keys. The hash code returned is guaranteed to fit
3785 in a Lisp integer. */
3788 hashfn_eql (struct hash_table_test
*ht
, Lisp_Object key
)
3790 return FLOATP (key
) ? hashfn_equal (ht
, key
) : hashfn_eq (ht
, key
);
3793 /* Value is a hash code for KEY for use in hash table H which uses as
3794 user-defined function to compare keys. The hash code returned is
3795 guaranteed to fit in a Lisp integer. */
3798 hashfn_user_defined (struct hash_table_test
*ht
, Lisp_Object key
)
3800 Lisp_Object hash
= call1 (ht
->user_hash_function
, key
);
3801 return hashfn_eq (ht
, hash
);
3804 struct hash_table_test
const
3805 hashtest_eq
= { LISPSYM_INITIALLY (Qeq
), LISPSYM_INITIALLY (Qnil
),
3806 LISPSYM_INITIALLY (Qnil
), 0, hashfn_eq
},
3807 hashtest_eql
= { LISPSYM_INITIALLY (Qeql
), LISPSYM_INITIALLY (Qnil
),
3808 LISPSYM_INITIALLY (Qnil
), cmpfn_eql
, hashfn_eql
},
3809 hashtest_equal
= { LISPSYM_INITIALLY (Qequal
), LISPSYM_INITIALLY (Qnil
),
3810 LISPSYM_INITIALLY (Qnil
), cmpfn_equal
, hashfn_equal
};
3812 /* Allocate basically initialized hash table. */
3814 static struct Lisp_Hash_Table
*
3815 allocate_hash_table (void)
3817 return ALLOCATE_PSEUDOVECTOR (struct Lisp_Hash_Table
,
3818 count
, PVEC_HASH_TABLE
);
3821 /* An upper bound on the size of a hash table index. It must fit in
3822 ptrdiff_t and be a valid Emacs fixnum. */
3823 #define INDEX_SIZE_BOUND \
3824 ((ptrdiff_t) min (MOST_POSITIVE_FIXNUM, PTRDIFF_MAX / word_size))
3826 /* Create and initialize a new hash table.
3828 TEST specifies the test the hash table will use to compare keys.
3829 It must be either one of the predefined tests `eq', `eql' or
3830 `equal' or a symbol denoting a user-defined test named TEST with
3831 test and hash functions USER_TEST and USER_HASH.
3833 Give the table initial capacity SIZE, 0 <= SIZE <= MOST_POSITIVE_FIXNUM.
3835 If REHASH_SIZE is equal to a negative integer, this hash table's
3836 new size when it becomes full is computed by subtracting
3837 REHASH_SIZE from its old size. Otherwise it must be positive, and
3838 the table's new size is computed by multiplying its old size by
3841 REHASH_THRESHOLD must be a float <= 1.0, and > 0. The table will
3842 be resized when the approximate ratio of table entries to table
3843 size exceeds REHASH_THRESHOLD.
3845 WEAK specifies the weakness of the table. If non-nil, it must be
3846 one of the symbols `key', `value', `key-or-value', or `key-and-value'.
3848 If PURECOPY is non-nil, the table can be copied to pure storage via
3849 `purecopy' when Emacs is being dumped. Such tables can no longer be
3850 changed after purecopy. */
3853 make_hash_table (struct hash_table_test test
, EMACS_INT size
,
3854 float rehash_size
, float rehash_threshold
,
3855 Lisp_Object weak
, bool pure
)
3857 struct Lisp_Hash_Table
*h
;
3859 EMACS_INT index_size
;
3863 /* Preconditions. */
3864 eassert (SYMBOLP (test
.name
));
3865 eassert (0 <= size
&& size
<= MOST_POSITIVE_FIXNUM
);
3866 eassert (rehash_size
<= -1 || 0 < rehash_size
);
3867 eassert (0 < rehash_threshold
&& rehash_threshold
<= 1);
3872 double threshold
= rehash_threshold
;
3873 index_float
= size
/ threshold
;
3874 index_size
= (index_float
< INDEX_SIZE_BOUND
+ 1
3875 ? next_almost_prime (index_float
)
3876 : INDEX_SIZE_BOUND
+ 1);
3877 if (INDEX_SIZE_BOUND
< max (index_size
, 2 * size
))
3878 error ("Hash table too large");
3880 /* Allocate a table and initialize it. */
3881 h
= allocate_hash_table ();
3883 /* Initialize hash table slots. */
3886 h
->rehash_threshold
= rehash_threshold
;
3887 h
->rehash_size
= rehash_size
;
3889 h
->key_and_value
= Fmake_vector (make_number (2 * size
), Qnil
);
3890 h
->hash
= Fmake_vector (make_number (size
), Qnil
);
3891 h
->next
= Fmake_vector (make_number (size
), make_number (-1));
3892 h
->index
= Fmake_vector (make_number (index_size
), make_number (-1));
3895 /* Set up the free list. */
3896 for (i
= 0; i
< size
- 1; ++i
)
3897 set_hash_next_slot (h
, i
, i
+ 1);
3900 XSET_HASH_TABLE (table
, h
);
3901 eassert (HASH_TABLE_P (table
));
3902 eassert (XHASH_TABLE (table
) == h
);
3904 /* Maybe add this hash table to the list of all weak hash tables. */
3907 h
->next_weak
= weak_hash_tables
;
3908 weak_hash_tables
= h
;
3915 /* Return a copy of hash table H1. Keys and values are not copied,
3916 only the table itself is. */
3919 copy_hash_table (struct Lisp_Hash_Table
*h1
)
3922 struct Lisp_Hash_Table
*h2
;
3924 h2
= allocate_hash_table ();
3926 h2
->key_and_value
= Fcopy_sequence (h1
->key_and_value
);
3927 h2
->hash
= Fcopy_sequence (h1
->hash
);
3928 h2
->next
= Fcopy_sequence (h1
->next
);
3929 h2
->index
= Fcopy_sequence (h1
->index
);
3930 XSET_HASH_TABLE (table
, h2
);
3932 /* Maybe add this hash table to the list of all weak hash tables. */
3933 if (!NILP (h2
->weak
))
3935 h2
->next_weak
= h1
->next_weak
;
3943 /* Resize hash table H if it's too full. If H cannot be resized
3944 because it's already too large, throw an error. */
3947 maybe_resize_hash_table (struct Lisp_Hash_Table
*h
)
3949 if (h
->next_free
< 0)
3951 ptrdiff_t old_size
= HASH_TABLE_SIZE (h
);
3952 EMACS_INT new_size
, index_size
, nsize
;
3954 double rehash_size
= h
->rehash_size
;
3957 if (rehash_size
< 0)
3958 new_size
= old_size
- rehash_size
;
3961 double float_new_size
= old_size
* (rehash_size
+ 1);
3962 if (float_new_size
< INDEX_SIZE_BOUND
+ 1)
3963 new_size
= float_new_size
;
3965 new_size
= INDEX_SIZE_BOUND
+ 1;
3967 if (new_size
<= old_size
)
3968 new_size
= old_size
+ 1;
3969 double threshold
= h
->rehash_threshold
;
3970 index_float
= new_size
/ threshold
;
3971 index_size
= (index_float
< INDEX_SIZE_BOUND
+ 1
3972 ? next_almost_prime (index_float
)
3973 : INDEX_SIZE_BOUND
+ 1);
3974 nsize
= max (index_size
, 2 * new_size
);
3975 if (INDEX_SIZE_BOUND
< nsize
)
3976 error ("Hash table too large to resize");
3978 #ifdef ENABLE_CHECKING
3979 if (HASH_TABLE_P (Vpurify_flag
)
3980 && XHASH_TABLE (Vpurify_flag
) == h
)
3981 message ("Growing hash table to: %"pI
"d", new_size
);
3984 set_hash_key_and_value (h
, larger_vector (h
->key_and_value
,
3985 2 * (new_size
- old_size
), -1));
3986 set_hash_hash (h
, larger_vector (h
->hash
, new_size
- old_size
, -1));
3987 set_hash_index (h
, Fmake_vector (make_number (index_size
),
3989 set_hash_next (h
, larger_vecalloc (h
->next
, new_size
- old_size
, -1));
3991 /* Update the free list. Do it so that new entries are added at
3992 the end of the free list. This makes some operations like
3994 for (i
= old_size
; i
< new_size
- 1; ++i
)
3995 set_hash_next_slot (h
, i
, i
+ 1);
3996 set_hash_next_slot (h
, i
, -1);
3998 if (h
->next_free
< 0)
3999 h
->next_free
= old_size
;
4002 ptrdiff_t last
= h
->next_free
;
4005 ptrdiff_t next
= HASH_NEXT (h
, last
);
4010 set_hash_next_slot (h
, last
, old_size
);
4014 for (i
= 0; i
< old_size
; ++i
)
4015 if (!NILP (HASH_HASH (h
, i
)))
4017 EMACS_UINT hash_code
= XUINT (HASH_HASH (h
, i
));
4018 ptrdiff_t start_of_bucket
= hash_code
% ASIZE (h
->index
);
4019 set_hash_next_slot (h
, i
, HASH_INDEX (h
, start_of_bucket
));
4020 set_hash_index_slot (h
, start_of_bucket
, i
);
4026 /* Lookup KEY in hash table H. If HASH is non-null, return in *HASH
4027 the hash code of KEY. Value is the index of the entry in H
4028 matching KEY, or -1 if not found. */
4031 hash_lookup (struct Lisp_Hash_Table
*h
, Lisp_Object key
, EMACS_UINT
*hash
)
4033 EMACS_UINT hash_code
;
4034 ptrdiff_t start_of_bucket
, i
;
4036 hash_code
= h
->test
.hashfn (&h
->test
, key
);
4037 eassert ((hash_code
& ~INTMASK
) == 0);
4041 start_of_bucket
= hash_code
% ASIZE (h
->index
);
4043 for (i
= HASH_INDEX (h
, start_of_bucket
); 0 <= i
; i
= HASH_NEXT (h
, i
))
4044 if (EQ (key
, HASH_KEY (h
, i
))
4046 && hash_code
== XUINT (HASH_HASH (h
, i
))
4047 && h
->test
.cmpfn (&h
->test
, key
, HASH_KEY (h
, i
))))
4054 /* Put an entry into hash table H that associates KEY with VALUE.
4055 HASH is a previously computed hash code of KEY.
4056 Value is the index of the entry in H matching KEY. */
4059 hash_put (struct Lisp_Hash_Table
*h
, Lisp_Object key
, Lisp_Object value
,
4062 ptrdiff_t start_of_bucket
, i
;
4064 eassert ((hash
& ~INTMASK
) == 0);
4066 /* Increment count after resizing because resizing may fail. */
4067 maybe_resize_hash_table (h
);
4070 /* Store key/value in the key_and_value vector. */
4072 h
->next_free
= HASH_NEXT (h
, i
);
4073 set_hash_key_slot (h
, i
, key
);
4074 set_hash_value_slot (h
, i
, value
);
4076 /* Remember its hash code. */
4077 set_hash_hash_slot (h
, i
, make_number (hash
));
4079 /* Add new entry to its collision chain. */
4080 start_of_bucket
= hash
% ASIZE (h
->index
);
4081 set_hash_next_slot (h
, i
, HASH_INDEX (h
, start_of_bucket
));
4082 set_hash_index_slot (h
, start_of_bucket
, i
);
4087 /* Remove the entry matching KEY from hash table H, if there is one. */
4090 hash_remove_from_table (struct Lisp_Hash_Table
*h
, Lisp_Object key
)
4092 EMACS_UINT hash_code
= h
->test
.hashfn (&h
->test
, key
);
4093 eassert ((hash_code
& ~INTMASK
) == 0);
4094 ptrdiff_t start_of_bucket
= hash_code
% ASIZE (h
->index
);
4095 ptrdiff_t prev
= -1;
4097 for (ptrdiff_t i
= HASH_INDEX (h
, start_of_bucket
);
4099 i
= HASH_NEXT (h
, i
))
4101 if (EQ (key
, HASH_KEY (h
, i
))
4103 && hash_code
== XUINT (HASH_HASH (h
, i
))
4104 && h
->test
.cmpfn (&h
->test
, key
, HASH_KEY (h
, i
))))
4106 /* Take entry out of collision chain. */
4108 set_hash_index_slot (h
, start_of_bucket
, HASH_NEXT (h
, i
));
4110 set_hash_next_slot (h
, prev
, HASH_NEXT (h
, i
));
4112 /* Clear slots in key_and_value and add the slots to
4114 set_hash_key_slot (h
, i
, Qnil
);
4115 set_hash_value_slot (h
, i
, Qnil
);
4116 set_hash_hash_slot (h
, i
, Qnil
);
4117 set_hash_next_slot (h
, i
, h
->next_free
);
4120 eassert (h
->count
>= 0);
4129 /* Clear hash table H. */
4132 hash_clear (struct Lisp_Hash_Table
*h
)
4136 ptrdiff_t i
, size
= HASH_TABLE_SIZE (h
);
4138 for (i
= 0; i
< size
; ++i
)
4140 set_hash_next_slot (h
, i
, i
< size
- 1 ? i
+ 1 : -1);
4141 set_hash_key_slot (h
, i
, Qnil
);
4142 set_hash_value_slot (h
, i
, Qnil
);
4143 set_hash_hash_slot (h
, i
, Qnil
);
4146 for (i
= 0; i
< ASIZE (h
->index
); ++i
)
4147 ASET (h
->index
, i
, make_number (-1));
4156 /************************************************************************
4158 ************************************************************************/
4160 /* Sweep weak hash table H. REMOVE_ENTRIES_P means remove
4161 entries from the table that don't survive the current GC.
4162 !REMOVE_ENTRIES_P means mark entries that are in use. Value is
4163 true if anything was marked. */
4166 sweep_weak_table (struct Lisp_Hash_Table
*h
, bool remove_entries_p
)
4168 ptrdiff_t n
= gc_asize (h
->index
);
4169 bool marked
= false;
4171 for (ptrdiff_t bucket
= 0; bucket
< n
; ++bucket
)
4173 /* Follow collision chain, removing entries that
4174 don't survive this garbage collection. */
4175 ptrdiff_t prev
= -1;
4177 for (ptrdiff_t i
= HASH_INDEX (h
, bucket
); 0 <= i
; i
= next
)
4179 bool key_known_to_survive_p
= survives_gc_p (HASH_KEY (h
, i
));
4180 bool value_known_to_survive_p
= survives_gc_p (HASH_VALUE (h
, i
));
4183 if (EQ (h
->weak
, Qkey
))
4184 remove_p
= !key_known_to_survive_p
;
4185 else if (EQ (h
->weak
, Qvalue
))
4186 remove_p
= !value_known_to_survive_p
;
4187 else if (EQ (h
->weak
, Qkey_or_value
))
4188 remove_p
= !(key_known_to_survive_p
|| value_known_to_survive_p
);
4189 else if (EQ (h
->weak
, Qkey_and_value
))
4190 remove_p
= !(key_known_to_survive_p
&& value_known_to_survive_p
);
4194 next
= HASH_NEXT (h
, i
);
4196 if (remove_entries_p
)
4200 /* Take out of collision chain. */
4202 set_hash_index_slot (h
, bucket
, next
);
4204 set_hash_next_slot (h
, prev
, next
);
4206 /* Add to free list. */
4207 set_hash_next_slot (h
, i
, h
->next_free
);
4210 /* Clear key, value, and hash. */
4211 set_hash_key_slot (h
, i
, Qnil
);
4212 set_hash_value_slot (h
, i
, Qnil
);
4213 set_hash_hash_slot (h
, i
, Qnil
);
4226 /* Make sure key and value survive. */
4227 if (!key_known_to_survive_p
)
4229 mark_object (HASH_KEY (h
, i
));
4233 if (!value_known_to_survive_p
)
4235 mark_object (HASH_VALUE (h
, i
));
4246 /* Remove elements from weak hash tables that don't survive the
4247 current garbage collection. Remove weak tables that don't survive
4248 from Vweak_hash_tables. Called from gc_sweep. */
4250 NO_INLINE
/* For better stack traces */
4252 sweep_weak_hash_tables (void)
4254 struct Lisp_Hash_Table
*h
, *used
, *next
;
4257 /* Mark all keys and values that are in use. Keep on marking until
4258 there is no more change. This is necessary for cases like
4259 value-weak table A containing an entry X -> Y, where Y is used in a
4260 key-weak table B, Z -> Y. If B comes after A in the list of weak
4261 tables, X -> Y might be removed from A, although when looking at B
4262 one finds that it shouldn't. */
4266 for (h
= weak_hash_tables
; h
; h
= h
->next_weak
)
4268 if (h
->header
.size
& ARRAY_MARK_FLAG
)
4269 marked
|= sweep_weak_table (h
, 0);
4274 /* Remove tables and entries that aren't used. */
4275 for (h
= weak_hash_tables
, used
= NULL
; h
; h
= next
)
4277 next
= h
->next_weak
;
4279 if (h
->header
.size
& ARRAY_MARK_FLAG
)
4281 /* TABLE is marked as used. Sweep its contents. */
4283 sweep_weak_table (h
, 1);
4285 /* Add table to the list of used weak hash tables. */
4286 h
->next_weak
= used
;
4291 weak_hash_tables
= used
;
4296 /***********************************************************************
4297 Hash Code Computation
4298 ***********************************************************************/
4300 /* Maximum depth up to which to dive into Lisp structures. */
4302 #define SXHASH_MAX_DEPTH 3
4304 /* Maximum length up to which to take list and vector elements into
4307 #define SXHASH_MAX_LEN 7
4309 /* Return a hash for string PTR which has length LEN. The hash value
4310 can be any EMACS_UINT value. */
4313 hash_string (char const *ptr
, ptrdiff_t len
)
4315 char const *p
= ptr
;
4316 char const *end
= p
+ len
;
4318 EMACS_UINT hash
= 0;
4323 hash
= sxhash_combine (hash
, c
);
4329 /* Return a hash for string PTR which has length LEN. The hash
4330 code returned is guaranteed to fit in a Lisp integer. */
4333 sxhash_string (char const *ptr
, ptrdiff_t len
)
4335 EMACS_UINT hash
= hash_string (ptr
, len
);
4336 return SXHASH_REDUCE (hash
);
4339 /* Return a hash for the floating point value VAL. */
4342 sxhash_float (double val
)
4344 EMACS_UINT hash
= 0;
4345 union double_and_words u
= { .val
= val
};
4346 for (int i
= 0; i
< WORDS_PER_DOUBLE
; i
++)
4347 hash
= sxhash_combine (hash
, u
.word
[i
]);
4348 return SXHASH_REDUCE (hash
);
4351 /* Return a hash for list LIST. DEPTH is the current depth in the
4352 list. We don't recurse deeper than SXHASH_MAX_DEPTH in it. */
4355 sxhash_list (Lisp_Object list
, int depth
)
4357 EMACS_UINT hash
= 0;
4360 if (depth
< SXHASH_MAX_DEPTH
)
4362 CONSP (list
) && i
< SXHASH_MAX_LEN
;
4363 list
= XCDR (list
), ++i
)
4365 EMACS_UINT hash2
= sxhash (XCAR (list
), depth
+ 1);
4366 hash
= sxhash_combine (hash
, hash2
);
4371 EMACS_UINT hash2
= sxhash (list
, depth
+ 1);
4372 hash
= sxhash_combine (hash
, hash2
);
4375 return SXHASH_REDUCE (hash
);
4379 /* Return a hash for (pseudo)vector VECTOR. DEPTH is the current depth in
4380 the Lisp structure. */
4383 sxhash_vector (Lisp_Object vec
, int depth
)
4385 EMACS_UINT hash
= ASIZE (vec
);
4388 n
= min (SXHASH_MAX_LEN
, hash
& PSEUDOVECTOR_FLAG
? PVSIZE (vec
) : hash
);
4389 for (i
= 0; i
< n
; ++i
)
4391 EMACS_UINT hash2
= sxhash (AREF (vec
, i
), depth
+ 1);
4392 hash
= sxhash_combine (hash
, hash2
);
4395 return SXHASH_REDUCE (hash
);
4398 /* Return a hash for bool-vector VECTOR. */
4401 sxhash_bool_vector (Lisp_Object vec
)
4403 EMACS_INT size
= bool_vector_size (vec
);
4404 EMACS_UINT hash
= size
;
4407 n
= min (SXHASH_MAX_LEN
, bool_vector_words (size
));
4408 for (i
= 0; i
< n
; ++i
)
4409 hash
= sxhash_combine (hash
, bool_vector_data (vec
)[i
]);
4411 return SXHASH_REDUCE (hash
);
4415 /* Return a hash code for OBJ. DEPTH is the current depth in the Lisp
4416 structure. Value is an unsigned integer clipped to INTMASK. */
4419 sxhash (Lisp_Object obj
, int depth
)
4423 if (depth
> SXHASH_MAX_DEPTH
)
4426 switch (XTYPE (obj
))
4438 hash
= sxhash_string (SSDATA (obj
), SBYTES (obj
));
4441 /* This can be everything from a vector to an overlay. */
4442 case Lisp_Vectorlike
:
4443 if (VECTORP (obj
) || RECORDP (obj
))
4444 /* According to the CL HyperSpec, two arrays are equal only if
4445 they are `eq', except for strings and bit-vectors. In
4446 Emacs, this works differently. We have to compare element
4447 by element. Same for records. */
4448 hash
= sxhash_vector (obj
, depth
);
4449 else if (BOOL_VECTOR_P (obj
))
4450 hash
= sxhash_bool_vector (obj
);
4452 /* Others are `equal' if they are `eq', so let's take their
4458 hash
= sxhash_list (obj
, depth
);
4462 hash
= sxhash_float (XFLOAT_DATA (obj
));
4474 /***********************************************************************
4476 ***********************************************************************/
4478 DEFUN ("sxhash-eq", Fsxhash_eq
, Ssxhash_eq
, 1, 1, 0,
4479 doc
: /* Return an integer hash code for OBJ suitable for `eq'.
4480 If (eq A B), then (= (sxhash-eq A) (sxhash-eq B)). */)
4483 return make_number (hashfn_eq (NULL
, obj
));
4486 DEFUN ("sxhash-eql", Fsxhash_eql
, Ssxhash_eql
, 1, 1, 0,
4487 doc
: /* Return an integer hash code for OBJ suitable for `eql'.
4488 If (eql A B), then (= (sxhash-eql A) (sxhash-eql B)). */)
4491 return make_number (hashfn_eql (NULL
, obj
));
4494 DEFUN ("sxhash-equal", Fsxhash_equal
, Ssxhash_equal
, 1, 1, 0,
4495 doc
: /* Return an integer hash code for OBJ suitable for `equal'.
4496 If (equal A B), then (= (sxhash-equal A) (sxhash-equal B)). */)
4499 return make_number (hashfn_equal (NULL
, obj
));
4502 DEFUN ("make-hash-table", Fmake_hash_table
, Smake_hash_table
, 0, MANY
, 0,
4503 doc
: /* Create and return a new hash table.
4505 Arguments are specified as keyword/argument pairs. The following
4506 arguments are defined:
4508 :test TEST -- TEST must be a symbol that specifies how to compare
4509 keys. Default is `eql'. Predefined are the tests `eq', `eql', and
4510 `equal'. User-supplied test and hash functions can be specified via
4511 `define-hash-table-test'.
4513 :size SIZE -- A hint as to how many elements will be put in the table.
4516 :rehash-size REHASH-SIZE - Indicates how to expand the table when it
4517 fills up. If REHASH-SIZE is an integer, increase the size by that
4518 amount. If it is a float, it must be > 1.0, and the new size is the
4519 old size multiplied by that factor. Default is 1.5.
4521 :rehash-threshold THRESHOLD -- THRESHOLD must a float > 0, and <= 1.0.
4522 Resize the hash table when the ratio (table entries / table size)
4523 exceeds an approximation to THRESHOLD. Default is 0.8125.
4525 :weakness WEAK -- WEAK must be one of nil, t, `key', `value',
4526 `key-or-value', or `key-and-value'. If WEAK is not nil, the table
4527 returned is a weak table. Key/value pairs are removed from a weak
4528 hash table when there are no non-weak references pointing to their
4529 key, value, one of key or value, or both key and value, depending on
4530 WEAK. WEAK t is equivalent to `key-and-value'. Default value of WEAK
4533 :purecopy PURECOPY -- If PURECOPY is non-nil, the table can be copied
4534 to pure storage when Emacs is being dumped, making the contents of the
4535 table read only. Any further changes to purified tables will result
4538 usage: (make-hash-table &rest KEYWORD-ARGS) */)
4539 (ptrdiff_t nargs
, Lisp_Object
*args
)
4541 Lisp_Object test
, weak
;
4543 struct hash_table_test testdesc
;
4547 /* The vector `used' is used to keep track of arguments that
4548 have been consumed. */
4549 char *used
= SAFE_ALLOCA (nargs
* sizeof *used
);
4550 memset (used
, 0, nargs
* sizeof *used
);
4552 /* See if there's a `:test TEST' among the arguments. */
4553 i
= get_key_arg (QCtest
, nargs
, args
, used
);
4554 test
= i
? args
[i
] : Qeql
;
4556 testdesc
= hashtest_eq
;
4557 else if (EQ (test
, Qeql
))
4558 testdesc
= hashtest_eql
;
4559 else if (EQ (test
, Qequal
))
4560 testdesc
= hashtest_equal
;
4563 /* See if it is a user-defined test. */
4566 prop
= Fget (test
, Qhash_table_test
);
4567 if (!CONSP (prop
) || !CONSP (XCDR (prop
)))
4568 signal_error ("Invalid hash table test", test
);
4569 testdesc
.name
= test
;
4570 testdesc
.user_cmp_function
= XCAR (prop
);
4571 testdesc
.user_hash_function
= XCAR (XCDR (prop
));
4572 testdesc
.hashfn
= hashfn_user_defined
;
4573 testdesc
.cmpfn
= cmpfn_user_defined
;
4576 /* See if there's a `:purecopy PURECOPY' argument. */
4577 i
= get_key_arg (QCpurecopy
, nargs
, args
, used
);
4578 pure
= i
&& !NILP (args
[i
]);
4579 /* See if there's a `:size SIZE' argument. */
4580 i
= get_key_arg (QCsize
, nargs
, args
, used
);
4581 Lisp_Object size_arg
= i
? args
[i
] : Qnil
;
4583 if (NILP (size_arg
))
4584 size
= DEFAULT_HASH_SIZE
;
4585 else if (NATNUMP (size_arg
))
4586 size
= XFASTINT (size_arg
);
4588 signal_error ("Invalid hash table size", size_arg
);
4590 /* Look for `:rehash-size SIZE'. */
4592 i
= get_key_arg (QCrehash_size
, nargs
, args
, used
);
4594 rehash_size
= DEFAULT_REHASH_SIZE
;
4595 else if (INTEGERP (args
[i
]) && 0 < XINT (args
[i
]))
4596 rehash_size
= - XINT (args
[i
]);
4597 else if (FLOATP (args
[i
]) && 0 < (float) (XFLOAT_DATA (args
[i
]) - 1))
4598 rehash_size
= (float) (XFLOAT_DATA (args
[i
]) - 1);
4600 signal_error ("Invalid hash table rehash size", args
[i
]);
4602 /* Look for `:rehash-threshold THRESHOLD'. */
4603 i
= get_key_arg (QCrehash_threshold
, nargs
, args
, used
);
4604 float rehash_threshold
= (!i
? DEFAULT_REHASH_THRESHOLD
4605 : !FLOATP (args
[i
]) ? 0
4606 : (float) XFLOAT_DATA (args
[i
]));
4607 if (! (0 < rehash_threshold
&& rehash_threshold
<= 1))
4608 signal_error ("Invalid hash table rehash threshold", args
[i
]);
4610 /* Look for `:weakness WEAK'. */
4611 i
= get_key_arg (QCweakness
, nargs
, args
, used
);
4612 weak
= i
? args
[i
] : Qnil
;
4614 weak
= Qkey_and_value
;
4617 && !EQ (weak
, Qvalue
)
4618 && !EQ (weak
, Qkey_or_value
)
4619 && !EQ (weak
, Qkey_and_value
))
4620 signal_error ("Invalid hash table weakness", weak
);
4622 /* Now, all args should have been used up, or there's a problem. */
4623 for (i
= 0; i
< nargs
; ++i
)
4625 signal_error ("Invalid argument list", args
[i
]);
4628 return make_hash_table (testdesc
, size
, rehash_size
, rehash_threshold
, weak
,
4633 DEFUN ("copy-hash-table", Fcopy_hash_table
, Scopy_hash_table
, 1, 1, 0,
4634 doc
: /* Return a copy of hash table TABLE. */)
4637 return copy_hash_table (check_hash_table (table
));
4641 DEFUN ("hash-table-count", Fhash_table_count
, Shash_table_count
, 1, 1, 0,
4642 doc
: /* Return the number of elements in TABLE. */)
4645 return make_number (check_hash_table (table
)->count
);
4649 DEFUN ("hash-table-rehash-size", Fhash_table_rehash_size
,
4650 Shash_table_rehash_size
, 1, 1, 0,
4651 doc
: /* Return the current rehash size of TABLE. */)
4654 double rehash_size
= check_hash_table (table
)->rehash_size
;
4655 if (rehash_size
< 0)
4657 EMACS_INT s
= -rehash_size
;
4658 return make_number (min (s
, MOST_POSITIVE_FIXNUM
));
4661 return make_float (rehash_size
+ 1);
4665 DEFUN ("hash-table-rehash-threshold", Fhash_table_rehash_threshold
,
4666 Shash_table_rehash_threshold
, 1, 1, 0,
4667 doc
: /* Return the current rehash threshold of TABLE. */)
4670 return make_float (check_hash_table (table
)->rehash_threshold
);
4674 DEFUN ("hash-table-size", Fhash_table_size
, Shash_table_size
, 1, 1, 0,
4675 doc
: /* Return the size of TABLE.
4676 The size can be used as an argument to `make-hash-table' to create
4677 a hash table than can hold as many elements as TABLE holds
4678 without need for resizing. */)
4681 struct Lisp_Hash_Table
*h
= check_hash_table (table
);
4682 return make_number (HASH_TABLE_SIZE (h
));
4686 DEFUN ("hash-table-test", Fhash_table_test
, Shash_table_test
, 1, 1, 0,
4687 doc
: /* Return the test TABLE uses. */)
4690 return check_hash_table (table
)->test
.name
;
4694 DEFUN ("hash-table-weakness", Fhash_table_weakness
, Shash_table_weakness
,
4696 doc
: /* Return the weakness of TABLE. */)
4699 return check_hash_table (table
)->weak
;
4703 DEFUN ("hash-table-p", Fhash_table_p
, Shash_table_p
, 1, 1, 0,
4704 doc
: /* Return t if OBJ is a Lisp hash table object. */)
4707 return HASH_TABLE_P (obj
) ? Qt
: Qnil
;
4711 DEFUN ("clrhash", Fclrhash
, Sclrhash
, 1, 1, 0,
4712 doc
: /* Clear hash table TABLE and return it. */)
4715 struct Lisp_Hash_Table
*h
= check_hash_table (table
);
4716 CHECK_IMPURE (table
, h
);
4718 /* Be compatible with XEmacs. */
4723 DEFUN ("gethash", Fgethash
, Sgethash
, 2, 3, 0,
4724 doc
: /* Look up KEY in TABLE and return its associated value.
4725 If KEY is not found, return DFLT which defaults to nil. */)
4726 (Lisp_Object key
, Lisp_Object table
, Lisp_Object dflt
)
4728 struct Lisp_Hash_Table
*h
= check_hash_table (table
);
4729 ptrdiff_t i
= hash_lookup (h
, key
, NULL
);
4730 return i
>= 0 ? HASH_VALUE (h
, i
) : dflt
;
4734 DEFUN ("puthash", Fputhash
, Sputhash
, 3, 3, 0,
4735 doc
: /* Associate KEY with VALUE in hash table TABLE.
4736 If KEY is already present in table, replace its current value with
4737 VALUE. In any case, return VALUE. */)
4738 (Lisp_Object key
, Lisp_Object value
, Lisp_Object table
)
4740 struct Lisp_Hash_Table
*h
= check_hash_table (table
);
4741 CHECK_IMPURE (table
, h
);
4745 i
= hash_lookup (h
, key
, &hash
);
4747 set_hash_value_slot (h
, i
, value
);
4749 hash_put (h
, key
, value
, hash
);
4755 DEFUN ("remhash", Fremhash
, Sremhash
, 2, 2, 0,
4756 doc
: /* Remove KEY from TABLE. */)
4757 (Lisp_Object key
, Lisp_Object table
)
4759 struct Lisp_Hash_Table
*h
= check_hash_table (table
);
4760 CHECK_IMPURE (table
, h
);
4761 hash_remove_from_table (h
, key
);
4766 DEFUN ("maphash", Fmaphash
, Smaphash
, 2, 2, 0,
4767 doc
: /* Call FUNCTION for all entries in hash table TABLE.
4768 FUNCTION is called with two arguments, KEY and VALUE.
4769 `maphash' always returns nil. */)
4770 (Lisp_Object function
, Lisp_Object table
)
4772 struct Lisp_Hash_Table
*h
= check_hash_table (table
);
4774 for (ptrdiff_t i
= 0; i
< HASH_TABLE_SIZE (h
); ++i
)
4775 if (!NILP (HASH_HASH (h
, i
)))
4776 call2 (function
, HASH_KEY (h
, i
), HASH_VALUE (h
, i
));
4782 DEFUN ("define-hash-table-test", Fdefine_hash_table_test
,
4783 Sdefine_hash_table_test
, 3, 3, 0,
4784 doc
: /* Define a new hash table test with name NAME, a symbol.
4786 In hash tables created with NAME specified as test, use TEST to
4787 compare keys, and HASH for computing hash codes of keys.
4789 TEST must be a function taking two arguments and returning non-nil if
4790 both arguments are the same. HASH must be a function taking one
4791 argument and returning an object that is the hash code of the argument.
4792 It should be the case that if (eq (funcall HASH x1) (funcall HASH x2))
4793 returns nil, then (funcall TEST x1 x2) also returns nil. */)
4794 (Lisp_Object name
, Lisp_Object test
, Lisp_Object hash
)
4796 return Fput (name
, Qhash_table_test
, list2 (test
, hash
));
4801 /************************************************************************
4802 MD5, SHA-1, and SHA-2
4803 ************************************************************************/
4811 make_digest_string (Lisp_Object digest
, int digest_size
)
4813 unsigned char *p
= SDATA (digest
);
4815 for (int i
= digest_size
- 1; i
>= 0; i
--)
4817 static char const hexdigit
[16] = "0123456789abcdef";
4819 p
[2 * i
] = hexdigit
[p_i
>> 4];
4820 p
[2 * i
+ 1] = hexdigit
[p_i
& 0xf];
4825 DEFUN ("secure-hash-algorithms", Fsecure_hash_algorithms
,
4826 Ssecure_hash_algorithms
, 0, 0, 0,
4827 doc
: /* Return a list of all the supported `secure_hash' algorithms. */)
4830 return listn (CONSTYPE_HEAP
, 6,
4839 /* Extract data from a string or a buffer. SPEC is a list of
4840 (BUFFER-OR-STRING-OR-SYMBOL START END CODING-SYSTEM NOERROR) which behave as
4841 specified with `secure-hash' and in Info node
4842 `(elisp)Format of GnuTLS Cryptography Inputs'. */
4844 extract_data_from_object (Lisp_Object spec
,
4845 ptrdiff_t *start_byte
,
4846 ptrdiff_t *end_byte
)
4848 Lisp_Object object
= XCAR (spec
);
4850 if (CONSP (spec
)) spec
= XCDR (spec
);
4851 Lisp_Object start
= CAR_SAFE (spec
);
4853 if (CONSP (spec
)) spec
= XCDR (spec
);
4854 Lisp_Object end
= CAR_SAFE (spec
);
4856 if (CONSP (spec
)) spec
= XCDR (spec
);
4857 Lisp_Object coding_system
= CAR_SAFE (spec
);
4859 if (CONSP (spec
)) spec
= XCDR (spec
);
4860 Lisp_Object noerror
= CAR_SAFE (spec
);
4862 if (STRINGP (object
))
4864 if (NILP (coding_system
))
4866 /* Decide the coding-system to encode the data with. */
4868 if (STRING_MULTIBYTE (object
))
4869 /* use default, we can't guess correct value */
4870 coding_system
= preferred_coding_system ();
4872 coding_system
= Qraw_text
;
4875 if (NILP (Fcoding_system_p (coding_system
)))
4877 /* Invalid coding system. */
4879 if (!NILP (noerror
))
4880 coding_system
= Qraw_text
;
4882 xsignal1 (Qcoding_system_error
, coding_system
);
4885 if (STRING_MULTIBYTE (object
))
4886 object
= code_convert_string (object
, coding_system
, Qnil
, 1, 0, 1);
4888 ptrdiff_t size
= SCHARS (object
), start_char
, end_char
;
4889 validate_subarray (object
, start
, end
, size
, &start_char
, &end_char
);
4891 *start_byte
= !start_char
? 0 : string_char_to_byte (object
, start_char
);
4892 *end_byte
= (end_char
== size
4894 : string_char_to_byte (object
, end_char
));
4896 else if (BUFFERP (object
))
4898 struct buffer
*prev
= current_buffer
;
4901 record_unwind_current_buffer ();
4903 struct buffer
*bp
= XBUFFER (object
);
4904 set_buffer_internal (bp
);
4910 CHECK_NUMBER_COERCE_MARKER (start
);
4918 CHECK_NUMBER_COERCE_MARKER (end
);
4929 if (!(BEGV
<= b
&& e
<= ZV
))
4930 args_out_of_range (start
, end
);
4932 if (NILP (coding_system
))
4934 /* Decide the coding-system to encode the data with.
4935 See fileio.c:Fwrite-region */
4937 if (!NILP (Vcoding_system_for_write
))
4938 coding_system
= Vcoding_system_for_write
;
4941 bool force_raw_text
= 0;
4943 coding_system
= BVAR (XBUFFER (object
), buffer_file_coding_system
);
4944 if (NILP (coding_system
)
4945 || NILP (Flocal_variable_p (Qbuffer_file_coding_system
, Qnil
)))
4947 coding_system
= Qnil
;
4948 if (NILP (BVAR (current_buffer
, enable_multibyte_characters
)))
4952 if (NILP (coding_system
) && !NILP (Fbuffer_file_name (object
)))
4954 /* Check file-coding-system-alist. */
4955 Lisp_Object val
= CALLN (Ffind_operation_coding_system
,
4956 Qwrite_region
, start
, end
,
4957 Fbuffer_file_name (object
));
4958 if (CONSP (val
) && !NILP (XCDR (val
)))
4959 coding_system
= XCDR (val
);
4962 if (NILP (coding_system
)
4963 && !NILP (BVAR (XBUFFER (object
), buffer_file_coding_system
)))
4965 /* If we still have not decided a coding system, use the
4966 default value of buffer-file-coding-system. */
4967 coding_system
= BVAR (XBUFFER (object
), buffer_file_coding_system
);
4971 && !NILP (Ffboundp (Vselect_safe_coding_system_function
)))
4972 /* Confirm that VAL can surely encode the current region. */
4973 coding_system
= call4 (Vselect_safe_coding_system_function
,
4974 make_number (b
), make_number (e
),
4975 coding_system
, Qnil
);
4978 coding_system
= Qraw_text
;
4981 if (NILP (Fcoding_system_p (coding_system
)))
4983 /* Invalid coding system. */
4985 if (!NILP (noerror
))
4986 coding_system
= Qraw_text
;
4988 xsignal1 (Qcoding_system_error
, coding_system
);
4992 object
= make_buffer_string (b
, e
, 0);
4993 set_buffer_internal (prev
);
4994 /* Discard the unwind protect for recovering the current
4998 if (STRING_MULTIBYTE (object
))
4999 object
= code_convert_string (object
, coding_system
, Qnil
, 1, 0, 0);
5001 *end_byte
= SBYTES (object
);
5003 else if (EQ (object
, Qiv_auto
))
5006 /* Format: (iv-auto REQUIRED-LENGTH). */
5008 if (! NATNUMP (start
))
5009 error ("Without a length, `iv-auto' can't be used; see ELisp manual");
5012 EMACS_INT start_hold
= XFASTINT (start
);
5013 object
= make_uninit_string (start_hold
);
5014 gnutls_rnd (GNUTLS_RND_NONCE
, SSDATA (object
), start_hold
);
5017 *end_byte
= start_hold
;
5020 error ("GnuTLS is not available, so `iv-auto' can't be used");
5024 if (!STRINGP (object
))
5025 signal_error ("Invalid object argument",
5026 NILP (object
) ? build_string ("nil") : object
);
5027 return SSDATA (object
);
5031 /* ALGORITHM is a symbol: md5, sha1, sha224 and so on. */
5034 secure_hash (Lisp_Object algorithm
, Lisp_Object object
, Lisp_Object start
,
5035 Lisp_Object end
, Lisp_Object coding_system
, Lisp_Object noerror
,
5038 ptrdiff_t start_byte
, end_byte
;
5040 void *(*hash_func
) (const char *, size_t, void *);
5043 CHECK_SYMBOL (algorithm
);
5045 Lisp_Object spec
= list5 (object
, start
, end
, coding_system
, noerror
);
5047 const char *input
= extract_data_from_object (spec
, &start_byte
, &end_byte
);
5050 error ("secure_hash: failed to extract data from object, aborting!");
5052 if (EQ (algorithm
, Qmd5
))
5054 digest_size
= MD5_DIGEST_SIZE
;
5055 hash_func
= md5_buffer
;
5057 else if (EQ (algorithm
, Qsha1
))
5059 digest_size
= SHA1_DIGEST_SIZE
;
5060 hash_func
= sha1_buffer
;
5062 else if (EQ (algorithm
, Qsha224
))
5064 digest_size
= SHA224_DIGEST_SIZE
;
5065 hash_func
= sha224_buffer
;
5067 else if (EQ (algorithm
, Qsha256
))
5069 digest_size
= SHA256_DIGEST_SIZE
;
5070 hash_func
= sha256_buffer
;
5072 else if (EQ (algorithm
, Qsha384
))
5074 digest_size
= SHA384_DIGEST_SIZE
;
5075 hash_func
= sha384_buffer
;
5077 else if (EQ (algorithm
, Qsha512
))
5079 digest_size
= SHA512_DIGEST_SIZE
;
5080 hash_func
= sha512_buffer
;
5083 error ("Invalid algorithm arg: %s", SDATA (Fsymbol_name (algorithm
)));
5085 /* allocate 2 x digest_size so that it can be re-used to hold the
5087 digest
= make_uninit_string (digest_size
* 2);
5089 hash_func (input
+ start_byte
,
5090 end_byte
- start_byte
,
5094 return make_digest_string (digest
, digest_size
);
5096 return make_unibyte_string (SSDATA (digest
), digest_size
);
5099 DEFUN ("md5", Fmd5
, Smd5
, 1, 5, 0,
5100 doc
: /* Return MD5 message digest of OBJECT, a buffer or string.
5102 A message digest is a cryptographic checksum of a document, and the
5103 algorithm to calculate it is defined in RFC 1321.
5105 The two optional arguments START and END are character positions
5106 specifying for which part of OBJECT the message digest should be
5107 computed. If nil or omitted, the digest is computed for the whole
5110 The MD5 message digest is computed from the result of encoding the
5111 text in a coding system, not directly from the internal Emacs form of
5112 the text. The optional fourth argument CODING-SYSTEM specifies which
5113 coding system to encode the text with. It should be the same coding
5114 system that you used or will use when actually writing the text into a
5117 If CODING-SYSTEM is nil or omitted, the default depends on OBJECT. If
5118 OBJECT is a buffer, the default for CODING-SYSTEM is whatever coding
5119 system would be chosen by default for writing this text into a file.
5121 If OBJECT is a string, the most preferred coding system (see the
5122 command `prefer-coding-system') is used.
5124 If NOERROR is non-nil, silently assume the `raw-text' coding if the
5125 guesswork fails. Normally, an error is signaled in such case. */)
5126 (Lisp_Object object
, Lisp_Object start
, Lisp_Object end
, Lisp_Object coding_system
, Lisp_Object noerror
)
5128 return secure_hash (Qmd5
, object
, start
, end
, coding_system
, noerror
, Qnil
);
5131 DEFUN ("secure-hash", Fsecure_hash
, Ssecure_hash
, 2, 5, 0,
5132 doc
: /* Return the secure hash of OBJECT, a buffer or string.
5133 ALGORITHM is a symbol specifying the hash to use:
5134 md5, sha1, sha224, sha256, sha384 or sha512.
5136 The two optional arguments START and END are positions specifying for
5137 which part of OBJECT to compute the hash. If nil or omitted, uses the
5140 The full list of algorithms can be obtained with `secure-hash-algorithms'.
5142 If BINARY is non-nil, returns a string in binary form. */)
5143 (Lisp_Object algorithm
, Lisp_Object object
, Lisp_Object start
, Lisp_Object end
, Lisp_Object binary
)
5145 return secure_hash (algorithm
, object
, start
, end
, Qnil
, Qnil
, binary
);
5148 DEFUN ("buffer-hash", Fbuffer_hash
, Sbuffer_hash
, 0, 1, 0,
5149 doc
: /* Return a hash of the contents of BUFFER-OR-NAME.
5150 This hash is performed on the raw internal format of the buffer,
5151 disregarding any coding systems. If nil, use the current buffer. */ )
5152 (Lisp_Object buffer_or_name
)
5156 struct sha1_ctx ctx
;
5158 if (NILP (buffer_or_name
))
5159 buffer
= Fcurrent_buffer ();
5161 buffer
= Fget_buffer (buffer_or_name
);
5163 nsberror (buffer_or_name
);
5165 b
= XBUFFER (buffer
);
5166 sha1_init_ctx (&ctx
);
5168 /* Process the first part of the buffer. */
5169 sha1_process_bytes (BUF_BEG_ADDR (b
),
5170 BUF_GPT_BYTE (b
) - BUF_BEG_BYTE (b
),
5173 /* If the gap is before the end of the buffer, process the last half
5175 if (BUF_GPT_BYTE (b
) < BUF_Z_BYTE (b
))
5176 sha1_process_bytes (BUF_GAP_END_ADDR (b
),
5177 BUF_Z_ADDR (b
) - BUF_GAP_END_ADDR (b
),
5180 Lisp_Object digest
= make_uninit_string (SHA1_DIGEST_SIZE
* 2);
5181 sha1_finish_ctx (&ctx
, SSDATA (digest
));
5182 return make_digest_string (digest
, SHA1_DIGEST_SIZE
);
5189 /* Hash table stuff. */
5190 DEFSYM (Qhash_table_p
, "hash-table-p");
5192 DEFSYM (Qeql
, "eql");
5193 DEFSYM (Qequal
, "equal");
5194 DEFSYM (QCtest
, ":test");
5195 DEFSYM (QCsize
, ":size");
5196 DEFSYM (QCpurecopy
, ":purecopy");
5197 DEFSYM (QCrehash_size
, ":rehash-size");
5198 DEFSYM (QCrehash_threshold
, ":rehash-threshold");
5199 DEFSYM (QCweakness
, ":weakness");
5200 DEFSYM (Qkey
, "key");
5201 DEFSYM (Qvalue
, "value");
5202 DEFSYM (Qhash_table_test
, "hash-table-test");
5203 DEFSYM (Qkey_or_value
, "key-or-value");
5204 DEFSYM (Qkey_and_value
, "key-and-value");
5206 defsubr (&Ssxhash_eq
);
5207 defsubr (&Ssxhash_eql
);
5208 defsubr (&Ssxhash_equal
);
5209 defsubr (&Smake_hash_table
);
5210 defsubr (&Scopy_hash_table
);
5211 defsubr (&Shash_table_count
);
5212 defsubr (&Shash_table_rehash_size
);
5213 defsubr (&Shash_table_rehash_threshold
);
5214 defsubr (&Shash_table_size
);
5215 defsubr (&Shash_table_test
);
5216 defsubr (&Shash_table_weakness
);
5217 defsubr (&Shash_table_p
);
5218 defsubr (&Sclrhash
);
5219 defsubr (&Sgethash
);
5220 defsubr (&Sputhash
);
5221 defsubr (&Sremhash
);
5222 defsubr (&Smaphash
);
5223 defsubr (&Sdefine_hash_table_test
);
5225 /* Crypto and hashing stuff. */
5226 DEFSYM (Qiv_auto
, "iv-auto");
5228 DEFSYM (Qmd5
, "md5");
5229 DEFSYM (Qsha1
, "sha1");
5230 DEFSYM (Qsha224
, "sha224");
5231 DEFSYM (Qsha256
, "sha256");
5232 DEFSYM (Qsha384
, "sha384");
5233 DEFSYM (Qsha512
, "sha512");
5235 /* Miscellaneous stuff. */
5237 DEFSYM (Qstring_lessp
, "string-lessp");
5238 DEFSYM (Qprovide
, "provide");
5239 DEFSYM (Qrequire
, "require");
5240 DEFSYM (Qyes_or_no_p_history
, "yes-or-no-p-history");
5241 DEFSYM (Qcursor_in_echo_area
, "cursor-in-echo-area");
5242 DEFSYM (Qwidget_type
, "widget-type");
5244 DEFVAR_LISP ("overriding-plist-environment", Voverriding_plist_environment
,
5245 doc
: /* An alist that overrides the plists of the symbols which it lists.
5246 Used by the byte-compiler to apply `define-symbol-prop' during
5248 Voverriding_plist_environment
= Qnil
;
5249 DEFSYM (Qoverriding_plist_environment
, "overriding-plist-environment");
5251 staticpro (&string_char_byte_cache_string
);
5252 string_char_byte_cache_string
= Qnil
;
5254 require_nesting_list
= Qnil
;
5255 staticpro (&require_nesting_list
);
5257 Fset (Qyes_or_no_p_history
, Qnil
);
5259 DEFVAR_LISP ("features", Vfeatures
,
5260 doc
: /* A list of symbols which are the features of the executing Emacs.
5261 Used by `featurep' and `require', and altered by `provide'. */);
5262 Vfeatures
= list1 (Qemacs
);
5263 DEFSYM (Qfeatures
, "features");
5264 /* Let people use lexically scoped vars named `features'. */
5265 Fmake_var_non_special (Qfeatures
);
5266 DEFSYM (Qsubfeatures
, "subfeatures");
5267 DEFSYM (Qfuncall
, "funcall");
5268 DEFSYM (Qplistp
, "plistp");
5270 #ifdef HAVE_LANGINFO_CODESET
5271 DEFSYM (Qcodeset
, "codeset");
5272 DEFSYM (Qdays
, "days");
5273 DEFSYM (Qmonths
, "months");
5274 DEFSYM (Qpaper
, "paper");
5275 #endif /* HAVE_LANGINFO_CODESET */
5277 DEFVAR_BOOL ("use-dialog-box", use_dialog_box
,
5278 doc
: /* Non-nil means mouse commands use dialog boxes to ask questions.
5279 This applies to `y-or-n-p' and `yes-or-no-p' questions asked by commands
5280 invoked by mouse clicks and mouse menu items.
5282 On some platforms, file selection dialogs are also enabled if this is
5286 DEFVAR_BOOL ("use-file-dialog", use_file_dialog
,
5287 doc
: /* Non-nil means mouse commands use a file dialog to ask for files.
5288 This applies to commands from menus and tool bar buttons even when
5289 they are initiated from the keyboard. If `use-dialog-box' is nil,
5290 that disables the use of a file dialog, regardless of the value of
5292 use_file_dialog
= 1;
5294 defsubr (&Sidentity
);
5297 defsubr (&Ssafe_length
);
5298 defsubr (&Sstring_bytes
);
5299 defsubr (&Sstring_distance
);
5300 defsubr (&Sstring_equal
);
5301 defsubr (&Scompare_strings
);
5302 defsubr (&Sstring_lessp
);
5303 defsubr (&Sstring_version_lessp
);
5304 defsubr (&Sstring_collate_lessp
);
5305 defsubr (&Sstring_collate_equalp
);
5308 defsubr (&Svconcat
);
5309 defsubr (&Scopy_sequence
);
5310 defsubr (&Sstring_make_multibyte
);
5311 defsubr (&Sstring_make_unibyte
);
5312 defsubr (&Sstring_as_multibyte
);
5313 defsubr (&Sstring_as_unibyte
);
5314 defsubr (&Sstring_to_multibyte
);
5315 defsubr (&Sstring_to_unibyte
);
5316 defsubr (&Scopy_alist
);
5317 defsubr (&Ssubstring
);
5318 defsubr (&Ssubstring_no_properties
);
5331 defsubr (&Snreverse
);
5332 defsubr (&Sreverse
);
5334 defsubr (&Splist_get
);
5336 defsubr (&Splist_put
);
5338 defsubr (&Slax_plist_get
);
5339 defsubr (&Slax_plist_put
);
5342 defsubr (&Sequal_including_properties
);
5343 defsubr (&Sfillarray
);
5344 defsubr (&Sclear_string
);
5349 defsubr (&Smapconcat
);
5350 defsubr (&Syes_or_no_p
);
5351 defsubr (&Sload_average
);
5352 defsubr (&Sfeaturep
);
5353 defsubr (&Srequire
);
5354 defsubr (&Sprovide
);
5355 defsubr (&Splist_member
);
5356 defsubr (&Swidget_put
);
5357 defsubr (&Swidget_get
);
5358 defsubr (&Swidget_apply
);
5359 defsubr (&Sbase64_encode_region
);
5360 defsubr (&Sbase64_decode_region
);
5361 defsubr (&Sbase64_encode_string
);
5362 defsubr (&Sbase64_decode_string
);
5364 defsubr (&Ssecure_hash_algorithms
);
5365 defsubr (&Ssecure_hash
);
5366 defsubr (&Sbuffer_hash
);
5367 defsubr (&Slocale_info
);