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"
39 static void sort_vector_copy (Lisp_Object
, ptrdiff_t,
40 Lisp_Object
*restrict
, Lisp_Object
*restrict
);
41 static bool internal_equal (Lisp_Object
, Lisp_Object
, int, bool, Lisp_Object
);
43 DEFUN ("identity", Fidentity
, Sidentity
, 1, 1, 0,
44 doc
: /* Return the argument unchanged. */
51 DEFUN ("random", Frandom
, Srandom
, 0, 1, 0,
52 doc
: /* Return a pseudo-random number.
53 All integers representable in Lisp, i.e. between `most-negative-fixnum'
54 and `most-positive-fixnum', inclusive, are equally likely.
56 With positive integer LIMIT, return random number in interval [0,LIMIT).
57 With argument t, set the random number seed from the system's entropy
58 pool if available, otherwise from less-random volatile data such as the time.
59 With a string argument, set the seed based on the string's contents.
60 Other values of LIMIT are ignored.
62 See Info node `(elisp)Random Numbers' for more details. */)
69 else if (STRINGP (limit
))
70 seed_random (SSDATA (limit
), SBYTES (limit
));
73 if (INTEGERP (limit
) && 0 < XINT (limit
))
76 /* Return the remainder, except reject the rare case where
77 get_random returns a number so close to INTMASK that the
78 remainder isn't random. */
79 EMACS_INT remainder
= val
% XINT (limit
);
80 if (val
- remainder
<= INTMASK
- XINT (limit
) + 1)
81 return make_number (remainder
);
84 return make_number (val
);
87 /* Heuristic on how many iterations of a tight loop can be safely done
88 before it's time to do a quit. This must be a power of 2. It
89 is nice but not necessary for it to equal USHRT_MAX + 1. */
90 enum { QUIT_COUNT_HEURISTIC
= 1 << 16 };
92 /* Process a quit, but do it only rarely, for efficiency. "Rarely"
93 means once per QUIT_COUNT_HEURISTIC or per USHRT_MAX + 1 times,
94 whichever is smaller. Use *QUIT_COUNT to count this. */
97 rarely_quit (unsigned short int *quit_count
)
99 if (! (++*quit_count
& (QUIT_COUNT_HEURISTIC
- 1)))
103 /* Random data-structure functions. */
105 DEFUN ("length", Flength
, Slength
, 1, 1, 0,
106 doc
: /* Return the length of vector, list or string SEQUENCE.
107 A byte-code function object is also allowed.
108 If the string contains multibyte characters, this is not necessarily
109 the number of bytes in the string; it is the number of characters.
110 To get the number of bytes, use `string-bytes'. */)
111 (register Lisp_Object sequence
)
113 register Lisp_Object val
;
115 if (STRINGP (sequence
))
116 XSETFASTINT (val
, SCHARS (sequence
));
117 else if (VECTORP (sequence
))
118 XSETFASTINT (val
, ASIZE (sequence
));
119 else if (CHAR_TABLE_P (sequence
))
120 XSETFASTINT (val
, MAX_CHAR
);
121 else if (BOOL_VECTOR_P (sequence
))
122 XSETFASTINT (val
, bool_vector_size (sequence
));
123 else if (COMPILEDP (sequence
))
124 XSETFASTINT (val
, ASIZE (sequence
) & PSEUDOVECTOR_SIZE_MASK
);
125 else if (CONSP (sequence
))
132 if ((i
& (QUIT_COUNT_HEURISTIC
- 1)) == 0)
134 if (MOST_POSITIVE_FIXNUM
< i
)
135 error ("List too long");
138 sequence
= XCDR (sequence
);
140 while (CONSP (sequence
));
142 CHECK_LIST_END (sequence
, sequence
);
144 val
= make_number (i
);
146 else if (NILP (sequence
))
147 XSETFASTINT (val
, 0);
149 wrong_type_argument (Qsequencep
, sequence
);
154 DEFUN ("safe-length", Fsafe_length
, Ssafe_length
, 1, 1, 0,
155 doc
: /* Return the length of a list, but avoid error or infinite loop.
156 This function never gets an error. If LIST is not really a list,
157 it returns 0. If LIST is circular, it returns a finite value
158 which is at least the number of distinct elements. */)
161 Lisp_Object tail
, halftail
;
166 return make_number (0);
168 /* halftail is used to detect circular lists. */
169 for (tail
= halftail
= list
; ; )
174 if (EQ (tail
, halftail
))
177 if ((lolen
& 1) == 0)
179 halftail
= XCDR (halftail
);
180 if ((lolen
& (QUIT_COUNT_HEURISTIC
- 1)) == 0)
184 hilen
+= UINTMAX_MAX
+ 1.0;
189 /* If the length does not fit into a fixnum, return a float.
190 On all known practical machines this returns an upper bound on
192 return hilen
? make_float (hilen
+ lolen
) : make_fixnum_or_float (lolen
);
195 DEFUN ("string-bytes", Fstring_bytes
, Sstring_bytes
, 1, 1, 0,
196 doc
: /* Return the number of bytes in STRING.
197 If STRING is multibyte, this may be greater than the length of STRING. */)
200 CHECK_STRING (string
);
201 return make_number (SBYTES (string
));
204 DEFUN ("string-equal", Fstring_equal
, Sstring_equal
, 2, 2, 0,
205 doc
: /* Return t if two strings have identical contents.
206 Case is significant, but text properties are ignored.
207 Symbols are also allowed; their print names are used instead. */)
208 (register Lisp_Object s1
, Lisp_Object s2
)
211 s1
= SYMBOL_NAME (s1
);
213 s2
= SYMBOL_NAME (s2
);
217 if (SCHARS (s1
) != SCHARS (s2
)
218 || SBYTES (s1
) != SBYTES (s2
)
219 || memcmp (SDATA (s1
), SDATA (s2
), SBYTES (s1
)))
224 DEFUN ("compare-strings", Fcompare_strings
, Scompare_strings
, 6, 7, 0,
225 doc
: /* Compare the contents of two strings, converting to multibyte if needed.
226 The arguments START1, END1, START2, and END2, if non-nil, are
227 positions specifying which parts of STR1 or STR2 to compare. In
228 string STR1, compare the part between START1 (inclusive) and END1
229 \(exclusive). If START1 is nil, it defaults to 0, the beginning of
230 the string; if END1 is nil, it defaults to the length of the string.
231 Likewise, in string STR2, compare the part between START2 and END2.
232 Like in `substring', negative values are counted from the end.
234 The strings are compared by the numeric values of their characters.
235 For instance, STR1 is "less than" STR2 if its first differing
236 character has a smaller numeric value. If IGNORE-CASE is non-nil,
237 characters are converted to upper-case before comparing them. Unibyte
238 strings are converted to multibyte for comparison.
240 The value is t if the strings (or specified portions) match.
241 If string STR1 is less, the value is a negative number N;
242 - 1 - N is the number of characters that match at the beginning.
243 If string STR1 is greater, the value is a positive number N;
244 N - 1 is the number of characters that match at the beginning. */)
245 (Lisp_Object str1
, Lisp_Object start1
, Lisp_Object end1
, Lisp_Object str2
,
246 Lisp_Object start2
, Lisp_Object end2
, Lisp_Object ignore_case
)
248 ptrdiff_t from1
, to1
, from2
, to2
, i1
, i1_byte
, i2
, i2_byte
;
253 /* For backward compatibility, silently bring too-large positive end
254 values into range. */
255 if (INTEGERP (end1
) && SCHARS (str1
) < XINT (end1
))
256 end1
= make_number (SCHARS (str1
));
257 if (INTEGERP (end2
) && SCHARS (str2
) < XINT (end2
))
258 end2
= make_number (SCHARS (str2
));
260 validate_subarray (str1
, start1
, end1
, SCHARS (str1
), &from1
, &to1
);
261 validate_subarray (str2
, start2
, end2
, SCHARS (str2
), &from2
, &to2
);
266 i1_byte
= string_char_to_byte (str1
, i1
);
267 i2_byte
= string_char_to_byte (str2
, i2
);
269 while (i1
< to1
&& i2
< to2
)
271 /* When we find a mismatch, we must compare the
272 characters, not just the bytes. */
275 FETCH_STRING_CHAR_AS_MULTIBYTE_ADVANCE (c1
, str1
, i1
, i1_byte
);
276 FETCH_STRING_CHAR_AS_MULTIBYTE_ADVANCE (c2
, str2
, i2
, i2_byte
);
281 if (! NILP (ignore_case
))
283 c1
= XINT (Fupcase (make_number (c1
)));
284 c2
= XINT (Fupcase (make_number (c2
)));
290 /* Note that I1 has already been incremented
291 past the character that we are comparing;
292 hence we don't add or subtract 1 here. */
294 return make_number (- i1
+ from1
);
296 return make_number (i1
- from1
);
300 return make_number (i1
- from1
+ 1);
302 return make_number (- i1
+ from1
- 1);
307 DEFUN ("string-lessp", Fstring_lessp
, Sstring_lessp
, 2, 2, 0,
308 doc
: /* Return non-nil if STRING1 is less than STRING2 in lexicographic order.
310 Symbols are also allowed; their print names are used instead. */)
311 (register Lisp_Object string1
, Lisp_Object string2
)
313 register ptrdiff_t end
;
314 register ptrdiff_t i1
, i1_byte
, i2
, i2_byte
;
316 if (SYMBOLP (string1
))
317 string1
= SYMBOL_NAME (string1
);
318 if (SYMBOLP (string2
))
319 string2
= SYMBOL_NAME (string2
);
320 CHECK_STRING (string1
);
321 CHECK_STRING (string2
);
323 i1
= i1_byte
= i2
= i2_byte
= 0;
325 end
= SCHARS (string1
);
326 if (end
> SCHARS (string2
))
327 end
= SCHARS (string2
);
331 /* When we find a mismatch, we must compare the
332 characters, not just the bytes. */
335 FETCH_STRING_CHAR_ADVANCE (c1
, string1
, i1
, i1_byte
);
336 FETCH_STRING_CHAR_ADVANCE (c2
, string2
, i2
, i2_byte
);
339 return c1
< c2
? Qt
: Qnil
;
341 return i1
< SCHARS (string2
) ? Qt
: Qnil
;
344 DEFUN ("string-version-lessp", Fstring_version_lessp
,
345 Sstring_version_lessp
, 2, 2, 0,
346 doc
: /* Return non-nil if S1 is less than S2, as version strings.
348 This function compares version strings S1 and S2:
349 1) By prefix lexicographically.
350 2) Then by version (similarly to version comparison of Debian's dpkg).
351 Leading zeros in version numbers are ignored.
352 3) If both prefix and version are equal, compare as ordinary strings.
354 For example, \"foo2.png\" compares less than \"foo12.png\".
356 Symbols are also allowed; their print names are used instead. */)
357 (Lisp_Object string1
, Lisp_Object string2
)
359 if (SYMBOLP (string1
))
360 string1
= SYMBOL_NAME (string1
);
361 if (SYMBOLP (string2
))
362 string2
= SYMBOL_NAME (string2
);
363 CHECK_STRING (string1
);
364 CHECK_STRING (string2
);
366 char *p1
= SSDATA (string1
);
367 char *p2
= SSDATA (string2
);
368 char *lim1
= p1
+ SBYTES (string1
);
369 char *lim2
= p2
+ SBYTES (string2
);
372 while ((cmp
= filevercmp (p1
, p2
)) == 0)
374 /* If the strings are identical through their first null bytes,
375 skip past identical prefixes and try again. */
376 ptrdiff_t size
= strlen (p1
) + 1;
380 return lim2
< p2
? Qnil
: Qt
;
385 return cmp
< 0 ? Qt
: Qnil
;
388 DEFUN ("string-collate-lessp", Fstring_collate_lessp
, Sstring_collate_lessp
, 2, 4, 0,
389 doc
: /* Return t if first arg string is less than second in collation order.
390 Symbols are also allowed; their print names are used instead.
392 This function obeys the conventions for collation order in your
393 locale settings. For example, punctuation and whitespace characters
394 might be considered less significant for sorting:
396 \(sort \\='("11" "12" "1 1" "1 2" "1.1" "1.2") \\='string-collate-lessp)
397 => ("11" "1 1" "1.1" "12" "1 2" "1.2")
399 The optional argument LOCALE, a string, overrides the setting of your
400 current locale identifier for collation. The value is system
401 dependent; a LOCALE \"en_US.UTF-8\" is applicable on POSIX systems,
402 while it would be, e.g., \"enu_USA.1252\" on MS-Windows systems.
404 If IGNORE-CASE is non-nil, characters are converted to lower-case
405 before comparing them.
407 To emulate Unicode-compliant collation on MS-Windows systems,
408 bind `w32-collate-ignore-punctuation' to a non-nil value, since
409 the codeset part of the locale cannot be \"UTF-8\" on MS-Windows.
411 If your system does not support a locale environment, this function
412 behaves like `string-lessp'. */)
413 (Lisp_Object s1
, Lisp_Object s2
, Lisp_Object locale
, Lisp_Object ignore_case
)
415 #if defined __STDC_ISO_10646__ || defined WINDOWSNT
416 /* Check parameters. */
418 s1
= SYMBOL_NAME (s1
);
420 s2
= SYMBOL_NAME (s2
);
424 CHECK_STRING (locale
);
426 return (str_collate (s1
, s2
, locale
, ignore_case
) < 0) ? Qt
: Qnil
;
428 #else /* !__STDC_ISO_10646__, !WINDOWSNT */
429 return Fstring_lessp (s1
, s2
);
430 #endif /* !__STDC_ISO_10646__, !WINDOWSNT */
433 DEFUN ("string-collate-equalp", Fstring_collate_equalp
, Sstring_collate_equalp
, 2, 4, 0,
434 doc
: /* Return t if two strings have identical contents.
435 Symbols are also allowed; their print names are used instead.
437 This function obeys the conventions for collation order in your locale
438 settings. For example, characters with different coding points but
439 the same meaning might be considered as equal, like different grave
440 accent Unicode characters:
442 \(string-collate-equalp (string ?\\uFF40) (string ?\\u1FEF))
445 The optional argument LOCALE, a string, overrides the setting of your
446 current locale identifier for collation. The value is system
447 dependent; a LOCALE \"en_US.UTF-8\" is applicable on POSIX systems,
448 while it would be \"enu_USA.1252\" on MS Windows systems.
450 If IGNORE-CASE is non-nil, characters are converted to lower-case
451 before comparing them.
453 To emulate Unicode-compliant collation on MS-Windows systems,
454 bind `w32-collate-ignore-punctuation' to a non-nil value, since
455 the codeset part of the locale cannot be \"UTF-8\" on MS-Windows.
457 If your system does not support a locale environment, this function
458 behaves like `string-equal'.
460 Do NOT use this function to compare file names for equality. */)
461 (Lisp_Object s1
, Lisp_Object s2
, Lisp_Object locale
, Lisp_Object ignore_case
)
463 #if defined __STDC_ISO_10646__ || defined WINDOWSNT
464 /* Check parameters. */
466 s1
= SYMBOL_NAME (s1
);
468 s2
= SYMBOL_NAME (s2
);
472 CHECK_STRING (locale
);
474 return (str_collate (s1
, s2
, locale
, ignore_case
) == 0) ? Qt
: Qnil
;
476 #else /* !__STDC_ISO_10646__, !WINDOWSNT */
477 return Fstring_equal (s1
, s2
);
478 #endif /* !__STDC_ISO_10646__, !WINDOWSNT */
481 static Lisp_Object
concat (ptrdiff_t nargs
, Lisp_Object
*args
,
482 enum Lisp_Type target_type
, bool last_special
);
486 concat2 (Lisp_Object s1
, Lisp_Object s2
)
488 return concat (2, ((Lisp_Object
[]) {s1
, s2
}), Lisp_String
, 0);
493 concat3 (Lisp_Object s1
, Lisp_Object s2
, Lisp_Object s3
)
495 return concat (3, ((Lisp_Object
[]) {s1
, s2
, s3
}), Lisp_String
, 0);
498 DEFUN ("append", Fappend
, Sappend
, 0, MANY
, 0,
499 doc
: /* Concatenate all the arguments and make the result a list.
500 The result is a list whose elements are the elements of all the arguments.
501 Each argument may be a list, vector or string.
502 The last argument is not copied, just used as the tail of the new list.
503 usage: (append &rest SEQUENCES) */)
504 (ptrdiff_t nargs
, Lisp_Object
*args
)
506 return concat (nargs
, args
, Lisp_Cons
, 1);
509 DEFUN ("concat", Fconcat
, Sconcat
, 0, MANY
, 0,
510 doc
: /* Concatenate all the arguments and make the result a string.
511 The result is a string whose elements are the elements of all the arguments.
512 Each argument may be a string or a list or vector of characters (integers).
513 usage: (concat &rest SEQUENCES) */)
514 (ptrdiff_t nargs
, Lisp_Object
*args
)
516 return concat (nargs
, args
, Lisp_String
, 0);
519 DEFUN ("vconcat", Fvconcat
, Svconcat
, 0, MANY
, 0,
520 doc
: /* Concatenate all the arguments and make the result a vector.
521 The result is a vector whose elements are the elements of all the arguments.
522 Each argument may be a list, vector or string.
523 usage: (vconcat &rest SEQUENCES) */)
524 (ptrdiff_t nargs
, Lisp_Object
*args
)
526 return concat (nargs
, args
, Lisp_Vectorlike
, 0);
530 DEFUN ("copy-sequence", Fcopy_sequence
, Scopy_sequence
, 1, 1, 0,
531 doc
: /* Return a copy of a list, vector, string or char-table.
532 The elements of a list or vector are not copied; they are shared
533 with the original. */)
536 if (NILP (arg
)) return arg
;
538 if (CHAR_TABLE_P (arg
))
540 return copy_char_table (arg
);
543 if (BOOL_VECTOR_P (arg
))
545 EMACS_INT nbits
= bool_vector_size (arg
);
546 ptrdiff_t nbytes
= bool_vector_bytes (nbits
);
547 Lisp_Object val
= make_uninit_bool_vector (nbits
);
548 memcpy (bool_vector_data (val
), bool_vector_data (arg
), nbytes
);
552 if (!CONSP (arg
) && !VECTORP (arg
) && !STRINGP (arg
))
553 wrong_type_argument (Qsequencep
, arg
);
555 return concat (1, &arg
, XTYPE (arg
), 0);
558 /* This structure holds information of an argument of `concat' that is
559 a string and has text properties to be copied. */
562 ptrdiff_t argnum
; /* refer to ARGS (arguments of `concat') */
563 ptrdiff_t from
; /* refer to ARGS[argnum] (argument string) */
564 ptrdiff_t to
; /* refer to VAL (the target string) */
568 concat (ptrdiff_t nargs
, Lisp_Object
*args
,
569 enum Lisp_Type target_type
, bool last_special
)
575 ptrdiff_t toindex_byte
= 0;
576 EMACS_INT result_len
;
577 EMACS_INT result_len_byte
;
579 Lisp_Object last_tail
;
582 /* When we make a multibyte string, we can't copy text properties
583 while concatenating each string because the length of resulting
584 string can't be decided until we finish the whole concatenation.
585 So, we record strings that have text properties to be copied
586 here, and copy the text properties after the concatenation. */
587 struct textprop_rec
*textprops
= NULL
;
588 /* Number of elements in textprops. */
589 ptrdiff_t num_textprops
= 0;
594 /* In append, the last arg isn't treated like the others */
595 if (last_special
&& nargs
> 0)
598 last_tail
= args
[nargs
];
603 /* Check each argument. */
604 for (argnum
= 0; argnum
< nargs
; argnum
++)
607 if (!(CONSP (this) || NILP (this) || VECTORP (this) || STRINGP (this)
608 || COMPILEDP (this) || BOOL_VECTOR_P (this)))
609 wrong_type_argument (Qsequencep
, this);
612 /* Compute total length in chars of arguments in RESULT_LEN.
613 If desired output is a string, also compute length in bytes
614 in RESULT_LEN_BYTE, and determine in SOME_MULTIBYTE
615 whether the result should be a multibyte string. */
619 for (argnum
= 0; argnum
< nargs
; argnum
++)
623 len
= XFASTINT (Flength (this));
624 if (target_type
== Lisp_String
)
626 /* We must count the number of bytes needed in the string
627 as well as the number of characters. */
631 ptrdiff_t this_len_byte
;
633 if (VECTORP (this) || COMPILEDP (this))
634 for (i
= 0; i
< len
; i
++)
637 CHECK_CHARACTER (ch
);
639 this_len_byte
= CHAR_BYTES (c
);
640 if (STRING_BYTES_BOUND
- result_len_byte
< this_len_byte
)
642 result_len_byte
+= this_len_byte
;
643 if (! ASCII_CHAR_P (c
) && ! CHAR_BYTE8_P (c
))
646 else if (BOOL_VECTOR_P (this) && bool_vector_size (this) > 0)
647 wrong_type_argument (Qintegerp
, Faref (this, make_number (0)));
648 else if (CONSP (this))
649 for (; CONSP (this); this = XCDR (this))
652 CHECK_CHARACTER (ch
);
654 this_len_byte
= CHAR_BYTES (c
);
655 if (STRING_BYTES_BOUND
- result_len_byte
< this_len_byte
)
657 result_len_byte
+= this_len_byte
;
658 if (! ASCII_CHAR_P (c
) && ! CHAR_BYTE8_P (c
))
661 else if (STRINGP (this))
663 if (STRING_MULTIBYTE (this))
666 this_len_byte
= SBYTES (this);
669 this_len_byte
= count_size_as_multibyte (SDATA (this),
671 if (STRING_BYTES_BOUND
- result_len_byte
< this_len_byte
)
673 result_len_byte
+= this_len_byte
;
678 if (MOST_POSITIVE_FIXNUM
< result_len
)
679 memory_full (SIZE_MAX
);
682 if (! some_multibyte
)
683 result_len_byte
= result_len
;
685 /* Create the output object. */
686 if (target_type
== Lisp_Cons
)
687 val
= Fmake_list (make_number (result_len
), Qnil
);
688 else if (target_type
== Lisp_Vectorlike
)
689 val
= Fmake_vector (make_number (result_len
), Qnil
);
690 else if (some_multibyte
)
691 val
= make_uninit_multibyte_string (result_len
, result_len_byte
);
693 val
= make_uninit_string (result_len
);
695 /* In `append', if all but last arg are nil, return last arg. */
696 if (target_type
== Lisp_Cons
&& EQ (val
, Qnil
))
699 /* Copy the contents of the args into the result. */
701 tail
= val
, toindex
= -1; /* -1 in toindex is flag we are making a list */
703 toindex
= 0, toindex_byte
= 0;
707 SAFE_NALLOCA (textprops
, 1, nargs
);
709 for (argnum
= 0; argnum
< nargs
; argnum
++)
712 ptrdiff_t thisleni
= 0;
713 register ptrdiff_t thisindex
= 0;
714 register ptrdiff_t thisindex_byte
= 0;
718 thislen
= Flength (this), thisleni
= XINT (thislen
);
720 /* Between strings of the same kind, copy fast. */
721 if (STRINGP (this) && STRINGP (val
)
722 && STRING_MULTIBYTE (this) == some_multibyte
)
724 ptrdiff_t thislen_byte
= SBYTES (this);
726 memcpy (SDATA (val
) + toindex_byte
, SDATA (this), SBYTES (this));
727 if (string_intervals (this))
729 textprops
[num_textprops
].argnum
= argnum
;
730 textprops
[num_textprops
].from
= 0;
731 textprops
[num_textprops
++].to
= toindex
;
733 toindex_byte
+= thislen_byte
;
736 /* Copy a single-byte string to a multibyte string. */
737 else if (STRINGP (this) && STRINGP (val
))
739 if (string_intervals (this))
741 textprops
[num_textprops
].argnum
= argnum
;
742 textprops
[num_textprops
].from
= 0;
743 textprops
[num_textprops
++].to
= toindex
;
745 toindex_byte
+= copy_text (SDATA (this),
746 SDATA (val
) + toindex_byte
,
747 SCHARS (this), 0, 1);
751 /* Copy element by element. */
754 register Lisp_Object elt
;
756 /* Fetch next element of `this' arg into `elt', or break if
757 `this' is exhausted. */
758 if (NILP (this)) break;
760 elt
= XCAR (this), this = XCDR (this);
761 else if (thisindex
>= thisleni
)
763 else if (STRINGP (this))
766 if (STRING_MULTIBYTE (this))
767 FETCH_STRING_CHAR_ADVANCE_NO_CHECK (c
, this,
772 c
= SREF (this, thisindex
); thisindex
++;
773 if (some_multibyte
&& !ASCII_CHAR_P (c
))
774 c
= BYTE8_TO_CHAR (c
);
776 XSETFASTINT (elt
, c
);
778 else if (BOOL_VECTOR_P (this))
780 elt
= bool_vector_ref (this, thisindex
);
785 elt
= AREF (this, thisindex
);
789 /* Store this element into the result. */
796 else if (VECTORP (val
))
798 ASET (val
, toindex
, elt
);
804 CHECK_CHARACTER (elt
);
807 toindex_byte
+= CHAR_STRING (c
, SDATA (val
) + toindex_byte
);
809 SSET (val
, toindex_byte
++, c
);
815 XSETCDR (prev
, last_tail
);
817 if (num_textprops
> 0)
820 ptrdiff_t last_to_end
= -1;
822 for (argnum
= 0; argnum
< num_textprops
; argnum
++)
824 this = args
[textprops
[argnum
].argnum
];
825 props
= text_property_list (this,
827 make_number (SCHARS (this)),
829 /* If successive arguments have properties, be sure that the
830 value of `composition' property be the copy. */
831 if (last_to_end
== textprops
[argnum
].to
)
832 make_composition_value_copy (props
);
833 add_text_properties_from_list (val
, props
,
834 make_number (textprops
[argnum
].to
));
835 last_to_end
= textprops
[argnum
].to
+ SCHARS (this);
843 static Lisp_Object string_char_byte_cache_string
;
844 static ptrdiff_t string_char_byte_cache_charpos
;
845 static ptrdiff_t string_char_byte_cache_bytepos
;
848 clear_string_char_byte_cache (void)
850 string_char_byte_cache_string
= Qnil
;
853 /* Return the byte index corresponding to CHAR_INDEX in STRING. */
856 string_char_to_byte (Lisp_Object string
, ptrdiff_t char_index
)
859 ptrdiff_t best_below
, best_below_byte
;
860 ptrdiff_t best_above
, best_above_byte
;
862 best_below
= best_below_byte
= 0;
863 best_above
= SCHARS (string
);
864 best_above_byte
= SBYTES (string
);
865 if (best_above
== best_above_byte
)
868 if (EQ (string
, string_char_byte_cache_string
))
870 if (string_char_byte_cache_charpos
< char_index
)
872 best_below
= string_char_byte_cache_charpos
;
873 best_below_byte
= string_char_byte_cache_bytepos
;
877 best_above
= string_char_byte_cache_charpos
;
878 best_above_byte
= string_char_byte_cache_bytepos
;
882 if (char_index
- best_below
< best_above
- char_index
)
884 unsigned char *p
= SDATA (string
) + best_below_byte
;
886 while (best_below
< char_index
)
888 p
+= BYTES_BY_CHAR_HEAD (*p
);
891 i_byte
= p
- SDATA (string
);
895 unsigned char *p
= SDATA (string
) + best_above_byte
;
897 while (best_above
> char_index
)
900 while (!CHAR_HEAD_P (*p
)) p
--;
903 i_byte
= p
- SDATA (string
);
906 string_char_byte_cache_bytepos
= i_byte
;
907 string_char_byte_cache_charpos
= char_index
;
908 string_char_byte_cache_string
= string
;
913 /* Return the character index corresponding to BYTE_INDEX in STRING. */
916 string_byte_to_char (Lisp_Object string
, ptrdiff_t byte_index
)
919 ptrdiff_t best_below
, best_below_byte
;
920 ptrdiff_t best_above
, best_above_byte
;
922 best_below
= best_below_byte
= 0;
923 best_above
= SCHARS (string
);
924 best_above_byte
= SBYTES (string
);
925 if (best_above
== best_above_byte
)
928 if (EQ (string
, string_char_byte_cache_string
))
930 if (string_char_byte_cache_bytepos
< byte_index
)
932 best_below
= string_char_byte_cache_charpos
;
933 best_below_byte
= string_char_byte_cache_bytepos
;
937 best_above
= string_char_byte_cache_charpos
;
938 best_above_byte
= string_char_byte_cache_bytepos
;
942 if (byte_index
- best_below_byte
< best_above_byte
- byte_index
)
944 unsigned char *p
= SDATA (string
) + best_below_byte
;
945 unsigned char *pend
= SDATA (string
) + byte_index
;
949 p
+= BYTES_BY_CHAR_HEAD (*p
);
953 i_byte
= p
- SDATA (string
);
957 unsigned char *p
= SDATA (string
) + best_above_byte
;
958 unsigned char *pbeg
= SDATA (string
) + byte_index
;
963 while (!CHAR_HEAD_P (*p
)) p
--;
967 i_byte
= p
- SDATA (string
);
970 string_char_byte_cache_bytepos
= i_byte
;
971 string_char_byte_cache_charpos
= i
;
972 string_char_byte_cache_string
= string
;
977 /* Convert STRING to a multibyte string. */
980 string_make_multibyte (Lisp_Object string
)
987 if (STRING_MULTIBYTE (string
))
990 nbytes
= count_size_as_multibyte (SDATA (string
),
992 /* If all the chars are ASCII, they won't need any more bytes
993 once converted. In that case, we can return STRING itself. */
994 if (nbytes
== SBYTES (string
))
997 buf
= SAFE_ALLOCA (nbytes
);
998 copy_text (SDATA (string
), buf
, SBYTES (string
),
1001 ret
= make_multibyte_string ((char *) buf
, SCHARS (string
), nbytes
);
1008 /* Convert STRING (if unibyte) to a multibyte string without changing
1009 the number of characters. Characters 0200 trough 0237 are
1010 converted to eight-bit characters. */
1013 string_to_multibyte (Lisp_Object string
)
1020 if (STRING_MULTIBYTE (string
))
1023 nbytes
= count_size_as_multibyte (SDATA (string
), SBYTES (string
));
1024 /* If all the chars are ASCII, they won't need any more bytes once
1026 if (nbytes
== SBYTES (string
))
1027 return make_multibyte_string (SSDATA (string
), nbytes
, nbytes
);
1029 buf
= SAFE_ALLOCA (nbytes
);
1030 memcpy (buf
, SDATA (string
), SBYTES (string
));
1031 str_to_multibyte (buf
, nbytes
, SBYTES (string
));
1033 ret
= make_multibyte_string ((char *) buf
, SCHARS (string
), nbytes
);
1040 /* Convert STRING to a single-byte string. */
1043 string_make_unibyte (Lisp_Object string
)
1050 if (! STRING_MULTIBYTE (string
))
1053 nchars
= SCHARS (string
);
1055 buf
= SAFE_ALLOCA (nchars
);
1056 copy_text (SDATA (string
), buf
, SBYTES (string
),
1059 ret
= make_unibyte_string ((char *) buf
, nchars
);
1065 DEFUN ("string-make-multibyte", Fstring_make_multibyte
, Sstring_make_multibyte
,
1067 doc
: /* Return the multibyte equivalent of STRING.
1068 If STRING is unibyte and contains non-ASCII characters, the function
1069 `unibyte-char-to-multibyte' is used to convert each unibyte character
1070 to a multibyte character. In this case, the returned string is a
1071 newly created string with no text properties. If STRING is multibyte
1072 or entirely ASCII, it is returned unchanged. In particular, when
1073 STRING is unibyte and entirely ASCII, the returned string is unibyte.
1074 \(When the characters are all ASCII, Emacs primitives will treat the
1075 string the same way whether it is unibyte or multibyte.) */)
1076 (Lisp_Object string
)
1078 CHECK_STRING (string
);
1080 return string_make_multibyte (string
);
1083 DEFUN ("string-make-unibyte", Fstring_make_unibyte
, Sstring_make_unibyte
,
1085 doc
: /* Return the unibyte equivalent of STRING.
1086 Multibyte character codes are converted to unibyte according to
1087 `nonascii-translation-table' or, if that is nil, `nonascii-insert-offset'.
1088 If the lookup in the translation table fails, this function takes just
1089 the low 8 bits of each character. */)
1090 (Lisp_Object string
)
1092 CHECK_STRING (string
);
1094 return string_make_unibyte (string
);
1097 DEFUN ("string-as-unibyte", Fstring_as_unibyte
, Sstring_as_unibyte
,
1099 doc
: /* Return a unibyte string with the same individual bytes as STRING.
1100 If STRING is unibyte, the result is STRING itself.
1101 Otherwise it is a newly created string, with no text properties.
1102 If STRING is multibyte and contains a character of charset
1103 `eight-bit', it is converted to the corresponding single byte. */)
1104 (Lisp_Object string
)
1106 CHECK_STRING (string
);
1108 if (STRING_MULTIBYTE (string
))
1110 unsigned char *str
= (unsigned char *) xlispstrdup (string
);
1111 ptrdiff_t bytes
= str_as_unibyte (str
, SBYTES (string
));
1113 string
= make_unibyte_string ((char *) str
, bytes
);
1119 DEFUN ("string-as-multibyte", Fstring_as_multibyte
, Sstring_as_multibyte
,
1121 doc
: /* Return a multibyte string with the same individual bytes as STRING.
1122 If STRING is multibyte, the result is STRING itself.
1123 Otherwise it is a newly created string, with no text properties.
1125 If STRING is unibyte and contains an individual 8-bit byte (i.e. not
1126 part of a correct utf-8 sequence), it is converted to the corresponding
1127 multibyte character of charset `eight-bit'.
1128 See also `string-to-multibyte'.
1130 Beware, this often doesn't really do what you think it does.
1131 It is similar to (decode-coding-string STRING \\='utf-8-emacs).
1132 If you're not sure, whether to use `string-as-multibyte' or
1133 `string-to-multibyte', use `string-to-multibyte'. */)
1134 (Lisp_Object string
)
1136 CHECK_STRING (string
);
1138 if (! STRING_MULTIBYTE (string
))
1140 Lisp_Object new_string
;
1141 ptrdiff_t nchars
, nbytes
;
1143 parse_str_as_multibyte (SDATA (string
),
1146 new_string
= make_uninit_multibyte_string (nchars
, nbytes
);
1147 memcpy (SDATA (new_string
), SDATA (string
), SBYTES (string
));
1148 if (nbytes
!= SBYTES (string
))
1149 str_as_multibyte (SDATA (new_string
), nbytes
,
1150 SBYTES (string
), NULL
);
1151 string
= new_string
;
1152 set_string_intervals (string
, NULL
);
1157 DEFUN ("string-to-multibyte", Fstring_to_multibyte
, Sstring_to_multibyte
,
1159 doc
: /* Return a multibyte string with the same individual chars as STRING.
1160 If STRING is multibyte, the result is STRING itself.
1161 Otherwise it is a newly created string, with no text properties.
1163 If STRING is unibyte and contains an 8-bit byte, it is converted to
1164 the corresponding multibyte character of charset `eight-bit'.
1166 This differs from `string-as-multibyte' by converting each byte of a correct
1167 utf-8 sequence to an eight-bit character, not just bytes that don't form a
1168 correct sequence. */)
1169 (Lisp_Object string
)
1171 CHECK_STRING (string
);
1173 return string_to_multibyte (string
);
1176 DEFUN ("string-to-unibyte", Fstring_to_unibyte
, Sstring_to_unibyte
,
1178 doc
: /* Return a unibyte string with the same individual chars as STRING.
1179 If STRING is unibyte, the result is STRING itself.
1180 Otherwise it is a newly created string, with no text properties,
1181 where each `eight-bit' character is converted to the corresponding byte.
1182 If STRING contains a non-ASCII, non-`eight-bit' character,
1183 an error is signaled. */)
1184 (Lisp_Object string
)
1186 CHECK_STRING (string
);
1188 if (STRING_MULTIBYTE (string
))
1190 ptrdiff_t chars
= SCHARS (string
);
1191 unsigned char *str
= xmalloc (chars
);
1192 ptrdiff_t converted
= str_to_unibyte (SDATA (string
), str
, chars
);
1194 if (converted
< chars
)
1195 error ("Can't convert the %"pD
"dth character to unibyte", converted
);
1196 string
= make_unibyte_string ((char *) str
, chars
);
1203 DEFUN ("copy-alist", Fcopy_alist
, Scopy_alist
, 1, 1, 0,
1204 doc
: /* Return a copy of ALIST.
1205 This is an alist which represents the same mapping from objects to objects,
1206 but does not share the alist structure with ALIST.
1207 The objects mapped (cars and cdrs of elements of the alist)
1208 are shared, however.
1209 Elements of ALIST that are not conses are also shared. */)
1214 alist
= concat (1, &alist
, Lisp_Cons
, false);
1215 for (Lisp_Object tem
= alist
; !NILP (tem
); tem
= XCDR (tem
))
1217 Lisp_Object car
= XCAR (tem
);
1219 XSETCAR (tem
, Fcons (XCAR (car
), XCDR (car
)));
1224 /* Check that ARRAY can have a valid subarray [FROM..TO),
1225 given that its size is SIZE.
1226 If FROM is nil, use 0; if TO is nil, use SIZE.
1227 Count negative values backwards from the end.
1228 Set *IFROM and *ITO to the two indexes used. */
1231 validate_subarray (Lisp_Object array
, Lisp_Object from
, Lisp_Object to
,
1232 ptrdiff_t size
, ptrdiff_t *ifrom
, ptrdiff_t *ito
)
1236 if (INTEGERP (from
))
1242 else if (NILP (from
))
1245 wrong_type_argument (Qintegerp
, from
);
1256 wrong_type_argument (Qintegerp
, to
);
1258 if (! (0 <= f
&& f
<= t
&& t
<= size
))
1259 args_out_of_range_3 (array
, from
, to
);
1265 DEFUN ("substring", Fsubstring
, Ssubstring
, 1, 3, 0,
1266 doc
: /* Return a new string whose contents are a substring of STRING.
1267 The returned string consists of the characters between index FROM
1268 \(inclusive) and index TO (exclusive) of STRING. FROM and TO are
1269 zero-indexed: 0 means the first character of STRING. Negative values
1270 are counted from the end of STRING. If TO is nil, the substring runs
1271 to the end of STRING.
1273 The STRING argument may also be a vector. In that case, the return
1274 value is a new vector that contains the elements between index FROM
1275 \(inclusive) and index TO (exclusive) of that vector argument.
1277 With one argument, just copy STRING (with properties, if any). */)
1278 (Lisp_Object string
, Lisp_Object from
, Lisp_Object to
)
1281 ptrdiff_t size
, ifrom
, ito
;
1283 size
= CHECK_VECTOR_OR_STRING (string
);
1284 validate_subarray (string
, from
, to
, size
, &ifrom
, &ito
);
1286 if (STRINGP (string
))
1289 = !ifrom
? 0 : string_char_to_byte (string
, ifrom
);
1291 = ito
== size
? SBYTES (string
) : string_char_to_byte (string
, ito
);
1292 res
= make_specified_string (SSDATA (string
) + from_byte
,
1293 ito
- ifrom
, to_byte
- from_byte
,
1294 STRING_MULTIBYTE (string
));
1295 copy_text_properties (make_number (ifrom
), make_number (ito
),
1296 string
, make_number (0), res
, Qnil
);
1299 res
= Fvector (ito
- ifrom
, aref_addr (string
, ifrom
));
1305 DEFUN ("substring-no-properties", Fsubstring_no_properties
, Ssubstring_no_properties
, 1, 3, 0,
1306 doc
: /* Return a substring of STRING, without text properties.
1307 It starts at index FROM and ends before TO.
1308 TO may be nil or omitted; then the substring runs to the end of STRING.
1309 If FROM is nil or omitted, the substring starts at the beginning of STRING.
1310 If FROM or TO is negative, it counts from the end.
1312 With one argument, just copy STRING without its properties. */)
1313 (Lisp_Object string
, register Lisp_Object from
, Lisp_Object to
)
1315 ptrdiff_t from_char
, to_char
, from_byte
, to_byte
, size
;
1317 CHECK_STRING (string
);
1319 size
= SCHARS (string
);
1320 validate_subarray (string
, from
, to
, size
, &from_char
, &to_char
);
1322 from_byte
= !from_char
? 0 : string_char_to_byte (string
, from_char
);
1324 to_char
== size
? SBYTES (string
) : string_char_to_byte (string
, to_char
);
1325 return make_specified_string (SSDATA (string
) + from_byte
,
1326 to_char
- from_char
, to_byte
- from_byte
,
1327 STRING_MULTIBYTE (string
));
1330 /* Extract a substring of STRING, giving start and end positions
1331 both in characters and in bytes. */
1334 substring_both (Lisp_Object string
, ptrdiff_t from
, ptrdiff_t from_byte
,
1335 ptrdiff_t to
, ptrdiff_t to_byte
)
1338 ptrdiff_t size
= CHECK_VECTOR_OR_STRING (string
);
1340 if (!(0 <= from
&& from
<= to
&& to
<= size
))
1341 args_out_of_range_3 (string
, make_number (from
), make_number (to
));
1343 if (STRINGP (string
))
1345 res
= make_specified_string (SSDATA (string
) + from_byte
,
1346 to
- from
, to_byte
- from_byte
,
1347 STRING_MULTIBYTE (string
));
1348 copy_text_properties (make_number (from
), make_number (to
),
1349 string
, make_number (0), res
, Qnil
);
1352 res
= Fvector (to
- from
, aref_addr (string
, from
));
1357 DEFUN ("nthcdr", Fnthcdr
, Snthcdr
, 2, 2, 0,
1358 doc
: /* Take cdr N times on LIST, return the result. */)
1359 (Lisp_Object n
, Lisp_Object list
)
1362 EMACS_INT num
= XINT (n
);
1363 Lisp_Object tail
= list
;
1364 immediate_quit
= true;
1365 for (EMACS_INT i
= 0; i
< num
; i
++)
1369 immediate_quit
= false;
1370 CHECK_LIST_END (tail
, list
);
1375 immediate_quit
= false;
1379 DEFUN ("nth", Fnth
, Snth
, 2, 2, 0,
1380 doc
: /* Return the Nth element of LIST.
1381 N counts from zero. If LIST is not that long, nil is returned. */)
1382 (Lisp_Object n
, Lisp_Object list
)
1384 return Fcar (Fnthcdr (n
, list
));
1387 DEFUN ("elt", Felt
, Selt
, 2, 2, 0,
1388 doc
: /* Return element of SEQUENCE at index N. */)
1389 (register Lisp_Object sequence
, Lisp_Object n
)
1392 if (CONSP (sequence
) || NILP (sequence
))
1393 return Fcar (Fnthcdr (n
, sequence
));
1395 /* Faref signals a "not array" error, so check here. */
1396 CHECK_ARRAY (sequence
, Qsequencep
);
1397 return Faref (sequence
, n
);
1400 DEFUN ("member", Fmember
, Smember
, 2, 2, 0,
1401 doc
: /* Return non-nil if ELT is an element of LIST. Comparison done with `equal'.
1402 The value is actually the tail of LIST whose car is ELT. */)
1403 (Lisp_Object elt
, Lisp_Object list
)
1405 unsigned short int quit_count
= 0;
1407 for (tail
= list
; CONSP (tail
); tail
= XCDR (tail
))
1409 if (! NILP (Fequal (elt
, XCAR (tail
))))
1411 rarely_quit (&quit_count
);
1413 CHECK_LIST_END (tail
, list
);
1417 DEFUN ("memq", Fmemq
, Smemq
, 2, 2, 0,
1418 doc
: /* Return non-nil if ELT is an element of LIST. Comparison done with `eq'.
1419 The value is actually the tail of LIST whose car is ELT. */)
1420 (Lisp_Object elt
, Lisp_Object list
)
1422 immediate_quit
= true;
1424 for (tail
= list
; CONSP (tail
); tail
= XCDR (tail
))
1426 if (EQ (XCAR (tail
), elt
))
1428 immediate_quit
= false;
1432 immediate_quit
= false;
1433 CHECK_LIST_END (tail
, list
);
1437 DEFUN ("memql", Fmemql
, Smemql
, 2, 2, 0,
1438 doc
: /* Return non-nil if ELT is an element of LIST. Comparison done with `eql'.
1439 The value is actually the tail of LIST whose car is ELT. */)
1440 (Lisp_Object elt
, Lisp_Object list
)
1443 return Fmemq (elt
, list
);
1445 immediate_quit
= true;
1447 for (tail
= list
; CONSP (tail
); tail
= XCDR (tail
))
1449 Lisp_Object tem
= XCAR (tail
);
1450 if (FLOATP (tem
) && internal_equal (elt
, tem
, 0, 0, Qnil
))
1452 immediate_quit
= false;
1456 immediate_quit
= false;
1457 CHECK_LIST_END (tail
, list
);
1461 DEFUN ("assq", Fassq
, Sassq
, 2, 2, 0,
1462 doc
: /* Return non-nil if KEY is `eq' to the car of an element of LIST.
1463 The value is actually the first element of LIST whose car is KEY.
1464 Elements of LIST that are not conses are ignored. */)
1465 (Lisp_Object key
, Lisp_Object list
)
1467 immediate_quit
= true;
1469 for (tail
= list
; CONSP (tail
); tail
= XCDR (tail
))
1470 if (CONSP (XCAR (tail
)) && EQ (XCAR (XCAR (tail
)), key
))
1472 immediate_quit
= false;
1475 immediate_quit
= false;
1476 CHECK_LIST_END (tail
, list
);
1480 /* Like Fassq but never report an error and do not allow quits.
1481 Use only on objects known to be non-circular lists. */
1484 assq_no_quit (Lisp_Object key
, Lisp_Object list
)
1486 for (; ! NILP (list
); list
= XCDR (list
))
1487 if (CONSP (XCAR (list
)) && EQ (XCAR (XCAR (list
)), key
))
1492 DEFUN ("assoc", Fassoc
, Sassoc
, 2, 2, 0,
1493 doc
: /* Return non-nil if KEY is `equal' to the car of an element of LIST.
1494 The value is actually the first element of LIST whose car equals KEY. */)
1495 (Lisp_Object key
, Lisp_Object list
)
1497 unsigned short int quit_count
= 0;
1499 for (tail
= list
; CONSP (tail
); tail
= XCDR (tail
))
1501 Lisp_Object car
= XCAR (tail
);
1503 && (EQ (XCAR (car
), key
) || !NILP (Fequal (XCAR (car
), key
))))
1505 rarely_quit (&quit_count
);
1507 CHECK_LIST_END (tail
, list
);
1511 /* Like Fassoc but never report an error and do not allow quits.
1512 Use only on objects known to be non-circular lists. */
1515 assoc_no_quit (Lisp_Object key
, Lisp_Object list
)
1517 for (; ! NILP (list
); list
= XCDR (list
))
1519 Lisp_Object car
= XCAR (list
);
1521 && (EQ (XCAR (car
), key
) || !NILP (Fequal (XCAR (car
), key
))))
1527 DEFUN ("rassq", Frassq
, Srassq
, 2, 2, 0,
1528 doc
: /* Return non-nil if KEY is `eq' to the cdr of an element of LIST.
1529 The value is actually the first element of LIST whose cdr is KEY. */)
1530 (Lisp_Object key
, Lisp_Object list
)
1532 immediate_quit
= true;
1534 for (tail
= list
; CONSP (tail
); tail
= XCDR (tail
))
1535 if (CONSP (XCAR (tail
)) && EQ (XCDR (XCAR (tail
)), key
))
1537 immediate_quit
= false;
1540 immediate_quit
= false;
1541 CHECK_LIST_END (tail
, list
);
1545 DEFUN ("rassoc", Frassoc
, Srassoc
, 2, 2, 0,
1546 doc
: /* Return non-nil if KEY is `equal' to the cdr of an element of LIST.
1547 The value is actually the first element of LIST whose cdr equals KEY. */)
1548 (Lisp_Object key
, Lisp_Object list
)
1550 unsigned short int quit_count
= 0;
1552 for (tail
= list
; CONSP (tail
); tail
= XCDR (tail
))
1554 Lisp_Object car
= XCAR (tail
);
1556 && (EQ (XCDR (car
), key
) || !NILP (Fequal (XCDR (car
), key
))))
1558 rarely_quit (&quit_count
);
1560 CHECK_LIST_END (tail
, list
);
1564 DEFUN ("delq", Fdelq
, Sdelq
, 2, 2, 0,
1565 doc
: /* Delete members of LIST which are `eq' to ELT, and return the result.
1566 More precisely, this function skips any members `eq' to ELT at the
1567 front of LIST, then removes members `eq' to ELT from the remaining
1568 sublist by modifying its list structure, then returns the resulting
1571 Write `(setq foo (delq element foo))' to be sure of correctly changing
1572 the value of a list `foo'. See also `remq', which does not modify the
1574 (register Lisp_Object elt
, Lisp_Object list
)
1576 Lisp_Object tail
, tortoise
, prev
= Qnil
;
1579 FOR_EACH_TAIL (tail
, list
, tortoise
, skip
)
1581 Lisp_Object tem
= XCAR (tail
);
1587 Fsetcdr (prev
, XCDR (tail
));
1592 CHECK_LIST_END (tail
, list
);
1596 DEFUN ("delete", Fdelete
, Sdelete
, 2, 2, 0,
1597 doc
: /* Delete members of SEQ which are `equal' to ELT, and return the result.
1598 SEQ must be a sequence (i.e. a list, a vector, or a string).
1599 The return value is a sequence of the same type.
1601 If SEQ is a list, this behaves like `delq', except that it compares
1602 with `equal' instead of `eq'. In particular, it may remove elements
1603 by altering the list structure.
1605 If SEQ is not a list, deletion is never performed destructively;
1606 instead this function creates and returns a new vector or string.
1608 Write `(setq foo (delete element foo))' to be sure of correctly
1609 changing the value of a sequence `foo'. */)
1610 (Lisp_Object elt
, Lisp_Object seq
)
1616 for (i
= n
= 0; i
< ASIZE (seq
); ++i
)
1617 if (NILP (Fequal (AREF (seq
, i
), elt
)))
1620 if (n
!= ASIZE (seq
))
1622 struct Lisp_Vector
*p
= allocate_vector (n
);
1624 for (i
= n
= 0; i
< ASIZE (seq
); ++i
)
1625 if (NILP (Fequal (AREF (seq
, i
), elt
)))
1626 p
->contents
[n
++] = AREF (seq
, i
);
1628 XSETVECTOR (seq
, p
);
1631 else if (STRINGP (seq
))
1633 ptrdiff_t i
, ibyte
, nchars
, nbytes
, cbytes
;
1636 for (i
= nchars
= nbytes
= ibyte
= 0;
1638 ++i
, ibyte
+= cbytes
)
1640 if (STRING_MULTIBYTE (seq
))
1642 c
= STRING_CHAR (SDATA (seq
) + ibyte
);
1643 cbytes
= CHAR_BYTES (c
);
1651 if (!INTEGERP (elt
) || c
!= XINT (elt
))
1658 if (nchars
!= SCHARS (seq
))
1662 tem
= make_uninit_multibyte_string (nchars
, nbytes
);
1663 if (!STRING_MULTIBYTE (seq
))
1664 STRING_SET_UNIBYTE (tem
);
1666 for (i
= nchars
= nbytes
= ibyte
= 0;
1668 ++i
, ibyte
+= cbytes
)
1670 if (STRING_MULTIBYTE (seq
))
1672 c
= STRING_CHAR (SDATA (seq
) + ibyte
);
1673 cbytes
= CHAR_BYTES (c
);
1681 if (!INTEGERP (elt
) || c
!= XINT (elt
))
1683 unsigned char *from
= SDATA (seq
) + ibyte
;
1684 unsigned char *to
= SDATA (tem
) + nbytes
;
1690 for (n
= cbytes
; n
--; )
1700 unsigned short int quit_count
= 0;
1701 Lisp_Object tail
, prev
;
1703 for (tail
= seq
, prev
= Qnil
; CONSP (tail
); tail
= XCDR (tail
))
1705 if (!NILP (Fequal (elt
, XCAR (tail
))))
1710 Fsetcdr (prev
, XCDR (tail
));
1714 rarely_quit (&quit_count
);
1716 CHECK_LIST_END (tail
, seq
);
1722 DEFUN ("nreverse", Fnreverse
, Snreverse
, 1, 1, 0,
1723 doc
: /* Reverse order of items in a list, vector or string SEQ.
1724 If SEQ is a list, it should be nil-terminated.
1725 This function may destructively modify SEQ to produce the value. */)
1730 else if (STRINGP (seq
))
1731 return Freverse (seq
);
1732 else if (CONSP (seq
))
1734 unsigned short int quit_count
= 0;
1735 Lisp_Object prev
, tail
, next
;
1737 for (prev
= Qnil
, tail
= seq
; CONSP (tail
); tail
= next
)
1739 rarely_quit (&quit_count
);
1741 Fsetcdr (tail
, prev
);
1744 CHECK_LIST_END (tail
, seq
);
1747 else if (VECTORP (seq
))
1749 ptrdiff_t i
, size
= ASIZE (seq
);
1751 for (i
= 0; i
< size
/ 2; i
++)
1753 Lisp_Object tem
= AREF (seq
, i
);
1754 ASET (seq
, i
, AREF (seq
, size
- i
- 1));
1755 ASET (seq
, size
- i
- 1, tem
);
1758 else if (BOOL_VECTOR_P (seq
))
1760 ptrdiff_t i
, size
= bool_vector_size (seq
);
1762 for (i
= 0; i
< size
/ 2; i
++)
1764 bool tem
= bool_vector_bitref (seq
, i
);
1765 bool_vector_set (seq
, i
, bool_vector_bitref (seq
, size
- i
- 1));
1766 bool_vector_set (seq
, size
- i
- 1, tem
);
1770 wrong_type_argument (Qarrayp
, seq
);
1774 DEFUN ("reverse", Freverse
, Sreverse
, 1, 1, 0,
1775 doc
: /* Return the reversed copy of list, vector, or string SEQ.
1776 See also the function `nreverse', which is used more often. */)
1783 else if (CONSP (seq
))
1785 unsigned short int quit_count
= 0;
1786 for (new = Qnil
; CONSP (seq
); seq
= XCDR (seq
))
1788 rarely_quit (&quit_count
);
1789 new = Fcons (XCAR (seq
), new);
1791 CHECK_LIST_END (seq
, seq
);
1793 else if (VECTORP (seq
))
1795 ptrdiff_t i
, size
= ASIZE (seq
);
1797 new = make_uninit_vector (size
);
1798 for (i
= 0; i
< size
; i
++)
1799 ASET (new, i
, AREF (seq
, size
- i
- 1));
1801 else if (BOOL_VECTOR_P (seq
))
1804 EMACS_INT nbits
= bool_vector_size (seq
);
1806 new = make_uninit_bool_vector (nbits
);
1807 for (i
= 0; i
< nbits
; i
++)
1808 bool_vector_set (new, i
, bool_vector_bitref (seq
, nbits
- i
- 1));
1810 else if (STRINGP (seq
))
1812 ptrdiff_t size
= SCHARS (seq
), bytes
= SBYTES (seq
);
1818 new = make_uninit_string (size
);
1819 for (i
= 0; i
< size
; i
++)
1820 SSET (new, i
, SREF (seq
, size
- i
- 1));
1824 unsigned char *p
, *q
;
1826 new = make_uninit_multibyte_string (size
, bytes
);
1827 p
= SDATA (seq
), q
= SDATA (new) + bytes
;
1828 while (q
> SDATA (new))
1832 ch
= STRING_CHAR_AND_LENGTH (p
, len
);
1834 CHAR_STRING (ch
, q
);
1839 wrong_type_argument (Qsequencep
, seq
);
1843 /* Sort LIST using PREDICATE, preserving original order of elements
1844 considered as equal. */
1847 sort_list (Lisp_Object list
, Lisp_Object predicate
)
1849 Lisp_Object front
, back
;
1850 Lisp_Object len
, tem
;
1854 len
= Flength (list
);
1855 length
= XINT (len
);
1859 XSETINT (len
, (length
/ 2) - 1);
1860 tem
= Fnthcdr (len
, list
);
1862 Fsetcdr (tem
, Qnil
);
1864 front
= Fsort (front
, predicate
);
1865 back
= Fsort (back
, predicate
);
1866 return merge (front
, back
, predicate
);
1869 /* Using PRED to compare, return whether A and B are in order.
1870 Compare stably when A appeared before B in the input. */
1872 inorder (Lisp_Object pred
, Lisp_Object a
, Lisp_Object b
)
1874 return NILP (call2 (pred
, b
, a
));
1877 /* Using PRED to compare, merge from ALEN-length A and BLEN-length B
1878 into DEST. Argument arrays must be nonempty and must not overlap,
1879 except that B might be the last part of DEST. */
1881 merge_vectors (Lisp_Object pred
,
1882 ptrdiff_t alen
, Lisp_Object
const a
[restrict
VLA_ELEMS (alen
)],
1883 ptrdiff_t blen
, Lisp_Object
const b
[VLA_ELEMS (blen
)],
1884 Lisp_Object dest
[VLA_ELEMS (alen
+ blen
)])
1886 eassume (0 < alen
&& 0 < blen
);
1887 Lisp_Object
const *alim
= a
+ alen
;
1888 Lisp_Object
const *blim
= b
+ blen
;
1892 if (inorder (pred
, a
[0], b
[0]))
1898 memcpy (dest
, b
, (blim
- b
) * sizeof *dest
);
1907 memcpy (dest
, a
, (alim
- a
) * sizeof *dest
);
1914 /* Using PRED to compare, sort LEN-length VEC in place, using TMP for
1915 temporary storage. LEN must be at least 2. */
1917 sort_vector_inplace (Lisp_Object pred
, ptrdiff_t len
,
1918 Lisp_Object vec
[restrict
VLA_ELEMS (len
)],
1919 Lisp_Object tmp
[restrict
VLA_ELEMS (len
>> 1)])
1922 ptrdiff_t halflen
= len
>> 1;
1923 sort_vector_copy (pred
, halflen
, vec
, tmp
);
1924 if (1 < len
- halflen
)
1925 sort_vector_inplace (pred
, len
- halflen
, vec
+ halflen
, vec
);
1926 merge_vectors (pred
, halflen
, tmp
, len
- halflen
, vec
+ halflen
, vec
);
1929 /* Using PRED to compare, sort from LEN-length SRC into DST.
1930 Len must be positive. */
1932 sort_vector_copy (Lisp_Object pred
, ptrdiff_t len
,
1933 Lisp_Object src
[restrict
VLA_ELEMS (len
)],
1934 Lisp_Object dest
[restrict
VLA_ELEMS (len
)])
1937 ptrdiff_t halflen
= len
>> 1;
1943 sort_vector_inplace (pred
, halflen
, src
, dest
);
1944 if (1 < len
- halflen
)
1945 sort_vector_inplace (pred
, len
- halflen
, src
+ halflen
, dest
);
1946 merge_vectors (pred
, halflen
, src
, len
- halflen
, src
+ halflen
, dest
);
1950 /* Sort VECTOR in place using PREDICATE, preserving original order of
1951 elements considered as equal. */
1954 sort_vector (Lisp_Object vector
, Lisp_Object predicate
)
1956 ptrdiff_t len
= ASIZE (vector
);
1959 ptrdiff_t halflen
= len
>> 1;
1962 SAFE_ALLOCA_LISP (tmp
, halflen
);
1963 for (ptrdiff_t i
= 0; i
< halflen
; i
++)
1964 tmp
[i
] = make_number (0);
1965 sort_vector_inplace (predicate
, len
, XVECTOR (vector
)->contents
, tmp
);
1969 DEFUN ("sort", Fsort
, Ssort
, 2, 2, 0,
1970 doc
: /* Sort SEQ, stably, comparing elements using PREDICATE.
1971 Returns the sorted sequence. SEQ should be a list or vector. SEQ is
1972 modified by side effects. PREDICATE is called with two elements of
1973 SEQ, and should return non-nil if the first element should sort before
1975 (Lisp_Object seq
, Lisp_Object predicate
)
1978 seq
= sort_list (seq
, predicate
);
1979 else if (VECTORP (seq
))
1980 sort_vector (seq
, predicate
);
1981 else if (!NILP (seq
))
1982 wrong_type_argument (Qsequencep
, seq
);
1987 merge (Lisp_Object org_l1
, Lisp_Object org_l2
, Lisp_Object pred
)
1989 Lisp_Object l1
= org_l1
;
1990 Lisp_Object l2
= org_l2
;
1991 Lisp_Object tail
= Qnil
;
1992 Lisp_Object value
= Qnil
;
2012 if (inorder (pred
, Fcar (l1
), Fcar (l2
)))
2027 Fsetcdr (tail
, tem
);
2033 /* This does not check for quits. That is safe since it must terminate. */
2035 DEFUN ("plist-get", Fplist_get
, Splist_get
, 2, 2, 0,
2036 doc
: /* Extract a value from a property list.
2037 PLIST is a property list, which is a list of the form
2038 \(PROP1 VALUE1 PROP2 VALUE2...). This function returns the value
2039 corresponding to the given PROP, or nil if PROP is not one of the
2040 properties on the list. This function never signals an error. */)
2041 (Lisp_Object plist
, Lisp_Object prop
)
2043 Lisp_Object tail
, halftail
;
2045 /* halftail is used to detect circular lists. */
2046 tail
= halftail
= plist
;
2047 while (CONSP (tail
) && CONSP (XCDR (tail
)))
2049 if (EQ (prop
, XCAR (tail
)))
2050 return XCAR (XCDR (tail
));
2052 tail
= XCDR (XCDR (tail
));
2053 halftail
= XCDR (halftail
);
2054 if (EQ (tail
, halftail
))
2061 DEFUN ("get", Fget
, Sget
, 2, 2, 0,
2062 doc
: /* Return the value of SYMBOL's PROPNAME property.
2063 This is the last value stored with `(put SYMBOL PROPNAME VALUE)'. */)
2064 (Lisp_Object symbol
, Lisp_Object propname
)
2066 CHECK_SYMBOL (symbol
);
2067 return Fplist_get (XSYMBOL (symbol
)->plist
, propname
);
2070 DEFUN ("plist-put", Fplist_put
, Splist_put
, 3, 3, 0,
2071 doc
: /* Change value in PLIST of PROP to VAL.
2072 PLIST is a property list, which is a list of the form
2073 \(PROP1 VALUE1 PROP2 VALUE2 ...). PROP is a symbol and VAL is any object.
2074 If PROP is already a property on the list, its value is set to VAL,
2075 otherwise the new PROP VAL pair is added. The new plist is returned;
2076 use `(setq x (plist-put x prop val))' to be sure to use the new value.
2077 The PLIST is modified by side effects. */)
2078 (Lisp_Object plist
, Lisp_Object prop
, Lisp_Object val
)
2080 immediate_quit
= true;
2081 Lisp_Object prev
= Qnil
;
2082 for (Lisp_Object tail
= plist
; CONSP (tail
) && CONSP (XCDR (tail
));
2083 tail
= XCDR (XCDR (tail
)))
2085 if (EQ (prop
, XCAR (tail
)))
2087 immediate_quit
= false;
2088 Fsetcar (XCDR (tail
), val
);
2094 immediate_quit
= false;
2096 = Fcons (prop
, Fcons (val
, NILP (prev
) ? plist
: XCDR (XCDR (prev
))));
2099 Fsetcdr (XCDR (prev
), newcell
);
2103 DEFUN ("put", Fput
, Sput
, 3, 3, 0,
2104 doc
: /* Store SYMBOL's PROPNAME property with value VALUE.
2105 It can be retrieved with `(get SYMBOL PROPNAME)'. */)
2106 (Lisp_Object symbol
, Lisp_Object propname
, Lisp_Object value
)
2108 CHECK_SYMBOL (symbol
);
2110 (symbol
, Fplist_put (XSYMBOL (symbol
)->plist
, propname
, value
));
2114 DEFUN ("lax-plist-get", Flax_plist_get
, Slax_plist_get
, 2, 2, 0,
2115 doc
: /* Extract a value from a property list, comparing with `equal'.
2116 PLIST is a property list, which is a list of the form
2117 \(PROP1 VALUE1 PROP2 VALUE2...). This function returns the value
2118 corresponding to the given PROP, or nil if PROP is not
2119 one of the properties on the list. */)
2120 (Lisp_Object plist
, Lisp_Object prop
)
2122 unsigned short int quit_count
= 0;
2126 CONSP (tail
) && CONSP (XCDR (tail
));
2127 tail
= XCDR (XCDR (tail
)))
2129 if (! NILP (Fequal (prop
, XCAR (tail
))))
2130 return XCAR (XCDR (tail
));
2131 rarely_quit (&quit_count
);
2134 CHECK_LIST_END (tail
, prop
);
2139 DEFUN ("lax-plist-put", Flax_plist_put
, Slax_plist_put
, 3, 3, 0,
2140 doc
: /* Change value in PLIST of PROP to VAL, comparing with `equal'.
2141 PLIST is a property list, which is a list of the form
2142 \(PROP1 VALUE1 PROP2 VALUE2 ...). PROP and VAL are any objects.
2143 If PROP is already a property on the list, its value is set to VAL,
2144 otherwise the new PROP VAL pair is added. The new plist is returned;
2145 use `(setq x (lax-plist-put x prop val))' to be sure to use the new value.
2146 The PLIST is modified by side effects. */)
2147 (Lisp_Object plist
, Lisp_Object prop
, Lisp_Object val
)
2149 unsigned short int quit_count
= 0;
2150 Lisp_Object prev
= Qnil
;
2151 for (Lisp_Object tail
= plist
; CONSP (tail
) && CONSP (XCDR (tail
));
2152 tail
= XCDR (XCDR (tail
)))
2154 if (! NILP (Fequal (prop
, XCAR (tail
))))
2156 Fsetcar (XCDR (tail
), val
);
2161 rarely_quit (&quit_count
);
2163 Lisp_Object newcell
= list2 (prop
, val
);
2166 Fsetcdr (XCDR (prev
), newcell
);
2170 DEFUN ("eql", Feql
, Seql
, 2, 2, 0,
2171 doc
: /* Return t if the two args are the same Lisp object.
2172 Floating-point numbers of equal value are `eql', but they may not be `eq'. */)
2173 (Lisp_Object obj1
, Lisp_Object obj2
)
2176 return internal_equal (obj1
, obj2
, 0, 0, Qnil
) ? Qt
: Qnil
;
2178 return EQ (obj1
, obj2
) ? Qt
: Qnil
;
2181 DEFUN ("equal", Fequal
, Sequal
, 2, 2, 0,
2182 doc
: /* Return t if two Lisp objects have similar structure and contents.
2183 They must have the same data type.
2184 Conses are compared by comparing the cars and the cdrs.
2185 Vectors and strings are compared element by element.
2186 Numbers are compared by value, but integers cannot equal floats.
2187 (Use `=' if you want integers and floats to be able to be equal.)
2188 Symbols must match exactly. */)
2189 (register Lisp_Object o1
, Lisp_Object o2
)
2191 return internal_equal (o1
, o2
, 0, 0, Qnil
) ? Qt
: Qnil
;
2194 DEFUN ("equal-including-properties", Fequal_including_properties
, Sequal_including_properties
, 2, 2, 0,
2195 doc
: /* Return t if two Lisp objects have similar structure and contents.
2196 This is like `equal' except that it compares the text properties
2197 of strings. (`equal' ignores text properties.) */)
2198 (register Lisp_Object o1
, Lisp_Object o2
)
2200 return internal_equal (o1
, o2
, 0, 1, Qnil
) ? Qt
: Qnil
;
2203 /* DEPTH is current depth of recursion. Signal an error if it
2205 PROPS means compare string text properties too. */
2208 internal_equal (Lisp_Object o1
, Lisp_Object o2
, int depth
, bool props
,
2214 error ("Stack overflow in equal");
2216 ht
= CALLN (Fmake_hash_table
, QCtest
, Qeq
);
2219 case Lisp_Cons
: case Lisp_Misc
: case Lisp_Vectorlike
:
2221 struct Lisp_Hash_Table
*h
= XHASH_TABLE (ht
);
2223 ptrdiff_t i
= hash_lookup (h
, o1
, &hash
);
2225 { /* `o1' was seen already. */
2226 Lisp_Object o2s
= HASH_VALUE (h
, i
);
2227 if (!NILP (Fmemq (o2
, o2s
)))
2230 set_hash_value_slot (h
, i
, Fcons (o2
, o2s
));
2233 hash_put (h
, o1
, Fcons (o2
, Qnil
), hash
);
2239 unsigned short int quit_count
= 0;
2241 rarely_quit (&quit_count
);
2244 if (XTYPE (o1
) != XTYPE (o2
))
2253 d1
= extract_float (o1
);
2254 d2
= extract_float (o2
);
2255 /* If d is a NaN, then d != d. Two NaNs should be `equal' even
2256 though they are not =. */
2257 return d1
== d2
|| (d1
!= d1
&& d2
!= d2
);
2261 if (!internal_equal (XCAR (o1
), XCAR (o2
), depth
+ 1, props
, ht
))
2265 /* FIXME: This inf-loops in a circular list! */
2269 if (XMISCTYPE (o1
) != XMISCTYPE (o2
))
2273 if (!internal_equal (OVERLAY_START (o1
), OVERLAY_START (o2
),
2274 depth
+ 1, props
, ht
)
2275 || !internal_equal (OVERLAY_END (o1
), OVERLAY_END (o2
),
2276 depth
+ 1, props
, ht
))
2278 o1
= XOVERLAY (o1
)->plist
;
2279 o2
= XOVERLAY (o2
)->plist
;
2284 return (XMARKER (o1
)->buffer
== XMARKER (o2
)->buffer
2285 && (XMARKER (o1
)->buffer
== 0
2286 || XMARKER (o1
)->bytepos
== XMARKER (o2
)->bytepos
));
2290 case Lisp_Vectorlike
:
2293 ptrdiff_t size
= ASIZE (o1
);
2294 /* Pseudovectors have the type encoded in the size field, so this test
2295 actually checks that the objects have the same type as well as the
2297 if (ASIZE (o2
) != size
)
2299 /* Boolvectors are compared much like strings. */
2300 if (BOOL_VECTOR_P (o1
))
2302 EMACS_INT size
= bool_vector_size (o1
);
2303 if (size
!= bool_vector_size (o2
))
2305 if (memcmp (bool_vector_data (o1
), bool_vector_data (o2
),
2306 bool_vector_bytes (size
)))
2310 if (WINDOW_CONFIGURATIONP (o1
))
2311 return compare_window_configurations (o1
, o2
, 0);
2313 /* Aside from them, only true vectors, char-tables, compiled
2314 functions, and fonts (font-spec, font-entity, font-object)
2315 are sensible to compare, so eliminate the others now. */
2316 if (size
& PSEUDOVECTOR_FLAG
)
2318 if (((size
& PVEC_TYPE_MASK
) >> PSEUDOVECTOR_AREA_BITS
)
2321 size
&= PSEUDOVECTOR_SIZE_MASK
;
2323 for (i
= 0; i
< size
; i
++)
2328 if (!internal_equal (v1
, v2
, depth
+ 1, props
, ht
))
2336 if (SCHARS (o1
) != SCHARS (o2
))
2338 if (SBYTES (o1
) != SBYTES (o2
))
2340 if (memcmp (SDATA (o1
), SDATA (o2
), SBYTES (o1
)))
2342 if (props
&& !compare_string_intervals (o1
, o2
))
2354 DEFUN ("fillarray", Ffillarray
, Sfillarray
, 2, 2, 0,
2355 doc
: /* Store each element of ARRAY with ITEM.
2356 ARRAY is a vector, string, char-table, or bool-vector. */)
2357 (Lisp_Object array
, Lisp_Object item
)
2359 register ptrdiff_t size
, idx
;
2361 if (VECTORP (array
))
2362 for (idx
= 0, size
= ASIZE (array
); idx
< size
; idx
++)
2363 ASET (array
, idx
, item
);
2364 else if (CHAR_TABLE_P (array
))
2368 for (i
= 0; i
< (1 << CHARTAB_SIZE_BITS_0
); i
++)
2369 set_char_table_contents (array
, i
, item
);
2370 set_char_table_defalt (array
, item
);
2372 else if (STRINGP (array
))
2374 register unsigned char *p
= SDATA (array
);
2376 CHECK_CHARACTER (item
);
2377 charval
= XFASTINT (item
);
2378 size
= SCHARS (array
);
2379 if (STRING_MULTIBYTE (array
))
2381 unsigned char str
[MAX_MULTIBYTE_LENGTH
];
2382 int len
= CHAR_STRING (charval
, str
);
2383 ptrdiff_t size_byte
= SBYTES (array
);
2386 if (INT_MULTIPLY_WRAPV (size
, len
, &product
) || product
!= size_byte
)
2387 error ("Attempt to change byte length of a string");
2388 for (idx
= 0; idx
< size_byte
; idx
++)
2389 *p
++ = str
[idx
% len
];
2392 for (idx
= 0; idx
< size
; idx
++)
2395 else if (BOOL_VECTOR_P (array
))
2396 return bool_vector_fill (array
, item
);
2398 wrong_type_argument (Qarrayp
, array
);
2402 DEFUN ("clear-string", Fclear_string
, Sclear_string
,
2404 doc
: /* Clear the contents of STRING.
2405 This makes STRING unibyte and may change its length. */)
2406 (Lisp_Object string
)
2409 CHECK_STRING (string
);
2410 len
= SBYTES (string
);
2411 memset (SDATA (string
), 0, len
);
2412 STRING_SET_CHARS (string
, len
);
2413 STRING_SET_UNIBYTE (string
);
2419 nconc2 (Lisp_Object s1
, Lisp_Object s2
)
2421 return CALLN (Fnconc
, s1
, s2
);
2424 DEFUN ("nconc", Fnconc
, Snconc
, 0, MANY
, 0,
2425 doc
: /* Concatenate any number of lists by altering them.
2426 Only the last argument is not altered, and need not be a list.
2427 usage: (nconc &rest LISTS) */)
2428 (ptrdiff_t nargs
, Lisp_Object
*args
)
2430 unsigned short int quit_count
= 0;
2431 Lisp_Object val
= Qnil
;
2433 for (ptrdiff_t argnum
= 0; argnum
< nargs
; argnum
++)
2435 Lisp_Object tem
= args
[argnum
];
2436 if (NILP (tem
)) continue;
2441 if (argnum
+ 1 == nargs
) break;
2445 immediate_quit
= true;
2452 while (CONSP (tem
));
2454 immediate_quit
= false;
2455 rarely_quit (&quit_count
);
2457 tem
= args
[argnum
+ 1];
2458 Fsetcdr (tail
, tem
);
2460 args
[argnum
+ 1] = tail
;
2466 /* This is the guts of all mapping functions.
2467 Apply FN to each element of SEQ, one by one, storing the results
2468 into elements of VALS, a C vector of Lisp_Objects. LENI is the
2469 length of VALS, which should also be the length of SEQ. Return the
2470 number of results; although this is normally LENI, it can be less
2471 if SEQ is made shorter as a side effect of FN. */
2474 mapcar1 (EMACS_INT leni
, Lisp_Object
*vals
, Lisp_Object fn
, Lisp_Object seq
)
2476 Lisp_Object tail
, dummy
;
2479 if (VECTORP (seq
) || COMPILEDP (seq
))
2481 for (i
= 0; i
< leni
; i
++)
2483 dummy
= call1 (fn
, AREF (seq
, i
));
2488 else if (BOOL_VECTOR_P (seq
))
2490 for (i
= 0; i
< leni
; i
++)
2492 dummy
= call1 (fn
, bool_vector_ref (seq
, i
));
2497 else if (STRINGP (seq
))
2501 for (i
= 0, i_byte
= 0; i
< leni
;)
2504 ptrdiff_t i_before
= i
;
2506 FETCH_STRING_CHAR_ADVANCE (c
, seq
, i
, i_byte
);
2507 XSETFASTINT (dummy
, c
);
2508 dummy
= call1 (fn
, dummy
);
2510 vals
[i_before
] = dummy
;
2513 else /* Must be a list, since Flength did not get an error */
2516 for (i
= 0; i
< leni
; i
++)
2520 dummy
= call1 (fn
, XCAR (tail
));
2530 DEFUN ("mapconcat", Fmapconcat
, Smapconcat
, 3, 3, 0,
2531 doc
: /* Apply FUNCTION to each element of SEQUENCE, and concat the results as strings.
2532 In between each pair of results, stick in SEPARATOR. Thus, " " as
2533 SEPARATOR results in spaces between the values returned by FUNCTION.
2534 SEQUENCE may be a list, a vector, a bool-vector, or a string. */)
2535 (Lisp_Object function
, Lisp_Object sequence
, Lisp_Object separator
)
2538 EMACS_INT leni
= XFASTINT (Flength (sequence
));
2539 if (CHAR_TABLE_P (sequence
))
2540 wrong_type_argument (Qlistp
, sequence
);
2541 EMACS_INT args_alloc
= 2 * leni
- 1;
2543 return empty_unibyte_string
;
2545 SAFE_ALLOCA_LISP (args
, args_alloc
);
2546 ptrdiff_t nmapped
= mapcar1 (leni
, args
, function
, sequence
);
2547 ptrdiff_t nargs
= 2 * nmapped
- 1;
2549 for (ptrdiff_t i
= nmapped
- 1; i
> 0; i
--)
2550 args
[i
+ i
] = args
[i
];
2552 for (ptrdiff_t i
= 1; i
< nargs
; i
+= 2)
2553 args
[i
] = separator
;
2555 Lisp_Object ret
= Fconcat (nargs
, args
);
2560 DEFUN ("mapcar", Fmapcar
, Smapcar
, 2, 2, 0,
2561 doc
: /* Apply FUNCTION to each element of SEQUENCE, and make a list of the results.
2562 The result is a list just as long as SEQUENCE.
2563 SEQUENCE may be a list, a vector, a bool-vector, or a string. */)
2564 (Lisp_Object function
, Lisp_Object sequence
)
2567 EMACS_INT leni
= XFASTINT (Flength (sequence
));
2568 if (CHAR_TABLE_P (sequence
))
2569 wrong_type_argument (Qlistp
, sequence
);
2571 SAFE_ALLOCA_LISP (args
, leni
);
2572 ptrdiff_t nmapped
= mapcar1 (leni
, args
, function
, sequence
);
2573 Lisp_Object ret
= Flist (nmapped
, args
);
2578 DEFUN ("mapc", Fmapc
, Smapc
, 2, 2, 0,
2579 doc
: /* Apply FUNCTION to each element of SEQUENCE for side effects only.
2580 Unlike `mapcar', don't accumulate the results. Return SEQUENCE.
2581 SEQUENCE may be a list, a vector, a bool-vector, or a string. */)
2582 (Lisp_Object function
, Lisp_Object sequence
)
2584 register EMACS_INT leni
;
2586 leni
= XFASTINT (Flength (sequence
));
2587 if (CHAR_TABLE_P (sequence
))
2588 wrong_type_argument (Qlistp
, sequence
);
2589 mapcar1 (leni
, 0, function
, sequence
);
2594 DEFUN ("mapcan", Fmapcan
, Smapcan
, 2, 2, 0,
2595 doc
: /* Apply FUNCTION to each element of SEQUENCE, and concatenate
2596 the results by altering them (using `nconc').
2597 SEQUENCE may be a list, a vector, a bool-vector, or a string. */)
2598 (Lisp_Object function
, Lisp_Object sequence
)
2601 EMACS_INT leni
= XFASTINT (Flength (sequence
));
2602 if (CHAR_TABLE_P (sequence
))
2603 wrong_type_argument (Qlistp
, sequence
);
2605 SAFE_ALLOCA_LISP (args
, leni
);
2606 ptrdiff_t nmapped
= mapcar1 (leni
, args
, function
, sequence
);
2607 Lisp_Object ret
= Fnconc (nmapped
, args
);
2612 /* This is how C code calls `yes-or-no-p' and allows the user
2616 do_yes_or_no_p (Lisp_Object prompt
)
2618 return call1 (intern ("yes-or-no-p"), prompt
);
2621 DEFUN ("yes-or-no-p", Fyes_or_no_p
, Syes_or_no_p
, 1, 1, 0,
2622 doc
: /* Ask user a yes-or-no question.
2623 Return t if answer is yes, and nil if the answer is no.
2624 PROMPT is the string to display to ask the question. It should end in
2625 a space; `yes-or-no-p' adds \"(yes or no) \" to it.
2627 The user must confirm the answer with RET, and can edit it until it
2630 If dialog boxes are supported, a dialog box will be used
2631 if `last-nonmenu-event' is nil, and `use-dialog-box' is non-nil. */)
2632 (Lisp_Object prompt
)
2636 CHECK_STRING (prompt
);
2638 if ((NILP (last_nonmenu_event
) || CONSP (last_nonmenu_event
))
2639 && use_dialog_box
&& ! NILP (last_input_event
))
2641 Lisp_Object pane
, menu
, obj
;
2642 redisplay_preserve_echo_area (4);
2643 pane
= list2 (Fcons (build_string ("Yes"), Qt
),
2644 Fcons (build_string ("No"), Qnil
));
2645 menu
= Fcons (prompt
, pane
);
2646 obj
= Fx_popup_dialog (Qt
, menu
, Qnil
);
2650 AUTO_STRING (yes_or_no
, "(yes or no) ");
2651 prompt
= CALLN (Fconcat
, prompt
, yes_or_no
);
2655 ans
= Fdowncase (Fread_from_minibuffer (prompt
, Qnil
, Qnil
, Qnil
,
2656 Qyes_or_no_p_history
, Qnil
,
2658 if (SCHARS (ans
) == 3 && !strcmp (SSDATA (ans
), "yes"))
2660 if (SCHARS (ans
) == 2 && !strcmp (SSDATA (ans
), "no"))
2665 message1 ("Please answer yes or no.");
2666 Fsleep_for (make_number (2), Qnil
);
2670 DEFUN ("load-average", Fload_average
, Sload_average
, 0, 1, 0,
2671 doc
: /* Return list of 1 minute, 5 minute and 15 minute load averages.
2673 Each of the three load averages is multiplied by 100, then converted
2676 When USE-FLOATS is non-nil, floats will be used instead of integers.
2677 These floats are not multiplied by 100.
2679 If the 5-minute or 15-minute load averages are not available, return a
2680 shortened list, containing only those averages which are available.
2682 An error is thrown if the load average can't be obtained. In some
2683 cases making it work would require Emacs being installed setuid or
2684 setgid so that it can read kernel information, and that usually isn't
2686 (Lisp_Object use_floats
)
2689 int loads
= getloadavg (load_ave
, 3);
2690 Lisp_Object ret
= Qnil
;
2693 error ("load-average not implemented for this operating system");
2697 Lisp_Object load
= (NILP (use_floats
)
2698 ? make_number (100.0 * load_ave
[loads
])
2699 : make_float (load_ave
[loads
]));
2700 ret
= Fcons (load
, ret
);
2706 DEFUN ("featurep", Ffeaturep
, Sfeaturep
, 1, 2, 0,
2707 doc
: /* Return t if FEATURE is present in this Emacs.
2709 Use this to conditionalize execution of lisp code based on the
2710 presence or absence of Emacs or environment extensions.
2711 Use `provide' to declare that a feature is available. This function
2712 looks at the value of the variable `features'. The optional argument
2713 SUBFEATURE can be used to check a specific subfeature of FEATURE. */)
2714 (Lisp_Object feature
, Lisp_Object subfeature
)
2716 register Lisp_Object tem
;
2717 CHECK_SYMBOL (feature
);
2718 tem
= Fmemq (feature
, Vfeatures
);
2719 if (!NILP (tem
) && !NILP (subfeature
))
2720 tem
= Fmember (subfeature
, Fget (feature
, Qsubfeatures
));
2721 return (NILP (tem
)) ? Qnil
: Qt
;
2724 DEFUN ("provide", Fprovide
, Sprovide
, 1, 2, 0,
2725 doc
: /* Announce that FEATURE is a feature of the current Emacs.
2726 The optional argument SUBFEATURES should be a list of symbols listing
2727 particular subfeatures supported in this version of FEATURE. */)
2728 (Lisp_Object feature
, Lisp_Object subfeatures
)
2730 register Lisp_Object tem
;
2731 CHECK_SYMBOL (feature
);
2732 CHECK_LIST (subfeatures
);
2733 if (!NILP (Vautoload_queue
))
2734 Vautoload_queue
= Fcons (Fcons (make_number (0), Vfeatures
),
2736 tem
= Fmemq (feature
, Vfeatures
);
2738 Vfeatures
= Fcons (feature
, Vfeatures
);
2739 if (!NILP (subfeatures
))
2740 Fput (feature
, Qsubfeatures
, subfeatures
);
2741 LOADHIST_ATTACH (Fcons (Qprovide
, feature
));
2743 /* Run any load-hooks for this file. */
2744 tem
= Fassq (feature
, Vafter_load_alist
);
2746 Fmapc (Qfuncall
, XCDR (tem
));
2751 /* `require' and its subroutines. */
2753 /* List of features currently being require'd, innermost first. */
2755 static Lisp_Object require_nesting_list
;
2758 require_unwind (Lisp_Object old_value
)
2760 require_nesting_list
= old_value
;
2763 DEFUN ("require", Frequire
, Srequire
, 1, 3, 0,
2764 doc
: /* If feature FEATURE is not loaded, load it from FILENAME.
2765 If FEATURE is not a member of the list `features', then the feature is
2766 not loaded; so load the file FILENAME.
2768 If FILENAME is omitted, the printname of FEATURE is used as the file
2769 name, and `load' will try to load this name appended with the suffix
2770 `.elc', `.el', or the system-dependent suffix for dynamic module
2771 files, in that order. The name without appended suffix will not be
2772 used. See `get-load-suffixes' for the complete list of suffixes.
2774 The directories in `load-path' are searched when trying to find the
2777 If the optional third argument NOERROR is non-nil, then return nil if
2778 the file is not found instead of signaling an error. Normally the
2779 return value is FEATURE.
2781 The normal messages at start and end of loading FILENAME are
2783 (Lisp_Object feature
, Lisp_Object filename
, Lisp_Object noerror
)
2786 bool from_file
= load_in_progress
;
2788 CHECK_SYMBOL (feature
);
2790 /* Record the presence of `require' in this file
2791 even if the feature specified is already loaded.
2792 But not more than once in any file,
2793 and not when we aren't loading or reading from a file. */
2795 for (tem
= Vcurrent_load_list
; CONSP (tem
); tem
= XCDR (tem
))
2796 if (NILP (XCDR (tem
)) && STRINGP (XCAR (tem
)))
2801 tem
= Fcons (Qrequire
, feature
);
2802 if (NILP (Fmember (tem
, Vcurrent_load_list
)))
2803 LOADHIST_ATTACH (tem
);
2805 tem
= Fmemq (feature
, Vfeatures
);
2809 ptrdiff_t count
= SPECPDL_INDEX ();
2812 /* This is to make sure that loadup.el gives a clear picture
2813 of what files are preloaded and when. */
2814 if (! NILP (Vpurify_flag
))
2815 error ("(require %s) while preparing to dump",
2816 SDATA (SYMBOL_NAME (feature
)));
2818 /* A certain amount of recursive `require' is legitimate,
2819 but if we require the same feature recursively 3 times,
2821 tem
= require_nesting_list
;
2822 while (! NILP (tem
))
2824 if (! NILP (Fequal (feature
, XCAR (tem
))))
2829 error ("Recursive `require' for feature `%s'",
2830 SDATA (SYMBOL_NAME (feature
)));
2832 /* Update the list for any nested `require's that occur. */
2833 record_unwind_protect (require_unwind
, require_nesting_list
);
2834 require_nesting_list
= Fcons (feature
, require_nesting_list
);
2836 /* Value saved here is to be restored into Vautoload_queue */
2837 record_unwind_protect (un_autoload
, Vautoload_queue
);
2838 Vautoload_queue
= Qt
;
2840 /* Load the file. */
2841 tem
= Fload (NILP (filename
) ? Fsymbol_name (feature
) : filename
,
2842 noerror
, Qt
, Qnil
, (NILP (filename
) ? Qt
: Qnil
));
2844 /* If load failed entirely, return nil. */
2846 return unbind_to (count
, Qnil
);
2848 tem
= Fmemq (feature
, Vfeatures
);
2850 error ("Required feature `%s' was not provided",
2851 SDATA (SYMBOL_NAME (feature
)));
2853 /* Once loading finishes, don't undo it. */
2854 Vautoload_queue
= Qt
;
2855 feature
= unbind_to (count
, feature
);
2861 /* Primitives for work of the "widget" library.
2862 In an ideal world, this section would not have been necessary.
2863 However, lisp function calls being as slow as they are, it turns
2864 out that some functions in the widget library (wid-edit.el) are the
2865 bottleneck of Widget operation. Here is their translation to C,
2866 for the sole reason of efficiency. */
2868 DEFUN ("plist-member", Fplist_member
, Splist_member
, 2, 2, 0,
2869 doc
: /* Return non-nil if PLIST has the property PROP.
2870 PLIST is a property list, which is a list of the form
2871 \(PROP1 VALUE1 PROP2 VALUE2 ...). PROP is a symbol.
2872 Unlike `plist-get', this allows you to distinguish between a missing
2873 property and a property with the value nil.
2874 The value is actually the tail of PLIST whose car is PROP. */)
2875 (Lisp_Object plist
, Lisp_Object prop
)
2877 immediate_quit
= true;
2878 while (CONSP (plist
) && !EQ (XCAR (plist
), prop
))
2880 plist
= XCDR (plist
);
2881 plist
= CDR (plist
);
2883 immediate_quit
= false;
2887 DEFUN ("widget-put", Fwidget_put
, Swidget_put
, 3, 3, 0,
2888 doc
: /* In WIDGET, set PROPERTY to VALUE.
2889 The value can later be retrieved with `widget-get'. */)
2890 (Lisp_Object widget
, Lisp_Object property
, Lisp_Object value
)
2892 CHECK_CONS (widget
);
2893 XSETCDR (widget
, Fplist_put (XCDR (widget
), property
, value
));
2897 DEFUN ("widget-get", Fwidget_get
, Swidget_get
, 2, 2, 0,
2898 doc
: /* In WIDGET, get the value of PROPERTY.
2899 The value could either be specified when the widget was created, or
2900 later with `widget-put'. */)
2901 (Lisp_Object widget
, Lisp_Object property
)
2909 CHECK_CONS (widget
);
2910 tmp
= Fplist_member (XCDR (widget
), property
);
2916 tmp
= XCAR (widget
);
2919 widget
= Fget (tmp
, Qwidget_type
);
2923 DEFUN ("widget-apply", Fwidget_apply
, Swidget_apply
, 2, MANY
, 0,
2924 doc
: /* Apply the value of WIDGET's PROPERTY to the widget itself.
2925 ARGS are passed as extra arguments to the function.
2926 usage: (widget-apply WIDGET PROPERTY &rest ARGS) */)
2927 (ptrdiff_t nargs
, Lisp_Object
*args
)
2929 Lisp_Object widget
= args
[0];
2930 Lisp_Object property
= args
[1];
2931 Lisp_Object propval
= Fwidget_get (widget
, property
);
2932 Lisp_Object trailing_args
= Flist (nargs
- 2, args
+ 2);
2933 Lisp_Object result
= CALLN (Fapply
, propval
, widget
, trailing_args
);
2937 #ifdef HAVE_LANGINFO_CODESET
2938 #include <langinfo.h>
2941 DEFUN ("locale-info", Flocale_info
, Slocale_info
, 1, 1, 0,
2942 doc
: /* Access locale data ITEM for the current C locale, if available.
2943 ITEM should be one of the following:
2945 `codeset', returning the character set as a string (locale item CODESET);
2947 `days', returning a 7-element vector of day names (locale items DAY_n);
2949 `months', returning a 12-element vector of month names (locale items MON_n);
2951 `paper', returning a list (WIDTH HEIGHT) for the default paper size,
2952 both measured in millimeters (locale items PAPER_WIDTH, PAPER_HEIGHT).
2954 If the system can't provide such information through a call to
2955 `nl_langinfo', or if ITEM isn't from the list above, return nil.
2957 See also Info node `(libc)Locales'.
2959 The data read from the system are decoded using `locale-coding-system'. */)
2963 #ifdef HAVE_LANGINFO_CODESET
2964 if (EQ (item
, Qcodeset
))
2966 str
= nl_langinfo (CODESET
);
2967 return build_string (str
);
2970 else if (EQ (item
, Qdays
)) /* e.g. for calendar-day-name-array */
2972 Lisp_Object v
= Fmake_vector (make_number (7), Qnil
);
2973 const int days
[7] = {DAY_1
, DAY_2
, DAY_3
, DAY_4
, DAY_5
, DAY_6
, DAY_7
};
2975 synchronize_system_time_locale ();
2976 for (i
= 0; i
< 7; i
++)
2978 str
= nl_langinfo (days
[i
]);
2979 AUTO_STRING (val
, str
);
2980 /* Fixme: Is this coding system necessarily right, even if
2981 it is consistent with CODESET? If not, what to do? */
2982 ASET (v
, i
, code_convert_string_norecord (val
, Vlocale_coding_system
,
2989 else if (EQ (item
, Qmonths
)) /* e.g. for calendar-month-name-array */
2991 Lisp_Object v
= Fmake_vector (make_number (12), Qnil
);
2992 const int months
[12] = {MON_1
, MON_2
, MON_3
, MON_4
, MON_5
, MON_6
, MON_7
,
2993 MON_8
, MON_9
, MON_10
, MON_11
, MON_12
};
2995 synchronize_system_time_locale ();
2996 for (i
= 0; i
< 12; i
++)
2998 str
= nl_langinfo (months
[i
]);
2999 AUTO_STRING (val
, str
);
3000 ASET (v
, i
, code_convert_string_norecord (val
, Vlocale_coding_system
,
3006 /* LC_PAPER stuff isn't defined as accessible in glibc as of 2.3.1,
3007 but is in the locale files. This could be used by ps-print. */
3009 else if (EQ (item
, Qpaper
))
3010 return list2i (nl_langinfo (PAPER_WIDTH
), nl_langinfo (PAPER_HEIGHT
));
3011 #endif /* PAPER_WIDTH */
3012 #endif /* HAVE_LANGINFO_CODESET*/
3016 /* base64 encode/decode functions (RFC 2045).
3017 Based on code from GNU recode. */
3019 #define MIME_LINE_LENGTH 76
3021 #define IS_ASCII(Character) \
3023 #define IS_BASE64(Character) \
3024 (IS_ASCII (Character) && base64_char_to_value[Character] >= 0)
3025 #define IS_BASE64_IGNORABLE(Character) \
3026 ((Character) == ' ' || (Character) == '\t' || (Character) == '\n' \
3027 || (Character) == '\f' || (Character) == '\r')
3029 /* Used by base64_decode_1 to retrieve a non-base64-ignorable
3030 character or return retval if there are no characters left to
3032 #define READ_QUADRUPLET_BYTE(retval) \
3037 if (nchars_return) \
3038 *nchars_return = nchars; \
3043 while (IS_BASE64_IGNORABLE (c))
3045 /* Table of characters coding the 64 values. */
3046 static const char base64_value_to_char
[64] =
3048 'A', 'B', 'C', 'D', 'E', 'F', 'G', 'H', 'I', 'J', /* 0- 9 */
3049 'K', 'L', 'M', 'N', 'O', 'P', 'Q', 'R', 'S', 'T', /* 10-19 */
3050 'U', 'V', 'W', 'X', 'Y', 'Z', 'a', 'b', 'c', 'd', /* 20-29 */
3051 'e', 'f', 'g', 'h', 'i', 'j', 'k', 'l', 'm', 'n', /* 30-39 */
3052 'o', 'p', 'q', 'r', 's', 't', 'u', 'v', 'w', 'x', /* 40-49 */
3053 'y', 'z', '0', '1', '2', '3', '4', '5', '6', '7', /* 50-59 */
3054 '8', '9', '+', '/' /* 60-63 */
3057 /* Table of base64 values for first 128 characters. */
3058 static const short base64_char_to_value
[128] =
3060 -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, /* 0- 9 */
3061 -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, /* 10- 19 */
3062 -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, /* 20- 29 */
3063 -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, /* 30- 39 */
3064 -1, -1, -1, 62, -1, -1, -1, 63, 52, 53, /* 40- 49 */
3065 54, 55, 56, 57, 58, 59, 60, 61, -1, -1, /* 50- 59 */
3066 -1, -1, -1, -1, -1, 0, 1, 2, 3, 4, /* 60- 69 */
3067 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, /* 70- 79 */
3068 15, 16, 17, 18, 19, 20, 21, 22, 23, 24, /* 80- 89 */
3069 25, -1, -1, -1, -1, -1, -1, 26, 27, 28, /* 90- 99 */
3070 29, 30, 31, 32, 33, 34, 35, 36, 37, 38, /* 100-109 */
3071 39, 40, 41, 42, 43, 44, 45, 46, 47, 48, /* 110-119 */
3072 49, 50, 51, -1, -1, -1, -1, -1 /* 120-127 */
3075 /* The following diagram shows the logical steps by which three octets
3076 get transformed into four base64 characters.
3078 .--------. .--------. .--------.
3079 |aaaaaabb| |bbbbcccc| |ccdddddd|
3080 `--------' `--------' `--------'
3082 .--------+--------+--------+--------.
3083 |00aaaaaa|00bbbbbb|00cccccc|00dddddd|
3084 `--------+--------+--------+--------'
3086 .--------+--------+--------+--------.
3087 |AAAAAAAA|BBBBBBBB|CCCCCCCC|DDDDDDDD|
3088 `--------+--------+--------+--------'
3090 The octets are divided into 6 bit chunks, which are then encoded into
3091 base64 characters. */
3094 static ptrdiff_t base64_encode_1 (const char *, char *, ptrdiff_t, bool, bool);
3095 static ptrdiff_t base64_decode_1 (const char *, char *, ptrdiff_t, bool,
3098 DEFUN ("base64-encode-region", Fbase64_encode_region
, Sbase64_encode_region
,
3100 doc
: /* Base64-encode the region between BEG and END.
3101 Return the length of the encoded text.
3102 Optional third argument NO-LINE-BREAK means do not break long lines
3103 into shorter lines. */)
3104 (Lisp_Object beg
, Lisp_Object end
, Lisp_Object no_line_break
)
3107 ptrdiff_t allength
, length
;
3108 ptrdiff_t ibeg
, iend
, encoded_length
;
3109 ptrdiff_t old_pos
= PT
;
3112 validate_region (&beg
, &end
);
3114 ibeg
= CHAR_TO_BYTE (XFASTINT (beg
));
3115 iend
= CHAR_TO_BYTE (XFASTINT (end
));
3116 move_gap_both (XFASTINT (beg
), ibeg
);
3118 /* We need to allocate enough room for encoding the text.
3119 We need 33 1/3% more space, plus a newline every 76
3120 characters, and then we round up. */
3121 length
= iend
- ibeg
;
3122 allength
= length
+ length
/3 + 1;
3123 allength
+= allength
/ MIME_LINE_LENGTH
+ 1 + 6;
3125 encoded
= SAFE_ALLOCA (allength
);
3126 encoded_length
= base64_encode_1 ((char *) BYTE_POS_ADDR (ibeg
),
3127 encoded
, length
, NILP (no_line_break
),
3128 !NILP (BVAR (current_buffer
, enable_multibyte_characters
)));
3129 if (encoded_length
> allength
)
3132 if (encoded_length
< 0)
3134 /* The encoding wasn't possible. */
3136 error ("Multibyte character in data for base64 encoding");
3139 /* Now we have encoded the region, so we insert the new contents
3140 and delete the old. (Insert first in order to preserve markers.) */
3141 SET_PT_BOTH (XFASTINT (beg
), ibeg
);
3142 insert (encoded
, encoded_length
);
3144 del_range_byte (ibeg
+ encoded_length
, iend
+ encoded_length
);
3146 /* If point was outside of the region, restore it exactly; else just
3147 move to the beginning of the region. */
3148 if (old_pos
>= XFASTINT (end
))
3149 old_pos
+= encoded_length
- (XFASTINT (end
) - XFASTINT (beg
));
3150 else if (old_pos
> XFASTINT (beg
))
3151 old_pos
= XFASTINT (beg
);
3154 /* We return the length of the encoded text. */
3155 return make_number (encoded_length
);
3158 DEFUN ("base64-encode-string", Fbase64_encode_string
, Sbase64_encode_string
,
3160 doc
: /* Base64-encode STRING and return the result.
3161 Optional second argument NO-LINE-BREAK means do not break long lines
3162 into shorter lines. */)
3163 (Lisp_Object string
, Lisp_Object no_line_break
)
3165 ptrdiff_t allength
, length
, encoded_length
;
3167 Lisp_Object encoded_string
;
3170 CHECK_STRING (string
);
3172 /* We need to allocate enough room for encoding the text.
3173 We need 33 1/3% more space, plus a newline every 76
3174 characters, and then we round up. */
3175 length
= SBYTES (string
);
3176 allength
= length
+ length
/3 + 1;
3177 allength
+= allength
/ MIME_LINE_LENGTH
+ 1 + 6;
3179 /* We need to allocate enough room for decoding the text. */
3180 encoded
= SAFE_ALLOCA (allength
);
3182 encoded_length
= base64_encode_1 (SSDATA (string
),
3183 encoded
, length
, NILP (no_line_break
),
3184 STRING_MULTIBYTE (string
));
3185 if (encoded_length
> allength
)
3188 if (encoded_length
< 0)
3190 /* The encoding wasn't possible. */
3191 error ("Multibyte character in data for base64 encoding");
3194 encoded_string
= make_unibyte_string (encoded
, encoded_length
);
3197 return encoded_string
;
3201 base64_encode_1 (const char *from
, char *to
, ptrdiff_t length
,
3202 bool line_break
, bool multibyte
)
3215 c
= STRING_CHAR_AND_LENGTH ((unsigned char *) from
+ i
, bytes
);
3216 if (CHAR_BYTE8_P (c
))
3217 c
= CHAR_TO_BYTE8 (c
);
3225 /* Wrap line every 76 characters. */
3229 if (counter
< MIME_LINE_LENGTH
/ 4)
3238 /* Process first byte of a triplet. */
3240 *e
++ = base64_value_to_char
[0x3f & c
>> 2];
3241 value
= (0x03 & c
) << 4;
3243 /* Process second byte of a triplet. */
3247 *e
++ = base64_value_to_char
[value
];
3255 c
= STRING_CHAR_AND_LENGTH ((unsigned char *) from
+ i
, bytes
);
3256 if (CHAR_BYTE8_P (c
))
3257 c
= CHAR_TO_BYTE8 (c
);
3265 *e
++ = base64_value_to_char
[value
| (0x0f & c
>> 4)];
3266 value
= (0x0f & c
) << 2;
3268 /* Process third byte of a triplet. */
3272 *e
++ = base64_value_to_char
[value
];
3279 c
= STRING_CHAR_AND_LENGTH ((unsigned char *) from
+ i
, bytes
);
3280 if (CHAR_BYTE8_P (c
))
3281 c
= CHAR_TO_BYTE8 (c
);
3289 *e
++ = base64_value_to_char
[value
| (0x03 & c
>> 6)];
3290 *e
++ = base64_value_to_char
[0x3f & c
];
3297 DEFUN ("base64-decode-region", Fbase64_decode_region
, Sbase64_decode_region
,
3299 doc
: /* Base64-decode the region between BEG and END.
3300 Return the length of the decoded text.
3301 If the region can't be decoded, signal an error and don't modify the buffer. */)
3302 (Lisp_Object beg
, Lisp_Object end
)
3304 ptrdiff_t ibeg
, iend
, length
, allength
;
3306 ptrdiff_t old_pos
= PT
;
3307 ptrdiff_t decoded_length
;
3308 ptrdiff_t inserted_chars
;
3309 bool multibyte
= !NILP (BVAR (current_buffer
, enable_multibyte_characters
));
3312 validate_region (&beg
, &end
);
3314 ibeg
= CHAR_TO_BYTE (XFASTINT (beg
));
3315 iend
= CHAR_TO_BYTE (XFASTINT (end
));
3317 length
= iend
- ibeg
;
3319 /* We need to allocate enough room for decoding the text. If we are
3320 working on a multibyte buffer, each decoded code may occupy at
3322 allength
= multibyte
? length
* 2 : length
;
3323 decoded
= SAFE_ALLOCA (allength
);
3325 move_gap_both (XFASTINT (beg
), ibeg
);
3326 decoded_length
= base64_decode_1 ((char *) BYTE_POS_ADDR (ibeg
),
3328 multibyte
, &inserted_chars
);
3329 if (decoded_length
> allength
)
3332 if (decoded_length
< 0)
3334 /* The decoding wasn't possible. */
3335 error ("Invalid base64 data");
3338 /* Now we have decoded the region, so we insert the new contents
3339 and delete the old. (Insert first in order to preserve markers.) */
3340 TEMP_SET_PT_BOTH (XFASTINT (beg
), ibeg
);
3341 insert_1_both (decoded
, inserted_chars
, decoded_length
, 0, 1, 0);
3344 /* Delete the original text. */
3345 del_range_both (PT
, PT_BYTE
, XFASTINT (end
) + inserted_chars
,
3346 iend
+ decoded_length
, 1);
3348 /* If point was outside of the region, restore it exactly; else just
3349 move to the beginning of the region. */
3350 if (old_pos
>= XFASTINT (end
))
3351 old_pos
+= inserted_chars
- (XFASTINT (end
) - XFASTINT (beg
));
3352 else if (old_pos
> XFASTINT (beg
))
3353 old_pos
= XFASTINT (beg
);
3354 SET_PT (old_pos
> ZV
? ZV
: old_pos
);
3356 return make_number (inserted_chars
);
3359 DEFUN ("base64-decode-string", Fbase64_decode_string
, Sbase64_decode_string
,
3361 doc
: /* Base64-decode STRING and return the result. */)
3362 (Lisp_Object string
)
3365 ptrdiff_t length
, decoded_length
;
3366 Lisp_Object decoded_string
;
3369 CHECK_STRING (string
);
3371 length
= SBYTES (string
);
3372 /* We need to allocate enough room for decoding the text. */
3373 decoded
= SAFE_ALLOCA (length
);
3375 /* The decoded result should be unibyte. */
3376 decoded_length
= base64_decode_1 (SSDATA (string
), decoded
, length
,
3378 if (decoded_length
> length
)
3380 else if (decoded_length
>= 0)
3381 decoded_string
= make_unibyte_string (decoded
, decoded_length
);
3383 decoded_string
= Qnil
;
3386 if (!STRINGP (decoded_string
))
3387 error ("Invalid base64 data");
3389 return decoded_string
;
3392 /* Base64-decode the data at FROM of LENGTH bytes into TO. If
3393 MULTIBYTE, the decoded result should be in multibyte
3394 form. If NCHARS_RETURN is not NULL, store the number of produced
3395 characters in *NCHARS_RETURN. */
3398 base64_decode_1 (const char *from
, char *to
, ptrdiff_t length
,
3399 bool multibyte
, ptrdiff_t *nchars_return
)
3401 ptrdiff_t i
= 0; /* Used inside READ_QUADRUPLET_BYTE */
3404 unsigned long value
;
3405 ptrdiff_t nchars
= 0;
3409 /* Process first byte of a quadruplet. */
3411 READ_QUADRUPLET_BYTE (e
-to
);
3415 value
= base64_char_to_value
[c
] << 18;
3417 /* Process second byte of a quadruplet. */
3419 READ_QUADRUPLET_BYTE (-1);
3423 value
|= base64_char_to_value
[c
] << 12;
3425 c
= (unsigned char) (value
>> 16);
3426 if (multibyte
&& c
>= 128)
3427 e
+= BYTE8_STRING (c
, e
);
3432 /* Process third byte of a quadruplet. */
3434 READ_QUADRUPLET_BYTE (-1);
3438 READ_QUADRUPLET_BYTE (-1);
3447 value
|= base64_char_to_value
[c
] << 6;
3449 c
= (unsigned char) (0xff & value
>> 8);
3450 if (multibyte
&& c
>= 128)
3451 e
+= BYTE8_STRING (c
, e
);
3456 /* Process fourth byte of a quadruplet. */
3458 READ_QUADRUPLET_BYTE (-1);
3465 value
|= base64_char_to_value
[c
];
3467 c
= (unsigned char) (0xff & value
);
3468 if (multibyte
&& c
>= 128)
3469 e
+= BYTE8_STRING (c
, e
);
3478 /***********************************************************************
3480 ***** Hash Tables *****
3482 ***********************************************************************/
3484 /* Implemented by gerd@gnu.org. This hash table implementation was
3485 inspired by CMUCL hash tables. */
3489 1. For small tables, association lists are probably faster than
3490 hash tables because they have lower overhead.
3492 For uses of hash tables where the O(1) behavior of table
3493 operations is not a requirement, it might therefore be a good idea
3494 not to hash. Instead, we could just do a linear search in the
3495 key_and_value vector of the hash table. This could be done
3496 if a `:linear-search t' argument is given to make-hash-table. */
3499 /* The list of all weak hash tables. Don't staticpro this one. */
3501 static struct Lisp_Hash_Table
*weak_hash_tables
;
3504 /***********************************************************************
3506 ***********************************************************************/
3509 CHECK_HASH_TABLE (Lisp_Object x
)
3511 CHECK_TYPE (HASH_TABLE_P (x
), Qhash_table_p
, x
);
3515 set_hash_key_and_value (struct Lisp_Hash_Table
*h
, Lisp_Object key_and_value
)
3517 h
->key_and_value
= key_and_value
;
3520 set_hash_next (struct Lisp_Hash_Table
*h
, Lisp_Object next
)
3525 set_hash_next_slot (struct Lisp_Hash_Table
*h
, ptrdiff_t idx
, Lisp_Object val
)
3527 gc_aset (h
->next
, idx
, val
);
3530 set_hash_hash (struct Lisp_Hash_Table
*h
, Lisp_Object hash
)
3535 set_hash_hash_slot (struct Lisp_Hash_Table
*h
, ptrdiff_t idx
, Lisp_Object val
)
3537 gc_aset (h
->hash
, idx
, val
);
3540 set_hash_index (struct Lisp_Hash_Table
*h
, Lisp_Object index
)
3545 set_hash_index_slot (struct Lisp_Hash_Table
*h
, ptrdiff_t idx
, Lisp_Object val
)
3547 gc_aset (h
->index
, idx
, val
);
3550 /* If OBJ is a Lisp hash table, return a pointer to its struct
3551 Lisp_Hash_Table. Otherwise, signal an error. */
3553 static struct Lisp_Hash_Table
*
3554 check_hash_table (Lisp_Object obj
)
3556 CHECK_HASH_TABLE (obj
);
3557 return XHASH_TABLE (obj
);
3561 /* Value is the next integer I >= N, N >= 0 which is "almost" a prime
3562 number. A number is "almost" a prime number if it is not divisible
3563 by any integer in the range 2 .. (NEXT_ALMOST_PRIME_LIMIT - 1). */
3566 next_almost_prime (EMACS_INT n
)
3568 verify (NEXT_ALMOST_PRIME_LIMIT
== 11);
3569 for (n
|= 1; ; n
+= 2)
3570 if (n
% 3 != 0 && n
% 5 != 0 && n
% 7 != 0)
3575 /* Find KEY in ARGS which has size NARGS. Don't consider indices for
3576 which USED[I] is non-zero. If found at index I in ARGS, set
3577 USED[I] and USED[I + 1] to 1, and return I + 1. Otherwise return
3578 0. This function is used to extract a keyword/argument pair from
3579 a DEFUN parameter list. */
3582 get_key_arg (Lisp_Object key
, ptrdiff_t nargs
, Lisp_Object
*args
, char *used
)
3586 for (i
= 1; i
< nargs
; i
++)
3587 if (!used
[i
- 1] && EQ (args
[i
- 1], key
))
3598 /* Return a Lisp vector which has the same contents as VEC but has
3599 at least INCR_MIN more entries, where INCR_MIN is positive.
3600 If NITEMS_MAX is not -1, do not grow the vector to be any larger
3601 than NITEMS_MAX. Entries in the resulting
3602 vector that are not copied from VEC are set to nil. */
3605 larger_vector (Lisp_Object vec
, ptrdiff_t incr_min
, ptrdiff_t nitems_max
)
3607 struct Lisp_Vector
*v
;
3608 ptrdiff_t incr
, incr_max
, old_size
, new_size
;
3609 ptrdiff_t C_language_max
= min (PTRDIFF_MAX
, SIZE_MAX
) / sizeof *v
->contents
;
3610 ptrdiff_t n_max
= (0 <= nitems_max
&& nitems_max
< C_language_max
3611 ? nitems_max
: C_language_max
);
3612 eassert (VECTORP (vec
));
3613 eassert (0 < incr_min
&& -1 <= nitems_max
);
3614 old_size
= ASIZE (vec
);
3615 incr_max
= n_max
- old_size
;
3616 incr
= max (incr_min
, min (old_size
>> 1, incr_max
));
3617 if (incr_max
< incr
)
3618 memory_full (SIZE_MAX
);
3619 new_size
= old_size
+ incr
;
3620 v
= allocate_vector (new_size
);
3621 memcpy (v
->contents
, XVECTOR (vec
)->contents
, old_size
* sizeof *v
->contents
);
3622 memclear (v
->contents
+ old_size
, incr
* word_size
);
3623 XSETVECTOR (vec
, v
);
3628 /***********************************************************************
3630 ***********************************************************************/
3632 /* Compare KEY1 which has hash code HASH1 and KEY2 with hash code
3633 HASH2 in hash table H using `eql'. Value is true if KEY1 and
3634 KEY2 are the same. */
3637 cmpfn_eql (struct hash_table_test
*ht
,
3641 return (FLOATP (key1
)
3643 && XFLOAT_DATA (key1
) == XFLOAT_DATA (key2
));
3647 /* Compare KEY1 which has hash code HASH1 and KEY2 with hash code
3648 HASH2 in hash table H using `equal'. Value is true if KEY1 and
3649 KEY2 are the same. */
3652 cmpfn_equal (struct hash_table_test
*ht
,
3656 return !NILP (Fequal (key1
, key2
));
3660 /* Compare KEY1 which has hash code HASH1, and KEY2 with hash code
3661 HASH2 in hash table H using H->user_cmp_function. Value is true
3662 if KEY1 and KEY2 are the same. */
3665 cmpfn_user_defined (struct hash_table_test
*ht
,
3669 return !NILP (call2 (ht
->user_cmp_function
, key1
, key2
));
3672 /* Value is a hash code for KEY for use in hash table H which uses
3673 `eq' to compare keys. The hash code returned is guaranteed to fit
3674 in a Lisp integer. */
3677 hashfn_eq (struct hash_table_test
*ht
, Lisp_Object key
)
3679 return XHASH (key
) ^ XTYPE (key
);
3682 /* Value is a hash code for KEY for use in hash table H which uses
3683 `equal' to compare keys. The hash code returned is guaranteed to fit
3684 in a Lisp integer. */
3687 hashfn_equal (struct hash_table_test
*ht
, Lisp_Object key
)
3689 return sxhash (key
, 0);
3692 /* Value is a hash code for KEY for use in hash table H which uses
3693 `eql' to compare keys. The hash code returned is guaranteed to fit
3694 in a Lisp integer. */
3697 hashfn_eql (struct hash_table_test
*ht
, Lisp_Object key
)
3699 return FLOATP (key
) ? hashfn_equal (ht
, key
) : hashfn_eq (ht
, key
);
3702 /* Value is a hash code for KEY for use in hash table H which uses as
3703 user-defined function to compare keys. The hash code returned is
3704 guaranteed to fit in a Lisp integer. */
3707 hashfn_user_defined (struct hash_table_test
*ht
, Lisp_Object key
)
3709 Lisp_Object hash
= call1 (ht
->user_hash_function
, key
);
3710 return hashfn_eq (ht
, hash
);
3713 struct hash_table_test
const
3714 hashtest_eq
= { LISPSYM_INITIALLY (Qeq
), LISPSYM_INITIALLY (Qnil
),
3715 LISPSYM_INITIALLY (Qnil
), 0, hashfn_eq
},
3716 hashtest_eql
= { LISPSYM_INITIALLY (Qeql
), LISPSYM_INITIALLY (Qnil
),
3717 LISPSYM_INITIALLY (Qnil
), cmpfn_eql
, hashfn_eql
},
3718 hashtest_equal
= { LISPSYM_INITIALLY (Qequal
), LISPSYM_INITIALLY (Qnil
),
3719 LISPSYM_INITIALLY (Qnil
), cmpfn_equal
, hashfn_equal
};
3721 /* Allocate basically initialized hash table. */
3723 static struct Lisp_Hash_Table
*
3724 allocate_hash_table (void)
3726 return ALLOCATE_PSEUDOVECTOR (struct Lisp_Hash_Table
,
3727 count
, PVEC_HASH_TABLE
);
3730 /* An upper bound on the size of a hash table index. It must fit in
3731 ptrdiff_t and be a valid Emacs fixnum. */
3732 #define INDEX_SIZE_BOUND \
3733 ((ptrdiff_t) min (MOST_POSITIVE_FIXNUM, PTRDIFF_MAX / word_size))
3735 /* Create and initialize a new hash table.
3737 TEST specifies the test the hash table will use to compare keys.
3738 It must be either one of the predefined tests `eq', `eql' or
3739 `equal' or a symbol denoting a user-defined test named TEST with
3740 test and hash functions USER_TEST and USER_HASH.
3742 Give the table initial capacity SIZE, SIZE >= 0, an integer.
3744 If REHASH_SIZE is an integer, it must be > 0, and this hash table's
3745 new size when it becomes full is computed by adding REHASH_SIZE to
3746 its old size. If REHASH_SIZE is a float, it must be > 1.0, and the
3747 table's new size is computed by multiplying its old size with
3750 REHASH_THRESHOLD must be a float <= 1.0, and > 0. The table will
3751 be resized when the ratio of (number of entries in the table) /
3752 (table size) is >= REHASH_THRESHOLD.
3754 WEAK specifies the weakness of the table. If non-nil, it must be
3755 one of the symbols `key', `value', `key-or-value', or `key-and-value'.
3757 If PURECOPY is non-nil, the table can be copied to pure storage via
3758 `purecopy' when Emacs is being dumped. Such tables can no longer be
3759 changed after purecopy. */
3762 make_hash_table (struct hash_table_test test
,
3763 Lisp_Object size
, Lisp_Object rehash_size
,
3764 Lisp_Object rehash_threshold
, Lisp_Object weak
,
3767 struct Lisp_Hash_Table
*h
;
3769 EMACS_INT index_size
, sz
;
3773 /* Preconditions. */
3774 eassert (SYMBOLP (test
.name
));
3775 eassert (INTEGERP (size
) && XINT (size
) >= 0);
3776 eassert ((INTEGERP (rehash_size
) && XINT (rehash_size
) > 0)
3777 || (FLOATP (rehash_size
) && 1 < XFLOAT_DATA (rehash_size
)));
3778 eassert (FLOATP (rehash_threshold
)
3779 && 0 < XFLOAT_DATA (rehash_threshold
)
3780 && XFLOAT_DATA (rehash_threshold
) <= 1.0);
3782 if (XFASTINT (size
) == 0)
3783 size
= make_number (1);
3785 sz
= XFASTINT (size
);
3786 index_float
= sz
/ XFLOAT_DATA (rehash_threshold
);
3787 index_size
= (index_float
< INDEX_SIZE_BOUND
+ 1
3788 ? next_almost_prime (index_float
)
3789 : INDEX_SIZE_BOUND
+ 1);
3790 if (INDEX_SIZE_BOUND
< max (index_size
, 2 * sz
))
3791 error ("Hash table too large");
3793 /* Allocate a table and initialize it. */
3794 h
= allocate_hash_table ();
3796 /* Initialize hash table slots. */
3799 h
->rehash_threshold
= rehash_threshold
;
3800 h
->rehash_size
= rehash_size
;
3802 h
->key_and_value
= Fmake_vector (make_number (2 * sz
), Qnil
);
3803 h
->hash
= Fmake_vector (size
, Qnil
);
3804 h
->next
= Fmake_vector (size
, Qnil
);
3805 h
->index
= Fmake_vector (make_number (index_size
), Qnil
);
3808 /* Set up the free list. */
3809 for (i
= 0; i
< sz
- 1; ++i
)
3810 set_hash_next_slot (h
, i
, make_number (i
+ 1));
3811 h
->next_free
= make_number (0);
3813 XSET_HASH_TABLE (table
, h
);
3814 eassert (HASH_TABLE_P (table
));
3815 eassert (XHASH_TABLE (table
) == h
);
3817 /* Maybe add this hash table to the list of all weak hash tables. */
3819 h
->next_weak
= NULL
;
3822 h
->next_weak
= weak_hash_tables
;
3823 weak_hash_tables
= h
;
3830 /* Return a copy of hash table H1. Keys and values are not copied,
3831 only the table itself is. */
3834 copy_hash_table (struct Lisp_Hash_Table
*h1
)
3837 struct Lisp_Hash_Table
*h2
;
3839 h2
= allocate_hash_table ();
3841 h2
->key_and_value
= Fcopy_sequence (h1
->key_and_value
);
3842 h2
->hash
= Fcopy_sequence (h1
->hash
);
3843 h2
->next
= Fcopy_sequence (h1
->next
);
3844 h2
->index
= Fcopy_sequence (h1
->index
);
3845 XSET_HASH_TABLE (table
, h2
);
3847 /* Maybe add this hash table to the list of all weak hash tables. */
3848 if (!NILP (h2
->weak
))
3850 h2
->next_weak
= weak_hash_tables
;
3851 weak_hash_tables
= h2
;
3858 /* Resize hash table H if it's too full. If H cannot be resized
3859 because it's already too large, throw an error. */
3862 maybe_resize_hash_table (struct Lisp_Hash_Table
*h
)
3864 if (NILP (h
->next_free
))
3866 ptrdiff_t old_size
= HASH_TABLE_SIZE (h
);
3867 EMACS_INT new_size
, index_size
, nsize
;
3871 if (INTEGERP (h
->rehash_size
))
3872 new_size
= old_size
+ XFASTINT (h
->rehash_size
);
3875 double float_new_size
= old_size
* XFLOAT_DATA (h
->rehash_size
);
3876 if (float_new_size
< INDEX_SIZE_BOUND
+ 1)
3878 new_size
= float_new_size
;
3879 if (new_size
<= old_size
)
3880 new_size
= old_size
+ 1;
3883 new_size
= INDEX_SIZE_BOUND
+ 1;
3885 index_float
= new_size
/ XFLOAT_DATA (h
->rehash_threshold
);
3886 index_size
= (index_float
< INDEX_SIZE_BOUND
+ 1
3887 ? next_almost_prime (index_float
)
3888 : INDEX_SIZE_BOUND
+ 1);
3889 nsize
= max (index_size
, 2 * new_size
);
3890 if (INDEX_SIZE_BOUND
< nsize
)
3891 error ("Hash table too large to resize");
3893 #ifdef ENABLE_CHECKING
3894 if (HASH_TABLE_P (Vpurify_flag
)
3895 && XHASH_TABLE (Vpurify_flag
) == h
)
3896 message ("Growing hash table to: %"pI
"d", new_size
);
3899 set_hash_key_and_value (h
, larger_vector (h
->key_and_value
,
3900 2 * (new_size
- old_size
), -1));
3901 set_hash_next (h
, larger_vector (h
->next
, new_size
- old_size
, -1));
3902 set_hash_hash (h
, larger_vector (h
->hash
, new_size
- old_size
, -1));
3903 set_hash_index (h
, Fmake_vector (make_number (index_size
), Qnil
));
3905 /* Update the free list. Do it so that new entries are added at
3906 the end of the free list. This makes some operations like
3908 for (i
= old_size
; i
< new_size
- 1; ++i
)
3909 set_hash_next_slot (h
, i
, make_number (i
+ 1));
3911 if (!NILP (h
->next_free
))
3913 Lisp_Object last
, next
;
3915 last
= h
->next_free
;
3916 while (next
= HASH_NEXT (h
, XFASTINT (last
)),
3920 set_hash_next_slot (h
, XFASTINT (last
), make_number (old_size
));
3923 XSETFASTINT (h
->next_free
, old_size
);
3926 for (i
= 0; i
< old_size
; ++i
)
3927 if (!NILP (HASH_HASH (h
, i
)))
3929 EMACS_UINT hash_code
= XUINT (HASH_HASH (h
, i
));
3930 ptrdiff_t start_of_bucket
= hash_code
% ASIZE (h
->index
);
3931 set_hash_next_slot (h
, i
, HASH_INDEX (h
, start_of_bucket
));
3932 set_hash_index_slot (h
, start_of_bucket
, make_number (i
));
3938 /* Lookup KEY in hash table H. If HASH is non-null, return in *HASH
3939 the hash code of KEY. Value is the index of the entry in H
3940 matching KEY, or -1 if not found. */
3943 hash_lookup (struct Lisp_Hash_Table
*h
, Lisp_Object key
, EMACS_UINT
*hash
)
3945 EMACS_UINT hash_code
;
3946 ptrdiff_t start_of_bucket
;
3949 hash_code
= h
->test
.hashfn (&h
->test
, key
);
3950 eassert ((hash_code
& ~INTMASK
) == 0);
3954 start_of_bucket
= hash_code
% ASIZE (h
->index
);
3955 idx
= HASH_INDEX (h
, start_of_bucket
);
3959 ptrdiff_t i
= XFASTINT (idx
);
3960 if (EQ (key
, HASH_KEY (h
, i
))
3962 && hash_code
== XUINT (HASH_HASH (h
, i
))
3963 && h
->test
.cmpfn (&h
->test
, key
, HASH_KEY (h
, i
))))
3965 idx
= HASH_NEXT (h
, i
);
3968 return NILP (idx
) ? -1 : XFASTINT (idx
);
3972 /* Put an entry into hash table H that associates KEY with VALUE.
3973 HASH is a previously computed hash code of KEY.
3974 Value is the index of the entry in H matching KEY. */
3977 hash_put (struct Lisp_Hash_Table
*h
, Lisp_Object key
, Lisp_Object value
,
3980 ptrdiff_t start_of_bucket
, i
;
3982 eassert ((hash
& ~INTMASK
) == 0);
3984 /* Increment count after resizing because resizing may fail. */
3985 maybe_resize_hash_table (h
);
3988 /* Store key/value in the key_and_value vector. */
3989 i
= XFASTINT (h
->next_free
);
3990 h
->next_free
= HASH_NEXT (h
, i
);
3991 set_hash_key_slot (h
, i
, key
);
3992 set_hash_value_slot (h
, i
, value
);
3994 /* Remember its hash code. */
3995 set_hash_hash_slot (h
, i
, make_number (hash
));
3997 /* Add new entry to its collision chain. */
3998 start_of_bucket
= hash
% ASIZE (h
->index
);
3999 set_hash_next_slot (h
, i
, HASH_INDEX (h
, start_of_bucket
));
4000 set_hash_index_slot (h
, start_of_bucket
, make_number (i
));
4005 /* Remove the entry matching KEY from hash table H, if there is one. */
4008 hash_remove_from_table (struct Lisp_Hash_Table
*h
, Lisp_Object key
)
4010 EMACS_UINT hash_code
;
4011 ptrdiff_t start_of_bucket
;
4012 Lisp_Object idx
, prev
;
4014 hash_code
= h
->test
.hashfn (&h
->test
, key
);
4015 eassert ((hash_code
& ~INTMASK
) == 0);
4016 start_of_bucket
= hash_code
% ASIZE (h
->index
);
4017 idx
= HASH_INDEX (h
, start_of_bucket
);
4022 ptrdiff_t i
= XFASTINT (idx
);
4024 if (EQ (key
, HASH_KEY (h
, i
))
4026 && hash_code
== XUINT (HASH_HASH (h
, i
))
4027 && h
->test
.cmpfn (&h
->test
, key
, HASH_KEY (h
, i
))))
4029 /* Take entry out of collision chain. */
4031 set_hash_index_slot (h
, start_of_bucket
, HASH_NEXT (h
, i
));
4033 set_hash_next_slot (h
, XFASTINT (prev
), HASH_NEXT (h
, i
));
4035 /* Clear slots in key_and_value and add the slots to
4037 set_hash_key_slot (h
, i
, Qnil
);
4038 set_hash_value_slot (h
, i
, Qnil
);
4039 set_hash_hash_slot (h
, i
, Qnil
);
4040 set_hash_next_slot (h
, i
, h
->next_free
);
4041 h
->next_free
= make_number (i
);
4043 eassert (h
->count
>= 0);
4049 idx
= HASH_NEXT (h
, i
);
4055 /* Clear hash table H. */
4058 hash_clear (struct Lisp_Hash_Table
*h
)
4062 ptrdiff_t i
, size
= HASH_TABLE_SIZE (h
);
4064 for (i
= 0; i
< size
; ++i
)
4066 set_hash_next_slot (h
, i
, i
< size
- 1 ? make_number (i
+ 1) : Qnil
);
4067 set_hash_key_slot (h
, i
, Qnil
);
4068 set_hash_value_slot (h
, i
, Qnil
);
4069 set_hash_hash_slot (h
, i
, Qnil
);
4072 for (i
= 0; i
< ASIZE (h
->index
); ++i
)
4073 ASET (h
->index
, i
, Qnil
);
4075 h
->next_free
= make_number (0);
4082 /************************************************************************
4084 ************************************************************************/
4086 /* Sweep weak hash table H. REMOVE_ENTRIES_P means remove
4087 entries from the table that don't survive the current GC.
4088 !REMOVE_ENTRIES_P means mark entries that are in use. Value is
4089 true if anything was marked. */
4092 sweep_weak_table (struct Lisp_Hash_Table
*h
, bool remove_entries_p
)
4094 ptrdiff_t n
= gc_asize (h
->index
);
4095 bool marked
= false;
4097 for (ptrdiff_t bucket
= 0; bucket
< n
; ++bucket
)
4099 Lisp_Object idx
, next
, prev
;
4101 /* Follow collision chain, removing entries that
4102 don't survive this garbage collection. */
4104 for (idx
= HASH_INDEX (h
, bucket
); !NILP (idx
); idx
= next
)
4106 ptrdiff_t i
= XFASTINT (idx
);
4107 bool key_known_to_survive_p
= survives_gc_p (HASH_KEY (h
, i
));
4108 bool value_known_to_survive_p
= survives_gc_p (HASH_VALUE (h
, i
));
4111 if (EQ (h
->weak
, Qkey
))
4112 remove_p
= !key_known_to_survive_p
;
4113 else if (EQ (h
->weak
, Qvalue
))
4114 remove_p
= !value_known_to_survive_p
;
4115 else if (EQ (h
->weak
, Qkey_or_value
))
4116 remove_p
= !(key_known_to_survive_p
|| value_known_to_survive_p
);
4117 else if (EQ (h
->weak
, Qkey_and_value
))
4118 remove_p
= !(key_known_to_survive_p
&& value_known_to_survive_p
);
4122 next
= HASH_NEXT (h
, i
);
4124 if (remove_entries_p
)
4128 /* Take out of collision chain. */
4130 set_hash_index_slot (h
, bucket
, next
);
4132 set_hash_next_slot (h
, XFASTINT (prev
), next
);
4134 /* Add to free list. */
4135 set_hash_next_slot (h
, i
, h
->next_free
);
4138 /* Clear key, value, and hash. */
4139 set_hash_key_slot (h
, i
, Qnil
);
4140 set_hash_value_slot (h
, i
, Qnil
);
4141 set_hash_hash_slot (h
, i
, Qnil
);
4154 /* Make sure key and value survive. */
4155 if (!key_known_to_survive_p
)
4157 mark_object (HASH_KEY (h
, i
));
4161 if (!value_known_to_survive_p
)
4163 mark_object (HASH_VALUE (h
, i
));
4174 /* Remove elements from weak hash tables that don't survive the
4175 current garbage collection. Remove weak tables that don't survive
4176 from Vweak_hash_tables. Called from gc_sweep. */
4178 NO_INLINE
/* For better stack traces */
4180 sweep_weak_hash_tables (void)
4182 struct Lisp_Hash_Table
*h
, *used
, *next
;
4185 /* Mark all keys and values that are in use. Keep on marking until
4186 there is no more change. This is necessary for cases like
4187 value-weak table A containing an entry X -> Y, where Y is used in a
4188 key-weak table B, Z -> Y. If B comes after A in the list of weak
4189 tables, X -> Y might be removed from A, although when looking at B
4190 one finds that it shouldn't. */
4194 for (h
= weak_hash_tables
; h
; h
= h
->next_weak
)
4196 if (h
->header
.size
& ARRAY_MARK_FLAG
)
4197 marked
|= sweep_weak_table (h
, 0);
4202 /* Remove tables and entries that aren't used. */
4203 for (h
= weak_hash_tables
, used
= NULL
; h
; h
= next
)
4205 next
= h
->next_weak
;
4207 if (h
->header
.size
& ARRAY_MARK_FLAG
)
4209 /* TABLE is marked as used. Sweep its contents. */
4211 sweep_weak_table (h
, 1);
4213 /* Add table to the list of used weak hash tables. */
4214 h
->next_weak
= used
;
4219 weak_hash_tables
= used
;
4224 /***********************************************************************
4225 Hash Code Computation
4226 ***********************************************************************/
4228 /* Maximum depth up to which to dive into Lisp structures. */
4230 #define SXHASH_MAX_DEPTH 3
4232 /* Maximum length up to which to take list and vector elements into
4235 #define SXHASH_MAX_LEN 7
4237 /* Return a hash for string PTR which has length LEN. The hash value
4238 can be any EMACS_UINT value. */
4241 hash_string (char const *ptr
, ptrdiff_t len
)
4243 char const *p
= ptr
;
4244 char const *end
= p
+ len
;
4246 EMACS_UINT hash
= 0;
4251 hash
= sxhash_combine (hash
, c
);
4257 /* Return a hash for string PTR which has length LEN. The hash
4258 code returned is guaranteed to fit in a Lisp integer. */
4261 sxhash_string (char const *ptr
, ptrdiff_t len
)
4263 EMACS_UINT hash
= hash_string (ptr
, len
);
4264 return SXHASH_REDUCE (hash
);
4267 /* Return a hash for the floating point value VAL. */
4270 sxhash_float (double val
)
4272 EMACS_UINT hash
= 0;
4274 WORDS_PER_DOUBLE
= (sizeof val
/ sizeof hash
4275 + (sizeof val
% sizeof hash
!= 0))
4279 EMACS_UINT word
[WORDS_PER_DOUBLE
];
4283 memset (&u
.val
+ 1, 0, sizeof u
- sizeof u
.val
);
4284 for (i
= 0; i
< WORDS_PER_DOUBLE
; i
++)
4285 hash
= sxhash_combine (hash
, u
.word
[i
]);
4286 return SXHASH_REDUCE (hash
);
4289 /* Return a hash for list LIST. DEPTH is the current depth in the
4290 list. We don't recurse deeper than SXHASH_MAX_DEPTH in it. */
4293 sxhash_list (Lisp_Object list
, int depth
)
4295 EMACS_UINT hash
= 0;
4298 if (depth
< SXHASH_MAX_DEPTH
)
4300 CONSP (list
) && i
< SXHASH_MAX_LEN
;
4301 list
= XCDR (list
), ++i
)
4303 EMACS_UINT hash2
= sxhash (XCAR (list
), depth
+ 1);
4304 hash
= sxhash_combine (hash
, hash2
);
4309 EMACS_UINT hash2
= sxhash (list
, depth
+ 1);
4310 hash
= sxhash_combine (hash
, hash2
);
4313 return SXHASH_REDUCE (hash
);
4317 /* Return a hash for vector VECTOR. DEPTH is the current depth in
4318 the Lisp structure. */
4321 sxhash_vector (Lisp_Object vec
, int depth
)
4323 EMACS_UINT hash
= ASIZE (vec
);
4326 n
= min (SXHASH_MAX_LEN
, ASIZE (vec
));
4327 for (i
= 0; i
< n
; ++i
)
4329 EMACS_UINT hash2
= sxhash (AREF (vec
, i
), depth
+ 1);
4330 hash
= sxhash_combine (hash
, hash2
);
4333 return SXHASH_REDUCE (hash
);
4336 /* Return a hash for bool-vector VECTOR. */
4339 sxhash_bool_vector (Lisp_Object vec
)
4341 EMACS_INT size
= bool_vector_size (vec
);
4342 EMACS_UINT hash
= size
;
4345 n
= min (SXHASH_MAX_LEN
, bool_vector_words (size
));
4346 for (i
= 0; i
< n
; ++i
)
4347 hash
= sxhash_combine (hash
, bool_vector_data (vec
)[i
]);
4349 return SXHASH_REDUCE (hash
);
4353 /* Return a hash code for OBJ. DEPTH is the current depth in the Lisp
4354 structure. Value is an unsigned integer clipped to INTMASK. */
4357 sxhash (Lisp_Object obj
, int depth
)
4361 if (depth
> SXHASH_MAX_DEPTH
)
4364 switch (XTYPE (obj
))
4376 hash
= sxhash_string (SSDATA (obj
), SBYTES (obj
));
4379 /* This can be everything from a vector to an overlay. */
4380 case Lisp_Vectorlike
:
4382 /* According to the CL HyperSpec, two arrays are equal only if
4383 they are `eq', except for strings and bit-vectors. In
4384 Emacs, this works differently. We have to compare element
4386 hash
= sxhash_vector (obj
, depth
);
4387 else if (BOOL_VECTOR_P (obj
))
4388 hash
= sxhash_bool_vector (obj
);
4390 /* Others are `equal' if they are `eq', so let's take their
4396 hash
= sxhash_list (obj
, depth
);
4400 hash
= sxhash_float (XFLOAT_DATA (obj
));
4412 /***********************************************************************
4414 ***********************************************************************/
4416 DEFUN ("sxhash-eq", Fsxhash_eq
, Ssxhash_eq
, 1, 1, 0,
4417 doc
: /* Return an integer hash code for OBJ suitable for `eq'.
4418 If (eq A B), then (= (sxhash-eq A) (sxhash-eq B)). */)
4421 return make_number (hashfn_eq (NULL
, obj
));
4424 DEFUN ("sxhash-eql", Fsxhash_eql
, Ssxhash_eql
, 1, 1, 0,
4425 doc
: /* Return an integer hash code for OBJ suitable for `eql'.
4426 If (eql A B), then (= (sxhash-eql A) (sxhash-eql B)). */)
4429 return make_number (hashfn_eql (NULL
, obj
));
4432 DEFUN ("sxhash-equal", Fsxhash_equal
, Ssxhash_equal
, 1, 1, 0,
4433 doc
: /* Return an integer hash code for OBJ suitable for `equal'.
4434 If (equal A B), then (= (sxhash-equal A) (sxhash-equal B)). */)
4437 return make_number (hashfn_equal (NULL
, obj
));
4440 DEFUN ("make-hash-table", Fmake_hash_table
, Smake_hash_table
, 0, MANY
, 0,
4441 doc
: /* Create and return a new hash table.
4443 Arguments are specified as keyword/argument pairs. The following
4444 arguments are defined:
4446 :test TEST -- TEST must be a symbol that specifies how to compare
4447 keys. Default is `eql'. Predefined are the tests `eq', `eql', and
4448 `equal'. User-supplied test and hash functions can be specified via
4449 `define-hash-table-test'.
4451 :size SIZE -- A hint as to how many elements will be put in the table.
4454 :rehash-size REHASH-SIZE - Indicates how to expand the table when it
4455 fills up. If REHASH-SIZE is an integer, increase the size by that
4456 amount. If it is a float, it must be > 1.0, and the new size is the
4457 old size multiplied by that factor. Default is 1.5.
4459 :rehash-threshold THRESHOLD -- THRESHOLD must a float > 0, and <= 1.0.
4460 Resize the hash table when the ratio (number of entries / table size)
4461 is greater than or equal to THRESHOLD. Default is 0.8.
4463 :weakness WEAK -- WEAK must be one of nil, t, `key', `value',
4464 `key-or-value', or `key-and-value'. If WEAK is not nil, the table
4465 returned is a weak table. Key/value pairs are removed from a weak
4466 hash table when there are no non-weak references pointing to their
4467 key, value, one of key or value, or both key and value, depending on
4468 WEAK. WEAK t is equivalent to `key-and-value'. Default value of WEAK
4471 :purecopy PURECOPY -- If PURECOPY is non-nil, the table can be copied
4472 to pure storage when Emacs is being dumped, making the contents of the
4473 table read only. Any further changes to purified tables will result
4476 usage: (make-hash-table &rest KEYWORD-ARGS) */)
4477 (ptrdiff_t nargs
, Lisp_Object
*args
)
4479 Lisp_Object test
, size
, rehash_size
, rehash_threshold
, weak
, pure
;
4480 struct hash_table_test testdesc
;
4484 /* The vector `used' is used to keep track of arguments that
4485 have been consumed. */
4486 char *used
= SAFE_ALLOCA (nargs
* sizeof *used
);
4487 memset (used
, 0, nargs
* sizeof *used
);
4489 /* See if there's a `:test TEST' among the arguments. */
4490 i
= get_key_arg (QCtest
, nargs
, args
, used
);
4491 test
= i
? args
[i
] : Qeql
;
4493 testdesc
= hashtest_eq
;
4494 else if (EQ (test
, Qeql
))
4495 testdesc
= hashtest_eql
;
4496 else if (EQ (test
, Qequal
))
4497 testdesc
= hashtest_equal
;
4500 /* See if it is a user-defined test. */
4503 prop
= Fget (test
, Qhash_table_test
);
4504 if (!CONSP (prop
) || !CONSP (XCDR (prop
)))
4505 signal_error ("Invalid hash table test", test
);
4506 testdesc
.name
= test
;
4507 testdesc
.user_cmp_function
= XCAR (prop
);
4508 testdesc
.user_hash_function
= XCAR (XCDR (prop
));
4509 testdesc
.hashfn
= hashfn_user_defined
;
4510 testdesc
.cmpfn
= cmpfn_user_defined
;
4513 /* See if there's a `:purecopy PURECOPY' argument. */
4514 i
= get_key_arg (QCpurecopy
, nargs
, args
, used
);
4515 pure
= i
? args
[i
] : Qnil
;
4516 /* See if there's a `:size SIZE' argument. */
4517 i
= get_key_arg (QCsize
, nargs
, args
, used
);
4518 size
= i
? args
[i
] : Qnil
;
4520 size
= make_number (DEFAULT_HASH_SIZE
);
4521 else if (!INTEGERP (size
) || XINT (size
) < 0)
4522 signal_error ("Invalid hash table size", size
);
4524 /* Look for `:rehash-size SIZE'. */
4525 i
= get_key_arg (QCrehash_size
, nargs
, args
, used
);
4526 rehash_size
= i
? args
[i
] : make_float (DEFAULT_REHASH_SIZE
);
4527 if (! ((INTEGERP (rehash_size
) && 0 < XINT (rehash_size
))
4528 || (FLOATP (rehash_size
) && 1 < XFLOAT_DATA (rehash_size
))))
4529 signal_error ("Invalid hash table rehash size", rehash_size
);
4531 /* Look for `:rehash-threshold THRESHOLD'. */
4532 i
= get_key_arg (QCrehash_threshold
, nargs
, args
, used
);
4533 rehash_threshold
= i
? args
[i
] : make_float (DEFAULT_REHASH_THRESHOLD
);
4534 if (! (FLOATP (rehash_threshold
)
4535 && 0 < XFLOAT_DATA (rehash_threshold
)
4536 && XFLOAT_DATA (rehash_threshold
) <= 1))
4537 signal_error ("Invalid hash table rehash threshold", rehash_threshold
);
4539 /* Look for `:weakness WEAK'. */
4540 i
= get_key_arg (QCweakness
, nargs
, args
, used
);
4541 weak
= i
? args
[i
] : Qnil
;
4543 weak
= Qkey_and_value
;
4546 && !EQ (weak
, Qvalue
)
4547 && !EQ (weak
, Qkey_or_value
)
4548 && !EQ (weak
, Qkey_and_value
))
4549 signal_error ("Invalid hash table weakness", weak
);
4551 /* Now, all args should have been used up, or there's a problem. */
4552 for (i
= 0; i
< nargs
; ++i
)
4554 signal_error ("Invalid argument list", args
[i
]);
4557 return make_hash_table (testdesc
, size
, rehash_size
, rehash_threshold
, weak
,
4562 DEFUN ("copy-hash-table", Fcopy_hash_table
, Scopy_hash_table
, 1, 1, 0,
4563 doc
: /* Return a copy of hash table TABLE. */)
4566 return copy_hash_table (check_hash_table (table
));
4570 DEFUN ("hash-table-count", Fhash_table_count
, Shash_table_count
, 1, 1, 0,
4571 doc
: /* Return the number of elements in TABLE. */)
4574 return make_number (check_hash_table (table
)->count
);
4578 DEFUN ("hash-table-rehash-size", Fhash_table_rehash_size
,
4579 Shash_table_rehash_size
, 1, 1, 0,
4580 doc
: /* Return the current rehash size of TABLE. */)
4583 return check_hash_table (table
)->rehash_size
;
4587 DEFUN ("hash-table-rehash-threshold", Fhash_table_rehash_threshold
,
4588 Shash_table_rehash_threshold
, 1, 1, 0,
4589 doc
: /* Return the current rehash threshold of TABLE. */)
4592 return check_hash_table (table
)->rehash_threshold
;
4596 DEFUN ("hash-table-size", Fhash_table_size
, Shash_table_size
, 1, 1, 0,
4597 doc
: /* Return the size of TABLE.
4598 The size can be used as an argument to `make-hash-table' to create
4599 a hash table than can hold as many elements as TABLE holds
4600 without need for resizing. */)
4603 struct Lisp_Hash_Table
*h
= check_hash_table (table
);
4604 return make_number (HASH_TABLE_SIZE (h
));
4608 DEFUN ("hash-table-test", Fhash_table_test
, Shash_table_test
, 1, 1, 0,
4609 doc
: /* Return the test TABLE uses. */)
4612 return check_hash_table (table
)->test
.name
;
4616 DEFUN ("hash-table-weakness", Fhash_table_weakness
, Shash_table_weakness
,
4618 doc
: /* Return the weakness of TABLE. */)
4621 return check_hash_table (table
)->weak
;
4625 DEFUN ("hash-table-p", Fhash_table_p
, Shash_table_p
, 1, 1, 0,
4626 doc
: /* Return t if OBJ is a Lisp hash table object. */)
4629 return HASH_TABLE_P (obj
) ? Qt
: Qnil
;
4633 DEFUN ("clrhash", Fclrhash
, Sclrhash
, 1, 1, 0,
4634 doc
: /* Clear hash table TABLE and return it. */)
4637 struct Lisp_Hash_Table
*h
= check_hash_table (table
);
4638 CHECK_IMPURE (table
, h
);
4640 /* Be compatible with XEmacs. */
4645 DEFUN ("gethash", Fgethash
, Sgethash
, 2, 3, 0,
4646 doc
: /* Look up KEY in TABLE and return its associated value.
4647 If KEY is not found, return DFLT which defaults to nil. */)
4648 (Lisp_Object key
, Lisp_Object table
, Lisp_Object dflt
)
4650 struct Lisp_Hash_Table
*h
= check_hash_table (table
);
4651 ptrdiff_t i
= hash_lookup (h
, key
, NULL
);
4652 return i
>= 0 ? HASH_VALUE (h
, i
) : dflt
;
4656 DEFUN ("puthash", Fputhash
, Sputhash
, 3, 3, 0,
4657 doc
: /* Associate KEY with VALUE in hash table TABLE.
4658 If KEY is already present in table, replace its current value with
4659 VALUE. In any case, return VALUE. */)
4660 (Lisp_Object key
, Lisp_Object value
, Lisp_Object table
)
4662 struct Lisp_Hash_Table
*h
= check_hash_table (table
);
4663 CHECK_IMPURE (table
, h
);
4667 i
= hash_lookup (h
, key
, &hash
);
4669 set_hash_value_slot (h
, i
, value
);
4671 hash_put (h
, key
, value
, hash
);
4677 DEFUN ("remhash", Fremhash
, Sremhash
, 2, 2, 0,
4678 doc
: /* Remove KEY from TABLE. */)
4679 (Lisp_Object key
, Lisp_Object table
)
4681 struct Lisp_Hash_Table
*h
= check_hash_table (table
);
4682 CHECK_IMPURE (table
, h
);
4683 hash_remove_from_table (h
, key
);
4688 DEFUN ("maphash", Fmaphash
, Smaphash
, 2, 2, 0,
4689 doc
: /* Call FUNCTION for all entries in hash table TABLE.
4690 FUNCTION is called with two arguments, KEY and VALUE.
4691 `maphash' always returns nil. */)
4692 (Lisp_Object function
, Lisp_Object table
)
4694 struct Lisp_Hash_Table
*h
= check_hash_table (table
);
4696 for (ptrdiff_t i
= 0; i
< HASH_TABLE_SIZE (h
); ++i
)
4697 if (!NILP (HASH_HASH (h
, i
)))
4698 call2 (function
, HASH_KEY (h
, i
), HASH_VALUE (h
, i
));
4704 DEFUN ("define-hash-table-test", Fdefine_hash_table_test
,
4705 Sdefine_hash_table_test
, 3, 3, 0,
4706 doc
: /* Define a new hash table test with name NAME, a symbol.
4708 In hash tables created with NAME specified as test, use TEST to
4709 compare keys, and HASH for computing hash codes of keys.
4711 TEST must be a function taking two arguments and returning non-nil if
4712 both arguments are the same. HASH must be a function taking one
4713 argument and returning an object that is the hash code of the argument.
4714 It should be the case that if (eq (funcall HASH x1) (funcall HASH x2))
4715 returns nil, then (funcall TEST x1 x2) also returns nil. */)
4716 (Lisp_Object name
, Lisp_Object test
, Lisp_Object hash
)
4718 return Fput (name
, Qhash_table_test
, list2 (test
, hash
));
4723 /************************************************************************
4724 MD5, SHA-1, and SHA-2
4725 ************************************************************************/
4733 make_digest_string (Lisp_Object digest
, int digest_size
)
4735 unsigned char *p
= SDATA (digest
);
4737 for (int i
= digest_size
- 1; i
>= 0; i
--)
4739 static char const hexdigit
[16] = "0123456789abcdef";
4741 p
[2 * i
] = hexdigit
[p_i
>> 4];
4742 p
[2 * i
+ 1] = hexdigit
[p_i
& 0xf];
4747 /* ALGORITHM is a symbol: md5, sha1, sha224 and so on. */
4750 secure_hash (Lisp_Object algorithm
, Lisp_Object object
, Lisp_Object start
,
4751 Lisp_Object end
, Lisp_Object coding_system
, Lisp_Object noerror
,
4754 ptrdiff_t size
, start_char
= 0, start_byte
, end_char
= 0, end_byte
;
4755 register EMACS_INT b
, e
;
4756 register struct buffer
*bp
;
4759 void *(*hash_func
) (const char *, size_t, void *);
4762 CHECK_SYMBOL (algorithm
);
4764 if (STRINGP (object
))
4766 if (NILP (coding_system
))
4768 /* Decide the coding-system to encode the data with. */
4770 if (STRING_MULTIBYTE (object
))
4771 /* use default, we can't guess correct value */
4772 coding_system
= preferred_coding_system ();
4774 coding_system
= Qraw_text
;
4777 if (NILP (Fcoding_system_p (coding_system
)))
4779 /* Invalid coding system. */
4781 if (!NILP (noerror
))
4782 coding_system
= Qraw_text
;
4784 xsignal1 (Qcoding_system_error
, coding_system
);
4787 if (STRING_MULTIBYTE (object
))
4788 object
= code_convert_string (object
, coding_system
, Qnil
, 1, 0, 1);
4790 size
= SCHARS (object
);
4791 validate_subarray (object
, start
, end
, size
, &start_char
, &end_char
);
4793 start_byte
= !start_char
? 0 : string_char_to_byte (object
, start_char
);
4794 end_byte
= (end_char
== size
4796 : string_char_to_byte (object
, end_char
));
4800 struct buffer
*prev
= current_buffer
;
4802 record_unwind_current_buffer ();
4804 CHECK_BUFFER (object
);
4806 bp
= XBUFFER (object
);
4807 set_buffer_internal (bp
);
4813 CHECK_NUMBER_COERCE_MARKER (start
);
4821 CHECK_NUMBER_COERCE_MARKER (end
);
4826 temp
= b
, b
= e
, e
= temp
;
4828 if (!(BEGV
<= b
&& e
<= ZV
))
4829 args_out_of_range (start
, end
);
4831 if (NILP (coding_system
))
4833 /* Decide the coding-system to encode the data with.
4834 See fileio.c:Fwrite-region */
4836 if (!NILP (Vcoding_system_for_write
))
4837 coding_system
= Vcoding_system_for_write
;
4840 bool force_raw_text
= 0;
4842 coding_system
= BVAR (XBUFFER (object
), buffer_file_coding_system
);
4843 if (NILP (coding_system
)
4844 || NILP (Flocal_variable_p (Qbuffer_file_coding_system
, Qnil
)))
4846 coding_system
= Qnil
;
4847 if (NILP (BVAR (current_buffer
, enable_multibyte_characters
)))
4851 if (NILP (coding_system
) && !NILP (Fbuffer_file_name (object
)))
4853 /* Check file-coding-system-alist. */
4854 Lisp_Object val
= CALLN (Ffind_operation_coding_system
,
4855 Qwrite_region
, start
, end
,
4856 Fbuffer_file_name (object
));
4857 if (CONSP (val
) && !NILP (XCDR (val
)))
4858 coding_system
= XCDR (val
);
4861 if (NILP (coding_system
)
4862 && !NILP (BVAR (XBUFFER (object
), buffer_file_coding_system
)))
4864 /* If we still have not decided a coding system, use the
4865 default value of buffer-file-coding-system. */
4866 coding_system
= BVAR (XBUFFER (object
), buffer_file_coding_system
);
4870 && !NILP (Ffboundp (Vselect_safe_coding_system_function
)))
4871 /* Confirm that VAL can surely encode the current region. */
4872 coding_system
= call4 (Vselect_safe_coding_system_function
,
4873 make_number (b
), make_number (e
),
4874 coding_system
, Qnil
);
4877 coding_system
= Qraw_text
;
4880 if (NILP (Fcoding_system_p (coding_system
)))
4882 /* Invalid coding system. */
4884 if (!NILP (noerror
))
4885 coding_system
= Qraw_text
;
4887 xsignal1 (Qcoding_system_error
, coding_system
);
4891 object
= make_buffer_string (b
, e
, 0);
4892 set_buffer_internal (prev
);
4893 /* Discard the unwind protect for recovering the current
4897 if (STRING_MULTIBYTE (object
))
4898 object
= code_convert_string (object
, coding_system
, Qnil
, 1, 0, 0);
4900 end_byte
= SBYTES (object
);
4903 if (EQ (algorithm
, Qmd5
))
4905 digest_size
= MD5_DIGEST_SIZE
;
4906 hash_func
= md5_buffer
;
4908 else if (EQ (algorithm
, Qsha1
))
4910 digest_size
= SHA1_DIGEST_SIZE
;
4911 hash_func
= sha1_buffer
;
4913 else if (EQ (algorithm
, Qsha224
))
4915 digest_size
= SHA224_DIGEST_SIZE
;
4916 hash_func
= sha224_buffer
;
4918 else if (EQ (algorithm
, Qsha256
))
4920 digest_size
= SHA256_DIGEST_SIZE
;
4921 hash_func
= sha256_buffer
;
4923 else if (EQ (algorithm
, Qsha384
))
4925 digest_size
= SHA384_DIGEST_SIZE
;
4926 hash_func
= sha384_buffer
;
4928 else if (EQ (algorithm
, Qsha512
))
4930 digest_size
= SHA512_DIGEST_SIZE
;
4931 hash_func
= sha512_buffer
;
4934 error ("Invalid algorithm arg: %s", SDATA (Fsymbol_name (algorithm
)));
4936 /* allocate 2 x digest_size so that it can be re-used to hold the
4938 digest
= make_uninit_string (digest_size
* 2);
4940 hash_func (SSDATA (object
) + start_byte
,
4941 end_byte
- start_byte
,
4945 return make_digest_string (digest
, digest_size
);
4947 return make_unibyte_string (SSDATA (digest
), digest_size
);
4950 DEFUN ("md5", Fmd5
, Smd5
, 1, 5, 0,
4951 doc
: /* Return MD5 message digest of OBJECT, a buffer or string.
4953 A message digest is a cryptographic checksum of a document, and the
4954 algorithm to calculate it is defined in RFC 1321.
4956 The two optional arguments START and END are character positions
4957 specifying for which part of OBJECT the message digest should be
4958 computed. If nil or omitted, the digest is computed for the whole
4961 The MD5 message digest is computed from the result of encoding the
4962 text in a coding system, not directly from the internal Emacs form of
4963 the text. The optional fourth argument CODING-SYSTEM specifies which
4964 coding system to encode the text with. It should be the same coding
4965 system that you used or will use when actually writing the text into a
4968 If CODING-SYSTEM is nil or omitted, the default depends on OBJECT. If
4969 OBJECT is a buffer, the default for CODING-SYSTEM is whatever coding
4970 system would be chosen by default for writing this text into a file.
4972 If OBJECT is a string, the most preferred coding system (see the
4973 command `prefer-coding-system') is used.
4975 If NOERROR is non-nil, silently assume the `raw-text' coding if the
4976 guesswork fails. Normally, an error is signaled in such case. */)
4977 (Lisp_Object object
, Lisp_Object start
, Lisp_Object end
, Lisp_Object coding_system
, Lisp_Object noerror
)
4979 return secure_hash (Qmd5
, object
, start
, end
, coding_system
, noerror
, Qnil
);
4982 DEFUN ("secure-hash", Fsecure_hash
, Ssecure_hash
, 2, 5, 0,
4983 doc
: /* Return the secure hash of OBJECT, a buffer or string.
4984 ALGORITHM is a symbol specifying the hash to use:
4985 md5, sha1, sha224, sha256, sha384 or sha512.
4987 The two optional arguments START and END are positions specifying for
4988 which part of OBJECT to compute the hash. If nil or omitted, uses the
4991 If BINARY is non-nil, returns a string in binary form. */)
4992 (Lisp_Object algorithm
, Lisp_Object object
, Lisp_Object start
, Lisp_Object end
, Lisp_Object binary
)
4994 return secure_hash (algorithm
, object
, start
, end
, Qnil
, Qnil
, binary
);
4997 DEFUN ("buffer-hash", Fbuffer_hash
, Sbuffer_hash
, 0, 1, 0,
4998 doc
: /* Return a hash of the contents of BUFFER-OR-NAME.
4999 This hash is performed on the raw internal format of the buffer,
5000 disregarding any coding systems.
5001 If nil, use the current buffer." */ )
5002 (Lisp_Object buffer_or_name
)
5006 struct sha1_ctx ctx
;
5008 if (NILP (buffer_or_name
))
5009 buffer
= Fcurrent_buffer ();
5011 buffer
= Fget_buffer (buffer_or_name
);
5013 nsberror (buffer_or_name
);
5015 b
= XBUFFER (buffer
);
5016 sha1_init_ctx (&ctx
);
5018 /* Process the first part of the buffer. */
5019 sha1_process_bytes (BUF_BEG_ADDR (b
),
5020 BUF_GPT_BYTE (b
) - BUF_BEG_BYTE (b
),
5023 /* If the gap is before the end of the buffer, process the last half
5025 if (BUF_GPT_BYTE (b
) < BUF_Z_BYTE (b
))
5026 sha1_process_bytes (BUF_GAP_END_ADDR (b
),
5027 BUF_Z_ADDR (b
) - BUF_GAP_END_ADDR (b
),
5030 Lisp_Object digest
= make_uninit_string (SHA1_DIGEST_SIZE
* 2);
5031 sha1_finish_ctx (&ctx
, SSDATA (digest
));
5032 return make_digest_string (digest
, SHA1_DIGEST_SIZE
);
5039 DEFSYM (Qmd5
, "md5");
5040 DEFSYM (Qsha1
, "sha1");
5041 DEFSYM (Qsha224
, "sha224");
5042 DEFSYM (Qsha256
, "sha256");
5043 DEFSYM (Qsha384
, "sha384");
5044 DEFSYM (Qsha512
, "sha512");
5046 /* Hash table stuff. */
5047 DEFSYM (Qhash_table_p
, "hash-table-p");
5049 DEFSYM (Qeql
, "eql");
5050 DEFSYM (Qequal
, "equal");
5051 DEFSYM (QCtest
, ":test");
5052 DEFSYM (QCsize
, ":size");
5053 DEFSYM (QCpurecopy
, ":purecopy");
5054 DEFSYM (QCrehash_size
, ":rehash-size");
5055 DEFSYM (QCrehash_threshold
, ":rehash-threshold");
5056 DEFSYM (QCweakness
, ":weakness");
5057 DEFSYM (Qkey
, "key");
5058 DEFSYM (Qvalue
, "value");
5059 DEFSYM (Qhash_table_test
, "hash-table-test");
5060 DEFSYM (Qkey_or_value
, "key-or-value");
5061 DEFSYM (Qkey_and_value
, "key-and-value");
5063 defsubr (&Ssxhash_eq
);
5064 defsubr (&Ssxhash_eql
);
5065 defsubr (&Ssxhash_equal
);
5066 defsubr (&Smake_hash_table
);
5067 defsubr (&Scopy_hash_table
);
5068 defsubr (&Shash_table_count
);
5069 defsubr (&Shash_table_rehash_size
);
5070 defsubr (&Shash_table_rehash_threshold
);
5071 defsubr (&Shash_table_size
);
5072 defsubr (&Shash_table_test
);
5073 defsubr (&Shash_table_weakness
);
5074 defsubr (&Shash_table_p
);
5075 defsubr (&Sclrhash
);
5076 defsubr (&Sgethash
);
5077 defsubr (&Sputhash
);
5078 defsubr (&Sremhash
);
5079 defsubr (&Smaphash
);
5080 defsubr (&Sdefine_hash_table_test
);
5082 DEFSYM (Qstring_lessp
, "string-lessp");
5083 DEFSYM (Qprovide
, "provide");
5084 DEFSYM (Qrequire
, "require");
5085 DEFSYM (Qyes_or_no_p_history
, "yes-or-no-p-history");
5086 DEFSYM (Qcursor_in_echo_area
, "cursor-in-echo-area");
5087 DEFSYM (Qwidget_type
, "widget-type");
5089 staticpro (&string_char_byte_cache_string
);
5090 string_char_byte_cache_string
= Qnil
;
5092 require_nesting_list
= Qnil
;
5093 staticpro (&require_nesting_list
);
5095 Fset (Qyes_or_no_p_history
, Qnil
);
5097 DEFVAR_LISP ("features", Vfeatures
,
5098 doc
: /* A list of symbols which are the features of the executing Emacs.
5099 Used by `featurep' and `require', and altered by `provide'. */);
5100 Vfeatures
= list1 (Qemacs
);
5101 DEFSYM (Qfeatures
, "features");
5102 /* Let people use lexically scoped vars named `features'. */
5103 Fmake_var_non_special (Qfeatures
);
5104 DEFSYM (Qsubfeatures
, "subfeatures");
5105 DEFSYM (Qfuncall
, "funcall");
5107 #ifdef HAVE_LANGINFO_CODESET
5108 DEFSYM (Qcodeset
, "codeset");
5109 DEFSYM (Qdays
, "days");
5110 DEFSYM (Qmonths
, "months");
5111 DEFSYM (Qpaper
, "paper");
5112 #endif /* HAVE_LANGINFO_CODESET */
5114 DEFVAR_BOOL ("use-dialog-box", use_dialog_box
,
5115 doc
: /* Non-nil means mouse commands use dialog boxes to ask questions.
5116 This applies to `y-or-n-p' and `yes-or-no-p' questions asked by commands
5117 invoked by mouse clicks and mouse menu items.
5119 On some platforms, file selection dialogs are also enabled if this is
5123 DEFVAR_BOOL ("use-file-dialog", use_file_dialog
,
5124 doc
: /* Non-nil means mouse commands use a file dialog to ask for files.
5125 This applies to commands from menus and tool bar buttons even when
5126 they are initiated from the keyboard. If `use-dialog-box' is nil,
5127 that disables the use of a file dialog, regardless of the value of
5129 use_file_dialog
= 1;
5131 defsubr (&Sidentity
);
5134 defsubr (&Ssafe_length
);
5135 defsubr (&Sstring_bytes
);
5136 defsubr (&Sstring_equal
);
5137 defsubr (&Scompare_strings
);
5138 defsubr (&Sstring_lessp
);
5139 defsubr (&Sstring_version_lessp
);
5140 defsubr (&Sstring_collate_lessp
);
5141 defsubr (&Sstring_collate_equalp
);
5144 defsubr (&Svconcat
);
5145 defsubr (&Scopy_sequence
);
5146 defsubr (&Sstring_make_multibyte
);
5147 defsubr (&Sstring_make_unibyte
);
5148 defsubr (&Sstring_as_multibyte
);
5149 defsubr (&Sstring_as_unibyte
);
5150 defsubr (&Sstring_to_multibyte
);
5151 defsubr (&Sstring_to_unibyte
);
5152 defsubr (&Scopy_alist
);
5153 defsubr (&Ssubstring
);
5154 defsubr (&Ssubstring_no_properties
);
5167 defsubr (&Snreverse
);
5168 defsubr (&Sreverse
);
5170 defsubr (&Splist_get
);
5172 defsubr (&Splist_put
);
5174 defsubr (&Slax_plist_get
);
5175 defsubr (&Slax_plist_put
);
5178 defsubr (&Sequal_including_properties
);
5179 defsubr (&Sfillarray
);
5180 defsubr (&Sclear_string
);
5185 defsubr (&Smapconcat
);
5186 defsubr (&Syes_or_no_p
);
5187 defsubr (&Sload_average
);
5188 defsubr (&Sfeaturep
);
5189 defsubr (&Srequire
);
5190 defsubr (&Sprovide
);
5191 defsubr (&Splist_member
);
5192 defsubr (&Swidget_put
);
5193 defsubr (&Swidget_get
);
5194 defsubr (&Swidget_apply
);
5195 defsubr (&Sbase64_encode_region
);
5196 defsubr (&Sbase64_decode_region
);
5197 defsubr (&Sbase64_encode_string
);
5198 defsubr (&Sbase64_decode_string
);
5200 defsubr (&Ssecure_hash
);
5201 defsubr (&Sbuffer_hash
);
5202 defsubr (&Slocale_info
);