1 /* Random utility Lisp functions.
3 Copyright (C) 1985-1987, 1993-1995, 1997-2019 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>
32 #include "character.h"
34 #include "composite.h"
36 #include "intervals.h"
41 #if defined WINDOWSNT && defined HAVE_GNUTLS3
42 # define gnutls_rnd w32_gnutls_rnd
45 static void sort_vector_copy (Lisp_Object
, ptrdiff_t,
46 Lisp_Object
*restrict
, Lisp_Object
*restrict
);
47 enum equal_kind
{ EQUAL_NO_QUIT
, EQUAL_PLAIN
, EQUAL_INCLUDING_PROPERTIES
};
48 static bool internal_equal (Lisp_Object
, Lisp_Object
,
49 enum equal_kind
, int, Lisp_Object
);
51 DEFUN ("identity", Fidentity
, Sidentity
, 1, 1, 0,
52 doc
: /* Return the ARGUMENT unchanged. */
54 (Lisp_Object argument
)
59 DEFUN ("random", Frandom
, Srandom
, 0, 1, 0,
60 doc
: /* Return a pseudo-random integer.
61 By default, return a fixnum; all fixnums are equally likely.
62 With positive fixnum LIMIT, return random integer in interval [0,LIMIT).
63 With argument t, set the random number seed from the system's entropy
64 pool if available, otherwise from less-random volatile data such as the time.
65 With a string argument, set the seed based on the string's contents.
67 See Info node `(elisp)Random Numbers' for more details. */)
74 else if (STRINGP (limit
))
75 seed_random (SSDATA (limit
), SBYTES (limit
));
78 if (FIXNUMP (limit
) && 0 < XFIXNUM (limit
))
81 /* Return the remainder, except reject the rare case where
82 get_random returns a number so close to INTMASK that the
83 remainder isn't random. */
84 EMACS_INT remainder
= val
% XFIXNUM (limit
);
85 if (val
- remainder
<= INTMASK
- XFIXNUM (limit
) + 1)
86 return make_fixnum (remainder
);
89 return make_ufixnum (val
);
92 /* Random data-structure functions. */
94 /* Return LIST's length. Signal an error if LIST is not a proper list. */
97 list_length (Lisp_Object list
)
102 CHECK_LIST_END (list
, list
);
107 DEFUN ("length", Flength
, Slength
, 1, 1, 0,
108 doc
: /* Return the length of vector, list or string SEQUENCE.
109 A byte-code function object is also allowed.
110 If the string contains multibyte characters, this is not necessarily
111 the number of bytes in the string; it is the number of characters.
112 To get the number of bytes, use `string-bytes'. */)
113 (Lisp_Object sequence
)
117 if (STRINGP (sequence
))
118 val
= SCHARS (sequence
);
119 else if (VECTORP (sequence
))
120 val
= ASIZE (sequence
);
121 else if (CHAR_TABLE_P (sequence
))
123 else if (BOOL_VECTOR_P (sequence
))
124 val
= bool_vector_size (sequence
);
125 else if (COMPILEDP (sequence
) || RECORDP (sequence
))
126 val
= PVSIZE (sequence
);
127 else if (CONSP (sequence
))
128 val
= list_length (sequence
);
129 else if (NILP (sequence
))
132 wrong_type_argument (Qsequencep
, sequence
);
134 return make_fixnum (val
);
137 DEFUN ("safe-length", Fsafe_length
, Ssafe_length
, 1, 1, 0,
138 doc
: /* Return the length of a list, but avoid error or infinite loop.
139 This function never gets an error. If LIST is not really a list,
140 it returns 0. If LIST is circular, it returns an integer that is at
141 least the number of distinct elements. */)
145 FOR_EACH_TAIL_SAFE (list
)
147 return make_fixnum (len
);
150 DEFUN ("proper-list-p", Fproper_list_p
, Sproper_list_p
, 1, 1, 0,
151 doc
: /* Return OBJECT's length if it is a proper list, nil otherwise.
152 A proper list is neither circular nor dotted (i.e., its last cdr is nil). */
157 Lisp_Object last_tail
= object
;
158 Lisp_Object tail
= object
;
159 FOR_EACH_TAIL_SAFE (tail
)
163 last_tail
= XCDR (tail
);
165 if (!NILP (last_tail
))
167 return make_fixnum (len
);
170 DEFUN ("string-bytes", Fstring_bytes
, Sstring_bytes
, 1, 1, 0,
171 doc
: /* Return the number of bytes in STRING.
172 If STRING is multibyte, this may be greater than the length of STRING. */)
175 CHECK_STRING (string
);
176 return make_fixnum (SBYTES (string
));
179 DEFUN ("string-distance", Fstring_distance
, Sstring_distance
, 2, 3, 0,
180 doc
: /* Return Levenshtein distance between STRING1 and STRING2.
181 The distance is the number of deletions, insertions, and substitutions
182 required to transform STRING1 into STRING2.
183 If BYTECOMPARE is nil or omitted, compute distance in terms of characters.
184 If BYTECOMPARE is non-nil, compute distance in terms of bytes.
185 Letter-case is significant, but text properties are ignored. */)
186 (Lisp_Object string1
, Lisp_Object string2
, Lisp_Object bytecompare
)
189 CHECK_STRING (string1
);
190 CHECK_STRING (string2
);
192 bool use_byte_compare
=
194 || (!STRING_MULTIBYTE (string1
) && !STRING_MULTIBYTE (string2
));
195 ptrdiff_t len1
= use_byte_compare
? SBYTES (string1
) : SCHARS (string1
);
196 ptrdiff_t len2
= use_byte_compare
? SBYTES (string2
) : SCHARS (string2
);
197 ptrdiff_t x
, y
, lastdiag
, olddiag
;
200 ptrdiff_t *column
= SAFE_ALLOCA ((len1
+ 1) * sizeof (ptrdiff_t));
201 for (y
= 1; y
<= len1
; y
++)
204 if (use_byte_compare
)
206 char *s1
= SSDATA (string1
);
207 char *s2
= SSDATA (string2
);
209 for (x
= 1; x
<= len2
; x
++)
212 for (y
= 1, lastdiag
= x
- 1; y
<= len1
; y
++)
215 column
[y
] = min (min (column
[y
] + 1, column
[y
-1] + 1),
216 lastdiag
+ (s1
[y
-1] == s2
[x
-1] ? 0 : 1));
224 ptrdiff_t i1
, i1_byte
, i2
= 0, i2_byte
= 0;
225 for (x
= 1; x
<= len2
; x
++)
228 FETCH_STRING_CHAR_ADVANCE (c2
, string2
, i2
, i2_byte
);
230 for (y
= 1, lastdiag
= x
- 1; y
<= len1
; y
++)
233 FETCH_STRING_CHAR_ADVANCE (c1
, string1
, i1
, i1_byte
);
234 column
[y
] = min (min (column
[y
] + 1, column
[y
-1] + 1),
235 lastdiag
+ (c1
== c2
? 0 : 1));
242 return make_fixnum (column
[len1
]);
245 DEFUN ("string-equal", Fstring_equal
, Sstring_equal
, 2, 2, 0,
246 doc
: /* Return t if two strings have identical contents.
247 Case is significant, but text properties are ignored.
248 Symbols are also allowed; their print names are used instead. */)
249 (register Lisp_Object s1
, Lisp_Object s2
)
252 s1
= SYMBOL_NAME (s1
);
254 s2
= SYMBOL_NAME (s2
);
258 if (SCHARS (s1
) != SCHARS (s2
)
259 || SBYTES (s1
) != SBYTES (s2
)
260 || memcmp (SDATA (s1
), SDATA (s2
), SBYTES (s1
)))
265 DEFUN ("compare-strings", Fcompare_strings
, Scompare_strings
, 6, 7, 0,
266 doc
: /* Compare the contents of two strings, converting to multibyte if needed.
267 The arguments START1, END1, START2, and END2, if non-nil, are
268 positions specifying which parts of STR1 or STR2 to compare. In
269 string STR1, compare the part between START1 (inclusive) and END1
270 \(exclusive). If START1 is nil, it defaults to 0, the beginning of
271 the string; if END1 is nil, it defaults to the length of the string.
272 Likewise, in string STR2, compare the part between START2 and END2.
273 Like in `substring', negative values are counted from the end.
275 The strings are compared by the numeric values of their characters.
276 For instance, STR1 is "less than" STR2 if its first differing
277 character has a smaller numeric value. If IGNORE-CASE is non-nil,
278 characters are converted to upper-case before comparing them. Unibyte
279 strings are converted to multibyte for comparison.
281 The value is t if the strings (or specified portions) match.
282 If string STR1 is less, the value is a negative number N;
283 - 1 - N is the number of characters that match at the beginning.
284 If string STR1 is greater, the value is a positive number N;
285 N - 1 is the number of characters that match at the beginning. */)
286 (Lisp_Object str1
, Lisp_Object start1
, Lisp_Object end1
, Lisp_Object str2
,
287 Lisp_Object start2
, Lisp_Object end2
, Lisp_Object ignore_case
)
289 ptrdiff_t from1
, to1
, from2
, to2
, i1
, i1_byte
, i2
, i2_byte
;
294 /* For backward compatibility, silently bring too-large positive end
295 values into range. */
296 if (FIXNUMP (end1
) && SCHARS (str1
) < XFIXNUM (end1
))
297 end1
= make_fixnum (SCHARS (str1
));
298 if (FIXNUMP (end2
) && SCHARS (str2
) < XFIXNUM (end2
))
299 end2
= make_fixnum (SCHARS (str2
));
301 validate_subarray (str1
, start1
, end1
, SCHARS (str1
), &from1
, &to1
);
302 validate_subarray (str2
, start2
, end2
, SCHARS (str2
), &from2
, &to2
);
307 i1_byte
= string_char_to_byte (str1
, i1
);
308 i2_byte
= string_char_to_byte (str2
, i2
);
310 while (i1
< to1
&& i2
< to2
)
312 /* When we find a mismatch, we must compare the
313 characters, not just the bytes. */
316 FETCH_STRING_CHAR_AS_MULTIBYTE_ADVANCE (c1
, str1
, i1
, i1_byte
);
317 FETCH_STRING_CHAR_AS_MULTIBYTE_ADVANCE (c2
, str2
, i2
, i2_byte
);
322 if (! NILP (ignore_case
))
324 c1
= XFIXNUM (Fupcase (make_fixnum (c1
)));
325 c2
= XFIXNUM (Fupcase (make_fixnum (c2
)));
331 /* Note that I1 has already been incremented
332 past the character that we are comparing;
333 hence we don't add or subtract 1 here. */
335 return make_fixnum (- i1
+ from1
);
337 return make_fixnum (i1
- from1
);
341 return make_fixnum (i1
- from1
+ 1);
343 return make_fixnum (- i1
+ from1
- 1);
348 DEFUN ("string-lessp", Fstring_lessp
, Sstring_lessp
, 2, 2, 0,
349 doc
: /* Return non-nil if STRING1 is less than STRING2 in lexicographic order.
351 Symbols are also allowed; their print names are used instead. */)
352 (register Lisp_Object string1
, Lisp_Object string2
)
354 register ptrdiff_t end
;
355 register ptrdiff_t i1
, i1_byte
, i2
, i2_byte
;
357 if (SYMBOLP (string1
))
358 string1
= SYMBOL_NAME (string1
);
359 if (SYMBOLP (string2
))
360 string2
= SYMBOL_NAME (string2
);
361 CHECK_STRING (string1
);
362 CHECK_STRING (string2
);
364 i1
= i1_byte
= i2
= i2_byte
= 0;
366 end
= SCHARS (string1
);
367 if (end
> SCHARS (string2
))
368 end
= SCHARS (string2
);
372 /* When we find a mismatch, we must compare the
373 characters, not just the bytes. */
376 FETCH_STRING_CHAR_ADVANCE (c1
, string1
, i1
, i1_byte
);
377 FETCH_STRING_CHAR_ADVANCE (c2
, string2
, i2
, i2_byte
);
380 return c1
< c2
? Qt
: Qnil
;
382 return i1
< SCHARS (string2
) ? Qt
: Qnil
;
385 DEFUN ("string-version-lessp", Fstring_version_lessp
,
386 Sstring_version_lessp
, 2, 2, 0,
387 doc
: /* Return non-nil if S1 is less than S2, as version strings.
389 This function compares version strings S1 and S2:
390 1) By prefix lexicographically.
391 2) Then by version (similarly to version comparison of Debian's dpkg).
392 Leading zeros in version numbers are ignored.
393 3) If both prefix and version are equal, compare as ordinary strings.
395 For example, \"foo2.png\" compares less than \"foo12.png\".
397 Symbols are also allowed; their print names are used instead. */)
398 (Lisp_Object string1
, Lisp_Object string2
)
400 if (SYMBOLP (string1
))
401 string1
= SYMBOL_NAME (string1
);
402 if (SYMBOLP (string2
))
403 string2
= SYMBOL_NAME (string2
);
404 CHECK_STRING (string1
);
405 CHECK_STRING (string2
);
406 return string_version_cmp (string1
, string2
) < 0 ? Qt
: Qnil
;
409 /* Return negative, 0, positive if STRING1 is <, =, > STRING2 as per
410 string-version-lessp. */
412 string_version_cmp (Lisp_Object string1
, Lisp_Object string2
)
414 char *p1
= SSDATA (string1
);
415 char *p2
= SSDATA (string2
);
416 char *lim1
= p1
+ SBYTES (string1
);
417 char *lim2
= p2
+ SBYTES (string2
);
420 while ((cmp
= filevercmp (p1
, p2
)) == 0)
422 /* If the strings are identical through their first NUL bytes,
423 skip past identical prefixes and try again. */
424 ptrdiff_t size
= strlen (p1
) + 1;
425 eassert (size
== strlen (p2
) + 1);
428 bool more1
= p1
<= lim1
;
429 bool more2
= p2
<= lim2
;
439 DEFUN ("string-collate-lessp", Fstring_collate_lessp
, Sstring_collate_lessp
, 2, 4, 0,
440 doc
: /* Return t if first arg string is less than second in collation order.
441 Symbols are also allowed; their print names are used instead.
443 This function obeys the conventions for collation order in your
444 locale settings. For example, punctuation and whitespace characters
445 might be considered less significant for sorting:
447 \(sort \\='("11" "12" "1 1" "1 2" "1.1" "1.2") \\='string-collate-lessp)
448 => ("11" "1 1" "1.1" "12" "1 2" "1.2")
450 The optional argument LOCALE, a string, overrides the setting of your
451 current locale identifier for collation. The value is system
452 dependent; a LOCALE \"en_US.UTF-8\" is applicable on POSIX systems,
453 while it would be, e.g., \"enu_USA.1252\" on MS-Windows systems.
455 If IGNORE-CASE is non-nil, characters are converted to lower-case
456 before comparing them.
458 To emulate Unicode-compliant collation on MS-Windows systems,
459 bind `w32-collate-ignore-punctuation' to a non-nil value, since
460 the codeset part of the locale cannot be \"UTF-8\" on MS-Windows.
462 If your system does not support a locale environment, this function
463 behaves like `string-lessp'. */)
464 (Lisp_Object s1
, Lisp_Object s2
, Lisp_Object locale
, Lisp_Object ignore_case
)
466 #if defined __STDC_ISO_10646__ || defined WINDOWSNT
467 /* Check parameters. */
469 s1
= SYMBOL_NAME (s1
);
471 s2
= SYMBOL_NAME (s2
);
475 CHECK_STRING (locale
);
477 return (str_collate (s1
, s2
, locale
, ignore_case
) < 0) ? Qt
: Qnil
;
479 #else /* !__STDC_ISO_10646__, !WINDOWSNT */
480 return Fstring_lessp (s1
, s2
);
481 #endif /* !__STDC_ISO_10646__, !WINDOWSNT */
484 DEFUN ("string-collate-equalp", Fstring_collate_equalp
, Sstring_collate_equalp
, 2, 4, 0,
485 doc
: /* Return t if two strings have identical contents.
486 Symbols are also allowed; their print names are used instead.
488 This function obeys the conventions for collation order in your locale
489 settings. For example, characters with different coding points but
490 the same meaning might be considered as equal, like different grave
491 accent Unicode characters:
493 \(string-collate-equalp (string ?\\uFF40) (string ?\\u1FEF))
496 The optional argument LOCALE, a string, overrides the setting of your
497 current locale identifier for collation. The value is system
498 dependent; a LOCALE \"en_US.UTF-8\" is applicable on POSIX systems,
499 while it would be \"enu_USA.1252\" on MS Windows systems.
501 If IGNORE-CASE is non-nil, characters are converted to lower-case
502 before comparing them.
504 To emulate Unicode-compliant collation on MS-Windows systems,
505 bind `w32-collate-ignore-punctuation' to a non-nil value, since
506 the codeset part of the locale cannot be \"UTF-8\" on MS-Windows.
508 If your system does not support a locale environment, this function
509 behaves like `string-equal'.
511 Do NOT use this function to compare file names for equality. */)
512 (Lisp_Object s1
, Lisp_Object s2
, Lisp_Object locale
, Lisp_Object ignore_case
)
514 #if defined __STDC_ISO_10646__ || defined WINDOWSNT
515 /* Check parameters. */
517 s1
= SYMBOL_NAME (s1
);
519 s2
= SYMBOL_NAME (s2
);
523 CHECK_STRING (locale
);
525 return (str_collate (s1
, s2
, locale
, ignore_case
) == 0) ? Qt
: Qnil
;
527 #else /* !__STDC_ISO_10646__, !WINDOWSNT */
528 return Fstring_equal (s1
, s2
);
529 #endif /* !__STDC_ISO_10646__, !WINDOWSNT */
532 static Lisp_Object
concat (ptrdiff_t nargs
, Lisp_Object
*args
,
533 enum Lisp_Type target_type
, bool last_special
);
536 concat2 (Lisp_Object s1
, Lisp_Object s2
)
538 return concat (2, ((Lisp_Object
[]) {s1
, s2
}), Lisp_String
, 0);
542 concat3 (Lisp_Object s1
, Lisp_Object s2
, Lisp_Object s3
)
544 return concat (3, ((Lisp_Object
[]) {s1
, s2
, s3
}), Lisp_String
, 0);
547 DEFUN ("append", Fappend
, Sappend
, 0, MANY
, 0,
548 doc
: /* Concatenate all the arguments and make the result a list.
549 The result is a list whose elements are the elements of all the arguments.
550 Each argument may be a list, vector or string.
551 The last argument is not copied, just used as the tail of the new list.
552 usage: (append &rest SEQUENCES) */)
553 (ptrdiff_t nargs
, Lisp_Object
*args
)
555 return concat (nargs
, args
, Lisp_Cons
, 1);
558 DEFUN ("concat", Fconcat
, Sconcat
, 0, MANY
, 0,
559 doc
: /* Concatenate all the arguments and make the result a string.
560 The result is a string whose elements are the elements of all the arguments.
561 Each argument may be a string or a list or vector of characters (integers).
562 usage: (concat &rest SEQUENCES) */)
563 (ptrdiff_t nargs
, Lisp_Object
*args
)
565 return concat (nargs
, args
, Lisp_String
, 0);
568 DEFUN ("vconcat", Fvconcat
, Svconcat
, 0, MANY
, 0,
569 doc
: /* Concatenate all the arguments and make the result a vector.
570 The result is a vector whose elements are the elements of all the arguments.
571 Each argument may be a list, vector or string.
572 usage: (vconcat &rest SEQUENCES) */)
573 (ptrdiff_t nargs
, Lisp_Object
*args
)
575 return concat (nargs
, args
, Lisp_Vectorlike
, 0);
579 DEFUN ("copy-sequence", Fcopy_sequence
, Scopy_sequence
, 1, 1, 0,
580 doc
: /* Return a copy of a list, vector, string, char-table or record.
581 The elements of a list, vector or record are not copied; they are
582 shared with the original.
583 If the original sequence is empty, this function may return
584 the same empty object instead of its copy. */)
587 if (NILP (arg
)) return arg
;
591 return Frecord (PVSIZE (arg
), XVECTOR (arg
)->contents
);
594 if (CHAR_TABLE_P (arg
))
596 return copy_char_table (arg
);
599 if (BOOL_VECTOR_P (arg
))
601 EMACS_INT nbits
= bool_vector_size (arg
);
602 ptrdiff_t nbytes
= bool_vector_bytes (nbits
);
603 Lisp_Object val
= make_uninit_bool_vector (nbits
);
604 memcpy (bool_vector_data (val
), bool_vector_data (arg
), nbytes
);
608 if (!CONSP (arg
) && !VECTORP (arg
) && !STRINGP (arg
))
609 wrong_type_argument (Qsequencep
, arg
);
611 return concat (1, &arg
, XTYPE (arg
), 0);
614 /* This structure holds information of an argument of `concat' that is
615 a string and has text properties to be copied. */
618 ptrdiff_t argnum
; /* refer to ARGS (arguments of `concat') */
619 ptrdiff_t from
; /* refer to ARGS[argnum] (argument string) */
620 ptrdiff_t to
; /* refer to VAL (the target string) */
624 concat (ptrdiff_t nargs
, Lisp_Object
*args
,
625 enum Lisp_Type target_type
, bool last_special
)
631 ptrdiff_t toindex_byte
= 0;
632 EMACS_INT result_len
;
633 EMACS_INT result_len_byte
;
635 Lisp_Object last_tail
;
638 /* When we make a multibyte string, we can't copy text properties
639 while concatenating each string because the length of resulting
640 string can't be decided until we finish the whole concatenation.
641 So, we record strings that have text properties to be copied
642 here, and copy the text properties after the concatenation. */
643 struct textprop_rec
*textprops
= NULL
;
644 /* Number of elements in textprops. */
645 ptrdiff_t num_textprops
= 0;
650 /* In append, the last arg isn't treated like the others */
651 if (last_special
&& nargs
> 0)
654 last_tail
= args
[nargs
];
659 /* Check each argument. */
660 for (argnum
= 0; argnum
< nargs
; argnum
++)
663 if (!(CONSP (this) || NILP (this) || VECTORP (this) || STRINGP (this)
664 || COMPILEDP (this) || BOOL_VECTOR_P (this)))
665 wrong_type_argument (Qsequencep
, this);
668 /* Compute total length in chars of arguments in RESULT_LEN.
669 If desired output is a string, also compute length in bytes
670 in RESULT_LEN_BYTE, and determine in SOME_MULTIBYTE
671 whether the result should be a multibyte string. */
675 for (argnum
= 0; argnum
< nargs
; argnum
++)
679 len
= XFIXNAT (Flength (this));
680 if (target_type
== Lisp_String
)
682 /* We must count the number of bytes needed in the string
683 as well as the number of characters. */
687 ptrdiff_t this_len_byte
;
689 if (VECTORP (this) || COMPILEDP (this))
690 for (i
= 0; i
< len
; i
++)
693 CHECK_CHARACTER (ch
);
695 this_len_byte
= CHAR_BYTES (c
);
696 if (STRING_BYTES_BOUND
- result_len_byte
< this_len_byte
)
698 result_len_byte
+= this_len_byte
;
699 if (! ASCII_CHAR_P (c
) && ! CHAR_BYTE8_P (c
))
702 else if (BOOL_VECTOR_P (this) && bool_vector_size (this) > 0)
703 wrong_type_argument (Qintegerp
, Faref (this, make_fixnum (0)));
704 else if (CONSP (this))
705 for (; CONSP (this); this = XCDR (this))
708 CHECK_CHARACTER (ch
);
710 this_len_byte
= CHAR_BYTES (c
);
711 if (STRING_BYTES_BOUND
- result_len_byte
< this_len_byte
)
713 result_len_byte
+= this_len_byte
;
714 if (! ASCII_CHAR_P (c
) && ! CHAR_BYTE8_P (c
))
717 else if (STRINGP (this))
719 if (STRING_MULTIBYTE (this))
722 this_len_byte
= SBYTES (this);
725 this_len_byte
= count_size_as_multibyte (SDATA (this),
727 if (STRING_BYTES_BOUND
- result_len_byte
< this_len_byte
)
729 result_len_byte
+= this_len_byte
;
734 if (MOST_POSITIVE_FIXNUM
< result_len
)
735 memory_full (SIZE_MAX
);
738 if (! some_multibyte
)
739 result_len_byte
= result_len
;
741 /* Create the output object. */
742 if (target_type
== Lisp_Cons
)
743 val
= Fmake_list (make_fixnum (result_len
), Qnil
);
744 else if (target_type
== Lisp_Vectorlike
)
745 val
= make_nil_vector (result_len
);
746 else if (some_multibyte
)
747 val
= make_uninit_multibyte_string (result_len
, result_len_byte
);
749 val
= make_uninit_string (result_len
);
751 /* In `append', if all but last arg are nil, return last arg. */
752 if (target_type
== Lisp_Cons
&& NILP (val
))
755 /* Copy the contents of the args into the result. */
757 tail
= val
, toindex
= -1; /* -1 in toindex is flag we are making a list */
759 toindex
= 0, toindex_byte
= 0;
763 SAFE_NALLOCA (textprops
, 1, nargs
);
765 for (argnum
= 0; argnum
< nargs
; argnum
++)
768 ptrdiff_t thisleni
= 0;
769 register ptrdiff_t thisindex
= 0;
770 register ptrdiff_t thisindex_byte
= 0;
774 thislen
= Flength (this), thisleni
= XFIXNUM (thislen
);
776 /* Between strings of the same kind, copy fast. */
777 if (STRINGP (this) && STRINGP (val
)
778 && STRING_MULTIBYTE (this) == some_multibyte
)
780 ptrdiff_t thislen_byte
= SBYTES (this);
782 memcpy (SDATA (val
) + toindex_byte
, SDATA (this), SBYTES (this));
783 if (string_intervals (this))
785 textprops
[num_textprops
].argnum
= argnum
;
786 textprops
[num_textprops
].from
= 0;
787 textprops
[num_textprops
++].to
= toindex
;
789 toindex_byte
+= thislen_byte
;
792 /* Copy a single-byte string to a multibyte string. */
793 else if (STRINGP (this) && STRINGP (val
))
795 if (string_intervals (this))
797 textprops
[num_textprops
].argnum
= argnum
;
798 textprops
[num_textprops
].from
= 0;
799 textprops
[num_textprops
++].to
= toindex
;
801 toindex_byte
+= copy_text (SDATA (this),
802 SDATA (val
) + toindex_byte
,
803 SCHARS (this), 0, 1);
807 /* Copy element by element. */
810 register Lisp_Object elt
;
812 /* Fetch next element of `this' arg into `elt', or break if
813 `this' is exhausted. */
814 if (NILP (this)) break;
816 elt
= XCAR (this), this = XCDR (this);
817 else if (thisindex
>= thisleni
)
819 else if (STRINGP (this))
822 if (STRING_MULTIBYTE (this))
823 FETCH_STRING_CHAR_ADVANCE_NO_CHECK (c
, this,
828 c
= SREF (this, thisindex
); thisindex
++;
829 if (some_multibyte
&& !ASCII_CHAR_P (c
))
830 c
= BYTE8_TO_CHAR (c
);
832 XSETFASTINT (elt
, c
);
834 else if (BOOL_VECTOR_P (this))
836 elt
= bool_vector_ref (this, thisindex
);
841 elt
= AREF (this, thisindex
);
845 /* Store this element into the result. */
852 else if (VECTORP (val
))
854 ASET (val
, toindex
, elt
);
860 CHECK_CHARACTER (elt
);
863 toindex_byte
+= CHAR_STRING (c
, SDATA (val
) + toindex_byte
);
865 SSET (val
, toindex_byte
++, c
);
871 XSETCDR (prev
, last_tail
);
873 if (num_textprops
> 0)
876 ptrdiff_t last_to_end
= -1;
878 for (argnum
= 0; argnum
< num_textprops
; argnum
++)
880 this = args
[textprops
[argnum
].argnum
];
881 props
= text_property_list (this,
883 make_fixnum (SCHARS (this)),
885 /* If successive arguments have properties, be sure that the
886 value of `composition' property be the copy. */
887 if (last_to_end
== textprops
[argnum
].to
)
888 make_composition_value_copy (props
);
889 add_text_properties_from_list (val
, props
,
890 make_fixnum (textprops
[argnum
].to
));
891 last_to_end
= textprops
[argnum
].to
+ SCHARS (this);
899 static Lisp_Object string_char_byte_cache_string
;
900 static ptrdiff_t string_char_byte_cache_charpos
;
901 static ptrdiff_t string_char_byte_cache_bytepos
;
904 clear_string_char_byte_cache (void)
906 string_char_byte_cache_string
= Qnil
;
909 /* Return the byte index corresponding to CHAR_INDEX in STRING. */
912 string_char_to_byte (Lisp_Object string
, ptrdiff_t char_index
)
915 ptrdiff_t best_below
, best_below_byte
;
916 ptrdiff_t best_above
, best_above_byte
;
918 best_below
= best_below_byte
= 0;
919 best_above
= SCHARS (string
);
920 best_above_byte
= SBYTES (string
);
921 if (best_above
== best_above_byte
)
924 if (EQ (string
, string_char_byte_cache_string
))
926 if (string_char_byte_cache_charpos
< char_index
)
928 best_below
= string_char_byte_cache_charpos
;
929 best_below_byte
= string_char_byte_cache_bytepos
;
933 best_above
= string_char_byte_cache_charpos
;
934 best_above_byte
= string_char_byte_cache_bytepos
;
938 if (char_index
- best_below
< best_above
- char_index
)
940 unsigned char *p
= SDATA (string
) + best_below_byte
;
942 while (best_below
< char_index
)
944 p
+= BYTES_BY_CHAR_HEAD (*p
);
947 i_byte
= p
- SDATA (string
);
951 unsigned char *p
= SDATA (string
) + best_above_byte
;
953 while (best_above
> char_index
)
956 while (!CHAR_HEAD_P (*p
)) p
--;
959 i_byte
= p
- SDATA (string
);
962 string_char_byte_cache_bytepos
= i_byte
;
963 string_char_byte_cache_charpos
= char_index
;
964 string_char_byte_cache_string
= string
;
969 /* Return the character index corresponding to BYTE_INDEX in STRING. */
972 string_byte_to_char (Lisp_Object string
, ptrdiff_t byte_index
)
975 ptrdiff_t best_below
, best_below_byte
;
976 ptrdiff_t best_above
, best_above_byte
;
978 best_below
= best_below_byte
= 0;
979 best_above
= SCHARS (string
);
980 best_above_byte
= SBYTES (string
);
981 if (best_above
== best_above_byte
)
984 if (EQ (string
, string_char_byte_cache_string
))
986 if (string_char_byte_cache_bytepos
< byte_index
)
988 best_below
= string_char_byte_cache_charpos
;
989 best_below_byte
= string_char_byte_cache_bytepos
;
993 best_above
= string_char_byte_cache_charpos
;
994 best_above_byte
= string_char_byte_cache_bytepos
;
998 if (byte_index
- best_below_byte
< best_above_byte
- byte_index
)
1000 unsigned char *p
= SDATA (string
) + best_below_byte
;
1001 unsigned char *pend
= SDATA (string
) + byte_index
;
1005 p
+= BYTES_BY_CHAR_HEAD (*p
);
1009 i_byte
= p
- SDATA (string
);
1013 unsigned char *p
= SDATA (string
) + best_above_byte
;
1014 unsigned char *pbeg
= SDATA (string
) + byte_index
;
1019 while (!CHAR_HEAD_P (*p
)) p
--;
1023 i_byte
= p
- SDATA (string
);
1026 string_char_byte_cache_bytepos
= i_byte
;
1027 string_char_byte_cache_charpos
= i
;
1028 string_char_byte_cache_string
= string
;
1033 /* Convert STRING to a multibyte string. */
1036 string_make_multibyte (Lisp_Object string
)
1043 if (STRING_MULTIBYTE (string
))
1046 nbytes
= count_size_as_multibyte (SDATA (string
),
1048 /* If all the chars are ASCII, they won't need any more bytes
1049 once converted. In that case, we can return STRING itself. */
1050 if (nbytes
== SBYTES (string
))
1053 buf
= SAFE_ALLOCA (nbytes
);
1054 copy_text (SDATA (string
), buf
, SBYTES (string
),
1057 ret
= make_multibyte_string ((char *) buf
, SCHARS (string
), nbytes
);
1064 /* Convert STRING (if unibyte) to a multibyte string without changing
1065 the number of characters. Characters 0200 trough 0237 are
1066 converted to eight-bit characters. */
1069 string_to_multibyte (Lisp_Object string
)
1076 if (STRING_MULTIBYTE (string
))
1079 nbytes
= count_size_as_multibyte (SDATA (string
), SBYTES (string
));
1080 /* If all the chars are ASCII, they won't need any more bytes once
1082 if (nbytes
== SBYTES (string
))
1083 return make_multibyte_string (SSDATA (string
), nbytes
, nbytes
);
1085 buf
= SAFE_ALLOCA (nbytes
);
1086 memcpy (buf
, SDATA (string
), SBYTES (string
));
1087 str_to_multibyte (buf
, nbytes
, SBYTES (string
));
1089 ret
= make_multibyte_string ((char *) buf
, SCHARS (string
), nbytes
);
1096 /* Convert STRING to a single-byte string. */
1099 string_make_unibyte (Lisp_Object string
)
1106 if (! STRING_MULTIBYTE (string
))
1109 nchars
= SCHARS (string
);
1111 buf
= SAFE_ALLOCA (nchars
);
1112 copy_text (SDATA (string
), buf
, SBYTES (string
),
1115 ret
= make_unibyte_string ((char *) buf
, nchars
);
1121 DEFUN ("string-make-multibyte", Fstring_make_multibyte
, Sstring_make_multibyte
,
1123 doc
: /* Return the multibyte equivalent of STRING.
1124 If STRING is unibyte and contains non-ASCII characters, the function
1125 `unibyte-char-to-multibyte' is used to convert each unibyte character
1126 to a multibyte character. In this case, the returned string is a
1127 newly created string with no text properties. If STRING is multibyte
1128 or entirely ASCII, it is returned unchanged. In particular, when
1129 STRING is unibyte and entirely ASCII, the returned string is unibyte.
1130 \(When the characters are all ASCII, Emacs primitives will treat the
1131 string the same way whether it is unibyte or multibyte.) */)
1132 (Lisp_Object string
)
1134 CHECK_STRING (string
);
1136 return string_make_multibyte (string
);
1139 DEFUN ("string-make-unibyte", Fstring_make_unibyte
, Sstring_make_unibyte
,
1141 doc
: /* Return the unibyte equivalent of STRING.
1142 Multibyte character codes above 255 are converted to unibyte
1143 by taking just the low 8 bits of each character's code. */)
1144 (Lisp_Object string
)
1146 CHECK_STRING (string
);
1148 return string_make_unibyte (string
);
1151 DEFUN ("string-as-unibyte", Fstring_as_unibyte
, Sstring_as_unibyte
,
1153 doc
: /* Return a unibyte string with the same individual bytes as STRING.
1154 If STRING is unibyte, the result is STRING itself.
1155 Otherwise it is a newly created string, with no text properties.
1156 If STRING is multibyte and contains a character of charset
1157 `eight-bit', it is converted to the corresponding single byte. */)
1158 (Lisp_Object string
)
1160 CHECK_STRING (string
);
1162 if (STRING_MULTIBYTE (string
))
1164 unsigned char *str
= (unsigned char *) xlispstrdup (string
);
1165 ptrdiff_t bytes
= str_as_unibyte (str
, SBYTES (string
));
1167 string
= make_unibyte_string ((char *) str
, bytes
);
1173 DEFUN ("string-as-multibyte", Fstring_as_multibyte
, Sstring_as_multibyte
,
1175 doc
: /* Return a multibyte string with the same individual bytes as STRING.
1176 If STRING is multibyte, the result is STRING itself.
1177 Otherwise it is a newly created string, with no text properties.
1179 If STRING is unibyte and contains an individual 8-bit byte (i.e. not
1180 part of a correct utf-8 sequence), it is converted to the corresponding
1181 multibyte character of charset `eight-bit'.
1182 See also `string-to-multibyte'.
1184 Beware, this often doesn't really do what you think it does.
1185 It is similar to (decode-coding-string STRING \\='utf-8-emacs).
1186 If you're not sure, whether to use `string-as-multibyte' or
1187 `string-to-multibyte', use `string-to-multibyte'. */)
1188 (Lisp_Object string
)
1190 CHECK_STRING (string
);
1192 if (! STRING_MULTIBYTE (string
))
1194 Lisp_Object new_string
;
1195 ptrdiff_t nchars
, nbytes
;
1197 parse_str_as_multibyte (SDATA (string
),
1200 new_string
= make_uninit_multibyte_string (nchars
, nbytes
);
1201 memcpy (SDATA (new_string
), SDATA (string
), SBYTES (string
));
1202 if (nbytes
!= SBYTES (string
))
1203 str_as_multibyte (SDATA (new_string
), nbytes
,
1204 SBYTES (string
), NULL
);
1205 string
= new_string
;
1206 set_string_intervals (string
, NULL
);
1211 DEFUN ("string-to-multibyte", Fstring_to_multibyte
, Sstring_to_multibyte
,
1213 doc
: /* Return a multibyte string with the same individual chars as STRING.
1214 If STRING is multibyte, the result is STRING itself.
1215 Otherwise it is a newly created string, with no text properties.
1217 If STRING is unibyte and contains an 8-bit byte, it is converted to
1218 the corresponding multibyte character of charset `eight-bit'.
1220 This differs from `string-as-multibyte' by converting each byte of a correct
1221 utf-8 sequence to an eight-bit character, not just bytes that don't form a
1222 correct sequence. */)
1223 (Lisp_Object string
)
1225 CHECK_STRING (string
);
1227 return string_to_multibyte (string
);
1230 DEFUN ("string-to-unibyte", Fstring_to_unibyte
, Sstring_to_unibyte
,
1232 doc
: /* Return a unibyte string with the same individual chars as STRING.
1233 If STRING is unibyte, the result is STRING itself.
1234 Otherwise it is a newly created string, with no text properties,
1235 where each `eight-bit' character is converted to the corresponding byte.
1236 If STRING contains a non-ASCII, non-`eight-bit' character,
1237 an error is signaled. */)
1238 (Lisp_Object string
)
1240 CHECK_STRING (string
);
1242 if (STRING_MULTIBYTE (string
))
1244 ptrdiff_t chars
= SCHARS (string
);
1245 unsigned char *str
= xmalloc (chars
);
1246 ptrdiff_t converted
= str_to_unibyte (SDATA (string
), str
, chars
);
1248 if (converted
< chars
)
1249 error ("Can't convert the %"pD
"dth character to unibyte", converted
);
1250 string
= make_unibyte_string ((char *) str
, chars
);
1257 DEFUN ("copy-alist", Fcopy_alist
, Scopy_alist
, 1, 1, 0,
1258 doc
: /* Return a copy of ALIST.
1259 This is an alist which represents the same mapping from objects to objects,
1260 but does not share the alist structure with ALIST.
1261 The objects mapped (cars and cdrs of elements of the alist)
1262 are shared, however.
1263 Elements of ALIST that are not conses are also shared. */)
1268 alist
= concat (1, &alist
, Lisp_Cons
, false);
1269 for (Lisp_Object tem
= alist
; !NILP (tem
); tem
= XCDR (tem
))
1271 Lisp_Object car
= XCAR (tem
);
1273 XSETCAR (tem
, Fcons (XCAR (car
), XCDR (car
)));
1278 /* Check that ARRAY can have a valid subarray [FROM..TO),
1279 given that its size is SIZE.
1280 If FROM is nil, use 0; if TO is nil, use SIZE.
1281 Count negative values backwards from the end.
1282 Set *IFROM and *ITO to the two indexes used. */
1285 validate_subarray (Lisp_Object array
, Lisp_Object from
, Lisp_Object to
,
1286 ptrdiff_t size
, ptrdiff_t *ifrom
, ptrdiff_t *ito
)
1296 else if (NILP (from
))
1299 wrong_type_argument (Qintegerp
, from
);
1310 wrong_type_argument (Qintegerp
, to
);
1312 if (! (0 <= f
&& f
<= t
&& t
<= size
))
1313 args_out_of_range_3 (array
, from
, to
);
1319 DEFUN ("substring", Fsubstring
, Ssubstring
, 1, 3, 0,
1320 doc
: /* Return a new string whose contents are a substring of STRING.
1321 The returned string consists of the characters between index FROM
1322 \(inclusive) and index TO (exclusive) of STRING. FROM and TO are
1323 zero-indexed: 0 means the first character of STRING. Negative values
1324 are counted from the end of STRING. If TO is nil, the substring runs
1325 to the end of STRING.
1327 The STRING argument may also be a vector. In that case, the return
1328 value is a new vector that contains the elements between index FROM
1329 \(inclusive) and index TO (exclusive) of that vector argument.
1331 With one argument, just copy STRING (with properties, if any). */)
1332 (Lisp_Object string
, Lisp_Object from
, Lisp_Object to
)
1335 ptrdiff_t size
, ifrom
, ito
;
1337 size
= CHECK_VECTOR_OR_STRING (string
);
1338 validate_subarray (string
, from
, to
, size
, &ifrom
, &ito
);
1340 if (STRINGP (string
))
1343 = !ifrom
? 0 : string_char_to_byte (string
, ifrom
);
1345 = ito
== size
? SBYTES (string
) : string_char_to_byte (string
, ito
);
1346 res
= make_specified_string (SSDATA (string
) + from_byte
,
1347 ito
- ifrom
, to_byte
- from_byte
,
1348 STRING_MULTIBYTE (string
));
1349 copy_text_properties (make_fixnum (ifrom
), make_fixnum (ito
),
1350 string
, make_fixnum (0), res
, Qnil
);
1353 res
= Fvector (ito
- ifrom
, aref_addr (string
, ifrom
));
1359 DEFUN ("substring-no-properties", Fsubstring_no_properties
, Ssubstring_no_properties
, 1, 3, 0,
1360 doc
: /* Return a substring of STRING, without text properties.
1361 It starts at index FROM and ends before TO.
1362 TO may be nil or omitted; then the substring runs to the end of STRING.
1363 If FROM is nil or omitted, the substring starts at the beginning of STRING.
1364 If FROM or TO is negative, it counts from the end.
1366 With one argument, just copy STRING without its properties. */)
1367 (Lisp_Object string
, register Lisp_Object from
, Lisp_Object to
)
1369 ptrdiff_t from_char
, to_char
, from_byte
, to_byte
, size
;
1371 CHECK_STRING (string
);
1373 size
= SCHARS (string
);
1374 validate_subarray (string
, from
, to
, size
, &from_char
, &to_char
);
1376 from_byte
= !from_char
? 0 : string_char_to_byte (string
, from_char
);
1378 to_char
== size
? SBYTES (string
) : string_char_to_byte (string
, to_char
);
1379 return make_specified_string (SSDATA (string
) + from_byte
,
1380 to_char
- from_char
, to_byte
- from_byte
,
1381 STRING_MULTIBYTE (string
));
1384 /* Extract a substring of STRING, giving start and end positions
1385 both in characters and in bytes. */
1388 substring_both (Lisp_Object string
, ptrdiff_t from
, ptrdiff_t from_byte
,
1389 ptrdiff_t to
, ptrdiff_t to_byte
)
1392 ptrdiff_t size
= CHECK_VECTOR_OR_STRING (string
);
1394 if (!(0 <= from
&& from
<= to
&& to
<= size
))
1395 args_out_of_range_3 (string
, make_fixnum (from
), make_fixnum (to
));
1397 if (STRINGP (string
))
1399 res
= make_specified_string (SSDATA (string
) + from_byte
,
1400 to
- from
, to_byte
- from_byte
,
1401 STRING_MULTIBYTE (string
));
1402 copy_text_properties (make_fixnum (from
), make_fixnum (to
),
1403 string
, make_fixnum (0), res
, Qnil
);
1406 res
= Fvector (to
- from
, aref_addr (string
, from
));
1411 DEFUN ("nthcdr", Fnthcdr
, Snthcdr
, 2, 2, 0,
1412 doc
: /* Take cdr N times on LIST, return the result. */)
1413 (Lisp_Object n
, Lisp_Object list
)
1415 Lisp_Object tail
= list
;
1419 /* A huge but in-range EMACS_INT that can be substituted for a
1420 positive bignum while counting down. It does not introduce
1421 miscounts because a list or cycle cannot possibly be this long,
1422 and any counting error is fixed up later. */
1423 EMACS_INT large_num
= EMACS_INT_MAX
;
1430 /* Speed up small lists by omitting circularity and quit checking. */
1431 if (num
<= SMALL_LIST_LEN_MAX
)
1433 for (; 0 < num
; num
--, tail
= XCDR (tail
))
1436 CHECK_LIST_END (tail
, list
);
1444 if (mpz_sgn (*xbignum_val (n
)) < 0)
1449 EMACS_INT tortoise_num
= num
;
1450 Lisp_Object saved_tail
= tail
;
1451 FOR_EACH_TAIL_SAFE (tail
)
1453 /* If the tortoise just jumped (which is rare),
1454 update TORTOISE_NUM accordingly. */
1455 if (EQ (tail
, li
.tortoise
))
1458 saved_tail
= XCDR (tail
);
1468 CHECK_LIST_END (tail
, list
);
1472 /* TAIL is part of a cycle. Reduce NUM modulo the cycle length to
1473 avoid going around this cycle repeatedly. */
1474 intptr_t cycle_length
= tortoise_num
- num
;
1477 /* Undo any error introduced when LARGE_NUM was substituted for
1478 N, by adding N - LARGE_NUM to NUM, using arithmetic modulo
1480 /* Add N mod CYCLE_LENGTH to NUM. */
1481 if (cycle_length
<= ULONG_MAX
)
1482 num
+= mpz_tdiv_ui (*xbignum_val (n
), cycle_length
);
1485 mpz_set_intmax (mpz
[0], cycle_length
);
1486 mpz_tdiv_r (mpz
[0], *xbignum_val (n
), mpz
[0]);
1488 mpz_export (&iz
, NULL
, -1, sizeof iz
, 0, 0, mpz
[0]);
1491 num
+= cycle_length
- large_num
% cycle_length
;
1493 num
%= cycle_length
;
1495 /* One last time through the cycle. */
1496 for (; 0 < num
; num
--)
1504 DEFUN ("nth", Fnth
, Snth
, 2, 2, 0,
1505 doc
: /* Return the Nth element of LIST.
1506 N counts from zero. If LIST is not that long, nil is returned. */)
1507 (Lisp_Object n
, Lisp_Object list
)
1509 return Fcar (Fnthcdr (n
, list
));
1512 DEFUN ("elt", Felt
, Selt
, 2, 2, 0,
1513 doc
: /* Return element of SEQUENCE at index N. */)
1514 (Lisp_Object sequence
, Lisp_Object n
)
1516 if (CONSP (sequence
) || NILP (sequence
))
1517 return Fcar (Fnthcdr (n
, sequence
));
1519 /* Faref signals a "not array" error, so check here. */
1520 CHECK_ARRAY (sequence
, Qsequencep
);
1521 return Faref (sequence
, n
);
1524 enum { WORDS_PER_DOUBLE
= (sizeof (double) / sizeof (EMACS_UINT
)
1525 + (sizeof (double) % sizeof (EMACS_UINT
) != 0)) };
1526 union double_and_words
1529 EMACS_UINT word
[WORDS_PER_DOUBLE
];
1532 /* Return true if the floats X and Y have the same value.
1533 This looks at X's and Y's representation, since (unlike '==')
1534 it returns true if X and Y are the same NaN. */
1536 same_float (Lisp_Object x
, Lisp_Object y
)
1538 union double_and_words
1539 xu
= { .val
= XFLOAT_DATA (x
) },
1540 yu
= { .val
= XFLOAT_DATA (y
) };
1541 EMACS_UINT neql
= 0;
1542 for (int i
= 0; i
< WORDS_PER_DOUBLE
; i
++)
1543 neql
|= xu
.word
[i
] ^ yu
.word
[i
];
1547 DEFUN ("member", Fmember
, Smember
, 2, 2, 0,
1548 doc
: /* Return non-nil if ELT is an element of LIST. Comparison done with `equal'.
1549 The value is actually the tail of LIST whose car is ELT. */)
1550 (Lisp_Object elt
, Lisp_Object list
)
1552 Lisp_Object tail
= list
;
1553 FOR_EACH_TAIL (tail
)
1554 if (! NILP (Fequal (elt
, XCAR (tail
))))
1556 CHECK_LIST_END (tail
, list
);
1560 DEFUN ("memq", Fmemq
, Smemq
, 2, 2, 0,
1561 doc
: /* Return non-nil if ELT is an element of LIST. Comparison done with `eq'.
1562 The value is actually the tail of LIST whose car is ELT. */)
1563 (Lisp_Object elt
, Lisp_Object list
)
1565 Lisp_Object tail
= list
;
1566 FOR_EACH_TAIL (tail
)
1567 if (EQ (XCAR (tail
), elt
))
1569 CHECK_LIST_END (tail
, list
);
1573 DEFUN ("memql", Fmemql
, Smemql
, 2, 2, 0,
1574 doc
: /* Return non-nil if ELT is an element of LIST. Comparison done with `eql'.
1575 The value is actually the tail of LIST whose car is ELT. */)
1576 (Lisp_Object elt
, Lisp_Object list
)
1578 Lisp_Object tail
= list
;
1582 FOR_EACH_TAIL (tail
)
1584 Lisp_Object tem
= XCAR (tail
);
1585 if (FLOATP (tem
) && same_float (elt
, tem
))
1589 else if (BIGNUMP (elt
))
1591 FOR_EACH_TAIL (tail
)
1593 Lisp_Object tem
= XCAR (tail
);
1595 && mpz_cmp (*xbignum_val (elt
), *xbignum_val (tem
)) == 0)
1600 return Fmemq (elt
, list
);
1602 CHECK_LIST_END (tail
, list
);
1606 DEFUN ("assq", Fassq
, Sassq
, 2, 2, 0,
1607 doc
: /* Return non-nil if KEY is `eq' to the car of an element of LIST.
1608 The value is actually the first element of LIST whose car is KEY.
1609 Elements of LIST that are not conses are ignored. */)
1610 (Lisp_Object key
, Lisp_Object list
)
1612 Lisp_Object tail
= list
;
1613 FOR_EACH_TAIL (tail
)
1614 if (CONSP (XCAR (tail
)) && EQ (XCAR (XCAR (tail
)), key
))
1616 CHECK_LIST_END (tail
, list
);
1620 /* Like Fassq but never report an error and do not allow quits.
1621 Use only on objects known to be non-circular lists. */
1624 assq_no_quit (Lisp_Object key
, Lisp_Object list
)
1626 for (; ! NILP (list
); list
= XCDR (list
))
1627 if (CONSP (XCAR (list
)) && EQ (XCAR (XCAR (list
)), key
))
1632 DEFUN ("assoc", Fassoc
, Sassoc
, 2, 3, 0,
1633 doc
: /* Return non-nil if KEY is equal to the car of an element of LIST.
1634 The value is actually the first element of LIST whose car equals KEY.
1636 Equality is defined by TESTFN if non-nil or by `equal' if nil. */)
1637 (Lisp_Object key
, Lisp_Object list
, Lisp_Object testfn
)
1639 Lisp_Object tail
= list
;
1640 FOR_EACH_TAIL (tail
)
1642 Lisp_Object car
= XCAR (tail
);
1645 ? (EQ (XCAR (car
), key
) || !NILP (Fequal
1647 : !NILP (call2 (testfn
, XCAR (car
), key
))))
1650 CHECK_LIST_END (tail
, list
);
1654 /* Like Fassoc but never report an error and do not allow quits.
1655 Use only on keys and lists known to be non-circular, and on keys
1656 that are not too deep and are not window configurations. */
1659 assoc_no_quit (Lisp_Object key
, Lisp_Object list
)
1661 for (; ! NILP (list
); list
= XCDR (list
))
1663 Lisp_Object car
= XCAR (list
);
1665 && (EQ (XCAR (car
), key
) || equal_no_quit (XCAR (car
), key
)))
1671 DEFUN ("rassq", Frassq
, Srassq
, 2, 2, 0,
1672 doc
: /* Return non-nil if KEY is `eq' to the cdr of an element of LIST.
1673 The value is actually the first element of LIST whose cdr is KEY. */)
1674 (Lisp_Object key
, Lisp_Object list
)
1676 Lisp_Object tail
= list
;
1677 FOR_EACH_TAIL (tail
)
1678 if (CONSP (XCAR (tail
)) && EQ (XCDR (XCAR (tail
)), key
))
1680 CHECK_LIST_END (tail
, list
);
1684 DEFUN ("rassoc", Frassoc
, Srassoc
, 2, 2, 0,
1685 doc
: /* Return non-nil if KEY is `equal' to the cdr of an element of LIST.
1686 The value is actually the first element of LIST whose cdr equals KEY. */)
1687 (Lisp_Object key
, Lisp_Object list
)
1689 Lisp_Object tail
= list
;
1690 FOR_EACH_TAIL (tail
)
1692 Lisp_Object car
= XCAR (tail
);
1694 && (EQ (XCDR (car
), key
) || !NILP (Fequal (XCDR (car
), key
))))
1697 CHECK_LIST_END (tail
, list
);
1701 DEFUN ("delq", Fdelq
, Sdelq
, 2, 2, 0,
1702 doc
: /* Delete members of LIST which are `eq' to ELT, and return the result.
1703 More precisely, this function skips any members `eq' to ELT at the
1704 front of LIST, then removes members `eq' to ELT from the remaining
1705 sublist by modifying its list structure, then returns the resulting
1708 Write `(setq foo (delq element foo))' to be sure of correctly changing
1709 the value of a list `foo'. See also `remq', which does not modify the
1711 (Lisp_Object elt
, Lisp_Object list
)
1713 Lisp_Object prev
= Qnil
, tail
= list
;
1715 FOR_EACH_TAIL (tail
)
1717 Lisp_Object tem
= XCAR (tail
);
1723 Fsetcdr (prev
, XCDR (tail
));
1728 CHECK_LIST_END (tail
, list
);
1732 DEFUN ("delete", Fdelete
, Sdelete
, 2, 2, 0,
1733 doc
: /* Delete members of SEQ which are `equal' to ELT, and return the result.
1734 SEQ must be a sequence (i.e. a list, a vector, or a string).
1735 The return value is a sequence of the same type.
1737 If SEQ is a list, this behaves like `delq', except that it compares
1738 with `equal' instead of `eq'. In particular, it may remove elements
1739 by altering the list structure.
1741 If SEQ is not a list, deletion is never performed destructively;
1742 instead this function creates and returns a new vector or string.
1744 Write `(setq foo (delete element foo))' to be sure of correctly
1745 changing the value of a sequence `foo'. */)
1746 (Lisp_Object elt
, Lisp_Object seq
)
1752 for (i
= n
= 0; i
< ASIZE (seq
); ++i
)
1753 if (NILP (Fequal (AREF (seq
, i
), elt
)))
1756 if (n
!= ASIZE (seq
))
1758 struct Lisp_Vector
*p
= allocate_vector (n
);
1760 for (i
= n
= 0; i
< ASIZE (seq
); ++i
)
1761 if (NILP (Fequal (AREF (seq
, i
), elt
)))
1762 p
->contents
[n
++] = AREF (seq
, i
);
1764 XSETVECTOR (seq
, p
);
1767 else if (STRINGP (seq
))
1769 ptrdiff_t i
, ibyte
, nchars
, nbytes
, cbytes
;
1772 for (i
= nchars
= nbytes
= ibyte
= 0;
1774 ++i
, ibyte
+= cbytes
)
1776 if (STRING_MULTIBYTE (seq
))
1778 c
= STRING_CHAR (SDATA (seq
) + ibyte
);
1779 cbytes
= CHAR_BYTES (c
);
1787 if (!FIXNUMP (elt
) || c
!= XFIXNUM (elt
))
1794 if (nchars
!= SCHARS (seq
))
1798 tem
= make_uninit_multibyte_string (nchars
, nbytes
);
1799 if (!STRING_MULTIBYTE (seq
))
1800 STRING_SET_UNIBYTE (tem
);
1802 for (i
= nchars
= nbytes
= ibyte
= 0;
1804 ++i
, ibyte
+= cbytes
)
1806 if (STRING_MULTIBYTE (seq
))
1808 c
= STRING_CHAR (SDATA (seq
) + ibyte
);
1809 cbytes
= CHAR_BYTES (c
);
1817 if (!FIXNUMP (elt
) || c
!= XFIXNUM (elt
))
1819 unsigned char *from
= SDATA (seq
) + ibyte
;
1820 unsigned char *to
= SDATA (tem
) + nbytes
;
1826 for (n
= cbytes
; n
--; )
1836 Lisp_Object prev
= Qnil
, tail
= seq
;
1838 FOR_EACH_TAIL (tail
)
1840 if (!NILP (Fequal (elt
, XCAR (tail
))))
1845 Fsetcdr (prev
, XCDR (tail
));
1850 CHECK_LIST_END (tail
, seq
);
1856 DEFUN ("nreverse", Fnreverse
, Snreverse
, 1, 1, 0,
1857 doc
: /* Reverse order of items in a list, vector or string SEQ.
1858 If SEQ is a list, it should be nil-terminated.
1859 This function may destructively modify SEQ to produce the value. */)
1864 else if (STRINGP (seq
))
1865 return Freverse (seq
);
1866 else if (CONSP (seq
))
1868 Lisp_Object prev
, tail
, next
;
1870 for (prev
= Qnil
, tail
= seq
; CONSP (tail
); tail
= next
)
1873 /* If SEQ contains a cycle, attempting to reverse it
1874 in-place will inevitably come back to SEQ. */
1876 circular_list (seq
);
1877 Fsetcdr (tail
, prev
);
1880 CHECK_LIST_END (tail
, seq
);
1883 else if (VECTORP (seq
))
1885 ptrdiff_t i
, size
= ASIZE (seq
);
1887 for (i
= 0; i
< size
/ 2; i
++)
1889 Lisp_Object tem
= AREF (seq
, i
);
1890 ASET (seq
, i
, AREF (seq
, size
- i
- 1));
1891 ASET (seq
, size
- i
- 1, tem
);
1894 else if (BOOL_VECTOR_P (seq
))
1896 ptrdiff_t i
, size
= bool_vector_size (seq
);
1898 for (i
= 0; i
< size
/ 2; i
++)
1900 bool tem
= bool_vector_bitref (seq
, i
);
1901 bool_vector_set (seq
, i
, bool_vector_bitref (seq
, size
- i
- 1));
1902 bool_vector_set (seq
, size
- i
- 1, tem
);
1906 wrong_type_argument (Qarrayp
, seq
);
1910 DEFUN ("reverse", Freverse
, Sreverse
, 1, 1, 0,
1911 doc
: /* Return the reversed copy of list, vector, or string SEQ.
1912 See also the function `nreverse', which is used more often. */)
1919 else if (CONSP (seq
))
1923 new = Fcons (XCAR (seq
), new);
1924 CHECK_LIST_END (seq
, seq
);
1926 else if (VECTORP (seq
))
1928 ptrdiff_t i
, size
= ASIZE (seq
);
1930 new = make_uninit_vector (size
);
1931 for (i
= 0; i
< size
; i
++)
1932 ASET (new, i
, AREF (seq
, size
- i
- 1));
1934 else if (BOOL_VECTOR_P (seq
))
1937 EMACS_INT nbits
= bool_vector_size (seq
);
1939 new = make_uninit_bool_vector (nbits
);
1940 for (i
= 0; i
< nbits
; i
++)
1941 bool_vector_set (new, i
, bool_vector_bitref (seq
, nbits
- i
- 1));
1943 else if (STRINGP (seq
))
1945 ptrdiff_t size
= SCHARS (seq
), bytes
= SBYTES (seq
);
1951 new = make_uninit_string (size
);
1952 for (i
= 0; i
< size
; i
++)
1953 SSET (new, i
, SREF (seq
, size
- i
- 1));
1957 unsigned char *p
, *q
;
1959 new = make_uninit_multibyte_string (size
, bytes
);
1960 p
= SDATA (seq
), q
= SDATA (new) + bytes
;
1961 while (q
> SDATA (new))
1965 ch
= STRING_CHAR_AND_LENGTH (p
, len
);
1967 CHAR_STRING (ch
, q
);
1972 wrong_type_argument (Qsequencep
, seq
);
1976 /* Sort LIST using PREDICATE, preserving original order of elements
1977 considered as equal. */
1980 sort_list (Lisp_Object list
, Lisp_Object predicate
)
1982 ptrdiff_t length
= list_length (list
);
1986 Lisp_Object tem
= Fnthcdr (make_fixnum (length
/ 2 - 1), list
);
1987 Lisp_Object back
= Fcdr (tem
);
1988 Fsetcdr (tem
, Qnil
);
1990 return merge (Fsort (list
, predicate
), Fsort (back
, predicate
), predicate
);
1993 /* Using PRED to compare, return whether A and B are in order.
1994 Compare stably when A appeared before B in the input. */
1996 inorder (Lisp_Object pred
, Lisp_Object a
, Lisp_Object b
)
1998 return NILP (call2 (pred
, b
, a
));
2001 /* Using PRED to compare, merge from ALEN-length A and BLEN-length B
2002 into DEST. Argument arrays must be nonempty and must not overlap,
2003 except that B might be the last part of DEST. */
2005 merge_vectors (Lisp_Object pred
,
2006 ptrdiff_t alen
, Lisp_Object
const a
[restrict
VLA_ELEMS (alen
)],
2007 ptrdiff_t blen
, Lisp_Object
const b
[VLA_ELEMS (blen
)],
2008 Lisp_Object dest
[VLA_ELEMS (alen
+ blen
)])
2010 eassume (0 < alen
&& 0 < blen
);
2011 Lisp_Object
const *alim
= a
+ alen
;
2012 Lisp_Object
const *blim
= b
+ blen
;
2016 if (inorder (pred
, a
[0], b
[0]))
2022 memcpy (dest
, b
, (blim
- b
) * sizeof *dest
);
2031 memcpy (dest
, a
, (alim
- a
) * sizeof *dest
);
2038 /* Using PRED to compare, sort LEN-length VEC in place, using TMP for
2039 temporary storage. LEN must be at least 2. */
2041 sort_vector_inplace (Lisp_Object pred
, ptrdiff_t len
,
2042 Lisp_Object vec
[restrict
VLA_ELEMS (len
)],
2043 Lisp_Object tmp
[restrict
VLA_ELEMS (len
>> 1)])
2046 ptrdiff_t halflen
= len
>> 1;
2047 sort_vector_copy (pred
, halflen
, vec
, tmp
);
2048 if (1 < len
- halflen
)
2049 sort_vector_inplace (pred
, len
- halflen
, vec
+ halflen
, vec
);
2050 merge_vectors (pred
, halflen
, tmp
, len
- halflen
, vec
+ halflen
, vec
);
2053 /* Using PRED to compare, sort from LEN-length SRC into DST.
2054 Len must be positive. */
2056 sort_vector_copy (Lisp_Object pred
, ptrdiff_t len
,
2057 Lisp_Object src
[restrict
VLA_ELEMS (len
)],
2058 Lisp_Object dest
[restrict
VLA_ELEMS (len
)])
2061 ptrdiff_t halflen
= len
>> 1;
2067 sort_vector_inplace (pred
, halflen
, src
, dest
);
2068 if (1 < len
- halflen
)
2069 sort_vector_inplace (pred
, len
- halflen
, src
+ halflen
, dest
);
2070 merge_vectors (pred
, halflen
, src
, len
- halflen
, src
+ halflen
, dest
);
2074 /* Sort VECTOR in place using PREDICATE, preserving original order of
2075 elements considered as equal. */
2078 sort_vector (Lisp_Object vector
, Lisp_Object predicate
)
2080 ptrdiff_t len
= ASIZE (vector
);
2083 ptrdiff_t halflen
= len
>> 1;
2086 SAFE_ALLOCA_LISP (tmp
, halflen
);
2087 for (ptrdiff_t i
= 0; i
< halflen
; i
++)
2088 tmp
[i
] = make_fixnum (0);
2089 sort_vector_inplace (predicate
, len
, XVECTOR (vector
)->contents
, tmp
);
2093 DEFUN ("sort", Fsort
, Ssort
, 2, 2, 0,
2094 doc
: /* Sort SEQ, stably, comparing elements using PREDICATE.
2095 Returns the sorted sequence. SEQ should be a list or vector. SEQ is
2096 modified by side effects. PREDICATE is called with two elements of
2097 SEQ, and should return non-nil if the first element should sort before
2099 (Lisp_Object seq
, Lisp_Object predicate
)
2102 seq
= sort_list (seq
, predicate
);
2103 else if (VECTORP (seq
))
2104 sort_vector (seq
, predicate
);
2105 else if (!NILP (seq
))
2106 wrong_type_argument (Qlist_or_vector_p
, seq
);
2111 merge (Lisp_Object org_l1
, Lisp_Object org_l2
, Lisp_Object pred
)
2113 Lisp_Object l1
= org_l1
;
2114 Lisp_Object l2
= org_l2
;
2115 Lisp_Object tail
= Qnil
;
2116 Lisp_Object value
= Qnil
;
2136 if (inorder (pred
, Fcar (l1
), Fcar (l2
)))
2151 Fsetcdr (tail
, tem
);
2157 /* This does not check for quits. That is safe since it must terminate. */
2159 DEFUN ("plist-get", Fplist_get
, Splist_get
, 2, 2, 0,
2160 doc
: /* Extract a value from a property list.
2161 PLIST is a property list, which is a list of the form
2162 \(PROP1 VALUE1 PROP2 VALUE2...).
2164 This function returns the value corresponding to the given PROP, or
2165 nil if PROP is not one of the properties on the list. The comparison
2166 with PROP is done using `eq'.
2168 This function never signals an error. */)
2169 (Lisp_Object plist
, Lisp_Object prop
)
2171 Lisp_Object tail
= plist
;
2172 FOR_EACH_TAIL_SAFE (tail
)
2174 if (! CONSP (XCDR (tail
)))
2176 if (EQ (prop
, XCAR (tail
)))
2177 return XCAR (XCDR (tail
));
2184 DEFUN ("get", Fget
, Sget
, 2, 2, 0,
2185 doc
: /* Return the value of SYMBOL's PROPNAME property.
2186 This is the last value stored with `(put SYMBOL PROPNAME VALUE)'. */)
2187 (Lisp_Object symbol
, Lisp_Object propname
)
2189 CHECK_SYMBOL (symbol
);
2190 Lisp_Object propval
= Fplist_get (CDR (Fassq (symbol
, Voverriding_plist_environment
)),
2192 if (!NILP (propval
))
2194 return Fplist_get (XSYMBOL (symbol
)->u
.s
.plist
, propname
);
2197 DEFUN ("plist-put", Fplist_put
, Splist_put
, 3, 3, 0,
2198 doc
: /* Change value in PLIST of PROP to VAL.
2199 PLIST is a property list, which is a list of the form
2200 \(PROP1 VALUE1 PROP2 VALUE2 ...). PROP is a symbol and VAL is any object.
2201 If PROP is already a property on the list, its value is set to VAL,
2202 otherwise the new PROP VAL pair is added. The new plist is returned;
2203 use `(setq x (plist-put x prop val))' to be sure to use the new value.
2204 The PLIST is modified by side effects. */)
2205 (Lisp_Object plist
, Lisp_Object prop
, Lisp_Object val
)
2207 Lisp_Object prev
= Qnil
, tail
= plist
;
2208 FOR_EACH_TAIL (tail
)
2210 if (! CONSP (XCDR (tail
)))
2213 if (EQ (prop
, XCAR (tail
)))
2215 Fsetcar (XCDR (tail
), val
);
2222 CHECK_TYPE (NILP (tail
), Qplistp
, plist
);
2224 = Fcons (prop
, Fcons (val
, NILP (prev
) ? plist
: XCDR (XCDR (prev
))));
2227 Fsetcdr (XCDR (prev
), newcell
);
2231 DEFUN ("put", Fput
, Sput
, 3, 3, 0,
2232 doc
: /* Store SYMBOL's PROPNAME property with value VALUE.
2233 It can be retrieved with `(get SYMBOL PROPNAME)'. */)
2234 (Lisp_Object symbol
, Lisp_Object propname
, Lisp_Object value
)
2236 CHECK_SYMBOL (symbol
);
2238 (symbol
, Fplist_put (XSYMBOL (symbol
)->u
.s
.plist
, propname
, value
));
2242 DEFUN ("lax-plist-get", Flax_plist_get
, Slax_plist_get
, 2, 2, 0,
2243 doc
: /* Extract a value from a property list, comparing with `equal'.
2244 This function is otherwise like `plist-get', but may signal an error
2245 if PLIST isn't a valid plist. */)
2246 (Lisp_Object plist
, Lisp_Object prop
)
2248 Lisp_Object tail
= plist
;
2249 FOR_EACH_TAIL (tail
)
2251 if (! CONSP (XCDR (tail
)))
2253 if (! NILP (Fequal (prop
, XCAR (tail
))))
2254 return XCAR (XCDR (tail
));
2258 CHECK_TYPE (NILP (tail
), Qplistp
, plist
);
2263 DEFUN ("lax-plist-put", Flax_plist_put
, Slax_plist_put
, 3, 3, 0,
2264 doc
: /* Change value in PLIST of PROP to VAL, comparing with `equal'.
2265 PLIST is a property list, which is a list of the form
2266 \(PROP1 VALUE1 PROP2 VALUE2 ...). PROP and VAL are any objects.
2267 If PROP is already a property on the list, its value is set to VAL,
2268 otherwise the new PROP VAL pair is added. The new plist is returned;
2269 use `(setq x (lax-plist-put x prop val))' to be sure to use the new value.
2270 The PLIST is modified by side effects. */)
2271 (Lisp_Object plist
, Lisp_Object prop
, Lisp_Object val
)
2273 Lisp_Object prev
= Qnil
, tail
= plist
;
2274 FOR_EACH_TAIL (tail
)
2276 if (! CONSP (XCDR (tail
)))
2279 if (! NILP (Fequal (prop
, XCAR (tail
))))
2281 Fsetcar (XCDR (tail
), val
);
2288 CHECK_TYPE (NILP (tail
), Qplistp
, plist
);
2289 Lisp_Object newcell
= list2 (prop
, val
);
2292 Fsetcdr (XCDR (prev
), newcell
);
2296 DEFUN ("eql", Feql
, Seql
, 2, 2, 0,
2297 doc
: /* Return t if the two args are `eq' or are indistinguishable numbers.
2298 Floating-point values with the same sign, exponent and fraction are `eql'.
2299 This differs from numeric comparison: (eql 0.0 -0.0) returns nil and
2300 \(eql 0.0e+NaN 0.0e+NaN) returns t, whereas `=' does the opposite. */)
2301 (Lisp_Object obj1
, Lisp_Object obj2
)
2304 return FLOATP (obj2
) && same_float (obj1
, obj2
) ? Qt
: Qnil
;
2305 else if (BIGNUMP (obj1
))
2306 return ((BIGNUMP (obj2
)
2307 && mpz_cmp (*xbignum_val (obj1
), *xbignum_val (obj2
)) == 0)
2310 return EQ (obj1
, obj2
) ? Qt
: Qnil
;
2313 DEFUN ("equal", Fequal
, Sequal
, 2, 2, 0,
2314 doc
: /* Return t if two Lisp objects have similar structure and contents.
2315 They must have the same data type.
2316 Conses are compared by comparing the cars and the cdrs.
2317 Vectors and strings are compared element by element.
2318 Numbers are compared via `eql', so integers do not equal floats.
2319 \(Use `=' if you want integers and floats to be able to be equal.)
2320 Symbols must match exactly. */)
2321 (Lisp_Object o1
, Lisp_Object o2
)
2323 return internal_equal (o1
, o2
, EQUAL_PLAIN
, 0, Qnil
) ? Qt
: Qnil
;
2326 DEFUN ("equal-including-properties", Fequal_including_properties
, Sequal_including_properties
, 2, 2, 0,
2327 doc
: /* Return t if two Lisp objects have similar structure and contents.
2328 This is like `equal' except that it compares the text properties
2329 of strings. (`equal' ignores text properties.) */)
2330 (Lisp_Object o1
, Lisp_Object o2
)
2332 return (internal_equal (o1
, o2
, EQUAL_INCLUDING_PROPERTIES
, 0, Qnil
)
2336 /* Return true if O1 and O2 are equal. Do not quit or check for cycles.
2337 Use this only on arguments that are cycle-free and not too large and
2338 are not window configurations. */
2341 equal_no_quit (Lisp_Object o1
, Lisp_Object o2
)
2343 return internal_equal (o1
, o2
, EQUAL_NO_QUIT
, 0, Qnil
);
2346 /* Return true if O1 and O2 are equal. EQUAL_KIND specifies what kind
2347 of equality test to use: if it is EQUAL_NO_QUIT, do not check for
2348 cycles or large arguments or quits; if EQUAL_PLAIN, do ordinary
2349 Lisp equality; and if EQUAL_INCLUDING_PROPERTIES, do
2350 equal-including-properties.
2352 If DEPTH is the current depth of recursion; signal an error if it
2353 gets too deep. HT is a hash table used to detect cycles; if nil,
2354 it has not been allocated yet. But ignore the last two arguments
2355 if EQUAL_KIND == EQUAL_NO_QUIT. */
2358 internal_equal (Lisp_Object o1
, Lisp_Object o2
, enum equal_kind equal_kind
,
2359 int depth
, Lisp_Object ht
)
2364 eassert (equal_kind
!= EQUAL_NO_QUIT
);
2366 error ("Stack overflow in equal");
2368 ht
= CALLN (Fmake_hash_table
, QCtest
, Qeq
);
2371 case Lisp_Cons
: case Lisp_Vectorlike
:
2373 struct Lisp_Hash_Table
*h
= XHASH_TABLE (ht
);
2375 ptrdiff_t i
= hash_lookup (h
, o1
, &hash
);
2377 { /* `o1' was seen already. */
2378 Lisp_Object o2s
= HASH_VALUE (h
, i
);
2379 if (!NILP (Fmemq (o2
, o2s
)))
2382 set_hash_value_slot (h
, i
, Fcons (o2
, o2s
));
2385 hash_put (h
, o1
, Fcons (o2
, Qnil
), hash
);
2393 if (XTYPE (o1
) != XTYPE (o2
))
2399 return same_float (o1
, o2
);
2402 if (equal_kind
== EQUAL_NO_QUIT
)
2403 for (; CONSP (o1
); o1
= XCDR (o1
))
2407 if (! equal_no_quit (XCAR (o1
), XCAR (o2
)))
2410 if (EQ (XCDR (o1
), o2
))
2418 if (! internal_equal (XCAR (o1
), XCAR (o2
),
2419 equal_kind
, depth
+ 1, ht
))
2422 if (EQ (XCDR (o1
), o2
))
2428 case Lisp_Vectorlike
:
2430 ptrdiff_t size
= ASIZE (o1
);
2431 /* Pseudovectors have the type encoded in the size field, so this test
2432 actually checks that the objects have the same type as well as the
2434 if (ASIZE (o2
) != size
)
2437 return mpz_cmp (*xbignum_val (o1
), *xbignum_val (o2
)) == 0;
2440 if (!internal_equal (OVERLAY_START (o1
), OVERLAY_START (o2
),
2441 equal_kind
, depth
+ 1, ht
)
2442 || !internal_equal (OVERLAY_END (o1
), OVERLAY_END (o2
),
2443 equal_kind
, depth
+ 1, ht
))
2445 o1
= XOVERLAY (o1
)->plist
;
2446 o2
= XOVERLAY (o2
)->plist
;
2452 return (XMARKER (o1
)->buffer
== XMARKER (o2
)->buffer
2453 && (XMARKER (o1
)->buffer
== 0
2454 || XMARKER (o1
)->bytepos
== XMARKER (o2
)->bytepos
));
2456 /* Boolvectors are compared much like strings. */
2457 if (BOOL_VECTOR_P (o1
))
2459 EMACS_INT size
= bool_vector_size (o1
);
2460 if (size
!= bool_vector_size (o2
))
2462 if (memcmp (bool_vector_data (o1
), bool_vector_data (o2
),
2463 bool_vector_bytes (size
)))
2467 if (WINDOW_CONFIGURATIONP (o1
))
2469 eassert (equal_kind
!= EQUAL_NO_QUIT
);
2470 return compare_window_configurations (o1
, o2
, false);
2473 /* Aside from them, only true vectors, char-tables, compiled
2474 functions, and fonts (font-spec, font-entity, font-object)
2475 are sensible to compare, so eliminate the others now. */
2476 if (size
& PSEUDOVECTOR_FLAG
)
2478 if (((size
& PVEC_TYPE_MASK
) >> PSEUDOVECTOR_AREA_BITS
)
2481 size
&= PSEUDOVECTOR_SIZE_MASK
;
2483 for (ptrdiff_t i
= 0; i
< size
; i
++)
2488 if (!internal_equal (v1
, v2
, equal_kind
, depth
+ 1, ht
))
2496 if (SCHARS (o1
) != SCHARS (o2
))
2498 if (SBYTES (o1
) != SBYTES (o2
))
2500 if (memcmp (SDATA (o1
), SDATA (o2
), SBYTES (o1
)))
2502 if (equal_kind
== EQUAL_INCLUDING_PROPERTIES
2503 && !compare_string_intervals (o1
, o2
))
2515 DEFUN ("fillarray", Ffillarray
, Sfillarray
, 2, 2, 0,
2516 doc
: /* Store each element of ARRAY with ITEM.
2517 ARRAY is a vector, string, char-table, or bool-vector. */)
2518 (Lisp_Object array
, Lisp_Object item
)
2520 register ptrdiff_t size
, idx
;
2522 if (VECTORP (array
))
2523 for (idx
= 0, size
= ASIZE (array
); idx
< size
; idx
++)
2524 ASET (array
, idx
, item
);
2525 else if (CHAR_TABLE_P (array
))
2529 for (i
= 0; i
< (1 << CHARTAB_SIZE_BITS_0
); i
++)
2530 set_char_table_contents (array
, i
, item
);
2531 set_char_table_defalt (array
, item
);
2533 else if (STRINGP (array
))
2535 register unsigned char *p
= SDATA (array
);
2537 CHECK_CHARACTER (item
);
2538 charval
= XFIXNAT (item
);
2539 size
= SCHARS (array
);
2540 if (STRING_MULTIBYTE (array
))
2542 unsigned char str
[MAX_MULTIBYTE_LENGTH
];
2543 int len
= CHAR_STRING (charval
, str
);
2544 ptrdiff_t size_byte
= SBYTES (array
);
2547 if (INT_MULTIPLY_WRAPV (size
, len
, &product
) || product
!= size_byte
)
2548 error ("Attempt to change byte length of a string");
2549 for (idx
= 0; idx
< size_byte
; idx
++)
2550 *p
++ = str
[idx
% len
];
2553 for (idx
= 0; idx
< size
; idx
++)
2556 else if (BOOL_VECTOR_P (array
))
2557 return bool_vector_fill (array
, item
);
2559 wrong_type_argument (Qarrayp
, array
);
2563 DEFUN ("clear-string", Fclear_string
, Sclear_string
,
2565 doc
: /* Clear the contents of STRING.
2566 This makes STRING unibyte and may change its length. */)
2567 (Lisp_Object string
)
2570 CHECK_STRING (string
);
2571 len
= SBYTES (string
);
2572 memset (SDATA (string
), 0, len
);
2573 STRING_SET_CHARS (string
, len
);
2574 STRING_SET_UNIBYTE (string
);
2579 nconc2 (Lisp_Object s1
, Lisp_Object s2
)
2581 return CALLN (Fnconc
, s1
, s2
);
2584 DEFUN ("nconc", Fnconc
, Snconc
, 0, MANY
, 0,
2585 doc
: /* Concatenate any number of lists by altering them.
2586 Only the last argument is not altered, and need not be a list.
2587 usage: (nconc &rest LISTS) */)
2588 (ptrdiff_t nargs
, Lisp_Object
*args
)
2590 Lisp_Object val
= Qnil
;
2592 for (ptrdiff_t argnum
= 0; argnum
< nargs
; argnum
++)
2594 Lisp_Object tem
= args
[argnum
];
2595 if (NILP (tem
)) continue;
2600 if (argnum
+ 1 == nargs
) break;
2604 Lisp_Object tail UNINIT
;
2608 tem
= args
[argnum
+ 1];
2609 Fsetcdr (tail
, tem
);
2611 args
[argnum
+ 1] = tail
;
2617 /* This is the guts of all mapping functions.
2618 Apply FN to each element of SEQ, one by one, storing the results
2619 into elements of VALS, a C vector of Lisp_Objects. LENI is the
2620 length of VALS, which should also be the length of SEQ. Return the
2621 number of results; although this is normally LENI, it can be less
2622 if SEQ is made shorter as a side effect of FN. */
2625 mapcar1 (EMACS_INT leni
, Lisp_Object
*vals
, Lisp_Object fn
, Lisp_Object seq
)
2627 Lisp_Object tail
, dummy
;
2630 if (VECTORP (seq
) || COMPILEDP (seq
))
2632 for (i
= 0; i
< leni
; i
++)
2634 dummy
= call1 (fn
, AREF (seq
, i
));
2639 else if (BOOL_VECTOR_P (seq
))
2641 for (i
= 0; i
< leni
; i
++)
2643 dummy
= call1 (fn
, bool_vector_ref (seq
, i
));
2648 else if (STRINGP (seq
))
2652 for (i
= 0, i_byte
= 0; i
< leni
;)
2655 ptrdiff_t i_before
= i
;
2657 FETCH_STRING_CHAR_ADVANCE (c
, seq
, i
, i_byte
);
2658 XSETFASTINT (dummy
, c
);
2659 dummy
= call1 (fn
, dummy
);
2661 vals
[i_before
] = dummy
;
2664 else /* Must be a list, since Flength did not get an error */
2667 for (i
= 0; i
< leni
; i
++)
2671 dummy
= call1 (fn
, XCAR (tail
));
2681 DEFUN ("mapconcat", Fmapconcat
, Smapconcat
, 3, 3, 0,
2682 doc
: /* Apply FUNCTION to each element of SEQUENCE, and concat the results as strings.
2683 In between each pair of results, stick in SEPARATOR. Thus, " " as
2684 SEPARATOR results in spaces between the values returned by FUNCTION.
2685 SEQUENCE may be a list, a vector, a bool-vector, or a string.
2686 SEPARATOR must be a string, a vector, or a list of characters.
2687 FUNCTION must be a function of one argument, and must return a value
2688 that is a sequence of characters: either a string, or a vector or
2689 list of numbers that are valid character codepoints. */)
2690 (Lisp_Object function
, Lisp_Object sequence
, Lisp_Object separator
)
2693 EMACS_INT leni
= XFIXNAT (Flength (sequence
));
2694 if (CHAR_TABLE_P (sequence
))
2695 wrong_type_argument (Qlistp
, sequence
);
2696 EMACS_INT args_alloc
= 2 * leni
- 1;
2698 return empty_unibyte_string
;
2700 SAFE_ALLOCA_LISP (args
, args_alloc
);
2701 ptrdiff_t nmapped
= mapcar1 (leni
, args
, function
, sequence
);
2702 ptrdiff_t nargs
= 2 * nmapped
- 1;
2704 for (ptrdiff_t i
= nmapped
- 1; i
> 0; i
--)
2705 args
[i
+ i
] = args
[i
];
2707 for (ptrdiff_t i
= 1; i
< nargs
; i
+= 2)
2708 args
[i
] = separator
;
2710 Lisp_Object ret
= Fconcat (nargs
, args
);
2715 DEFUN ("mapcar", Fmapcar
, Smapcar
, 2, 2, 0,
2716 doc
: /* Apply FUNCTION to each element of SEQUENCE, and make a list of the results.
2717 The result is a list just as long as SEQUENCE.
2718 SEQUENCE may be a list, a vector, a bool-vector, or a string. */)
2719 (Lisp_Object function
, Lisp_Object sequence
)
2722 EMACS_INT leni
= XFIXNAT (Flength (sequence
));
2723 if (CHAR_TABLE_P (sequence
))
2724 wrong_type_argument (Qlistp
, sequence
);
2726 SAFE_ALLOCA_LISP (args
, leni
);
2727 ptrdiff_t nmapped
= mapcar1 (leni
, args
, function
, sequence
);
2728 Lisp_Object ret
= Flist (nmapped
, args
);
2733 DEFUN ("mapc", Fmapc
, Smapc
, 2, 2, 0,
2734 doc
: /* Apply FUNCTION to each element of SEQUENCE for side effects only.
2735 Unlike `mapcar', don't accumulate the results. Return SEQUENCE.
2736 SEQUENCE may be a list, a vector, a bool-vector, or a string. */)
2737 (Lisp_Object function
, Lisp_Object sequence
)
2739 register EMACS_INT leni
;
2741 leni
= XFIXNAT (Flength (sequence
));
2742 if (CHAR_TABLE_P (sequence
))
2743 wrong_type_argument (Qlistp
, sequence
);
2744 mapcar1 (leni
, 0, function
, sequence
);
2749 DEFUN ("mapcan", Fmapcan
, Smapcan
, 2, 2, 0,
2750 doc
: /* Apply FUNCTION to each element of SEQUENCE, and concatenate
2751 the results by altering them (using `nconc').
2752 SEQUENCE may be a list, a vector, a bool-vector, or a string. */)
2753 (Lisp_Object function
, Lisp_Object sequence
)
2756 EMACS_INT leni
= XFIXNAT (Flength (sequence
));
2757 if (CHAR_TABLE_P (sequence
))
2758 wrong_type_argument (Qlistp
, sequence
);
2760 SAFE_ALLOCA_LISP (args
, leni
);
2761 ptrdiff_t nmapped
= mapcar1 (leni
, args
, function
, sequence
);
2762 Lisp_Object ret
= Fnconc (nmapped
, args
);
2767 /* This is how C code calls `yes-or-no-p' and allows the user
2771 do_yes_or_no_p (Lisp_Object prompt
)
2773 return call1 (intern ("yes-or-no-p"), prompt
);
2776 DEFUN ("yes-or-no-p", Fyes_or_no_p
, Syes_or_no_p
, 1, 1, 0,
2777 doc
: /* Ask user a yes-or-no question.
2778 Return t if answer is yes, and nil if the answer is no.
2779 PROMPT is the string to display to ask the question. It should end in
2780 a space; `yes-or-no-p' adds \"(yes or no) \" to it.
2782 The user must confirm the answer with RET, and can edit it until it
2785 If dialog boxes are supported, a dialog box will be used
2786 if `last-nonmenu-event' is nil, and `use-dialog-box' is non-nil. */)
2787 (Lisp_Object prompt
)
2791 CHECK_STRING (prompt
);
2793 if ((NILP (last_nonmenu_event
) || CONSP (last_nonmenu_event
))
2794 && use_dialog_box
&& ! NILP (last_input_event
))
2796 Lisp_Object pane
, menu
, obj
;
2797 redisplay_preserve_echo_area (4);
2798 pane
= list2 (Fcons (build_string ("Yes"), Qt
),
2799 Fcons (build_string ("No"), Qnil
));
2800 menu
= Fcons (prompt
, pane
);
2801 obj
= Fx_popup_dialog (Qt
, menu
, Qnil
);
2805 AUTO_STRING (yes_or_no
, "(yes or no) ");
2806 prompt
= CALLN (Fconcat
, prompt
, yes_or_no
);
2810 ans
= Fdowncase (Fread_from_minibuffer (prompt
, Qnil
, Qnil
, Qnil
,
2811 Qyes_or_no_p_history
, Qnil
,
2813 if (SCHARS (ans
) == 3 && !strcmp (SSDATA (ans
), "yes"))
2815 if (SCHARS (ans
) == 2 && !strcmp (SSDATA (ans
), "no"))
2820 message1 ("Please answer yes or no.");
2821 Fsleep_for (make_fixnum (2), Qnil
);
2825 DEFUN ("load-average", Fload_average
, Sload_average
, 0, 1, 0,
2826 doc
: /* Return list of 1 minute, 5 minute and 15 minute load averages.
2828 Each of the three load averages is multiplied by 100, then converted
2831 When USE-FLOATS is non-nil, floats will be used instead of integers.
2832 These floats are not multiplied by 100.
2834 If the 5-minute or 15-minute load averages are not available, return a
2835 shortened list, containing only those averages which are available.
2837 An error is thrown if the load average can't be obtained. In some
2838 cases making it work would require Emacs being installed setuid or
2839 setgid so that it can read kernel information, and that usually isn't
2841 (Lisp_Object use_floats
)
2844 int loads
= getloadavg (load_ave
, 3);
2845 Lisp_Object ret
= Qnil
;
2848 error ("load-average not implemented for this operating system");
2852 Lisp_Object load
= (NILP (use_floats
)
2853 ? make_fixnum (100.0 * load_ave
[loads
])
2854 : make_float (load_ave
[loads
]));
2855 ret
= Fcons (load
, ret
);
2861 DEFUN ("featurep", Ffeaturep
, Sfeaturep
, 1, 2, 0,
2862 doc
: /* Return t if FEATURE is present in this Emacs.
2864 Use this to conditionalize execution of lisp code based on the
2865 presence or absence of Emacs or environment extensions.
2866 Use `provide' to declare that a feature is available. This function
2867 looks at the value of the variable `features'. The optional argument
2868 SUBFEATURE can be used to check a specific subfeature of FEATURE. */)
2869 (Lisp_Object feature
, Lisp_Object subfeature
)
2871 register Lisp_Object tem
;
2872 CHECK_SYMBOL (feature
);
2873 tem
= Fmemq (feature
, Vfeatures
);
2874 if (!NILP (tem
) && !NILP (subfeature
))
2875 tem
= Fmember (subfeature
, Fget (feature
, Qsubfeatures
));
2876 return (NILP (tem
)) ? Qnil
: Qt
;
2879 DEFUN ("provide", Fprovide
, Sprovide
, 1, 2, 0,
2880 doc
: /* Announce that FEATURE is a feature of the current Emacs.
2881 The optional argument SUBFEATURES should be a list of symbols listing
2882 particular subfeatures supported in this version of FEATURE. */)
2883 (Lisp_Object feature
, Lisp_Object subfeatures
)
2885 register Lisp_Object tem
;
2886 CHECK_SYMBOL (feature
);
2887 CHECK_LIST (subfeatures
);
2888 if (!NILP (Vautoload_queue
))
2889 Vautoload_queue
= Fcons (Fcons (make_fixnum (0), Vfeatures
),
2891 tem
= Fmemq (feature
, Vfeatures
);
2893 Vfeatures
= Fcons (feature
, Vfeatures
);
2894 if (!NILP (subfeatures
))
2895 Fput (feature
, Qsubfeatures
, subfeatures
);
2896 LOADHIST_ATTACH (Fcons (Qprovide
, feature
));
2898 /* Run any load-hooks for this file. */
2899 tem
= Fassq (feature
, Vafter_load_alist
);
2901 Fmapc (Qfuncall
, XCDR (tem
));
2906 /* `require' and its subroutines. */
2908 /* List of features currently being require'd, innermost first. */
2910 static Lisp_Object require_nesting_list
;
2913 require_unwind (Lisp_Object old_value
)
2915 require_nesting_list
= old_value
;
2918 DEFUN ("require", Frequire
, Srequire
, 1, 3, 0,
2919 doc
: /* If feature FEATURE is not loaded, load it from FILENAME.
2920 If FEATURE is not a member of the list `features', then the feature is
2921 not loaded; so load the file FILENAME.
2923 If FILENAME is omitted, the printname of FEATURE is used as the file
2924 name, and `load' will try to load this name appended with the suffix
2925 `.elc', `.el', or the system-dependent suffix for dynamic module
2926 files, in that order. The name without appended suffix will not be
2927 used. See `get-load-suffixes' for the complete list of suffixes.
2929 The directories in `load-path' are searched when trying to find the
2932 If the optional third argument NOERROR is non-nil, then return nil if
2933 the file is not found instead of signaling an error. Normally the
2934 return value is FEATURE.
2936 The normal messages at start and end of loading FILENAME are
2938 (Lisp_Object feature
, Lisp_Object filename
, Lisp_Object noerror
)
2941 bool from_file
= load_in_progress
;
2943 CHECK_SYMBOL (feature
);
2945 /* Record the presence of `require' in this file
2946 even if the feature specified is already loaded.
2947 But not more than once in any file,
2948 and not when we aren't loading or reading from a file. */
2951 Lisp_Object tail
= Vcurrent_load_list
;
2952 FOR_EACH_TAIL_SAFE (tail
)
2953 if (NILP (XCDR (tail
)) && STRINGP (XCAR (tail
)))
2959 tem
= Fcons (Qrequire
, feature
);
2960 if (NILP (Fmember (tem
, Vcurrent_load_list
)))
2961 LOADHIST_ATTACH (tem
);
2963 tem
= Fmemq (feature
, Vfeatures
);
2967 ptrdiff_t count
= SPECPDL_INDEX ();
2970 /* This is to make sure that loadup.el gives a clear picture
2971 of what files are preloaded and when. */
2972 if (will_dump_p () && !will_bootstrap_p ())
2973 error ("(require %s) while preparing to dump",
2974 SDATA (SYMBOL_NAME (feature
)));
2976 /* A certain amount of recursive `require' is legitimate,
2977 but if we require the same feature recursively 3 times,
2979 tem
= require_nesting_list
;
2980 while (! NILP (tem
))
2982 if (! NILP (Fequal (feature
, XCAR (tem
))))
2987 error ("Recursive `require' for feature `%s'",
2988 SDATA (SYMBOL_NAME (feature
)));
2990 /* Update the list for any nested `require's that occur. */
2991 record_unwind_protect (require_unwind
, require_nesting_list
);
2992 require_nesting_list
= Fcons (feature
, require_nesting_list
);
2994 /* Value saved here is to be restored into Vautoload_queue */
2995 record_unwind_protect (un_autoload
, Vautoload_queue
);
2996 Vautoload_queue
= Qt
;
2998 /* Load the file. */
2999 tem
= save_match_data_load
3000 (NILP (filename
) ? Fsymbol_name (feature
) : filename
,
3001 noerror
, Qt
, Qnil
, (NILP (filename
) ? Qt
: Qnil
));
3003 /* If load failed entirely, return nil. */
3005 return unbind_to (count
, Qnil
);
3007 tem
= Fmemq (feature
, Vfeatures
);
3010 unsigned char *tem2
= SDATA (SYMBOL_NAME (feature
));
3011 Lisp_Object tem3
= Fcar (Fcar (Vload_history
));
3014 error ("Required feature `%s' was not provided", tem2
);
3016 /* Cf autoload-do-load. */
3017 error ("Loading file %s failed to provide feature `%s'",
3018 SDATA (tem3
), tem2
);
3021 /* Once loading finishes, don't undo it. */
3022 Vautoload_queue
= Qt
;
3023 feature
= unbind_to (count
, feature
);
3029 /* Primitives for work of the "widget" library.
3030 In an ideal world, this section would not have been necessary.
3031 However, lisp function calls being as slow as they are, it turns
3032 out that some functions in the widget library (wid-edit.el) are the
3033 bottleneck of Widget operation. Here is their translation to C,
3034 for the sole reason of efficiency. */
3036 DEFUN ("plist-member", Fplist_member
, Splist_member
, 2, 2, 0,
3037 doc
: /* Return non-nil if PLIST has the property PROP.
3038 PLIST is a property list, which is a list of the form
3039 \(PROP1 VALUE1 PROP2 VALUE2 ...). PROP is a symbol.
3040 Unlike `plist-get', this allows you to distinguish between a missing
3041 property and a property with the value nil.
3042 The value is actually the tail of PLIST whose car is PROP. */)
3043 (Lisp_Object plist
, Lisp_Object prop
)
3045 Lisp_Object tail
= plist
;
3046 FOR_EACH_TAIL (tail
)
3048 if (EQ (XCAR (tail
), prop
))
3054 CHECK_TYPE (NILP (tail
), Qplistp
, plist
);
3058 DEFUN ("widget-put", Fwidget_put
, Swidget_put
, 3, 3, 0,
3059 doc
: /* In WIDGET, set PROPERTY to VALUE.
3060 The value can later be retrieved with `widget-get'. */)
3061 (Lisp_Object widget
, Lisp_Object property
, Lisp_Object value
)
3063 CHECK_CONS (widget
);
3064 XSETCDR (widget
, Fplist_put (XCDR (widget
), property
, value
));
3068 DEFUN ("widget-get", Fwidget_get
, Swidget_get
, 2, 2, 0,
3069 doc
: /* In WIDGET, get the value of PROPERTY.
3070 The value could either be specified when the widget was created, or
3071 later with `widget-put'. */)
3072 (Lisp_Object widget
, Lisp_Object property
)
3080 CHECK_CONS (widget
);
3081 tmp
= Fplist_member (XCDR (widget
), property
);
3087 tmp
= XCAR (widget
);
3090 widget
= Fget (tmp
, Qwidget_type
);
3094 DEFUN ("widget-apply", Fwidget_apply
, Swidget_apply
, 2, MANY
, 0,
3095 doc
: /* Apply the value of WIDGET's PROPERTY to the widget itself.
3096 Return the result of applying the value of PROPERTY to WIDGET.
3097 ARGS are passed as extra arguments to the function.
3098 usage: (widget-apply WIDGET PROPERTY &rest ARGS) */)
3099 (ptrdiff_t nargs
, Lisp_Object
*args
)
3101 Lisp_Object widget
= args
[0];
3102 Lisp_Object property
= args
[1];
3103 Lisp_Object propval
= Fwidget_get (widget
, property
);
3104 Lisp_Object trailing_args
= Flist (nargs
- 2, args
+ 2);
3105 Lisp_Object result
= CALLN (Fapply
, propval
, widget
, trailing_args
);
3109 #ifdef HAVE_LANGINFO_CODESET
3110 #include <langinfo.h>
3113 DEFUN ("locale-info", Flocale_info
, Slocale_info
, 1, 1, 0,
3114 doc
: /* Access locale data ITEM for the current C locale, if available.
3115 ITEM should be one of the following:
3117 `codeset', returning the character set as a string (locale item CODESET);
3119 `days', returning a 7-element vector of day names (locale items DAY_n);
3121 `months', returning a 12-element vector of month names (locale items MON_n);
3123 `paper', returning a list of 2 integers (WIDTH HEIGHT) for the default
3124 paper size, both measured in millimeters (locale items _NL_PAPER_WIDTH,
3127 If the system can't provide such information through a call to
3128 `nl_langinfo', or if ITEM isn't from the list above, return nil.
3130 See also Info node `(libc)Locales'.
3132 The data read from the system are decoded using `locale-coding-system'. */)
3136 #ifdef HAVE_LANGINFO_CODESET
3137 if (EQ (item
, Qcodeset
))
3139 str
= nl_langinfo (CODESET
);
3140 return build_string (str
);
3143 if (EQ (item
, Qdays
)) /* E.g., for calendar-day-name-array. */
3145 Lisp_Object v
= make_nil_vector (7);
3146 const int days
[7] = {DAY_1
, DAY_2
, DAY_3
, DAY_4
, DAY_5
, DAY_6
, DAY_7
};
3148 synchronize_system_time_locale ();
3149 for (i
= 0; i
< 7; i
++)
3151 str
= nl_langinfo (days
[i
]);
3152 AUTO_STRING (val
, str
);
3153 /* Fixme: Is this coding system necessarily right, even if
3154 it is consistent with CODESET? If not, what to do? */
3155 ASET (v
, i
, code_convert_string_norecord (val
, Vlocale_coding_system
,
3162 if (EQ (item
, Qmonths
)) /* E.g., for calendar-month-name-array. */
3164 Lisp_Object v
= make_nil_vector (12);
3165 const int months
[12] = {MON_1
, MON_2
, MON_3
, MON_4
, MON_5
, MON_6
, MON_7
,
3166 MON_8
, MON_9
, MON_10
, MON_11
, MON_12
};
3167 synchronize_system_time_locale ();
3168 for (int i
= 0; i
< 12; i
++)
3170 str
= nl_langinfo (months
[i
]);
3171 AUTO_STRING (val
, str
);
3172 ASET (v
, i
, code_convert_string_norecord (val
, Vlocale_coding_system
,
3178 # ifdef HAVE_LANGINFO__NL_PAPER_WIDTH
3179 if (EQ (item
, Qpaper
))
3180 /* We have to cast twice here: first to a correctly-sized integer,
3181 then to int, because that's what nl_langinfo is documented to
3182 return for _NO_PAPER_{WIDTH,HEIGHT}. The first cast doesn't
3183 suffice because it could overflow an Emacs fixnum. This can
3184 happen when running under ASan, which fills allocated but
3185 uninitialized memory with 0xBE bytes. */
3186 return list2i ((int) (intptr_t) nl_langinfo (_NL_PAPER_WIDTH
),
3187 (int) (intptr_t) nl_langinfo (_NL_PAPER_HEIGHT
));
3189 #endif /* HAVE_LANGINFO_CODESET*/
3193 /* base64 encode/decode functions (RFC 2045).
3194 Based on code from GNU recode. */
3196 #define MIME_LINE_LENGTH 76
3198 /* Tables of characters coding the 64 values. */
3199 static char const base64_value_to_char
[2][64] =
3203 'A', 'B', 'C', 'D', 'E', 'F', 'G', 'H', 'I', 'J', /* 0- 9 */
3204 'K', 'L', 'M', 'N', 'O', 'P', 'Q', 'R', 'S', 'T', /* 10-19 */
3205 'U', 'V', 'W', 'X', 'Y', 'Z', 'a', 'b', 'c', 'd', /* 20-29 */
3206 'e', 'f', 'g', 'h', 'i', 'j', 'k', 'l', 'm', 'n', /* 30-39 */
3207 'o', 'p', 'q', 'r', 's', 't', 'u', 'v', 'w', 'x', /* 40-49 */
3208 'y', 'z', '0', '1', '2', '3', '4', '5', '6', '7', /* 50-59 */
3209 '8', '9', '+', '/' /* 60-63 */
3213 'A', 'B', 'C', 'D', 'E', 'F', 'G', 'H', 'I', 'J', /* 0- 9 */
3214 'K', 'L', 'M', 'N', 'O', 'P', 'Q', 'R', 'S', 'T', /* 10-19 */
3215 'U', 'V', 'W', 'X', 'Y', 'Z', 'a', 'b', 'c', 'd', /* 20-29 */
3216 'e', 'f', 'g', 'h', 'i', 'j', 'k', 'l', 'm', 'n', /* 30-39 */
3217 'o', 'p', 'q', 'r', 's', 't', 'u', 'v', 'w', 'x', /* 40-49 */
3218 'y', 'z', '0', '1', '2', '3', '4', '5', '6', '7', /* 50-59 */
3219 '8', '9', '-', '_' /* 60-63 */
3223 /* Tables of base64 values for bytes. -1 means ignorable, 0 invalid,
3224 positive means 1 + the represented value. */
3225 static signed char const base64_char_to_value
[2][UCHAR_MAX
] =
3229 ['\t']= -1, ['\n']= -1, ['\f']= -1, ['\r']= -1, [' '] = -1,
3230 ['A'] = 1, ['B'] = 2, ['C'] = 3, ['D'] = 4, ['E'] = 5,
3231 ['F'] = 6, ['G'] = 7, ['H'] = 8, ['I'] = 9, ['J'] = 10,
3232 ['K'] = 11, ['L'] = 12, ['M'] = 13, ['N'] = 14, ['O'] = 15,
3233 ['P'] = 16, ['Q'] = 17, ['R'] = 18, ['S'] = 19, ['T'] = 20,
3234 ['U'] = 21, ['V'] = 22, ['W'] = 23, ['X'] = 24, ['Y'] = 25, ['Z'] = 26,
3235 ['a'] = 27, ['b'] = 28, ['c'] = 29, ['d'] = 30, ['e'] = 31,
3236 ['f'] = 32, ['g'] = 33, ['h'] = 34, ['i'] = 35, ['j'] = 36,
3237 ['k'] = 37, ['l'] = 38, ['m'] = 39, ['n'] = 40, ['o'] = 41,
3238 ['p'] = 42, ['q'] = 43, ['r'] = 44, ['s'] = 45, ['t'] = 46,
3239 ['u'] = 47, ['v'] = 48, ['w'] = 49, ['x'] = 50, ['y'] = 51, ['z'] = 52,
3240 ['0'] = 53, ['1'] = 54, ['2'] = 55, ['3'] = 56, ['4'] = 57,
3241 ['5'] = 58, ['6'] = 59, ['7'] = 60, ['8'] = 61, ['9'] = 62,
3242 ['+'] = 63, ['/'] = 64
3246 ['\t']= -1, ['\n']= -1, ['\f']= -1, ['\r']= -1, [' '] = -1,
3247 ['A'] = 1, ['B'] = 2, ['C'] = 3, ['D'] = 4, ['E'] = 5,
3248 ['F'] = 6, ['G'] = 7, ['H'] = 8, ['I'] = 9, ['J'] = 10,
3249 ['K'] = 11, ['L'] = 12, ['M'] = 13, ['N'] = 14, ['O'] = 15,
3250 ['P'] = 16, ['Q'] = 17, ['R'] = 18, ['S'] = 19, ['T'] = 20,
3251 ['U'] = 21, ['V'] = 22, ['W'] = 23, ['X'] = 24, ['Y'] = 25, ['Z'] = 26,
3252 ['a'] = 27, ['b'] = 28, ['c'] = 29, ['d'] = 30, ['e'] = 31,
3253 ['f'] = 32, ['g'] = 33, ['h'] = 34, ['i'] = 35, ['j'] = 36,
3254 ['k'] = 37, ['l'] = 38, ['m'] = 39, ['n'] = 40, ['o'] = 41,
3255 ['p'] = 42, ['q'] = 43, ['r'] = 44, ['s'] = 45, ['t'] = 46,
3256 ['u'] = 47, ['v'] = 48, ['w'] = 49, ['x'] = 50, ['y'] = 51, ['z'] = 52,
3257 ['0'] = 53, ['1'] = 54, ['2'] = 55, ['3'] = 56, ['4'] = 57,
3258 ['5'] = 58, ['6'] = 59, ['7'] = 60, ['8'] = 61, ['9'] = 62,
3259 ['-'] = 63, ['_'] = 64
3263 /* The following diagram shows the logical steps by which three octets
3264 get transformed into four base64 characters.
3266 .--------. .--------. .--------.
3267 |aaaaaabb| |bbbbcccc| |ccdddddd|
3268 `--------' `--------' `--------'
3270 .--------+--------+--------+--------.
3271 |00aaaaaa|00bbbbbb|00cccccc|00dddddd|
3272 `--------+--------+--------+--------'
3274 .--------+--------+--------+--------.
3275 |AAAAAAAA|BBBBBBBB|CCCCCCCC|DDDDDDDD|
3276 `--------+--------+--------+--------'
3278 The octets are divided into 6 bit chunks, which are then encoded into
3279 base64 characters. */
3282 static ptrdiff_t base64_encode_1 (const char *, char *, ptrdiff_t, bool, bool,
3284 static ptrdiff_t base64_decode_1 (const char *, char *, ptrdiff_t, bool,
3287 static Lisp_Object
base64_encode_region_1 (Lisp_Object
, Lisp_Object
, bool,
3290 static Lisp_Object
base64_encode_string_1 (Lisp_Object
, bool,
3294 DEFUN ("base64-encode-region", Fbase64_encode_region
, Sbase64_encode_region
,
3296 doc
: /* Base64-encode the region between BEG and END.
3297 Return the length of the encoded text.
3298 Optional third argument NO-LINE-BREAK means do not break long lines
3299 into shorter lines. */)
3300 (Lisp_Object beg
, Lisp_Object end
, Lisp_Object no_line_break
)
3302 return base64_encode_region_1 (beg
, end
, NILP (no_line_break
), true, false);
3306 DEFUN ("base64url-encode-region", Fbase64url_encode_region
, Sbase64url_encode_region
,
3308 doc
: /* Base64url-encode the region between BEG and END.
3309 Return the length of the encoded text.
3310 Optional second argument NO-PAD means do not add padding char =.
3312 This produces the URL variant of base 64 encoding defined in RFC 4648. */)
3313 (Lisp_Object beg
, Lisp_Object end
, Lisp_Object no_pad
)
3315 return base64_encode_region_1 (beg
, end
, false, NILP(no_pad
), true);
3319 base64_encode_region_1 (Lisp_Object beg
, Lisp_Object end
, bool line_break
,
3320 bool pad
, bool base64url
)
3323 ptrdiff_t allength
, length
;
3324 ptrdiff_t ibeg
, iend
, encoded_length
;
3325 ptrdiff_t old_pos
= PT
;
3328 validate_region (&beg
, &end
);
3330 ibeg
= CHAR_TO_BYTE (XFIXNAT (beg
));
3331 iend
= CHAR_TO_BYTE (XFIXNAT (end
));
3332 move_gap_both (XFIXNAT (beg
), ibeg
);
3334 /* We need to allocate enough room for encoding the text.
3335 We need 33 1/3% more space, plus a newline every 76
3336 characters, and then we round up. */
3337 length
= iend
- ibeg
;
3338 allength
= length
+ length
/3 + 1;
3339 allength
+= allength
/ MIME_LINE_LENGTH
+ 1 + 6;
3341 encoded
= SAFE_ALLOCA (allength
);
3342 encoded_length
= base64_encode_1 ((char *) BYTE_POS_ADDR (ibeg
),
3343 encoded
, length
, line_break
,
3345 !NILP (BVAR (current_buffer
, enable_multibyte_characters
)));
3346 if (encoded_length
> allength
)
3349 if (encoded_length
< 0)
3351 /* The encoding wasn't possible. */
3353 error ("Multibyte character in data for base64 encoding");
3356 /* Now we have encoded the region, so we insert the new contents
3357 and delete the old. (Insert first in order to preserve markers.) */
3358 SET_PT_BOTH (XFIXNAT (beg
), ibeg
);
3359 insert (encoded
, encoded_length
);
3361 del_range_byte (ibeg
+ encoded_length
, iend
+ encoded_length
);
3363 /* If point was outside of the region, restore it exactly; else just
3364 move to the beginning of the region. */
3365 if (old_pos
>= XFIXNAT (end
))
3366 old_pos
+= encoded_length
- (XFIXNAT (end
) - XFIXNAT (beg
));
3367 else if (old_pos
> XFIXNAT (beg
))
3368 old_pos
= XFIXNAT (beg
);
3371 /* We return the length of the encoded text. */
3372 return make_fixnum (encoded_length
);
3375 DEFUN ("base64-encode-string", Fbase64_encode_string
, Sbase64_encode_string
,
3377 doc
: /* Base64-encode STRING and return the result.
3378 Optional second argument NO-LINE-BREAK means do not break long lines
3379 into shorter lines. */)
3380 (Lisp_Object string
, Lisp_Object no_line_break
)
3383 return base64_encode_string_1 (string
, NILP (no_line_break
), true, false);
3386 DEFUN ("base64url-encode-string", Fbase64url_encode_string
,
3387 Sbase64url_encode_string
, 1, 2, 0,
3388 doc
: /* Base64url-encode STRING and return the result.
3389 Optional second argument NO-PAD means do not add padding char =.
3391 This produces the URL variant of base 64 encoding defined in RFC 4648. */)
3392 (Lisp_Object string
, Lisp_Object no_pad
)
3395 return base64_encode_string_1 (string
, false, NILP(no_pad
), true);
3399 base64_encode_string_1 (Lisp_Object string
, bool line_break
,
3400 bool pad
, bool base64url
)
3402 ptrdiff_t allength
, length
, encoded_length
;
3404 Lisp_Object encoded_string
;
3407 CHECK_STRING (string
);
3409 /* We need to allocate enough room for encoding the text.
3410 We need 33 1/3% more space, plus a newline every 76
3411 characters, and then we round up. */
3412 length
= SBYTES (string
);
3413 allength
= length
+ length
/3 + 1;
3414 allength
+= allength
/ MIME_LINE_LENGTH
+ 1 + 6;
3416 /* We need to allocate enough room for decoding the text. */
3417 encoded
= SAFE_ALLOCA (allength
);
3419 encoded_length
= base64_encode_1 (SSDATA (string
),
3420 encoded
, length
, line_break
,
3422 STRING_MULTIBYTE (string
));
3423 if (encoded_length
> allength
)
3426 if (encoded_length
< 0)
3428 /* The encoding wasn't possible. */
3429 error ("Multibyte character in data for base64 encoding");
3432 encoded_string
= make_unibyte_string (encoded
, encoded_length
);
3435 return encoded_string
;
3439 base64_encode_1 (const char *from
, char *to
, ptrdiff_t length
,
3440 bool line_break
, bool pad
, bool base64url
,
3449 char const *b64_value_to_char
= base64_value_to_char
[base64url
];
3455 c
= STRING_CHAR_AND_LENGTH ((unsigned char *) from
+ i
, bytes
);
3456 if (CHAR_BYTE8_P (c
))
3457 c
= CHAR_TO_BYTE8 (c
);
3465 /* Wrap line every 76 characters. */
3469 if (counter
< MIME_LINE_LENGTH
/ 4)
3478 /* Process first byte of a triplet. */
3480 *e
++ = b64_value_to_char
[0x3f & c
>> 2];
3481 value
= (0x03 & c
) << 4;
3483 /* Process second byte of a triplet. */
3487 *e
++ = b64_value_to_char
[value
];
3498 c
= STRING_CHAR_AND_LENGTH ((unsigned char *) from
+ i
, bytes
);
3499 if (CHAR_BYTE8_P (c
))
3500 c
= CHAR_TO_BYTE8 (c
);
3508 *e
++ = b64_value_to_char
[value
| (0x0f & c
>> 4)];
3509 value
= (0x0f & c
) << 2;
3511 /* Process third byte of a triplet. */
3515 *e
++ = b64_value_to_char
[value
];
3523 c
= STRING_CHAR_AND_LENGTH ((unsigned char *) from
+ i
, bytes
);
3524 if (CHAR_BYTE8_P (c
))
3525 c
= CHAR_TO_BYTE8 (c
);
3533 *e
++ = b64_value_to_char
[value
| (0x03 & c
>> 6)];
3534 *e
++ = b64_value_to_char
[0x3f & c
];
3541 DEFUN ("base64-decode-region", Fbase64_decode_region
, Sbase64_decode_region
,
3543 doc
: /* Base64-decode the region between BEG and END.
3544 Return the length of the decoded text.
3545 If the region can't be decoded, signal an error and don't modify the buffer.
3546 Optional third argument BASE64URL determines whether to use the URL variant
3547 of the base 64 encoding, as defined in RFC 4648. */)
3548 (Lisp_Object beg
, Lisp_Object end
, Lisp_Object base64url
)
3550 ptrdiff_t ibeg
, iend
, length
, allength
;
3552 ptrdiff_t old_pos
= PT
;
3553 ptrdiff_t decoded_length
;
3554 ptrdiff_t inserted_chars
;
3555 bool multibyte
= !NILP (BVAR (current_buffer
, enable_multibyte_characters
));
3558 validate_region (&beg
, &end
);
3560 ibeg
= CHAR_TO_BYTE (XFIXNAT (beg
));
3561 iend
= CHAR_TO_BYTE (XFIXNAT (end
));
3563 length
= iend
- ibeg
;
3565 /* We need to allocate enough room for decoding the text. If we are
3566 working on a multibyte buffer, each decoded code may occupy at
3568 allength
= multibyte
? length
* 2 : length
;
3569 decoded
= SAFE_ALLOCA (allength
);
3571 move_gap_both (XFIXNAT (beg
), ibeg
);
3572 decoded_length
= base64_decode_1 ((char *) BYTE_POS_ADDR (ibeg
),
3573 decoded
, length
, !NILP (base64url
),
3574 multibyte
, &inserted_chars
);
3575 if (decoded_length
> allength
)
3578 if (decoded_length
< 0)
3580 /* The decoding wasn't possible. */
3581 error ("Invalid base64 data");
3584 /* Now we have decoded the region, so we insert the new contents
3585 and delete the old. (Insert first in order to preserve markers.) */
3586 TEMP_SET_PT_BOTH (XFIXNAT (beg
), ibeg
);
3587 insert_1_both (decoded
, inserted_chars
, decoded_length
, 0, 1, 0);
3588 signal_after_change (XFIXNAT (beg
), 0, inserted_chars
);
3591 /* Delete the original text. */
3592 del_range_both (PT
, PT_BYTE
, XFIXNAT (end
) + inserted_chars
,
3593 iend
+ decoded_length
, 1);
3595 /* If point was outside of the region, restore it exactly; else just
3596 move to the beginning of the region. */
3597 if (old_pos
>= XFIXNAT (end
))
3598 old_pos
+= inserted_chars
- (XFIXNAT (end
) - XFIXNAT (beg
));
3599 else if (old_pos
> XFIXNAT (beg
))
3600 old_pos
= XFIXNAT (beg
);
3601 SET_PT (old_pos
> ZV
? ZV
: old_pos
);
3603 return make_fixnum (inserted_chars
);
3606 DEFUN ("base64-decode-string", Fbase64_decode_string
, Sbase64_decode_string
,
3608 doc
: /* Base64-decode STRING and return the result as a string.
3609 Optional argument BASE64URL determines whether to use the URL variant of
3610 the base 64 encoding, as defined in RFC 4648. */)
3611 (Lisp_Object string
, Lisp_Object base64url
)
3614 ptrdiff_t length
, decoded_length
;
3615 Lisp_Object decoded_string
;
3618 CHECK_STRING (string
);
3620 length
= SBYTES (string
);
3621 /* We need to allocate enough room for decoding the text. */
3622 decoded
= SAFE_ALLOCA (length
);
3624 /* The decoded result should be unibyte. */
3625 ptrdiff_t decoded_chars
;
3626 decoded_length
= base64_decode_1 (SSDATA (string
), decoded
, length
,
3627 !NILP (base64url
), 0, &decoded_chars
);
3628 if (decoded_length
> length
)
3630 else if (decoded_length
>= 0)
3631 decoded_string
= make_unibyte_string (decoded
, decoded_length
);
3633 decoded_string
= Qnil
;
3636 if (!STRINGP (decoded_string
))
3637 error ("Invalid base64 data");
3639 return decoded_string
;
3642 /* Base64-decode the data at FROM of LENGTH bytes into TO. If
3643 MULTIBYTE, the decoded result should be in multibyte
3644 form. Store the number of produced characters in *NCHARS_RETURN. */
3647 base64_decode_1 (const char *from
, char *to
, ptrdiff_t length
,
3649 bool multibyte
, ptrdiff_t *nchars_return
)
3651 char const *f
= from
;
3652 char const *flim
= from
+ length
;
3654 ptrdiff_t nchars
= 0;
3655 signed char const *b64_char_to_value
= base64_char_to_value
[base64url
];
3656 unsigned char multibyte_bit
= multibyte
<< 7;
3663 /* Process first byte of a quadruplet. */
3669 *nchars_return
= nchars
;
3673 v1
= b64_char_to_value
[c
];
3679 unsigned int value
= (v1
- 1) << 18;
3681 /* Process second byte of a quadruplet. */
3688 v1
= b64_char_to_value
[c
];
3694 value
+= (v1
- 1) << 12;
3696 c
= value
>> 16 & 0xff;
3697 if (c
& multibyte_bit
)
3698 e
+= BYTE8_STRING (c
, e
);
3703 /* Process third byte of a quadruplet. */
3711 *nchars_return
= nchars
;
3715 v1
= b64_char_to_value
[c
];
3727 while (b64_char_to_value
[c
] < 0);
3736 value
+= (v1
- 1) << 6;
3738 c
= value
>> 8 & 0xff;
3739 if (c
& multibyte_bit
)
3740 e
+= BYTE8_STRING (c
, e
);
3745 /* Process fourth byte of a quadruplet. */
3753 *nchars_return
= nchars
;
3757 v1
= b64_char_to_value
[c
];
3769 if (c
& multibyte_bit
)
3770 e
+= BYTE8_STRING (c
, e
);
3779 /***********************************************************************
3781 ***** Hash Tables *****
3783 ***********************************************************************/
3785 /* Implemented by gerd@gnu.org. This hash table implementation was
3786 inspired by CMUCL hash tables. */
3790 1. For small tables, association lists are probably faster than
3791 hash tables because they have lower overhead.
3793 For uses of hash tables where the O(1) behavior of table
3794 operations is not a requirement, it might therefore be a good idea
3795 not to hash. Instead, we could just do a linear search in the
3796 key_and_value vector of the hash table. This could be done
3797 if a `:linear-search t' argument is given to make-hash-table. */
3801 /***********************************************************************
3803 ***********************************************************************/
3806 CHECK_HASH_TABLE (Lisp_Object x
)
3808 CHECK_TYPE (HASH_TABLE_P (x
), Qhash_table_p
, x
);
3812 set_hash_next_slot (struct Lisp_Hash_Table
*h
, ptrdiff_t idx
, ptrdiff_t val
)
3814 gc_aset (h
->next
, idx
, make_fixnum (val
));
3817 set_hash_hash_slot (struct Lisp_Hash_Table
*h
, ptrdiff_t idx
, Lisp_Object val
)
3819 gc_aset (h
->hash
, idx
, val
);
3822 set_hash_index_slot (struct Lisp_Hash_Table
*h
, ptrdiff_t idx
, ptrdiff_t val
)
3824 gc_aset (h
->index
, idx
, make_fixnum (val
));
3827 /* If OBJ is a Lisp hash table, return a pointer to its struct
3828 Lisp_Hash_Table. Otherwise, signal an error. */
3830 static struct Lisp_Hash_Table
*
3831 check_hash_table (Lisp_Object obj
)
3833 CHECK_HASH_TABLE (obj
);
3834 return XHASH_TABLE (obj
);
3838 /* Value is the next integer I >= N, N >= 0 which is "almost" a prime
3839 number. A number is "almost" a prime number if it is not divisible
3840 by any integer in the range 2 .. (NEXT_ALMOST_PRIME_LIMIT - 1). */
3843 next_almost_prime (EMACS_INT n
)
3845 verify (NEXT_ALMOST_PRIME_LIMIT
== 11);
3846 for (n
|= 1; ; n
+= 2)
3847 if (n
% 3 != 0 && n
% 5 != 0 && n
% 7 != 0)
3852 /* Find KEY in ARGS which has size NARGS. Don't consider indices for
3853 which USED[I] is non-zero. If found at index I in ARGS, set
3854 USED[I] and USED[I + 1] to 1, and return I + 1. Otherwise return
3855 0. This function is used to extract a keyword/argument pair from
3856 a DEFUN parameter list. */
3859 get_key_arg (Lisp_Object key
, ptrdiff_t nargs
, Lisp_Object
*args
, char *used
)
3863 for (i
= 1; i
< nargs
; i
++)
3864 if (!used
[i
- 1] && EQ (args
[i
- 1], key
))
3875 /* Return a Lisp vector which has the same contents as VEC but has
3876 at least INCR_MIN more entries, where INCR_MIN is positive.
3877 If NITEMS_MAX is not -1, do not grow the vector to be any larger
3878 than NITEMS_MAX. New entries in the resulting vector are
3882 larger_vecalloc (Lisp_Object vec
, ptrdiff_t incr_min
, ptrdiff_t nitems_max
)
3884 struct Lisp_Vector
*v
;
3885 ptrdiff_t incr
, incr_max
, old_size
, new_size
;
3886 ptrdiff_t C_language_max
= min (PTRDIFF_MAX
, SIZE_MAX
) / sizeof *v
->contents
;
3887 ptrdiff_t n_max
= (0 <= nitems_max
&& nitems_max
< C_language_max
3888 ? nitems_max
: C_language_max
);
3889 eassert (VECTORP (vec
));
3890 eassert (0 < incr_min
&& -1 <= nitems_max
);
3891 old_size
= ASIZE (vec
);
3892 incr_max
= n_max
- old_size
;
3893 incr
= max (incr_min
, min (old_size
>> 1, incr_max
));
3894 if (incr_max
< incr
)
3895 memory_full (SIZE_MAX
);
3896 new_size
= old_size
+ incr
;
3897 v
= allocate_vector (new_size
);
3898 memcpy (v
->contents
, XVECTOR (vec
)->contents
, old_size
* sizeof *v
->contents
);
3899 XSETVECTOR (vec
, v
);
3903 /* Likewise, except set new entries in the resulting vector to nil. */
3906 larger_vector (Lisp_Object vec
, ptrdiff_t incr_min
, ptrdiff_t nitems_max
)
3908 ptrdiff_t old_size
= ASIZE (vec
);
3909 Lisp_Object v
= larger_vecalloc (vec
, incr_min
, nitems_max
);
3910 ptrdiff_t new_size
= ASIZE (v
);
3911 memclear (XVECTOR (v
)->contents
+ old_size
,
3912 (new_size
- old_size
) * word_size
);
3917 /***********************************************************************
3919 ***********************************************************************/
3921 /* Return the index of the next entry in H following the one at IDX,
3925 HASH_NEXT (struct Lisp_Hash_Table
*h
, ptrdiff_t idx
)
3927 return XFIXNUM (AREF (h
->next
, idx
));
3930 /* Return the index of the element in hash table H that is the start
3931 of the collision list at index IDX, or -1 if the list is empty. */
3934 HASH_INDEX (struct Lisp_Hash_Table
*h
, ptrdiff_t idx
)
3936 return XFIXNUM (AREF (h
->index
, idx
));
3939 /* Restore a hash table's mutability after the critical section exits. */
3942 restore_mutability (void *ptr
)
3944 struct Lisp_Hash_Table
*h
= ptr
;
3948 /* Return the result of calling a user-defined hash or comparison
3949 function ARGS[0] with arguments ARGS[1] through ARGS[NARGS - 1].
3950 Signal an error if the function attempts to modify H, which
3951 otherwise might lead to undefined behavior. */
3954 hash_table_user_defined_call (ptrdiff_t nargs
, Lisp_Object
*args
,
3955 struct Lisp_Hash_Table
*h
)
3958 return Ffuncall (nargs
, args
);
3959 ptrdiff_t count
= inhibit_garbage_collection ();
3960 record_unwind_protect_ptr (restore_mutability
, h
);
3962 return unbind_to (count
, Ffuncall (nargs
, args
));
3965 /* Ignore HT and compare KEY1 and KEY2 using 'eql'.
3966 Value is true if KEY1 and KEY2 are the same. */
3969 cmpfn_eql (Lisp_Object key1
, Lisp_Object key2
, struct Lisp_Hash_Table
*h
)
3971 return Feql (key1
, key2
);
3974 /* Ignore HT and compare KEY1 and KEY2 using 'equal'.
3975 Value is true if KEY1 and KEY2 are the same. */
3978 cmpfn_equal (Lisp_Object key1
, Lisp_Object key2
, struct Lisp_Hash_Table
*h
)
3980 return Fequal (key1
, key2
);
3984 /* Given HT, compare KEY1 and KEY2 using HT->user_cmp_function.
3985 Value is true if KEY1 and KEY2 are the same. */
3988 cmpfn_user_defined (Lisp_Object key1
, Lisp_Object key2
,
3989 struct Lisp_Hash_Table
*h
)
3991 Lisp_Object args
[] = { h
->test
.user_cmp_function
, key1
, key2
};
3992 return hash_table_user_defined_call (ARRAYELTS (args
), args
, h
);
3995 /* Ignore HT and return a hash code for KEY which uses 'eq' to compare
3999 hashfn_eq (Lisp_Object key
, struct Lisp_Hash_Table
*h
)
4001 return make_ufixnum (XHASH (key
) ^ XTYPE (key
));
4004 /* Ignore HT and return a hash code for KEY which uses 'equal' to compare keys.
4005 The hash code is at most INTMASK. */
4008 hashfn_equal (Lisp_Object key
, struct Lisp_Hash_Table
*h
)
4010 return make_ufixnum (sxhash (key
, 0));
4013 /* Ignore HT and return a hash code for KEY which uses 'eql' to compare keys.
4014 The hash code is at most INTMASK. */
4017 hashfn_eql (Lisp_Object key
, struct Lisp_Hash_Table
*h
)
4019 return (FLOATP (key
) || BIGNUMP (key
) ? hashfn_equal
: hashfn_eq
) (key
, h
);
4022 /* Given HT, return a hash code for KEY which uses a user-defined
4023 function to compare keys. */
4026 hashfn_user_defined (Lisp_Object key
, struct Lisp_Hash_Table
*h
)
4028 Lisp_Object args
[] = { h
->test
.user_hash_function
, key
};
4029 Lisp_Object hash
= hash_table_user_defined_call (ARRAYELTS (args
), args
, h
);
4030 return FIXNUMP (hash
) ? hash
: make_ufixnum (sxhash (hash
, 0));
4033 struct hash_table_test
const
4034 hashtest_eq
= { LISPSYM_INITIALLY (Qeq
), LISPSYM_INITIALLY (Qnil
),
4035 LISPSYM_INITIALLY (Qnil
), 0, hashfn_eq
},
4036 hashtest_eql
= { LISPSYM_INITIALLY (Qeql
), LISPSYM_INITIALLY (Qnil
),
4037 LISPSYM_INITIALLY (Qnil
), cmpfn_eql
, hashfn_eql
},
4038 hashtest_equal
= { LISPSYM_INITIALLY (Qequal
), LISPSYM_INITIALLY (Qnil
),
4039 LISPSYM_INITIALLY (Qnil
), cmpfn_equal
, hashfn_equal
};
4041 /* Allocate basically initialized hash table. */
4043 static struct Lisp_Hash_Table
*
4044 allocate_hash_table (void)
4046 return ALLOCATE_PSEUDOVECTOR (struct Lisp_Hash_Table
,
4047 index
, PVEC_HASH_TABLE
);
4050 /* An upper bound on the size of a hash table index. It must fit in
4051 ptrdiff_t and be a valid Emacs fixnum. This is an upper bound on
4052 VECTOR_ELTS_MAX (see alloc.c) and gets as close as we can without
4053 violating modularity. */
4054 #define INDEX_SIZE_BOUND \
4055 ((ptrdiff_t) min (MOST_POSITIVE_FIXNUM, \
4056 ((min (PTRDIFF_MAX, SIZE_MAX) \
4057 - header_size - GCALIGNMENT) \
4061 hash_index_size (struct Lisp_Hash_Table
*h
, ptrdiff_t size
)
4063 double threshold
= h
->rehash_threshold
;
4064 double index_float
= size
/ threshold
;
4065 ptrdiff_t index_size
= (index_float
< INDEX_SIZE_BOUND
+ 1
4066 ? next_almost_prime (index_float
)
4067 : INDEX_SIZE_BOUND
+ 1);
4068 if (INDEX_SIZE_BOUND
< index_size
)
4069 error ("Hash table too large");
4073 /* Create and initialize a new hash table.
4075 TEST specifies the test the hash table will use to compare keys.
4076 It must be either one of the predefined tests `eq', `eql' or
4077 `equal' or a symbol denoting a user-defined test named TEST with
4078 test and hash functions USER_TEST and USER_HASH.
4080 Give the table initial capacity SIZE, 0 <= SIZE <= MOST_POSITIVE_FIXNUM.
4082 If REHASH_SIZE is equal to a negative integer, this hash table's
4083 new size when it becomes full is computed by subtracting
4084 REHASH_SIZE from its old size. Otherwise it must be positive, and
4085 the table's new size is computed by multiplying its old size by
4088 REHASH_THRESHOLD must be a float <= 1.0, and > 0. The table will
4089 be resized when the approximate ratio of table entries to table
4090 size exceeds REHASH_THRESHOLD.
4092 WEAK specifies the weakness of the table. If non-nil, it must be
4093 one of the symbols `key', `value', `key-or-value', or `key-and-value'.
4095 If PURECOPY is non-nil, the table can be copied to pure storage via
4096 `purecopy' when Emacs is being dumped. Such tables can no longer be
4097 changed after purecopy. */
4100 make_hash_table (struct hash_table_test test
, EMACS_INT size
,
4101 float rehash_size
, float rehash_threshold
,
4102 Lisp_Object weak
, bool purecopy
)
4104 struct Lisp_Hash_Table
*h
;
4108 /* Preconditions. */
4109 eassert (SYMBOLP (test
.name
));
4110 eassert (0 <= size
&& size
<= MOST_POSITIVE_FIXNUM
);
4111 eassert (rehash_size
<= -1 || 0 < rehash_size
);
4112 eassert (0 < rehash_threshold
&& rehash_threshold
<= 1);
4117 /* Allocate a table and initialize it. */
4118 h
= allocate_hash_table ();
4120 /* Initialize hash table slots. */
4123 h
->rehash_threshold
= rehash_threshold
;
4124 h
->rehash_size
= rehash_size
;
4126 h
->key_and_value
= make_vector (2 * size
, Qunbound
);
4127 h
->hash
= make_nil_vector (size
);
4128 h
->next
= make_vector (size
, make_fixnum (-1));
4129 h
->index
= make_vector (hash_index_size (h
, size
), make_fixnum (-1));
4130 h
->next_weak
= NULL
;
4131 h
->purecopy
= purecopy
;
4134 /* Set up the free list. */
4135 for (i
= 0; i
< size
- 1; ++i
)
4136 set_hash_next_slot (h
, i
, i
+ 1);
4139 XSET_HASH_TABLE (table
, h
);
4140 eassert (HASH_TABLE_P (table
));
4141 eassert (XHASH_TABLE (table
) == h
);
4147 /* Return a copy of hash table H1. Keys and values are not copied,
4148 only the table itself is. */
4151 copy_hash_table (struct Lisp_Hash_Table
*h1
)
4154 struct Lisp_Hash_Table
*h2
;
4156 h2
= allocate_hash_table ();
4159 h2
->key_and_value
= Fcopy_sequence (h1
->key_and_value
);
4160 h2
->hash
= Fcopy_sequence (h1
->hash
);
4161 h2
->next
= Fcopy_sequence (h1
->next
);
4162 h2
->index
= Fcopy_sequence (h1
->index
);
4163 XSET_HASH_TABLE (table
, h2
);
4169 /* Resize hash table H if it's too full. If H cannot be resized
4170 because it's already too large, throw an error. */
4173 maybe_resize_hash_table (struct Lisp_Hash_Table
*h
)
4175 if (h
->next_free
< 0)
4177 ptrdiff_t old_size
= HASH_TABLE_SIZE (h
);
4179 double rehash_size
= h
->rehash_size
;
4181 if (rehash_size
< 0)
4182 new_size
= old_size
- rehash_size
;
4185 double float_new_size
= old_size
* (rehash_size
+ 1);
4186 if (float_new_size
< EMACS_INT_MAX
)
4187 new_size
= float_new_size
;
4189 new_size
= EMACS_INT_MAX
;
4191 if (PTRDIFF_MAX
< new_size
)
4192 new_size
= PTRDIFF_MAX
;
4193 if (new_size
<= old_size
)
4194 new_size
= old_size
+ 1;
4196 /* Allocate all the new vectors before updating *H, to
4197 avoid problems if memory is exhausted. larger_vecalloc
4198 finishes computing the size of the replacement vectors. */
4199 Lisp_Object next
= larger_vecalloc (h
->next
, new_size
- old_size
,
4201 ptrdiff_t next_size
= ASIZE (next
);
4202 for (ptrdiff_t i
= old_size
; i
< next_size
- 1; i
++)
4203 ASET (next
, i
, make_fixnum (i
+ 1));
4204 ASET (next
, next_size
- 1, make_fixnum (-1));
4206 /* Build the new&larger key_and_value vector, making sure the new
4207 fields are initialized to `unbound`. */
4208 Lisp_Object key_and_value
4209 = larger_vecalloc (h
->key_and_value
, 2 * (next_size
- old_size
),
4211 for (ptrdiff_t i
= 2 * old_size
; i
< 2 * next_size
; i
++)
4212 ASET (key_and_value
, i
, Qunbound
);
4214 Lisp_Object hash
= larger_vector (h
->hash
, next_size
- old_size
,
4216 ptrdiff_t index_size
= hash_index_size (h
, next_size
);
4217 h
->index
= make_vector (index_size
, make_fixnum (-1));
4218 h
->key_and_value
= key_and_value
;
4221 h
->next_free
= old_size
;
4224 for (ptrdiff_t i
= 0; i
< old_size
; i
++)
4225 if (!NILP (HASH_HASH (h
, i
)))
4227 EMACS_UINT hash_code
= XUFIXNUM (HASH_HASH (h
, i
));
4228 ptrdiff_t start_of_bucket
= hash_code
% ASIZE (h
->index
);
4229 set_hash_next_slot (h
, i
, HASH_INDEX (h
, start_of_bucket
));
4230 set_hash_index_slot (h
, start_of_bucket
, i
);
4233 #ifdef ENABLE_CHECKING
4234 if (HASH_TABLE_P (Vpurify_flag
) && XHASH_TABLE (Vpurify_flag
) == h
)
4235 message ("Growing hash table to: %"pD
"d", next_size
);
4240 /* Recompute the hashes (and hence also the "next" pointers).
4241 Normally there's never a need to recompute hashes.
4242 This is done only on first-access to a hash-table loaded from
4243 the "pdump", because the object's addresses may have changed, thus
4244 affecting their hash. */
4246 hash_table_rehash (struct Lisp_Hash_Table
*h
)
4248 ptrdiff_t size
= HASH_TABLE_SIZE (h
);
4250 /* These structures may have been purecopied and shared
4252 Lisp_Object hash
= make_nil_vector (size
);
4253 h
->next
= Fcopy_sequence (h
->next
);
4254 h
->index
= Fcopy_sequence (h
->index
);
4256 /* Recompute the actual hash codes for each entry in the table.
4257 Order is still invalid. */
4258 for (ptrdiff_t i
= 0; i
< size
; ++i
)
4260 Lisp_Object key
= HASH_KEY (h
, i
);
4261 if (!EQ (key
, Qunbound
))
4262 ASET (hash
, i
, h
->test
.hashfn (key
, h
));
4265 /* Reset the index so that any slot we don't fill below is marked
4267 Ffillarray (h
->index
, make_fixnum (-1));
4269 /* Rebuild the collision chains. */
4270 for (ptrdiff_t i
= 0; i
< size
; ++i
)
4271 if (!NILP (AREF (hash
, i
)))
4273 EMACS_UINT hash_code
= XUFIXNUM (AREF (hash
, i
));
4274 ptrdiff_t start_of_bucket
= hash_code
% ASIZE (h
->index
);
4275 set_hash_next_slot (h
, i
, HASH_INDEX (h
, start_of_bucket
));
4276 set_hash_index_slot (h
, start_of_bucket
, i
);
4277 eassert (HASH_NEXT (h
, i
) != i
); /* Stop loops. */
4280 /* Finally, mark the hash table as having a valid hash order.
4281 Do this last so that if we're interrupted, we retry on next
4283 eassert (hash_rehash_needed_p (h
));
4285 eassert (!hash_rehash_needed_p (h
));
4288 /* Lookup KEY in hash table H. If HASH is non-null, return in *HASH
4289 the hash code of KEY. Value is the index of the entry in H
4290 matching KEY, or -1 if not found. */
4293 hash_lookup (struct Lisp_Hash_Table
*h
, Lisp_Object key
, Lisp_Object
*hash
)
4295 ptrdiff_t start_of_bucket
, i
;
4297 hash_rehash_if_needed (h
);
4299 Lisp_Object hash_code
= h
->test
.hashfn (key
, h
);
4303 start_of_bucket
= XUFIXNUM (hash_code
) % ASIZE (h
->index
);
4305 for (i
= HASH_INDEX (h
, start_of_bucket
); 0 <= i
; i
= HASH_NEXT (h
, i
))
4306 if (EQ (key
, HASH_KEY (h
, i
))
4308 && EQ (hash_code
, HASH_HASH (h
, i
))
4309 && !NILP (h
->test
.cmpfn (key
, HASH_KEY (h
, i
), h
))))
4316 check_mutable_hash_table (Lisp_Object obj
, struct Lisp_Hash_Table
*h
)
4319 signal_error ("hash table test modifies table", obj
);
4320 eassert (!PURE_P (h
));
4323 /* Put an entry into hash table H that associates KEY with VALUE.
4324 HASH is a previously computed hash code of KEY.
4325 Value is the index of the entry in H matching KEY. */
4328 hash_put (struct Lisp_Hash_Table
*h
, Lisp_Object key
, Lisp_Object value
,
4331 ptrdiff_t start_of_bucket
, i
;
4333 hash_rehash_if_needed (h
);
4335 /* Increment count after resizing because resizing may fail. */
4336 maybe_resize_hash_table (h
);
4339 /* Store key/value in the key_and_value vector. */
4341 eassert (NILP (HASH_HASH (h
, i
)));
4342 eassert (EQ (Qunbound
, (HASH_KEY (h
, i
))));
4343 h
->next_free
= HASH_NEXT (h
, i
);
4344 set_hash_key_slot (h
, i
, key
);
4345 set_hash_value_slot (h
, i
, value
);
4347 /* Remember its hash code. */
4348 set_hash_hash_slot (h
, i
, hash
);
4350 /* Add new entry to its collision chain. */
4351 start_of_bucket
= XUFIXNUM (hash
) % ASIZE (h
->index
);
4352 set_hash_next_slot (h
, i
, HASH_INDEX (h
, start_of_bucket
));
4353 set_hash_index_slot (h
, start_of_bucket
, i
);
4358 /* Remove the entry matching KEY from hash table H, if there is one. */
4361 hash_remove_from_table (struct Lisp_Hash_Table
*h
, Lisp_Object key
)
4363 Lisp_Object hash_code
= h
->test
.hashfn (key
, h
);
4364 ptrdiff_t start_of_bucket
= XUFIXNUM (hash_code
) % ASIZE (h
->index
);
4365 ptrdiff_t prev
= -1;
4367 hash_rehash_if_needed (h
);
4369 for (ptrdiff_t i
= HASH_INDEX (h
, start_of_bucket
);
4371 i
= HASH_NEXT (h
, i
))
4373 if (EQ (key
, HASH_KEY (h
, i
))
4375 && EQ (hash_code
, HASH_HASH (h
, i
))
4376 && !NILP (h
->test
.cmpfn (key
, HASH_KEY (h
, i
), h
))))
4378 /* Take entry out of collision chain. */
4380 set_hash_index_slot (h
, start_of_bucket
, HASH_NEXT (h
, i
));
4382 set_hash_next_slot (h
, prev
, HASH_NEXT (h
, i
));
4384 /* Clear slots in key_and_value and add the slots to
4386 set_hash_key_slot (h
, i
, Qunbound
);
4387 set_hash_value_slot (h
, i
, Qnil
);
4388 set_hash_hash_slot (h
, i
, Qnil
);
4389 set_hash_next_slot (h
, i
, h
->next_free
);
4392 eassert (h
->count
>= 0);
4401 /* Clear hash table H. */
4404 hash_clear (struct Lisp_Hash_Table
*h
)
4408 ptrdiff_t size
= HASH_TABLE_SIZE (h
);
4409 if (!hash_rehash_needed_p (h
))
4410 memclear (XVECTOR (h
->hash
)->contents
, size
* word_size
);
4411 for (ptrdiff_t i
= 0; i
< size
; i
++)
4413 set_hash_next_slot (h
, i
, i
< size
- 1 ? i
+ 1 : -1);
4414 set_hash_key_slot (h
, i
, Qunbound
);
4415 set_hash_value_slot (h
, i
, Qnil
);
4418 for (ptrdiff_t i
= 0; i
< ASIZE (h
->index
); i
++)
4419 ASET (h
->index
, i
, make_fixnum (-1));
4428 /************************************************************************
4430 ************************************************************************/
4432 /* Sweep weak hash table H. REMOVE_ENTRIES_P means remove
4433 entries from the table that don't survive the current GC.
4434 !REMOVE_ENTRIES_P means mark entries that are in use. Value is
4435 true if anything was marked. */
4438 sweep_weak_table (struct Lisp_Hash_Table
*h
, bool remove_entries_p
)
4440 ptrdiff_t n
= gc_asize (h
->index
);
4441 bool marked
= false;
4443 for (ptrdiff_t bucket
= 0; bucket
< n
; ++bucket
)
4445 /* Follow collision chain, removing entries that don't survive
4446 this garbage collection. It's okay if hash_rehash_needed_p
4447 (h) is true, since we're operating entirely on the cached
4449 ptrdiff_t prev
= -1;
4451 for (ptrdiff_t i
= HASH_INDEX (h
, bucket
); 0 <= i
; i
= next
)
4453 bool key_known_to_survive_p
= survives_gc_p (HASH_KEY (h
, i
));
4454 bool value_known_to_survive_p
= survives_gc_p (HASH_VALUE (h
, i
));
4457 if (EQ (h
->weak
, Qkey
))
4458 remove_p
= !key_known_to_survive_p
;
4459 else if (EQ (h
->weak
, Qvalue
))
4460 remove_p
= !value_known_to_survive_p
;
4461 else if (EQ (h
->weak
, Qkey_or_value
))
4462 remove_p
= !(key_known_to_survive_p
|| value_known_to_survive_p
);
4463 else if (EQ (h
->weak
, Qkey_and_value
))
4464 remove_p
= !(key_known_to_survive_p
&& value_known_to_survive_p
);
4468 next
= HASH_NEXT (h
, i
);
4470 if (remove_entries_p
)
4473 == (key_known_to_survive_p
&& value_known_to_survive_p
));
4476 /* Take out of collision chain. */
4478 set_hash_index_slot (h
, bucket
, next
);
4480 set_hash_next_slot (h
, prev
, next
);
4482 /* Add to free list. */
4483 set_hash_next_slot (h
, i
, h
->next_free
);
4486 /* Clear key, value, and hash. */
4487 set_hash_key_slot (h
, i
, Qunbound
);
4488 set_hash_value_slot (h
, i
, Qnil
);
4489 if (!NILP (h
->hash
))
4490 set_hash_hash_slot (h
, i
, Qnil
);
4492 eassert (h
->count
!= 0);
4493 h
->count
+= h
->count
> 0 ? -1 : 1;
4504 /* Make sure key and value survive. */
4505 if (!key_known_to_survive_p
)
4507 mark_object (HASH_KEY (h
, i
));
4511 if (!value_known_to_survive_p
)
4513 mark_object (HASH_VALUE (h
, i
));
4525 /***********************************************************************
4526 Hash Code Computation
4527 ***********************************************************************/
4529 /* Maximum depth up to which to dive into Lisp structures. */
4531 #define SXHASH_MAX_DEPTH 3
4533 /* Maximum length up to which to take list and vector elements into
4536 #define SXHASH_MAX_LEN 7
4538 /* Return a hash for string PTR which has length LEN. The hash value
4539 can be any EMACS_UINT value. */
4542 hash_string (char const *ptr
, ptrdiff_t len
)
4544 char const *p
= ptr
;
4545 char const *end
= p
+ len
;
4547 EMACS_UINT hash
= 0;
4552 hash
= sxhash_combine (hash
, c
);
4558 /* Return a hash for string PTR which has length LEN. The hash
4559 code returned is at most INTMASK. */
4562 sxhash_string (char const *ptr
, ptrdiff_t len
)
4564 EMACS_UINT hash
= hash_string (ptr
, len
);
4565 return SXHASH_REDUCE (hash
);
4568 /* Return a hash for the floating point value VAL. */
4571 sxhash_float (double val
)
4573 EMACS_UINT hash
= 0;
4574 union double_and_words u
= { .val
= val
};
4575 for (int i
= 0; i
< WORDS_PER_DOUBLE
; i
++)
4576 hash
= sxhash_combine (hash
, u
.word
[i
]);
4577 return SXHASH_REDUCE (hash
);
4580 /* Return a hash for list LIST. DEPTH is the current depth in the
4581 list. We don't recurse deeper than SXHASH_MAX_DEPTH in it. */
4584 sxhash_list (Lisp_Object list
, int depth
)
4586 EMACS_UINT hash
= 0;
4589 if (depth
< SXHASH_MAX_DEPTH
)
4591 CONSP (list
) && i
< SXHASH_MAX_LEN
;
4592 list
= XCDR (list
), ++i
)
4594 EMACS_UINT hash2
= sxhash (XCAR (list
), depth
+ 1);
4595 hash
= sxhash_combine (hash
, hash2
);
4600 EMACS_UINT hash2
= sxhash (list
, depth
+ 1);
4601 hash
= sxhash_combine (hash
, hash2
);
4604 return SXHASH_REDUCE (hash
);
4608 /* Return a hash for (pseudo)vector VECTOR. DEPTH is the current depth in
4609 the Lisp structure. */
4612 sxhash_vector (Lisp_Object vec
, int depth
)
4614 EMACS_UINT hash
= ASIZE (vec
);
4617 n
= min (SXHASH_MAX_LEN
, hash
& PSEUDOVECTOR_FLAG
? PVSIZE (vec
) : hash
);
4618 for (i
= 0; i
< n
; ++i
)
4620 EMACS_UINT hash2
= sxhash (AREF (vec
, i
), depth
+ 1);
4621 hash
= sxhash_combine (hash
, hash2
);
4624 return SXHASH_REDUCE (hash
);
4627 /* Return a hash for bool-vector VECTOR. */
4630 sxhash_bool_vector (Lisp_Object vec
)
4632 EMACS_INT size
= bool_vector_size (vec
);
4633 EMACS_UINT hash
= size
;
4636 n
= min (SXHASH_MAX_LEN
, bool_vector_words (size
));
4637 for (i
= 0; i
< n
; ++i
)
4638 hash
= sxhash_combine (hash
, bool_vector_data (vec
)[i
]);
4640 return SXHASH_REDUCE (hash
);
4643 /* Return a hash for a bignum. */
4646 sxhash_bignum (Lisp_Object bignum
)
4648 mpz_t
const *n
= xbignum_val (bignum
);
4649 size_t i
, nlimbs
= mpz_size (*n
);
4650 EMACS_UINT hash
= 0;
4652 for (i
= 0; i
< nlimbs
; ++i
)
4653 hash
= sxhash_combine (hash
, mpz_getlimbn (*n
, i
));
4655 return SXHASH_REDUCE (hash
);
4659 /* Return a hash code for OBJ. DEPTH is the current depth in the Lisp
4660 structure. Value is an unsigned integer clipped to INTMASK. */
4663 sxhash (Lisp_Object obj
, int depth
)
4667 if (depth
> SXHASH_MAX_DEPTH
)
4670 switch (XTYPE (obj
))
4673 hash
= XUFIXNUM (obj
);
4681 hash
= sxhash_string (SSDATA (obj
), SBYTES (obj
));
4684 /* This can be everything from a vector to an overlay. */
4685 case Lisp_Vectorlike
:
4687 hash
= sxhash_bignum (obj
);
4688 else if (VECTORP (obj
) || RECORDP (obj
))
4689 /* According to the CL HyperSpec, two arrays are equal only if
4690 they are `eq', except for strings and bit-vectors. In
4691 Emacs, this works differently. We have to compare element
4692 by element. Same for records. */
4693 hash
= sxhash_vector (obj
, depth
);
4694 else if (BOOL_VECTOR_P (obj
))
4695 hash
= sxhash_bool_vector (obj
);
4697 /* Others are `equal' if they are `eq', so let's take their
4703 hash
= sxhash_list (obj
, depth
);
4707 hash
= sxhash_float (XFLOAT_DATA (obj
));
4719 /***********************************************************************
4721 ***********************************************************************/
4723 DEFUN ("sxhash-eq", Fsxhash_eq
, Ssxhash_eq
, 1, 1, 0,
4724 doc
: /* Return an integer hash code for OBJ suitable for `eq'.
4725 If (eq A B), then (= (sxhash-eq A) (sxhash-eq B)).
4727 Hash codes are not guaranteed to be preserved across Emacs sessions. */)
4730 return hashfn_eq (obj
, NULL
);
4733 DEFUN ("sxhash-eql", Fsxhash_eql
, Ssxhash_eql
, 1, 1, 0,
4734 doc
: /* Return an integer hash code for OBJ suitable for `eql'.
4735 If (eql A B), then (= (sxhash-eql A) (sxhash-eql B)).
4737 Hash codes are not guaranteed to be preserved across Emacs sessions. */)
4740 return hashfn_eql (obj
, NULL
);
4743 DEFUN ("sxhash-equal", Fsxhash_equal
, Ssxhash_equal
, 1, 1, 0,
4744 doc
: /* Return an integer hash code for OBJ suitable for `equal'.
4745 If (equal A B), then (= (sxhash-equal A) (sxhash-equal B)).
4747 Hash codes are not guaranteed to be preserved across Emacs sessions. */)
4750 return hashfn_equal (obj
, NULL
);
4753 DEFUN ("make-hash-table", Fmake_hash_table
, Smake_hash_table
, 0, MANY
, 0,
4754 doc
: /* Create and return a new hash table.
4756 Arguments are specified as keyword/argument pairs. The following
4757 arguments are defined:
4759 :test TEST -- TEST must be a symbol that specifies how to compare
4760 keys. Default is `eql'. Predefined are the tests `eq', `eql', and
4761 `equal'. User-supplied test and hash functions can be specified via
4762 `define-hash-table-test'.
4764 :size SIZE -- A hint as to how many elements will be put in the table.
4767 :rehash-size REHASH-SIZE - Indicates how to expand the table when it
4768 fills up. If REHASH-SIZE is an integer, increase the size by that
4769 amount. If it is a float, it must be > 1.0, and the new size is the
4770 old size multiplied by that factor. Default is 1.5.
4772 :rehash-threshold THRESHOLD -- THRESHOLD must a float > 0, and <= 1.0.
4773 Resize the hash table when the ratio (table entries / table size)
4774 exceeds an approximation to THRESHOLD. Default is 0.8125.
4776 :weakness WEAK -- WEAK must be one of nil, t, `key', `value',
4777 `key-or-value', or `key-and-value'. If WEAK is not nil, the table
4778 returned is a weak table. Key/value pairs are removed from a weak
4779 hash table when there are no non-weak references pointing to their
4780 key, value, one of key or value, or both key and value, depending on
4781 WEAK. WEAK t is equivalent to `key-and-value'. Default value of WEAK
4784 :purecopy PURECOPY -- If PURECOPY is non-nil, the table can be copied
4785 to pure storage when Emacs is being dumped, making the contents of the
4786 table read only. Any further changes to purified tables will result
4789 usage: (make-hash-table &rest KEYWORD-ARGS) */)
4790 (ptrdiff_t nargs
, Lisp_Object
*args
)
4792 Lisp_Object test
, weak
;
4794 struct hash_table_test testdesc
;
4798 /* The vector `used' is used to keep track of arguments that
4799 have been consumed. */
4800 char *used
= SAFE_ALLOCA (nargs
* sizeof *used
);
4801 memset (used
, 0, nargs
* sizeof *used
);
4803 /* See if there's a `:test TEST' among the arguments. */
4804 i
= get_key_arg (QCtest
, nargs
, args
, used
);
4805 test
= i
? args
[i
] : Qeql
;
4807 testdesc
= hashtest_eq
;
4808 else if (EQ (test
, Qeql
))
4809 testdesc
= hashtest_eql
;
4810 else if (EQ (test
, Qequal
))
4811 testdesc
= hashtest_equal
;
4814 /* See if it is a user-defined test. */
4817 prop
= Fget (test
, Qhash_table_test
);
4818 if (!CONSP (prop
) || !CONSP (XCDR (prop
)))
4819 signal_error ("Invalid hash table test", test
);
4820 testdesc
.name
= test
;
4821 testdesc
.user_cmp_function
= XCAR (prop
);
4822 testdesc
.user_hash_function
= XCAR (XCDR (prop
));
4823 testdesc
.hashfn
= hashfn_user_defined
;
4824 testdesc
.cmpfn
= cmpfn_user_defined
;
4827 /* See if there's a `:purecopy PURECOPY' argument. */
4828 i
= get_key_arg (QCpurecopy
, nargs
, args
, used
);
4829 purecopy
= i
&& !NILP (args
[i
]);
4830 /* See if there's a `:size SIZE' argument. */
4831 i
= get_key_arg (QCsize
, nargs
, args
, used
);
4832 Lisp_Object size_arg
= i
? args
[i
] : Qnil
;
4834 if (NILP (size_arg
))
4835 size
= DEFAULT_HASH_SIZE
;
4836 else if (FIXNATP (size_arg
))
4837 size
= XFIXNAT (size_arg
);
4839 signal_error ("Invalid hash table size", size_arg
);
4841 /* Look for `:rehash-size SIZE'. */
4843 i
= get_key_arg (QCrehash_size
, nargs
, args
, used
);
4845 rehash_size
= DEFAULT_REHASH_SIZE
;
4846 else if (FIXNUMP (args
[i
]) && 0 < XFIXNUM (args
[i
]))
4847 rehash_size
= - XFIXNUM (args
[i
]);
4848 else if (FLOATP (args
[i
]) && 0 < (float) (XFLOAT_DATA (args
[i
]) - 1))
4849 rehash_size
= (float) (XFLOAT_DATA (args
[i
]) - 1);
4851 signal_error ("Invalid hash table rehash size", args
[i
]);
4853 /* Look for `:rehash-threshold THRESHOLD'. */
4854 i
= get_key_arg (QCrehash_threshold
, nargs
, args
, used
);
4855 float rehash_threshold
= (!i
? DEFAULT_REHASH_THRESHOLD
4856 : !FLOATP (args
[i
]) ? 0
4857 : (float) XFLOAT_DATA (args
[i
]));
4858 if (! (0 < rehash_threshold
&& rehash_threshold
<= 1))
4859 signal_error ("Invalid hash table rehash threshold", args
[i
]);
4861 /* Look for `:weakness WEAK'. */
4862 i
= get_key_arg (QCweakness
, nargs
, args
, used
);
4863 weak
= i
? args
[i
] : Qnil
;
4865 weak
= Qkey_and_value
;
4868 && !EQ (weak
, Qvalue
)
4869 && !EQ (weak
, Qkey_or_value
)
4870 && !EQ (weak
, Qkey_and_value
))
4871 signal_error ("Invalid hash table weakness", weak
);
4873 /* Now, all args should have been used up, or there's a problem. */
4874 for (i
= 0; i
< nargs
; ++i
)
4876 signal_error ("Invalid argument list", args
[i
]);
4879 return make_hash_table (testdesc
, size
, rehash_size
, rehash_threshold
, weak
,
4884 DEFUN ("copy-hash-table", Fcopy_hash_table
, Scopy_hash_table
, 1, 1, 0,
4885 doc
: /* Return a copy of hash table TABLE. */)
4888 return copy_hash_table (check_hash_table (table
));
4892 DEFUN ("hash-table-count", Fhash_table_count
, Shash_table_count
, 1, 1, 0,
4893 doc
: /* Return the number of elements in TABLE. */)
4896 struct Lisp_Hash_Table
*h
= check_hash_table (table
);
4897 eassert (h
->count
>= 0);
4898 return make_fixnum (h
->count
);
4902 DEFUN ("hash-table-rehash-size", Fhash_table_rehash_size
,
4903 Shash_table_rehash_size
, 1, 1, 0,
4904 doc
: /* Return the current rehash size of TABLE. */)
4907 double rehash_size
= check_hash_table (table
)->rehash_size
;
4908 if (rehash_size
< 0)
4910 EMACS_INT s
= -rehash_size
;
4911 return make_fixnum (min (s
, MOST_POSITIVE_FIXNUM
));
4914 return make_float (rehash_size
+ 1);
4918 DEFUN ("hash-table-rehash-threshold", Fhash_table_rehash_threshold
,
4919 Shash_table_rehash_threshold
, 1, 1, 0,
4920 doc
: /* Return the current rehash threshold of TABLE. */)
4923 return make_float (check_hash_table (table
)->rehash_threshold
);
4927 DEFUN ("hash-table-size", Fhash_table_size
, Shash_table_size
, 1, 1, 0,
4928 doc
: /* Return the size of TABLE.
4929 The size can be used as an argument to `make-hash-table' to create
4930 a hash table than can hold as many elements as TABLE holds
4931 without need for resizing. */)
4934 struct Lisp_Hash_Table
*h
= check_hash_table (table
);
4935 return make_fixnum (HASH_TABLE_SIZE (h
));
4939 DEFUN ("hash-table-test", Fhash_table_test
, Shash_table_test
, 1, 1, 0,
4940 doc
: /* Return the test TABLE uses. */)
4943 return check_hash_table (table
)->test
.name
;
4947 DEFUN ("hash-table-weakness", Fhash_table_weakness
, Shash_table_weakness
,
4949 doc
: /* Return the weakness of TABLE. */)
4952 return check_hash_table (table
)->weak
;
4956 DEFUN ("hash-table-p", Fhash_table_p
, Shash_table_p
, 1, 1, 0,
4957 doc
: /* Return t if OBJ is a Lisp hash table object. */)
4960 return HASH_TABLE_P (obj
) ? Qt
: Qnil
;
4964 DEFUN ("clrhash", Fclrhash
, Sclrhash
, 1, 1, 0,
4965 doc
: /* Clear hash table TABLE and return it. */)
4968 struct Lisp_Hash_Table
*h
= check_hash_table (table
);
4969 check_mutable_hash_table (table
, h
);
4971 /* Be compatible with XEmacs. */
4976 DEFUN ("gethash", Fgethash
, Sgethash
, 2, 3, 0,
4977 doc
: /* Look up KEY in TABLE and return its associated value.
4978 If KEY is not found, return DFLT which defaults to nil. */)
4979 (Lisp_Object key
, Lisp_Object table
, Lisp_Object dflt
)
4981 struct Lisp_Hash_Table
*h
= check_hash_table (table
);
4982 ptrdiff_t i
= hash_lookup (h
, key
, NULL
);
4983 return i
>= 0 ? HASH_VALUE (h
, i
) : dflt
;
4987 DEFUN ("puthash", Fputhash
, Sputhash
, 3, 3, 0,
4988 doc
: /* Associate KEY with VALUE in hash table TABLE.
4989 If KEY is already present in table, replace its current value with
4990 VALUE. In any case, return VALUE. */)
4991 (Lisp_Object key
, Lisp_Object value
, Lisp_Object table
)
4993 struct Lisp_Hash_Table
*h
= check_hash_table (table
);
4994 check_mutable_hash_table (table
, h
);
4997 ptrdiff_t i
= hash_lookup (h
, key
, &hash
);
4999 set_hash_value_slot (h
, i
, value
);
5001 hash_put (h
, key
, value
, hash
);
5007 DEFUN ("remhash", Fremhash
, Sremhash
, 2, 2, 0,
5008 doc
: /* Remove KEY from TABLE. */)
5009 (Lisp_Object key
, Lisp_Object table
)
5011 struct Lisp_Hash_Table
*h
= check_hash_table (table
);
5012 check_mutable_hash_table (table
, h
);
5013 hash_remove_from_table (h
, key
);
5018 DEFUN ("maphash", Fmaphash
, Smaphash
, 2, 2, 0,
5019 doc
: /* Call FUNCTION for all entries in hash table TABLE.
5020 FUNCTION is called with two arguments, KEY and VALUE.
5021 `maphash' always returns nil. */)
5022 (Lisp_Object function
, Lisp_Object table
)
5024 struct Lisp_Hash_Table
*h
= check_hash_table (table
);
5026 for (ptrdiff_t i
= 0; i
< HASH_TABLE_SIZE (h
); ++i
)
5028 Lisp_Object k
= HASH_KEY (h
, i
);
5029 if (!EQ (k
, Qunbound
))
5030 call2 (function
, k
, HASH_VALUE (h
, i
));
5037 DEFUN ("define-hash-table-test", Fdefine_hash_table_test
,
5038 Sdefine_hash_table_test
, 3, 3, 0,
5039 doc
: /* Define a new hash table test with name NAME, a symbol.
5041 In hash tables created with NAME specified as test, use TEST to
5042 compare keys, and HASH for computing hash codes of keys.
5044 TEST must be a function taking two arguments and returning non-nil if
5045 both arguments are the same. HASH must be a function taking one
5046 argument and returning an object that is the hash code of the argument.
5047 It should be the case that if (eq (funcall HASH x1) (funcall HASH x2))
5048 returns nil, then (funcall TEST x1 x2) also returns nil. */)
5049 (Lisp_Object name
, Lisp_Object test
, Lisp_Object hash
)
5051 return Fput (name
, Qhash_table_test
, list2 (test
, hash
));
5056 /************************************************************************
5057 MD5, SHA-1, and SHA-2
5058 ************************************************************************/
5065 /* Store into HEXBUF an unterminated hexadecimal character string
5066 representing DIGEST, which is binary data of size DIGEST_SIZE bytes.
5067 HEXBUF might equal DIGEST. */
5069 hexbuf_digest (char *hexbuf
, void const *digest
, int digest_size
)
5071 unsigned char const *p
= digest
;
5073 for (int i
= digest_size
- 1; i
>= 0; i
--)
5075 static char const hexdigit
[16] = "0123456789abcdef";
5077 hexbuf
[2 * i
] = hexdigit
[p_i
>> 4];
5078 hexbuf
[2 * i
+ 1] = hexdigit
[p_i
& 0xf];
5083 make_digest_string (Lisp_Object digest
, int digest_size
)
5085 hexbuf_digest (SSDATA (digest
), SDATA (digest
), digest_size
);
5089 DEFUN ("secure-hash-algorithms", Fsecure_hash_algorithms
,
5090 Ssecure_hash_algorithms
, 0, 0, 0,
5091 doc
: /* Return a list of all the supported `secure-hash' algorithms. */)
5094 return list (Qmd5
, Qsha1
, Qsha224
, Qsha256
, Qsha384
, Qsha512
);
5097 /* Extract data from a string or a buffer. SPEC is a list of
5098 (BUFFER-OR-STRING-OR-SYMBOL START END CODING-SYSTEM NOERROR) which behave as
5099 specified with `secure-hash' and in Info node
5100 `(elisp)Format of GnuTLS Cryptography Inputs'. */
5102 extract_data_from_object (Lisp_Object spec
,
5103 ptrdiff_t *start_byte
,
5104 ptrdiff_t *end_byte
)
5106 Lisp_Object object
= XCAR (spec
);
5108 if (CONSP (spec
)) spec
= XCDR (spec
);
5109 Lisp_Object start
= CAR_SAFE (spec
);
5111 if (CONSP (spec
)) spec
= XCDR (spec
);
5112 Lisp_Object end
= CAR_SAFE (spec
);
5114 if (CONSP (spec
)) spec
= XCDR (spec
);
5115 Lisp_Object coding_system
= CAR_SAFE (spec
);
5117 if (CONSP (spec
)) spec
= XCDR (spec
);
5118 Lisp_Object noerror
= CAR_SAFE (spec
);
5120 if (STRINGP (object
))
5122 if (NILP (coding_system
))
5124 /* Decide the coding-system to encode the data with. */
5126 if (STRING_MULTIBYTE (object
))
5127 /* use default, we can't guess correct value */
5128 coding_system
= preferred_coding_system ();
5130 coding_system
= Qraw_text
;
5133 if (NILP (Fcoding_system_p (coding_system
)))
5135 /* Invalid coding system. */
5137 if (!NILP (noerror
))
5138 coding_system
= Qraw_text
;
5140 xsignal1 (Qcoding_system_error
, coding_system
);
5143 if (STRING_MULTIBYTE (object
))
5144 object
= code_convert_string (object
, coding_system
,
5145 Qnil
, true, false, true);
5147 ptrdiff_t size
= SCHARS (object
), start_char
, end_char
;
5148 validate_subarray (object
, start
, end
, size
, &start_char
, &end_char
);
5150 *start_byte
= !start_char
? 0 : string_char_to_byte (object
, start_char
);
5151 *end_byte
= (end_char
== size
5153 : string_char_to_byte (object
, end_char
));
5155 else if (BUFFERP (object
))
5157 struct buffer
*prev
= current_buffer
;
5160 record_unwind_current_buffer ();
5162 struct buffer
*bp
= XBUFFER (object
);
5163 set_buffer_internal (bp
);
5169 CHECK_FIXNUM_COERCE_MARKER (start
);
5170 b
= XFIXNUM (start
);
5177 CHECK_FIXNUM_COERCE_MARKER (end
);
5188 if (!(BEGV
<= b
&& e
<= ZV
))
5189 args_out_of_range (start
, end
);
5191 if (NILP (coding_system
))
5193 /* Decide the coding-system to encode the data with.
5194 See fileio.c:Fwrite-region */
5196 if (!NILP (Vcoding_system_for_write
))
5197 coding_system
= Vcoding_system_for_write
;
5200 bool force_raw_text
= false;
5202 coding_system
= BVAR (XBUFFER (object
), buffer_file_coding_system
);
5203 if (NILP (coding_system
)
5204 || NILP (Flocal_variable_p (Qbuffer_file_coding_system
, Qnil
)))
5206 coding_system
= Qnil
;
5207 if (NILP (BVAR (current_buffer
, enable_multibyte_characters
)))
5208 force_raw_text
= true;
5211 if (NILP (coding_system
) && !NILP (Fbuffer_file_name (object
)))
5213 /* Check file-coding-system-alist. */
5214 Lisp_Object val
= CALLN (Ffind_operation_coding_system
,
5216 make_fixnum (b
), make_fixnum (e
),
5217 Fbuffer_file_name (object
));
5218 if (CONSP (val
) && !NILP (XCDR (val
)))
5219 coding_system
= XCDR (val
);
5222 if (NILP (coding_system
)
5223 && !NILP (BVAR (XBUFFER (object
), buffer_file_coding_system
)))
5225 /* If we still have not decided a coding system, use the
5226 default value of buffer-file-coding-system. */
5227 coding_system
= BVAR (XBUFFER (object
), buffer_file_coding_system
);
5231 && !NILP (Ffboundp (Vselect_safe_coding_system_function
)))
5232 /* Confirm that VAL can surely encode the current region. */
5233 coding_system
= call4 (Vselect_safe_coding_system_function
,
5234 make_fixnum (b
), make_fixnum (e
),
5235 coding_system
, Qnil
);
5238 coding_system
= Qraw_text
;
5241 if (NILP (Fcoding_system_p (coding_system
)))
5243 /* Invalid coding system. */
5245 if (!NILP (noerror
))
5246 coding_system
= Qraw_text
;
5248 xsignal1 (Qcoding_system_error
, coding_system
);
5252 object
= make_buffer_string (b
, e
, false);
5253 set_buffer_internal (prev
);
5254 /* Discard the unwind protect for recovering the current
5258 if (STRING_MULTIBYTE (object
))
5259 object
= code_convert_string (object
, coding_system
,
5260 Qnil
, true, false, false);
5262 *end_byte
= SBYTES (object
);
5264 else if (EQ (object
, Qiv_auto
))
5267 /* Format: (iv-auto REQUIRED-LENGTH). */
5269 if (! FIXNATP (start
))
5270 error ("Without a length, `iv-auto' can't be used; see ELisp manual");
5273 EMACS_INT start_hold
= XFIXNAT (start
);
5274 object
= make_uninit_string (start_hold
);
5275 gnutls_rnd (GNUTLS_RND_NONCE
, SSDATA (object
), start_hold
);
5278 *end_byte
= start_hold
;
5281 error ("GnuTLS is not available, so `iv-auto' can't be used");
5285 if (!STRINGP (object
))
5286 signal_error ("Invalid object argument",
5287 NILP (object
) ? build_string ("nil") : object
);
5288 return SSDATA (object
);
5292 /* ALGORITHM is a symbol: md5, sha1, sha224 and so on. */
5295 secure_hash (Lisp_Object algorithm
, Lisp_Object object
, Lisp_Object start
,
5296 Lisp_Object end
, Lisp_Object coding_system
, Lisp_Object noerror
,
5299 ptrdiff_t start_byte
, end_byte
;
5301 void *(*hash_func
) (const char *, size_t, void *);
5304 CHECK_SYMBOL (algorithm
);
5306 Lisp_Object spec
= list5 (object
, start
, end
, coding_system
, noerror
);
5308 const char *input
= extract_data_from_object (spec
, &start_byte
, &end_byte
);
5311 error ("secure_hash: failed to extract data from object, aborting!");
5313 if (EQ (algorithm
, Qmd5
))
5315 digest_size
= MD5_DIGEST_SIZE
;
5316 hash_func
= md5_buffer
;
5318 else if (EQ (algorithm
, Qsha1
))
5320 digest_size
= SHA1_DIGEST_SIZE
;
5321 hash_func
= sha1_buffer
;
5323 else if (EQ (algorithm
, Qsha224
))
5325 digest_size
= SHA224_DIGEST_SIZE
;
5326 hash_func
= sha224_buffer
;
5328 else if (EQ (algorithm
, Qsha256
))
5330 digest_size
= SHA256_DIGEST_SIZE
;
5331 hash_func
= sha256_buffer
;
5333 else if (EQ (algorithm
, Qsha384
))
5335 digest_size
= SHA384_DIGEST_SIZE
;
5336 hash_func
= sha384_buffer
;
5338 else if (EQ (algorithm
, Qsha512
))
5340 digest_size
= SHA512_DIGEST_SIZE
;
5341 hash_func
= sha512_buffer
;
5344 error ("Invalid algorithm arg: %s", SDATA (Fsymbol_name (algorithm
)));
5346 /* allocate 2 x digest_size so that it can be re-used to hold the
5348 digest
= make_uninit_string (digest_size
* 2);
5350 hash_func (input
+ start_byte
,
5351 end_byte
- start_byte
,
5355 return make_digest_string (digest
, digest_size
);
5357 return make_unibyte_string (SSDATA (digest
), digest_size
);
5360 DEFUN ("md5", Fmd5
, Smd5
, 1, 5, 0,
5361 doc
: /* Return MD5 message digest of OBJECT, a buffer or string.
5363 A message digest is a cryptographic checksum of a document, and the
5364 algorithm to calculate it is defined in RFC 1321.
5366 The two optional arguments START and END are character positions
5367 specifying for which part of OBJECT the message digest should be
5368 computed. If nil or omitted, the digest is computed for the whole
5371 The MD5 message digest is computed from the result of encoding the
5372 text in a coding system, not directly from the internal Emacs form of
5373 the text. The optional fourth argument CODING-SYSTEM specifies which
5374 coding system to encode the text with. It should be the same coding
5375 system that you used or will use when actually writing the text into a
5378 If CODING-SYSTEM is nil or omitted, the default depends on OBJECT. If
5379 OBJECT is a buffer, the default for CODING-SYSTEM is whatever coding
5380 system would be chosen by default for writing this text into a file.
5382 If OBJECT is a string, the most preferred coding system (see the
5383 command `prefer-coding-system') is used.
5385 If NOERROR is non-nil, silently assume the `raw-text' coding if the
5386 guesswork fails. Normally, an error is signaled in such case.
5388 Note that MD5 is not collision resistant and should not be used for
5389 anything security-related. See `secure-hash' for alternatives. */)
5390 (Lisp_Object object
, Lisp_Object start
, Lisp_Object end
, Lisp_Object coding_system
, Lisp_Object noerror
)
5392 return secure_hash (Qmd5
, object
, start
, end
, coding_system
, noerror
, Qnil
);
5395 DEFUN ("secure-hash", Fsecure_hash
, Ssecure_hash
, 2, 5, 0,
5396 doc
: /* Return the secure hash of OBJECT, a buffer or string.
5397 ALGORITHM is a symbol specifying the hash to use:
5398 - md5 corresponds to MD5
5399 - sha1 corresponds to SHA-1
5400 - sha224 corresponds to SHA-2 (SHA-224)
5401 - sha256 corresponds to SHA-2 (SHA-256)
5402 - sha384 corresponds to SHA-2 (SHA-384)
5403 - sha512 corresponds to SHA-2 (SHA-512)
5405 The two optional arguments START and END are positions specifying for
5406 which part of OBJECT to compute the hash. If nil or omitted, uses the
5409 The full list of algorithms can be obtained with `secure-hash-algorithms'.
5411 If BINARY is non-nil, returns a string in binary form.
5413 Note that MD5 and SHA-1 are not collision resistant and should not be
5414 used for anything security-related. For these applications, use one
5415 of the other hash types instead, e.g. sha256 or sha512. */)
5416 (Lisp_Object algorithm
, Lisp_Object object
, Lisp_Object start
, Lisp_Object end
, Lisp_Object binary
)
5418 return secure_hash (algorithm
, object
, start
, end
, Qnil
, Qnil
, binary
);
5421 DEFUN ("buffer-hash", Fbuffer_hash
, Sbuffer_hash
, 0, 1, 0,
5422 doc
: /* Return a hash of the contents of BUFFER-OR-NAME.
5423 This hash is performed on the raw internal format of the buffer,
5424 disregarding any coding systems. If nil, use the current buffer.
5426 This function is useful for comparing two buffers running in the same
5427 Emacs, but is not guaranteed to return the same hash between different
5430 It should not be used for anything security-related. See
5431 `secure-hash' for these applications. */ )
5432 (Lisp_Object buffer_or_name
)
5436 struct sha1_ctx ctx
;
5438 if (NILP (buffer_or_name
))
5439 buffer
= Fcurrent_buffer ();
5441 buffer
= Fget_buffer (buffer_or_name
);
5443 nsberror (buffer_or_name
);
5445 b
= XBUFFER (buffer
);
5446 sha1_init_ctx (&ctx
);
5448 /* Process the first part of the buffer. */
5449 sha1_process_bytes (BUF_BEG_ADDR (b
),
5450 BUF_GPT_BYTE (b
) - BUF_BEG_BYTE (b
),
5453 /* If the gap is before the end of the buffer, process the last half
5455 if (BUF_GPT_BYTE (b
) < BUF_Z_BYTE (b
))
5456 sha1_process_bytes (BUF_GAP_END_ADDR (b
),
5457 BUF_Z_ADDR (b
) - BUF_GAP_END_ADDR (b
),
5460 Lisp_Object digest
= make_uninit_string (SHA1_DIGEST_SIZE
* 2);
5461 sha1_finish_ctx (&ctx
, SSDATA (digest
));
5462 return make_digest_string (digest
, SHA1_DIGEST_SIZE
);
5470 /* Hash table stuff. */
5471 DEFSYM (Qhash_table_p
, "hash-table-p");
5473 DEFSYM (Qeql
, "eql");
5474 DEFSYM (Qequal
, "equal");
5475 DEFSYM (QCtest
, ":test");
5476 DEFSYM (QCsize
, ":size");
5477 DEFSYM (QCpurecopy
, ":purecopy");
5478 DEFSYM (QCrehash_size
, ":rehash-size");
5479 DEFSYM (QCrehash_threshold
, ":rehash-threshold");
5480 DEFSYM (QCweakness
, ":weakness");
5481 DEFSYM (Qkey
, "key");
5482 DEFSYM (Qvalue
, "value");
5483 DEFSYM (Qhash_table_test
, "hash-table-test");
5484 DEFSYM (Qkey_or_value
, "key-or-value");
5485 DEFSYM (Qkey_and_value
, "key-and-value");
5487 defsubr (&Ssxhash_eq
);
5488 defsubr (&Ssxhash_eql
);
5489 defsubr (&Ssxhash_equal
);
5490 defsubr (&Smake_hash_table
);
5491 defsubr (&Scopy_hash_table
);
5492 defsubr (&Shash_table_count
);
5493 defsubr (&Shash_table_rehash_size
);
5494 defsubr (&Shash_table_rehash_threshold
);
5495 defsubr (&Shash_table_size
);
5496 defsubr (&Shash_table_test
);
5497 defsubr (&Shash_table_weakness
);
5498 defsubr (&Shash_table_p
);
5499 defsubr (&Sclrhash
);
5500 defsubr (&Sgethash
);
5501 defsubr (&Sputhash
);
5502 defsubr (&Sremhash
);
5503 defsubr (&Smaphash
);
5504 defsubr (&Sdefine_hash_table_test
);
5506 /* Crypto and hashing stuff. */
5507 DEFSYM (Qiv_auto
, "iv-auto");
5509 DEFSYM (Qmd5
, "md5");
5510 DEFSYM (Qsha1
, "sha1");
5511 DEFSYM (Qsha224
, "sha224");
5512 DEFSYM (Qsha256
, "sha256");
5513 DEFSYM (Qsha384
, "sha384");
5514 DEFSYM (Qsha512
, "sha512");
5516 /* Miscellaneous stuff. */
5518 DEFSYM (Qstring_lessp
, "string-lessp");
5519 DEFSYM (Qprovide
, "provide");
5520 DEFSYM (Qrequire
, "require");
5521 DEFSYM (Qyes_or_no_p_history
, "yes-or-no-p-history");
5522 DEFSYM (Qcursor_in_echo_area
, "cursor-in-echo-area");
5523 DEFSYM (Qwidget_type
, "widget-type");
5525 DEFVAR_LISP ("overriding-plist-environment", Voverriding_plist_environment
,
5526 doc
: /* An alist that overrides the plists of the symbols which it lists.
5527 Used by the byte-compiler to apply `define-symbol-prop' during
5529 Voverriding_plist_environment
= Qnil
;
5530 DEFSYM (Qoverriding_plist_environment
, "overriding-plist-environment");
5532 staticpro (&string_char_byte_cache_string
);
5533 string_char_byte_cache_string
= Qnil
;
5535 require_nesting_list
= Qnil
;
5536 staticpro (&require_nesting_list
);
5538 Fset (Qyes_or_no_p_history
, Qnil
);
5540 DEFVAR_LISP ("features", Vfeatures
,
5541 doc
: /* A list of symbols which are the features of the executing Emacs.
5542 Used by `featurep' and `require', and altered by `provide'. */);
5543 Vfeatures
= list1 (Qemacs
);
5544 DEFSYM (Qfeatures
, "features");
5545 /* Let people use lexically scoped vars named `features'. */
5546 Fmake_var_non_special (Qfeatures
);
5547 DEFSYM (Qsubfeatures
, "subfeatures");
5548 DEFSYM (Qfuncall
, "funcall");
5549 DEFSYM (Qplistp
, "plistp");
5550 DEFSYM (Qlist_or_vector_p
, "list-or-vector-p");
5552 #ifdef HAVE_LANGINFO_CODESET
5553 DEFSYM (Qcodeset
, "codeset");
5554 DEFSYM (Qdays
, "days");
5555 DEFSYM (Qmonths
, "months");
5556 DEFSYM (Qpaper
, "paper");
5557 #endif /* HAVE_LANGINFO_CODESET */
5559 DEFVAR_BOOL ("use-dialog-box", use_dialog_box
,
5560 doc
: /* Non-nil means mouse commands use dialog boxes to ask questions.
5561 This applies to `y-or-n-p' and `yes-or-no-p' questions asked by commands
5562 invoked by mouse clicks and mouse menu items.
5564 On some platforms, file selection dialogs are also enabled if this is
5566 use_dialog_box
= true;
5568 DEFVAR_BOOL ("use-file-dialog", use_file_dialog
,
5569 doc
: /* Non-nil means mouse commands use a file dialog to ask for files.
5570 This applies to commands from menus and tool bar buttons even when
5571 they are initiated from the keyboard. If `use-dialog-box' is nil,
5572 that disables the use of a file dialog, regardless of the value of
5574 use_file_dialog
= true;
5576 defsubr (&Sidentity
);
5579 defsubr (&Ssafe_length
);
5580 defsubr (&Sproper_list_p
);
5581 defsubr (&Sstring_bytes
);
5582 defsubr (&Sstring_distance
);
5583 defsubr (&Sstring_equal
);
5584 defsubr (&Scompare_strings
);
5585 defsubr (&Sstring_lessp
);
5586 defsubr (&Sstring_version_lessp
);
5587 defsubr (&Sstring_collate_lessp
);
5588 defsubr (&Sstring_collate_equalp
);
5591 defsubr (&Svconcat
);
5592 defsubr (&Scopy_sequence
);
5593 defsubr (&Sstring_make_multibyte
);
5594 defsubr (&Sstring_make_unibyte
);
5595 defsubr (&Sstring_as_multibyte
);
5596 defsubr (&Sstring_as_unibyte
);
5597 defsubr (&Sstring_to_multibyte
);
5598 defsubr (&Sstring_to_unibyte
);
5599 defsubr (&Scopy_alist
);
5600 defsubr (&Ssubstring
);
5601 defsubr (&Ssubstring_no_properties
);
5614 defsubr (&Snreverse
);
5615 defsubr (&Sreverse
);
5617 defsubr (&Splist_get
);
5619 defsubr (&Splist_put
);
5621 defsubr (&Slax_plist_get
);
5622 defsubr (&Slax_plist_put
);
5625 defsubr (&Sequal_including_properties
);
5626 defsubr (&Sfillarray
);
5627 defsubr (&Sclear_string
);
5632 defsubr (&Smapconcat
);
5633 defsubr (&Syes_or_no_p
);
5634 defsubr (&Sload_average
);
5635 defsubr (&Sfeaturep
);
5636 defsubr (&Srequire
);
5637 defsubr (&Sprovide
);
5638 defsubr (&Splist_member
);
5639 defsubr (&Swidget_put
);
5640 defsubr (&Swidget_get
);
5641 defsubr (&Swidget_apply
);
5642 defsubr (&Sbase64_encode_region
);
5643 defsubr (&Sbase64_decode_region
);
5644 defsubr (&Sbase64_encode_string
);
5645 defsubr (&Sbase64_decode_string
);
5646 defsubr (&Sbase64url_encode_region
);
5647 defsubr (&Sbase64url_encode_string
);
5649 defsubr (&Ssecure_hash_algorithms
);
5650 defsubr (&Ssecure_hash
);
5651 defsubr (&Sbuffer_hash
);
5652 defsubr (&Slocale_info
);