1 /* Random utility Lisp functions.
3 Copyright (C) 1985-1987, 1993-1995, 1997-2017 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 <http://www.gnu.org/licenses/>. */
25 #include <filevercmp.h>
31 #include "character.h"
33 #include "composite.h"
35 #include "intervals.h"
38 static void sort_vector_copy (Lisp_Object
, ptrdiff_t,
39 Lisp_Object
*restrict
, Lisp_Object
*restrict
);
40 static bool internal_equal (Lisp_Object
, Lisp_Object
, int, bool, Lisp_Object
);
42 DEFUN ("identity", Fidentity
, Sidentity
, 1, 1, 0,
43 doc
: /* Return the argument unchanged. */
50 DEFUN ("random", Frandom
, Srandom
, 0, 1, 0,
51 doc
: /* Return a pseudo-random number.
52 All integers representable in Lisp, i.e. between `most-negative-fixnum'
53 and `most-positive-fixnum', inclusive, are equally likely.
55 With positive integer LIMIT, return random number in interval [0,LIMIT).
56 With argument t, set the random number seed from the system's entropy
57 pool if available, otherwise from less-random volatile data such as the time.
58 With a string argument, set the seed based on the string's contents.
59 Other values of LIMIT are ignored.
61 See Info node `(elisp)Random Numbers' for more details. */)
68 else if (STRINGP (limit
))
69 seed_random (SSDATA (limit
), SBYTES (limit
));
72 if (INTEGERP (limit
) && 0 < XINT (limit
))
75 /* Return the remainder, except reject the rare case where
76 get_random returns a number so close to INTMASK that the
77 remainder isn't random. */
78 EMACS_INT remainder
= val
% XINT (limit
);
79 if (val
- remainder
<= INTMASK
- XINT (limit
) + 1)
80 return make_number (remainder
);
83 return make_number (val
);
86 /* Heuristic on how many iterations of a tight loop can be safely done
87 before it's time to do a QUIT. This must be a power of 2. */
88 enum { QUIT_COUNT_HEURISTIC
= 1 << 16 };
90 /* Random data-structure functions. */
92 DEFUN ("length", Flength
, Slength
, 1, 1, 0,
93 doc
: /* Return the length of vector, list or string SEQUENCE.
94 A byte-code function object is also allowed.
95 If the string contains multibyte characters, this is not necessarily
96 the number of bytes in the string; it is the number of characters.
97 To get the number of bytes, use `string-bytes'. */)
98 (register Lisp_Object sequence
)
100 register Lisp_Object val
;
102 if (STRINGP (sequence
))
103 XSETFASTINT (val
, SCHARS (sequence
));
104 else if (VECTORP (sequence
))
105 XSETFASTINT (val
, ASIZE (sequence
));
106 else if (CHAR_TABLE_P (sequence
))
107 XSETFASTINT (val
, MAX_CHAR
);
108 else if (BOOL_VECTOR_P (sequence
))
109 XSETFASTINT (val
, bool_vector_size (sequence
));
110 else if (COMPILEDP (sequence
))
111 XSETFASTINT (val
, ASIZE (sequence
) & PSEUDOVECTOR_SIZE_MASK
);
112 else if (CONSP (sequence
))
119 if ((i
& (QUIT_COUNT_HEURISTIC
- 1)) == 0)
121 if (MOST_POSITIVE_FIXNUM
< i
)
122 error ("List too long");
125 sequence
= XCDR (sequence
);
127 while (CONSP (sequence
));
129 CHECK_LIST_END (sequence
, sequence
);
131 val
= make_number (i
);
133 else if (NILP (sequence
))
134 XSETFASTINT (val
, 0);
136 wrong_type_argument (Qsequencep
, sequence
);
141 DEFUN ("safe-length", Fsafe_length
, Ssafe_length
, 1, 1, 0,
142 doc
: /* Return the length of a list, but avoid error or infinite loop.
143 This function never gets an error. If LIST is not really a list,
144 it returns 0. If LIST is circular, it returns a finite value
145 which is at least the number of distinct elements. */)
148 Lisp_Object tail
, halftail
;
153 return make_number (0);
155 /* halftail is used to detect circular lists. */
156 for (tail
= halftail
= list
; ; )
161 if (EQ (tail
, halftail
))
164 if ((lolen
& 1) == 0)
166 halftail
= XCDR (halftail
);
167 if ((lolen
& (QUIT_COUNT_HEURISTIC
- 1)) == 0)
171 hilen
+= UINTMAX_MAX
+ 1.0;
176 /* If the length does not fit into a fixnum, return a float.
177 On all known practical machines this returns an upper bound on
179 return hilen
? make_float (hilen
+ lolen
) : make_fixnum_or_float (lolen
);
182 DEFUN ("string-bytes", Fstring_bytes
, Sstring_bytes
, 1, 1, 0,
183 doc
: /* Return the number of bytes in STRING.
184 If STRING is multibyte, this may be greater than the length of STRING. */)
187 CHECK_STRING (string
);
188 return make_number (SBYTES (string
));
191 DEFUN ("string-equal", Fstring_equal
, Sstring_equal
, 2, 2, 0,
192 doc
: /* Return t if two strings have identical contents.
193 Case is significant, but text properties are ignored.
194 Symbols are also allowed; their print names are used instead. */)
195 (register Lisp_Object s1
, Lisp_Object s2
)
198 s1
= SYMBOL_NAME (s1
);
200 s2
= SYMBOL_NAME (s2
);
204 if (SCHARS (s1
) != SCHARS (s2
)
205 || SBYTES (s1
) != SBYTES (s2
)
206 || memcmp (SDATA (s1
), SDATA (s2
), SBYTES (s1
)))
211 DEFUN ("compare-strings", Fcompare_strings
, Scompare_strings
, 6, 7, 0,
212 doc
: /* Compare the contents of two strings, converting to multibyte if needed.
213 The arguments START1, END1, START2, and END2, if non-nil, are
214 positions specifying which parts of STR1 or STR2 to compare. In
215 string STR1, compare the part between START1 (inclusive) and END1
216 \(exclusive). If START1 is nil, it defaults to 0, the beginning of
217 the string; if END1 is nil, it defaults to the length of the string.
218 Likewise, in string STR2, compare the part between START2 and END2.
219 Like in `substring', negative values are counted from the end.
221 The strings are compared by the numeric values of their characters.
222 For instance, STR1 is "less than" STR2 if its first differing
223 character has a smaller numeric value. If IGNORE-CASE is non-nil,
224 characters are converted to upper-case before comparing them. Unibyte
225 strings are converted to multibyte for comparison.
227 The value is t if the strings (or specified portions) match.
228 If string STR1 is less, the value is a negative number N;
229 - 1 - N is the number of characters that match at the beginning.
230 If string STR1 is greater, the value is a positive number N;
231 N - 1 is the number of characters that match at the beginning. */)
232 (Lisp_Object str1
, Lisp_Object start1
, Lisp_Object end1
, Lisp_Object str2
,
233 Lisp_Object start2
, Lisp_Object end2
, Lisp_Object ignore_case
)
235 ptrdiff_t from1
, to1
, from2
, to2
, i1
, i1_byte
, i2
, i2_byte
;
240 /* For backward compatibility, silently bring too-large positive end
241 values into range. */
242 if (INTEGERP (end1
) && SCHARS (str1
) < XINT (end1
))
243 end1
= make_number (SCHARS (str1
));
244 if (INTEGERP (end2
) && SCHARS (str2
) < XINT (end2
))
245 end2
= make_number (SCHARS (str2
));
247 validate_subarray (str1
, start1
, end1
, SCHARS (str1
), &from1
, &to1
);
248 validate_subarray (str2
, start2
, end2
, SCHARS (str2
), &from2
, &to2
);
253 i1_byte
= string_char_to_byte (str1
, i1
);
254 i2_byte
= string_char_to_byte (str2
, i2
);
256 while (i1
< to1
&& i2
< to2
)
258 /* When we find a mismatch, we must compare the
259 characters, not just the bytes. */
262 FETCH_STRING_CHAR_AS_MULTIBYTE_ADVANCE (c1
, str1
, i1
, i1_byte
);
263 FETCH_STRING_CHAR_AS_MULTIBYTE_ADVANCE (c2
, str2
, i2
, i2_byte
);
268 if (! NILP (ignore_case
))
270 c1
= XINT (Fupcase (make_number (c1
)));
271 c2
= XINT (Fupcase (make_number (c2
)));
277 /* Note that I1 has already been incremented
278 past the character that we are comparing;
279 hence we don't add or subtract 1 here. */
281 return make_number (- i1
+ from1
);
283 return make_number (i1
- from1
);
287 return make_number (i1
- from1
+ 1);
289 return make_number (- i1
+ from1
- 1);
294 DEFUN ("string-lessp", Fstring_lessp
, Sstring_lessp
, 2, 2, 0,
295 doc
: /* Return non-nil if STRING1 is less than STRING2 in lexicographic order.
297 Symbols are also allowed; their print names are used instead. */)
298 (register Lisp_Object string1
, Lisp_Object string2
)
300 register ptrdiff_t end
;
301 register ptrdiff_t i1
, i1_byte
, i2
, i2_byte
;
303 if (SYMBOLP (string1
))
304 string1
= SYMBOL_NAME (string1
);
305 if (SYMBOLP (string2
))
306 string2
= SYMBOL_NAME (string2
);
307 CHECK_STRING (string1
);
308 CHECK_STRING (string2
);
310 i1
= i1_byte
= i2
= i2_byte
= 0;
312 end
= SCHARS (string1
);
313 if (end
> SCHARS (string2
))
314 end
= SCHARS (string2
);
318 /* When we find a mismatch, we must compare the
319 characters, not just the bytes. */
322 FETCH_STRING_CHAR_ADVANCE (c1
, string1
, i1
, i1_byte
);
323 FETCH_STRING_CHAR_ADVANCE (c2
, string2
, i2
, i2_byte
);
326 return c1
< c2
? Qt
: Qnil
;
328 return i1
< SCHARS (string2
) ? Qt
: Qnil
;
331 DEFUN ("string-version-lessp", Fstring_version_lessp
,
332 Sstring_version_lessp
, 2, 2, 0,
333 doc
: /* Return non-nil if S1 is less than S2, as version strings.
335 This function compares version strings S1 and S2:
336 1) By prefix lexicographically.
337 2) Then by version (similarly to version comparison of Debian's dpkg).
338 Leading zeros in version numbers are ignored.
339 3) If both prefix and version are equal, compare as ordinary strings.
341 For example, \"foo2.png\" compares less than \"foo12.png\".
343 Symbols are also allowed; their print names are used instead. */)
344 (Lisp_Object string1
, Lisp_Object string2
)
346 if (SYMBOLP (string1
))
347 string1
= SYMBOL_NAME (string1
);
348 if (SYMBOLP (string2
))
349 string2
= SYMBOL_NAME (string2
);
350 CHECK_STRING (string1
);
351 CHECK_STRING (string2
);
353 char *p1
= SSDATA (string1
);
354 char *p2
= SSDATA (string2
);
355 char *lim1
= p1
+ SBYTES (string1
);
356 char *lim2
= p2
+ SBYTES (string2
);
359 while ((cmp
= filevercmp (p1
, p2
)) == 0)
361 /* If the strings are identical through their first null bytes,
362 skip past identical prefixes and try again. */
363 ptrdiff_t size
= strlen (p1
) + 1;
367 return lim2
< p2
? Qnil
: Qt
;
372 return cmp
< 0 ? Qt
: Qnil
;
375 DEFUN ("string-collate-lessp", Fstring_collate_lessp
, Sstring_collate_lessp
, 2, 4, 0,
376 doc
: /* Return t if first arg string is less than second in collation order.
377 Symbols are also allowed; their print names are used instead.
379 This function obeys the conventions for collation order in your
380 locale settings. For example, punctuation and whitespace characters
381 might be considered less significant for sorting:
383 \(sort \\='("11" "12" "1 1" "1 2" "1.1" "1.2") \\='string-collate-lessp)
384 => ("11" "1 1" "1.1" "12" "1 2" "1.2")
386 The optional argument LOCALE, a string, overrides the setting of your
387 current locale identifier for collation. The value is system
388 dependent; a LOCALE \"en_US.UTF-8\" is applicable on POSIX systems,
389 while it would be, e.g., \"enu_USA.1252\" on MS-Windows systems.
391 If IGNORE-CASE is non-nil, characters are converted to lower-case
392 before comparing them.
394 To emulate Unicode-compliant collation on MS-Windows systems,
395 bind `w32-collate-ignore-punctuation' to a non-nil value, since
396 the codeset part of the locale cannot be \"UTF-8\" on MS-Windows.
398 If your system does not support a locale environment, this function
399 behaves like `string-lessp'. */)
400 (Lisp_Object s1
, Lisp_Object s2
, Lisp_Object locale
, Lisp_Object ignore_case
)
402 #if defined __STDC_ISO_10646__ || defined WINDOWSNT
403 /* Check parameters. */
405 s1
= SYMBOL_NAME (s1
);
407 s2
= SYMBOL_NAME (s2
);
411 CHECK_STRING (locale
);
413 return (str_collate (s1
, s2
, locale
, ignore_case
) < 0) ? Qt
: Qnil
;
415 #else /* !__STDC_ISO_10646__, !WINDOWSNT */
416 return Fstring_lessp (s1
, s2
);
417 #endif /* !__STDC_ISO_10646__, !WINDOWSNT */
420 DEFUN ("string-collate-equalp", Fstring_collate_equalp
, Sstring_collate_equalp
, 2, 4, 0,
421 doc
: /* Return t if two strings have identical contents.
422 Symbols are also allowed; their print names are used instead.
424 This function obeys the conventions for collation order in your locale
425 settings. For example, characters with different coding points but
426 the same meaning might be considered as equal, like different grave
427 accent Unicode characters:
429 \(string-collate-equalp (string ?\\uFF40) (string ?\\u1FEF))
432 The optional argument LOCALE, a string, overrides the setting of your
433 current locale identifier for collation. The value is system
434 dependent; a LOCALE \"en_US.UTF-8\" is applicable on POSIX systems,
435 while it would be \"enu_USA.1252\" on MS Windows systems.
437 If IGNORE-CASE is non-nil, characters are converted to lower-case
438 before comparing them.
440 To emulate Unicode-compliant collation on MS-Windows systems,
441 bind `w32-collate-ignore-punctuation' to a non-nil value, since
442 the codeset part of the locale cannot be \"UTF-8\" on MS-Windows.
444 If your system does not support a locale environment, this function
445 behaves like `string-equal'.
447 Do NOT use this function to compare file names for equality. */)
448 (Lisp_Object s1
, Lisp_Object s2
, Lisp_Object locale
, Lisp_Object ignore_case
)
450 #if defined __STDC_ISO_10646__ || defined WINDOWSNT
451 /* Check parameters. */
453 s1
= SYMBOL_NAME (s1
);
455 s2
= SYMBOL_NAME (s2
);
459 CHECK_STRING (locale
);
461 return (str_collate (s1
, s2
, locale
, ignore_case
) == 0) ? Qt
: Qnil
;
463 #else /* !__STDC_ISO_10646__, !WINDOWSNT */
464 return Fstring_equal (s1
, s2
);
465 #endif /* !__STDC_ISO_10646__, !WINDOWSNT */
468 static Lisp_Object
concat (ptrdiff_t nargs
, Lisp_Object
*args
,
469 enum Lisp_Type target_type
, bool last_special
);
473 concat2 (Lisp_Object s1
, Lisp_Object s2
)
475 return concat (2, ((Lisp_Object
[]) {s1
, s2
}), Lisp_String
, 0);
480 concat3 (Lisp_Object s1
, Lisp_Object s2
, Lisp_Object s3
)
482 return concat (3, ((Lisp_Object
[]) {s1
, s2
, s3
}), Lisp_String
, 0);
485 DEFUN ("append", Fappend
, Sappend
, 0, MANY
, 0,
486 doc
: /* Concatenate all the arguments and make the result a list.
487 The result is a list whose elements are the elements of all the arguments.
488 Each argument may be a list, vector or string.
489 The last argument is not copied, just used as the tail of the new list.
490 usage: (append &rest SEQUENCES) */)
491 (ptrdiff_t nargs
, Lisp_Object
*args
)
493 return concat (nargs
, args
, Lisp_Cons
, 1);
496 DEFUN ("concat", Fconcat
, Sconcat
, 0, MANY
, 0,
497 doc
: /* Concatenate all the arguments and make the result a string.
498 The result is a string whose elements are the elements of all the arguments.
499 Each argument may be a string or a list or vector of characters (integers).
500 usage: (concat &rest SEQUENCES) */)
501 (ptrdiff_t nargs
, Lisp_Object
*args
)
503 return concat (nargs
, args
, Lisp_String
, 0);
506 DEFUN ("vconcat", Fvconcat
, Svconcat
, 0, MANY
, 0,
507 doc
: /* Concatenate all the arguments and make the result a vector.
508 The result is a vector whose elements are the elements of all the arguments.
509 Each argument may be a list, vector or string.
510 usage: (vconcat &rest SEQUENCES) */)
511 (ptrdiff_t nargs
, Lisp_Object
*args
)
513 return concat (nargs
, args
, Lisp_Vectorlike
, 0);
517 DEFUN ("copy-sequence", Fcopy_sequence
, Scopy_sequence
, 1, 1, 0,
518 doc
: /* Return a copy of a list, vector, string or char-table.
519 The elements of a list or vector are not copied; they are shared
520 with the original. */)
523 if (NILP (arg
)) return arg
;
525 if (CHAR_TABLE_P (arg
))
527 return copy_char_table (arg
);
530 if (BOOL_VECTOR_P (arg
))
532 EMACS_INT nbits
= bool_vector_size (arg
);
533 ptrdiff_t nbytes
= bool_vector_bytes (nbits
);
534 Lisp_Object val
= make_uninit_bool_vector (nbits
);
535 memcpy (bool_vector_data (val
), bool_vector_data (arg
), nbytes
);
539 if (!CONSP (arg
) && !VECTORP (arg
) && !STRINGP (arg
))
540 wrong_type_argument (Qsequencep
, arg
);
542 return concat (1, &arg
, XTYPE (arg
), 0);
545 /* This structure holds information of an argument of `concat' that is
546 a string and has text properties to be copied. */
549 ptrdiff_t argnum
; /* refer to ARGS (arguments of `concat') */
550 ptrdiff_t from
; /* refer to ARGS[argnum] (argument string) */
551 ptrdiff_t to
; /* refer to VAL (the target string) */
555 concat (ptrdiff_t nargs
, Lisp_Object
*args
,
556 enum Lisp_Type target_type
, bool last_special
)
562 ptrdiff_t toindex_byte
= 0;
563 EMACS_INT result_len
;
564 EMACS_INT result_len_byte
;
566 Lisp_Object last_tail
;
569 /* When we make a multibyte string, we can't copy text properties
570 while concatenating each string because the length of resulting
571 string can't be decided until we finish the whole concatenation.
572 So, we record strings that have text properties to be copied
573 here, and copy the text properties after the concatenation. */
574 struct textprop_rec
*textprops
= NULL
;
575 /* Number of elements in textprops. */
576 ptrdiff_t num_textprops
= 0;
581 /* In append, the last arg isn't treated like the others */
582 if (last_special
&& nargs
> 0)
585 last_tail
= args
[nargs
];
590 /* Check each argument. */
591 for (argnum
= 0; argnum
< nargs
; argnum
++)
594 if (!(CONSP (this) || NILP (this) || VECTORP (this) || STRINGP (this)
595 || COMPILEDP (this) || BOOL_VECTOR_P (this)))
596 wrong_type_argument (Qsequencep
, this);
599 /* Compute total length in chars of arguments in RESULT_LEN.
600 If desired output is a string, also compute length in bytes
601 in RESULT_LEN_BYTE, and determine in SOME_MULTIBYTE
602 whether the result should be a multibyte string. */
606 for (argnum
= 0; argnum
< nargs
; argnum
++)
610 len
= XFASTINT (Flength (this));
611 if (target_type
== Lisp_String
)
613 /* We must count the number of bytes needed in the string
614 as well as the number of characters. */
618 ptrdiff_t this_len_byte
;
620 if (VECTORP (this) || COMPILEDP (this))
621 for (i
= 0; i
< len
; i
++)
624 CHECK_CHARACTER (ch
);
626 this_len_byte
= CHAR_BYTES (c
);
627 if (STRING_BYTES_BOUND
- result_len_byte
< this_len_byte
)
629 result_len_byte
+= this_len_byte
;
630 if (! ASCII_CHAR_P (c
) && ! CHAR_BYTE8_P (c
))
633 else if (BOOL_VECTOR_P (this) && bool_vector_size (this) > 0)
634 wrong_type_argument (Qintegerp
, Faref (this, make_number (0)));
635 else if (CONSP (this))
636 for (; CONSP (this); this = XCDR (this))
639 CHECK_CHARACTER (ch
);
641 this_len_byte
= CHAR_BYTES (c
);
642 if (STRING_BYTES_BOUND
- result_len_byte
< this_len_byte
)
644 result_len_byte
+= this_len_byte
;
645 if (! ASCII_CHAR_P (c
) && ! CHAR_BYTE8_P (c
))
648 else if (STRINGP (this))
650 if (STRING_MULTIBYTE (this))
653 this_len_byte
= SBYTES (this);
656 this_len_byte
= count_size_as_multibyte (SDATA (this),
658 if (STRING_BYTES_BOUND
- result_len_byte
< this_len_byte
)
660 result_len_byte
+= this_len_byte
;
665 if (MOST_POSITIVE_FIXNUM
< result_len
)
666 memory_full (SIZE_MAX
);
669 if (! some_multibyte
)
670 result_len_byte
= result_len
;
672 /* Create the output object. */
673 if (target_type
== Lisp_Cons
)
674 val
= Fmake_list (make_number (result_len
), Qnil
);
675 else if (target_type
== Lisp_Vectorlike
)
676 val
= Fmake_vector (make_number (result_len
), Qnil
);
677 else if (some_multibyte
)
678 val
= make_uninit_multibyte_string (result_len
, result_len_byte
);
680 val
= make_uninit_string (result_len
);
682 /* In `append', if all but last arg are nil, return last arg. */
683 if (target_type
== Lisp_Cons
&& EQ (val
, Qnil
))
686 /* Copy the contents of the args into the result. */
688 tail
= val
, toindex
= -1; /* -1 in toindex is flag we are making a list */
690 toindex
= 0, toindex_byte
= 0;
694 SAFE_NALLOCA (textprops
, 1, nargs
);
696 for (argnum
= 0; argnum
< nargs
; argnum
++)
699 ptrdiff_t thisleni
= 0;
700 register ptrdiff_t thisindex
= 0;
701 register ptrdiff_t thisindex_byte
= 0;
705 thislen
= Flength (this), thisleni
= XINT (thislen
);
707 /* Between strings of the same kind, copy fast. */
708 if (STRINGP (this) && STRINGP (val
)
709 && STRING_MULTIBYTE (this) == some_multibyte
)
711 ptrdiff_t thislen_byte
= SBYTES (this);
713 memcpy (SDATA (val
) + toindex_byte
, SDATA (this), SBYTES (this));
714 if (string_intervals (this))
716 textprops
[num_textprops
].argnum
= argnum
;
717 textprops
[num_textprops
].from
= 0;
718 textprops
[num_textprops
++].to
= toindex
;
720 toindex_byte
+= thislen_byte
;
723 /* Copy a single-byte string to a multibyte string. */
724 else if (STRINGP (this) && STRINGP (val
))
726 if (string_intervals (this))
728 textprops
[num_textprops
].argnum
= argnum
;
729 textprops
[num_textprops
].from
= 0;
730 textprops
[num_textprops
++].to
= toindex
;
732 toindex_byte
+= copy_text (SDATA (this),
733 SDATA (val
) + toindex_byte
,
734 SCHARS (this), 0, 1);
738 /* Copy element by element. */
741 register Lisp_Object elt
;
743 /* Fetch next element of `this' arg into `elt', or break if
744 `this' is exhausted. */
745 if (NILP (this)) break;
747 elt
= XCAR (this), this = XCDR (this);
748 else if (thisindex
>= thisleni
)
750 else if (STRINGP (this))
753 if (STRING_MULTIBYTE (this))
754 FETCH_STRING_CHAR_ADVANCE_NO_CHECK (c
, this,
759 c
= SREF (this, thisindex
); thisindex
++;
760 if (some_multibyte
&& !ASCII_CHAR_P (c
))
761 c
= BYTE8_TO_CHAR (c
);
763 XSETFASTINT (elt
, c
);
765 else if (BOOL_VECTOR_P (this))
767 elt
= bool_vector_ref (this, thisindex
);
772 elt
= AREF (this, thisindex
);
776 /* Store this element into the result. */
783 else if (VECTORP (val
))
785 ASET (val
, toindex
, elt
);
791 CHECK_CHARACTER (elt
);
794 toindex_byte
+= CHAR_STRING (c
, SDATA (val
) + toindex_byte
);
796 SSET (val
, toindex_byte
++, c
);
802 XSETCDR (prev
, last_tail
);
804 if (num_textprops
> 0)
807 ptrdiff_t last_to_end
= -1;
809 for (argnum
= 0; argnum
< num_textprops
; argnum
++)
811 this = args
[textprops
[argnum
].argnum
];
812 props
= text_property_list (this,
814 make_number (SCHARS (this)),
816 /* If successive arguments have properties, be sure that the
817 value of `composition' property be the copy. */
818 if (last_to_end
== textprops
[argnum
].to
)
819 make_composition_value_copy (props
);
820 add_text_properties_from_list (val
, props
,
821 make_number (textprops
[argnum
].to
));
822 last_to_end
= textprops
[argnum
].to
+ SCHARS (this);
830 static Lisp_Object string_char_byte_cache_string
;
831 static ptrdiff_t string_char_byte_cache_charpos
;
832 static ptrdiff_t string_char_byte_cache_bytepos
;
835 clear_string_char_byte_cache (void)
837 string_char_byte_cache_string
= Qnil
;
840 /* Return the byte index corresponding to CHAR_INDEX in STRING. */
843 string_char_to_byte (Lisp_Object string
, ptrdiff_t char_index
)
846 ptrdiff_t best_below
, best_below_byte
;
847 ptrdiff_t best_above
, best_above_byte
;
849 best_below
= best_below_byte
= 0;
850 best_above
= SCHARS (string
);
851 best_above_byte
= SBYTES (string
);
852 if (best_above
== best_above_byte
)
855 if (EQ (string
, string_char_byte_cache_string
))
857 if (string_char_byte_cache_charpos
< char_index
)
859 best_below
= string_char_byte_cache_charpos
;
860 best_below_byte
= string_char_byte_cache_bytepos
;
864 best_above
= string_char_byte_cache_charpos
;
865 best_above_byte
= string_char_byte_cache_bytepos
;
869 if (char_index
- best_below
< best_above
- char_index
)
871 unsigned char *p
= SDATA (string
) + best_below_byte
;
873 while (best_below
< char_index
)
875 p
+= BYTES_BY_CHAR_HEAD (*p
);
878 i_byte
= p
- SDATA (string
);
882 unsigned char *p
= SDATA (string
) + best_above_byte
;
884 while (best_above
> char_index
)
887 while (!CHAR_HEAD_P (*p
)) p
--;
890 i_byte
= p
- SDATA (string
);
893 string_char_byte_cache_bytepos
= i_byte
;
894 string_char_byte_cache_charpos
= char_index
;
895 string_char_byte_cache_string
= string
;
900 /* Return the character index corresponding to BYTE_INDEX in STRING. */
903 string_byte_to_char (Lisp_Object string
, ptrdiff_t byte_index
)
906 ptrdiff_t best_below
, best_below_byte
;
907 ptrdiff_t best_above
, best_above_byte
;
909 best_below
= best_below_byte
= 0;
910 best_above
= SCHARS (string
);
911 best_above_byte
= SBYTES (string
);
912 if (best_above
== best_above_byte
)
915 if (EQ (string
, string_char_byte_cache_string
))
917 if (string_char_byte_cache_bytepos
< byte_index
)
919 best_below
= string_char_byte_cache_charpos
;
920 best_below_byte
= string_char_byte_cache_bytepos
;
924 best_above
= string_char_byte_cache_charpos
;
925 best_above_byte
= string_char_byte_cache_bytepos
;
929 if (byte_index
- best_below_byte
< best_above_byte
- byte_index
)
931 unsigned char *p
= SDATA (string
) + best_below_byte
;
932 unsigned char *pend
= SDATA (string
) + byte_index
;
936 p
+= BYTES_BY_CHAR_HEAD (*p
);
940 i_byte
= p
- SDATA (string
);
944 unsigned char *p
= SDATA (string
) + best_above_byte
;
945 unsigned char *pbeg
= SDATA (string
) + byte_index
;
950 while (!CHAR_HEAD_P (*p
)) p
--;
954 i_byte
= p
- SDATA (string
);
957 string_char_byte_cache_bytepos
= i_byte
;
958 string_char_byte_cache_charpos
= i
;
959 string_char_byte_cache_string
= string
;
964 /* Convert STRING to a multibyte string. */
967 string_make_multibyte (Lisp_Object string
)
974 if (STRING_MULTIBYTE (string
))
977 nbytes
= count_size_as_multibyte (SDATA (string
),
979 /* If all the chars are ASCII, they won't need any more bytes
980 once converted. In that case, we can return STRING itself. */
981 if (nbytes
== SBYTES (string
))
984 buf
= SAFE_ALLOCA (nbytes
);
985 copy_text (SDATA (string
), buf
, SBYTES (string
),
988 ret
= make_multibyte_string ((char *) buf
, SCHARS (string
), nbytes
);
995 /* Convert STRING (if unibyte) to a multibyte string without changing
996 the number of characters. Characters 0200 trough 0237 are
997 converted to eight-bit characters. */
1000 string_to_multibyte (Lisp_Object string
)
1007 if (STRING_MULTIBYTE (string
))
1010 nbytes
= count_size_as_multibyte (SDATA (string
), SBYTES (string
));
1011 /* If all the chars are ASCII, they won't need any more bytes once
1013 if (nbytes
== SBYTES (string
))
1014 return make_multibyte_string (SSDATA (string
), nbytes
, nbytes
);
1016 buf
= SAFE_ALLOCA (nbytes
);
1017 memcpy (buf
, SDATA (string
), SBYTES (string
));
1018 str_to_multibyte (buf
, nbytes
, SBYTES (string
));
1020 ret
= make_multibyte_string ((char *) buf
, SCHARS (string
), nbytes
);
1027 /* Convert STRING to a single-byte string. */
1030 string_make_unibyte (Lisp_Object string
)
1037 if (! STRING_MULTIBYTE (string
))
1040 nchars
= SCHARS (string
);
1042 buf
= SAFE_ALLOCA (nchars
);
1043 copy_text (SDATA (string
), buf
, SBYTES (string
),
1046 ret
= make_unibyte_string ((char *) buf
, nchars
);
1052 DEFUN ("string-make-multibyte", Fstring_make_multibyte
, Sstring_make_multibyte
,
1054 doc
: /* Return the multibyte equivalent of STRING.
1055 If STRING is unibyte and contains non-ASCII characters, the function
1056 `unibyte-char-to-multibyte' is used to convert each unibyte character
1057 to a multibyte character. In this case, the returned string is a
1058 newly created string with no text properties. If STRING is multibyte
1059 or entirely ASCII, it is returned unchanged. In particular, when
1060 STRING is unibyte and entirely ASCII, the returned string is unibyte.
1061 \(When the characters are all ASCII, Emacs primitives will treat the
1062 string the same way whether it is unibyte or multibyte.) */)
1063 (Lisp_Object string
)
1065 CHECK_STRING (string
);
1067 return string_make_multibyte (string
);
1070 DEFUN ("string-make-unibyte", Fstring_make_unibyte
, Sstring_make_unibyte
,
1072 doc
: /* Return the unibyte equivalent of STRING.
1073 Multibyte character codes are converted to unibyte according to
1074 `nonascii-translation-table' or, if that is nil, `nonascii-insert-offset'.
1075 If the lookup in the translation table fails, this function takes just
1076 the low 8 bits of each character. */)
1077 (Lisp_Object string
)
1079 CHECK_STRING (string
);
1081 return string_make_unibyte (string
);
1084 DEFUN ("string-as-unibyte", Fstring_as_unibyte
, Sstring_as_unibyte
,
1086 doc
: /* Return a unibyte string with the same individual bytes as STRING.
1087 If STRING is unibyte, the result is STRING itself.
1088 Otherwise it is a newly created string, with no text properties.
1089 If STRING is multibyte and contains a character of charset
1090 `eight-bit', it is converted to the corresponding single byte. */)
1091 (Lisp_Object string
)
1093 CHECK_STRING (string
);
1095 if (STRING_MULTIBYTE (string
))
1097 unsigned char *str
= (unsigned char *) xlispstrdup (string
);
1098 ptrdiff_t bytes
= str_as_unibyte (str
, SBYTES (string
));
1100 string
= make_unibyte_string ((char *) str
, bytes
);
1106 DEFUN ("string-as-multibyte", Fstring_as_multibyte
, Sstring_as_multibyte
,
1108 doc
: /* Return a multibyte string with the same individual bytes as STRING.
1109 If STRING is multibyte, the result is STRING itself.
1110 Otherwise it is a newly created string, with no text properties.
1112 If STRING is unibyte and contains an individual 8-bit byte (i.e. not
1113 part of a correct utf-8 sequence), it is converted to the corresponding
1114 multibyte character of charset `eight-bit'.
1115 See also `string-to-multibyte'.
1117 Beware, this often doesn't really do what you think it does.
1118 It is similar to (decode-coding-string STRING \\='utf-8-emacs).
1119 If you're not sure, whether to use `string-as-multibyte' or
1120 `string-to-multibyte', use `string-to-multibyte'. */)
1121 (Lisp_Object string
)
1123 CHECK_STRING (string
);
1125 if (! STRING_MULTIBYTE (string
))
1127 Lisp_Object new_string
;
1128 ptrdiff_t nchars
, nbytes
;
1130 parse_str_as_multibyte (SDATA (string
),
1133 new_string
= make_uninit_multibyte_string (nchars
, nbytes
);
1134 memcpy (SDATA (new_string
), SDATA (string
), SBYTES (string
));
1135 if (nbytes
!= SBYTES (string
))
1136 str_as_multibyte (SDATA (new_string
), nbytes
,
1137 SBYTES (string
), NULL
);
1138 string
= new_string
;
1139 set_string_intervals (string
, NULL
);
1144 DEFUN ("string-to-multibyte", Fstring_to_multibyte
, Sstring_to_multibyte
,
1146 doc
: /* Return a multibyte string with the same individual chars as STRING.
1147 If STRING is multibyte, the result is STRING itself.
1148 Otherwise it is a newly created string, with no text properties.
1150 If STRING is unibyte and contains an 8-bit byte, it is converted to
1151 the corresponding multibyte character of charset `eight-bit'.
1153 This differs from `string-as-multibyte' by converting each byte of a correct
1154 utf-8 sequence to an eight-bit character, not just bytes that don't form a
1155 correct sequence. */)
1156 (Lisp_Object string
)
1158 CHECK_STRING (string
);
1160 return string_to_multibyte (string
);
1163 DEFUN ("string-to-unibyte", Fstring_to_unibyte
, Sstring_to_unibyte
,
1165 doc
: /* Return a unibyte string with the same individual chars as STRING.
1166 If STRING is unibyte, the result is STRING itself.
1167 Otherwise it is a newly created string, with no text properties,
1168 where each `eight-bit' character is converted to the corresponding byte.
1169 If STRING contains a non-ASCII, non-`eight-bit' character,
1170 an error is signaled. */)
1171 (Lisp_Object string
)
1173 CHECK_STRING (string
);
1175 if (STRING_MULTIBYTE (string
))
1177 ptrdiff_t chars
= SCHARS (string
);
1178 unsigned char *str
= xmalloc (chars
);
1179 ptrdiff_t converted
= str_to_unibyte (SDATA (string
), str
, chars
);
1181 if (converted
< chars
)
1182 error ("Can't convert the %"pD
"dth character to unibyte", converted
);
1183 string
= make_unibyte_string ((char *) str
, chars
);
1190 DEFUN ("copy-alist", Fcopy_alist
, Scopy_alist
, 1, 1, 0,
1191 doc
: /* Return a copy of ALIST.
1192 This is an alist which represents the same mapping from objects to objects,
1193 but does not share the alist structure with ALIST.
1194 The objects mapped (cars and cdrs of elements of the alist)
1195 are shared, however.
1196 Elements of ALIST that are not conses are also shared. */)
1201 alist
= concat (1, &alist
, Lisp_Cons
, false);
1202 for (Lisp_Object tem
= alist
; !NILP (tem
); tem
= XCDR (tem
))
1204 Lisp_Object car
= XCAR (tem
);
1206 XSETCAR (tem
, Fcons (XCAR (car
), XCDR (car
)));
1211 /* Check that ARRAY can have a valid subarray [FROM..TO),
1212 given that its size is SIZE.
1213 If FROM is nil, use 0; if TO is nil, use SIZE.
1214 Count negative values backwards from the end.
1215 Set *IFROM and *ITO to the two indexes used. */
1218 validate_subarray (Lisp_Object array
, Lisp_Object from
, Lisp_Object to
,
1219 ptrdiff_t size
, ptrdiff_t *ifrom
, ptrdiff_t *ito
)
1223 if (INTEGERP (from
))
1229 else if (NILP (from
))
1232 wrong_type_argument (Qintegerp
, from
);
1243 wrong_type_argument (Qintegerp
, to
);
1245 if (! (0 <= f
&& f
<= t
&& t
<= size
))
1246 args_out_of_range_3 (array
, from
, to
);
1252 DEFUN ("substring", Fsubstring
, Ssubstring
, 1, 3, 0,
1253 doc
: /* Return a new string whose contents are a substring of STRING.
1254 The returned string consists of the characters between index FROM
1255 \(inclusive) and index TO (exclusive) of STRING. FROM and TO are
1256 zero-indexed: 0 means the first character of STRING. Negative values
1257 are counted from the end of STRING. If TO is nil, the substring runs
1258 to the end of STRING.
1260 The STRING argument may also be a vector. In that case, the return
1261 value is a new vector that contains the elements between index FROM
1262 \(inclusive) and index TO (exclusive) of that vector argument.
1264 With one argument, just copy STRING (with properties, if any). */)
1265 (Lisp_Object string
, Lisp_Object from
, Lisp_Object to
)
1268 ptrdiff_t size
, ifrom
, ito
;
1270 size
= CHECK_VECTOR_OR_STRING (string
);
1271 validate_subarray (string
, from
, to
, size
, &ifrom
, &ito
);
1273 if (STRINGP (string
))
1276 = !ifrom
? 0 : string_char_to_byte (string
, ifrom
);
1278 = ito
== size
? SBYTES (string
) : string_char_to_byte (string
, ito
);
1279 res
= make_specified_string (SSDATA (string
) + from_byte
,
1280 ito
- ifrom
, to_byte
- from_byte
,
1281 STRING_MULTIBYTE (string
));
1282 copy_text_properties (make_number (ifrom
), make_number (ito
),
1283 string
, make_number (0), res
, Qnil
);
1286 res
= Fvector (ito
- ifrom
, aref_addr (string
, ifrom
));
1292 DEFUN ("substring-no-properties", Fsubstring_no_properties
, Ssubstring_no_properties
, 1, 3, 0,
1293 doc
: /* Return a substring of STRING, without text properties.
1294 It starts at index FROM and ends before TO.
1295 TO may be nil or omitted; then the substring runs to the end of STRING.
1296 If FROM is nil or omitted, the substring starts at the beginning of STRING.
1297 If FROM or TO is negative, it counts from the end.
1299 With one argument, just copy STRING without its properties. */)
1300 (Lisp_Object string
, register Lisp_Object from
, Lisp_Object to
)
1302 ptrdiff_t from_char
, to_char
, from_byte
, to_byte
, size
;
1304 CHECK_STRING (string
);
1306 size
= SCHARS (string
);
1307 validate_subarray (string
, from
, to
, size
, &from_char
, &to_char
);
1309 from_byte
= !from_char
? 0 : string_char_to_byte (string
, from_char
);
1311 to_char
== size
? SBYTES (string
) : string_char_to_byte (string
, to_char
);
1312 return make_specified_string (SSDATA (string
) + from_byte
,
1313 to_char
- from_char
, to_byte
- from_byte
,
1314 STRING_MULTIBYTE (string
));
1317 /* Extract a substring of STRING, giving start and end positions
1318 both in characters and in bytes. */
1321 substring_both (Lisp_Object string
, ptrdiff_t from
, ptrdiff_t from_byte
,
1322 ptrdiff_t to
, ptrdiff_t to_byte
)
1325 ptrdiff_t size
= CHECK_VECTOR_OR_STRING (string
);
1327 if (!(0 <= from
&& from
<= to
&& to
<= size
))
1328 args_out_of_range_3 (string
, make_number (from
), make_number (to
));
1330 if (STRINGP (string
))
1332 res
= make_specified_string (SSDATA (string
) + from_byte
,
1333 to
- from
, to_byte
- from_byte
,
1334 STRING_MULTIBYTE (string
));
1335 copy_text_properties (make_number (from
), make_number (to
),
1336 string
, make_number (0), res
, Qnil
);
1339 res
= Fvector (to
- from
, aref_addr (string
, from
));
1344 DEFUN ("nthcdr", Fnthcdr
, Snthcdr
, 2, 2, 0,
1345 doc
: /* Take cdr N times on LIST, return the result. */)
1346 (Lisp_Object n
, Lisp_Object list
)
1349 EMACS_INT num
= XINT (n
);
1350 Lisp_Object tail
= list
;
1351 for (EMACS_INT i
= 0; i
< num
; i
++)
1355 CHECK_LIST_END (tail
, list
);
1364 DEFUN ("nth", Fnth
, Snth
, 2, 2, 0,
1365 doc
: /* Return the Nth element of LIST.
1366 N counts from zero. If LIST is not that long, nil is returned. */)
1367 (Lisp_Object n
, Lisp_Object list
)
1369 return Fcar (Fnthcdr (n
, list
));
1372 DEFUN ("elt", Felt
, Selt
, 2, 2, 0,
1373 doc
: /* Return element of SEQUENCE at index N. */)
1374 (register Lisp_Object sequence
, Lisp_Object n
)
1377 if (CONSP (sequence
) || NILP (sequence
))
1378 return Fcar (Fnthcdr (n
, sequence
));
1380 /* Faref signals a "not array" error, so check here. */
1381 CHECK_ARRAY (sequence
, Qsequencep
);
1382 return Faref (sequence
, n
);
1385 DEFUN ("member", Fmember
, Smember
, 2, 2, 0,
1386 doc
: /* Return non-nil if ELT is an element of LIST. Comparison done with `equal'.
1387 The value is actually the tail of LIST whose car is ELT. */)
1388 (Lisp_Object elt
, Lisp_Object list
)
1391 for (tail
= list
; CONSP (tail
); tail
= XCDR (tail
))
1393 if (! NILP (Fequal (elt
, XCAR (tail
))))
1397 CHECK_LIST_END (tail
, list
);
1401 DEFUN ("memq", Fmemq
, Smemq
, 2, 2, 0,
1402 doc
: /* Return non-nil if ELT is an element of LIST. Comparison done with `eq'.
1403 The value is actually the tail of LIST whose car is ELT. */)
1404 (Lisp_Object elt
, Lisp_Object list
)
1407 for (tail
= list
; CONSP (tail
); tail
= XCDR (tail
))
1409 if (EQ (XCAR (tail
), elt
))
1413 CHECK_LIST_END (tail
, list
);
1417 DEFUN ("memql", Fmemql
, Smemql
, 2, 2, 0,
1418 doc
: /* Return non-nil if ELT is an element of LIST. Comparison done with `eql'.
1419 The value is actually the tail of LIST whose car is ELT. */)
1420 (Lisp_Object elt
, Lisp_Object list
)
1423 return Fmemq (elt
, list
);
1426 for (tail
= list
; CONSP (tail
); tail
= XCDR (tail
))
1428 Lisp_Object tem
= XCAR (tail
);
1429 if (FLOATP (tem
) && internal_equal (elt
, tem
, 0, 0, Qnil
))
1433 CHECK_LIST_END (tail
, list
);
1437 DEFUN ("assq", Fassq
, Sassq
, 2, 2, 0,
1438 doc
: /* Return non-nil if KEY is `eq' to the car of an element of LIST.
1439 The value is actually the first element of LIST whose car is KEY.
1440 Elements of LIST that are not conses are ignored. */)
1441 (Lisp_Object key
, Lisp_Object list
)
1444 for (tail
= list
; CONSP (tail
); tail
= XCDR (tail
))
1446 if (CONSP (XCAR (tail
)) && EQ (XCAR (XCAR (tail
)), key
))
1450 CHECK_LIST_END (tail
, list
);
1454 /* Like Fassq but never report an error and do not allow quits.
1455 Use only on objects known to be non-circular lists. */
1458 assq_no_quit (Lisp_Object key
, Lisp_Object list
)
1460 for (; ! NILP (list
); list
= XCDR (list
))
1461 if (CONSP (XCAR (list
)) && EQ (XCAR (XCAR (list
)), key
))
1466 DEFUN ("assoc", Fassoc
, Sassoc
, 2, 2, 0,
1467 doc
: /* Return non-nil if KEY is `equal' to the car of an element of LIST.
1468 The value is actually the first element of LIST whose car equals KEY. */)
1469 (Lisp_Object key
, Lisp_Object list
)
1472 for (tail
= list
; CONSP (tail
); tail
= XCDR (tail
))
1474 Lisp_Object car
= XCAR (tail
);
1476 && (EQ (XCAR (car
), key
) || !NILP (Fequal (XCAR (car
), key
))))
1480 CHECK_LIST_END (tail
, list
);
1484 /* Like Fassoc but never report an error and do not allow quits.
1485 Use only on objects known to be non-circular lists. */
1488 assoc_no_quit (Lisp_Object key
, Lisp_Object list
)
1490 for (; ! NILP (list
); list
= XCDR (list
))
1492 Lisp_Object car
= XCAR (list
);
1494 && (EQ (XCAR (car
), key
) || !NILP (Fequal (XCAR (car
), key
))))
1500 DEFUN ("rassq", Frassq
, Srassq
, 2, 2, 0,
1501 doc
: /* Return non-nil if KEY is `eq' to the cdr of an element of LIST.
1502 The value is actually the first element of LIST whose cdr is KEY. */)
1503 (Lisp_Object key
, Lisp_Object list
)
1506 for (tail
= list
; CONSP (tail
); tail
= XCDR (tail
))
1508 if (CONSP (XCAR (tail
)) && EQ (XCDR (XCAR (tail
)), key
))
1512 CHECK_LIST_END (tail
, list
);
1516 DEFUN ("rassoc", Frassoc
, Srassoc
, 2, 2, 0,
1517 doc
: /* Return non-nil if KEY is `equal' to the cdr of an element of LIST.
1518 The value is actually the first element of LIST whose cdr equals KEY. */)
1519 (Lisp_Object key
, Lisp_Object list
)
1522 for (tail
= list
; CONSP (tail
); tail
= XCDR (tail
))
1524 Lisp_Object car
= XCAR (tail
);
1526 && (EQ (XCDR (car
), key
) || !NILP (Fequal (XCDR (car
), key
))))
1530 CHECK_LIST_END (tail
, list
);
1534 DEFUN ("delq", Fdelq
, Sdelq
, 2, 2, 0,
1535 doc
: /* Delete members of LIST which are `eq' to ELT, and return the result.
1536 More precisely, this function skips any members `eq' to ELT at the
1537 front of LIST, then removes members `eq' to ELT from the remaining
1538 sublist by modifying its list structure, then returns the resulting
1541 Write `(setq foo (delq element foo))' to be sure of correctly changing
1542 the value of a list `foo'. See also `remq', which does not modify the
1544 (register Lisp_Object elt
, Lisp_Object list
)
1546 Lisp_Object tail
, tortoise
, prev
= Qnil
;
1549 FOR_EACH_TAIL (tail
, list
, tortoise
, skip
)
1551 Lisp_Object tem
= XCAR (tail
);
1557 Fsetcdr (prev
, XCDR (tail
));
1565 DEFUN ("delete", Fdelete
, Sdelete
, 2, 2, 0,
1566 doc
: /* Delete members of SEQ which are `equal' to ELT, and return the result.
1567 SEQ must be a sequence (i.e. a list, a vector, or a string).
1568 The return value is a sequence of the same type.
1570 If SEQ is a list, this behaves like `delq', except that it compares
1571 with `equal' instead of `eq'. In particular, it may remove elements
1572 by altering the list structure.
1574 If SEQ is not a list, deletion is never performed destructively;
1575 instead this function creates and returns a new vector or string.
1577 Write `(setq foo (delete element foo))' to be sure of correctly
1578 changing the value of a sequence `foo'. */)
1579 (Lisp_Object elt
, Lisp_Object seq
)
1585 for (i
= n
= 0; i
< ASIZE (seq
); ++i
)
1586 if (NILP (Fequal (AREF (seq
, i
), elt
)))
1589 if (n
!= ASIZE (seq
))
1591 struct Lisp_Vector
*p
= allocate_vector (n
);
1593 for (i
= n
= 0; i
< ASIZE (seq
); ++i
)
1594 if (NILP (Fequal (AREF (seq
, i
), elt
)))
1595 p
->contents
[n
++] = AREF (seq
, i
);
1597 XSETVECTOR (seq
, p
);
1600 else if (STRINGP (seq
))
1602 ptrdiff_t i
, ibyte
, nchars
, nbytes
, cbytes
;
1605 for (i
= nchars
= nbytes
= ibyte
= 0;
1607 ++i
, ibyte
+= cbytes
)
1609 if (STRING_MULTIBYTE (seq
))
1611 c
= STRING_CHAR (SDATA (seq
) + ibyte
);
1612 cbytes
= CHAR_BYTES (c
);
1620 if (!INTEGERP (elt
) || c
!= XINT (elt
))
1627 if (nchars
!= SCHARS (seq
))
1631 tem
= make_uninit_multibyte_string (nchars
, nbytes
);
1632 if (!STRING_MULTIBYTE (seq
))
1633 STRING_SET_UNIBYTE (tem
);
1635 for (i
= nchars
= nbytes
= ibyte
= 0;
1637 ++i
, ibyte
+= cbytes
)
1639 if (STRING_MULTIBYTE (seq
))
1641 c
= STRING_CHAR (SDATA (seq
) + ibyte
);
1642 cbytes
= CHAR_BYTES (c
);
1650 if (!INTEGERP (elt
) || c
!= XINT (elt
))
1652 unsigned char *from
= SDATA (seq
) + ibyte
;
1653 unsigned char *to
= SDATA (tem
) + nbytes
;
1659 for (n
= cbytes
; n
--; )
1669 Lisp_Object tail
, prev
;
1671 for (tail
= seq
, prev
= Qnil
; CONSP (tail
); tail
= XCDR (tail
))
1673 if (!NILP (Fequal (elt
, XCAR (tail
))))
1678 Fsetcdr (prev
, XCDR (tail
));
1684 CHECK_LIST_END (tail
, seq
);
1690 DEFUN ("nreverse", Fnreverse
, Snreverse
, 1, 1, 0,
1691 doc
: /* Reverse order of items in a list, vector or string SEQ.
1692 If SEQ is a list, it should be nil-terminated.
1693 This function may destructively modify SEQ to produce the value. */)
1698 else if (STRINGP (seq
))
1699 return Freverse (seq
);
1700 else if (CONSP (seq
))
1702 Lisp_Object prev
, tail
, next
;
1704 for (prev
= Qnil
, tail
= seq
; CONSP (tail
); tail
= next
)
1708 Fsetcdr (tail
, prev
);
1711 CHECK_LIST_END (tail
, seq
);
1714 else if (VECTORP (seq
))
1716 ptrdiff_t i
, size
= ASIZE (seq
);
1718 for (i
= 0; i
< size
/ 2; i
++)
1720 Lisp_Object tem
= AREF (seq
, i
);
1721 ASET (seq
, i
, AREF (seq
, size
- i
- 1));
1722 ASET (seq
, size
- i
- 1, tem
);
1725 else if (BOOL_VECTOR_P (seq
))
1727 ptrdiff_t i
, size
= bool_vector_size (seq
);
1729 for (i
= 0; i
< size
/ 2; i
++)
1731 bool tem
= bool_vector_bitref (seq
, i
);
1732 bool_vector_set (seq
, i
, bool_vector_bitref (seq
, size
- i
- 1));
1733 bool_vector_set (seq
, size
- i
- 1, tem
);
1737 wrong_type_argument (Qarrayp
, seq
);
1741 DEFUN ("reverse", Freverse
, Sreverse
, 1, 1, 0,
1742 doc
: /* Return the reversed copy of list, vector, or string SEQ.
1743 See also the function `nreverse', which is used more often. */)
1750 else if (CONSP (seq
))
1752 for (new = Qnil
; CONSP (seq
); seq
= XCDR (seq
))
1755 new = Fcons (XCAR (seq
), new);
1757 CHECK_LIST_END (seq
, seq
);
1759 else if (VECTORP (seq
))
1761 ptrdiff_t i
, size
= ASIZE (seq
);
1763 new = make_uninit_vector (size
);
1764 for (i
= 0; i
< size
; i
++)
1765 ASET (new, i
, AREF (seq
, size
- i
- 1));
1767 else if (BOOL_VECTOR_P (seq
))
1770 EMACS_INT nbits
= bool_vector_size (seq
);
1772 new = make_uninit_bool_vector (nbits
);
1773 for (i
= 0; i
< nbits
; i
++)
1774 bool_vector_set (new, i
, bool_vector_bitref (seq
, nbits
- i
- 1));
1776 else if (STRINGP (seq
))
1778 ptrdiff_t size
= SCHARS (seq
), bytes
= SBYTES (seq
);
1784 new = make_uninit_string (size
);
1785 for (i
= 0; i
< size
; i
++)
1786 SSET (new, i
, SREF (seq
, size
- i
- 1));
1790 unsigned char *p
, *q
;
1792 new = make_uninit_multibyte_string (size
, bytes
);
1793 p
= SDATA (seq
), q
= SDATA (new) + bytes
;
1794 while (q
> SDATA (new))
1798 ch
= STRING_CHAR_AND_LENGTH (p
, len
);
1800 CHAR_STRING (ch
, q
);
1805 wrong_type_argument (Qsequencep
, seq
);
1809 /* Sort LIST using PREDICATE, preserving original order of elements
1810 considered as equal. */
1813 sort_list (Lisp_Object list
, Lisp_Object predicate
)
1815 Lisp_Object front
, back
;
1816 Lisp_Object len
, tem
;
1820 len
= Flength (list
);
1821 length
= XINT (len
);
1825 XSETINT (len
, (length
/ 2) - 1);
1826 tem
= Fnthcdr (len
, list
);
1828 Fsetcdr (tem
, Qnil
);
1830 front
= Fsort (front
, predicate
);
1831 back
= Fsort (back
, predicate
);
1832 return merge (front
, back
, predicate
);
1835 /* Using PRED to compare, return whether A and B are in order.
1836 Compare stably when A appeared before B in the input. */
1838 inorder (Lisp_Object pred
, Lisp_Object a
, Lisp_Object b
)
1840 return NILP (call2 (pred
, b
, a
));
1843 /* Using PRED to compare, merge from ALEN-length A and BLEN-length B
1844 into DEST. Argument arrays must be nonempty and must not overlap,
1845 except that B might be the last part of DEST. */
1847 merge_vectors (Lisp_Object pred
,
1848 ptrdiff_t alen
, Lisp_Object
const a
[restrict
VLA_ELEMS (alen
)],
1849 ptrdiff_t blen
, Lisp_Object
const b
[VLA_ELEMS (blen
)],
1850 Lisp_Object dest
[VLA_ELEMS (alen
+ blen
)])
1852 eassume (0 < alen
&& 0 < blen
);
1853 Lisp_Object
const *alim
= a
+ alen
;
1854 Lisp_Object
const *blim
= b
+ blen
;
1858 if (inorder (pred
, a
[0], b
[0]))
1864 memcpy (dest
, b
, (blim
- b
) * sizeof *dest
);
1873 memcpy (dest
, a
, (alim
- a
) * sizeof *dest
);
1880 /* Using PRED to compare, sort LEN-length VEC in place, using TMP for
1881 temporary storage. LEN must be at least 2. */
1883 sort_vector_inplace (Lisp_Object pred
, ptrdiff_t len
,
1884 Lisp_Object vec
[restrict
VLA_ELEMS (len
)],
1885 Lisp_Object tmp
[restrict
VLA_ELEMS (len
>> 1)])
1888 ptrdiff_t halflen
= len
>> 1;
1889 sort_vector_copy (pred
, halflen
, vec
, tmp
);
1890 if (1 < len
- halflen
)
1891 sort_vector_inplace (pred
, len
- halflen
, vec
+ halflen
, vec
);
1892 merge_vectors (pred
, halflen
, tmp
, len
- halflen
, vec
+ halflen
, vec
);
1895 /* Using PRED to compare, sort from LEN-length SRC into DST.
1896 Len must be positive. */
1898 sort_vector_copy (Lisp_Object pred
, ptrdiff_t len
,
1899 Lisp_Object src
[restrict
VLA_ELEMS (len
)],
1900 Lisp_Object dest
[restrict
VLA_ELEMS (len
)])
1903 ptrdiff_t halflen
= len
>> 1;
1909 sort_vector_inplace (pred
, halflen
, src
, dest
);
1910 if (1 < len
- halflen
)
1911 sort_vector_inplace (pred
, len
- halflen
, src
+ halflen
, dest
);
1912 merge_vectors (pred
, halflen
, src
, len
- halflen
, src
+ halflen
, dest
);
1916 /* Sort VECTOR in place using PREDICATE, preserving original order of
1917 elements considered as equal. */
1920 sort_vector (Lisp_Object vector
, Lisp_Object predicate
)
1922 ptrdiff_t len
= ASIZE (vector
);
1925 ptrdiff_t halflen
= len
>> 1;
1928 SAFE_ALLOCA_LISP (tmp
, halflen
);
1929 for (ptrdiff_t i
= 0; i
< halflen
; i
++)
1930 tmp
[i
] = make_number (0);
1931 sort_vector_inplace (predicate
, len
, XVECTOR (vector
)->contents
, tmp
);
1935 DEFUN ("sort", Fsort
, Ssort
, 2, 2, 0,
1936 doc
: /* Sort SEQ, stably, comparing elements using PREDICATE.
1937 Returns the sorted sequence. SEQ should be a list or vector. SEQ is
1938 modified by side effects. PREDICATE is called with two elements of
1939 SEQ, and should return non-nil if the first element should sort before
1941 (Lisp_Object seq
, Lisp_Object predicate
)
1944 seq
= sort_list (seq
, predicate
);
1945 else if (VECTORP (seq
))
1946 sort_vector (seq
, predicate
);
1947 else if (!NILP (seq
))
1948 wrong_type_argument (Qsequencep
, seq
);
1953 merge (Lisp_Object org_l1
, Lisp_Object org_l2
, Lisp_Object pred
)
1955 Lisp_Object l1
= org_l1
;
1956 Lisp_Object l2
= org_l2
;
1957 Lisp_Object tail
= Qnil
;
1958 Lisp_Object value
= Qnil
;
1978 if (inorder (pred
, Fcar (l1
), Fcar (l2
)))
1993 Fsetcdr (tail
, tem
);
1999 /* This does not check for quits. That is safe since it must terminate. */
2001 DEFUN ("plist-get", Fplist_get
, Splist_get
, 2, 2, 0,
2002 doc
: /* Extract a value from a property list.
2003 PLIST is a property list, which is a list of the form
2004 \(PROP1 VALUE1 PROP2 VALUE2...). This function returns the value
2005 corresponding to the given PROP, or nil if PROP is not one of the
2006 properties on the list. This function never signals an error. */)
2007 (Lisp_Object plist
, Lisp_Object prop
)
2009 Lisp_Object tail
, halftail
;
2011 /* halftail is used to detect circular lists. */
2012 tail
= halftail
= plist
;
2013 while (CONSP (tail
) && CONSP (XCDR (tail
)))
2015 if (EQ (prop
, XCAR (tail
)))
2016 return XCAR (XCDR (tail
));
2018 tail
= XCDR (XCDR (tail
));
2019 halftail
= XCDR (halftail
);
2020 if (EQ (tail
, halftail
))
2027 DEFUN ("get", Fget
, Sget
, 2, 2, 0,
2028 doc
: /* Return the value of SYMBOL's PROPNAME property.
2029 This is the last value stored with `(put SYMBOL PROPNAME VALUE)'. */)
2030 (Lisp_Object symbol
, Lisp_Object propname
)
2032 CHECK_SYMBOL (symbol
);
2033 return Fplist_get (XSYMBOL (symbol
)->plist
, propname
);
2036 DEFUN ("plist-put", Fplist_put
, Splist_put
, 3, 3, 0,
2037 doc
: /* Change value in PLIST of PROP to VAL.
2038 PLIST is a property list, which is a list of the form
2039 \(PROP1 VALUE1 PROP2 VALUE2 ...). PROP is a symbol and VAL is any object.
2040 If PROP is already a property on the list, its value is set to VAL,
2041 otherwise the new PROP VAL pair is added. The new plist is returned;
2042 use `(setq x (plist-put x prop val))' to be sure to use the new value.
2043 The PLIST is modified by side effects. */)
2044 (Lisp_Object plist
, register Lisp_Object prop
, Lisp_Object val
)
2046 register Lisp_Object tail
, prev
;
2047 Lisp_Object newcell
;
2049 for (tail
= plist
; CONSP (tail
) && CONSP (XCDR (tail
));
2050 tail
= XCDR (XCDR (tail
)))
2052 if (EQ (prop
, XCAR (tail
)))
2054 Fsetcar (XCDR (tail
), val
);
2061 newcell
= Fcons (prop
, Fcons (val
, NILP (prev
) ? plist
: XCDR (XCDR (prev
))));
2065 Fsetcdr (XCDR (prev
), newcell
);
2069 DEFUN ("put", Fput
, Sput
, 3, 3, 0,
2070 doc
: /* Store SYMBOL's PROPNAME property with value VALUE.
2071 It can be retrieved with `(get SYMBOL PROPNAME)'. */)
2072 (Lisp_Object symbol
, Lisp_Object propname
, Lisp_Object value
)
2074 CHECK_SYMBOL (symbol
);
2076 (symbol
, Fplist_put (XSYMBOL (symbol
)->plist
, propname
, value
));
2080 DEFUN ("lax-plist-get", Flax_plist_get
, Slax_plist_get
, 2, 2, 0,
2081 doc
: /* Extract a value from a property list, comparing with `equal'.
2082 PLIST is a property list, which is a list of the form
2083 \(PROP1 VALUE1 PROP2 VALUE2...). This function returns the value
2084 corresponding to the given PROP, or nil if PROP is not
2085 one of the properties on the list. */)
2086 (Lisp_Object plist
, Lisp_Object prop
)
2091 CONSP (tail
) && CONSP (XCDR (tail
));
2092 tail
= XCDR (XCDR (tail
)))
2094 if (! NILP (Fequal (prop
, XCAR (tail
))))
2095 return XCAR (XCDR (tail
));
2100 CHECK_LIST_END (tail
, prop
);
2105 DEFUN ("lax-plist-put", Flax_plist_put
, Slax_plist_put
, 3, 3, 0,
2106 doc
: /* Change value in PLIST of PROP to VAL, comparing with `equal'.
2107 PLIST is a property list, which is a list of the form
2108 \(PROP1 VALUE1 PROP2 VALUE2 ...). PROP and VAL are any objects.
2109 If PROP is already a property on the list, its value is set to VAL,
2110 otherwise the new PROP VAL pair is added. The new plist is returned;
2111 use `(setq x (lax-plist-put x prop val))' to be sure to use the new value.
2112 The PLIST is modified by side effects. */)
2113 (Lisp_Object plist
, register Lisp_Object prop
, Lisp_Object val
)
2115 register Lisp_Object tail
, prev
;
2116 Lisp_Object newcell
;
2118 for (tail
= plist
; CONSP (tail
) && CONSP (XCDR (tail
));
2119 tail
= XCDR (XCDR (tail
)))
2121 if (! NILP (Fequal (prop
, XCAR (tail
))))
2123 Fsetcar (XCDR (tail
), val
);
2130 newcell
= list2 (prop
, val
);
2134 Fsetcdr (XCDR (prev
), newcell
);
2138 DEFUN ("eql", Feql
, Seql
, 2, 2, 0,
2139 doc
: /* Return t if the two args are the same Lisp object.
2140 Floating-point numbers of equal value are `eql', but they may not be `eq'. */)
2141 (Lisp_Object obj1
, Lisp_Object obj2
)
2144 return internal_equal (obj1
, obj2
, 0, 0, Qnil
) ? Qt
: Qnil
;
2146 return EQ (obj1
, obj2
) ? Qt
: Qnil
;
2149 DEFUN ("equal", Fequal
, Sequal
, 2, 2, 0,
2150 doc
: /* Return t if two Lisp objects have similar structure and contents.
2151 They must have the same data type.
2152 Conses are compared by comparing the cars and the cdrs.
2153 Vectors and strings are compared element by element.
2154 Numbers are compared by value, but integers cannot equal floats.
2155 (Use `=' if you want integers and floats to be able to be equal.)
2156 Symbols must match exactly. */)
2157 (register Lisp_Object o1
, Lisp_Object o2
)
2159 return internal_equal (o1
, o2
, 0, 0, Qnil
) ? Qt
: Qnil
;
2162 DEFUN ("equal-including-properties", Fequal_including_properties
, Sequal_including_properties
, 2, 2, 0,
2163 doc
: /* Return t if two Lisp objects have similar structure and contents.
2164 This is like `equal' except that it compares the text properties
2165 of strings. (`equal' ignores text properties.) */)
2166 (register Lisp_Object o1
, Lisp_Object o2
)
2168 return internal_equal (o1
, o2
, 0, 1, Qnil
) ? Qt
: Qnil
;
2171 /* DEPTH is current depth of recursion. Signal an error if it
2173 PROPS means compare string text properties too. */
2176 internal_equal (Lisp_Object o1
, Lisp_Object o2
, int depth
, bool props
,
2182 error ("Stack overflow in equal");
2184 ht
= CALLN (Fmake_hash_table
, QCtest
, Qeq
);
2187 case Lisp_Cons
: case Lisp_Misc
: case Lisp_Vectorlike
:
2189 struct Lisp_Hash_Table
*h
= XHASH_TABLE (ht
);
2191 ptrdiff_t i
= hash_lookup (h
, o1
, &hash
);
2193 { /* `o1' was seen already. */
2194 Lisp_Object o2s
= HASH_VALUE (h
, i
);
2195 if (!NILP (Fmemq (o2
, o2s
)))
2198 set_hash_value_slot (h
, i
, Fcons (o2
, o2s
));
2201 hash_put (h
, o1
, Fcons (o2
, Qnil
), hash
);
2211 if (XTYPE (o1
) != XTYPE (o2
))
2220 d1
= extract_float (o1
);
2221 d2
= extract_float (o2
);
2222 /* If d is a NaN, then d != d. Two NaNs should be `equal' even
2223 though they are not =. */
2224 return d1
== d2
|| (d1
!= d1
&& d2
!= d2
);
2228 if (!internal_equal (XCAR (o1
), XCAR (o2
), depth
+ 1, props
, ht
))
2232 /* FIXME: This inf-loops in a circular list! */
2236 if (XMISCTYPE (o1
) != XMISCTYPE (o2
))
2240 if (!internal_equal (OVERLAY_START (o1
), OVERLAY_START (o2
),
2241 depth
+ 1, props
, ht
)
2242 || !internal_equal (OVERLAY_END (o1
), OVERLAY_END (o2
),
2243 depth
+ 1, props
, ht
))
2245 o1
= XOVERLAY (o1
)->plist
;
2246 o2
= XOVERLAY (o2
)->plist
;
2251 return (XMARKER (o1
)->buffer
== XMARKER (o2
)->buffer
2252 && (XMARKER (o1
)->buffer
== 0
2253 || XMARKER (o1
)->bytepos
== XMARKER (o2
)->bytepos
));
2257 case Lisp_Vectorlike
:
2260 ptrdiff_t size
= ASIZE (o1
);
2261 /* Pseudovectors have the type encoded in the size field, so this test
2262 actually checks that the objects have the same type as well as the
2264 if (ASIZE (o2
) != size
)
2266 /* Boolvectors are compared much like strings. */
2267 if (BOOL_VECTOR_P (o1
))
2269 EMACS_INT size
= bool_vector_size (o1
);
2270 if (size
!= bool_vector_size (o2
))
2272 if (memcmp (bool_vector_data (o1
), bool_vector_data (o2
),
2273 bool_vector_bytes (size
)))
2277 if (WINDOW_CONFIGURATIONP (o1
))
2278 return compare_window_configurations (o1
, o2
, 0);
2280 /* Aside from them, only true vectors, char-tables, compiled
2281 functions, and fonts (font-spec, font-entity, font-object)
2282 are sensible to compare, so eliminate the others now. */
2283 if (size
& PSEUDOVECTOR_FLAG
)
2285 if (((size
& PVEC_TYPE_MASK
) >> PSEUDOVECTOR_AREA_BITS
)
2288 size
&= PSEUDOVECTOR_SIZE_MASK
;
2290 for (i
= 0; i
< size
; i
++)
2295 if (!internal_equal (v1
, v2
, depth
+ 1, props
, ht
))
2303 if (SCHARS (o1
) != SCHARS (o2
))
2305 if (SBYTES (o1
) != SBYTES (o2
))
2307 if (memcmp (SDATA (o1
), SDATA (o2
), SBYTES (o1
)))
2309 if (props
&& !compare_string_intervals (o1
, o2
))
2321 DEFUN ("fillarray", Ffillarray
, Sfillarray
, 2, 2, 0,
2322 doc
: /* Store each element of ARRAY with ITEM.
2323 ARRAY is a vector, string, char-table, or bool-vector. */)
2324 (Lisp_Object array
, Lisp_Object item
)
2326 register ptrdiff_t size
, idx
;
2328 if (VECTORP (array
))
2329 for (idx
= 0, size
= ASIZE (array
); idx
< size
; idx
++)
2330 ASET (array
, idx
, item
);
2331 else if (CHAR_TABLE_P (array
))
2335 for (i
= 0; i
< (1 << CHARTAB_SIZE_BITS_0
); i
++)
2336 set_char_table_contents (array
, i
, item
);
2337 set_char_table_defalt (array
, item
);
2339 else if (STRINGP (array
))
2341 register unsigned char *p
= SDATA (array
);
2343 CHECK_CHARACTER (item
);
2344 charval
= XFASTINT (item
);
2345 size
= SCHARS (array
);
2346 if (STRING_MULTIBYTE (array
))
2348 unsigned char str
[MAX_MULTIBYTE_LENGTH
];
2349 int len
= CHAR_STRING (charval
, str
);
2350 ptrdiff_t size_byte
= SBYTES (array
);
2353 if (INT_MULTIPLY_WRAPV (size
, len
, &product
) || product
!= size_byte
)
2354 error ("Attempt to change byte length of a string");
2355 for (idx
= 0; idx
< size_byte
; idx
++)
2356 *p
++ = str
[idx
% len
];
2359 for (idx
= 0; idx
< size
; idx
++)
2362 else if (BOOL_VECTOR_P (array
))
2363 return bool_vector_fill (array
, item
);
2365 wrong_type_argument (Qarrayp
, array
);
2369 DEFUN ("clear-string", Fclear_string
, Sclear_string
,
2371 doc
: /* Clear the contents of STRING.
2372 This makes STRING unibyte and may change its length. */)
2373 (Lisp_Object string
)
2376 CHECK_STRING (string
);
2377 len
= SBYTES (string
);
2378 memset (SDATA (string
), 0, len
);
2379 STRING_SET_CHARS (string
, len
);
2380 STRING_SET_UNIBYTE (string
);
2386 nconc2 (Lisp_Object s1
, Lisp_Object s2
)
2388 return CALLN (Fnconc
, s1
, s2
);
2391 DEFUN ("nconc", Fnconc
, Snconc
, 0, MANY
, 0,
2392 doc
: /* Concatenate any number of lists by altering them.
2393 Only the last argument is not altered, and need not be a list.
2394 usage: (nconc &rest LISTS) */)
2395 (ptrdiff_t nargs
, Lisp_Object
*args
)
2398 register Lisp_Object tail
, tem
, val
;
2402 for (argnum
= 0; argnum
< nargs
; argnum
++)
2405 if (NILP (tem
)) continue;
2410 if (argnum
+ 1 == nargs
) break;
2420 while (CONSP (tem
));
2422 tem
= args
[argnum
+ 1];
2423 Fsetcdr (tail
, tem
);
2425 args
[argnum
+ 1] = tail
;
2431 /* This is the guts of all mapping functions.
2432 Apply FN to each element of SEQ, one by one, storing the results
2433 into elements of VALS, a C vector of Lisp_Objects. LENI is the
2434 length of VALS, which should also be the length of SEQ. Return the
2435 number of results; although this is normally LENI, it can be less
2436 if SEQ is made shorter as a side effect of FN. */
2439 mapcar1 (EMACS_INT leni
, Lisp_Object
*vals
, Lisp_Object fn
, Lisp_Object seq
)
2441 Lisp_Object tail
, dummy
;
2444 if (VECTORP (seq
) || COMPILEDP (seq
))
2446 for (i
= 0; i
< leni
; i
++)
2448 dummy
= call1 (fn
, AREF (seq
, i
));
2453 else if (BOOL_VECTOR_P (seq
))
2455 for (i
= 0; i
< leni
; i
++)
2457 dummy
= call1 (fn
, bool_vector_ref (seq
, i
));
2462 else if (STRINGP (seq
))
2466 for (i
= 0, i_byte
= 0; i
< leni
;)
2469 ptrdiff_t i_before
= i
;
2471 FETCH_STRING_CHAR_ADVANCE (c
, seq
, i
, i_byte
);
2472 XSETFASTINT (dummy
, c
);
2473 dummy
= call1 (fn
, dummy
);
2475 vals
[i_before
] = dummy
;
2478 else /* Must be a list, since Flength did not get an error */
2481 for (i
= 0; i
< leni
; i
++)
2485 dummy
= call1 (fn
, XCAR (tail
));
2495 DEFUN ("mapconcat", Fmapconcat
, Smapconcat
, 3, 3, 0,
2496 doc
: /* Apply FUNCTION to each element of SEQUENCE, and concat the results as strings.
2497 In between each pair of results, stick in SEPARATOR. Thus, " " as
2498 SEPARATOR results in spaces between the values returned by FUNCTION.
2499 SEQUENCE may be a list, a vector, a bool-vector, or a string. */)
2500 (Lisp_Object function
, Lisp_Object sequence
, Lisp_Object separator
)
2503 EMACS_INT leni
= XFASTINT (Flength (sequence
));
2504 if (CHAR_TABLE_P (sequence
))
2505 wrong_type_argument (Qlistp
, sequence
);
2506 EMACS_INT args_alloc
= 2 * leni
- 1;
2508 return empty_unibyte_string
;
2510 SAFE_ALLOCA_LISP (args
, args_alloc
);
2511 ptrdiff_t nmapped
= mapcar1 (leni
, args
, function
, sequence
);
2512 ptrdiff_t nargs
= 2 * nmapped
- 1;
2514 for (ptrdiff_t i
= nmapped
- 1; i
> 0; i
--)
2515 args
[i
+ i
] = args
[i
];
2517 for (ptrdiff_t i
= 1; i
< nargs
; i
+= 2)
2518 args
[i
] = separator
;
2520 Lisp_Object ret
= Fconcat (nargs
, args
);
2525 DEFUN ("mapcar", Fmapcar
, Smapcar
, 2, 2, 0,
2526 doc
: /* Apply FUNCTION to each element of SEQUENCE, and make a list of the results.
2527 The result is a list just as long as SEQUENCE.
2528 SEQUENCE may be a list, a vector, a bool-vector, or a string. */)
2529 (Lisp_Object function
, Lisp_Object sequence
)
2532 EMACS_INT leni
= XFASTINT (Flength (sequence
));
2533 if (CHAR_TABLE_P (sequence
))
2534 wrong_type_argument (Qlistp
, sequence
);
2536 SAFE_ALLOCA_LISP (args
, leni
);
2537 ptrdiff_t nmapped
= mapcar1 (leni
, args
, function
, sequence
);
2538 Lisp_Object ret
= Flist (nmapped
, args
);
2543 DEFUN ("mapc", Fmapc
, Smapc
, 2, 2, 0,
2544 doc
: /* Apply FUNCTION to each element of SEQUENCE for side effects only.
2545 Unlike `mapcar', don't accumulate the results. Return SEQUENCE.
2546 SEQUENCE may be a list, a vector, a bool-vector, or a string. */)
2547 (Lisp_Object function
, Lisp_Object sequence
)
2549 register EMACS_INT leni
;
2551 leni
= XFASTINT (Flength (sequence
));
2552 if (CHAR_TABLE_P (sequence
))
2553 wrong_type_argument (Qlistp
, sequence
);
2554 mapcar1 (leni
, 0, function
, sequence
);
2559 DEFUN ("mapcan", Fmapcan
, Smapcan
, 2, 2, 0,
2560 doc
: /* Apply FUNCTION to each element of SEQUENCE, and concatenate
2561 the results by altering them (using `nconc').
2562 SEQUENCE may be a list, a vector, a bool-vector, or a string. */)
2563 (Lisp_Object function
, Lisp_Object sequence
)
2566 EMACS_INT leni
= XFASTINT (Flength (sequence
));
2567 if (CHAR_TABLE_P (sequence
))
2568 wrong_type_argument (Qlistp
, sequence
);
2570 SAFE_ALLOCA_LISP (args
, leni
);
2571 ptrdiff_t nmapped
= mapcar1 (leni
, args
, function
, sequence
);
2572 Lisp_Object ret
= Fnconc (nmapped
, args
);
2577 /* This is how C code calls `yes-or-no-p' and allows the user
2581 do_yes_or_no_p (Lisp_Object prompt
)
2583 return call1 (intern ("yes-or-no-p"), prompt
);
2586 DEFUN ("yes-or-no-p", Fyes_or_no_p
, Syes_or_no_p
, 1, 1, 0,
2587 doc
: /* Ask user a yes-or-no question.
2588 Return t if answer is yes, and nil if the answer is no.
2589 PROMPT is the string to display to ask the question. It should end in
2590 a space; `yes-or-no-p' adds \"(yes or no) \" to it.
2592 The user must confirm the answer with RET, and can edit it until it
2595 If dialog boxes are supported, a dialog box will be used
2596 if `last-nonmenu-event' is nil, and `use-dialog-box' is non-nil. */)
2597 (Lisp_Object prompt
)
2601 CHECK_STRING (prompt
);
2603 if ((NILP (last_nonmenu_event
) || CONSP (last_nonmenu_event
))
2604 && use_dialog_box
&& ! NILP (last_input_event
))
2606 Lisp_Object pane
, menu
, obj
;
2607 redisplay_preserve_echo_area (4);
2608 pane
= list2 (Fcons (build_string ("Yes"), Qt
),
2609 Fcons (build_string ("No"), Qnil
));
2610 menu
= Fcons (prompt
, pane
);
2611 obj
= Fx_popup_dialog (Qt
, menu
, Qnil
);
2615 AUTO_STRING (yes_or_no
, "(yes or no) ");
2616 prompt
= CALLN (Fconcat
, prompt
, yes_or_no
);
2620 ans
= Fdowncase (Fread_from_minibuffer (prompt
, Qnil
, Qnil
, Qnil
,
2621 Qyes_or_no_p_history
, Qnil
,
2623 if (SCHARS (ans
) == 3 && !strcmp (SSDATA (ans
), "yes"))
2625 if (SCHARS (ans
) == 2 && !strcmp (SSDATA (ans
), "no"))
2630 message1 ("Please answer yes or no.");
2631 Fsleep_for (make_number (2), Qnil
);
2635 DEFUN ("load-average", Fload_average
, Sload_average
, 0, 1, 0,
2636 doc
: /* Return list of 1 minute, 5 minute and 15 minute load averages.
2638 Each of the three load averages is multiplied by 100, then converted
2641 When USE-FLOATS is non-nil, floats will be used instead of integers.
2642 These floats are not multiplied by 100.
2644 If the 5-minute or 15-minute load averages are not available, return a
2645 shortened list, containing only those averages which are available.
2647 An error is thrown if the load average can't be obtained. In some
2648 cases making it work would require Emacs being installed setuid or
2649 setgid so that it can read kernel information, and that usually isn't
2651 (Lisp_Object use_floats
)
2654 int loads
= getloadavg (load_ave
, 3);
2655 Lisp_Object ret
= Qnil
;
2658 error ("load-average not implemented for this operating system");
2662 Lisp_Object load
= (NILP (use_floats
)
2663 ? make_number (100.0 * load_ave
[loads
])
2664 : make_float (load_ave
[loads
]));
2665 ret
= Fcons (load
, ret
);
2671 DEFUN ("featurep", Ffeaturep
, Sfeaturep
, 1, 2, 0,
2672 doc
: /* Return t if FEATURE is present in this Emacs.
2674 Use this to conditionalize execution of lisp code based on the
2675 presence or absence of Emacs or environment extensions.
2676 Use `provide' to declare that a feature is available. This function
2677 looks at the value of the variable `features'. The optional argument
2678 SUBFEATURE can be used to check a specific subfeature of FEATURE. */)
2679 (Lisp_Object feature
, Lisp_Object subfeature
)
2681 register Lisp_Object tem
;
2682 CHECK_SYMBOL (feature
);
2683 tem
= Fmemq (feature
, Vfeatures
);
2684 if (!NILP (tem
) && !NILP (subfeature
))
2685 tem
= Fmember (subfeature
, Fget (feature
, Qsubfeatures
));
2686 return (NILP (tem
)) ? Qnil
: Qt
;
2689 DEFUN ("provide", Fprovide
, Sprovide
, 1, 2, 0,
2690 doc
: /* Announce that FEATURE is a feature of the current Emacs.
2691 The optional argument SUBFEATURES should be a list of symbols listing
2692 particular subfeatures supported in this version of FEATURE. */)
2693 (Lisp_Object feature
, Lisp_Object subfeatures
)
2695 register Lisp_Object tem
;
2696 CHECK_SYMBOL (feature
);
2697 CHECK_LIST (subfeatures
);
2698 if (!NILP (Vautoload_queue
))
2699 Vautoload_queue
= Fcons (Fcons (make_number (0), Vfeatures
),
2701 tem
= Fmemq (feature
, Vfeatures
);
2703 Vfeatures
= Fcons (feature
, Vfeatures
);
2704 if (!NILP (subfeatures
))
2705 Fput (feature
, Qsubfeatures
, subfeatures
);
2706 LOADHIST_ATTACH (Fcons (Qprovide
, feature
));
2708 /* Run any load-hooks for this file. */
2709 tem
= Fassq (feature
, Vafter_load_alist
);
2711 Fmapc (Qfuncall
, XCDR (tem
));
2716 /* `require' and its subroutines. */
2718 /* List of features currently being require'd, innermost first. */
2720 static Lisp_Object require_nesting_list
;
2723 require_unwind (Lisp_Object old_value
)
2725 require_nesting_list
= old_value
;
2728 DEFUN ("require", Frequire
, Srequire
, 1, 3, 0,
2729 doc
: /* If feature FEATURE is not loaded, load it from FILENAME.
2730 If FEATURE is not a member of the list `features', then the feature is
2731 not loaded; so load the file FILENAME.
2733 If FILENAME is omitted, the printname of FEATURE is used as the file
2734 name, and `load' will try to load this name appended with the suffix
2735 `.elc', `.el', or the system-dependent suffix for dynamic module
2736 files, in that order. The name without appended suffix will not be
2737 used. See `get-load-suffixes' for the complete list of suffixes.
2739 The directories in `load-path' are searched when trying to find the
2742 If the optional third argument NOERROR is non-nil, then return nil if
2743 the file is not found instead of signaling an error. Normally the
2744 return value is FEATURE.
2746 The normal messages at start and end of loading FILENAME are
2748 (Lisp_Object feature
, Lisp_Object filename
, Lisp_Object noerror
)
2751 bool from_file
= load_in_progress
;
2753 CHECK_SYMBOL (feature
);
2755 /* Record the presence of `require' in this file
2756 even if the feature specified is already loaded.
2757 But not more than once in any file,
2758 and not when we aren't loading or reading from a file. */
2760 for (tem
= Vcurrent_load_list
; CONSP (tem
); tem
= XCDR (tem
))
2761 if (NILP (XCDR (tem
)) && STRINGP (XCAR (tem
)))
2766 tem
= Fcons (Qrequire
, feature
);
2767 if (NILP (Fmember (tem
, Vcurrent_load_list
)))
2768 LOADHIST_ATTACH (tem
);
2770 tem
= Fmemq (feature
, Vfeatures
);
2774 ptrdiff_t count
= SPECPDL_INDEX ();
2777 /* This is to make sure that loadup.el gives a clear picture
2778 of what files are preloaded and when. */
2779 if (! NILP (Vpurify_flag
))
2780 error ("(require %s) while preparing to dump",
2781 SDATA (SYMBOL_NAME (feature
)));
2783 /* A certain amount of recursive `require' is legitimate,
2784 but if we require the same feature recursively 3 times,
2786 tem
= require_nesting_list
;
2787 while (! NILP (tem
))
2789 if (! NILP (Fequal (feature
, XCAR (tem
))))
2794 error ("Recursive `require' for feature `%s'",
2795 SDATA (SYMBOL_NAME (feature
)));
2797 /* Update the list for any nested `require's that occur. */
2798 record_unwind_protect (require_unwind
, require_nesting_list
);
2799 require_nesting_list
= Fcons (feature
, require_nesting_list
);
2801 /* Value saved here is to be restored into Vautoload_queue */
2802 record_unwind_protect (un_autoload
, Vautoload_queue
);
2803 Vautoload_queue
= Qt
;
2805 /* Load the file. */
2806 tem
= Fload (NILP (filename
) ? Fsymbol_name (feature
) : filename
,
2807 noerror
, Qt
, Qnil
, (NILP (filename
) ? Qt
: Qnil
));
2809 /* If load failed entirely, return nil. */
2811 return unbind_to (count
, Qnil
);
2813 tem
= Fmemq (feature
, Vfeatures
);
2815 error ("Required feature `%s' was not provided",
2816 SDATA (SYMBOL_NAME (feature
)));
2818 /* Once loading finishes, don't undo it. */
2819 Vautoload_queue
= Qt
;
2820 feature
= unbind_to (count
, feature
);
2826 /* Primitives for work of the "widget" library.
2827 In an ideal world, this section would not have been necessary.
2828 However, lisp function calls being as slow as they are, it turns
2829 out that some functions in the widget library (wid-edit.el) are the
2830 bottleneck of Widget operation. Here is their translation to C,
2831 for the sole reason of efficiency. */
2833 DEFUN ("plist-member", Fplist_member
, Splist_member
, 2, 2, 0,
2834 doc
: /* Return non-nil if PLIST has the property PROP.
2835 PLIST is a property list, which is a list of the form
2836 \(PROP1 VALUE1 PROP2 VALUE2 ...). PROP is a symbol.
2837 Unlike `plist-get', this allows you to distinguish between a missing
2838 property and a property with the value nil.
2839 The value is actually the tail of PLIST whose car is PROP. */)
2840 (Lisp_Object plist
, Lisp_Object prop
)
2842 while (CONSP (plist
) && !EQ (XCAR (plist
), prop
))
2844 plist
= XCDR (plist
);
2845 plist
= CDR (plist
);
2851 DEFUN ("widget-put", Fwidget_put
, Swidget_put
, 3, 3, 0,
2852 doc
: /* In WIDGET, set PROPERTY to VALUE.
2853 The value can later be retrieved with `widget-get'. */)
2854 (Lisp_Object widget
, Lisp_Object property
, Lisp_Object value
)
2856 CHECK_CONS (widget
);
2857 XSETCDR (widget
, Fplist_put (XCDR (widget
), property
, value
));
2861 DEFUN ("widget-get", Fwidget_get
, Swidget_get
, 2, 2, 0,
2862 doc
: /* In WIDGET, get the value of PROPERTY.
2863 The value could either be specified when the widget was created, or
2864 later with `widget-put'. */)
2865 (Lisp_Object widget
, Lisp_Object property
)
2873 CHECK_CONS (widget
);
2874 tmp
= Fplist_member (XCDR (widget
), property
);
2880 tmp
= XCAR (widget
);
2883 widget
= Fget (tmp
, Qwidget_type
);
2887 DEFUN ("widget-apply", Fwidget_apply
, Swidget_apply
, 2, MANY
, 0,
2888 doc
: /* Apply the value of WIDGET's PROPERTY to the widget itself.
2889 ARGS are passed as extra arguments to the function.
2890 usage: (widget-apply WIDGET PROPERTY &rest ARGS) */)
2891 (ptrdiff_t nargs
, Lisp_Object
*args
)
2893 Lisp_Object widget
= args
[0];
2894 Lisp_Object property
= args
[1];
2895 Lisp_Object propval
= Fwidget_get (widget
, property
);
2896 Lisp_Object trailing_args
= Flist (nargs
- 2, args
+ 2);
2897 Lisp_Object result
= CALLN (Fapply
, propval
, widget
, trailing_args
);
2901 #ifdef HAVE_LANGINFO_CODESET
2902 #include <langinfo.h>
2905 DEFUN ("locale-info", Flocale_info
, Slocale_info
, 1, 1, 0,
2906 doc
: /* Access locale data ITEM for the current C locale, if available.
2907 ITEM should be one of the following:
2909 `codeset', returning the character set as a string (locale item CODESET);
2911 `days', returning a 7-element vector of day names (locale items DAY_n);
2913 `months', returning a 12-element vector of month names (locale items MON_n);
2915 `paper', returning a list (WIDTH HEIGHT) for the default paper size,
2916 both measured in millimeters (locale items PAPER_WIDTH, PAPER_HEIGHT).
2918 If the system can't provide such information through a call to
2919 `nl_langinfo', or if ITEM isn't from the list above, return nil.
2921 See also Info node `(libc)Locales'.
2923 The data read from the system are decoded using `locale-coding-system'. */)
2927 #ifdef HAVE_LANGINFO_CODESET
2928 if (EQ (item
, Qcodeset
))
2930 str
= nl_langinfo (CODESET
);
2931 return build_string (str
);
2934 else if (EQ (item
, Qdays
)) /* e.g. for calendar-day-name-array */
2936 Lisp_Object v
= Fmake_vector (make_number (7), Qnil
);
2937 const int days
[7] = {DAY_1
, DAY_2
, DAY_3
, DAY_4
, DAY_5
, DAY_6
, DAY_7
};
2939 synchronize_system_time_locale ();
2940 for (i
= 0; i
< 7; i
++)
2942 str
= nl_langinfo (days
[i
]);
2943 AUTO_STRING (val
, str
);
2944 /* Fixme: Is this coding system necessarily right, even if
2945 it is consistent with CODESET? If not, what to do? */
2946 ASET (v
, i
, code_convert_string_norecord (val
, Vlocale_coding_system
,
2953 else if (EQ (item
, Qmonths
)) /* e.g. for calendar-month-name-array */
2955 Lisp_Object v
= Fmake_vector (make_number (12), Qnil
);
2956 const int months
[12] = {MON_1
, MON_2
, MON_3
, MON_4
, MON_5
, MON_6
, MON_7
,
2957 MON_8
, MON_9
, MON_10
, MON_11
, MON_12
};
2959 synchronize_system_time_locale ();
2960 for (i
= 0; i
< 12; i
++)
2962 str
= nl_langinfo (months
[i
]);
2963 AUTO_STRING (val
, str
);
2964 ASET (v
, i
, code_convert_string_norecord (val
, Vlocale_coding_system
,
2970 /* LC_PAPER stuff isn't defined as accessible in glibc as of 2.3.1,
2971 but is in the locale files. This could be used by ps-print. */
2973 else if (EQ (item
, Qpaper
))
2974 return list2i (nl_langinfo (PAPER_WIDTH
), nl_langinfo (PAPER_HEIGHT
));
2975 #endif /* PAPER_WIDTH */
2976 #endif /* HAVE_LANGINFO_CODESET*/
2980 /* base64 encode/decode functions (RFC 2045).
2981 Based on code from GNU recode. */
2983 #define MIME_LINE_LENGTH 76
2985 #define IS_ASCII(Character) \
2987 #define IS_BASE64(Character) \
2988 (IS_ASCII (Character) && base64_char_to_value[Character] >= 0)
2989 #define IS_BASE64_IGNORABLE(Character) \
2990 ((Character) == ' ' || (Character) == '\t' || (Character) == '\n' \
2991 || (Character) == '\f' || (Character) == '\r')
2993 /* Used by base64_decode_1 to retrieve a non-base64-ignorable
2994 character or return retval if there are no characters left to
2996 #define READ_QUADRUPLET_BYTE(retval) \
3001 if (nchars_return) \
3002 *nchars_return = nchars; \
3007 while (IS_BASE64_IGNORABLE (c))
3009 /* Table of characters coding the 64 values. */
3010 static const char base64_value_to_char
[64] =
3012 'A', 'B', 'C', 'D', 'E', 'F', 'G', 'H', 'I', 'J', /* 0- 9 */
3013 'K', 'L', 'M', 'N', 'O', 'P', 'Q', 'R', 'S', 'T', /* 10-19 */
3014 'U', 'V', 'W', 'X', 'Y', 'Z', 'a', 'b', 'c', 'd', /* 20-29 */
3015 'e', 'f', 'g', 'h', 'i', 'j', 'k', 'l', 'm', 'n', /* 30-39 */
3016 'o', 'p', 'q', 'r', 's', 't', 'u', 'v', 'w', 'x', /* 40-49 */
3017 'y', 'z', '0', '1', '2', '3', '4', '5', '6', '7', /* 50-59 */
3018 '8', '9', '+', '/' /* 60-63 */
3021 /* Table of base64 values for first 128 characters. */
3022 static const short base64_char_to_value
[128] =
3024 -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, /* 0- 9 */
3025 -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, /* 10- 19 */
3026 -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, /* 20- 29 */
3027 -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, /* 30- 39 */
3028 -1, -1, -1, 62, -1, -1, -1, 63, 52, 53, /* 40- 49 */
3029 54, 55, 56, 57, 58, 59, 60, 61, -1, -1, /* 50- 59 */
3030 -1, -1, -1, -1, -1, 0, 1, 2, 3, 4, /* 60- 69 */
3031 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, /* 70- 79 */
3032 15, 16, 17, 18, 19, 20, 21, 22, 23, 24, /* 80- 89 */
3033 25, -1, -1, -1, -1, -1, -1, 26, 27, 28, /* 90- 99 */
3034 29, 30, 31, 32, 33, 34, 35, 36, 37, 38, /* 100-109 */
3035 39, 40, 41, 42, 43, 44, 45, 46, 47, 48, /* 110-119 */
3036 49, 50, 51, -1, -1, -1, -1, -1 /* 120-127 */
3039 /* The following diagram shows the logical steps by which three octets
3040 get transformed into four base64 characters.
3042 .--------. .--------. .--------.
3043 |aaaaaabb| |bbbbcccc| |ccdddddd|
3044 `--------' `--------' `--------'
3046 .--------+--------+--------+--------.
3047 |00aaaaaa|00bbbbbb|00cccccc|00dddddd|
3048 `--------+--------+--------+--------'
3050 .--------+--------+--------+--------.
3051 |AAAAAAAA|BBBBBBBB|CCCCCCCC|DDDDDDDD|
3052 `--------+--------+--------+--------'
3054 The octets are divided into 6 bit chunks, which are then encoded into
3055 base64 characters. */
3058 static ptrdiff_t base64_encode_1 (const char *, char *, ptrdiff_t, bool, bool);
3059 static ptrdiff_t base64_decode_1 (const char *, char *, ptrdiff_t, bool,
3062 DEFUN ("base64-encode-region", Fbase64_encode_region
, Sbase64_encode_region
,
3064 doc
: /* Base64-encode the region between BEG and END.
3065 Return the length of the encoded text.
3066 Optional third argument NO-LINE-BREAK means do not break long lines
3067 into shorter lines. */)
3068 (Lisp_Object beg
, Lisp_Object end
, Lisp_Object no_line_break
)
3071 ptrdiff_t allength
, length
;
3072 ptrdiff_t ibeg
, iend
, encoded_length
;
3073 ptrdiff_t old_pos
= PT
;
3076 validate_region (&beg
, &end
);
3078 ibeg
= CHAR_TO_BYTE (XFASTINT (beg
));
3079 iend
= CHAR_TO_BYTE (XFASTINT (end
));
3080 move_gap_both (XFASTINT (beg
), ibeg
);
3082 /* We need to allocate enough room for encoding the text.
3083 We need 33 1/3% more space, plus a newline every 76
3084 characters, and then we round up. */
3085 length
= iend
- ibeg
;
3086 allength
= length
+ length
/3 + 1;
3087 allength
+= allength
/ MIME_LINE_LENGTH
+ 1 + 6;
3089 encoded
= SAFE_ALLOCA (allength
);
3090 encoded_length
= base64_encode_1 ((char *) BYTE_POS_ADDR (ibeg
),
3091 encoded
, length
, NILP (no_line_break
),
3092 !NILP (BVAR (current_buffer
, enable_multibyte_characters
)));
3093 if (encoded_length
> allength
)
3096 if (encoded_length
< 0)
3098 /* The encoding wasn't possible. */
3100 error ("Multibyte character in data for base64 encoding");
3103 /* Now we have encoded the region, so we insert the new contents
3104 and delete the old. (Insert first in order to preserve markers.) */
3105 SET_PT_BOTH (XFASTINT (beg
), ibeg
);
3106 insert (encoded
, encoded_length
);
3108 del_range_byte (ibeg
+ encoded_length
, iend
+ encoded_length
);
3110 /* If point was outside of the region, restore it exactly; else just
3111 move to the beginning of the region. */
3112 if (old_pos
>= XFASTINT (end
))
3113 old_pos
+= encoded_length
- (XFASTINT (end
) - XFASTINT (beg
));
3114 else if (old_pos
> XFASTINT (beg
))
3115 old_pos
= XFASTINT (beg
);
3118 /* We return the length of the encoded text. */
3119 return make_number (encoded_length
);
3122 DEFUN ("base64-encode-string", Fbase64_encode_string
, Sbase64_encode_string
,
3124 doc
: /* Base64-encode STRING and return the result.
3125 Optional second argument NO-LINE-BREAK means do not break long lines
3126 into shorter lines. */)
3127 (Lisp_Object string
, Lisp_Object no_line_break
)
3129 ptrdiff_t allength
, length
, encoded_length
;
3131 Lisp_Object encoded_string
;
3134 CHECK_STRING (string
);
3136 /* We need to allocate enough room for encoding the text.
3137 We need 33 1/3% more space, plus a newline every 76
3138 characters, and then we round up. */
3139 length
= SBYTES (string
);
3140 allength
= length
+ length
/3 + 1;
3141 allength
+= allength
/ MIME_LINE_LENGTH
+ 1 + 6;
3143 /* We need to allocate enough room for decoding the text. */
3144 encoded
= SAFE_ALLOCA (allength
);
3146 encoded_length
= base64_encode_1 (SSDATA (string
),
3147 encoded
, length
, NILP (no_line_break
),
3148 STRING_MULTIBYTE (string
));
3149 if (encoded_length
> allength
)
3152 if (encoded_length
< 0)
3154 /* The encoding wasn't possible. */
3155 error ("Multibyte character in data for base64 encoding");
3158 encoded_string
= make_unibyte_string (encoded
, encoded_length
);
3161 return encoded_string
;
3165 base64_encode_1 (const char *from
, char *to
, ptrdiff_t length
,
3166 bool line_break
, bool multibyte
)
3179 c
= STRING_CHAR_AND_LENGTH ((unsigned char *) from
+ i
, bytes
);
3180 if (CHAR_BYTE8_P (c
))
3181 c
= CHAR_TO_BYTE8 (c
);
3189 /* Wrap line every 76 characters. */
3193 if (counter
< MIME_LINE_LENGTH
/ 4)
3202 /* Process first byte of a triplet. */
3204 *e
++ = base64_value_to_char
[0x3f & c
>> 2];
3205 value
= (0x03 & c
) << 4;
3207 /* Process second byte of a triplet. */
3211 *e
++ = base64_value_to_char
[value
];
3219 c
= STRING_CHAR_AND_LENGTH ((unsigned char *) from
+ i
, bytes
);
3220 if (CHAR_BYTE8_P (c
))
3221 c
= CHAR_TO_BYTE8 (c
);
3229 *e
++ = base64_value_to_char
[value
| (0x0f & c
>> 4)];
3230 value
= (0x0f & c
) << 2;
3232 /* Process third byte of a triplet. */
3236 *e
++ = base64_value_to_char
[value
];
3243 c
= STRING_CHAR_AND_LENGTH ((unsigned char *) from
+ i
, bytes
);
3244 if (CHAR_BYTE8_P (c
))
3245 c
= CHAR_TO_BYTE8 (c
);
3253 *e
++ = base64_value_to_char
[value
| (0x03 & c
>> 6)];
3254 *e
++ = base64_value_to_char
[0x3f & c
];
3261 DEFUN ("base64-decode-region", Fbase64_decode_region
, Sbase64_decode_region
,
3263 doc
: /* Base64-decode the region between BEG and END.
3264 Return the length of the decoded text.
3265 If the region can't be decoded, signal an error and don't modify the buffer. */)
3266 (Lisp_Object beg
, Lisp_Object end
)
3268 ptrdiff_t ibeg
, iend
, length
, allength
;
3270 ptrdiff_t old_pos
= PT
;
3271 ptrdiff_t decoded_length
;
3272 ptrdiff_t inserted_chars
;
3273 bool multibyte
= !NILP (BVAR (current_buffer
, enable_multibyte_characters
));
3276 validate_region (&beg
, &end
);
3278 ibeg
= CHAR_TO_BYTE (XFASTINT (beg
));
3279 iend
= CHAR_TO_BYTE (XFASTINT (end
));
3281 length
= iend
- ibeg
;
3283 /* We need to allocate enough room for decoding the text. If we are
3284 working on a multibyte buffer, each decoded code may occupy at
3286 allength
= multibyte
? length
* 2 : length
;
3287 decoded
= SAFE_ALLOCA (allength
);
3289 move_gap_both (XFASTINT (beg
), ibeg
);
3290 decoded_length
= base64_decode_1 ((char *) BYTE_POS_ADDR (ibeg
),
3292 multibyte
, &inserted_chars
);
3293 if (decoded_length
> allength
)
3296 if (decoded_length
< 0)
3298 /* The decoding wasn't possible. */
3299 error ("Invalid base64 data");
3302 /* Now we have decoded the region, so we insert the new contents
3303 and delete the old. (Insert first in order to preserve markers.) */
3304 TEMP_SET_PT_BOTH (XFASTINT (beg
), ibeg
);
3305 insert_1_both (decoded
, inserted_chars
, decoded_length
, 0, 1, 0);
3308 /* Delete the original text. */
3309 del_range_both (PT
, PT_BYTE
, XFASTINT (end
) + inserted_chars
,
3310 iend
+ decoded_length
, 1);
3312 /* If point was outside of the region, restore it exactly; else just
3313 move to the beginning of the region. */
3314 if (old_pos
>= XFASTINT (end
))
3315 old_pos
+= inserted_chars
- (XFASTINT (end
) - XFASTINT (beg
));
3316 else if (old_pos
> XFASTINT (beg
))
3317 old_pos
= XFASTINT (beg
);
3318 SET_PT (old_pos
> ZV
? ZV
: old_pos
);
3320 return make_number (inserted_chars
);
3323 DEFUN ("base64-decode-string", Fbase64_decode_string
, Sbase64_decode_string
,
3325 doc
: /* Base64-decode STRING and return the result. */)
3326 (Lisp_Object string
)
3329 ptrdiff_t length
, decoded_length
;
3330 Lisp_Object decoded_string
;
3333 CHECK_STRING (string
);
3335 length
= SBYTES (string
);
3336 /* We need to allocate enough room for decoding the text. */
3337 decoded
= SAFE_ALLOCA (length
);
3339 /* The decoded result should be unibyte. */
3340 decoded_length
= base64_decode_1 (SSDATA (string
), decoded
, length
,
3342 if (decoded_length
> length
)
3344 else if (decoded_length
>= 0)
3345 decoded_string
= make_unibyte_string (decoded
, decoded_length
);
3347 decoded_string
= Qnil
;
3350 if (!STRINGP (decoded_string
))
3351 error ("Invalid base64 data");
3353 return decoded_string
;
3356 /* Base64-decode the data at FROM of LENGTH bytes into TO. If
3357 MULTIBYTE, the decoded result should be in multibyte
3358 form. If NCHARS_RETURN is not NULL, store the number of produced
3359 characters in *NCHARS_RETURN. */
3362 base64_decode_1 (const char *from
, char *to
, ptrdiff_t length
,
3363 bool multibyte
, ptrdiff_t *nchars_return
)
3365 ptrdiff_t i
= 0; /* Used inside READ_QUADRUPLET_BYTE */
3368 unsigned long value
;
3369 ptrdiff_t nchars
= 0;
3373 /* Process first byte of a quadruplet. */
3375 READ_QUADRUPLET_BYTE (e
-to
);
3379 value
= base64_char_to_value
[c
] << 18;
3381 /* Process second byte of a quadruplet. */
3383 READ_QUADRUPLET_BYTE (-1);
3387 value
|= base64_char_to_value
[c
] << 12;
3389 c
= (unsigned char) (value
>> 16);
3390 if (multibyte
&& c
>= 128)
3391 e
+= BYTE8_STRING (c
, e
);
3396 /* Process third byte of a quadruplet. */
3398 READ_QUADRUPLET_BYTE (-1);
3402 READ_QUADRUPLET_BYTE (-1);
3411 value
|= base64_char_to_value
[c
] << 6;
3413 c
= (unsigned char) (0xff & value
>> 8);
3414 if (multibyte
&& c
>= 128)
3415 e
+= BYTE8_STRING (c
, e
);
3420 /* Process fourth byte of a quadruplet. */
3422 READ_QUADRUPLET_BYTE (-1);
3429 value
|= base64_char_to_value
[c
];
3431 c
= (unsigned char) (0xff & value
);
3432 if (multibyte
&& c
>= 128)
3433 e
+= BYTE8_STRING (c
, e
);
3442 /***********************************************************************
3444 ***** Hash Tables *****
3446 ***********************************************************************/
3448 /* Implemented by gerd@gnu.org. This hash table implementation was
3449 inspired by CMUCL hash tables. */
3453 1. For small tables, association lists are probably faster than
3454 hash tables because they have lower overhead.
3456 For uses of hash tables where the O(1) behavior of table
3457 operations is not a requirement, it might therefore be a good idea
3458 not to hash. Instead, we could just do a linear search in the
3459 key_and_value vector of the hash table. This could be done
3460 if a `:linear-search t' argument is given to make-hash-table. */
3463 /* The list of all weak hash tables. Don't staticpro this one. */
3465 static struct Lisp_Hash_Table
*weak_hash_tables
;
3468 /***********************************************************************
3470 ***********************************************************************/
3473 CHECK_HASH_TABLE (Lisp_Object x
)
3475 CHECK_TYPE (HASH_TABLE_P (x
), Qhash_table_p
, x
);
3479 set_hash_key_and_value (struct Lisp_Hash_Table
*h
, Lisp_Object key_and_value
)
3481 h
->key_and_value
= key_and_value
;
3484 set_hash_next (struct Lisp_Hash_Table
*h
, Lisp_Object next
)
3489 set_hash_next_slot (struct Lisp_Hash_Table
*h
, ptrdiff_t idx
, Lisp_Object val
)
3491 gc_aset (h
->next
, idx
, val
);
3494 set_hash_hash (struct Lisp_Hash_Table
*h
, Lisp_Object hash
)
3499 set_hash_hash_slot (struct Lisp_Hash_Table
*h
, ptrdiff_t idx
, Lisp_Object val
)
3501 gc_aset (h
->hash
, idx
, val
);
3504 set_hash_index (struct Lisp_Hash_Table
*h
, Lisp_Object index
)
3509 set_hash_index_slot (struct Lisp_Hash_Table
*h
, ptrdiff_t idx
, Lisp_Object val
)
3511 gc_aset (h
->index
, idx
, val
);
3514 /* If OBJ is a Lisp hash table, return a pointer to its struct
3515 Lisp_Hash_Table. Otherwise, signal an error. */
3517 static struct Lisp_Hash_Table
*
3518 check_hash_table (Lisp_Object obj
)
3520 CHECK_HASH_TABLE (obj
);
3521 return XHASH_TABLE (obj
);
3525 /* Value is the next integer I >= N, N >= 0 which is "almost" a prime
3526 number. A number is "almost" a prime number if it is not divisible
3527 by any integer in the range 2 .. (NEXT_ALMOST_PRIME_LIMIT - 1). */
3530 next_almost_prime (EMACS_INT n
)
3532 verify (NEXT_ALMOST_PRIME_LIMIT
== 11);
3533 for (n
|= 1; ; n
+= 2)
3534 if (n
% 3 != 0 && n
% 5 != 0 && n
% 7 != 0)
3539 /* Find KEY in ARGS which has size NARGS. Don't consider indices for
3540 which USED[I] is non-zero. If found at index I in ARGS, set
3541 USED[I] and USED[I + 1] to 1, and return I + 1. Otherwise return
3542 0. This function is used to extract a keyword/argument pair from
3543 a DEFUN parameter list. */
3546 get_key_arg (Lisp_Object key
, ptrdiff_t nargs
, Lisp_Object
*args
, char *used
)
3550 for (i
= 1; i
< nargs
; i
++)
3551 if (!used
[i
- 1] && EQ (args
[i
- 1], key
))
3562 /* Return a Lisp vector which has the same contents as VEC but has
3563 at least INCR_MIN more entries, where INCR_MIN is positive.
3564 If NITEMS_MAX is not -1, do not grow the vector to be any larger
3565 than NITEMS_MAX. Entries in the resulting
3566 vector that are not copied from VEC are set to nil. */
3569 larger_vector (Lisp_Object vec
, ptrdiff_t incr_min
, ptrdiff_t nitems_max
)
3571 struct Lisp_Vector
*v
;
3572 ptrdiff_t incr
, incr_max
, old_size
, new_size
;
3573 ptrdiff_t C_language_max
= min (PTRDIFF_MAX
, SIZE_MAX
) / sizeof *v
->contents
;
3574 ptrdiff_t n_max
= (0 <= nitems_max
&& nitems_max
< C_language_max
3575 ? nitems_max
: C_language_max
);
3576 eassert (VECTORP (vec
));
3577 eassert (0 < incr_min
&& -1 <= nitems_max
);
3578 old_size
= ASIZE (vec
);
3579 incr_max
= n_max
- old_size
;
3580 incr
= max (incr_min
, min (old_size
>> 1, incr_max
));
3581 if (incr_max
< incr
)
3582 memory_full (SIZE_MAX
);
3583 new_size
= old_size
+ incr
;
3584 v
= allocate_vector (new_size
);
3585 memcpy (v
->contents
, XVECTOR (vec
)->contents
, old_size
* sizeof *v
->contents
);
3586 memclear (v
->contents
+ old_size
, incr
* word_size
);
3587 XSETVECTOR (vec
, v
);
3592 /***********************************************************************
3594 ***********************************************************************/
3596 /* Compare KEY1 which has hash code HASH1 and KEY2 with hash code
3597 HASH2 in hash table H using `eql'. Value is true if KEY1 and
3598 KEY2 are the same. */
3601 cmpfn_eql (struct hash_table_test
*ht
,
3605 return (FLOATP (key1
)
3607 && XFLOAT_DATA (key1
) == XFLOAT_DATA (key2
));
3611 /* Compare KEY1 which has hash code HASH1 and KEY2 with hash code
3612 HASH2 in hash table H using `equal'. Value is true if KEY1 and
3613 KEY2 are the same. */
3616 cmpfn_equal (struct hash_table_test
*ht
,
3620 return !NILP (Fequal (key1
, key2
));
3624 /* Compare KEY1 which has hash code HASH1, and KEY2 with hash code
3625 HASH2 in hash table H using H->user_cmp_function. Value is true
3626 if KEY1 and KEY2 are the same. */
3629 cmpfn_user_defined (struct hash_table_test
*ht
,
3633 return !NILP (call2 (ht
->user_cmp_function
, key1
, key2
));
3636 /* Value is a hash code for KEY for use in hash table H which uses
3637 `eq' to compare keys. The hash code returned is guaranteed to fit
3638 in a Lisp integer. */
3641 hashfn_eq (struct hash_table_test
*ht
, Lisp_Object key
)
3643 return XHASH (key
) ^ XTYPE (key
);
3646 /* Value is a hash code for KEY for use in hash table H which uses
3647 `equal' to compare keys. The hash code returned is guaranteed to fit
3648 in a Lisp integer. */
3651 hashfn_equal (struct hash_table_test
*ht
, Lisp_Object key
)
3653 return sxhash (key
, 0);
3656 /* Value is a hash code for KEY for use in hash table H which uses
3657 `eql' to compare keys. The hash code returned is guaranteed to fit
3658 in a Lisp integer. */
3661 hashfn_eql (struct hash_table_test
*ht
, Lisp_Object key
)
3663 return FLOATP (key
) ? hashfn_equal (ht
, key
) : hashfn_eq (ht
, key
);
3666 /* Value is a hash code for KEY for use in hash table H which uses as
3667 user-defined function to compare keys. The hash code returned is
3668 guaranteed to fit in a Lisp integer. */
3671 hashfn_user_defined (struct hash_table_test
*ht
, Lisp_Object key
)
3673 Lisp_Object hash
= call1 (ht
->user_hash_function
, key
);
3674 return hashfn_eq (ht
, hash
);
3677 struct hash_table_test
const
3678 hashtest_eq
= { LISPSYM_INITIALLY (Qeq
), LISPSYM_INITIALLY (Qnil
),
3679 LISPSYM_INITIALLY (Qnil
), 0, hashfn_eq
},
3680 hashtest_eql
= { LISPSYM_INITIALLY (Qeql
), LISPSYM_INITIALLY (Qnil
),
3681 LISPSYM_INITIALLY (Qnil
), cmpfn_eql
, hashfn_eql
},
3682 hashtest_equal
= { LISPSYM_INITIALLY (Qequal
), LISPSYM_INITIALLY (Qnil
),
3683 LISPSYM_INITIALLY (Qnil
), cmpfn_equal
, hashfn_equal
};
3685 /* Allocate basically initialized hash table. */
3687 static struct Lisp_Hash_Table
*
3688 allocate_hash_table (void)
3690 return ALLOCATE_PSEUDOVECTOR (struct Lisp_Hash_Table
,
3691 count
, PVEC_HASH_TABLE
);
3694 /* An upper bound on the size of a hash table index. It must fit in
3695 ptrdiff_t and be a valid Emacs fixnum. */
3696 #define INDEX_SIZE_BOUND \
3697 ((ptrdiff_t) min (MOST_POSITIVE_FIXNUM, PTRDIFF_MAX / word_size))
3699 /* Create and initialize a new hash table.
3701 TEST specifies the test the hash table will use to compare keys.
3702 It must be either one of the predefined tests `eq', `eql' or
3703 `equal' or a symbol denoting a user-defined test named TEST with
3704 test and hash functions USER_TEST and USER_HASH.
3706 Give the table initial capacity SIZE, SIZE >= 0, an integer.
3708 If REHASH_SIZE is an integer, it must be > 0, and this hash table's
3709 new size when it becomes full is computed by adding REHASH_SIZE to
3710 its old size. If REHASH_SIZE is a float, it must be > 1.0, and the
3711 table's new size is computed by multiplying its old size with
3714 REHASH_THRESHOLD must be a float <= 1.0, and > 0. The table will
3715 be resized when the ratio of (number of entries in the table) /
3716 (table size) is >= REHASH_THRESHOLD.
3718 WEAK specifies the weakness of the table. If non-nil, it must be
3719 one of the symbols `key', `value', `key-or-value', or `key-and-value'. */
3722 make_hash_table (struct hash_table_test test
,
3723 Lisp_Object size
, Lisp_Object rehash_size
,
3724 Lisp_Object rehash_threshold
, Lisp_Object weak
)
3726 struct Lisp_Hash_Table
*h
;
3728 EMACS_INT index_size
, sz
;
3732 /* Preconditions. */
3733 eassert (SYMBOLP (test
.name
));
3734 eassert (INTEGERP (size
) && XINT (size
) >= 0);
3735 eassert ((INTEGERP (rehash_size
) && XINT (rehash_size
) > 0)
3736 || (FLOATP (rehash_size
) && 1 < XFLOAT_DATA (rehash_size
)));
3737 eassert (FLOATP (rehash_threshold
)
3738 && 0 < XFLOAT_DATA (rehash_threshold
)
3739 && XFLOAT_DATA (rehash_threshold
) <= 1.0);
3741 if (XFASTINT (size
) == 0)
3742 size
= make_number (1);
3744 sz
= XFASTINT (size
);
3745 index_float
= sz
/ XFLOAT_DATA (rehash_threshold
);
3746 index_size
= (index_float
< INDEX_SIZE_BOUND
+ 1
3747 ? next_almost_prime (index_float
)
3748 : INDEX_SIZE_BOUND
+ 1);
3749 if (INDEX_SIZE_BOUND
< max (index_size
, 2 * sz
))
3750 error ("Hash table too large");
3752 /* Allocate a table and initialize it. */
3753 h
= allocate_hash_table ();
3755 /* Initialize hash table slots. */
3758 h
->rehash_threshold
= rehash_threshold
;
3759 h
->rehash_size
= rehash_size
;
3761 h
->key_and_value
= Fmake_vector (make_number (2 * sz
), Qnil
);
3762 h
->hash
= Fmake_vector (size
, Qnil
);
3763 h
->next
= Fmake_vector (size
, Qnil
);
3764 h
->index
= Fmake_vector (make_number (index_size
), Qnil
);
3766 /* Set up the free list. */
3767 for (i
= 0; i
< sz
- 1; ++i
)
3768 set_hash_next_slot (h
, i
, make_number (i
+ 1));
3769 h
->next_free
= make_number (0);
3771 XSET_HASH_TABLE (table
, h
);
3772 eassert (HASH_TABLE_P (table
));
3773 eassert (XHASH_TABLE (table
) == h
);
3775 /* Maybe add this hash table to the list of all weak hash tables. */
3777 h
->next_weak
= NULL
;
3780 h
->next_weak
= weak_hash_tables
;
3781 weak_hash_tables
= h
;
3788 /* Return a copy of hash table H1. Keys and values are not copied,
3789 only the table itself is. */
3792 copy_hash_table (struct Lisp_Hash_Table
*h1
)
3795 struct Lisp_Hash_Table
*h2
;
3797 h2
= allocate_hash_table ();
3799 h2
->key_and_value
= Fcopy_sequence (h1
->key_and_value
);
3800 h2
->hash
= Fcopy_sequence (h1
->hash
);
3801 h2
->next
= Fcopy_sequence (h1
->next
);
3802 h2
->index
= Fcopy_sequence (h1
->index
);
3803 XSET_HASH_TABLE (table
, h2
);
3805 /* Maybe add this hash table to the list of all weak hash tables. */
3806 if (!NILP (h2
->weak
))
3808 h2
->next_weak
= weak_hash_tables
;
3809 weak_hash_tables
= h2
;
3816 /* Resize hash table H if it's too full. If H cannot be resized
3817 because it's already too large, throw an error. */
3820 maybe_resize_hash_table (struct Lisp_Hash_Table
*h
)
3822 if (NILP (h
->next_free
))
3824 ptrdiff_t old_size
= HASH_TABLE_SIZE (h
);
3825 EMACS_INT new_size
, index_size
, nsize
;
3829 if (INTEGERP (h
->rehash_size
))
3830 new_size
= old_size
+ XFASTINT (h
->rehash_size
);
3833 double float_new_size
= old_size
* XFLOAT_DATA (h
->rehash_size
);
3834 if (float_new_size
< INDEX_SIZE_BOUND
+ 1)
3836 new_size
= float_new_size
;
3837 if (new_size
<= old_size
)
3838 new_size
= old_size
+ 1;
3841 new_size
= INDEX_SIZE_BOUND
+ 1;
3843 index_float
= new_size
/ XFLOAT_DATA (h
->rehash_threshold
);
3844 index_size
= (index_float
< INDEX_SIZE_BOUND
+ 1
3845 ? next_almost_prime (index_float
)
3846 : INDEX_SIZE_BOUND
+ 1);
3847 nsize
= max (index_size
, 2 * new_size
);
3848 if (INDEX_SIZE_BOUND
< nsize
)
3849 error ("Hash table too large to resize");
3851 #ifdef ENABLE_CHECKING
3852 if (HASH_TABLE_P (Vpurify_flag
)
3853 && XHASH_TABLE (Vpurify_flag
) == h
)
3854 message ("Growing hash table to: %"pI
"d", new_size
);
3857 set_hash_key_and_value (h
, larger_vector (h
->key_and_value
,
3858 2 * (new_size
- old_size
), -1));
3859 set_hash_next (h
, larger_vector (h
->next
, new_size
- old_size
, -1));
3860 set_hash_hash (h
, larger_vector (h
->hash
, new_size
- old_size
, -1));
3861 set_hash_index (h
, Fmake_vector (make_number (index_size
), Qnil
));
3863 /* Update the free list. Do it so that new entries are added at
3864 the end of the free list. This makes some operations like
3866 for (i
= old_size
; i
< new_size
- 1; ++i
)
3867 set_hash_next_slot (h
, i
, make_number (i
+ 1));
3869 if (!NILP (h
->next_free
))
3871 Lisp_Object last
, next
;
3873 last
= h
->next_free
;
3874 while (next
= HASH_NEXT (h
, XFASTINT (last
)),
3878 set_hash_next_slot (h
, XFASTINT (last
), make_number (old_size
));
3881 XSETFASTINT (h
->next_free
, old_size
);
3884 for (i
= 0; i
< old_size
; ++i
)
3885 if (!NILP (HASH_HASH (h
, i
)))
3887 EMACS_UINT hash_code
= XUINT (HASH_HASH (h
, i
));
3888 ptrdiff_t start_of_bucket
= hash_code
% ASIZE (h
->index
);
3889 set_hash_next_slot (h
, i
, HASH_INDEX (h
, start_of_bucket
));
3890 set_hash_index_slot (h
, start_of_bucket
, make_number (i
));
3896 /* Lookup KEY in hash table H. If HASH is non-null, return in *HASH
3897 the hash code of KEY. Value is the index of the entry in H
3898 matching KEY, or -1 if not found. */
3901 hash_lookup (struct Lisp_Hash_Table
*h
, Lisp_Object key
, EMACS_UINT
*hash
)
3903 EMACS_UINT hash_code
;
3904 ptrdiff_t start_of_bucket
;
3907 hash_code
= h
->test
.hashfn (&h
->test
, key
);
3908 eassert ((hash_code
& ~INTMASK
) == 0);
3912 start_of_bucket
= hash_code
% ASIZE (h
->index
);
3913 idx
= HASH_INDEX (h
, start_of_bucket
);
3917 ptrdiff_t i
= XFASTINT (idx
);
3918 if (EQ (key
, HASH_KEY (h
, i
))
3920 && hash_code
== XUINT (HASH_HASH (h
, i
))
3921 && h
->test
.cmpfn (&h
->test
, key
, HASH_KEY (h
, i
))))
3923 idx
= HASH_NEXT (h
, i
);
3926 return NILP (idx
) ? -1 : XFASTINT (idx
);
3930 /* Put an entry into hash table H that associates KEY with VALUE.
3931 HASH is a previously computed hash code of KEY.
3932 Value is the index of the entry in H matching KEY. */
3935 hash_put (struct Lisp_Hash_Table
*h
, Lisp_Object key
, Lisp_Object value
,
3938 ptrdiff_t start_of_bucket
, i
;
3940 eassert ((hash
& ~INTMASK
) == 0);
3942 /* Increment count after resizing because resizing may fail. */
3943 maybe_resize_hash_table (h
);
3946 /* Store key/value in the key_and_value vector. */
3947 i
= XFASTINT (h
->next_free
);
3948 h
->next_free
= HASH_NEXT (h
, i
);
3949 set_hash_key_slot (h
, i
, key
);
3950 set_hash_value_slot (h
, i
, value
);
3952 /* Remember its hash code. */
3953 set_hash_hash_slot (h
, i
, make_number (hash
));
3955 /* Add new entry to its collision chain. */
3956 start_of_bucket
= hash
% ASIZE (h
->index
);
3957 set_hash_next_slot (h
, i
, HASH_INDEX (h
, start_of_bucket
));
3958 set_hash_index_slot (h
, start_of_bucket
, make_number (i
));
3963 /* Remove the entry matching KEY from hash table H, if there is one. */
3966 hash_remove_from_table (struct Lisp_Hash_Table
*h
, Lisp_Object key
)
3968 EMACS_UINT hash_code
;
3969 ptrdiff_t start_of_bucket
;
3970 Lisp_Object idx
, prev
;
3972 hash_code
= h
->test
.hashfn (&h
->test
, key
);
3973 eassert ((hash_code
& ~INTMASK
) == 0);
3974 start_of_bucket
= hash_code
% ASIZE (h
->index
);
3975 idx
= HASH_INDEX (h
, start_of_bucket
);
3980 ptrdiff_t i
= XFASTINT (idx
);
3982 if (EQ (key
, HASH_KEY (h
, i
))
3984 && hash_code
== XUINT (HASH_HASH (h
, i
))
3985 && h
->test
.cmpfn (&h
->test
, key
, HASH_KEY (h
, i
))))
3987 /* Take entry out of collision chain. */
3989 set_hash_index_slot (h
, start_of_bucket
, HASH_NEXT (h
, i
));
3991 set_hash_next_slot (h
, XFASTINT (prev
), HASH_NEXT (h
, i
));
3993 /* Clear slots in key_and_value and add the slots to
3995 set_hash_key_slot (h
, i
, Qnil
);
3996 set_hash_value_slot (h
, i
, Qnil
);
3997 set_hash_hash_slot (h
, i
, Qnil
);
3998 set_hash_next_slot (h
, i
, h
->next_free
);
3999 h
->next_free
= make_number (i
);
4001 eassert (h
->count
>= 0);
4007 idx
= HASH_NEXT (h
, i
);
4013 /* Clear hash table H. */
4016 hash_clear (struct Lisp_Hash_Table
*h
)
4020 ptrdiff_t i
, size
= HASH_TABLE_SIZE (h
);
4022 for (i
= 0; i
< size
; ++i
)
4024 set_hash_next_slot (h
, i
, i
< size
- 1 ? make_number (i
+ 1) : Qnil
);
4025 set_hash_key_slot (h
, i
, Qnil
);
4026 set_hash_value_slot (h
, i
, Qnil
);
4027 set_hash_hash_slot (h
, i
, Qnil
);
4030 for (i
= 0; i
< ASIZE (h
->index
); ++i
)
4031 ASET (h
->index
, i
, Qnil
);
4033 h
->next_free
= make_number (0);
4040 /************************************************************************
4042 ************************************************************************/
4044 /* Sweep weak hash table H. REMOVE_ENTRIES_P means remove
4045 entries from the table that don't survive the current GC.
4046 !REMOVE_ENTRIES_P means mark entries that are in use. Value is
4047 true if anything was marked. */
4050 sweep_weak_table (struct Lisp_Hash_Table
*h
, bool remove_entries_p
)
4052 ptrdiff_t n
= gc_asize (h
->index
);
4053 bool marked
= false;
4055 for (ptrdiff_t bucket
= 0; bucket
< n
; ++bucket
)
4057 Lisp_Object idx
, next
, prev
;
4059 /* Follow collision chain, removing entries that
4060 don't survive this garbage collection. */
4062 for (idx
= HASH_INDEX (h
, bucket
); !NILP (idx
); idx
= next
)
4064 ptrdiff_t i
= XFASTINT (idx
);
4065 bool key_known_to_survive_p
= survives_gc_p (HASH_KEY (h
, i
));
4066 bool value_known_to_survive_p
= survives_gc_p (HASH_VALUE (h
, i
));
4069 if (EQ (h
->weak
, Qkey
))
4070 remove_p
= !key_known_to_survive_p
;
4071 else if (EQ (h
->weak
, Qvalue
))
4072 remove_p
= !value_known_to_survive_p
;
4073 else if (EQ (h
->weak
, Qkey_or_value
))
4074 remove_p
= !(key_known_to_survive_p
|| value_known_to_survive_p
);
4075 else if (EQ (h
->weak
, Qkey_and_value
))
4076 remove_p
= !(key_known_to_survive_p
&& value_known_to_survive_p
);
4080 next
= HASH_NEXT (h
, i
);
4082 if (remove_entries_p
)
4086 /* Take out of collision chain. */
4088 set_hash_index_slot (h
, bucket
, next
);
4090 set_hash_next_slot (h
, XFASTINT (prev
), next
);
4092 /* Add to free list. */
4093 set_hash_next_slot (h
, i
, h
->next_free
);
4096 /* Clear key, value, and hash. */
4097 set_hash_key_slot (h
, i
, Qnil
);
4098 set_hash_value_slot (h
, i
, Qnil
);
4099 set_hash_hash_slot (h
, i
, Qnil
);
4112 /* Make sure key and value survive. */
4113 if (!key_known_to_survive_p
)
4115 mark_object (HASH_KEY (h
, i
));
4119 if (!value_known_to_survive_p
)
4121 mark_object (HASH_VALUE (h
, i
));
4132 /* Remove elements from weak hash tables that don't survive the
4133 current garbage collection. Remove weak tables that don't survive
4134 from Vweak_hash_tables. Called from gc_sweep. */
4136 NO_INLINE
/* For better stack traces */
4138 sweep_weak_hash_tables (void)
4140 struct Lisp_Hash_Table
*h
, *used
, *next
;
4143 /* Mark all keys and values that are in use. Keep on marking until
4144 there is no more change. This is necessary for cases like
4145 value-weak table A containing an entry X -> Y, where Y is used in a
4146 key-weak table B, Z -> Y. If B comes after A in the list of weak
4147 tables, X -> Y might be removed from A, although when looking at B
4148 one finds that it shouldn't. */
4152 for (h
= weak_hash_tables
; h
; h
= h
->next_weak
)
4154 if (h
->header
.size
& ARRAY_MARK_FLAG
)
4155 marked
|= sweep_weak_table (h
, 0);
4160 /* Remove tables and entries that aren't used. */
4161 for (h
= weak_hash_tables
, used
= NULL
; h
; h
= next
)
4163 next
= h
->next_weak
;
4165 if (h
->header
.size
& ARRAY_MARK_FLAG
)
4167 /* TABLE is marked as used. Sweep its contents. */
4169 sweep_weak_table (h
, 1);
4171 /* Add table to the list of used weak hash tables. */
4172 h
->next_weak
= used
;
4177 weak_hash_tables
= used
;
4182 /***********************************************************************
4183 Hash Code Computation
4184 ***********************************************************************/
4186 /* Maximum depth up to which to dive into Lisp structures. */
4188 #define SXHASH_MAX_DEPTH 3
4190 /* Maximum length up to which to take list and vector elements into
4193 #define SXHASH_MAX_LEN 7
4195 /* Return a hash for string PTR which has length LEN. The hash value
4196 can be any EMACS_UINT value. */
4199 hash_string (char const *ptr
, ptrdiff_t len
)
4201 char const *p
= ptr
;
4202 char const *end
= p
+ len
;
4204 EMACS_UINT hash
= 0;
4209 hash
= sxhash_combine (hash
, c
);
4215 /* Return a hash for string PTR which has length LEN. The hash
4216 code returned is guaranteed to fit in a Lisp integer. */
4219 sxhash_string (char const *ptr
, ptrdiff_t len
)
4221 EMACS_UINT hash
= hash_string (ptr
, len
);
4222 return SXHASH_REDUCE (hash
);
4225 /* Return a hash for the floating point value VAL. */
4228 sxhash_float (double val
)
4230 EMACS_UINT hash
= 0;
4232 WORDS_PER_DOUBLE
= (sizeof val
/ sizeof hash
4233 + (sizeof val
% sizeof hash
!= 0))
4237 EMACS_UINT word
[WORDS_PER_DOUBLE
];
4241 memset (&u
.val
+ 1, 0, sizeof u
- sizeof u
.val
);
4242 for (i
= 0; i
< WORDS_PER_DOUBLE
; i
++)
4243 hash
= sxhash_combine (hash
, u
.word
[i
]);
4244 return SXHASH_REDUCE (hash
);
4247 /* Return a hash for list LIST. DEPTH is the current depth in the
4248 list. We don't recurse deeper than SXHASH_MAX_DEPTH in it. */
4251 sxhash_list (Lisp_Object list
, int depth
)
4253 EMACS_UINT hash
= 0;
4256 if (depth
< SXHASH_MAX_DEPTH
)
4258 CONSP (list
) && i
< SXHASH_MAX_LEN
;
4259 list
= XCDR (list
), ++i
)
4261 EMACS_UINT hash2
= sxhash (XCAR (list
), depth
+ 1);
4262 hash
= sxhash_combine (hash
, hash2
);
4267 EMACS_UINT hash2
= sxhash (list
, depth
+ 1);
4268 hash
= sxhash_combine (hash
, hash2
);
4271 return SXHASH_REDUCE (hash
);
4275 /* Return a hash for vector VECTOR. DEPTH is the current depth in
4276 the Lisp structure. */
4279 sxhash_vector (Lisp_Object vec
, int depth
)
4281 EMACS_UINT hash
= ASIZE (vec
);
4284 n
= min (SXHASH_MAX_LEN
, ASIZE (vec
));
4285 for (i
= 0; i
< n
; ++i
)
4287 EMACS_UINT hash2
= sxhash (AREF (vec
, i
), depth
+ 1);
4288 hash
= sxhash_combine (hash
, hash2
);
4291 return SXHASH_REDUCE (hash
);
4294 /* Return a hash for bool-vector VECTOR. */
4297 sxhash_bool_vector (Lisp_Object vec
)
4299 EMACS_INT size
= bool_vector_size (vec
);
4300 EMACS_UINT hash
= size
;
4303 n
= min (SXHASH_MAX_LEN
, bool_vector_words (size
));
4304 for (i
= 0; i
< n
; ++i
)
4305 hash
= sxhash_combine (hash
, bool_vector_data (vec
)[i
]);
4307 return SXHASH_REDUCE (hash
);
4311 /* Return a hash code for OBJ. DEPTH is the current depth in the Lisp
4312 structure. Value is an unsigned integer clipped to INTMASK. */
4315 sxhash (Lisp_Object obj
, int depth
)
4319 if (depth
> SXHASH_MAX_DEPTH
)
4322 switch (XTYPE (obj
))
4334 hash
= sxhash_string (SSDATA (obj
), SBYTES (obj
));
4337 /* This can be everything from a vector to an overlay. */
4338 case Lisp_Vectorlike
:
4340 /* According to the CL HyperSpec, two arrays are equal only if
4341 they are `eq', except for strings and bit-vectors. In
4342 Emacs, this works differently. We have to compare element
4344 hash
= sxhash_vector (obj
, depth
);
4345 else if (BOOL_VECTOR_P (obj
))
4346 hash
= sxhash_bool_vector (obj
);
4348 /* Others are `equal' if they are `eq', so let's take their
4354 hash
= sxhash_list (obj
, depth
);
4358 hash
= sxhash_float (XFLOAT_DATA (obj
));
4370 /***********************************************************************
4372 ***********************************************************************/
4374 DEFUN ("sxhash-eq", Fsxhash_eq
, Ssxhash_eq
, 1, 1, 0,
4375 doc
: /* Return an integer hash code for OBJ suitable for `eq'.
4376 If (eq A B), then (= (sxhash-eq A) (sxhash-eq B)). */)
4379 return make_number (hashfn_eq (NULL
, obj
));
4382 DEFUN ("sxhash-eql", Fsxhash_eql
, Ssxhash_eql
, 1, 1, 0,
4383 doc
: /* Return an integer hash code for OBJ suitable for `eql'.
4384 If (eql A B), then (= (sxhash-eql A) (sxhash-eql B)). */)
4387 return make_number (hashfn_eql (NULL
, obj
));
4390 DEFUN ("sxhash-equal", Fsxhash_equal
, Ssxhash_equal
, 1, 1, 0,
4391 doc
: /* Return an integer hash code for OBJ suitable for `equal'.
4392 If (equal A B), then (= (sxhash-equal A) (sxhash-equal B)). */)
4395 return make_number (hashfn_equal (NULL
, obj
));
4398 DEFUN ("make-hash-table", Fmake_hash_table
, Smake_hash_table
, 0, MANY
, 0,
4399 doc
: /* Create and return a new hash table.
4401 Arguments are specified as keyword/argument pairs. The following
4402 arguments are defined:
4404 :test TEST -- TEST must be a symbol that specifies how to compare
4405 keys. Default is `eql'. Predefined are the tests `eq', `eql', and
4406 `equal'. User-supplied test and hash functions can be specified via
4407 `define-hash-table-test'.
4409 :size SIZE -- A hint as to how many elements will be put in the table.
4412 :rehash-size REHASH-SIZE - Indicates how to expand the table when it
4413 fills up. If REHASH-SIZE is an integer, increase the size by that
4414 amount. If it is a float, it must be > 1.0, and the new size is the
4415 old size multiplied by that factor. Default is 1.5.
4417 :rehash-threshold THRESHOLD -- THRESHOLD must a float > 0, and <= 1.0.
4418 Resize the hash table when the ratio (number of entries / table size)
4419 is greater than or equal to THRESHOLD. Default is 0.8.
4421 :weakness WEAK -- WEAK must be one of nil, t, `key', `value',
4422 `key-or-value', or `key-and-value'. If WEAK is not nil, the table
4423 returned is a weak table. Key/value pairs are removed from a weak
4424 hash table when there are no non-weak references pointing to their
4425 key, value, one of key or value, or both key and value, depending on
4426 WEAK. WEAK t is equivalent to `key-and-value'. Default value of WEAK
4429 usage: (make-hash-table &rest KEYWORD-ARGS) */)
4430 (ptrdiff_t nargs
, Lisp_Object
*args
)
4432 Lisp_Object test
, size
, rehash_size
, rehash_threshold
, weak
;
4433 struct hash_table_test testdesc
;
4437 /* The vector `used' is used to keep track of arguments that
4438 have been consumed. */
4439 char *used
= SAFE_ALLOCA (nargs
* sizeof *used
);
4440 memset (used
, 0, nargs
* sizeof *used
);
4442 /* See if there's a `:test TEST' among the arguments. */
4443 i
= get_key_arg (QCtest
, nargs
, args
, used
);
4444 test
= i
? args
[i
] : Qeql
;
4446 testdesc
= hashtest_eq
;
4447 else if (EQ (test
, Qeql
))
4448 testdesc
= hashtest_eql
;
4449 else if (EQ (test
, Qequal
))
4450 testdesc
= hashtest_equal
;
4453 /* See if it is a user-defined test. */
4456 prop
= Fget (test
, Qhash_table_test
);
4457 if (!CONSP (prop
) || !CONSP (XCDR (prop
)))
4458 signal_error ("Invalid hash table test", test
);
4459 testdesc
.name
= test
;
4460 testdesc
.user_cmp_function
= XCAR (prop
);
4461 testdesc
.user_hash_function
= XCAR (XCDR (prop
));
4462 testdesc
.hashfn
= hashfn_user_defined
;
4463 testdesc
.cmpfn
= cmpfn_user_defined
;
4466 /* See if there's a `:size SIZE' argument. */
4467 i
= get_key_arg (QCsize
, nargs
, args
, used
);
4468 size
= i
? args
[i
] : Qnil
;
4470 size
= make_number (DEFAULT_HASH_SIZE
);
4471 else if (!INTEGERP (size
) || XINT (size
) < 0)
4472 signal_error ("Invalid hash table size", size
);
4474 /* Look for `:rehash-size SIZE'. */
4475 i
= get_key_arg (QCrehash_size
, nargs
, args
, used
);
4476 rehash_size
= i
? args
[i
] : make_float (DEFAULT_REHASH_SIZE
);
4477 if (! ((INTEGERP (rehash_size
) && 0 < XINT (rehash_size
))
4478 || (FLOATP (rehash_size
) && 1 < XFLOAT_DATA (rehash_size
))))
4479 signal_error ("Invalid hash table rehash size", rehash_size
);
4481 /* Look for `:rehash-threshold THRESHOLD'. */
4482 i
= get_key_arg (QCrehash_threshold
, nargs
, args
, used
);
4483 rehash_threshold
= i
? args
[i
] : make_float (DEFAULT_REHASH_THRESHOLD
);
4484 if (! (FLOATP (rehash_threshold
)
4485 && 0 < XFLOAT_DATA (rehash_threshold
)
4486 && XFLOAT_DATA (rehash_threshold
) <= 1))
4487 signal_error ("Invalid hash table rehash threshold", rehash_threshold
);
4489 /* Look for `:weakness WEAK'. */
4490 i
= get_key_arg (QCweakness
, nargs
, args
, used
);
4491 weak
= i
? args
[i
] : Qnil
;
4493 weak
= Qkey_and_value
;
4496 && !EQ (weak
, Qvalue
)
4497 && !EQ (weak
, Qkey_or_value
)
4498 && !EQ (weak
, Qkey_and_value
))
4499 signal_error ("Invalid hash table weakness", weak
);
4501 /* Now, all args should have been used up, or there's a problem. */
4502 for (i
= 0; i
< nargs
; ++i
)
4504 signal_error ("Invalid argument list", args
[i
]);
4507 return make_hash_table (testdesc
, size
, rehash_size
, rehash_threshold
, weak
);
4511 DEFUN ("copy-hash-table", Fcopy_hash_table
, Scopy_hash_table
, 1, 1, 0,
4512 doc
: /* Return a copy of hash table TABLE. */)
4515 return copy_hash_table (check_hash_table (table
));
4519 DEFUN ("hash-table-count", Fhash_table_count
, Shash_table_count
, 1, 1, 0,
4520 doc
: /* Return the number of elements in TABLE. */)
4523 return make_number (check_hash_table (table
)->count
);
4527 DEFUN ("hash-table-rehash-size", Fhash_table_rehash_size
,
4528 Shash_table_rehash_size
, 1, 1, 0,
4529 doc
: /* Return the current rehash size of TABLE. */)
4532 return check_hash_table (table
)->rehash_size
;
4536 DEFUN ("hash-table-rehash-threshold", Fhash_table_rehash_threshold
,
4537 Shash_table_rehash_threshold
, 1, 1, 0,
4538 doc
: /* Return the current rehash threshold of TABLE. */)
4541 return check_hash_table (table
)->rehash_threshold
;
4545 DEFUN ("hash-table-size", Fhash_table_size
, Shash_table_size
, 1, 1, 0,
4546 doc
: /* Return the size of TABLE.
4547 The size can be used as an argument to `make-hash-table' to create
4548 a hash table than can hold as many elements as TABLE holds
4549 without need for resizing. */)
4552 struct Lisp_Hash_Table
*h
= check_hash_table (table
);
4553 return make_number (HASH_TABLE_SIZE (h
));
4557 DEFUN ("hash-table-test", Fhash_table_test
, Shash_table_test
, 1, 1, 0,
4558 doc
: /* Return the test TABLE uses. */)
4561 return check_hash_table (table
)->test
.name
;
4565 DEFUN ("hash-table-weakness", Fhash_table_weakness
, Shash_table_weakness
,
4567 doc
: /* Return the weakness of TABLE. */)
4570 return check_hash_table (table
)->weak
;
4574 DEFUN ("hash-table-p", Fhash_table_p
, Shash_table_p
, 1, 1, 0,
4575 doc
: /* Return t if OBJ is a Lisp hash table object. */)
4578 return HASH_TABLE_P (obj
) ? Qt
: Qnil
;
4582 DEFUN ("clrhash", Fclrhash
, Sclrhash
, 1, 1, 0,
4583 doc
: /* Clear hash table TABLE and return it. */)
4586 hash_clear (check_hash_table (table
));
4587 /* Be compatible with XEmacs. */
4592 DEFUN ("gethash", Fgethash
, Sgethash
, 2, 3, 0,
4593 doc
: /* Look up KEY in TABLE and return its associated value.
4594 If KEY is not found, return DFLT which defaults to nil. */)
4595 (Lisp_Object key
, Lisp_Object table
, Lisp_Object dflt
)
4597 struct Lisp_Hash_Table
*h
= check_hash_table (table
);
4598 ptrdiff_t i
= hash_lookup (h
, key
, NULL
);
4599 return i
>= 0 ? HASH_VALUE (h
, i
) : dflt
;
4603 DEFUN ("puthash", Fputhash
, Sputhash
, 3, 3, 0,
4604 doc
: /* Associate KEY with VALUE in hash table TABLE.
4605 If KEY is already present in table, replace its current value with
4606 VALUE. In any case, return VALUE. */)
4607 (Lisp_Object key
, Lisp_Object value
, Lisp_Object table
)
4609 struct Lisp_Hash_Table
*h
= check_hash_table (table
);
4613 i
= hash_lookup (h
, key
, &hash
);
4615 set_hash_value_slot (h
, i
, value
);
4617 hash_put (h
, key
, value
, hash
);
4623 DEFUN ("remhash", Fremhash
, Sremhash
, 2, 2, 0,
4624 doc
: /* Remove KEY from TABLE. */)
4625 (Lisp_Object key
, Lisp_Object table
)
4627 struct Lisp_Hash_Table
*h
= check_hash_table (table
);
4628 hash_remove_from_table (h
, key
);
4633 DEFUN ("maphash", Fmaphash
, Smaphash
, 2, 2, 0,
4634 doc
: /* Call FUNCTION for all entries in hash table TABLE.
4635 FUNCTION is called with two arguments, KEY and VALUE.
4636 `maphash' always returns nil. */)
4637 (Lisp_Object function
, Lisp_Object table
)
4639 struct Lisp_Hash_Table
*h
= check_hash_table (table
);
4641 for (ptrdiff_t i
= 0; i
< HASH_TABLE_SIZE (h
); ++i
)
4642 if (!NILP (HASH_HASH (h
, i
)))
4643 call2 (function
, HASH_KEY (h
, i
), HASH_VALUE (h
, i
));
4649 DEFUN ("define-hash-table-test", Fdefine_hash_table_test
,
4650 Sdefine_hash_table_test
, 3, 3, 0,
4651 doc
: /* Define a new hash table test with name NAME, a symbol.
4653 In hash tables created with NAME specified as test, use TEST to
4654 compare keys, and HASH for computing hash codes of keys.
4656 TEST must be a function taking two arguments and returning non-nil if
4657 both arguments are the same. HASH must be a function taking one
4658 argument and returning an object that is the hash code of the argument.
4659 It should be the case that if (eq (funcall HASH x1) (funcall HASH x2))
4660 returns nil, then (funcall TEST x1 x2) also returns nil. */)
4661 (Lisp_Object name
, Lisp_Object test
, Lisp_Object hash
)
4663 return Fput (name
, Qhash_table_test
, list2 (test
, hash
));
4668 /************************************************************************
4669 MD5, SHA-1, and SHA-2
4670 ************************************************************************/
4678 make_digest_string (Lisp_Object digest
, int digest_size
)
4680 unsigned char *p
= SDATA (digest
);
4682 for (int i
= digest_size
- 1; i
>= 0; i
--)
4684 static char const hexdigit
[16] = "0123456789abcdef";
4686 p
[2 * i
] = hexdigit
[p_i
>> 4];
4687 p
[2 * i
+ 1] = hexdigit
[p_i
& 0xf];
4692 /* ALGORITHM is a symbol: md5, sha1, sha224 and so on. */
4695 secure_hash (Lisp_Object algorithm
, Lisp_Object object
, Lisp_Object start
,
4696 Lisp_Object end
, Lisp_Object coding_system
, Lisp_Object noerror
,
4699 ptrdiff_t size
, start_char
= 0, start_byte
, end_char
= 0, end_byte
;
4700 register EMACS_INT b
, e
;
4701 register struct buffer
*bp
;
4704 void *(*hash_func
) (const char *, size_t, void *);
4707 CHECK_SYMBOL (algorithm
);
4709 if (STRINGP (object
))
4711 if (NILP (coding_system
))
4713 /* Decide the coding-system to encode the data with. */
4715 if (STRING_MULTIBYTE (object
))
4716 /* use default, we can't guess correct value */
4717 coding_system
= preferred_coding_system ();
4719 coding_system
= Qraw_text
;
4722 if (NILP (Fcoding_system_p (coding_system
)))
4724 /* Invalid coding system. */
4726 if (!NILP (noerror
))
4727 coding_system
= Qraw_text
;
4729 xsignal1 (Qcoding_system_error
, coding_system
);
4732 if (STRING_MULTIBYTE (object
))
4733 object
= code_convert_string (object
, coding_system
, Qnil
, 1, 0, 1);
4735 size
= SCHARS (object
);
4736 validate_subarray (object
, start
, end
, size
, &start_char
, &end_char
);
4738 start_byte
= !start_char
? 0 : string_char_to_byte (object
, start_char
);
4739 end_byte
= (end_char
== size
4741 : string_char_to_byte (object
, end_char
));
4745 struct buffer
*prev
= current_buffer
;
4747 record_unwind_current_buffer ();
4749 CHECK_BUFFER (object
);
4751 bp
= XBUFFER (object
);
4752 set_buffer_internal (bp
);
4758 CHECK_NUMBER_COERCE_MARKER (start
);
4766 CHECK_NUMBER_COERCE_MARKER (end
);
4771 temp
= b
, b
= e
, e
= temp
;
4773 if (!(BEGV
<= b
&& e
<= ZV
))
4774 args_out_of_range (start
, end
);
4776 if (NILP (coding_system
))
4778 /* Decide the coding-system to encode the data with.
4779 See fileio.c:Fwrite-region */
4781 if (!NILP (Vcoding_system_for_write
))
4782 coding_system
= Vcoding_system_for_write
;
4785 bool force_raw_text
= 0;
4787 coding_system
= BVAR (XBUFFER (object
), buffer_file_coding_system
);
4788 if (NILP (coding_system
)
4789 || NILP (Flocal_variable_p (Qbuffer_file_coding_system
, Qnil
)))
4791 coding_system
= Qnil
;
4792 if (NILP (BVAR (current_buffer
, enable_multibyte_characters
)))
4796 if (NILP (coding_system
) && !NILP (Fbuffer_file_name (object
)))
4798 /* Check file-coding-system-alist. */
4799 Lisp_Object val
= CALLN (Ffind_operation_coding_system
,
4800 Qwrite_region
, start
, end
,
4801 Fbuffer_file_name (object
));
4802 if (CONSP (val
) && !NILP (XCDR (val
)))
4803 coding_system
= XCDR (val
);
4806 if (NILP (coding_system
)
4807 && !NILP (BVAR (XBUFFER (object
), buffer_file_coding_system
)))
4809 /* If we still have not decided a coding system, use the
4810 default value of buffer-file-coding-system. */
4811 coding_system
= BVAR (XBUFFER (object
), buffer_file_coding_system
);
4815 && !NILP (Ffboundp (Vselect_safe_coding_system_function
)))
4816 /* Confirm that VAL can surely encode the current region. */
4817 coding_system
= call4 (Vselect_safe_coding_system_function
,
4818 make_number (b
), make_number (e
),
4819 coding_system
, Qnil
);
4822 coding_system
= Qraw_text
;
4825 if (NILP (Fcoding_system_p (coding_system
)))
4827 /* Invalid coding system. */
4829 if (!NILP (noerror
))
4830 coding_system
= Qraw_text
;
4832 xsignal1 (Qcoding_system_error
, coding_system
);
4836 object
= make_buffer_string (b
, e
, 0);
4837 set_buffer_internal (prev
);
4838 /* Discard the unwind protect for recovering the current
4842 if (STRING_MULTIBYTE (object
))
4843 object
= code_convert_string (object
, coding_system
, Qnil
, 1, 0, 0);
4845 end_byte
= SBYTES (object
);
4848 if (EQ (algorithm
, Qmd5
))
4850 digest_size
= MD5_DIGEST_SIZE
;
4851 hash_func
= md5_buffer
;
4853 else if (EQ (algorithm
, Qsha1
))
4855 digest_size
= SHA1_DIGEST_SIZE
;
4856 hash_func
= sha1_buffer
;
4858 else if (EQ (algorithm
, Qsha224
))
4860 digest_size
= SHA224_DIGEST_SIZE
;
4861 hash_func
= sha224_buffer
;
4863 else if (EQ (algorithm
, Qsha256
))
4865 digest_size
= SHA256_DIGEST_SIZE
;
4866 hash_func
= sha256_buffer
;
4868 else if (EQ (algorithm
, Qsha384
))
4870 digest_size
= SHA384_DIGEST_SIZE
;
4871 hash_func
= sha384_buffer
;
4873 else if (EQ (algorithm
, Qsha512
))
4875 digest_size
= SHA512_DIGEST_SIZE
;
4876 hash_func
= sha512_buffer
;
4879 error ("Invalid algorithm arg: %s", SDATA (Fsymbol_name (algorithm
)));
4881 /* allocate 2 x digest_size so that it can be re-used to hold the
4883 digest
= make_uninit_string (digest_size
* 2);
4885 hash_func (SSDATA (object
) + start_byte
,
4886 end_byte
- start_byte
,
4890 return make_digest_string (digest
, digest_size
);
4892 return make_unibyte_string (SSDATA (digest
), digest_size
);
4895 DEFUN ("md5", Fmd5
, Smd5
, 1, 5, 0,
4896 doc
: /* Return MD5 message digest of OBJECT, a buffer or string.
4898 A message digest is a cryptographic checksum of a document, and the
4899 algorithm to calculate it is defined in RFC 1321.
4901 The two optional arguments START and END are character positions
4902 specifying for which part of OBJECT the message digest should be
4903 computed. If nil or omitted, the digest is computed for the whole
4906 The MD5 message digest is computed from the result of encoding the
4907 text in a coding system, not directly from the internal Emacs form of
4908 the text. The optional fourth argument CODING-SYSTEM specifies which
4909 coding system to encode the text with. It should be the same coding
4910 system that you used or will use when actually writing the text into a
4913 If CODING-SYSTEM is nil or omitted, the default depends on OBJECT. If
4914 OBJECT is a buffer, the default for CODING-SYSTEM is whatever coding
4915 system would be chosen by default for writing this text into a file.
4917 If OBJECT is a string, the most preferred coding system (see the
4918 command `prefer-coding-system') is used.
4920 If NOERROR is non-nil, silently assume the `raw-text' coding if the
4921 guesswork fails. Normally, an error is signaled in such case. */)
4922 (Lisp_Object object
, Lisp_Object start
, Lisp_Object end
, Lisp_Object coding_system
, Lisp_Object noerror
)
4924 return secure_hash (Qmd5
, object
, start
, end
, coding_system
, noerror
, Qnil
);
4927 DEFUN ("secure-hash", Fsecure_hash
, Ssecure_hash
, 2, 5, 0,
4928 doc
: /* Return the secure hash of OBJECT, a buffer or string.
4929 ALGORITHM is a symbol specifying the hash to use:
4930 md5, sha1, sha224, sha256, sha384 or sha512.
4932 The two optional arguments START and END are positions specifying for
4933 which part of OBJECT to compute the hash. If nil or omitted, uses the
4936 If BINARY is non-nil, returns a string in binary form. */)
4937 (Lisp_Object algorithm
, Lisp_Object object
, Lisp_Object start
, Lisp_Object end
, Lisp_Object binary
)
4939 return secure_hash (algorithm
, object
, start
, end
, Qnil
, Qnil
, binary
);
4942 DEFUN ("buffer-hash", Fbuffer_hash
, Sbuffer_hash
, 0, 1, 0,
4943 doc
: /* Return a hash of the contents of BUFFER-OR-NAME.
4944 This hash is performed on the raw internal format of the buffer,
4945 disregarding any coding systems.
4946 If nil, use the current buffer." */ )
4947 (Lisp_Object buffer_or_name
)
4951 struct sha1_ctx ctx
;
4953 if (NILP (buffer_or_name
))
4954 buffer
= Fcurrent_buffer ();
4956 buffer
= Fget_buffer (buffer_or_name
);
4958 nsberror (buffer_or_name
);
4960 b
= XBUFFER (buffer
);
4961 sha1_init_ctx (&ctx
);
4963 /* Process the first part of the buffer. */
4964 sha1_process_bytes (BUF_BEG_ADDR (b
),
4965 BUF_GPT_BYTE (b
) - BUF_BEG_BYTE (b
),
4968 /* If the gap is before the end of the buffer, process the last half
4970 if (BUF_GPT_BYTE (b
) < BUF_Z_BYTE (b
))
4971 sha1_process_bytes (BUF_GAP_END_ADDR (b
),
4972 BUF_Z_ADDR (b
) - BUF_GAP_END_ADDR (b
),
4975 Lisp_Object digest
= make_uninit_string (SHA1_DIGEST_SIZE
* 2);
4976 sha1_finish_ctx (&ctx
, SSDATA (digest
));
4977 return make_digest_string (digest
, SHA1_DIGEST_SIZE
);
4984 DEFSYM (Qmd5
, "md5");
4985 DEFSYM (Qsha1
, "sha1");
4986 DEFSYM (Qsha224
, "sha224");
4987 DEFSYM (Qsha256
, "sha256");
4988 DEFSYM (Qsha384
, "sha384");
4989 DEFSYM (Qsha512
, "sha512");
4991 /* Hash table stuff. */
4992 DEFSYM (Qhash_table_p
, "hash-table-p");
4994 DEFSYM (Qeql
, "eql");
4995 DEFSYM (Qequal
, "equal");
4996 DEFSYM (QCtest
, ":test");
4997 DEFSYM (QCsize
, ":size");
4998 DEFSYM (QCrehash_size
, ":rehash-size");
4999 DEFSYM (QCrehash_threshold
, ":rehash-threshold");
5000 DEFSYM (QCweakness
, ":weakness");
5001 DEFSYM (Qkey
, "key");
5002 DEFSYM (Qvalue
, "value");
5003 DEFSYM (Qhash_table_test
, "hash-table-test");
5004 DEFSYM (Qkey_or_value
, "key-or-value");
5005 DEFSYM (Qkey_and_value
, "key-and-value");
5007 defsubr (&Ssxhash_eq
);
5008 defsubr (&Ssxhash_eql
);
5009 defsubr (&Ssxhash_equal
);
5010 defsubr (&Smake_hash_table
);
5011 defsubr (&Scopy_hash_table
);
5012 defsubr (&Shash_table_count
);
5013 defsubr (&Shash_table_rehash_size
);
5014 defsubr (&Shash_table_rehash_threshold
);
5015 defsubr (&Shash_table_size
);
5016 defsubr (&Shash_table_test
);
5017 defsubr (&Shash_table_weakness
);
5018 defsubr (&Shash_table_p
);
5019 defsubr (&Sclrhash
);
5020 defsubr (&Sgethash
);
5021 defsubr (&Sputhash
);
5022 defsubr (&Sremhash
);
5023 defsubr (&Smaphash
);
5024 defsubr (&Sdefine_hash_table_test
);
5026 DEFSYM (Qstring_lessp
, "string-lessp");
5027 DEFSYM (Qprovide
, "provide");
5028 DEFSYM (Qrequire
, "require");
5029 DEFSYM (Qyes_or_no_p_history
, "yes-or-no-p-history");
5030 DEFSYM (Qcursor_in_echo_area
, "cursor-in-echo-area");
5031 DEFSYM (Qwidget_type
, "widget-type");
5033 staticpro (&string_char_byte_cache_string
);
5034 string_char_byte_cache_string
= Qnil
;
5036 require_nesting_list
= Qnil
;
5037 staticpro (&require_nesting_list
);
5039 Fset (Qyes_or_no_p_history
, Qnil
);
5041 DEFVAR_LISP ("features", Vfeatures
,
5042 doc
: /* A list of symbols which are the features of the executing Emacs.
5043 Used by `featurep' and `require', and altered by `provide'. */);
5044 Vfeatures
= list1 (Qemacs
);
5045 DEFSYM (Qfeatures
, "features");
5046 /* Let people use lexically scoped vars named `features'. */
5047 Fmake_var_non_special (Qfeatures
);
5048 DEFSYM (Qsubfeatures
, "subfeatures");
5049 DEFSYM (Qfuncall
, "funcall");
5051 #ifdef HAVE_LANGINFO_CODESET
5052 DEFSYM (Qcodeset
, "codeset");
5053 DEFSYM (Qdays
, "days");
5054 DEFSYM (Qmonths
, "months");
5055 DEFSYM (Qpaper
, "paper");
5056 #endif /* HAVE_LANGINFO_CODESET */
5058 DEFVAR_BOOL ("use-dialog-box", use_dialog_box
,
5059 doc
: /* Non-nil means mouse commands use dialog boxes to ask questions.
5060 This applies to `y-or-n-p' and `yes-or-no-p' questions asked by commands
5061 invoked by mouse clicks and mouse menu items.
5063 On some platforms, file selection dialogs are also enabled if this is
5067 DEFVAR_BOOL ("use-file-dialog", use_file_dialog
,
5068 doc
: /* Non-nil means mouse commands use a file dialog to ask for files.
5069 This applies to commands from menus and tool bar buttons even when
5070 they are initiated from the keyboard. If `use-dialog-box' is nil,
5071 that disables the use of a file dialog, regardless of the value of
5073 use_file_dialog
= 1;
5075 defsubr (&Sidentity
);
5078 defsubr (&Ssafe_length
);
5079 defsubr (&Sstring_bytes
);
5080 defsubr (&Sstring_equal
);
5081 defsubr (&Scompare_strings
);
5082 defsubr (&Sstring_lessp
);
5083 defsubr (&Sstring_version_lessp
);
5084 defsubr (&Sstring_collate_lessp
);
5085 defsubr (&Sstring_collate_equalp
);
5088 defsubr (&Svconcat
);
5089 defsubr (&Scopy_sequence
);
5090 defsubr (&Sstring_make_multibyte
);
5091 defsubr (&Sstring_make_unibyte
);
5092 defsubr (&Sstring_as_multibyte
);
5093 defsubr (&Sstring_as_unibyte
);
5094 defsubr (&Sstring_to_multibyte
);
5095 defsubr (&Sstring_to_unibyte
);
5096 defsubr (&Scopy_alist
);
5097 defsubr (&Ssubstring
);
5098 defsubr (&Ssubstring_no_properties
);
5111 defsubr (&Snreverse
);
5112 defsubr (&Sreverse
);
5114 defsubr (&Splist_get
);
5116 defsubr (&Splist_put
);
5118 defsubr (&Slax_plist_get
);
5119 defsubr (&Slax_plist_put
);
5122 defsubr (&Sequal_including_properties
);
5123 defsubr (&Sfillarray
);
5124 defsubr (&Sclear_string
);
5129 defsubr (&Smapconcat
);
5130 defsubr (&Syes_or_no_p
);
5131 defsubr (&Sload_average
);
5132 defsubr (&Sfeaturep
);
5133 defsubr (&Srequire
);
5134 defsubr (&Sprovide
);
5135 defsubr (&Splist_member
);
5136 defsubr (&Swidget_put
);
5137 defsubr (&Swidget_get
);
5138 defsubr (&Swidget_apply
);
5139 defsubr (&Sbase64_encode_region
);
5140 defsubr (&Sbase64_decode_region
);
5141 defsubr (&Sbase64_encode_string
);
5142 defsubr (&Sbase64_decode_string
);
5144 defsubr (&Ssecure_hash
);
5145 defsubr (&Sbuffer_hash
);
5146 defsubr (&Slocale_info
);