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
&& EQ (val
, Qnil
))
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 DEFUN ("member", Fmember
, Smember
, 2, 2, 0,
1423 doc
: /* Return non-nil if ELT is an element of LIST. Comparison done with `equal'.
1424 The value is actually the tail of LIST whose car is ELT. */)
1425 (Lisp_Object elt
, Lisp_Object list
)
1427 Lisp_Object tail
= list
;
1428 FOR_EACH_TAIL (tail
)
1429 if (! NILP (Fequal (elt
, XCAR (tail
))))
1431 CHECK_LIST_END (tail
, list
);
1435 DEFUN ("memq", Fmemq
, Smemq
, 2, 2, 0,
1436 doc
: /* Return non-nil if ELT is an element of LIST. Comparison done with `eq'.
1437 The value is actually the tail of LIST whose car is ELT. */)
1438 (Lisp_Object elt
, Lisp_Object list
)
1440 Lisp_Object tail
= list
;
1441 FOR_EACH_TAIL (tail
)
1442 if (EQ (XCAR (tail
), elt
))
1444 CHECK_LIST_END (tail
, list
);
1448 DEFUN ("memql", Fmemql
, Smemql
, 2, 2, 0,
1449 doc
: /* Return non-nil if ELT is an element of LIST. Comparison done with `eql'.
1450 The value is actually the tail of LIST whose car is ELT. */)
1451 (Lisp_Object elt
, Lisp_Object list
)
1454 return Fmemq (elt
, list
);
1456 Lisp_Object tail
= list
;
1457 FOR_EACH_TAIL (tail
)
1459 Lisp_Object tem
= XCAR (tail
);
1460 if (FLOATP (tem
) && equal_no_quit (elt
, tem
))
1463 CHECK_LIST_END (tail
, list
);
1467 DEFUN ("assq", Fassq
, Sassq
, 2, 2, 0,
1468 doc
: /* Return non-nil if KEY is `eq' to the car of an element of LIST.
1469 The value is actually the first element of LIST whose car is KEY.
1470 Elements of LIST that are not conses are ignored. */)
1471 (Lisp_Object key
, Lisp_Object list
)
1473 Lisp_Object tail
= list
;
1474 FOR_EACH_TAIL (tail
)
1475 if (CONSP (XCAR (tail
)) && EQ (XCAR (XCAR (tail
)), key
))
1477 CHECK_LIST_END (tail
, list
);
1481 /* Like Fassq but never report an error and do not allow quits.
1482 Use only on objects known to be non-circular lists. */
1485 assq_no_quit (Lisp_Object key
, Lisp_Object list
)
1487 for (; ! NILP (list
); list
= XCDR (list
))
1488 if (CONSP (XCAR (list
)) && EQ (XCAR (XCAR (list
)), key
))
1493 DEFUN ("assoc", Fassoc
, Sassoc
, 2, 3, 0,
1494 doc
: /* Return non-nil if KEY is equal to the car of an element of LIST.
1495 The value is actually the first element of LIST whose car equals KEY.
1497 Equality is defined by TESTFN if non-nil or by `equal' if nil. */)
1498 (Lisp_Object key
, Lisp_Object list
, Lisp_Object testfn
)
1500 Lisp_Object tail
= list
;
1501 FOR_EACH_TAIL (tail
)
1503 Lisp_Object car
= XCAR (tail
);
1506 ? (EQ (XCAR (car
), key
) || !NILP (Fequal
1508 : !NILP (call2 (testfn
, XCAR (car
), key
))))
1511 CHECK_LIST_END (tail
, list
);
1515 /* Like Fassoc but never report an error and do not allow quits.
1516 Use only on keys and lists known to be non-circular, and on keys
1517 that are not too deep and are not window configurations. */
1520 assoc_no_quit (Lisp_Object key
, Lisp_Object list
)
1522 for (; ! NILP (list
); list
= XCDR (list
))
1524 Lisp_Object car
= XCAR (list
);
1526 && (EQ (XCAR (car
), key
) || equal_no_quit (XCAR (car
), key
)))
1532 DEFUN ("rassq", Frassq
, Srassq
, 2, 2, 0,
1533 doc
: /* Return non-nil if KEY is `eq' to the cdr of an element of LIST.
1534 The value is actually the first element of LIST whose cdr is KEY. */)
1535 (Lisp_Object key
, Lisp_Object list
)
1537 Lisp_Object tail
= list
;
1538 FOR_EACH_TAIL (tail
)
1539 if (CONSP (XCAR (tail
)) && EQ (XCDR (XCAR (tail
)), key
))
1541 CHECK_LIST_END (tail
, list
);
1545 DEFUN ("rassoc", Frassoc
, Srassoc
, 2, 2, 0,
1546 doc
: /* Return non-nil if KEY is `equal' to the cdr of an element of LIST.
1547 The value is actually the first element of LIST whose cdr equals KEY. */)
1548 (Lisp_Object key
, Lisp_Object list
)
1550 Lisp_Object tail
= list
;
1551 FOR_EACH_TAIL (tail
)
1553 Lisp_Object car
= XCAR (tail
);
1555 && (EQ (XCDR (car
), key
) || !NILP (Fequal (XCDR (car
), key
))))
1558 CHECK_LIST_END (tail
, list
);
1562 DEFUN ("delq", Fdelq
, Sdelq
, 2, 2, 0,
1563 doc
: /* Delete members of LIST which are `eq' to ELT, and return the result.
1564 More precisely, this function skips any members `eq' to ELT at the
1565 front of LIST, then removes members `eq' to ELT from the remaining
1566 sublist by modifying its list structure, then returns the resulting
1569 Write `(setq foo (delq element foo))' to be sure of correctly changing
1570 the value of a list `foo'. See also `remq', which does not modify the
1572 (Lisp_Object elt
, Lisp_Object list
)
1574 Lisp_Object prev
= Qnil
, tail
= list
;
1576 FOR_EACH_TAIL (tail
)
1578 Lisp_Object tem
= XCAR (tail
);
1584 Fsetcdr (prev
, XCDR (tail
));
1589 CHECK_LIST_END (tail
, list
);
1593 DEFUN ("delete", Fdelete
, Sdelete
, 2, 2, 0,
1594 doc
: /* Delete members of SEQ which are `equal' to ELT, and return the result.
1595 SEQ must be a sequence (i.e. a list, a vector, or a string).
1596 The return value is a sequence of the same type.
1598 If SEQ is a list, this behaves like `delq', except that it compares
1599 with `equal' instead of `eq'. In particular, it may remove elements
1600 by altering the list structure.
1602 If SEQ is not a list, deletion is never performed destructively;
1603 instead this function creates and returns a new vector or string.
1605 Write `(setq foo (delete element foo))' to be sure of correctly
1606 changing the value of a sequence `foo'. */)
1607 (Lisp_Object elt
, Lisp_Object seq
)
1613 for (i
= n
= 0; i
< ASIZE (seq
); ++i
)
1614 if (NILP (Fequal (AREF (seq
, i
), elt
)))
1617 if (n
!= ASIZE (seq
))
1619 struct Lisp_Vector
*p
= allocate_vector (n
);
1621 for (i
= n
= 0; i
< ASIZE (seq
); ++i
)
1622 if (NILP (Fequal (AREF (seq
, i
), elt
)))
1623 p
->contents
[n
++] = AREF (seq
, i
);
1625 XSETVECTOR (seq
, p
);
1628 else if (STRINGP (seq
))
1630 ptrdiff_t i
, ibyte
, nchars
, nbytes
, cbytes
;
1633 for (i
= nchars
= nbytes
= ibyte
= 0;
1635 ++i
, ibyte
+= cbytes
)
1637 if (STRING_MULTIBYTE (seq
))
1639 c
= STRING_CHAR (SDATA (seq
) + ibyte
);
1640 cbytes
= CHAR_BYTES (c
);
1648 if (!INTEGERP (elt
) || c
!= XINT (elt
))
1655 if (nchars
!= SCHARS (seq
))
1659 tem
= make_uninit_multibyte_string (nchars
, nbytes
);
1660 if (!STRING_MULTIBYTE (seq
))
1661 STRING_SET_UNIBYTE (tem
);
1663 for (i
= nchars
= nbytes
= ibyte
= 0;
1665 ++i
, ibyte
+= cbytes
)
1667 if (STRING_MULTIBYTE (seq
))
1669 c
= STRING_CHAR (SDATA (seq
) + ibyte
);
1670 cbytes
= CHAR_BYTES (c
);
1678 if (!INTEGERP (elt
) || c
!= XINT (elt
))
1680 unsigned char *from
= SDATA (seq
) + ibyte
;
1681 unsigned char *to
= SDATA (tem
) + nbytes
;
1687 for (n
= cbytes
; n
--; )
1697 Lisp_Object prev
= Qnil
, tail
= seq
;
1699 FOR_EACH_TAIL (tail
)
1701 if (!NILP (Fequal (elt
, XCAR (tail
))))
1706 Fsetcdr (prev
, XCDR (tail
));
1711 CHECK_LIST_END (tail
, seq
);
1717 DEFUN ("nreverse", Fnreverse
, Snreverse
, 1, 1, 0,
1718 doc
: /* Reverse order of items in a list, vector or string SEQ.
1719 If SEQ is a list, it should be nil-terminated.
1720 This function may destructively modify SEQ to produce the value. */)
1725 else if (STRINGP (seq
))
1726 return Freverse (seq
);
1727 else if (CONSP (seq
))
1729 Lisp_Object prev
, tail
, next
;
1731 for (prev
= Qnil
, tail
= seq
; CONSP (tail
); tail
= next
)
1734 /* If SEQ contains a cycle, attempting to reverse it
1735 in-place will inevitably come back to SEQ. */
1737 circular_list (seq
);
1738 Fsetcdr (tail
, prev
);
1741 CHECK_LIST_END (tail
, seq
);
1744 else if (VECTORP (seq
))
1746 ptrdiff_t i
, size
= ASIZE (seq
);
1748 for (i
= 0; i
< size
/ 2; i
++)
1750 Lisp_Object tem
= AREF (seq
, i
);
1751 ASET (seq
, i
, AREF (seq
, size
- i
- 1));
1752 ASET (seq
, size
- i
- 1, tem
);
1755 else if (BOOL_VECTOR_P (seq
))
1757 ptrdiff_t i
, size
= bool_vector_size (seq
);
1759 for (i
= 0; i
< size
/ 2; i
++)
1761 bool tem
= bool_vector_bitref (seq
, i
);
1762 bool_vector_set (seq
, i
, bool_vector_bitref (seq
, size
- i
- 1));
1763 bool_vector_set (seq
, size
- i
- 1, tem
);
1767 wrong_type_argument (Qarrayp
, seq
);
1771 DEFUN ("reverse", Freverse
, Sreverse
, 1, 1, 0,
1772 doc
: /* Return the reversed copy of list, vector, or string SEQ.
1773 See also the function `nreverse', which is used more often. */)
1780 else if (CONSP (seq
))
1784 new = Fcons (XCAR (seq
), new);
1785 CHECK_LIST_END (seq
, seq
);
1787 else if (VECTORP (seq
))
1789 ptrdiff_t i
, size
= ASIZE (seq
);
1791 new = make_uninit_vector (size
);
1792 for (i
= 0; i
< size
; i
++)
1793 ASET (new, i
, AREF (seq
, size
- i
- 1));
1795 else if (BOOL_VECTOR_P (seq
))
1798 EMACS_INT nbits
= bool_vector_size (seq
);
1800 new = make_uninit_bool_vector (nbits
);
1801 for (i
= 0; i
< nbits
; i
++)
1802 bool_vector_set (new, i
, bool_vector_bitref (seq
, nbits
- i
- 1));
1804 else if (STRINGP (seq
))
1806 ptrdiff_t size
= SCHARS (seq
), bytes
= SBYTES (seq
);
1812 new = make_uninit_string (size
);
1813 for (i
= 0; i
< size
; i
++)
1814 SSET (new, i
, SREF (seq
, size
- i
- 1));
1818 unsigned char *p
, *q
;
1820 new = make_uninit_multibyte_string (size
, bytes
);
1821 p
= SDATA (seq
), q
= SDATA (new) + bytes
;
1822 while (q
> SDATA (new))
1826 ch
= STRING_CHAR_AND_LENGTH (p
, len
);
1828 CHAR_STRING (ch
, q
);
1833 wrong_type_argument (Qsequencep
, seq
);
1837 /* Sort LIST using PREDICATE, preserving original order of elements
1838 considered as equal. */
1841 sort_list (Lisp_Object list
, Lisp_Object predicate
)
1843 Lisp_Object front
, back
;
1844 Lisp_Object len
, tem
;
1848 len
= Flength (list
);
1849 length
= XINT (len
);
1853 XSETINT (len
, (length
/ 2) - 1);
1854 tem
= Fnthcdr (len
, list
);
1856 Fsetcdr (tem
, Qnil
);
1858 front
= Fsort (front
, predicate
);
1859 back
= Fsort (back
, predicate
);
1860 return merge (front
, back
, predicate
);
1863 /* Using PRED to compare, return whether A and B are in order.
1864 Compare stably when A appeared before B in the input. */
1866 inorder (Lisp_Object pred
, Lisp_Object a
, Lisp_Object b
)
1868 return NILP (call2 (pred
, b
, a
));
1871 /* Using PRED to compare, merge from ALEN-length A and BLEN-length B
1872 into DEST. Argument arrays must be nonempty and must not overlap,
1873 except that B might be the last part of DEST. */
1875 merge_vectors (Lisp_Object pred
,
1876 ptrdiff_t alen
, Lisp_Object
const a
[restrict
VLA_ELEMS (alen
)],
1877 ptrdiff_t blen
, Lisp_Object
const b
[VLA_ELEMS (blen
)],
1878 Lisp_Object dest
[VLA_ELEMS (alen
+ blen
)])
1880 eassume (0 < alen
&& 0 < blen
);
1881 Lisp_Object
const *alim
= a
+ alen
;
1882 Lisp_Object
const *blim
= b
+ blen
;
1886 if (inorder (pred
, a
[0], b
[0]))
1892 memcpy (dest
, b
, (blim
- b
) * sizeof *dest
);
1901 memcpy (dest
, a
, (alim
- a
) * sizeof *dest
);
1908 /* Using PRED to compare, sort LEN-length VEC in place, using TMP for
1909 temporary storage. LEN must be at least 2. */
1911 sort_vector_inplace (Lisp_Object pred
, ptrdiff_t len
,
1912 Lisp_Object vec
[restrict
VLA_ELEMS (len
)],
1913 Lisp_Object tmp
[restrict
VLA_ELEMS (len
>> 1)])
1916 ptrdiff_t halflen
= len
>> 1;
1917 sort_vector_copy (pred
, halflen
, vec
, tmp
);
1918 if (1 < len
- halflen
)
1919 sort_vector_inplace (pred
, len
- halflen
, vec
+ halflen
, vec
);
1920 merge_vectors (pred
, halflen
, tmp
, len
- halflen
, vec
+ halflen
, vec
);
1923 /* Using PRED to compare, sort from LEN-length SRC into DST.
1924 Len must be positive. */
1926 sort_vector_copy (Lisp_Object pred
, ptrdiff_t len
,
1927 Lisp_Object src
[restrict
VLA_ELEMS (len
)],
1928 Lisp_Object dest
[restrict
VLA_ELEMS (len
)])
1931 ptrdiff_t halflen
= len
>> 1;
1937 sort_vector_inplace (pred
, halflen
, src
, dest
);
1938 if (1 < len
- halflen
)
1939 sort_vector_inplace (pred
, len
- halflen
, src
+ halflen
, dest
);
1940 merge_vectors (pred
, halflen
, src
, len
- halflen
, src
+ halflen
, dest
);
1944 /* Sort VECTOR in place using PREDICATE, preserving original order of
1945 elements considered as equal. */
1948 sort_vector (Lisp_Object vector
, Lisp_Object predicate
)
1950 ptrdiff_t len
= ASIZE (vector
);
1953 ptrdiff_t halflen
= len
>> 1;
1956 SAFE_ALLOCA_LISP (tmp
, halflen
);
1957 for (ptrdiff_t i
= 0; i
< halflen
; i
++)
1958 tmp
[i
] = make_number (0);
1959 sort_vector_inplace (predicate
, len
, XVECTOR (vector
)->contents
, tmp
);
1963 DEFUN ("sort", Fsort
, Ssort
, 2, 2, 0,
1964 doc
: /* Sort SEQ, stably, comparing elements using PREDICATE.
1965 Returns the sorted sequence. SEQ should be a list or vector. SEQ is
1966 modified by side effects. PREDICATE is called with two elements of
1967 SEQ, and should return non-nil if the first element should sort before
1969 (Lisp_Object seq
, Lisp_Object predicate
)
1972 seq
= sort_list (seq
, predicate
);
1973 else if (VECTORP (seq
))
1974 sort_vector (seq
, predicate
);
1975 else if (!NILP (seq
))
1976 wrong_type_argument (Qsequencep
, seq
);
1981 merge (Lisp_Object org_l1
, Lisp_Object org_l2
, Lisp_Object pred
)
1983 Lisp_Object l1
= org_l1
;
1984 Lisp_Object l2
= org_l2
;
1985 Lisp_Object tail
= Qnil
;
1986 Lisp_Object value
= Qnil
;
2006 if (inorder (pred
, Fcar (l1
), Fcar (l2
)))
2021 Fsetcdr (tail
, tem
);
2027 /* This does not check for quits. That is safe since it must terminate. */
2029 DEFUN ("plist-get", Fplist_get
, Splist_get
, 2, 2, 0,
2030 doc
: /* Extract a value from a property list.
2031 PLIST is a property list, which is a list of the form
2032 \(PROP1 VALUE1 PROP2 VALUE2...). This function returns the value
2033 corresponding to the given PROP, or nil if PROP is not one of the
2034 properties on the list. This function never signals an error. */)
2035 (Lisp_Object plist
, Lisp_Object prop
)
2037 Lisp_Object tail
= plist
;
2038 FOR_EACH_TAIL_SAFE (tail
)
2040 if (! CONSP (XCDR (tail
)))
2042 if (EQ (prop
, XCAR (tail
)))
2043 return XCAR (XCDR (tail
));
2045 if (EQ (tail
, li
.tortoise
))
2052 DEFUN ("get", Fget
, Sget
, 2, 2, 0,
2053 doc
: /* Return the value of SYMBOL's PROPNAME property.
2054 This is the last value stored with `(put SYMBOL PROPNAME VALUE)'. */)
2055 (Lisp_Object symbol
, Lisp_Object propname
)
2057 CHECK_SYMBOL (symbol
);
2058 Lisp_Object propval
= Fplist_get (CDR (Fassq (symbol
, Voverriding_plist_environment
)),
2060 if (!NILP (propval
))
2062 return Fplist_get (XSYMBOL (symbol
)->u
.s
.plist
, propname
);
2065 DEFUN ("plist-put", Fplist_put
, Splist_put
, 3, 3, 0,
2066 doc
: /* Change value in PLIST of PROP to VAL.
2067 PLIST is a property list, which is a list of the form
2068 \(PROP1 VALUE1 PROP2 VALUE2 ...). PROP is a symbol and VAL is any object.
2069 If PROP is already a property on the list, its value is set to VAL,
2070 otherwise the new PROP VAL pair is added. The new plist is returned;
2071 use `(setq x (plist-put x prop val))' to be sure to use the new value.
2072 The PLIST is modified by side effects. */)
2073 (Lisp_Object plist
, Lisp_Object prop
, Lisp_Object val
)
2075 Lisp_Object prev
= Qnil
, tail
= plist
;
2076 FOR_EACH_TAIL (tail
)
2078 if (! CONSP (XCDR (tail
)))
2081 if (EQ (prop
, XCAR (tail
)))
2083 Fsetcar (XCDR (tail
), val
);
2089 if (EQ (tail
, li
.tortoise
))
2090 circular_list (plist
);
2092 CHECK_TYPE (NILP (tail
), Qplistp
, plist
);
2094 = Fcons (prop
, Fcons (val
, NILP (prev
) ? plist
: XCDR (XCDR (prev
))));
2097 Fsetcdr (XCDR (prev
), newcell
);
2101 DEFUN ("put", Fput
, Sput
, 3, 3, 0,
2102 doc
: /* Store SYMBOL's PROPNAME property with value VALUE.
2103 It can be retrieved with `(get SYMBOL PROPNAME)'. */)
2104 (Lisp_Object symbol
, Lisp_Object propname
, Lisp_Object value
)
2106 CHECK_SYMBOL (symbol
);
2108 (symbol
, Fplist_put (XSYMBOL (symbol
)->u
.s
.plist
, propname
, value
));
2112 DEFUN ("lax-plist-get", Flax_plist_get
, Slax_plist_get
, 2, 2, 0,
2113 doc
: /* Extract a value from a property list, comparing with `equal'.
2114 PLIST is a property list, which is a list of the form
2115 \(PROP1 VALUE1 PROP2 VALUE2...). This function returns the value
2116 corresponding to the given PROP, or nil if PROP is not
2117 one of the properties on the list. */)
2118 (Lisp_Object plist
, Lisp_Object prop
)
2120 Lisp_Object tail
= plist
;
2121 FOR_EACH_TAIL (tail
)
2123 if (! CONSP (XCDR (tail
)))
2125 if (! NILP (Fequal (prop
, XCAR (tail
))))
2126 return XCAR (XCDR (tail
));
2128 if (EQ (tail
, li
.tortoise
))
2129 circular_list (plist
);
2132 CHECK_TYPE (NILP (tail
), Qplistp
, plist
);
2137 DEFUN ("lax-plist-put", Flax_plist_put
, Slax_plist_put
, 3, 3, 0,
2138 doc
: /* Change value in PLIST of PROP to VAL, comparing with `equal'.
2139 PLIST is a property list, which is a list of the form
2140 \(PROP1 VALUE1 PROP2 VALUE2 ...). PROP and VAL are any objects.
2141 If PROP is already a property on the list, its value is set to VAL,
2142 otherwise the new PROP VAL pair is added. The new plist is returned;
2143 use `(setq x (lax-plist-put x prop val))' to be sure to use the new value.
2144 The PLIST is modified by side effects. */)
2145 (Lisp_Object plist
, Lisp_Object prop
, Lisp_Object val
)
2147 Lisp_Object prev
= Qnil
, tail
= plist
;
2148 FOR_EACH_TAIL (tail
)
2150 if (! CONSP (XCDR (tail
)))
2153 if (! NILP (Fequal (prop
, XCAR (tail
))))
2155 Fsetcar (XCDR (tail
), val
);
2161 if (EQ (tail
, li
.tortoise
))
2162 circular_list (plist
);
2164 CHECK_TYPE (NILP (tail
), Qplistp
, plist
);
2165 Lisp_Object newcell
= list2 (prop
, val
);
2168 Fsetcdr (XCDR (prev
), newcell
);
2172 DEFUN ("eql", Feql
, Seql
, 2, 2, 0,
2173 doc
: /* Return t if the two args are the same Lisp object.
2174 Floating-point numbers of equal value are `eql', but they may not be `eq'. */)
2175 (Lisp_Object obj1
, Lisp_Object obj2
)
2178 return equal_no_quit (obj1
, obj2
) ? Qt
: Qnil
;
2180 return EQ (obj1
, obj2
) ? Qt
: Qnil
;
2183 DEFUN ("equal", Fequal
, Sequal
, 2, 2, 0,
2184 doc
: /* Return t if two Lisp objects have similar structure and contents.
2185 They must have the same data type.
2186 Conses are compared by comparing the cars and the cdrs.
2187 Vectors and strings are compared element by element.
2188 Numbers are compared by value, but integers cannot equal floats.
2189 (Use `=' if you want integers and floats to be able to be equal.)
2190 Symbols must match exactly. */)
2191 (Lisp_Object o1
, Lisp_Object o2
)
2193 return internal_equal (o1
, o2
, EQUAL_PLAIN
, 0, Qnil
) ? Qt
: Qnil
;
2196 DEFUN ("equal-including-properties", Fequal_including_properties
, Sequal_including_properties
, 2, 2, 0,
2197 doc
: /* Return t if two Lisp objects have similar structure and contents.
2198 This is like `equal' except that it compares the text properties
2199 of strings. (`equal' ignores text properties.) */)
2200 (Lisp_Object o1
, Lisp_Object o2
)
2202 return (internal_equal (o1
, o2
, EQUAL_INCLUDING_PROPERTIES
, 0, Qnil
)
2206 /* Return true if O1 and O2 are equal. Do not quit or check for cycles.
2207 Use this only on arguments that are cycle-free and not too large and
2208 are not window configurations. */
2211 equal_no_quit (Lisp_Object o1
, Lisp_Object o2
)
2213 return internal_equal (o1
, o2
, EQUAL_NO_QUIT
, 0, Qnil
);
2216 /* Return true if O1 and O2 are equal. EQUAL_KIND specifies what kind
2217 of equality test to use: if it is EQUAL_NO_QUIT, do not check for
2218 cycles or large arguments or quits; if EQUAL_PLAIN, do ordinary
2219 Lisp equality; and if EQUAL_INCLUDING_PROPERTIES, do
2220 equal-including-properties.
2222 If DEPTH is the current depth of recursion; signal an error if it
2223 gets too deep. HT is a hash table used to detect cycles; if nil,
2224 it has not been allocated yet. But ignore the last two arguments
2225 if EQUAL_KIND == EQUAL_NO_QUIT. */
2228 internal_equal (Lisp_Object o1
, Lisp_Object o2
, enum equal_kind equal_kind
,
2229 int depth
, Lisp_Object ht
)
2234 eassert (equal_kind
!= EQUAL_NO_QUIT
);
2236 error ("Stack overflow in equal");
2238 ht
= CALLN (Fmake_hash_table
, QCtest
, Qeq
);
2241 case Lisp_Cons
: case Lisp_Misc
: case Lisp_Vectorlike
:
2243 struct Lisp_Hash_Table
*h
= XHASH_TABLE (ht
);
2245 ptrdiff_t i
= hash_lookup (h
, o1
, &hash
);
2247 { /* `o1' was seen already. */
2248 Lisp_Object o2s
= HASH_VALUE (h
, i
);
2249 if (!NILP (Fmemq (o2
, o2s
)))
2252 set_hash_value_slot (h
, i
, Fcons (o2
, o2s
));
2255 hash_put (h
, o1
, Fcons (o2
, Qnil
), hash
);
2263 if (XTYPE (o1
) != XTYPE (o2
))
2270 double d1
= XFLOAT_DATA (o1
);
2271 double d2
= XFLOAT_DATA (o2
);
2272 /* If d is a NaN, then d != d. Two NaNs should be `equal' even
2273 though they are not =. */
2274 return d1
== d2
|| (d1
!= d1
&& d2
!= d2
);
2278 if (equal_kind
== EQUAL_NO_QUIT
)
2279 for (; CONSP (o1
); o1
= XCDR (o1
))
2283 if (! equal_no_quit (XCAR (o1
), XCAR (o2
)))
2286 if (EQ (XCDR (o1
), o2
))
2294 if (! internal_equal (XCAR (o1
), XCAR (o2
),
2295 equal_kind
, depth
+ 1, ht
))
2298 if (EQ (XCDR (o1
), o2
))
2305 if (XMISCTYPE (o1
) != XMISCTYPE (o2
))
2309 if (!internal_equal (OVERLAY_START (o1
), OVERLAY_START (o2
),
2310 equal_kind
, depth
+ 1, ht
)
2311 || !internal_equal (OVERLAY_END (o1
), OVERLAY_END (o2
),
2312 equal_kind
, depth
+ 1, ht
))
2314 o1
= XOVERLAY (o1
)->plist
;
2315 o2
= XOVERLAY (o2
)->plist
;
2321 return (XMARKER (o1
)->buffer
== XMARKER (o2
)->buffer
2322 && (XMARKER (o1
)->buffer
== 0
2323 || XMARKER (o1
)->bytepos
== XMARKER (o2
)->bytepos
));
2327 case Lisp_Vectorlike
:
2330 ptrdiff_t size
= ASIZE (o1
);
2331 /* Pseudovectors have the type encoded in the size field, so this test
2332 actually checks that the objects have the same type as well as the
2334 if (ASIZE (o2
) != size
)
2336 /* Boolvectors are compared much like strings. */
2337 if (BOOL_VECTOR_P (o1
))
2339 EMACS_INT size
= bool_vector_size (o1
);
2340 if (size
!= bool_vector_size (o2
))
2342 if (memcmp (bool_vector_data (o1
), bool_vector_data (o2
),
2343 bool_vector_bytes (size
)))
2347 if (WINDOW_CONFIGURATIONP (o1
))
2349 eassert (equal_kind
!= EQUAL_NO_QUIT
);
2350 return compare_window_configurations (o1
, o2
, false);
2353 /* Aside from them, only true vectors, char-tables, compiled
2354 functions, and fonts (font-spec, font-entity, font-object)
2355 are sensible to compare, so eliminate the others now. */
2356 if (size
& PSEUDOVECTOR_FLAG
)
2358 if (((size
& PVEC_TYPE_MASK
) >> PSEUDOVECTOR_AREA_BITS
)
2361 size
&= PSEUDOVECTOR_SIZE_MASK
;
2363 for (i
= 0; i
< size
; i
++)
2368 if (!internal_equal (v1
, v2
, equal_kind
, depth
+ 1, ht
))
2376 if (SCHARS (o1
) != SCHARS (o2
))
2378 if (SBYTES (o1
) != SBYTES (o2
))
2380 if (memcmp (SDATA (o1
), SDATA (o2
), SBYTES (o1
)))
2382 if (equal_kind
== EQUAL_INCLUDING_PROPERTIES
2383 && !compare_string_intervals (o1
, o2
))
2395 DEFUN ("fillarray", Ffillarray
, Sfillarray
, 2, 2, 0,
2396 doc
: /* Store each element of ARRAY with ITEM.
2397 ARRAY is a vector, string, char-table, or bool-vector. */)
2398 (Lisp_Object array
, Lisp_Object item
)
2400 register ptrdiff_t size
, idx
;
2402 if (VECTORP (array
))
2403 for (idx
= 0, size
= ASIZE (array
); idx
< size
; idx
++)
2404 ASET (array
, idx
, item
);
2405 else if (CHAR_TABLE_P (array
))
2409 for (i
= 0; i
< (1 << CHARTAB_SIZE_BITS_0
); i
++)
2410 set_char_table_contents (array
, i
, item
);
2411 set_char_table_defalt (array
, item
);
2413 else if (STRINGP (array
))
2415 register unsigned char *p
= SDATA (array
);
2417 CHECK_CHARACTER (item
);
2418 charval
= XFASTINT (item
);
2419 size
= SCHARS (array
);
2420 if (STRING_MULTIBYTE (array
))
2422 unsigned char str
[MAX_MULTIBYTE_LENGTH
];
2423 int len
= CHAR_STRING (charval
, str
);
2424 ptrdiff_t size_byte
= SBYTES (array
);
2427 if (INT_MULTIPLY_WRAPV (size
, len
, &product
) || product
!= size_byte
)
2428 error ("Attempt to change byte length of a string");
2429 for (idx
= 0; idx
< size_byte
; idx
++)
2430 *p
++ = str
[idx
% len
];
2433 for (idx
= 0; idx
< size
; idx
++)
2436 else if (BOOL_VECTOR_P (array
))
2437 return bool_vector_fill (array
, item
);
2439 wrong_type_argument (Qarrayp
, array
);
2443 DEFUN ("clear-string", Fclear_string
, Sclear_string
,
2445 doc
: /* Clear the contents of STRING.
2446 This makes STRING unibyte and may change its length. */)
2447 (Lisp_Object string
)
2450 CHECK_STRING (string
);
2451 len
= SBYTES (string
);
2452 memset (SDATA (string
), 0, len
);
2453 STRING_SET_CHARS (string
, len
);
2454 STRING_SET_UNIBYTE (string
);
2460 nconc2 (Lisp_Object s1
, Lisp_Object s2
)
2462 return CALLN (Fnconc
, s1
, s2
);
2465 DEFUN ("nconc", Fnconc
, Snconc
, 0, MANY
, 0,
2466 doc
: /* Concatenate any number of lists by altering them.
2467 Only the last argument is not altered, and need not be a list.
2468 usage: (nconc &rest LISTS) */)
2469 (ptrdiff_t nargs
, Lisp_Object
*args
)
2471 Lisp_Object val
= Qnil
;
2473 for (ptrdiff_t argnum
= 0; argnum
< nargs
; argnum
++)
2475 Lisp_Object tem
= args
[argnum
];
2476 if (NILP (tem
)) continue;
2481 if (argnum
+ 1 == nargs
) break;
2489 tem
= args
[argnum
+ 1];
2490 Fsetcdr (tail
, tem
);
2492 args
[argnum
+ 1] = tail
;
2498 /* This is the guts of all mapping functions.
2499 Apply FN to each element of SEQ, one by one, storing the results
2500 into elements of VALS, a C vector of Lisp_Objects. LENI is the
2501 length of VALS, which should also be the length of SEQ. Return the
2502 number of results; although this is normally LENI, it can be less
2503 if SEQ is made shorter as a side effect of FN. */
2506 mapcar1 (EMACS_INT leni
, Lisp_Object
*vals
, Lisp_Object fn
, Lisp_Object seq
)
2508 Lisp_Object tail
, dummy
;
2511 if (VECTORP (seq
) || COMPILEDP (seq
))
2513 for (i
= 0; i
< leni
; i
++)
2515 dummy
= call1 (fn
, AREF (seq
, i
));
2520 else if (BOOL_VECTOR_P (seq
))
2522 for (i
= 0; i
< leni
; i
++)
2524 dummy
= call1 (fn
, bool_vector_ref (seq
, i
));
2529 else if (STRINGP (seq
))
2533 for (i
= 0, i_byte
= 0; i
< leni
;)
2536 ptrdiff_t i_before
= i
;
2538 FETCH_STRING_CHAR_ADVANCE (c
, seq
, i
, i_byte
);
2539 XSETFASTINT (dummy
, c
);
2540 dummy
= call1 (fn
, dummy
);
2542 vals
[i_before
] = dummy
;
2545 else /* Must be a list, since Flength did not get an error */
2548 for (i
= 0; i
< leni
; i
++)
2552 dummy
= call1 (fn
, XCAR (tail
));
2562 DEFUN ("mapconcat", Fmapconcat
, Smapconcat
, 3, 3, 0,
2563 doc
: /* Apply FUNCTION to each element of SEQUENCE, and concat the results as strings.
2564 In between each pair of results, stick in SEPARATOR. Thus, " " as
2565 SEPARATOR results in spaces between the values returned by FUNCTION.
2566 SEQUENCE may be a list, a vector, a bool-vector, or a string. */)
2567 (Lisp_Object function
, Lisp_Object sequence
, Lisp_Object separator
)
2570 EMACS_INT leni
= XFASTINT (Flength (sequence
));
2571 if (CHAR_TABLE_P (sequence
))
2572 wrong_type_argument (Qlistp
, sequence
);
2573 EMACS_INT args_alloc
= 2 * leni
- 1;
2575 return empty_unibyte_string
;
2577 SAFE_ALLOCA_LISP (args
, args_alloc
);
2578 ptrdiff_t nmapped
= mapcar1 (leni
, args
, function
, sequence
);
2579 ptrdiff_t nargs
= 2 * nmapped
- 1;
2581 for (ptrdiff_t i
= nmapped
- 1; i
> 0; i
--)
2582 args
[i
+ i
] = args
[i
];
2584 for (ptrdiff_t i
= 1; i
< nargs
; i
+= 2)
2585 args
[i
] = separator
;
2587 Lisp_Object ret
= Fconcat (nargs
, args
);
2592 DEFUN ("mapcar", Fmapcar
, Smapcar
, 2, 2, 0,
2593 doc
: /* Apply FUNCTION to each element of SEQUENCE, and make a list of the results.
2594 The result is a list just as long as SEQUENCE.
2595 SEQUENCE may be a list, a vector, a bool-vector, or a string. */)
2596 (Lisp_Object function
, Lisp_Object sequence
)
2599 EMACS_INT leni
= XFASTINT (Flength (sequence
));
2600 if (CHAR_TABLE_P (sequence
))
2601 wrong_type_argument (Qlistp
, sequence
);
2603 SAFE_ALLOCA_LISP (args
, leni
);
2604 ptrdiff_t nmapped
= mapcar1 (leni
, args
, function
, sequence
);
2605 Lisp_Object ret
= Flist (nmapped
, args
);
2610 DEFUN ("mapc", Fmapc
, Smapc
, 2, 2, 0,
2611 doc
: /* Apply FUNCTION to each element of SEQUENCE for side effects only.
2612 Unlike `mapcar', don't accumulate the results. Return SEQUENCE.
2613 SEQUENCE may be a list, a vector, a bool-vector, or a string. */)
2614 (Lisp_Object function
, Lisp_Object sequence
)
2616 register EMACS_INT leni
;
2618 leni
= XFASTINT (Flength (sequence
));
2619 if (CHAR_TABLE_P (sequence
))
2620 wrong_type_argument (Qlistp
, sequence
);
2621 mapcar1 (leni
, 0, function
, sequence
);
2626 DEFUN ("mapcan", Fmapcan
, Smapcan
, 2, 2, 0,
2627 doc
: /* Apply FUNCTION to each element of SEQUENCE, and concatenate
2628 the results by altering them (using `nconc').
2629 SEQUENCE may be a list, a vector, a bool-vector, or a string. */)
2630 (Lisp_Object function
, Lisp_Object sequence
)
2633 EMACS_INT leni
= XFASTINT (Flength (sequence
));
2634 if (CHAR_TABLE_P (sequence
))
2635 wrong_type_argument (Qlistp
, sequence
);
2637 SAFE_ALLOCA_LISP (args
, leni
);
2638 ptrdiff_t nmapped
= mapcar1 (leni
, args
, function
, sequence
);
2639 Lisp_Object ret
= Fnconc (nmapped
, args
);
2644 /* This is how C code calls `yes-or-no-p' and allows the user
2648 do_yes_or_no_p (Lisp_Object prompt
)
2650 return call1 (intern ("yes-or-no-p"), prompt
);
2653 DEFUN ("yes-or-no-p", Fyes_or_no_p
, Syes_or_no_p
, 1, 1, 0,
2654 doc
: /* Ask user a yes-or-no question.
2655 Return t if answer is yes, and nil if the answer is no.
2656 PROMPT is the string to display to ask the question. It should end in
2657 a space; `yes-or-no-p' adds \"(yes or no) \" to it.
2659 The user must confirm the answer with RET, and can edit it until it
2662 If dialog boxes are supported, a dialog box will be used
2663 if `last-nonmenu-event' is nil, and `use-dialog-box' is non-nil. */)
2664 (Lisp_Object prompt
)
2668 CHECK_STRING (prompt
);
2670 if ((NILP (last_nonmenu_event
) || CONSP (last_nonmenu_event
))
2671 && use_dialog_box
&& ! NILP (last_input_event
))
2673 Lisp_Object pane
, menu
, obj
;
2674 redisplay_preserve_echo_area (4);
2675 pane
= list2 (Fcons (build_string ("Yes"), Qt
),
2676 Fcons (build_string ("No"), Qnil
));
2677 menu
= Fcons (prompt
, pane
);
2678 obj
= Fx_popup_dialog (Qt
, menu
, Qnil
);
2682 AUTO_STRING (yes_or_no
, "(yes or no) ");
2683 prompt
= CALLN (Fconcat
, prompt
, yes_or_no
);
2687 ans
= Fdowncase (Fread_from_minibuffer (prompt
, Qnil
, Qnil
, Qnil
,
2688 Qyes_or_no_p_history
, Qnil
,
2690 if (SCHARS (ans
) == 3 && !strcmp (SSDATA (ans
), "yes"))
2692 if (SCHARS (ans
) == 2 && !strcmp (SSDATA (ans
), "no"))
2697 message1 ("Please answer yes or no.");
2698 Fsleep_for (make_number (2), Qnil
);
2702 DEFUN ("load-average", Fload_average
, Sload_average
, 0, 1, 0,
2703 doc
: /* Return list of 1 minute, 5 minute and 15 minute load averages.
2705 Each of the three load averages is multiplied by 100, then converted
2708 When USE-FLOATS is non-nil, floats will be used instead of integers.
2709 These floats are not multiplied by 100.
2711 If the 5-minute or 15-minute load averages are not available, return a
2712 shortened list, containing only those averages which are available.
2714 An error is thrown if the load average can't be obtained. In some
2715 cases making it work would require Emacs being installed setuid or
2716 setgid so that it can read kernel information, and that usually isn't
2718 (Lisp_Object use_floats
)
2721 int loads
= getloadavg (load_ave
, 3);
2722 Lisp_Object ret
= Qnil
;
2725 error ("load-average not implemented for this operating system");
2729 Lisp_Object load
= (NILP (use_floats
)
2730 ? make_number (100.0 * load_ave
[loads
])
2731 : make_float (load_ave
[loads
]));
2732 ret
= Fcons (load
, ret
);
2738 DEFUN ("featurep", Ffeaturep
, Sfeaturep
, 1, 2, 0,
2739 doc
: /* Return t if FEATURE is present in this Emacs.
2741 Use this to conditionalize execution of lisp code based on the
2742 presence or absence of Emacs or environment extensions.
2743 Use `provide' to declare that a feature is available. This function
2744 looks at the value of the variable `features'. The optional argument
2745 SUBFEATURE can be used to check a specific subfeature of FEATURE. */)
2746 (Lisp_Object feature
, Lisp_Object subfeature
)
2748 register Lisp_Object tem
;
2749 CHECK_SYMBOL (feature
);
2750 tem
= Fmemq (feature
, Vfeatures
);
2751 if (!NILP (tem
) && !NILP (subfeature
))
2752 tem
= Fmember (subfeature
, Fget (feature
, Qsubfeatures
));
2753 return (NILP (tem
)) ? Qnil
: Qt
;
2756 DEFUN ("provide", Fprovide
, Sprovide
, 1, 2, 0,
2757 doc
: /* Announce that FEATURE is a feature of the current Emacs.
2758 The optional argument SUBFEATURES should be a list of symbols listing
2759 particular subfeatures supported in this version of FEATURE. */)
2760 (Lisp_Object feature
, Lisp_Object subfeatures
)
2762 register Lisp_Object tem
;
2763 CHECK_SYMBOL (feature
);
2764 CHECK_LIST (subfeatures
);
2765 if (!NILP (Vautoload_queue
))
2766 Vautoload_queue
= Fcons (Fcons (make_number (0), Vfeatures
),
2768 tem
= Fmemq (feature
, Vfeatures
);
2770 Vfeatures
= Fcons (feature
, Vfeatures
);
2771 if (!NILP (subfeatures
))
2772 Fput (feature
, Qsubfeatures
, subfeatures
);
2773 LOADHIST_ATTACH (Fcons (Qprovide
, feature
));
2775 /* Run any load-hooks for this file. */
2776 tem
= Fassq (feature
, Vafter_load_alist
);
2778 Fmapc (Qfuncall
, XCDR (tem
));
2783 /* `require' and its subroutines. */
2785 /* List of features currently being require'd, innermost first. */
2787 static Lisp_Object require_nesting_list
;
2790 require_unwind (Lisp_Object old_value
)
2792 require_nesting_list
= old_value
;
2795 DEFUN ("require", Frequire
, Srequire
, 1, 3, 0,
2796 doc
: /* If feature FEATURE is not loaded, load it from FILENAME.
2797 If FEATURE is not a member of the list `features', then the feature is
2798 not loaded; so load the file FILENAME.
2800 If FILENAME is omitted, the printname of FEATURE is used as the file
2801 name, and `load' will try to load this name appended with the suffix
2802 `.elc', `.el', or the system-dependent suffix for dynamic module
2803 files, in that order. The name without appended suffix will not be
2804 used. See `get-load-suffixes' for the complete list of suffixes.
2806 The directories in `load-path' are searched when trying to find the
2809 If the optional third argument NOERROR is non-nil, then return nil if
2810 the file is not found instead of signaling an error. Normally the
2811 return value is FEATURE.
2813 The normal messages at start and end of loading FILENAME are
2815 (Lisp_Object feature
, Lisp_Object filename
, Lisp_Object noerror
)
2818 bool from_file
= load_in_progress
;
2820 CHECK_SYMBOL (feature
);
2822 /* Record the presence of `require' in this file
2823 even if the feature specified is already loaded.
2824 But not more than once in any file,
2825 and not when we aren't loading or reading from a file. */
2827 for (tem
= Vcurrent_load_list
; CONSP (tem
); tem
= XCDR (tem
))
2828 if (NILP (XCDR (tem
)) && STRINGP (XCAR (tem
)))
2833 tem
= Fcons (Qrequire
, feature
);
2834 if (NILP (Fmember (tem
, Vcurrent_load_list
)))
2835 LOADHIST_ATTACH (tem
);
2837 tem
= Fmemq (feature
, Vfeatures
);
2841 ptrdiff_t count
= SPECPDL_INDEX ();
2844 /* This is to make sure that loadup.el gives a clear picture
2845 of what files are preloaded and when. */
2846 if (! NILP (Vpurify_flag
))
2847 error ("(require %s) while preparing to dump",
2848 SDATA (SYMBOL_NAME (feature
)));
2850 /* A certain amount of recursive `require' is legitimate,
2851 but if we require the same feature recursively 3 times,
2853 tem
= require_nesting_list
;
2854 while (! NILP (tem
))
2856 if (! NILP (Fequal (feature
, XCAR (tem
))))
2861 error ("Recursive `require' for feature `%s'",
2862 SDATA (SYMBOL_NAME (feature
)));
2864 /* Update the list for any nested `require's that occur. */
2865 record_unwind_protect (require_unwind
, require_nesting_list
);
2866 require_nesting_list
= Fcons (feature
, require_nesting_list
);
2868 /* Value saved here is to be restored into Vautoload_queue */
2869 record_unwind_protect (un_autoload
, Vautoload_queue
);
2870 Vautoload_queue
= Qt
;
2872 /* Load the file. */
2873 tem
= Fload (NILP (filename
) ? Fsymbol_name (feature
) : filename
,
2874 noerror
, Qt
, Qnil
, (NILP (filename
) ? Qt
: Qnil
));
2876 /* If load failed entirely, return nil. */
2878 return unbind_to (count
, Qnil
);
2880 tem
= Fmemq (feature
, Vfeatures
);
2883 unsigned char *tem2
= SDATA (SYMBOL_NAME (feature
));
2884 Lisp_Object tem3
= Fcar (Fcar (Vload_history
));
2887 error ("Required feature `%s' was not provided", tem2
);
2889 /* Cf autoload-do-load. */
2890 error ("Loading file %s failed to provide feature `%s'",
2891 SDATA (tem3
), tem2
);
2894 /* Once loading finishes, don't undo it. */
2895 Vautoload_queue
= Qt
;
2896 feature
= unbind_to (count
, feature
);
2902 /* Primitives for work of the "widget" library.
2903 In an ideal world, this section would not have been necessary.
2904 However, lisp function calls being as slow as they are, it turns
2905 out that some functions in the widget library (wid-edit.el) are the
2906 bottleneck of Widget operation. Here is their translation to C,
2907 for the sole reason of efficiency. */
2909 DEFUN ("plist-member", Fplist_member
, Splist_member
, 2, 2, 0,
2910 doc
: /* Return non-nil if PLIST has the property PROP.
2911 PLIST is a property list, which is a list of the form
2912 \(PROP1 VALUE1 PROP2 VALUE2 ...). PROP is a symbol.
2913 Unlike `plist-get', this allows you to distinguish between a missing
2914 property and a property with the value nil.
2915 The value is actually the tail of PLIST whose car is PROP. */)
2916 (Lisp_Object plist
, Lisp_Object prop
)
2918 Lisp_Object tail
= plist
;
2919 FOR_EACH_TAIL (tail
)
2921 if (EQ (XCAR (tail
), prop
))
2926 if (EQ (tail
, li
.tortoise
))
2927 circular_list (tail
);
2929 CHECK_TYPE (NILP (tail
), Qplistp
, plist
);
2933 DEFUN ("widget-put", Fwidget_put
, Swidget_put
, 3, 3, 0,
2934 doc
: /* In WIDGET, set PROPERTY to VALUE.
2935 The value can later be retrieved with `widget-get'. */)
2936 (Lisp_Object widget
, Lisp_Object property
, Lisp_Object value
)
2938 CHECK_CONS (widget
);
2939 XSETCDR (widget
, Fplist_put (XCDR (widget
), property
, value
));
2943 DEFUN ("widget-get", Fwidget_get
, Swidget_get
, 2, 2, 0,
2944 doc
: /* In WIDGET, get the value of PROPERTY.
2945 The value could either be specified when the widget was created, or
2946 later with `widget-put'. */)
2947 (Lisp_Object widget
, Lisp_Object property
)
2955 CHECK_CONS (widget
);
2956 tmp
= Fplist_member (XCDR (widget
), property
);
2962 tmp
= XCAR (widget
);
2965 widget
= Fget (tmp
, Qwidget_type
);
2969 DEFUN ("widget-apply", Fwidget_apply
, Swidget_apply
, 2, MANY
, 0,
2970 doc
: /* Apply the value of WIDGET's PROPERTY to the widget itself.
2971 ARGS are passed as extra arguments to the function.
2972 usage: (widget-apply WIDGET PROPERTY &rest ARGS) */)
2973 (ptrdiff_t nargs
, Lisp_Object
*args
)
2975 Lisp_Object widget
= args
[0];
2976 Lisp_Object property
= args
[1];
2977 Lisp_Object propval
= Fwidget_get (widget
, property
);
2978 Lisp_Object trailing_args
= Flist (nargs
- 2, args
+ 2);
2979 Lisp_Object result
= CALLN (Fapply
, propval
, widget
, trailing_args
);
2983 #ifdef HAVE_LANGINFO_CODESET
2984 #include <langinfo.h>
2987 DEFUN ("locale-info", Flocale_info
, Slocale_info
, 1, 1, 0,
2988 doc
: /* Access locale data ITEM for the current C locale, if available.
2989 ITEM should be one of the following:
2991 `codeset', returning the character set as a string (locale item CODESET);
2993 `days', returning a 7-element vector of day names (locale items DAY_n);
2995 `months', returning a 12-element vector of month names (locale items MON_n);
2997 `paper', returning a list (WIDTH HEIGHT) for the default paper size,
2998 both measured in millimeters (locale items PAPER_WIDTH, PAPER_HEIGHT).
3000 If the system can't provide such information through a call to
3001 `nl_langinfo', or if ITEM isn't from the list above, return nil.
3003 See also Info node `(libc)Locales'.
3005 The data read from the system are decoded using `locale-coding-system'. */)
3009 #ifdef HAVE_LANGINFO_CODESET
3010 if (EQ (item
, Qcodeset
))
3012 str
= nl_langinfo (CODESET
);
3013 return build_string (str
);
3016 else if (EQ (item
, Qdays
)) /* e.g. for calendar-day-name-array */
3018 Lisp_Object v
= Fmake_vector (make_number (7), Qnil
);
3019 const int days
[7] = {DAY_1
, DAY_2
, DAY_3
, DAY_4
, DAY_5
, DAY_6
, DAY_7
};
3021 synchronize_system_time_locale ();
3022 for (i
= 0; i
< 7; i
++)
3024 str
= nl_langinfo (days
[i
]);
3025 AUTO_STRING (val
, str
);
3026 /* Fixme: Is this coding system necessarily right, even if
3027 it is consistent with CODESET? If not, what to do? */
3028 ASET (v
, i
, code_convert_string_norecord (val
, Vlocale_coding_system
,
3035 else if (EQ (item
, Qmonths
)) /* e.g. for calendar-month-name-array */
3037 Lisp_Object v
= Fmake_vector (make_number (12), Qnil
);
3038 const int months
[12] = {MON_1
, MON_2
, MON_3
, MON_4
, MON_5
, MON_6
, MON_7
,
3039 MON_8
, MON_9
, MON_10
, MON_11
, MON_12
};
3041 synchronize_system_time_locale ();
3042 for (i
= 0; i
< 12; i
++)
3044 str
= nl_langinfo (months
[i
]);
3045 AUTO_STRING (val
, str
);
3046 ASET (v
, i
, code_convert_string_norecord (val
, Vlocale_coding_system
,
3052 /* LC_PAPER stuff isn't defined as accessible in glibc as of 2.3.1,
3053 but is in the locale files. This could be used by ps-print. */
3055 else if (EQ (item
, Qpaper
))
3056 return list2i (nl_langinfo (PAPER_WIDTH
), nl_langinfo (PAPER_HEIGHT
));
3057 #endif /* PAPER_WIDTH */
3058 #endif /* HAVE_LANGINFO_CODESET*/
3062 /* base64 encode/decode functions (RFC 2045).
3063 Based on code from GNU recode. */
3065 #define MIME_LINE_LENGTH 76
3067 #define IS_ASCII(Character) \
3069 #define IS_BASE64(Character) \
3070 (IS_ASCII (Character) && base64_char_to_value[Character] >= 0)
3071 #define IS_BASE64_IGNORABLE(Character) \
3072 ((Character) == ' ' || (Character) == '\t' || (Character) == '\n' \
3073 || (Character) == '\f' || (Character) == '\r')
3075 /* Used by base64_decode_1 to retrieve a non-base64-ignorable
3076 character or return retval if there are no characters left to
3078 #define READ_QUADRUPLET_BYTE(retval) \
3083 if (nchars_return) \
3084 *nchars_return = nchars; \
3089 while (IS_BASE64_IGNORABLE (c))
3091 /* Table of characters coding the 64 values. */
3092 static const char base64_value_to_char
[64] =
3094 'A', 'B', 'C', 'D', 'E', 'F', 'G', 'H', 'I', 'J', /* 0- 9 */
3095 'K', 'L', 'M', 'N', 'O', 'P', 'Q', 'R', 'S', 'T', /* 10-19 */
3096 'U', 'V', 'W', 'X', 'Y', 'Z', 'a', 'b', 'c', 'd', /* 20-29 */
3097 'e', 'f', 'g', 'h', 'i', 'j', 'k', 'l', 'm', 'n', /* 30-39 */
3098 'o', 'p', 'q', 'r', 's', 't', 'u', 'v', 'w', 'x', /* 40-49 */
3099 'y', 'z', '0', '1', '2', '3', '4', '5', '6', '7', /* 50-59 */
3100 '8', '9', '+', '/' /* 60-63 */
3103 /* Table of base64 values for first 128 characters. */
3104 static const short base64_char_to_value
[128] =
3106 -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, /* 0- 9 */
3107 -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, /* 10- 19 */
3108 -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, /* 20- 29 */
3109 -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, /* 30- 39 */
3110 -1, -1, -1, 62, -1, -1, -1, 63, 52, 53, /* 40- 49 */
3111 54, 55, 56, 57, 58, 59, 60, 61, -1, -1, /* 50- 59 */
3112 -1, -1, -1, -1, -1, 0, 1, 2, 3, 4, /* 60- 69 */
3113 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, /* 70- 79 */
3114 15, 16, 17, 18, 19, 20, 21, 22, 23, 24, /* 80- 89 */
3115 25, -1, -1, -1, -1, -1, -1, 26, 27, 28, /* 90- 99 */
3116 29, 30, 31, 32, 33, 34, 35, 36, 37, 38, /* 100-109 */
3117 39, 40, 41, 42, 43, 44, 45, 46, 47, 48, /* 110-119 */
3118 49, 50, 51, -1, -1, -1, -1, -1 /* 120-127 */
3121 /* The following diagram shows the logical steps by which three octets
3122 get transformed into four base64 characters.
3124 .--------. .--------. .--------.
3125 |aaaaaabb| |bbbbcccc| |ccdddddd|
3126 `--------' `--------' `--------'
3128 .--------+--------+--------+--------.
3129 |00aaaaaa|00bbbbbb|00cccccc|00dddddd|
3130 `--------+--------+--------+--------'
3132 .--------+--------+--------+--------.
3133 |AAAAAAAA|BBBBBBBB|CCCCCCCC|DDDDDDDD|
3134 `--------+--------+--------+--------'
3136 The octets are divided into 6 bit chunks, which are then encoded into
3137 base64 characters. */
3140 static ptrdiff_t base64_encode_1 (const char *, char *, ptrdiff_t, bool, bool);
3141 static ptrdiff_t base64_decode_1 (const char *, char *, ptrdiff_t, bool,
3144 DEFUN ("base64-encode-region", Fbase64_encode_region
, Sbase64_encode_region
,
3146 doc
: /* Base64-encode the region between BEG and END.
3147 Return the length of the encoded text.
3148 Optional third argument NO-LINE-BREAK means do not break long lines
3149 into shorter lines. */)
3150 (Lisp_Object beg
, Lisp_Object end
, Lisp_Object no_line_break
)
3153 ptrdiff_t allength
, length
;
3154 ptrdiff_t ibeg
, iend
, encoded_length
;
3155 ptrdiff_t old_pos
= PT
;
3158 validate_region (&beg
, &end
);
3160 ibeg
= CHAR_TO_BYTE (XFASTINT (beg
));
3161 iend
= CHAR_TO_BYTE (XFASTINT (end
));
3162 move_gap_both (XFASTINT (beg
), ibeg
);
3164 /* We need to allocate enough room for encoding the text.
3165 We need 33 1/3% more space, plus a newline every 76
3166 characters, and then we round up. */
3167 length
= iend
- ibeg
;
3168 allength
= length
+ length
/3 + 1;
3169 allength
+= allength
/ MIME_LINE_LENGTH
+ 1 + 6;
3171 encoded
= SAFE_ALLOCA (allength
);
3172 encoded_length
= base64_encode_1 ((char *) BYTE_POS_ADDR (ibeg
),
3173 encoded
, length
, NILP (no_line_break
),
3174 !NILP (BVAR (current_buffer
, enable_multibyte_characters
)));
3175 if (encoded_length
> allength
)
3178 if (encoded_length
< 0)
3180 /* The encoding wasn't possible. */
3182 error ("Multibyte character in data for base64 encoding");
3185 /* Now we have encoded the region, so we insert the new contents
3186 and delete the old. (Insert first in order to preserve markers.) */
3187 SET_PT_BOTH (XFASTINT (beg
), ibeg
);
3188 insert (encoded
, encoded_length
);
3190 del_range_byte (ibeg
+ encoded_length
, iend
+ encoded_length
);
3192 /* If point was outside of the region, restore it exactly; else just
3193 move to the beginning of the region. */
3194 if (old_pos
>= XFASTINT (end
))
3195 old_pos
+= encoded_length
- (XFASTINT (end
) - XFASTINT (beg
));
3196 else if (old_pos
> XFASTINT (beg
))
3197 old_pos
= XFASTINT (beg
);
3200 /* We return the length of the encoded text. */
3201 return make_number (encoded_length
);
3204 DEFUN ("base64-encode-string", Fbase64_encode_string
, Sbase64_encode_string
,
3206 doc
: /* Base64-encode STRING and return the result.
3207 Optional second argument NO-LINE-BREAK means do not break long lines
3208 into shorter lines. */)
3209 (Lisp_Object string
, Lisp_Object no_line_break
)
3211 ptrdiff_t allength
, length
, encoded_length
;
3213 Lisp_Object encoded_string
;
3216 CHECK_STRING (string
);
3218 /* We need to allocate enough room for encoding the text.
3219 We need 33 1/3% more space, plus a newline every 76
3220 characters, and then we round up. */
3221 length
= SBYTES (string
);
3222 allength
= length
+ length
/3 + 1;
3223 allength
+= allength
/ MIME_LINE_LENGTH
+ 1 + 6;
3225 /* We need to allocate enough room for decoding the text. */
3226 encoded
= SAFE_ALLOCA (allength
);
3228 encoded_length
= base64_encode_1 (SSDATA (string
),
3229 encoded
, length
, NILP (no_line_break
),
3230 STRING_MULTIBYTE (string
));
3231 if (encoded_length
> allength
)
3234 if (encoded_length
< 0)
3236 /* The encoding wasn't possible. */
3237 error ("Multibyte character in data for base64 encoding");
3240 encoded_string
= make_unibyte_string (encoded
, encoded_length
);
3243 return encoded_string
;
3247 base64_encode_1 (const char *from
, char *to
, ptrdiff_t length
,
3248 bool line_break
, bool multibyte
)
3261 c
= STRING_CHAR_AND_LENGTH ((unsigned char *) from
+ i
, bytes
);
3262 if (CHAR_BYTE8_P (c
))
3263 c
= CHAR_TO_BYTE8 (c
);
3271 /* Wrap line every 76 characters. */
3275 if (counter
< MIME_LINE_LENGTH
/ 4)
3284 /* Process first byte of a triplet. */
3286 *e
++ = base64_value_to_char
[0x3f & c
>> 2];
3287 value
= (0x03 & c
) << 4;
3289 /* Process second byte of a triplet. */
3293 *e
++ = base64_value_to_char
[value
];
3301 c
= STRING_CHAR_AND_LENGTH ((unsigned char *) from
+ i
, bytes
);
3302 if (CHAR_BYTE8_P (c
))
3303 c
= CHAR_TO_BYTE8 (c
);
3311 *e
++ = base64_value_to_char
[value
| (0x0f & c
>> 4)];
3312 value
= (0x0f & c
) << 2;
3314 /* Process third byte of a triplet. */
3318 *e
++ = base64_value_to_char
[value
];
3325 c
= STRING_CHAR_AND_LENGTH ((unsigned char *) from
+ i
, bytes
);
3326 if (CHAR_BYTE8_P (c
))
3327 c
= CHAR_TO_BYTE8 (c
);
3335 *e
++ = base64_value_to_char
[value
| (0x03 & c
>> 6)];
3336 *e
++ = base64_value_to_char
[0x3f & c
];
3343 DEFUN ("base64-decode-region", Fbase64_decode_region
, Sbase64_decode_region
,
3345 doc
: /* Base64-decode the region between BEG and END.
3346 Return the length of the decoded text.
3347 If the region can't be decoded, signal an error and don't modify the buffer. */)
3348 (Lisp_Object beg
, Lisp_Object end
)
3350 ptrdiff_t ibeg
, iend
, length
, allength
;
3352 ptrdiff_t old_pos
= PT
;
3353 ptrdiff_t decoded_length
;
3354 ptrdiff_t inserted_chars
;
3355 bool multibyte
= !NILP (BVAR (current_buffer
, enable_multibyte_characters
));
3358 validate_region (&beg
, &end
);
3360 ibeg
= CHAR_TO_BYTE (XFASTINT (beg
));
3361 iend
= CHAR_TO_BYTE (XFASTINT (end
));
3363 length
= iend
- ibeg
;
3365 /* We need to allocate enough room for decoding the text. If we are
3366 working on a multibyte buffer, each decoded code may occupy at
3368 allength
= multibyte
? length
* 2 : length
;
3369 decoded
= SAFE_ALLOCA (allength
);
3371 move_gap_both (XFASTINT (beg
), ibeg
);
3372 decoded_length
= base64_decode_1 ((char *) BYTE_POS_ADDR (ibeg
),
3374 multibyte
, &inserted_chars
);
3375 if (decoded_length
> allength
)
3378 if (decoded_length
< 0)
3380 /* The decoding wasn't possible. */
3381 error ("Invalid base64 data");
3384 /* Now we have decoded the region, so we insert the new contents
3385 and delete the old. (Insert first in order to preserve markers.) */
3386 TEMP_SET_PT_BOTH (XFASTINT (beg
), ibeg
);
3387 insert_1_both (decoded
, inserted_chars
, decoded_length
, 0, 1, 0);
3388 signal_after_change (XFASTINT (beg
), 0, inserted_chars
);
3391 /* Delete the original text. */
3392 del_range_both (PT
, PT_BYTE
, XFASTINT (end
) + inserted_chars
,
3393 iend
+ decoded_length
, 1);
3395 /* If point was outside of the region, restore it exactly; else just
3396 move to the beginning of the region. */
3397 if (old_pos
>= XFASTINT (end
))
3398 old_pos
+= inserted_chars
- (XFASTINT (end
) - XFASTINT (beg
));
3399 else if (old_pos
> XFASTINT (beg
))
3400 old_pos
= XFASTINT (beg
);
3401 SET_PT (old_pos
> ZV
? ZV
: old_pos
);
3403 return make_number (inserted_chars
);
3406 DEFUN ("base64-decode-string", Fbase64_decode_string
, Sbase64_decode_string
,
3408 doc
: /* Base64-decode STRING and return the result. */)
3409 (Lisp_Object string
)
3412 ptrdiff_t length
, decoded_length
;
3413 Lisp_Object decoded_string
;
3416 CHECK_STRING (string
);
3418 length
= SBYTES (string
);
3419 /* We need to allocate enough room for decoding the text. */
3420 decoded
= SAFE_ALLOCA (length
);
3422 /* The decoded result should be unibyte. */
3423 decoded_length
= base64_decode_1 (SSDATA (string
), decoded
, length
,
3425 if (decoded_length
> length
)
3427 else if (decoded_length
>= 0)
3428 decoded_string
= make_unibyte_string (decoded
, decoded_length
);
3430 decoded_string
= Qnil
;
3433 if (!STRINGP (decoded_string
))
3434 error ("Invalid base64 data");
3436 return decoded_string
;
3439 /* Base64-decode the data at FROM of LENGTH bytes into TO. If
3440 MULTIBYTE, the decoded result should be in multibyte
3441 form. If NCHARS_RETURN is not NULL, store the number of produced
3442 characters in *NCHARS_RETURN. */
3445 base64_decode_1 (const char *from
, char *to
, ptrdiff_t length
,
3446 bool multibyte
, ptrdiff_t *nchars_return
)
3448 ptrdiff_t i
= 0; /* Used inside READ_QUADRUPLET_BYTE */
3451 unsigned long value
;
3452 ptrdiff_t nchars
= 0;
3456 /* Process first byte of a quadruplet. */
3458 READ_QUADRUPLET_BYTE (e
-to
);
3462 value
= base64_char_to_value
[c
] << 18;
3464 /* Process second byte of a quadruplet. */
3466 READ_QUADRUPLET_BYTE (-1);
3470 value
|= base64_char_to_value
[c
] << 12;
3472 c
= (unsigned char) (value
>> 16);
3473 if (multibyte
&& c
>= 128)
3474 e
+= BYTE8_STRING (c
, e
);
3479 /* Process third byte of a quadruplet. */
3481 READ_QUADRUPLET_BYTE (-1);
3485 READ_QUADRUPLET_BYTE (-1);
3494 value
|= base64_char_to_value
[c
] << 6;
3496 c
= (unsigned char) (0xff & value
>> 8);
3497 if (multibyte
&& c
>= 128)
3498 e
+= BYTE8_STRING (c
, e
);
3503 /* Process fourth byte of a quadruplet. */
3505 READ_QUADRUPLET_BYTE (-1);
3512 value
|= base64_char_to_value
[c
];
3514 c
= (unsigned char) (0xff & value
);
3515 if (multibyte
&& c
>= 128)
3516 e
+= BYTE8_STRING (c
, e
);
3525 /***********************************************************************
3527 ***** Hash Tables *****
3529 ***********************************************************************/
3531 /* Implemented by gerd@gnu.org. This hash table implementation was
3532 inspired by CMUCL hash tables. */
3536 1. For small tables, association lists are probably faster than
3537 hash tables because they have lower overhead.
3539 For uses of hash tables where the O(1) behavior of table
3540 operations is not a requirement, it might therefore be a good idea
3541 not to hash. Instead, we could just do a linear search in the
3542 key_and_value vector of the hash table. This could be done
3543 if a `:linear-search t' argument is given to make-hash-table. */
3546 /* The list of all weak hash tables. Don't staticpro this one. */
3548 static struct Lisp_Hash_Table
*weak_hash_tables
;
3551 /***********************************************************************
3553 ***********************************************************************/
3556 CHECK_HASH_TABLE (Lisp_Object x
)
3558 CHECK_TYPE (HASH_TABLE_P (x
), Qhash_table_p
, x
);
3562 set_hash_key_and_value (struct Lisp_Hash_Table
*h
, Lisp_Object key_and_value
)
3564 h
->key_and_value
= key_and_value
;
3567 set_hash_next (struct Lisp_Hash_Table
*h
, Lisp_Object next
)
3572 set_hash_next_slot (struct Lisp_Hash_Table
*h
, ptrdiff_t idx
, ptrdiff_t val
)
3574 gc_aset (h
->next
, idx
, make_number (val
));
3577 set_hash_hash (struct Lisp_Hash_Table
*h
, Lisp_Object hash
)
3582 set_hash_hash_slot (struct Lisp_Hash_Table
*h
, ptrdiff_t idx
, Lisp_Object val
)
3584 gc_aset (h
->hash
, idx
, val
);
3587 set_hash_index (struct Lisp_Hash_Table
*h
, Lisp_Object index
)
3592 set_hash_index_slot (struct Lisp_Hash_Table
*h
, ptrdiff_t idx
, ptrdiff_t val
)
3594 gc_aset (h
->index
, idx
, make_number (val
));
3597 /* If OBJ is a Lisp hash table, return a pointer to its struct
3598 Lisp_Hash_Table. Otherwise, signal an error. */
3600 static struct Lisp_Hash_Table
*
3601 check_hash_table (Lisp_Object obj
)
3603 CHECK_HASH_TABLE (obj
);
3604 return XHASH_TABLE (obj
);
3608 /* Value is the next integer I >= N, N >= 0 which is "almost" a prime
3609 number. A number is "almost" a prime number if it is not divisible
3610 by any integer in the range 2 .. (NEXT_ALMOST_PRIME_LIMIT - 1). */
3613 next_almost_prime (EMACS_INT n
)
3615 verify (NEXT_ALMOST_PRIME_LIMIT
== 11);
3616 for (n
|= 1; ; n
+= 2)
3617 if (n
% 3 != 0 && n
% 5 != 0 && n
% 7 != 0)
3622 /* Find KEY in ARGS which has size NARGS. Don't consider indices for
3623 which USED[I] is non-zero. If found at index I in ARGS, set
3624 USED[I] and USED[I + 1] to 1, and return I + 1. Otherwise return
3625 0. This function is used to extract a keyword/argument pair from
3626 a DEFUN parameter list. */
3629 get_key_arg (Lisp_Object key
, ptrdiff_t nargs
, Lisp_Object
*args
, char *used
)
3633 for (i
= 1; i
< nargs
; i
++)
3634 if (!used
[i
- 1] && EQ (args
[i
- 1], key
))
3645 /* Return a Lisp vector which has the same contents as VEC but has
3646 at least INCR_MIN more entries, where INCR_MIN is positive.
3647 If NITEMS_MAX is not -1, do not grow the vector to be any larger
3648 than NITEMS_MAX. New entries in the resulting vector are
3652 larger_vecalloc (Lisp_Object vec
, ptrdiff_t incr_min
, ptrdiff_t nitems_max
)
3654 struct Lisp_Vector
*v
;
3655 ptrdiff_t incr
, incr_max
, old_size
, new_size
;
3656 ptrdiff_t C_language_max
= min (PTRDIFF_MAX
, SIZE_MAX
) / sizeof *v
->contents
;
3657 ptrdiff_t n_max
= (0 <= nitems_max
&& nitems_max
< C_language_max
3658 ? nitems_max
: C_language_max
);
3659 eassert (VECTORP (vec
));
3660 eassert (0 < incr_min
&& -1 <= nitems_max
);
3661 old_size
= ASIZE (vec
);
3662 incr_max
= n_max
- old_size
;
3663 incr
= max (incr_min
, min (old_size
>> 1, incr_max
));
3664 if (incr_max
< incr
)
3665 memory_full (SIZE_MAX
);
3666 new_size
= old_size
+ incr
;
3667 v
= allocate_vector (new_size
);
3668 memcpy (v
->contents
, XVECTOR (vec
)->contents
, old_size
* sizeof *v
->contents
);
3669 XSETVECTOR (vec
, v
);
3673 /* Likewise, except set new entries in the resulting vector to nil. */
3676 larger_vector (Lisp_Object vec
, ptrdiff_t incr_min
, ptrdiff_t nitems_max
)
3678 ptrdiff_t old_size
= ASIZE (vec
);
3679 Lisp_Object v
= larger_vecalloc (vec
, incr_min
, nitems_max
);
3680 ptrdiff_t new_size
= ASIZE (v
);
3681 memclear (XVECTOR (v
)->contents
+ old_size
,
3682 (new_size
- old_size
) * word_size
);
3687 /***********************************************************************
3689 ***********************************************************************/
3691 /* Return the index of the next entry in H following the one at IDX,
3695 HASH_NEXT (struct Lisp_Hash_Table
*h
, ptrdiff_t idx
)
3697 return XINT (AREF (h
->next
, idx
));
3700 /* Return the index of the element in hash table H that is the start
3701 of the collision list at index IDX, or -1 if the list is empty. */
3704 HASH_INDEX (struct Lisp_Hash_Table
*h
, ptrdiff_t idx
)
3706 return XINT (AREF (h
->index
, idx
));
3709 /* Compare KEY1 which has hash code HASH1 and KEY2 with hash code
3710 HASH2 in hash table H using `eql'. Value is true if KEY1 and
3711 KEY2 are the same. */
3714 cmpfn_eql (struct hash_table_test
*ht
,
3718 return (FLOATP (key1
)
3720 && XFLOAT_DATA (key1
) == XFLOAT_DATA (key2
));
3724 /* Compare KEY1 which has hash code HASH1 and KEY2 with hash code
3725 HASH2 in hash table H using `equal'. Value is true if KEY1 and
3726 KEY2 are the same. */
3729 cmpfn_equal (struct hash_table_test
*ht
,
3733 return !NILP (Fequal (key1
, key2
));
3737 /* Compare KEY1 which has hash code HASH1, and KEY2 with hash code
3738 HASH2 in hash table H using H->user_cmp_function. Value is true
3739 if KEY1 and KEY2 are the same. */
3742 cmpfn_user_defined (struct hash_table_test
*ht
,
3746 return !NILP (call2 (ht
->user_cmp_function
, key1
, key2
));
3749 /* Value is a hash code for KEY for use in hash table H which uses
3750 `eq' to compare keys. The hash code returned is guaranteed to fit
3751 in a Lisp integer. */
3754 hashfn_eq (struct hash_table_test
*ht
, Lisp_Object key
)
3756 return XHASH (key
) ^ XTYPE (key
);
3759 /* Value is a hash code for KEY for use in hash table H which uses
3760 `equal' to compare keys. The hash code returned is guaranteed to fit
3761 in a Lisp integer. */
3764 hashfn_equal (struct hash_table_test
*ht
, Lisp_Object key
)
3766 return sxhash (key
, 0);
3769 /* Value is a hash code for KEY for use in hash table H which uses
3770 `eql' to compare keys. The hash code returned is guaranteed to fit
3771 in a Lisp integer. */
3774 hashfn_eql (struct hash_table_test
*ht
, Lisp_Object key
)
3776 return FLOATP (key
) ? hashfn_equal (ht
, key
) : hashfn_eq (ht
, key
);
3779 /* Value is a hash code for KEY for use in hash table H which uses as
3780 user-defined function to compare keys. The hash code returned is
3781 guaranteed to fit in a Lisp integer. */
3784 hashfn_user_defined (struct hash_table_test
*ht
, Lisp_Object key
)
3786 Lisp_Object hash
= call1 (ht
->user_hash_function
, key
);
3787 return hashfn_eq (ht
, hash
);
3790 struct hash_table_test
const
3791 hashtest_eq
= { LISPSYM_INITIALLY (Qeq
), LISPSYM_INITIALLY (Qnil
),
3792 LISPSYM_INITIALLY (Qnil
), 0, hashfn_eq
},
3793 hashtest_eql
= { LISPSYM_INITIALLY (Qeql
), LISPSYM_INITIALLY (Qnil
),
3794 LISPSYM_INITIALLY (Qnil
), cmpfn_eql
, hashfn_eql
},
3795 hashtest_equal
= { LISPSYM_INITIALLY (Qequal
), LISPSYM_INITIALLY (Qnil
),
3796 LISPSYM_INITIALLY (Qnil
), cmpfn_equal
, hashfn_equal
};
3798 /* Allocate basically initialized hash table. */
3800 static struct Lisp_Hash_Table
*
3801 allocate_hash_table (void)
3803 return ALLOCATE_PSEUDOVECTOR (struct Lisp_Hash_Table
,
3804 count
, PVEC_HASH_TABLE
);
3807 /* An upper bound on the size of a hash table index. It must fit in
3808 ptrdiff_t and be a valid Emacs fixnum. */
3809 #define INDEX_SIZE_BOUND \
3810 ((ptrdiff_t) min (MOST_POSITIVE_FIXNUM, PTRDIFF_MAX / word_size))
3812 /* Create and initialize a new hash table.
3814 TEST specifies the test the hash table will use to compare keys.
3815 It must be either one of the predefined tests `eq', `eql' or
3816 `equal' or a symbol denoting a user-defined test named TEST with
3817 test and hash functions USER_TEST and USER_HASH.
3819 Give the table initial capacity SIZE, 0 <= SIZE <= MOST_POSITIVE_FIXNUM.
3821 If REHASH_SIZE is equal to a negative integer, this hash table's
3822 new size when it becomes full is computed by subtracting
3823 REHASH_SIZE from its old size. Otherwise it must be positive, and
3824 the table's new size is computed by multiplying its old size by
3827 REHASH_THRESHOLD must be a float <= 1.0, and > 0. The table will
3828 be resized when the approximate ratio of table entries to table
3829 size exceeds REHASH_THRESHOLD.
3831 WEAK specifies the weakness of the table. If non-nil, it must be
3832 one of the symbols `key', `value', `key-or-value', or `key-and-value'.
3834 If PURECOPY is non-nil, the table can be copied to pure storage via
3835 `purecopy' when Emacs is being dumped. Such tables can no longer be
3836 changed after purecopy. */
3839 make_hash_table (struct hash_table_test test
, EMACS_INT size
,
3840 float rehash_size
, float rehash_threshold
,
3841 Lisp_Object weak
, bool pure
)
3843 struct Lisp_Hash_Table
*h
;
3845 EMACS_INT index_size
;
3849 /* Preconditions. */
3850 eassert (SYMBOLP (test
.name
));
3851 eassert (0 <= size
&& size
<= MOST_POSITIVE_FIXNUM
);
3852 eassert (rehash_size
<= -1 || 0 < rehash_size
);
3853 eassert (0 < rehash_threshold
&& rehash_threshold
<= 1);
3858 double threshold
= rehash_threshold
;
3859 index_float
= size
/ threshold
;
3860 index_size
= (index_float
< INDEX_SIZE_BOUND
+ 1
3861 ? next_almost_prime (index_float
)
3862 : INDEX_SIZE_BOUND
+ 1);
3863 if (INDEX_SIZE_BOUND
< max (index_size
, 2 * size
))
3864 error ("Hash table too large");
3866 /* Allocate a table and initialize it. */
3867 h
= allocate_hash_table ();
3869 /* Initialize hash table slots. */
3872 h
->rehash_threshold
= rehash_threshold
;
3873 h
->rehash_size
= rehash_size
;
3875 h
->key_and_value
= Fmake_vector (make_number (2 * size
), Qnil
);
3876 h
->hash
= Fmake_vector (make_number (size
), Qnil
);
3877 h
->next
= Fmake_vector (make_number (size
), make_number (-1));
3878 h
->index
= Fmake_vector (make_number (index_size
), make_number (-1));
3881 /* Set up the free list. */
3882 for (i
= 0; i
< size
- 1; ++i
)
3883 set_hash_next_slot (h
, i
, i
+ 1);
3886 XSET_HASH_TABLE (table
, h
);
3887 eassert (HASH_TABLE_P (table
));
3888 eassert (XHASH_TABLE (table
) == h
);
3890 /* Maybe add this hash table to the list of all weak hash tables. */
3893 h
->next_weak
= weak_hash_tables
;
3894 weak_hash_tables
= h
;
3901 /* Return a copy of hash table H1. Keys and values are not copied,
3902 only the table itself is. */
3905 copy_hash_table (struct Lisp_Hash_Table
*h1
)
3908 struct Lisp_Hash_Table
*h2
;
3910 h2
= allocate_hash_table ();
3912 h2
->key_and_value
= Fcopy_sequence (h1
->key_and_value
);
3913 h2
->hash
= Fcopy_sequence (h1
->hash
);
3914 h2
->next
= Fcopy_sequence (h1
->next
);
3915 h2
->index
= Fcopy_sequence (h1
->index
);
3916 XSET_HASH_TABLE (table
, h2
);
3918 /* Maybe add this hash table to the list of all weak hash tables. */
3919 if (!NILP (h2
->weak
))
3921 h2
->next_weak
= h1
->next_weak
;
3929 /* Resize hash table H if it's too full. If H cannot be resized
3930 because it's already too large, throw an error. */
3933 maybe_resize_hash_table (struct Lisp_Hash_Table
*h
)
3935 if (h
->next_free
< 0)
3937 ptrdiff_t old_size
= HASH_TABLE_SIZE (h
);
3938 EMACS_INT new_size
, index_size
, nsize
;
3940 double rehash_size
= h
->rehash_size
;
3943 if (rehash_size
< 0)
3944 new_size
= old_size
- rehash_size
;
3947 double float_new_size
= old_size
* (rehash_size
+ 1);
3948 if (float_new_size
< INDEX_SIZE_BOUND
+ 1)
3949 new_size
= float_new_size
;
3951 new_size
= INDEX_SIZE_BOUND
+ 1;
3953 if (new_size
<= old_size
)
3954 new_size
= old_size
+ 1;
3955 double threshold
= h
->rehash_threshold
;
3956 index_float
= new_size
/ threshold
;
3957 index_size
= (index_float
< INDEX_SIZE_BOUND
+ 1
3958 ? next_almost_prime (index_float
)
3959 : INDEX_SIZE_BOUND
+ 1);
3960 nsize
= max (index_size
, 2 * new_size
);
3961 if (INDEX_SIZE_BOUND
< nsize
)
3962 error ("Hash table too large to resize");
3964 #ifdef ENABLE_CHECKING
3965 if (HASH_TABLE_P (Vpurify_flag
)
3966 && XHASH_TABLE (Vpurify_flag
) == h
)
3967 message ("Growing hash table to: %"pI
"d", new_size
);
3970 set_hash_key_and_value (h
, larger_vector (h
->key_and_value
,
3971 2 * (new_size
- old_size
), -1));
3972 set_hash_hash (h
, larger_vector (h
->hash
, new_size
- old_size
, -1));
3973 set_hash_index (h
, Fmake_vector (make_number (index_size
),
3975 set_hash_next (h
, larger_vecalloc (h
->next
, new_size
- old_size
, -1));
3977 /* Update the free list. Do it so that new entries are added at
3978 the end of the free list. This makes some operations like
3980 for (i
= old_size
; i
< new_size
- 1; ++i
)
3981 set_hash_next_slot (h
, i
, i
+ 1);
3982 set_hash_next_slot (h
, i
, -1);
3984 if (h
->next_free
< 0)
3985 h
->next_free
= old_size
;
3988 ptrdiff_t last
= h
->next_free
;
3991 ptrdiff_t next
= HASH_NEXT (h
, last
);
3996 set_hash_next_slot (h
, last
, old_size
);
4000 for (i
= 0; i
< old_size
; ++i
)
4001 if (!NILP (HASH_HASH (h
, i
)))
4003 EMACS_UINT hash_code
= XUINT (HASH_HASH (h
, i
));
4004 ptrdiff_t start_of_bucket
= hash_code
% ASIZE (h
->index
);
4005 set_hash_next_slot (h
, i
, HASH_INDEX (h
, start_of_bucket
));
4006 set_hash_index_slot (h
, start_of_bucket
, i
);
4012 /* Lookup KEY in hash table H. If HASH is non-null, return in *HASH
4013 the hash code of KEY. Value is the index of the entry in H
4014 matching KEY, or -1 if not found. */
4017 hash_lookup (struct Lisp_Hash_Table
*h
, Lisp_Object key
, EMACS_UINT
*hash
)
4019 EMACS_UINT hash_code
;
4020 ptrdiff_t start_of_bucket
, i
;
4022 hash_code
= h
->test
.hashfn (&h
->test
, key
);
4023 eassert ((hash_code
& ~INTMASK
) == 0);
4027 start_of_bucket
= hash_code
% ASIZE (h
->index
);
4029 for (i
= HASH_INDEX (h
, start_of_bucket
); 0 <= i
; i
= HASH_NEXT (h
, i
))
4030 if (EQ (key
, HASH_KEY (h
, i
))
4032 && hash_code
== XUINT (HASH_HASH (h
, i
))
4033 && h
->test
.cmpfn (&h
->test
, key
, HASH_KEY (h
, i
))))
4040 /* Put an entry into hash table H that associates KEY with VALUE.
4041 HASH is a previously computed hash code of KEY.
4042 Value is the index of the entry in H matching KEY. */
4045 hash_put (struct Lisp_Hash_Table
*h
, Lisp_Object key
, Lisp_Object value
,
4048 ptrdiff_t start_of_bucket
, i
;
4050 eassert ((hash
& ~INTMASK
) == 0);
4052 /* Increment count after resizing because resizing may fail. */
4053 maybe_resize_hash_table (h
);
4056 /* Store key/value in the key_and_value vector. */
4058 h
->next_free
= HASH_NEXT (h
, i
);
4059 set_hash_key_slot (h
, i
, key
);
4060 set_hash_value_slot (h
, i
, value
);
4062 /* Remember its hash code. */
4063 set_hash_hash_slot (h
, i
, make_number (hash
));
4065 /* Add new entry to its collision chain. */
4066 start_of_bucket
= hash
% ASIZE (h
->index
);
4067 set_hash_next_slot (h
, i
, HASH_INDEX (h
, start_of_bucket
));
4068 set_hash_index_slot (h
, start_of_bucket
, i
);
4073 /* Remove the entry matching KEY from hash table H, if there is one. */
4076 hash_remove_from_table (struct Lisp_Hash_Table
*h
, Lisp_Object key
)
4078 EMACS_UINT hash_code
= h
->test
.hashfn (&h
->test
, key
);
4079 eassert ((hash_code
& ~INTMASK
) == 0);
4080 ptrdiff_t start_of_bucket
= hash_code
% ASIZE (h
->index
);
4081 ptrdiff_t prev
= -1;
4083 for (ptrdiff_t i
= HASH_INDEX (h
, start_of_bucket
);
4085 i
= HASH_NEXT (h
, i
))
4087 if (EQ (key
, HASH_KEY (h
, i
))
4089 && hash_code
== XUINT (HASH_HASH (h
, i
))
4090 && h
->test
.cmpfn (&h
->test
, key
, HASH_KEY (h
, i
))))
4092 /* Take entry out of collision chain. */
4094 set_hash_index_slot (h
, start_of_bucket
, HASH_NEXT (h
, i
));
4096 set_hash_next_slot (h
, prev
, HASH_NEXT (h
, i
));
4098 /* Clear slots in key_and_value and add the slots to
4100 set_hash_key_slot (h
, i
, Qnil
);
4101 set_hash_value_slot (h
, i
, Qnil
);
4102 set_hash_hash_slot (h
, i
, Qnil
);
4103 set_hash_next_slot (h
, i
, h
->next_free
);
4106 eassert (h
->count
>= 0);
4115 /* Clear hash table H. */
4118 hash_clear (struct Lisp_Hash_Table
*h
)
4122 ptrdiff_t i
, size
= HASH_TABLE_SIZE (h
);
4124 for (i
= 0; i
< size
; ++i
)
4126 set_hash_next_slot (h
, i
, i
< size
- 1 ? i
+ 1 : -1);
4127 set_hash_key_slot (h
, i
, Qnil
);
4128 set_hash_value_slot (h
, i
, Qnil
);
4129 set_hash_hash_slot (h
, i
, Qnil
);
4132 for (i
= 0; i
< ASIZE (h
->index
); ++i
)
4133 ASET (h
->index
, i
, make_number (-1));
4142 /************************************************************************
4144 ************************************************************************/
4146 /* Sweep weak hash table H. REMOVE_ENTRIES_P means remove
4147 entries from the table that don't survive the current GC.
4148 !REMOVE_ENTRIES_P means mark entries that are in use. Value is
4149 true if anything was marked. */
4152 sweep_weak_table (struct Lisp_Hash_Table
*h
, bool remove_entries_p
)
4154 ptrdiff_t n
= gc_asize (h
->index
);
4155 bool marked
= false;
4157 for (ptrdiff_t bucket
= 0; bucket
< n
; ++bucket
)
4159 /* Follow collision chain, removing entries that
4160 don't survive this garbage collection. */
4161 ptrdiff_t prev
= -1;
4163 for (ptrdiff_t i
= HASH_INDEX (h
, bucket
); 0 <= i
; i
= next
)
4165 bool key_known_to_survive_p
= survives_gc_p (HASH_KEY (h
, i
));
4166 bool value_known_to_survive_p
= survives_gc_p (HASH_VALUE (h
, i
));
4169 if (EQ (h
->weak
, Qkey
))
4170 remove_p
= !key_known_to_survive_p
;
4171 else if (EQ (h
->weak
, Qvalue
))
4172 remove_p
= !value_known_to_survive_p
;
4173 else if (EQ (h
->weak
, Qkey_or_value
))
4174 remove_p
= !(key_known_to_survive_p
|| value_known_to_survive_p
);
4175 else if (EQ (h
->weak
, Qkey_and_value
))
4176 remove_p
= !(key_known_to_survive_p
&& value_known_to_survive_p
);
4180 next
= HASH_NEXT (h
, i
);
4182 if (remove_entries_p
)
4186 /* Take out of collision chain. */
4188 set_hash_index_slot (h
, bucket
, next
);
4190 set_hash_next_slot (h
, prev
, next
);
4192 /* Add to free list. */
4193 set_hash_next_slot (h
, i
, h
->next_free
);
4196 /* Clear key, value, and hash. */
4197 set_hash_key_slot (h
, i
, Qnil
);
4198 set_hash_value_slot (h
, i
, Qnil
);
4199 set_hash_hash_slot (h
, i
, Qnil
);
4212 /* Make sure key and value survive. */
4213 if (!key_known_to_survive_p
)
4215 mark_object (HASH_KEY (h
, i
));
4219 if (!value_known_to_survive_p
)
4221 mark_object (HASH_VALUE (h
, i
));
4232 /* Remove elements from weak hash tables that don't survive the
4233 current garbage collection. Remove weak tables that don't survive
4234 from Vweak_hash_tables. Called from gc_sweep. */
4236 NO_INLINE
/* For better stack traces */
4238 sweep_weak_hash_tables (void)
4240 struct Lisp_Hash_Table
*h
, *used
, *next
;
4243 /* Mark all keys and values that are in use. Keep on marking until
4244 there is no more change. This is necessary for cases like
4245 value-weak table A containing an entry X -> Y, where Y is used in a
4246 key-weak table B, Z -> Y. If B comes after A in the list of weak
4247 tables, X -> Y might be removed from A, although when looking at B
4248 one finds that it shouldn't. */
4252 for (h
= weak_hash_tables
; h
; h
= h
->next_weak
)
4254 if (h
->header
.size
& ARRAY_MARK_FLAG
)
4255 marked
|= sweep_weak_table (h
, 0);
4260 /* Remove tables and entries that aren't used. */
4261 for (h
= weak_hash_tables
, used
= NULL
; h
; h
= next
)
4263 next
= h
->next_weak
;
4265 if (h
->header
.size
& ARRAY_MARK_FLAG
)
4267 /* TABLE is marked as used. Sweep its contents. */
4269 sweep_weak_table (h
, 1);
4271 /* Add table to the list of used weak hash tables. */
4272 h
->next_weak
= used
;
4277 weak_hash_tables
= used
;
4282 /***********************************************************************
4283 Hash Code Computation
4284 ***********************************************************************/
4286 /* Maximum depth up to which to dive into Lisp structures. */
4288 #define SXHASH_MAX_DEPTH 3
4290 /* Maximum length up to which to take list and vector elements into
4293 #define SXHASH_MAX_LEN 7
4295 /* Return a hash for string PTR which has length LEN. The hash value
4296 can be any EMACS_UINT value. */
4299 hash_string (char const *ptr
, ptrdiff_t len
)
4301 char const *p
= ptr
;
4302 char const *end
= p
+ len
;
4304 EMACS_UINT hash
= 0;
4309 hash
= sxhash_combine (hash
, c
);
4315 /* Return a hash for string PTR which has length LEN. The hash
4316 code returned is guaranteed to fit in a Lisp integer. */
4319 sxhash_string (char const *ptr
, ptrdiff_t len
)
4321 EMACS_UINT hash
= hash_string (ptr
, len
);
4322 return SXHASH_REDUCE (hash
);
4325 /* Return a hash for the floating point value VAL. */
4328 sxhash_float (double val
)
4330 EMACS_UINT hash
= 0;
4332 WORDS_PER_DOUBLE
= (sizeof val
/ sizeof hash
4333 + (sizeof val
% sizeof hash
!= 0))
4337 EMACS_UINT word
[WORDS_PER_DOUBLE
];
4341 memset (&u
.val
+ 1, 0, sizeof u
- sizeof u
.val
);
4342 for (i
= 0; i
< WORDS_PER_DOUBLE
; i
++)
4343 hash
= sxhash_combine (hash
, u
.word
[i
]);
4344 return SXHASH_REDUCE (hash
);
4347 /* Return a hash for list LIST. DEPTH is the current depth in the
4348 list. We don't recurse deeper than SXHASH_MAX_DEPTH in it. */
4351 sxhash_list (Lisp_Object list
, int depth
)
4353 EMACS_UINT hash
= 0;
4356 if (depth
< SXHASH_MAX_DEPTH
)
4358 CONSP (list
) && i
< SXHASH_MAX_LEN
;
4359 list
= XCDR (list
), ++i
)
4361 EMACS_UINT hash2
= sxhash (XCAR (list
), depth
+ 1);
4362 hash
= sxhash_combine (hash
, hash2
);
4367 EMACS_UINT hash2
= sxhash (list
, depth
+ 1);
4368 hash
= sxhash_combine (hash
, hash2
);
4371 return SXHASH_REDUCE (hash
);
4375 /* Return a hash for (pseudo)vector VECTOR. DEPTH is the current depth in
4376 the Lisp structure. */
4379 sxhash_vector (Lisp_Object vec
, int depth
)
4381 EMACS_UINT hash
= ASIZE (vec
);
4384 n
= min (SXHASH_MAX_LEN
, hash
& PSEUDOVECTOR_FLAG
? PVSIZE (vec
) : hash
);
4385 for (i
= 0; i
< n
; ++i
)
4387 EMACS_UINT hash2
= sxhash (AREF (vec
, i
), depth
+ 1);
4388 hash
= sxhash_combine (hash
, hash2
);
4391 return SXHASH_REDUCE (hash
);
4394 /* Return a hash for bool-vector VECTOR. */
4397 sxhash_bool_vector (Lisp_Object vec
)
4399 EMACS_INT size
= bool_vector_size (vec
);
4400 EMACS_UINT hash
= size
;
4403 n
= min (SXHASH_MAX_LEN
, bool_vector_words (size
));
4404 for (i
= 0; i
< n
; ++i
)
4405 hash
= sxhash_combine (hash
, bool_vector_data (vec
)[i
]);
4407 return SXHASH_REDUCE (hash
);
4411 /* Return a hash code for OBJ. DEPTH is the current depth in the Lisp
4412 structure. Value is an unsigned integer clipped to INTMASK. */
4415 sxhash (Lisp_Object obj
, int depth
)
4419 if (depth
> SXHASH_MAX_DEPTH
)
4422 switch (XTYPE (obj
))
4434 hash
= sxhash_string (SSDATA (obj
), SBYTES (obj
));
4437 /* This can be everything from a vector to an overlay. */
4438 case Lisp_Vectorlike
:
4439 if (VECTORP (obj
) || RECORDP (obj
))
4440 /* According to the CL HyperSpec, two arrays are equal only if
4441 they are `eq', except for strings and bit-vectors. In
4442 Emacs, this works differently. We have to compare element
4443 by element. Same for records. */
4444 hash
= sxhash_vector (obj
, depth
);
4445 else if (BOOL_VECTOR_P (obj
))
4446 hash
= sxhash_bool_vector (obj
);
4448 /* Others are `equal' if they are `eq', so let's take their
4454 hash
= sxhash_list (obj
, depth
);
4458 hash
= sxhash_float (XFLOAT_DATA (obj
));
4470 /***********************************************************************
4472 ***********************************************************************/
4474 DEFUN ("sxhash-eq", Fsxhash_eq
, Ssxhash_eq
, 1, 1, 0,
4475 doc
: /* Return an integer hash code for OBJ suitable for `eq'.
4476 If (eq A B), then (= (sxhash-eq A) (sxhash-eq B)). */)
4479 return make_number (hashfn_eq (NULL
, obj
));
4482 DEFUN ("sxhash-eql", Fsxhash_eql
, Ssxhash_eql
, 1, 1, 0,
4483 doc
: /* Return an integer hash code for OBJ suitable for `eql'.
4484 If (eql A B), then (= (sxhash-eql A) (sxhash-eql B)). */)
4487 return make_number (hashfn_eql (NULL
, obj
));
4490 DEFUN ("sxhash-equal", Fsxhash_equal
, Ssxhash_equal
, 1, 1, 0,
4491 doc
: /* Return an integer hash code for OBJ suitable for `equal'.
4492 If (equal A B), then (= (sxhash-equal A) (sxhash-equal B)). */)
4495 return make_number (hashfn_equal (NULL
, obj
));
4498 DEFUN ("make-hash-table", Fmake_hash_table
, Smake_hash_table
, 0, MANY
, 0,
4499 doc
: /* Create and return a new hash table.
4501 Arguments are specified as keyword/argument pairs. The following
4502 arguments are defined:
4504 :test TEST -- TEST must be a symbol that specifies how to compare
4505 keys. Default is `eql'. Predefined are the tests `eq', `eql', and
4506 `equal'. User-supplied test and hash functions can be specified via
4507 `define-hash-table-test'.
4509 :size SIZE -- A hint as to how many elements will be put in the table.
4512 :rehash-size REHASH-SIZE - Indicates how to expand the table when it
4513 fills up. If REHASH-SIZE is an integer, increase the size by that
4514 amount. If it is a float, it must be > 1.0, and the new size is the
4515 old size multiplied by that factor. Default is 1.5.
4517 :rehash-threshold THRESHOLD -- THRESHOLD must a float > 0, and <= 1.0.
4518 Resize the hash table when the ratio (table entries / table size)
4519 exceeds an approximation to THRESHOLD. Default is 0.8125.
4521 :weakness WEAK -- WEAK must be one of nil, t, `key', `value',
4522 `key-or-value', or `key-and-value'. If WEAK is not nil, the table
4523 returned is a weak table. Key/value pairs are removed from a weak
4524 hash table when there are no non-weak references pointing to their
4525 key, value, one of key or value, or both key and value, depending on
4526 WEAK. WEAK t is equivalent to `key-and-value'. Default value of WEAK
4529 :purecopy PURECOPY -- If PURECOPY is non-nil, the table can be copied
4530 to pure storage when Emacs is being dumped, making the contents of the
4531 table read only. Any further changes to purified tables will result
4534 usage: (make-hash-table &rest KEYWORD-ARGS) */)
4535 (ptrdiff_t nargs
, Lisp_Object
*args
)
4537 Lisp_Object test
, weak
;
4539 struct hash_table_test testdesc
;
4543 /* The vector `used' is used to keep track of arguments that
4544 have been consumed. */
4545 char *used
= SAFE_ALLOCA (nargs
* sizeof *used
);
4546 memset (used
, 0, nargs
* sizeof *used
);
4548 /* See if there's a `:test TEST' among the arguments. */
4549 i
= get_key_arg (QCtest
, nargs
, args
, used
);
4550 test
= i
? args
[i
] : Qeql
;
4552 testdesc
= hashtest_eq
;
4553 else if (EQ (test
, Qeql
))
4554 testdesc
= hashtest_eql
;
4555 else if (EQ (test
, Qequal
))
4556 testdesc
= hashtest_equal
;
4559 /* See if it is a user-defined test. */
4562 prop
= Fget (test
, Qhash_table_test
);
4563 if (!CONSP (prop
) || !CONSP (XCDR (prop
)))
4564 signal_error ("Invalid hash table test", test
);
4565 testdesc
.name
= test
;
4566 testdesc
.user_cmp_function
= XCAR (prop
);
4567 testdesc
.user_hash_function
= XCAR (XCDR (prop
));
4568 testdesc
.hashfn
= hashfn_user_defined
;
4569 testdesc
.cmpfn
= cmpfn_user_defined
;
4572 /* See if there's a `:purecopy PURECOPY' argument. */
4573 i
= get_key_arg (QCpurecopy
, nargs
, args
, used
);
4574 pure
= i
&& !NILP (args
[i
]);
4575 /* See if there's a `:size SIZE' argument. */
4576 i
= get_key_arg (QCsize
, nargs
, args
, used
);
4577 Lisp_Object size_arg
= i
? args
[i
] : Qnil
;
4579 if (NILP (size_arg
))
4580 size
= DEFAULT_HASH_SIZE
;
4581 else if (NATNUMP (size_arg
))
4582 size
= XFASTINT (size_arg
);
4584 signal_error ("Invalid hash table size", size_arg
);
4586 /* Look for `:rehash-size SIZE'. */
4588 i
= get_key_arg (QCrehash_size
, nargs
, args
, used
);
4590 rehash_size
= DEFAULT_REHASH_SIZE
;
4591 else if (INTEGERP (args
[i
]) && 0 < XINT (args
[i
]))
4592 rehash_size
= - XINT (args
[i
]);
4593 else if (FLOATP (args
[i
]) && 0 < (float) (XFLOAT_DATA (args
[i
]) - 1))
4594 rehash_size
= (float) (XFLOAT_DATA (args
[i
]) - 1);
4596 signal_error ("Invalid hash table rehash size", args
[i
]);
4598 /* Look for `:rehash-threshold THRESHOLD'. */
4599 i
= get_key_arg (QCrehash_threshold
, nargs
, args
, used
);
4600 float rehash_threshold
= (!i
? DEFAULT_REHASH_THRESHOLD
4601 : !FLOATP (args
[i
]) ? 0
4602 : (float) XFLOAT_DATA (args
[i
]));
4603 if (! (0 < rehash_threshold
&& rehash_threshold
<= 1))
4604 signal_error ("Invalid hash table rehash threshold", args
[i
]);
4606 /* Look for `:weakness WEAK'. */
4607 i
= get_key_arg (QCweakness
, nargs
, args
, used
);
4608 weak
= i
? args
[i
] : Qnil
;
4610 weak
= Qkey_and_value
;
4613 && !EQ (weak
, Qvalue
)
4614 && !EQ (weak
, Qkey_or_value
)
4615 && !EQ (weak
, Qkey_and_value
))
4616 signal_error ("Invalid hash table weakness", weak
);
4618 /* Now, all args should have been used up, or there's a problem. */
4619 for (i
= 0; i
< nargs
; ++i
)
4621 signal_error ("Invalid argument list", args
[i
]);
4624 return make_hash_table (testdesc
, size
, rehash_size
, rehash_threshold
, weak
,
4629 DEFUN ("copy-hash-table", Fcopy_hash_table
, Scopy_hash_table
, 1, 1, 0,
4630 doc
: /* Return a copy of hash table TABLE. */)
4633 return copy_hash_table (check_hash_table (table
));
4637 DEFUN ("hash-table-count", Fhash_table_count
, Shash_table_count
, 1, 1, 0,
4638 doc
: /* Return the number of elements in TABLE. */)
4641 return make_number (check_hash_table (table
)->count
);
4645 DEFUN ("hash-table-rehash-size", Fhash_table_rehash_size
,
4646 Shash_table_rehash_size
, 1, 1, 0,
4647 doc
: /* Return the current rehash size of TABLE. */)
4650 double rehash_size
= check_hash_table (table
)->rehash_size
;
4651 if (rehash_size
< 0)
4653 EMACS_INT s
= -rehash_size
;
4654 return make_number (min (s
, MOST_POSITIVE_FIXNUM
));
4657 return make_float (rehash_size
+ 1);
4661 DEFUN ("hash-table-rehash-threshold", Fhash_table_rehash_threshold
,
4662 Shash_table_rehash_threshold
, 1, 1, 0,
4663 doc
: /* Return the current rehash threshold of TABLE. */)
4666 return make_float (check_hash_table (table
)->rehash_threshold
);
4670 DEFUN ("hash-table-size", Fhash_table_size
, Shash_table_size
, 1, 1, 0,
4671 doc
: /* Return the size of TABLE.
4672 The size can be used as an argument to `make-hash-table' to create
4673 a hash table than can hold as many elements as TABLE holds
4674 without need for resizing. */)
4677 struct Lisp_Hash_Table
*h
= check_hash_table (table
);
4678 return make_number (HASH_TABLE_SIZE (h
));
4682 DEFUN ("hash-table-test", Fhash_table_test
, Shash_table_test
, 1, 1, 0,
4683 doc
: /* Return the test TABLE uses. */)
4686 return check_hash_table (table
)->test
.name
;
4690 DEFUN ("hash-table-weakness", Fhash_table_weakness
, Shash_table_weakness
,
4692 doc
: /* Return the weakness of TABLE. */)
4695 return check_hash_table (table
)->weak
;
4699 DEFUN ("hash-table-p", Fhash_table_p
, Shash_table_p
, 1, 1, 0,
4700 doc
: /* Return t if OBJ is a Lisp hash table object. */)
4703 return HASH_TABLE_P (obj
) ? Qt
: Qnil
;
4707 DEFUN ("clrhash", Fclrhash
, Sclrhash
, 1, 1, 0,
4708 doc
: /* Clear hash table TABLE and return it. */)
4711 struct Lisp_Hash_Table
*h
= check_hash_table (table
);
4712 CHECK_IMPURE (table
, h
);
4714 /* Be compatible with XEmacs. */
4719 DEFUN ("gethash", Fgethash
, Sgethash
, 2, 3, 0,
4720 doc
: /* Look up KEY in TABLE and return its associated value.
4721 If KEY is not found, return DFLT which defaults to nil. */)
4722 (Lisp_Object key
, Lisp_Object table
, Lisp_Object dflt
)
4724 struct Lisp_Hash_Table
*h
= check_hash_table (table
);
4725 ptrdiff_t i
= hash_lookup (h
, key
, NULL
);
4726 return i
>= 0 ? HASH_VALUE (h
, i
) : dflt
;
4730 DEFUN ("puthash", Fputhash
, Sputhash
, 3, 3, 0,
4731 doc
: /* Associate KEY with VALUE in hash table TABLE.
4732 If KEY is already present in table, replace its current value with
4733 VALUE. In any case, return VALUE. */)
4734 (Lisp_Object key
, Lisp_Object value
, Lisp_Object table
)
4736 struct Lisp_Hash_Table
*h
= check_hash_table (table
);
4737 CHECK_IMPURE (table
, h
);
4741 i
= hash_lookup (h
, key
, &hash
);
4743 set_hash_value_slot (h
, i
, value
);
4745 hash_put (h
, key
, value
, hash
);
4751 DEFUN ("remhash", Fremhash
, Sremhash
, 2, 2, 0,
4752 doc
: /* Remove KEY from TABLE. */)
4753 (Lisp_Object key
, Lisp_Object table
)
4755 struct Lisp_Hash_Table
*h
= check_hash_table (table
);
4756 CHECK_IMPURE (table
, h
);
4757 hash_remove_from_table (h
, key
);
4762 DEFUN ("maphash", Fmaphash
, Smaphash
, 2, 2, 0,
4763 doc
: /* Call FUNCTION for all entries in hash table TABLE.
4764 FUNCTION is called with two arguments, KEY and VALUE.
4765 `maphash' always returns nil. */)
4766 (Lisp_Object function
, Lisp_Object table
)
4768 struct Lisp_Hash_Table
*h
= check_hash_table (table
);
4770 for (ptrdiff_t i
= 0; i
< HASH_TABLE_SIZE (h
); ++i
)
4771 if (!NILP (HASH_HASH (h
, i
)))
4772 call2 (function
, HASH_KEY (h
, i
), HASH_VALUE (h
, i
));
4778 DEFUN ("define-hash-table-test", Fdefine_hash_table_test
,
4779 Sdefine_hash_table_test
, 3, 3, 0,
4780 doc
: /* Define a new hash table test with name NAME, a symbol.
4782 In hash tables created with NAME specified as test, use TEST to
4783 compare keys, and HASH for computing hash codes of keys.
4785 TEST must be a function taking two arguments and returning non-nil if
4786 both arguments are the same. HASH must be a function taking one
4787 argument and returning an object that is the hash code of the argument.
4788 It should be the case that if (eq (funcall HASH x1) (funcall HASH x2))
4789 returns nil, then (funcall TEST x1 x2) also returns nil. */)
4790 (Lisp_Object name
, Lisp_Object test
, Lisp_Object hash
)
4792 return Fput (name
, Qhash_table_test
, list2 (test
, hash
));
4797 /************************************************************************
4798 MD5, SHA-1, and SHA-2
4799 ************************************************************************/
4807 make_digest_string (Lisp_Object digest
, int digest_size
)
4809 unsigned char *p
= SDATA (digest
);
4811 for (int i
= digest_size
- 1; i
>= 0; i
--)
4813 static char const hexdigit
[16] = "0123456789abcdef";
4815 p
[2 * i
] = hexdigit
[p_i
>> 4];
4816 p
[2 * i
+ 1] = hexdigit
[p_i
& 0xf];
4821 DEFUN ("secure-hash-algorithms", Fsecure_hash_algorithms
,
4822 Ssecure_hash_algorithms
, 0, 0, 0,
4823 doc
: /* Return a list of all the supported `secure_hash' algorithms. */)
4826 return listn (CONSTYPE_HEAP
, 6,
4835 /* Extract data from a string or a buffer. SPEC is a list of
4836 (BUFFER-OR-STRING-OR-SYMBOL START END CODING-SYSTEM NOERROR) which behave as
4837 specified with `secure-hash' and in Info node
4838 `(elisp)Format of GnuTLS Cryptography Inputs'. */
4840 extract_data_from_object (Lisp_Object spec
,
4841 ptrdiff_t *start_byte
,
4842 ptrdiff_t *end_byte
)
4844 Lisp_Object object
= XCAR (spec
);
4846 if (CONSP (spec
)) spec
= XCDR (spec
);
4847 Lisp_Object start
= CAR_SAFE (spec
);
4849 if (CONSP (spec
)) spec
= XCDR (spec
);
4850 Lisp_Object end
= CAR_SAFE (spec
);
4852 if (CONSP (spec
)) spec
= XCDR (spec
);
4853 Lisp_Object coding_system
= CAR_SAFE (spec
);
4855 if (CONSP (spec
)) spec
= XCDR (spec
);
4856 Lisp_Object noerror
= CAR_SAFE (spec
);
4858 if (STRINGP (object
))
4860 if (NILP (coding_system
))
4862 /* Decide the coding-system to encode the data with. */
4864 if (STRING_MULTIBYTE (object
))
4865 /* use default, we can't guess correct value */
4866 coding_system
= preferred_coding_system ();
4868 coding_system
= Qraw_text
;
4871 if (NILP (Fcoding_system_p (coding_system
)))
4873 /* Invalid coding system. */
4875 if (!NILP (noerror
))
4876 coding_system
= Qraw_text
;
4878 xsignal1 (Qcoding_system_error
, coding_system
);
4881 if (STRING_MULTIBYTE (object
))
4882 object
= code_convert_string (object
, coding_system
, Qnil
, 1, 0, 1);
4884 ptrdiff_t size
= SCHARS (object
), start_char
, end_char
;
4885 validate_subarray (object
, start
, end
, size
, &start_char
, &end_char
);
4887 *start_byte
= !start_char
? 0 : string_char_to_byte (object
, start_char
);
4888 *end_byte
= (end_char
== size
4890 : string_char_to_byte (object
, end_char
));
4892 else if (BUFFERP (object
))
4894 struct buffer
*prev
= current_buffer
;
4897 record_unwind_current_buffer ();
4899 struct buffer
*bp
= XBUFFER (object
);
4900 set_buffer_internal (bp
);
4906 CHECK_NUMBER_COERCE_MARKER (start
);
4914 CHECK_NUMBER_COERCE_MARKER (end
);
4925 if (!(BEGV
<= b
&& e
<= ZV
))
4926 args_out_of_range (start
, end
);
4928 if (NILP (coding_system
))
4930 /* Decide the coding-system to encode the data with.
4931 See fileio.c:Fwrite-region */
4933 if (!NILP (Vcoding_system_for_write
))
4934 coding_system
= Vcoding_system_for_write
;
4937 bool force_raw_text
= 0;
4939 coding_system
= BVAR (XBUFFER (object
), buffer_file_coding_system
);
4940 if (NILP (coding_system
)
4941 || NILP (Flocal_variable_p (Qbuffer_file_coding_system
, Qnil
)))
4943 coding_system
= Qnil
;
4944 if (NILP (BVAR (current_buffer
, enable_multibyte_characters
)))
4948 if (NILP (coding_system
) && !NILP (Fbuffer_file_name (object
)))
4950 /* Check file-coding-system-alist. */
4951 Lisp_Object val
= CALLN (Ffind_operation_coding_system
,
4952 Qwrite_region
, start
, end
,
4953 Fbuffer_file_name (object
));
4954 if (CONSP (val
) && !NILP (XCDR (val
)))
4955 coding_system
= XCDR (val
);
4958 if (NILP (coding_system
)
4959 && !NILP (BVAR (XBUFFER (object
), buffer_file_coding_system
)))
4961 /* If we still have not decided a coding system, use the
4962 default value of buffer-file-coding-system. */
4963 coding_system
= BVAR (XBUFFER (object
), buffer_file_coding_system
);
4967 && !NILP (Ffboundp (Vselect_safe_coding_system_function
)))
4968 /* Confirm that VAL can surely encode the current region. */
4969 coding_system
= call4 (Vselect_safe_coding_system_function
,
4970 make_number (b
), make_number (e
),
4971 coding_system
, Qnil
);
4974 coding_system
= Qraw_text
;
4977 if (NILP (Fcoding_system_p (coding_system
)))
4979 /* Invalid coding system. */
4981 if (!NILP (noerror
))
4982 coding_system
= Qraw_text
;
4984 xsignal1 (Qcoding_system_error
, coding_system
);
4988 object
= make_buffer_string (b
, e
, 0);
4989 set_buffer_internal (prev
);
4990 /* Discard the unwind protect for recovering the current
4994 if (STRING_MULTIBYTE (object
))
4995 object
= code_convert_string (object
, coding_system
, Qnil
, 1, 0, 0);
4997 *end_byte
= SBYTES (object
);
4999 else if (EQ (object
, Qiv_auto
))
5002 /* Format: (iv-auto REQUIRED-LENGTH). */
5004 if (! NATNUMP (start
))
5005 error ("Without a length, `iv-auto' can't be used; see ELisp manual");
5008 EMACS_INT start_hold
= XFASTINT (start
);
5009 object
= make_uninit_string (start_hold
);
5010 gnutls_rnd (GNUTLS_RND_NONCE
, SSDATA (object
), start_hold
);
5013 *end_byte
= start_hold
;
5016 error ("GnuTLS is not available, so `iv-auto' can't be used");
5020 if (!STRINGP (object
))
5021 signal_error ("Invalid object argument",
5022 NILP (object
) ? build_string ("nil") : object
);
5023 return SSDATA (object
);
5027 /* ALGORITHM is a symbol: md5, sha1, sha224 and so on. */
5030 secure_hash (Lisp_Object algorithm
, Lisp_Object object
, Lisp_Object start
,
5031 Lisp_Object end
, Lisp_Object coding_system
, Lisp_Object noerror
,
5034 ptrdiff_t start_byte
, end_byte
;
5036 void *(*hash_func
) (const char *, size_t, void *);
5039 CHECK_SYMBOL (algorithm
);
5041 Lisp_Object spec
= list5 (object
, start
, end
, coding_system
, noerror
);
5043 const char *input
= extract_data_from_object (spec
, &start_byte
, &end_byte
);
5046 error ("secure_hash: failed to extract data from object, aborting!");
5048 if (EQ (algorithm
, Qmd5
))
5050 digest_size
= MD5_DIGEST_SIZE
;
5051 hash_func
= md5_buffer
;
5053 else if (EQ (algorithm
, Qsha1
))
5055 digest_size
= SHA1_DIGEST_SIZE
;
5056 hash_func
= sha1_buffer
;
5058 else if (EQ (algorithm
, Qsha224
))
5060 digest_size
= SHA224_DIGEST_SIZE
;
5061 hash_func
= sha224_buffer
;
5063 else if (EQ (algorithm
, Qsha256
))
5065 digest_size
= SHA256_DIGEST_SIZE
;
5066 hash_func
= sha256_buffer
;
5068 else if (EQ (algorithm
, Qsha384
))
5070 digest_size
= SHA384_DIGEST_SIZE
;
5071 hash_func
= sha384_buffer
;
5073 else if (EQ (algorithm
, Qsha512
))
5075 digest_size
= SHA512_DIGEST_SIZE
;
5076 hash_func
= sha512_buffer
;
5079 error ("Invalid algorithm arg: %s", SDATA (Fsymbol_name (algorithm
)));
5081 /* allocate 2 x digest_size so that it can be re-used to hold the
5083 digest
= make_uninit_string (digest_size
* 2);
5085 hash_func (input
+ start_byte
,
5086 end_byte
- start_byte
,
5090 return make_digest_string (digest
, digest_size
);
5092 return make_unibyte_string (SSDATA (digest
), digest_size
);
5095 DEFUN ("md5", Fmd5
, Smd5
, 1, 5, 0,
5096 doc
: /* Return MD5 message digest of OBJECT, a buffer or string.
5098 A message digest is a cryptographic checksum of a document, and the
5099 algorithm to calculate it is defined in RFC 1321.
5101 The two optional arguments START and END are character positions
5102 specifying for which part of OBJECT the message digest should be
5103 computed. If nil or omitted, the digest is computed for the whole
5106 The MD5 message digest is computed from the result of encoding the
5107 text in a coding system, not directly from the internal Emacs form of
5108 the text. The optional fourth argument CODING-SYSTEM specifies which
5109 coding system to encode the text with. It should be the same coding
5110 system that you used or will use when actually writing the text into a
5113 If CODING-SYSTEM is nil or omitted, the default depends on OBJECT. If
5114 OBJECT is a buffer, the default for CODING-SYSTEM is whatever coding
5115 system would be chosen by default for writing this text into a file.
5117 If OBJECT is a string, the most preferred coding system (see the
5118 command `prefer-coding-system') is used.
5120 If NOERROR is non-nil, silently assume the `raw-text' coding if the
5121 guesswork fails. Normally, an error is signaled in such case. */)
5122 (Lisp_Object object
, Lisp_Object start
, Lisp_Object end
, Lisp_Object coding_system
, Lisp_Object noerror
)
5124 return secure_hash (Qmd5
, object
, start
, end
, coding_system
, noerror
, Qnil
);
5127 DEFUN ("secure-hash", Fsecure_hash
, Ssecure_hash
, 2, 5, 0,
5128 doc
: /* Return the secure hash of OBJECT, a buffer or string.
5129 ALGORITHM is a symbol specifying the hash to use:
5130 md5, sha1, sha224, sha256, sha384 or sha512.
5132 The two optional arguments START and END are positions specifying for
5133 which part of OBJECT to compute the hash. If nil or omitted, uses the
5136 The full list of algorithms can be obtained with `secure-hash-algorithms'.
5138 If BINARY is non-nil, returns a string in binary form. */)
5139 (Lisp_Object algorithm
, Lisp_Object object
, Lisp_Object start
, Lisp_Object end
, Lisp_Object binary
)
5141 return secure_hash (algorithm
, object
, start
, end
, Qnil
, Qnil
, binary
);
5144 DEFUN ("buffer-hash", Fbuffer_hash
, Sbuffer_hash
, 0, 1, 0,
5145 doc
: /* Return a hash of the contents of BUFFER-OR-NAME.
5146 This hash is performed on the raw internal format of the buffer,
5147 disregarding any coding systems. If nil, use the current buffer. */ )
5148 (Lisp_Object buffer_or_name
)
5152 struct sha1_ctx ctx
;
5154 if (NILP (buffer_or_name
))
5155 buffer
= Fcurrent_buffer ();
5157 buffer
= Fget_buffer (buffer_or_name
);
5159 nsberror (buffer_or_name
);
5161 b
= XBUFFER (buffer
);
5162 sha1_init_ctx (&ctx
);
5164 /* Process the first part of the buffer. */
5165 sha1_process_bytes (BUF_BEG_ADDR (b
),
5166 BUF_GPT_BYTE (b
) - BUF_BEG_BYTE (b
),
5169 /* If the gap is before the end of the buffer, process the last half
5171 if (BUF_GPT_BYTE (b
) < BUF_Z_BYTE (b
))
5172 sha1_process_bytes (BUF_GAP_END_ADDR (b
),
5173 BUF_Z_ADDR (b
) - BUF_GAP_END_ADDR (b
),
5176 Lisp_Object digest
= make_uninit_string (SHA1_DIGEST_SIZE
* 2);
5177 sha1_finish_ctx (&ctx
, SSDATA (digest
));
5178 return make_digest_string (digest
, SHA1_DIGEST_SIZE
);
5185 /* Hash table stuff. */
5186 DEFSYM (Qhash_table_p
, "hash-table-p");
5188 DEFSYM (Qeql
, "eql");
5189 DEFSYM (Qequal
, "equal");
5190 DEFSYM (QCtest
, ":test");
5191 DEFSYM (QCsize
, ":size");
5192 DEFSYM (QCpurecopy
, ":purecopy");
5193 DEFSYM (QCrehash_size
, ":rehash-size");
5194 DEFSYM (QCrehash_threshold
, ":rehash-threshold");
5195 DEFSYM (QCweakness
, ":weakness");
5196 DEFSYM (Qkey
, "key");
5197 DEFSYM (Qvalue
, "value");
5198 DEFSYM (Qhash_table_test
, "hash-table-test");
5199 DEFSYM (Qkey_or_value
, "key-or-value");
5200 DEFSYM (Qkey_and_value
, "key-and-value");
5202 defsubr (&Ssxhash_eq
);
5203 defsubr (&Ssxhash_eql
);
5204 defsubr (&Ssxhash_equal
);
5205 defsubr (&Smake_hash_table
);
5206 defsubr (&Scopy_hash_table
);
5207 defsubr (&Shash_table_count
);
5208 defsubr (&Shash_table_rehash_size
);
5209 defsubr (&Shash_table_rehash_threshold
);
5210 defsubr (&Shash_table_size
);
5211 defsubr (&Shash_table_test
);
5212 defsubr (&Shash_table_weakness
);
5213 defsubr (&Shash_table_p
);
5214 defsubr (&Sclrhash
);
5215 defsubr (&Sgethash
);
5216 defsubr (&Sputhash
);
5217 defsubr (&Sremhash
);
5218 defsubr (&Smaphash
);
5219 defsubr (&Sdefine_hash_table_test
);
5221 /* Crypto and hashing stuff. */
5222 DEFSYM (Qiv_auto
, "iv-auto");
5224 DEFSYM (Qmd5
, "md5");
5225 DEFSYM (Qsha1
, "sha1");
5226 DEFSYM (Qsha224
, "sha224");
5227 DEFSYM (Qsha256
, "sha256");
5228 DEFSYM (Qsha384
, "sha384");
5229 DEFSYM (Qsha512
, "sha512");
5231 /* Miscellaneous stuff. */
5233 DEFSYM (Qstring_lessp
, "string-lessp");
5234 DEFSYM (Qprovide
, "provide");
5235 DEFSYM (Qrequire
, "require");
5236 DEFSYM (Qyes_or_no_p_history
, "yes-or-no-p-history");
5237 DEFSYM (Qcursor_in_echo_area
, "cursor-in-echo-area");
5238 DEFSYM (Qwidget_type
, "widget-type");
5240 DEFVAR_LISP ("overriding-plist-environment", Voverriding_plist_environment
,
5241 doc
: /* An alist that overrides the plists of the symbols which it lists.
5242 Used by the byte-compiler to apply `define-symbol-prop' during
5244 Voverriding_plist_environment
= Qnil
;
5245 DEFSYM (Qoverriding_plist_environment
, "overriding-plist-environment");
5247 staticpro (&string_char_byte_cache_string
);
5248 string_char_byte_cache_string
= Qnil
;
5250 require_nesting_list
= Qnil
;
5251 staticpro (&require_nesting_list
);
5253 Fset (Qyes_or_no_p_history
, Qnil
);
5255 DEFVAR_LISP ("features", Vfeatures
,
5256 doc
: /* A list of symbols which are the features of the executing Emacs.
5257 Used by `featurep' and `require', and altered by `provide'. */);
5258 Vfeatures
= list1 (Qemacs
);
5259 DEFSYM (Qfeatures
, "features");
5260 /* Let people use lexically scoped vars named `features'. */
5261 Fmake_var_non_special (Qfeatures
);
5262 DEFSYM (Qsubfeatures
, "subfeatures");
5263 DEFSYM (Qfuncall
, "funcall");
5264 DEFSYM (Qplistp
, "plistp");
5266 #ifdef HAVE_LANGINFO_CODESET
5267 DEFSYM (Qcodeset
, "codeset");
5268 DEFSYM (Qdays
, "days");
5269 DEFSYM (Qmonths
, "months");
5270 DEFSYM (Qpaper
, "paper");
5271 #endif /* HAVE_LANGINFO_CODESET */
5273 DEFVAR_BOOL ("use-dialog-box", use_dialog_box
,
5274 doc
: /* Non-nil means mouse commands use dialog boxes to ask questions.
5275 This applies to `y-or-n-p' and `yes-or-no-p' questions asked by commands
5276 invoked by mouse clicks and mouse menu items.
5278 On some platforms, file selection dialogs are also enabled if this is
5282 DEFVAR_BOOL ("use-file-dialog", use_file_dialog
,
5283 doc
: /* Non-nil means mouse commands use a file dialog to ask for files.
5284 This applies to commands from menus and tool bar buttons even when
5285 they are initiated from the keyboard. If `use-dialog-box' is nil,
5286 that disables the use of a file dialog, regardless of the value of
5288 use_file_dialog
= 1;
5290 defsubr (&Sidentity
);
5293 defsubr (&Ssafe_length
);
5294 defsubr (&Sstring_bytes
);
5295 defsubr (&Sstring_distance
);
5296 defsubr (&Sstring_equal
);
5297 defsubr (&Scompare_strings
);
5298 defsubr (&Sstring_lessp
);
5299 defsubr (&Sstring_version_lessp
);
5300 defsubr (&Sstring_collate_lessp
);
5301 defsubr (&Sstring_collate_equalp
);
5304 defsubr (&Svconcat
);
5305 defsubr (&Scopy_sequence
);
5306 defsubr (&Sstring_make_multibyte
);
5307 defsubr (&Sstring_make_unibyte
);
5308 defsubr (&Sstring_as_multibyte
);
5309 defsubr (&Sstring_as_unibyte
);
5310 defsubr (&Sstring_to_multibyte
);
5311 defsubr (&Sstring_to_unibyte
);
5312 defsubr (&Scopy_alist
);
5313 defsubr (&Ssubstring
);
5314 defsubr (&Ssubstring_no_properties
);
5327 defsubr (&Snreverse
);
5328 defsubr (&Sreverse
);
5330 defsubr (&Splist_get
);
5332 defsubr (&Splist_put
);
5334 defsubr (&Slax_plist_get
);
5335 defsubr (&Slax_plist_put
);
5338 defsubr (&Sequal_including_properties
);
5339 defsubr (&Sfillarray
);
5340 defsubr (&Sclear_string
);
5345 defsubr (&Smapconcat
);
5346 defsubr (&Syes_or_no_p
);
5347 defsubr (&Sload_average
);
5348 defsubr (&Sfeaturep
);
5349 defsubr (&Srequire
);
5350 defsubr (&Sprovide
);
5351 defsubr (&Splist_member
);
5352 defsubr (&Swidget_put
);
5353 defsubr (&Swidget_get
);
5354 defsubr (&Swidget_apply
);
5355 defsubr (&Sbase64_encode_region
);
5356 defsubr (&Sbase64_decode_region
);
5357 defsubr (&Sbase64_encode_string
);
5358 defsubr (&Sbase64_decode_string
);
5360 defsubr (&Ssecure_hash_algorithms
);
5361 defsubr (&Ssecure_hash
);
5362 defsubr (&Sbuffer_hash
);
5363 defsubr (&Slocale_info
);